/[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.113 by alendvai, Tue Dec 19 10:47:36 2006 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             ))             ))
43    
44  (defpackage :swank-mop  (defpackage :swank-mop
# Line 84  Line 87 
87     #:slot-definition-type     #:slot-definition-type
88     #:slot-definition-readers     #:slot-definition-readers
89     #:slot-definition-writers     #:slot-definition-writers
90       #:slot-boundp-using-class
91       #:slot-value-using-class
92       #:slot-makunbound-using-class
93     ;; generic function protocol     ;; generic function protocol
94     #:compute-applicable-methods-using-classes     #:compute-applicable-methods-using-classes
95     #:finalize-inheritance))     #:finalize-inheritance))
# Line 110  implementation. Line 116  implementation.
116    
117  Backends implement these functions using DEFIMPLEMENTATION."  Backends implement these functions using DEFIMPLEMENTATION."
118    (check-type documentation string "a documentation string")    (check-type documentation string "a documentation string")
119    (flet ((gen-default-impl ()    (assert (every #'symbolp args) ()
120             `(defmethod ,name ,args ,@default-body)))            "Complex lambda-list not supported: ~S ~S" name args)
121      `(progn (defgeneric ,name ,args (:documentation ,documentation))    (labels ((gen-default-impl ()
122              (pushnew ',name *interface-functions*)               `(setf (get ',name 'default) (lambda ,args ,@default-body)))
123              ,(if (null default-body)             (args-as-list (args)
124                   `(pushnew ',name *unimplemented-interfaces*)               (destructuring-bind (req opt key rest) (parse-lambda-list args)
125                   (gen-default-impl))                 `(,@req ,@opt
126              ;; 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))
127              (eval-when (:compile-toplevel :load-toplevel :execute)                         ,@(or rest '(())))))
128                (export ',name :swank-backend))             (parse-lambda-list (args)
129              ',name)))               (parse args '(&optional &key &rest)
130                        (make-array 4 :initial-element nil)))
131               (parse (args keywords vars)
132                 (cond ((null args)
133                        (reverse (map 'list #'reverse vars)))
134                       ((member (car args) keywords)
135                        (parse (cdr args) (cdr (member (car args) keywords)) vars))
136                       (t (push (car args) (aref vars (length keywords)))
137                          (parse (cdr args) keywords vars))))
138               (kw (s) (intern (string s) :keyword)))
139        `(progn
140           (defun ,name ,args
141             ,documentation
142             (let ((f (or (get ',name 'implementation)
143                          (get ',name 'default))))
144               (cond (f (apply f ,@(args-as-list args)))
145                     (t (error "~S not implementated" ',name)))))
146           (pushnew ',name *interface-functions*)
147           ,(if (null default-body)
148                `(pushnew ',name *unimplemented-interfaces*)
149                (gen-default-impl))
150           ;; see <http://www.franz.com/support/documentation/6.2/doc/pages/variables/compiler/s_cltl1-compile-file-toplevel-compatibility-p_s.htm>
151           (eval-when (:compile-toplevel :load-toplevel :execute)
152             (export ',name :swank-backend))
153           ',name)))
154    
155  (defmacro defimplementation (name args &body body)  (defmacro defimplementation (name args &body body)
156    `(progn (defmethod ,name ,args ,@body)    (assert (every #'symbolp args) ()
157            (if (member ',name *interface-functions*)            "Complex lambda-list not supported: ~S ~S" name args)
158                (setq *unimplemented-interfaces*    `(progn
159                      (remove ',name *unimplemented-interfaces*))       (setf (get ',name 'implementation) (lambda ,args ,@body))
160                (warn "DEFIMPLEMENTATION of undefined interface (~S)" ',name))       (if (member ',name *interface-functions*)
161            ',name))           (setq *unimplemented-interfaces*
162                   (remove ',name *unimplemented-interfaces*))
163             (warn "DEFIMPLEMENTATION of undefined interface (~S)" ',name))
164         ',name))
165    
166    (define-condition request-abort (error)
167      ((reason  :initarg :reason :reader reason))
168      (:report (lambda (condition stream)
169                 (princ (reason condition) stream)))
170      (:documentation "Condition signalled when SLIME wasn't able to
171    complete a user request due to bad data. This condition is not
172    for real errors but for situations where SLIME has to give up and
173    return control back to the user."))
174    
175    (defun abort-request (reason-control &rest reason-args)
176      "Abort whatever swank is currently do and send a message to the
177    user."
178      (error 'request-abort :reason (apply #'format nil reason-control reason-args)))
179    
180  (defun warn-unimplemented-interfaces ()  (defun warn-unimplemented-interfaces ()
181    "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 259  EXCEPT is a list of symbol names which s
259    "Close the socket SOCKET.")    "Close the socket SOCKET.")
260    
261  (definterface accept-connection (socket &key external-format  (definterface accept-connection (socket &key external-format
262                                          buffering)                                          buffering timeout)
263     "Accept a client connection on the listening socket SOCKET.     "Accept a client connection on the listening socket SOCKET.
264  Return a stream for the new connection.")  Return a stream for the new connection.")
265    
# Line 232  Return a stream for the new connection." Line 279  Return a stream for the new connection."
279    "Return one of the symbols :spawn, :sigio, :fd-handler, or NIL."    "Return one of the symbols :spawn, :sigio, :fd-handler, or NIL."
280    nil)    nil)
281    
282    (definterface set-stream-timeout (stream timeout)
283      "Set the 'stream 'timeout.  The timeout is either the real number
284      specifying the timeout in seconds or 'nil for no timeout."
285      (declare (ignore stream timeout))
286      nil)
287    
288  ;;; Base condition for networking errors.  ;;; Base condition for networking errors.
289  (define-condition network-error (simple-error) ())  (define-condition network-error (simple-error) ())
290    
# Line 311  The KEYWORD-ARGS are passed on to the op Line 364  The KEYWORD-ARGS are passed on to the op
364  Example:  Example:
365  \(operate-on-system \"SWANK\" \"COMPILE-OP\" :force t)"  \(operate-on-system \"SWANK\" \"COMPILE-OP\" :force t)"
366    (unless (member :asdf *features*)    (unless (member :asdf *features*)
367      (error "ASDF is not loaded."))      (abort-request "ASDF is not loaded."))
368    (with-compilation-hooks ()    (with-compilation-hooks ()
369      (let ((operate (find-symbol "OPERATE" :asdf))      (let ((operate (find-symbol (symbol-name '#:operate) :asdf))
370            (operation (find-symbol operation-name :asdf)))            (operation (find-symbol operation-name :asdf)))
371        (when (null operation)        (when (null operation)
372          (error "Couldn't find ASDF operation ~S" operation-name))          (abort-request "Couldn't find ASDF operation ~S" operation-name))
373        (apply operate operation system-name keyword-args))))        (apply operate operation system-name keyword-args))))
374    
375  (definterface swank-compile-file (filename load-p &optional external-format)  (definterface swank-compile-file (filename load-p external-format)
376     "Compile FILENAME signalling COMPILE-CONDITIONs.     "Compile FILENAME signalling COMPILE-CONDITIONs.
377  If LOAD-P is true, load the file after compilation.")  If LOAD-P is true, load the file after compilation.
378    EXTERNAL-FORMAT is a value returned by find-external-format or
379    :default.")
380    
381  (deftype severity ()  (deftype severity ()
382    '(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 408  If LOAD-P is true, load the file after c
408     (location :initarg :location     (location :initarg :location
409               :accessor location)))               :accessor location)))
410    
411    (definterface find-external-format (coding-system)
412      "Return a \"external file format designator\" for CODING-SYSTEM.
413    CODING-SYSTEM is Emacs-style coding system name (a string),
414    e.g. \"latin-1-unix\"."
415      (if (equal coding-system "iso-latin-1-unix")
416          :default
417          nil))
418    
419    (definterface guess-external-format (filename)
420      "Detect the external format for the file with name FILENAME.
421    Return nil if the file contains no special markers."
422      ;; Look for a Emacs-style -*- coding: ... -*- or Local Variable: section.
423      (with-open-file (s filename :if-does-not-exist nil
424                         :external-format (or (find-external-format "latin-1-unix")
425                                              :default))
426        (if s
427            (or (let* ((line (read-line s nil))
428                       (p (search "-*-" line)))
429                  (when p
430                    (let* ((start (+ p (length "-*-")))
431                           (end (search "-*-" line :start2 start)))
432                      (when end
433                        (%search-coding line start end)))))
434                (let* ((len (file-length s))
435                       (buf (make-string (min len 3000))))
436                  (file-position s (- len (length buf)))
437                  (read-sequence buf s)
438                  (let ((start (search "Local Variables:" buf :from-end t))
439                        (end (search "End:" buf :from-end t)))
440                    (and start end (< start end)
441                         (%search-coding buf start end))))))))
442    
443    (defun %search-coding (str start end)
444      (let ((p (search "coding:" str :start2 start :end2 end)))
445        (when p
446          (incf p (length "coding:"))
447          (loop while (and (< p end)
448                           (member (aref str p) '(#\space #\tab)))
449                do (incf p))
450          (let ((end (position-if (lambda (c) (find c '(#\space #\tab #\newline)))
451                                  str :start p)))
452            (find-external-format (subseq str p end))))))
453    
454    
455  ;;;; Streams  ;;;; Streams
456    
# Line 585  The allowed elements are of the form: Line 683  The allowed elements are of the form:
683  (definterface sldb-break-at-start (symbol)  (definterface sldb-break-at-start (symbol)
684    "Set a breakpoint on the beginning of the function for SYMBOL.")    "Set a breakpoint on the beginning of the function for SYMBOL.")
685    
686    (definterface sldb-stepper-condition-p (condition)
687      "Return true if SLDB was invoked due to a single-stepping condition,
688    false otherwise. "
689      (declare (ignore condition))
690      nil)
691    
692    (definterface sldb-step-into ()
693      "Step into the current single-stepper form.")
694    
695    (definterface sldb-step-next ()
696      "Step to the next form in the current function.")
697    
698    (definterface sldb-step-out ()
699      "Stop single-stepping temporarily, but resume it once the current function
700    returns.")
701    
702    
703  ;;;; Definition finding  ;;;; Definition finding
# Line 716  inspect-for-emacs method.")) Line 829  inspect-for-emacs method."))
829  (definterface make-default-inspector ()  (definterface make-default-inspector ()
830    "Return an inspector object suitable for passing to inspect-for-emacs.")    "Return an inspector object suitable for passing to inspect-for-emacs.")
831    
832  (definterface inspect-for-emacs (object inspector)  (defgeneric inspect-for-emacs (object inspector)
833      (:documentation
834     "Explain to Emacs how to inspect OBJECT.     "Explain to Emacs how to inspect OBJECT.
835    
836  The argument INSPECTOR is an object representing how to get at  The argument INSPECTOR is an object representing how to get at
# Line 742  inserted into the buffer as is, or a lis Line 856  inserted into the buffer as is, or a lis
856   (:action label lambda) - Render LABEL (a text string) which when   (:action label lambda) - Render LABEL (a text string) which when
857   clicked will call LAMBDA.   clicked will call LAMBDA.
858    
859   NIL - do nothing.")   NIL - do nothing."))
860    
861  (defmethod inspect-for-emacs ((object t) (inspector t))  (defmethod inspect-for-emacs ((object t) (inspector t))
862    "Generic method for inspecting any kind of object.    "Generic method for inspecting any kind of object.
# Line 767  output of CL:DESCRIBE." Line 881  output of CL:DESCRIBE."
881    ` (append ,@(loop for (label value) in label-values    ` (append ,@(loop for (label value) in label-values
882                      collect `(label-value-line ,label ,value))))                      collect `(label-value-line ,label ,value))))
883    
884    (defgeneric type-for-emacs (object)
885      (:documentation
886       "Return a type specifier suitable for display in the Emacs inspector.")
887      (:method (object)
888        (type-of object))
889      (:method ((object integer))
890        ;; Some lisps report integer types as (MOD ...), which while nice
891        ;; in a sense doesn't answer the often more immediate question of
892        ;; fixnumness.
893        (if (typep object 'fixnum)
894            'fixnum
895            'bignum)))
896    
897    
898  (definterface describe-primitive-type (object)  (definterface describe-primitive-type (object)
899    "Return a string describing the primitive type of object."    "Return a string describing the primitive type of object."
900    (declare (ignore object))    (declare (ignore object))
# Line 778  output of CL:DESCRIBE." Line 906  output of CL:DESCRIBE."
906  ;;; The default implementations are sufficient for non-multiprocessing  ;;; The default implementations are sufficient for non-multiprocessing
907  ;;; implementations.  ;;; implementations.
908    
909  (definterface initialize-multiprocessing ()  (definterface initialize-multiprocessing (continuation)
910     "Initialize multiprocessing, if necessary."     "Initialize multiprocessing, if necessary and then invoke CONTINUATION.
    nil)  
911    
912  (definterface startup-idle-and-top-level-loops ()  Depending on the impleimentaion, this function may never return."
913    "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)  
914    
915  (definterface spawn (fn &key name)  (definterface spawn (fn &key name)
916    "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 951  Only one thread may hold the lock (via C
951              (type function function))              (type function function))
952     (funcall function))     (funcall function))
953    
954    (definterface make-recursive-lock (&key name)
955      "Make a lock for thread synchronization.
956    Only one thread may hold the lock (via CALL-WITH-RECURSIVE-LOCK-HELD)
957    at a time, but that thread may hold it more than once."
958      (cons nil (make-lock :name name)))
959    
960    (definterface call-with-recursive-lock-held (lock function)
961      "Call FUNCTION with LOCK held, queueing if necessary."
962      (if (eql (car lock) (current-thread))
963          (funcall function)
964          (call-with-lock-held (cdr lock)
965                               (lambda ()
966                                 (unwind-protect
967                                      (progn
968                                        (setf (car lock) (current-thread))
969                                        (funcall function))
970                                   (setf (car lock) nil))))))
971    
972  (definterface current-thread ()  (definterface current-thread ()
973    "Return the currently executing thread."    "Return the currently executing thread."
974    0)    0)
# Line 873  SPEC can be: Line 1014  SPEC can be:
1014  (definterface make-weak-value-hash-table (&rest args)  (definterface make-weak-value-hash-table (&rest args)
1015    "Like MAKE-HASH-TABLE, but weak w.r.t. the values."    "Like MAKE-HASH-TABLE, but weak w.r.t. the values."
1016    (apply #'make-hash-table args))    (apply #'make-hash-table args))
1017    
1018    (definterface hash-table-weakness (hashtable)
1019      "Return nil or one of :key :value :key-or-value :key-and-value"
1020      (declare (ignore hashtable))
1021      nil)
1022    
1023    
1024    ;;;; Character names
1025    
1026    (definterface character-completion-set (prefix matchp)
1027      "Return a list of names of characters that match PREFIX."
1028      ;; Handle the standard and semi-standard characters.
1029      (loop for name in '("Newline" "Space" "Tab" "Page" "Rubout"
1030                          "Linefeed" "Return" "Backspace")
1031         when (funcall matchp prefix name)
1032         collect name))
1033    

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

  ViewVC Help
Powered by ViewVC 1.1.5