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

Contents of /slime/swank-backend.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5