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

Contents of /slime/swank-backend.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5