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

Contents of /slime/swank-backend.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.212 - (show annotations)
Mon Nov 21 16:34:12 2011 UTC (2 years, 4 months ago) by heller
Branch: MAIN
Changes since 1.211: +6 -0 lines
* slime.el (sldb-eval-in-frame): Try to figure the package out.
Ask Lisp if the function for frame was defined in a particular
package and use it to read the form.
(sldb-read-form-for-frame): New helper.

* swank-backend (frame-package): New.
* swank-cmucl (frame-package): Implement it.

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

  ViewVC Help
Powered by ViewVC 1.1.5