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

Contents of /slime/swank-backend.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5