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

Contents of /slime/swank-backend.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.188 - (show annotations)
Tue Dec 22 09:31:15 2009 UTC (4 years, 3 months ago) by heller
Branch: MAIN
Changes since 1.187: +22 -0 lines
Commands to save&restore image files without disconnecting.

* slime-snapshot.el: New file.
* swank-snapshot.lisp: New file.

Some new backend functions used for loading image files.

* swank-backend.lisp (socket-fd, make-fd-stream, dup, exec-image)
(command-line-args): New functions.
* swank-cmucl.lisp: Impemented.
* swank-cmucl.lisp (reset-sigio-handlers): New function.
(save-image): Fix quoting bug.

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

  ViewVC Help
Powered by ViewVC 1.1.5