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

Contents of /slime/swank-backend.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5