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

Contents of /slime/swank-backend.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5