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

Contents of /slime/swank-backend.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.197 - (hide annotations)
Thu Mar 18 12:29:07 2010 UTC (4 years, 1 month ago) by trittweiler
Branch: MAIN
Changes since 1.196: +5 -0 lines
	Add an ATTACH-GDB restart to SLDB.

	* swank.lisp (call-with-gdb-restart): New. Sends the new :gdb-attach event to Emacs.
	(with-gdb-restart): Sugar.
	(with-top-level-restart): Also expand to with-gdb-restart.
	(dispatch-event): Add :gdb-attach event.

	* swank-backend.lisp (gdb-initial-commands): New interface
	function so backends can customize how gdb needs to be configured
	for their implementation.

	* swank-ecl.lisp (gdb-initial-commands): Implement.

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

  ViewVC Help
Powered by ViewVC 1.1.5