[slime-cvs] CVS update: slime/swank-backend.lisp slime/swank-sbcl.lisp slime/swank-openmcl.lisp slime/swank-lispworks.lisp slime/swank-clisp.lisp
Helmut Eller
heller at common-lisp.net
Sun Jan 18 07:15:49 UTC 2004
Update of /project/slime/cvsroot/slime
In directory common-lisp.net:/tmp/cvs-serv17429
Modified Files:
swank-backend.lisp swank-sbcl.lisp swank-openmcl.lisp
swank-lispworks.lisp swank-clisp.lisp
Log Message:
(arglist-string): Refactor common code to swank.lisp.
(call-without-interrupts, getpid): Are now generic functions.
Date: Sun Jan 18 02:15:49 2004
Author: heller
Index: slime/swank-backend.lisp
diff -u slime/swank-backend.lisp:1.19 slime/swank-backend.lisp:1.20
--- slime/swank-backend.lisp:1.19 Fri Jan 16 16:49:29 2004
+++ slime/swank-backend.lisp Sun Jan 18 02:15:49 2004
@@ -132,6 +132,17 @@
nil)
+;;;; Unix signals
+
+(defconstant +sigint+ 2)
+
+(defgeneric call-without-interrupts (fn)
+ (:documentation "Call FN in a context where interrupts are disabled."))
+
+(defgeneric getpid ()
+ (:documentation "Return the (Unix) process ID of this superior Lisp."))
+
+
;;;; Compilation
(defgeneric call-with-compilation-hooks (func)
Index: slime/swank-sbcl.lisp
diff -u slime/swank-sbcl.lisp:1.51 slime/swank-sbcl.lisp:1.52
--- slime/swank-sbcl.lisp:1.51 Thu Jan 15 13:31:04 2004
+++ slime/swank-sbcl.lisp Sun Jan 18 02:15:49 2004
@@ -56,9 +56,6 @@
sb-gray:stream-line-column
sb-gray:stream-line-length))
-(defun without-interrupts* (body)
- (sb-sys:without-interrupts (funcall body)))
-
;;; TCP Server
(setq *swank-in-background* :fd-handler)
@@ -117,6 +114,12 @@
:output-stream output)))
(values input output)))
+(defmethod call-without-interrupts (fn)
+ (sb-sys:without-interrupts (funcall fn)))
+
+(defmethod getpid ()
+ (sb-unix:unix-getpid))
+
;;; Utilities
(defvar *swank-debugger-stack-frame*)
@@ -127,17 +130,7 @@
(namestring *default-pathname-defaults*))
(defmethod arglist-string (fname)
- (let ((*print-case* :downcase))
- (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
- (ignore-errors (sb-introspect:function-arglist function))))
- (if arglist
- (princ-to-string arglist)
- "(-- <Unknown-Function>)")))))
+ (format-arglist fname #'sb-introspect:function-arglist))
(defvar *buffer-name* nil)
(defvar *buffer-offset*)
@@ -384,12 +377,6 @@
(defmethod macroexpand-all (form)
(let ((sb-walker:*walk-form-expand-macros-p* t))
(sb-walker:walk-form form)))
-
-
-;;;
-
-(defslimefun getpid ()
- (sb-unix:unix-getpid))
;;; Debugging
Index: slime/swank-openmcl.lisp
diff -u slime/swank-openmcl.lisp:1.49 slime/swank-openmcl.lisp:1.50
--- slime/swank-openmcl.lisp:1.49 Fri Jan 16 16:49:29 2004
+++ slime/swank-openmcl.lisp Sun Jan 18 02:15:49 2004
@@ -65,9 +65,6 @@
ccl:stream-line-column
ccl:stream-line-length))
-(defun without-interrupts* (body)
- (ccl:without-interrupts (funcall body)))
-
(defvar *swank-debugger-stack-frame* nil)
;;; TCP Server
@@ -92,7 +89,13 @@
(defmethod emacs-connected ()
(setq ccl::*interactive-abort-process* ccl::*current-process*))
-;;;
+;;; Unix signals
+
+(defmethod call-without-interrupts (fn)
+ (ccl:without-interrupts (funcall fn)))
+
+(defmethod getpid ()
+ (ccl::getpid))
(let ((ccl::*warn-if-redefine-kernel* nil))
(defun ccl::force-break-in-listener (p)
@@ -151,16 +154,7 @@
(setq *swank-debugger-stack-frame* error-pointer))
(defmethod arglist-string (fname)
- (let ((*print-case* :downcase))
- (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 (ccl:arglist function)))
- (if arglist
- (princ-to-string arglist)
- "(-- <Unknown-Function>)")))))
+ (format-arglist fname #'ccl:arglist))
;;; Compilation
@@ -213,10 +207,6 @@
(let ((binary-filename (compile-file filename :load t)))
(delete-file binary-filename)))
(delete-file filename))))
-
-(defslimefun getpid ()
- "Return the process ID of this superior Lisp."
- (ccl::getpid))
;;; Debugging
Index: slime/swank-lispworks.lisp
diff -u slime/swank-lispworks.lisp:1.14 slime/swank-lispworks.lisp:1.15
--- slime/swank-lispworks.lisp:1.14 Tue Jan 13 17:51:56 2004
+++ slime/swank-lispworks.lisp Sun Jan 18 02:15:49 2004
@@ -7,7 +7,7 @@
;;; This code has been placed in the Public Domain. All warranties
;;; are disclaimed.
;;;
-;;; $Id: swank-lispworks.lisp,v 1.14 2004/01/13 22:51:56 heller Exp $
+;;; $Id: swank-lispworks.lisp,v 1.15 2004/01/18 07:15:49 heller Exp $
;;;
(in-package :swank)
@@ -27,11 +27,6 @@
stream:stream-line-column
))
-(defun without-interrupts* (body)
- (lispworks:without-interrupts (funcall body)))
-
-(defconstant +sigint+ 2)
-
;;; TCP server
(defun socket-fd (socket)
@@ -68,29 +63,22 @@
;; Set SIGINT handler on Swank request handler thread.
(sys:set-signal-handler +sigint+ #'sigint-handler))
+;;; Unix signals
+
(defun sigint-handler (&rest args)
(declare (ignore args))
(invoke-debugger "SIGINT"))
-;;;
+(defmethod call-without-interrupts (fn)
+ (lispworks:without-interrupts (funcall fn)))
-(defslimefun getpid ()
- "Return the process ID of this superior Lisp."
+(defmethod getpid ()
(system::getpid))
+;;;
+
(defmethod arglist-string (fname)
- "Return the lambda list for function FNAME as a string."
- (let ((*print-case* :downcase))
- (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 (and (fboundp function)
- (lispworks:function-lambda-list function))))
- (if arglist
- (princ-to-string arglist)
- "(-- <Unknown-Function>)")))))
+ (format-arglist fname #'lw:function-lambda-list))
(defmethod macroexpand-all (form)
(walker:walk-form form))
Index: slime/swank-clisp.lisp
diff -u slime/swank-clisp.lisp:1.11 slime/swank-clisp.lisp:1.12
--- slime/swank-clisp.lisp:1.11 Sun Jan 18 00:47:39 2004
+++ slime/swank-clisp.lisp Sun Jan 18 02:15:49 2004
@@ -43,18 +43,15 @@
(linux:sigprocmask-set ,linux:SIG_SETMASK ,mask nil)))))
#+linux
-(defmacro without-interrupts (&body body)
- `(with-blocked-signals (,linux:SIGINT) , at body))
+(defmethod call-without-interrupts (fn)
+ (with-blocked-signals (linux:SIGINT) (funcall fn)))
#-linux
-(defmacro without-interrupts (&body body)
- `(progn , at body))
+(defmethod call-without-interrupts (fn)
+ (funcall fn))
-(defun without-interrupts* (fun)
- (without-interrupts (funcall fun)))
-
-#+unix (defslimefun getpid () (system::program-id))
-#+win32 (defslimefun getpid () (or (system::getenv "PID") -1))
+#+unix (defmethod getpid () (system::program-id))
+#+win32 (defmethod getpid () (or (system::getenv "PID") -1))
;; the above is likely broken; we need windows NT users!
@@ -80,15 +77,7 @@
;;; Swank functions
(defmethod arglist-string (fname)
- (declare (type string fname))
- (multiple-value-bind (function condition)
- (ignore-errors (values (from-string fname)))
- (when condition
- (return-from arglist-string (format nil "(-- ~A)" condition)))
- (multiple-value-bind (arglist condition)
- (ignore-errors (values (ext:arglist function)))
- (cond (condition (format nil "(-- ~A)" condition))
- (t (format nil "(~{~A~^ ~})" arglist))))))
+ (format-arglist fname #'ext:arglist))
(defmethod macroexpand-all (form)
(ext:expand-form form))
More information about the slime-cvs
mailing list