/[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.152 by heller, Sun Sep 14 17:10:34 2008 UTC
# Line 19  Line 19 
19             #:short-message             #:short-message
20             #:condition             #:condition
21             #:severity             #:severity
22               #:with-compilation-hooks
23               #:swank-frame
24               #:swank-frame-p
25               #:swank-frame.restartable
26             #:location             #:location
27             #:location-p             #:location-p
28             #:location-buffer             #:location-buffer
# Line 29  Line 33 
33             #:quit-lisp             #:quit-lisp
34             #:references             #:references
35             #:unbound-slot-filler             #:unbound-slot-filler
36               #:declaration-arglist
37               #:type-specifier-arglist
38               ;; interrupt macro for the backend
39               #:*pending-slime-interrupts*
40               #:check-slime-interrupts
41             ;; inspector related symbols             ;; inspector related symbols
42             #:inspector             #:emacs-inspect
            #:inspect-for-emacs  
            #:raw-inspection  
            #:fancy-inspection  
43             #:label-value-line             #:label-value-line
44             #:label-value-line*             #:label-value-line*
45    
46               #:with-struct
47             ))             ))
48    
49  (defpackage :swank-mop  (defpackage :swank-mop
# Line 84  Line 92 
92     #:slot-definition-type     #:slot-definition-type
93     #:slot-definition-readers     #:slot-definition-readers
94     #:slot-definition-writers     #:slot-definition-writers
95       #:slot-boundp-using-class
96       #:slot-value-using-class
97       #:slot-makunbound-using-class
98     ;; generic function protocol     ;; generic function protocol
99     #:compute-applicable-methods-using-classes     #:compute-applicable-methods-using-classes
100     #:finalize-inheritance))     #:finalize-inheritance))
# Line 102  DEFINTERFACE adds to this list and DEFIM Line 113  DEFINTERFACE adds to this list and DEFIM
113    
114  (defmacro definterface (name args documentation &rest default-body)  (defmacro definterface (name args documentation &rest default-body)
115    "Define an interface function for the backend to implement.    "Define an interface function for the backend to implement.
116  A generic function is defined with NAME, ARGS, and DOCUMENTATION.  A function is defined with NAME, ARGS, and DOCUMENTATION.  This
117    function first looks for a function to call in NAME's property list
118  If a DEFAULT-BODY is supplied then NO-APPLICABLE-METHOD is specialized  that is indicated by 'IMPLEMENTATION; failing that, it looks for a
119  to execute the body if the backend doesn't provide a specific  function indicated by 'DEFAULT. If neither is present, an error is
120  implementation.  signaled.
121    
122    If a DEFAULT-BODY is supplied, then a function with the same body and
123    ARGS will be added to NAME's property list as the property indicated
124    by 'DEFAULT.
125    
126  Backends implement these functions using DEFIMPLEMENTATION."  Backends implement these functions using DEFIMPLEMENTATION."
127    (check-type documentation string "a documentation string")    (check-type documentation string "a documentation string")
128    (flet ((gen-default-impl ()    (assert (every #'symbolp args) ()
129             `(defmethod ,name ,args ,@default-body)))            "Complex lambda-list not supported: ~S ~S" name args)
130      `(progn (defgeneric ,name ,args (:documentation ,documentation))    (labels ((gen-default-impl ()
131              (pushnew ',name *interface-functions*)               `(setf (get ',name 'default) (lambda ,args ,@default-body)))
132              ,(if (null default-body)             (args-as-list (args)
133                   `(pushnew ',name *unimplemented-interfaces*)               (destructuring-bind (req opt key rest) (parse-lambda-list args)
134                   (gen-default-impl))                 `(,@req ,@opt
135              ;; 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))
136              (eval-when (:compile-toplevel :load-toplevel :execute)                         ,@(or rest '(())))))
137                (export ',name :swank-backend))             (parse-lambda-list (args)
138              ',name)))               (parse args '(&optional &key &rest)
139                        (make-array 4 :initial-element nil)))
140               (parse (args keywords vars)
141                 (cond ((null args)
142                        (reverse (map 'list #'reverse vars)))
143                       ((member (car args) keywords)
144                        (parse (cdr args) (cdr (member (car args) keywords)) vars))
145                       (t (push (car args) (aref vars (length keywords)))
146                          (parse (cdr args) keywords vars))))
147               (kw (s) (intern (string s) :keyword)))
148        `(progn
149           (defun ,name ,args
150             ,documentation
151             (let ((f (or (get ',name 'implementation)
152                          (get ',name 'default))))
153               (cond (f (apply f ,@(args-as-list args)))
154                     (t (error "~S not implementated" ',name)))))
155           (pushnew ',name *interface-functions*)
156           ,(if (null default-body)
157                `(pushnew ',name *unimplemented-interfaces*)
158                (gen-default-impl))
159           ;; see <http://www.franz.com/support/documentation/6.2/doc/pages/variables/compiler/s_cltl1-compile-file-toplevel-compatibility-p_s.htm>
160           (eval-when (:compile-toplevel :load-toplevel :execute)
161             (export ',name :swank-backend))
162           ',name)))
163    
164  (defmacro defimplementation (name args &body body)  (defmacro defimplementation (name args &body body)
165    `(progn (defmethod ,name ,args ,@body)    (assert (every #'symbolp args) ()
166            (if (member ',name *interface-functions*)            "Complex lambda-list not supported: ~S ~S" name args)
167                (setq *unimplemented-interfaces*    `(progn
168                      (remove ',name *unimplemented-interfaces*))       (setf (get ',name 'implementation) (lambda ,args ,@body))
169                (warn "DEFIMPLEMENTATION of undefined interface (~S)" ',name))       (if (member ',name *interface-functions*)
170            ',name))           (setq *unimplemented-interfaces*
171                   (remove ',name *unimplemented-interfaces*))
172             (warn "DEFIMPLEMENTATION of undefined interface (~S)" ',name))
173         ',name))
174    
175  (defun warn-unimplemented-interfaces ()  (defun warn-unimplemented-interfaces ()
176    "Warn the user about unimplemented backend features.    "Warn the user about unimplemented backend features.
# Line 158  EXCEPT is a list of symbol names which s Line 200  EXCEPT is a list of symbol names which s
200  (defvar *gray-stream-symbols*  (defvar *gray-stream-symbols*
201    '(:fundamental-character-output-stream    '(:fundamental-character-output-stream
202      :stream-write-char      :stream-write-char
203        :stream-write-string
204      :stream-fresh-line      :stream-fresh-line
205      :stream-force-output      :stream-force-output
206      :stream-finish-output      :stream-finish-output
207      :fundamental-character-input-stream      :fundamental-character-input-stream
208      :stream-read-char      :stream-read-char
209        :stream-peek-char
210        :stream-read-line
211        ;; STREAM-FILE-POSITION is not available on all implementations, or
212        ;; partially under a different name.
213        ; :stream-file-posiion
214      :stream-listen      :stream-listen
215      :stream-unread-char      :stream-unread-char
216      :stream-clear-input      :stream-clear-input
# Line 212  EXCEPT is a list of symbol names which s Line 260  EXCEPT is a list of symbol names which s
260    "Close the socket SOCKET.")    "Close the socket SOCKET.")
261    
262  (definterface accept-connection (socket &key external-format  (definterface accept-connection (socket &key external-format
263                                          buffering)                                          buffering timeout)
264     "Accept a client connection on the listening socket SOCKET.     "Accept a client connection on the listening socket SOCKET.
265  Return a stream for the new connection.")  Return a stream for the new connection.")
266    
# Line 232  Return a stream for the new connection." Line 280  Return a stream for the new connection."
280    "Return one of the symbols :spawn, :sigio, :fd-handler, or NIL."    "Return one of the symbols :spawn, :sigio, :fd-handler, or NIL."
281    nil)    nil)
282    
283    (definterface set-stream-timeout (stream timeout)
284      "Set the 'stream 'timeout.  The timeout is either the real number
285      specifying the timeout in seconds or 'nil for no timeout."
286      (declare (ignore stream timeout))
287      nil)
288    
289  ;;; Base condition for networking errors.  ;;; Base condition for networking errors.
290  (define-condition network-error (simple-error) ())  (define-condition network-error (simple-error) ())
291    
# Line 256  that the calling thread is the one that Line 310  that the calling thread is the one that
310  (definterface getpid ()  (definterface getpid ()
311    "Return the (Unix) process ID of this superior Lisp.")    "Return the (Unix) process ID of this superior Lisp.")
312    
313    (definterface install-sigint-handler (function)
314      "Call FUNCTION on SIGINT (instead of invoking the debugger).
315    Return old signal handler."
316      nil)
317    
318    (definterface call-with-user-break-handler (handler function)
319      "Install the break handler HANDLER while executing FUNCTION."
320      (let ((old-handler (install-sigint-handler handler)))
321        (unwind-protect (funcall function)
322          (install-sigint-handler old-handler))))
323    
324  (definterface lisp-implementation-type-name ()  (definterface lisp-implementation-type-name ()
325    "Return a short name for the Lisp implementation."    "Return a short name for the Lisp implementation."
326    (lisp-implementation-type))    (lisp-implementation-type))
# Line 292  This is used to resolve filenames withou Line 357  This is used to resolve filenames withou
357    (declare (ignore ignore))    (declare (ignore ignore))
358    `(call-with-compilation-hooks (lambda () (progn ,@body))))    `(call-with-compilation-hooks (lambda () (progn ,@body))))
359    
360  (definterface swank-compile-string (string &key buffer position directory)  (definterface swank-compile-string (string &key buffer position directory debug)
361    "Compile source from STRING.  During compilation, compiler    "Compile source from STRING.  During compilation, compiler
362  conditions must be trapped and resignalled as COMPILER-CONDITIONs.  conditions must be trapped and resignalled as COMPILER-CONDITIONs.
363    
# Line 303  positions reported in compiler condition Line 368  positions reported in compiler condition
368    
369  If DIRECTORY is specified it may be used by certain implementations to  If DIRECTORY is specified it may be used by certain implementations to
370  rebind *DEFAULT-PATHNAME-DEFAULTS* which may improve the recording of  rebind *DEFAULT-PATHNAME-DEFAULTS* which may improve the recording of
371  source information.")  source information.
372    
373  (definterface operate-on-system (system-name operation-name &rest keyword-args)  If DEBUG is supplied, and non-NIL, it may be used by certain
374    "Perform OPERATION-NAME on SYSTEM-NAME using ASDF.  implementations to compile with a debug optimization quality of its
375  The KEYWORD-ARGS are passed on to the operation.  value.
376  Example:  
377  \(operate-on-system \"SWANK\" \"COMPILE-OP\" :force t)"  Should return T on successfull compilation, NIL otherwise.
378    (unless (member :asdf *features*)  ")
379      (error "ASDF is not loaded."))  
380    (with-compilation-hooks ()  (definterface swank-compile-file (pathname load-p external-format)
381      (let ((operate (find-symbol "OPERATE" :asdf))     "Compile PATHNAME signalling COMPILE-CONDITIONs.
382            (operation (find-symbol operation-name :asdf)))  If LOAD-P is true, load the file after compilation.
383        (when (null operation)  EXTERNAL-FORMAT is a value returned by find-external-format or
384          (error "Couldn't find ASDF operation ~S" operation-name))  :default.
385        (apply operate operation system-name keyword-args))))  
386    Should return T on successfull compilation, NIL otherwise.")
 (definterface swank-compile-file (filename load-p &optional external-format)  
    "Compile FILENAME signalling COMPILE-CONDITIONs.  
 If LOAD-P is true, load the file after compilation.")  
387    
388  (deftype severity ()  (deftype severity ()
389    '(member :error :read-error :warning :style-warning :note))    '(member :error :read-error :warning :style-warning :note))
# Line 353  If LOAD-P is true, load the file after c Line 415  If LOAD-P is true, load the file after c
415     (location :initarg :location     (location :initarg :location
416               :accessor location)))               :accessor location)))
417    
418    (definterface parse-emacs-filename (filename)
419      "Return a PATHNAME for FILENAME. A filename in Emacs may for example
420    contain asterisks which should not be translated to wildcards."
421      (parse-namestring filename))
422    
423    (definterface find-external-format (coding-system)
424      "Return a \"external file format designator\" for CODING-SYSTEM.
425    CODING-SYSTEM is Emacs-style coding system name (a string),
426    e.g. \"latin-1-unix\"."
427      (if (equal coding-system "iso-latin-1-unix")
428          :default
429          nil))
430    
431    (definterface guess-external-format (pathname)
432      "Detect the external format for the file with name pathname.
433    Return nil if the file contains no special markers."
434      ;; Look for a Emacs-style -*- coding: ... -*- or Local Variable: section.
435      (with-open-file (s pathname :if-does-not-exist nil
436                         :external-format (or (find-external-format "latin-1-unix")
437                                              :default))
438        (if s
439            (or (let* ((line (read-line s nil))
440                       (p (search "-*-" line)))
441                  (when p
442                    (let* ((start (+ p (length "-*-")))
443                           (end (search "-*-" line :start2 start)))
444                      (when end
445                        (%search-coding line start end)))))
446                (let* ((len (file-length s))
447                       (buf (make-string (min len 3000))))
448                  (file-position s (- len (length buf)))
449                  (read-sequence buf s)
450                  (let ((start (search "Local Variables:" buf :from-end t))
451                        (end (search "End:" buf :from-end t)))
452                    (and start end (< start end)
453                         (%search-coding buf start end))))))))
454    
455    (defun %search-coding (str start end)
456      (let ((p (search "coding:" str :start2 start :end2 end)))
457        (when p
458          (incf p (length "coding:"))
459          (loop while (and (< p end)
460                           (member (aref str p) '(#\space #\tab)))
461                do (incf p))
462          (let ((end (position-if (lambda (c) (find c '(#\space #\tab #\newline)))
463                                  str :start p)))
464            (find-external-format (subseq str p end))))))
465    
466    
467  ;;;; Streams  ;;;; Streams
468    
469  (definterface make-fn-streams (input-fn output-fn)  (definterface make-output-stream (write-string)
470     "Return character input and output streams backended by functions.    "Return a new character output stream.
471  When input is needed, INPUT-FN is called with no arguments to  The stream calls WRITE-STRING when output is ready.")
472  return a string.  
473  When output is ready, OUTPUT-FN is called with the output as its  (definterface make-input-stream (read-string)
474  argument.    "Return a new character input stream.
475    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)  
476    
477    
478  ;;;; Documentation  ;;;; Documentation
# Line 383  like." Line 481  like."
481     "Return the lambda list for the symbol NAME. NAME can also be     "Return the lambda list for the symbol NAME. NAME can also be
482  a lisp function object, on lisps which support this.  a lisp function object, on lisps which support this.
483    
484  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
485  cannot be determined."  arglist cannot be determined."
486     (declare (ignore name))     (declare (ignore name))
487     :not-available)     :not-available)
488    
489    (defgeneric declaration-arglist (decl-identifier)
490      (:documentation
491       "Return the argument list of the declaration specifier belonging to the
492    declaration identifier DECL-IDENTIFIER. If the arglist cannot be determined,
493    the keyword :NOT-AVAILABLE is returned.
494    
495    The different SWANK backends can specialize this generic function to
496    include implementation-dependend declaration specifiers, or to provide
497    additional information on the specifiers defined in ANSI Common Lisp.")
498      (:method (decl-identifier)
499        (case decl-identifier
500          (dynamic-extent '(&rest vars))
501          (ignore         '(&rest vars))
502          (ignorable      '(&rest vars))
503          (special        '(&rest vars))
504          (inline         '(&rest function-names))
505          (notinline      '(&rest function-name))
506          (optimize       '(&any compilation-speed debug safety space speed))
507          (type           '(type-specifier &rest args))
508          (ftype          '(type-specifier &rest function-names))
509          (otherwise
510           (flet ((typespec-p (symbol) (member :type (describe-symbol-for-emacs symbol))))
511             (cond ((and (symbolp decl-identifier) (typespec-p decl-identifier))
512                    '(&rest vars))
513                   ((and (listp decl-identifier) (typespec-p (first decl-identifier)))
514                    '(&rest vars))
515                   (t :not-available)))))))
516    
517    (defgeneric type-specifier-arglist (typespec-operator)
518      (:documentation
519       "Return the argument list of the type specifier belonging to
520    TYPESPEC-OPERATOR.. If the arglist cannot be determined, the keyword
521    :NOT-AVAILABLE is returned.
522    
523    The different SWANK backends can specialize this generic function to
524    include implementation-dependend declaration specifiers, or to provide
525    additional information on the specifiers defined in ANSI Common Lisp.")
526      (:method (typespec-operator)
527        (declare (special *type-specifier-arglists*)) ; defined at end of file.
528        (typecase typespec-operator
529          (symbol (or (cdr (assoc typespec-operator *type-specifier-arglists*))
530                      :not-available))
531          (t :not-available))))
532    
533  (definterface function-name (function)  (definterface function-name (function)
534    "Return the name of the function object FUNCTION.    "Return the name of the function object FUNCTION.
535    
# Line 492  debug the debugger! Instead, such condit Line 634  debug the debugger! Instead, such condit
634  user without (re)entering the debugger by wrapping them as  user without (re)entering the debugger by wrapping them as
635  `sldb-condition's."))  `sldb-condition's."))
636    
637    (definterface compute-sane-restarts (condition)
638      "This is an opportunity for Lisps such as CLISP to remove
639    unwanted restarts from the output of CL:COMPUTE-RESTARTS,
640    otherwise it should simply call CL:COMPUTE-RESTARTS, which is
641    what the default implementation does."
642      (compute-restarts condition))
643    
644    ;;; The following functions in this section are supposed to be called
645    ;;; within the dynamic contour of CALL-WITH-DEBUGGING-ENVIRONMENT only.
646    
647    (defstruct (swank-frame (:conc-name swank-frame.))
648      %frame
649      restartable)
650    
651  (definterface compute-backtrace (start end)  (definterface compute-backtrace (start end)
652     "Return a list containing a backtrace of the condition current     "Returns a backtrace of the condition currently being debugged,
653  being debugged.  The results are unspecified if this function is  that is an ordered list consisting of swank-frames. ``Ordered list''
654  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
655    backtrace.
656    
657  START and END are zero-based indices constraining the number of frames  START and END are zero-based indices constraining the number of frames
658  returned.  Frame zero is defined as the frame which invoked the  returned. Frame zero is defined as the frame which invoked the
659  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
660  the stack.")  the stack.")
661    
662  (definterface print-frame (frame stream)  (definterface print-swank-frame (frame stream)
663    "Print frame to stream.")    "Print frame to stream.")
664    
665  (definterface frame-source-location-for-emacs (frame-number)  (definterface frame-source-location-for-emacs (frame-number)
666    "Return the source location for FRAME-NUMBER.")    "Return the source location for the frame associated to FRAME-NUMBER.")
667    
668  (definterface frame-catch-tags (frame-number)  (definterface frame-catch-tags (frame-number)
669    "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
670  stack frame.  The results are undefined unless this is called  frame.")
 within the dynamic contour of a function defined by  
 DEFINE-DEBUGGER-HOOK.")  
671    
672  (definterface frame-locals (frame-number)  (definterface frame-locals (frame-number)
673    "Return a list of XXX local variable designators define me    "Return a list of ((&key NAME ID VALUE) ...) where each element of
674  for a debugger stack frame.  The results are undefined unless  the list represents a local variable in the stack frame associated to
675  this is called within the dynamic contour of a function defined  FRAME-NUMBER.
676  by DEFINE-DEBUGGER-HOOK.")  
677    NAME, a symbol; the name of the local variable.
678  (definterface frame-var-value (frame var)  
679    "Return the value of VAR in FRAME.  ID, an integer; used as primary key for the local variable, unique
680  FRAME is the number of the frame in the backtrace.  relatively to the frame under operation.
681  VAR is the number of the variable in the frame.")  
682    value, an object; the value of the local variable.")
683    
684    (definterface frame-var-value (frame-number var-id)
685      "Return the value of the local variable associated to VAR-ID
686    relatively to the frame associated to FRAME-NUMBER.")
687    
688  (definterface disassemble-frame (frame-number)  (definterface disassemble-frame (frame-number)
689    "Disassemble the code for the FRAME-NUMBER.    "Disassemble the code for the FRAME-NUMBER.
# Line 532  FRAME-NUMBER is a non-negative integer." Line 692  FRAME-NUMBER is a non-negative integer."
692    
693  (definterface eval-in-frame (form frame-number)  (definterface eval-in-frame (form frame-number)
694     "Evaluate a Lisp form in the lexical context of a stack frame     "Evaluate a Lisp form in the lexical context of a stack frame
695  in the debugger.  The results are undefined unless called in the  in the debugger.
 dynamic contour of a function defined by DEFINE-DEBUGGER-HOOK.  
696    
697  FRAME-NUMBER must be a positive integer with 0 indicating the  FRAME-NUMBER must be a positive integer with 0 indicating the
698  frame which invoked the debugger.  frame which invoked the debugger.
# Line 559  as it was called originally.") Line 718  as it was called originally.")
718    "Format a condition for display in SLDB."    "Format a condition for display in SLDB."
719    (princ-to-string condition))    (princ-to-string condition))
720    
 (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))  
   '())  
   
721  (definterface condition-extras (condition)  (definterface condition-extras (condition)
722    "Return a list of extra for the debugger.    "Return a list of extra for the debugger.
723  The allowed elements are of the form:  The allowed elements are of the form:
724    (:SHOW-FRAME-SOURCE frame-number)"    (:SHOW-FRAME-SOURCE frame-number)
725      (:REFERENCES &rest refs)
726    "
727    (declare (ignore condition))    (declare (ignore condition))
728    '())    '())
729    
# Line 585  The allowed elements are of the form: Line 736  The allowed elements are of the form:
736  (definterface sldb-break-at-start (symbol)  (definterface sldb-break-at-start (symbol)
737    "Set a breakpoint on the beginning of the function for SYMBOL.")    "Set a breakpoint on the beginning of the function for SYMBOL.")
738    
739    (definterface sldb-stepper-condition-p (condition)
740      "Return true if SLDB was invoked due to a single-stepping condition,
741    false otherwise. "
742      (declare (ignore condition))
743      nil)
744    
745    (definterface sldb-step-into ()
746      "Step into the current single-stepper form.")
747    
748    (definterface sldb-step-next ()
749      "Step to the next form in the current function.")
750    
751    (definterface sldb-step-out ()
752      "Stop single-stepping temporarily, but resume it once the current function
753    returns.")
754    
755    
756  ;;;; Definition finding  ;;;; Definition finding
# Line 615  definition, e.g., FOO or (METHOD FOO (ST Line 781  definition, e.g., FOO or (METHOD FOO (ST
781    
782  LOCATION is the source location for the definition.")  LOCATION is the source location for the definition.")
783    
784    (definterface find-source-location (object)
785      "Returns the source location of OBJECT, or NIL.
786    
787    That is the source location of the underlying datastructure of
788    OBJECT. E.g. on a STANDARD-OBJECT, the source location of the
789    respective DEFCLASS definition is returned, on a STRUCTURE-CLASS the
790    respective DEFSTRUCT definition, and so on."
791      ;; This returns one source location and not a list of locations. It's
792      ;; supposed to return the location of the DEFGENERIC definition on
793      ;; #'SOME-GENERIC-FUNCTION.
794      )
795    
796    
797  (definterface buffer-first-change (filename)  (definterface buffer-first-change (filename)
798    "Called for effect the first time FILENAME's buffer is modified."    "Called for effect the first time FILENAME's buffer is modified."
799    (declare (ignore filename))    (declare (ignore filename))
800    nil)    nil)
801    
802    
803    
804  ;;;; XREF  ;;;; XREF
805    
# Line 706  themselves, that is, their dispatch func Line 886  themselves, that is, their dispatch func
886    
887  ;;;; Inspector  ;;;; Inspector
888    
889  (defclass inspector ()  (defgeneric emacs-inspect (object)
890    ()    (: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)  
891     "Explain to Emacs how to inspect OBJECT.     "Explain to Emacs how to inspect OBJECT.
892    
893  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.  
894    
895  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
896  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 901  inserted into the buffer as is, or a lis
901    
902   (:newline) - Render a \\n   (:newline) - Render a \\n
903    
904   (:action label lambda) - Render LABEL (a text string) which when   (:action label lambda &key (refresh t)) - Render LABEL (a text
905   clicked will call LAMBDA.   string) which when clicked will call LAMBDA. If REFRESH is
906     non-NIL the currently inspected object will be re-inspected
907   NIL - do nothing.")   after calling the lambda.
908    "))
909    
910  (defmethod inspect-for-emacs ((object t) (inspector t))  (defmethod emacs-inspect ((object t))
911    "Generic method for inspecting any kind of object.    "Generic method for inspecting any kind of object.
912    
913  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
914  output of CL:DESCRIBE."  output of CL:DESCRIBE."
   (declare (ignore inspector))  
   (values  
    "A value."  
915     `("Type: " (:value ,(type-of object)) (:newline)     `("Type: " (:value ,(type-of object)) (:newline)
916       "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:"
917       (:newline) (:newline)       (:newline) (:newline)
918       ,(with-output-to-string (desc) (describe object desc)))))       ,(with-output-to-string (desc) (describe object desc))))
919    
920  ;;; Utilities for inspector methods.  ;;; Utilities for inspector methods.
921  ;;;  ;;;
922  (defun label-value-line (label value)  (defun label-value-line (label value &key (newline t))
923    "Create a control list which prints \"LABEL: VALUE\" in the inspector."    "Create a control list which prints \"LABEL: VALUE\" in the inspector.
924    (list (princ-to-string label) ": " `(:value ,value) '(:newline)))  If NEWLINE is non-NIL a `(:newline)' is added to the result."
925      (list* (princ-to-string label) ": " `(:value ,value)
926             (if newline '((:newline)) nil)))
927    
928  (defmacro label-value-line* (&rest label-values)  (defmacro label-value-line* (&rest label-values)
929    ` (append ,@(loop for (label value) in label-values    ` (append ,@(loop for (label value) in label-values
# Line 778  output of CL:DESCRIBE." Line 940  output of CL:DESCRIBE."
940  ;;; The default implementations are sufficient for non-multiprocessing  ;;; The default implementations are sufficient for non-multiprocessing
941  ;;; implementations.  ;;; implementations.
942    
943  (definterface initialize-multiprocessing ()  (definterface initialize-multiprocessing (continuation)
944     "Initialize multiprocessing, if necessary."     "Initialize multiprocessing, if necessary and then invoke CONTINUATION.
    nil)  
945    
946  (definterface startup-idle-and-top-level-loops ()  Depending on the impleimentaion, this function may never return."
947    "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)  
948    
949  (definterface spawn (fn &key name)  (definterface spawn (fn &key name)
950    "Create a new thread to call FN.")    "Create a new thread to call FN.")
# Line 796  normal function." Line 953  normal function."
953    "Return an Emacs-parsable object to identify THREAD.    "Return an Emacs-parsable object to identify THREAD.
954    
955  Ids should be comparable with equal, i.e.:  Ids should be comparable with equal, i.e.:
956   (equal (thread-id <t1>) (thread-id <t2>)) <==> (eq <t1> <t2>)")   (equal (thread-id <t1>) (thread-id <t2>)) <==> (eq <t1> <t2>)"
957      thread)
958    
959  (definterface find-thread (id)  (definterface find-thread (id)
960    "Return the thread for ID.    "Return the thread for ID.
961  ID should be an id previously obtained with THREAD-ID.  ID should be an id previously obtained with THREAD-ID.
962  Can return nil if the thread no longer exists.")  Can return nil if the thread no longer exists."
963      (current-thread))
964    
965  (definterface thread-name (thread)  (definterface thread-name (thread)
966     "Return the name of THREAD.     "Return the name of THREAD.
# Line 816  user. They do not have to be unique." Line 975  user. They do not have to be unique."
975     (declare (ignore thread))     (declare (ignore thread))
976     "")     "")
977    
978    (definterface thread-description (thread)
979      "Return a string describing THREAD."
980      (declare (ignore thread))
981      "")
982    
983    (definterface set-thread-description (thread description)
984      "Set THREAD's description to DESCRIPTION."
985      (declare (ignore thread description))
986      "")
987    
988  (definterface make-lock (&key name)  (definterface make-lock (&key name)
989     "Make a lock for thread synchronization.     "Make a lock for thread synchronization.
990  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
991    but that thread may hold it more than once."
992     (declare (ignore name))     (declare (ignore name))
993     :null-lock)     :null-lock)
994    
# Line 833  Only one thread may hold the lock (via C Line 1003  Only one thread may hold the lock (via C
1003    0)    0)
1004    
1005  (definterface all-threads ()  (definterface all-threads ()
1006    "Return a list of all threads.")    "Return a fresh list of all threads.")
1007    
1008  (definterface thread-alive-p (thread)  (definterface thread-alive-p (thread)
1009    "Test if THREAD is termintated."    "Test if THREAD is termintated."
# Line 850  Only one thread may hold the lock (via C Line 1020  Only one thread may hold the lock (via C
1020  (definterface send (thread object)  (definterface send (thread object)
1021    "Send OBJECT to thread THREAD.")    "Send OBJECT to thread THREAD.")
1022    
1023  (definterface receive ()  (definterface receive (&optional timeout)
1024    "Return the next message from current thread's mailbox.")    "Return the next message from current thread's mailbox."
1025      (receive-if (constantly t) timeout))
1026    
1027    (definterface receive-if (predicate &optional timeout)
1028      "Return the first message satisfiying PREDICATE.")
1029    
1030    (defvar *pending-slime-interrupts* '())
1031    
1032    (defun check-slime-interrupts ()
1033      "Execute pending interrupts if any.
1034    This should be called periodically in operations which
1035    can take a long time to complete."
1036      (when (and *pending-slime-interrupts*)
1037        (funcall (pop *pending-slime-interrupts*))))
1038    
1039    (definterface wait-for-input (streams &optional timeout)
1040      "Wait for input on a list of streams.  Return those that are ready.
1041    STREAMS is a list of streams
1042    TIMEOUT nil, t, or real number. If TIMEOUT is t, return
1043    those streams which are ready immediately, without waiting.
1044    If TIMEOUT is a number and no streams is ready after TIMEOUT seconds,
1045    return nil.
1046    
1047    Return :interrupt if an interrupt occurs while waiting."
1048      (assert (= (length streams) 1))
1049      (let ((stream (car streams)))
1050        (case timeout
1051          ((nil)
1052           (cond (*pending-slime-interrupts* :interrupt)
1053                 (t (peek-char nil stream nil nil)
1054                    streams)))
1055          ((t)
1056           (let ((c (read-char-no-hang stream nil nil)))
1057             (cond (c
1058                    (unread-char c stream)
1059                    streams)
1060                   (t '()))))
1061          (t
1062           (loop
1063            (if *pending-slime-interrupts* (return :interrupt))
1064            (when (wait-for-input streams t) (return streams))
1065            (sleep 0.1)
1066            (when (<= (decf timeout 0.1) 0) (return nil)))))))
1067    
1068  (definterface toggle-trace (spec)  (definterface toggle-trace (spec)
1069    "Toggle tracing of the function(s) given with SPEC.    "Toggle tracing of the function(s) given with SPEC.
# Line 873  SPEC can be: Line 1085  SPEC can be:
1085  (definterface make-weak-value-hash-table (&rest args)  (definterface make-weak-value-hash-table (&rest args)
1086    "Like MAKE-HASH-TABLE, but weak w.r.t. the values."    "Like MAKE-HASH-TABLE, but weak w.r.t. the values."
1087    (apply #'make-hash-table args))    (apply #'make-hash-table args))
1088    
1089    (definterface hash-table-weakness (hashtable)
1090      "Return nil or one of :key :value :key-or-value :key-and-value"
1091      (declare (ignore hashtable))
1092      nil)
1093    
1094    
1095    ;;;; Character names
1096    
1097    (definterface character-completion-set (prefix matchp)
1098      "Return a list of names of characters that match PREFIX."
1099      ;; Handle the standard and semi-standard characters.
1100      (loop for name in '("Newline" "Space" "Tab" "Page" "Rubout"
1101                          "Linefeed" "Return" "Backspace")
1102         when (funcall matchp prefix name)
1103         collect name))
1104    
1105    
1106    (defparameter *type-specifier-arglists*
1107      '((and                . (&rest type-specifiers))
1108        (array              . (&optional element-type dimension-spec))
1109        (base-string        . (&optional size))
1110        (bit-vector         . (&optional size))
1111        (complex            . (&optional type-specifier))
1112        (cons               . (&optional car-typespec cdr-typespec))
1113        (double-float       . (&optional lower-limit upper-limit))
1114        (eql                . (object))
1115        (float              . (&optional lower-limit upper-limit))
1116        (function           . (&optional arg-typespec value-typespec))
1117        (integer            . (&optional lower-limit upper-limit))
1118        (long-float         . (&optional lower-limit upper-limit))
1119        (member             . (&rest eql-objects))
1120        (mod                . (n))
1121        (not                . (type-specifier))
1122        (or                 . (&rest type-specifiers))
1123        (rational           . (&optional lower-limit upper-limit))
1124        (real               . (&optional lower-limit upper-limit))
1125        (satisfies          . (predicate-symbol))
1126        (short-float        . (&optional lower-limit upper-limit))
1127        (signed-byte        . (&optional size))
1128        (simple-array       . (&optional element-type dimension-spec))
1129        (simple-base-string . (&optional size))
1130        (simple-bit-vector  . (&optional size))
1131        (simple-string      . (&optional size))
1132        (single-float       . (&optional lower-limit upper-limit))
1133        (simple-vector      . (&optional size))
1134        (string             . (&optional size))
1135        (unsigned-byte      . (&optional size))
1136        (values             . (&rest typespecs))
1137        (vector             . (&optional element-type size))
1138        ))
1139    
1140    ;;; Heap dumps
1141    
1142    (definterface save-image (filename &optional restart-function)
1143      "Save a heap image to the file FILENAME.
1144    RESTART-FUNCTION, if non-nil, should be called when the image is loaded.")
1145    
1146    
1147    

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

  ViewVC Help
Powered by ViewVC 1.1.5