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

Contents of /slime/swank-backend.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.224 - (hide annotations)
Sat Feb 2 10:11:16 2013 UTC (14 months, 2 weeks ago) by sboukarev
Branch: MAIN
CVS Tags: HEAD
Changes since 1.223: +5 -0 lines
* swank-backend.lisp (type-specifier-p): New.
Implement it for ACL, ECL, CCL, Clisp, SBCL, LW.

* contrib/swank-util.lisp (symbol-classification-string): Use
type-specifier-p.
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 sboukarev 1.224 (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 mbaringer 1.65 (definterface function-name (function)
790     "Return the name of the function object FUNCTION.
791    
792 heller 1.217 The result is either a symbol, a list, or NIL if no function name is
793     available."
794 mbaringer 1.65 (declare (ignore function))
795     nil)
796 lgorrie 1.1
797 trittweiler 1.201 (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 lgorrie 1.21 (definterface macroexpand-all (form)
807 lgorrie 1.1 "Recursively expand all macros in FORM.
808 lgorrie 1.21 Return the resulting form.")
809 lgorrie 1.1
810 heller 1.94 (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 trittweiler 1.201 (let ((fun (and (consp form)
817     (valid-function-name-p (car form))
818     (compiler-macro-function (car form)))))
819 heller 1.94 (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 trittweiler 1.173 (definterface format-string-expand (control-string)
835     "Expand the format string CONTROL-STRING."
836     (macroexpand `(formatter ,control-string)))
837    
838 lgorrie 1.21 (definterface describe-symbol-for-emacs (symbol)
839 lgorrie 1.1 "Return a property list describing SYMBOL.
840    
841     The property list has an entry for each interesting aspect of the
842     symbol. The recognised keys are:
843    
844 heller 1.86 :VARIABLE :FUNCTION :SETF :SPECIAL-OPERATOR :MACRO :COMPILER-MACRO
845     :TYPE :CLASS :ALIEN-TYPE :ALIEN-STRUCT :ALIEN-UNION :ALIEN-ENUM
846 lgorrie 1.1
847     The value of each property is the corresponding documentation string,
848 heller 1.222 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 lgorrie 1.1
852     Properties should be included if and only if they are applicable to
853     the symbol. For example, only (and all) fbound symbols should include
854     the :FUNCTION property.
855    
856     Example:
857     \(describe-symbol-for-emacs 'vector)
858     => (:CLASS :NOT-DOCUMENTED
859     :TYPE :NOT-DOCUMENTED
860 lgorrie 1.21 :FUNCTION \"Constructs a simple-vector from the given objects.\")")
861    
862     (definterface describe-definition (name type)
863     "Describe the definition NAME of TYPE.
864     TYPE can be any value returned by DESCRIBE-SYMBOL-FOR-EMACS.
865    
866     Return a documentation string, or NIL if none is available.")
867 lgorrie 1.2
868    
869     ;;;; Debugging
870    
871 heller 1.92 (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 lgorrie 1.21 (definterface call-with-debugging-environment (debugger-loop-fn)
878 lgorrie 1.2 "Call DEBUGGER-LOOP-FN in a suitable debugging environment.
879    
880     This function is called recursively at each debug level to invoke the
881     debugger loop. The purpose is to setup any necessary environment for
882     other debugger callbacks that will be called within the debugger loop.
883    
884     For example, this is a reasonable place to compute a backtrace, switch
885 lgorrie 1.21 to safe reader/printer settings, and so on.")
886 lgorrie 1.2
887 heller 1.80 (definterface call-with-debugger-hook (hook fun)
888 trittweiler 1.181 "Call FUN and use HOOK as debugger hook. HOOK can be NIL.
889 heller 1.80
890     HOOK should be called for both BREAK and INVOKE-DEBUGGER."
891     (let ((*debugger-hook* hook))
892     (funcall fun)))
893    
894 lgorrie 1.2 (define-condition sldb-condition (condition)
895     ((original-condition
896     :initarg :original-condition
897 heller 1.5 :accessor original-condition))
898 heller 1.63 (:report (lambda (condition stream)
899     (format stream "Condition in debugger code~@[: ~A~]"
900     (original-condition condition))))
901 lgorrie 1.2 (:documentation
902     "Wrapper for conditions that should not be debugged.
903    
904     When a condition arises from the internals of the debugger, it is not
905     desirable to debug it -- we'd risk entering an endless loop trying to
906     debug the debugger! Instead, such conditions can be reported to the
907     user without (re)entering the debugger by wrapping them as
908     `sldb-condition's."))
909    
910 trittweiler 1.132 ;;; The following functions in this section are supposed to be called
911     ;;; within the dynamic contour of CALL-WITH-DEBUGGING-ENVIRONMENT only.
912    
913 heller 1.36 (definterface compute-backtrace (start end)
914 trittweiler 1.132 "Returns a backtrace of the condition currently being debugged,
915 heller 1.157 that is an ordered list consisting of frames. ``Ordered list''
916 trittweiler 1.151 means that an integer I can be mapped back to the i-th frame of this
917     backtrace.
918 heller 1.36
919     START and END are zero-based indices constraining the number of frames
920 trittweiler 1.151 returned. Frame zero is defined as the frame which invoked the
921     debugger. If END is nil, return the frames from START to the end of
922 heller 1.36 the stack.")
923 lgorrie 1.3
924 heller 1.157 (definterface print-frame (frame stream)
925 heller 1.36 "Print frame to stream.")
926 heller 1.70
927 heller 1.157 (definterface frame-restartable-p (frame)
928     "Is the frame FRAME restartable?.
929     Return T if `restart-frame' can safely be called on the frame."
930 heller 1.161 (declare (ignore frame))
931 heller 1.157 nil)
932    
933 heller 1.176 (definterface frame-source-location (frame-number)
934 trittweiler 1.132 "Return the source location for the frame associated to FRAME-NUMBER.")
935 lgorrie 1.3
936 lgorrie 1.21 (definterface frame-catch-tags (frame-number)
937 trittweiler 1.132 "Return a list of catch tags for being printed in a debugger stack
938 heller 1.159 frame."
939 heller 1.160 (declare (ignore frame-number))
940 heller 1.159 '())
941 lgorrie 1.3
942 lgorrie 1.21 (definterface frame-locals (frame-number)
943 trittweiler 1.132 "Return a list of ((&key NAME ID VALUE) ...) where each element of
944     the list represents a local variable in the stack frame associated to
945     FRAME-NUMBER.
946    
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 heller 1.57
958 heller 1.37 (definterface disassemble-frame (frame-number)
959     "Disassemble the code for the FRAME-NUMBER.
960     The output should be written to standard output.
961 heller 1.84 FRAME-NUMBER is a non-negative integer.")
962 heller 1.37
963 lgorrie 1.21 (definterface eval-in-frame (form frame-number)
964 lgorrie 1.3 "Evaluate a Lisp form in the lexical context of a stack frame
965 trittweiler 1.132 in the debugger.
966 lgorrie 1.3
967     FRAME-NUMBER must be a positive integer with 0 indicating the
968     frame which invoked the debugger.
969    
970     The return value is the result of evaulating FORM in the
971 lgorrie 1.21 appropriate context.")
972 heller 1.22
973 heller 1.212 (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 sboukarev 1.189 (definterface frame-call (frame-number)
980     "Return a string representing a call to the entry point of a frame.")
981    
982 heller 1.22 (definterface return-from-frame (frame-number form)
983     "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.
985    
986     Execute any clean-up code from unwind-protect forms above the frame
987     during unwinding.
988    
989     Return a string describing the error if it's not possible to return
990     from the frame.")
991    
992     (definterface restart-frame (frame-number)
993     "Restart execution of the frame FRAME-NUMBER with the same arguments
994     as it was called originally.")
995 lgorrie 1.3
996 lgorrie 1.49 (definterface format-sldb-condition (condition)
997     "Format a condition for display in SLDB."
998     (princ-to-string condition))
999    
1000 heller 1.69 (definterface condition-extras (condition)
1001     "Return a list of extra for the debugger.
1002     The allowed elements are of the form:
1003 heller 1.126 (:SHOW-FRAME-SOURCE frame-number)
1004     (:REFERENCES &rest refs)
1005     "
1006 mbaringer 1.73 (declare (ignore condition))
1007 heller 1.69 '())
1008    
1009 trittweiler 1.197 (definterface gdb-initial-commands ()
1010     "List of gdb commands supposed to be executed first for the
1011     ATTACH-GDB restart."
1012     nil)
1013    
1014 heller 1.71 (definterface activate-stepping (frame-number)
1015     "Prepare the frame FRAME-NUMBER for stepping.")
1016 heller 1.69
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 heller 1.52
1023 jsnellman 1.103 (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 lgorrie 1.49
1039 lgorrie 1.3
1040 heller 1.36 ;;;; Definition finding
1041    
1042     (defstruct (:location (:type list) :named
1043 lgorrie 1.45 (: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 heller 1.36
1052     (defstruct (:error (:type list) :named (:constructor)) message)
1053 trittweiler 1.193
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 heller 1.36 (defstruct (:position (:type list) :named (:constructor)) pos)
1061 trittweiler 1.193 (defstruct (:tag (:type list) :named (:constructor)) tag1 tag2)
1062 heller 1.36
1063 trittweiler 1.194 (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 trittweiler 1.186 (defun make-error-location (datum &rest args)
1076     (cond ((typep datum 'condition)
1077     `(:error ,(format nil "Error: ~A" datum)))
1078     ((symbolp datum)
1079 heller 1.217 `(:error ,(format nil "Error: ~A"
1080     (apply #'make-condition datum args))))
1081 trittweiler 1.186 (t
1082     (assert (stringp datum))
1083     `(:error ,(apply #'format nil datum args)))))
1084    
1085 heller 1.36 (definterface find-definitions (name)
1086     "Return a list ((DSPEC LOCATION) ...) for NAME's definitions.
1087    
1088 heller 1.38 NAME is a \"definition specifier\".
1089 heller 1.36
1090 heller 1.38 DSPEC is a \"definition specifier\" describing the
1091 heller 1.36 definition, e.g., FOO or (METHOD FOO (STRING NUMBER)) or
1092 heller 1.38 \(DEFVAR FOO).
1093    
1094     LOCATION is the source location for the definition.")
1095 heller 1.36
1096 trittweiler 1.130 (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 trittweiler 1.135 ;; This returns one source location and not a list of locations. It's
1104 trittweiler 1.130 ;; supposed to return the location of the DEFGENERIC definition on
1105     ;; #'SOME-GENERIC-FUNCTION.
1106 trittweiler 1.186 (declare (ignore object))
1107     (make-error-location "FIND-DEFINITIONS is not yet implemented on ~
1108     this implementation."))
1109 trittweiler 1.130
1110 lgorrie 1.61 (definterface buffer-first-change (filename)
1111 heller 1.215 "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 mbaringer 1.73 (declare (ignore filename))
1115 lgorrie 1.61 nil)
1116    
1117 trittweiler 1.130
1118 heller 1.36
1119     ;;;; XREF
1120    
1121     (definterface who-calls (function-name)
1122     "Return the call sites of FUNCTION-NAME (a symbol).
1123 trittweiler 1.181 The results is a list ((DSPEC LOCATION) ...)."
1124     (declare (ignore function-name))
1125     :not-implemented)
1126 heller 1.36
1127 heller 1.81 (definterface calls-who (function-name)
1128     "Return the call sites of FUNCTION-NAME (a symbol).
1129 trittweiler 1.181 The results is a list ((DSPEC LOCATION) ...)."
1130     (declare (ignore function-name))
1131     :not-implemented)
1132 heller 1.81
1133 heller 1.36 (definterface who-references (variable-name)
1134     "Return the locations where VARIABLE-NAME (a symbol) is referenced.
1135 trittweiler 1.181 See WHO-CALLS for a description of the return value."
1136     (declare (ignore variable-name))
1137     :not-implemented)
1138 heller 1.36
1139     (definterface who-binds (variable-name)
1140     "Return the locations where VARIABLE-NAME (a symbol) is bound.
1141 trittweiler 1.181 See WHO-CALLS for a description of the return value."
1142     (declare (ignore variable-name))
1143     :not-implemented)
1144 heller 1.36
1145     (definterface who-sets (variable-name)
1146     "Return the locations where VARIABLE-NAME (a symbol) is set.
1147 trittweiler 1.181 See WHO-CALLS for a description of the return value."
1148     (declare (ignore variable-name))
1149     :not-implemented)
1150 heller 1.36
1151     (definterface who-macroexpands (macro-name)
1152     "Return the locations where MACRO-NAME (a symbol) is expanded.
1153 trittweiler 1.181 See WHO-CALLS for a description of the return value."
1154     (declare (ignore macro-name))
1155     :not-implemented)
1156 heller 1.36
1157     (definterface who-specializes (class-name)
1158     "Return the locations where CLASS-NAME (a symbol) is specialized.
1159 trittweiler 1.181 See WHO-CALLS for a description of the return value."
1160     (declare (ignore class-name))
1161     :not-implemented)
1162 heller 1.36
1163     ;;; Simpler variants.
1164    
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 heller 1.23 ;;;; 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 heller 1.215 ;;;; 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 heller 1.19 ;;;; Inspector
1230 lgorrie 1.56
1231 heller 1.128 (defgeneric emacs-inspect (object)
1232 heller 1.100 (:documentation
1233 heller 1.86 "Explain to Emacs how to inspect OBJECT.
1234 mbaringer 1.67
1235 heller 1.129 Returns a list specifying how to render the object for inspection.
1236 mbaringer 1.67
1237 lgorrie 1.83 Every element of the list must be either a string, which will be
1238 mbaringer 1.67 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 mbaringer 1.117 (: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 heller 1.129 "))
1251 mbaringer 1.67
1252 heller 1.128 (defmethod emacs-inspect ((object t))
1253 mbaringer 1.67 "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 heller 1.86 `("Type: " (:value ,(type-of object)) (:newline)
1258     "Don't know how to inspect the object, dumping output of CL:DESCRIBE:"
1259     (:newline) (:newline)
1260 heller 1.129 ,(with-output-to-string (desc) (describe object desc))))
1261 heller 1.70
1262 heller 1.192 (definterface eval-context (object)
1263     "Return a list of bindings corresponding to OBJECT's slots."
1264     (declare (ignore object))
1265     '())
1266 trittweiler 1.185
1267 heller 1.84 ;;; Utilities for inspector methods.
1268 heller 1.70 ;;;
1269 heller 1.205
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 heller 1.70
1276     (defmacro label-value-line* (&rest label-values)
1277 heller 1.205 ` (append ,@(loop for (label value) in label-values
1278     collect `(label-value-line ,label ,value))))
1279 heller 1.19
1280 heller 1.29 (definterface describe-primitive-type (object)
1281 heller 1.35 "Return a string describing the primitive type of object."
1282 heller 1.36 (declare (ignore object))
1283 heller 1.35 "N/A")
1284 heller 1.19
1285    
1286 heller 1.36 ;;;; Multithreading
1287 lgorrie 1.21 ;;;
1288     ;;; The default implementations are sufficient for non-multiprocessing
1289     ;;; implementations.
1290 lgorrie 1.9
1291 mbaringer 1.106 (definterface initialize-multiprocessing (continuation)
1292 heller 1.107 "Initialize multiprocessing, if necessary and then invoke CONTINUATION.
1293    
1294     Depending on the impleimentaion, this function may never return."
1295 mbaringer 1.106 (funcall continuation))
1296 lgorrie 1.9
1297 lgorrie 1.21 (definterface spawn (fn &key name)
1298     "Create a new thread to call FN.")
1299 lgorrie 1.17
1300 heller 1.58 (definterface thread-id (thread)
1301     "Return an Emacs-parsable object to identify THREAD.
1302    
1303     Ids should be comparable with equal, i.e.:
1304 heller 1.139 (equal (thread-id <t1>) (thread-id <t2>)) <==> (eq <t1> <t2>)"
1305     thread)
1306 heller 1.58
1307     (definterface find-thread (id)
1308     "Return the thread for ID.
1309     ID should be an id previously obtained with THREAD-ID.
1310 heller 1.142 Can return nil if the thread no longer exists."
1311 heller 1.162 (declare (ignore id))
1312 heller 1.142 (current-thread))
1313 heller 1.58
1314 heller 1.28 (definterface thread-name (thread)
1315     "Return the name of THREAD.
1316 heller 1.183 Thread names are short strings meaningful to the user. They do not
1317     have to be unique."
1318 heller 1.28 (declare (ignore thread))
1319 lgorrie 1.21 "The One True Thread")
1320 lgorrie 1.9
1321 heller 1.28 (definterface thread-status (thread)
1322     "Return a string describing THREAD's state."
1323     (declare (ignore thread))
1324     "")
1325    
1326 heller 1.177 (definterface thread-attributes (thread)
1327     "Return a plist of implementation-dependent attributes for THREAD"
1328     (declare (ignore thread))
1329     '())
1330    
1331 heller 1.25 (definterface current-thread ()
1332     "Return the currently executing thread."
1333     0)
1334 heller 1.28
1335     (definterface all-threads ()
1336 heller 1.190 "Return a fresh list of all threads."
1337     '())
1338 heller 1.28
1339     (definterface thread-alive-p (thread)
1340 heller 1.35 "Test if THREAD is termintated."
1341     (member thread (all-threads)))
1342 heller 1.25
1343     (definterface interrupt-thread (thread fn)
1344     "Cause THREAD to execute FN.")
1345    
1346 mbaringer 1.34 (definterface kill-thread (thread)
1347 heller 1.182 "Terminate THREAD immediately.
1348     Don't execute unwind-protected sections, don't raise conditions.
1349     (Do not pass go, do not collect $200.)"
1350 mbaringer 1.34 (declare (ignore thread))
1351     nil)
1352    
1353 heller 1.25 (definterface send (thread object)
1354 heller 1.216 "Send OBJECT to thread THREAD."
1355 sboukarev 1.223 (declare (ignore thread))
1356 heller 1.216 object)
1357 heller 1.25
1358 heller 1.143 (definterface receive (&optional timeout)
1359 heller 1.142 "Return the next message from current thread's mailbox."
1360 heller 1.143 (receive-if (constantly t) timeout))
1361 mbaringer 1.78
1362 heller 1.143 (definterface receive-if (predicate &optional timeout)
1363 heller 1.136 "Return the first message satisfiying PREDICATE.")
1364    
1365 heller 1.216 (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 sboukarev 1.223 (declare (ignore name))
1376 heller 1.216 nil)
1377    
1378 heller 1.168 (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 heller 1.153 ;; List of delayed interrupts.
1387     ;; This should only have thread-local bindings, so no init form.
1388     (defvar *pending-slime-interrupts*)
1389 heller 1.140
1390 heller 1.154 (defun check-slime-interrupts ()
1391 heller 1.140 "Execute pending interrupts if any.
1392     This should be called periodically in operations which
1393 heller 1.153 can take a long time to complete.
1394 heller 1.154 Return a boolean indicating whether any interrupts was processed."
1395 heller 1.153 (when (and (boundp '*pending-slime-interrupts*)
1396     *pending-slime-interrupts*)
1397 heller 1.154 (funcall (pop *pending-slime-interrupts*))
1398 heller 1.153 t))
1399 heller 1.140
1400 heller 1.172 (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 heller 1.163
1407 heller 1.152 (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 heller 1.210 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 heller 1.152 If TIMEOUT is a number and no streams is ready after TIMEOUT seconds,
1413     return nil.
1414    
1415 heller 1.210 Return :interrupt if an interrupt occurs while waiting.")
1416    
1417 heller 1.215
1418     ;;;; Locks
1419    
1420     ;; Please use locks only in swank-gray.lisp. Locks are too low-level
1421     ;; for our taste.
1422    
1423     (definterface make-lock (&key name)
1424     "Make a lock for thread synchronization.
1425     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     (declare (ignore name))
1428     :null-lock)
1429    
1430     (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 mkoeppe 1.87
1437     ;;;; Weak datastructures
1438    
1439     (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 mkoeppe 1.108
1447 alendvai 1.113 (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 mkoeppe 1.108
1453     ;;;; Character names
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 trittweiler 1.120
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 heller 1.121 ))
1497 heller 1.145
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 heller 1.200 (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 sboukarev 1.221
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))

  ViewVC Help
Powered by ViewVC 1.1.5