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

Contents of /slime/swank-backend.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5