/[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.22.2.2 by heller, Sat Jan 31 11:26:02 2004 UTC revision 1.224 by sboukarev, Sat Feb 2 10:11:16 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  ;;;  ;;;
5  ;;; Created by James Bielman in 2003. Released into the public domain.  ;;; Created by James Bielman in 2003. Released into the public domain.
6  ;;;  ;;;
7    ;;;; Frontmatter
8    ;;;
9  ;;; This file defines the functions that must be implemented  ;;; This file defines the functions that must be implemented
10  ;;; separately for each Lisp. Each is declared as a generic function  ;;; separately for each Lisp. Each is declared as a generic function
11  ;;; for which swank-<implementation>.lisp provides methods.  ;;; for which swank-<implementation>.lisp provides methods.
12    
13  (defpackage :swank  (defpackage :swank-backend
14    (:use :common-lisp)    (:use :common-lisp)
15    (:nicknames #:swank-backend)    (:export #:*debug-swank-backend*
16    (:export #:*sldb-pprint-frames*             #:sldb-condition
17             #:apropos-list-for-emacs             #:compiler-condition
18             #:arglist-string             #:original-condition
19             #:backtrace             #:message
20             #:call-with-I/O-lock             #:source-context
21             #:call-with-conversation-lock             #:condition
22             #:compiler-notes-for-emacs             #:severity
23             #:completions             #:with-compilation-hooks
24             #:create-server             #:location
25             #:create-swank-server             #:location-p
26             #:describe-definition             #:location-buffer
27             #:describe-symbol             #:location-position
28             #:describe-symbol-for-emacs             #:position-p
29             #:disassemble-symbol             #:position-pos
30             #:documentation-symbol             #:print-output-to-string
31             #:eval-in-frame             #:quit-lisp
32             #:return-from-frame             #:references
33             #:restart-frame             #:unbound-slot-filler
34             #:eval-string             #:declaration-arglist
35             #:eval-string-in-frame             #:type-specifier-arglist
36             #:find-function-locations             #:with-struct
37             #:frame-catch-tags             #:when-let
38             #:frame-locals             ;; interrupt macro for the backend
39             #:frame-source-location-for-emacs             #:*pending-slime-interrupts*
40             #:frame-source-position             #:check-slime-interrupts
41             #:getpid             #:*interrupt-queued-handler*
42             #:give-goahead             ;; inspector related symbols
43             #:give-gohead             #:emacs-inspect
44             #:init-inspector             #:label-value-line
45             #:inspect-in-frame             #:label-value-line*
46             #:inspect-nth-part             #:with-symbol))
47             #:inspector-next  
48             #:inspector-pop  (defpackage :swank-mop
49             #:interactive-eval    (:use)
50             #:interactive-eval-region    (:export
51             #:invoke-nth-restart     ;; classes
52             #:invoke-nth-restart-for-emacs     #:standard-generic-function
53             #:list-all-package-names     #:standard-slot-definition
54             #:list-callees     #:standard-method
55             #:list-callers     #:standard-class
56             #:listener-eval     #:eql-specializer
57             #:load-file     #:eql-specializer-object
58             #:pprint-eval     ;; standard-class readers
59             #:pprint-eval-string-in-frame     #:class-default-initargs
60             #:quit-inspector     #:class-direct-default-initargs
61             #:re-evaluate-defvar     #:class-direct-slots
62             #:set-default-directory     #:class-direct-subclasses
63             #:set-package     #:class-direct-superclasses
64             #:sldb-abort     #:class-finalized-p
65             #:sldb-break-with-default-debugger     #:class-name
66             #:sldb-continue     #:class-precedence-list
67             #:slime-debugger-function     #:class-prototype
68             #:start-server     #:class-slots
69             #:startup-multiprocessing     #:specializer-direct-methods
70             #:startup-multiprocessing-for-emacs     ;; generic function readers
71             #:swank-compile-file     #:generic-function-argument-precedence-order
72             #:swank-compile-string     #:generic-function-declarations
73             #:swank-macroexpand     #:generic-function-lambda-list
74             #:swank-macroexpand-1     #:generic-function-methods
75             #:swank-macroexpand-all     #:generic-function-method-class
76             #:take-input     #:generic-function-method-combination
77             #:thread-id     #:generic-function-name
78             #:thread-name     ;; method readers
79             #:throw-to-toplevel     #:method-generic-function
80             #:toggle-trace-fdefinition     #:method-function
81             #:untrace-all     #:method-lambda-list
82             #:wait-goahead     #:method-specializers
83             #:warn-unimplemented-interfaces     #:method-qualifiers
84             #:who-binds     ;; slot readers
85             #:who-calls     #:slot-definition-allocation
86             #:who-macroexpands     #:slot-definition-documentation
87             #:who-references     #:slot-definition-initargs
88             #:who-sets     #:slot-definition-initform
89             ))     #:slot-definition-initfunction
90       #:slot-definition-name
91       #:slot-definition-type
92       #:slot-definition-readers
93       #:slot-definition-writers
94       #:slot-boundp-using-class
95       #:slot-value-using-class
96       #:slot-makunbound-using-class
97       ;; generic function protocol
98       #:compute-applicable-methods-using-classes
99       #:finalize-inheritance))
100    
101  (in-package :swank)  (in-package :swank-backend)
102    
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 98  Line 115 
115    "List of interface functions that are not implemented.    "List of interface functions that are not implemented.
116  DEFINTERFACE adds to this list and DEFIMPLEMENTATION removes.")  DEFINTERFACE adds to this list and DEFIMPLEMENTATION removes.")
117    
118  (defmacro definterface (name args documentation &body 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    (flet ((gen-default-impl ()    (check-type documentation string "a documentation string")
132             (let ((received-args (gensym "ARGS-")))    (assert (every #'symbolp args) ()
133               `(defmethod no-applicable-method ((#:method            "Complex lambda-list not supported: ~S ~S" name args)
134                                                  (eql (function ,name)))    (labels ((gen-default-impl ()
135                                                 &rest ,received-args)               `(setf (get ',name 'default) (lambda ,args ,@default-body)))
136                 (destructuring-bind ,args ,received-args             (args-as-list (args)
137                   ,@default-body)))))               (destructuring-bind (req opt key rest) (parse-lambda-list args)
138      `(progn (defgeneric ,name ,args (:documentation ,documentation))                 `(,@req ,@opt
139              (pushnew ',name *interface-functions*)                         ,@(loop for k in key append `(,(kw k) ,k))
140              ,(if (null default-body)                         ,@(or rest '(())))))
141                   `(pushnew ',name *unimplemented-interfaces*)             (parse-lambda-list (args)
142                   (gen-default-impl))               (parse args '(&optional &key &rest)
143              ',name)))                      (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    ;; Is this a macro no-no -- should it be pushed out of macroexpansion?    (assert (every #'symbolp args) ()
169    `(progn (defmethod ,name ,args ,@body)            "Complex lambda-list not supported: ~S ~S" name args)
170            (if (member ',name *interface-functions*)    `(progn
171                (setq *unimplemented-interfaces*       (setf (get ',name 'implementation)
172                      (remove ',name *unimplemented-interfaces*))             ;; For implicit BLOCK. FLET because of interplay w/ decls.
173                (warn "DEFIMPLEMENTATION of undefined interface (~S)" ',name))             (flet ((,name ,args ,@body)) #',name))
174            ',name))       (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)
188      (dolist (sym symbol-list)
189        (let* ((swank-mop-sym (find-symbol (symbol-name sym) :swank-mop)))
190          (when swank-mop-sym
191            (unintern swank-mop-sym :swank-mop))
192          (import sym :swank-mop)
193          (export sym :swank-mop))))
194    
195    (defun import-swank-mop-symbols (package except)
196      "Import the mop symbols from PACKAGE to SWANK-MOP.
197    EXCEPT is a list of symbol names which should be ignored."
198      (do-symbols (s :swank-mop)
199        (unless (member s except :test #'string=)
200          (let ((real-symbol (find-symbol (string s) package)))
201            (assert real-symbol () "Symbol ~A not found in package ~A" s package)
202            (unintern s :swank-mop)
203            (import real-symbol :swank-mop)
204            (export real-symbol :swank-mop)))))
205    
206    (defvar *gray-stream-symbols*
207      '(:fundamental-character-output-stream
208        :stream-write-char
209        :stream-write-string
210        :stream-fresh-line
211        :stream-force-output
212        :stream-finish-output
213        :fundamental-character-input-stream
214        :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
221        :stream-unread-char
222        :stream-clear-input
223        :stream-line-column
224        :stream-read-char-no-hang
225        ;; STREAM-LINE-LENGTH is an extension to gray streams that's apparently
226        ;; supported by CMUCL, OpenMCL, SBCL and SCL.
227        #+(or cmu openmcl sbcl scl)
228        :stream-line-length))
229    
230    (defun import-from (package symbol-names &optional (to-package *package*))
231      "Import the list of SYMBOL-NAMES found in the package PACKAGE."
232      (dolist (name symbol-names)
233        (multiple-value-bind (symbol found) (find-symbol (string name) package)
234          (assert found () "Symbol ~A not found in package ~A" name package)
235          (import symbol to-package))))
236    
237    
238    ;;;; Utilities
239    
240    (defmacro with-struct ((conc-name &rest names) obj &body body)
241      "Like with-slots but works only for structs."
242      (check-type conc-name symbol)
243      (flet ((reader (slot)
244               (intern (concatenate 'string
245                                    (symbol-name conc-name)
246                                    (symbol-name slot))
247                       (symbol-package conc-name))))
248        (let ((tmp (gensym "OO-")))
249          ` (let ((,tmp ,obj))
250              (symbol-macrolet
251                  ,(loop for name in names collect
252                         (typecase name
253                           (symbol `(,name (,(reader name) ,tmp)))
254                           (cons `(,(first name) (,(reader (second name)) ,tmp)))
255                           (t (error "Malformed syntax in WITH-STRUCT: ~A" name))))
256                ,@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 (port)  (definterface create-socket (host port &key backlog)
448    "Create a listening TCP socket on 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 148  The portable code calls this function at Line 454  The portable code calls this function at
454  (definterface close-socket (socket)  (definterface close-socket (socket)
455    "Close the socket SOCKET.")    "Close the socket SOCKET.")
456    
457  (definterface accept-connection (socket)  (definterface accept-connection (socket &key external-format
458     "Accept a client connection on the listening socket SOCKET.  Return                                          buffering timeout)
459  a stream for the new connection.")     "Accept a client connection on the listening socket SOCKET.
460    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-input-handler (socket fn)  (definterface add-sigio-handler (socket fn)
469    "Call FN whenever SOCKET is readable.")    "Call FN whenever SOCKET is readable.")
470    
471  (definterface remove-input-handlers (socket)  (definterface remove-sigio-handlers (socket)
472    "Remove all input handlers for SOCKET.")    "Remove all sigio handlers for SOCKET.")
473    
474    (definterface add-fd-handler (socket fn)
475      "Call FN when Lisp is waiting for input and SOCKET is readable.")
476    
477    (definterface remove-fd-handlers (socket)
478      "Remove all fd-handlers for SOCKET.")
479    
480    (definterface preferred-communication-style ()
481      "Return one of the symbols :spawn, :sigio, :fd-handler, or NIL."
482      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 (error) ())  (define-condition network-error (simple-error) ())
492    
493  (definterface emacs-connected ()  (definterface emacs-connected ()
494     "Hook called when the first connection from Emacs is established.     "Hook called when the first connection from Emacs is established.
# Line 175  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    
507  (defgeneric call-without-interrupts (fn)  (definterface getpid ()
508    (:documentation "Call FN in a context where interrupts are disabled."))    "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 ()
526      "Return a short name for the Lisp implementation."
527      (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 ()
572      "Return the default directory."
573      (directory-namestring (truename *default-pathname-defaults*)))
574    
575    (definterface set-default-directory (directory)
576      "Set the default directory.
577    This is used to resolve filenames without directory component."
578      (setf *default-pathname-defaults* (truename (merge-pathnames directory)))
579      (default-directory))
580    
581  (defgeneric getpid ()  
582    (:documentation "Return the (Unix) process ID of this superior Lisp."))  (definterface call-with-syntax-hooks (fn)
583      "Call FN with hooks to handle special syntax."
584      (funcall fn))
585    
586    (definterface default-readtable-alist ()
587      "Return a suitable initial value for SWANK:*READTABLE-ALIST*."
588      '())
589    
590    
591  ;;;; Compilation  ;;;; Compilation
592    
593  (definterface call-with-compilation-hooks (func)  (definterface call-with-compilation-hooks (func)
594     "Call FUNC with hooks to trigger SLDB on compiler errors.")    "Call FUNC with hooks to record compiler conditions.")
595    
596  (defmacro with-compilation-hooks ((&rest ignore) &body body)  (defmacro with-compilation-hooks ((&rest ignore) &body body)
597      "Execute BODY as in CALL-WITH-COMPILATION-HOOKS."
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 compile-string-for-emacs (string &key buffer position)  (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 FILENAME is specified it may be used by certain implementations to
613    rebind *DEFAULT-PATHNAME-DEFAULTS* which may improve the recording of
614    source information.
615    
616    If POLICY is supplied, and non-NIL, it may be used by certain
617    implementations to compile with optimization qualities of its
618    value.
619    
620    Should return T on successful compilation, NIL otherwise.
621    ")
622    
623  (definterface compile-file-for-emacs (filename load-p)  (definterface swank-compile-file (input-file output-file load-p
624     "Compile FILENAME signalling COMPILE-CONDITIONs.                                               external-format
625  If LOAD-P is true, load the file after compilation.")                                               &key policy)
626       "Compile INPUT-FILE signalling COMPILE-CONDITIONs.
627    If LOAD-P is true, load the file after compilation.
628    EXTERNAL-FORMAT is a value returned by find-external-format or
629    :default.
630    
631    If POLICY is supplied, and non-NIL, it may be used by certain
632    implementations to compile with optimization qualities of its
633    value.
634    
635  (deftype severity () '(member :error :warning :style-warning :note))  Should return OUTPUT-TRUENAME, WARNINGS-P and FAILURE-p
636    like `compile-file'")
637    
638    (deftype severity ()
639      '(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 222  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       ;; Macro expansion history etc. which may be helpful in some cases
658       ;; but is often very verbose.
659       (source-context :initarg :source-context
660                       :type (or null string)
661                       :initform nil
662                       :accessor source-context)
663    
664       (references :initarg :references
665                   :initform nil
666                   :accessor references)
667    
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.")  
724    
725    
726  ;;;; Documentation  ;;;; Documentation
727    
728  (definterface arglist-string (function-name)  (definterface arglist (name)
729     "Return the argument for FUNCTION-NAME as a string.     "Return the lambda list for the symbol NAME. NAME can also be
730  The result should begin and end with parenthesis.")  a lisp function object, on lisps which support this.
731    
732    The result can be a list or the :not-available keyword if the
733    arglist cannot be determined."
734       (declare (ignore name))
735       :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 type-specifier-p (symbol)
785      "Determine if SYMBOL is a type-specifier."
786      (or (documentation symbol 'type)
787          (not (eq (type-specifier-arglist symbol) :not-available))))
788    
789    (definterface function-name (function)
790      "Return the name of the function object FUNCTION.
791    
792    The result is either a symbol, a list, or NIL if no function name is
793    available."
794      (declare (ignore function))
795      nil)
796    
797    (definterface valid-function-name-p (form)
798      "Is FORM syntactically valid to name a function?
799       If true, FBOUNDP should not signal a type-error for FORM."
800      (flet ((length=2 (list)
801               (and (not (null (cdr list))) (null (cddr list)))))
802        (or (symbolp form)
803            (and (consp form) (length=2 form)
804                 (eq (first form) 'setf) (symbolp (second form))))))
805    
806  (definterface macroexpand-all (form)  (definterface macroexpand-all (form)
807     "Recursively expand all macros in FORM.     "Recursively expand all macros in FORM.
808  Return the resulting form.")  Return the resulting form.")
809    
810    (definterface compiler-macroexpand-1 (form &optional env)
811      "Call the compiler-macro for form.
812    If FORM is a function call for which a compiler-macro has been
813    defined, invoke the expander function using *macroexpand-hook* and
814    return the results and T.  Otherwise, return the original form and
815    NIL."
816      (let ((fun (and (consp form)
817                      (valid-function-name-p (car form))
818                      (compiler-macro-function (car form)))))
819        (if fun
820            (let ((result (funcall *macroexpand-hook* fun form env)))
821              (values result (not (eq result form))))
822            (values form nil))))
823    
824    (definterface compiler-macroexpand (form &optional env)
825      "Repetitively call `compiler-macroexpand-1'."
826      (labels ((frob (form expanded)
827                 (multiple-value-bind (new-form newly-expanded)
828                     (compiler-macroexpand-1 form env)
829                   (if newly-expanded
830                       (frob new-form t)
831                       (values new-form expanded)))))
832        (frob form env)))
833    
834    (definterface format-string-expand (control-string)
835      "Expand the format string CONTROL-STRING."
836      (macroexpand `(formatter ,control-string)))
837    
838  (definterface describe-symbol-for-emacs (symbol)  (definterface describe-symbol-for-emacs (symbol)
839     "Return a property list describing SYMBOL.     "Return a property list describing SYMBOL.
840    
841  The property list has an entry for each interesting aspect of the  The property list has an entry for each interesting aspect of the
842  symbol. The recognised keys are:  symbol. The recognised keys are:
843    
844    :VARIABLE :FUNCTION :SETF :TYPE :CLASS :MACRO :COMPILER-MACRO    :VARIABLE :FUNCTION :SETF :SPECIAL-OPERATOR :MACRO :COMPILER-MACRO
845    :ALIEN-TYPE :ALIEN-STRUCT :ALIEN-UNION :ALIEN-ENUM    :TYPE :CLASS :ALIEN-TYPE :ALIEN-STRUCT :ALIEN-UNION :ALIEN-ENUM
846    
847  The value of each property is the corresponding documentation string,  The value of each property is the corresponding documentation string,
848  or :NOT-DOCUMENTED. It is legal to include keys not listed here.  or NIL (or the obsolete :NOT-DOCUMENTED). It is legal to include keys
849    not listed here (but slime-print-apropos in Emacs must know about
850    them).
851    
852  Properties should be included if and only if they are applicable to  Properties should be included if and only if they are applicable to
853  the symbol. For example, only (and all) fbound symbols should include  the symbol. For example, only (and all) fbound symbols should include
# Line 281  Return a documentation string, or NIL if Line 868  Return a documentation string, or NIL if
868    
869  ;;;; Debugging  ;;;; Debugging
870    
871    (definterface install-debugger-globally (function)
872      "Install FUNCTION as the debugger for all threads/processes. This
873    usually involves setting *DEBUGGER-HOOK* and, if the implementation
874    permits, hooking into BREAK as well."
875      (setq *debugger-hook* function))
876    
877  (definterface call-with-debugging-environment (debugger-loop-fn)  (definterface call-with-debugging-environment (debugger-loop-fn)
878     "Call DEBUGGER-LOOP-FN in a suitable debugging environment.     "Call DEBUGGER-LOOP-FN in a suitable debugging environment.
879    
# Line 291  other debugger callbacks that will be ca Line 884  other debugger callbacks that will be ca
884  For example, this is a reasonable place to compute a backtrace, switch  For example, this is a reasonable place to compute a backtrace, switch
885  to safe reader/printer settings, and so on.")  to safe reader/printer settings, and so on.")
886    
887    (definterface call-with-debugger-hook (hook fun)
888      "Call FUN and use HOOK as debugger hook. HOOK can be NIL.
889    
890    HOOK should be called for both BREAK and INVOKE-DEBUGGER."
891      (let ((*debugger-hook* hook))
892        (funcall fun)))
893    
894  (define-condition sldb-condition (condition)  (define-condition sldb-condition (condition)
895    ((original-condition    ((original-condition
896      :initarg :original-condition      :initarg :original-condition
897      :accessor original-condition))      :accessor original-condition))
898      (:report (lambda (condition stream)
899                 (format stream "Condition in debugger code~@[: ~A~]"
900                         (original-condition condition))))
901    (:documentation    (:documentation
902     "Wrapper for conditions that should not be debugged.     "Wrapper for conditions that should not be debugged.
903    
# Line 304  debug the debugger! Instead, such condit Line 907  debug the debugger! Instead, such condit
907  user without (re)entering the debugger by wrapping them as  user without (re)entering the debugger by wrapping them as
908  `sldb-condition's."))  `sldb-condition's."))
909    
910  (definterface debugger-info-for-emacs (start end)  ;;; The following functions in this section are supposed to be called
911     "Return debugger state, with stack frames from START to END.  ;;; within the dynamic contour of CALL-WITH-DEBUGGING-ENVIRONMENT only.
912  The result is a list:  
913    (condition ({restart}*) ({stack-frame}*)  (definterface compute-backtrace (start end)
914  where     "Returns a backtrace of the condition currently being debugged,
915    condition   ::= (description type)  that is an ordered list consisting of frames. ``Ordered list''
916    restart     ::= (name description)  means that an integer I can be mapped back to the i-th frame of this
917    stack-frame ::= (number description)  backtrace.
918    
919  condition---a pair of strings: message, and type.  START and END are zero-based indices constraining the number of frames
920    returned. Frame zero is defined as the frame which invoked the
921  restart---a pair of strings: restart name, and description.  debugger. If END is nil, return the frames from START to the end of
922    the stack.")
923  stack-frame---a number from zero (the top), and a printed  
924  representation of the frame's call.  (definterface print-frame (frame stream)
925      "Print frame to stream.")
926  Below is an example return value. In this case the condition was a  
927  division by zero (multi-line description), and only one frame is being  (definterface frame-restartable-p (frame)
928  fetched (start=0, end=1).    "Is the frame FRAME restartable?.
929    Return T if `restart-frame' can safely be called on the frame."
930   ((\"Arithmetic error DIVISION-BY-ZERO signalled.    (declare (ignore frame))
931  Operation was KERNEL::DIVISION, operands (1 0).\"    nil)
    \"[Condition of type DIVISION-BY-ZERO]\")  
   ((\"ABORT\" \"Return to Slime toplevel.\")  
    (\"ABORT\" \"Return to Top-Level.\"))  
   ((0 \"(KERNEL::INTEGER-/-INTEGER 1 0)\")))")  
   
 (definterface backtrace (start end)  
    "Return a list containing a backtrace of the condition current  
 being debugged.  The results are unspecified if this function is  
 called outside the dynamic contour of a debugger hook defined by  
 DEFINE-DEBUGGER-HOOK.  
   
 START and END are zero-based indices constraining the number of  
 frames returned.  Frame zero is defined as the frame which invoked  
 the debugger.  
   
 The backtrace is returned as a list of tuples of the form  
 \(FRAME-NUMBER FRAME-DESCRIPTION), where FRAME-NUMBER is the  
 index of the frame, defined like START/END, and FRAME-DESCRIPTION  
 is a string containing text to display in the debugger for this  
 frame.  
   
 An example return value:  
   
    ((0 \"(HELLO \"world\")\")  
     (1 \"(RUN-EXCITING-LISP-DEMO)\")  
     (2 \"(SYS::%TOPLEVEL #<SYS::ENVIRONMENT #x394834>)\"))")  
932    
933  (definterface frame-source-location-for-emacs (frame-number)  (definterface frame-source-location (frame-number)
934    "Return the source location for FRAME-NUMBER.")    "Return the source location for the frame associated to FRAME-NUMBER.")
935    
936  (definterface frame-catch-tags (frame-number)  (definterface frame-catch-tags (frame-number)
937    "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
938  stack frame.  The results are undefined unless this is called  frame."
939  within the dynamic contour of a function defined by    (declare (ignore frame-number))
940  DEFINE-DEBUGGER-HOOK.")    '())
941    
942  (definterface frame-locals (frame-number)  (definterface frame-locals (frame-number)
943     "Return a list of XXX local variable designators define me    "Return a list of ((&key NAME ID VALUE) ...) where each element of
944  for a debugger stack frame.  The results are undefined unless  the list represents a local variable in the stack frame associated to
945  this is called within the dynamic contour of a function defined  FRAME-NUMBER.
946  by DEFINE-DEBUGGER-HOOK.")  
947    NAME, a symbol; the name of the local variable.
948    
949    ID, an integer; used as primary key for the local variable, unique
950    relatively to the frame under operation.
951    
952    value, an object; the value of the local variable.")
953    
954    (definterface frame-var-value (frame-number var-id)
955      "Return the value of the local variable associated to VAR-ID
956    relatively to the frame associated to FRAME-NUMBER.")
957    
958    (definterface disassemble-frame (frame-number)
959      "Disassemble the code for the FRAME-NUMBER.
960    The output should be written to standard output.
961    FRAME-NUMBER is a non-negative integer.")
962    
963  (definterface eval-in-frame (form frame-number)  (definterface eval-in-frame (form frame-number)
964     "Evaluate a Lisp form in the lexical context of a stack frame     "Evaluate a Lisp form in the lexical context of a stack frame
965  in the debugger.  The results are undefined unless called in the  in the debugger.
 dynamic contour of a function defined by DEFINE-DEBUGGER-HOOK.  
966    
967  FRAME-NUMBER must be a positive integer with 0 indicating the  FRAME-NUMBER must be a positive integer with 0 indicating the
968  frame which invoked the debugger.  frame which invoked the debugger.
# Line 379  frame which invoked the debugger. Line 970  frame which invoked the debugger.
970  The return value is the result of evaulating FORM in the  The return value is the result of evaulating FORM in the
971  appropriate context.")  appropriate context.")
972    
973    (definterface frame-package (frame-number)
974      "Return the package corresponding to the frame at FRAME-NUMBER.
975    Return nil if the backend can't figure it out."
976      (declare (ignore frame-number))
977      nil)
978    
979    (definterface frame-call (frame-number)
980      "Return a string representing a call to the entry point of a frame.")
981    
982  (definterface return-from-frame (frame-number form)  (definterface return-from-frame (frame-number form)
983    "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)
984  produced by evaluating FORM in the frame context to its caller.  produced by evaluating FORM in the frame context to its caller.
# Line 393  from the frame.") Line 993  from the frame.")
993    "Restart execution of the frame FRAME-NUMBER with the same arguments    "Restart execution of the frame FRAME-NUMBER with the same arguments
994  as it was called originally.")  as it was called originally.")
995    
996    (definterface format-sldb-condition (condition)
997      "Format a condition for display in SLDB."
998      (princ-to-string condition))
999    
1000    (definterface condition-extras (condition)
1001      "Return a list of extra for the debugger.
1002    The allowed elements are of the form:
1003      (:SHOW-FRAME-SOURCE frame-number)
1004      (:REFERENCES &rest refs)
1005    "
1006      (declare (ignore condition))
1007      '())
1008    
1009    (definterface gdb-initial-commands ()
1010      "List of gdb commands supposed to be executed first for the
1011       ATTACH-GDB restart."
1012      nil)
1013    
1014    (definterface activate-stepping (frame-number)
1015      "Prepare the frame FRAME-NUMBER for stepping.")
1016    
1017    (definterface sldb-break-on-return (frame-number)
1018      "Set a breakpoint in the frame FRAME-NUMBER.")
1019    
1020    (definterface sldb-break-at-start (symbol)
1021      "Set a breakpoint on the beginning of the function for SYMBOL.")
1022    
1023    (definterface sldb-stepper-condition-p (condition)
1024      "Return true if SLDB was invoked due to a single-stepping condition,
1025    false otherwise. "
1026      (declare (ignore condition))
1027      nil)
1028    
1029    (definterface sldb-step-into ()
1030      "Step into the current single-stepper form.")
1031    
1032    (definterface sldb-step-next ()
1033      "Step to the next form in the current function.")
1034    
1035    (definterface sldb-step-out ()
1036      "Stop single-stepping temporarily, but resume it once the current function
1037    returns.")
1038    
1039    
1040  ;;;; Queries  ;;;; Definition finding
1041    
1042    (defstruct (:location (:type list) :named
1043                          (:constructor make-location
1044                                        (buffer position &optional hints)))
1045      buffer position
1046      ;; Hints is a property list optionally containing:
1047      ;;   :snippet SOURCE-TEXT
1048      ;;     This is a snippet of the actual source text at the start of
1049      ;;     the definition, which could be used in a text search.
1050      hints)
1051    
1052    (defstruct (:error (:type list) :named (:constructor)) message)
1053    
1054    ;;; Valid content for BUFFER slot
1055    (defstruct (:file       (:type list) :named (:constructor)) name)
1056    (defstruct (:buffer     (:type list) :named (:constructor)) name)
1057    (defstruct (:etags-file (:type list) :named (:constructor)) filename)
1058    
1059    ;;; Valid content for POSITION slot
1060    (defstruct (:position (:type list) :named (:constructor)) pos)
1061    (defstruct (:tag      (:type list) :named (:constructor)) tag1 tag2)
1062    
1063    (defmacro converting-errors-to-error-location (&body body)
1064      "Catches errors during BODY and converts them to an error location."
1065      (let ((gblock (gensym "CONVERTING-ERRORS+")))
1066        `(block ,gblock
1067           (handler-bind ((error
1068                           #'(lambda (e)
1069                                (if *debug-swank-backend*
1070                                    nil     ;decline
1071                                    (return-from ,gblock
1072                                      (make-error-location e))))))
1073             ,@body))))
1074    
1075    (defun make-error-location (datum &rest args)
1076      (cond ((typep datum 'condition)
1077             `(:error ,(format nil "Error: ~A" datum)))
1078            ((symbolp datum)
1079             `(:error ,(format nil "Error: ~A"
1080                               (apply #'make-condition datum args))))
1081            (t
1082             (assert (stringp datum))
1083             `(:error ,(apply #'format nil datum args)))))
1084    
 #+(or)  
 ;;; This is probably a better interface than find-function-locations.  
1085  (definterface find-definitions (name)  (definterface find-definitions (name)
1086     "Return a list of (LABEL . LOCATION) pairs for NAME's definitions.     "Return a list ((DSPEC LOCATION) ...) for NAME's definitions.
1087    
1088  NAME is string denoting a symbol or \"definition specifier\".  NAME is a \"definition specifier\".
1089    
1090  LABEL is a string describing the definition, e.g., \"foo\" or  DSPEC is a \"definition specifier\" describing the
1091  \"(method foo (string number))\" or \"(variable bar)\".  definition, e.g., FOO or (METHOD FOO (STRING NUMBER)) or
1092    \(DEFVAR FOO).
1093    
1094    LOCATION is the source location for the definition.")
1095    
1096    (definterface find-source-location (object)
1097      "Returns the source location of OBJECT, or NIL.
1098    
1099    That is the source location of the underlying datastructure of
1100    OBJECT. E.g. on a STANDARD-OBJECT, the source location of the
1101    respective DEFCLASS definition is returned, on a STRUCTURE-CLASS the
1102    respective DEFSTRUCT definition, and so on."
1103      ;; This returns one source location and not a list of locations. It's
1104      ;; supposed to return the location of the DEFGENERIC definition on
1105      ;; #'SOME-GENERIC-FUNCTION.
1106      (declare (ignore object))
1107      (make-error-location "FIND-DEFINITIONS is not yet implemented on ~
1108                            this implementation."))
1109    
1110    (definterface buffer-first-change (filename)
1111      "Called for effect the first time FILENAME's buffer is modified.
1112    CMUCL/SBCL use this to cache the unmodified file and use the
1113    unmodified text to improve the precision of source locations."
1114      (declare (ignore filename))
1115      nil)
1116    
 LOCATION is a source location of the form:  
1117    
1118  <location> ::= (:location <buffer> <position>)  
1119               | (:error <message>)  ;;;; XREF
1120    
1121  <buffer>   ::= (:file <filename>)  (definterface who-calls (function-name)
1122               | (:buffer <buffername>)    "Return the call sites of FUNCTION-NAME (a symbol).
1123               | (:source-form <string>)  The results is a list ((DSPEC LOCATION) ...)."
1124      (declare (ignore function-name))
1125      :not-implemented)
1126    
1127    (definterface calls-who (function-name)
1128      "Return the call sites of FUNCTION-NAME (a symbol).
1129    The results is a list ((DSPEC LOCATION) ...)."
1130      (declare (ignore function-name))
1131      :not-implemented)
1132    
1133  <position> ::= (:position <fixnum> [<align>]) ; 1 based  (definterface who-references (variable-name)
1134               | (:function-name <string>)    "Return the locations where VARIABLE-NAME (a symbol) is referenced.
1135  ")  See WHO-CALLS for a description of the return value."
1136      (declare (ignore variable-name))
1137      :not-implemented)
1138    
1139  (definterface find-function-locations (name)  (definterface who-binds (variable-name)
1140     "Return a list (LOCATION LOCATION ...) for NAME's definitions.    "Return the locations where VARIABLE-NAME (a symbol) is bound.
1141    See WHO-CALLS for a description of the return value."
1142      (declare (ignore variable-name))
1143      :not-implemented)
1144    
1145  LOCATION is a source location of the form:  (definterface who-sets (variable-name)
1146      "Return the locations where VARIABLE-NAME (a symbol) is set.
1147    See WHO-CALLS for a description of the return value."
1148      (declare (ignore variable-name))
1149      :not-implemented)
1150    
1151  <location> ::= (:location <buffer> <position>)  (definterface who-macroexpands (macro-name)
1152               | (:error <message>)    "Return the locations where MACRO-NAME (a symbol) is expanded.
1153    See WHO-CALLS for a description of the return value."
1154      (declare (ignore macro-name))
1155      :not-implemented)
1156    
1157  <buffer>   ::= (:file <filename>)  (definterface who-specializes (class-name)
1158               | (:buffer <buffername>)    "Return the locations where CLASS-NAME (a symbol) is specialized.
1159               | (:source-form <string>)  See WHO-CALLS for a description of the return value."
1160      (declare (ignore class-name))
1161  <position> ::= (:position <fixnum> [<align>]) ; 1 based    :not-implemented)
1162               | (:line <fixnum> [<fixnum>])  
1163               | (:function-name <string>)  ;;; Simpler variants.
1164               | (:source-path <list> <start-position>)  
1165  ")  (definterface list-callers (function-name)
1166      "List the callers of FUNCTION-NAME.
1167    This function is like WHO-CALLS except that it is expected to use
1168    lower-level means. Whereas WHO-CALLS is usually implemented with
1169    special compiler support, LIST-CALLERS is usually implemented by
1170    groveling for constants in function objects throughout the heap.
1171    
1172    The return value is as for WHO-CALLS.")
1173    
1174    (definterface list-callees (function-name)
1175      "List the functions called by FUNCTION-NAME.
1176    See LIST-CALLERS for a description of the return value.")
1177    
1178    
1179    ;;;; Profiling
1180    
1181    ;;; The following functions define a minimal profiling interface.
1182    
1183    (definterface profile (fname)
1184      "Marks symbol FNAME for profiling.")
1185    
1186    (definterface profiled-functions ()
1187      "Returns a list of profiled functions.")
1188    
1189    (definterface unprofile (fname)
1190      "Marks symbol FNAME as not profiled.")
1191    
1192    (definterface unprofile-all ()
1193      "Marks all currently profiled functions as not profiled."
1194      (dolist (f (profiled-functions))
1195        (unprofile f)))
1196    
1197    (definterface profile-report ()
1198      "Prints profile report.")
1199    
1200    (definterface profile-reset ()
1201      "Resets profile counters.")
1202    
1203    (definterface profile-package (package callers-p methods)
1204      "Wrap profiling code around all functions in PACKAGE.  If a function
1205    is already profiled, then unprofile and reprofile (useful to notice
1206    function redefinition.)
1207    
1208    If CALLERS-P is T names have counts of the most common calling
1209    functions recorded.
1210    
1211    When called with arguments :METHODS T, profile all methods of all
1212    generic functions having names in the given package.  Generic functions
1213    themselves, that is, their dispatch functions, are left alone.")
1214    
1215    
1216    ;;;; Trace
1217    
1218    (definterface toggle-trace (spec)
1219      "Toggle tracing of the function(s) given with SPEC.
1220    SPEC can be:
1221     (setf NAME)                            ; a setf function
1222     (:defmethod NAME QUALIFIER... (SPECIALIZER...)) ; a specific method
1223     (:defgeneric NAME)                     ; a generic function with all methods
1224     (:call CALLER CALLEE)                  ; trace calls from CALLER to CALLEE.
1225     (:labels TOPLEVEL LOCAL)
1226     (:flet TOPLEVEL LOCAL) ")
1227    
1228    
1229  ;;;; Inspector  ;;;; Inspector
1230    
1231  (defgeneric inspected-parts (object)  (defgeneric emacs-inspect (object)
1232    (:documentation    (:documentation
1233     "Return a short description and a list of (LABEL . VALUE) pairs."))     "Explain to Emacs how to inspect OBJECT.
1234    
1235  (defgeneric describe-primitive-type (object)  Returns a list specifying how to render the object for inspection.
1236    (:documentation  
1237     "Return a string describing the primitive type of object."))  Every element of the list must be either a string, which will be
1238    inserted into the buffer as is, or a list of the form:
1239    
1240     (:value object &optional format) - Render an inspectable
1241     object. If format is provided it must be a string and will be
1242     rendered in place of the value, otherwise use princ-to-string.
1243    
1244     (:newline) - Render a \\n
1245    
1246     (:action label lambda &key (refresh t)) - Render LABEL (a text
1247     string) which when clicked will call LAMBDA. If REFRESH is
1248     non-NIL the currently inspected object will be re-inspected
1249     after calling the lambda.
1250    "))
1251    
1252    (defmethod emacs-inspect ((object t))
1253      "Generic method for inspecting any kind of object.
1254    
1255    Since we don't know how to deal with OBJECT we simply dump the
1256    output of CL:DESCRIBE."
1257       `("Type: " (:value ,(type-of object)) (:newline)
1258         "Don't know how to inspect the object, dumping output of CL:DESCRIBE:"
1259         (:newline) (:newline)
1260         ,(with-output-to-string (desc) (describe object desc))))
1261    
1262    (definterface eval-context (object)
1263      "Return a list of bindings corresponding to OBJECT's slots."
1264      (declare (ignore object))
1265      '())
1266    
1267    ;;; Utilities for inspector methods.
1268    ;;;
1269    
1270    (defun label-value-line (label value &key (newline t))
1271      "Create a control list which prints \"LABEL: VALUE\" in the inspector.
1272    If NEWLINE is non-NIL a `(:newline)' is added to the result."
1273      (list* (princ-to-string label) ": " `(:value ,value)
1274             (if newline '((:newline)) nil)))
1275    
1276    (defmacro label-value-line* (&rest label-values)
1277      ` (append ,@(loop for (label value) in label-values
1278                        collect `(label-value-line ,label ,value))))
1279    
1280    (definterface describe-primitive-type (object)
1281      "Return a string describing the primitive type of object."
1282      (declare (ignore object))
1283      "N/A")
1284    
1285    
1286  ;;;; Multiprocessing  ;;;; Multithreading
1287  ;;;  ;;;
1288  ;;; The default implementations are sufficient for non-multiprocessing  ;;; The default implementations are sufficient for non-multiprocessing
1289  ;;; implementations.  ;;; implementations.
1290    
1291  (definterface startup-multiprocessing ()  (definterface initialize-multiprocessing (continuation)
1292     "Initialize multiprocessing, if necessary.     "Initialize multiprocessing, if necessary and then invoke CONTINUATION.
1293    
1294  This function is called directly through the listener, not in an RPC  Depending on the impleimentaion, this function may never return."
1295  from Emacs. This is to support interfaces such as CMUCL's     (funcall continuation))
 MP::STARTUP-IDLE-AND-TOP-LEVEL-LOOPS which does not return like a  
 normal function."  
    nil)  
1296    
1297  (definterface spawn (fn &key name)  (definterface spawn (fn &key name)
1298    "Create a new thread to call FN.")    "Create a new thread to call FN.")
1299    
1300  (definterface thread-id ()  (definterface thread-id (thread)
1301     "Return a value that uniquely identifies the current thread.    "Return an Emacs-parsable object to identify THREAD.
 Thread-IDs allow Emacs to refer to individual threads.  
   
 When called several times by the same thread, all return values are  
 EQUAL. The value has a READable printed representation that preserves  
 equality. The printed representation must be identical in Emacs Lisp  
 and Common Lisp, and short enough to include in the REPL prompt.  
   
 For example, a THREAD-ID could be an integer or a short ASCII string.  
   
 Systems that do not support multiprocessing return NIL."  
    nil)  
   
 (definterface thread-name (thread-id)  
    "Return the name of the thread identified by THREAD-ID.  
1302    
1303  Thread names are be single-line strings and are meaningful to the  Ids should be comparable with equal, i.e.:
1304  user. They do not have to be unique."   (equal (thread-id <t1>) (thread-id <t2>)) <==> (eq <t1> <t2>)"
1305     (declare (ignore thread-id))    thread)
1306    
1307    (definterface find-thread (id)
1308      "Return the thread for ID.
1309    ID should be an id previously obtained with THREAD-ID.
1310    Can return nil if the thread no longer exists."
1311      (declare (ignore id))
1312      (current-thread))
1313    
1314    (definterface thread-name (thread)
1315       "Return the name of THREAD.
1316    Thread names are short strings meaningful to the user. They do not
1317    have to be unique."
1318       (declare (ignore thread))
1319     "The One True Thread")     "The One True Thread")
1320    
1321  (definterface make-lock (&key name)  (definterface thread-status (thread)
1322     "Make a lock for thread synchronization.     "Return a string describing THREAD's state."
1323  Only one thread may hold the lock (via CALL-WITH-LOCK-HELD) at a time."     (declare (ignore thread))
1324     :null-lock)     "")
1325    
1326  (definterface call-with-lock-held (lock function)  (definterface thread-attributes (thread)
1327     "Call FUNCTION with LOCK held, queueing if necessary."    "Return a plist of implementation-dependent attributes for THREAD"
1328     (declare (ignore lock))    (declare (ignore thread))
1329     (funcall function))    '())
1330    
1331  (definterface current-thread ()  (definterface current-thread ()
1332    "Return the currently executing thread."    "Return the currently executing thread."
1333    0)    0)
1334    
1335    (definterface all-threads ()
1336      "Return a fresh list of all threads."
1337      '())
1338    
1339    (definterface thread-alive-p (thread)
1340      "Test if THREAD is termintated."
1341      (member thread (all-threads)))
1342    
1343  (definterface interrupt-thread (thread fn)  (definterface interrupt-thread (thread fn)
1344    "Cause THREAD to execute FN.")    "Cause THREAD to execute FN.")
1345    
1346    (definterface kill-thread (thread)
1347      "Terminate THREAD immediately.
1348    Don't execute unwind-protected sections, don't raise conditions.
1349    (Do not pass go, do not collect $200.)"
1350      (declare (ignore thread))
1351      nil)
1352    
1353  (definterface send (thread object)  (definterface send (thread object)
1354    "Send OBJECT to thread THREAD.")    "Send OBJECT to thread THREAD."
1355      (declare (ignore thread))
1356      object)
1357    
1358    (definterface receive (&optional timeout)
1359      "Return the next message from current thread's mailbox."
1360      (receive-if (constantly t) timeout))
1361    
1362    (definterface receive-if (predicate &optional timeout)
1363      "Return the first message satisfiying PREDICATE.")
1364    
1365    (definterface register-thread (name thread)
1366      "Associate the thread THREAD with the symbol NAME.
1367    The thread can then be retrieved with `find-registered'.
1368    If THREAD is nil delete the association."
1369      (declare (ignore name thread))
1370      nil)
1371    
1372    (definterface find-registered (name)
1373      "Find the thread that was registered for the symbol NAME.
1374    Return nil if the no thread was registred or if the tread is dead."
1375      (declare (ignore name))
1376      nil)
1377    
1378    (definterface set-default-initial-binding (var form)
1379      "Initialize special variable VAR by default with FORM.
1380    
1381    Some implementations initialize certain variables in each newly
1382    created thread.  This function sets the form which is used to produce
1383    the initial value."
1384      (set var (eval form)))
1385    
1386    ;; List of delayed interrupts.
1387    ;; This should only have thread-local bindings, so no init form.
1388    (defvar *pending-slime-interrupts*)
1389    
1390    (defun check-slime-interrupts ()
1391      "Execute pending interrupts if any.
1392    This should be called periodically in operations which
1393    can take a long time to complete.
1394    Return a boolean indicating whether any interrupts was processed."
1395      (when (and (boundp '*pending-slime-interrupts*)
1396                 *pending-slime-interrupts*)
1397        (funcall (pop *pending-slime-interrupts*))
1398        t))
1399    
1400    (defvar *interrupt-queued-handler* nil
1401      "Function to call on queued interrupts.
1402    Interrupts get queued when an interrupt occurs while interrupt
1403    handling is disabled.
1404    
1405    Backends can use this function to abort slow operations.")
1406    
1407    (definterface wait-for-input (streams &optional timeout)
1408      "Wait for input on a list of streams.  Return those that are ready.
1409    STREAMS is a list of streams
1410    TIMEOUT nil, t, or real number. If TIMEOUT is t, return those streams
1411    which are ready (or have reached end-of-file) without waiting.
1412    If TIMEOUT is a number and no streams is ready after TIMEOUT seconds,
1413    return nil.
1414    
1415  (definterface receive ()  Return :interrupt if an interrupt occurs while waiting.")
   "Return the next message from current thread's mailbox.")  
1416    
1417    
1418  ;;;; XREF  ;;;;  Locks
1419    
1420  (definterface who-calls (function-name)  ;; Please use locks only in swank-gray.lisp.  Locks are too low-level
1421    "Return the call sites of FUNCTION-NAME (a string).  ;; for our taste.
 The results are grouped together by filename:  
   <result>    ::= (<file>*)  
   <file>      ::= (<filename> . (<reference>*))  
   <reference> ::= (<label> . <location>)  
   <label>     ::= string  
   <location>  ::= source-location")  
   
 (definterface who-references (variable-name)  
   "Return the locations where VARIABLE-NAME (a string) is referenced.  
 See WHO-CALLS for a description of the return value.")  
   
 (definterface who-binds (variable-name)  
   "Return the locations where VARIABLE-NAME (a string) is bound.  
 See WHO-CALLS for a description of the return value.")  
1422    
1423  (definterface who-sets (variable-name)  (definterface make-lock (&key name)
1424    "Return the locations where VARIABLE-NAME (a string) is set.     "Make a lock for thread synchronization.
1425  See WHO-CALLS for a description of the return value.")  Only one thread may hold the lock (via CALL-WITH-LOCK-HELD) at a time
1426    but that thread may hold it more than once."
1427  (definterface who-macroexpands (macro-name)     (declare (ignore name))
1428    "Return the locations where MACRO-NAME (a string) is expanded.     :null-lock)
 See WHO-CALLS for a description of the return value.")  
   
 (definterface who-specializes (class-name)  
   "Return the locations where CLASS-NAME (a string) is specialized.  
 See WHO-CALLS for a description of the return value.")  
1429    
1430  ;;; Simpler variants.  (definterface call-with-lock-held (lock function)
1431       "Call FUNCTION with LOCK held, queueing if necessary."
1432       (declare (ignore lock)
1433                (type function function))
1434       (funcall function))
1435    
1436  (definterface list-callers (function-name)  
1437    "List the callers of FUNCTION-NAME.  ;;;; Weak datastructures
 This function is like WHO-CALLS except that it is expected to use  
 lower-level means. Whereas WHO-CALLS is usually implemented with  
 special compiler support, LIST-CALLERS is usually implemented by  
 groveling for constants in function objects throughout the heap.  
1438    
1439  The return value is as for WHO-CALLS.")  (definterface make-weak-key-hash-table (&rest args)
1440      "Like MAKE-HASH-TABLE, but weak w.r.t. the keys."
1441      (apply #'make-hash-table args))
1442    
1443    (definterface make-weak-value-hash-table (&rest args)
1444      "Like MAKE-HASH-TABLE, but weak w.r.t. the values."
1445      (apply #'make-hash-table args))
1446    
1447    (definterface hash-table-weakness (hashtable)
1448      "Return nil or one of :key :value :key-or-value :key-and-value"
1449      (declare (ignore hashtable))
1450      nil)
1451    
1452  (definterface list-callees (function-name)  
1453    "List the functions called by FUNCTION-NAME.  ;;;; Character names
 See LIST-CALLERS for a description of the return value.")  
1454    
1455    (definterface character-completion-set (prefix matchp)
1456      "Return a list of names of characters that match PREFIX."
1457      ;; Handle the standard and semi-standard characters.
1458      (loop for name in '("Newline" "Space" "Tab" "Page" "Rubout"
1459                          "Linefeed" "Return" "Backspace")
1460         when (funcall matchp prefix name)
1461         collect name))
1462    
1463    
1464    (defparameter *type-specifier-arglists*
1465      '((and                . (&rest type-specifiers))
1466        (array              . (&optional element-type dimension-spec))
1467        (base-string        . (&optional size))
1468        (bit-vector         . (&optional size))
1469        (complex            . (&optional type-specifier))
1470        (cons               . (&optional car-typespec cdr-typespec))
1471        (double-float       . (&optional lower-limit upper-limit))
1472        (eql                . (object))
1473        (float              . (&optional lower-limit upper-limit))
1474        (function           . (&optional arg-typespec value-typespec))
1475        (integer            . (&optional lower-limit upper-limit))
1476        (long-float         . (&optional lower-limit upper-limit))
1477        (member             . (&rest eql-objects))
1478        (mod                . (n))
1479        (not                . (type-specifier))
1480        (or                 . (&rest type-specifiers))
1481        (rational           . (&optional lower-limit upper-limit))
1482        (real               . (&optional lower-limit upper-limit))
1483        (satisfies          . (predicate-symbol))
1484        (short-float        . (&optional lower-limit upper-limit))
1485        (signed-byte        . (&optional size))
1486        (simple-array       . (&optional element-type dimension-spec))
1487        (simple-base-string . (&optional size))
1488        (simple-bit-vector  . (&optional size))
1489        (simple-string      . (&optional size))
1490        (single-float       . (&optional lower-limit upper-limit))
1491        (simple-vector      . (&optional size))
1492        (string             . (&optional size))
1493        (unsigned-byte      . (&optional size))
1494        (values             . (&rest typespecs))
1495        (vector             . (&optional element-type size))
1496        ))
1497    
1498    ;;; Heap dumps
1499    
1500    (definterface save-image (filename &optional restart-function)
1501      "Save a heap image to the file FILENAME.
1502    RESTART-FUNCTION, if non-nil, should be called when the image is loaded.")
1503    
1504    (definterface background-save-image (filename &key restart-function
1505                                                  completion-function)
1506      "Request saving a heap image to the file FILENAME.
1507    RESTART-FUNCTION, if non-nil, should be called when the image is loaded.
1508    COMPLETION-FUNCTION, if non-nil, should be called after saving the image.")
1509    
1510    (defun deinit-log-output ()
1511      ;; Can't hang on to an fd-stream from a previous session.
1512      (setf (symbol-value (find-symbol "*LOG-OUTPUT*" 'swank))
1513            nil))

Legend:
Removed from v.1.22.2.2  
changed lines
  Added in v.1.224

  ViewVC Help
Powered by ViewVC 1.1.5