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

Contents of /slime/swank-backend.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.189 - (hide annotations)
Sun Jan 3 15:58:29 2010 UTC (4 years, 3 months ago) by sboukarev
Branch: MAIN
Changes since 1.188: +3 -0 lines
* contrib/slime-repl.el (sldb-insert-frame-call-to-repl): New function
for inserting a call to a frame into the REPL. Bound to C-y in SLDB.

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

  ViewVC Help
Powered by ViewVC 1.1.5