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

Contents of /slime/swank-backend.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.200 - (hide annotations)
Sat Aug 21 06:39:59 2010 UTC (3 years, 7 months ago) by heller
Branch: MAIN
Changes since 1.199: +5 -2 lines
Snapshot restore support for SBCL.

* swank-backend.lisp (background-save-image): New.
* swank-sbcl.lisp (command-line-args, dup, sys-execv, exec-image)
(make-fd-stream, background-save-image): New.

Add support to save snapshots in backround.

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

  ViewVC Help
Powered by ViewVC 1.1.5