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

Contents of /slime/swank-backend.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5