Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 560 lines (465 sloc) 17.939 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
98a99bd basic/simple implementation of find-definitions
Geo Carncross authored
13 (defvar *tmp*)
14
48bd841 ECL moved gray streams into GRAY package
Geo Carncross authored
15 (if (find-package :gray)
16 (import-from :gray *gray-stream-symbols* :swank-backend)
17 (import-from :ext *gray-stream-symbols* :swank-backend))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
18
19 (swank-backend::import-swank-mop-symbols :clos
20 '(:eql-specializer
21 :eql-specializer-object
22 :generic-function-declarations
23 :specializer-direct-methods
24 :compute-applicable-methods-using-classes))
25
26
27 ;;;; TCP Server
28
29 (require 'sockets)
30
31 (defun resolve-hostname (name)
32 (car (sb-bsd-sockets:host-ent-addresses
33 (sb-bsd-sockets:get-host-by-name name))))
34
35 (defimplementation create-socket (host port)
36 (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
37 :type :stream
38 :protocol :tcp)))
39 (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
40 (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
41 (sb-bsd-sockets:socket-listen socket 5)
42 socket))
43
44 (defimplementation local-port (socket)
45 (nth-value 1 (sb-bsd-sockets:socket-name socket)))
46
47 (defimplementation close-socket (socket)
48 (sb-bsd-sockets:socket-close socket))
49
50 (defimplementation accept-connection (socket
e51892e swank-backend.lisp (definterface): Drop that incredibly unportable
Helmut Eller authored
51 &key external-format
d4ac7e7 * Improve the robustness of connection establishment.
Douglas Crosher authored
52 buffering timeout)
5fb5464 (find-external-format, guess-external-format): New.
Helmut Eller authored
53 (declare (ignore buffering timeout external-format))
54 (make-socket-io-stream (accept socket)))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
55
5fb5464 (find-external-format, guess-external-format): New.
Helmut Eller authored
56 (defun make-socket-io-stream (socket)
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
57 (sb-bsd-sockets:socket-make-stream socket
58 :output t
59 :input t
60 :element-type 'base-char))
61
62 (defun accept (socket)
63 "Like socket-accept, but retry on EAGAIN."
64 (loop (handler-case
65 (return (sb-bsd-sockets:socket-accept socket))
66 (sb-bsd-sockets:interrupted-error ()))))
67
68 (defimplementation preferred-communication-style ()
69 (values nil))
70
71
72 ;;;; Unix signals
73
74 (defimplementation getpid ()
75 (si:getpid))
76
77 #+nil
78 (defimplementation set-default-directory (directory)
79 (ext::chdir (namestring directory))
80 ;; Setting *default-pathname-defaults* to an absolute directory
81 ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive.
82 (setf *default-pathname-defaults* (ext::getcwd))
83 (default-directory))
84
85 #+nil
86 (defimplementation default-directory ()
87 (namestring (ext:getcwd)))
88
89 (defimplementation quit-lisp ()
90 (ext:quit))
91
92
93 ;;;; Compilation
94
95 (defvar *buffer-name* nil)
96 (defvar *buffer-start-position*)
97 (defvar *buffer-string*)
98 (defvar *compile-filename*)
99
100 (defun signal-compiler-condition (&rest args)
101 (signal (apply #'make-condition 'compiler-condition args)))
102
103 (defun handle-compiler-warning (condition)
104 (signal-compiler-condition
105 :original-condition condition
106 :message (format nil "~A" condition)
107 :severity :warning
108 :location
109 (if *buffer-name*
110 (make-location (list :buffer *buffer-name*)
111 (list :position *buffer-start-position*))
112 ;; ;; compiler::*current-form*
113 ;; (if compiler::*current-function*
114 ;; (make-location (list :file *compile-filename*)
115 ;; (list :function-name
116 ;; (symbol-name
117 ;; (slot-value compiler::*current-function*
118 ;; 'compiler::name))))
119 (list :error "No location found.")
120 ;; )
121 )))
122
123 (defimplementation call-with-compilation-hooks (function)
124 (handler-bind ((warning #'handle-compiler-warning))
125 (funcall function)))
126
127 (defimplementation swank-compile-file (*compile-filename* load-p
5fb5464 (find-external-format, guess-external-format): New.
Helmut Eller authored
128 external-format)
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
129 (declare (ignore external-format))
130 (with-compilation-hooks ()
131 (let ((*buffer-name* nil))
132 (multiple-value-bind (fn warn fail)
133 (compile-file *compile-filename*)
134 (when load-p (unless fail (load fn)))))))
135
e04fa03 C-c C-c with prefix args now uses the maximal debug level. (By Zach …
Helmut Eller authored
136 (defimplementation swank-compile-string (string &key buffer position directory
137 debug)
138 (declare (ignore directory debug))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
139 (with-compilation-hooks ()
140 (let ((*buffer-name* buffer)
141 (*buffer-start-position* position)
142 (*buffer-string* string))
143 (with-input-from-string (s string)
144 (compile-from-stream s :load t)))))
145
146 (defun compile-from-stream (stream &rest args)
147 (let ((file (si::mkstemp "TMP:ECLXXXXXX")))
148 (with-open-file (s file :direction :output :if-exists :overwrite)
149 (do ((line (read-line stream nil) (read-line stream nil)))
d2ab4d0 @trittweiler * swank-ecl.lisp (compile-from-stream): Fixed typo that prevented
trittweiler authored
150 ((not line))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
151 (write-line line s)))
152 (unwind-protect
153 (apply #'compile-file file args)
154 (delete-file file))))
155
156
157 ;;;; Documentation
158
159 (defimplementation arglist (name)
160 (or (functionp name) (setf name (symbol-function name)))
161 (if (functionp name)
162 (typecase name
163 (generic-function
164 (clos::generic-function-lambda-list name))
d31550c try to parse the Args: line in most ecl functions to make modelines m…
Geo Carncross authored
165 (compiled-function
166 ; most of the compiled functions have an Args: line in their docs
167 (with-input-from-string (s (or
168 (si::get-documentation
169 (si:compiled-function-name name) 'function)
170 ""))
171 (do ((line (read-line s nil) (read-line s nil)))
172 ((not line) :not-available)
173 (ignore-errors
174 (if (string= (subseq line 0 6) "Args: ")
175 (return-from nil
176 (read-from-string (subseq line 6))))))))
177 ;
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
178 (function
179 (let ((fle (function-lambda-expression name)))
180 (case (car fle)
181 (si:lambda-block (caddr fle))
182 (t :not-available)))))
183 :not-available))
184
e51892e swank-backend.lisp (definterface): Drop that incredibly unportable
Helmut Eller authored
185 (defimplementation function-name (f)
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
186 (si:compiled-function-name f))
187
188 (defimplementation macroexpand-all (form)
189 ;;; FIXME! This is not the same as a recursive macroexpansion!
190 (macroexpand form))
191
192 (defimplementation describe-symbol-for-emacs (symbol)
193 (let ((result '()))
194 (dolist (type '(:VARIABLE :FUNCTION :CLASS))
195 (let ((doc (describe-definition symbol type)))
196 (when doc
197 (setf result (list* type doc result)))))
198 result))
199
200 (defimplementation describe-definition (name type)
201 (case type
202 (:variable (documentation name 'variable))
203 (:function (documentation name 'function))
204 (:class (documentation name 'class))
205 (t nil)))
206
207 ;;; Debugging
208
209 (import
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
210 '(si::*break-env*
211 si::*ihs-top*
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
212 si::*ihs-current*
213 si::*ihs-base*
214 si::*frs-base*
215 si::*frs-top*
216 si::*tpl-commands*
217 si::*tpl-level*
218 si::frs-top
219 si::ihs-top
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
220 si::ihs-fun
221 si::ihs-env
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
222 si::sch-frs-base
223 si::set-break-env
224 si::set-current-ihs
225 si::tpl-commands))
226
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
227 (defvar *backtrace* '())
228
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
229 (defimplementation call-with-debugging-environment (debugger-loop-fn)
230 (declare (type function debugger-loop-fn))
231 (let* ((*tpl-commands* si::tpl-commands)
232 (*ihs-top* (ihs-top 'call-with-debugging-environment))
233 (*ihs-current* *ihs-top*)
234 (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
235 (*frs-top* (frs-top))
236 (*read-suppress* nil)
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
237 (*tpl-level* (1+ *tpl-level*))
238 (*backtrace* (loop for ihs from *ihs-base* below *ihs-top*
239 collect (list (si::ihs-fun (1+ ihs))
240 (si::ihs-env ihs)
241 nil))))
242 (loop for f from *frs-base* until *frs-top*
243 do (let ((i (- (si::frs-ihs f) *ihs-base* 1)))
244 (when (plusp i)
245 (let* ((x (elt *backtrace* i))
246 (name (si::frs-tag f)))
247 (unless (fixnump name)
248 (push name (third x)))))))
249 (setf *backtrace* (nreverse *backtrace*))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
250 (set-break-env)
251 (set-current-ihs)
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
252 (let ((*ihs-base* *ihs-top*))
253 (funcall debugger-loop-fn))))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
254
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
255 (defimplementation call-with-debugger-hook (hook fun)
256 (let ((*debugger-hook* hook)
257 (*ihs-base*(si::ihs-top 'call-with-debugger-hook)))
258 (funcall fun)))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
259
260 (defimplementation compute-backtrace (start end)
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
261 (when (numberp end)
262 (setf end (min end (length *backtrace*))))
263 (subseq *backtrace* start end))
264
265 (defun frame-name (frame)
266 (let ((x (first frame)))
267 (if (symbolp x)
268 x
269 (function-name x))))
270
271 (defun function-position (fun)
272 (multiple-value-bind (file position)
273 (si::bc-file fun)
274 (and file (make-location `(:file ,file) `(:position ,position)))))
275
276 (defun frame-function (frame)
277 (let* ((x (first frame))
278 fun position)
279 (etypecase x
280 (symbol (and (fboundp x)
281 (setf fun (fdefinition x)
282 position (function-position fun))))
283 (function (setf fun x position (function-position x))))
284 (values fun position)))
285
286 (defun frame-decode-env (frame)
287 (let ((functions '())
288 (blocks '())
289 (variables '()))
290 (dolist (record (second frame))
291 (let* ((record0 (car record))
292 (record1 (cdr record)))
293 (cond ((symbolp record0)
294 (setq variables (acons record0 record1 variables)))
295 ((not (fixnump record0))
296 (push record1 functions))
297 ((symbolp record1)
298 (push record1 blocks))
299 (t
300 ))))
301 (values functions blocks variables)))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
302
303 (defimplementation print-frame (frame stream)
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
304 (format stream "~A" (first frame)))
305
306 (defimplementation frame-source-location-for-emacs (frame-number)
307 (nth-value 1 (frame-function (elt *backtrace* frame-number))))
308
309 (defimplementation frame-catch-tags (frame-number)
310 (third (elt *backtrace* frame-number)))
311
312 (defimplementation frame-locals (frame-number)
313 (loop for (name . value) in (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
314 with i = 0
315 collect (list :name name :id (prog1 i (incf i)) :value value)))
316
317 (defimplementation frame-var-value (frame-number var-id)
318 (elt (nth-value 2 (frame-decode-env (elt *backtrace* frame-number)))
319 var-id))
320
321 (defimplementation disassemble-frame (frame-number)
322 (let ((fun (frame-fun (elt *backtrace* frame-number))))
323 (disassemble fun)))
324
325 (defimplementation eval-in-frame (form frame-number)
326 (let ((env (second (elt *backtrace* frame-number))))
327 (si:eval-with-env form env)))
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
328
329 ;;;; Inspector
330
0c75cea Inspector cleanups.
Helmut Eller authored
331 (defmethod emacs-inspect ((o t))
6eb426d Make ELC inspection better; should be able to handle all builtin type…
Geo Carncross authored
332 ; ecl clos support leaves some to be desired
333 (cond
334 ((streamp o)
6a300a7 Drop the first return value of emacs-inspect.
Helmut Eller authored
335 (list*
336 (format nil "~S is an ordinary stream~%" o)
6eb426d Make ELC inspection better; should be able to handle all builtin type…
Geo Carncross authored
337 (append
338 (list
339 "Open for "
340 (cond
341 ((ignore-errors (interactive-stream-p o)) "Interactive")
342 ((and (input-stream-p o) (output-stream-p o)) "Input and output")
343 ((input-stream-p o) "Input")
344 ((output-stream-p o) "Output"))
345 `(:newline) `(:newline))
346 (label-value-line*
347 ("Element type" (stream-element-type o))
348 ("External format" (stream-external-format o)))
349 (ignore-errors (label-value-line*
350 ("Broadcast streams" (broadcast-stream-streams o))))
351 (ignore-errors (label-value-line*
352 ("Concatenated streams" (concatenated-stream-streams o))))
353 (ignore-errors (label-value-line*
354 ("Echo input stream" (echo-stream-input-stream o))))
355 (ignore-errors (label-value-line*
356 ("Echo output stream" (echo-stream-output-stream o))))
357 (ignore-errors (label-value-line*
358 ("Output String" (get-output-stream-string o))))
359 (ignore-errors (label-value-line*
360 ("Synonym symbol" (synonym-stream-symbol o))))
361 (ignore-errors (label-value-line*
362 ("Input stream" (two-way-stream-input-stream o))))
363 (ignore-errors (label-value-line*
364 ("Output stream" (two-way-stream-output-stream o)))))))
365 (t
366 (let* ((cl (si:instance-class o))
367 (slots (clos:class-slots cl)))
6a300a7 Drop the first return value of emacs-inspect.
Helmut Eller authored
368 (list* (format nil "~S is an instance of class ~A~%"
6eb426d Make ELC inspection better; should be able to handle all builtin type…
Geo Carncross authored
369 o (clos::class-name cl))
370 (loop for x in slots append
371 (let* ((name (clos:slot-definition-name x))
372 (value (clos::slot-value o name)))
373 (list
374 (format nil "~S: " name)
375 `(:value ,value)
376 `(:newline)))))))))
377
f33058f Initial port to ECL
Juan Jose Garcia Ripoll authored
378 ;;;; Definitions
379
98a99bd basic/simple implementation of find-definitions
Geo Carncross authored
380 (defimplementation find-definitions (name)
381 (if (fboundp name)
382 (let ((tmp (find-source-location (symbol-function name))))
383 `(((defun ,name) ,tmp)))))
5415cdc Add ECL threads implementation to swank
Geo Carncross authored
384
2791323 Initial support for find-source-location with functions
Geo Carncross authored
385 (defimplementation find-source-location (obj)
98a99bd basic/simple implementation of find-definitions
Geo Carncross authored
386 (setf *tmp* obj)
2791323 Initial support for find-source-location with functions
Geo Carncross authored
387 (or
388 (typecase obj
389 (function
a8e47da Backtrace and frame/eval improvements
Geo Carncross authored
390 (multiple-value-bind (file pos) (ignore-errors (si::bc-file obj))
2791323 Initial support for find-source-location with functions
Geo Carncross authored
391 (if (and file pos)
e8c6143 fixup flushing and location create
Geo Carncross authored
392 (make-location
98a99bd basic/simple implementation of find-definitions
Geo Carncross authored
393 `(:file ,(namestring file))
e8c6143 fixup flushing and location create
Geo Carncross authored
394 `(:position ,pos)
395 `(:snippet
396 ,(with-open-file (s file)
397 (skip-toplevel-forms pos s)
398 (skip-comments-and-whitespace s)
399 (read-snippet s))))))))
2791323 Initial support for find-source-location with functions
Geo Carncross authored
400 `(:error (format nil "Source definition of ~S not found" obj))))
401
5415cdc Add ECL threads implementation to swank
Geo Carncross authored
402 ;;;; Threads
403
404 #+threads
405 (progn
406 (defvar *thread-id-counter* 0)
407
408 (defvar *thread-id-counter-lock*
409 (mp:make-lock :name "thread id counter lock"))
410
411 (defun next-thread-id ()
412 (mp:with-lock (*thread-id-counter-lock*)
413 (incf *thread-id-counter*)))
414
415 (defparameter *thread-id-map* (make-hash-table))
416
417 (defvar *thread-id-map-lock*
418 (mp:make-lock :name "thread id map lock"))
419
420 ; ecl doesn't have weak pointers
421 (defimplementation spawn (fn &key name)
422 (let ((thread (mp:make-process :name name))
423 (id (next-thread-id)))
424 (mp:process-preset
425 thread
426 #'(lambda ()
427 (unwind-protect
428 (mp:with-lock (*thread-id-map-lock*)
429 (setf (gethash id *thread-id-map*) thread))
430 (funcall fn)
431 (mp:with-lock (*thread-id-map-lock*)
432 (remhash id *thread-id-map*)))))
433 (mp:process-enable thread)))
434
435 (defimplementation thread-id (thread)
436 (block thread-id
437 (mp:with-lock (*thread-id-map-lock*)
438 (loop for id being the hash-key in *thread-id-map*
439 using (hash-value thread-pointer)
440 do (if (eq thread thread-pointer)
441 (return-from thread-id id))))))
442
443 (defimplementation find-thread (id)
444 (mp:with-lock (*thread-id-map-lock*)
445 (gethash id *thread-id-map*)))
446
447 (defimplementation thread-name (thread)
448 (mp:process-name thread))
449
450 (defimplementation thread-status (thread)
451 (if (mp:process-active-p thread)
452 "RUNNING"
453 "STOPPED"))
454
455 (defimplementation make-lock (&key name)
456 (mp:make-lock :name name))
457
458 (defimplementation call-with-lock-held (lock function)
459 (declare (type function function))
460 (mp:with-lock (lock) (funcall function)))
461
462 (defimplementation make-recursive-lock (&key name)
463 (mp:make-lock :name name))
464
465 (defimplementation call-with-recursive-lock-held (lock function)
466 (declare (type function function))
467 (mp:with-lock (lock) (funcall function)))
468
469 (defimplementation current-thread ()
470 mp:*current-process*)
471
472 (defimplementation all-threads ()
473 (mp:all-processes))
474
475 (defimplementation interrupt-thread (thread fn)
476 (mp:interrupt-process thread fn))
477
478 (defimplementation kill-thread (thread)
479 (mp:process-kill thread))
480
481 (defimplementation thread-alive-p (thread)
482 (mp:process-active-p thread))
483
484 (defvar *mailbox-lock* (mp:make-lock :name "mailbox lock"))
485
486 (defstruct (mailbox (:conc-name mailbox.))
487 (mutex (mp:make-lock :name "process mailbox"))
488 (queue '() :type list))
489
490 (defun mailbox (thread)
491 "Return THREAD's mailbox."
492 (mp:with-lock (*mailbox-lock*)
493 (or (find thread *mailboxes* :key #'mailbox.thread)
494 (let ((mb (make-mailbox :thread thread)))
495 (push mb *mailboxes*)
496 mb))))
497
498 (defimplementation send (thread message)
499 (let* ((mbox (mailbox thread))
500 (mutex (mailbox.mutex mbox)))
501 (mp:interrupt-process
502 thread
503 (lambda ()
504 (mp:with-lock (mutex)
505 (setf (mailbox.queue mbox)
506 (nconc (mailbox.queue mbox) (list message))))))))
507
508 (defimplementation receive ()
509 (block got-mail
510 (let* ((mbox (mailbox mp:*current-process*))
511 (mutex (mailbox.mutex mbox)))
512 (loop
513 (mp:with-lock (mutex)
514 (if (mailbox.queue mbox)
515 (return-from got-mail (pop (mailbox.queue mbox)))))
516 ;interrupt-process will halt this if it takes longer than 1sec
517 (sleep 1)))))
518
519 ;; Auto-flush streams
520 (defvar *auto-flush-interval* 0.15
521 "How often to flush interactive streams. This valu is passed
522 directly to cl:sleep.")
523
524 (defvar *auto-flush-lock* (make-recursive-lock :name "auto flush"))
525
526 (defvar *auto-flush-thread* nil)
527
528 (defvar *auto-flush-streams* '())
529
530 (defimplementation make-stream-interactive (stream)
531 (call-with-recursive-lock-held
532 *auto-flush-lock*
533 (lambda ()
534 (pushnew stream *auto-flush-streams*)
535 (unless *auto-flush-thread*
536 (setq *auto-flush-thread*
537 (spawn #'flush-streams
538 :name "auto-flush-thread"))))))
539
540 (defmethod stream-finish-output ((stream stream))
541 (finish-output stream))
542
543 (defun flush-streams ()
544 (loop
545 (call-with-recursive-lock-held
546 *auto-flush-lock*
547 (lambda ()
548 (setq *auto-flush-streams*
549 (remove-if (lambda (x)
550 (not (and (open-stream-p x)
551 (output-stream-p x))))
552 *auto-flush-streams*))
e8c6143 fixup flushing and location create
Geo Carncross authored
553 (dolist (i *auto-flush-streams*)
554 (ignore-errors (stream-finish-output i))
555 (ignore-errors (finish-output i)))))
5415cdc Add ECL threads implementation to swank
Geo Carncross authored
556 (sleep *auto-flush-interval*)))
557
558 )
559
Something went wrong with that request. Please try again.