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

Diff of /slime/swank-backend.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.94 by heller, Sun Nov 20 23:25:38 2005 UTC revision 1.223 by sboukarev, Sat Jan 12 12:32:21 2013 UTC
# Line 1  Line 1 
1  ;;; -*- Mode: lisp; indent-tabs-mode: nil; outline-regexp: ";;;;;*" -*-  ;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;*" -*-
2  ;;;  ;;;
3  ;;; slime-backend.lisp --- SLIME backend interface.  ;;; slime-backend.lisp --- SLIME backend interface.
4  ;;;  ;;;
# Line 12  Line 12 
12    
13  (defpackage :swank-backend  (defpackage :swank-backend
14    (:use :common-lisp)    (:use :common-lisp)
15    (:export #:sldb-condition    (:export #:*debug-swank-backend*
16             #:original-condition             #:sldb-condition
17             #:compiler-condition             #:compiler-condition
18               #:original-condition
19             #:message             #:message
20             #:short-message             #:source-context
21             #:condition             #:condition
22             #:severity             #:severity
23               #:with-compilation-hooks
24             #:location             #:location
25             #:location-p             #:location-p
26             #:location-buffer             #:location-buffer
# Line 29  Line 31 
31             #:quit-lisp             #:quit-lisp
32             #:references             #:references
33             #:unbound-slot-filler             #:unbound-slot-filler
34               #:declaration-arglist
35               #:type-specifier-arglist
36               #:with-struct
37               #:when-let
38               ;; interrupt macro for the backend
39               #:*pending-slime-interrupts*
40               #:check-slime-interrupts
41               #:*interrupt-queued-handler*
42             ;; inspector related symbols             ;; inspector related symbols
43             #:inspector             #:emacs-inspect
            #:inspect-for-emacs  
            #:raw-inspection  
            #:fancy-inspection  
44             #:label-value-line             #:label-value-line
45             #:label-value-line*             #:label-value-line*
46             ))             #:with-symbol))
47    
48  (defpackage :swank-mop  (defpackage :swank-mop
49    (:use)    (:use)
# Line 84  Line 91 
91     #:slot-definition-type     #:slot-definition-type
92     #:slot-definition-readers     #:slot-definition-readers
93     #:slot-definition-writers     #:slot-definition-writers
94       #:slot-boundp-using-class
95       #:slot-value-using-class
96       #:slot-makunbound-using-class
97     ;; generic function protocol     ;; generic function protocol
98     #:compute-applicable-methods-using-classes     #:compute-applicable-methods-using-classes
99     #:finalize-inheritance))     #:finalize-inheritance))
# Line 93  Line 103 
103    
104  ;;;; Metacode  ;;;; Metacode
105    
106    (defparameter *debug-swank-backend* nil
107      "If this is true, backends should not catch errors but enter the
108    debugger where appropriate. Also, they should not perform backtrace
109    magic but really show every frame including SWANK related ones.")
110    
111  (defparameter *interface-functions* '()  (defparameter *interface-functions* '()
112    "The names of all interface functions.")    "The names of all interface functions.")
113    
# Line 102  DEFINTERFACE adds to this list and DEFIM Line 117  DEFINTERFACE adds to this list and DEFIM
117    
118  (defmacro definterface (name args documentation &rest default-body)  (defmacro definterface (name args documentation &rest default-body)
119    "Define an interface function for the backend to implement.    "Define an interface function for the backend to implement.
120  A generic function is defined with NAME, ARGS, and DOCUMENTATION.  A function is defined with NAME, ARGS, and DOCUMENTATION.  This
121    function first looks for a function to call in NAME's property list
122  If a DEFAULT-BODY is supplied then NO-APPLICABLE-METHOD is specialized  that is indicated by 'IMPLEMENTATION; failing that, it looks for a
123  to execute the body if the backend doesn't provide a specific  function indicated by 'DEFAULT. If neither is present, an error is
124  implementation.  signaled.
125    
126    If a DEFAULT-BODY is supplied, then a function with the same body and
127    ARGS will be added to NAME's property list as the property indicated
128    by 'DEFAULT.
129    
130  Backends implement these functions using DEFIMPLEMENTATION."  Backends implement these functions using DEFIMPLEMENTATION."
131    (check-type documentation string "a documentation string")    (check-type documentation string "a documentation string")
132    (flet ((gen-default-impl ()    (assert (every #'symbolp args) ()
133             `(defmethod ,name ,args ,@default-body)))            "Complex lambda-list not supported: ~S ~S" name args)
134      `(progn (defgeneric ,name ,args (:documentation ,documentation))    (labels ((gen-default-impl ()
135              (pushnew ',name *interface-functions*)               `(setf (get ',name 'default) (lambda ,args ,@default-body)))
136              ,(if (null default-body)             (args-as-list (args)
137                   `(pushnew ',name *unimplemented-interfaces*)               (destructuring-bind (req opt key rest) (parse-lambda-list args)
138                   (gen-default-impl))                 `(,@req ,@opt
139              ;; see <http://www.franz.com/support/documentation/6.2/doc/pages/variables/compiler/s_cltl1-compile-file-toplevel-compatibility-p_s.htm>                         ,@(loop for k in key append `(,(kw k) ,k))
140              (eval-when (:compile-toplevel :load-toplevel :execute)                         ,@(or rest '(())))))
141                (export ',name :swank-backend))             (parse-lambda-list (args)
142              ',name)))               (parse args '(&optional &key &rest)
143                        (make-array 4 :initial-element nil)))
144               (parse (args keywords vars)
145                 (cond ((null args)
146                        (reverse (map 'list #'reverse vars)))
147                       ((member (car args) keywords)
148                        (parse (cdr args) (cdr (member (car args) keywords)) vars))
149                       (t (push (car args) (aref vars (length keywords)))
150                          (parse (cdr args) keywords vars))))
151               (kw (s) (intern (string s) :keyword)))
152        `(progn
153           (defun ,name ,args
154             ,documentation
155             (let ((f (or (get ',name 'implementation)
156                          (get ',name 'default))))
157               (cond (f (apply f ,@(args-as-list args)))
158                     (t (error "~S not implemented" ',name)))))
159           (pushnew ',name *interface-functions*)
160           ,(if (null default-body)
161                `(pushnew ',name *unimplemented-interfaces*)
162                (gen-default-impl))
163           (eval-when (:compile-toplevel :load-toplevel :execute)
164             (export ',name :swank-backend))
165           ',name)))
166    
167  (defmacro defimplementation (name args &body body)  (defmacro defimplementation (name args &body body)
168    `(progn (defmethod ,name ,args ,@body)    (assert (every #'symbolp args) ()
169            (if (member ',name *interface-functions*)            "Complex lambda-list not supported: ~S ~S" name args)
170                (setq *unimplemented-interfaces*    `(progn
171                      (remove ',name *unimplemented-interfaces*))       (setf (get ',name 'implementation)
172                (warn "DEFIMPLEMENTATION of undefined interface (~S)" ',name))             ;; For implicit BLOCK. FLET because of interplay w/ decls.
173            ',name))             (flet ((,name ,args ,@body)) #',name))
174         (if (member ',name *interface-functions*)
175             (setq *unimplemented-interfaces*
176                   (remove ',name *unimplemented-interfaces*))
177             (warn "DEFIMPLEMENTATION of undefined interface (~S)" ',name))
178         ',name))
179    
180  (defun warn-unimplemented-interfaces ()  (defun warn-unimplemented-interfaces ()
181    "Warn the user about unimplemented backend features.    "Warn the user about unimplemented backend features.
182  The portable code calls this function at startup."  The portable code calls this function at startup."
183    (warn "These Swank interfaces are unimplemented:~% ~A"    (let ((*print-pretty* t))
184          (sort (copy-list *unimplemented-interfaces*) #'string<)))      (warn "These Swank interfaces are unimplemented:~% ~:<~{~A~^ ~:_~}~:>"
185              (list (sort (copy-list *unimplemented-interfaces*) #'string<)))))
186    
187  (defun import-to-swank-mop (symbol-list)  (defun import-to-swank-mop (symbol-list)
188    (dolist (sym symbol-list)    (dolist (sym symbol-list)
# Line 158  EXCEPT is a list of symbol names which s Line 206  EXCEPT is a list of symbol names which s
206  (defvar *gray-stream-symbols*  (defvar *gray-stream-symbols*
207    '(:fundamental-character-output-stream    '(:fundamental-character-output-stream
208      :stream-write-char      :stream-write-char
209        :stream-write-string
210      :stream-fresh-line      :stream-fresh-line
211      :stream-force-output      :stream-force-output
212      :stream-finish-output      :stream-finish-output
213      :fundamental-character-input-stream      :fundamental-character-input-stream
214      :stream-read-char      :stream-read-char
215        :stream-peek-char
216        :stream-read-line
217        ;; STREAM-FILE-POSITION is not available on all implementations, or
218        ;; partially under a different name.
219        ; :stream-file-posiion
220      :stream-listen      :stream-listen
221      :stream-unread-char      :stream-unread-char
222      :stream-clear-input      :stream-clear-input
# Line 185  EXCEPT is a list of symbol names which s Line 239  EXCEPT is a list of symbol names which s
239    
240  (defmacro with-struct ((conc-name &rest names) obj &body body)  (defmacro with-struct ((conc-name &rest names) obj &body body)
241    "Like with-slots but works only for structs."    "Like with-slots but works only for structs."
242    (flet ((reader (slot) (intern (concatenate 'string    (check-type conc-name symbol)
243                                               (symbol-name conc-name)    (flet ((reader (slot)
244                                               (symbol-name slot))             (intern (concatenate 'string
245                                  (symbol-package conc-name))))                                  (symbol-name conc-name)
246                                    (symbol-name slot))
247                       (symbol-package conc-name))))
248      (let ((tmp (gensym "OO-")))      (let ((tmp (gensym "OO-")))
249      ` (let ((,tmp ,obj))        ` (let ((,tmp ,obj))
250          (symbol-macrolet            (symbol-macrolet
251              ,(loop for name in names collect                ,(loop for name in names collect
252                     (typecase name                       (typecase name
253                       (symbol `(,name (,(reader name) ,tmp)))                         (symbol `(,name (,(reader name) ,tmp)))
254                       (cons `(,(first name) (,(reader (second name)) ,tmp)))                         (cons `(,(first name) (,(reader (second name)) ,tmp)))
255                       (t (error "Malformed syntax in WITH-STRUCT: ~A" name))))                         (t (error "Malformed syntax in WITH-STRUCT: ~A" name))))
256            ,@body)))))              ,@body)))))
257    
258    (defmacro when-let ((var value) &body body)
259      `(let ((,var ,value))
260         (when ,var ,@body)))
261    
262    (defun with-symbol (name package)
263      "Generate a form suitable for testing with #+."
264      (if (and (find-package package)
265               (find-symbol (string name) package))
266          '(:and)
267          '(:or)))
268    
269    
270    ;;;; UFT8
271    
272    (deftype octet () '(unsigned-byte 8))
273    (deftype octets () '(simple-array octet (*)))
274    
275    ;; Helper function.  Decode the next N bytes starting from INDEX.
276    ;; Return the decoded char and the new index.
277    (defun utf8-decode-aux (buffer index limit byte0 n)
278      (declare (type octets buffer) (fixnum index limit byte0 n))
279      (if (< (- limit index) n)
280          (values nil index)
281          (do ((i 0 (1+ i))
282               (code byte0 (let ((byte (aref buffer (+ index i))))
283                             (cond ((= (ldb (byte 2 6) byte) #b10)
284                                    (+ (ash code 6) (ldb (byte 6 0) byte)))
285                                   (t
286                                    (error "Invalid encoding"))))))
287              ((= i n)
288               (values (cond ((<= code #xff) (code-char code))
289                             ((<= #xd800 code #xdfff)
290                              (error "Invalid Unicode code point: #x~x" code))
291                             ((and (< code char-code-limit)
292                                   (code-char code)))
293                             (t
294                              (error
295                               "Can't represent code point: #x~x ~
296                                (char-code-limit is #x~x)"
297                               code char-code-limit)))
298                       (+ index n))))))
299    
300    ;; Decode one character in BUFFER starting at INDEX.
301    ;; Return 2 values: the character and the new index.
302    ;; If there aren't enough bytes between INDEX and LIMIT return nil.
303    (defun utf8-decode (buffer index limit)
304      (declare (type octets buffer) (fixnum index limit))
305      (if (= index limit)
306          (values nil index)
307          (let ((b (aref buffer index)))
308            (if (<= b #x7f)
309                (values (code-char b) (1+ index))
310                (macrolet ((try (marker else)
311                             (let* ((l (integer-length marker))
312                                    (n (- l 2)))
313                               `(if (= (ldb (byte ,l ,(- 8 l)) b) ,marker)
314                                    (utf8-decode-aux buffer (1+ index) limit
315                                                     (ldb (byte ,(- 8 l) 0) b)
316                                                     ,n)
317                                    ,else))))
318                  (try #b110
319                       (try #b1110
320                            (try #b11110
321                                 (try #b111110
322                                      (try #b1111110
323                                           (error "Invalid encoding")))))))))))
324    
325    ;; Decode characters from BUFFER and write them to STRING.
326    ;; Return 2 values: LASTINDEX and LASTSTART where
327    ;; LASTINDEX is the last index in BUFFER that was not decoded
328    ;; and LASTSTART is the last index in STRING not written.
329    (defun utf8-decode-into (buffer index limit string start end)
330      (declare (string string) (fixnum index limit start end) (type octets buffer))
331      (loop
332       (cond ((= start end)
333              (return (values index start)))
334             (t
335              (multiple-value-bind (c i) (utf8-decode buffer index limit)
336                (cond (c
337                       (setf (aref string start) c)
338                       (setq index i)
339                       (setq start (1+ start)))
340                      (t
341                       (return (values index start)))))))))
342    
343    (defun default-utf8-to-string (octets)
344      (let* ((limit (length octets))
345             (str (make-string limit)))
346        (multiple-value-bind (i s) (utf8-decode-into octets 0 limit str 0 limit)
347          (if (= i limit)
348              (if (= limit s)
349                  str
350                  (adjust-array str s))
351              (loop
352               (let ((end (+ (length str) (- limit i))))
353                 (setq str (adjust-array str end))
354                 (multiple-value-bind (i2 s2)
355                     (utf8-decode-into octets i limit str s end)
356                   (cond ((= i2 limit)
357                          (return (adjust-array str s2)))
358                         (t
359                          (setq i i2)
360                          (setq s s2))))))))))
361    
362    (defmacro utf8-encode-aux (code buffer start end n)
363      `(cond ((< (- ,end ,start) ,n)
364              ,start)
365             (t
366              (setf (aref ,buffer ,start)
367                    (dpb (ldb (byte ,(- 7 n) ,(* 6 (1- n))) ,code)
368                         (byte ,(- 7 n) 0)
369                         ,(dpb 0 (byte 1 (- 7 n)) #xff)))
370              ,@(loop for i from 0 upto (- n 2) collect
371                      `(setf (aref ,buffer (+ ,start ,(- n 1 i)))
372                             (dpb (ldb (byte 6 ,(* 6 i)) ,code)
373                                  (byte 6 0)
374                                  #b10111111)))
375              (+ ,start ,n))))
376    
377    (defun utf8-encode (char buffer start end)
378      (declare (character char) (type octets buffer) (fixnum start end))
379      (let ((code (char-code char)))
380        (cond ((<= code #x7f)
381               (cond ((< start end)
382                      (setf (aref buffer start) code)
383                      (1+ start))
384                     (t start)))
385              ((<= code #x7ff) (utf8-encode-aux code buffer start end 2))
386              ((<= #xd800 code #xdfff)
387               (error "Invalid Unicode code point (surrogate): #x~x" code))
388              ((<= code #xffff) (utf8-encode-aux code buffer start end 3))
389              ((<= code #x1fffff) (utf8-encode-aux code buffer start end 4))
390              ((<= code #x3ffffff) (utf8-encode-aux code buffer start end 5))
391              ((<= code #x7fffffff) (utf8-encode-aux code buffer start end 6))
392              (t (error "Can't encode ~s (~x)" char code)))))
393    
394    (defun utf8-encode-into (string start end buffer index limit)
395      (declare (string string) (type octets buffer) (fixnum start end index limit))
396      (loop
397       (cond ((= start end)
398              (return (values start index)))
399             ((= index limit)
400              (return (values start index)))
401             (t
402              (let ((i2 (utf8-encode (char string start) buffer index limit)))
403                (cond ((= i2 index)
404                       (return (values start index)))
405                      (t
406                       (setq index i2)
407                       (incf start))))))))
408    
409    (defun default-string-to-utf8 (string)
410      (let* ((len (length string))
411             (b (make-array len :element-type 'octet)))
412        (multiple-value-bind (s i) (utf8-encode-into string 0 len b 0 len)
413          (if (= s len)
414              b
415              (loop
416               (let ((limit (+ (length b) (- len s))))
417                 (setq b (coerce (adjust-array b limit) 'octets))
418                 (multiple-value-bind (s2 i2)
419                     (utf8-encode-into string s len b i limit)
420                   (cond ((= s2 len)
421                          (return (coerce (adjust-array b i2) 'octets)))
422                         (t
423                          (setq i i2)
424                          (setq s s2))))))))))
425    
426    (definterface string-to-utf8 (string)
427      "Convert the string STRING to a (simple-array (unsigned-byte 8))"
428      (default-string-to-utf8 string))
429    
430    (definterface utf8-to-string (octets)
431      "Convert the (simple-array (unsigned-byte 8)) OCTETS to a string."
432      (default-utf8-to-string octets))
433    
434    ;;; Codepoint length
435    
436    ;; we don't need this anymore.
437    (definterface codepoint-length (string)
438      "Return the number of codepoints in STRING.
439    With some Lisps, like cmucl, LENGTH returns the number of UTF-16 code
440    units, but other Lisps return the number of codepoints. The slime
441    protocol wants string lengths in terms of codepoints."
442      (length string))
443    
444    
445  ;;;; TCP server  ;;;; TCP server
446    
447  (definterface create-socket (host port)  (definterface create-socket (host port &key backlog)
448    "Create a listening TCP socket on interface HOST and port PORT .")    "Create a listening TCP socket on interface HOST and port PORT.
449    BACKLOG queue length for incoming connections.")
450    
451  (definterface local-port (socket)  (definterface local-port (socket)
452    "Return the local port number of SOCKET.")    "Return the local port number of SOCKET.")
# Line 212  EXCEPT is a list of symbol names which s Line 455  EXCEPT is a list of symbol names which s
455    "Close the socket SOCKET.")    "Close the socket SOCKET.")
456    
457  (definterface accept-connection (socket &key external-format  (definterface accept-connection (socket &key external-format
458                                          buffering)                                          buffering timeout)
459     "Accept a client connection on the listening socket SOCKET.     "Accept a client connection on the listening socket SOCKET.
460  Return a stream for the new connection.")  Return a stream for the new connection.
461    If EXTERNAL-FORMAT is nil return a binary stream
462    otherwise create a character stream.
463    BUFFERING can be one of:
464      nil   ... no buffering
465      t     ... enable buffering
466      :line ... enable buffering with automatic flushing on eol.")
467    
468  (definterface add-sigio-handler (socket fn)  (definterface add-sigio-handler (socket fn)
469    "Call FN whenever SOCKET is readable.")    "Call FN whenever SOCKET is readable.")
# Line 232  Return a stream for the new connection." Line 481  Return a stream for the new connection."
481    "Return one of the symbols :spawn, :sigio, :fd-handler, or NIL."    "Return one of the symbols :spawn, :sigio, :fd-handler, or NIL."
482    nil)    nil)
483    
484    (definterface set-stream-timeout (stream timeout)
485      "Set the 'stream 'timeout.  The timeout is either the real number
486      specifying the timeout in seconds or 'nil for no timeout."
487      (declare (ignore stream timeout))
488      nil)
489    
490  ;;; Base condition for networking errors.  ;;; Base condition for networking errors.
491  (define-condition network-error (simple-error) ())  (define-condition network-error (simple-error) ())
492    
# Line 249  that the calling thread is the one that Line 504  that the calling thread is the one that
504    
505  (defconstant +sigint+ 2)  (defconstant +sigint+ 2)
506    
 (definterface call-without-interrupts (fn)  
   "Call FN in a context where interrupts are disabled."  
   (funcall fn))  
   
507  (definterface getpid ()  (definterface getpid ()
508    "Return the (Unix) process ID of this superior Lisp.")    "Return the (Unix) process ID of this superior Lisp.")
509    
510    (definterface install-sigint-handler (function)
511      "Call FUNCTION on SIGINT (instead of invoking the debugger).
512    Return old signal handler."
513      (declare (ignore function))
514      nil)
515    
516    (definterface call-with-user-break-handler (handler function)
517      "Install the break handler HANDLER while executing FUNCTION."
518      (let ((old-handler (install-sigint-handler handler)))
519        (unwind-protect (funcall function)
520          (install-sigint-handler old-handler))))
521    
522    (definterface quit-lisp ()
523      "Exit the current lisp image.")
524    
525  (definterface lisp-implementation-type-name ()  (definterface lisp-implementation-type-name ()
526    "Return a short name for the Lisp implementation."    "Return a short name for the Lisp implementation."
527    (lisp-implementation-type))    (lisp-implementation-type))
528    
529    (definterface lisp-implementation-program ()
530      "Return the argv[0] of the running Lisp process, or NIL."
531      (let ((file (car (command-line-args))))
532        (when (and file (probe-file file))
533          (namestring (truename file)))))
534    
535    (definterface socket-fd (socket-stream)
536      "Return the file descriptor for SOCKET-STREAM.")
537    
538    (definterface make-fd-stream (fd external-format)
539      "Create a character stream for the file descriptor FD.")
540    
541    (definterface dup (fd)
542      "Duplicate a file descriptor.
543    If the syscall fails, signal a condition.
544    See dup(2).")
545    
546    (definterface exec-image (image-file args)
547      "Replace the current process with a new process image.
548    The new image is created by loading the previously dumped
549    core file IMAGE-FILE.
550    ARGS is a list of strings passed as arguments to
551    the new image.
552    This is thin wrapper around exec(3).")
553    
554    (definterface command-line-args ()
555      "Return a list of strings as passed by the OS."
556      nil)
557    
558    
559    ;; pathnames are sooo useless
560    
561    (definterface filename-to-pathname (filename)
562      "Return a pathname for FILENAME.
563    A filename in Emacs may for example contain asterisks which should not
564    be translated to wildcards."
565      (parse-namestring filename))
566    
567    (definterface pathname-to-filename (pathname)
568      "Return the filename for PATHNAME."
569      (namestring pathname))
570    
571  (definterface default-directory ()  (definterface default-directory ()
572    "Return the default directory."    "Return the default directory."
573    (directory-namestring (truename *default-pathname-defaults*)))    (directory-namestring (truename *default-pathname-defaults*)))
# Line 270  This is used to resolve filenames withou Line 578  This is used to resolve filenames withou
578    (setf *default-pathname-defaults* (truename (merge-pathnames directory)))    (setf *default-pathname-defaults* (truename (merge-pathnames directory)))
579    (default-directory))    (default-directory))
580    
581    
582  (definterface call-with-syntax-hooks (fn)  (definterface call-with-syntax-hooks (fn)
583    "Call FN with hooks to handle special syntax."    "Call FN with hooks to handle special syntax."
584    (funcall fn))    (funcall fn))
# Line 278  This is used to resolve filenames withou Line 587  This is used to resolve filenames withou
587    "Return a suitable initial value for SWANK:*READTABLE-ALIST*."    "Return a suitable initial value for SWANK:*READTABLE-ALIST*."
588    '())    '())
589    
 (definterface quit-lisp ()  
   "Exit the current lisp image.")  
   
590    
591  ;;;; Compilation  ;;;; Compilation
592    
# Line 292  This is used to resolve filenames withou Line 598  This is used to resolve filenames withou
598    (declare (ignore ignore))    (declare (ignore ignore))
599    `(call-with-compilation-hooks (lambda () (progn ,@body))))    `(call-with-compilation-hooks (lambda () (progn ,@body))))
600    
601  (definterface swank-compile-string (string &key buffer position directory)  (definterface swank-compile-string (string &key buffer position filename
602    "Compile source from STRING.  During compilation, compiler                                             policy)
603  conditions must be trapped and resignalled as COMPILER-CONDITIONs.    "Compile source from STRING.
604    During compilation, compiler conditions must be trapped and
605    resignalled as COMPILER-CONDITIONs.
606    
607  If supplied, BUFFER and POSITION specify the source location in Emacs.  If supplied, BUFFER and POSITION specify the source location in Emacs.
608    
609  Additionally, if POSITION is supplied, it must be added to source  Additionally, if POSITION is supplied, it must be added to source
610  positions reported in compiler conditions.  positions reported in compiler conditions.
611    
612  If DIRECTORY is specified it may be used by certain implementations to  If FILENAME is specified it may be used by certain implementations to
613  rebind *DEFAULT-PATHNAME-DEFAULTS* which may improve the recording of  rebind *DEFAULT-PATHNAME-DEFAULTS* which may improve the recording of
614  source information.")  source information.
615    
616  (definterface operate-on-system (system-name operation-name &rest keyword-args)  If POLICY is supplied, and non-NIL, it may be used by certain
617    "Perform OPERATION-NAME on SYSTEM-NAME using ASDF.  implementations to compile with optimization qualities of its
618  The KEYWORD-ARGS are passed on to the operation.  value.
619  Example:  
620  \(operate-on-system \"SWANK\" \"COMPILE-OP\" :force t)"  Should return T on successful compilation, NIL otherwise.
621    (unless (member :asdf *features*)  ")
622      (error "ASDF is not loaded."))  
623    (with-compilation-hooks ()  (definterface swank-compile-file (input-file output-file load-p
624      (let ((operate (find-symbol "OPERATE" :asdf))                                               external-format
625            (operation (find-symbol operation-name :asdf)))                                               &key policy)
626        (when (null operation)     "Compile INPUT-FILE signalling COMPILE-CONDITIONs.
627          (error "Couldn't find ASDF operation ~S" operation-name))  If LOAD-P is true, load the file after compilation.
628        (apply operate operation system-name keyword-args))))  EXTERNAL-FORMAT is a value returned by find-external-format or
629    :default.
630  (definterface swank-compile-file (filename load-p &optional external-format)  
631     "Compile FILENAME signalling COMPILE-CONDITIONs.  If POLICY is supplied, and non-NIL, it may be used by certain
632  If LOAD-P is true, load the file after compilation.")  implementations to compile with optimization qualities of its
633    value.
634    
635    Should return OUTPUT-TRUENAME, WARNINGS-P and FAILURE-p
636    like `compile-file'")
637    
638  (deftype severity ()  (deftype severity ()
639    '(member :error :read-error :warning :style-warning :note))    '(member :error :read-error :warning :style-warning :note :redefinition))
640    
641  ;; Base condition type for compiler errors, warnings and notes.  ;; Base condition type for compiler errors, warnings and notes.
642  (define-condition compiler-condition (condition)  (define-condition compiler-condition (condition)
# Line 342  If LOAD-P is true, load the file after c Line 654  If LOAD-P is true, load the file after c
654     (message :initarg :message     (message :initarg :message
655              :accessor message)              :accessor message)
656    
657     (short-message :initarg :short-message     ;; Macro expansion history etc. which may be helpful in some cases
658                    :initform nil     ;; but is often very verbose.
659                    :accessor short-message)     (source-context :initarg :source-context
660                       :type (or null string)
661                       :initform nil
662                       :accessor source-context)
663    
664     (references :initarg :references     (references :initarg :references
665                 :initform nil                 :initform nil
# Line 353  If LOAD-P is true, load the file after c Line 668  If LOAD-P is true, load the file after c
668     (location :initarg :location     (location :initarg :location
669               :accessor location)))               :accessor location)))
670    
671    (definterface find-external-format (coding-system)
672      "Return a \"external file format designator\" for CODING-SYSTEM.
673    CODING-SYSTEM is Emacs-style coding system name (a string),
674    e.g. \"latin-1-unix\"."
675      (if (equal coding-system "iso-latin-1-unix")
676          :default
677          nil))
678    
679    (definterface guess-external-format (pathname)
680      "Detect the external format for the file with name pathname.
681    Return nil if the file contains no special markers."
682      ;; Look for a Emacs-style -*- coding: ... -*- or Local Variable: section.
683      (with-open-file (s pathname :if-does-not-exist nil
684                         :external-format (or (find-external-format "latin-1-unix")
685                                              :default))
686        (if s
687            (or (let* ((line (read-line s nil))
688                       (p (search "-*-" line)))
689                  (when p
690                    (let* ((start (+ p (length "-*-")))
691                           (end (search "-*-" line :start2 start)))
692                      (when end
693                        (%search-coding line start end)))))
694                (let* ((len (file-length s))
695                       (buf (make-string (min len 3000))))
696                  (file-position s (- len (length buf)))
697                  (read-sequence buf s)
698                  (let ((start (search "Local Variables:" buf :from-end t))
699                        (end (search "End:" buf :from-end t)))
700                    (and start end (< start end)
701                         (%search-coding buf start end))))))))
702    
703    (defun %search-coding (str start end)
704      (let ((p (search "coding:" str :start2 start :end2 end)))
705        (when p
706          (incf p (length "coding:"))
707          (loop while (and (< p end)
708                           (member (aref str p) '(#\space #\tab)))
709                do (incf p))
710          (let ((end (position-if (lambda (c) (find c '(#\space #\tab #\newline)))
711                                  str :start p)))
712            (find-external-format (subseq str p end))))))
713    
714    
715  ;;;; Streams  ;;;; Streams
716    
717  (definterface make-fn-streams (input-fn output-fn)  (definterface make-output-stream (write-string)
718     "Return character input and output streams backended by functions.    "Return a new character output stream.
719  When input is needed, INPUT-FN is called with no arguments to  The stream calls WRITE-STRING when output is ready.")
720  return a string.  
721  When output is ready, OUTPUT-FN is called with the output as its  (definterface make-input-stream (read-string)
722  argument.    "Return a new character input stream.
723    The stream calls READ-STRING when input is needed.")
 Output should be forced to OUTPUT-FN before calling INPUT-FN.  
   
 The streams are returned as two values.")  
   
 (definterface make-stream-interactive (stream)  
   "Do any necessary setup to make STREAM work interactively.  
 This is called for each stream used for interaction with the user  
 \(e.g. *standard-output*). An implementation could setup some  
 implementation-specific functions to control output flushing at the  
 like."  
   (declare (ignore stream))  
   nil)  
724    
725    
726  ;;;; Documentation  ;;;; Documentation
# Line 383  like." Line 729  like."
729     "Return the lambda list for the symbol NAME. NAME can also be     "Return the lambda list for the symbol NAME. NAME can also be
730  a lisp function object, on lisps which support this.  a lisp function object, on lisps which support this.
731    
732  The result can be a list or the :not-available if the arglist  The result can be a list or the :not-available keyword if the
733  cannot be determined."  arglist cannot be determined."
734     (declare (ignore name))     (declare (ignore name))
735     :not-available)     :not-available)
736    
737    (defgeneric declaration-arglist (decl-identifier)
738      (:documentation
739       "Return the argument list of the declaration specifier belonging to the
740    declaration identifier DECL-IDENTIFIER. If the arglist cannot be determined,
741    the keyword :NOT-AVAILABLE is returned.
742    
743    The different SWANK backends can specialize this generic function to
744    include implementation-dependend declaration specifiers, or to provide
745    additional information on the specifiers defined in ANSI Common Lisp.")
746      (:method (decl-identifier)
747        (case decl-identifier
748          (dynamic-extent '(&rest variables))
749          (ignore         '(&rest variables))
750          (ignorable      '(&rest variables))
751          (special        '(&rest variables))
752          (inline         '(&rest function-names))
753          (notinline      '(&rest function-names))
754          (declaration    '(&rest names))
755          (optimize       '(&any compilation-speed debug safety space speed))
756          (type           '(type-specifier &rest args))
757          (ftype          '(type-specifier &rest function-names))
758          (otherwise
759           (flet ((typespec-p (symbol)
760                    (member :type (describe-symbol-for-emacs symbol))))
761             (cond ((and (symbolp decl-identifier) (typespec-p decl-identifier))
762                    '(&rest variables))
763                   ((and (listp decl-identifier)
764                         (typespec-p (first decl-identifier)))
765                    '(&rest variables))
766                   (t :not-available)))))))
767    
768    (defgeneric type-specifier-arglist (typespec-operator)
769      (:documentation
770       "Return the argument list of the type specifier belonging to
771    TYPESPEC-OPERATOR.. If the arglist cannot be determined, the keyword
772    :NOT-AVAILABLE is returned.
773    
774    The different SWANK backends can specialize this generic function to
775    include implementation-dependend declaration specifiers, or to provide
776    additional information on the specifiers defined in ANSI Common Lisp.")
777      (:method (typespec-operator)
778        (declare (special *type-specifier-arglists*)) ; defined at end of file.
779        (typecase typespec-operator
780          (symbol (or (cdr (assoc typespec-operator *type-specifier-arglists*))
781                      :not-available))
782          (t :not-available))))
783    
784  (definterface function-name (function)  (definterface function-name (function)
785    "Return the name of the function object FUNCTION.    "Return the name of the function object FUNCTION.
786    
787  The result is either a symbol, a list, or NIL if no function name is available."  The result is either a symbol, a list, or NIL if no function name is
788    available."
789    (declare (ignore function))    (declare (ignore function))
790    nil)    nil)
791    
792    (definterface valid-function-name-p (form)
793      "Is FORM syntactically valid to name a function?
794       If true, FBOUNDP should not signal a type-error for FORM."
795      (flet ((length=2 (list)
796               (and (not (null (cdr list))) (null (cddr list)))))
797        (or (symbolp form)
798            (and (consp form) (length=2 form)
799                 (eq (first form) 'setf) (symbolp (second form))))))
800    
801  (definterface macroexpand-all (form)  (definterface macroexpand-all (form)
802     "Recursively expand all macros in FORM.     "Recursively expand all macros in FORM.
803  Return the resulting form.")  Return the resulting form.")
# Line 405  If FORM is a function call for which a c Line 808  If FORM is a function call for which a c
808  defined, invoke the expander function using *macroexpand-hook* and  defined, invoke the expander function using *macroexpand-hook* and
809  return the results and T.  Otherwise, return the original form and  return the results and T.  Otherwise, return the original form and
810  NIL."  NIL."
811    (let ((fun (and (consp form) (compiler-macro-function (car form)))))    (let ((fun (and (consp form)
812                      (valid-function-name-p (car form))
813                      (compiler-macro-function (car form)))))
814      (if fun      (if fun
815          (let ((result (funcall *macroexpand-hook* fun form env)))          (let ((result (funcall *macroexpand-hook* fun form env)))
816            (values result (not (eq result form))))            (values result (not (eq result form))))
# Line 421  NIL." Line 826  NIL."
826                     (values new-form expanded)))))                     (values new-form expanded)))))
827      (frob form env)))      (frob form env)))
828    
829    (definterface format-string-expand (control-string)
830      "Expand the format string CONTROL-STRING."
831      (macroexpand `(formatter ,control-string)))
832    
833  (definterface describe-symbol-for-emacs (symbol)  (definterface describe-symbol-for-emacs (symbol)
834     "Return a property list describing SYMBOL.     "Return a property list describing SYMBOL.
835    
# Line 431  symbol. The recognised keys are: Line 840  symbol. The recognised keys are:
840    :TYPE :CLASS :ALIEN-TYPE :ALIEN-STRUCT :ALIEN-UNION :ALIEN-ENUM    :TYPE :CLASS :ALIEN-TYPE :ALIEN-STRUCT :ALIEN-UNION :ALIEN-ENUM
841    
842  The value of each property is the corresponding documentation string,  The value of each property is the corresponding documentation string,
843  or :NOT-DOCUMENTED. It is legal to include keys not listed here (but  or NIL (or the obsolete :NOT-DOCUMENTED). It is legal to include keys
844  slime-print-apropos in Emacs must know about them).  not listed here (but slime-print-apropos in Emacs must know about
845    them).
846    
847  Properties should be included if and only if they are applicable to  Properties should be included if and only if they are applicable to
848  the symbol. For example, only (and all) fbound symbols should include  the symbol. For example, only (and all) fbound symbols should include
# Line 470  For example, this is a reasonable place Line 880  For example, this is a reasonable place
880  to safe reader/printer settings, and so on.")  to safe reader/printer settings, and so on.")
881    
882  (definterface call-with-debugger-hook (hook fun)  (definterface call-with-debugger-hook (hook fun)
883    "Call FUN and use HOOK as debugger hook.    "Call FUN and use HOOK as debugger hook. HOOK can be NIL.
884    
885  HOOK should be called for both BREAK and INVOKE-DEBUGGER."  HOOK should be called for both BREAK and INVOKE-DEBUGGER."
886    (let ((*debugger-hook* hook))    (let ((*debugger-hook* hook))
# Line 492  debug the debugger! Instead, such condit Line 902  debug the debugger! Instead, such condit
902  user without (re)entering the debugger by wrapping them as  user without (re)entering the debugger by wrapping them as
903  `sldb-condition's."))  `sldb-condition's."))
904    
905    ;;; The following functions in this section are supposed to be called
906    ;;; within the dynamic contour of CALL-WITH-DEBUGGING-ENVIRONMENT only.
907    
908  (definterface compute-backtrace (start end)  (definterface compute-backtrace (start end)
909     "Return a list containing a backtrace of the condition current     "Returns a backtrace of the condition currently being debugged,
910  being debugged.  The results are unspecified if this function is  that is an ordered list consisting of frames. ``Ordered list''
911  called outside the dynamic contour CALL-WITH-DEBUGGING-ENVIRONMENT.  means that an integer I can be mapped back to the i-th frame of this
912    backtrace.
913    
914  START and END are zero-based indices constraining the number of frames  START and END are zero-based indices constraining the number of frames
915  returned.  Frame zero is defined as the frame which invoked the  returned. Frame zero is defined as the frame which invoked the
916  debugger.  If END is nil, return the frames from START to the end of  debugger. If END is nil, return the frames from START to the end of
917  the stack.")  the stack.")
918    
919  (definterface print-frame (frame stream)  (definterface print-frame (frame stream)
920    "Print frame to stream.")    "Print frame to stream.")
921    
922  (definterface frame-source-location-for-emacs (frame-number)  (definterface frame-restartable-p (frame)
923    "Return the source location for FRAME-NUMBER.")    "Is the frame FRAME restartable?.
924    Return T if `restart-frame' can safely be called on the frame."
925      (declare (ignore frame))
926      nil)
927    
928    (definterface frame-source-location (frame-number)
929      "Return the source location for the frame associated to FRAME-NUMBER.")
930    
931  (definterface frame-catch-tags (frame-number)  (definterface frame-catch-tags (frame-number)
932    "Return a list of XXX list of what? catch tags for a debugger    "Return a list of catch tags for being printed in a debugger stack
933  stack frame.  The results are undefined unless this is called  frame."
934  within the dynamic contour of a function defined by    (declare (ignore frame-number))
935  DEFINE-DEBUGGER-HOOK.")    '())
936    
937  (definterface frame-locals (frame-number)  (definterface frame-locals (frame-number)
938    "Return a list of XXX local variable designators define me    "Return a list of ((&key NAME ID VALUE) ...) where each element of
939  for a debugger stack frame.  The results are undefined unless  the list represents a local variable in the stack frame associated to
940  this is called within the dynamic contour of a function defined  FRAME-NUMBER.
941  by DEFINE-DEBUGGER-HOOK.")  
942    NAME, a symbol; the name of the local variable.
943  (definterface frame-var-value (frame var)  
944    "Return the value of VAR in FRAME.  ID, an integer; used as primary key for the local variable, unique
945  FRAME is the number of the frame in the backtrace.  relatively to the frame under operation.
946  VAR is the number of the variable in the frame.")  
947    value, an object; the value of the local variable.")
948    
949    (definterface frame-var-value (frame-number var-id)
950      "Return the value of the local variable associated to VAR-ID
951    relatively to the frame associated to FRAME-NUMBER.")
952    
953  (definterface disassemble-frame (frame-number)  (definterface disassemble-frame (frame-number)
954    "Disassemble the code for the FRAME-NUMBER.    "Disassemble the code for the FRAME-NUMBER.
# Line 532  FRAME-NUMBER is a non-negative integer." Line 957  FRAME-NUMBER is a non-negative integer."
957    
958  (definterface eval-in-frame (form frame-number)  (definterface eval-in-frame (form frame-number)
959     "Evaluate a Lisp form in the lexical context of a stack frame     "Evaluate a Lisp form in the lexical context of a stack frame
960  in the debugger.  The results are undefined unless called in the  in the debugger.
 dynamic contour of a function defined by DEFINE-DEBUGGER-HOOK.  
961    
962  FRAME-NUMBER must be a positive integer with 0 indicating the  FRAME-NUMBER must be a positive integer with 0 indicating the
963  frame which invoked the debugger.  frame which invoked the debugger.
# Line 541  frame which invoked the debugger. Line 965  frame which invoked the debugger.
965  The return value is the result of evaulating FORM in the  The return value is the result of evaulating FORM in the
966  appropriate context.")  appropriate context.")
967    
968    (definterface frame-package (frame-number)
969      "Return the package corresponding to the frame at FRAME-NUMBER.
970    Return nil if the backend can't figure it out."
971      (declare (ignore frame-number))
972      nil)
973    
974    (definterface frame-call (frame-number)
975      "Return a string representing a call to the entry point of a frame.")
976    
977  (definterface return-from-frame (frame-number form)  (definterface return-from-frame (frame-number form)
978    "Unwind the stack to the frame FRAME-NUMBER and return the value(s)    "Unwind the stack to the frame FRAME-NUMBER and return the value(s)
979  produced by evaluating FORM in the frame context to its caller.  produced by evaluating FORM in the frame context to its caller.
# Line 559  as it was called originally.") Line 992  as it was called originally.")
992    "Format a condition for display in SLDB."    "Format a condition for display in SLDB."
993    (princ-to-string condition))    (princ-to-string condition))
994    
 (definterface condition-references (condition)  
   "Return a list of documentation references for a condition.  
 Each reference is one of:  
   (:ANSI-CL  
    {:FUNCTION | :SPECIAL-OPERATOR | :MACRO | :SECTION | :GLOSSARY }  
    symbol-or-name)  
   (:SBCL :NODE node-name)"  
   (declare (ignore condition))  
   '())  
   
995  (definterface condition-extras (condition)  (definterface condition-extras (condition)
996    "Return a list of extra for the debugger.    "Return a list of extra for the debugger.
997  The allowed elements are of the form:  The allowed elements are of the form:
998    (:SHOW-FRAME-SOURCE frame-number)"    (:SHOW-FRAME-SOURCE frame-number)
999      (:REFERENCES &rest refs)
1000    "
1001    (declare (ignore condition))    (declare (ignore condition))
1002    '())    '())
1003    
1004    (definterface gdb-initial-commands ()
1005      "List of gdb commands supposed to be executed first for the
1006       ATTACH-GDB restart."
1007      nil)
1008    
1009  (definterface activate-stepping (frame-number)  (definterface activate-stepping (frame-number)
1010    "Prepare the frame FRAME-NUMBER for stepping.")    "Prepare the frame FRAME-NUMBER for stepping.")
1011    
# Line 585  The allowed elements are of the form: Line 1015  The allowed elements are of the form:
1015  (definterface sldb-break-at-start (symbol)  (definterface sldb-break-at-start (symbol)
1016    "Set a breakpoint on the beginning of the function for SYMBOL.")    "Set a breakpoint on the beginning of the function for SYMBOL.")
1017    
1018    (definterface sldb-stepper-condition-p (condition)
1019      "Return true if SLDB was invoked due to a single-stepping condition,
1020    false otherwise. "
1021      (declare (ignore condition))
1022      nil)
1023    
1024    (definterface sldb-step-into ()
1025      "Step into the current single-stepper form.")
1026    
1027    (definterface sldb-step-next ()
1028      "Step to the next form in the current function.")
1029    
1030    (definterface sldb-step-out ()
1031      "Stop single-stepping temporarily, but resume it once the current function
1032    returns.")
1033    
1034    
1035  ;;;; Definition finding  ;;;; Definition finding
# Line 600  The allowed elements are of the form: Line 1045  The allowed elements are of the form:
1045    hints)    hints)
1046    
1047  (defstruct (:error (:type list) :named (:constructor)) message)  (defstruct (:error (:type list) :named (:constructor)) message)
1048  (defstruct (:file (:type list) :named (:constructor)) name)  
1049  (defstruct (:buffer (:type list) :named (:constructor)) name)  ;;; Valid content for BUFFER slot
1050    (defstruct (:file       (:type list) :named (:constructor)) name)
1051    (defstruct (:buffer     (:type list) :named (:constructor)) name)
1052    (defstruct (:etags-file (:type list) :named (:constructor)) filename)
1053    
1054    ;;; Valid content for POSITION slot
1055  (defstruct (:position (:type list) :named (:constructor)) pos)  (defstruct (:position (:type list) :named (:constructor)) pos)
1056    (defstruct (:tag      (:type list) :named (:constructor)) tag1 tag2)
1057    
1058    (defmacro converting-errors-to-error-location (&body body)
1059      "Catches errors during BODY and converts them to an error location."
1060      (let ((gblock (gensym "CONVERTING-ERRORS+")))
1061        `(block ,gblock
1062           (handler-bind ((error
1063                           #'(lambda (e)
1064                                (if *debug-swank-backend*
1065                                    nil     ;decline
1066                                    (return-from ,gblock
1067                                      (make-error-location e))))))
1068             ,@body))))
1069    
1070    (defun make-error-location (datum &rest args)
1071      (cond ((typep datum 'condition)
1072             `(:error ,(format nil "Error: ~A" datum)))
1073            ((symbolp datum)
1074             `(:error ,(format nil "Error: ~A"
1075                               (apply #'make-condition datum args))))
1076            (t
1077             (assert (stringp datum))
1078             `(:error ,(apply #'format nil datum args)))))
1079    
1080  (definterface find-definitions (name)  (definterface find-definitions (name)
1081     "Return a list ((DSPEC LOCATION) ...) for NAME's definitions.     "Return a list ((DSPEC LOCATION) ...) for NAME's definitions.
# Line 615  definition, e.g., FOO or (METHOD FOO (ST Line 1088  definition, e.g., FOO or (METHOD FOO (ST
1088    
1089  LOCATION is the source location for the definition.")  LOCATION is the source location for the definition.")
1090    
1091    (definterface find-source-location (object)
1092      "Returns the source location of OBJECT, or NIL.
1093    
1094    That is the source location of the underlying datastructure of
1095    OBJECT. E.g. on a STANDARD-OBJECT, the source location of the
1096    respective DEFCLASS definition is returned, on a STRUCTURE-CLASS the
1097    respective DEFSTRUCT definition, and so on."
1098      ;; This returns one source location and not a list of locations. It's
1099      ;; supposed to return the location of the DEFGENERIC definition on
1100      ;; #'SOME-GENERIC-FUNCTION.
1101      (declare (ignore object))
1102      (make-error-location "FIND-DEFINITIONS is not yet implemented on ~
1103                            this implementation."))
1104    
1105  (definterface buffer-first-change (filename)  (definterface buffer-first-change (filename)
1106    "Called for effect the first time FILENAME's buffer is modified."    "Called for effect the first time FILENAME's buffer is modified.
1107    CMUCL/SBCL use this to cache the unmodified file and use the
1108    unmodified text to improve the precision of source locations."
1109    (declare (ignore filename))    (declare (ignore filename))
1110    nil)    nil)
1111    
1112    
1113    
1114  ;;;; XREF  ;;;; XREF
1115    
1116  (definterface who-calls (function-name)  (definterface who-calls (function-name)
1117    "Return the call sites of FUNCTION-NAME (a symbol).    "Return the call sites of FUNCTION-NAME (a symbol).
1118  The results is a list ((DSPEC LOCATION) ...).")  The results is a list ((DSPEC LOCATION) ...)."
1119      (declare (ignore function-name))
1120      :not-implemented)
1121    
1122  (definterface calls-who (function-name)  (definterface calls-who (function-name)
1123    "Return the call sites of FUNCTION-NAME (a symbol).    "Return the call sites of FUNCTION-NAME (a symbol).
1124  The results is a list ((DSPEC LOCATION) ...).")  The results is a list ((DSPEC LOCATION) ...)."
1125      (declare (ignore function-name))
1126      :not-implemented)
1127    
1128  (definterface who-references (variable-name)  (definterface who-references (variable-name)
1129    "Return the locations where VARIABLE-NAME (a symbol) is referenced.    "Return the locations where VARIABLE-NAME (a symbol) is referenced.
1130  See WHO-CALLS for a description of the return value.")  See WHO-CALLS for a description of the return value."
1131      (declare (ignore variable-name))
1132      :not-implemented)
1133    
1134  (definterface who-binds (variable-name)  (definterface who-binds (variable-name)
1135    "Return the locations where VARIABLE-NAME (a symbol) is bound.    "Return the locations where VARIABLE-NAME (a symbol) is bound.
1136  See WHO-CALLS for a description of the return value.")  See WHO-CALLS for a description of the return value."
1137      (declare (ignore variable-name))
1138      :not-implemented)
1139    
1140  (definterface who-sets (variable-name)  (definterface who-sets (variable-name)
1141    "Return the locations where VARIABLE-NAME (a symbol) is set.    "Return the locations where VARIABLE-NAME (a symbol) is set.
1142  See WHO-CALLS for a description of the return value.")  See WHO-CALLS for a description of the return value."
1143      (declare (ignore variable-name))
1144      :not-implemented)
1145    
1146  (definterface who-macroexpands (macro-name)  (definterface who-macroexpands (macro-name)
1147    "Return the locations where MACRO-NAME (a symbol) is expanded.    "Return the locations where MACRO-NAME (a symbol) is expanded.
1148  See WHO-CALLS for a description of the return value.")  See WHO-CALLS for a description of the return value."
1149      (declare (ignore macro-name))
1150      :not-implemented)
1151    
1152  (definterface who-specializes (class-name)  (definterface who-specializes (class-name)
1153    "Return the locations where CLASS-NAME (a symbol) is specialized.    "Return the locations where CLASS-NAME (a symbol) is specialized.
1154  See WHO-CALLS for a description of the return value.")  See WHO-CALLS for a description of the return value."
1155      (declare (ignore class-name))
1156      :not-implemented)
1157    
1158  ;;; Simpler variants.  ;;; Simpler variants.
1159    
# Line 704  generic functions having names in the gi Line 1208  generic functions having names in the gi
1208  themselves, that is, their dispatch functions, are left alone.")  themselves, that is, their dispatch functions, are left alone.")
1209    
1210    
1211  ;;;; Inspector  ;;;; Trace
1212    
1213  (defclass inspector ()  (definterface toggle-trace (spec)
1214    ()    "Toggle tracing of the function(s) given with SPEC.
1215    (:documentation "Super class of inspector objects.  SPEC can be:
1216     (setf NAME)                            ; a setf function
1217  Implementations should sub class in order to dispatch off of the   (:defmethod NAME QUALIFIER... (SPECIALIZER...)) ; a specific method
1218  inspect-for-emacs method."))   (:defgeneric NAME)                     ; a generic function with all methods
1219     (:call CALLER CALLEE)                  ; trace calls from CALLER to CALLEE.
1220     (:labels TOPLEVEL LOCAL)
1221     (:flet TOPLEVEL LOCAL) ")
1222    
1223  (definterface make-default-inspector ()  
1224    "Return an inspector object suitable for passing to inspect-for-emacs.")  ;;;; Inspector
1225    
1226  (definterface inspect-for-emacs (object inspector)  (defgeneric emacs-inspect (object)
1227      (:documentation
1228     "Explain to Emacs how to inspect OBJECT.     "Explain to Emacs how to inspect OBJECT.
1229    
1230  The argument INSPECTOR is an object representing how to get at  Returns a list specifying how to render the object for inspection.
 the internals of OBJECT, it is usually an implementation specific  
 class used simply for dispatching to the proper method.  
   
 The orgument INSPECTION-MODE is an object specifying how, and  
 what, to show to the user.  
   
 Returns two values: a string which will be used as the title of  
 the inspector buffer and a list specifying how to render the  
 object for inspection.  
1231    
1232  Every element of the list must be either a string, which will be  Every element of the list must be either a string, which will be
1233  inserted into the buffer as is, or a list of the form:  inserted into the buffer as is, or a list of the form:
# Line 739  inserted into the buffer as is, or a lis Line 1238  inserted into the buffer as is, or a lis
1238    
1239   (:newline) - Render a \\n   (:newline) - Render a \\n
1240    
1241   (:action label lambda) - Render LABEL (a text string) which when   (:action label lambda &key (refresh t)) - Render LABEL (a text
1242   clicked will call LAMBDA.   string) which when clicked will call LAMBDA. If REFRESH is
1243     non-NIL the currently inspected object will be re-inspected
1244     after calling the lambda.
1245    "))
1246    
1247   NIL - do nothing.")  (defmethod emacs-inspect ((object t))
   
 (defmethod inspect-for-emacs ((object t) (inspector t))  
1248    "Generic method for inspecting any kind of object.    "Generic method for inspecting any kind of object.
1249    
1250  Since we don't know how to deal with OBJECT we simply dump the  Since we don't know how to deal with OBJECT we simply dump the
1251  output of CL:DESCRIBE."  output of CL:DESCRIBE."
   (declare (ignore inspector))  
   (values  
    "A value."  
1252     `("Type: " (:value ,(type-of object)) (:newline)     `("Type: " (:value ,(type-of object)) (:newline)
1253       "Don't know how to inspect the object, dumping output of CL:DESCRIBE:"       "Don't know how to inspect the object, dumping output of CL:DESCRIBE:"
1254       (:newline) (:newline)       (:newline) (:newline)
1255       ,(with-output-to-string (desc) (describe object desc)))))       ,(with-output-to-string (desc) (describe object desc))))
1256    
1257    (definterface eval-context (object)
1258      "Return a list of bindings corresponding to OBJECT's slots."
1259      (declare (ignore object))
1260      '())
1261    
1262  ;;; Utilities for inspector methods.  ;;; Utilities for inspector methods.
1263  ;;;  ;;;
1264  (defun label-value-line (label value)  
1265    "Create a control list which prints \"LABEL: VALUE\" in the inspector."  (defun label-value-line (label value &key (newline t))
1266    (list (princ-to-string label) ": " `(:value ,value) '(:newline)))    "Create a control list which prints \"LABEL: VALUE\" in the inspector.
1267    If NEWLINE is non-NIL a `(:newline)' is added to the result."
1268      (list* (princ-to-string label) ": " `(:value ,value)
1269             (if newline '((:newline)) nil)))
1270    
1271  (defmacro label-value-line* (&rest label-values)  (defmacro label-value-line* (&rest label-values)
1272    ` (append ,@(loop for (label value) in label-values    ` (append ,@(loop for (label value) in label-values
# Line 778  output of CL:DESCRIBE." Line 1283  output of CL:DESCRIBE."
1283  ;;; The default implementations are sufficient for non-multiprocessing  ;;; The default implementations are sufficient for non-multiprocessing
1284  ;;; implementations.  ;;; implementations.
1285    
1286  (definterface initialize-multiprocessing ()  (definterface initialize-multiprocessing (continuation)
1287     "Initialize multiprocessing, if necessary."     "Initialize multiprocessing, if necessary and then invoke CONTINUATION.
    nil)  
1288    
1289  (definterface startup-idle-and-top-level-loops ()  Depending on the impleimentaion, this function may never return."
1290    "This function is called directly through the listener, not in an RPC     (funcall continuation))
 from Emacs. This is to support interfaces such as CMUCL's  
 MP::STARTUP-IDLE-AND-TOP-LEVEL-LOOPS which does not return like a  
 normal function."  
    nil)  
1291    
1292  (definterface spawn (fn &key name)  (definterface spawn (fn &key name)
1293    "Create a new thread to call FN.")    "Create a new thread to call FN.")
# Line 796  normal function." Line 1296  normal function."
1296    "Return an Emacs-parsable object to identify THREAD.    "Return an Emacs-parsable object to identify THREAD.
1297    
1298  Ids should be comparable with equal, i.e.:  Ids should be comparable with equal, i.e.:
1299   (equal (thread-id <t1>) (thread-id <t2>)) <==> (eq <t1> <t2>)")   (equal (thread-id <t1>) (thread-id <t2>)) <==> (eq <t1> <t2>)"
1300      thread)
1301    
1302  (definterface find-thread (id)  (definterface find-thread (id)
1303    "Return the thread for ID.    "Return the thread for ID.
1304  ID should be an id previously obtained with THREAD-ID.  ID should be an id previously obtained with THREAD-ID.
1305  Can return nil if the thread no longer exists.")  Can return nil if the thread no longer exists."
1306      (declare (ignore id))
1307      (current-thread))
1308    
1309  (definterface thread-name (thread)  (definterface thread-name (thread)
1310     "Return the name of THREAD.     "Return the name of THREAD.
1311    Thread names are short strings meaningful to the user. They do not
1312  Thread names are be single-line strings and are meaningful to the  have to be unique."
 user. They do not have to be unique."  
1313     (declare (ignore thread))     (declare (ignore thread))
1314     "The One True Thread")     "The One True Thread")
1315    
# Line 816  user. They do not have to be unique." Line 1318  user. They do not have to be unique."
1318     (declare (ignore thread))     (declare (ignore thread))
1319     "")     "")
1320    
1321  (definterface make-lock (&key name)  (definterface thread-attributes (thread)
1322     "Make a lock for thread synchronization.    "Return a plist of implementation-dependent attributes for THREAD"
1323  Only one thread may hold the lock (via CALL-WITH-LOCK-HELD) at a time."    (declare (ignore thread))
1324     (declare (ignore name))    '())
    :null-lock)  
   
 (definterface call-with-lock-held (lock function)  
    "Call FUNCTION with LOCK held, queueing if necessary."  
    (declare (ignore lock)  
             (type function function))  
    (funcall function))  
1325    
1326  (definterface current-thread ()  (definterface current-thread ()
1327    "Return the currently executing thread."    "Return the currently executing thread."
1328    0)    0)
1329    
1330  (definterface all-threads ()  (definterface all-threads ()
1331    "Return a list of all threads.")    "Return a fresh list of all threads."
1332      '())
1333    
1334  (definterface thread-alive-p (thread)  (definterface thread-alive-p (thread)
1335    "Test if THREAD is termintated."    "Test if THREAD is termintated."
# Line 843  Only one thread may hold the lock (via C Line 1339  Only one thread may hold the lock (via C
1339    "Cause THREAD to execute FN.")    "Cause THREAD to execute FN.")
1340    
1341  (definterface kill-thread (thread)  (definterface kill-thread (thread)
1342    "Kill THREAD."    "Terminate THREAD immediately.
1343    Don't execute unwind-protected sections, don't raise conditions.
1344    (Do not pass go, do not collect $200.)"
1345    (declare (ignore thread))    (declare (ignore thread))
1346    nil)    nil)
1347    
1348  (definterface send (thread object)  (definterface send (thread object)
1349    "Send OBJECT to thread THREAD.")    "Send OBJECT to thread THREAD."
1350      (declare (ignore thread))
1351      object)
1352    
1353  (definterface receive ()  (definterface receive (&optional timeout)
1354    "Return the next message from current thread's mailbox.")    "Return the next message from current thread's mailbox."
1355      (receive-if (constantly t) timeout))
1356    
1357    (definterface receive-if (predicate &optional timeout)
1358      "Return the first message satisfiying PREDICATE.")
1359    
1360    (definterface register-thread (name thread)
1361      "Associate the thread THREAD with the symbol NAME.
1362    The thread can then be retrieved with `find-registered'.
1363    If THREAD is nil delete the association."
1364      (declare (ignore name thread))
1365      nil)
1366    
1367  (definterface toggle-trace (spec)  (definterface find-registered (name)
1368    "Toggle tracing of the function(s) given with SPEC.    "Find the thread that was registered for the symbol NAME.
1369  SPEC can be:  Return nil if the no thread was registred or if the tread is dead."
1370   (setf NAME)                            ; a setf function    (declare (ignore name))
1371   (:defmethod NAME QUALIFIER... (SPECIALIZER...)) ; a specific method    nil)
1372   (:defgeneric NAME)                     ; a generic function with all methods  
1373   (:call CALLER CALLEE)                  ; trace calls from CALLER to CALLEE.  (definterface set-default-initial-binding (var form)
1374   (:labels TOPLEVEL LOCAL)    "Initialize special variable VAR by default with FORM.
1375   (:flet TOPLEVEL LOCAL) ")  
1376    Some implementations initialize certain variables in each newly
1377    created thread.  This function sets the form which is used to produce
1378    the initial value."
1379      (set var (eval form)))
1380    
1381    ;; List of delayed interrupts.
1382    ;; This should only have thread-local bindings, so no init form.
1383    (defvar *pending-slime-interrupts*)
1384    
1385    (defun check-slime-interrupts ()
1386      "Execute pending interrupts if any.
1387    This should be called periodically in operations which
1388    can take a long time to complete.
1389    Return a boolean indicating whether any interrupts was processed."
1390      (when (and (boundp '*pending-slime-interrupts*)
1391                 *pending-slime-interrupts*)
1392        (funcall (pop *pending-slime-interrupts*))
1393        t))
1394    
1395    (defvar *interrupt-queued-handler* nil
1396      "Function to call on queued interrupts.
1397    Interrupts get queued when an interrupt occurs while interrupt
1398    handling is disabled.
1399    
1400    Backends can use this function to abort slow operations.")
1401    
1402    (definterface wait-for-input (streams &optional timeout)
1403      "Wait for input on a list of streams.  Return those that are ready.
1404    STREAMS is a list of streams
1405    TIMEOUT nil, t, or real number. If TIMEOUT is t, return those streams
1406    which are ready (or have reached end-of-file) without waiting.
1407    If TIMEOUT is a number and no streams is ready after TIMEOUT seconds,
1408    return nil.
1409    
1410    Return :interrupt if an interrupt occurs while waiting.")
1411    
1412    
1413    ;;;;  Locks
1414    
1415    ;; Please use locks only in swank-gray.lisp.  Locks are too low-level
1416    ;; for our taste.
1417    
1418    (definterface make-lock (&key name)
1419       "Make a lock for thread synchronization.
1420    Only one thread may hold the lock (via CALL-WITH-LOCK-HELD) at a time
1421    but that thread may hold it more than once."
1422       (declare (ignore name))
1423       :null-lock)
1424    
1425    (definterface call-with-lock-held (lock function)
1426       "Call FUNCTION with LOCK held, queueing if necessary."
1427       (declare (ignore lock)
1428                (type function function))
1429       (funcall function))
1430    
1431    
1432  ;;;; Weak datastructures  ;;;; Weak datastructures
# Line 873  SPEC can be: Line 1438  SPEC can be:
1438  (definterface make-weak-value-hash-table (&rest args)  (definterface make-weak-value-hash-table (&rest args)
1439    "Like MAKE-HASH-TABLE, but weak w.r.t. the values."    "Like MAKE-HASH-TABLE, but weak w.r.t. the values."
1440    (apply #'make-hash-table args))    (apply #'make-hash-table args))
1441    
1442    (definterface hash-table-weakness (hashtable)
1443      "Return nil or one of :key :value :key-or-value :key-and-value"
1444      (declare (ignore hashtable))
1445      nil)
1446    
1447    
1448    ;;;; Character names
1449    
1450    (definterface character-completion-set (prefix matchp)
1451      "Return a list of names of characters that match PREFIX."
1452      ;; Handle the standard and semi-standard characters.
1453      (loop for name in '("Newline" "Space" "Tab" "Page" "Rubout"
1454                          "Linefeed" "Return" "Backspace")
1455         when (funcall matchp prefix name)
1456         collect name))
1457    
1458    
1459    (defparameter *type-specifier-arglists*
1460      '((and                . (&rest type-specifiers))
1461        (array              . (&optional element-type dimension-spec))
1462        (base-string        . (&optional size))
1463        (bit-vector         . (&optional size))
1464        (complex            . (&optional type-specifier))
1465        (cons               . (&optional car-typespec cdr-typespec))
1466        (double-float       . (&optional lower-limit upper-limit))
1467        (eql                . (object))
1468        (float              . (&optional lower-limit upper-limit))
1469        (function           . (&optional arg-typespec value-typespec))
1470        (integer            . (&optional lower-limit upper-limit))
1471        (long-float         . (&optional lower-limit upper-limit))
1472        (member             . (&rest eql-objects))
1473        (mod                . (n))
1474        (not                . (type-specifier))
1475        (or                 . (&rest type-specifiers))
1476        (rational           . (&optional lower-limit upper-limit))
1477        (real               . (&optional lower-limit upper-limit))
1478        (satisfies          . (predicate-symbol))
1479        (short-float        . (&optional lower-limit upper-limit))
1480        (signed-byte        . (&optional size))
1481        (simple-array       . (&optional element-type dimension-spec))
1482        (simple-base-string . (&optional size))
1483        (simple-bit-vector  . (&optional size))
1484        (simple-string      . (&optional size))
1485        (single-float       . (&optional lower-limit upper-limit))
1486        (simple-vector      . (&optional size))
1487        (string             . (&optional size))
1488        (unsigned-byte      . (&optional size))
1489        (values             . (&rest typespecs))
1490        (vector             . (&optional element-type size))
1491        ))
1492    
1493    ;;; Heap dumps
1494    
1495    (definterface save-image (filename &optional restart-function)
1496      "Save a heap image to the file FILENAME.
1497    RESTART-FUNCTION, if non-nil, should be called when the image is loaded.")
1498    
1499    (definterface background-save-image (filename &key restart-function
1500                                                  completion-function)
1501      "Request saving a heap image to the file FILENAME.
1502    RESTART-FUNCTION, if non-nil, should be called when the image is loaded.
1503    COMPLETION-FUNCTION, if non-nil, should be called after saving the image.")
1504    
1505    (defun deinit-log-output ()
1506      ;; Can't hang on to an fd-stream from a previous session.
1507      (setf (symbol-value (find-symbol "*LOG-OUTPUT*" 'swank))
1508            nil))

Legend:
Removed from v.1.94  
changed lines
  Added in v.1.223

  ViewVC Help
Powered by ViewVC 1.1.5