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

Contents of /slime/swank-backend.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5