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

Contents of /slime/swank-backend.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.198 - (show annotations)
Fri Mar 19 12:32:30 2010 UTC (4 years, 1 month ago) by trittweiler
Branch: MAIN
Changes since 1.197: +8 -1 lines
	* slime.el (slime-lisp-implementation-program): New connection
	variable.
	(slime-set-connection-info): Adapted to set it.
	(slime-attach-gdb): Use it to invoke gdb so gdb is able to find
	debugging symbols on non-Linux platforms.

	* swank.lisp (connection-info): Include lisp-implementation-program.

	* swank-backend.lisp (lisp-implementation-program): New interface.
	Default implementation based on command-line-args.

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

  ViewVC Help
Powered by ViewVC 1.1.5