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

Contents of /slime/swank-backend.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.135 - (hide annotations)
Sat Jul 26 23:05:59 2008 UTC (5 years, 8 months ago) by trittweiler
Branch: MAIN
Changes since 1.134: +7 -3 lines
* swank.lisp (swank-compiler): Fix bug when invoking an abort
restart on a failed compilation attempt.

* swank-sbcl.lisp (swank-compile-string): If a compilation attempt
fails, COMPILE-FILE returns NIL which we tried to LOAD. Fix that.

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

  ViewVC Help
Powered by ViewVC 1.1.5