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

Contents of /slime/swank-backend.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.120 - (show annotations)
Thu Aug 23 16:20:22 2007 UTC (6 years, 8 months ago) by trittweiler
Branch: MAIN
Changes since 1.119: +82 -2 lines
	Added arglist display for declaration specifiers and type
	specifiers.

	Examples:

	`(declare (type' will display

	   (declare (type type-specifier &rest vars))

	`(declare (type (float' will display

	   [Typespec] (float &optional lower-limit upper-limit)

	`(declare (optimize' will display

	   (declare (optimize &any (safety 1) (space 1) (speed 1) ...))

	&ANY is a new lambda keyword that is introduced for arglist
	description purpose, and is very similiar to &KEY, but isn't based
	upon plists; they're more based upon *FEATURES* lists. (See the
	comment near the ARGLIST defstruct in `swank.lisp'.)

	* slime.el:
	(slime-to-feature-keyword): Renamed to `slime-keywordify'.
	(slime-eval-feature-conditional): Adapted to use `slime-keywordify'.
	(slime-ensure-list): New utility.
	(slime-sexp-at-point): Now takes an argument that specify how many
	sexps at point should be returned.
	(slime-enclosing-operator-names): Renamed to
	`slime-enclosing-form-specs'.
	(slime-enclosing-form-specs): Returns a list of ``raw form specs''
	instead of what was called ``extended operator names'' before, see
	`swank::parse-form-spec' for more information. This is a
	simplified superset. Additionally as tertiary return value return
	a list of points to let the caller see where each form spec is
	located. Adapted callers accordingly. Extended docstring.
	(slime-parse-extended-operator-name): Adapted to changes in
	`slime-enclosing-form-specs'. Now gets more context, and is such
	more powerful. This was needed to allow parsing DECLARE forms.
	(slime-make-extended-operator-parser/look-ahead): Because the
	protocol for arglist display was simplified, it was possible to
	replace the plethora of parsing function just by this one.
	(slime-extended-operator-name-parser-alist): Use it. Also add
	parser for DECLARE forms.
	(slime-parse-extended-operator/declare): Responsible for parsing
	DECLARE forms.
	(%slime-in-mid-of-typespec-p): Helper function for
	`slime-parse-extended-operator/declare'.
	(slime-incomplete-form-at-point): New. Return the ``raw form
	spec'' near point.
	(slime-complete-form): Use `slime-incomplete-form-at-point'.

	* swank.lisp: New Helper functions.
	(length=, ensure-list, recursively-empty-p): New.
	(maybecall, exactly-one-p): New.

	* swank.lisp (arglist-for-echo-area): Adapted to take ``raw form
	specs'' from Slime.
	(parse-form-spec): New. Takes a ``raw form spec'' and returns a
	``form spec'' for further processing in Swank. Docstring documents
	these two terms.
	(split-form-spec): New. Return relevant information from a form	spec.
	(parse-first-valid-form-spec): Replaces `find-valid-operator-name'.
	(find-valid-operator-name): Removed.
	(operator-designator-to-form): Removed. Obsoleted by `parse-form-spec'.

	(defstruct arglist): Add `any-p' and `any-args' slots to contain
	arguments belonging to the &ANY lambda keyword.
	(print-arglist): Adapted to also print &ANY args.
	(print-decoded-arglist-as-template): Likewise.
	(decode-arglist): Adapted to also decode &ANY args.
	(remove-actual-args): Adapted to also remove &ANY args.
	(remove-&key-args): Split out from `remove-actual-args'.
	(remove-&any-args): New. Removes already provided &ANY args.
	(arglist-from-form-spec): New. Added detailed docstring.
	(arglist-dispatch): Dispatching generic function for
	`arglist-from-form-spec' that does all the work. Renamed from
	prior `form-completion'.
	(arglist-dispatch) Added methods for dealing with declaration and
	type-specifiers.
	(complete-form): Adapted to take ``raw form specs'' from Slime.
	(completions-for-keyword): Likewise.
	(format-arglist-for-echo-area): Removed. Not needed anymore.

	* swank-backend.lisp (declaration-arglist): New generic
	function. Returns the arglist for a given declaration
	identifier. (Backends are supposed to specialize it if they can
	provide additional information.)
	(type-specifier-arglist): New generic function. Returns the
	arglist for a given type-specifier operator. (Backends are
	supposed to specialize it if they can provide additional
	information.)
	(*type-specifier-arglists*): New variable. Contains the arglists
	for the type specifiers in Common Lisp.

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

  ViewVC Help
Powered by ViewVC 1.1.5