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

Contents of /slime/swank-backend.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.222 - (hide annotations)
Mon Jan 7 10:12:09 2013 UTC (15 months, 1 week ago) by heller
Branch: MAIN
Changes since 1.221: +3 -2 lines
* swank-ecl.lisp (describe-symbol-for-emacs): Include bound
symbols even those without documentation.

* slime.el (slime-print-apropos): Do some input validation to
detect bugs on the Lisp side.

* swank-backend.lisp (describe-symbol-for-emacs): Allow NIL where
:NOT-DOCUMENTED was needed.
1 heller 1.219 ;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;*" -*-
2 lgorrie 1.1 ;;;
3 lgorrie 1.13 ;;; slime-backend.lisp --- SLIME backend interface.
4 lgorrie 1.1 ;;;
5 lgorrie 1.13 ;;; Created by James Bielman in 2003. Released into the public domain.
6 lgorrie 1.85 ;;;
7     ;;;; Frontmatter
8 lgorrie 1.1 ;;;
9 lgorrie 1.13 ;;; This file defines the functions that must be implemented
10     ;;; separately for each Lisp. Each is declared as a generic function
11     ;;; for which swank-<implementation>.lisp provides methods.
12 lgorrie 1.1
13 heller 1.36 (defpackage :swank-backend
14 lgorrie 1.1 (:use :common-lisp)
15 trittweiler 1.186 (:export #:*debug-swank-backend*
16     #:sldb-condition
17 trittweiler 1.179 #:compiler-condition
18 heller 1.36 #:original-condition
19     #:message
20 heller 1.180 #:source-context
21 heller 1.36 #:condition
22     #:severity
23 heller 1.124 #:with-compilation-hooks
24 heller 1.36 #:location
25     #:location-p
26     #:location-buffer
27     #:location-position
28     #:position-p
29     #:position-pos
30     #:print-output-to-string
31 mbaringer 1.42 #:quit-lisp
32 crhodes 1.62 #:references
33 mbaringer 1.67 #:unbound-slot-filler
34 trittweiler 1.120 #:declaration-arglist
35     #:type-specifier-arglist
36 trittweiler 1.186 #:with-struct
37 trittweiler 1.195 #:when-let
38 heller 1.140 ;; interrupt macro for the backend
39     #:*pending-slime-interrupts*
40     #:check-slime-interrupts
41 heller 1.172 #:*interrupt-queued-handler*
42 mbaringer 1.67 ;; inspector related symbols
43 heller 1.128 #:emacs-inspect
44 heller 1.70 #:label-value-line
45     #:label-value-line*
46 sboukarev 1.187 #:with-symbol))
47 lgorrie 1.1
48 mbaringer 1.65 (defpackage :swank-mop
49     (:use)
50     (:export
51     ;; classes
52     #:standard-generic-function
53     #:standard-slot-definition
54     #:standard-method
55     #:standard-class
56 mbaringer 1.68 #:eql-specializer
57     #:eql-specializer-object
58 mbaringer 1.65 ;; standard-class readers
59     #:class-default-initargs
60     #:class-direct-default-initargs
61     #:class-direct-slots
62     #:class-direct-subclasses
63     #:class-direct-superclasses
64     #:class-finalized-p
65     #:class-name
66     #:class-precedence-list
67     #:class-prototype
68     #:class-slots
69 mbaringer 1.68 #:specializer-direct-methods
70 mbaringer 1.65 ;; generic function readers
71     #:generic-function-argument-precedence-order
72     #:generic-function-declarations
73     #:generic-function-lambda-list
74     #:generic-function-methods
75     #:generic-function-method-class
76     #:generic-function-method-combination
77     #:generic-function-name
78     ;; method readers
79     #:method-generic-function
80     #:method-function
81     #:method-lambda-list
82     #:method-specializers
83     #:method-qualifiers
84     ;; slot readers
85     #:slot-definition-allocation
86     #:slot-definition-documentation
87     #:slot-definition-initargs
88     #:slot-definition-initform
89     #:slot-definition-initfunction
90     #:slot-definition-name
91     #:slot-definition-type
92     #:slot-definition-readers
93 lgorrie 1.79 #:slot-definition-writers
94 heller 1.95 #:slot-boundp-using-class
95     #:slot-value-using-class
96 alendvai 1.111 #:slot-makunbound-using-class
97 lgorrie 1.79 ;; generic function protocol
98 lgorrie 1.82 #:compute-applicable-methods-using-classes
99     #:finalize-inheritance))
100 mbaringer 1.65
101 heller 1.36 (in-package :swank-backend)
102 lgorrie 1.1
103    
104 lgorrie 1.21 ;;;; Metacode
105    
106 trittweiler 1.186 (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 lgorrie 1.21 (defparameter *interface-functions* '()
112     "The names of all interface functions.")
113    
114     (defparameter *unimplemented-interfaces* '()
115     "List of interface functions that are not implemented.
116     DEFINTERFACE adds to this list and DEFIMPLEMENTATION removes.")
117    
118 heller 1.52 (defmacro definterface (name args documentation &rest default-body)
119 lgorrie 1.21 "Define an interface function for the backend to implement.
120 trittweiler 1.125 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     that is indicated by 'IMPLEMENTATION; failing that, it looks for a
123     function indicated by 'DEFAULT. If neither is present, an error is
124     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 lgorrie 1.21
130     Backends implement these functions using DEFIMPLEMENTATION."
131 lgorrie 1.43 (check-type documentation string "a documentation string")
132 heller 1.101 (assert (every #'symbolp args) ()
133     "Complex lambda-list not supported: ~S ~S" name args)
134     (labels ((gen-default-impl ()
135     `(setf (get ',name 'default) (lambda ,args ,@default-body)))
136     (args-as-list (args)
137     (destructuring-bind (req opt key rest) (parse-lambda-list args)
138     `(,@req ,@opt
139     ,@(loop for k in key append `(,(kw k) ,k))
140     ,@(or rest '(())))))
141     (parse-lambda-list (args)
142     (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 mkoeppe 1.178 (t (error "~S not implemented" ',name)))))
159 heller 1.101 (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 lgorrie 1.21
167     (defmacro defimplementation (name args &body body)
168 heller 1.101 (assert (every #'symbolp args) ()
169     "Complex lambda-list not supported: ~S ~S" name args)
170 heller 1.99 `(progn
171 trittweiler 1.193 (setf (get ',name 'implementation)
172     ;; For implicit BLOCK. FLET because of interplay w/ decls.
173     (flet ((,name ,args ,@body)) #',name))
174 heller 1.99 (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 lgorrie 1.21
180     (defun warn-unimplemented-interfaces ()
181     "Warn the user about unimplemented backend features.
182     The portable code calls this function at startup."
183 trittweiler 1.174 (let ((*print-pretty* t))
184     (warn "These Swank interfaces are unimplemented:~% ~:<~{~A~^ ~:_~}~:>"
185     (list (sort (copy-list *unimplemented-interfaces*) #'string<)))))
186 lgorrie 1.21
187 heller 1.69 (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 heller 1.76 (assert real-symbol () "Symbol ~A not found in package ~A" s package)
202 heller 1.69 (unintern s :swank-mop)
203     (import real-symbol :swank-mop)
204     (export real-symbol :swank-mop)))))
205    
206 heller 1.88 (defvar *gray-stream-symbols*
207     '(:fundamental-character-output-stream
208     :stream-write-char
209 heller 1.137 :stream-write-string
210 heller 1.88 :stream-fresh-line
211     :stream-force-output
212     :stream-finish-output
213     :fundamental-character-input-stream
214     :stream-read-char
215 heller 1.148 :stream-peek-char
216     :stream-read-line
217 trittweiler 1.150 ;; STREAM-FILE-POSITION is not available on all implementations, or
218     ;; partially under a different name.
219     ; :stream-file-posiion
220 heller 1.88 :stream-listen
221     :stream-unread-char
222     :stream-clear-input
223     :stream-line-column
224 jsnellman 1.90 :stream-read-char-no-hang
225     ;; STREAM-LINE-LENGTH is an extension to gray streams that's apparently
226 dcrosher 1.91 ;; supported by CMUCL, OpenMCL, SBCL and SCL.
227     #+(or cmu openmcl sbcl scl)
228 jsnellman 1.90 :stream-line-length))
229 heller 1.88
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 lgorrie 1.21
238 heller 1.46 ;;;; Utilities
239    
240     (defmacro with-struct ((conc-name &rest names) obj &body body)
241     "Like with-slots but works only for structs."
242 heller 1.219 (check-type conc-name symbol)
243 sboukarev 1.218 (flet ((reader (slot)
244 heller 1.219 (intern (concatenate 'string
245     (symbol-name conc-name)
246     (symbol-name slot))
247     (symbol-package conc-name))))
248 heller 1.46 (let ((tmp (gensym "OO-")))
249 sboukarev 1.218 ` (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 lgorrie 1.54
258 trittweiler 1.195 (defmacro when-let ((var value) &body body)
259     `(let ((,var ,value))
260     (when ,var ,@body)))
261    
262 trittweiler 1.171 (defun with-symbol (name package)
263     "Generate a form suitable for testing with #+."
264 sboukarev 1.199 (if (and (find-package package)
265     (find-symbol (string name) package))
266 trittweiler 1.171 '(:and)
267     '(:or)))
268    
269 lgorrie 1.54
270 heller 1.207 ;;;; UFT8
271    
272 heller 1.211 (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 heller 1.207 (definterface string-to-utf8 (string)
427 heller 1.211 "Convert the string STRING to a (simple-array (unsigned-byte 8))"
428     (default-string-to-utf8 string))
429 heller 1.207
430     (definterface utf8-to-string (octets)
431 heller 1.211 "Convert the (simple-array (unsigned-byte 8)) OCTETS to a string."
432     (default-utf8-to-string octets))
433 heller 1.207
434 heller 1.215 ;;; 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 heller 1.207
445 lgorrie 1.13 ;;;; TCP server
446    
447 heller 1.213 (definterface create-socket (host port &key backlog)
448     "Create a listening TCP socket on interface HOST and port PORT.
449     BACKLOG queue length for incoming connections.")
450 lgorrie 1.13
451 lgorrie 1.21 (definterface local-port (socket)
452     "Return the local port number of SOCKET.")
453 lgorrie 1.1
454 lgorrie 1.21 (definterface close-socket (socket)
455     "Close the socket SOCKET.")
456 lgorrie 1.1
457 heller 1.93 (definterface accept-connection (socket &key external-format
458 dcrosher 1.97 buffering timeout)
459 heller 1.93 "Accept a client connection on the listening socket SOCKET.
460 heller 1.208 Return a stream for the new connection.
461     If EXTERNAL-FORMAT is nil return a binary stream
462     otherwise create a character stream.
463 heller 1.209 BUFFERING can be one of:
464     nil ... no buffering
465     t ... enable buffering
466     :line ... enable buffering with automatic flushing on eol.")
467 heller 1.16
468 heller 1.31 (definterface add-sigio-handler (socket fn)
469 lgorrie 1.21 "Call FN whenever SOCKET is readable.")
470 heller 1.16
471 heller 1.31 (definterface remove-sigio-handlers (socket)
472     "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 heller 1.18
480 heller 1.36 (definterface preferred-communication-style ()
481     "Return one of the symbols :spawn, :sigio, :fd-handler, or NIL."
482     nil)
483    
484 dcrosher 1.97 (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 lgorrie 1.13 ;;; Base condition for networking errors.
491 msimmons 1.50 (define-condition network-error (simple-error) ())
492 lgorrie 1.13
493 heller 1.74 (definterface emacs-connected ()
494 lgorrie 1.13 "Hook called when the first connection from Emacs is established.
495     Called from the INIT-FN of the socket server that accepts the
496     connection.
497 lgorrie 1.1
498 lgorrie 1.13 This is intended for setting up extra context, e.g. to discover
499 heller 1.74 that the calling thread is the one that interacts with Emacs."
500 mbaringer 1.73 nil)
501 lgorrie 1.1
502    
503 heller 1.20 ;;;; Unix signals
504    
505     (defconstant +sigint+ 2)
506    
507 heller 1.32 (definterface getpid ()
508     "Return the (Unix) process ID of this superior Lisp.")
509    
510 heller 1.144 (definterface install-sigint-handler (function)
511     "Call FUNCTION on SIGINT (instead of invoking the debugger).
512     Return old signal handler."
513 heller 1.162 (declare (ignore function))
514 heller 1.144 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 heller 1.155 (definterface quit-lisp ()
523     "Exit the current lisp image.")
524    
525 heller 1.32 (definterface lisp-implementation-type-name ()
526     "Return a short name for the Lisp implementation."
527     (lisp-implementation-type))
528 heller 1.20
529 trittweiler 1.198 (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 heller 1.188 (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 trittweiler 1.198 "Return a list of strings as passed by the OS."
556     nil)
557 heller 1.188
558 heller 1.155
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 heller 1.51 (definterface default-directory ()
572     "Return the default directory."
573     (directory-namestring (truename *default-pathname-defaults*)))
574    
575 heller 1.39 (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 heller 1.51 (default-directory))
580    
581 heller 1.155
582 heller 1.51 (definterface call-with-syntax-hooks (fn)
583     "Call FN with hooks to handle special syntax."
584     (funcall fn))
585 heller 1.39
586 heller 1.52 (definterface default-readtable-alist ()
587 heller 1.77 "Return a suitable initial value for SWANK:*READTABLE-ALIST*."
588 heller 1.52 '())
589    
590 heller 1.20
591 lgorrie 1.1 ;;;; Compilation
592 dbarlow 1.8
593 lgorrie 1.21 (definterface call-with-compilation-hooks (func)
594 lgorrie 1.47 "Call FUNC with hooks to record compiler conditions.")
595 lgorrie 1.13
596 vsedach 1.14 (defmacro with-compilation-hooks ((&rest ignore) &body body)
597 lgorrie 1.47 "Execute BODY as in CALL-WITH-COMPILATION-HOOKS."
598 vsedach 1.14 (declare (ignore ignore))
599 dbarlow 1.8 `(call-with-compilation-hooks (lambda () (progn ,@body))))
600 lgorrie 1.1
601 heller 1.167 (definterface swank-compile-string (string &key buffer position filename
602 trittweiler 1.165 policy)
603 heller 1.156 "Compile source from STRING.
604     During compilation, compiler conditions must be trapped and
605     resignalled as COMPILER-CONDITIONs.
606 lgorrie 1.1
607     If supplied, BUFFER and POSITION specify the source location in Emacs.
608    
609     Additionally, if POSITION is supplied, it must be added to source
610 pseibel 1.64 positions reported in compiler conditions.
611    
612 heller 1.167 If FILENAME is specified it may be used by certain implementations to
613 pseibel 1.64 rebind *DEFAULT-PATHNAME-DEFAULTS* which may improve the recording of
614 heller 1.131 source information.
615    
616 heller 1.167 If POLICY is supplied, and non-NIL, it may be used by certain
617 sboukarev 1.196 implementations to compile with optimization qualities of its
618 trittweiler 1.135 value.
619    
620 crhodes 1.202 Should return T on successful compilation, NIL otherwise.
621 heller 1.131 ")
622 lgorrie 1.1
623 heller 1.169 (definterface swank-compile-file (input-file output-file load-p
624 sboukarev 1.196 external-format
625     &key policy)
626 heller 1.169 "Compile INPUT-FILE signalling COMPILE-CONDITIONs.
627 heller 1.109 If LOAD-P is true, load the file after compilation.
628     EXTERNAL-FORMAT is a value returned by find-external-format or
629 trittweiler 1.135 :default.
630    
631 sboukarev 1.196 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 heller 1.156 Should return OUTPUT-TRUENAME, WARNINGS-P and FAILURE-p
636     like `compile-file'")
637 lgorrie 1.1
638 heller 1.72 (deftype severity ()
639 trittweiler 1.179 '(member :error :read-error :warning :style-warning :note :redefinition))
640 lgorrie 1.13
641     ;; Base condition type for compiler errors, warnings and notes.
642     (define-condition compiler-condition (condition)
643     ((original-condition
644     ;; The original condition thrown by the compiler if appropriate.
645     ;; May be NIL if a compiler does not report using conditions.
646     :type (or null condition)
647     :initarg :original-condition
648     :accessor original-condition)
649    
650     (severity :type severity
651     :initarg :severity
652     :accessor severity)
653    
654     (message :initarg :message
655     :accessor message)
656    
657 heller 1.180 ;; 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 crhodes 1.62
664     (references :initarg :references
665     :initform nil
666     :accessor references)
667 heller 1.30
668 lgorrie 1.13 (location :initarg :location
669     :accessor location)))
670 heller 1.30
671 heller 1.109 (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 trittweiler 1.146 (definterface guess-external-format (pathname)
680     "Detect the external format for the file with name pathname.
681 heller 1.109 Return nil if the file contains no special markers."
682     ;; Look for a Emacs-style -*- coding: ... -*- or Local Variable: section.
683 trittweiler 1.146 (with-open-file (s pathname :if-does-not-exist nil
684 heller 1.109 :external-format (or (find-external-format "latin-1-unix")
685     :default))
686 heller 1.110 (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 heller 1.109
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 lgorrie 1.17
715 lgorrie 1.13 ;;;; Streams
716    
717 heller 1.147 (definterface make-output-stream (write-string)
718     "Return a new character output stream.
719     The stream calls WRITE-STRING when output is ready.")
720    
721     (definterface make-input-stream (read-string)
722     "Return a new character input stream.
723     The stream calls READ-STRING when input is needed.")
724    
725 lgorrie 1.1
726     ;;;; Documentation
727    
728 heller 1.36 (definterface arglist (name)
729 mbaringer 1.65 "Return the lambda list for the symbol NAME. NAME can also be
730     a lisp function object, on lisps which support this.
731    
732 trittweiler 1.120 The result can be a list or the :not-available keyword if the
733     arglist cannot be determined."
734 mbaringer 1.65 (declare (ignore name))
735     :not-available)
736 heller 1.36
737 trittweiler 1.120 (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 trittweiler 1.191 (dynamic-extent '(&rest variables))
749     (ignore '(&rest variables))
750     (ignorable '(&rest variables))
751     (special '(&rest variables))
752 trittweiler 1.120 (inline '(&rest function-names))
753 trittweiler 1.175 (notinline '(&rest function-names))
754     (declaration '(&rest names))
755 trittweiler 1.120 (optimize '(&any compilation-speed debug safety space speed))
756     (type '(type-specifier &rest args))
757     (ftype '(type-specifier &rest function-names))
758     (otherwise
759 heller 1.217 (flet ((typespec-p (symbol)
760     (member :type (describe-symbol-for-emacs symbol))))
761 trittweiler 1.120 (cond ((and (symbolp decl-identifier) (typespec-p decl-identifier))
762 trittweiler 1.191 '(&rest variables))
763 heller 1.217 ((and (listp decl-identifier)
764     (typespec-p (first decl-identifier)))
765 trittweiler 1.191 '(&rest variables))
766 trittweiler 1.120 (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 mbaringer 1.65 (definterface function-name (function)
785     "Return the name of the function object FUNCTION.
786    
787 heller 1.217 The result is either a symbol, a list, or NIL if no function name is
788     available."
789 mbaringer 1.65 (declare (ignore function))
790     nil)
791 lgorrie 1.1
792 trittweiler 1.201 (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 lgorrie 1.21 (definterface macroexpand-all (form)
802 lgorrie 1.1 "Recursively expand all macros in FORM.
803 lgorrie 1.21 Return the resulting form.")
804 lgorrie 1.1
805 heller 1.94 (definterface compiler-macroexpand-1 (form &optional env)
806     "Call the compiler-macro for form.
807     If FORM is a function call for which a compiler-macro has been
808     defined, invoke the expander function using *macroexpand-hook* and
809     return the results and T. Otherwise, return the original form and
810     NIL."
811 trittweiler 1.201 (let ((fun (and (consp form)
812     (valid-function-name-p (car form))
813     (compiler-macro-function (car form)))))
814 heller 1.94 (if fun
815     (let ((result (funcall *macroexpand-hook* fun form env)))
816     (values result (not (eq result form))))
817     (values form nil))))
818    
819     (definterface compiler-macroexpand (form &optional env)
820     "Repetitively call `compiler-macroexpand-1'."
821     (labels ((frob (form expanded)
822     (multiple-value-bind (new-form newly-expanded)
823     (compiler-macroexpand-1 form env)
824     (if newly-expanded
825     (frob new-form t)
826     (values new-form expanded)))))
827     (frob form env)))
828    
829 trittweiler 1.173 (definterface format-string-expand (control-string)
830     "Expand the format string CONTROL-STRING."
831     (macroexpand `(formatter ,control-string)))
832    
833 lgorrie 1.21 (definterface describe-symbol-for-emacs (symbol)
834 lgorrie 1.1 "Return a property list describing SYMBOL.
835    
836     The property list has an entry for each interesting aspect of the
837     symbol. The recognised keys are:
838    
839 heller 1.86 :VARIABLE :FUNCTION :SETF :SPECIAL-OPERATOR :MACRO :COMPILER-MACRO
840     :TYPE :CLASS :ALIEN-TYPE :ALIEN-STRUCT :ALIEN-UNION :ALIEN-ENUM
841 lgorrie 1.1
842     The value of each property is the corresponding documentation string,
843 heller 1.222 or NIL (or the obsolete :NOT-DOCUMENTED). It is legal to include keys
844     not listed here (but slime-print-apropos in Emacs must know about
845     them).
846 lgorrie 1.1
847     Properties should be included if and only if they are applicable to
848     the symbol. For example, only (and all) fbound symbols should include
849     the :FUNCTION property.
850    
851     Example:
852     \(describe-symbol-for-emacs 'vector)
853     => (:CLASS :NOT-DOCUMENTED
854     :TYPE :NOT-DOCUMENTED
855 lgorrie 1.21 :FUNCTION \"Constructs a simple-vector from the given objects.\")")
856    
857     (definterface describe-definition (name type)
858     "Describe the definition NAME of TYPE.
859     TYPE can be any value returned by DESCRIBE-SYMBOL-FOR-EMACS.
860    
861     Return a documentation string, or NIL if none is available.")
862 lgorrie 1.2
863    
864     ;;;; Debugging
865    
866 heller 1.92 (definterface install-debugger-globally (function)
867     "Install FUNCTION as the debugger for all threads/processes. This
868     usually involves setting *DEBUGGER-HOOK* and, if the implementation
869     permits, hooking into BREAK as well."
870     (setq *debugger-hook* function))
871    
872 lgorrie 1.21 (definterface call-with-debugging-environment (debugger-loop-fn)
873 lgorrie 1.2 "Call DEBUGGER-LOOP-FN in a suitable debugging environment.
874    
875     This function is called recursively at each debug level to invoke the
876     debugger loop. The purpose is to setup any necessary environment for
877     other debugger callbacks that will be called within the debugger loop.
878    
879     For example, this is a reasonable place to compute a backtrace, switch
880 lgorrie 1.21 to safe reader/printer settings, and so on.")
881 lgorrie 1.2
882 heller 1.80 (definterface call-with-debugger-hook (hook fun)
883 trittweiler 1.181 "Call FUN and use HOOK as debugger hook. HOOK can be NIL.
884 heller 1.80
885     HOOK should be called for both BREAK and INVOKE-DEBUGGER."
886     (let ((*debugger-hook* hook))
887     (funcall fun)))
888    
889 lgorrie 1.2 (define-condition sldb-condition (condition)
890     ((original-condition
891     :initarg :original-condition
892 heller 1.5 :accessor original-condition))
893 heller 1.63 (:report (lambda (condition stream)
894     (format stream "Condition in debugger code~@[: ~A~]"
895     (original-condition condition))))
896 lgorrie 1.2 (:documentation
897     "Wrapper for conditions that should not be debugged.
898    
899     When a condition arises from the internals of the debugger, it is not
900     desirable to debug it -- we'd risk entering an endless loop trying to
901     debug the debugger! Instead, such conditions can be reported to the
902     user without (re)entering the debugger by wrapping them as
903     `sldb-condition's."))
904    
905 trittweiler 1.132 ;;; The following functions in this section are supposed to be called
906     ;;; within the dynamic contour of CALL-WITH-DEBUGGING-ENVIRONMENT only.
907    
908 heller 1.36 (definterface compute-backtrace (start end)
909 trittweiler 1.132 "Returns a backtrace of the condition currently being debugged,
910 heller 1.157 that is an ordered list consisting of frames. ``Ordered list''
911 trittweiler 1.151 means that an integer I can be mapped back to the i-th frame of this
912     backtrace.
913 heller 1.36
914     START and END are zero-based indices constraining the number of frames
915 trittweiler 1.151 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
917 heller 1.36 the stack.")
918 lgorrie 1.3
919 heller 1.157 (definterface print-frame (frame stream)
920 heller 1.36 "Print frame to stream.")
921 heller 1.70
922 heller 1.157 (definterface frame-restartable-p (frame)
923     "Is the frame FRAME restartable?.
924     Return T if `restart-frame' can safely be called on the frame."
925 heller 1.161 (declare (ignore frame))
926 heller 1.157 nil)
927    
928 heller 1.176 (definterface frame-source-location (frame-number)
929 trittweiler 1.132 "Return the source location for the frame associated to FRAME-NUMBER.")
930 lgorrie 1.3
931 lgorrie 1.21 (definterface frame-catch-tags (frame-number)
932 trittweiler 1.132 "Return a list of catch tags for being printed in a debugger stack
933 heller 1.159 frame."
934 heller 1.160 (declare (ignore frame-number))
935 heller 1.159 '())
936 lgorrie 1.3
937 lgorrie 1.21 (definterface frame-locals (frame-number)
938 trittweiler 1.132 "Return a list of ((&key NAME ID VALUE) ...) where each element of
939     the list represents a local variable in the stack frame associated to
940     FRAME-NUMBER.
941    
942     NAME, a symbol; the name of the local variable.
943    
944     ID, an integer; used as primary key for the local variable, unique
945     relatively to the frame under operation.
946    
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 heller 1.57
953 heller 1.37 (definterface disassemble-frame (frame-number)
954     "Disassemble the code for the FRAME-NUMBER.
955     The output should be written to standard output.
956 heller 1.84 FRAME-NUMBER is a non-negative integer.")
957 heller 1.37
958 lgorrie 1.21 (definterface eval-in-frame (form frame-number)
959 lgorrie 1.3 "Evaluate a Lisp form in the lexical context of a stack frame
960 trittweiler 1.132 in the debugger.
961 lgorrie 1.3
962     FRAME-NUMBER must be a positive integer with 0 indicating the
963     frame which invoked the debugger.
964    
965     The return value is the result of evaulating FORM in the
966 lgorrie 1.21 appropriate context.")
967 heller 1.22
968 heller 1.212 (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 sboukarev 1.189 (definterface frame-call (frame-number)
975     "Return a string representing a call to the entry point of a frame.")
976    
977 heller 1.22 (definterface return-from-frame (frame-number form)
978     "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.
980    
981     Execute any clean-up code from unwind-protect forms above the frame
982     during unwinding.
983    
984     Return a string describing the error if it's not possible to return
985     from the frame.")
986    
987     (definterface restart-frame (frame-number)
988     "Restart execution of the frame FRAME-NUMBER with the same arguments
989     as it was called originally.")
990 lgorrie 1.3
991 lgorrie 1.49 (definterface format-sldb-condition (condition)
992     "Format a condition for display in SLDB."
993     (princ-to-string condition))
994    
995 heller 1.69 (definterface condition-extras (condition)
996     "Return a list of extra for the debugger.
997     The allowed elements are of the form:
998 heller 1.126 (:SHOW-FRAME-SOURCE frame-number)
999     (:REFERENCES &rest refs)
1000     "
1001 mbaringer 1.73 (declare (ignore condition))
1002 heller 1.69 '())
1003    
1004 trittweiler 1.197 (definterface gdb-initial-commands ()
1005     "List of gdb commands supposed to be executed first for the
1006     ATTACH-GDB restart."
1007     nil)
1008    
1009 heller 1.71 (definterface activate-stepping (frame-number)
1010     "Prepare the frame FRAME-NUMBER for stepping.")
1011 heller 1.69
1012     (definterface sldb-break-on-return (frame-number)
1013     "Set a breakpoint in the frame FRAME-NUMBER.")
1014    
1015     (definterface sldb-break-at-start (symbol)
1016     "Set a breakpoint on the beginning of the function for SYMBOL.")
1017 heller 1.52
1018 jsnellman 1.103 (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 lgorrie 1.49
1034 lgorrie 1.3
1035 heller 1.36 ;;;; Definition finding
1036    
1037     (defstruct (:location (:type list) :named
1038 lgorrie 1.45 (:constructor make-location
1039     (buffer position &optional hints)))
1040     buffer position
1041     ;; Hints is a property list optionally containing:
1042     ;; :snippet SOURCE-TEXT
1043     ;; This is a snippet of the actual source text at the start of
1044     ;; the definition, which could be used in a text search.
1045     hints)
1046 heller 1.36
1047     (defstruct (:error (:type list) :named (:constructor)) message)
1048 trittweiler 1.193
1049     ;;; 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 heller 1.36 (defstruct (:position (:type list) :named (:constructor)) pos)
1056 trittweiler 1.193 (defstruct (:tag (:type list) :named (:constructor)) tag1 tag2)
1057 heller 1.36
1058 trittweiler 1.194 (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 trittweiler 1.186 (defun make-error-location (datum &rest args)
1071     (cond ((typep datum 'condition)
1072     `(:error ,(format nil "Error: ~A" datum)))
1073     ((symbolp datum)
1074 heller 1.217 `(:error ,(format nil "Error: ~A"
1075     (apply #'make-condition datum args))))
1076 trittweiler 1.186 (t
1077     (assert (stringp datum))
1078     `(:error ,(apply #'format nil datum args)))))
1079    
1080 heller 1.36 (definterface find-definitions (name)
1081     "Return a list ((DSPEC LOCATION) ...) for NAME's definitions.
1082    
1083 heller 1.38 NAME is a \"definition specifier\".
1084 heller 1.36
1085 heller 1.38 DSPEC is a \"definition specifier\" describing the
1086 heller 1.36 definition, e.g., FOO or (METHOD FOO (STRING NUMBER)) or
1087 heller 1.38 \(DEFVAR FOO).
1088    
1089     LOCATION is the source location for the definition.")
1090 heller 1.36
1091 trittweiler 1.130 (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 trittweiler 1.135 ;; This returns one source location and not a list of locations. It's
1099 trittweiler 1.130 ;; supposed to return the location of the DEFGENERIC definition on
1100     ;; #'SOME-GENERIC-FUNCTION.
1101 trittweiler 1.186 (declare (ignore object))
1102     (make-error-location "FIND-DEFINITIONS is not yet implemented on ~
1103     this implementation."))
1104 trittweiler 1.130
1105 lgorrie 1.61 (definterface buffer-first-change (filename)
1106 heller 1.215 "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 mbaringer 1.73 (declare (ignore filename))
1110 lgorrie 1.61 nil)
1111    
1112 trittweiler 1.130
1113 heller 1.36
1114     ;;;; XREF
1115    
1116     (definterface who-calls (function-name)
1117     "Return the call sites of FUNCTION-NAME (a symbol).
1118 trittweiler 1.181 The results is a list ((DSPEC LOCATION) ...)."
1119     (declare (ignore function-name))
1120     :not-implemented)
1121 heller 1.36
1122 heller 1.81 (definterface calls-who (function-name)
1123     "Return the call sites of FUNCTION-NAME (a symbol).
1124 trittweiler 1.181 The results is a list ((DSPEC LOCATION) ...)."
1125     (declare (ignore function-name))
1126     :not-implemented)
1127 heller 1.81
1128 heller 1.36 (definterface who-references (variable-name)
1129     "Return the locations where VARIABLE-NAME (a symbol) is referenced.
1130 trittweiler 1.181 See WHO-CALLS for a description of the return value."
1131     (declare (ignore variable-name))
1132     :not-implemented)
1133 heller 1.36
1134     (definterface who-binds (variable-name)
1135     "Return the locations where VARIABLE-NAME (a symbol) is bound.
1136 trittweiler 1.181 See WHO-CALLS for a description of the return value."
1137     (declare (ignore variable-name))
1138     :not-implemented)
1139 heller 1.36
1140     (definterface who-sets (variable-name)
1141     "Return the locations where VARIABLE-NAME (a symbol) is set.
1142 trittweiler 1.181 See WHO-CALLS for a description of the return value."
1143     (declare (ignore variable-name))
1144     :not-implemented)
1145 heller 1.36
1146     (definterface who-macroexpands (macro-name)
1147     "Return the locations where MACRO-NAME (a symbol) is expanded.
1148 trittweiler 1.181 See WHO-CALLS for a description of the return value."
1149     (declare (ignore macro-name))
1150     :not-implemented)
1151 heller 1.36
1152     (definterface who-specializes (class-name)
1153     "Return the locations where CLASS-NAME (a symbol) is specialized.
1154 trittweiler 1.181 See WHO-CALLS for a description of the return value."
1155     (declare (ignore class-name))
1156     :not-implemented)
1157 heller 1.36
1158     ;;; Simpler variants.
1159    
1160     (definterface list-callers (function-name)
1161     "List the callers of FUNCTION-NAME.
1162     This function is like WHO-CALLS except that it is expected to use
1163     lower-level means. Whereas WHO-CALLS is usually implemented with
1164     special compiler support, LIST-CALLERS is usually implemented by
1165     groveling for constants in function objects throughout the heap.
1166    
1167     The return value is as for WHO-CALLS.")
1168    
1169     (definterface list-callees (function-name)
1170     "List the functions called by FUNCTION-NAME.
1171     See LIST-CALLERS for a description of the return value.")
1172    
1173    
1174 heller 1.23 ;;;; Profiling
1175    
1176     ;;; The following functions define a minimal profiling interface.
1177    
1178     (definterface profile (fname)
1179     "Marks symbol FNAME for profiling.")
1180    
1181     (definterface profiled-functions ()
1182     "Returns a list of profiled functions.")
1183    
1184     (definterface unprofile (fname)
1185     "Marks symbol FNAME as not profiled.")
1186    
1187     (definterface unprofile-all ()
1188     "Marks all currently profiled functions as not profiled."
1189     (dolist (f (profiled-functions))
1190     (unprofile f)))
1191    
1192     (definterface profile-report ()
1193     "Prints profile report.")
1194    
1195     (definterface profile-reset ()
1196     "Resets profile counters.")
1197    
1198     (definterface profile-package (package callers-p methods)
1199     "Wrap profiling code around all functions in PACKAGE. If a function
1200     is already profiled, then unprofile and reprofile (useful to notice
1201     function redefinition.)
1202    
1203     If CALLERS-P is T names have counts of the most common calling
1204     functions recorded.
1205    
1206     When called with arguments :METHODS T, profile all methods of all
1207     generic functions having names in the given package. Generic functions
1208     themselves, that is, their dispatch functions, are left alone.")
1209    
1210    
1211 heller 1.215 ;;;; Trace
1212    
1213     (definterface toggle-trace (spec)
1214     "Toggle tracing of the function(s) given with SPEC.
1215     SPEC can be:
1216     (setf NAME) ; a setf function
1217     (:defmethod NAME QUALIFIER... (SPECIALIZER...)) ; a specific method
1218     (: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    
1224 heller 1.19 ;;;; Inspector
1225 lgorrie 1.56
1226 heller 1.128 (defgeneric emacs-inspect (object)
1227 heller 1.100 (:documentation
1228 heller 1.86 "Explain to Emacs how to inspect OBJECT.
1229 mbaringer 1.67
1230 heller 1.129 Returns a list specifying how to render the object for inspection.
1231 mbaringer 1.67
1232 lgorrie 1.83 Every element of the list must be either a string, which will be
1233 mbaringer 1.67 inserted into the buffer as is, or a list of the form:
1234    
1235     (:value object &optional format) - Render an inspectable
1236     object. If format is provided it must be a string and will be
1237     rendered in place of the value, otherwise use princ-to-string.
1238    
1239     (:newline) - Render a \\n
1240    
1241 mbaringer 1.117 (:action label lambda &key (refresh t)) - Render LABEL (a text
1242     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 heller 1.129 "))
1246 mbaringer 1.67
1247 heller 1.128 (defmethod emacs-inspect ((object t))
1248 mbaringer 1.67 "Generic method for inspecting any kind of object.
1249    
1250     Since we don't know how to deal with OBJECT we simply dump the
1251     output of CL:DESCRIBE."
1252 heller 1.86 `("Type: " (:value ,(type-of object)) (:newline)
1253     "Don't know how to inspect the object, dumping output of CL:DESCRIBE:"
1254     (:newline) (:newline)
1255 heller 1.129 ,(with-output-to-string (desc) (describe object desc))))
1256 heller 1.70
1257 heller 1.192 (definterface eval-context (object)
1258     "Return a list of bindings corresponding to OBJECT's slots."
1259     (declare (ignore object))
1260     '())
1261 trittweiler 1.185
1262 heller 1.84 ;;; Utilities for inspector methods.
1263 heller 1.70 ;;;
1264 heller 1.205
1265     (defun label-value-line (label value &key (newline t))
1266     "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 heller 1.70
1271     (defmacro label-value-line* (&rest label-values)
1272 heller 1.205 ` (append ,@(loop for (label value) in label-values
1273     collect `(label-value-line ,label ,value))))
1274 heller 1.19
1275 heller 1.29 (definterface describe-primitive-type (object)
1276 heller 1.35 "Return a string describing the primitive type of object."
1277 heller 1.36 (declare (ignore object))
1278 heller 1.35 "N/A")
1279 heller 1.19
1280    
1281 heller 1.36 ;;;; Multithreading
1282 lgorrie 1.21 ;;;
1283     ;;; The default implementations are sufficient for non-multiprocessing
1284     ;;; implementations.
1285 lgorrie 1.9
1286 mbaringer 1.106 (definterface initialize-multiprocessing (continuation)
1287 heller 1.107 "Initialize multiprocessing, if necessary and then invoke CONTINUATION.
1288    
1289     Depending on the impleimentaion, this function may never return."
1290 mbaringer 1.106 (funcall continuation))
1291 lgorrie 1.9
1292 lgorrie 1.21 (definterface spawn (fn &key name)
1293     "Create a new thread to call FN.")
1294 lgorrie 1.17
1295 heller 1.58 (definterface thread-id (thread)
1296     "Return an Emacs-parsable object to identify THREAD.
1297    
1298     Ids should be comparable with equal, i.e.:
1299 heller 1.139 (equal (thread-id <t1>) (thread-id <t2>)) <==> (eq <t1> <t2>)"
1300     thread)
1301 heller 1.58
1302     (definterface find-thread (id)
1303     "Return the thread for ID.
1304     ID should be an id previously obtained with THREAD-ID.
1305 heller 1.142 Can return nil if the thread no longer exists."
1306 heller 1.162 (declare (ignore id))
1307 heller 1.142 (current-thread))
1308 heller 1.58
1309 heller 1.28 (definterface thread-name (thread)
1310     "Return the name of THREAD.
1311 heller 1.183 Thread names are short strings meaningful to the user. They do not
1312     have to be unique."
1313 heller 1.28 (declare (ignore thread))
1314 lgorrie 1.21 "The One True Thread")
1315 lgorrie 1.9
1316 heller 1.28 (definterface thread-status (thread)
1317     "Return a string describing THREAD's state."
1318     (declare (ignore thread))
1319     "")
1320    
1321 heller 1.177 (definterface thread-attributes (thread)
1322     "Return a plist of implementation-dependent attributes for THREAD"
1323     (declare (ignore thread))
1324     '())
1325    
1326 heller 1.25 (definterface current-thread ()
1327     "Return the currently executing thread."
1328     0)
1329 heller 1.28
1330     (definterface all-threads ()
1331 heller 1.190 "Return a fresh list of all threads."
1332     '())
1333 heller 1.28
1334     (definterface thread-alive-p (thread)
1335 heller 1.35 "Test if THREAD is termintated."
1336     (member thread (all-threads)))
1337 heller 1.25
1338     (definterface interrupt-thread (thread fn)
1339     "Cause THREAD to execute FN.")
1340    
1341 mbaringer 1.34 (definterface kill-thread (thread)
1342 heller 1.182 "Terminate THREAD immediately.
1343     Don't execute unwind-protected sections, don't raise conditions.
1344     (Do not pass go, do not collect $200.)"
1345 mbaringer 1.34 (declare (ignore thread))
1346     nil)
1347    
1348 heller 1.25 (definterface send (thread object)
1349 heller 1.216 "Send OBJECT to thread THREAD."
1350     object)
1351 heller 1.25
1352 heller 1.143 (definterface receive (&optional timeout)
1353 heller 1.142 "Return the next message from current thread's mailbox."
1354 heller 1.143 (receive-if (constantly t) timeout))
1355 mbaringer 1.78
1356 heller 1.143 (definterface receive-if (predicate &optional timeout)
1357 heller 1.136 "Return the first message satisfiying PREDICATE.")
1358    
1359 heller 1.216 (definterface register-thread (name thread)
1360     "Associate the thread THREAD with the symbol NAME.
1361     The thread can then be retrieved with `find-registered'.
1362     If THREAD is nil delete the association."
1363     (declare (ignore name thread))
1364     nil)
1365    
1366     (definterface find-registered (name)
1367     "Find the thread that was registered for the symbol NAME.
1368     Return nil if the no thread was registred or if the tread is dead."
1369     nil)
1370    
1371 heller 1.168 (definterface set-default-initial-binding (var form)
1372     "Initialize special variable VAR by default with FORM.
1373    
1374     Some implementations initialize certain variables in each newly
1375     created thread. This function sets the form which is used to produce
1376     the initial value."
1377     (set var (eval form)))
1378    
1379 heller 1.153 ;; List of delayed interrupts.
1380     ;; This should only have thread-local bindings, so no init form.
1381     (defvar *pending-slime-interrupts*)
1382 heller 1.140
1383 heller 1.154 (defun check-slime-interrupts ()
1384 heller 1.140 "Execute pending interrupts if any.
1385     This should be called periodically in operations which
1386 heller 1.153 can take a long time to complete.
1387 heller 1.154 Return a boolean indicating whether any interrupts was processed."
1388 heller 1.153 (when (and (boundp '*pending-slime-interrupts*)
1389     *pending-slime-interrupts*)
1390 heller 1.154 (funcall (pop *pending-slime-interrupts*))
1391 heller 1.153 t))
1392 heller 1.140
1393 heller 1.172 (defvar *interrupt-queued-handler* nil
1394     "Function to call on queued interrupts.
1395     Interrupts get queued when an interrupt occurs while interrupt
1396     handling is disabled.
1397    
1398     Backends can use this function to abort slow operations.")
1399 heller 1.163
1400 heller 1.152 (definterface wait-for-input (streams &optional timeout)
1401     "Wait for input on a list of streams. Return those that are ready.
1402     STREAMS is a list of streams
1403 heller 1.210 TIMEOUT nil, t, or real number. If TIMEOUT is t, return those streams
1404     which are ready (or have reached end-of-file) without waiting.
1405 heller 1.152 If TIMEOUT is a number and no streams is ready after TIMEOUT seconds,
1406     return nil.
1407    
1408 heller 1.210 Return :interrupt if an interrupt occurs while waiting.")
1409    
1410 heller 1.215
1411     ;;;; Locks
1412    
1413     ;; Please use locks only in swank-gray.lisp. Locks are too low-level
1414     ;; for our taste.
1415    
1416     (definterface make-lock (&key name)
1417     "Make a lock for thread synchronization.
1418     Only one thread may hold the lock (via CALL-WITH-LOCK-HELD) at a time
1419     but that thread may hold it more than once."
1420     (declare (ignore name))
1421     :null-lock)
1422    
1423     (definterface call-with-lock-held (lock function)
1424     "Call FUNCTION with LOCK held, queueing if necessary."
1425     (declare (ignore lock)
1426     (type function function))
1427     (funcall function))
1428    
1429 mkoeppe 1.87
1430     ;;;; Weak datastructures
1431    
1432     (definterface make-weak-key-hash-table (&rest args)
1433     "Like MAKE-HASH-TABLE, but weak w.r.t. the keys."
1434     (apply #'make-hash-table args))
1435    
1436     (definterface make-weak-value-hash-table (&rest args)
1437     "Like MAKE-HASH-TABLE, but weak w.r.t. the values."
1438     (apply #'make-hash-table args))
1439 mkoeppe 1.108
1440 alendvai 1.113 (definterface hash-table-weakness (hashtable)
1441     "Return nil or one of :key :value :key-or-value :key-and-value"
1442     (declare (ignore hashtable))
1443     nil)
1444    
1445 mkoeppe 1.108
1446     ;;;; Character names
1447    
1448     (definterface character-completion-set (prefix matchp)
1449     "Return a list of names of characters that match PREFIX."
1450     ;; Handle the standard and semi-standard characters.
1451     (loop for name in '("Newline" "Space" "Tab" "Page" "Rubout"
1452     "Linefeed" "Return" "Backspace")
1453     when (funcall matchp prefix name)
1454     collect name))
1455    
1456 trittweiler 1.120
1457     (defparameter *type-specifier-arglists*
1458     '((and . (&rest type-specifiers))
1459     (array . (&optional element-type dimension-spec))
1460     (base-string . (&optional size))
1461     (bit-vector . (&optional size))
1462     (complex . (&optional type-specifier))
1463     (cons . (&optional car-typespec cdr-typespec))
1464     (double-float . (&optional lower-limit upper-limit))
1465     (eql . (object))
1466     (float . (&optional lower-limit upper-limit))
1467     (function . (&optional arg-typespec value-typespec))
1468     (integer . (&optional lower-limit upper-limit))
1469     (long-float . (&optional lower-limit upper-limit))
1470     (member . (&rest eql-objects))
1471     (mod . (n))
1472     (not . (type-specifier))
1473     (or . (&rest type-specifiers))
1474     (rational . (&optional lower-limit upper-limit))
1475     (real . (&optional lower-limit upper-limit))
1476     (satisfies . (predicate-symbol))
1477     (short-float . (&optional lower-limit upper-limit))
1478     (signed-byte . (&optional size))
1479     (simple-array . (&optional element-type dimension-spec))
1480     (simple-base-string . (&optional size))
1481     (simple-bit-vector . (&optional size))
1482     (simple-string . (&optional size))
1483     (single-float . (&optional lower-limit upper-limit))
1484     (simple-vector . (&optional size))
1485     (string . (&optional size))
1486     (unsigned-byte . (&optional size))
1487     (values . (&rest typespecs))
1488     (vector . (&optional element-type size))
1489 heller 1.121 ))
1490 heller 1.145
1491     ;;; Heap dumps
1492    
1493     (definterface save-image (filename &optional restart-function)
1494     "Save a heap image to the file FILENAME.
1495     RESTART-FUNCTION, if non-nil, should be called when the image is loaded.")
1496    
1497 heller 1.200 (definterface background-save-image (filename &key restart-function
1498     completion-function)
1499     "Request saving a heap image to the file FILENAME.
1500     RESTART-FUNCTION, if non-nil, should be called when the image is loaded.
1501     COMPLETION-FUNCTION, if non-nil, should be called after saving the image.")
1502 sboukarev 1.221
1503     (defun deinit-log-output ()
1504     ;; Can't hang on to an fd-stream from a previous session.
1505     (setf (symbol-value (find-symbol "*LOG-OUTPUT*" 'swank))
1506     nil))

  ViewVC Help
Powered by ViewVC 1.1.5