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

Contents of /slime/swank-backend.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5