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

Contents of /slime/swank-ecl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.32 - (hide annotations)
Fri Sep 26 23:14:10 2008 UTC (5 years, 6 months ago) by trittweiler
Branch: MAIN
Changes since 1.31: +38 -24 lines
Improve ECL's arglist support somewhat.

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

  ViewVC Help
Powered by ViewVC 1.1.5