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

Contents of /slime/swank-backend.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.202 - (show annotations)
Fri Oct 8 09:03:24 2010 UTC (3 years, 6 months ago) by crhodes
Branch: MAIN
Changes since 1.201: +1 -1 lines
add richer location information to the position arg in compile-string-for-emacs

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

  ViewVC Help
Powered by ViewVC 1.1.5