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

Contents of /slime/swank-backend.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.211 - (hide annotations)
Sun Nov 6 17:06:35 2011 UTC (2 years, 5 months ago) by heller
Branch: MAIN
Changes since 1.210: +158 -9 lines
Forgot this file in last commit.
1 lgorrie 1.85 ;;; -*- Mode: lisp; 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     ;; see <http://www.franz.com/support/documentation/6.2/doc/pages/variables/compiler/s_cltl1-compile-file-toplevel-compatibility-p_s.htm>
164     (eval-when (:compile-toplevel :load-toplevel :execute)
165     (export ',name :swank-backend))
166     ',name)))
167 lgorrie 1.21
168     (defmacro defimplementation (name args &body body)
169 heller 1.101 (assert (every #'symbolp args) ()
170     "Complex lambda-list not supported: ~S ~S" name args)
171 heller 1.99 `(progn
172 trittweiler 1.193 (setf (get ',name 'implementation)
173     ;; For implicit BLOCK. FLET because of interplay w/ decls.
174     (flet ((,name ,args ,@body)) #',name))
175 heller 1.99 (if (member ',name *interface-functions*)
176     (setq *unimplemented-interfaces*
177     (remove ',name *unimplemented-interfaces*))
178     (warn "DEFIMPLEMENTATION of undefined interface (~S)" ',name))
179     ',name))
180 lgorrie 1.21
181     (defun warn-unimplemented-interfaces ()
182     "Warn the user about unimplemented backend features.
183     The portable code calls this function at startup."
184 trittweiler 1.174 (let ((*print-pretty* t))
185     (warn "These Swank interfaces are unimplemented:~% ~:<~{~A~^ ~:_~}~:>"
186     (list (sort (copy-list *unimplemented-interfaces*) #'string<)))))
187 lgorrie 1.21
188 heller 1.69 (defun import-to-swank-mop (symbol-list)
189     (dolist (sym symbol-list)
190     (let* ((swank-mop-sym (find-symbol (symbol-name sym) :swank-mop)))
191     (when swank-mop-sym
192     (unintern swank-mop-sym :swank-mop))
193     (import sym :swank-mop)
194     (export sym :swank-mop))))
195    
196     (defun import-swank-mop-symbols (package except)
197     "Import the mop symbols from PACKAGE to SWANK-MOP.
198     EXCEPT is a list of symbol names which should be ignored."
199     (do-symbols (s :swank-mop)
200     (unless (member s except :test #'string=)
201     (let ((real-symbol (find-symbol (string s) package)))
202 heller 1.76 (assert real-symbol () "Symbol ~A not found in package ~A" s package)
203 heller 1.69 (unintern s :swank-mop)
204     (import real-symbol :swank-mop)
205     (export real-symbol :swank-mop)))))
206    
207 heller 1.88 (defvar *gray-stream-symbols*
208     '(:fundamental-character-output-stream
209     :stream-write-char
210 heller 1.137 :stream-write-string
211 heller 1.88 :stream-fresh-line
212     :stream-force-output
213     :stream-finish-output
214     :fundamental-character-input-stream
215     :stream-read-char
216 heller 1.148 :stream-peek-char
217     :stream-read-line
218 trittweiler 1.150 ;; STREAM-FILE-POSITION is not available on all implementations, or
219     ;; partially under a different name.
220     ; :stream-file-posiion
221 heller 1.88 :stream-listen
222     :stream-unread-char
223     :stream-clear-input
224     :stream-line-column
225 jsnellman 1.90 :stream-read-char-no-hang
226     ;; STREAM-LINE-LENGTH is an extension to gray streams that's apparently
227 dcrosher 1.91 ;; supported by CMUCL, OpenMCL, SBCL and SCL.
228     #+(or cmu openmcl sbcl scl)
229 jsnellman 1.90 :stream-line-length))
230 heller 1.88
231     (defun import-from (package symbol-names &optional (to-package *package*))
232     "Import the list of SYMBOL-NAMES found in the package PACKAGE."
233     (dolist (name symbol-names)
234     (multiple-value-bind (symbol found) (find-symbol (string name) package)
235     (assert found () "Symbol ~A not found in package ~A" name package)
236     (import symbol to-package))))
237    
238 lgorrie 1.21
239 heller 1.46 ;;;; Utilities
240    
241     (defmacro with-struct ((conc-name &rest names) obj &body body)
242     "Like with-slots but works only for structs."
243     (flet ((reader (slot) (intern (concatenate 'string
244     (symbol-name conc-name)
245     (symbol-name slot))
246     (symbol-package conc-name))))
247     (let ((tmp (gensym "OO-")))
248     ` (let ((,tmp ,obj))
249     (symbol-macrolet
250     ,(loop for name in names collect
251     (typecase name
252     (symbol `(,name (,(reader name) ,tmp)))
253     (cons `(,(first name) (,(reader (second name)) ,tmp)))
254     (t (error "Malformed syntax in WITH-STRUCT: ~A" name))))
255     ,@body)))))
256 lgorrie 1.54
257 trittweiler 1.195 (defmacro when-let ((var value) &body body)
258     `(let ((,var ,value))
259     (when ,var ,@body)))
260    
261 trittweiler 1.171 (defun with-symbol (name package)
262     "Generate a form suitable for testing with #+."
263 sboukarev 1.199 (if (and (find-package package)
264     (find-symbol (string name) package))
265 trittweiler 1.171 '(:and)
266     '(:or)))
267    
268 lgorrie 1.54
269 heller 1.207 ;;;; UFT8
270    
271 heller 1.211 (deftype octet () '(unsigned-byte 8))
272     (deftype octets () '(simple-array octet (*)))
273    
274     ;; Helper function. Decode the next N bytes starting from INDEX.
275     ;; Return the decoded char and the new index.
276     (defun utf8-decode-aux (buffer index limit byte0 n)
277     (declare (type octets buffer) (fixnum index limit byte0 n))
278     (if (< (- limit index) n)
279     (values nil index)
280     (do ((i 0 (1+ i))
281     (code byte0 (let ((byte (aref buffer (+ index i))))
282     (cond ((= (ldb (byte 2 6) byte) #b10)
283     (+ (ash code 6) (ldb (byte 6 0) byte)))
284     (t
285     (error "Invalid encoding"))))))
286     ((= i n)
287     (values (cond ((<= code #xff) (code-char code))
288     ((<= #xd800 code #xdfff)
289     (error "Invalid Unicode code point: #x~x" code))
290     ((and (< code char-code-limit)
291     (code-char code)))
292     (t
293     (error
294     "Can't represent code point: #x~x ~
295     (char-code-limit is #x~x)"
296     code char-code-limit)))
297     (+ index n))))))
298    
299     ;; Decode one character in BUFFER starting at INDEX.
300     ;; Return 2 values: the character and the new index.
301     ;; If there aren't enough bytes between INDEX and LIMIT return nil.
302     (defun utf8-decode (buffer index limit)
303     (declare (type octets buffer) (fixnum index limit))
304     (if (= index limit)
305     (values nil index)
306     (let ((b (aref buffer index)))
307     (if (<= b #x7f)
308     (values (code-char b) (1+ index))
309     (macrolet ((try (marker else)
310     (let* ((l (integer-length marker))
311     (n (- l 2)))
312     `(if (= (ldb (byte ,l ,(- 8 l)) b) ,marker)
313     (utf8-decode-aux buffer (1+ index) limit
314     (ldb (byte ,(- 8 l) 0) b)
315     ,n)
316     ,else))))
317     (try #b110
318     (try #b1110
319     (try #b11110
320     (try #b111110
321     (try #b1111110
322     (error "Invalid encoding")))))))))))
323    
324     ;; Decode characters from BUFFER and write them to STRING.
325     ;; Return 2 values: LASTINDEX and LASTSTART where
326     ;; LASTINDEX is the last index in BUFFER that was not decoded
327     ;; and LASTSTART is the last index in STRING not written.
328     (defun utf8-decode-into (buffer index limit string start end)
329     (declare (string string) (fixnum index limit start end) (type octets buffer))
330     (loop
331     (cond ((= start end)
332     (return (values index start)))
333     (t
334     (multiple-value-bind (c i) (utf8-decode buffer index limit)
335     (cond (c
336     (setf (aref string start) c)
337     (setq index i)
338     (setq start (1+ start)))
339     (t
340     (return (values index start)))))))))
341    
342     (defun default-utf8-to-string (octets)
343     (let* ((limit (length octets))
344     (str (make-string limit)))
345     (multiple-value-bind (i s) (utf8-decode-into octets 0 limit str 0 limit)
346     (if (= i limit)
347     (if (= limit s)
348     str
349     (adjust-array str s))
350     (loop
351     (let ((end (+ (length str) (- limit i))))
352     (setq str (adjust-array str end))
353     (multiple-value-bind (i2 s2)
354     (utf8-decode-into octets i limit str s end)
355     (cond ((= i2 limit)
356     (return (adjust-array str s2)))
357     (t
358     (setq i i2)
359     (setq s s2))))))))))
360    
361     (defmacro utf8-encode-aux (code buffer start end n)
362     `(cond ((< (- ,end ,start) ,n)
363     ,start)
364     (t
365     (setf (aref ,buffer ,start)
366     (dpb (ldb (byte ,(- 7 n) ,(* 6 (1- n))) ,code)
367     (byte ,(- 7 n) 0)
368     ,(dpb 0 (byte 1 (- 7 n)) #xff)))
369     ,@(loop for i from 0 upto (- n 2) collect
370     `(setf (aref ,buffer (+ ,start ,(- n 1 i)))
371     (dpb (ldb (byte 6 ,(* 6 i)) ,code)
372     (byte 6 0)
373     #b10111111)))
374     (+ ,start ,n))))
375    
376     (defun utf8-encode (char buffer start end)
377     (declare (character char) (type octets buffer) (fixnum start end))
378     (let ((code (char-code char)))
379     (cond ((<= code #x7f)
380     (cond ((< start end)
381     (setf (aref buffer start) code)
382     (1+ start))
383     (t start)))
384     ((<= code #x7ff) (utf8-encode-aux code buffer start end 2))
385     ((<= #xd800 code #xdfff)
386     (error "Invalid Unicode code point (surrogate): #x~x" code))
387     ((<= code #xffff) (utf8-encode-aux code buffer start end 3))
388     ((<= code #x1fffff) (utf8-encode-aux code buffer start end 4))
389     ((<= code #x3ffffff) (utf8-encode-aux code buffer start end 5))
390     ((<= code #x7fffffff) (utf8-encode-aux code buffer start end 6))
391     (t (error "Can't encode ~s (~x)" char code)))))
392    
393     (defun utf8-encode-into (string start end buffer index limit)
394     (declare (string string) (type octets buffer) (fixnum start end index limit))
395     (loop
396     (cond ((= start end)
397     (return (values start index)))
398     ((= index limit)
399     (return (values start index)))
400     (t
401     (let ((i2 (utf8-encode (char string start) buffer index limit)))
402     (cond ((= i2 index)
403     (return (values start index)))
404     (t
405     (setq index i2)
406     (incf start))))))))
407    
408     (defun default-string-to-utf8 (string)
409     (let* ((len (length string))
410     (b (make-array len :element-type 'octet)))
411     (multiple-value-bind (s i) (utf8-encode-into string 0 len b 0 len)
412     (if (= s len)
413     b
414     (loop
415     (let ((limit (+ (length b) (- len s))))
416     (setq b (coerce (adjust-array b limit) 'octets))
417     (multiple-value-bind (s2 i2)
418     (utf8-encode-into string s len b i limit)
419     (cond ((= s2 len)
420     (return (coerce (adjust-array b i2) 'octets)))
421     (t
422     (setq i i2)
423     (setq s s2))))))))))
424    
425 heller 1.207 (definterface string-to-utf8 (string)
426 heller 1.211 "Convert the string STRING to a (simple-array (unsigned-byte 8))"
427     (default-string-to-utf8 string))
428 heller 1.207
429     (definterface utf8-to-string (octets)
430 heller 1.211 "Convert the (simple-array (unsigned-byte 8)) OCTETS to a string."
431     (default-utf8-to-string octets))
432 heller 1.207
433    
434 lgorrie 1.13 ;;;; TCP server
435    
436 heller 1.29 (definterface create-socket (host port)
437     "Create a listening TCP socket on interface HOST and port PORT .")
438 lgorrie 1.13
439 lgorrie 1.21 (definterface local-port (socket)
440     "Return the local port number of SOCKET.")
441 lgorrie 1.1
442 lgorrie 1.21 (definterface close-socket (socket)
443     "Close the socket SOCKET.")
444 lgorrie 1.1
445 heller 1.93 (definterface accept-connection (socket &key external-format
446 dcrosher 1.97 buffering timeout)
447 heller 1.93 "Accept a client connection on the listening socket SOCKET.
448 heller 1.208 Return a stream for the new connection.
449     If EXTERNAL-FORMAT is nil return a binary stream
450     otherwise create a character stream.
451 heller 1.209 BUFFERING can be one of:
452     nil ... no buffering
453     t ... enable buffering
454     :line ... enable buffering with automatic flushing on eol.")
455 heller 1.16
456 heller 1.31 (definterface add-sigio-handler (socket fn)
457 lgorrie 1.21 "Call FN whenever SOCKET is readable.")
458 heller 1.16
459 heller 1.31 (definterface remove-sigio-handlers (socket)
460     "Remove all sigio handlers for SOCKET.")
461    
462     (definterface add-fd-handler (socket fn)
463     "Call FN when Lisp is waiting for input and SOCKET is readable.")
464    
465     (definterface remove-fd-handlers (socket)
466     "Remove all fd-handlers for SOCKET.")
467 heller 1.18
468 heller 1.36 (definterface preferred-communication-style ()
469     "Return one of the symbols :spawn, :sigio, :fd-handler, or NIL."
470     nil)
471    
472 dcrosher 1.97 (definterface set-stream-timeout (stream timeout)
473     "Set the 'stream 'timeout. The timeout is either the real number
474     specifying the timeout in seconds or 'nil for no timeout."
475     (declare (ignore stream timeout))
476     nil)
477    
478 lgorrie 1.13 ;;; Base condition for networking errors.
479 msimmons 1.50 (define-condition network-error (simple-error) ())
480 lgorrie 1.13
481 heller 1.74 (definterface emacs-connected ()
482 lgorrie 1.13 "Hook called when the first connection from Emacs is established.
483     Called from the INIT-FN of the socket server that accepts the
484     connection.
485 lgorrie 1.1
486 lgorrie 1.13 This is intended for setting up extra context, e.g. to discover
487 heller 1.74 that the calling thread is the one that interacts with Emacs."
488 mbaringer 1.73 nil)
489 lgorrie 1.1
490    
491 heller 1.20 ;;;; Unix signals
492    
493     (defconstant +sigint+ 2)
494    
495 heller 1.32 (definterface getpid ()
496     "Return the (Unix) process ID of this superior Lisp.")
497    
498 heller 1.144 (definterface install-sigint-handler (function)
499     "Call FUNCTION on SIGINT (instead of invoking the debugger).
500     Return old signal handler."
501 heller 1.162 (declare (ignore function))
502 heller 1.144 nil)
503    
504     (definterface call-with-user-break-handler (handler function)
505     "Install the break handler HANDLER while executing FUNCTION."
506     (let ((old-handler (install-sigint-handler handler)))
507     (unwind-protect (funcall function)
508     (install-sigint-handler old-handler))))
509    
510 heller 1.155 (definterface quit-lisp ()
511     "Exit the current lisp image.")
512    
513 heller 1.32 (definterface lisp-implementation-type-name ()
514     "Return a short name for the Lisp implementation."
515     (lisp-implementation-type))
516 heller 1.20
517 trittweiler 1.198 (definterface lisp-implementation-program ()
518     "Return the argv[0] of the running Lisp process, or NIL."
519     (let ((file (car (command-line-args))))
520     (when (and file (probe-file file))
521     (namestring (truename file)))))
522    
523 heller 1.188 (definterface socket-fd (socket-stream)
524     "Return the file descriptor for SOCKET-STREAM.")
525    
526     (definterface make-fd-stream (fd external-format)
527     "Create a character stream for the file descriptor FD.")
528    
529     (definterface dup (fd)
530     "Duplicate a file descriptor.
531     If the syscall fails, signal a condition.
532     See dup(2).")
533    
534     (definterface exec-image (image-file args)
535     "Replace the current process with a new process image.
536     The new image is created by loading the previously dumped
537     core file IMAGE-FILE.
538     ARGS is a list of strings passed as arguments to
539     the new image.
540     This is thin wrapper around exec(3).")
541    
542     (definterface command-line-args ()
543 trittweiler 1.198 "Return a list of strings as passed by the OS."
544     nil)
545 heller 1.188
546 heller 1.155
547     ;; pathnames are sooo useless
548    
549     (definterface filename-to-pathname (filename)
550     "Return a pathname for FILENAME.
551     A filename in Emacs may for example contain asterisks which should not
552     be translated to wildcards."
553     (parse-namestring filename))
554    
555     (definterface pathname-to-filename (pathname)
556     "Return the filename for PATHNAME."
557     (namestring pathname))
558    
559 heller 1.51 (definterface default-directory ()
560     "Return the default directory."
561     (directory-namestring (truename *default-pathname-defaults*)))
562    
563 heller 1.39 (definterface set-default-directory (directory)
564     "Set the default directory.
565     This is used to resolve filenames without directory component."
566     (setf *default-pathname-defaults* (truename (merge-pathnames directory)))
567 heller 1.51 (default-directory))
568    
569 heller 1.155
570 heller 1.51 (definterface call-with-syntax-hooks (fn)
571     "Call FN with hooks to handle special syntax."
572     (funcall fn))
573 heller 1.39
574 heller 1.52 (definterface default-readtable-alist ()
575 heller 1.77 "Return a suitable initial value for SWANK:*READTABLE-ALIST*."
576 heller 1.52 '())
577    
578 heller 1.20
579 lgorrie 1.1 ;;;; Compilation
580 dbarlow 1.8
581 lgorrie 1.21 (definterface call-with-compilation-hooks (func)
582 lgorrie 1.47 "Call FUNC with hooks to record compiler conditions.")
583 lgorrie 1.13
584 vsedach 1.14 (defmacro with-compilation-hooks ((&rest ignore) &body body)
585 lgorrie 1.47 "Execute BODY as in CALL-WITH-COMPILATION-HOOKS."
586 vsedach 1.14 (declare (ignore ignore))
587 dbarlow 1.8 `(call-with-compilation-hooks (lambda () (progn ,@body))))
588 lgorrie 1.1
589 heller 1.167 (definterface swank-compile-string (string &key buffer position filename
590 trittweiler 1.165 policy)
591 heller 1.156 "Compile source from STRING.
592     During compilation, compiler conditions must be trapped and
593     resignalled as COMPILER-CONDITIONs.
594 lgorrie 1.1
595     If supplied, BUFFER and POSITION specify the source location in Emacs.
596    
597     Additionally, if POSITION is supplied, it must be added to source
598 pseibel 1.64 positions reported in compiler conditions.
599    
600 heller 1.167 If FILENAME is specified it may be used by certain implementations to
601 pseibel 1.64 rebind *DEFAULT-PATHNAME-DEFAULTS* which may improve the recording of
602 heller 1.131 source information.
603    
604 heller 1.167 If POLICY is supplied, and non-NIL, it may be used by certain
605 sboukarev 1.196 implementations to compile with optimization qualities of its
606 trittweiler 1.135 value.
607    
608 crhodes 1.202 Should return T on successful compilation, NIL otherwise.
609 heller 1.131 ")
610 lgorrie 1.1
611 heller 1.169 (definterface swank-compile-file (input-file output-file load-p
612 sboukarev 1.196 external-format
613     &key policy)
614 heller 1.169 "Compile INPUT-FILE signalling COMPILE-CONDITIONs.
615 heller 1.109 If LOAD-P is true, load the file after compilation.
616     EXTERNAL-FORMAT is a value returned by find-external-format or
617 trittweiler 1.135 :default.
618    
619 sboukarev 1.196 If POLICY is supplied, and non-NIL, it may be used by certain
620     implementations to compile with optimization qualities of its
621     value.
622    
623 heller 1.156 Should return OUTPUT-TRUENAME, WARNINGS-P and FAILURE-p
624     like `compile-file'")
625 lgorrie 1.1
626 heller 1.72 (deftype severity ()
627 trittweiler 1.179 '(member :error :read-error :warning :style-warning :note :redefinition))
628 lgorrie 1.13
629     ;; Base condition type for compiler errors, warnings and notes.
630     (define-condition compiler-condition (condition)
631     ((original-condition
632     ;; The original condition thrown by the compiler if appropriate.
633     ;; May be NIL if a compiler does not report using conditions.
634     :type (or null condition)
635     :initarg :original-condition
636     :accessor original-condition)
637    
638     (severity :type severity
639     :initarg :severity
640     :accessor severity)
641    
642     (message :initarg :message
643     :accessor message)
644    
645 heller 1.180 ;; Macro expansion history etc. which may be helpful in some cases
646     ;; but is often very verbose.
647     (source-context :initarg :source-context
648     :type (or null string)
649     :initform nil
650     :accessor source-context)
651 crhodes 1.62
652     (references :initarg :references
653     :initform nil
654     :accessor references)
655 heller 1.30
656 lgorrie 1.13 (location :initarg :location
657     :accessor location)))
658 heller 1.30
659 heller 1.109 (definterface find-external-format (coding-system)
660     "Return a \"external file format designator\" for CODING-SYSTEM.
661     CODING-SYSTEM is Emacs-style coding system name (a string),
662     e.g. \"latin-1-unix\"."
663     (if (equal coding-system "iso-latin-1-unix")
664     :default
665     nil))
666    
667 trittweiler 1.146 (definterface guess-external-format (pathname)
668     "Detect the external format for the file with name pathname.
669 heller 1.109 Return nil if the file contains no special markers."
670     ;; Look for a Emacs-style -*- coding: ... -*- or Local Variable: section.
671 trittweiler 1.146 (with-open-file (s pathname :if-does-not-exist nil
672 heller 1.109 :external-format (or (find-external-format "latin-1-unix")
673     :default))
674 heller 1.110 (if s
675     (or (let* ((line (read-line s nil))
676     (p (search "-*-" line)))
677     (when p
678     (let* ((start (+ p (length "-*-")))
679     (end (search "-*-" line :start2 start)))
680     (when end
681     (%search-coding line start end)))))
682     (let* ((len (file-length s))
683     (buf (make-string (min len 3000))))
684     (file-position s (- len (length buf)))
685     (read-sequence buf s)
686     (let ((start (search "Local Variables:" buf :from-end t))
687     (end (search "End:" buf :from-end t)))
688     (and start end (< start end)
689     (%search-coding buf start end))))))))
690 heller 1.109
691     (defun %search-coding (str start end)
692     (let ((p (search "coding:" str :start2 start :end2 end)))
693     (when p
694     (incf p (length "coding:"))
695     (loop while (and (< p end)
696     (member (aref str p) '(#\space #\tab)))
697     do (incf p))
698     (let ((end (position-if (lambda (c) (find c '(#\space #\tab #\newline)))
699     str :start p)))
700     (find-external-format (subseq str p end))))))
701    
702 lgorrie 1.17
703 lgorrie 1.13 ;;;; Streams
704    
705 heller 1.147 (definterface make-output-stream (write-string)
706     "Return a new character output stream.
707     The stream calls WRITE-STRING when output is ready.")
708    
709     (definterface make-input-stream (read-string)
710     "Return a new character input stream.
711     The stream calls READ-STRING when input is needed.")
712    
713 lgorrie 1.1
714     ;;;; Documentation
715    
716 heller 1.36 (definterface arglist (name)
717 mbaringer 1.65 "Return the lambda list for the symbol NAME. NAME can also be
718     a lisp function object, on lisps which support this.
719    
720 trittweiler 1.120 The result can be a list or the :not-available keyword if the
721     arglist cannot be determined."
722 mbaringer 1.65 (declare (ignore name))
723     :not-available)
724 heller 1.36
725 trittweiler 1.120 (defgeneric declaration-arglist (decl-identifier)
726     (:documentation
727     "Return the argument list of the declaration specifier belonging to the
728     declaration identifier DECL-IDENTIFIER. If the arglist cannot be determined,
729     the keyword :NOT-AVAILABLE is returned.
730    
731     The different SWANK backends can specialize this generic function to
732     include implementation-dependend declaration specifiers, or to provide
733     additional information on the specifiers defined in ANSI Common Lisp.")
734     (:method (decl-identifier)
735     (case decl-identifier
736 trittweiler 1.191 (dynamic-extent '(&rest variables))
737     (ignore '(&rest variables))
738     (ignorable '(&rest variables))
739     (special '(&rest variables))
740 trittweiler 1.120 (inline '(&rest function-names))
741 trittweiler 1.175 (notinline '(&rest function-names))
742     (declaration '(&rest names))
743 trittweiler 1.120 (optimize '(&any compilation-speed debug safety space speed))
744     (type '(type-specifier &rest args))
745     (ftype '(type-specifier &rest function-names))
746     (otherwise
747     (flet ((typespec-p (symbol) (member :type (describe-symbol-for-emacs symbol))))
748     (cond ((and (symbolp decl-identifier) (typespec-p decl-identifier))
749 trittweiler 1.191 '(&rest variables))
750 trittweiler 1.120 ((and (listp decl-identifier) (typespec-p (first decl-identifier)))
751 trittweiler 1.191 '(&rest variables))
752 trittweiler 1.120 (t :not-available)))))))
753    
754     (defgeneric type-specifier-arglist (typespec-operator)
755     (:documentation
756     "Return the argument list of the type specifier belonging to
757     TYPESPEC-OPERATOR.. If the arglist cannot be determined, the keyword
758     :NOT-AVAILABLE is returned.
759    
760     The different SWANK backends can specialize this generic function to
761     include implementation-dependend declaration specifiers, or to provide
762     additional information on the specifiers defined in ANSI Common Lisp.")
763     (:method (typespec-operator)
764     (declare (special *type-specifier-arglists*)) ; defined at end of file.
765     (typecase typespec-operator
766     (symbol (or (cdr (assoc typespec-operator *type-specifier-arglists*))
767     :not-available))
768     (t :not-available))))
769    
770 mbaringer 1.65 (definterface function-name (function)
771     "Return the name of the function object FUNCTION.
772    
773     The result is either a symbol, a list, or NIL if no function name is available."
774     (declare (ignore function))
775     nil)
776 lgorrie 1.1
777 trittweiler 1.201 (definterface valid-function-name-p (form)
778     "Is FORM syntactically valid to name a function?
779     If true, FBOUNDP should not signal a type-error for FORM."
780     (flet ((length=2 (list)
781     (and (not (null (cdr list))) (null (cddr list)))))
782     (or (symbolp form)
783     (and (consp form) (length=2 form)
784     (eq (first form) 'setf) (symbolp (second form))))))
785    
786 lgorrie 1.21 (definterface macroexpand-all (form)
787 lgorrie 1.1 "Recursively expand all macros in FORM.
788 lgorrie 1.21 Return the resulting form.")
789 lgorrie 1.1
790 heller 1.94 (definterface compiler-macroexpand-1 (form &optional env)
791     "Call the compiler-macro for form.
792     If FORM is a function call for which a compiler-macro has been
793     defined, invoke the expander function using *macroexpand-hook* and
794     return the results and T. Otherwise, return the original form and
795     NIL."
796 trittweiler 1.201 (let ((fun (and (consp form)
797     (valid-function-name-p (car form))
798     (compiler-macro-function (car form)))))
799 heller 1.94 (if fun
800     (let ((result (funcall *macroexpand-hook* fun form env)))
801     (values result (not (eq result form))))
802     (values form nil))))
803    
804     (definterface compiler-macroexpand (form &optional env)
805     "Repetitively call `compiler-macroexpand-1'."
806     (labels ((frob (form expanded)
807     (multiple-value-bind (new-form newly-expanded)
808     (compiler-macroexpand-1 form env)
809     (if newly-expanded
810     (frob new-form t)
811     (values new-form expanded)))))
812     (frob form env)))
813    
814 trittweiler 1.173 (definterface format-string-expand (control-string)
815     "Expand the format string CONTROL-STRING."
816     (macroexpand `(formatter ,control-string)))
817    
818 lgorrie 1.21 (definterface describe-symbol-for-emacs (symbol)
819 lgorrie 1.1 "Return a property list describing SYMBOL.
820    
821     The property list has an entry for each interesting aspect of the
822     symbol. The recognised keys are:
823    
824 heller 1.86 :VARIABLE :FUNCTION :SETF :SPECIAL-OPERATOR :MACRO :COMPILER-MACRO
825     :TYPE :CLASS :ALIEN-TYPE :ALIEN-STRUCT :ALIEN-UNION :ALIEN-ENUM
826 lgorrie 1.1
827     The value of each property is the corresponding documentation string,
828 heller 1.86 or :NOT-DOCUMENTED. It is legal to include keys not listed here (but
829     slime-print-apropos in Emacs must know about them).
830 lgorrie 1.1
831     Properties should be included if and only if they are applicable to
832     the symbol. For example, only (and all) fbound symbols should include
833     the :FUNCTION property.
834    
835     Example:
836     \(describe-symbol-for-emacs 'vector)
837     => (:CLASS :NOT-DOCUMENTED
838     :TYPE :NOT-DOCUMENTED
839 lgorrie 1.21 :FUNCTION \"Constructs a simple-vector from the given objects.\")")
840    
841     (definterface describe-definition (name type)
842     "Describe the definition NAME of TYPE.
843     TYPE can be any value returned by DESCRIBE-SYMBOL-FOR-EMACS.
844    
845     Return a documentation string, or NIL if none is available.")
846 lgorrie 1.2
847    
848     ;;;; Debugging
849    
850 heller 1.92 (definterface install-debugger-globally (function)
851     "Install FUNCTION as the debugger for all threads/processes. This
852     usually involves setting *DEBUGGER-HOOK* and, if the implementation
853     permits, hooking into BREAK as well."
854     (setq *debugger-hook* function))
855    
856 lgorrie 1.21 (definterface call-with-debugging-environment (debugger-loop-fn)
857 lgorrie 1.2 "Call DEBUGGER-LOOP-FN in a suitable debugging environment.
858    
859     This function is called recursively at each debug level to invoke the
860     debugger loop. The purpose is to setup any necessary environment for
861     other debugger callbacks that will be called within the debugger loop.
862    
863     For example, this is a reasonable place to compute a backtrace, switch
864 lgorrie 1.21 to safe reader/printer settings, and so on.")
865 lgorrie 1.2
866 heller 1.80 (definterface call-with-debugger-hook (hook fun)
867 trittweiler 1.181 "Call FUN and use HOOK as debugger hook. HOOK can be NIL.
868 heller 1.80
869     HOOK should be called for both BREAK and INVOKE-DEBUGGER."
870     (let ((*debugger-hook* hook))
871     (funcall fun)))
872    
873 lgorrie 1.2 (define-condition sldb-condition (condition)
874     ((original-condition
875     :initarg :original-condition
876 heller 1.5 :accessor original-condition))
877 heller 1.63 (:report (lambda (condition stream)
878     (format stream "Condition in debugger code~@[: ~A~]"
879     (original-condition condition))))
880 lgorrie 1.2 (:documentation
881     "Wrapper for conditions that should not be debugged.
882    
883     When a condition arises from the internals of the debugger, it is not
884     desirable to debug it -- we'd risk entering an endless loop trying to
885     debug the debugger! Instead, such conditions can be reported to the
886     user without (re)entering the debugger by wrapping them as
887     `sldb-condition's."))
888    
889 trittweiler 1.132 ;;; The following functions in this section are supposed to be called
890     ;;; within the dynamic contour of CALL-WITH-DEBUGGING-ENVIRONMENT only.
891    
892 heller 1.36 (definterface compute-backtrace (start end)
893 trittweiler 1.132 "Returns a backtrace of the condition currently being debugged,
894 heller 1.157 that is an ordered list consisting of frames. ``Ordered list''
895 trittweiler 1.151 means that an integer I can be mapped back to the i-th frame of this
896     backtrace.
897 heller 1.36
898     START and END are zero-based indices constraining the number of frames
899 trittweiler 1.151 returned. Frame zero is defined as the frame which invoked the
900     debugger. If END is nil, return the frames from START to the end of
901 heller 1.36 the stack.")
902 lgorrie 1.3
903 heller 1.157 (definterface print-frame (frame stream)
904 heller 1.36 "Print frame to stream.")
905 heller 1.70
906 heller 1.157 (definterface frame-restartable-p (frame)
907     "Is the frame FRAME restartable?.
908     Return T if `restart-frame' can safely be called on the frame."
909 heller 1.161 (declare (ignore frame))
910 heller 1.157 nil)
911    
912 heller 1.176 (definterface frame-source-location (frame-number)
913 trittweiler 1.132 "Return the source location for the frame associated to FRAME-NUMBER.")
914 lgorrie 1.3
915 lgorrie 1.21 (definterface frame-catch-tags (frame-number)
916 trittweiler 1.132 "Return a list of catch tags for being printed in a debugger stack
917 heller 1.159 frame."
918 heller 1.160 (declare (ignore frame-number))
919 heller 1.159 '())
920 lgorrie 1.3
921 lgorrie 1.21 (definterface frame-locals (frame-number)
922 trittweiler 1.132 "Return a list of ((&key NAME ID VALUE) ...) where each element of
923     the list represents a local variable in the stack frame associated to
924     FRAME-NUMBER.
925    
926     NAME, a symbol; the name of the local variable.
927    
928     ID, an integer; used as primary key for the local variable, unique
929     relatively to the frame under operation.
930    
931     value, an object; the value of the local variable.")
932    
933     (definterface frame-var-value (frame-number var-id)
934     "Return the value of the local variable associated to VAR-ID
935     relatively to the frame associated to FRAME-NUMBER.")
936 heller 1.57
937 heller 1.37 (definterface disassemble-frame (frame-number)
938     "Disassemble the code for the FRAME-NUMBER.
939     The output should be written to standard output.
940 heller 1.84 FRAME-NUMBER is a non-negative integer.")
941 heller 1.37
942 lgorrie 1.21 (definterface eval-in-frame (form frame-number)
943 lgorrie 1.3 "Evaluate a Lisp form in the lexical context of a stack frame
944 trittweiler 1.132 in the debugger.
945 lgorrie 1.3
946     FRAME-NUMBER must be a positive integer with 0 indicating the
947     frame which invoked the debugger.
948    
949     The return value is the result of evaulating FORM in the
950 lgorrie 1.21 appropriate context.")
951 heller 1.22
952 sboukarev 1.189 (definterface frame-call (frame-number)
953     "Return a string representing a call to the entry point of a frame.")
954    
955 heller 1.22 (definterface return-from-frame (frame-number form)
956     "Unwind the stack to the frame FRAME-NUMBER and return the value(s)
957     produced by evaluating FORM in the frame context to its caller.
958    
959     Execute any clean-up code from unwind-protect forms above the frame
960     during unwinding.
961    
962     Return a string describing the error if it's not possible to return
963     from the frame.")
964    
965     (definterface restart-frame (frame-number)
966     "Restart execution of the frame FRAME-NUMBER with the same arguments
967     as it was called originally.")
968 lgorrie 1.3
969 lgorrie 1.49 (definterface format-sldb-condition (condition)
970     "Format a condition for display in SLDB."
971     (princ-to-string condition))
972    
973 heller 1.69 (definterface condition-extras (condition)
974     "Return a list of extra for the debugger.
975     The allowed elements are of the form:
976 heller 1.126 (:SHOW-FRAME-SOURCE frame-number)
977     (:REFERENCES &rest refs)
978     "
979 mbaringer 1.73 (declare (ignore condition))
980 heller 1.69 '())
981    
982 trittweiler 1.197 (definterface gdb-initial-commands ()
983     "List of gdb commands supposed to be executed first for the
984     ATTACH-GDB restart."
985     nil)
986    
987 heller 1.71 (definterface activate-stepping (frame-number)
988     "Prepare the frame FRAME-NUMBER for stepping.")
989 heller 1.69
990     (definterface sldb-break-on-return (frame-number)
991     "Set a breakpoint in the frame FRAME-NUMBER.")
992    
993     (definterface sldb-break-at-start (symbol)
994     "Set a breakpoint on the beginning of the function for SYMBOL.")
995 heller 1.52
996 jsnellman 1.103 (definterface sldb-stepper-condition-p (condition)
997     "Return true if SLDB was invoked due to a single-stepping condition,
998     false otherwise. "
999     (declare (ignore condition))
1000     nil)
1001    
1002     (definterface sldb-step-into ()
1003     "Step into the current single-stepper form.")
1004    
1005     (definterface sldb-step-next ()
1006     "Step to the next form in the current function.")
1007    
1008     (definterface sldb-step-out ()
1009     "Stop single-stepping temporarily, but resume it once the current function
1010     returns.")
1011 lgorrie 1.49
1012 lgorrie 1.3
1013 heller 1.36 ;;;; Definition finding
1014    
1015     (defstruct (:location (:type list) :named
1016 lgorrie 1.45 (:constructor make-location
1017     (buffer position &optional hints)))
1018     buffer position
1019     ;; Hints is a property list optionally containing:
1020     ;; :snippet SOURCE-TEXT
1021     ;; This is a snippet of the actual source text at the start of
1022     ;; the definition, which could be used in a text search.
1023     hints)
1024 heller 1.36
1025     (defstruct (:error (:type list) :named (:constructor)) message)
1026 trittweiler 1.193
1027     ;;; Valid content for BUFFER slot
1028     (defstruct (:file (:type list) :named (:constructor)) name)
1029     (defstruct (:buffer (:type list) :named (:constructor)) name)
1030     (defstruct (:etags-file (:type list) :named (:constructor)) filename)
1031    
1032     ;;; Valid content for POSITION slot
1033 heller 1.36 (defstruct (:position (:type list) :named (:constructor)) pos)
1034 trittweiler 1.193 (defstruct (:tag (:type list) :named (:constructor)) tag1 tag2)
1035 heller 1.36
1036 trittweiler 1.194 (defmacro converting-errors-to-error-location (&body body)
1037     "Catches errors during BODY and converts them to an error location."
1038     (let ((gblock (gensym "CONVERTING-ERRORS+")))
1039     `(block ,gblock
1040     (handler-bind ((error
1041     #'(lambda (e)
1042     (if *debug-swank-backend*
1043     nil ;decline
1044     (return-from ,gblock
1045     (make-error-location e))))))
1046     ,@body))))
1047    
1048 trittweiler 1.186 (defun make-error-location (datum &rest args)
1049     (cond ((typep datum 'condition)
1050     `(:error ,(format nil "Error: ~A" datum)))
1051     ((symbolp datum)
1052     `(:error ,(format nil "Error: ~A" (apply #'make-condition datum args))))
1053     (t
1054     (assert (stringp datum))
1055     `(:error ,(apply #'format nil datum args)))))
1056    
1057 heller 1.36 (definterface find-definitions (name)
1058     "Return a list ((DSPEC LOCATION) ...) for NAME's definitions.
1059    
1060 heller 1.38 NAME is a \"definition specifier\".
1061 heller 1.36
1062 heller 1.38 DSPEC is a \"definition specifier\" describing the
1063 heller 1.36 definition, e.g., FOO or (METHOD FOO (STRING NUMBER)) or
1064 heller 1.38 \(DEFVAR FOO).
1065    
1066     LOCATION is the source location for the definition.")
1067 heller 1.36
1068 trittweiler 1.130 (definterface find-source-location (object)
1069     "Returns the source location of OBJECT, or NIL.
1070    
1071     That is the source location of the underlying datastructure of
1072     OBJECT. E.g. on a STANDARD-OBJECT, the source location of the
1073     respective DEFCLASS definition is returned, on a STRUCTURE-CLASS the
1074     respective DEFSTRUCT definition, and so on."
1075 trittweiler 1.135 ;; This returns one source location and not a list of locations. It's
1076 trittweiler 1.130 ;; supposed to return the location of the DEFGENERIC definition on
1077     ;; #'SOME-GENERIC-FUNCTION.
1078 trittweiler 1.186 (declare (ignore object))
1079     (make-error-location "FIND-DEFINITIONS is not yet implemented on ~
1080     this implementation."))
1081 trittweiler 1.130
1082    
1083 lgorrie 1.61 (definterface buffer-first-change (filename)
1084     "Called for effect the first time FILENAME's buffer is modified."
1085 mbaringer 1.73 (declare (ignore filename))
1086 lgorrie 1.61 nil)
1087    
1088 trittweiler 1.130
1089 heller 1.36
1090     ;;;; XREF
1091    
1092     (definterface who-calls (function-name)
1093     "Return the call sites of FUNCTION-NAME (a symbol).
1094 trittweiler 1.181 The results is a list ((DSPEC LOCATION) ...)."
1095     (declare (ignore function-name))
1096     :not-implemented)
1097 heller 1.36
1098 heller 1.81 (definterface calls-who (function-name)
1099     "Return the call sites of FUNCTION-NAME (a symbol).
1100 trittweiler 1.181 The results is a list ((DSPEC LOCATION) ...)."
1101     (declare (ignore function-name))
1102     :not-implemented)
1103 heller 1.81
1104 heller 1.36 (definterface who-references (variable-name)
1105     "Return the locations where VARIABLE-NAME (a symbol) is referenced.
1106 trittweiler 1.181 See WHO-CALLS for a description of the return value."
1107     (declare (ignore variable-name))
1108     :not-implemented)
1109 heller 1.36
1110     (definterface who-binds (variable-name)
1111     "Return the locations where VARIABLE-NAME (a symbol) is bound.
1112 trittweiler 1.181 See WHO-CALLS for a description of the return value."
1113     (declare (ignore variable-name))
1114     :not-implemented)
1115 heller 1.36
1116     (definterface who-sets (variable-name)
1117     "Return the locations where VARIABLE-NAME (a symbol) is set.
1118 trittweiler 1.181 See WHO-CALLS for a description of the return value."
1119     (declare (ignore variable-name))
1120     :not-implemented)
1121 heller 1.36
1122     (definterface who-macroexpands (macro-name)
1123     "Return the locations where MACRO-NAME (a symbol) is expanded.
1124 trittweiler 1.181 See WHO-CALLS for a description of the return value."
1125     (declare (ignore macro-name))
1126     :not-implemented)
1127 heller 1.36
1128     (definterface who-specializes (class-name)
1129     "Return the locations where CLASS-NAME (a symbol) is specialized.
1130 trittweiler 1.181 See WHO-CALLS for a description of the return value."
1131     (declare (ignore class-name))
1132     :not-implemented)
1133 heller 1.36
1134     ;;; Simpler variants.
1135    
1136     (definterface list-callers (function-name)
1137     "List the callers of FUNCTION-NAME.
1138     This function is like WHO-CALLS except that it is expected to use
1139     lower-level means. Whereas WHO-CALLS is usually implemented with
1140     special compiler support, LIST-CALLERS is usually implemented by
1141     groveling for constants in function objects throughout the heap.
1142    
1143     The return value is as for WHO-CALLS.")
1144    
1145     (definterface list-callees (function-name)
1146     "List the functions called by FUNCTION-NAME.
1147     See LIST-CALLERS for a description of the return value.")
1148    
1149    
1150 heller 1.23 ;;;; Profiling
1151    
1152     ;;; The following functions define a minimal profiling interface.
1153    
1154     (definterface profile (fname)
1155     "Marks symbol FNAME for profiling.")
1156    
1157     (definterface profiled-functions ()
1158     "Returns a list of profiled functions.")
1159    
1160     (definterface unprofile (fname)
1161     "Marks symbol FNAME as not profiled.")
1162    
1163     (definterface unprofile-all ()
1164     "Marks all currently profiled functions as not profiled."
1165     (dolist (f (profiled-functions))
1166     (unprofile f)))
1167    
1168     (definterface profile-report ()
1169     "Prints profile report.")
1170    
1171     (definterface profile-reset ()
1172     "Resets profile counters.")
1173    
1174     (definterface profile-package (package callers-p methods)
1175     "Wrap profiling code around all functions in PACKAGE. If a function
1176     is already profiled, then unprofile and reprofile (useful to notice
1177     function redefinition.)
1178    
1179     If CALLERS-P is T names have counts of the most common calling
1180     functions recorded.
1181    
1182     When called with arguments :METHODS T, profile all methods of all
1183     generic functions having names in the given package. Generic functions
1184     themselves, that is, their dispatch functions, are left alone.")
1185    
1186    
1187 heller 1.19 ;;;; Inspector
1188 lgorrie 1.56
1189 heller 1.128 (defgeneric emacs-inspect (object)
1190 heller 1.100 (:documentation
1191 heller 1.86 "Explain to Emacs how to inspect OBJECT.
1192 mbaringer 1.67
1193 heller 1.129 Returns a list specifying how to render the object for inspection.
1194 mbaringer 1.67
1195 lgorrie 1.83 Every element of the list must be either a string, which will be
1196 mbaringer 1.67 inserted into the buffer as is, or a list of the form:
1197    
1198     (:value object &optional format) - Render an inspectable
1199     object. If format is provided it must be a string and will be
1200     rendered in place of the value, otherwise use princ-to-string.
1201    
1202     (:newline) - Render a \\n
1203    
1204 mbaringer 1.117 (:action label lambda &key (refresh t)) - Render LABEL (a text
1205     string) which when clicked will call LAMBDA. If REFRESH is
1206     non-NIL the currently inspected object will be re-inspected
1207     after calling the lambda.
1208 heller 1.129 "))
1209 mbaringer 1.67
1210 heller 1.128 (defmethod emacs-inspect ((object t))
1211 mbaringer 1.67 "Generic method for inspecting any kind of object.
1212    
1213     Since we don't know how to deal with OBJECT we simply dump the
1214     output of CL:DESCRIBE."
1215 heller 1.86 `("Type: " (:value ,(type-of object)) (:newline)
1216     "Don't know how to inspect the object, dumping output of CL:DESCRIBE:"
1217     (:newline) (:newline)
1218 heller 1.129 ,(with-output-to-string (desc) (describe object desc))))
1219 heller 1.70
1220 heller 1.192 (definterface eval-context (object)
1221     "Return a list of bindings corresponding to OBJECT's slots."
1222     (declare (ignore object))
1223     '())
1224 trittweiler 1.185
1225 heller 1.84 ;;; Utilities for inspector methods.
1226 heller 1.70 ;;;
1227 heller 1.205
1228     (defun label-value-line (label value &key (newline t))
1229     "Create a control list which prints \"LABEL: VALUE\" in the inspector.
1230     If NEWLINE is non-NIL a `(:newline)' is added to the result."
1231     (list* (princ-to-string label) ": " `(:value ,value)
1232     (if newline '((:newline)) nil)))
1233 heller 1.70
1234     (defmacro label-value-line* (&rest label-values)
1235 heller 1.205 ` (append ,@(loop for (label value) in label-values
1236     collect `(label-value-line ,label ,value))))
1237 heller 1.19
1238 heller 1.29 (definterface describe-primitive-type (object)
1239 heller 1.35 "Return a string describing the primitive type of object."
1240 heller 1.36 (declare (ignore object))
1241 heller 1.35 "N/A")
1242 heller 1.19
1243    
1244 heller 1.36 ;;;; Multithreading
1245 lgorrie 1.21 ;;;
1246     ;;; The default implementations are sufficient for non-multiprocessing
1247     ;;; implementations.
1248 lgorrie 1.9
1249 mbaringer 1.106 (definterface initialize-multiprocessing (continuation)
1250 heller 1.107 "Initialize multiprocessing, if necessary and then invoke CONTINUATION.
1251    
1252     Depending on the impleimentaion, this function may never return."
1253 mbaringer 1.106 (funcall continuation))
1254 lgorrie 1.9
1255 lgorrie 1.21 (definterface spawn (fn &key name)
1256     "Create a new thread to call FN.")
1257 lgorrie 1.17
1258 heller 1.58 (definterface thread-id (thread)
1259     "Return an Emacs-parsable object to identify THREAD.
1260    
1261     Ids should be comparable with equal, i.e.:
1262 heller 1.139 (equal (thread-id <t1>) (thread-id <t2>)) <==> (eq <t1> <t2>)"
1263     thread)
1264 heller 1.58
1265     (definterface find-thread (id)
1266     "Return the thread for ID.
1267     ID should be an id previously obtained with THREAD-ID.
1268 heller 1.142 Can return nil if the thread no longer exists."
1269 heller 1.162 (declare (ignore id))
1270 heller 1.142 (current-thread))
1271 heller 1.58
1272 heller 1.28 (definterface thread-name (thread)
1273     "Return the name of THREAD.
1274 heller 1.183 Thread names are short strings meaningful to the user. They do not
1275     have to be unique."
1276 heller 1.28 (declare (ignore thread))
1277 lgorrie 1.21 "The One True Thread")
1278 lgorrie 1.9
1279 heller 1.28 (definterface thread-status (thread)
1280     "Return a string describing THREAD's state."
1281     (declare (ignore thread))
1282     "")
1283    
1284 heller 1.177 (definterface thread-attributes (thread)
1285     "Return a plist of implementation-dependent attributes for THREAD"
1286     (declare (ignore thread))
1287     '())
1288    
1289 lgorrie 1.21 (definterface make-lock (&key name)
1290 lgorrie 1.17 "Make a lock for thread synchronization.
1291 heller 1.138 Only one thread may hold the lock (via CALL-WITH-LOCK-HELD) at a time
1292     but that thread may hold it more than once."
1293 heller 1.23 (declare (ignore name))
1294 lgorrie 1.21 :null-lock)
1295 lgorrie 1.9
1296 lgorrie 1.21 (definterface call-with-lock-held (lock function)
1297     "Call FUNCTION with LOCK held, queueing if necessary."
1298 heller 1.24 (declare (ignore lock)
1299     (type function function))
1300 lgorrie 1.21 (funcall function))
1301 heller 1.25
1302     (definterface current-thread ()
1303     "Return the currently executing thread."
1304     0)
1305 heller 1.28
1306     (definterface all-threads ()
1307 heller 1.190 "Return a fresh list of all threads."
1308     '())
1309 heller 1.28
1310     (definterface thread-alive-p (thread)
1311 heller 1.35 "Test if THREAD is termintated."
1312     (member thread (all-threads)))
1313 heller 1.25
1314     (definterface interrupt-thread (thread fn)
1315     "Cause THREAD to execute FN.")
1316    
1317 mbaringer 1.34 (definterface kill-thread (thread)
1318 heller 1.182 "Terminate THREAD immediately.
1319     Don't execute unwind-protected sections, don't raise conditions.
1320     (Do not pass go, do not collect $200.)"
1321 mbaringer 1.34 (declare (ignore thread))
1322     nil)
1323    
1324 heller 1.25 (definterface send (thread object)
1325     "Send OBJECT to thread THREAD.")
1326    
1327 heller 1.143 (definterface receive (&optional timeout)
1328 heller 1.142 "Return the next message from current thread's mailbox."
1329 heller 1.143 (receive-if (constantly t) timeout))
1330 mbaringer 1.78
1331 heller 1.143 (definterface receive-if (predicate &optional timeout)
1332 heller 1.136 "Return the first message satisfiying PREDICATE.")
1333    
1334 heller 1.168 (definterface set-default-initial-binding (var form)
1335     "Initialize special variable VAR by default with FORM.
1336    
1337     Some implementations initialize certain variables in each newly
1338     created thread. This function sets the form which is used to produce
1339     the initial value."
1340     (set var (eval form)))
1341    
1342 heller 1.153 ;; List of delayed interrupts.
1343     ;; This should only have thread-local bindings, so no init form.
1344     (defvar *pending-slime-interrupts*)
1345 heller 1.140
1346 heller 1.154 (defun check-slime-interrupts ()
1347 heller 1.140 "Execute pending interrupts if any.
1348     This should be called periodically in operations which
1349 heller 1.153 can take a long time to complete.
1350 heller 1.154 Return a boolean indicating whether any interrupts was processed."
1351 heller 1.153 (when (and (boundp '*pending-slime-interrupts*)
1352     *pending-slime-interrupts*)
1353 heller 1.154 (funcall (pop *pending-slime-interrupts*))
1354 heller 1.153 t))
1355 heller 1.140
1356 heller 1.172 (defvar *interrupt-queued-handler* nil
1357     "Function to call on queued interrupts.
1358     Interrupts get queued when an interrupt occurs while interrupt
1359     handling is disabled.
1360    
1361     Backends can use this function to abort slow operations.")
1362 heller 1.163
1363 heller 1.152 (definterface wait-for-input (streams &optional timeout)
1364     "Wait for input on a list of streams. Return those that are ready.
1365     STREAMS is a list of streams
1366 heller 1.210 TIMEOUT nil, t, or real number. If TIMEOUT is t, return those streams
1367     which are ready (or have reached end-of-file) without waiting.
1368 heller 1.152 If TIMEOUT is a number and no streams is ready after TIMEOUT seconds,
1369     return nil.
1370    
1371 heller 1.210 Return :interrupt if an interrupt occurs while waiting.")
1372    
1373 heller 1.164 (defun wait-for-streams (streams timeout)
1374 heller 1.166 (loop
1375     (when (check-slime-interrupts) (return :interrupt))
1376     (let ((ready (remove-if-not #'stream-readable-p streams)))
1377     (when ready (return ready)))
1378     (when timeout (return nil))
1379     (sleep 0.1)))
1380 heller 1.164
1381 heller 1.166 ;; Note: Usually we can't interrupt PEEK-CHAR cleanly.
1382 heller 1.164 (defun wait-for-one-stream (stream timeout)
1383     (ecase timeout
1384     ((nil)
1385     (cond ((check-slime-interrupts) :interrupt)
1386     (t (peek-char nil stream nil nil)
1387     (list stream))))
1388     ((t)
1389     (let ((c (read-char-no-hang stream nil nil)))
1390     (cond (c
1391     (unread-char c stream)
1392     (list stream))
1393     (t '()))))))
1394 heller 1.152
1395 heller 1.166 (defun stream-readable-p (stream)
1396     (let ((c (read-char-no-hang stream nil :eof)))
1397     (cond ((not c) nil)
1398     ((eq c :eof) t)
1399     (t (unread-char c stream) t))))
1400    
1401 heller 1.81 (definterface toggle-trace (spec)
1402     "Toggle tracing of the function(s) given with SPEC.
1403     SPEC can be:
1404     (setf NAME) ; a setf function
1405     (:defmethod NAME QUALIFIER... (SPECIALIZER...)) ; a specific method
1406     (:defgeneric NAME) ; a generic function with all methods
1407     (:call CALLER CALLEE) ; trace calls from CALLER to CALLEE.
1408     (:labels TOPLEVEL LOCAL)
1409     (:flet TOPLEVEL LOCAL) ")
1410 mkoeppe 1.87
1411    
1412     ;;;; Weak datastructures
1413    
1414     (definterface make-weak-key-hash-table (&rest args)
1415     "Like MAKE-HASH-TABLE, but weak w.r.t. the keys."
1416     (apply #'make-hash-table args))
1417    
1418     (definterface make-weak-value-hash-table (&rest args)
1419     "Like MAKE-HASH-TABLE, but weak w.r.t. the values."
1420     (apply #'make-hash-table args))
1421 mkoeppe 1.108
1422 alendvai 1.113 (definterface hash-table-weakness (hashtable)
1423     "Return nil or one of :key :value :key-or-value :key-and-value"
1424     (declare (ignore hashtable))
1425     nil)
1426    
1427 mkoeppe 1.108
1428     ;;;; Character names
1429    
1430     (definterface character-completion-set (prefix matchp)
1431     "Return a list of names of characters that match PREFIX."
1432     ;; Handle the standard and semi-standard characters.
1433     (loop for name in '("Newline" "Space" "Tab" "Page" "Rubout"
1434     "Linefeed" "Return" "Backspace")
1435     when (funcall matchp prefix name)
1436     collect name))
1437    
1438 trittweiler 1.120
1439     (defparameter *type-specifier-arglists*
1440     '((and . (&rest type-specifiers))
1441     (array . (&optional element-type dimension-spec))
1442     (base-string . (&optional size))
1443     (bit-vector . (&optional size))
1444     (complex . (&optional type-specifier))
1445     (cons . (&optional car-typespec cdr-typespec))
1446     (double-float . (&optional lower-limit upper-limit))
1447     (eql . (object))
1448     (float . (&optional lower-limit upper-limit))
1449     (function . (&optional arg-typespec value-typespec))
1450     (integer . (&optional lower-limit upper-limit))
1451     (long-float . (&optional lower-limit upper-limit))
1452     (member . (&rest eql-objects))
1453     (mod . (n))
1454     (not . (type-specifier))
1455     (or . (&rest type-specifiers))
1456     (rational . (&optional lower-limit upper-limit))
1457     (real . (&optional lower-limit upper-limit))
1458     (satisfies . (predicate-symbol))
1459     (short-float . (&optional lower-limit upper-limit))
1460     (signed-byte . (&optional size))
1461     (simple-array . (&optional element-type dimension-spec))
1462     (simple-base-string . (&optional size))
1463     (simple-bit-vector . (&optional size))
1464     (simple-string . (&optional size))
1465     (single-float . (&optional lower-limit upper-limit))
1466     (simple-vector . (&optional size))
1467     (string . (&optional size))
1468     (unsigned-byte . (&optional size))
1469     (values . (&rest typespecs))
1470     (vector . (&optional element-type size))
1471 heller 1.121 ))
1472 heller 1.145
1473     ;;; Heap dumps
1474    
1475     (definterface save-image (filename &optional restart-function)
1476     "Save a heap image to the file FILENAME.
1477     RESTART-FUNCTION, if non-nil, should be called when the image is loaded.")
1478    
1479 heller 1.200 (definterface background-save-image (filename &key restart-function
1480     completion-function)
1481     "Request saving a heap image to the file FILENAME.
1482     RESTART-FUNCTION, if non-nil, should be called when the image is loaded.
1483     COMPLETION-FUNCTION, if non-nil, should be called after saving the image.")
1484 rtoy 1.203
1485     ;;; Codepoint length
1486    
1487     (definterface codepoint-length (string)
1488     "Return the number of codepoints in STRING.
1489     With some Lisps, like cmucl, LENGTH returns the number of UTF-16 code
1490     units, but other Lisps return the number of codepoints. The slime
1491     protocol wants string lengths in terms of codepoints."
1492     (length string))
1493 nsiivola 1.206
1494     ;;; Timeouts
1495    
1496     (definterface call-with-io-timeout (function &key seconds)
1497     "Calls function with the specified IO timeout."
1498     (declare (ignore seconds))
1499     (funcall function))

  ViewVC Help
Powered by ViewVC 1.1.5