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

Contents of /slime/swank-backend.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.203 - (hide annotations)
Sat Oct 9 23:02:33 2010 UTC (3 years, 6 months ago) by rtoy
Branch: MAIN
Changes since 1.202: +9 -0 lines
Add CODEPOINT-LENGTH function to return the number of codepoints in a
string.  Needed to make sure that Emacs and Lisp agree on the length
of a string.  Emacs wants codepoints and some lisps give code units.
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 crhodes 1.202 Should return T on successful 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 trittweiler 1.201 (definterface valid-function-name-p (form)
607     "Is FORM syntactically valid to name a function?
608     If true, FBOUNDP should not signal a type-error for FORM."
609     (flet ((length=2 (list)
610     (and (not (null (cdr list))) (null (cddr list)))))
611     (or (symbolp form)
612     (and (consp form) (length=2 form)
613     (eq (first form) 'setf) (symbolp (second form))))))
614    
615 lgorrie 1.21 (definterface macroexpand-all (form)
616 lgorrie 1.1 "Recursively expand all macros in FORM.
617 lgorrie 1.21 Return the resulting form.")
618 lgorrie 1.1
619 heller 1.94 (definterface compiler-macroexpand-1 (form &optional env)
620     "Call the compiler-macro for form.
621     If FORM is a function call for which a compiler-macro has been
622     defined, invoke the expander function using *macroexpand-hook* and
623     return the results and T. Otherwise, return the original form and
624     NIL."
625 trittweiler 1.201 (let ((fun (and (consp form)
626     (valid-function-name-p (car form))
627     (compiler-macro-function (car form)))))
628 heller 1.94 (if fun
629     (let ((result (funcall *macroexpand-hook* fun form env)))
630     (values result (not (eq result form))))
631     (values form nil))))
632    
633     (definterface compiler-macroexpand (form &optional env)
634     "Repetitively call `compiler-macroexpand-1'."
635     (labels ((frob (form expanded)
636     (multiple-value-bind (new-form newly-expanded)
637     (compiler-macroexpand-1 form env)
638     (if newly-expanded
639     (frob new-form t)
640     (values new-form expanded)))))
641     (frob form env)))
642    
643 trittweiler 1.173 (definterface format-string-expand (control-string)
644     "Expand the format string CONTROL-STRING."
645     (macroexpand `(formatter ,control-string)))
646    
647 lgorrie 1.21 (definterface describe-symbol-for-emacs (symbol)
648 lgorrie 1.1 "Return a property list describing SYMBOL.
649    
650     The property list has an entry for each interesting aspect of the
651     symbol. The recognised keys are:
652    
653 heller 1.86 :VARIABLE :FUNCTION :SETF :SPECIAL-OPERATOR :MACRO :COMPILER-MACRO
654     :TYPE :CLASS :ALIEN-TYPE :ALIEN-STRUCT :ALIEN-UNION :ALIEN-ENUM
655 lgorrie 1.1
656     The value of each property is the corresponding documentation string,
657 heller 1.86 or :NOT-DOCUMENTED. It is legal to include keys not listed here (but
658     slime-print-apropos in Emacs must know about them).
659 lgorrie 1.1
660     Properties should be included if and only if they are applicable to
661     the symbol. For example, only (and all) fbound symbols should include
662     the :FUNCTION property.
663    
664     Example:
665     \(describe-symbol-for-emacs 'vector)
666     => (:CLASS :NOT-DOCUMENTED
667     :TYPE :NOT-DOCUMENTED
668 lgorrie 1.21 :FUNCTION \"Constructs a simple-vector from the given objects.\")")
669    
670     (definterface describe-definition (name type)
671     "Describe the definition NAME of TYPE.
672     TYPE can be any value returned by DESCRIBE-SYMBOL-FOR-EMACS.
673    
674     Return a documentation string, or NIL if none is available.")
675 lgorrie 1.2
676    
677     ;;;; Debugging
678    
679 heller 1.92 (definterface install-debugger-globally (function)
680     "Install FUNCTION as the debugger for all threads/processes. This
681     usually involves setting *DEBUGGER-HOOK* and, if the implementation
682     permits, hooking into BREAK as well."
683     (setq *debugger-hook* function))
684    
685 lgorrie 1.21 (definterface call-with-debugging-environment (debugger-loop-fn)
686 lgorrie 1.2 "Call DEBUGGER-LOOP-FN in a suitable debugging environment.
687    
688     This function is called recursively at each debug level to invoke the
689     debugger loop. The purpose is to setup any necessary environment for
690     other debugger callbacks that will be called within the debugger loop.
691    
692     For example, this is a reasonable place to compute a backtrace, switch
693 lgorrie 1.21 to safe reader/printer settings, and so on.")
694 lgorrie 1.2
695 heller 1.80 (definterface call-with-debugger-hook (hook fun)
696 trittweiler 1.181 "Call FUN and use HOOK as debugger hook. HOOK can be NIL.
697 heller 1.80
698     HOOK should be called for both BREAK and INVOKE-DEBUGGER."
699     (let ((*debugger-hook* hook))
700     (funcall fun)))
701    
702 lgorrie 1.2 (define-condition sldb-condition (condition)
703     ((original-condition
704     :initarg :original-condition
705 heller 1.5 :accessor original-condition))
706 heller 1.63 (:report (lambda (condition stream)
707     (format stream "Condition in debugger code~@[: ~A~]"
708     (original-condition condition))))
709 lgorrie 1.2 (:documentation
710     "Wrapper for conditions that should not be debugged.
711    
712     When a condition arises from the internals of the debugger, it is not
713     desirable to debug it -- we'd risk entering an endless loop trying to
714     debug the debugger! Instead, such conditions can be reported to the
715     user without (re)entering the debugger by wrapping them as
716     `sldb-condition's."))
717    
718 trittweiler 1.132 ;;; The following functions in this section are supposed to be called
719     ;;; within the dynamic contour of CALL-WITH-DEBUGGING-ENVIRONMENT only.
720    
721 heller 1.36 (definterface compute-backtrace (start end)
722 trittweiler 1.132 "Returns a backtrace of the condition currently being debugged,
723 heller 1.157 that is an ordered list consisting of frames. ``Ordered list''
724 trittweiler 1.151 means that an integer I can be mapped back to the i-th frame of this
725     backtrace.
726 heller 1.36
727     START and END are zero-based indices constraining the number of frames
728 trittweiler 1.151 returned. Frame zero is defined as the frame which invoked the
729     debugger. If END is nil, return the frames from START to the end of
730 heller 1.36 the stack.")
731 lgorrie 1.3
732 heller 1.157 (definterface print-frame (frame stream)
733 heller 1.36 "Print frame to stream.")
734 heller 1.70
735 heller 1.157 (definterface frame-restartable-p (frame)
736     "Is the frame FRAME restartable?.
737     Return T if `restart-frame' can safely be called on the frame."
738 heller 1.161 (declare (ignore frame))
739 heller 1.157 nil)
740    
741 heller 1.176 (definterface frame-source-location (frame-number)
742 trittweiler 1.132 "Return the source location for the frame associated to FRAME-NUMBER.")
743 lgorrie 1.3
744 lgorrie 1.21 (definterface frame-catch-tags (frame-number)
745 trittweiler 1.132 "Return a list of catch tags for being printed in a debugger stack
746 heller 1.159 frame."
747 heller 1.160 (declare (ignore frame-number))
748 heller 1.159 '())
749 lgorrie 1.3
750 lgorrie 1.21 (definterface frame-locals (frame-number)
751 trittweiler 1.132 "Return a list of ((&key NAME ID VALUE) ...) where each element of
752     the list represents a local variable in the stack frame associated to
753     FRAME-NUMBER.
754    
755     NAME, a symbol; the name of the local variable.
756    
757     ID, an integer; used as primary key for the local variable, unique
758     relatively to the frame under operation.
759    
760     value, an object; the value of the local variable.")
761    
762     (definterface frame-var-value (frame-number var-id)
763     "Return the value of the local variable associated to VAR-ID
764     relatively to the frame associated to FRAME-NUMBER.")
765 heller 1.57
766 heller 1.37 (definterface disassemble-frame (frame-number)
767     "Disassemble the code for the FRAME-NUMBER.
768     The output should be written to standard output.
769 heller 1.84 FRAME-NUMBER is a non-negative integer.")
770 heller 1.37
771 lgorrie 1.21 (definterface eval-in-frame (form frame-number)
772 lgorrie 1.3 "Evaluate a Lisp form in the lexical context of a stack frame
773 trittweiler 1.132 in the debugger.
774 lgorrie 1.3
775     FRAME-NUMBER must be a positive integer with 0 indicating the
776     frame which invoked the debugger.
777    
778     The return value is the result of evaulating FORM in the
779 lgorrie 1.21 appropriate context.")
780 heller 1.22
781 sboukarev 1.189 (definterface frame-call (frame-number)
782     "Return a string representing a call to the entry point of a frame.")
783    
784 heller 1.22 (definterface return-from-frame (frame-number form)
785     "Unwind the stack to the frame FRAME-NUMBER and return the value(s)
786     produced by evaluating FORM in the frame context to its caller.
787    
788     Execute any clean-up code from unwind-protect forms above the frame
789     during unwinding.
790    
791     Return a string describing the error if it's not possible to return
792     from the frame.")
793    
794     (definterface restart-frame (frame-number)
795     "Restart execution of the frame FRAME-NUMBER with the same arguments
796     as it was called originally.")
797 lgorrie 1.3
798 lgorrie 1.49 (definterface format-sldb-condition (condition)
799     "Format a condition for display in SLDB."
800     (princ-to-string condition))
801    
802 heller 1.69 (definterface condition-extras (condition)
803     "Return a list of extra for the debugger.
804     The allowed elements are of the form:
805 heller 1.126 (:SHOW-FRAME-SOURCE frame-number)
806     (:REFERENCES &rest refs)
807     "
808 mbaringer 1.73 (declare (ignore condition))
809 heller 1.69 '())
810    
811 trittweiler 1.197 (definterface gdb-initial-commands ()
812     "List of gdb commands supposed to be executed first for the
813     ATTACH-GDB restart."
814     nil)
815    
816 heller 1.71 (definterface activate-stepping (frame-number)
817     "Prepare the frame FRAME-NUMBER for stepping.")
818 heller 1.69
819     (definterface sldb-break-on-return (frame-number)
820     "Set a breakpoint in the frame FRAME-NUMBER.")
821    
822     (definterface sldb-break-at-start (symbol)
823     "Set a breakpoint on the beginning of the function for SYMBOL.")
824 heller 1.52
825 jsnellman 1.103 (definterface sldb-stepper-condition-p (condition)
826     "Return true if SLDB was invoked due to a single-stepping condition,
827     false otherwise. "
828     (declare (ignore condition))
829     nil)
830    
831     (definterface sldb-step-into ()
832     "Step into the current single-stepper form.")
833    
834     (definterface sldb-step-next ()
835     "Step to the next form in the current function.")
836    
837     (definterface sldb-step-out ()
838     "Stop single-stepping temporarily, but resume it once the current function
839     returns.")
840 lgorrie 1.49
841 lgorrie 1.3
842 heller 1.36 ;;;; Definition finding
843    
844     (defstruct (:location (:type list) :named
845 lgorrie 1.45 (:constructor make-location
846     (buffer position &optional hints)))
847     buffer position
848     ;; Hints is a property list optionally containing:
849     ;; :snippet SOURCE-TEXT
850     ;; This is a snippet of the actual source text at the start of
851     ;; the definition, which could be used in a text search.
852     hints)
853 heller 1.36
854     (defstruct (:error (:type list) :named (:constructor)) message)
855 trittweiler 1.193
856     ;;; Valid content for BUFFER slot
857     (defstruct (:file (:type list) :named (:constructor)) name)
858     (defstruct (:buffer (:type list) :named (:constructor)) name)
859     (defstruct (:etags-file (:type list) :named (:constructor)) filename)
860    
861     ;;; Valid content for POSITION slot
862 heller 1.36 (defstruct (:position (:type list) :named (:constructor)) pos)
863 trittweiler 1.193 (defstruct (:tag (:type list) :named (:constructor)) tag1 tag2)
864 heller 1.36
865 trittweiler 1.194 (defmacro converting-errors-to-error-location (&body body)
866     "Catches errors during BODY and converts them to an error location."
867     (let ((gblock (gensym "CONVERTING-ERRORS+")))
868     `(block ,gblock
869     (handler-bind ((error
870     #'(lambda (e)
871     (if *debug-swank-backend*
872     nil ;decline
873     (return-from ,gblock
874     (make-error-location e))))))
875     ,@body))))
876    
877 trittweiler 1.186 (defun make-error-location (datum &rest args)
878     (cond ((typep datum 'condition)
879     `(:error ,(format nil "Error: ~A" datum)))
880     ((symbolp datum)
881     `(:error ,(format nil "Error: ~A" (apply #'make-condition datum args))))
882     (t
883     (assert (stringp datum))
884     `(:error ,(apply #'format nil datum args)))))
885    
886 heller 1.36 (definterface find-definitions (name)
887     "Return a list ((DSPEC LOCATION) ...) for NAME's definitions.
888    
889 heller 1.38 NAME is a \"definition specifier\".
890 heller 1.36
891 heller 1.38 DSPEC is a \"definition specifier\" describing the
892 heller 1.36 definition, e.g., FOO or (METHOD FOO (STRING NUMBER)) or
893 heller 1.38 \(DEFVAR FOO).
894    
895     LOCATION is the source location for the definition.")
896 heller 1.36
897 trittweiler 1.130 (definterface find-source-location (object)
898     "Returns the source location of OBJECT, or NIL.
899    
900     That is the source location of the underlying datastructure of
901     OBJECT. E.g. on a STANDARD-OBJECT, the source location of the
902     respective DEFCLASS definition is returned, on a STRUCTURE-CLASS the
903     respective DEFSTRUCT definition, and so on."
904 trittweiler 1.135 ;; This returns one source location and not a list of locations. It's
905 trittweiler 1.130 ;; supposed to return the location of the DEFGENERIC definition on
906     ;; #'SOME-GENERIC-FUNCTION.
907 trittweiler 1.186 (declare (ignore object))
908     (make-error-location "FIND-DEFINITIONS is not yet implemented on ~
909     this implementation."))
910 trittweiler 1.130
911    
912 lgorrie 1.61 (definterface buffer-first-change (filename)
913     "Called for effect the first time FILENAME's buffer is modified."
914 mbaringer 1.73 (declare (ignore filename))
915 lgorrie 1.61 nil)
916    
917 trittweiler 1.130
918 heller 1.36
919     ;;;; XREF
920    
921     (definterface who-calls (function-name)
922     "Return the call sites of FUNCTION-NAME (a symbol).
923 trittweiler 1.181 The results is a list ((DSPEC LOCATION) ...)."
924     (declare (ignore function-name))
925     :not-implemented)
926 heller 1.36
927 heller 1.81 (definterface calls-who (function-name)
928     "Return the call sites of FUNCTION-NAME (a symbol).
929 trittweiler 1.181 The results is a list ((DSPEC LOCATION) ...)."
930     (declare (ignore function-name))
931     :not-implemented)
932 heller 1.81
933 heller 1.36 (definterface who-references (variable-name)
934     "Return the locations where VARIABLE-NAME (a symbol) is referenced.
935 trittweiler 1.181 See WHO-CALLS for a description of the return value."
936     (declare (ignore variable-name))
937     :not-implemented)
938 heller 1.36
939     (definterface who-binds (variable-name)
940     "Return the locations where VARIABLE-NAME (a symbol) is bound.
941 trittweiler 1.181 See WHO-CALLS for a description of the return value."
942     (declare (ignore variable-name))
943     :not-implemented)
944 heller 1.36
945     (definterface who-sets (variable-name)
946     "Return the locations where VARIABLE-NAME (a symbol) is set.
947 trittweiler 1.181 See WHO-CALLS for a description of the return value."
948     (declare (ignore variable-name))
949     :not-implemented)
950 heller 1.36
951     (definterface who-macroexpands (macro-name)
952     "Return the locations where MACRO-NAME (a symbol) is expanded.
953 trittweiler 1.181 See WHO-CALLS for a description of the return value."
954     (declare (ignore macro-name))
955     :not-implemented)
956 heller 1.36
957     (definterface who-specializes (class-name)
958     "Return the locations where CLASS-NAME (a symbol) is specialized.
959 trittweiler 1.181 See WHO-CALLS for a description of the return value."
960     (declare (ignore class-name))
961     :not-implemented)
962 heller 1.36
963     ;;; Simpler variants.
964    
965     (definterface list-callers (function-name)
966     "List the callers of FUNCTION-NAME.
967     This function is like WHO-CALLS except that it is expected to use
968     lower-level means. Whereas WHO-CALLS is usually implemented with
969     special compiler support, LIST-CALLERS is usually implemented by
970     groveling for constants in function objects throughout the heap.
971    
972     The return value is as for WHO-CALLS.")
973    
974     (definterface list-callees (function-name)
975     "List the functions called by FUNCTION-NAME.
976     See LIST-CALLERS for a description of the return value.")
977    
978    
979 heller 1.23 ;;;; Profiling
980    
981     ;;; The following functions define a minimal profiling interface.
982    
983     (definterface profile (fname)
984     "Marks symbol FNAME for profiling.")
985    
986     (definterface profiled-functions ()
987     "Returns a list of profiled functions.")
988    
989     (definterface unprofile (fname)
990     "Marks symbol FNAME as not profiled.")
991    
992     (definterface unprofile-all ()
993     "Marks all currently profiled functions as not profiled."
994     (dolist (f (profiled-functions))
995     (unprofile f)))
996    
997     (definterface profile-report ()
998     "Prints profile report.")
999    
1000     (definterface profile-reset ()
1001     "Resets profile counters.")
1002    
1003     (definterface profile-package (package callers-p methods)
1004     "Wrap profiling code around all functions in PACKAGE. If a function
1005     is already profiled, then unprofile and reprofile (useful to notice
1006     function redefinition.)
1007    
1008     If CALLERS-P is T names have counts of the most common calling
1009     functions recorded.
1010    
1011     When called with arguments :METHODS T, profile all methods of all
1012     generic functions having names in the given package. Generic functions
1013     themselves, that is, their dispatch functions, are left alone.")
1014    
1015    
1016 heller 1.19 ;;;; Inspector
1017 lgorrie 1.56
1018 heller 1.128 (defgeneric emacs-inspect (object)
1019 heller 1.100 (:documentation
1020 heller 1.86 "Explain to Emacs how to inspect OBJECT.
1021 mbaringer 1.67
1022 heller 1.129 Returns a list specifying how to render the object for inspection.
1023 mbaringer 1.67
1024 lgorrie 1.83 Every element of the list must be either a string, which will be
1025 mbaringer 1.67 inserted into the buffer as is, or a list of the form:
1026    
1027     (:value object &optional format) - Render an inspectable
1028     object. If format is provided it must be a string and will be
1029     rendered in place of the value, otherwise use princ-to-string.
1030    
1031     (:newline) - Render a \\n
1032    
1033 mbaringer 1.117 (:action label lambda &key (refresh t)) - Render LABEL (a text
1034     string) which when clicked will call LAMBDA. If REFRESH is
1035     non-NIL the currently inspected object will be re-inspected
1036     after calling the lambda.
1037 heller 1.129 "))
1038 mbaringer 1.67
1039 heller 1.128 (defmethod emacs-inspect ((object t))
1040 mbaringer 1.67 "Generic method for inspecting any kind of object.
1041    
1042     Since we don't know how to deal with OBJECT we simply dump the
1043     output of CL:DESCRIBE."
1044 heller 1.86 `("Type: " (:value ,(type-of object)) (:newline)
1045     "Don't know how to inspect the object, dumping output of CL:DESCRIBE:"
1046     (:newline) (:newline)
1047 heller 1.129 ,(with-output-to-string (desc) (describe object desc))))
1048 heller 1.70
1049 heller 1.192 (definterface eval-context (object)
1050     "Return a list of bindings corresponding to OBJECT's slots."
1051     (declare (ignore object))
1052     '())
1053 trittweiler 1.185
1054 heller 1.84 ;;; Utilities for inspector methods.
1055 heller 1.70 ;;;
1056 trittweiler 1.185
1057 mbaringer 1.118 (defun label-value-line (label value &key (newline t))
1058     "Create a control list which prints \"LABEL: VALUE\" in the inspector.
1059     If NEWLINE is non-NIL a `(:newline)' is added to the result."
1060 trittweiler 1.185
1061 mbaringer 1.118 (list* (princ-to-string label) ": " `(:value ,value)
1062     (if newline '((:newline)) nil)))
1063 heller 1.70
1064     (defmacro label-value-line* (&rest label-values)
1065     ` (append ,@(loop for (label value) in label-values
1066     collect `(label-value-line ,label ,value))))
1067 heller 1.19
1068 heller 1.29 (definterface describe-primitive-type (object)
1069 heller 1.35 "Return a string describing the primitive type of object."
1070 heller 1.36 (declare (ignore object))
1071 heller 1.35 "N/A")
1072 heller 1.19
1073    
1074 heller 1.36 ;;;; Multithreading
1075 lgorrie 1.21 ;;;
1076     ;;; The default implementations are sufficient for non-multiprocessing
1077     ;;; implementations.
1078 lgorrie 1.9
1079 mbaringer 1.106 (definterface initialize-multiprocessing (continuation)
1080 heller 1.107 "Initialize multiprocessing, if necessary and then invoke CONTINUATION.
1081    
1082     Depending on the impleimentaion, this function may never return."
1083 mbaringer 1.106 (funcall continuation))
1084 lgorrie 1.9
1085 lgorrie 1.21 (definterface spawn (fn &key name)
1086     "Create a new thread to call FN.")
1087 lgorrie 1.17
1088 heller 1.58 (definterface thread-id (thread)
1089     "Return an Emacs-parsable object to identify THREAD.
1090    
1091     Ids should be comparable with equal, i.e.:
1092 heller 1.139 (equal (thread-id <t1>) (thread-id <t2>)) <==> (eq <t1> <t2>)"
1093     thread)
1094 heller 1.58
1095     (definterface find-thread (id)
1096     "Return the thread for ID.
1097     ID should be an id previously obtained with THREAD-ID.
1098 heller 1.142 Can return nil if the thread no longer exists."
1099 heller 1.162 (declare (ignore id))
1100 heller 1.142 (current-thread))
1101 heller 1.58
1102 heller 1.28 (definterface thread-name (thread)
1103     "Return the name of THREAD.
1104 heller 1.183 Thread names are short strings meaningful to the user. They do not
1105     have to be unique."
1106 heller 1.28 (declare (ignore thread))
1107 lgorrie 1.21 "The One True Thread")
1108 lgorrie 1.9
1109 heller 1.28 (definterface thread-status (thread)
1110     "Return a string describing THREAD's state."
1111     (declare (ignore thread))
1112     "")
1113    
1114 heller 1.177 (definterface thread-attributes (thread)
1115     "Return a plist of implementation-dependent attributes for THREAD"
1116     (declare (ignore thread))
1117     '())
1118    
1119 lgorrie 1.21 (definterface make-lock (&key name)
1120 lgorrie 1.17 "Make a lock for thread synchronization.
1121 heller 1.138 Only one thread may hold the lock (via CALL-WITH-LOCK-HELD) at a time
1122     but that thread may hold it more than once."
1123 heller 1.23 (declare (ignore name))
1124 lgorrie 1.21 :null-lock)
1125 lgorrie 1.9
1126 lgorrie 1.21 (definterface call-with-lock-held (lock function)
1127     "Call FUNCTION with LOCK held, queueing if necessary."
1128 heller 1.24 (declare (ignore lock)
1129     (type function function))
1130 lgorrie 1.21 (funcall function))
1131 heller 1.25
1132     (definterface current-thread ()
1133     "Return the currently executing thread."
1134     0)
1135 heller 1.28
1136     (definterface all-threads ()
1137 heller 1.190 "Return a fresh list of all threads."
1138     '())
1139 heller 1.28
1140     (definterface thread-alive-p (thread)
1141 heller 1.35 "Test if THREAD is termintated."
1142     (member thread (all-threads)))
1143 heller 1.25
1144     (definterface interrupt-thread (thread fn)
1145     "Cause THREAD to execute FN.")
1146    
1147 mbaringer 1.34 (definterface kill-thread (thread)
1148 heller 1.182 "Terminate THREAD immediately.
1149     Don't execute unwind-protected sections, don't raise conditions.
1150     (Do not pass go, do not collect $200.)"
1151 mbaringer 1.34 (declare (ignore thread))
1152     nil)
1153    
1154 heller 1.25 (definterface send (thread object)
1155     "Send OBJECT to thread THREAD.")
1156    
1157 heller 1.143 (definterface receive (&optional timeout)
1158 heller 1.142 "Return the next message from current thread's mailbox."
1159 heller 1.143 (receive-if (constantly t) timeout))
1160 mbaringer 1.78
1161 heller 1.143 (definterface receive-if (predicate &optional timeout)
1162 heller 1.136 "Return the first message satisfiying PREDICATE.")
1163    
1164 heller 1.168 (definterface set-default-initial-binding (var form)
1165     "Initialize special variable VAR by default with FORM.
1166    
1167     Some implementations initialize certain variables in each newly
1168     created thread. This function sets the form which is used to produce
1169     the initial value."
1170     (set var (eval form)))
1171    
1172 heller 1.153 ;; List of delayed interrupts.
1173     ;; This should only have thread-local bindings, so no init form.
1174     (defvar *pending-slime-interrupts*)
1175 heller 1.140
1176 heller 1.154 (defun check-slime-interrupts ()
1177 heller 1.140 "Execute pending interrupts if any.
1178     This should be called periodically in operations which
1179 heller 1.153 can take a long time to complete.
1180 heller 1.154 Return a boolean indicating whether any interrupts was processed."
1181 heller 1.153 (when (and (boundp '*pending-slime-interrupts*)
1182     *pending-slime-interrupts*)
1183 heller 1.154 (funcall (pop *pending-slime-interrupts*))
1184 heller 1.153 t))
1185 heller 1.140
1186 heller 1.172 (defvar *interrupt-queued-handler* nil
1187     "Function to call on queued interrupts.
1188     Interrupts get queued when an interrupt occurs while interrupt
1189     handling is disabled.
1190    
1191     Backends can use this function to abort slow operations.")
1192 heller 1.163
1193 heller 1.152 (definterface wait-for-input (streams &optional timeout)
1194     "Wait for input on a list of streams. Return those that are ready.
1195     STREAMS is a list of streams
1196     TIMEOUT nil, t, or real number. If TIMEOUT is t, return
1197     those streams which are ready immediately, without waiting.
1198     If TIMEOUT is a number and no streams is ready after TIMEOUT seconds,
1199     return nil.
1200    
1201     Return :interrupt if an interrupt occurs while waiting."
1202 heller 1.164 (assert (member timeout '(nil t)))
1203 heller 1.166 (cond #+(or)
1204     ((null (cdr streams))
1205 heller 1.164 (wait-for-one-stream (car streams) timeout))
1206     (t
1207     (wait-for-streams streams timeout))))
1208    
1209     (defun wait-for-streams (streams timeout)
1210 heller 1.166 (loop
1211     (when (check-slime-interrupts) (return :interrupt))
1212     (let ((ready (remove-if-not #'stream-readable-p streams)))
1213     (when ready (return ready)))
1214     (when timeout (return nil))
1215     (sleep 0.1)))
1216 heller 1.164
1217 heller 1.166 ;; Note: Usually we can't interrupt PEEK-CHAR cleanly.
1218 heller 1.164 (defun wait-for-one-stream (stream timeout)
1219     (ecase timeout
1220     ((nil)
1221     (cond ((check-slime-interrupts) :interrupt)
1222     (t (peek-char nil stream nil nil)
1223     (list stream))))
1224     ((t)
1225     (let ((c (read-char-no-hang stream nil nil)))
1226     (cond (c
1227     (unread-char c stream)
1228     (list stream))
1229     (t '()))))))
1230 heller 1.152
1231 heller 1.166 (defun stream-readable-p (stream)
1232     (let ((c (read-char-no-hang stream nil :eof)))
1233     (cond ((not c) nil)
1234     ((eq c :eof) t)
1235     (t (unread-char c stream) t))))
1236    
1237 heller 1.81 (definterface toggle-trace (spec)
1238     "Toggle tracing of the function(s) given with SPEC.
1239     SPEC can be:
1240     (setf NAME) ; a setf function
1241     (:defmethod NAME QUALIFIER... (SPECIALIZER...)) ; a specific method
1242     (:defgeneric NAME) ; a generic function with all methods
1243     (:call CALLER CALLEE) ; trace calls from CALLER to CALLEE.
1244     (:labels TOPLEVEL LOCAL)
1245     (:flet TOPLEVEL LOCAL) ")
1246 mkoeppe 1.87
1247    
1248     ;;;; Weak datastructures
1249    
1250     (definterface make-weak-key-hash-table (&rest args)
1251     "Like MAKE-HASH-TABLE, but weak w.r.t. the keys."
1252     (apply #'make-hash-table args))
1253    
1254     (definterface make-weak-value-hash-table (&rest args)
1255     "Like MAKE-HASH-TABLE, but weak w.r.t. the values."
1256     (apply #'make-hash-table args))
1257 mkoeppe 1.108
1258 alendvai 1.113 (definterface hash-table-weakness (hashtable)
1259     "Return nil or one of :key :value :key-or-value :key-and-value"
1260     (declare (ignore hashtable))
1261     nil)
1262    
1263 mkoeppe 1.108
1264     ;;;; Character names
1265    
1266     (definterface character-completion-set (prefix matchp)
1267     "Return a list of names of characters that match PREFIX."
1268     ;; Handle the standard and semi-standard characters.
1269     (loop for name in '("Newline" "Space" "Tab" "Page" "Rubout"
1270     "Linefeed" "Return" "Backspace")
1271     when (funcall matchp prefix name)
1272     collect name))
1273    
1274 trittweiler 1.120
1275     (defparameter *type-specifier-arglists*
1276     '((and . (&rest type-specifiers))
1277     (array . (&optional element-type dimension-spec))
1278     (base-string . (&optional size))
1279     (bit-vector . (&optional size))
1280     (complex . (&optional type-specifier))
1281     (cons . (&optional car-typespec cdr-typespec))
1282     (double-float . (&optional lower-limit upper-limit))
1283     (eql . (object))
1284     (float . (&optional lower-limit upper-limit))
1285     (function . (&optional arg-typespec value-typespec))
1286     (integer . (&optional lower-limit upper-limit))
1287     (long-float . (&optional lower-limit upper-limit))
1288     (member . (&rest eql-objects))
1289     (mod . (n))
1290     (not . (type-specifier))
1291     (or . (&rest type-specifiers))
1292     (rational . (&optional lower-limit upper-limit))
1293     (real . (&optional lower-limit upper-limit))
1294     (satisfies . (predicate-symbol))
1295     (short-float . (&optional lower-limit upper-limit))
1296     (signed-byte . (&optional size))
1297     (simple-array . (&optional element-type dimension-spec))
1298     (simple-base-string . (&optional size))
1299     (simple-bit-vector . (&optional size))
1300     (simple-string . (&optional size))
1301     (single-float . (&optional lower-limit upper-limit))
1302     (simple-vector . (&optional size))
1303     (string . (&optional size))
1304     (unsigned-byte . (&optional size))
1305     (values . (&rest typespecs))
1306     (vector . (&optional element-type size))
1307 heller 1.121 ))
1308 heller 1.145
1309     ;;; Heap dumps
1310    
1311     (definterface save-image (filename &optional restart-function)
1312     "Save a heap image to the file FILENAME.
1313     RESTART-FUNCTION, if non-nil, should be called when the image is loaded.")
1314    
1315 heller 1.200 (definterface background-save-image (filename &key restart-function
1316     completion-function)
1317     "Request saving a heap image to the file FILENAME.
1318     RESTART-FUNCTION, if non-nil, should be called when the image is loaded.
1319     COMPLETION-FUNCTION, if non-nil, should be called after saving the image.")
1320 rtoy 1.203
1321     ;;; Codepoint length
1322    
1323     (definterface codepoint-length (string)
1324     "Return the number of codepoints in STRING.
1325     With some Lisps, like cmucl, LENGTH returns the number of UTF-16 code
1326     units, but other Lisps return the number of codepoints. The slime
1327     protocol wants string lengths in terms of codepoints."
1328     (length string))

  ViewVC Help
Powered by ViewVC 1.1.5