/[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.137 by heller, Tue Aug 5 17:38:39 2008 UTC
# Line 19  Line 19 
19             #:short-message             #:short-message
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             ;; inspector related symbols             ;; inspector related symbols
36             #:inspector             #:emacs-inspect
            #:inspect-for-emacs  
            #:raw-inspection  
            #:fancy-inspection  
37             #:label-value-line             #:label-value-line
38             #:label-value-line*             #:label-value-line*
39    
40               #:with-struct
41             ))             ))
42    
43  (defpackage :swank-mop  (defpackage :swank-mop
# Line 84  Line 86 
86     #:slot-definition-type     #:slot-definition-type
87     #:slot-definition-readers     #:slot-definition-readers
88     #:slot-definition-writers     #:slot-definition-writers
89       #:slot-boundp-using-class
90       #:slot-value-using-class
91       #:slot-makunbound-using-class
92     ;; generic function protocol     ;; generic function protocol
93     #:compute-applicable-methods-using-classes     #:compute-applicable-methods-using-classes
94     #:finalize-inheritance))     #:finalize-inheritance))
# Line 102  DEFINTERFACE adds to this list and DEFIM Line 107  DEFINTERFACE adds to this list and DEFIM
107    
108  (defmacro definterface (name args documentation &rest default-body)  (defmacro definterface (name args documentation &rest default-body)
109    "Define an interface function for the backend to implement.    "Define an interface function for the backend to implement.
110  A generic function is defined with NAME, ARGS, and DOCUMENTATION.  A function is defined with NAME, ARGS, and DOCUMENTATION.  This
111    function first looks for a function to call in NAME's property list
112  If a DEFAULT-BODY is supplied then NO-APPLICABLE-METHOD is specialized  that is indicated by 'IMPLEMENTATION; failing that, it looks for a
113  to execute the body if the backend doesn't provide a specific  function indicated by 'DEFAULT. If neither is present, an error is
114  implementation.  signaled.
115    
116    If a DEFAULT-BODY is supplied, then a function with the same body and
117    ARGS will be added to NAME's property list as the property indicated
118    by 'DEFAULT.
119    
120  Backends implement these functions using DEFIMPLEMENTATION."  Backends implement these functions using DEFIMPLEMENTATION."
121    (check-type documentation string "a documentation string")    (check-type documentation string "a documentation string")
122    (flet ((gen-default-impl ()    (assert (every #'symbolp args) ()
123             `(defmethod ,name ,args ,@default-body)))            "Complex lambda-list not supported: ~S ~S" name args)
124      `(progn (defgeneric ,name ,args (:documentation ,documentation))    (labels ((gen-default-impl ()
125              (pushnew ',name *interface-functions*)               `(setf (get ',name 'default) (lambda ,args ,@default-body)))
126              ,(if (null default-body)             (args-as-list (args)
127                   `(pushnew ',name *unimplemented-interfaces*)               (destructuring-bind (req opt key rest) (parse-lambda-list args)
128                   (gen-default-impl))                 `(,@req ,@opt
129              ;; 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))
130              (eval-when (:compile-toplevel :load-toplevel :execute)                         ,@(or rest '(())))))
131                (export ',name :swank-backend))             (parse-lambda-list (args)
132              ',name)))               (parse args '(&optional &key &rest)
133                        (make-array 4 :initial-element nil)))
134               (parse (args keywords vars)
135                 (cond ((null args)
136                        (reverse (map 'list #'reverse vars)))
137                       ((member (car args) keywords)
138                        (parse (cdr args) (cdr (member (car args) keywords)) vars))
139                       (t (push (car args) (aref vars (length keywords)))
140                          (parse (cdr args) keywords vars))))
141               (kw (s) (intern (string s) :keyword)))
142        `(progn
143           (defun ,name ,args
144             ,documentation
145             (let ((f (or (get ',name 'implementation)
146                          (get ',name 'default))))
147               (cond (f (apply f ,@(args-as-list args)))
148                     (t (error "~S not implementated" ',name)))))
149           (pushnew ',name *interface-functions*)
150           ,(if (null default-body)
151                `(pushnew ',name *unimplemented-interfaces*)
152                (gen-default-impl))
153           ;; see <http://www.franz.com/support/documentation/6.2/doc/pages/variables/compiler/s_cltl1-compile-file-toplevel-compatibility-p_s.htm>
154           (eval-when (:compile-toplevel :load-toplevel :execute)
155             (export ',name :swank-backend))
156           ',name)))
157    
158  (defmacro defimplementation (name args &body body)  (defmacro defimplementation (name args &body body)
159    `(progn (defmethod ,name ,args ,@body)    (assert (every #'symbolp args) ()
160            (if (member ',name *interface-functions*)            "Complex lambda-list not supported: ~S ~S" name args)
161                (setq *unimplemented-interfaces*    `(progn
162                      (remove ',name *unimplemented-interfaces*))       (setf (get ',name 'implementation) (lambda ,args ,@body))
163                (warn "DEFIMPLEMENTATION of undefined interface (~S)" ',name))       (if (member ',name *interface-functions*)
164            ',name))           (setq *unimplemented-interfaces*
165                   (remove ',name *unimplemented-interfaces*))
166             (warn "DEFIMPLEMENTATION of undefined interface (~S)" ',name))
167         ',name))
168    
169  (defun warn-unimplemented-interfaces ()  (defun warn-unimplemented-interfaces ()
170    "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 194  EXCEPT is a list of symbol names which s
194  (defvar *gray-stream-symbols*  (defvar *gray-stream-symbols*
195    '(:fundamental-character-output-stream    '(:fundamental-character-output-stream
196      :stream-write-char      :stream-write-char
197        :stream-write-string
198      :stream-fresh-line      :stream-fresh-line
199      :stream-force-output      :stream-force-output
200      :stream-finish-output      :stream-finish-output
# Line 212  EXCEPT is a list of symbol names which s Line 249  EXCEPT is a list of symbol names which s
249    "Close the socket SOCKET.")    "Close the socket SOCKET.")
250    
251  (definterface accept-connection (socket &key external-format  (definterface accept-connection (socket &key external-format
252                                          buffering)                                          buffering timeout)
253     "Accept a client connection on the listening socket SOCKET.     "Accept a client connection on the listening socket SOCKET.
254  Return a stream for the new connection.")  Return a stream for the new connection.")
255    
# Line 232  Return a stream for the new connection." Line 269  Return a stream for the new connection."
269    "Return one of the symbols :spawn, :sigio, :fd-handler, or NIL."    "Return one of the symbols :spawn, :sigio, :fd-handler, or NIL."
270    nil)    nil)
271    
272    (definterface set-stream-timeout (stream timeout)
273      "Set the 'stream 'timeout.  The timeout is either the real number
274      specifying the timeout in seconds or 'nil for no timeout."
275      (declare (ignore stream timeout))
276      nil)
277    
278  ;;; Base condition for networking errors.  ;;; Base condition for networking errors.
279  (define-condition network-error (simple-error) ())  (define-condition network-error (simple-error) ())
280    
# Line 292  This is used to resolve filenames withou Line 335  This is used to resolve filenames withou
335    (declare (ignore ignore))    (declare (ignore ignore))
336    `(call-with-compilation-hooks (lambda () (progn ,@body))))    `(call-with-compilation-hooks (lambda () (progn ,@body))))
337    
338  (definterface swank-compile-string (string &key buffer position directory)  (definterface swank-compile-string (string &key buffer position directory debug)
339    "Compile source from STRING.  During compilation, compiler    "Compile source from STRING.  During compilation, compiler
340  conditions must be trapped and resignalled as COMPILER-CONDITIONs.  conditions must be trapped and resignalled as COMPILER-CONDITIONs.
341    
# Line 303  positions reported in compiler condition Line 346  positions reported in compiler condition
346    
347  If DIRECTORY is specified it may be used by certain implementations to  If DIRECTORY is specified it may be used by certain implementations to
348  rebind *DEFAULT-PATHNAME-DEFAULTS* which may improve the recording of  rebind *DEFAULT-PATHNAME-DEFAULTS* which may improve the recording of
349  source information.")  source information.
350    
351  (definterface operate-on-system (system-name operation-name &rest keyword-args)  If DEBUG is supplied, and non-NIL, it may be used by certain
352    "Perform OPERATION-NAME on SYSTEM-NAME using ASDF.  implementations to compile with a debug optimization quality of its
353  The KEYWORD-ARGS are passed on to the operation.  value.
354  Example:  
355  \(operate-on-system \"SWANK\" \"COMPILE-OP\" :force t)"  Should return T on successfull compilation, NIL otherwise.
356    (unless (member :asdf *features*)  ")
     (error "ASDF is not loaded."))  
   (with-compilation-hooks ()  
     (let ((operate (find-symbol "OPERATE" :asdf))  
           (operation (find-symbol operation-name :asdf)))  
       (when (null operation)  
         (error "Couldn't find ASDF operation ~S" operation-name))  
       (apply operate operation system-name keyword-args))))  
357    
358  (definterface swank-compile-file (filename load-p &optional external-format)  (definterface swank-compile-file (filename load-p external-format)
359     "Compile FILENAME signalling COMPILE-CONDITIONs.     "Compile FILENAME signalling COMPILE-CONDITIONs.
360  If LOAD-P is true, load the file after compilation.")  If LOAD-P is true, load the file after compilation.
361    EXTERNAL-FORMAT is a value returned by find-external-format or
362    :default.
363    
364    Should return T on successfull compilation, NIL otherwise.")
365    
366  (deftype severity ()  (deftype severity ()
367    '(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 393  If LOAD-P is true, load the file after c
393     (location :initarg :location     (location :initarg :location
394               :accessor location)))               :accessor location)))
395    
396    (definterface find-external-format (coding-system)
397      "Return a \"external file format designator\" for CODING-SYSTEM.
398    CODING-SYSTEM is Emacs-style coding system name (a string),
399    e.g. \"latin-1-unix\"."
400      (if (equal coding-system "iso-latin-1-unix")
401          :default
402          nil))
403    
404    (definterface guess-external-format (filename)
405      "Detect the external format for the file with name FILENAME.
406    Return nil if the file contains no special markers."
407      ;; Look for a Emacs-style -*- coding: ... -*- or Local Variable: section.
408      (with-open-file (s filename :if-does-not-exist nil
409                         :external-format (or (find-external-format "latin-1-unix")
410                                              :default))
411        (if s
412            (or (let* ((line (read-line s nil))
413                       (p (search "-*-" line)))
414                  (when p
415                    (let* ((start (+ p (length "-*-")))
416                           (end (search "-*-" line :start2 start)))
417                      (when end
418                        (%search-coding line start end)))))
419                (let* ((len (file-length s))
420                       (buf (make-string (min len 3000))))
421                  (file-position s (- len (length buf)))
422                  (read-sequence buf s)
423                  (let ((start (search "Local Variables:" buf :from-end t))
424                        (end (search "End:" buf :from-end t)))
425                    (and start end (< start end)
426                         (%search-coding buf start end))))))))
427    
428    (defun %search-coding (str start end)
429      (let ((p (search "coding:" str :start2 start :end2 end)))
430        (when p
431          (incf p (length "coding:"))
432          (loop while (and (< p end)
433                           (member (aref str p) '(#\space #\tab)))
434                do (incf p))
435          (let ((end (position-if (lambda (c) (find c '(#\space #\tab #\newline)))
436                                  str :start p)))
437            (find-external-format (subseq str p end))))))
438    
439    
440  ;;;; Streams  ;;;; Streams
441    
# Line 383  like." Line 466  like."
466     "Return the lambda list for the symbol NAME. NAME can also be     "Return the lambda list for the symbol NAME. NAME can also be
467  a lisp function object, on lisps which support this.  a lisp function object, on lisps which support this.
468    
469  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
470  cannot be determined."  arglist cannot be determined."
471     (declare (ignore name))     (declare (ignore name))
472     :not-available)     :not-available)
473    
474    (defgeneric declaration-arglist (decl-identifier)
475      (:documentation
476       "Return the argument list of the declaration specifier belonging to the
477    declaration identifier DECL-IDENTIFIER. If the arglist cannot be determined,
478    the keyword :NOT-AVAILABLE is returned.
479    
480    The different SWANK backends can specialize this generic function to
481    include implementation-dependend declaration specifiers, or to provide
482    additional information on the specifiers defined in ANSI Common Lisp.")
483      (:method (decl-identifier)
484        (case decl-identifier
485          (dynamic-extent '(&rest vars))
486          (ignore         '(&rest vars))
487          (ignorable      '(&rest vars))
488          (special        '(&rest vars))
489          (inline         '(&rest function-names))
490          (notinline      '(&rest function-name))
491          (optimize       '(&any compilation-speed debug safety space speed))
492          (type           '(type-specifier &rest args))
493          (ftype          '(type-specifier &rest function-names))
494          (otherwise
495           (flet ((typespec-p (symbol) (member :type (describe-symbol-for-emacs symbol))))
496             (cond ((and (symbolp decl-identifier) (typespec-p decl-identifier))
497                    '(&rest vars))
498                   ((and (listp decl-identifier) (typespec-p (first decl-identifier)))
499                    '(&rest vars))
500                   (t :not-available)))))))
501    
502    (defgeneric type-specifier-arglist (typespec-operator)
503      (:documentation
504       "Return the argument list of the type specifier belonging to
505    TYPESPEC-OPERATOR.. If the arglist cannot be determined, the keyword
506    :NOT-AVAILABLE is returned.
507    
508    The different SWANK backends can specialize this generic function to
509    include implementation-dependend declaration specifiers, or to provide
510    additional information on the specifiers defined in ANSI Common Lisp.")
511      (:method (typespec-operator)
512        (declare (special *type-specifier-arglists*)) ; defined at end of file.
513        (typecase typespec-operator
514          (symbol (or (cdr (assoc typespec-operator *type-specifier-arglists*))
515                      :not-available))
516          (t :not-available))))
517    
518  (definterface function-name (function)  (definterface function-name (function)
519    "Return the name of the function object FUNCTION.    "Return the name of the function object FUNCTION.
520    
# Line 492  debug the debugger! Instead, such condit Line 619  debug the debugger! Instead, such condit
619  user without (re)entering the debugger by wrapping them as  user without (re)entering the debugger by wrapping them as
620  `sldb-condition's."))  `sldb-condition's."))
621    
622    (definterface compute-sane-restarts (condition)
623      "This is an opportunity for Lisps such as CLISP to remove
624    unwanted restarts from the output of CL:COMPUTE-RESTARTS,
625    otherwise it should simply call CL:COMPUTE-RESTARTS, which is
626    what the default implementation does."
627      (compute-restarts condition))
628    
629    ;;; The following functions in this section are supposed to be called
630    ;;; within the dynamic contour of CALL-WITH-DEBUGGING-ENVIRONMENT only.
631    
632  (definterface compute-backtrace (start end)  (definterface compute-backtrace (start end)
633     "Return a list containing a backtrace of the condition current     "Returns a backtrace of the condition currently being debugged,
634  being debugged.  The results are unspecified if this function is  that is an ordered list consisting of frames. (What constitutes a
635  called outside the dynamic contour CALL-WITH-DEBUGGING-ENVIRONMENT.  frame is implementation dependent, but PRINT-FRAME must be defined on
636    it.)
637    
638    ``Ordered list'' means that the i-th. frame is associated to the
639    frame-number i.
640    
641  START and END are zero-based indices constraining the number of frames  START and END are zero-based indices constraining the number of frames
642  returned.  Frame zero is defined as the frame which invoked the  returned.  Frame zero is defined as the frame which invoked the
# Line 506  the stack.") Line 647  the stack.")
647    "Print frame to stream.")    "Print frame to stream.")
648    
649  (definterface frame-source-location-for-emacs (frame-number)  (definterface frame-source-location-for-emacs (frame-number)
650    "Return the source location for FRAME-NUMBER.")    "Return the source location for the frame associated to FRAME-NUMBER.")
651    
652  (definterface frame-catch-tags (frame-number)  (definterface frame-catch-tags (frame-number)
653    "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
654  stack frame.  The results are undefined unless this is called  frame.")
 within the dynamic contour of a function defined by  
 DEFINE-DEBUGGER-HOOK.")  
655    
656  (definterface frame-locals (frame-number)  (definterface frame-locals (frame-number)
657    "Return a list of XXX local variable designators define me    "Return a list of ((&key NAME ID VALUE) ...) where each element of
658  for a debugger stack frame.  The results are undefined unless  the list represents a local variable in the stack frame associated to
659  this is called within the dynamic contour of a function defined  FRAME-NUMBER.
660  by DEFINE-DEBUGGER-HOOK.")  
661    NAME, a symbol; the name of the local variable.
662  (definterface frame-var-value (frame var)  
663    "Return the value of VAR in FRAME.  ID, an integer; used as primary key for the local variable, unique
664  FRAME is the number of the frame in the backtrace.  relatively to the frame under operation.
665  VAR is the number of the variable in the frame.")  
666    value, an object; the value of the local variable.")
667    
668    (definterface frame-var-value (frame-number var-id)
669      "Return the value of the local variable associated to VAR-ID
670    relatively to the frame associated to FRAME-NUMBER.")
671    
672  (definterface disassemble-frame (frame-number)  (definterface disassemble-frame (frame-number)
673    "Disassemble the code for the FRAME-NUMBER.    "Disassemble the code for the FRAME-NUMBER.
# Line 532  FRAME-NUMBER is a non-negative integer." Line 676  FRAME-NUMBER is a non-negative integer."
676    
677  (definterface eval-in-frame (form frame-number)  (definterface eval-in-frame (form frame-number)
678     "Evaluate a Lisp form in the lexical context of a stack frame     "Evaluate a Lisp form in the lexical context of a stack frame
679  in the debugger.  The results are undefined unless called in the  in the debugger.
 dynamic contour of a function defined by DEFINE-DEBUGGER-HOOK.  
680    
681  FRAME-NUMBER must be a positive integer with 0 indicating the  FRAME-NUMBER must be a positive integer with 0 indicating the
682  frame which invoked the debugger.  frame which invoked the debugger.
# Line 559  as it was called originally.") Line 702  as it was called originally.")
702    "Format a condition for display in SLDB."    "Format a condition for display in SLDB."
703    (princ-to-string condition))    (princ-to-string condition))
704    
 (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))  
   '())  
   
705  (definterface condition-extras (condition)  (definterface condition-extras (condition)
706    "Return a list of extra for the debugger.    "Return a list of extra for the debugger.
707  The allowed elements are of the form:  The allowed elements are of the form:
708    (:SHOW-FRAME-SOURCE frame-number)"    (:SHOW-FRAME-SOURCE frame-number)
709      (:REFERENCES &rest refs)
710    "
711    (declare (ignore condition))    (declare (ignore condition))
712    '())    '())
713    
# Line 585  The allowed elements are of the form: Line 720  The allowed elements are of the form:
720  (definterface sldb-break-at-start (symbol)  (definterface sldb-break-at-start (symbol)
721    "Set a breakpoint on the beginning of the function for SYMBOL.")    "Set a breakpoint on the beginning of the function for SYMBOL.")
722    
723    (definterface sldb-stepper-condition-p (condition)
724      "Return true if SLDB was invoked due to a single-stepping condition,
725    false otherwise. "
726      (declare (ignore condition))
727      nil)
728    
729    (definterface sldb-step-into ()
730      "Step into the current single-stepper form.")
731    
732    (definterface sldb-step-next ()
733      "Step to the next form in the current function.")
734    
735    (definterface sldb-step-out ()
736      "Stop single-stepping temporarily, but resume it once the current function
737    returns.")
738    
739    
740  ;;;; Definition finding  ;;;; Definition finding
# Line 615  definition, e.g., FOO or (METHOD FOO (ST Line 765  definition, e.g., FOO or (METHOD FOO (ST
765    
766  LOCATION is the source location for the definition.")  LOCATION is the source location for the definition.")
767    
768    (definterface find-source-location (object)
769      "Returns the source location of OBJECT, or NIL.
770    
771    That is the source location of the underlying datastructure of
772    OBJECT. E.g. on a STANDARD-OBJECT, the source location of the
773    respective DEFCLASS definition is returned, on a STRUCTURE-CLASS the
774    respective DEFSTRUCT definition, and so on."
775      ;; This returns one source location and not a list of locations. It's
776      ;; supposed to return the location of the DEFGENERIC definition on
777      ;; #'SOME-GENERIC-FUNCTION.
778      )
779    
780    
781  (definterface buffer-first-change (filename)  (definterface buffer-first-change (filename)
782    "Called for effect the first time FILENAME's buffer is modified."    "Called for effect the first time FILENAME's buffer is modified."
783    (declare (ignore filename))    (declare (ignore filename))
784    nil)    nil)
785    
786    
787    
788  ;;;; XREF  ;;;; XREF
789    
# Line 706  themselves, that is, their dispatch func Line 870  themselves, that is, their dispatch func
870    
871  ;;;; Inspector  ;;;; Inspector
872    
873  (defclass inspector ()  (defgeneric emacs-inspect (object)
874    ()    (: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)  
875     "Explain to Emacs how to inspect OBJECT.     "Explain to Emacs how to inspect OBJECT.
876    
877  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.  
878    
879  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
880  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 885  inserted into the buffer as is, or a lis
885    
886   (:newline) - Render a \\n   (:newline) - Render a \\n
887    
888   (:action label lambda) - Render LABEL (a text string) which when   (:action label lambda &key (refresh t)) - Render LABEL (a text
889   clicked will call LAMBDA.   string) which when clicked will call LAMBDA. If REFRESH is
890     non-NIL the currently inspected object will be re-inspected
891   NIL - do nothing.")   after calling the lambda.
892    "))
893    
894  (defmethod inspect-for-emacs ((object t) (inspector t))  (defmethod emacs-inspect ((object t))
895    "Generic method for inspecting any kind of object.    "Generic method for inspecting any kind of object.
896    
897  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
898  output of CL:DESCRIBE."  output of CL:DESCRIBE."
   (declare (ignore inspector))  
   (values  
    "A value."  
899     `("Type: " (:value ,(type-of object)) (:newline)     `("Type: " (:value ,(type-of object)) (:newline)
900       "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:"
901       (:newline) (:newline)       (:newline) (:newline)
902       ,(with-output-to-string (desc) (describe object desc)))))       ,(with-output-to-string (desc) (describe object desc))))
903    
904  ;;; Utilities for inspector methods.  ;;; Utilities for inspector methods.
905  ;;;  ;;;
906  (defun label-value-line (label value)  (defun label-value-line (label value &key (newline t))
907    "Create a control list which prints \"LABEL: VALUE\" in the inspector."    "Create a control list which prints \"LABEL: VALUE\" in the inspector.
908    (list (princ-to-string label) ": " `(:value ,value) '(:newline)))  If NEWLINE is non-NIL a `(:newline)' is added to the result."
909      (list* (princ-to-string label) ": " `(:value ,value)
910             (if newline '((:newline)) nil)))
911    
912  (defmacro label-value-line* (&rest label-values)  (defmacro label-value-line* (&rest label-values)
913    ` (append ,@(loop for (label value) in label-values    ` (append ,@(loop for (label value) in label-values
# Line 778  output of CL:DESCRIBE." Line 924  output of CL:DESCRIBE."
924  ;;; The default implementations are sufficient for non-multiprocessing  ;;; The default implementations are sufficient for non-multiprocessing
925  ;;; implementations.  ;;; implementations.
926    
927  (definterface initialize-multiprocessing ()  (definterface initialize-multiprocessing (continuation)
928     "Initialize multiprocessing, if necessary."     "Initialize multiprocessing, if necessary and then invoke CONTINUATION.
    nil)  
929    
930  (definterface startup-idle-and-top-level-loops ()  Depending on the impleimentaion, this function may never return."
931    "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)  
932    
933  (definterface spawn (fn &key name)  (definterface spawn (fn &key name)
934    "Create a new thread to call FN.")    "Create a new thread to call FN.")
# Line 816  user. They do not have to be unique." Line 957  user. They do not have to be unique."
957     (declare (ignore thread))     (declare (ignore thread))
958     "")     "")
959    
960    (definterface thread-description (thread)
961      "Return a string describing THREAD."
962      (declare (ignore thread))
963      "")
964    
965    (definterface set-thread-description (thread description)
966      "Set THREAD's description to DESCRIPTION."
967      (declare (ignore thread description))
968      "")
969    
970  (definterface make-lock (&key name)  (definterface make-lock (&key name)
971     "Make a lock for thread synchronization.     "Make a lock for thread synchronization.
972  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."
# Line 828  Only one thread may hold the lock (via C Line 979  Only one thread may hold the lock (via C
979              (type function function))              (type function function))
980     (funcall function))     (funcall function))
981    
982    (definterface make-recursive-lock (&key name)
983      "Make a lock for thread synchronization.
984    Only one thread may hold the lock (via CALL-WITH-RECURSIVE-LOCK-HELD)
985    at a time, but that thread may hold it more than once."
986      (cons nil (make-lock :name name)))
987    
988    (definterface call-with-recursive-lock-held (lock function)
989      "Call FUNCTION with LOCK held, queueing if necessary."
990      (if (eql (car lock) (current-thread))
991          (funcall function)
992          (call-with-lock-held (cdr lock)
993                               (lambda ()
994                                 (unwind-protect
995                                      (progn
996                                        (setf (car lock) (current-thread))
997                                        (funcall function))
998                                   (setf (car lock) nil))))))
999    
1000  (definterface current-thread ()  (definterface current-thread ()
1001    "Return the currently executing thread."    "Return the currently executing thread."
1002    0)    0)
# Line 853  Only one thread may hold the lock (via C Line 1022  Only one thread may hold the lock (via C
1022  (definterface receive ()  (definterface receive ()
1023    "Return the next message from current thread's mailbox.")    "Return the next message from current thread's mailbox.")
1024    
1025    (definterface receive-if (predicate)
1026      "Return the first message satisfiying PREDICATE.")
1027    
1028  (definterface toggle-trace (spec)  (definterface toggle-trace (spec)
1029    "Toggle tracing of the function(s) given with SPEC.    "Toggle tracing of the function(s) given with SPEC.
1030  SPEC can be:  SPEC can be:
# Line 873  SPEC can be: Line 1045  SPEC can be:
1045  (definterface make-weak-value-hash-table (&rest args)  (definterface make-weak-value-hash-table (&rest args)
1046    "Like MAKE-HASH-TABLE, but weak w.r.t. the values."    "Like MAKE-HASH-TABLE, but weak w.r.t. the values."
1047    (apply #'make-hash-table args))    (apply #'make-hash-table args))
1048    
1049    (definterface hash-table-weakness (hashtable)
1050      "Return nil or one of :key :value :key-or-value :key-and-value"
1051      (declare (ignore hashtable))
1052      nil)
1053    
1054    
1055    ;;;; Character names
1056    
1057    (definterface character-completion-set (prefix matchp)
1058      "Return a list of names of characters that match PREFIX."
1059      ;; Handle the standard and semi-standard characters.
1060      (loop for name in '("Newline" "Space" "Tab" "Page" "Rubout"
1061                          "Linefeed" "Return" "Backspace")
1062         when (funcall matchp prefix name)
1063         collect name))
1064    
1065    
1066    (defparameter *type-specifier-arglists*
1067      '((and                . (&rest type-specifiers))
1068        (array              . (&optional element-type dimension-spec))
1069        (base-string        . (&optional size))
1070        (bit-vector         . (&optional size))
1071        (complex            . (&optional type-specifier))
1072        (cons               . (&optional car-typespec cdr-typespec))
1073        (double-float       . (&optional lower-limit upper-limit))
1074        (eql                . (object))
1075        (float              . (&optional lower-limit upper-limit))
1076        (function           . (&optional arg-typespec value-typespec))
1077        (integer            . (&optional lower-limit upper-limit))
1078        (long-float         . (&optional lower-limit upper-limit))
1079        (member             . (&rest eql-objects))
1080        (mod                . (n))
1081        (not                . (type-specifier))
1082        (or                 . (&rest type-specifiers))
1083        (rational           . (&optional lower-limit upper-limit))
1084        (real               . (&optional lower-limit upper-limit))
1085        (satisfies          . (predicate-symbol))
1086        (short-float        . (&optional lower-limit upper-limit))
1087        (signed-byte        . (&optional size))
1088        (simple-array       . (&optional element-type dimension-spec))
1089        (simple-base-string . (&optional size))
1090        (simple-bit-vector  . (&optional size))
1091        (simple-string      . (&optional size))
1092        (single-float       . (&optional lower-limit upper-limit))
1093        (simple-vector      . (&optional size))
1094        (string             . (&optional size))
1095        (unsigned-byte      . (&optional size))
1096        (values             . (&rest typespecs))
1097        (vector             . (&optional element-type size))
1098        ))

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

  ViewVC Help
Powered by ViewVC 1.1.5