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

Contents of /slime/swank-backend.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.121 - (hide annotations)
Thu Aug 23 19:03:37 2007 UTC (6 years, 7 months ago) by heller
Branch: MAIN
Changes since 1.120: +3 -1 lines
Introduce backend-inspector class.

* swank-backend.lisp (backend-inspector): New class. Introduce a named
  class to give as another way to dispatch to backend methods.

* swank-cmucl.lisp: Use backend-inspector class.
* swank-sbcl.lisp: Use backend-inspector class.
* swank-clisp.lisp: Use backend-inspector class.
* swank-lispworks.lisp: Use backend-inspector class.
* swank-allegro.lisp: Use backend-inspector class.
* swank-openmcl.lisp: Use backend-inspector class.
* swank-abcl.lisp: Use backend-inspector class.
* swank-corman.lisp: Use backend-inspector class.
* swank-scl.lisp: Use backend-inspector class.
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 heller 1.36 (:export #:sldb-condition
16     #:original-condition
17     #:compiler-condition
18 mbaringer 1.102 #:abort-request
19     #:request-abort
20 heller 1.36 #:message
21     #:short-message
22     #:condition
23     #:severity
24     #: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 mbaringer 1.67 ;; inspector related symbols
37     #:inspector
38     #:inspect-for-emacs
39     #:raw-inspection
40     #:fancy-inspection
41 heller 1.70 #:label-value-line
42     #:label-value-line*
43 mbaringer 1.115 #:with-struct
44 mbaringer 1.67 ))
45 lgorrie 1.1
46 mbaringer 1.65 (defpackage :swank-mop
47     (:use)
48     (:export
49     ;; classes
50     #:standard-generic-function
51     #:standard-slot-definition
52     #:standard-method
53     #:standard-class
54 mbaringer 1.68 #:eql-specializer
55     #:eql-specializer-object
56 mbaringer 1.65 ;; standard-class readers
57     #:class-default-initargs
58     #:class-direct-default-initargs
59     #:class-direct-slots
60     #:class-direct-subclasses
61     #:class-direct-superclasses
62     #:class-finalized-p
63     #:class-name
64     #:class-precedence-list
65     #:class-prototype
66     #:class-slots
67 mbaringer 1.68 #:specializer-direct-methods
68 mbaringer 1.65 ;; generic function readers
69     #:generic-function-argument-precedence-order
70     #:generic-function-declarations
71     #:generic-function-lambda-list
72     #:generic-function-methods
73     #:generic-function-method-class
74     #:generic-function-method-combination
75     #:generic-function-name
76     ;; method readers
77     #:method-generic-function
78     #:method-function
79     #:method-lambda-list
80     #:method-specializers
81     #:method-qualifiers
82     ;; slot readers
83     #:slot-definition-allocation
84     #:slot-definition-documentation
85     #:slot-definition-initargs
86     #:slot-definition-initform
87     #:slot-definition-initfunction
88     #:slot-definition-name
89     #:slot-definition-type
90     #:slot-definition-readers
91 lgorrie 1.79 #:slot-definition-writers
92 heller 1.95 #:slot-boundp-using-class
93     #:slot-value-using-class
94 alendvai 1.111 #:slot-makunbound-using-class
95 lgorrie 1.79 ;; generic function protocol
96 lgorrie 1.82 #:compute-applicable-methods-using-classes
97     #:finalize-inheritance))
98 mbaringer 1.65
99 heller 1.36 (in-package :swank-backend)
100 lgorrie 1.1
101    
102 lgorrie 1.21 ;;;; Metacode
103    
104     (defparameter *interface-functions* '()
105     "The names of all interface functions.")
106    
107     (defparameter *unimplemented-interfaces* '()
108     "List of interface functions that are not implemented.
109     DEFINTERFACE adds to this list and DEFIMPLEMENTATION removes.")
110    
111 heller 1.52 (defmacro definterface (name args documentation &rest default-body)
112 lgorrie 1.21 "Define an interface function for the backend to implement.
113     A generic function is defined with NAME, ARGS, and DOCUMENTATION.
114    
115     If a DEFAULT-BODY is supplied then NO-APPLICABLE-METHOD is specialized
116     to execute the body if the backend doesn't provide a specific
117     implementation.
118    
119     Backends implement these functions using DEFIMPLEMENTATION."
120 lgorrie 1.43 (check-type documentation string "a documentation string")
121 heller 1.101 (assert (every #'symbolp args) ()
122     "Complex lambda-list not supported: ~S ~S" name args)
123     (labels ((gen-default-impl ()
124     `(setf (get ',name 'default) (lambda ,args ,@default-body)))
125     (args-as-list (args)
126     (destructuring-bind (req opt key rest) (parse-lambda-list args)
127     `(,@req ,@opt
128     ,@(loop for k in key append `(,(kw k) ,k))
129     ,@(or rest '(())))))
130     (parse-lambda-list (args)
131     (parse args '(&optional &key &rest)
132     (make-array 4 :initial-element nil)))
133     (parse (args keywords vars)
134     (cond ((null args)
135     (reverse (map 'list #'reverse vars)))
136     ((member (car args) keywords)
137     (parse (cdr args) (cdr (member (car args) keywords)) vars))
138     (t (push (car args) (aref vars (length keywords)))
139     (parse (cdr args) keywords vars))))
140     (kw (s) (intern (string s) :keyword)))
141     `(progn
142     (defun ,name ,args
143     ,documentation
144     (let ((f (or (get ',name 'implementation)
145     (get ',name 'default))))
146     (cond (f (apply f ,@(args-as-list args)))
147     (t (error "~S not implementated" ',name)))))
148     (pushnew ',name *interface-functions*)
149     ,(if (null default-body)
150     `(pushnew ',name *unimplemented-interfaces*)
151     (gen-default-impl))
152     ;; see <http://www.franz.com/support/documentation/6.2/doc/pages/variables/compiler/s_cltl1-compile-file-toplevel-compatibility-p_s.htm>
153     (eval-when (:compile-toplevel :load-toplevel :execute)
154     (export ',name :swank-backend))
155     ',name)))
156 lgorrie 1.21
157     (defmacro defimplementation (name args &body body)
158 heller 1.101 (assert (every #'symbolp args) ()
159     "Complex lambda-list not supported: ~S ~S" name args)
160 heller 1.99 `(progn
161 heller 1.101 (setf (get ',name 'implementation) (lambda ,args ,@body))
162 heller 1.99 (if (member ',name *interface-functions*)
163     (setq *unimplemented-interfaces*
164     (remove ',name *unimplemented-interfaces*))
165     (warn "DEFIMPLEMENTATION of undefined interface (~S)" ',name))
166     ',name))
167 lgorrie 1.21
168 mbaringer 1.102 (define-condition request-abort (error)
169     ((reason :initarg :reason :reader reason))
170     (:report (lambda (condition stream)
171     (princ (reason condition) stream)))
172     (:documentation "Condition signalled when SLIME wasn't able to
173     complete a user request due to bad data. This condition is not
174     for real errors but for situations where SLIME has to give up and
175     return control back to the user."))
176    
177     (defun abort-request (reason-control &rest reason-args)
178     "Abort whatever swank is currently do and send a message to the
179     user."
180     (error 'request-abort :reason (apply #'format nil reason-control reason-args)))
181    
182 lgorrie 1.21 (defun warn-unimplemented-interfaces ()
183     "Warn the user about unimplemented backend features.
184     The portable code calls this function at startup."
185     (warn "These Swank interfaces are unimplemented:~% ~A"
186     (sort (copy-list *unimplemented-interfaces*) #'string<)))
187    
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     :stream-fresh-line
211     :stream-force-output
212     :stream-finish-output
213     :fundamental-character-input-stream
214     :stream-read-char
215     :stream-listen
216     :stream-unread-char
217     :stream-clear-input
218     :stream-line-column
219 jsnellman 1.90 :stream-read-char-no-hang
220     ;; STREAM-LINE-LENGTH is an extension to gray streams that's apparently
221 dcrosher 1.91 ;; supported by CMUCL, OpenMCL, SBCL and SCL.
222     #+(or cmu openmcl sbcl scl)
223 jsnellman 1.90 :stream-line-length))
224 heller 1.88
225     (defun import-from (package symbol-names &optional (to-package *package*))
226     "Import the list of SYMBOL-NAMES found in the package PACKAGE."
227     (dolist (name symbol-names)
228     (multiple-value-bind (symbol found) (find-symbol (string name) package)
229     (assert found () "Symbol ~A not found in package ~A" name package)
230     (import symbol to-package))))
231    
232 lgorrie 1.21
233 heller 1.46 ;;;; Utilities
234    
235     (defmacro with-struct ((conc-name &rest names) obj &body body)
236     "Like with-slots but works only for structs."
237     (flet ((reader (slot) (intern (concatenate 'string
238     (symbol-name conc-name)
239     (symbol-name slot))
240     (symbol-package conc-name))))
241     (let ((tmp (gensym "OO-")))
242     ` (let ((,tmp ,obj))
243     (symbol-macrolet
244     ,(loop for name in names collect
245     (typecase name
246     (symbol `(,name (,(reader name) ,tmp)))
247     (cons `(,(first name) (,(reader (second name)) ,tmp)))
248     (t (error "Malformed syntax in WITH-STRUCT: ~A" name))))
249     ,@body)))))
250 lgorrie 1.54
251    
252 lgorrie 1.13 ;;;; TCP server
253    
254 heller 1.29 (definterface create-socket (host port)
255     "Create a listening TCP socket on interface HOST and port PORT .")
256 lgorrie 1.13
257 lgorrie 1.21 (definterface local-port (socket)
258     "Return the local port number of SOCKET.")
259 lgorrie 1.1
260 lgorrie 1.21 (definterface close-socket (socket)
261     "Close the socket SOCKET.")
262 lgorrie 1.1
263 heller 1.93 (definterface accept-connection (socket &key external-format
264 dcrosher 1.97 buffering timeout)
265 heller 1.93 "Accept a client connection on the listening socket SOCKET.
266     Return a stream for the new connection.")
267 heller 1.16
268 heller 1.31 (definterface add-sigio-handler (socket fn)
269 lgorrie 1.21 "Call FN whenever SOCKET is readable.")
270 heller 1.16
271 heller 1.31 (definterface remove-sigio-handlers (socket)
272     "Remove all sigio handlers for SOCKET.")
273    
274     (definterface add-fd-handler (socket fn)
275     "Call FN when Lisp is waiting for input and SOCKET is readable.")
276    
277     (definterface remove-fd-handlers (socket)
278     "Remove all fd-handlers for SOCKET.")
279 heller 1.18
280 heller 1.36 (definterface preferred-communication-style ()
281     "Return one of the symbols :spawn, :sigio, :fd-handler, or NIL."
282     nil)
283    
284 dcrosher 1.97 (definterface set-stream-timeout (stream timeout)
285     "Set the 'stream 'timeout. The timeout is either the real number
286     specifying the timeout in seconds or 'nil for no timeout."
287     (declare (ignore stream timeout))
288     nil)
289    
290 lgorrie 1.13 ;;; Base condition for networking errors.
291 msimmons 1.50 (define-condition network-error (simple-error) ())
292 lgorrie 1.13
293 heller 1.74 (definterface emacs-connected ()
294 lgorrie 1.13 "Hook called when the first connection from Emacs is established.
295     Called from the INIT-FN of the socket server that accepts the
296     connection.
297 lgorrie 1.1
298 lgorrie 1.13 This is intended for setting up extra context, e.g. to discover
299 heller 1.74 that the calling thread is the one that interacts with Emacs."
300 mbaringer 1.73 nil)
301 lgorrie 1.1
302    
303 heller 1.20 ;;;; Unix signals
304    
305     (defconstant +sigint+ 2)
306    
307 heller 1.36 (definterface call-without-interrupts (fn)
308     "Call FN in a context where interrupts are disabled."
309     (funcall fn))
310 heller 1.20
311 heller 1.32 (definterface getpid ()
312     "Return the (Unix) process ID of this superior Lisp.")
313    
314     (definterface lisp-implementation-type-name ()
315     "Return a short name for the Lisp implementation."
316     (lisp-implementation-type))
317 heller 1.20
318 heller 1.51 (definterface default-directory ()
319     "Return the default directory."
320     (directory-namestring (truename *default-pathname-defaults*)))
321    
322 heller 1.39 (definterface set-default-directory (directory)
323     "Set the default directory.
324     This is used to resolve filenames without directory component."
325     (setf *default-pathname-defaults* (truename (merge-pathnames directory)))
326 heller 1.51 (default-directory))
327    
328     (definterface call-with-syntax-hooks (fn)
329     "Call FN with hooks to handle special syntax."
330     (funcall fn))
331 heller 1.39
332 heller 1.52 (definterface default-readtable-alist ()
333 heller 1.77 "Return a suitable initial value for SWANK:*READTABLE-ALIST*."
334 heller 1.52 '())
335    
336 heller 1.58 (definterface quit-lisp ()
337     "Exit the current lisp image.")
338    
339 heller 1.20
340 lgorrie 1.1 ;;;; Compilation
341 dbarlow 1.8
342 lgorrie 1.21 (definterface call-with-compilation-hooks (func)
343 lgorrie 1.47 "Call FUNC with hooks to record compiler conditions.")
344 lgorrie 1.13
345 vsedach 1.14 (defmacro with-compilation-hooks ((&rest ignore) &body body)
346 lgorrie 1.47 "Execute BODY as in CALL-WITH-COMPILATION-HOOKS."
347 vsedach 1.14 (declare (ignore ignore))
348 dbarlow 1.8 `(call-with-compilation-hooks (lambda () (progn ,@body))))
349 lgorrie 1.1
350 pseibel 1.64 (definterface swank-compile-string (string &key buffer position directory)
351 lgorrie 1.47 "Compile source from STRING. During compilation, compiler
352 lgorrie 1.1 conditions must be trapped and resignalled as COMPILER-CONDITIONs.
353    
354     If supplied, BUFFER and POSITION specify the source location in Emacs.
355    
356     Additionally, if POSITION is supplied, it must be added to source
357 pseibel 1.64 positions reported in compiler conditions.
358    
359     If DIRECTORY is specified it may be used by certain implementations to
360     rebind *DEFAULT-PATHNAME-DEFAULTS* which may improve the recording of
361     source information.")
362 lgorrie 1.1
363 lgorrie 1.43 (definterface operate-on-system (system-name operation-name &rest keyword-args)
364     "Perform OPERATION-NAME on SYSTEM-NAME using ASDF.
365     The KEYWORD-ARGS are passed on to the operation.
366     Example:
367     \(operate-on-system \"SWANK\" \"COMPILE-OP\" :force t)"
368     (unless (member :asdf *features*)
369 mbaringer 1.102 (abort-request "ASDF is not loaded."))
370 heller 1.30 (with-compilation-hooks ()
371 dcrosher 1.96 (let ((operate (find-symbol (symbol-name '#:operate) :asdf))
372 lgorrie 1.43 (operation (find-symbol operation-name :asdf)))
373     (when (null operation)
374 mbaringer 1.102 (abort-request "Couldn't find ASDF operation ~S" operation-name))
375 lgorrie 1.43 (apply operate operation system-name keyword-args))))
376 mbaringer 1.26
377 heller 1.109 (definterface swank-compile-file (filename load-p external-format)
378 lgorrie 1.1 "Compile FILENAME signalling COMPILE-CONDITIONs.
379 heller 1.109 If LOAD-P is true, load the file after compilation.
380     EXTERNAL-FORMAT is a value returned by find-external-format or
381     :default.")
382 lgorrie 1.1
383 heller 1.72 (deftype severity ()
384     '(member :error :read-error :warning :style-warning :note))
385 lgorrie 1.13
386     ;; Base condition type for compiler errors, warnings and notes.
387     (define-condition compiler-condition (condition)
388     ((original-condition
389     ;; The original condition thrown by the compiler if appropriate.
390     ;; May be NIL if a compiler does not report using conditions.
391     :type (or null condition)
392     :initarg :original-condition
393     :accessor original-condition)
394    
395     (severity :type severity
396     :initarg :severity
397     :accessor severity)
398    
399     (message :initarg :message
400     :accessor message)
401    
402 heller 1.30 (short-message :initarg :short-message
403     :initform nil
404     :accessor short-message)
405 crhodes 1.62
406     (references :initarg :references
407     :initform nil
408     :accessor references)
409 heller 1.30
410 lgorrie 1.13 (location :initarg :location
411     :accessor location)))
412 heller 1.30
413 heller 1.109 (definterface find-external-format (coding-system)
414     "Return a \"external file format designator\" for CODING-SYSTEM.
415     CODING-SYSTEM is Emacs-style coding system name (a string),
416     e.g. \"latin-1-unix\"."
417     (if (equal coding-system "iso-latin-1-unix")
418     :default
419     nil))
420    
421     (definterface guess-external-format (filename)
422     "Detect the external format for the file with name FILENAME.
423     Return nil if the file contains no special markers."
424     ;; Look for a Emacs-style -*- coding: ... -*- or Local Variable: section.
425     (with-open-file (s filename :if-does-not-exist nil
426     :external-format (or (find-external-format "latin-1-unix")
427     :default))
428 heller 1.110 (if s
429     (or (let* ((line (read-line s nil))
430     (p (search "-*-" line)))
431     (when p
432     (let* ((start (+ p (length "-*-")))
433     (end (search "-*-" line :start2 start)))
434     (when end
435     (%search-coding line start end)))))
436     (let* ((len (file-length s))
437     (buf (make-string (min len 3000))))
438     (file-position s (- len (length buf)))
439     (read-sequence buf s)
440     (let ((start (search "Local Variables:" buf :from-end t))
441     (end (search "End:" buf :from-end t)))
442     (and start end (< start end)
443     (%search-coding buf start end))))))))
444 heller 1.109
445     (defun %search-coding (str start end)
446     (let ((p (search "coding:" str :start2 start :end2 end)))
447     (when p
448     (incf p (length "coding:"))
449     (loop while (and (< p end)
450     (member (aref str p) '(#\space #\tab)))
451     do (incf p))
452     (let ((end (position-if (lambda (c) (find c '(#\space #\tab #\newline)))
453     str :start p)))
454     (find-external-format (subseq str p end))))))
455    
456 lgorrie 1.17
457 lgorrie 1.13 ;;;; Streams
458    
459 lgorrie 1.21 (definterface make-fn-streams (input-fn output-fn)
460 lgorrie 1.13 "Return character input and output streams backended by functions.
461     When input is needed, INPUT-FN is called with no arguments to
462     return a string.
463     When output is ready, OUTPUT-FN is called with the output as its
464     argument.
465    
466     Output should be forced to OUTPUT-FN before calling INPUT-FN.
467    
468 lgorrie 1.21 The streams are returned as two values.")
469 lgorrie 1.13
470 lgorrie 1.60 (definterface make-stream-interactive (stream)
471     "Do any necessary setup to make STREAM work interactively.
472     This is called for each stream used for interaction with the user
473     \(e.g. *standard-output*). An implementation could setup some
474     implementation-specific functions to control output flushing at the
475     like."
476 mbaringer 1.73 (declare (ignore stream))
477 lgorrie 1.60 nil)
478    
479 lgorrie 1.1
480     ;;;; Documentation
481    
482 heller 1.36 (definterface arglist (name)
483 mbaringer 1.65 "Return the lambda list for the symbol NAME. NAME can also be
484     a lisp function object, on lisps which support this.
485    
486 trittweiler 1.120 The result can be a list or the :not-available keyword if the
487     arglist cannot be determined."
488 mbaringer 1.65 (declare (ignore name))
489     :not-available)
490 heller 1.36
491 trittweiler 1.120 (defgeneric declaration-arglist (decl-identifier)
492     (:documentation
493     "Return the argument list of the declaration specifier belonging to the
494     declaration identifier DECL-IDENTIFIER. If the arglist cannot be determined,
495     the keyword :NOT-AVAILABLE is returned.
496    
497     The different SWANK backends can specialize this generic function to
498     include implementation-dependend declaration specifiers, or to provide
499     additional information on the specifiers defined in ANSI Common Lisp.")
500     (:method (decl-identifier)
501     (case decl-identifier
502     (dynamic-extent '(&rest vars))
503     (ignore '(&rest vars))
504     (ignorable '(&rest vars))
505     (special '(&rest vars))
506     (inline '(&rest function-names))
507     (notinline '(&rest function-name))
508     (optimize '(&any compilation-speed debug safety space speed))
509     (type '(type-specifier &rest args))
510     (ftype '(type-specifier &rest function-names))
511     (otherwise
512     (flet ((typespec-p (symbol) (member :type (describe-symbol-for-emacs symbol))))
513     (cond ((and (symbolp decl-identifier) (typespec-p decl-identifier))
514     '(&rest vars))
515     ((and (listp decl-identifier) (typespec-p (first decl-identifier)))
516     '(&rest vars))
517     (t :not-available)))))))
518    
519     (defgeneric type-specifier-arglist (typespec-operator)
520     (:documentation
521     "Return the argument list of the type specifier belonging to
522     TYPESPEC-OPERATOR.. If the arglist cannot be determined, the keyword
523     :NOT-AVAILABLE is returned.
524    
525     The different SWANK backends can specialize this generic function to
526     include implementation-dependend declaration specifiers, or to provide
527     additional information on the specifiers defined in ANSI Common Lisp.")
528     (:method (typespec-operator)
529     (declare (special *type-specifier-arglists*)) ; defined at end of file.
530     (typecase typespec-operator
531     (symbol (or (cdr (assoc typespec-operator *type-specifier-arglists*))
532     :not-available))
533     (t :not-available))))
534    
535 mbaringer 1.65 (definterface function-name (function)
536     "Return the name of the function object FUNCTION.
537    
538     The result is either a symbol, a list, or NIL if no function name is available."
539     (declare (ignore function))
540     nil)
541 lgorrie 1.1
542 lgorrie 1.21 (definterface macroexpand-all (form)
543 lgorrie 1.1 "Recursively expand all macros in FORM.
544 lgorrie 1.21 Return the resulting form.")
545 lgorrie 1.1
546 heller 1.94 (definterface compiler-macroexpand-1 (form &optional env)
547     "Call the compiler-macro for form.
548     If FORM is a function call for which a compiler-macro has been
549     defined, invoke the expander function using *macroexpand-hook* and
550     return the results and T. Otherwise, return the original form and
551     NIL."
552     (let ((fun (and (consp form) (compiler-macro-function (car form)))))
553     (if fun
554     (let ((result (funcall *macroexpand-hook* fun form env)))
555     (values result (not (eq result form))))
556     (values form nil))))
557    
558     (definterface compiler-macroexpand (form &optional env)
559     "Repetitively call `compiler-macroexpand-1'."
560     (labels ((frob (form expanded)
561     (multiple-value-bind (new-form newly-expanded)
562     (compiler-macroexpand-1 form env)
563     (if newly-expanded
564     (frob new-form t)
565     (values new-form expanded)))))
566     (frob form env)))
567    
568 lgorrie 1.21 (definterface describe-symbol-for-emacs (symbol)
569 lgorrie 1.1 "Return a property list describing SYMBOL.
570    
571     The property list has an entry for each interesting aspect of the
572     symbol. The recognised keys are:
573    
574 heller 1.86 :VARIABLE :FUNCTION :SETF :SPECIAL-OPERATOR :MACRO :COMPILER-MACRO
575     :TYPE :CLASS :ALIEN-TYPE :ALIEN-STRUCT :ALIEN-UNION :ALIEN-ENUM
576 lgorrie 1.1
577     The value of each property is the corresponding documentation string,
578 heller 1.86 or :NOT-DOCUMENTED. It is legal to include keys not listed here (but
579     slime-print-apropos in Emacs must know about them).
580 lgorrie 1.1
581     Properties should be included if and only if they are applicable to
582     the symbol. For example, only (and all) fbound symbols should include
583     the :FUNCTION property.
584    
585     Example:
586     \(describe-symbol-for-emacs 'vector)
587     => (:CLASS :NOT-DOCUMENTED
588     :TYPE :NOT-DOCUMENTED
589 lgorrie 1.21 :FUNCTION \"Constructs a simple-vector from the given objects.\")")
590    
591     (definterface describe-definition (name type)
592     "Describe the definition NAME of TYPE.
593     TYPE can be any value returned by DESCRIBE-SYMBOL-FOR-EMACS.
594    
595     Return a documentation string, or NIL if none is available.")
596 lgorrie 1.2
597    
598     ;;;; Debugging
599    
600 heller 1.92 (definterface install-debugger-globally (function)
601     "Install FUNCTION as the debugger for all threads/processes. This
602     usually involves setting *DEBUGGER-HOOK* and, if the implementation
603     permits, hooking into BREAK as well."
604     (setq *debugger-hook* function))
605    
606 lgorrie 1.21 (definterface call-with-debugging-environment (debugger-loop-fn)
607 lgorrie 1.2 "Call DEBUGGER-LOOP-FN in a suitable debugging environment.
608    
609     This function is called recursively at each debug level to invoke the
610     debugger loop. The purpose is to setup any necessary environment for
611     other debugger callbacks that will be called within the debugger loop.
612    
613     For example, this is a reasonable place to compute a backtrace, switch
614 lgorrie 1.21 to safe reader/printer settings, and so on.")
615 lgorrie 1.2
616 heller 1.80 (definterface call-with-debugger-hook (hook fun)
617     "Call FUN and use HOOK as debugger hook.
618    
619     HOOK should be called for both BREAK and INVOKE-DEBUGGER."
620     (let ((*debugger-hook* hook))
621     (funcall fun)))
622    
623 lgorrie 1.2 (define-condition sldb-condition (condition)
624     ((original-condition
625     :initarg :original-condition
626 heller 1.5 :accessor original-condition))
627 heller 1.63 (:report (lambda (condition stream)
628     (format stream "Condition in debugger code~@[: ~A~]"
629     (original-condition condition))))
630 lgorrie 1.2 (:documentation
631     "Wrapper for conditions that should not be debugged.
632    
633     When a condition arises from the internals of the debugger, it is not
634     desirable to debug it -- we'd risk entering an endless loop trying to
635     debug the debugger! Instead, such conditions can be reported to the
636     user without (re)entering the debugger by wrapping them as
637     `sldb-condition's."))
638    
639 heller 1.36 (definterface compute-backtrace (start end)
640 lgorrie 1.3 "Return a list containing a backtrace of the condition current
641     being debugged. The results are unspecified if this function is
642 heller 1.36 called outside the dynamic contour CALL-WITH-DEBUGGING-ENVIRONMENT.
643    
644     START and END are zero-based indices constraining the number of frames
645     returned. Frame zero is defined as the frame which invoked the
646     debugger. If END is nil, return the frames from START to the end of
647     the stack.")
648 lgorrie 1.3
649 mbaringer 1.116 (definterface compute-sane-restarts (condition)
650     "This is an opportunity for Lisps such as CLISP to remove
651     unwanted restarts from the output of CL:COMPUTE-RESTARTS,
652     otherwise it should simply call CL:COMPUTE-RESTARTS, which is
653     what the default implementation does."
654     (compute-restarts condition))
655    
656 heller 1.36 (definterface print-frame (frame stream)
657     "Print frame to stream.")
658 heller 1.70
659 lgorrie 1.21 (definterface frame-source-location-for-emacs (frame-number)
660     "Return the source location for FRAME-NUMBER.")
661 lgorrie 1.3
662 lgorrie 1.21 (definterface frame-catch-tags (frame-number)
663 lgorrie 1.3 "Return a list of XXX list of what? catch tags for a debugger
664     stack frame. The results are undefined unless this is called
665     within the dynamic contour of a function defined by
666 lgorrie 1.21 DEFINE-DEBUGGER-HOOK.")
667 lgorrie 1.3
668 lgorrie 1.21 (definterface frame-locals (frame-number)
669 heller 1.57 "Return a list of XXX local variable designators define me
670 lgorrie 1.3 for a debugger stack frame. The results are undefined unless
671     this is called within the dynamic contour of a function defined
672 lgorrie 1.21 by DEFINE-DEBUGGER-HOOK.")
673 heller 1.37
674 heller 1.57 (definterface frame-var-value (frame var)
675     "Return the value of VAR in FRAME.
676     FRAME is the number of the frame in the backtrace.
677     VAR is the number of the variable in the frame.")
678    
679 heller 1.37 (definterface disassemble-frame (frame-number)
680     "Disassemble the code for the FRAME-NUMBER.
681     The output should be written to standard output.
682 heller 1.84 FRAME-NUMBER is a non-negative integer.")
683 heller 1.37
684 lgorrie 1.21 (definterface eval-in-frame (form frame-number)
685 lgorrie 1.3 "Evaluate a Lisp form in the lexical context of a stack frame
686     in the debugger. The results are undefined unless called in the
687     dynamic contour of a function defined by DEFINE-DEBUGGER-HOOK.
688    
689     FRAME-NUMBER must be a positive integer with 0 indicating the
690     frame which invoked the debugger.
691    
692     The return value is the result of evaulating FORM in the
693 lgorrie 1.21 appropriate context.")
694 heller 1.22
695     (definterface return-from-frame (frame-number form)
696     "Unwind the stack to the frame FRAME-NUMBER and return the value(s)
697     produced by evaluating FORM in the frame context to its caller.
698    
699     Execute any clean-up code from unwind-protect forms above the frame
700     during unwinding.
701    
702     Return a string describing the error if it's not possible to return
703     from the frame.")
704    
705     (definterface restart-frame (frame-number)
706     "Restart execution of the frame FRAME-NUMBER with the same arguments
707     as it was called originally.")
708 lgorrie 1.3
709 lgorrie 1.49 (definterface format-sldb-condition (condition)
710     "Format a condition for display in SLDB."
711     (princ-to-string condition))
712    
713     (definterface condition-references (condition)
714     "Return a list of documentation references for a condition.
715     Each reference is one of:
716     (:ANSI-CL
717     {:FUNCTION | :SPECIAL-OPERATOR | :MACRO | :SECTION | :GLOSSARY }
718     symbol-or-name)
719     (:SBCL :NODE node-name)"
720 mbaringer 1.73 (declare (ignore condition))
721 lgorrie 1.49 '())
722 heller 1.52
723 heller 1.69 (definterface condition-extras (condition)
724     "Return a list of extra for the debugger.
725     The allowed elements are of the form:
726     (:SHOW-FRAME-SOURCE frame-number)"
727 mbaringer 1.73 (declare (ignore condition))
728 heller 1.69 '())
729    
730 heller 1.71 (definterface activate-stepping (frame-number)
731     "Prepare the frame FRAME-NUMBER for stepping.")
732 heller 1.69
733     (definterface sldb-break-on-return (frame-number)
734     "Set a breakpoint in the frame FRAME-NUMBER.")
735    
736     (definterface sldb-break-at-start (symbol)
737     "Set a breakpoint on the beginning of the function for SYMBOL.")
738 heller 1.52
739 jsnellman 1.103 (definterface sldb-stepper-condition-p (condition)
740     "Return true if SLDB was invoked due to a single-stepping condition,
741     false otherwise. "
742     (declare (ignore condition))
743     nil)
744    
745     (definterface sldb-step-into ()
746     "Step into the current single-stepper form.")
747    
748     (definterface sldb-step-next ()
749     "Step to the next form in the current function.")
750    
751     (definterface sldb-step-out ()
752     "Stop single-stepping temporarily, but resume it once the current function
753     returns.")
754 lgorrie 1.49
755 lgorrie 1.3
756 heller 1.36 ;;;; Definition finding
757    
758     (defstruct (:location (:type list) :named
759 lgorrie 1.45 (:constructor make-location
760     (buffer position &optional hints)))
761     buffer position
762     ;; Hints is a property list optionally containing:
763     ;; :snippet SOURCE-TEXT
764     ;; This is a snippet of the actual source text at the start of
765     ;; the definition, which could be used in a text search.
766     hints)
767 heller 1.36
768     (defstruct (:error (:type list) :named (:constructor)) message)
769     (defstruct (:file (:type list) :named (:constructor)) name)
770     (defstruct (:buffer (:type list) :named (:constructor)) name)
771     (defstruct (:position (:type list) :named (:constructor)) pos)
772    
773     (definterface find-definitions (name)
774     "Return a list ((DSPEC LOCATION) ...) for NAME's definitions.
775    
776 heller 1.38 NAME is a \"definition specifier\".
777 heller 1.36
778 heller 1.38 DSPEC is a \"definition specifier\" describing the
779 heller 1.36 definition, e.g., FOO or (METHOD FOO (STRING NUMBER)) or
780 heller 1.38 \(DEFVAR FOO).
781    
782     LOCATION is the source location for the definition.")
783 heller 1.36
784 lgorrie 1.61 (definterface buffer-first-change (filename)
785     "Called for effect the first time FILENAME's buffer is modified."
786 mbaringer 1.73 (declare (ignore filename))
787 lgorrie 1.61 nil)
788    
789 heller 1.36
790     ;;;; XREF
791    
792     (definterface who-calls (function-name)
793     "Return the call sites of FUNCTION-NAME (a symbol).
794     The results is a list ((DSPEC LOCATION) ...).")
795    
796 heller 1.81 (definterface calls-who (function-name)
797     "Return the call sites of FUNCTION-NAME (a symbol).
798     The results is a list ((DSPEC LOCATION) ...).")
799    
800 heller 1.36 (definterface who-references (variable-name)
801     "Return the locations where VARIABLE-NAME (a symbol) is referenced.
802     See WHO-CALLS for a description of the return value.")
803    
804     (definterface who-binds (variable-name)
805     "Return the locations where VARIABLE-NAME (a symbol) is bound.
806     See WHO-CALLS for a description of the return value.")
807    
808     (definterface who-sets (variable-name)
809     "Return the locations where VARIABLE-NAME (a symbol) is set.
810     See WHO-CALLS for a description of the return value.")
811    
812     (definterface who-macroexpands (macro-name)
813     "Return the locations where MACRO-NAME (a symbol) is expanded.
814     See WHO-CALLS for a description of the return value.")
815    
816     (definterface who-specializes (class-name)
817     "Return the locations where CLASS-NAME (a symbol) is specialized.
818     See WHO-CALLS for a description of the return value.")
819    
820     ;;; Simpler variants.
821    
822     (definterface list-callers (function-name)
823     "List the callers of FUNCTION-NAME.
824     This function is like WHO-CALLS except that it is expected to use
825     lower-level means. Whereas WHO-CALLS is usually implemented with
826     special compiler support, LIST-CALLERS is usually implemented by
827     groveling for constants in function objects throughout the heap.
828    
829     The return value is as for WHO-CALLS.")
830    
831     (definterface list-callees (function-name)
832     "List the functions called by FUNCTION-NAME.
833     See LIST-CALLERS for a description of the return value.")
834    
835    
836 heller 1.23 ;;;; Profiling
837    
838     ;;; The following functions define a minimal profiling interface.
839    
840     (definterface profile (fname)
841     "Marks symbol FNAME for profiling.")
842    
843     (definterface profiled-functions ()
844     "Returns a list of profiled functions.")
845    
846     (definterface unprofile (fname)
847     "Marks symbol FNAME as not profiled.")
848    
849     (definterface unprofile-all ()
850     "Marks all currently profiled functions as not profiled."
851     (dolist (f (profiled-functions))
852     (unprofile f)))
853    
854     (definterface profile-report ()
855     "Prints profile report.")
856    
857     (definterface profile-reset ()
858     "Resets profile counters.")
859    
860     (definterface profile-package (package callers-p methods)
861     "Wrap profiling code around all functions in PACKAGE. If a function
862     is already profiled, then unprofile and reprofile (useful to notice
863     function redefinition.)
864    
865     If CALLERS-P is T names have counts of the most common calling
866     functions recorded.
867    
868     When called with arguments :METHODS T, profile all methods of all
869     generic functions having names in the given package. Generic functions
870     themselves, that is, their dispatch functions, are left alone.")
871    
872    
873 heller 1.19 ;;;; Inspector
874 lgorrie 1.56
875 mbaringer 1.67 (defclass inspector ()
876     ()
877     (:documentation "Super class of inspector objects.
878    
879     Implementations should sub class in order to dispatch off of the
880     inspect-for-emacs method."))
881    
882 heller 1.121 (defclass backend-inspector (inspector) ())
883    
884 mbaringer 1.67 (definterface make-default-inspector ()
885     "Return an inspector object suitable for passing to inspect-for-emacs.")
886    
887 heller 1.99 (defgeneric inspect-for-emacs (object inspector)
888 heller 1.100 (:documentation
889 heller 1.86 "Explain to Emacs how to inspect OBJECT.
890 mbaringer 1.67
891     The argument INSPECTOR is an object representing how to get at
892     the internals of OBJECT, it is usually an implementation specific
893     class used simply for dispatching to the proper method.
894    
895     Returns two values: a string which will be used as the title of
896     the inspector buffer and a list specifying how to render the
897     object for inspection.
898    
899 lgorrie 1.83 Every element of the list must be either a string, which will be
900 mbaringer 1.67 inserted into the buffer as is, or a list of the form:
901    
902     (:value object &optional format) - Render an inspectable
903     object. If format is provided it must be a string and will be
904     rendered in place of the value, otherwise use princ-to-string.
905    
906     (:newline) - Render a \\n
907    
908 mbaringer 1.117 (:action label lambda &key (refresh t)) - Render LABEL (a text
909     string) which when clicked will call LAMBDA. If REFRESH is
910     non-NIL the currently inspected object will be re-inspected
911     after calling the lambda.
912 mbaringer 1.67
913 heller 1.100 NIL - do nothing."))
914 mbaringer 1.67
915 mbaringer 1.73 (defmethod inspect-for-emacs ((object t) (inspector t))
916 mbaringer 1.67 "Generic method for inspecting any kind of object.
917    
918     Since we don't know how to deal with OBJECT we simply dump the
919     output of CL:DESCRIBE."
920 mbaringer 1.73 (declare (ignore inspector))
921 heller 1.86 (values
922     "A value."
923     `("Type: " (:value ,(type-of object)) (:newline)
924     "Don't know how to inspect the object, dumping output of CL:DESCRIBE:"
925     (:newline) (:newline)
926     ,(with-output-to-string (desc) (describe object desc)))))
927 heller 1.70
928 heller 1.84 ;;; Utilities for inspector methods.
929 heller 1.70 ;;;
930 mbaringer 1.118 (defun label-value-line (label value &key (newline t))
931     "Create a control list which prints \"LABEL: VALUE\" in the inspector.
932     If NEWLINE is non-NIL a `(:newline)' is added to the result."
933     (list* (princ-to-string label) ": " `(:value ,value)
934     (if newline '((:newline)) nil)))
935 heller 1.70
936     (defmacro label-value-line* (&rest label-values)
937     ` (append ,@(loop for (label value) in label-values
938     collect `(label-value-line ,label ,value))))
939 heller 1.19
940 heller 1.29 (definterface describe-primitive-type (object)
941 heller 1.35 "Return a string describing the primitive type of object."
942 heller 1.36 (declare (ignore object))
943 heller 1.35 "N/A")
944 heller 1.19
945    
946 heller 1.36 ;;;; Multithreading
947 lgorrie 1.21 ;;;
948     ;;; The default implementations are sufficient for non-multiprocessing
949     ;;; implementations.
950 lgorrie 1.9
951 mbaringer 1.106 (definterface initialize-multiprocessing (continuation)
952 heller 1.107 "Initialize multiprocessing, if necessary and then invoke CONTINUATION.
953    
954     Depending on the impleimentaion, this function may never return."
955 mbaringer 1.106 (funcall continuation))
956 lgorrie 1.9
957 lgorrie 1.21 (definterface spawn (fn &key name)
958     "Create a new thread to call FN.")
959 lgorrie 1.17
960 heller 1.58 (definterface thread-id (thread)
961     "Return an Emacs-parsable object to identify THREAD.
962    
963     Ids should be comparable with equal, i.e.:
964     (equal (thread-id <t1>) (thread-id <t2>)) <==> (eq <t1> <t2>)")
965    
966     (definterface find-thread (id)
967     "Return the thread for ID.
968     ID should be an id previously obtained with THREAD-ID.
969     Can return nil if the thread no longer exists.")
970    
971 heller 1.28 (definterface thread-name (thread)
972     "Return the name of THREAD.
973 lgorrie 1.9
974     Thread names are be single-line strings and are meaningful to the
975 lgorrie 1.21 user. They do not have to be unique."
976 heller 1.28 (declare (ignore thread))
977 lgorrie 1.21 "The One True Thread")
978 lgorrie 1.9
979 heller 1.28 (definterface thread-status (thread)
980     "Return a string describing THREAD's state."
981     (declare (ignore thread))
982     "")
983    
984 lgorrie 1.21 (definterface make-lock (&key name)
985 lgorrie 1.17 "Make a lock for thread synchronization.
986 lgorrie 1.21 Only one thread may hold the lock (via CALL-WITH-LOCK-HELD) at a time."
987 heller 1.23 (declare (ignore name))
988 lgorrie 1.21 :null-lock)
989 lgorrie 1.9
990 lgorrie 1.21 (definterface call-with-lock-held (lock function)
991     "Call FUNCTION with LOCK held, queueing if necessary."
992 heller 1.24 (declare (ignore lock)
993     (type function function))
994 lgorrie 1.21 (funcall function))
995 heller 1.25
996 nsiivola 1.98 (definterface make-recursive-lock (&key name)
997     "Make a lock for thread synchronization.
998     Only one thread may hold the lock (via CALL-WITH-RECURSIVE-LOCK-HELD)
999     at a time, but that thread may hold it more than once."
1000     (cons nil (make-lock :name name)))
1001    
1002     (definterface call-with-recursive-lock-held (lock function)
1003     "Call FUNCTION with LOCK held, queueing if necessary."
1004     (if (eql (car lock) (current-thread))
1005     (funcall function)
1006     (call-with-lock-held (cdr lock)
1007     (lambda ()
1008     (unwind-protect
1009     (progn
1010     (setf (car lock) (current-thread))
1011     (funcall function))
1012     (setf (car lock) nil))))))
1013    
1014 heller 1.25 (definterface current-thread ()
1015     "Return the currently executing thread."
1016     0)
1017 heller 1.28
1018     (definterface all-threads ()
1019     "Return a list of all threads.")
1020    
1021     (definterface thread-alive-p (thread)
1022 heller 1.35 "Test if THREAD is termintated."
1023     (member thread (all-threads)))
1024 heller 1.25
1025     (definterface interrupt-thread (thread fn)
1026     "Cause THREAD to execute FN.")
1027    
1028 mbaringer 1.34 (definterface kill-thread (thread)
1029     "Kill THREAD."
1030     (declare (ignore thread))
1031     nil)
1032    
1033 heller 1.25 (definterface send (thread object)
1034     "Send OBJECT to thread THREAD.")
1035    
1036     (definterface receive ()
1037 heller 1.84 "Return the next message from current thread's mailbox.")
1038 mbaringer 1.78
1039 heller 1.81 (definterface toggle-trace (spec)
1040     "Toggle tracing of the function(s) given with SPEC.
1041     SPEC can be:
1042     (setf NAME) ; a setf function
1043     (:defmethod NAME QUALIFIER... (SPECIALIZER...)) ; a specific method
1044     (:defgeneric NAME) ; a generic function with all methods
1045     (:call CALLER CALLEE) ; trace calls from CALLER to CALLEE.
1046     (:labels TOPLEVEL LOCAL)
1047     (:flet TOPLEVEL LOCAL) ")
1048 mkoeppe 1.87
1049    
1050     ;;;; Weak datastructures
1051    
1052     (definterface make-weak-key-hash-table (&rest args)
1053     "Like MAKE-HASH-TABLE, but weak w.r.t. the keys."
1054     (apply #'make-hash-table args))
1055    
1056     (definterface make-weak-value-hash-table (&rest args)
1057     "Like MAKE-HASH-TABLE, but weak w.r.t. the values."
1058     (apply #'make-hash-table args))
1059 mkoeppe 1.108
1060 alendvai 1.113 (definterface hash-table-weakness (hashtable)
1061     "Return nil or one of :key :value :key-or-value :key-and-value"
1062     (declare (ignore hashtable))
1063     nil)
1064    
1065 mkoeppe 1.108
1066     ;;;; Character names
1067    
1068     (definterface character-completion-set (prefix matchp)
1069     "Return a list of names of characters that match PREFIX."
1070     ;; Handle the standard and semi-standard characters.
1071     (loop for name in '("Newline" "Space" "Tab" "Page" "Rubout"
1072     "Linefeed" "Return" "Backspace")
1073     when (funcall matchp prefix name)
1074     collect name))
1075    
1076 trittweiler 1.120
1077     (defparameter *type-specifier-arglists*
1078     '((and . (&rest type-specifiers))
1079     (array . (&optional element-type dimension-spec))
1080     (base-string . (&optional size))
1081     (bit-vector . (&optional size))
1082     (complex . (&optional type-specifier))
1083     (cons . (&optional car-typespec cdr-typespec))
1084     (double-float . (&optional lower-limit upper-limit))
1085     (eql . (object))
1086     (float . (&optional lower-limit upper-limit))
1087     (function . (&optional arg-typespec value-typespec))
1088     (integer . (&optional lower-limit upper-limit))
1089     (long-float . (&optional lower-limit upper-limit))
1090     (member . (&rest eql-objects))
1091     (mod . (n))
1092     (not . (type-specifier))
1093     (or . (&rest type-specifiers))
1094     (rational . (&optional lower-limit upper-limit))
1095     (real . (&optional lower-limit upper-limit))
1096     (satisfies . (predicate-symbol))
1097     (short-float . (&optional lower-limit upper-limit))
1098     (signed-byte . (&optional size))
1099     (simple-array . (&optional element-type dimension-spec))
1100     (simple-base-string . (&optional size))
1101     (simple-bit-vector . (&optional size))
1102     (simple-string . (&optional size))
1103     (single-float . (&optional lower-limit upper-limit))
1104     (simple-vector . (&optional size))
1105     (string . (&optional size))
1106     (unsigned-byte . (&optional size))
1107     (values . (&rest typespecs))
1108     (vector . (&optional element-type size))
1109 heller 1.121 ))

  ViewVC Help
Powered by ViewVC 1.1.5