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

Contents of /slime/swank-backend.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.194 - (show annotations)
Mon Feb 22 21:38:46 2010 UTC (4 years, 1 month ago) by trittweiler
Branch: MAIN
Changes since 1.193: +12 -0 lines
	* swank-backend.lisp (converting-errors-to-error-location): Moved
	here from swank-sbcl.lisp so other backends can make use of it, too.

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

  ViewVC Help
Powered by ViewVC 1.1.5