Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 417 lines (333 sloc) 12.414 kb
5fb5464 (find-external-format, guess-external-format): New.
Helmut Eller authored
1 ;;;; -*- indent-tabs-mode: nil -*-
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
2 ;;;
3 ;;; swank-ecl.lisp --- SLIME backend for ECL.
5fb5464 (find-external-format, guess-external-format): New.
Helmut Eller authored
4 ;;;
5 ;;; This code has been placed in the Public Domain. All warranties
6 ;;; are disclaimed.
7 ;;;
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
8
9 ;;; Administrivia
10
11 (in-package :swank-backend)
12
55bf49e Use *gray-stream-symbols* instead of enumerating them in each backend.
Helmut Eller authored
13 (import-from :ext *gray-stream-symbols* :swank-backend)
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
14
15 (swank-backend::import-swank-mop-symbols :clos
16 '(:eql-specializer
17 :eql-specializer-object
18 :generic-function-declarations
19 :specializer-direct-methods
20 :compute-applicable-methods-using-classes))
21
22
23 ;;;; TCP Server
24
25 (require 'sockets)
26
27 (defun resolve-hostname (name)
28 (car (sb-bsd-sockets:host-ent-addresses
29 (sb-bsd-sockets:get-host-by-name name))))
30
31 (defimplementation create-socket (host port)
32 (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
33 :type :stream
34 :protocol :tcp)))
35 (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
36 (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
37 (sb-bsd-sockets:socket-listen socket 5)
38 socket))
39
40 (defimplementation local-port (socket)
41 (nth-value 1 (sb-bsd-sockets:socket-name socket)))
42
43 (defimplementation close-socket (socket)
44 (sb-bsd-sockets:socket-close socket))
45
46 (defimplementation accept-connection (socket
e51892e swank-backend.lisp (definterface): Drop that incredibly unportable
Helmut Eller authored
47 &key external-format
d4ac7e7 * Improve the robustness of connection establishment.
Douglas Crosher authored
48 buffering timeout)
5fb5464 (find-external-format, guess-external-format): New.
Helmut Eller authored
49 (declare (ignore buffering timeout external-format))
50 (make-socket-io-stream (accept socket)))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
51
5fb5464 (find-external-format, guess-external-format): New.
Helmut Eller authored
52 (defun make-socket-io-stream (socket)
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
53 (sb-bsd-sockets:socket-make-stream socket
54 :output t
55 :input t
56 :element-type 'base-char))
57
58 (defun accept (socket)
59 "Like socket-accept, but retry on EAGAIN."
60 (loop (handler-case
61 (return (sb-bsd-sockets:socket-accept socket))
62 (sb-bsd-sockets:interrupted-error ()))))
63
64 (defimplementation preferred-communication-style ()
65 (values nil))
66
67
68 ;;;; Unix signals
69
70 (defimplementation getpid ()
71 (si:getpid))
72
73 #+nil
74 (defimplementation set-default-directory (directory)
75 (ext::chdir (namestring directory))
76 ;; Setting *default-pathname-defaults* to an absolute directory
77 ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive.
78 (setf *default-pathname-defaults* (ext::getcwd))
79 (default-directory))
80
81 #+nil
82 (defimplementation default-directory ()
83 (namestring (ext:getcwd)))
84
85 (defimplementation quit-lisp ()
86 (ext:quit))
87
88
89 ;;;; Compilation
90
91 (defvar *buffer-name* nil)
92 (defvar *buffer-start-position*)
93 (defvar *buffer-string*)
94 (defvar *compile-filename*)
95
96 (defun signal-compiler-condition (&rest args)
97 (signal (apply #'make-condition 'compiler-condition args)))
98
99 (defun handle-compiler-warning (condition)
100 (signal-compiler-condition
101 :original-condition condition
102 :message (format nil "~A" condition)
103 :severity :warning
104 :location
105 (if *buffer-name*
106 (make-location (list :buffer *buffer-name*)
107 (list :position *buffer-start-position*))
108 ;; ;; compiler::*current-form*
109 ;; (if compiler::*current-function*
110 ;; (make-location (list :file *compile-filename*)
111 ;; (list :function-name
112 ;; (symbol-name
113 ;; (slot-value compiler::*current-function*
114 ;; 'compiler::name))))
115 (list :error "No location found.")
116 ;; )
117 )))
118
119 (defimplementation call-with-compilation-hooks (function)
120 (handler-bind ((warning #'handle-compiler-warning))
121 (funcall function)))
122
123 (defimplementation swank-compile-file (*compile-filename* load-p
5fb5464 (find-external-format, guess-external-format): New.
Helmut Eller authored
124 external-format)
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
125 (declare (ignore external-format))
126 (with-compilation-hooks ()
127 (let ((*buffer-name* nil))
128 (multiple-value-bind (fn warn fail)
129 (compile-file *compile-filename*)
130 (when load-p (unless fail (load fn)))))))
131
132 (defimplementation swank-compile-string (string &key buffer position directory)
133 (declare (ignore directory))
134 (with-compilation-hooks ()
135 (let ((*buffer-name* buffer)
136 (*buffer-start-position* position)
137 (*buffer-string* string))
138 (with-input-from-string (s string)
139 (compile-from-stream s :load t)))))
140
141 (defun compile-from-stream (stream &rest args)
142 (let ((file (si::mkstemp "TMP:ECLXXXXXX")))
143 (with-open-file (s file :direction :output :if-exists :overwrite)
144 (do ((line (read-line stream nil) (read-line stream nil)))
d2ab4d0 @trittweiler * swank-ecl.lisp (compile-from-stream): Fixed typo that prevented
trittweiler authored
145 ((not line))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
146 (write-line line s)))
147 (unwind-protect
148 (apply #'compile-file file args)
149 (delete-file file))))
150
151
152 ;;;; Documentation
153
154 (defimplementation arglist (name)
155 (or (functionp name) (setf name (symbol-function name)))
156 (if (functionp name)
157 (typecase name
158 (generic-function
159 (clos::generic-function-lambda-list name))
d31550c try to parse the Args: line in most ecl functions to make modelines m…
Geo Carncross authored
160 (compiled-function
161 ; most of the compiled functions have an Args: line in their docs
162 (with-input-from-string (s (or
163 (si::get-documentation
164 (si:compiled-function-name name) 'function)
165 ""))
166 (do ((line (read-line s nil) (read-line s nil)))
167 ((not line) :not-available)
168 (ignore-errors
169 (if (string= (subseq line 0 6) "Args: ")
170 (return-from nil
171 (read-from-string (subseq line 6))))))))
172 ;
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
173 (function
174 (let ((fle (function-lambda-expression name)))
175 (case (car fle)
176 (si:lambda-block (caddr fle))
177 (t :not-available)))))
178 :not-available))
179
e51892e swank-backend.lisp (definterface): Drop that incredibly unportable
Helmut Eller authored
180 (defimplementation function-name (f)
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
181 (si:compiled-function-name f))
182
183 (defimplementation macroexpand-all (form)
184 ;;; FIXME! This is not the same as a recursive macroexpansion!
185 (macroexpand form))
186
187 (defimplementation describe-symbol-for-emacs (symbol)
188 (let ((result '()))
189 (dolist (type '(:VARIABLE :FUNCTION :CLASS))
190 (let ((doc (describe-definition symbol type)))
191 (when doc
192 (setf result (list* type doc result)))))
193 result))
194
195 (defimplementation describe-definition (name type)
196 (case type
197 (:variable (documentation name 'variable))
198 (:function (documentation name 'function))
199 (:class (documentation name 'class))
200 (t nil)))
201
202 ;;; Debugging
203
204 (import
205 '(si::*ihs-top*
206 si::*ihs-current*
207 si::*ihs-base*
208 si::*frs-base*
209 si::*frs-top*
210 si::*tpl-commands*
211 si::*tpl-level*
212 si::frs-top
213 si::ihs-top
214 si::sch-frs-base
215 si::set-break-env
216 si::set-current-ihs
217 si::tpl-commands))
218
219 (defimplementation call-with-debugging-environment (debugger-loop-fn)
220 (declare (type function debugger-loop-fn))
221 (let* ((*tpl-commands* si::tpl-commands)
222 (*ihs-top* (ihs-top 'call-with-debugging-environment))
223 (*ihs-current* *ihs-top*)
224 (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
225 (*frs-top* (frs-top))
226 (*read-suppress* nil)
227 (*tpl-level* (1+ *tpl-level*)))
228 (set-break-env)
229 (set-current-ihs)
230 (funcall debugger-loop-fn)))
231
232 ;; (defimplementation call-with-debugger-hook (hook fun)
233 ;; (let ((*debugger-hook* hook))
234 ;; (funcall fun)))
235
236 (defun nth-frame (n)
237 (cond ((>= n *ihs-top* ) nil)
238 (t (- *ihs-top* n))))
239
240 (defimplementation compute-backtrace (start end)
241 (loop for i from start below end
242 for f = (nth-frame i)
243 while f
244 collect f))
245
246 (defimplementation print-frame (frame stream)
247 (format stream "~A" (si::ihs-fname frame)))
248
249 ;;;; Inspector
250
251 (defclass ecl-inspector (inspector)
252 ())
253
254 (defimplementation make-default-inspector ()
255 (make-instance 'ecl-inspector))
256
257 ;;;; Definitions
258
259 (defimplementation find-definitions (name) nil)
5415cdc Add ECL threads implementation to swank
Geo Carncross authored
260
261 ;;;; Threads
262
263 #+threads
264 (progn
265 (defvar *thread-id-counter* 0)
266
267 (defvar *thread-id-counter-lock*
268 (mp:make-lock :name "thread id counter lock"))
269
270 (defun next-thread-id ()
271 (mp:with-lock (*thread-id-counter-lock*)
272 (incf *thread-id-counter*)))
273
274 (defparameter *thread-id-map* (make-hash-table))
275
276 (defvar *thread-id-map-lock*
277 (mp:make-lock :name "thread id map lock"))
278
279 ; ecl doesn't have weak pointers
280 (defimplementation spawn (fn &key name)
281 (let ((thread (mp:make-process :name name))
282 (id (next-thread-id)))
283 (mp:process-preset
284 thread
285 #'(lambda ()
286 (unwind-protect
287 (mp:with-lock (*thread-id-map-lock*)
288 (setf (gethash id *thread-id-map*) thread))
289 (funcall fn)
290 (mp:with-lock (*thread-id-map-lock*)
291 (remhash id *thread-id-map*)))))
292 (mp:process-enable thread)))
293
294 (defimplementation thread-id (thread)
295 (block thread-id
296 (mp:with-lock (*thread-id-map-lock*)
297 (loop for id being the hash-key in *thread-id-map*
298 using (hash-value thread-pointer)
299 do (if (eq thread thread-pointer)
300 (return-from thread-id id))))))
301
302 (defimplementation find-thread (id)
303 (mp:with-lock (*thread-id-map-lock*)
304 (gethash id *thread-id-map*)))
305
306 (defimplementation thread-name (thread)
307 (mp:process-name thread))
308
309 (defimplementation thread-status (thread)
310 (if (mp:process-active-p thread)
311 "RUNNING"
312 "STOPPED"))
313
314 (defimplementation make-lock (&key name)
315 (mp:make-lock :name name))
316
317 (defimplementation call-with-lock-held (lock function)
318 (declare (type function function))
319 (mp:with-lock (lock) (funcall function)))
320
321 (defimplementation make-recursive-lock (&key name)
322 (mp:make-lock :name name))
323
324 (defimplementation call-with-recursive-lock-held (lock function)
325 (declare (type function function))
326 (mp:with-lock (lock) (funcall function)))
327
328 (defimplementation current-thread ()
329 mp:*current-process*)
330
331 (defimplementation all-threads ()
332 (mp:all-processes))
333
334 (defimplementation interrupt-thread (thread fn)
335 (mp:interrupt-process thread fn))
336
337 (defimplementation kill-thread (thread)
338 (mp:process-kill thread))
339
340 (defimplementation thread-alive-p (thread)
341 (mp:process-active-p thread))
342
343 (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock"))
344
345 (defstruct (mailbox (:conc-name mailbox.))
346 (mutex (mp:make-lock :name "process mailbox"))
347 (queue '() :type list))
348
349 (defun mailbox (thread)
350 "Return THREAD's mailbox."
351 (mp:with-lock (*mailbox-lock*)
352 (or (find thread *mailboxes* :key #'mailbox.thread)
353 (let ((mb (make-mailbox :thread thread)))
354 (push mb *mailboxes*)
355 mb))))
356
357 (defimplementation send (thread message)
358 (let* ((mbox (mailbox thread))
359 (mutex (mailbox.mutex mbox)))
360 (mp:interrupt-process
361 thread
362 (lambda ()
363 (mp:with-lock (mutex)
364 (setf (mailbox.queue mbox)
365 (nconc (mailbox.queue mbox) (list message))))))))
366
367 (defimplementation receive ()
368 (block got-mail
369 (let* ((mbox (mailbox mp:*current-process*))
370 (mutex (mailbox.mutex mbox)))
371 (loop
372 (mp:with-lock (mutex)
373 (if (mailbox.queue mbox)
374 (return-from got-mail (pop (mailbox.queue mbox)))))
375 ;interrupt-process will halt this if it takes longer than 1sec
376 (sleep 1)))))
377
378 ;; Auto-flush streams
379 (defvar *auto-flush-interval* 0.15
380 "How often to flush interactive streams. This valu is passed
381 directly to cl:sleep.")
382
383 (defvar *auto-flush-lock* (make-recursive-lock :name "auto flush"))
384
385 (defvar *auto-flush-thread* nil)
386
387 (defvar *auto-flush-streams* '())
388
389 (defimplementation make-stream-interactive (stream)
390 (call-with-recursive-lock-held
391 *auto-flush-lock*
392 (lambda ()
393 (pushnew stream *auto-flush-streams*)
394 (unless *auto-flush-thread*
395 (setq *auto-flush-thread*
396 (spawn #'flush-streams
397 :name "auto-flush-thread"))))))
398
399 (defmethod stream-finish-output ((stream stream))
400 (finish-output stream))
401
402 (defun flush-streams ()
403 (loop
404 (call-with-recursive-lock-held
405 *auto-flush-lock*
406 (lambda ()
407 (setq *auto-flush-streams*
408 (remove-if (lambda (x)
409 (not (and (open-stream-p x)
410 (output-stream-p x))))
411 *auto-flush-streams*))
412 (mapc #'stream-finish-output *auto-flush-streams*)))
413 (sleep *auto-flush-interval*)))
414
415 )
416
Something went wrong with that request. Please try again.