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

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

  ViewVC Help
Powered by ViewVC 1.1.5