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

Contents of /slime/swank-backend.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.224 - (show annotations)
Sat Feb 2 10:11:16 2013 UTC (14 months, 2 weeks ago) by sboukarev
Branch: MAIN
CVS Tags: HEAD
Changes since 1.223: +5 -0 lines
* swank-backend.lisp (type-specifier-p): New.
Implement it for ACL, ECL, CCL, Clisp, SBCL, LW.

* contrib/swank-util.lisp (symbol-classification-string): Use
type-specifier-p.
1 ;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;*" -*-
2 ;;;
3 ;;; slime-backend.lisp --- SLIME backend interface.
4 ;;;
5 ;;; Created by James Bielman in 2003. Released into the public domain.
6 ;;;
7 ;;;; Frontmatter
8 ;;;
9 ;;; 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
13 (defpackage :swank-backend
14 (:use :common-lisp)
15 (:export #:*debug-swank-backend*
16 #:sldb-condition
17 #:compiler-condition
18 #:original-condition
19 #:message
20 #:source-context
21 #:condition
22 #:severity
23 #:with-compilation-hooks
24 #:location
25 #:location-p
26 #:location-buffer
27 #:location-position
28 #:position-p
29 #:position-pos
30 #:print-output-to-string
31 #:quit-lisp
32 #:references
33 #:unbound-slot-filler
34 #:declaration-arglist
35 #:type-specifier-arglist
36 #:with-struct
37 #:when-let
38 ;; interrupt macro for the backend
39 #:*pending-slime-interrupts*
40 #:check-slime-interrupts
41 #:*interrupt-queued-handler*
42 ;; inspector related symbols
43 #:emacs-inspect
44 #:label-value-line
45 #:label-value-line*
46 #:with-symbol))
47
48 (defpackage :swank-mop
49 (:use)
50 (:export
51 ;; classes
52 #:standard-generic-function
53 #:standard-slot-definition
54 #:standard-method
55 #:standard-class
56 #:eql-specializer
57 #:eql-specializer-object
58 ;; 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 #:specializer-direct-methods
70 ;; 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 #:slot-definition-writers
94 #:slot-boundp-using-class
95 #:slot-value-using-class
96 #:slot-makunbound-using-class
97 ;; generic function protocol
98 #:compute-applicable-methods-using-classes
99 #:finalize-inheritance))
100
101 (in-package :swank-backend)
102
103
104 ;;;; Metacode
105
106 (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 (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 (defmacro definterface (name args documentation &rest default-body)
119 "Define an interface function for the backend to implement.
120 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
130 Backends implement these functions using DEFIMPLEMENTATION."
131 (check-type documentation string "a documentation string")
132 (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 (t (error "~S not implemented" ',name)))))
159 (pushnew ',name *interface-functions*)
160 ,(if (null default-body)
161 `(pushnew ',name *unimplemented-interfaces*)
162 (gen-default-impl))
163 (eval-when (:compile-toplevel :load-toplevel :execute)
164 (export ',name :swank-backend))
165 ',name)))
166
167 (defmacro defimplementation (name args &body body)
168 (assert (every #'symbolp args) ()
169 "Complex lambda-list not supported: ~S ~S" name args)
170 `(progn
171 (setf (get ',name 'implementation)
172 ;; For implicit BLOCK. FLET because of interplay w/ decls.
173 (flet ((,name ,args ,@body)) #',name))
174 (if (member ',name *interface-functions*)
175 (setq *unimplemented-interfaces*
176 (remove ',name *unimplemented-interfaces*))
177 (warn "DEFIMPLEMENTATION of undefined interface (~S)" ',name))
178 ',name))
179
180 (defun warn-unimplemented-interfaces ()
181 "Warn the user about unimplemented backend features.
182 The portable code calls this function at startup."
183 (let ((*print-pretty* t))
184 (warn "These Swank interfaces are unimplemented:~% ~:<~{~A~^ ~:_~}~:>"
185 (list (sort (copy-list *unimplemented-interfaces*) #'string<)))))
186
187 (defun import-to-swank-mop (symbol-list)
188 (dolist (sym symbol-list)
189 (let* ((swank-mop-sym (find-symbol (symbol-name sym) :swank-mop)))
190 (when swank-mop-sym
191 (unintern swank-mop-sym :swank-mop))
192 (import sym :swank-mop)
193 (export sym :swank-mop))))
194
195 (defun import-swank-mop-symbols (package except)
196 "Import the mop symbols from PACKAGE to SWANK-MOP.
197 EXCEPT is a list of symbol names which should be ignored."
198 (do-symbols (s :swank-mop)
199 (unless (member s except :test #'string=)
200 (let ((real-symbol (find-symbol (string s) package)))
201 (assert real-symbol () "Symbol ~A not found in package ~A" s package)
202 (unintern s :swank-mop)
203 (import real-symbol :swank-mop)
204 (export real-symbol :swank-mop)))))
205
206 (defvar *gray-stream-symbols*
207 '(:fundamental-character-output-stream
208 :stream-write-char
209 :stream-write-string
210 :stream-fresh-line
211 :stream-force-output
212 :stream-finish-output
213 :fundamental-character-input-stream
214 :stream-read-char
215 :stream-peek-char
216 :stream-read-line
217 ;; STREAM-FILE-POSITION is not available on all implementations, or
218 ;; partially under a different name.
219 ; :stream-file-posiion
220 :stream-listen
221 :stream-unread-char
222 :stream-clear-input
223 :stream-line-column
224 :stream-read-char-no-hang
225 ;; STREAM-LINE-LENGTH is an extension to gray streams that's apparently
226 ;; supported by CMUCL, OpenMCL, SBCL and SCL.
227 #+(or cmu openmcl sbcl scl)
228 :stream-line-length))
229
230 (defun import-from (package symbol-names &optional (to-package *package*))
231 "Import the list of SYMBOL-NAMES found in the package PACKAGE."
232 (dolist (name symbol-names)
233 (multiple-value-bind (symbol found) (find-symbol (string name) package)
234 (assert found () "Symbol ~A not found in package ~A" name package)
235 (import symbol to-package))))
236
237
238 ;;;; Utilities
239
240 (defmacro with-struct ((conc-name &rest names) obj &body body)
241 "Like with-slots but works only for structs."
242 (check-type conc-name symbol)
243 (flet ((reader (slot)
244 (intern (concatenate 'string
245 (symbol-name conc-name)
246 (symbol-name slot))
247 (symbol-package conc-name))))
248 (let ((tmp (gensym "OO-")))
249 ` (let ((,tmp ,obj))
250 (symbol-macrolet
251 ,(loop for name in names collect
252 (typecase name
253 (symbol `(,name (,(reader name) ,tmp)))
254 (cons `(,(first name) (,(reader (second name)) ,tmp)))
255 (t (error "Malformed syntax in WITH-STRUCT: ~A" name))))
256 ,@body)))))
257
258 (defmacro when-let ((var value) &body body)
259 `(let ((,var ,value))
260 (when ,var ,@body)))
261
262 (defun with-symbol (name package)
263 "Generate a form suitable for testing with #+."
264 (if (and (find-package package)
265 (find-symbol (string name) package))
266 '(:and)
267 '(:or)))
268
269
270 ;;;; UFT8
271
272 (deftype octet () '(unsigned-byte 8))
273 (deftype octets () '(simple-array octet (*)))
274
275 ;; Helper function. Decode the next N bytes starting from INDEX.
276 ;; Return the decoded char and the new index.
277 (defun utf8-decode-aux (buffer index limit byte0 n)
278 (declare (type octets buffer) (fixnum index limit byte0 n))
279 (if (< (- limit index) n)
280 (values nil index)
281 (do ((i 0 (1+ i))
282 (code byte0 (let ((byte (aref buffer (+ index i))))
283 (cond ((= (ldb (byte 2 6) byte) #b10)
284 (+ (ash code 6) (ldb (byte 6 0) byte)))
285 (t
286 (error "Invalid encoding"))))))
287 ((= i n)
288 (values (cond ((<= code #xff) (code-char code))
289 ((<= #xd800 code #xdfff)
290 (error "Invalid Unicode code point: #x~x" code))
291 ((and (< code char-code-limit)
292 (code-char code)))
293 (t
294 (error
295 "Can't represent code point: #x~x ~
296 (char-code-limit is #x~x)"
297 code char-code-limit)))
298 (+ index n))))))
299
300 ;; Decode one character in BUFFER starting at INDEX.
301 ;; Return 2 values: the character and the new index.
302 ;; If there aren't enough bytes between INDEX and LIMIT return nil.
303 (defun utf8-decode (buffer index limit)
304 (declare (type octets buffer) (fixnum index limit))
305 (if (= index limit)
306 (values nil index)
307 (let ((b (aref buffer index)))
308 (if (<= b #x7f)
309 (values (code-char b) (1+ index))
310 (macrolet ((try (marker else)
311 (let* ((l (integer-length marker))
312 (n (- l 2)))
313 `(if (= (ldb (byte ,l ,(- 8 l)) b) ,marker)
314 (utf8-decode-aux buffer (1+ index) limit
315 (ldb (byte ,(- 8 l) 0) b)
316 ,n)
317 ,else))))
318 (try #b110
319 (try #b1110
320 (try #b11110
321 (try #b111110
322 (try #b1111110
323 (error "Invalid encoding")))))))))))
324
325 ;; Decode characters from BUFFER and write them to STRING.
326 ;; Return 2 values: LASTINDEX and LASTSTART where
327 ;; LASTINDEX is the last index in BUFFER that was not decoded
328 ;; and LASTSTART is the last index in STRING not written.
329 (defun utf8-decode-into (buffer index limit string start end)
330 (declare (string string) (fixnum index limit start end) (type octets buffer))
331 (loop
332 (cond ((= start end)
333 (return (values index start)))
334 (t
335 (multiple-value-bind (c i) (utf8-decode buffer index limit)
336 (cond (c
337 (setf (aref string start) c)
338 (setq index i)
339 (setq start (1+ start)))
340 (t
341 (return (values index start)))))))))
342
343 (defun default-utf8-to-string (octets)
344 (let* ((limit (length octets))
345 (str (make-string limit)))
346 (multiple-value-bind (i s) (utf8-decode-into octets 0 limit str 0 limit)
347 (if (= i limit)
348 (if (= limit s)
349 str
350 (adjust-array str s))
351 (loop
352 (let ((end (+ (length str) (- limit i))))
353 (setq str (adjust-array str end))
354 (multiple-value-bind (i2 s2)
355 (utf8-decode-into octets i limit str s end)
356 (cond ((= i2 limit)
357 (return (adjust-array str s2)))
358 (t
359 (setq i i2)
360 (setq s s2))))))))))
361
362 (defmacro utf8-encode-aux (code buffer start end n)
363 `(cond ((< (- ,end ,start) ,n)
364 ,start)
365 (t
366 (setf (aref ,buffer ,start)
367 (dpb (ldb (byte ,(- 7 n) ,(* 6 (1- n))) ,code)
368 (byte ,(- 7 n) 0)
369 ,(dpb 0 (byte 1 (- 7 n)) #xff)))
370 ,@(loop for i from 0 upto (- n 2) collect
371 `(setf (aref ,buffer (+ ,start ,(- n 1 i)))
372 (dpb (ldb (byte 6 ,(* 6 i)) ,code)
373 (byte 6 0)
374 #b10111111)))
375 (+ ,start ,n))))
376
377 (defun utf8-encode (char buffer start end)
378 (declare (character char) (type octets buffer) (fixnum start end))
379 (let ((code (char-code char)))
380 (cond ((<= code #x7f)
381 (cond ((< start end)
382 (setf (aref buffer start) code)
383 (1+ start))
384 (t start)))
385 ((<= code #x7ff) (utf8-encode-aux code buffer start end 2))
386 ((<= #xd800 code #xdfff)
387 (error "Invalid Unicode code point (surrogate): #x~x" code))
388 ((<= code #xffff) (utf8-encode-aux code buffer start end 3))
389 ((<= code #x1fffff) (utf8-encode-aux code buffer start end 4))
390 ((<= code #x3ffffff) (utf8-encode-aux code buffer start end 5))
391 ((<= code #x7fffffff) (utf8-encode-aux code buffer start end 6))
392 (t (error "Can't encode ~s (~x)" char code)))))
393
394 (defun utf8-encode-into (string start end buffer index limit)
395 (declare (string string) (type octets buffer) (fixnum start end index limit))
396 (loop
397 (cond ((= start end)
398 (return (values start index)))
399 ((= index limit)
400 (return (values start index)))
401 (t
402 (let ((i2 (utf8-encode (char string start) buffer index limit)))
403 (cond ((= i2 index)
404 (return (values start index)))
405 (t
406 (setq index i2)
407 (incf start))))))))
408
409 (defun default-string-to-utf8 (string)
410 (let* ((len (length string))
411 (b (make-array len :element-type 'octet)))
412 (multiple-value-bind (s i) (utf8-encode-into string 0 len b 0 len)
413 (if (= s len)
414 b
415 (loop
416 (let ((limit (+ (length b) (- len s))))
417 (setq b (coerce (adjust-array b limit) 'octets))
418 (multiple-value-bind (s2 i2)
419 (utf8-encode-into string s len b i limit)
420 (cond ((= s2 len)
421 (return (coerce (adjust-array b i2) 'octets)))
422 (t
423 (setq i i2)
424 (setq s s2))))))))))
425
426 (definterface string-to-utf8 (string)
427 "Convert the string STRING to a (simple-array (unsigned-byte 8))"
428 (default-string-to-utf8 string))
429
430 (definterface utf8-to-string (octets)
431 "Convert the (simple-array (unsigned-byte 8)) OCTETS to a string."
432 (default-utf8-to-string octets))
433
434 ;;; Codepoint length
435
436 ;; we don't need this anymore.
437 (definterface codepoint-length (string)
438 "Return the number of codepoints in STRING.
439 With some Lisps, like cmucl, LENGTH returns the number of UTF-16 code
440 units, but other Lisps return the number of codepoints. The slime
441 protocol wants string lengths in terms of codepoints."
442 (length string))
443
444
445 ;;;; TCP server
446
447 (definterface create-socket (host port &key backlog)
448 "Create a listening TCP socket on interface HOST and port PORT.
449 BACKLOG queue length for incoming connections.")
450
451 (definterface local-port (socket)
452 "Return the local port number of SOCKET.")
453
454 (definterface close-socket (socket)
455 "Close the socket SOCKET.")
456
457 (definterface accept-connection (socket &key external-format
458 buffering timeout)
459 "Accept a client connection on the listening socket SOCKET.
460 Return a stream for the new connection.
461 If EXTERNAL-FORMAT is nil return a binary stream
462 otherwise create a character stream.
463 BUFFERING can be one of:
464 nil ... no buffering
465 t ... enable buffering
466 :line ... enable buffering with automatic flushing on eol.")
467
468 (definterface add-sigio-handler (socket fn)
469 "Call FN whenever SOCKET is readable.")
470
471 (definterface remove-sigio-handlers (socket)
472 "Remove all sigio handlers for SOCKET.")
473
474 (definterface add-fd-handler (socket fn)
475 "Call FN when Lisp is waiting for input and SOCKET is readable.")
476
477 (definterface remove-fd-handlers (socket)
478 "Remove all fd-handlers for SOCKET.")
479
480 (definterface preferred-communication-style ()
481 "Return one of the symbols :spawn, :sigio, :fd-handler, or NIL."
482 nil)
483
484 (definterface set-stream-timeout (stream timeout)
485 "Set the 'stream 'timeout. The timeout is either the real number
486 specifying the timeout in seconds or 'nil for no timeout."
487 (declare (ignore stream timeout))
488 nil)
489
490 ;;; Base condition for networking errors.
491 (define-condition network-error (simple-error) ())
492
493 (definterface emacs-connected ()
494 "Hook called when the first connection from Emacs is established.
495 Called from the INIT-FN of the socket server that accepts the
496 connection.
497
498 This is intended for setting up extra context, e.g. to discover
499 that the calling thread is the one that interacts with Emacs."
500 nil)
501
502
503 ;;;; Unix signals
504
505 (defconstant +sigint+ 2)
506
507 (definterface getpid ()
508 "Return the (Unix) process ID of this superior Lisp.")
509
510 (definterface install-sigint-handler (function)
511 "Call FUNCTION on SIGINT (instead of invoking the debugger).
512 Return old signal handler."
513 (declare (ignore function))
514 nil)
515
516 (definterface call-with-user-break-handler (handler function)
517 "Install the break handler HANDLER while executing FUNCTION."
518 (let ((old-handler (install-sigint-handler handler)))
519 (unwind-protect (funcall function)
520 (install-sigint-handler old-handler))))
521
522 (definterface quit-lisp ()
523 "Exit the current lisp image.")
524
525 (definterface lisp-implementation-type-name ()
526 "Return a short name for the Lisp implementation."
527 (lisp-implementation-type))
528
529 (definterface lisp-implementation-program ()
530 "Return the argv[0] of the running Lisp process, or NIL."
531 (let ((file (car (command-line-args))))
532 (when (and file (probe-file file))
533 (namestring (truename file)))))
534
535 (definterface socket-fd (socket-stream)
536 "Return the file descriptor for SOCKET-STREAM.")
537
538 (definterface make-fd-stream (fd external-format)
539 "Create a character stream for the file descriptor FD.")
540
541 (definterface dup (fd)
542 "Duplicate a file descriptor.
543 If the syscall fails, signal a condition.
544 See dup(2).")
545
546 (definterface exec-image (image-file args)
547 "Replace the current process with a new process image.
548 The new image is created by loading the previously dumped
549 core file IMAGE-FILE.
550 ARGS is a list of strings passed as arguments to
551 the new image.
552 This is thin wrapper around exec(3).")
553
554 (definterface command-line-args ()
555 "Return a list of strings as passed by the OS."
556 nil)
557
558
559 ;; pathnames are sooo useless
560
561 (definterface filename-to-pathname (filename)
562 "Return a pathname for FILENAME.
563 A filename in Emacs may for example contain asterisks which should not
564 be translated to wildcards."
565 (parse-namestring filename))
566
567 (definterface pathname-to-filename (pathname)
568 "Return the filename for PATHNAME."
569 (namestring pathname))
570
571 (definterface default-directory ()
572 "Return the default directory."
573 (directory-namestring (truename *default-pathname-defaults*)))
574
575 (definterface set-default-directory (directory)
576 "Set the default directory.
577 This is used to resolve filenames without directory component."
578 (setf *default-pathname-defaults* (truename (merge-pathnames directory)))
579 (default-directory))
580
581
582 (definterface call-with-syntax-hooks (fn)
583 "Call FN with hooks to handle special syntax."
584 (funcall fn))
585
586 (definterface default-readtable-alist ()
587 "Return a suitable initial value for SWANK:*READTABLE-ALIST*."
588 '())
589
590
591 ;;;; Compilation
592
593 (definterface call-with-compilation-hooks (func)
594 "Call FUNC with hooks to record compiler conditions.")
595
596 (defmacro with-compilation-hooks ((&rest ignore) &body body)
597 "Execute BODY as in CALL-WITH-COMPILATION-HOOKS."
598 (declare (ignore ignore))
599 `(call-with-compilation-hooks (lambda () (progn ,@body))))
600
601 (definterface swank-compile-string (string &key buffer position filename
602 policy)
603 "Compile source from STRING.
604 During compilation, compiler conditions must be trapped and
605 resignalled as COMPILER-CONDITIONs.
606
607 If supplied, BUFFER and POSITION specify the source location in Emacs.
608
609 Additionally, if POSITION is supplied, it must be added to source
610 positions reported in compiler conditions.
611
612 If FILENAME is specified it may be used by certain implementations to
613 rebind *DEFAULT-PATHNAME-DEFAULTS* which may improve the recording of
614 source information.
615
616 If POLICY is supplied, and non-NIL, it may be used by certain
617 implementations to compile with optimization qualities of its
618 value.
619
620 Should return T on successful compilation, NIL otherwise.
621 ")
622
623 (definterface swank-compile-file (input-file output-file load-p
624 external-format
625 &key policy)
626 "Compile INPUT-FILE signalling COMPILE-CONDITIONs.
627 If LOAD-P is true, load the file after compilation.
628 EXTERNAL-FORMAT is a value returned by find-external-format or
629 :default.
630
631 If POLICY is supplied, and non-NIL, it may be used by certain
632 implementations to compile with optimization qualities of its
633 value.
634
635 Should return OUTPUT-TRUENAME, WARNINGS-P and FAILURE-p
636 like `compile-file'")
637
638 (deftype severity ()
639 '(member :error :read-error :warning :style-warning :note :redefinition))
640
641 ;; Base condition type for compiler errors, warnings and notes.
642 (define-condition compiler-condition (condition)
643 ((original-condition
644 ;; The original condition thrown by the compiler if appropriate.
645 ;; May be NIL if a compiler does not report using conditions.
646 :type (or null condition)
647 :initarg :original-condition
648 :accessor original-condition)
649
650 (severity :type severity
651 :initarg :severity
652 :accessor severity)
653
654 (message :initarg :message
655 :accessor message)
656
657 ;; Macro expansion history etc. which may be helpful in some cases
658 ;; but is often very verbose.
659 (source-context :initarg :source-context
660 :type (or null string)
661 :initform nil
662 :accessor source-context)
663
664 (references :initarg :references
665 :initform nil
666 :accessor references)
667
668 (location :initarg :location
669 :accessor location)))
670
671 (definterface find-external-format (coding-system)
672 "Return a \"external file format designator\" for CODING-SYSTEM.
673 CODING-SYSTEM is Emacs-style coding system name (a string),
674 e.g. \"latin-1-unix\"."
675 (if (equal coding-system "iso-latin-1-unix")
676 :default
677 nil))
678
679 (definterface guess-external-format (pathname)
680 "Detect the external format for the file with name pathname.
681 Return nil if the file contains no special markers."
682 ;; Look for a Emacs-style -*- coding: ... -*- or Local Variable: section.
683 (with-open-file (s pathname :if-does-not-exist nil
684 :external-format (or (find-external-format "latin-1-unix")
685 :default))
686 (if s
687 (or (let* ((line (read-line s nil))
688 (p (search "-*-" line)))
689 (when p
690 (let* ((start (+ p (length "-*-")))
691 (end (search "-*-" line :start2 start)))
692 (when end
693 (%search-coding line start end)))))
694 (let* ((len (file-length s))
695 (buf (make-string (min len 3000))))
696 (file-position s (- len (length buf)))
697 (read-sequence buf s)
698 (let ((start (search "Local Variables:" buf :from-end t))
699 (end (search "End:" buf :from-end t)))
700 (and start end (< start end)
701 (%search-coding buf start end))))))))
702
703 (defun %search-coding (str start end)
704 (let ((p (search "coding:" str :start2 start :end2 end)))
705 (when p
706 (incf p (length "coding:"))
707 (loop while (and (< p end)
708 (member (aref str p) '(#\space #\tab)))
709 do (incf p))
710 (let ((end (position-if (lambda (c) (find c '(#\space #\tab #\newline)))
711 str :start p)))
712 (find-external-format (subseq str p end))))))
713
714
715 ;;;; Streams
716
717 (definterface make-output-stream (write-string)
718 "Return a new character output stream.
719 The stream calls WRITE-STRING when output is ready.")
720
721 (definterface make-input-stream (read-string)
722 "Return a new character input stream.
723 The stream calls READ-STRING when input is needed.")
724
725
726 ;;;; Documentation
727
728 (definterface arglist (name)
729 "Return the lambda list for the symbol NAME. NAME can also be
730 a lisp function object, on lisps which support this.
731
732 The result can be a list or the :not-available keyword if the
733 arglist cannot be determined."
734 (declare (ignore name))
735 :not-available)
736
737 (defgeneric declaration-arglist (decl-identifier)
738 (:documentation
739 "Return the argument list of the declaration specifier belonging to the
740 declaration identifier DECL-IDENTIFIER. If the arglist cannot be determined,
741 the keyword :NOT-AVAILABLE is returned.
742
743 The different SWANK backends can specialize this generic function to
744 include implementation-dependend declaration specifiers, or to provide
745 additional information on the specifiers defined in ANSI Common Lisp.")
746 (:method (decl-identifier)
747 (case decl-identifier
748 (dynamic-extent '(&rest variables))
749 (ignore '(&rest variables))
750 (ignorable '(&rest variables))
751 (special '(&rest variables))
752 (inline '(&rest function-names))
753 (notinline '(&rest function-names))
754 (declaration '(&rest names))
755 (optimize '(&any compilation-speed debug safety space speed))
756 (type '(type-specifier &rest args))
757 (ftype '(type-specifier &rest function-names))
758 (otherwise
759 (flet ((typespec-p (symbol)
760 (member :type (describe-symbol-for-emacs symbol))))
761 (cond ((and (symbolp decl-identifier) (typespec-p decl-identifier))
762 '(&rest variables))
763 ((and (listp decl-identifier)
764 (typespec-p (first decl-identifier)))
765 '(&rest variables))
766 (t :not-available)))))))
767
768 (defgeneric type-specifier-arglist (typespec-operator)
769 (:documentation
770 "Return the argument list of the type specifier belonging to
771 TYPESPEC-OPERATOR.. If the arglist cannot be determined, the keyword
772 :NOT-AVAILABLE is returned.
773
774 The different SWANK backends can specialize this generic function to
775 include implementation-dependend declaration specifiers, or to provide
776 additional information on the specifiers defined in ANSI Common Lisp.")
777 (:method (typespec-operator)
778 (declare (special *type-specifier-arglists*)) ; defined at end of file.
779 (typecase typespec-operator
780 (symbol (or (cdr (assoc typespec-operator *type-specifier-arglists*))
781 :not-available))
782 (t :not-available))))
783
784 (definterface type-specifier-p (symbol)
785 "Determine if SYMBOL is a type-specifier."
786 (or (documentation symbol 'type)
787 (not (eq (type-specifier-arglist symbol) :not-available))))
788
789 (definterface function-name (function)
790 "Return the name of the function object FUNCTION.
791
792 The result is either a symbol, a list, or NIL if no function name is
793 available."
794 (declare (ignore function))
795 nil)
796
797 (definterface valid-function-name-p (form)
798 "Is FORM syntactically valid to name a function?
799 If true, FBOUNDP should not signal a type-error for FORM."
800 (flet ((length=2 (list)
801 (and (not (null (cdr list))) (null (cddr list)))))
802 (or (symbolp form)
803 (and (consp form) (length=2 form)
804 (eq (first form) 'setf) (symbolp (second form))))))
805
806 (definterface macroexpand-all (form)
807 "Recursively expand all macros in FORM.
808 Return the resulting form.")
809
810 (definterface compiler-macroexpand-1 (form &optional env)
811 "Call the compiler-macro for form.
812 If FORM is a function call for which a compiler-macro has been
813 defined, invoke the expander function using *macroexpand-hook* and
814 return the results and T. Otherwise, return the original form and
815 NIL."
816 (let ((fun (and (consp form)
817 (valid-function-name-p (car form))
818 (compiler-macro-function (car form)))))
819 (if fun
820 (let ((result (funcall *macroexpand-hook* fun form env)))
821 (values result (not (eq result form))))
822 (values form nil))))
823
824 (definterface compiler-macroexpand (form &optional env)
825 "Repetitively call `compiler-macroexpand-1'."
826 (labels ((frob (form expanded)
827 (multiple-value-bind (new-form newly-expanded)
828 (compiler-macroexpand-1 form env)
829 (if newly-expanded
830 (frob new-form t)
831 (values new-form expanded)))))
832 (frob form env)))
833
834 (definterface format-string-expand (control-string)
835 "Expand the format string CONTROL-STRING."
836 (macroexpand `(formatter ,control-string)))
837
838 (definterface describe-symbol-for-emacs (symbol)
839 "Return a property list describing SYMBOL.
840
841 The property list has an entry for each interesting aspect of the
842 symbol. The recognised keys are:
843
844 :VARIABLE :FUNCTION :SETF :SPECIAL-OPERATOR :MACRO :COMPILER-MACRO
845 :TYPE :CLASS :ALIEN-TYPE :ALIEN-STRUCT :ALIEN-UNION :ALIEN-ENUM
846
847 The value of each property is the corresponding documentation string,
848 or NIL (or the obsolete :NOT-DOCUMENTED). It is legal to include keys
849 not listed here (but slime-print-apropos in Emacs must know about
850 them).
851
852 Properties should be included if and only if they are applicable to
853 the symbol. For example, only (and all) fbound symbols should include
854 the :FUNCTION property.
855
856 Example:
857 \(describe-symbol-for-emacs 'vector)
858 => (:CLASS :NOT-DOCUMENTED
859 :TYPE :NOT-DOCUMENTED
860 :FUNCTION \"Constructs a simple-vector from the given objects.\")")
861
862 (definterface describe-definition (name type)
863 "Describe the definition NAME of TYPE.
864 TYPE can be any value returned by DESCRIBE-SYMBOL-FOR-EMACS.
865
866 Return a documentation string, or NIL if none is available.")
867
868
869 ;;;; Debugging
870
871 (definterface install-debugger-globally (function)
872 "Install FUNCTION as the debugger for all threads/processes. This
873 usually involves setting *DEBUGGER-HOOK* and, if the implementation
874 permits, hooking into BREAK as well."
875 (setq *debugger-hook* function))
876
877 (definterface call-with-debugging-environment (debugger-loop-fn)
878 "Call DEBUGGER-LOOP-FN in a suitable debugging environment.
879
880 This function is called recursively at each debug level to invoke the
881 debugger loop. The purpose is to setup any necessary environment for
882 other debugger callbacks that will be called within the debugger loop.
883
884 For example, this is a reasonable place to compute a backtrace, switch
885 to safe reader/printer settings, and so on.")
886
887 (definterface call-with-debugger-hook (hook fun)
888 "Call FUN and use HOOK as debugger hook. HOOK can be NIL.
889
890 HOOK should be called for both BREAK and INVOKE-DEBUGGER."
891 (let ((*debugger-hook* hook))
892 (funcall fun)))
893
894 (define-condition sldb-condition (condition)
895 ((original-condition
896 :initarg :original-condition
897 :accessor original-condition))
898 (:report (lambda (condition stream)
899 (format stream "Condition in debugger code~@[: ~A~]"
900 (original-condition condition))))
901 (:documentation
902 "Wrapper for conditions that should not be debugged.
903
904 When a condition arises from the internals of the debugger, it is not
905 desirable to debug it -- we'd risk entering an endless loop trying to
906 debug the debugger! Instead, such conditions can be reported to the
907 user without (re)entering the debugger by wrapping them as
908 `sldb-condition's."))
909
910 ;;; The following functions in this section are supposed to be called
911 ;;; within the dynamic contour of CALL-WITH-DEBUGGING-ENVIRONMENT only.
912
913 (definterface compute-backtrace (start end)
914 "Returns a backtrace of the condition currently being debugged,
915 that is an ordered list consisting of frames. ``Ordered list''
916 means that an integer I can be mapped back to the i-th frame of this
917 backtrace.
918
919 START and END are zero-based indices constraining the number of frames
920 returned. Frame zero is defined as the frame which invoked the
921 debugger. If END is nil, return the frames from START to the end of
922 the stack.")
923
924 (definterface print-frame (frame stream)
925 "Print frame to stream.")
926
927 (definterface frame-restartable-p (frame)
928 "Is the frame FRAME restartable?.
929 Return T if `restart-frame' can safely be called on the frame."
930 (declare (ignore frame))
931 nil)
932
933 (definterface frame-source-location (frame-number)
934 "Return the source location for the frame associated to FRAME-NUMBER.")
935
936 (definterface frame-catch-tags (frame-number)
937 "Return a list of catch tags for being printed in a debugger stack
938 frame."
939 (declare (ignore frame-number))
940 '())
941
942 (definterface frame-locals (frame-number)
943 "Return a list of ((&key NAME ID VALUE) ...) where each element of
944 the list represents a local variable in the stack frame associated to
945 FRAME-NUMBER.
946
947 NAME, a symbol; the name of the local variable.
948
949 ID, an integer; used as primary key for the local variable, unique
950 relatively to the frame under operation.
951
952 value, an object; the value of the local variable.")
953
954 (definterface frame-var-value (frame-number var-id)
955 "Return the value of the local variable associated to VAR-ID
956 relatively to the frame associated to FRAME-NUMBER.")
957
958 (definterface disassemble-frame (frame-number)
959 "Disassemble the code for the FRAME-NUMBER.
960 The output should be written to standard output.
961 FRAME-NUMBER is a non-negative integer.")
962
963 (definterface eval-in-frame (form frame-number)
964 "Evaluate a Lisp form in the lexical context of a stack frame
965 in the debugger.
966
967 FRAME-NUMBER must be a positive integer with 0 indicating the
968 frame which invoked the debugger.
969
970 The return value is the result of evaulating FORM in the
971 appropriate context.")
972
973 (definterface frame-package (frame-number)
974 "Return the package corresponding to the frame at FRAME-NUMBER.
975 Return nil if the backend can't figure it out."
976 (declare (ignore frame-number))
977 nil)
978
979 (definterface frame-call (frame-number)
980 "Return a string representing a call to the entry point of a frame.")
981
982 (definterface return-from-frame (frame-number form)
983 "Unwind the stack to the frame FRAME-NUMBER and return the value(s)
984 produced by evaluating FORM in the frame context to its caller.
985
986 Execute any clean-up code from unwind-protect forms above the frame
987 during unwinding.
988
989 Return a string describing the error if it's not possible to return
990 from the frame.")
991
992 (definterface restart-frame (frame-number)
993 "Restart execution of the frame FRAME-NUMBER with the same arguments
994 as it was called originally.")
995
996 (definterface format-sldb-condition (condition)
997 "Format a condition for display in SLDB."
998 (princ-to-string condition))
999
1000 (definterface condition-extras (condition)
1001 "Return a list of extra for the debugger.
1002 The allowed elements are of the form:
1003 (:SHOW-FRAME-SOURCE frame-number)
1004 (:REFERENCES &rest refs)
1005 "
1006 (declare (ignore condition))
1007 '())
1008
1009 (definterface gdb-initial-commands ()
1010 "List of gdb commands supposed to be executed first for the
1011 ATTACH-GDB restart."
1012 nil)
1013
1014 (definterface activate-stepping (frame-number)
1015 "Prepare the frame FRAME-NUMBER for stepping.")
1016
1017 (definterface sldb-break-on-return (frame-number)
1018 "Set a breakpoint in the frame FRAME-NUMBER.")
1019
1020 (definterface sldb-break-at-start (symbol)
1021 "Set a breakpoint on the beginning of the function for SYMBOL.")
1022
1023 (definterface sldb-stepper-condition-p (condition)
1024 "Return true if SLDB was invoked due to a single-stepping condition,
1025 false otherwise. "
1026 (declare (ignore condition))
1027 nil)
1028
1029 (definterface sldb-step-into ()
1030 "Step into the current single-stepper form.")
1031
1032 (definterface sldb-step-next ()
1033 "Step to the next form in the current function.")
1034
1035 (definterface sldb-step-out ()
1036 "Stop single-stepping temporarily, but resume it once the current function
1037 returns.")
1038
1039
1040 ;;;; Definition finding
1041
1042 (defstruct (:location (:type list) :named
1043 (:constructor make-location
1044 (buffer position &optional hints)))
1045 buffer position
1046 ;; Hints is a property list optionally containing:
1047 ;; :snippet SOURCE-TEXT
1048 ;; This is a snippet of the actual source text at the start of
1049 ;; the definition, which could be used in a text search.
1050 hints)
1051
1052 (defstruct (:error (:type list) :named (:constructor)) message)
1053
1054 ;;; Valid content for BUFFER slot
1055 (defstruct (:file (:type list) :named (:constructor)) name)
1056 (defstruct (:buffer (:type list) :named (:constructor)) name)
1057 (defstruct (:etags-file (:type list) :named (:constructor)) filename)
1058
1059 ;;; Valid content for POSITION slot
1060 (defstruct (:position (:type list) :named (:constructor)) pos)
1061 (defstruct (:tag (:type list) :named (:constructor)) tag1 tag2)
1062
1063 (defmacro converting-errors-to-error-location (&body body)
1064 "Catches errors during BODY and converts them to an error location."
1065 (let ((gblock (gensym "CONVERTING-ERRORS+")))
1066 `(block ,gblock
1067 (handler-bind ((error
1068 #'(lambda (e)
1069 (if *debug-swank-backend*
1070 nil ;decline
1071 (return-from ,gblock
1072 (make-error-location e))))))
1073 ,@body))))
1074
1075 (defun make-error-location (datum &rest args)
1076 (cond ((typep datum 'condition)
1077 `(:error ,(format nil "Error: ~A" datum)))
1078 ((symbolp datum)
1079 `(:error ,(format nil "Error: ~A"
1080 (apply #'make-condition datum args))))
1081 (t
1082 (assert (stringp datum))
1083 `(:error ,(apply #'format nil datum args)))))
1084
1085 (definterface find-definitions (name)
1086 "Return a list ((DSPEC LOCATION) ...) for NAME's definitions.
1087
1088 NAME is a \"definition specifier\".
1089
1090 DSPEC is a \"definition specifier\" describing the
1091 definition, e.g., FOO or (METHOD FOO (STRING NUMBER)) or
1092 \(DEFVAR FOO).
1093
1094 LOCATION is the source location for the definition.")
1095
1096 (definterface find-source-location (object)
1097 "Returns the source location of OBJECT, or NIL.
1098
1099 That is the source location of the underlying datastructure of
1100 OBJECT. E.g. on a STANDARD-OBJECT, the source location of the
1101 respective DEFCLASS definition is returned, on a STRUCTURE-CLASS the
1102 respective DEFSTRUCT definition, and so on."
1103 ;; This returns one source location and not a list of locations. It's
1104 ;; supposed to return the location of the DEFGENERIC definition on
1105 ;; #'SOME-GENERIC-FUNCTION.
1106 (declare (ignore object))
1107 (make-error-location "FIND-DEFINITIONS is not yet implemented on ~
1108 this implementation."))
1109
1110 (definterface buffer-first-change (filename)
1111 "Called for effect the first time FILENAME's buffer is modified.
1112 CMUCL/SBCL use this to cache the unmodified file and use the
1113 unmodified text to improve the precision of source locations."
1114 (declare (ignore filename))
1115 nil)
1116
1117
1118
1119 ;;;; XREF
1120
1121 (definterface who-calls (function-name)
1122 "Return the call sites of FUNCTION-NAME (a symbol).
1123 The results is a list ((DSPEC LOCATION) ...)."
1124 (declare (ignore function-name))
1125 :not-implemented)
1126
1127 (definterface calls-who (function-name)
1128 "Return the call sites of FUNCTION-NAME (a symbol).
1129 The results is a list ((DSPEC LOCATION) ...)."
1130 (declare (ignore function-name))
1131 :not-implemented)
1132
1133 (definterface who-references (variable-name)
1134 "Return the locations where VARIABLE-NAME (a symbol) is referenced.
1135 See WHO-CALLS for a description of the return value."
1136 (declare (ignore variable-name))
1137 :not-implemented)
1138
1139 (definterface who-binds (variable-name)
1140 "Return the locations where VARIABLE-NAME (a symbol) is bound.
1141 See WHO-CALLS for a description of the return value."
1142 (declare (ignore variable-name))
1143 :not-implemented)
1144
1145 (definterface who-sets (variable-name)
1146 "Return the locations where VARIABLE-NAME (a symbol) is set.
1147 See WHO-CALLS for a description of the return value."
1148 (declare (ignore variable-name))
1149 :not-implemented)
1150
1151 (definterface who-macroexpands (macro-name)
1152 "Return the locations where MACRO-NAME (a symbol) is expanded.
1153 See WHO-CALLS for a description of the return value."
1154 (declare (ignore macro-name))
1155 :not-implemented)
1156
1157 (definterface who-specializes (class-name)
1158 "Return the locations where CLASS-NAME (a symbol) is specialized.
1159 See WHO-CALLS for a description of the return value."
1160 (declare (ignore class-name))
1161 :not-implemented)
1162
1163 ;;; Simpler variants.
1164
1165 (definterface list-callers (function-name)
1166 "List the callers of FUNCTION-NAME.
1167 This function is like WHO-CALLS except that it is expected to use
1168 lower-level means. Whereas WHO-CALLS is usually implemented with
1169 special compiler support, LIST-CALLERS is usually implemented by
1170 groveling for constants in function objects throughout the heap.
1171
1172 The return value is as for WHO-CALLS.")
1173
1174 (definterface list-callees (function-name)
1175 "List the functions called by FUNCTION-NAME.
1176 See LIST-CALLERS for a description of the return value.")
1177
1178
1179 ;;;; Profiling
1180
1181 ;;; The following functions define a minimal profiling interface.
1182
1183 (definterface profile (fname)
1184 "Marks symbol FNAME for profiling.")
1185
1186 (definterface profiled-functions ()
1187 "Returns a list of profiled functions.")
1188
1189 (definterface unprofile (fname)
1190 "Marks symbol FNAME as not profiled.")
1191
1192 (definterface unprofile-all ()
1193 "Marks all currently profiled functions as not profiled."
1194 (dolist (f (profiled-functions))
1195 (unprofile f)))
1196
1197 (definterface profile-report ()
1198 "Prints profile report.")
1199
1200 (definterface profile-reset ()
1201 "Resets profile counters.")
1202
1203 (definterface profile-package (package callers-p methods)
1204 "Wrap profiling code around all functions in PACKAGE. If a function
1205 is already profiled, then unprofile and reprofile (useful to notice
1206 function redefinition.)
1207
1208 If CALLERS-P is T names have counts of the most common calling
1209 functions recorded.
1210
1211 When called with arguments :METHODS T, profile all methods of all
1212 generic functions having names in the given package. Generic functions
1213 themselves, that is, their dispatch functions, are left alone.")
1214
1215
1216 ;;;; Trace
1217
1218 (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
1228
1229 ;;;; Inspector
1230
1231 (defgeneric emacs-inspect (object)
1232 (:documentation
1233 "Explain to Emacs how to inspect OBJECT.
1234
1235 Returns a list specifying how to render the object for inspection.
1236
1237 Every element of the list must be either a string, which will be
1238 inserted into the buffer as is, or a list of the form:
1239
1240 (:value object &optional format) - Render an inspectable
1241 object. If format is provided it must be a string and will be
1242 rendered in place of the value, otherwise use princ-to-string.
1243
1244 (:newline) - Render a \\n
1245
1246 (:action label lambda &key (refresh t)) - Render LABEL (a text
1247 string) which when clicked will call LAMBDA. If REFRESH is
1248 non-NIL the currently inspected object will be re-inspected
1249 after calling the lambda.
1250 "))
1251
1252 (defmethod emacs-inspect ((object t))
1253 "Generic method for inspecting any kind of object.
1254
1255 Since we don't know how to deal with OBJECT we simply dump the
1256 output of CL:DESCRIBE."
1257 `("Type: " (:value ,(type-of object)) (:newline)
1258 "Don't know how to inspect the object, dumping output of CL:DESCRIBE:"
1259 (:newline) (:newline)
1260 ,(with-output-to-string (desc) (describe object desc))))
1261
1262 (definterface eval-context (object)
1263 "Return a list of bindings corresponding to OBJECT's slots."
1264 (declare (ignore object))
1265 '())
1266
1267 ;;; Utilities for inspector methods.
1268 ;;;
1269
1270 (defun label-value-line (label value &key (newline t))
1271 "Create a control list which prints \"LABEL: VALUE\" in the inspector.
1272 If NEWLINE is non-NIL a `(:newline)' is added to the result."
1273 (list* (princ-to-string label) ": " `(:value ,value)
1274 (if newline '((:newline)) nil)))
1275
1276 (defmacro label-value-line* (&rest label-values)
1277 ` (append ,@(loop for (label value) in label-values
1278 collect `(label-value-line ,label ,value))))
1279
1280 (definterface describe-primitive-type (object)
1281 "Return a string describing the primitive type of object."
1282 (declare (ignore object))
1283 "N/A")
1284
1285
1286 ;;;; Multithreading
1287 ;;;
1288 ;;; The default implementations are sufficient for non-multiprocessing
1289 ;;; implementations.
1290
1291 (definterface initialize-multiprocessing (continuation)
1292 "Initialize multiprocessing, if necessary and then invoke CONTINUATION.
1293
1294 Depending on the impleimentaion, this function may never return."
1295 (funcall continuation))
1296
1297 (definterface spawn (fn &key name)
1298 "Create a new thread to call FN.")
1299
1300 (definterface thread-id (thread)
1301 "Return an Emacs-parsable object to identify THREAD.
1302
1303 Ids should be comparable with equal, i.e.:
1304 (equal (thread-id <t1>) (thread-id <t2>)) <==> (eq <t1> <t2>)"
1305 thread)
1306
1307 (definterface find-thread (id)
1308 "Return the thread for ID.
1309 ID should be an id previously obtained with THREAD-ID.
1310 Can return nil if the thread no longer exists."
1311 (declare (ignore id))
1312 (current-thread))
1313
1314 (definterface thread-name (thread)
1315 "Return the name of THREAD.
1316 Thread names are short strings meaningful to the user. They do not
1317 have to be unique."
1318 (declare (ignore thread))
1319 "The One True Thread")
1320
1321 (definterface thread-status (thread)
1322 "Return a string describing THREAD's state."
1323 (declare (ignore thread))
1324 "")
1325
1326 (definterface thread-attributes (thread)
1327 "Return a plist of implementation-dependent attributes for THREAD"
1328 (declare (ignore thread))
1329 '())
1330
1331 (definterface current-thread ()
1332 "Return the currently executing thread."
1333 0)
1334
1335 (definterface all-threads ()
1336 "Return a fresh list of all threads."
1337 '())
1338
1339 (definterface thread-alive-p (thread)
1340 "Test if THREAD is termintated."
1341 (member thread (all-threads)))
1342
1343 (definterface interrupt-thread (thread fn)
1344 "Cause THREAD to execute FN.")
1345
1346 (definterface kill-thread (thread)
1347 "Terminate THREAD immediately.
1348 Don't execute unwind-protected sections, don't raise conditions.
1349 (Do not pass go, do not collect $200.)"
1350 (declare (ignore thread))
1351 nil)
1352
1353 (definterface send (thread object)
1354 "Send OBJECT to thread THREAD."
1355 (declare (ignore thread))
1356 object)
1357
1358 (definterface receive (&optional timeout)
1359 "Return the next message from current thread's mailbox."
1360 (receive-if (constantly t) timeout))
1361
1362 (definterface receive-if (predicate &optional timeout)
1363 "Return the first message satisfiying PREDICATE.")
1364
1365 (definterface register-thread (name thread)
1366 "Associate the thread THREAD with the symbol NAME.
1367 The thread can then be retrieved with `find-registered'.
1368 If THREAD is nil delete the association."
1369 (declare (ignore name thread))
1370 nil)
1371
1372 (definterface find-registered (name)
1373 "Find the thread that was registered for the symbol NAME.
1374 Return nil if the no thread was registred or if the tread is dead."
1375 (declare (ignore name))
1376 nil)
1377
1378 (definterface set-default-initial-binding (var form)
1379 "Initialize special variable VAR by default with FORM.
1380
1381 Some implementations initialize certain variables in each newly
1382 created thread. This function sets the form which is used to produce
1383 the initial value."
1384 (set var (eval form)))
1385
1386 ;; List of delayed interrupts.
1387 ;; This should only have thread-local bindings, so no init form.
1388 (defvar *pending-slime-interrupts*)
1389
1390 (defun check-slime-interrupts ()
1391 "Execute pending interrupts if any.
1392 This should be called periodically in operations which
1393 can take a long time to complete.
1394 Return a boolean indicating whether any interrupts was processed."
1395 (when (and (boundp '*pending-slime-interrupts*)
1396 *pending-slime-interrupts*)
1397 (funcall (pop *pending-slime-interrupts*))
1398 t))
1399
1400 (defvar *interrupt-queued-handler* nil
1401 "Function to call on queued interrupts.
1402 Interrupts get queued when an interrupt occurs while interrupt
1403 handling is disabled.
1404
1405 Backends can use this function to abort slow operations.")
1406
1407 (definterface wait-for-input (streams &optional timeout)
1408 "Wait for input on a list of streams. Return those that are ready.
1409 STREAMS is a list of streams
1410 TIMEOUT nil, t, or real number. If TIMEOUT is t, return those streams
1411 which are ready (or have reached end-of-file) without waiting.
1412 If TIMEOUT is a number and no streams is ready after TIMEOUT seconds,
1413 return nil.
1414
1415 Return :interrupt if an interrupt occurs while waiting.")
1416
1417
1418 ;;;; Locks
1419
1420 ;; Please use locks only in swank-gray.lisp. Locks are too low-level
1421 ;; for our taste.
1422
1423 (definterface make-lock (&key name)
1424 "Make a lock for thread synchronization.
1425 Only one thread may hold the lock (via CALL-WITH-LOCK-HELD) at a time
1426 but that thread may hold it more than once."
1427 (declare (ignore name))
1428 :null-lock)
1429
1430 (definterface call-with-lock-held (lock function)
1431 "Call FUNCTION with LOCK held, queueing if necessary."
1432 (declare (ignore lock)
1433 (type function function))
1434 (funcall function))
1435
1436
1437 ;;;; Weak datastructures
1438
1439 (definterface make-weak-key-hash-table (&rest args)
1440 "Like MAKE-HASH-TABLE, but weak w.r.t. the keys."
1441 (apply #'make-hash-table args))
1442
1443 (definterface make-weak-value-hash-table (&rest args)
1444 "Like MAKE-HASH-TABLE, but weak w.r.t. the values."
1445 (apply #'make-hash-table args))
1446
1447 (definterface hash-table-weakness (hashtable)
1448 "Return nil or one of :key :value :key-or-value :key-and-value"
1449 (declare (ignore hashtable))
1450 nil)
1451
1452
1453 ;;;; Character names
1454
1455 (definterface character-completion-set (prefix matchp)
1456 "Return a list of names of characters that match PREFIX."
1457 ;; Handle the standard and semi-standard characters.
1458 (loop for name in '("Newline" "Space" "Tab" "Page" "Rubout"
1459 "Linefeed" "Return" "Backspace")
1460 when (funcall matchp prefix name)
1461 collect name))
1462
1463
1464 (defparameter *type-specifier-arglists*
1465 '((and . (&rest type-specifiers))
1466 (array . (&optional element-type dimension-spec))
1467 (base-string . (&optional size))
1468 (bit-vector . (&optional size))
1469 (complex . (&optional type-specifier))
1470 (cons . (&optional car-typespec cdr-typespec))
1471 (double-float . (&optional lower-limit upper-limit))
1472 (eql . (object))
1473 (float . (&optional lower-limit upper-limit))
1474 (function . (&optional arg-typespec value-typespec))
1475 (integer . (&optional lower-limit upper-limit))
1476 (long-float . (&optional lower-limit upper-limit))
1477 (member . (&rest eql-objects))
1478 (mod . (n))
1479 (not . (type-specifier))
1480 (or . (&rest type-specifiers))
1481 (rational . (&optional lower-limit upper-limit))
1482 (real . (&optional lower-limit upper-limit))
1483 (satisfies . (predicate-symbol))
1484 (short-float . (&optional lower-limit upper-limit))
1485 (signed-byte . (&optional size))
1486 (simple-array . (&optional element-type dimension-spec))
1487 (simple-base-string . (&optional size))
1488 (simple-bit-vector . (&optional size))
1489 (simple-string . (&optional size))
1490 (single-float . (&optional lower-limit upper-limit))
1491 (simple-vector . (&optional size))
1492 (string . (&optional size))
1493 (unsigned-byte . (&optional size))
1494 (values . (&rest typespecs))
1495 (vector . (&optional element-type size))
1496 ))
1497
1498 ;;; Heap dumps
1499
1500 (definterface save-image (filename &optional restart-function)
1501 "Save a heap image to the file FILENAME.
1502 RESTART-FUNCTION, if non-nil, should be called when the image is loaded.")
1503
1504 (definterface background-save-image (filename &key restart-function
1505 completion-function)
1506 "Request saving a heap image to the file FILENAME.
1507 RESTART-FUNCTION, if non-nil, should be called when the image is loaded.
1508 COMPLETION-FUNCTION, if non-nil, should be called after saving the image.")
1509
1510 (defun deinit-log-output ()
1511 ;; Can't hang on to an fd-stream from a previous session.
1512 (setf (symbol-value (find-symbol "*LOG-OUTPUT*" 'swank))
1513 nil))

  ViewVC Help
Powered by ViewVC 1.1.5