swank-backend.lisp 52.4 KB
Newer Older
Luke Gorrie's avatar
Luke Gorrie committed
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
;;;
Luke Gorrie's avatar
Luke Gorrie committed
7 8
;;;; Frontmatter
;;;
9 10 11
;;; This file defines the functions that must be implemented
;;; separately for each Lisp. Each is declared as a generic function
;;; for which swank-<implementation>.lisp provides methods.
12

13
(defpackage :swank-backend
14
  (:use :common-lisp)
15 16
  (:export #:*debug-swank-backend*
           #:sldb-condition
17
           #:compiler-condition
18
           #:original-condition
19
           #:message
20
           #:source-context
21 22
           #:condition
           #:severity
23
           #:with-compilation-hooks
24 25 26 27 28 29 30
           #:location
           #:location-p
           #:location-buffer
           #:location-position
           #:position-p
           #:position-pos
           #:print-output-to-string
31
           #:quit-lisp
32
           #:references
33
           #:unbound-slot-filler
34 35
           #:declaration-arglist
           #:type-specifier-arglist
36
           #:with-struct
37
           #:when-let
38 39 40
           ;; interrupt macro for the backend
           #:*pending-slime-interrupts*
           #:check-slime-interrupts
41
           #:*interrupt-queued-handler*
42
           ;; inspector related symbols
Helmut Eller's avatar
Helmut Eller committed
43
           #:emacs-inspect
44 45
           #:label-value-line
           #:label-value-line*
46
           #:with-symbol))
47

48 49 50 51 52 53 54 55
(defpackage :swank-mop
  (:use)
  (:export
   ;; classes
   #:standard-generic-function
   #:standard-slot-definition
   #:standard-method
   #:standard-class
56 57
   #:eql-specializer
   #:eql-specializer-object
58 59 60 61 62 63 64 65 66 67 68
   ;; standard-class readers
   #:class-default-initargs
   #:class-direct-default-initargs
   #:class-direct-slots
   #:class-direct-subclasses
   #:class-direct-superclasses
   #:class-finalized-p
   #:class-name
   #:class-precedence-list
   #:class-prototype
   #:class-slots
69
   #:specializer-direct-methods
70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92
   ;; generic function readers
   #:generic-function-argument-precedence-order
   #:generic-function-declarations
   #:generic-function-lambda-list
   #:generic-function-methods
   #:generic-function-method-class
   #:generic-function-method-combination
   #:generic-function-name
   ;; method readers
   #:method-generic-function
   #:method-function
   #:method-lambda-list
   #:method-specializers
   #:method-qualifiers
   ;; slot readers
   #:slot-definition-allocation
   #:slot-definition-documentation
   #:slot-definition-initargs
   #:slot-definition-initform
   #:slot-definition-initfunction
   #:slot-definition-name
   #:slot-definition-type
   #:slot-definition-readers
93
   #:slot-definition-writers
Helmut Eller's avatar
Helmut Eller committed
94 95
   #:slot-boundp-using-class
   #:slot-value-using-class
96
   #:slot-makunbound-using-class
97
   ;; generic function protocol
98 99
   #:compute-applicable-methods-using-classes
   #:finalize-inheritance))
100

101
(in-package :swank-backend)
102

103 104 105

;;;; Metacode

106 107 108 109 110
(defparameter *debug-swank-backend* nil
  "If this is true, backends should not catch errors but enter the
debugger where appropriate. Also, they should not perform backtrace
magic but really show every frame including SWANK related ones.")

111 112 113 114 115 116 117
(defparameter *interface-functions* '()
  "The names of all interface functions.")

(defparameter *unimplemented-interfaces* '()
  "List of interface functions that are not implemented.
DEFINTERFACE adds to this list and DEFIMPLEMENTATION removes.")

118
(defmacro definterface (name args documentation &rest default-body)
119
  "Define an interface function for the backend to implement.
120 121 122 123 124
A function is defined with NAME, ARGS, and DOCUMENTATION.  This
function first looks for a function to call in NAME's property list
that is indicated by 'IMPLEMENTATION; failing that, it looks for a
function indicated by 'DEFAULT. If neither is present, an error is
signaled.
125

126 127 128
If a DEFAULT-BODY is supplied, then a function with the same body and
ARGS will be added to NAME's property list as the property indicated
by 'DEFAULT.
129 130

Backends implement these functions using DEFIMPLEMENTATION."
Luke Gorrie's avatar
Luke Gorrie committed
131
  (check-type documentation string "a documentation string")
132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157
  (assert (every #'symbolp args) ()
          "Complex lambda-list not supported: ~S ~S" name args)
  (labels ((gen-default-impl ()
             `(setf (get ',name 'default) (lambda ,args ,@default-body)))
           (args-as-list (args)
             (destructuring-bind (req opt key rest) (parse-lambda-list args)
               `(,@req ,@opt 
                       ,@(loop for k in key append `(,(kw k) ,k)) 
                       ,@(or rest '(())))))
           (parse-lambda-list (args)
             (parse args '(&optional &key &rest) 
                    (make-array 4 :initial-element nil)))
           (parse (args keywords vars)
             (cond ((null args) 
                    (reverse (map 'list #'reverse vars)))
                   ((member (car args) keywords)
                    (parse (cdr args) (cdr (member (car args) keywords)) vars))
                   (t (push (car args) (aref vars (length keywords)))
                      (parse (cdr args) keywords vars))))
           (kw (s) (intern (string s) :keyword)))
    `(progn 
       (defun ,name ,args
         ,documentation
         (let ((f (or (get ',name 'implementation)
                      (get ',name 'default))))
           (cond (f (apply f ,@(args-as-list args)))
158
                 (t (error "~S not implemented" ',name)))))
159 160 161 162 163 164 165
       (pushnew ',name *interface-functions*)
       ,(if (null default-body)
            `(pushnew ',name *unimplemented-interfaces*)
            (gen-default-impl))
       (eval-when (:compile-toplevel :load-toplevel :execute)
         (export ',name :swank-backend))
       ',name)))
166 167

(defmacro defimplementation (name args &body body)
168 169
  (assert (every #'symbolp args) ()
          "Complex lambda-list not supported: ~S ~S" name args)
170
  `(progn
171 172 173
     (setf (get ',name 'implementation)
           ;; For implicit BLOCK. FLET because of interplay w/ decls.
           (flet ((,name ,args ,@body)) #',name))
174 175 176 177 178
     (if (member ',name *interface-functions*)
         (setq *unimplemented-interfaces*
               (remove ',name *unimplemented-interfaces*))
         (warn "DEFIMPLEMENTATION of undefined interface (~S)" ',name))
     ',name))
179 180 181 182

(defun warn-unimplemented-interfaces ()
  "Warn the user about unimplemented backend features.
The portable code calls this function at startup."
183 184 185
  (let ((*print-pretty* t))
    (warn "These Swank interfaces are unimplemented:~% ~:<~{~A~^ ~:_~}~:>"
          (list (sort (copy-list *unimplemented-interfaces*) #'string<)))))
186

187 188 189 190 191 192 193 194 195 196 197 198 199 200
(defun import-to-swank-mop (symbol-list)
  (dolist (sym symbol-list)
    (let* ((swank-mop-sym (find-symbol (symbol-name sym) :swank-mop)))
      (when swank-mop-sym
        (unintern swank-mop-sym :swank-mop))
      (import sym :swank-mop)
      (export sym :swank-mop))))

(defun import-swank-mop-symbols (package except)
  "Import the mop symbols from PACKAGE to SWANK-MOP.
EXCEPT is a list of symbol names which should be ignored."
  (do-symbols (s :swank-mop)
    (unless (member s except :test #'string=)
      (let ((real-symbol (find-symbol (string s) package)))
201
        (assert real-symbol () "Symbol ~A not found in package ~A" s package)
202 203 204 205
        (unintern s :swank-mop)
        (import real-symbol :swank-mop)
        (export real-symbol :swank-mop)))))

206 207 208
(defvar *gray-stream-symbols*
  '(:fundamental-character-output-stream
    :stream-write-char
209
    :stream-write-string
210 211 212 213 214
    :stream-fresh-line
    :stream-force-output
    :stream-finish-output
    :fundamental-character-input-stream
    :stream-read-char
215 216
    :stream-peek-char
    :stream-read-line
217 218 219
    ;; STREAM-FILE-POSITION is not available on all implementations, or
    ;; partially under a different name.
    ; :stream-file-posiion
220 221 222 223
    :stream-listen
    :stream-unread-char
    :stream-clear-input
    :stream-line-column
224 225
    :stream-read-char-no-hang
    ;; STREAM-LINE-LENGTH is an extension to gray streams that's apparently
226 227
    ;; supported by CMUCL, OpenMCL, SBCL and SCL.
    #+(or cmu openmcl sbcl scl)
228
    :stream-line-length))
229 230 231 232 233 234 235 236

(defun import-from (package symbol-names &optional (to-package *package*))
  "Import the list of SYMBOL-NAMES found in the package PACKAGE."
  (dolist (name symbol-names)
    (multiple-value-bind (symbol found) (find-symbol (string name) package)
      (assert found () "Symbol ~A not found in package ~A" name package)
      (import symbol to-package))))

237

Helmut Eller's avatar
Helmut Eller committed
238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254
;;;; Utilities

(defmacro with-struct ((conc-name &rest names) obj &body body)
  "Like with-slots but works only for structs."
  (flet ((reader (slot) (intern (concatenate 'string
					     (symbol-name conc-name)
					     (symbol-name slot))
				(symbol-package conc-name))))
    (let ((tmp (gensym "OO-")))
    ` (let ((,tmp ,obj))
        (symbol-macrolet
            ,(loop for name in names collect 
                   (typecase name
                     (symbol `(,name (,(reader name) ,tmp)))
                     (cons `(,(first name) (,(reader (second name)) ,tmp)))
                     (t (error "Malformed syntax in WITH-STRUCT: ~A" name))))
          ,@body)))))
255

256 257 258 259
(defmacro when-let ((var value) &body body)
  `(let ((,var ,value))
     (when ,var ,@body)))

260 261
(defun with-symbol (name package)
  "Generate a form suitable for testing with #+."
262 263
  (if (and (find-package package)
           (find-symbol (string name) package))
264 265 266
      '(:and)
      '(:or)))

267 268 269

;;;; UFT8

270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423
(deftype octet () '(unsigned-byte 8))
(deftype octets () '(simple-array octet (*)))

;; Helper function.  Decode the next N bytes starting from INDEX.
;; Return the decoded char and the new index.
(defun utf8-decode-aux (buffer index limit byte0 n)
  (declare (type octets buffer) (fixnum index limit byte0 n))
  (if (< (- limit index) n)
      (values nil index)
      (do ((i 0 (1+ i))
           (code byte0 (let ((byte (aref buffer (+ index i))))
                         (cond ((= (ldb (byte 2 6) byte) #b10)
                                (+ (ash code 6) (ldb (byte 6 0) byte)))
                               (t
                                (error "Invalid encoding"))))))
          ((= i n)
           (values (cond ((<= code #xff) (code-char code))
                         ((<= #xd800 code #xdfff)
                          (error "Invalid Unicode code point: #x~x" code))
                         ((and (< code char-code-limit) 
                               (code-char code)))
                         (t
                          (error
                           "Can't represent code point: #x~x ~
                            (char-code-limit is #x~x)" 
                           code char-code-limit)))
                   (+ index n))))))

;; Decode one character in BUFFER starting at INDEX.
;; Return 2 values: the character and the new index.
;; If there aren't enough bytes between INDEX and LIMIT return nil. 
(defun utf8-decode (buffer index limit)
  (declare (type octets buffer) (fixnum index limit))
  (if (= index limit)
      (values nil index)
      (let ((b (aref buffer index)))
        (if (<= b #x7f)
            (values (code-char b) (1+ index))
            (macrolet ((try (marker else)
                         (let* ((l (integer-length marker))
                                (n (- l 2)))
                           `(if (= (ldb (byte ,l ,(- 8 l)) b) ,marker)
                                (utf8-decode-aux buffer (1+ index) limit
                                                 (ldb (byte ,(- 8 l) 0) b)
                                                 ,n)
                                ,else))))
              (try #b110
                   (try #b1110
                        (try #b11110
                             (try #b111110
                                  (try #b1111110
                                       (error "Invalid encoding")))))))))))

;; Decode characters from BUFFER and write them to STRING.
;; Return 2 values: LASTINDEX and LASTSTART where
;; LASTINDEX is the last index in BUFFER that was not decoded
;; and LASTSTART is the last index in STRING not written.
(defun utf8-decode-into (buffer index limit string start end)
  (declare (string string) (fixnum index limit start end) (type octets buffer))
  (loop
   (cond ((= start end)
          (return (values index start)))
         (t
          (multiple-value-bind (c i) (utf8-decode buffer index limit)
            (cond (c
                   (setf (aref string start) c)
                   (setq index i)
                   (setq start (1+ start)))
                  (t
                   (return (values index start)))))))))

(defun default-utf8-to-string (octets)
  (let* ((limit (length octets))
         (str (make-string limit)))
    (multiple-value-bind (i s) (utf8-decode-into octets 0 limit str 0 limit)
      (if (= i limit)
          (if (= limit s)
              str
              (adjust-array str s))
          (loop
           (let ((end (+ (length str) (- limit i))))
             (setq str (adjust-array str end))
             (multiple-value-bind (i2 s2)
                 (utf8-decode-into octets i limit str s end)
               (cond ((= i2 limit)
                      (return (adjust-array str s2)))
                     (t
                      (setq i i2)
                      (setq s s2))))))))))

(defmacro utf8-encode-aux (code buffer start end n)
  `(cond ((< (- ,end ,start) ,n)
          ,start)
         (t
          (setf (aref ,buffer ,start)
                (dpb (ldb (byte ,(- 7 n) ,(* 6 (1- n))) ,code)
                     (byte ,(- 7 n) 0)
                     ,(dpb 0 (byte 1 (- 7 n)) #xff)))
          ,@(loop for i from 0 upto (- n 2) collect
                  `(setf (aref ,buffer (+ ,start ,(- n 1 i)))
                         (dpb (ldb (byte 6 ,(* 6 i)) ,code)
                              (byte 6 0)
                              #b10111111)))
          (+ ,start ,n))))

(defun utf8-encode (char buffer start end)
  (declare (character char) (type octets buffer) (fixnum start end))
  (let ((code (char-code char)))
    (cond ((<= code #x7f)
           (cond ((< start end)
                  (setf (aref buffer start) code)
                  (1+ start))
                 (t start)))
          ((<= code #x7ff) (utf8-encode-aux code buffer start end 2))
          ((<= #xd800 code #xdfff)
           (error "Invalid Unicode code point (surrogate): #x~x" code))
          ((<= code #xffff) (utf8-encode-aux code buffer start end 3))
          ((<= code #x1fffff) (utf8-encode-aux code buffer start end 4))
          ((<= code #x3ffffff) (utf8-encode-aux code buffer start end 5))
          ((<= code #x7fffffff) (utf8-encode-aux code buffer start end 6))
          (t (error "Can't encode ~s (~x)" char code)))))

(defun utf8-encode-into (string start end buffer index limit)
  (declare (string string) (type octets buffer) (fixnum start end index limit))
  (loop
   (cond ((= start end)
          (return (values start index)))
         ((= index limit)
          (return (values start index)))
         (t
          (let ((i2 (utf8-encode (char string start) buffer index limit)))
            (cond ((= i2 index)
                   (return (values start index)))
                  (t
                   (setq index i2)
                   (incf start))))))))

(defun default-string-to-utf8 (string)
  (let* ((len (length string))
         (b (make-array len :element-type 'octet)))
    (multiple-value-bind (s i) (utf8-encode-into string 0 len b 0 len)
      (if (= s len)
          b
          (loop
           (let ((limit (+ (length b) (- len s))))
             (setq b (coerce (adjust-array b limit) 'octets))
             (multiple-value-bind (s2 i2)
                 (utf8-encode-into string s len b i limit)
               (cond ((= s2 len)
                      (return (coerce (adjust-array b i2) 'octets)))
                     (t
                      (setq i i2)
                      (setq s s2))))))))))

424
(definterface string-to-utf8 (string)
425 426
  "Convert the string STRING to a (simple-array (unsigned-byte 8))"
  (default-string-to-utf8 string))
427 428

(definterface utf8-to-string (octets)
429 430
  "Convert the (simple-array (unsigned-byte 8)) OCTETS to a string."
  (default-utf8-to-string octets))
431

432 433 434 435 436 437 438 439 440 441
;;; Codepoint length

;; we don't need this anymore.
(definterface codepoint-length (string)
  "Return the number of codepoints in STRING.
With some Lisps, like cmucl, LENGTH returns the number of UTF-16 code
units, but other Lisps return the number of codepoints. The slime
protocol wants string lengths in terms of codepoints."
  (length string))

442

443
;;;; TCP server
444

445 446 447
(definterface create-socket (host port &key backlog)
  "Create a listening TCP socket on interface HOST and port PORT.
BACKLOG queue length for incoming connections.")
448

449 450
(definterface local-port (socket)
  "Return the local port number of SOCKET.")
451

452 453
(definterface close-socket (socket)
  "Close the socket SOCKET.")
454

455
(definterface accept-connection (socket &key external-format
456
                                        buffering timeout)
457
   "Accept a client connection on the listening socket SOCKET.  
458 459 460
Return a stream for the new connection.
If EXTERNAL-FORMAT is nil return a binary stream
otherwise create a character stream.
461 462 463 464
BUFFERING can be one of:
  nil   ... no buffering
  t     ... enable buffering
  :line ... enable buffering with automatic flushing on eol.")
465

466
(definterface add-sigio-handler (socket fn)
467
  "Call FN whenever SOCKET is readable.")
468

469 470 471 472 473 474 475 476
(definterface remove-sigio-handlers (socket)
  "Remove all sigio handlers for SOCKET.")

(definterface add-fd-handler (socket fn)
  "Call FN when Lisp is waiting for input and SOCKET is readable.")

(definterface remove-fd-handlers (socket)
  "Remove all fd-handlers for SOCKET.")
477

478 479 480 481
(definterface preferred-communication-style ()
  "Return one of the symbols :spawn, :sigio, :fd-handler, or NIL."
  nil)

482 483 484 485 486 487
(definterface set-stream-timeout (stream timeout)
  "Set the 'stream 'timeout.  The timeout is either the real number
  specifying the timeout in seconds or 'nil for no timeout."
  (declare (ignore stream timeout))
  nil)

488
;;; Base condition for networking errors.
489
(define-condition network-error (simple-error) ())
490

491
(definterface emacs-connected ()
492 493 494
   "Hook called when the first connection from Emacs is established.
Called from the INIT-FN of the socket server that accepts the
connection.
495

496
This is intended for setting up extra context, e.g. to discover
497
that the calling thread is the one that interacts with Emacs."
498
   nil)
499

500 501 502 503 504

;;;; Unix signals

(defconstant +sigint+ 2)

505 506 507
(definterface getpid ()
  "Return the (Unix) process ID of this superior Lisp.")

508 509 510
(definterface install-sigint-handler (function)
  "Call FUNCTION on SIGINT (instead of invoking the debugger).
Return old signal handler."
Helmut Eller's avatar
Helmut Eller committed
511
  (declare (ignore function))
512 513 514 515 516 517 518 519
  nil)

(definterface call-with-user-break-handler (handler function)
  "Install the break handler HANDLER while executing FUNCTION."
  (let ((old-handler (install-sigint-handler handler)))
    (unwind-protect (funcall function)
      (install-sigint-handler old-handler))))

520 521 522
(definterface quit-lisp ()
  "Exit the current lisp image.")

523 524 525
(definterface lisp-implementation-type-name ()
  "Return a short name for the Lisp implementation."
  (lisp-implementation-type))
526

527 528 529 530 531 532
(definterface lisp-implementation-program ()
  "Return the argv[0] of the running Lisp process, or NIL."
  (let ((file (car (command-line-args))))
    (when (and file (probe-file file))
      (namestring (truename file)))))

533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552
(definterface socket-fd (socket-stream)
  "Return the file descriptor for SOCKET-STREAM.")

(definterface make-fd-stream (fd external-format)
  "Create a character stream for the file descriptor FD.")

(definterface dup (fd)
  "Duplicate a file descriptor.
If the syscall fails, signal a condition.
See dup(2).")

(definterface exec-image (image-file args)
  "Replace the current process with a new process image.
The new image is created by loading the previously dumped
core file IMAGE-FILE.
ARGS is a list of strings passed as arguments to
the new image.
This is thin wrapper around exec(3).")

(definterface command-line-args ()
553 554
  "Return a list of strings as passed by the OS."
  nil)
555

556 557 558 559 560 561 562 563 564 565 566 567 568

;; pathnames are sooo useless

(definterface filename-to-pathname (filename)
  "Return a pathname for FILENAME.
A filename in Emacs may for example contain asterisks which should not
be translated to wildcards."
  (parse-namestring filename))

(definterface pathname-to-filename (pathname)
  "Return the filename for PATHNAME."
  (namestring pathname))

569 570 571 572
(definterface default-directory ()
  "Return the default directory."
  (directory-namestring (truename *default-pathname-defaults*)))

573 574 575 576
(definterface set-default-directory (directory)
  "Set the default directory.
This is used to resolve filenames without directory component."
  (setf *default-pathname-defaults* (truename (merge-pathnames directory)))
577 578
  (default-directory))

579

580 581 582
(definterface call-with-syntax-hooks (fn)
  "Call FN with hooks to handle special syntax."
  (funcall fn))
583

584
(definterface default-readtable-alist ()
585
  "Return a suitable initial value for SWANK:*READTABLE-ALIST*."
586 587
  '())

588 589 590

;;;; Compilation

591
(definterface call-with-compilation-hooks (func)
Luke Gorrie's avatar
Luke Gorrie committed
592
  "Call FUNC with hooks to record compiler conditions.")
593

594
(defmacro with-compilation-hooks ((&rest ignore) &body body)
Luke Gorrie's avatar
Luke Gorrie committed
595
  "Execute BODY as in CALL-WITH-COMPILATION-HOOKS."
596
  (declare (ignore ignore))
597 598
  `(call-with-compilation-hooks (lambda () (progn ,@body))))

599
(definterface swank-compile-string (string &key buffer position filename
600
                                           policy)
601 602 603
  "Compile source from STRING.
During compilation, compiler conditions must be trapped and
resignalled as COMPILER-CONDITIONs.
604 605 606 607

If supplied, BUFFER and POSITION specify the source location in Emacs.

Additionally, if POSITION is supplied, it must be added to source
608 609
positions reported in compiler conditions.

610
If FILENAME is specified it may be used by certain implementations to
611
rebind *DEFAULT-PATHNAME-DEFAULTS* which may improve the recording of
612 613
source information.

614
If POLICY is supplied, and non-NIL, it may be used by certain
615
implementations to compile with optimization qualities of its
616 617
value.

618
Should return T on successful compilation, NIL otherwise.
619
")
620

621
(definterface swank-compile-file (input-file output-file load-p 
622 623
                                             external-format
                                             &key policy)
624
   "Compile INPUT-FILE signalling COMPILE-CONDITIONs.
625 626
If LOAD-P is true, load the file after compilation.
EXTERNAL-FORMAT is a value returned by find-external-format or
627 628
:default.

629 630 631 632
If POLICY is supplied, and non-NIL, it may be used by certain
implementations to compile with optimization qualities of its
value.

633 634
Should return OUTPUT-TRUENAME, WARNINGS-P and FAILURE-p
like `compile-file'")
635

636
(deftype severity () 
637
  '(member :error :read-error :warning :style-warning :note :redefinition))
638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654

;; Base condition type for compiler errors, warnings and notes.
(define-condition compiler-condition (condition)
  ((original-condition
    ;; The original condition thrown by the compiler if appropriate.
    ;; May be NIL if a compiler does not report using conditions.
    :type (or null condition)
    :initarg :original-condition
    :accessor original-condition)

   (severity :type severity
             :initarg :severity
             :accessor severity)

   (message :initarg :message
            :accessor message)

655 656 657 658 659 660
   ;; Macro expansion history etc. which may be helpful in some cases
   ;; but is often very verbose.
   (source-context :initarg :source-context
                   :type (or null string)
                   :initform nil
                   :accessor source-context)
661

662 663 664 665
   (references :initarg :references
               :initform nil
               :accessor references)

666 667 668
   (location :initarg :location
             :accessor location)))

669 670 671 672 673 674 675 676
(definterface find-external-format (coding-system)
  "Return a \"external file format designator\" for CODING-SYSTEM.
CODING-SYSTEM is Emacs-style coding system name (a string),
e.g. \"latin-1-unix\"."
  (if (equal coding-system "iso-latin-1-unix")
      :default
      nil))

677 678
(definterface guess-external-format (pathname)
  "Detect the external format for the file with name pathname.
679 680
Return nil if the file contains no special markers."
  ;; Look for a Emacs-style -*- coding: ... -*- or Local Variable: section.
681
  (with-open-file (s pathname :if-does-not-exist nil
682 683
                     :external-format (or (find-external-format "latin-1-unix")
                                          :default))
684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699
    (if s 
        (or (let* ((line (read-line s nil))
                   (p (search "-*-" line)))
              (when p
                (let* ((start (+ p (length "-*-")))
                       (end (search "-*-" line :start2 start)))
                  (when end
                    (%search-coding line start end)))))
            (let* ((len (file-length s))
                   (buf (make-string (min len 3000))))
              (file-position s (- len (length buf)))
              (read-sequence buf s)
              (let ((start (search "Local Variables:" buf :from-end t))
                    (end (search "End:" buf :from-end t)))
                (and start end (< start end)
                     (%search-coding buf start end))))))))
700 701 702 703 704 705 706 707 708 709 710 711

(defun %search-coding (str start end)
  (let ((p (search "coding:" str :start2 start :end2 end)))
    (when p
      (incf p (length "coding:"))
      (loop while (and (< p end)
                       (member (aref str p) '(#\space #\tab)))
            do (incf p))
      (let ((end (position-if (lambda (c) (find c '(#\space #\tab #\newline)))
                              str :start p)))
        (find-external-format (subseq str p end))))))

712

713 714
;;;; Streams

715 716 717 718 719 720 721 722
(definterface make-output-stream (write-string)
  "Return a new character output stream.
The stream calls WRITE-STRING when output is ready.")

(definterface make-input-stream (read-string)
  "Return a new character input stream.
The stream calls READ-STRING when input is needed.")

723 724 725

;;;; Documentation

726
(definterface arglist (name)
727 728 729
   "Return the lambda list for the symbol NAME. NAME can also be
a lisp function object, on lisps which support this.

730 731
The result can be a list or the :not-available keyword if the
arglist cannot be determined."
732 733
   (declare (ignore name))
   :not-available)
734

735 736 737 738 739 740 741 742 743 744 745
(defgeneric declaration-arglist (decl-identifier)
  (:documentation
   "Return the argument list of the declaration specifier belonging to the
declaration identifier DECL-IDENTIFIER. If the arglist cannot be determined,
the keyword :NOT-AVAILABLE is returned.

The different SWANK backends can specialize this generic function to
include implementation-dependend declaration specifiers, or to provide
additional information on the specifiers defined in ANSI Common Lisp.")
  (:method (decl-identifier)
    (case decl-identifier
746 747 748 749
      (dynamic-extent '(&rest variables))
      (ignore         '(&rest variables))
      (ignorable      '(&rest variables))
      (special        '(&rest variables))
750
      (inline         '(&rest function-names))
751 752
      (notinline      '(&rest function-names))
      (declaration    '(&rest names))
753 754 755 756
      (optimize       '(&any compilation-speed debug safety space speed))  
      (type           '(type-specifier &rest args))
      (ftype          '(type-specifier &rest function-names))
      (otherwise
757 758
       (flet ((typespec-p (symbol) 
                (member :type (describe-symbol-for-emacs symbol))))
759
         (cond ((and (symbolp decl-identifier) (typespec-p decl-identifier))
760
                '(&rest variables))
761 762
               ((and (listp decl-identifier) 
                     (typespec-p (first decl-identifier)))
763
                '(&rest variables))
764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781
               (t :not-available)))))))

(defgeneric type-specifier-arglist (typespec-operator)
  (:documentation
   "Return the argument list of the type specifier belonging to
TYPESPEC-OPERATOR.. If the arglist cannot be determined, the keyword
:NOT-AVAILABLE is returned.

The different SWANK backends can specialize this generic function to
include implementation-dependend declaration specifiers, or to provide
additional information on the specifiers defined in ANSI Common Lisp.")
  (:method (typespec-operator)
    (declare (special *type-specifier-arglists*)) ; defined at end of file.
    (typecase typespec-operator
      (symbol (or (cdr (assoc typespec-operator *type-specifier-arglists*))
                  :not-available))
      (t :not-available))))

782 783 784
(definterface function-name (function)
  "Return the name of the function object FUNCTION.

785 786
The result is either a symbol, a list, or NIL if no function name is
available."
787 788
  (declare (ignore function))
  nil)
789

790 791 792 793 794 795 796 797 798
(definterface valid-function-name-p (form)
  "Is FORM syntactically valid to name a function?
   If true, FBOUNDP should not signal a type-error for FORM."
  (flet ((length=2 (list)
           (and (not (null (cdr list))) (null (cddr list)))))
    (or (symbolp form)
        (and (consp form) (length=2 form)
             (eq (first form) 'setf) (symbolp (second form))))))

799
(definterface macroexpand-all (form)
800
   "Recursively expand all macros in FORM.
801
Return the resulting form.")
802

803 804 805 806 807 808
(definterface compiler-macroexpand-1 (form &optional env)
  "Call the compiler-macro for form.
If FORM is a function call for which a compiler-macro has been
defined, invoke the expander function using *macroexpand-hook* and
return the results and T.  Otherwise, return the original form and
NIL."
809 810 811
  (let ((fun (and (consp form) 
                  (valid-function-name-p (car form))
                  (compiler-macro-function (car form)))))
812 813 814 815 816 817 818 819 820 821 822 823 824 825 826
    (if fun
	(let ((result (funcall *macroexpand-hook* fun form env)))
          (values result (not (eq result form))))
	(values form nil))))

(definterface compiler-macroexpand (form &optional env)
  "Repetitively call `compiler-macroexpand-1'."
  (labels ((frob (form expanded)
	     (multiple-value-bind (new-form newly-expanded)
		 (compiler-macroexpand-1 form env)
	       (if newly-expanded
		   (frob new-form t)
		   (values new-form expanded)))))
    (frob form env)))

827 828 829 830
(definterface format-string-expand (control-string)
  "Expand the format string CONTROL-STRING."
  (macroexpand `(formatter ,control-string)))

831
(definterface describe-symbol-for-emacs (symbol)
832 833 834 835 836
   "Return a property list describing SYMBOL.

The property list has an entry for each interesting aspect of the
symbol. The recognised keys are:

837 838
  :VARIABLE :FUNCTION :SETF :SPECIAL-OPERATOR :MACRO :COMPILER-MACRO
  :TYPE :CLASS :ALIEN-TYPE :ALIEN-STRUCT :ALIEN-UNION :ALIEN-ENUM
839 840

The value of each property is the corresponding documentation string,
841 842
or :NOT-DOCUMENTED. It is legal to include keys not listed here (but
slime-print-apropos in Emacs must know about them).
843 844 845 846 847 848 849 850 851

Properties should be included if and only if they are applicable to
the symbol. For example, only (and all) fbound symbols should include
the :FUNCTION property.

Example:
\(describe-symbol-for-emacs 'vector)
  => (:CLASS :NOT-DOCUMENTED
      :TYPE :NOT-DOCUMENTED
852 853 854 855 856 857 858
      :FUNCTION \"Constructs a simple-vector from the given objects.\")")

(definterface describe-definition (name type)
  "Describe the definition NAME of TYPE.
TYPE can be any value returned by DESCRIBE-SYMBOL-FOR-EMACS.

Return a documentation string, or NIL if none is available.")
859

860 861 862

;;;; Debugging

863 864 865 866 867 868
(definterface install-debugger-globally (function)
  "Install FUNCTION as the debugger for all threads/processes. This
usually involves setting *DEBUGGER-HOOK* and, if the implementation
permits, hooking into BREAK as well."
  (setq *debugger-hook* function))

869
(definterface call-with-debugging-environment (debugger-loop-fn)
870 871 872 873 874 875 876
   "Call DEBUGGER-LOOP-FN in a suitable debugging environment.

This function is called recursively at each debug level to invoke the
debugger loop. The purpose is to setup any necessary environment for
other debugger callbacks that will be called within the debugger loop.

For example, this is a reasonable place to compute a backtrace, switch
877
to safe reader/printer settings, and so on.")
878

879
(definterface call-with-debugger-hook (hook fun)
880
  "Call FUN and use HOOK as debugger hook. HOOK can be NIL.
881 882 883 884 885

HOOK should be called for both BREAK and INVOKE-DEBUGGER."
  (let ((*debugger-hook* hook))
    (funcall fun)))

886 887 888
(define-condition sldb-condition (condition)
  ((original-condition
    :initarg :original-condition
889
    :accessor original-condition))
890 891 892
  (:report (lambda (condition stream)
             (format stream "Condition in debugger code~@[: ~A~]" 
                     (original-condition condition))))
893 894 895 896 897 898 899 900 901
  (:documentation
   "Wrapper for conditions that should not be debugged.

When a condition arises from the internals of the debugger, it is not
desirable to debug it -- we'd risk entering an endless loop trying to
debug the debugger! Instead, such conditions can be reported to the
user without (re)entering the debugger by wrapping them as
`sldb-condition's."))

902 903 904 905 906
;;; The following functions in this section are supposed to be called
;;; within the dynamic contour of CALL-WITH-DEBUGGING-ENVIRONMENT only.

(definterface compute-backtrace (start end)
   "Returns a backtrace of the condition currently being debugged,
907
that is an ordered list consisting of frames. ``Ordered list''
908 909
means that an integer I can be mapped back to the i-th frame of this
backtrace.
910 911

START and END are zero-based indices constraining the number of frames
912 913
returned. Frame zero is defined as the frame which invoked the
debugger. If END is nil, return the frames from START to the end of
914 915
the stack.")

916
(definterface print-frame (frame stream)
917
  "Print frame to stream.")
918

919 920 921
(definterface frame-restartable-p (frame)
  "Is the frame FRAME restartable?.
Return T if `restart-frame' can safely be called on the frame."
922
  (declare (ignore frame))
923 924
  nil)

925
(definterface frame-source-location (frame-number)
926
  "Return the source location for the frame associated to FRAME-NUMBER.")
927

928
(definterface frame-catch-tags (frame-number)
929
  "Return a list of catch tags for being printed in a debugger stack
930
frame."
931
  (declare (ignore frame-number))
932
  '())
933

934
(definterface frame-locals (frame-number)
935 936 937 938 939 940 941 942 943 944
  "Return a list of ((&key NAME ID VALUE) ...) where each element of
the list represents a local variable in the stack frame associated to
FRAME-NUMBER.

NAME, a symbol; the name of the local variable.

ID, an integer; used as primary key for the local variable, unique
relatively to the frame under operation.

value, an object; the value of the local variable.")
Helmut Eller's avatar
Helmut Eller committed
945

946 947 948
(definterface frame-var-value (frame-number var-id)
  "Return the value of the local variable associated to VAR-ID
relatively to the frame associated to FRAME-NUMBER.")
949

Helmut Eller's avatar
Helmut Eller committed
950 951 952
(definterface disassemble-frame (frame-number)
  "Disassemble the code for the FRAME-NUMBER.
The output should be written to standard output.
Helmut Eller's avatar
Helmut Eller committed
953
FRAME-NUMBER is a non-negative integer.")
Helmut Eller's avatar
Helmut Eller committed
954

955
(definterface eval-in-frame (form frame-number)
956
   "Evaluate a Lisp form in the lexical context of a stack frame
957
in the debugger.
958 959 960 961 962

FRAME-NUMBER must be a positive integer with 0 indicating the
frame which invoked the debugger.

The return value is the result of evaulating FORM in the
963
appropriate context.")
964

965 966 967 968 969 970
(definterface frame-package (frame-number)
  "Return the package corresponding to the frame at FRAME-NUMBER.
Return nil if the backend can't figure it out."
  (declare (ignore frame-number))
  nil)

971 972 973
(definterface frame-call (frame-number)
  "Return a string representing a call to the entry point of a frame.")

974 975 976 977 978 979 980 981 982 983 984 985 986 987
(definterface return-from-frame (frame-number form)
  "Unwind the stack to the frame FRAME-NUMBER and return the value(s)
produced by evaluating FORM in the frame context to its caller.

Execute any clean-up code from unwind-protect forms above the frame
during unwinding.

Return a string describing the error if it's not possible to return
from the frame.")

(definterface restart-frame (frame-number)
  "Restart execution of the frame FRAME-NUMBER with the same arguments
as it was called originally.")

988 989 990 991
(definterface format-sldb-condition (condition)
  "Format a condition for display in SLDB."
  (princ-to-string condition))

992 993 994
(definterface condition-extras (condition)
  "Return a list of extra for the debugger.
The allowed elements are of the form:
995 996 997
  (:SHOW-FRAME-SOURCE frame-number)
  (:REFERENCES &rest refs)
"
998
  (declare (ignore condition))
999 1000
  '())

1001 1002 1003 1004 1005
(definterface gdb-initial-commands ()
  "List of gdb commands supposed to be executed first for the
   ATTACH-GDB restart."
  nil)

1006 1007
(definterface activate-stepping (frame-number)
  "Prepare the frame FRAME-NUMBER for stepping.")
1008 1009 1010 1011 1012 1013

(definterface sldb-break-on-return (frame-number)
  "Set a breakpoint in the frame FRAME-NUMBER.")

(definterface sldb-break-at-start (symbol)
  "Set a breakpoint on the beginning of the function for SYMBOL.")
1014
  
Juho Snellman's avatar
Juho Snellman committed
1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029
(definterface sldb-stepper-condition-p (condition)
  "Return true if SLDB was invoked due to a single-stepping condition,
false otherwise. "
  (declare (ignore condition))
  nil)

(definterface sldb-step-into ()
  "Step into the current single-stepper form.")

(definterface sldb-step-next ()
  "Step to the next form in the current function.")

(definterface sldb-step-out ()
  "Stop single-stepping temporarily, but resume it once the current function
returns.")
1030

1031 1032 1033 1034

;;;; Definition finding

(defstruct (:location (:type list) :named
1035 1036 1037 1038 1039 1040 1041 1042
                      (:constructor make-location
                                    (buffer position &optional hints)))
  buffer position
  ;; Hints is a property list optionally containing:
  ;;   :snippet SOURCE-TEXT
  ;;     This is a snippet of the actual source text at the start of
  ;;     the definition, which could be used in a text search.
  hints)
1043 1044

(defstruct (:error (:type list) :named (:constructor)) message)
1045 1046 1047 1048 1049 1050 1051

;;; Valid content for BUFFER slot
(defstruct (:file       (:type list) :named (:constructor)) name)
(defstruct (:buffer     (:type list) :named (:constructor)) name)
(defstruct (:etags-file (:type list) :named (:constructor)) filename)

;;; Valid content for POSITION slot
1052
(defstruct (:position (:type list) :named (:constructor)) pos)
1053
(defstruct (:tag      (:type list) :named (:constructor)) tag1 tag2)
1054

1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066
(defmacro converting-errors-to-error-location (&body body)
  "Catches errors during BODY and converts them to an error location."
  (let ((gblock (gensym "CONVERTING-ERRORS+")))
    `(block ,gblock
       (handler-bind ((error
                       #'(lambda (e)
                            (if *debug-swank-backend*
                                nil     ;decline
                                (return-from ,gblock
                                  (make-error-location e))))))
         ,@body))))

1067 1068 1069 1070
(defun make-error-location (datum &rest args)
  (cond ((typep datum 'condition)
         `(:error ,(format nil "Error: ~A" datum)))
        ((symbolp datum)
1071 1072
         `(:error ,(format nil "Error: ~A" 
                           (apply #'make-condition datum args))))
1073 1074 1075 1076
        (t
         (assert (stringp datum))
         `(:error ,(apply #'format nil datum args)))))

1077 1078 1079
(definterface find-definitions (name)
   "Return a list ((DSPEC LOCATION) ...) for NAME's definitions.

1080
NAME is a \"definition specifier\".
1081

1082
DSPEC is a \"definition specifier\" describing the
1083
definition, e.g., FOO or (METHOD FOO (STRING NUMBER)) or
1084 1085 1086
\(DEFVAR FOO).

LOCATION is the source location for the definition.")
1087

1088 1089 1090 1091 1092 1093 1094
(definterface find-source-location (object)
  "Returns the source location of OBJECT, or NIL.

That is the source location of the underlying datastructure of
OBJECT. E.g. on a STANDARD-OBJECT, the source location of the
respective DEFCLASS definition is returned, on a STRUCTURE-CLASS the
respective DEFSTRUCT definition, and so on."
1095
  ;; This returns one source location and not a list of locations. It's
1096 1097
  ;; supposed to return the location of the DEFGENERIC definition on
  ;; #'SOME-GENERIC-FUNCTION.
1098 1099 1100
  (declare (ignore object))
  (make-error-location "FIND-DEFINITIONS is not yet implemented on ~
                        this implementation."))
1101

1102
(definterface buffer-first-change (filename)
1103 1104 1105
  "Called for effect the first time FILENAME's buffer is modified.
CMUCL/SBCL use this to cache the unmodified file and use the
unmodified text to improve the precision of source locations."
1106
  (declare (ignore filename))
1107 1108
  nil)

1109

1110 1111 1112 1113 1114

;;;; XREF

(definterface who-calls (function-name)
  "Return the call sites of FUNCTION-NAME (a symbol).
1115 1116 1117
The results is a list ((DSPEC LOCATION) ...)."
  (declare (ignore function-name))
  :not-implemented)
1118

1119 1120
(definterface calls-who (function-name)
  "Return the call sites of FUNCTION-NAME (a symbol).
1121 1122 1123
The results is a list ((DSPEC LOCATION) ...)."
  (declare (ignore function-name))
  :not-implemented)
1124

1125 1126
(definterface who-references (variable-name)
  "Return the locations where VARIABLE-NAME (a symbol) is referenced.
1127 1128 1129
See WHO-CALLS for a description of the return value."
  (declare (ignore variable-name))
  :not-implemented)
1130 1131 1132

(definterface who-binds (variable-name)
  "Return the locations where VARIABLE-NAME (a symbol) is bound.
1133 1134 1135
See WHO-CALLS for a description of the return value."
  (declare (ignore variable-name))
  :not-implemented)
1136 1137 1138

(definterface who-sets (variable-name)
  "Return the locations where VARIABLE-NAME (a symbol) is set.
1139 1140 1141
See WHO-CALLS for a description of the return value."
  (declare (ignore variable-name))
  :not-implemented)
1142 1143 1144

(definterface who-macroexpands (macro-name)
  "Return the locations where MACRO-NAME (a symbol) is expanded.
1145 1146 1147
See WHO-CALLS for a description of the return value."
  (declare (ignore macro-name))
  :not-implemented)
1148 1149 1150

(definterface who-specializes (class-name)
  "Return the locations where CLASS-NAME (a symbol) is specialized.
1151 1152 1153
See WHO-CALLS for a description of the return value."
  (declare (ignore class-name))
  :not-implemented)
1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169

;;; Simpler variants.

(definterface list-callers (function-name)
  "List the callers of FUNCTION-NAME.
This function is like WHO-CALLS except that it is expected to use
lower-level means. Whereas WHO-CALLS is usually implemented with
special compiler support, LIST-CALLERS is usually implemented by
groveling for constants in function objects throughout the heap.

The return value is as for WHO-CALLS.")

(definterface list-callees (function-name)
  "List the functions called by FUNCTION-NAME.
See LIST-CALLERS for a description of the return value.")

1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206

;;;; Profiling

;;; The following functions define a minimal profiling interface.

(definterface profile (fname)
  "Marks symbol FNAME for profiling.")

(definterface profiled-functions ()
  "Returns a list of profiled functions.")

(definterface unprofile (fname)
  "Marks symbol FNAME as not profiled.")

(definterface unprofile-all ()
  "Marks all currently profiled functions as not profiled."
  (dolist (f (profiled-functions))
    (unprofile f)))

(definterface profile-report ()
  "Prints profile report.")

(definterface profile-reset ()
  "Resets profile counters.")

(definterface profile-package (package callers-p methods)
  "Wrap profiling code around all functions in PACKAGE.  If a function
is already profiled, then unprofile and reprofile (useful to notice
function redefinition.)

If CALLERS-P is T names have counts of the most common calling
functions recorded.

When called with arguments :METHODS T, profile all methods of all
generic functions having names in the given package.  Generic functions
themselves, that is, their dispatch functions, are left alone.")

1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219

;;;; Trace

(definterface toggle-trace (spec)
  "Toggle tracing of the function(s) given with SPEC.
SPEC can be:
 (setf NAME)                            ; a setf function
 (:defmethod NAME QUALIFIER... (SPECIALIZER...)) ; a specific method
 (:defgeneric NAME)                     ; a generic function with all methods
 (:call CALLER CALLEE)                  ; trace calls from CALLER to CALLEE.
 (:labels TOPLEVEL LOCAL) 
 (:flet TOPLEVEL LOCAL) ")

Helmut Eller's avatar
Helmut Eller committed
1220 1221 1222

;;;; Inspector

Helmut Eller's avatar
Helmut Eller committed
1223
(defgeneric emacs-inspect (object)
1224
  (:documentation
1225
   "Explain to Emacs how to inspect OBJECT.
1226

1227
Returns a list specifying how to render the object for inspection.
1228

Luke Gorrie's avatar
Luke Gorrie committed
1229
Every element of the list must be either a string, which will be
1230 1231 1232 1233 1234 1235 1236 1237
inserted into the buffer as is, or a list of the form:

 (:value object &optional format) - Render an inspectable
 object. If format is provided it must be a string and will be
 rendered in place of the value, otherwise use princ-to-string.

 (:newline) - Render a \\n

1238 1239 1240 1241
 (:action label lambda &key (refresh t)) - Render LABEL (a text
 string) which when clicked will call LAMBDA. If REFRESH is
 non-NIL the currently inspected object will be re-inspected
 after calling the lambda.
1242
"))
1243

Helmut Eller's avatar
Helmut Eller committed
1244
(defmethod emacs-inspect ((object t))
1245 1246 1247 1248
  "Generic method for inspecting any kind of object.

Since we don't know how to deal with OBJECT we simply dump the
output of CL:DESCRIBE."
1249 1250 1251
   `("Type: " (:value ,(type-of object)) (:newline)
     "Don't know how to inspect the object, dumping output of CL:DESCRIBE:"
     (:newline) (:newline)
1252
     ,(with-output-to-string (desc) (describe object desc))))
Helmut Eller's avatar
Helmut Eller committed
1253

1254 1255 1256 1257
(definterface eval-context (object)
  "Return a list of bindings corresponding to OBJECT's slots."
  (declare (ignore object))
  '())
1258

Helmut Eller's avatar
Helmut Eller committed
1259
;;; Utilities for inspector methods.
1260
;;; 
1261 1262 1263 1264 1265 1266

(defun label-value-line (label value &key (newline t))
  "Create a control list which prints \"LABEL: VALUE\" in the inspector.
If NEWLINE is non-NIL a `(:newline)' is added to the result."
  (list* (princ-to-string label) ": " `(:value ,value)
         (if newline '((:newline)) nil)))
1267 1268

(defmacro label-value-line* (&rest label-values)
1269 1270
  ` (append ,@(loop for (label value) in label-values
                    collect `(label-value-line ,label ,value))))
1271

1272
(definterface describe-primitive-type (object)
1273
  "Return a string describing the primitive type of object."
1274
  (declare (ignore object))
1275
  "N/A")
Helmut Eller's avatar
Helmut Eller committed
1276

1277

1278
;;;; Multithreading
1279 1280 1281
;;;
;;; The default implementations are sufficient for non-multiprocessing
;;; implementations.
1282

1283
(definterface initialize-multiprocessing (continuation)
1284
   "Initialize multiprocessing, if necessary and then invoke CONTINUATION.
1285

1286 1287
Depending on the impleimentaion, this function may never return."
   (funcall continuation))
1288

1289 1290
(definterface spawn (fn &key name)
  "Create a new thread to call FN.")
1291

1292 1293 1294 1295
(definterface thread-id (thread)
  "Return an Emacs-parsable object to identify THREAD.

Ids should be comparable with equal, i.e.:
1296 1297
 (equal (thread-id <t1>) (thread-id <t2>)) <==> (eq <t1> <t2>)"
  thread)
1298 1299 1300 1301

(definterface find-thread (id)
  "Return the thread for ID.
ID should be an id previously obtained with THREAD-ID.
1302
Can return nil if the thread no longer exists."
Helmut Eller's avatar
Helmut Eller committed
1303
  (declare (ignore id))
1304
  (current-thread))
1305

1306 1307
(definterface thread-name (thread)
   "Return the name of THREAD.
1308 1309
Thread names are short strings meaningful to the user. They do not
have to be unique."
1310
   (declare (ignore thread))
1311
   "The One True Thread")
1312

1313 1314 1315 1316 1317
(definterface thread-status (thread)
   "Return a string describing THREAD's state."
   (declare (ignore thread))
   "")

1318 1319 1320 1321 1322
(definterface thread-attributes (thread)
  "Return a plist of implementation-dependent attributes for THREAD"
  (declare (ignore thread))
  '())

1323 1324 1325 1326
(definterface current-thread ()
  "Return the currently executing thread."
  0)

1327
(definterface all-threads ()
1328 1329
  "Return a fresh list of all threads."
  '())
1330 1331

(definterface thread-alive-p (thread)
1332 1333
  "Test if THREAD is termintated."
  (member thread (all-threads)))
1334

1335 1336 1337
(definterface interrupt-thread (thread fn)
  "Cause THREAD to execute FN.")

1338
(definterface kill-thread (thread)
1339 1340 1341
  "Terminate THREAD immediately.
Don't execute unwind-protected sections, don't raise conditions.
(Do not pass go, do not collect $200.)"
1342 1343 1344
  (declare (ignore thread))
  nil)

1345
(definterface send (thread object)
1346 1347
  "Send OBJECT to thread THREAD."
  object)
1348

1349
(definterface receive (&optional timeout)
1350
  "Return the next message from current thread's mailbox."
1351
  (receive-if (constantly t) timeout))
Marco Baringer's avatar
Marco Baringer committed
1352

1353
(definterface receive-if (predicate &optional timeout)
Helmut Eller's avatar
Helmut Eller committed
1354 1355
  "Return the first message satisfiying PREDICATE.")

1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367
(definterface register-thread (name thread)
  "Associate the thread THREAD with the symbol NAME.
The thread can then be retrieved with `find-registered'.
If THREAD is nil delete the association."
  (declare (ignore name thread))
  nil)

(definterface find-registered (name)
  "Find the thread that was registered for the symbol NAME.
Return nil if the no thread was registred or if the tread is dead."
  nil)

1368 1369 1370 1371 1372 1373 1374 1375
(definterface set-default-initial-binding (var form)
  "Initialize special variable VAR by default with FORM.

Some implementations initialize certain variables in each newly
created thread.  This function sets the form which is used to produce
the initial value."
  (set var (eval form)))

1376 1377 1378
;; List of delayed interrupts.  
;; This should only have thread-local bindings, so no init form.
(defvar *pending-slime-interrupts*)
1379

1380
(defun check-slime-interrupts ()
1381 1382
  "Execute pending interrupts if any.
This should be called periodically in operations which
1383
can take a long time to complete.
1384
Return a boolean indicating whether any interrupts was processed."
1385 1386
  (when (and (boundp '*pending-slime-interrupts*)
             *pending-slime-interrupts*)
1387
    (funcall (pop *pending-slime-interrupts*))
1388
    t))
1389

1390 1391 1392 1393 1394 1395
(defvar *interrupt-queued-handler* nil
  "Function to call on queued interrupts.
Interrupts get queued when an interrupt occurs while interrupt
handling is disabled.

Backends can use this function to abort slow operations.")
1396

1397 1398 1399
(definterface wait-for-input (streams &optional timeout)
  "Wait for input on a list of streams.  Return those that are ready.
STREAMS is a list of streams
Helmut Eller's avatar
Helmut Eller committed
1400 1401
TIMEOUT nil, t, or real number. If TIMEOUT is t, return those streams
which are ready (or have reached end-of-file) without waiting.
1402 1403 1404
If TIMEOUT is a number and no streams is ready after TIMEOUT seconds,
return nil.

Helmut Eller's avatar
Helmut Eller committed
1405 1406
Return :interrupt if an interrupt occurs while waiting.")

1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430

;;;;  Locks 

;; Please use locks only in swank-gray.lisp.  Locks are too low-level
;; for our taste.

(definterface make-lock (&key name)
   "Make a lock for thread synchronization.
Only one thread may hold the lock (via CALL-WITH-LOCK-HELD) at a time
but that thread may hold it more than once."
   (declare (ignore name))
   :null-lock)

(definterface call-with-lock-held (lock function)
   "Call FUNCTION with LOCK held, queueing if necessary."
   (declare (ignore lock)
            (type function function))
   (funcall function))

;; Same here: don't use this outside of swank-gray.lisp.
(definterface call-with-io-timeout (function &key seconds)
  "Calls function with the specified IO timeout."
  (declare (ignore seconds))
  (funcall function))
1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441


;;;; Weak datastructures

(definterface make-weak-key-hash-table (&rest args)
  "Like MAKE-HASH-TABLE, but weak w.r.t. the keys."
  (apply #'make-hash-table args))

(definterface make-weak-value-hash-table (&rest args)
  "Like MAKE-HASH-TABLE, but weak w.r.t. the values."
  (apply #'make-hash-table args))
1442

1443 1444 1445 1446 1447
(definterface hash-table-weakness (hashtable)
  "Return nil or one of :key :value :key-or-value :key-and-value"
  (declare (ignore hashtable))
  nil)

1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458

;;;; Character names

(definterface character-completion-set (prefix matchp)
  "Return a list of names of characters that match PREFIX."
  ;; Handle the standard and semi-standard characters.
  (loop for name in '("Newline" "Space" "Tab" "Page" "Rubout"
                      "Linefeed" "Return" "Backspace")
     when (funcall matchp prefix name)
     collect name))

1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491

(defparameter *type-specifier-arglists*
  '((and                . (&rest type-specifiers))
    (array              . (&optional element-type dimension-spec))
    (base-string        . (&optional size))
    (bit-vector         . (&optional size))
    (complex            . (&optional type-specifier))
    (cons               . (&optional car-typespec cdr-typespec))
    (double-float       . (&optional lower-limit upper-limit))
    (eql                . (object))
    (float              . (&optional lower-limit upper-limit))
    (function           . (&optional arg-typespec value-typespec))
    (integer            . (&optional lower-limit upper-limit))
    (long-float         . (&optional lower-limit upper-limit))
    (member             . (&rest eql-objects))
    (mod                . (n))
    (not                . (type-specifier))
    (or                 . (&rest type-specifiers))
    (rational           . (&optional lower-limit upper-limit))
    (real               . (&optional lower-limit upper-limit))
    (satisfies          . (predicate-symbol))
    (short-float        . (&optional lower-limit upper-limit))
    (signed-byte        . (&optional size))
    (simple-array       . (&optional element-type dimension-spec))
    (simple-base-string . (&optional size))
    (simple-bit-vector  . (&optional size))
    (simple-string      . (&optional size))
    (single-float       . (&optional lower-limit upper-limit))
    (simple-vector      . (&optional size))
    (string             . (&optional size))
    (unsigned-byte      . (&optional size))
    (values             . (&rest typespecs))
    (vector             . (&optional element-type size))
1492
    ))
1493 1494 1495 1496 1497 1498 1499

;;; Heap dumps

(definterface save-image (filename &optional restart-function)
  "Save a heap image to the file FILENAME.
RESTART-FUNCTION, if non-nil, should be called when the image is loaded.")

1500 1501 1502 1503 1504
(definterface background-save-image (filename &key restart-function
                                              completion-function)
  "Request saving a heap image to the file FILENAME.
RESTART-FUNCTION, if non-nil, should be called when the image is loaded.
COMPLETION-FUNCTION, if non-nil, should be called after saving the image.")