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

Contents of /slime/swank-backend.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.173 - (show annotations)
Sun Feb 22 14:18:47 2009 UTC (5 years, 1 month ago) by trittweiler
Branch: MAIN
Changes since 1.172: +4 -0 lines
	`M-x slime-format-string-expand' displays the expansion of a
	format string.

	* slime.el (slime-string-at-point) New.
	(slime-string-at-point-or-error): New.
	(slime-format-string-expand): New; use them.

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

  ViewVC Help
Powered by ViewVC 1.1.5