/[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.118 by mbaringer, Thu Apr 19 16:36:12 2007 UTC
# Line 15  Line 15 
15    (:export #:sldb-condition    (:export #:sldb-condition
16             #:original-condition             #:original-condition
17             #:compiler-condition             #:compiler-condition
18               #:abort-request
19               #:request-abort
20             #:message             #:message
21             #:short-message             #:short-message
22             #:condition             #:condition
# Line 36  Line 38 
38             #:fancy-inspection             #:fancy-inspection
39             #:label-value-line             #:label-value-line
40             #:label-value-line*             #:label-value-line*
41               #:type-for-emacs
42               #:with-struct
43             ))             ))
44    
45  (defpackage :swank-mop  (defpackage :swank-mop
# Line 84  Line 88 
88     #:slot-definition-type     #:slot-definition-type
89     #:slot-definition-readers     #:slot-definition-readers
90     #:slot-definition-writers     #:slot-definition-writers
91       #:slot-boundp-using-class
92       #:slot-value-using-class
93       #:slot-makunbound-using-class
94     ;; generic function protocol     ;; generic function protocol
95     #:compute-applicable-methods-using-classes     #:compute-applicable-methods-using-classes
96     #:finalize-inheritance))     #:finalize-inheritance))
# Line 110  implementation. Line 117  implementation.
117    
118  Backends implement these functions using DEFIMPLEMENTATION."  Backends implement these functions using DEFIMPLEMENTATION."
119    (check-type documentation string "a documentation string")    (check-type documentation string "a documentation string")
120    (flet ((gen-default-impl ()    (assert (every #'symbolp args) ()
121             `(defmethod ,name ,args ,@default-body)))            "Complex lambda-list not supported: ~S ~S" name args)
122      `(progn (defgeneric ,name ,args (:documentation ,documentation))    (labels ((gen-default-impl ()
123              (pushnew ',name *interface-functions*)               `(setf (get ',name 'default) (lambda ,args ,@default-body)))
124              ,(if (null default-body)             (args-as-list (args)
125                   `(pushnew ',name *unimplemented-interfaces*)               (destructuring-bind (req opt key rest) (parse-lambda-list args)
126                   (gen-default-impl))                 `(,@req ,@opt
127              ;; 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))
128              (eval-when (:compile-toplevel :load-toplevel :execute)                         ,@(or rest '(())))))
129                (export ',name :swank-backend))             (parse-lambda-list (args)
130              ',name)))               (parse args '(&optional &key &rest)
131                        (make-array 4 :initial-element nil)))
132               (parse (args keywords vars)
133                 (cond ((null args)
134                        (reverse (map 'list #'reverse vars)))
135                       ((member (car args) keywords)
136                        (parse (cdr args) (cdr (member (car args) keywords)) vars))
137                       (t (push (car args) (aref vars (length keywords)))
138                          (parse (cdr args) keywords vars))))
139               (kw (s) (intern (string s) :keyword)))
140        `(progn
141           (defun ,name ,args
142             ,documentation
143             (let ((f (or (get ',name 'implementation)
144                          (get ',name 'default))))
145               (cond (f (apply f ,@(args-as-list args)))
146                     (t (error "~S not implementated" ',name)))))
147           (pushnew ',name *interface-functions*)
148           ,(if (null default-body)
149                `(pushnew ',name *unimplemented-interfaces*)
150                (gen-default-impl))
151           ;; see <http://www.franz.com/support/documentation/6.2/doc/pages/variables/compiler/s_cltl1-compile-file-toplevel-compatibility-p_s.htm>
152           (eval-when (:compile-toplevel :load-toplevel :execute)
153             (export ',name :swank-backend))
154           ',name)))
155    
156  (defmacro defimplementation (name args &body body)  (defmacro defimplementation (name args &body body)
157    `(progn (defmethod ,name ,args ,@body)    (assert (every #'symbolp args) ()
158            (if (member ',name *interface-functions*)            "Complex lambda-list not supported: ~S ~S" name args)
159                (setq *unimplemented-interfaces*    `(progn
160                      (remove ',name *unimplemented-interfaces*))       (setf (get ',name 'implementation) (lambda ,args ,@body))
161                (warn "DEFIMPLEMENTATION of undefined interface (~S)" ',name))       (if (member ',name *interface-functions*)
162            ',name))           (setq *unimplemented-interfaces*
163                   (remove ',name *unimplemented-interfaces*))
164             (warn "DEFIMPLEMENTATION of undefined interface (~S)" ',name))
165         ',name))
166    
167    (define-condition request-abort (error)
168      ((reason  :initarg :reason :reader reason))
169      (:report (lambda (condition stream)
170                 (princ (reason condition) stream)))
171      (:documentation "Condition signalled when SLIME wasn't able to
172    complete a user request due to bad data. This condition is not
173    for real errors but for situations where SLIME has to give up and
174    return control back to the user."))
175    
176    (defun abort-request (reason-control &rest reason-args)
177      "Abort whatever swank is currently do and send a message to the
178    user."
179      (error 'request-abort :reason (apply #'format nil reason-control reason-args)))
180    
181  (defun warn-unimplemented-interfaces ()  (defun warn-unimplemented-interfaces ()
182    "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 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 311  The KEYWORD-ARGS are passed on to the op Line 365  The KEYWORD-ARGS are passed on to the op
365  Example:  Example:
366  \(operate-on-system \"SWANK\" \"COMPILE-OP\" :force t)"  \(operate-on-system \"SWANK\" \"COMPILE-OP\" :force t)"
367    (unless (member :asdf *features*)    (unless (member :asdf *features*)
368      (error "ASDF is not loaded."))      (abort-request "ASDF is not loaded."))
369    (with-compilation-hooks ()    (with-compilation-hooks ()
370      (let ((operate (find-symbol "OPERATE" :asdf))      (let ((operate (find-symbol (symbol-name '#:operate) :asdf))
371            (operation (find-symbol operation-name :asdf)))            (operation (find-symbol operation-name :asdf)))
372        (when (null operation)        (when (null operation)
373          (error "Couldn't find ASDF operation ~S" operation-name))          (abort-request "Couldn't find ASDF operation ~S" operation-name))
374        (apply operate operation system-name keyword-args))))        (apply operate operation system-name keyword-args))))
375    
376  (definterface swank-compile-file (filename load-p &optional external-format)  (definterface swank-compile-file (filename load-p external-format)
377     "Compile FILENAME signalling COMPILE-CONDITIONs.     "Compile FILENAME signalling COMPILE-CONDITIONs.
378  If LOAD-P is true, load the file after compilation.")  If LOAD-P is true, load the file after compilation.
379    EXTERNAL-FORMAT is a value returned by find-external-format or
380    :default.")
381    
382  (deftype severity ()  (deftype severity ()
383    '(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 409  If LOAD-P is true, load the file after c
409     (location :initarg :location     (location :initarg :location
410               :accessor location)))               :accessor location)))
411    
412    (definterface find-external-format (coding-system)
413      "Return a \"external file format designator\" for CODING-SYSTEM.
414    CODING-SYSTEM is Emacs-style coding system name (a string),
415    e.g. \"latin-1-unix\"."
416      (if (equal coding-system "iso-latin-1-unix")
417          :default
418          nil))
419    
420    (definterface guess-external-format (filename)
421      "Detect the external format for the file with name FILENAME.
422    Return nil if the file contains no special markers."
423      ;; Look for a Emacs-style -*- coding: ... -*- or Local Variable: section.
424      (with-open-file (s filename :if-does-not-exist nil
425                         :external-format (or (find-external-format "latin-1-unix")
426                                              :default))
427        (if s
428            (or (let* ((line (read-line s nil))
429                       (p (search "-*-" line)))
430                  (when p
431                    (let* ((start (+ p (length "-*-")))
432                           (end (search "-*-" line :start2 start)))
433                      (when end
434                        (%search-coding line start end)))))
435                (let* ((len (file-length s))
436                       (buf (make-string (min len 3000))))
437                  (file-position s (- len (length buf)))
438                  (read-sequence buf s)
439                  (let ((start (search "Local Variables:" buf :from-end t))
440                        (end (search "End:" buf :from-end t)))
441                    (and start end (< start end)
442                         (%search-coding buf start end))))))))
443    
444    (defun %search-coding (str start end)
445      (let ((p (search "coding:" str :start2 start :end2 end)))
446        (when p
447          (incf p (length "coding:"))
448          (loop while (and (< p end)
449                           (member (aref str p) '(#\space #\tab)))
450                do (incf p))
451          (let ((end (position-if (lambda (c) (find c '(#\space #\tab #\newline)))
452                                  str :start p)))
453            (find-external-format (subseq str p end))))))
454    
455    
456  ;;;; Streams  ;;;; Streams
457    
# Line 502  returned.  Frame zero is defined as the Line 601  returned.  Frame zero is defined as the
601  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
602  the stack.")  the stack.")
603    
604    (definterface compute-sane-restarts (condition)
605      "This is an opportunity for Lisps such as CLISP to remove
606    unwanted restarts from the output of CL:COMPUTE-RESTARTS,
607    otherwise it should simply call CL:COMPUTE-RESTARTS, which is
608    what the default implementation does."
609      (compute-restarts condition))
610    
611  (definterface print-frame (frame stream)  (definterface print-frame (frame stream)
612    "Print frame to stream.")    "Print frame to stream.")
613    
# Line 585  The allowed elements are of the form: Line 691  The allowed elements are of the form:
691  (definterface sldb-break-at-start (symbol)  (definterface sldb-break-at-start (symbol)
692    "Set a breakpoint on the beginning of the function for SYMBOL.")    "Set a breakpoint on the beginning of the function for SYMBOL.")
693    
694    (definterface sldb-stepper-condition-p (condition)
695      "Return true if SLDB was invoked due to a single-stepping condition,
696    false otherwise. "
697      (declare (ignore condition))
698      nil)
699    
700    (definterface sldb-step-into ()
701      "Step into the current single-stepper form.")
702    
703    (definterface sldb-step-next ()
704      "Step to the next form in the current function.")
705    
706    (definterface sldb-step-out ()
707      "Stop single-stepping temporarily, but resume it once the current function
708    returns.")
709    
710    
711  ;;;; Definition finding  ;;;; Definition finding
# Line 716  inspect-for-emacs method.")) Line 837  inspect-for-emacs method."))
837  (definterface make-default-inspector ()  (definterface make-default-inspector ()
838    "Return an inspector object suitable for passing to inspect-for-emacs.")    "Return an inspector object suitable for passing to inspect-for-emacs.")
839    
840  (definterface inspect-for-emacs (object inspector)  (defgeneric inspect-for-emacs (object inspector)
841      (:documentation
842     "Explain to Emacs how to inspect OBJECT.     "Explain to Emacs how to inspect OBJECT.
843    
844  The argument INSPECTOR is an object representing how to get at  The argument INSPECTOR is an object representing how to get at
845  the internals of OBJECT, it is usually an implementation specific  the internals of OBJECT, it is usually an implementation specific
846  class used simply for dispatching to the proper method.  class used simply for dispatching to the proper method.
847    
 The orgument INSPECTION-MODE is an object specifying how, and  
 what, to show to the user.  
   
848  Returns two values: a string which will be used as the title of  Returns two values: a string which will be used as the title of
849  the inspector buffer and a list specifying how to render the  the inspector buffer and a list specifying how to render the
850  object for inspection.  object for inspection.
# Line 739  inserted into the buffer as is, or a lis Line 858  inserted into the buffer as is, or a lis
858    
859   (:newline) - Render a \\n   (:newline) - Render a \\n
860    
861   (:action label lambda) - Render LABEL (a text string) which when   (:action label lambda &key (refresh t)) - Render LABEL (a text
862   clicked will call LAMBDA.   string) which when clicked will call LAMBDA. If REFRESH is
863     non-NIL the currently inspected object will be re-inspected
864     after calling the lambda.
865    
866   NIL - do nothing.")   NIL - do nothing."))
867    
868  (defmethod inspect-for-emacs ((object t) (inspector t))  (defmethod inspect-for-emacs ((object t) (inspector t))
869    "Generic method for inspecting any kind of object.    "Generic method for inspecting any kind of object.
# Line 759  output of CL:DESCRIBE." Line 880  output of CL:DESCRIBE."
880    
881  ;;; Utilities for inspector methods.  ;;; Utilities for inspector methods.
882  ;;;  ;;;
883  (defun label-value-line (label value)  (defun label-value-line (label value &key (newline t))
884    "Create a control list which prints \"LABEL: VALUE\" in the inspector."    "Create a control list which prints \"LABEL: VALUE\" in the inspector.
885    (list (princ-to-string label) ": " `(:value ,value) '(:newline)))  If NEWLINE is non-NIL a `(:newline)' is added to the result."
886      (list* (princ-to-string label) ": " `(:value ,value)
887             (if newline '((:newline)) nil)))
888    
889  (defmacro label-value-line* (&rest label-values)  (defmacro label-value-line* (&rest label-values)
890    ` (append ,@(loop for (label value) in label-values    ` (append ,@(loop for (label value) in label-values
891                      collect `(label-value-line ,label ,value))))                      collect `(label-value-line ,label ,value))))
892    
893    (defgeneric type-for-emacs (object)
894      (:documentation
895       "Return a type specifier suitable for display in the Emacs inspector.")
896      (:method (object)
897        (type-of object))
898      (:method ((object integer))
899        ;; Some lisps report integer types as (MOD ...), which while nice
900        ;; in a sense doesn't answer the often more immediate question of
901        ;; fixnumness.
902        (if (typep object 'fixnum)
903            'fixnum
904            'bignum)))
905    
906    
907  (definterface describe-primitive-type (object)  (definterface describe-primitive-type (object)
908    "Return a string describing the primitive type of object."    "Return a string describing the primitive type of object."
909    (declare (ignore object))    (declare (ignore object))
# Line 778  output of CL:DESCRIBE." Line 915  output of CL:DESCRIBE."
915  ;;; The default implementations are sufficient for non-multiprocessing  ;;; The default implementations are sufficient for non-multiprocessing
916  ;;; implementations.  ;;; implementations.
917    
918  (definterface initialize-multiprocessing ()  (definterface initialize-multiprocessing (continuation)
919     "Initialize multiprocessing, if necessary."     "Initialize multiprocessing, if necessary and then invoke CONTINUATION.
    nil)  
920    
921  (definterface startup-idle-and-top-level-loops ()  Depending on the impleimentaion, this function may never return."
922    "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)  
923    
924  (definterface spawn (fn &key name)  (definterface spawn (fn &key name)
925    "Create a new thread to call FN.")    "Create a new thread to call FN.")
# Line 828  Only one thread may hold the lock (via C Line 960  Only one thread may hold the lock (via C
960              (type function function))              (type function function))
961     (funcall function))     (funcall function))
962    
963    (definterface make-recursive-lock (&key name)
964      "Make a lock for thread synchronization.
965    Only one thread may hold the lock (via CALL-WITH-RECURSIVE-LOCK-HELD)
966    at a time, but that thread may hold it more than once."
967      (cons nil (make-lock :name name)))
968    
969    (definterface call-with-recursive-lock-held (lock function)
970      "Call FUNCTION with LOCK held, queueing if necessary."
971      (if (eql (car lock) (current-thread))
972          (funcall function)
973          (call-with-lock-held (cdr lock)
974                               (lambda ()
975                                 (unwind-protect
976                                      (progn
977                                        (setf (car lock) (current-thread))
978                                        (funcall function))
979                                   (setf (car lock) nil))))))
980    
981  (definterface current-thread ()  (definterface current-thread ()
982    "Return the currently executing thread."    "Return the currently executing thread."
983    0)    0)
# Line 873  SPEC can be: Line 1023  SPEC can be:
1023  (definterface make-weak-value-hash-table (&rest args)  (definterface make-weak-value-hash-table (&rest args)
1024    "Like MAKE-HASH-TABLE, but weak w.r.t. the values."    "Like MAKE-HASH-TABLE, but weak w.r.t. the values."
1025    (apply #'make-hash-table args))    (apply #'make-hash-table args))
1026    
1027    (definterface hash-table-weakness (hashtable)
1028      "Return nil or one of :key :value :key-or-value :key-and-value"
1029      (declare (ignore hashtable))
1030      nil)
1031    
1032    
1033    ;;;; Character names
1034    
1035    (definterface character-completion-set (prefix matchp)
1036      "Return a list of names of characters that match PREFIX."
1037      ;; Handle the standard and semi-standard characters.
1038      (loop for name in '("Newline" "Space" "Tab" "Page" "Rubout"
1039                          "Linefeed" "Return" "Backspace")
1040         when (funcall matchp prefix name)
1041         collect name))
1042    

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

  ViewVC Help
Powered by ViewVC 1.1.5