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

Contents of /slime/swank-backend.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5