/[slime]/slime/swank-ecl.lisp
ViewVC logotype

Contents of /slime/swank-ecl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Fri Nov 11 23:43:43 2005 UTC (8 years, 5 months ago) by heller
Branch: MAIN
Changes since 1.3: +3 -1 lines
(accept-connection): New argument: buffering.
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2 ;;;
3 ;;; swank-ecl.lisp --- SLIME backend for ECL.
4
5 ;;; Administrivia
6
7 (in-package :swank-backend)
8
9 (import-from :ext *gray-stream-symbols* :swank-backend)
10
11 (swank-backend::import-swank-mop-symbols :clos
12 '(:eql-specializer
13 :eql-specializer-object
14 :generic-function-declarations
15 :specializer-direct-methods
16 :compute-applicable-methods-using-classes))
17
18 #+nil
19 (ffi:clines "
20 #include <unistd.h>
21 #include <sys/types.h>")
22
23
24 ;;;; TCP Server
25
26 (require 'sockets)
27
28 (defun resolve-hostname (name)
29 (car (sb-bsd-sockets:host-ent-addresses
30 (sb-bsd-sockets:get-host-by-name name))))
31
32 (defimplementation create-socket (host port)
33 (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
34 :type :stream
35 :protocol :tcp)))
36 (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
37 (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
38 (sb-bsd-sockets:socket-listen socket 5)
39 socket))
40
41 (defimplementation local-port (socket)
42 (nth-value 1 (sb-bsd-sockets:socket-name socket)))
43
44 (defimplementation close-socket (socket)
45 (sb-bsd-sockets:socket-close socket))
46
47 (defimplementation accept-connection (socket
48 &key (external-format :iso-latin-1-unix)
49 buffering)
50 (declare (ignore buffering))
51 (assert (eq external-format :iso-latin-1-unix))
52 (make-socket-io-stream (accept socket) external-format))
53
54 (defun make-socket-io-stream (socket external-format)
55 (sb-bsd-sockets:socket-make-stream socket
56 :output t
57 :input t
58 :element-type 'base-char))
59
60 (defun accept (socket)
61 "Like socket-accept, but retry on EAGAIN."
62 (loop (handler-case
63 (return (sb-bsd-sockets:socket-accept socket))
64 (sb-bsd-sockets:interrupted-error ()))))
65
66 (defimplementation preferred-communication-style ()
67 (values nil))
68
69
70 ;;;; Unix signals
71
72 (defimplementation getpid ()
73 (si:getpid))
74
75 #+nil
76 (defimplementation set-default-directory (directory)
77 (ext::chdir (namestring directory))
78 ;; Setting *default-pathname-defaults* to an absolute directory
79 ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive.
80 (setf *default-pathname-defaults* (ext::getcwd))
81 (default-directory))
82
83 #+nil
84 (defimplementation default-directory ()
85 (namestring (ext:getcwd)))
86
87 (defimplementation quit-lisp ()
88 (ext:quit))
89
90
91 ;;;; Compilation
92
93 (defvar *buffer-name* nil)
94 (defvar *buffer-start-position*)
95 (defvar *buffer-string*)
96 (defvar *compile-filename*)
97
98 (defun signal-compiler-condition (&rest args)
99 (signal (apply #'make-condition 'compiler-condition args)))
100
101 (defun handle-compiler-warning (condition)
102 (signal-compiler-condition
103 :original-condition condition
104 :message (format nil "~A" condition)
105 :severity :warning
106 :location
107 (if *buffer-name*
108 (make-location (list :buffer *buffer-name*)
109 (list :position *buffer-start-position*))
110 ;; ;; compiler::*current-form*
111 ;; (if compiler::*current-function*
112 ;; (make-location (list :file *compile-filename*)
113 ;; (list :function-name
114 ;; (symbol-name
115 ;; (slot-value compiler::*current-function*
116 ;; 'compiler::name))))
117 (list :error "No location found.")
118 ;; )
119 )))
120
121 (defimplementation call-with-compilation-hooks (function)
122 (handler-bind ((warning #'handle-compiler-warning))
123 (funcall function)))
124
125 (defimplementation swank-compile-file (*compile-filename* load-p
126 &optional external-format)
127 (declare (ignore external-format))
128 (with-compilation-hooks ()
129 (let ((*buffer-name* nil))
130 (multiple-value-bind (fn warn fail)
131 (compile-file *compile-filename*)
132 (when load-p (unless fail (load fn)))))))
133
134 (defimplementation swank-compile-string (string &key buffer position directory)
135 (declare (ignore directory))
136 (with-compilation-hooks ()
137 (let ((*buffer-name* buffer)
138 (*buffer-start-position* position)
139 (*buffer-string* string))
140 (with-input-from-string (s string)
141 (compile-from-stream s :load t)))))
142
143 (defun compile-from-stream (stream &rest args)
144 (let ((file (si::mkstemp "TMP:ECLXXXXXX")))
145 (with-open-file (s file :direction :output :if-exists :overwrite)
146 (do ((line (read-line stream nil) (read-line stream nil)))
147 (line)
148 (write-line line s)))
149 (unwind-protect
150 (apply #'compile-file file args)
151 (delete-file file))))
152
153
154 ;;;; Documentation
155
156 (defimplementation arglist (name)
157 (or (functionp name) (setf name (symbol-function name)))
158 (if (functionp name)
159 (typecase name
160 (generic-function
161 (clos::generic-function-lambda-list name))
162 (function
163 (let ((fle (function-lambda-expression name)))
164 (case (car fle)
165 (si:lambda-block (caddr fle))
166 (t :not-available)))))
167 :not-available))
168
169 (defimplementation function-name ((f function))
170 (si:compiled-function-name f))
171
172 (defimplementation macroexpand-all (form)
173 ;;; FIXME! This is not the same as a recursive macroexpansion!
174 (macroexpand form))
175
176 (defimplementation describe-symbol-for-emacs (symbol)
177 (let ((result '()))
178 (dolist (type '(:VARIABLE :FUNCTION :CLASS))
179 (let ((doc (describe-definition symbol type)))
180 (when doc
181 (setf result (list* type doc result)))))
182 result))
183
184 (defimplementation describe-definition (name type)
185 (case type
186 (:variable (documentation name 'variable))
187 (:function (documentation name 'function))
188 (:class (documentation name 'class))
189 (t nil)))
190
191 ;;; Debugging
192
193 (import
194 '(si::*ihs-top*
195 si::*ihs-current*
196 si::*ihs-base*
197 si::*frs-base*
198 si::*frs-top*
199 si::*tpl-commands*
200 si::*tpl-level*
201 si::frs-top
202 si::ihs-top
203 si::sch-frs-base
204 si::set-break-env
205 si::set-current-ihs
206 si::tpl-commands))
207
208 (defimplementation call-with-debugging-environment (debugger-loop-fn)
209 (declare (type function debugger-loop-fn))
210 (let* ((*tpl-commands* si::tpl-commands)
211 (*ihs-top* (ihs-top 'call-with-debugging-environment))
212 (*ihs-current* *ihs-top*)
213 (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
214 (*frs-top* (frs-top))
215 (*read-suppress* nil)
216 (*tpl-level* (1+ *tpl-level*)))
217 (set-break-env)
218 (set-current-ihs)
219 (funcall debugger-loop-fn)))
220
221 ;; (defimplementation call-with-debugger-hook (hook fun)
222 ;; (let ((*debugger-hook* hook))
223 ;; (funcall fun)))
224
225 (defun nth-frame (n)
226 (cond ((>= n *ihs-top* ) nil)
227 (t (- *ihs-top* n))))
228
229 (defimplementation compute-backtrace (start end)
230 (loop for i from start below end
231 for f = (nth-frame i)
232 while f
233 collect f))
234
235 (defimplementation print-frame (frame stream)
236 (format stream "~A" (si::ihs-fname frame)))
237
238 ;;;; Inspector
239
240 (defclass ecl-inspector (inspector)
241 ())
242
243 (defimplementation make-default-inspector ()
244 (make-instance 'ecl-inspector))
245
246 ;;;; Definitions
247
248 (defimplementation find-definitions (name) nil)

  ViewVC Help
Powered by ViewVC 1.1.5