[slime-cvs] CVS update: slime/swank-sbcl.lisp slime/swank-openmcl.lisp slime/swank-cmucl.lisp
Luke Gorrie
lgorrie at common-lisp.net
Sun Nov 23 12:14:04 UTC 2003
Update of /project/slime/cvsroot/slime
In directory common-lisp.net:/tmp/cvs-serv14521
Modified Files:
swank-sbcl.lisp swank-openmcl.lisp swank-cmucl.lisp
Log Message:
Updated to use new debugger interface in swank-backend.lisp.
* swank-cmucl.lisp: Tidied up outline-minor-mode structure and
added comments and docstrings.
Date: Sun Nov 23 07:14:04 2003
Author: lgorrie
Index: slime/swank-sbcl.lisp
diff -u slime/swank-sbcl.lisp:1.24 slime/swank-sbcl.lisp:1.25
--- slime/swank-sbcl.lisp:1.24 Sun Nov 23 00:00:13 2003
+++ slime/swank-sbcl.lisp Sun Nov 23 07:14:04 2003
@@ -412,39 +412,29 @@
(sb-debug::trace-1 fname (sb-debug::make-trace-info))
(format nil "~S is now traced." fname)))))
+(defslimefun getpid ()
+ (sb-unix:unix-getpid))
+
;;; Debugging
-(defvar *sldb-level* 0)
(defvar *sldb-stack-top*)
(defvar *sldb-restarts*)
-(defslimefun getpid ()
- (sb-unix:unix-getpid))
-
-(defslimefun sldb-loop ()
- (let* ((*sldb-level* (1+ *sldb-level*))
- (*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame)))
+(defmethod call-with-debugging-environment (debugger-loop-fn)
+ (let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame)))
(*sldb-restarts* (compute-restarts *swank-debugger-condition*))
(sb-debug:*stack-top-hint* nil)
(*debugger-hook* nil)
- (level *sldb-level*)
- (*package* *buffer-package*)
(*readtable* (or sb-debug:*debug-readtable* *readtable*))
(*print-level* nil #+nil sb-debug:*debug-print-level*)
(*print-length* nil #+nil sb-debug:*debug-print-length*))
- (send-to-emacs (list* :debug *sldb-level* (debugger-info-for-emacs 0 1)))
(handler-bind ((sb-di:debug-condition
(lambda (condition)
- (send-to-emacs `(:debug-condition
- ,(princ-to-string condition)))
- (throw 'sldb-loop-catcher nil))))
- (unwind-protect
- (loop
- (catch 'sldb-loop-catcher
- (with-simple-restart (abort "Return to sldb level ~D." level)
- (read-from-emacs))))
- (send-to-emacs `(:debug-return ,level))))))
+ (signal (make-condition
+ 'sldb-condition
+ :original-condition condition)))))
+ (funcall debugger-loop-fn))))
(defun format-restarts-for-emacs ()
"Return a list of restarts for *swank-debugger-condition* in a
@@ -488,7 +478,7 @@
(defslimefun backtrace-for-emacs (start end)
(mapcar #'format-frame-for-emacs (compute-backtrace start end)))
-(defslimefun debugger-info-for-emacs (start end)
+(defmethod debugger-info-for-emacs (start end)
(list (format-condition-for-emacs)
(format-restarts-for-emacs)
(backtrace-for-emacs start end)))
Index: slime/swank-openmcl.lisp
diff -u slime/swank-openmcl.lisp:1.22 slime/swank-openmcl.lisp:1.23
--- slime/swank-openmcl.lisp:1.22 Sun Nov 23 02:15:14 2003
+++ slime/swank-openmcl.lisp Sun Nov 23 07:14:04 2003
@@ -13,7 +13,7 @@
;;; The LLGPL is also available online at
;;; http://opensource.franz.com/preamble.html
;;;
-;;; $Id: swank-openmcl.lisp,v 1.22 2003/11/23 07:15:14 lgorrie Exp $
+;;; $Id: swank-openmcl.lisp,v 1.23 2003/11/23 12:14:04 lgorrie Exp $
;;;
;;;
@@ -157,10 +157,11 @@
:location
(let ((position (condition-source-position condition)))
(if *buffer-name*
- (list :emacs-buffer *buffer-name* position)
+ (list :emacs-buffer *buffer-name* position t)
(list :file
(ccl::compiler-warning-file-name condition)
- position))))))
+ position
+ t))))))
(defun temp-file-name ()
"Return a temporary file name to compile strings into."
@@ -185,19 +186,17 @@
(delete-file binary-filename)))
(delete-file filename))))
+(defslimefun getpid ()
+ "Return the process ID of this superior Lisp."
+ (ccl::getpid))
+
;;; Debugging
-(defvar *sldb-level* 0)
(defvar *sldb-stack-top*)
(defvar *sldb-restarts*)
-(defslimefun getpid ()
- "Return the process ID of this superior Lisp."
- (ccl::getpid))
-
-(defslimefun sldb-loop ()
- (let* ((*sldb-level* (1+ *sldb-level*))
- (*sldb-stack-top* nil)
+(defmethod call-with-debugging-environment (debugger-loop-fn)
+ (let* ((*sldb-stack-top* nil)
;; This is a complete hack --- since we're not running at top level we
;; don't want to publish the last restart to Emacs which would allow
;; the user to break outside of the request loop. What's the right
@@ -205,15 +204,8 @@
(*sldb-restarts* (butlast
(compute-restarts *swank-debugger-condition*)))
(*debugger-hook* nil)
- (level *sldb-level*)
(*package* *buffer-package*))
- (send-to-emacs (list* :debug *sldb-level* (debugger-info-for-emacs 0 1)))
- (unwind-protect
- (loop
- (catch 'sldb-loop-catcher
- (with-simple-restart (abort "Return to sldb level ~D." level)
- (read-from-emacs))))
- (send-to-emacs `(:debug-return ,level)))))
+ (funcall debugger-loop-fn)))
(defun format-restarts-for-emacs ()
(loop for restart in *sldb-restarts*
@@ -299,7 +291,7 @@
start-frame-number end-frame-number)
(nreverse result)))
-(defslimefun debugger-info-for-emacs (start end)
+(defmethod debugger-info-for-emacs (start end)
(list (format-condition-for-emacs)
(format-restarts-for-emacs)
(backtrace-for-emacs start end)))
Index: slime/swank-cmucl.lisp
diff -u slime/swank-cmucl.lisp:1.24 slime/swank-cmucl.lisp:1.25
--- slime/swank-cmucl.lisp:1.24 Sun Nov 23 00:00:13 2003
+++ slime/swank-cmucl.lisp Sun Nov 23 07:14:04 2003
@@ -4,11 +4,12 @@
(in-package :swank)
+;; Turn on xref. [should we?]
+(setf c:*record-xref-info* t)
+
(defun without-interrupts* (body)
(sys:without-interrupts (funcall body)))
-;;; Setup and hooks.
-
(defun set-fd-non-blocking (fd)
(flet ((fcntl (fd cmd arg)
(multiple-value-bind (flags errno) (unix:unix-fcntl fd cmd arg)
@@ -17,10 +18,54 @@
(let ((flags (fcntl fd unix:F-GETFL 0)))
(fcntl fd unix:F-SETFL (logior flags unix:O_NONBLOCK)))))
-;; (set-fd-non-blocking (sys:fd-stream-fd sys:*stdin*))
-(setf c:*record-xref-info* t)
+
+;;;; TCP server.
+
+(defun create-swank-server (port &key reuse-address (address "localhost"))
+ "Create a SWANK TCP server."
+ (let* ((hostent (ext:lookup-host-entry address))
+ (address (car (ext:host-entry-addr-list hostent)))
+ (ip (ext:htonl address)))
+ (let ((fd (ext:create-inet-listener port :stream
+ :reuse-address reuse-address
+ :host ip)))
+ (system:add-fd-handler fd :input #'accept-connection)
+ (nth-value 1 (ext::get-socket-host-and-port fd)))))
+
+(defun accept-connection (socket)
+ "Accept one Swank TCP connection on SOCKET and then close it."
+ (setup-request-handler (ext:accept-tcp-connection socket))
+ (sys:invalidate-descriptor socket)
+ (unix:unix-close socket))
+
+(defun setup-request-handler (socket)
+ "Setup request handling for SOCKET."
+ (let* ((stream (sys:make-fd-stream socket
+ :input t :output t
+ :element-type 'base-char))
+ (input (make-slime-input-stream))
+ (output (make-slime-output-stream))
+ (io (make-two-way-stream input output)))
+ (system:add-fd-handler socket
+ :input (lambda (fd)
+ (declare (ignore fd))
+ (serve-request stream output input io)))))
-;;; TCP Server.
+(defun serve-request (*emacs-io* *slime-output* *slime-input* *slime-io*)
+ "Read and process a request from a SWANK client.
+The request is read from the socket as a sexp and then evaluated."
+ (catch 'slime-toplevel
+ (with-simple-restart (abort "Return to Slime toplevel.")
+ (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))
+
+
+;;;; Stream handling
(defstruct (slime-output-stream
(:include lisp::lisp-stream
@@ -107,58 +152,7 @@
(:element-type 'base-char)
(:close nil)))
-(defun create-swank-server (port &key reuse-address (address "localhost"))
- "Create a SWANK TCP server."
- (let* ((hostent (ext:lookup-host-entry address))
- (address (car (ext:host-entry-addr-list hostent)))
- (ip (ext:htonl address)))
- (let ((fd (ext:create-inet-listener port :stream
- :reuse-address reuse-address
- :host ip)))
- (system:add-fd-handler fd :input #'accept-connection)
- (nth-value 1 (ext::get-socket-host-and-port fd)))))
-
-(defun accept-connection (socket)
- "Accept one Swank TCP connection on SOCKET and then close it."
- (setup-request-handler (ext:accept-tcp-connection socket))
- (sys:invalidate-descriptor socket)
- (unix:unix-close socket))
-
-(defun setup-request-handler (socket)
- "Setup request handling for SOCKET."
- (let* ((stream (sys:make-fd-stream socket
- :input t :output t
- :element-type 'base-char))
- (input (make-slime-input-stream))
- (output (make-slime-output-stream))
- (io (make-two-way-stream input output)))
- (system:add-fd-handler socket
- :input (lambda (fd)
- (declare (ignore fd))
- (serve-request stream output input io)))))
-
-(defun serve-request (*emacs-io* *slime-output* *slime-input* *slime-io*)
- "Read and process a request from a SWANK client.
-The request is read from the socket as a sexp and then evaluated."
- (catch 'slime-toplevel
- (with-simple-restart (abort "Return to Slime toplevel.")
- (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))
-
-;;;
-
-(defslimefun set-default-directory (directory)
- (setf (ext:default-directory) (namestring directory))
- ;; Setting *default-pathname-defaults* to an absolute directory
- ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive.
- (setf *default-pathname-defaults* (pathname (ext:default-directory)))
- (namestring (ext:default-directory)))
-
+
;;;; Compilation Commands
(defvar *swank-source-info* nil
@@ -184,6 +178,7 @@
(defvar *compiler-notes* '()
"List of compiler notes for the last compilation unit.")
+
;;;;; Trapping notes
(defun handle-notification-condition (condition)
@@ -261,8 +256,8 @@
(source (eql nil)))
'(:null))
-;;(defun call-trapping-compilation-notes (fn)
(defmacro with-compilation-hooks (() &body body)
+ "Execute BODY and record the set of compiler notes."
`(let ((*previous-compiler-condition* nil)
(*previous-context* nil))
(handler-bind ((c::compiler-error #'handle-notification-condition)
@@ -291,65 +286,8 @@
:emacs-buffer-offset ,position
:emacs-buffer-string ,string))))))
-(defun clear-xref-info (namestring)
- "Clear XREF notes pertaining to FILENAME.
-This is a workaround for a CMUCL bug: XREF records are cumulative."
- (let ((filename (parse-namestring namestring)))
- (when c:*record-xref-info*
- (dolist (db (list xref::*who-calls*
- #+cmu19 xref::*who-is-called*
- #+cmu19 xref::*who-macroexpands*
- xref::*who-references*
- xref::*who-binds*
- xref::*who-sets*))
- (maphash (lambda (target contexts)
- (setf (gethash target db)
- (delete-if
- (lambda (ctx)
- (xref-context-derived-from-p ctx filename))
- contexts)))
- db)))))
-
-(defun xref-context-derived-from-p (context filename)
- (let ((xref-file (xref:xref-context-file context)))
- (and xref-file (pathname= filename xref-file))))
-
-(defun pathname= (&rest pathnames)
- "True if PATHNAMES refer to the same file."
- (apply #'string= (mapcar #'unix-truename pathnames)))
-
-(defun unix-truename (pathname)
- (ext:unix-namestring (truename pathname)))
-
-(defmethod arglist-string (fname)
- "Return a string describing the argument list for FNAME.
-The result has the format \"(...)\"."
- (declare (type string fname))
- (multiple-value-bind (function condition)
- (ignore-errors (values (find-symbol-designator fname *buffer-package*)))
- (when condition
- (return-from arglist-string (format nil "(-- ~A)" condition)))
- (let ((arglist
- (if (not (or (fboundp function)
- (functionp function)))
- "(-- <Unknown-Function>)"
- (let* ((fun (or (macro-function function)
- (symbol-function function)))
- (df (di::function-debug-function fun))
- (arglist (kernel:%function-arglist fun)))
- (cond ((eval:interpreted-function-p fun)
- (eval:interpreted-function-arglist fun))
- ((pcl::generic-function-p fun)
- (pcl::gf-pretty-arglist fun))
- (arglist arglist)
- ;; this should work both for
- ;; compiled-debug-function and for
- ;; interpreted-debug-function
- (df (di::debug-function-lambda-list df))
- (t "(<arglist-unavailable>)"))))))
- (if (stringp arglist)
- arglist
- (to-string arglist)))))
+
+;;;; XREF
(defslimefun who-calls (function-name)
"Return the places where FUNCTION-NAME is called."
@@ -410,6 +348,39 @@
(and (every #'< path1 path2)
(< (length path1) (length path2))))
+(defun clear-xref-info (namestring)
+ "Clear XREF notes pertaining to FILENAME.
+This is a workaround for a CMUCL bug: XREF records are cumulative."
+ (let ((filename (parse-namestring namestring)))
+ (when c:*record-xref-info*
+ (dolist (db (list xref::*who-calls*
+ #+cmu19 xref::*who-is-called*
+ #+cmu19 xref::*who-macroexpands*
+ xref::*who-references*
+ xref::*who-binds*
+ xref::*who-sets*))
+ (maphash (lambda (target contexts)
+ (setf (gethash target db)
+ (delete-if
+ (lambda (ctx)
+ (xref-context-derived-from-p ctx filename))
+ contexts)))
+ db)))))
+
+(defun xref-context-derived-from-p (context filename)
+ (let ((xref-file (xref:xref-context-file context)))
+ (and xref-file (pathname= filename xref-file))))
+
+(defun pathname= (&rest pathnames)
+ "True if PATHNAMES refer to the same file."
+ (apply #'string= (mapcar #'unix-truename pathnames)))
+
+(defun unix-truename (pathname)
+ (ext:unix-namestring (truename pathname)))
+
+
+;;;; Find callers and callees
+
;;; Find callers and callees by looking at the constant pool of
;;; compiled code objects. We assume every fdefn object in the
;;; constant pool corresponds to a call to that function. A better
@@ -573,7 +544,8 @@
(handler-case (funcall finder)
(error (e) (list :error (format nil "Error: ~A" e)))))))
-;;;
+
+;;;; Documentation.
(defmethod describe-symbol-for-emacs (symbol)
(let ((result '()))
@@ -652,14 +624,42 @@
(defslimefun describe-alien-enum (symbol-name)
(%describe-alien symbol-name :enum))
-;;; Macroexpansion
+(defmethod arglist-string (fname)
+ "Return a string describing the argument list for FNAME.
+The result has the format \"(...)\"."
+ (declare (type string fname))
+ (multiple-value-bind (function condition)
+ (ignore-errors (values (find-symbol-designator fname *buffer-package*)))
+ (when condition
+ (return-from arglist-string (format nil "(-- ~A)" condition)))
+ (let ((arglist
+ (if (not (or (fboundp function)
+ (functionp function)))
+ "(-- <Unknown-Function>)"
+ (let* ((fun (or (macro-function function)
+ (symbol-function function)))
+ (df (di::function-debug-function fun))
+ (arglist (kernel:%function-arglist fun)))
+ (cond ((eval:interpreted-function-p fun)
+ (eval:interpreted-function-arglist fun))
+ ((pcl::generic-function-p fun)
+ (pcl::gf-pretty-arglist fun))
+ (arglist arglist)
+ ;; this should work both for
+ ;; compiled-debug-function and for
+ ;; interpreted-debug-function
+ (df (di::debug-function-lambda-list df))
+ (t "(<arglist-unavailable>)"))))))
+ (if (stringp arglist)
+ arglist
+ (to-string arglist)))))
+
+
+;;;; Miscellaneous.
(defmethod macroexpand-all (form)
(walker:macroexpand-all form))
-
-;;;
-
(defun tracedp (fname)
(gethash (debug::trace-fdefinition fname)
debug::*traced-functions*))
@@ -672,26 +672,34 @@
(t
(debug::trace-1 fname (debug::make-trace-info))
(format nil "~S is now traced." fname)))))
+
+(defslimefun set-default-directory (directory)
+ (setf (ext:default-directory) (namestring directory))
+ ;; Setting *default-pathname-defaults* to an absolute directory
+ ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive.
+ (setf *default-pathname-defaults* (pathname (ext:default-directory)))
+ (namestring (ext:default-directory)))
+
-;;; Source-path business
+;;;; Source-paths
-;; CMUCL uses a data structure called "source-path" to locate
-;; subforms. The compiler assigns a source-path to each form in a
-;; compilation unit. Compiler notes usually contain the source-path
-;; of the error location.
-;;
-;; Compiled code objects don't contain source paths, only the
-;; "toplevel-form-number" and the (sub-) "form-number". To get from
-;; the form-number to the source-path we need the entire toplevel-form
-;; (i.e. we have to read the source code). CMUCL has already some
-;; utilities to do this translation, but we use some extended
-;; versions, because we need more exact position info. Apparently
-;; Hemlock is happy with the position of the toplevel-form; we also
-;; need the position of subforms.
-;;
-;; We use a special readtable to get the positions of the subforms.
-;; The readtable stores the start and end position for each subform in
-;; hashtable for later retrieval.
+;;; CMUCL uses a data structure called "source-path" to locate
+;;; subforms. The compiler assigns a source-path to each form in a
+;;; compilation unit. Compiler notes usually contain the source-path
+;;; of the error location.
+;;;
+;;; Compiled code objects don't contain source paths, only the
+;;; "toplevel-form-number" and the (sub-) "form-number". To get from
+;;; the form-number to the source-path we need the entire toplevel-form
+;;; (i.e. we have to read the source code). CMUCL has already some
+;;; utilities to do this translation, but we use some extended
+;;; versions, because we need more exact position info. Apparently
+;;; Hemlock is happy with the position of the toplevel-form; we also
+;;; need the position of subforms.
+;;;
+;;; We use a special readtable to get the positions of the subforms.
+;;; The readtable stores the start and end position for each subform in
+;;; hashtable for later retrieval.
(defun make-source-recorder (fn source-map)
"Return a macro character function that does the same as FN, but
@@ -835,40 +843,30 @@
(handler-case (source-location-for-emacs code-location)
(t (c) (list :error (debug::safe-condition-message c)))))
+(defslimefun getpid ()
+ (unix:unix-getpid))
+
-;;; Debugging
+;;;; Debugging
-(defvar *sldb-level* 0)
(defvar *sldb-stack-top*)
(defvar *sldb-restarts*)
-(defslimefun getpid ()
- (unix:unix-getpid))
-
-(defslimefun sldb-loop ()
+(defmethod call-with-debugging-environment (debugger-loop-fn)
(unix:unix-sigsetmask 0)
- (let* ((*sldb-level* (1+ *sldb-level*))
- (*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame)))
+ (let* ((*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame)))
(*sldb-restarts* (compute-restarts *swank-debugger-condition*))
(debug:*stack-top-hint* nil)
(*debugger-hook* nil)
- (level *sldb-level*)
- (*package* *buffer-package*)
(*readtable* (or debug:*debug-readtable* *readtable*))
(*print-level* debug:*debug-print-level*)
(*print-length* debug:*debug-print-length*))
- (send-to-emacs (list* :debug *sldb-level* (debugger-info-for-emacs 0 1)))
(handler-bind ((di:debug-condition
(lambda (condition)
- (send-to-emacs `(:debug-condition
- ,(princ-to-string condition)))
- (throw 'sldb-loop-catcher nil))))
- (unwind-protect
- (loop
- (catch 'sldb-loop-catcher
- (with-simple-restart (abort "Return to sldb level ~D." level)
- (read-from-emacs))))
- (send-to-emacs `(:debug-return ,level))))))
+ (signal (make-condition
+ 'sldb-condition
+ :original-condition condition)))))
+ (funcall debugger-loop-fn))))
(defun format-restarts-for-emacs ()
"Return a list of restarts for *swank-debugger-condition* in a
@@ -909,7 +907,7 @@
(defslimefun backtrace-for-emacs (start end)
(mapcar #'format-frame-for-emacs (compute-backtrace start end)))
-(defslimefun debugger-info-for-emacs (start end)
+(defmethod debugger-info-for-emacs (start end)
(list (format-condition-for-emacs)
(format-restarts-for-emacs)
(backtrace-for-emacs start end)))
@@ -955,7 +953,7 @@
(invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
-;;; Inspecting
+;;;; Inspecting
(defvar *inspectee*)
(defvar *inspectee-parts*)
More information about the slime-cvs
mailing list