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

Contents of /slime/swank-backend.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.179 - (show annotations)
Sun Aug 2 12:57:23 2009 UTC (4 years, 8 months ago) by trittweiler
Branch: MAIN
Changes since 1.178: +2 -2 lines
	* swank-backend.lisp (severity [type]): Allow :redefinition.

	* swank-sbcl.lisp (signal-compiler-condition): Tag redefinitions.

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

  ViewVC Help
Powered by ViewVC 1.1.5