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

Contents of /slime/swank-backend.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.161 - (show annotations)
Sun Oct 19 20:03:44 2008 UTC (5 years, 5 months ago) by heller
Branch: MAIN
Changes since 1.160: +1 -0 lines
(frame-restartable-p): Add ignore decl.
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 #:with-compilation-hooks
23 #:location
24 #:location-p
25 #:location-buffer
26 #:location-position
27 #:position-p
28 #:position-pos
29 #:print-output-to-string
30 #:quit-lisp
31 #:references
32 #:unbound-slot-filler
33 #:declaration-arglist
34 #:type-specifier-arglist
35 ;; interrupt macro for the backend
36 #:*pending-slime-interrupts*
37 #:check-slime-interrupts
38 ;; inspector related symbols
39 #:emacs-inspect
40 #:label-value-line
41 #:label-value-line*
42
43 #:with-struct
44 ))
45
46 (defpackage :swank-mop
47 (:use)
48 (:export
49 ;; classes
50 #:standard-generic-function
51 #:standard-slot-definition
52 #:standard-method
53 #:standard-class
54 #:eql-specializer
55 #:eql-specializer-object
56 ;; standard-class readers
57 #:class-default-initargs
58 #:class-direct-default-initargs
59 #:class-direct-slots
60 #:class-direct-subclasses
61 #:class-direct-superclasses
62 #:class-finalized-p
63 #:class-name
64 #:class-precedence-list
65 #:class-prototype
66 #:class-slots
67 #:specializer-direct-methods
68 ;; generic function readers
69 #:generic-function-argument-precedence-order
70 #:generic-function-declarations
71 #:generic-function-lambda-list
72 #:generic-function-methods
73 #:generic-function-method-class
74 #:generic-function-method-combination
75 #:generic-function-name
76 ;; method readers
77 #:method-generic-function
78 #:method-function
79 #:method-lambda-list
80 #:method-specializers
81 #:method-qualifiers
82 ;; slot readers
83 #:slot-definition-allocation
84 #:slot-definition-documentation
85 #:slot-definition-initargs
86 #:slot-definition-initform
87 #:slot-definition-initfunction
88 #:slot-definition-name
89 #:slot-definition-type
90 #:slot-definition-readers
91 #:slot-definition-writers
92 #:slot-boundp-using-class
93 #:slot-value-using-class
94 #:slot-makunbound-using-class
95 ;; generic function protocol
96 #:compute-applicable-methods-using-classes
97 #:finalize-inheritance))
98
99 (in-package :swank-backend)
100
101
102 ;;;; Metacode
103
104 (defparameter *interface-functions* '()
105 "The names of all interface functions.")
106
107 (defparameter *unimplemented-interfaces* '()
108 "List of interface functions that are not implemented.
109 DEFINTERFACE adds to this list and DEFIMPLEMENTATION removes.")
110
111 (defmacro definterface (name args documentation &rest default-body)
112 "Define an interface function for the backend to implement.
113 A function is defined with NAME, ARGS, and DOCUMENTATION. This
114 function first looks for a function to call in NAME's property list
115 that is indicated by 'IMPLEMENTATION; failing that, it looks for a
116 function indicated by 'DEFAULT. If neither is present, an error is
117 signaled.
118
119 If a DEFAULT-BODY is supplied, then a function with the same body and
120 ARGS will be added to NAME's property list as the property indicated
121 by 'DEFAULT.
122
123 Backends implement these functions using DEFIMPLEMENTATION."
124 (check-type documentation string "a documentation string")
125 (assert (every #'symbolp args) ()
126 "Complex lambda-list not supported: ~S ~S" name args)
127 (labels ((gen-default-impl ()
128 `(setf (get ',name 'default) (lambda ,args ,@default-body)))
129 (args-as-list (args)
130 (destructuring-bind (req opt key rest) (parse-lambda-list args)
131 `(,@req ,@opt
132 ,@(loop for k in key append `(,(kw k) ,k))
133 ,@(or rest '(())))))
134 (parse-lambda-list (args)
135 (parse args '(&optional &key &rest)
136 (make-array 4 :initial-element nil)))
137 (parse (args keywords vars)
138 (cond ((null args)
139 (reverse (map 'list #'reverse vars)))
140 ((member (car args) keywords)
141 (parse (cdr args) (cdr (member (car args) keywords)) vars))
142 (t (push (car args) (aref vars (length keywords)))
143 (parse (cdr args) keywords vars))))
144 (kw (s) (intern (string s) :keyword)))
145 `(progn
146 (defun ,name ,args
147 ,documentation
148 (let ((f (or (get ',name 'implementation)
149 (get ',name 'default))))
150 (cond (f (apply f ,@(args-as-list args)))
151 (t (error "~S not implementated" ',name)))))
152 (pushnew ',name *interface-functions*)
153 ,(if (null default-body)
154 `(pushnew ',name *unimplemented-interfaces*)
155 (gen-default-impl))
156 ;; see <http://www.franz.com/support/documentation/6.2/doc/pages/variables/compiler/s_cltl1-compile-file-toplevel-compatibility-p_s.htm>
157 (eval-when (:compile-toplevel :load-toplevel :execute)
158 (export ',name :swank-backend))
159 ',name)))
160
161 (defmacro defimplementation (name args &body body)
162 (assert (every #'symbolp args) ()
163 "Complex lambda-list not supported: ~S ~S" name args)
164 `(progn
165 (setf (get ',name 'implementation) (lambda ,args ,@body))
166 (if (member ',name *interface-functions*)
167 (setq *unimplemented-interfaces*
168 (remove ',name *unimplemented-interfaces*))
169 (warn "DEFIMPLEMENTATION of undefined interface (~S)" ',name))
170 ',name))
171
172 (defun warn-unimplemented-interfaces ()
173 "Warn the user about unimplemented backend features.
174 The portable code calls this function at startup."
175 (warn "These Swank interfaces are unimplemented:~% ~A"
176 (sort (copy-list *unimplemented-interfaces*) #'string<)))
177
178 (defun import-to-swank-mop (symbol-list)
179 (dolist (sym symbol-list)
180 (let* ((swank-mop-sym (find-symbol (symbol-name sym) :swank-mop)))
181 (when swank-mop-sym
182 (unintern swank-mop-sym :swank-mop))
183 (import sym :swank-mop)
184 (export sym :swank-mop))))
185
186 (defun import-swank-mop-symbols (package except)
187 "Import the mop symbols from PACKAGE to SWANK-MOP.
188 EXCEPT is a list of symbol names which should be ignored."
189 (do-symbols (s :swank-mop)
190 (unless (member s except :test #'string=)
191 (let ((real-symbol (find-symbol (string s) package)))
192 (assert real-symbol () "Symbol ~A not found in package ~A" s package)
193 (unintern s :swank-mop)
194 (import real-symbol :swank-mop)
195 (export real-symbol :swank-mop)))))
196
197 (defvar *gray-stream-symbols*
198 '(:fundamental-character-output-stream
199 :stream-write-char
200 :stream-write-string
201 :stream-fresh-line
202 :stream-force-output
203 :stream-finish-output
204 :fundamental-character-input-stream
205 :stream-read-char
206 :stream-peek-char
207 :stream-read-line
208 ;; STREAM-FILE-POSITION is not available on all implementations, or
209 ;; partially under a different name.
210 ; :stream-file-posiion
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 install-sigint-handler (function)
311 "Call FUNCTION on SIGINT (instead of invoking the debugger).
312 Return old signal handler."
313 nil)
314
315 (definterface call-with-user-break-handler (handler function)
316 "Install the break handler HANDLER while executing FUNCTION."
317 (let ((old-handler (install-sigint-handler handler)))
318 (unwind-protect (funcall function)
319 (install-sigint-handler old-handler))))
320
321 (definterface quit-lisp ()
322 "Exit the current lisp image.")
323
324 (definterface lisp-implementation-type-name ()
325 "Return a short name for the Lisp implementation."
326 (lisp-implementation-type))
327
328
329 ;; pathnames are sooo useless
330
331 (definterface filename-to-pathname (filename)
332 "Return a pathname for FILENAME.
333 A filename in Emacs may for example contain asterisks which should not
334 be translated to wildcards."
335 (parse-namestring filename))
336
337 (definterface pathname-to-filename (pathname)
338 "Return the filename for PATHNAME."
339 (namestring pathname))
340
341 (definterface default-directory ()
342 "Return the default directory."
343 (directory-namestring (truename *default-pathname-defaults*)))
344
345 (definterface set-default-directory (directory)
346 "Set the default directory.
347 This is used to resolve filenames without directory component."
348 (setf *default-pathname-defaults* (truename (merge-pathnames directory)))
349 (default-directory))
350
351
352 (definterface call-with-syntax-hooks (fn)
353 "Call FN with hooks to handle special syntax."
354 (funcall fn))
355
356 (definterface default-readtable-alist ()
357 "Return a suitable initial value for SWANK:*READTABLE-ALIST*."
358 '())
359
360
361 ;;;; Compilation
362
363 (definterface call-with-compilation-hooks (func)
364 "Call FUNC with hooks to record compiler conditions.")
365
366 (defmacro with-compilation-hooks ((&rest ignore) &body body)
367 "Execute BODY as in CALL-WITH-COMPILATION-HOOKS."
368 (declare (ignore ignore))
369 `(call-with-compilation-hooks (lambda () (progn ,@body))))
370
371 (definterface swank-compile-string (string &key buffer position directory
372 debug)
373 "Compile source from STRING.
374 During compilation, compiler conditions must be trapped and
375 resignalled as COMPILER-CONDITIONs.
376
377 If supplied, BUFFER and POSITION specify the source location in Emacs.
378
379 Additionally, if POSITION is supplied, it must be added to source
380 positions reported in compiler conditions.
381
382 If DIRECTORY is specified it may be used by certain implementations to
383 rebind *DEFAULT-PATHNAME-DEFAULTS* which may improve the recording of
384 source information.
385
386 If DEBUG is supplied, and non-NIL, it may be used by certain
387 implementations to compile with a debug optimization quality of its
388 value.
389
390 Should return T on successfull compilation, NIL otherwise.
391 ")
392
393 (definterface swank-compile-file (pathname load-p external-format)
394 "Compile PATHNAME signalling COMPILE-CONDITIONs.
395 If LOAD-P is true, load the file after compilation.
396 EXTERNAL-FORMAT is a value returned by find-external-format or
397 :default.
398
399 Should return OUTPUT-TRUENAME, WARNINGS-P and FAILURE-p
400 like `compile-file'")
401
402 (deftype severity ()
403 '(member :error :read-error :warning :style-warning :note))
404
405 ;; Base condition type for compiler errors, warnings and notes.
406 (define-condition compiler-condition (condition)
407 ((original-condition
408 ;; The original condition thrown by the compiler if appropriate.
409 ;; May be NIL if a compiler does not report using conditions.
410 :type (or null condition)
411 :initarg :original-condition
412 :accessor original-condition)
413
414 (severity :type severity
415 :initarg :severity
416 :accessor severity)
417
418 (message :initarg :message
419 :accessor message)
420
421 (short-message :initarg :short-message
422 :initform nil
423 :accessor short-message)
424
425 (references :initarg :references
426 :initform nil
427 :accessor references)
428
429 (location :initarg :location
430 :accessor location)))
431
432 (definterface find-external-format (coding-system)
433 "Return a \"external file format designator\" for CODING-SYSTEM.
434 CODING-SYSTEM is Emacs-style coding system name (a string),
435 e.g. \"latin-1-unix\"."
436 (if (equal coding-system "iso-latin-1-unix")
437 :default
438 nil))
439
440 (definterface guess-external-format (pathname)
441 "Detect the external format for the file with name pathname.
442 Return nil if the file contains no special markers."
443 ;; Look for a Emacs-style -*- coding: ... -*- or Local Variable: section.
444 (with-open-file (s pathname :if-does-not-exist nil
445 :external-format (or (find-external-format "latin-1-unix")
446 :default))
447 (if s
448 (or (let* ((line (read-line s nil))
449 (p (search "-*-" line)))
450 (when p
451 (let* ((start (+ p (length "-*-")))
452 (end (search "-*-" line :start2 start)))
453 (when end
454 (%search-coding line start end)))))
455 (let* ((len (file-length s))
456 (buf (make-string (min len 3000))))
457 (file-position s (- len (length buf)))
458 (read-sequence buf s)
459 (let ((start (search "Local Variables:" buf :from-end t))
460 (end (search "End:" buf :from-end t)))
461 (and start end (< start end)
462 (%search-coding buf start end))))))))
463
464 (defun %search-coding (str start end)
465 (let ((p (search "coding:" str :start2 start :end2 end)))
466 (when p
467 (incf p (length "coding:"))
468 (loop while (and (< p end)
469 (member (aref str p) '(#\space #\tab)))
470 do (incf p))
471 (let ((end (position-if (lambda (c) (find c '(#\space #\tab #\newline)))
472 str :start p)))
473 (find-external-format (subseq str p end))))))
474
475
476 ;;;; Streams
477
478 (definterface make-output-stream (write-string)
479 "Return a new character output stream.
480 The stream calls WRITE-STRING when output is ready.")
481
482 (definterface make-input-stream (read-string)
483 "Return a new character input stream.
484 The stream calls READ-STRING when input is needed.")
485
486
487 ;;;; Documentation
488
489 (definterface arglist (name)
490 "Return the lambda list for the symbol NAME. NAME can also be
491 a lisp function object, on lisps which support this.
492
493 The result can be a list or the :not-available keyword if the
494 arglist cannot be determined."
495 (declare (ignore name))
496 :not-available)
497
498 (defgeneric declaration-arglist (decl-identifier)
499 (:documentation
500 "Return the argument list of the declaration specifier belonging to the
501 declaration identifier DECL-IDENTIFIER. If the arglist cannot be determined,
502 the keyword :NOT-AVAILABLE is returned.
503
504 The different SWANK backends can specialize this generic function to
505 include implementation-dependend declaration specifiers, or to provide
506 additional information on the specifiers defined in ANSI Common Lisp.")
507 (:method (decl-identifier)
508 (case decl-identifier
509 (dynamic-extent '(&rest vars))
510 (ignore '(&rest vars))
511 (ignorable '(&rest vars))
512 (special '(&rest vars))
513 (inline '(&rest function-names))
514 (notinline '(&rest function-name))
515 (optimize '(&any compilation-speed debug safety space speed))
516 (type '(type-specifier &rest args))
517 (ftype '(type-specifier &rest function-names))
518 (otherwise
519 (flet ((typespec-p (symbol) (member :type (describe-symbol-for-emacs symbol))))
520 (cond ((and (symbolp decl-identifier) (typespec-p decl-identifier))
521 '(&rest vars))
522 ((and (listp decl-identifier) (typespec-p (first decl-identifier)))
523 '(&rest vars))
524 (t :not-available)))))))
525
526 (defgeneric type-specifier-arglist (typespec-operator)
527 (:documentation
528 "Return the argument list of the type specifier belonging to
529 TYPESPEC-OPERATOR.. If the arglist cannot be determined, the keyword
530 :NOT-AVAILABLE is returned.
531
532 The different SWANK backends can specialize this generic function to
533 include implementation-dependend declaration specifiers, or to provide
534 additional information on the specifiers defined in ANSI Common Lisp.")
535 (:method (typespec-operator)
536 (declare (special *type-specifier-arglists*)) ; defined at end of file.
537 (typecase typespec-operator
538 (symbol (or (cdr (assoc typespec-operator *type-specifier-arglists*))
539 :not-available))
540 (t :not-available))))
541
542 (definterface function-name (function)
543 "Return the name of the function object FUNCTION.
544
545 The result is either a symbol, a list, or NIL if no function name is available."
546 (declare (ignore function))
547 nil)
548
549 (definterface macroexpand-all (form)
550 "Recursively expand all macros in FORM.
551 Return the resulting form.")
552
553 (definterface compiler-macroexpand-1 (form &optional env)
554 "Call the compiler-macro for form.
555 If FORM is a function call for which a compiler-macro has been
556 defined, invoke the expander function using *macroexpand-hook* and
557 return the results and T. Otherwise, return the original form and
558 NIL."
559 (let ((fun (and (consp form) (compiler-macro-function (car form)))))
560 (if fun
561 (let ((result (funcall *macroexpand-hook* fun form env)))
562 (values result (not (eq result form))))
563 (values form nil))))
564
565 (definterface compiler-macroexpand (form &optional env)
566 "Repetitively call `compiler-macroexpand-1'."
567 (labels ((frob (form expanded)
568 (multiple-value-bind (new-form newly-expanded)
569 (compiler-macroexpand-1 form env)
570 (if newly-expanded
571 (frob new-form t)
572 (values new-form expanded)))))
573 (frob form env)))
574
575 (definterface describe-symbol-for-emacs (symbol)
576 "Return a property list describing SYMBOL.
577
578 The property list has an entry for each interesting aspect of the
579 symbol. The recognised keys are:
580
581 :VARIABLE :FUNCTION :SETF :SPECIAL-OPERATOR :MACRO :COMPILER-MACRO
582 :TYPE :CLASS :ALIEN-TYPE :ALIEN-STRUCT :ALIEN-UNION :ALIEN-ENUM
583
584 The value of each property is the corresponding documentation string,
585 or :NOT-DOCUMENTED. It is legal to include keys not listed here (but
586 slime-print-apropos in Emacs must know about them).
587
588 Properties should be included if and only if they are applicable to
589 the symbol. For example, only (and all) fbound symbols should include
590 the :FUNCTION property.
591
592 Example:
593 \(describe-symbol-for-emacs 'vector)
594 => (:CLASS :NOT-DOCUMENTED
595 :TYPE :NOT-DOCUMENTED
596 :FUNCTION \"Constructs a simple-vector from the given objects.\")")
597
598 (definterface describe-definition (name type)
599 "Describe the definition NAME of TYPE.
600 TYPE can be any value returned by DESCRIBE-SYMBOL-FOR-EMACS.
601
602 Return a documentation string, or NIL if none is available.")
603
604
605 ;;;; Debugging
606
607 (definterface install-debugger-globally (function)
608 "Install FUNCTION as the debugger for all threads/processes. This
609 usually involves setting *DEBUGGER-HOOK* and, if the implementation
610 permits, hooking into BREAK as well."
611 (setq *debugger-hook* function))
612
613 (definterface call-with-debugging-environment (debugger-loop-fn)
614 "Call DEBUGGER-LOOP-FN in a suitable debugging environment.
615
616 This function is called recursively at each debug level to invoke the
617 debugger loop. The purpose is to setup any necessary environment for
618 other debugger callbacks that will be called within the debugger loop.
619
620 For example, this is a reasonable place to compute a backtrace, switch
621 to safe reader/printer settings, and so on.")
622
623 (definterface call-with-debugger-hook (hook fun)
624 "Call FUN and use HOOK as debugger hook.
625
626 HOOK should be called for both BREAK and INVOKE-DEBUGGER."
627 (let ((*debugger-hook* hook))
628 (funcall fun)))
629
630 (define-condition sldb-condition (condition)
631 ((original-condition
632 :initarg :original-condition
633 :accessor original-condition))
634 (:report (lambda (condition stream)
635 (format stream "Condition in debugger code~@[: ~A~]"
636 (original-condition condition))))
637 (:documentation
638 "Wrapper for conditions that should not be debugged.
639
640 When a condition arises from the internals of the debugger, it is not
641 desirable to debug it -- we'd risk entering an endless loop trying to
642 debug the debugger! Instead, such conditions can be reported to the
643 user without (re)entering the debugger by wrapping them as
644 `sldb-condition's."))
645
646 ;;; The following functions in this section are supposed to be called
647 ;;; within the dynamic contour of CALL-WITH-DEBUGGING-ENVIRONMENT only.
648
649 (definterface compute-backtrace (start end)
650 "Returns a backtrace of the condition currently being debugged,
651 that is an ordered list consisting of frames. ``Ordered list''
652 means that an integer I can be mapped back to the i-th frame of this
653 backtrace.
654
655 START and END are zero-based indices constraining the number of frames
656 returned. Frame zero is defined as the frame which invoked the
657 debugger. If END is nil, return the frames from START to the end of
658 the stack.")
659
660 (definterface print-frame (frame stream)
661 "Print frame to stream.")
662
663 (definterface frame-restartable-p (frame)
664 "Is the frame FRAME restartable?.
665 Return T if `restart-frame' can safely be called on the frame."
666 (declare (ignore frame))
667 nil)
668
669 (definterface frame-source-location-for-emacs (frame-number)
670 "Return the source location for the frame associated to FRAME-NUMBER.")
671
672 (definterface frame-catch-tags (frame-number)
673 "Return a list of catch tags for being printed in a debugger stack
674 frame."
675 (declare (ignore frame-number))
676 '())
677
678 (definterface frame-locals (frame-number)
679 "Return a list of ((&key NAME ID VALUE) ...) where each element of
680 the list represents a local variable in the stack frame associated to
681 FRAME-NUMBER.
682
683 NAME, a symbol; the name of the local variable.
684
685 ID, an integer; used as primary key for the local variable, unique
686 relatively to the frame under operation.
687
688 value, an object; the value of the local variable.")
689
690 (definterface frame-var-value (frame-number var-id)
691 "Return the value of the local variable associated to VAR-ID
692 relatively to the frame associated to FRAME-NUMBER.")
693
694 (definterface disassemble-frame (frame-number)
695 "Disassemble the code for the FRAME-NUMBER.
696 The output should be written to standard output.
697 FRAME-NUMBER is a non-negative integer.")
698
699 (definterface eval-in-frame (form frame-number)
700 "Evaluate a Lisp form in the lexical context of a stack frame
701 in the debugger.
702
703 FRAME-NUMBER must be a positive integer with 0 indicating the
704 frame which invoked the debugger.
705
706 The return value is the result of evaulating FORM in the
707 appropriate context.")
708
709 (definterface return-from-frame (frame-number form)
710 "Unwind the stack to the frame FRAME-NUMBER and return the value(s)
711 produced by evaluating FORM in the frame context to its caller.
712
713 Execute any clean-up code from unwind-protect forms above the frame
714 during unwinding.
715
716 Return a string describing the error if it's not possible to return
717 from the frame.")
718
719 (definterface restart-frame (frame-number)
720 "Restart execution of the frame FRAME-NUMBER with the same arguments
721 as it was called originally.")
722
723 (definterface format-sldb-condition (condition)
724 "Format a condition for display in SLDB."
725 (princ-to-string condition))
726
727 (definterface condition-extras (condition)
728 "Return a list of extra for the debugger.
729 The allowed elements are of the form:
730 (:SHOW-FRAME-SOURCE frame-number)
731 (:REFERENCES &rest refs)
732 "
733 (declare (ignore condition))
734 '())
735
736 (definterface activate-stepping (frame-number)
737 "Prepare the frame FRAME-NUMBER for stepping.")
738
739 (definterface sldb-break-on-return (frame-number)
740 "Set a breakpoint in the frame FRAME-NUMBER.")
741
742 (definterface sldb-break-at-start (symbol)
743 "Set a breakpoint on the beginning of the function for SYMBOL.")
744
745 (definterface sldb-stepper-condition-p (condition)
746 "Return true if SLDB was invoked due to a single-stepping condition,
747 false otherwise. "
748 (declare (ignore condition))
749 nil)
750
751 (definterface sldb-step-into ()
752 "Step into the current single-stepper form.")
753
754 (definterface sldb-step-next ()
755 "Step to the next form in the current function.")
756
757 (definterface sldb-step-out ()
758 "Stop single-stepping temporarily, but resume it once the current function
759 returns.")
760
761
762 ;;;; Definition finding
763
764 (defstruct (:location (:type list) :named
765 (:constructor make-location
766 (buffer position &optional hints)))
767 buffer position
768 ;; Hints is a property list optionally containing:
769 ;; :snippet SOURCE-TEXT
770 ;; This is a snippet of the actual source text at the start of
771 ;; the definition, which could be used in a text search.
772 hints)
773
774 (defstruct (:error (:type list) :named (:constructor)) message)
775 (defstruct (:file (:type list) :named (:constructor)) name)
776 (defstruct (:buffer (:type list) :named (:constructor)) name)
777 (defstruct (:position (:type list) :named (:constructor)) pos)
778
779 (definterface find-definitions (name)
780 "Return a list ((DSPEC LOCATION) ...) for NAME's definitions.
781
782 NAME is a \"definition specifier\".
783
784 DSPEC is a \"definition specifier\" describing the
785 definition, e.g., FOO or (METHOD FOO (STRING NUMBER)) or
786 \(DEFVAR FOO).
787
788 LOCATION is the source location for the definition.")
789
790 (definterface find-source-location (object)
791 "Returns the source location of OBJECT, or NIL.
792
793 That is the source location of the underlying datastructure of
794 OBJECT. E.g. on a STANDARD-OBJECT, the source location of the
795 respective DEFCLASS definition is returned, on a STRUCTURE-CLASS the
796 respective DEFSTRUCT definition, and so on."
797 ;; This returns one source location and not a list of locations. It's
798 ;; supposed to return the location of the DEFGENERIC definition on
799 ;; #'SOME-GENERIC-FUNCTION.
800 )
801
802
803 (definterface buffer-first-change (filename)
804 "Called for effect the first time FILENAME's buffer is modified."
805 (declare (ignore filename))
806 nil)
807
808
809
810 ;;;; XREF
811
812 (definterface who-calls (function-name)
813 "Return the call sites of FUNCTION-NAME (a symbol).
814 The results is a list ((DSPEC LOCATION) ...).")
815
816 (definterface calls-who (function-name)
817 "Return the call sites of FUNCTION-NAME (a symbol).
818 The results is a list ((DSPEC LOCATION) ...).")
819
820 (definterface who-references (variable-name)
821 "Return the locations where VARIABLE-NAME (a symbol) is referenced.
822 See WHO-CALLS for a description of the return value.")
823
824 (definterface who-binds (variable-name)
825 "Return the locations where VARIABLE-NAME (a symbol) is bound.
826 See WHO-CALLS for a description of the return value.")
827
828 (definterface who-sets (variable-name)
829 "Return the locations where VARIABLE-NAME (a symbol) is set.
830 See WHO-CALLS for a description of the return value.")
831
832 (definterface who-macroexpands (macro-name)
833 "Return the locations where MACRO-NAME (a symbol) is expanded.
834 See WHO-CALLS for a description of the return value.")
835
836 (definterface who-specializes (class-name)
837 "Return the locations where CLASS-NAME (a symbol) is specialized.
838 See WHO-CALLS for a description of the return value.")
839
840 ;;; Simpler variants.
841
842 (definterface list-callers (function-name)
843 "List the callers of FUNCTION-NAME.
844 This function is like WHO-CALLS except that it is expected to use
845 lower-level means. Whereas WHO-CALLS is usually implemented with
846 special compiler support, LIST-CALLERS is usually implemented by
847 groveling for constants in function objects throughout the heap.
848
849 The return value is as for WHO-CALLS.")
850
851 (definterface list-callees (function-name)
852 "List the functions called by FUNCTION-NAME.
853 See LIST-CALLERS for a description of the return value.")
854
855
856 ;;;; Profiling
857
858 ;;; The following functions define a minimal profiling interface.
859
860 (definterface profile (fname)
861 "Marks symbol FNAME for profiling.")
862
863 (definterface profiled-functions ()
864 "Returns a list of profiled functions.")
865
866 (definterface unprofile (fname)
867 "Marks symbol FNAME as not profiled.")
868
869 (definterface unprofile-all ()
870 "Marks all currently profiled functions as not profiled."
871 (dolist (f (profiled-functions))
872 (unprofile f)))
873
874 (definterface profile-report ()
875 "Prints profile report.")
876
877 (definterface profile-reset ()
878 "Resets profile counters.")
879
880 (definterface profile-package (package callers-p methods)
881 "Wrap profiling code around all functions in PACKAGE. If a function
882 is already profiled, then unprofile and reprofile (useful to notice
883 function redefinition.)
884
885 If CALLERS-P is T names have counts of the most common calling
886 functions recorded.
887
888 When called with arguments :METHODS T, profile all methods of all
889 generic functions having names in the given package. Generic functions
890 themselves, that is, their dispatch functions, are left alone.")
891
892
893 ;;;; Inspector
894
895 (defgeneric emacs-inspect (object)
896 (:documentation
897 "Explain to Emacs how to inspect OBJECT.
898
899 Returns a list specifying how to render the object for inspection.
900
901 Every element of the list must be either a string, which will be
902 inserted into the buffer as is, or a list of the form:
903
904 (:value object &optional format) - Render an inspectable
905 object. If format is provided it must be a string and will be
906 rendered in place of the value, otherwise use princ-to-string.
907
908 (:newline) - Render a \\n
909
910 (:action label lambda &key (refresh t)) - Render LABEL (a text
911 string) which when clicked will call LAMBDA. If REFRESH is
912 non-NIL the currently inspected object will be re-inspected
913 after calling the lambda.
914 "))
915
916 (defmethod emacs-inspect ((object t))
917 "Generic method for inspecting any kind of object.
918
919 Since we don't know how to deal with OBJECT we simply dump the
920 output of CL:DESCRIBE."
921 `("Type: " (:value ,(type-of object)) (:newline)
922 "Don't know how to inspect the object, dumping output of CL:DESCRIBE:"
923 (:newline) (:newline)
924 ,(with-output-to-string (desc) (describe object desc))))
925
926 ;;; Utilities for inspector methods.
927 ;;;
928 (defun label-value-line (label value &key (newline t))
929 "Create a control list which prints \"LABEL: VALUE\" in the inspector.
930 If NEWLINE is non-NIL a `(:newline)' is added to the result."
931 (list* (princ-to-string label) ": " `(:value ,value)
932 (if newline '((:newline)) nil)))
933
934 (defmacro label-value-line* (&rest label-values)
935 ` (append ,@(loop for (label value) in label-values
936 collect `(label-value-line ,label ,value))))
937
938 (definterface describe-primitive-type (object)
939 "Return a string describing the primitive type of object."
940 (declare (ignore object))
941 "N/A")
942
943
944 ;;;; Multithreading
945 ;;;
946 ;;; The default implementations are sufficient for non-multiprocessing
947 ;;; implementations.
948
949 (definterface initialize-multiprocessing (continuation)
950 "Initialize multiprocessing, if necessary and then invoke CONTINUATION.
951
952 Depending on the impleimentaion, this function may never return."
953 (funcall continuation))
954
955 (definterface spawn (fn &key name)
956 "Create a new thread to call FN.")
957
958 (definterface thread-id (thread)
959 "Return an Emacs-parsable object to identify THREAD.
960
961 Ids should be comparable with equal, i.e.:
962 (equal (thread-id <t1>) (thread-id <t2>)) <==> (eq <t1> <t2>)"
963 thread)
964
965 (definterface find-thread (id)
966 "Return the thread for ID.
967 ID should be an id previously obtained with THREAD-ID.
968 Can return nil if the thread no longer exists."
969 (current-thread))
970
971 (definterface thread-name (thread)
972 "Return the name of THREAD.
973
974 Thread names are be single-line strings and are meaningful to the
975 user. They do not have to be unique."
976 (declare (ignore thread))
977 "The One True Thread")
978
979 (definterface thread-status (thread)
980 "Return a string describing THREAD's state."
981 (declare (ignore thread))
982 "")
983
984 (definterface thread-description (thread)
985 "Return a string describing THREAD."
986 (declare (ignore thread))
987 "")
988
989 (definterface set-thread-description (thread description)
990 "Set THREAD's description to DESCRIPTION."
991 (declare (ignore thread description))
992 "")
993
994 (definterface make-lock (&key name)
995 "Make a lock for thread synchronization.
996 Only one thread may hold the lock (via CALL-WITH-LOCK-HELD) at a time
997 but that thread may hold it more than once."
998 (declare (ignore name))
999 :null-lock)
1000
1001 (definterface call-with-lock-held (lock function)
1002 "Call FUNCTION with LOCK held, queueing if necessary."
1003 (declare (ignore lock)
1004 (type function function))
1005 (funcall function))
1006
1007 (definterface current-thread ()
1008 "Return the currently executing thread."
1009 0)
1010
1011 (definterface all-threads ()
1012 "Return a fresh list of all threads.")
1013
1014 (definterface thread-alive-p (thread)
1015 "Test if THREAD is termintated."
1016 (member thread (all-threads)))
1017
1018 (definterface interrupt-thread (thread fn)
1019 "Cause THREAD to execute FN.")
1020
1021 (definterface kill-thread (thread)
1022 "Kill THREAD."
1023 (declare (ignore thread))
1024 nil)
1025
1026 (definterface send (thread object)
1027 "Send OBJECT to thread THREAD.")
1028
1029 (definterface receive (&optional timeout)
1030 "Return the next message from current thread's mailbox."
1031 (receive-if (constantly t) timeout))
1032
1033 (definterface receive-if (predicate &optional timeout)
1034 "Return the first message satisfiying PREDICATE.")
1035
1036 ;; List of delayed interrupts.
1037 ;; This should only have thread-local bindings, so no init form.
1038 (defvar *pending-slime-interrupts*)
1039
1040 (defun check-slime-interrupts ()
1041 "Execute pending interrupts if any.
1042 This should be called periodically in operations which
1043 can take a long time to complete.
1044 Return a boolean indicating whether any interrupts was processed."
1045 (when (and (boundp '*pending-slime-interrupts*)
1046 *pending-slime-interrupts*)
1047 (funcall (pop *pending-slime-interrupts*))
1048 t))
1049
1050 (definterface wait-for-input (streams &optional timeout)
1051 "Wait for input on a list of streams. Return those that are ready.
1052 STREAMS is a list of streams
1053 TIMEOUT nil, t, or real number. If TIMEOUT is t, return
1054 those streams which are ready immediately, without waiting.
1055 If TIMEOUT is a number and no streams is ready after TIMEOUT seconds,
1056 return nil.
1057
1058 Return :interrupt if an interrupt occurs while waiting."
1059 (assert (= (length streams) 1))
1060 (let ((stream (car streams)))
1061 (case timeout
1062 ((nil)
1063 (cond ((check-slime-interrupts) :interrupt)
1064 (t (peek-char nil stream nil nil)
1065 streams)))
1066 ((t)
1067 (let ((c (read-char-no-hang stream nil nil)))
1068 (cond (c
1069 (unread-char c stream)
1070 streams)
1071 (t '()))))
1072 (t
1073 (loop
1074 (if (check-slime-interrupts) (return :interrupt))
1075 (when (wait-for-input streams t) (return streams))
1076 (sleep 0.1)
1077 (when (<= (decf timeout 0.1) 0) (return nil)))))))
1078
1079 (definterface toggle-trace (spec)
1080 "Toggle tracing of the function(s) given with SPEC.
1081 SPEC can be:
1082 (setf NAME) ; a setf function
1083 (:defmethod NAME QUALIFIER... (SPECIALIZER...)) ; a specific method
1084 (:defgeneric NAME) ; a generic function with all methods
1085 (:call CALLER CALLEE) ; trace calls from CALLER to CALLEE.
1086 (:labels TOPLEVEL LOCAL)
1087 (:flet TOPLEVEL LOCAL) ")
1088
1089
1090 ;;;; Weak datastructures
1091
1092 (definterface make-weak-key-hash-table (&rest args)
1093 "Like MAKE-HASH-TABLE, but weak w.r.t. the keys."
1094 (apply #'make-hash-table args))
1095
1096 (definterface make-weak-value-hash-table (&rest args)
1097 "Like MAKE-HASH-TABLE, but weak w.r.t. the values."
1098 (apply #'make-hash-table args))
1099
1100 (definterface hash-table-weakness (hashtable)
1101 "Return nil or one of :key :value :key-or-value :key-and-value"
1102 (declare (ignore hashtable))
1103 nil)
1104
1105
1106 ;;;; Character names
1107
1108 (definterface character-completion-set (prefix matchp)
1109 "Return a list of names of characters that match PREFIX."
1110 ;; Handle the standard and semi-standard characters.
1111 (loop for name in '("Newline" "Space" "Tab" "Page" "Rubout"
1112 "Linefeed" "Return" "Backspace")
1113 when (funcall matchp prefix name)
1114 collect name))
1115
1116
1117 (defparameter *type-specifier-arglists*
1118 '((and . (&rest type-specifiers))
1119 (array . (&optional element-type dimension-spec))
1120 (base-string . (&optional size))
1121 (bit-vector . (&optional size))
1122 (complex . (&optional type-specifier))
1123 (cons . (&optional car-typespec cdr-typespec))
1124 (double-float . (&optional lower-limit upper-limit))
1125 (eql . (object))
1126 (float . (&optional lower-limit upper-limit))
1127 (function . (&optional arg-typespec value-typespec))
1128 (integer . (&optional lower-limit upper-limit))
1129 (long-float . (&optional lower-limit upper-limit))
1130 (member . (&rest eql-objects))
1131 (mod . (n))
1132 (not . (type-specifier))
1133 (or . (&rest type-specifiers))
1134 (rational . (&optional lower-limit upper-limit))
1135 (real . (&optional lower-limit upper-limit))
1136 (satisfies . (predicate-symbol))
1137 (short-float . (&optional lower-limit upper-limit))
1138 (signed-byte . (&optional size))
1139 (simple-array . (&optional element-type dimension-spec))
1140 (simple-base-string . (&optional size))
1141 (simple-bit-vector . (&optional size))
1142 (simple-string . (&optional size))
1143 (single-float . (&optional lower-limit upper-limit))
1144 (simple-vector . (&optional size))
1145 (string . (&optional size))
1146 (unsigned-byte . (&optional size))
1147 (values . (&rest typespecs))
1148 (vector . (&optional element-type size))
1149 ))
1150
1151 ;;; Heap dumps
1152
1153 (definterface save-image (filename &optional restart-function)
1154 "Save a heap image to the file FILENAME.
1155 RESTART-FUNCTION, if non-nil, should be called when the image is loaded.")
1156
1157
1158

  ViewVC Help
Powered by ViewVC 1.1.5