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

Contents of /slime/swank-backend.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.129 - (show annotations)
Sat Feb 9 18:47:05 2008 UTC (6 years, 2 months ago) by heller
Branch: MAIN
Changes since 1.128: +3 -8 lines
Drop the first return value of emacs-inspect.

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

  ViewVC Help
Powered by ViewVC 1.1.5