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

Contents of /slime/swank-backend.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5