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

Contents of /slime/swank-backend.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5