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

Diff of /slime/swank-backend.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.94 by heller, Sun Nov 20 23:25:38 2005 UTC revision 1.182 by heller, Sat Oct 31 08:22:56 2009 UTC
# Line 13  Line 13 
13  (defpackage :swank-backend  (defpackage :swank-backend
14    (:use :common-lisp)    (:use :common-lisp)
15    (:export #:sldb-condition    (:export #:sldb-condition
            #:original-condition  
16             #:compiler-condition             #:compiler-condition
17               #:original-condition
18             #:message             #:message
19             #:short-message             #:source-context
20             #:condition             #:condition
21             #:severity             #:severity
22               #:with-compilation-hooks
23             #:location             #:location
24             #:location-p             #:location-p
25             #:location-buffer             #:location-buffer
# Line 29  Line 30 
30             #:quit-lisp             #:quit-lisp
31             #:references             #:references
32             #:unbound-slot-filler             #:unbound-slot-filler
33               #:declaration-arglist
34               #:type-specifier-arglist
35               ;; interrupt macro for the backend
36               #:*pending-slime-interrupts*
37               #:check-slime-interrupts
38               #:*interrupt-queued-handler*
39             ;; inspector related symbols             ;; inspector related symbols
40             #:inspector             #:emacs-inspect
            #:inspect-for-emacs  
            #:raw-inspection  
            #:fancy-inspection  
41             #:label-value-line             #:label-value-line
42             #:label-value-line*             #:label-value-line*
43    
44               #:with-struct
45             ))             ))
46    
47  (defpackage :swank-mop  (defpackage :swank-mop
# Line 84  Line 90 
90     #:slot-definition-type     #:slot-definition-type
91     #:slot-definition-readers     #:slot-definition-readers
92     #:slot-definition-writers     #:slot-definition-writers
93       #:slot-boundp-using-class
94       #:slot-value-using-class
95       #:slot-makunbound-using-class
96     ;; generic function protocol     ;; generic function protocol
97     #:compute-applicable-methods-using-classes     #:compute-applicable-methods-using-classes
98     #:finalize-inheritance))     #:finalize-inheritance))
# Line 102  DEFINTERFACE adds to this list and DEFIM Line 111  DEFINTERFACE adds to this list and DEFIM
111    
112  (defmacro definterface (name args documentation &rest default-body)  (defmacro definterface (name args documentation &rest default-body)
113    "Define an interface function for the backend to implement.    "Define an interface function for the backend to implement.
114  A generic function is defined with NAME, ARGS, and DOCUMENTATION.  A function is defined with NAME, ARGS, and DOCUMENTATION.  This
115    function first looks for a function to call in NAME's property list
116  If a DEFAULT-BODY is supplied then NO-APPLICABLE-METHOD is specialized  that is indicated by 'IMPLEMENTATION; failing that, it looks for a
117  to execute the body if the backend doesn't provide a specific  function indicated by 'DEFAULT. If neither is present, an error is
118  implementation.  signaled.
119    
120    If a DEFAULT-BODY is supplied, then a function with the same body and
121    ARGS will be added to NAME's property list as the property indicated
122    by 'DEFAULT.
123    
124  Backends implement these functions using DEFIMPLEMENTATION."  Backends implement these functions using DEFIMPLEMENTATION."
125    (check-type documentation string "a documentation string")    (check-type documentation string "a documentation string")
126    (flet ((gen-default-impl ()    (assert (every #'symbolp args) ()
127             `(defmethod ,name ,args ,@default-body)))            "Complex lambda-list not supported: ~S ~S" name args)
128      `(progn (defgeneric ,name ,args (:documentation ,documentation))    (labels ((gen-default-impl ()
129              (pushnew ',name *interface-functions*)               `(setf (get ',name 'default) (lambda ,args ,@default-body)))
130              ,(if (null default-body)             (args-as-list (args)
131                   `(pushnew ',name *unimplemented-interfaces*)               (destructuring-bind (req opt key rest) (parse-lambda-list args)
132                   (gen-default-impl))                 `(,@req ,@opt
133              ;; see <http://www.franz.com/support/documentation/6.2/doc/pages/variables/compiler/s_cltl1-compile-file-toplevel-compatibility-p_s.htm>                         ,@(loop for k in key append `(,(kw k) ,k))
134              (eval-when (:compile-toplevel :load-toplevel :execute)                         ,@(or rest '(())))))
135                (export ',name :swank-backend))             (parse-lambda-list (args)
136              ',name)))               (parse args '(&optional &key &rest)
137                        (make-array 4 :initial-element nil)))
138               (parse (args keywords vars)
139                 (cond ((null args)
140                        (reverse (map 'list #'reverse vars)))
141                       ((member (car args) keywords)
142                        (parse (cdr args) (cdr (member (car args) keywords)) vars))
143                       (t (push (car args) (aref vars (length keywords)))
144                          (parse (cdr args) keywords vars))))
145               (kw (s) (intern (string s) :keyword)))
146        `(progn
147           (defun ,name ,args
148             ,documentation
149             (let ((f (or (get ',name 'implementation)
150                          (get ',name 'default))))
151               (cond (f (apply f ,@(args-as-list args)))
152                     (t (error "~S not implemented" ',name)))))
153           (pushnew ',name *interface-functions*)
154           ,(if (null default-body)
155                `(pushnew ',name *unimplemented-interfaces*)
156                (gen-default-impl))
157           ;; see <http://www.franz.com/support/documentation/6.2/doc/pages/variables/compiler/s_cltl1-compile-file-toplevel-compatibility-p_s.htm>
158           (eval-when (:compile-toplevel :load-toplevel :execute)
159             (export ',name :swank-backend))
160           ',name)))
161    
162  (defmacro defimplementation (name args &body body)  (defmacro defimplementation (name args &body body)
163    `(progn (defmethod ,name ,args ,@body)    (assert (every #'symbolp args) ()
164            (if (member ',name *interface-functions*)            "Complex lambda-list not supported: ~S ~S" name args)
165                (setq *unimplemented-interfaces*    `(progn
166                      (remove ',name *unimplemented-interfaces*))       (setf (get ',name 'implementation) (lambda ,args ,@body))
167                (warn "DEFIMPLEMENTATION of undefined interface (~S)" ',name))       (if (member ',name *interface-functions*)
168            ',name))           (setq *unimplemented-interfaces*
169                   (remove ',name *unimplemented-interfaces*))
170             (warn "DEFIMPLEMENTATION of undefined interface (~S)" ',name))
171         ',name))
172    
173  (defun warn-unimplemented-interfaces ()  (defun warn-unimplemented-interfaces ()
174    "Warn the user about unimplemented backend features.    "Warn the user about unimplemented backend features.
175  The portable code calls this function at startup."  The portable code calls this function at startup."
176    (warn "These Swank interfaces are unimplemented:~% ~A"    (let ((*print-pretty* t))
177          (sort (copy-list *unimplemented-interfaces*) #'string<)))      (warn "These Swank interfaces are unimplemented:~% ~:<~{~A~^ ~:_~}~:>"
178              (list (sort (copy-list *unimplemented-interfaces*) #'string<)))))
179    
180  (defun import-to-swank-mop (symbol-list)  (defun import-to-swank-mop (symbol-list)
181    (dolist (sym symbol-list)    (dolist (sym symbol-list)
# Line 158  EXCEPT is a list of symbol names which s Line 199  EXCEPT is a list of symbol names which s
199  (defvar *gray-stream-symbols*  (defvar *gray-stream-symbols*
200    '(:fundamental-character-output-stream    '(:fundamental-character-output-stream
201      :stream-write-char      :stream-write-char
202        :stream-write-string
203      :stream-fresh-line      :stream-fresh-line
204      :stream-force-output      :stream-force-output
205      :stream-finish-output      :stream-finish-output
206      :fundamental-character-input-stream      :fundamental-character-input-stream
207      :stream-read-char      :stream-read-char
208        :stream-peek-char
209        :stream-read-line
210        ;; STREAM-FILE-POSITION is not available on all implementations, or
211        ;; partially under a different name.
212        ; :stream-file-posiion
213      :stream-listen      :stream-listen
214      :stream-unread-char      :stream-unread-char
215      :stream-clear-input      :stream-clear-input
# Line 199  EXCEPT is a list of symbol names which s Line 246  EXCEPT is a list of symbol names which s
246                       (t (error "Malformed syntax in WITH-STRUCT: ~A" name))))                       (t (error "Malformed syntax in WITH-STRUCT: ~A" name))))
247            ,@body)))))            ,@body)))))
248    
249    (defun with-symbol (name package)
250      "Generate a form suitable for testing with #+."
251      (if (find-symbol (string name) (string package))
252          '(:and)
253          '(:or)))
254    
255    
256  ;;;; TCP server  ;;;; TCP server
257    
# Line 212  EXCEPT is a list of symbol names which s Line 265  EXCEPT is a list of symbol names which s
265    "Close the socket SOCKET.")    "Close the socket SOCKET.")
266    
267  (definterface accept-connection (socket &key external-format  (definterface accept-connection (socket &key external-format
268                                          buffering)                                          buffering timeout)
269     "Accept a client connection on the listening socket SOCKET.     "Accept a client connection on the listening socket SOCKET.
270  Return a stream for the new connection.")  Return a stream for the new connection.")
271    
# Line 232  Return a stream for the new connection." Line 285  Return a stream for the new connection."
285    "Return one of the symbols :spawn, :sigio, :fd-handler, or NIL."    "Return one of the symbols :spawn, :sigio, :fd-handler, or NIL."
286    nil)    nil)
287    
288    (definterface set-stream-timeout (stream timeout)
289      "Set the 'stream 'timeout.  The timeout is either the real number
290      specifying the timeout in seconds or 'nil for no timeout."
291      (declare (ignore stream timeout))
292      nil)
293    
294  ;;; Base condition for networking errors.  ;;; Base condition for networking errors.
295  (define-condition network-error (simple-error) ())  (define-condition network-error (simple-error) ())
296    
# Line 256  that the calling thread is the one that Line 315  that the calling thread is the one that
315  (definterface getpid ()  (definterface getpid ()
316    "Return the (Unix) process ID of this superior Lisp.")    "Return the (Unix) process ID of this superior Lisp.")
317    
318    (definterface install-sigint-handler (function)
319      "Call FUNCTION on SIGINT (instead of invoking the debugger).
320    Return old signal handler."
321      (declare (ignore function))
322      nil)
323    
324    (definterface call-with-user-break-handler (handler function)
325      "Install the break handler HANDLER while executing FUNCTION."
326      (let ((old-handler (install-sigint-handler handler)))
327        (unwind-protect (funcall function)
328          (install-sigint-handler old-handler))))
329    
330    (definterface quit-lisp ()
331      "Exit the current lisp image.")
332    
333  (definterface lisp-implementation-type-name ()  (definterface lisp-implementation-type-name ()
334    "Return a short name for the Lisp implementation."    "Return a short name for the Lisp implementation."
335    (lisp-implementation-type))    (lisp-implementation-type))
336    
337    
338    ;; pathnames are sooo useless
339    
340    (definterface filename-to-pathname (filename)
341      "Return a pathname for FILENAME.
342    A filename in Emacs may for example contain asterisks which should not
343    be translated to wildcards."
344      (parse-namestring filename))
345    
346    (definterface pathname-to-filename (pathname)
347      "Return the filename for PATHNAME."
348      (namestring pathname))
349    
350  (definterface default-directory ()  (definterface default-directory ()
351    "Return the default directory."    "Return the default directory."
352    (directory-namestring (truename *default-pathname-defaults*)))    (directory-namestring (truename *default-pathname-defaults*)))
# Line 270  This is used to resolve filenames withou Line 357  This is used to resolve filenames withou
357    (setf *default-pathname-defaults* (truename (merge-pathnames directory)))    (setf *default-pathname-defaults* (truename (merge-pathnames directory)))
358    (default-directory))    (default-directory))
359    
360    
361  (definterface call-with-syntax-hooks (fn)  (definterface call-with-syntax-hooks (fn)
362    "Call FN with hooks to handle special syntax."    "Call FN with hooks to handle special syntax."
363    (funcall fn))    (funcall fn))
# Line 278  This is used to resolve filenames withou Line 366  This is used to resolve filenames withou
366    "Return a suitable initial value for SWANK:*READTABLE-ALIST*."    "Return a suitable initial value for SWANK:*READTABLE-ALIST*."
367    '())    '())
368    
 (definterface quit-lisp ()  
   "Exit the current lisp image.")  
   
369    
370  ;;;; Compilation  ;;;; Compilation
371    
# Line 292  This is used to resolve filenames withou Line 377  This is used to resolve filenames withou
377    (declare (ignore ignore))    (declare (ignore ignore))
378    `(call-with-compilation-hooks (lambda () (progn ,@body))))    `(call-with-compilation-hooks (lambda () (progn ,@body))))
379    
380  (definterface swank-compile-string (string &key buffer position directory)  (definterface swank-compile-string (string &key buffer position filename
381    "Compile source from STRING.  During compilation, compiler                                             policy)
382  conditions must be trapped and resignalled as COMPILER-CONDITIONs.    "Compile source from STRING.
383    During compilation, compiler conditions must be trapped and
384    resignalled as COMPILER-CONDITIONs.
385    
386  If supplied, BUFFER and POSITION specify the source location in Emacs.  If supplied, BUFFER and POSITION specify the source location in Emacs.
387    
388  Additionally, if POSITION is supplied, it must be added to source  Additionally, if POSITION is supplied, it must be added to source
389  positions reported in compiler conditions.  positions reported in compiler conditions.
390    
391  If DIRECTORY is specified it may be used by certain implementations to  If FILENAME is specified it may be used by certain implementations to
392  rebind *DEFAULT-PATHNAME-DEFAULTS* which may improve the recording of  rebind *DEFAULT-PATHNAME-DEFAULTS* which may improve the recording of
393  source information.")  source information.
394    
395  (definterface operate-on-system (system-name operation-name &rest keyword-args)  If POLICY is supplied, and non-NIL, it may be used by certain
396    "Perform OPERATION-NAME on SYSTEM-NAME using ASDF.  implementations to compile with a debug optimization quality of its
397  The KEYWORD-ARGS are passed on to the operation.  value.
398  Example:  
399  \(operate-on-system \"SWANK\" \"COMPILE-OP\" :force t)"  Should return T on successfull compilation, NIL otherwise.
400    (unless (member :asdf *features*)  ")
401      (error "ASDF is not loaded."))  
402    (with-compilation-hooks ()  (definterface swank-compile-file (input-file output-file load-p
403      (let ((operate (find-symbol "OPERATE" :asdf))                                               external-format)
404            (operation (find-symbol operation-name :asdf)))     "Compile INPUT-FILE signalling COMPILE-CONDITIONs.
405        (when (null operation)  If LOAD-P is true, load the file after compilation.
406          (error "Couldn't find ASDF operation ~S" operation-name))  EXTERNAL-FORMAT is a value returned by find-external-format or
407        (apply operate operation system-name keyword-args))))  :default.
408    
409  (definterface swank-compile-file (filename load-p &optional external-format)  Should return OUTPUT-TRUENAME, WARNINGS-P and FAILURE-p
410     "Compile FILENAME signalling COMPILE-CONDITIONs.  like `compile-file'")
 If LOAD-P is true, load the file after compilation.")  
411    
412  (deftype severity ()  (deftype severity ()
413    '(member :error :read-error :warning :style-warning :note))    '(member :error :read-error :warning :style-warning :note :redefinition))
414    
415  ;; Base condition type for compiler errors, warnings and notes.  ;; Base condition type for compiler errors, warnings and notes.
416  (define-condition compiler-condition (condition)  (define-condition compiler-condition (condition)
# Line 342  If LOAD-P is true, load the file after c Line 428  If LOAD-P is true, load the file after c
428     (message :initarg :message     (message :initarg :message
429              :accessor message)              :accessor message)
430    
431     (short-message :initarg :short-message     ;; Macro expansion history etc. which may be helpful in some cases
432                    :initform nil     ;; but is often very verbose.
433                    :accessor short-message)     (source-context :initarg :source-context
434                       :type (or null string)
435                       :initform nil
436                       :accessor source-context)
437    
438     (references :initarg :references     (references :initarg :references
439                 :initform nil                 :initform nil
# Line 353  If LOAD-P is true, load the file after c Line 442  If LOAD-P is true, load the file after c
442     (location :initarg :location     (location :initarg :location
443               :accessor location)))               :accessor location)))
444    
445    (definterface find-external-format (coding-system)
446      "Return a \"external file format designator\" for CODING-SYSTEM.
447    CODING-SYSTEM is Emacs-style coding system name (a string),
448    e.g. \"latin-1-unix\"."
449      (if (equal coding-system "iso-latin-1-unix")
450          :default
451          nil))
452    
453    (definterface guess-external-format (pathname)
454      "Detect the external format for the file with name pathname.
455    Return nil if the file contains no special markers."
456      ;; Look for a Emacs-style -*- coding: ... -*- or Local Variable: section.
457      (with-open-file (s pathname :if-does-not-exist nil
458                         :external-format (or (find-external-format "latin-1-unix")
459                                              :default))
460        (if s
461            (or (let* ((line (read-line s nil))
462                       (p (search "-*-" line)))
463                  (when p
464                    (let* ((start (+ p (length "-*-")))
465                           (end (search "-*-" line :start2 start)))
466                      (when end
467                        (%search-coding line start end)))))
468                (let* ((len (file-length s))
469                       (buf (make-string (min len 3000))))
470                  (file-position s (- len (length buf)))
471                  (read-sequence buf s)
472                  (let ((start (search "Local Variables:" buf :from-end t))
473                        (end (search "End:" buf :from-end t)))
474                    (and start end (< start end)
475                         (%search-coding buf start end))))))))
476    
477    (defun %search-coding (str start end)
478      (let ((p (search "coding:" str :start2 start :end2 end)))
479        (when p
480          (incf p (length "coding:"))
481          (loop while (and (< p end)
482                           (member (aref str p) '(#\space #\tab)))
483                do (incf p))
484          (let ((end (position-if (lambda (c) (find c '(#\space #\tab #\newline)))
485                                  str :start p)))
486            (find-external-format (subseq str p end))))))
487    
488    
489  ;;;; Streams  ;;;; Streams
490    
491  (definterface make-fn-streams (input-fn output-fn)  (definterface make-output-stream (write-string)
492     "Return character input and output streams backended by functions.    "Return a new character output stream.
493  When input is needed, INPUT-FN is called with no arguments to  The stream calls WRITE-STRING when output is ready.")
494  return a string.  
495  When output is ready, OUTPUT-FN is called with the output as its  (definterface make-input-stream (read-string)
496  argument.    "Return a new character input stream.
497    The stream calls READ-STRING when input is needed.")
 Output should be forced to OUTPUT-FN before calling INPUT-FN.  
   
 The streams are returned as two values.")  
   
 (definterface make-stream-interactive (stream)  
   "Do any necessary setup to make STREAM work interactively.  
 This is called for each stream used for interaction with the user  
 \(e.g. *standard-output*). An implementation could setup some  
 implementation-specific functions to control output flushing at the  
 like."  
   (declare (ignore stream))  
   nil)  
498    
499    
500  ;;;; Documentation  ;;;; Documentation
# Line 383  like." Line 503  like."
503     "Return the lambda list for the symbol NAME. NAME can also be     "Return the lambda list for the symbol NAME. NAME can also be
504  a lisp function object, on lisps which support this.  a lisp function object, on lisps which support this.
505    
506  The result can be a list or the :not-available if the arglist  The result can be a list or the :not-available keyword if the
507  cannot be determined."  arglist cannot be determined."
508     (declare (ignore name))     (declare (ignore name))
509     :not-available)     :not-available)
510    
511    (defgeneric declaration-arglist (decl-identifier)
512      (:documentation
513       "Return the argument list of the declaration specifier belonging to the
514    declaration identifier DECL-IDENTIFIER. If the arglist cannot be determined,
515    the keyword :NOT-AVAILABLE is returned.
516    
517    The different SWANK backends can specialize this generic function to
518    include implementation-dependend declaration specifiers, or to provide
519    additional information on the specifiers defined in ANSI Common Lisp.")
520      (:method (decl-identifier)
521        (case decl-identifier
522          (dynamic-extent '(&rest vars))
523          (ignore         '(&rest vars))
524          (ignorable      '(&rest vars))
525          (special        '(&rest vars))
526          (inline         '(&rest function-names))
527          (notinline      '(&rest function-names))
528          (declaration    '(&rest names))
529          (optimize       '(&any compilation-speed debug safety space speed))
530          (type           '(type-specifier &rest args))
531          (ftype          '(type-specifier &rest function-names))
532          (otherwise
533           (flet ((typespec-p (symbol) (member :type (describe-symbol-for-emacs symbol))))
534             (cond ((and (symbolp decl-identifier) (typespec-p decl-identifier))
535                    '(&rest vars))
536                   ((and (listp decl-identifier) (typespec-p (first decl-identifier)))
537                    '(&rest vars))
538                   (t :not-available)))))))
539    
540    (defgeneric type-specifier-arglist (typespec-operator)
541      (:documentation
542       "Return the argument list of the type specifier belonging to
543    TYPESPEC-OPERATOR.. If the arglist cannot be determined, the keyword
544    :NOT-AVAILABLE is returned.
545    
546    The different SWANK backends can specialize this generic function to
547    include implementation-dependend declaration specifiers, or to provide
548    additional information on the specifiers defined in ANSI Common Lisp.")
549      (:method (typespec-operator)
550        (declare (special *type-specifier-arglists*)) ; defined at end of file.
551        (typecase typespec-operator
552          (symbol (or (cdr (assoc typespec-operator *type-specifier-arglists*))
553                      :not-available))
554          (t :not-available))))
555    
556  (definterface function-name (function)  (definterface function-name (function)
557    "Return the name of the function object FUNCTION.    "Return the name of the function object FUNCTION.
558    
# Line 421  NIL." Line 586  NIL."
586                     (values new-form expanded)))))                     (values new-form expanded)))))
587      (frob form env)))      (frob form env)))
588    
589    (definterface format-string-expand (control-string)
590      "Expand the format string CONTROL-STRING."
591      (macroexpand `(formatter ,control-string)))
592    
593  (definterface describe-symbol-for-emacs (symbol)  (definterface describe-symbol-for-emacs (symbol)
594     "Return a property list describing SYMBOL.     "Return a property list describing SYMBOL.
595    
# Line 470  For example, this is a reasonable place Line 639  For example, this is a reasonable place
639  to safe reader/printer settings, and so on.")  to safe reader/printer settings, and so on.")
640    
641  (definterface call-with-debugger-hook (hook fun)  (definterface call-with-debugger-hook (hook fun)
642    "Call FUN and use HOOK as debugger hook.    "Call FUN and use HOOK as debugger hook. HOOK can be NIL.
643    
644  HOOK should be called for both BREAK and INVOKE-DEBUGGER."  HOOK should be called for both BREAK and INVOKE-DEBUGGER."
645    (let ((*debugger-hook* hook))    (let ((*debugger-hook* hook))
# Line 492  debug the debugger! Instead, such condit Line 661  debug the debugger! Instead, such condit
661  user without (re)entering the debugger by wrapping them as  user without (re)entering the debugger by wrapping them as
662  `sldb-condition's."))  `sldb-condition's."))
663    
664    ;;; The following functions in this section are supposed to be called
665    ;;; within the dynamic contour of CALL-WITH-DEBUGGING-ENVIRONMENT only.
666    
667  (definterface compute-backtrace (start end)  (definterface compute-backtrace (start end)
668     "Return a list containing a backtrace of the condition current     "Returns a backtrace of the condition currently being debugged,
669  being debugged.  The results are unspecified if this function is  that is an ordered list consisting of frames. ``Ordered list''
670  called outside the dynamic contour CALL-WITH-DEBUGGING-ENVIRONMENT.  means that an integer I can be mapped back to the i-th frame of this
671    backtrace.
672    
673  START and END are zero-based indices constraining the number of frames  START and END are zero-based indices constraining the number of frames
674  returned.  Frame zero is defined as the frame which invoked the  returned. Frame zero is defined as the frame which invoked the
675  debugger.  If END is nil, return the frames from START to the end of  debugger. If END is nil, return the frames from START to the end of
676  the stack.")  the stack.")
677    
678  (definterface print-frame (frame stream)  (definterface print-frame (frame stream)
679    "Print frame to stream.")    "Print frame to stream.")
680    
681  (definterface frame-source-location-for-emacs (frame-number)  (definterface frame-restartable-p (frame)
682    "Return the source location for FRAME-NUMBER.")    "Is the frame FRAME restartable?.
683    Return T if `restart-frame' can safely be called on the frame."
684      (declare (ignore frame))
685      nil)
686    
687    (definterface frame-source-location (frame-number)
688      "Return the source location for the frame associated to FRAME-NUMBER.")
689    
690  (definterface frame-catch-tags (frame-number)  (definterface frame-catch-tags (frame-number)
691    "Return a list of XXX list of what? catch tags for a debugger    "Return a list of catch tags for being printed in a debugger stack
692  stack frame.  The results are undefined unless this is called  frame."
693  within the dynamic contour of a function defined by    (declare (ignore frame-number))
694  DEFINE-DEBUGGER-HOOK.")    '())
695    
696  (definterface frame-locals (frame-number)  (definterface frame-locals (frame-number)
697    "Return a list of XXX local variable designators define me    "Return a list of ((&key NAME ID VALUE) ...) where each element of
698  for a debugger stack frame.  The results are undefined unless  the list represents a local variable in the stack frame associated to
699  this is called within the dynamic contour of a function defined  FRAME-NUMBER.
700  by DEFINE-DEBUGGER-HOOK.")  
701    NAME, a symbol; the name of the local variable.
702  (definterface frame-var-value (frame var)  
703    "Return the value of VAR in FRAME.  ID, an integer; used as primary key for the local variable, unique
704  FRAME is the number of the frame in the backtrace.  relatively to the frame under operation.
705  VAR is the number of the variable in the frame.")  
706    value, an object; the value of the local variable.")
707    
708    (definterface frame-var-value (frame-number var-id)
709      "Return the value of the local variable associated to VAR-ID
710    relatively to the frame associated to FRAME-NUMBER.")
711    
712  (definterface disassemble-frame (frame-number)  (definterface disassemble-frame (frame-number)
713    "Disassemble the code for the FRAME-NUMBER.    "Disassemble the code for the FRAME-NUMBER.
# Line 532  FRAME-NUMBER is a non-negative integer." Line 716  FRAME-NUMBER is a non-negative integer."
716    
717  (definterface eval-in-frame (form frame-number)  (definterface eval-in-frame (form frame-number)
718     "Evaluate a Lisp form in the lexical context of a stack frame     "Evaluate a Lisp form in the lexical context of a stack frame
719  in the debugger.  The results are undefined unless called in the  in the debugger.
 dynamic contour of a function defined by DEFINE-DEBUGGER-HOOK.  
720    
721  FRAME-NUMBER must be a positive integer with 0 indicating the  FRAME-NUMBER must be a positive integer with 0 indicating the
722  frame which invoked the debugger.  frame which invoked the debugger.
# Line 559  as it was called originally.") Line 742  as it was called originally.")
742    "Format a condition for display in SLDB."    "Format a condition for display in SLDB."
743    (princ-to-string condition))    (princ-to-string condition))
744    
 (definterface condition-references (condition)  
   "Return a list of documentation references for a condition.  
 Each reference is one of:  
   (:ANSI-CL  
    {:FUNCTION | :SPECIAL-OPERATOR | :MACRO | :SECTION | :GLOSSARY }  
    symbol-or-name)  
   (:SBCL :NODE node-name)"  
   (declare (ignore condition))  
   '())  
   
745  (definterface condition-extras (condition)  (definterface condition-extras (condition)
746    "Return a list of extra for the debugger.    "Return a list of extra for the debugger.
747  The allowed elements are of the form:  The allowed elements are of the form:
748    (:SHOW-FRAME-SOURCE frame-number)"    (:SHOW-FRAME-SOURCE frame-number)
749      (:REFERENCES &rest refs)
750    "
751    (declare (ignore condition))    (declare (ignore condition))
752    '())    '())
753    
# Line 585  The allowed elements are of the form: Line 760  The allowed elements are of the form:
760  (definterface sldb-break-at-start (symbol)  (definterface sldb-break-at-start (symbol)
761    "Set a breakpoint on the beginning of the function for SYMBOL.")    "Set a breakpoint on the beginning of the function for SYMBOL.")
762    
763    (definterface sldb-stepper-condition-p (condition)
764      "Return true if SLDB was invoked due to a single-stepping condition,
765    false otherwise. "
766      (declare (ignore condition))
767      nil)
768    
769    (definterface sldb-step-into ()
770      "Step into the current single-stepper form.")
771    
772    (definterface sldb-step-next ()
773      "Step to the next form in the current function.")
774    
775    (definterface sldb-step-out ()
776      "Stop single-stepping temporarily, but resume it once the current function
777    returns.")
778    
779    
780  ;;;; Definition finding  ;;;; Definition finding
# Line 615  definition, e.g., FOO or (METHOD FOO (ST Line 805  definition, e.g., FOO or (METHOD FOO (ST
805    
806  LOCATION is the source location for the definition.")  LOCATION is the source location for the definition.")
807    
808    (definterface find-source-location (object)
809      "Returns the source location of OBJECT, or NIL.
810    
811    That is the source location of the underlying datastructure of
812    OBJECT. E.g. on a STANDARD-OBJECT, the source location of the
813    respective DEFCLASS definition is returned, on a STRUCTURE-CLASS the
814    respective DEFSTRUCT definition, and so on."
815      ;; This returns one source location and not a list of locations. It's
816      ;; supposed to return the location of the DEFGENERIC definition on
817      ;; #'SOME-GENERIC-FUNCTION.
818      )
819    
820    
821  (definterface buffer-first-change (filename)  (definterface buffer-first-change (filename)
822    "Called for effect the first time FILENAME's buffer is modified."    "Called for effect the first time FILENAME's buffer is modified."
823    (declare (ignore filename))    (declare (ignore filename))
824    nil)    nil)
825    
826    
827    
828  ;;;; XREF  ;;;; XREF
829    
830  (definterface who-calls (function-name)  (definterface who-calls (function-name)
831    "Return the call sites of FUNCTION-NAME (a symbol).    "Return the call sites of FUNCTION-NAME (a symbol).
832  The results is a list ((DSPEC LOCATION) ...).")  The results is a list ((DSPEC LOCATION) ...)."
833      (declare (ignore function-name))
834      :not-implemented)
835    
836  (definterface calls-who (function-name)  (definterface calls-who (function-name)
837    "Return the call sites of FUNCTION-NAME (a symbol).    "Return the call sites of FUNCTION-NAME (a symbol).
838  The results is a list ((DSPEC LOCATION) ...).")  The results is a list ((DSPEC LOCATION) ...)."
839      (declare (ignore function-name))
840      :not-implemented)
841    
842  (definterface who-references (variable-name)  (definterface who-references (variable-name)
843    "Return the locations where VARIABLE-NAME (a symbol) is referenced.    "Return the locations where VARIABLE-NAME (a symbol) is referenced.
844  See WHO-CALLS for a description of the return value.")  See WHO-CALLS for a description of the return value."
845      (declare (ignore variable-name))
846      :not-implemented)
847    
848  (definterface who-binds (variable-name)  (definterface who-binds (variable-name)
849    "Return the locations where VARIABLE-NAME (a symbol) is bound.    "Return the locations where VARIABLE-NAME (a symbol) is bound.
850  See WHO-CALLS for a description of the return value.")  See WHO-CALLS for a description of the return value."
851      (declare (ignore variable-name))
852      :not-implemented)
853    
854  (definterface who-sets (variable-name)  (definterface who-sets (variable-name)
855    "Return the locations where VARIABLE-NAME (a symbol) is set.    "Return the locations where VARIABLE-NAME (a symbol) is set.
856  See WHO-CALLS for a description of the return value.")  See WHO-CALLS for a description of the return value."
857      (declare (ignore variable-name))
858      :not-implemented)
859    
860  (definterface who-macroexpands (macro-name)  (definterface who-macroexpands (macro-name)
861    "Return the locations where MACRO-NAME (a symbol) is expanded.    "Return the locations where MACRO-NAME (a symbol) is expanded.
862  See WHO-CALLS for a description of the return value.")  See WHO-CALLS for a description of the return value."
863      (declare (ignore macro-name))
864      :not-implemented)
865    
866  (definterface who-specializes (class-name)  (definterface who-specializes (class-name)
867    "Return the locations where CLASS-NAME (a symbol) is specialized.    "Return the locations where CLASS-NAME (a symbol) is specialized.
868  See WHO-CALLS for a description of the return value.")  See WHO-CALLS for a description of the return value."
869      (declare (ignore class-name))
870      :not-implemented)
871    
872  ;;; Simpler variants.  ;;; Simpler variants.
873    
# Line 706  themselves, that is, their dispatch func Line 924  themselves, that is, their dispatch func
924    
925  ;;;; Inspector  ;;;; Inspector
926    
927  (defclass inspector ()  (defgeneric emacs-inspect (object)
928    ()    (:documentation
   (:documentation "Super class of inspector objects.  
   
 Implementations should sub class in order to dispatch off of the  
 inspect-for-emacs method."))  
   
 (definterface make-default-inspector ()  
   "Return an inspector object suitable for passing to inspect-for-emacs.")  
   
 (definterface inspect-for-emacs (object inspector)  
929     "Explain to Emacs how to inspect OBJECT.     "Explain to Emacs how to inspect OBJECT.
930    
931  The argument INSPECTOR is an object representing how to get at  Returns a list specifying how to render the object for inspection.
 the internals of OBJECT, it is usually an implementation specific  
 class used simply for dispatching to the proper method.  
   
 The orgument INSPECTION-MODE is an object specifying how, and  
 what, to show to the user.  
   
 Returns two values: a string which will be used as the title of  
 the inspector buffer and a list specifying how to render the  
 object for inspection.  
932    
933  Every element of the list must be either a string, which will be  Every element of the list must be either a string, which will be
934  inserted into the buffer as is, or a list of the form:  inserted into the buffer as is, or a list of the form:
# Line 739  inserted into the buffer as is, or a lis Line 939  inserted into the buffer as is, or a lis
939    
940   (:newline) - Render a \\n   (:newline) - Render a \\n
941    
942   (:action label lambda) - Render LABEL (a text string) which when   (:action label lambda &key (refresh t)) - Render LABEL (a text
943   clicked will call LAMBDA.   string) which when clicked will call LAMBDA. If REFRESH is
944     non-NIL the currently inspected object will be re-inspected
945   NIL - do nothing.")   after calling the lambda.
946    "))
947    
948  (defmethod inspect-for-emacs ((object t) (inspector t))  (defmethod emacs-inspect ((object t))
949    "Generic method for inspecting any kind of object.    "Generic method for inspecting any kind of object.
950    
951  Since we don't know how to deal with OBJECT we simply dump the  Since we don't know how to deal with OBJECT we simply dump the
952  output of CL:DESCRIBE."  output of CL:DESCRIBE."
   (declare (ignore inspector))  
   (values  
    "A value."  
953     `("Type: " (:value ,(type-of object)) (:newline)     `("Type: " (:value ,(type-of object)) (:newline)
954       "Don't know how to inspect the object, dumping output of CL:DESCRIBE:"       "Don't know how to inspect the object, dumping output of CL:DESCRIBE:"
955       (:newline) (:newline)       (:newline) (:newline)
956       ,(with-output-to-string (desc) (describe object desc)))))       ,(with-output-to-string (desc) (describe object desc))))
957    
958  ;;; Utilities for inspector methods.  ;;; Utilities for inspector methods.
959  ;;;  ;;;
960  (defun label-value-line (label value)  (defun label-value-line (label value &key (newline t))
961    "Create a control list which prints \"LABEL: VALUE\" in the inspector."    "Create a control list which prints \"LABEL: VALUE\" in the inspector.
962    (list (princ-to-string label) ": " `(:value ,value) '(:newline)))  If NEWLINE is non-NIL a `(:newline)' is added to the result."
963      (list* (princ-to-string label) ": " `(:value ,value)
964             (if newline '((:newline)) nil)))
965    
966  (defmacro label-value-line* (&rest label-values)  (defmacro label-value-line* (&rest label-values)
967    ` (append ,@(loop for (label value) in label-values    ` (append ,@(loop for (label value) in label-values
# Line 778  output of CL:DESCRIBE." Line 978  output of CL:DESCRIBE."
978  ;;; The default implementations are sufficient for non-multiprocessing  ;;; The default implementations are sufficient for non-multiprocessing
979  ;;; implementations.  ;;; implementations.
980    
981  (definterface initialize-multiprocessing ()  (definterface initialize-multiprocessing (continuation)
982     "Initialize multiprocessing, if necessary."     "Initialize multiprocessing, if necessary and then invoke CONTINUATION.
    nil)  
983    
984  (definterface startup-idle-and-top-level-loops ()  Depending on the impleimentaion, this function may never return."
985    "This function is called directly through the listener, not in an RPC     (funcall continuation))
 from Emacs. This is to support interfaces such as CMUCL's  
 MP::STARTUP-IDLE-AND-TOP-LEVEL-LOOPS which does not return like a  
 normal function."  
    nil)  
986    
987  (definterface spawn (fn &key name)  (definterface spawn (fn &key name)
988    "Create a new thread to call FN.")    "Create a new thread to call FN.")
# Line 796  normal function." Line 991  normal function."
991    "Return an Emacs-parsable object to identify THREAD.    "Return an Emacs-parsable object to identify THREAD.
992    
993  Ids should be comparable with equal, i.e.:  Ids should be comparable with equal, i.e.:
994   (equal (thread-id <t1>) (thread-id <t2>)) <==> (eq <t1> <t2>)")   (equal (thread-id <t1>) (thread-id <t2>)) <==> (eq <t1> <t2>)"
995      thread)
996    
997  (definterface find-thread (id)  (definterface find-thread (id)
998    "Return the thread for ID.    "Return the thread for ID.
999  ID should be an id previously obtained with THREAD-ID.  ID should be an id previously obtained with THREAD-ID.
1000  Can return nil if the thread no longer exists.")  Can return nil if the thread no longer exists."
1001      (declare (ignore id))
1002      (current-thread))
1003    
1004  (definterface thread-name (thread)  (definterface thread-name (thread)
1005     "Return the name of THREAD.     "Return the name of THREAD.
# Line 816  user. They do not have to be unique." Line 1014  user. They do not have to be unique."
1014     (declare (ignore thread))     (declare (ignore thread))
1015     "")     "")
1016    
1017    (definterface thread-description (thread)
1018      "Return a string describing THREAD."
1019      (declare (ignore thread))
1020      "")
1021    
1022    (definterface set-thread-description (thread description)
1023      "Set THREAD's description to DESCRIPTION."
1024      (declare (ignore thread description))
1025      "")
1026    
1027    (definterface thread-attributes (thread)
1028      "Return a plist of implementation-dependent attributes for THREAD"
1029      (declare (ignore thread))
1030      '())
1031    
1032  (definterface make-lock (&key name)  (definterface make-lock (&key name)
1033     "Make a lock for thread synchronization.     "Make a lock for thread synchronization.
1034  Only one thread may hold the lock (via CALL-WITH-LOCK-HELD) at a time."  Only one thread may hold the lock (via CALL-WITH-LOCK-HELD) at a time
1035    but that thread may hold it more than once."
1036     (declare (ignore name))     (declare (ignore name))
1037     :null-lock)     :null-lock)
1038    
# Line 833  Only one thread may hold the lock (via C Line 1047  Only one thread may hold the lock (via C
1047    0)    0)
1048    
1049  (definterface all-threads ()  (definterface all-threads ()
1050    "Return a list of all threads.")    "Return a fresh list of all threads.")
1051    
1052  (definterface thread-alive-p (thread)  (definterface thread-alive-p (thread)
1053    "Test if THREAD is termintated."    "Test if THREAD is termintated."
# Line 843  Only one thread may hold the lock (via C Line 1057  Only one thread may hold the lock (via C
1057    "Cause THREAD to execute FN.")    "Cause THREAD to execute FN.")
1058    
1059  (definterface kill-thread (thread)  (definterface kill-thread (thread)
1060    "Kill THREAD."    "Terminate THREAD immediately.
1061    Don't execute unwind-protected sections, don't raise conditions.
1062    (Do not pass go, do not collect $200.)"
1063    (declare (ignore thread))    (declare (ignore thread))
1064    nil)    nil)
1065    
1066  (definterface send (thread object)  (definterface send (thread object)
1067    "Send OBJECT to thread THREAD.")    "Send OBJECT to thread THREAD.")
1068    
1069  (definterface receive ()  (definterface receive (&optional timeout)
1070    "Return the next message from current thread's mailbox.")    "Return the next message from current thread's mailbox."
1071      (receive-if (constantly t) timeout))
1072    
1073    (definterface receive-if (predicate &optional timeout)
1074      "Return the first message satisfiying PREDICATE.")
1075    
1076    (definterface set-default-initial-binding (var form)
1077      "Initialize special variable VAR by default with FORM.
1078    
1079    Some implementations initialize certain variables in each newly
1080    created thread.  This function sets the form which is used to produce
1081    the initial value."
1082      (set var (eval form)))
1083    
1084    ;; List of delayed interrupts.
1085    ;; This should only have thread-local bindings, so no init form.
1086    (defvar *pending-slime-interrupts*)
1087    
1088    (defun check-slime-interrupts ()
1089      "Execute pending interrupts if any.
1090    This should be called periodically in operations which
1091    can take a long time to complete.
1092    Return a boolean indicating whether any interrupts was processed."
1093      (when (and (boundp '*pending-slime-interrupts*)
1094                 *pending-slime-interrupts*)
1095        (funcall (pop *pending-slime-interrupts*))
1096        t))
1097    
1098    (defvar *interrupt-queued-handler* nil
1099      "Function to call on queued interrupts.
1100    Interrupts get queued when an interrupt occurs while interrupt
1101    handling is disabled.
1102    
1103    Backends can use this function to abort slow operations.")
1104    
1105    (definterface wait-for-input (streams &optional timeout)
1106      "Wait for input on a list of streams.  Return those that are ready.
1107    STREAMS is a list of streams
1108    TIMEOUT nil, t, or real number. If TIMEOUT is t, return
1109    those streams which are ready immediately, without waiting.
1110    If TIMEOUT is a number and no streams is ready after TIMEOUT seconds,
1111    return nil.
1112    
1113    Return :interrupt if an interrupt occurs while waiting."
1114      (assert (member timeout '(nil t)))
1115      (cond #+(or)
1116            ((null (cdr streams))
1117             (wait-for-one-stream (car streams) timeout))
1118            (t
1119             (wait-for-streams streams timeout))))
1120    
1121    (defun wait-for-streams (streams timeout)
1122      (loop
1123       (when (check-slime-interrupts) (return :interrupt))
1124       (let ((ready (remove-if-not #'stream-readable-p streams)))
1125         (when ready (return ready)))
1126       (when timeout (return nil))
1127       (sleep 0.1)))
1128    
1129    ;; Note: Usually we can't interrupt PEEK-CHAR cleanly.
1130    (defun wait-for-one-stream (stream timeout)
1131      (ecase timeout
1132        ((nil)
1133         (cond ((check-slime-interrupts) :interrupt)
1134               (t (peek-char nil stream nil nil)
1135                  (list stream))))
1136        ((t)
1137         (let ((c (read-char-no-hang stream nil nil)))
1138           (cond (c
1139                  (unread-char c stream)
1140                  (list stream))
1141                 (t '()))))))
1142    
1143    (defun stream-readable-p (stream)
1144      (let ((c (read-char-no-hang stream nil :eof)))
1145        (cond ((not c) nil)
1146              ((eq c :eof) t)
1147              (t (unread-char c stream) t))))
1148    
1149  (definterface toggle-trace (spec)  (definterface toggle-trace (spec)
1150    "Toggle tracing of the function(s) given with SPEC.    "Toggle tracing of the function(s) given with SPEC.
# Line 873  SPEC can be: Line 1166  SPEC can be:
1166  (definterface make-weak-value-hash-table (&rest args)  (definterface make-weak-value-hash-table (&rest args)
1167    "Like MAKE-HASH-TABLE, but weak w.r.t. the values."    "Like MAKE-HASH-TABLE, but weak w.r.t. the values."
1168    (apply #'make-hash-table args))    (apply #'make-hash-table args))
1169    
1170    (definterface hash-table-weakness (hashtable)
1171      "Return nil or one of :key :value :key-or-value :key-and-value"
1172      (declare (ignore hashtable))
1173      nil)
1174    
1175    
1176    ;;;; Character names
1177    
1178    (definterface character-completion-set (prefix matchp)
1179      "Return a list of names of characters that match PREFIX."
1180      ;; Handle the standard and semi-standard characters.
1181      (loop for name in '("Newline" "Space" "Tab" "Page" "Rubout"
1182                          "Linefeed" "Return" "Backspace")
1183         when (funcall matchp prefix name)
1184         collect name))
1185    
1186    
1187    (defparameter *type-specifier-arglists*
1188      '((and                . (&rest type-specifiers))
1189        (array              . (&optional element-type dimension-spec))
1190        (base-string        . (&optional size))
1191        (bit-vector         . (&optional size))
1192        (complex            . (&optional type-specifier))
1193        (cons               . (&optional car-typespec cdr-typespec))
1194        (double-float       . (&optional lower-limit upper-limit))
1195        (eql                . (object))
1196        (float              . (&optional lower-limit upper-limit))
1197        (function           . (&optional arg-typespec value-typespec))
1198        (integer            . (&optional lower-limit upper-limit))
1199        (long-float         . (&optional lower-limit upper-limit))
1200        (member             . (&rest eql-objects))
1201        (mod                . (n))
1202        (not                . (type-specifier))
1203        (or                 . (&rest type-specifiers))
1204        (rational           . (&optional lower-limit upper-limit))
1205        (real               . (&optional lower-limit upper-limit))
1206        (satisfies          . (predicate-symbol))
1207        (short-float        . (&optional lower-limit upper-limit))
1208        (signed-byte        . (&optional size))
1209        (simple-array       . (&optional element-type dimension-spec))
1210        (simple-base-string . (&optional size))
1211        (simple-bit-vector  . (&optional size))
1212        (simple-string      . (&optional size))
1213        (single-float       . (&optional lower-limit upper-limit))
1214        (simple-vector      . (&optional size))
1215        (string             . (&optional size))
1216        (unsigned-byte      . (&optional size))
1217        (values             . (&rest typespecs))
1218        (vector             . (&optional element-type size))
1219        ))
1220    
1221    ;;; Heap dumps
1222    
1223    (definterface save-image (filename &optional restart-function)
1224      "Save a heap image to the file FILENAME.
1225    RESTART-FUNCTION, if non-nil, should be called when the image is loaded.")
1226    
1227    
1228    

Legend:
Removed from v.1.94  
changed lines
  Added in v.1.182

  ViewVC Help
Powered by ViewVC 1.1.5