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

Contents of /slime/swank-backend.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5