/[slime]/slime/swank-cmucl.lisp
ViewVC logotype

Diff of /slime/swank-cmucl.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.32 by heller, Wed Dec 3 22:34:50 2003 UTC revision 1.38 by dbarlow, Thu Dec 11 02:19:51 2003 UTC
# Line 27  Line 27 
27      (ext:htonl address)))      (ext:htonl address)))
28    
29  (defun create-swank-server (port &key (reuse-address t)  (defun create-swank-server (port &key (reuse-address t)
30                              (address "localhost"))                              (address "localhost")
31                                (announce #'simple-announce-function))
32    "Create a SWANK TCP server."    "Create a SWANK TCP server."
33    (let* ((ip (resolve-hostname address))    (let* ((ip (resolve-hostname address))
34           (fd (ext:create-inet-listener port :stream           (fd (ext:create-inet-listener port :stream
35                                         :reuse-address reuse-address                                         :reuse-address reuse-address
36                                         :host ip)))                                         :host ip)))
37      (system:add-fd-handler fd :input #'accept-connection)      (funcall announce (nth-value 1 (ext::get-socket-host-and-port fd)))
38      (nth-value 1 (ext::get-socket-host-and-port fd))))      (accept-connection fd)))
39    
40  (defun accept-connection (socket)  (defun accept-connection (socket)
41    "Accept one Swank TCP connection on SOCKET and then close it."    "Accept one Swank TCP connection on SOCKET and then close it."
42    (setup-request-handler (ext:accept-tcp-connection socket))    (let* ((fd (ext:accept-tcp-connection socket))
43    (sys:invalidate-descriptor socket)           (stream (sys:make-fd-stream fd :input t :output t
44    (unix:unix-close socket))                                       :element-type 'base-char)))
45        (sys:invalidate-descriptor socket)
46        (unix:unix-close socket)
47        (request-loop stream)))
48    
49  (defun open-stream-to-emacs ()  (defun open-stream-to-emacs ()
50    "Return an output-stream to Emacs' output buffer."    "Return an output-stream to Emacs' output buffer."
# Line 56  Line 60 
60    
61  (defvar *use-dedicated-output-stream* t)  (defvar *use-dedicated-output-stream* t)
62    
63  (defun setup-request-handler (socket)  (defun request-loop (*emacs-io*)
64    "Setup request handling for SOCKET."    "Processes requests until the remote Emacs goes away."
65    (let* ((stream (sys:make-fd-stream socket    (unwind-protect
66                                       :input t :output t         (let* ((*slime-output* (if *use-dedicated-output-stream*
67                                       :element-type 'base-char))                                    (open-stream-to-emacs)
68           (input (make-slime-input-stream))                                    (make-slime-output-stream)))
69           (output (if *use-dedicated-output-stream*                (*slime-input* (make-slime-input-stream))
70                       (let ((*emacs-io* stream)) (open-stream-to-emacs))                (*slime-io* (make-two-way-stream *slime-input* *slime-output*)))
71                       (make-slime-output-stream)))           (loop
72           (io (make-two-way-stream input output)))            (catch 'slime-toplevel
73      (system:add-fd-handler socket              (with-simple-restart (abort "Return to Slime toplevel.")
74                             :input (lambda (fd)                (handler-case (read-from-emacs)
75                                      (declare (ignore fd))                  (slime-read-error (e)
76                                      (serve-request stream output input io)))))                    (when *swank-debug-p*
77                        (format *debug-io*
78  (defun serve-request (*emacs-io* *slime-output* *slime-input* *slime-io*)                              "~&;; Connection to Emacs lost.~%;; [~A]~%" e))
79    "Read and process a request from a SWANK client.                    (return)))))
80  The request is read from the socket as a sexp and then evaluated."            (sys:scrub-control-stack)))
81    (catch 'slime-toplevel      (format *terminal-io* "~&;; Swank: Closed connection: ~A~%" *emacs-io*)
82      (with-simple-restart (abort "Return to Slime toplevel.")      (close *emacs-io*)))
       (handler-case (read-from-emacs)  
         (slime-read-error (e)  
           (when *swank-debug-p*  
             (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" e))  
           (sys:invalidate-descriptor (sys:fd-stream-fd *emacs-io*))  
           (close *emacs-io*)))))  
   (sys:scrub-control-stack))  
83    
84    
85  ;;;; Stream handling  ;;;; Stream handling
# Line 277  the error-context redundant." Line 274  the error-context redundant."
274           (make-location (list :file (namestring *compile-file-truename*))           (make-location (list :file (namestring *compile-file-truename*))
275                          (list :position 0)))                          (list :position 0)))
276          (*compile-filename*          (*compile-filename*
277             ;; XXX is this _ever_ used?  By what?  *compile-file-truename*
278             ;; should be set by the implementation inside any call to compile-file
279           (make-location (list :file *compile-filename*) (list :position 0)))           (make-location (list :file *compile-filename*) (list :position 0)))
280          (t          (t
281           (list :error "No error location available"))))           (list :error "No error location available"))))
282    
283  (defmacro with-compilation-hooks (() &body body)  (defmethod call-with-compilation-hooks (function)
284    "Execute BODY and record the set of compiler notes."    (let ((*previous-compiler-condition* nil)
285    `(let ((*previous-compiler-condition* nil)          (*previous-context* nil)
286           (*previous-context* nil)          (*print-readably* nil))
          (*print-readably* nil))  
287      (handler-bind ((c::compiler-error #'handle-notification-condition)      (handler-bind ((c::compiler-error #'handle-notification-condition)
288                     (c::style-warning  #'handle-notification-condition)                     (c::style-warning  #'handle-notification-condition)
289                     (c::warning        #'handle-notification-condition))                     (c::warning        #'handle-notification-condition))
290        ,@body)))        (funcall function))))
291    
292  (defmethod compile-file-for-emacs (filename load-p)  (defmethod compile-file-for-emacs (filename load-p)
293    (clear-xref-info filename)    (clear-xref-info filename)
# Line 553  the code omponent CODE." Line 551  the code omponent CODE."
551    
552  ;;;; Definitions  ;;;; Definitions
553    
554  (defvar *debug-definition-finding* t  (defvar *debug-definition-finding* nil
555    "When true don't handle errors while looking for definitions.    "When true don't handle errors while looking for definitions.
556  This is useful when debugging the definition-finding code.")  This is useful when debugging the definition-finding code.")
557    
# Line 670  The second return value is the condition Line 668  The second return value is the condition
668    (destructuring-bind (first) (function-source-locations function)    (destructuring-bind (first) (function-source-locations function)
669      first))      first))
670    
671  (defslimefun find-function-locations (symbol-name)  (defmethod find-function-locations (symbol-name)
672    "Return a list of source-locations for SYMBOL-NAME's functions."    "Return a list of source-locations for SYMBOL-NAME's functions."
673    (multiple-value-bind (symbol foundp) (find-symbol-designator symbol-name)    (multiple-value-bind (symbol foundp) (find-symbol-designator symbol-name)
674      (cond ((not foundp)      (cond ((not foundp)
# Line 807  The result has the format \"(...)\"." Line 805  The result has the format \"(...)\"."
805  (defmethod macroexpand-all (form)  (defmethod macroexpand-all (form)
806    (walker:macroexpand-all form))    (walker:macroexpand-all form))
807    
808    (in-package :c)
809    
810    (defun swank::expand-ir1-top-level (form)
811      "A scaled down version of the first pass of the compiler."
812      (with-compilation-unit ()
813        (let* ((*lexical-environment*
814                (make-lexenv :default (make-null-environment)
815                             :cookie *default-cookie*
816                             :interface-cookie *default-interface-cookie*))
817               (*source-info* (make-lisp-source-info form))
818               (*block-compile* nil)
819               (*block-compile-default* nil))
820          (with-ir1-namespace
821              (clear-stuff)
822            (find-source-paths form 0)
823            (ir1-top-level form '(0) t)))))
824    
825    (in-package :swank)
826    
827    (defslimefun print-ir1-converted-blocks (form)
828      (with-output-to-string (*standard-output*)
829        (c::print-all-blocks (expand-ir1-top-level (from-string form)))))
830    
831  (defun tracedp (fname)  (defun tracedp (fname)
832    (gethash (debug::trace-fdefinition fname)    (gethash (debug::trace-fdefinition fname)
833             debug::*traced-functions*))             debug::*traced-functions*))
# Line 1042  format suitable for Emacs." Line 1063  format suitable for Emacs."
1063    (nth index *sldb-restarts*))    (nth index *sldb-restarts*))
1064    
1065  (defun format-frame-for-emacs (frame)  (defun format-frame-for-emacs (frame)
1066    (list (di:frame-number frame)    (with-output-to-string (*standard-output*)
1067          (with-output-to-string (*standard-output*)      (let ((*print-pretty* *sldb-pprint-frames*))
1068            (let ((*print-pretty* *sldb-pprint-frames*))        (debug::print-frame-call frame :verbosity 1 :number t))))
             (debug::print-frame-call frame :verbosity 1 :number t)))))  
1069    
1070  (defun compute-backtrace (start end)  (defun compute-backtrace (start end)
1071    "Return a list of frames starting with frame number START and    "Return a list of frames starting with frame number START and
# Line 1055  stack." Line 1075  stack."
1075      (loop for f = (nth-frame start) then (di:frame-down f)      (loop for f = (nth-frame start) then (di:frame-down f)
1076            for i from start below end            for i from start below end
1077            while f            while f
1078            collect f)))            collect (cons i f))))
1079    
1080  (defmethod backtrace (start end)  (defmethod backtrace (start end)
1081    (mapcar #'format-frame-for-emacs (compute-backtrace start end)))    (loop for (n . frame) in (compute-backtrace start end)
1082            collect (list n (format-frame-for-emacs frame))))
1083    
1084  (defmethod debugger-info-for-emacs (start end)  (defmethod debugger-info-for-emacs (start end)
1085    (list (format-condition-for-emacs)    (list (format-condition-for-emacs)
# Line 1086  stack." Line 1107  stack."
1107           (debug-function (di:frame-debug-function frame))           (debug-function (di:frame-debug-function frame))
1108           (debug-variables (di::debug-function-debug-variables debug-function)))           (debug-variables (di::debug-function-debug-variables debug-function)))
1109      (loop for v across debug-variables      (loop for v across debug-variables
1110            collect (list            for symbol = (di:debug-variable-symbol v)
1111                     :symbol (di:debug-variable-symbol v)            for id =  (di:debug-variable-id v)
1112                     :id (di:debug-variable-id v)            for validy = (di:debug-variable-validity v location)
1113              collect (list :symbol symbol :id id
1114                     :value-string                     :value-string
1115                     (if (eq (di:debug-variable-validity v location)                     (ecase validy
1116                             :valid)                       (:valid (to-string (di:debug-variable-value v frame)))
1117                         (to-string (di:debug-variable-value v frame))                       ((:invalid :unknown) "<not-available>"))))))
                        "<not-available>")))))  
1118    
1119  (defmethod frame-catch-tags (index)  (defmethod frame-catch-tags (index)
1120    (loop for (tag . code-location) in (di:frame-catches (nth-frame index))    (loop for (tag . code-location) in (di:frame-catches (nth-frame index))
# Line 1105  stack." Line 1126  stack."
1126  (defslimefun sldb-abort ()  (defslimefun sldb-abort ()
1127    (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))    (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
1128    
1129    (defun set-step-breakpoints (frame)
1130      (when (di:debug-block-elsewhere-p (di:code-location-debug-block
1131                                         (di:frame-code-location frame)))
1132        (error "Cannot step, in elsewhere code~%"))
1133      (let* ((code-location (di:frame-code-location frame))
1134             (debug::*bad-code-location-types*
1135              (remove :call-site debug::*bad-code-location-types*))
1136             (next (debug::next-code-locations code-location)))
1137        (cond (next
1138               (let ((steppoints '()))
1139                 (flet ((hook (frame breakpoint)
1140                          (let ((debug:*stack-top-hint* frame))
1141                            (mapc #'di:delete-breakpoint steppoints)
1142                            (let ((cl (di::breakpoint-what breakpoint)))
1143                              (break "Breakpoint: ~S ~S"
1144                                     (di:code-location-kind cl)
1145                                     (di::compiled-code-location-pc cl))))))
1146                   (dolist (code-location next)
1147                     (let ((bp (di:make-breakpoint #'hook code-location
1148                                                   :kind :code-location)))
1149                       (di:activate-breakpoint bp)
1150                       (push bp steppoints))))))
1151             (t
1152              (flet ((hook (frame breakpoint values cookie)
1153                       (declare (ignore cookie))
1154                       (di:delete-breakpoint breakpoint)
1155                       (let ((debug:*stack-top-hint* frame))
1156                         (break "Function-end: ~A ~A" breakpoint values))))
1157                (let* ((debug-function (di:frame-debug-function frame))
1158                       (bp (di:make-breakpoint #'hook debug-function
1159                                               :kind :function-end)))
1160                  (di:activate-breakpoint bp)))))))
1161    
1162    (defslimefun sldb-step (frame)
1163      (cond ((find-restart 'continue *swank-debugger-condition*)
1164             (set-step-breakpoints (nth-frame frame))
1165             (continue *swank-debugger-condition*))
1166            (t
1167             (error "Cannot continue in from condition: ~A"
1168                    *swank-debugger-condition*))))
1169    
1170    (defslimefun sldb-disassemble (frame-number)
1171      "Return a string with the disassembly of frames code."
1172      ;; this could need some refactoring.
1173      (let* ((frame (nth-frame frame-number))
1174             (real-frame (di::frame-real-frame frame))
1175             (frame-pointer (di::frame-pointer real-frame))
1176             (debug-fun (di:frame-debug-function real-frame)))
1177        (with-output-to-string (*standard-output*)
1178          (format t "Frame: ~S~%~:[Real Frame: ~S~%~;~]Frame Pointer: ~S~%"
1179                  frame (eq frame real-frame) real-frame frame-pointer)
1180          (etypecase debug-fun
1181            (di::compiled-debug-function
1182             (let* ((code-loc (di:frame-code-location frame))
1183                    (component (di::compiled-debug-function-component debug-fun))
1184                    (pc (di::compiled-code-location-pc code-loc))
1185                    (ip (sys:sap-int
1186                         (sys:sap+ (kernel:code-instructions component) pc)))
1187                    (kind (if (di:code-location-unknown-p code-loc)
1188                              :unkown
1189                              (di:code-location-kind code-loc)))
1190                    (fun (di:debug-function-function debug-fun)))
1191               (format t "Instruction pointer: #x~X [pc: ~S kind: ~S]~%~%~%"
1192                       ip pc kind)
1193               (if fun
1194                   (disassemble fun)
1195                   (disassem:disassemble-code-component component))))
1196            (di::bogus-debug-function
1197             (format t "~%[Disassembling bogus frames not implemented]"))))))
1198    
1199  ;;;; Inspecting  ;;;; Inspecting
1200    

Legend:
Removed from v.1.32  
changed lines
  Added in v.1.38

  ViewVC Help
Powered by ViewVC 1.1.5