[slime-cvs] CVS slime
heller
heller at common-lisp.net
Thu Aug 10 11:53:36 UTC 2006
Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv12591
Modified Files:
swank-backend.lisp swank-cmucl.lisp swank-sbcl.lisp
swank-clisp.lisp swank-lispworks.lisp swank-corman.lisp
swank-scl.lisp swank-abcl.lisp swank-ecl.lisp swank.lisp
Log Message:
swank-backend.lisp (definterface): Drop that incredibly unportable
CLOS stuff. Use plists and plain functions instead. Update backends
accordingly.
--- /project/slime/cvsroot/slime/swank-backend.lisp 2006/08/09 17:08:01 1.100
+++ /project/slime/cvsroot/slime/swank-backend.lisp 2006/08/10 11:53:35 1.101
@@ -112,24 +112,47 @@
Backends implement these functions using DEFIMPLEMENTATION."
(check-type documentation string "a documentation string")
- (flet ((gen-default-impl ()
- `(defmethod no-applicable-method ((_gf (eql #',name)) &rest _rargs)
- (declare (ignore _gf))
- (destructuring-bind ,args _rargs
- , at default-body))))
- `(progn (defgeneric ,name ,args (:documentation ,documentation))
- (pushnew ',name *interface-functions*)
- ,(if (null default-body)
- `(pushnew ',name *unimplemented-interfaces*)
- (gen-default-impl))
- ;; see <http://www.franz.com/support/documentation/6.2/doc/pages/variables/compiler/s_cltl1-compile-file-toplevel-compatibility-p_s.htm>
- (eval-when (:compile-toplevel :load-toplevel :execute)
- (export ',name :swank-backend))
- ',name)))
+ (assert (every #'symbolp args) ()
+ "Complex lambda-list not supported: ~S ~S" name args)
+ (labels ((gen-default-impl ()
+ `(setf (get ',name 'default) (lambda ,args , at default-body)))
+ (args-as-list (args)
+ (destructuring-bind (req opt key rest) (parse-lambda-list args)
+ `(, at req , at opt
+ ,@(loop for k in key append `(,(kw k) ,k))
+ ,@(or rest '(())))))
+ (parse-lambda-list (args)
+ (parse args '(&optional &key &rest)
+ (make-array 4 :initial-element nil)))
+ (parse (args keywords vars)
+ (cond ((null args)
+ (reverse (map 'list #'reverse vars)))
+ ((member (car args) keywords)
+ (parse (cdr args) (cdr (member (car args) keywords)) vars))
+ (t (push (car args) (aref vars (length keywords)))
+ (parse (cdr args) keywords vars))))
+ (kw (s) (intern (string s) :keyword)))
+ `(progn
+ (defun ,name ,args
+ ,documentation
+ (let ((f (or (get ',name 'implementation)
+ (get ',name 'default))))
+ (cond (f (apply f ,@(args-as-list args)))
+ (t (error "~S not implementated" ',name)))))
+ (pushnew ',name *interface-functions*)
+ ,(if (null default-body)
+ `(pushnew ',name *unimplemented-interfaces*)
+ (gen-default-impl))
+ ;; see <http://www.franz.com/support/documentation/6.2/doc/pages/variables/compiler/s_cltl1-compile-file-toplevel-compatibility-p_s.htm>
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (export ',name :swank-backend))
+ ',name)))
(defmacro defimplementation (name args &body body)
+ (assert (every #'symbolp args) ()
+ "Complex lambda-list not supported: ~S ~S" name args)
`(progn
- (defmethod ,name ,args , at body)
+ (setf (get ',name 'implementation) (lambda ,args , at body))
(if (member ',name *interface-functions*)
(setq *unimplemented-interfaces*
(remove ',name *unimplemented-interfaces*))
--- /project/slime/cvsroot/slime/swank-cmucl.lisp 2006/08/09 17:01:13 1.161
+++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2006/08/10 11:53:35 1.162
@@ -98,16 +98,16 @@
(sys:invalidate-descriptor fd)
(ext:close-socket fd)))
-(defimplementation accept-connection (socket &key
- (external-format :iso-latin-1-unix)
- (buffering :full)
- timeout)
+(defimplementation accept-connection (socket &key
+ external-format buffering timeout)
(declare (ignore timeout))
- (unless (eq external-format ':iso-latin-1-unix)
- (remove-fd-handlers socket)
- (remove-sigio-handlers socket)
- (assert (eq external-format ':iso-latin-1-unix)))
- (make-socket-io-stream (ext:accept-tcp-connection socket) buffering))
+ (let ((ef (or external-format :iso-latin-1-unix))
+ (buffering (or buffering :full)))
+ (unless (eq ef ':iso-latin-1-unix)
+ (remove-fd-handlers socket)
+ (remove-sigio-handlers socket)
+ (error "External format ~S not supported" ef))
+ (make-socket-io-stream (ext:accept-tcp-connection socket) buffering)))
;;;;; Sockets
@@ -1276,18 +1276,15 @@
(list symbol))))
((:defined)
(ext:info :alien-type :definition symbol))
- (:unknown
- (return-from describe-definition
- (format nil "Unknown alien type: ~S" symbol))))))))
+ (:unknown :unkown))))))
;;;;; Argument lists
-(defimplementation arglist ((name symbol))
- (arglist (or (macro-function name)
- (symbol-function name))))
-
-(defimplementation arglist ((fun function))
- (function-arglist fun))
+(defimplementation arglist (fun)
+ (etypecase fun
+ (function (function-arglist fun))
+ (symbol (function-arglist (or (macro-function fun)
+ (symbol-function fun))))))
(defun function-arglist (fun)
(let ((arglist
@@ -1708,9 +1705,12 @@
(values :initarg :values :reader breakpoint.values))
(:report (lambda (c stream) (princ (breakpoint.message c) stream))))
-(defimplementation condition-extras ((c breakpoint))
- ;; simply pop up the source buffer
- `((:short-frame-source 0)))
+(defimplementation condition-extras (condition)
+ (typecase condition
+ (breakpoint
+ ;; pop up the source buffer
+ `((:short-frame-source 0)))
+ (t '())))
(defun signal-breakpoint (breakpoint frame)
"Signal a breakpoint condition for BREAKPOINT in FRAME.
@@ -2050,8 +2050,8 @@
;; available again.
(mp::startup-idle-and-top-level-loops))
- (defimplementation spawn (fn &key (name "Anonymous"))
- (mp:make-process fn :name name))
+ (defimplementation spawn (fn &key name)
+ (mp:make-process fn :name (or name "Anonymous")))
(defvar *thread-id-counter* 0)
--- /project/slime/cvsroot/slime/swank-sbcl.lisp 2006/07/15 11:03:29 1.159
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2006/08/10 11:53:35 1.160
@@ -60,10 +60,12 @@
(sb-bsd-sockets:socket-close socket))
(defimplementation accept-connection (socket &key
- (external-format :iso-latin-1-unix)
- (buffering :full) timeout)
+ external-format
+ buffering timeout)
(declare (ignore timeout))
- (make-socket-io-stream (accept socket) external-format buffering))
+ (make-socket-io-stream (accept socket)
+ (or external-format :iso-latin-1-unix)
+ (or buffering :full)))
(defvar *sigio-handlers* '()
"List of (key . fn) pairs to be called on SIGIO.")
@@ -135,7 +137,7 @@
(return (sb-bsd-sockets:socket-accept socket))
(sb-bsd-sockets:interrupted-error ()))))
-(defmethod call-without-interrupts (fn)
+(defimplementation call-without-interrupts (fn)
(declare (type function fn))
(sb-sys:without-interrupts (funcall fn)))
@@ -234,10 +236,11 @@
;;; Utilities
-(defimplementation arglist ((fname t))
+(defimplementation arglist (fname)
(sb-introspect:function-arglist fname))
-(defimplementation function-name ((f function))
+(defimplementation function-name (f)
+ (check-type f function)
(sb-impl::%fun-name f))
(defvar *buffer-name* nil)
@@ -934,23 +937,22 @@
(defimplementation spawn (fn &key name)
(sb-thread:make-thread fn :name name))
- (defimplementation startup-multiprocessing ())
-
(defimplementation thread-id (thread)
- (sb-thread:with-mutex (*thread-id-map-lock*)
- (loop for id being the hash-key in *thread-id-map*
- using (hash-value thread-pointer)
- do
- (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
- (cond ((null maybe-thread)
- ;; the value is gc'd, remove it manually
- (remhash id *thread-id-map*))
- ((eq thread maybe-thread)
- (return-from thread-id id)))))
- ;; lazy numbering
- (let ((id (next-thread-id)))
- (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread))
- id)))
+ (block thread-id
+ (sb-thread:with-mutex (*thread-id-map-lock*)
+ (loop for id being the hash-key in *thread-id-map*
+ using (hash-value thread-pointer)
+ do
+ (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
+ (cond ((null maybe-thread)
+ ;; the value is gc'd, remove it manually
+ (remhash id *thread-id-map*))
+ ((eq thread maybe-thread)
+ (return-from thread-id id)))))
+ ;; lazy numbering
+ (let ((id (next-thread-id)))
+ (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread))
+ id))))
(defimplementation find-thread (id)
(sb-thread:with-mutex (*thread-id-map-lock*)
@@ -1040,7 +1042,7 @@
mutex))))))))
- ;;; Auto-flush streams
+;;; Auto-flush streams
;; XXX race conditions
(defvar *auto-flush-streams* '())
--- /project/slime/cvsroot/slime/swank-clisp.lisp 2006/03/22 16:40:01 1.58
+++ /project/slime/cvsroot/slime/swank-clisp.lisp 2006/08/10 11:53:35 1.59
@@ -125,9 +125,9 @@
(ext:make-encoding :charset charset :line-terminator :unix)))
(defimplementation accept-connection (socket
- &key (external-format :iso-latin-1-unix)
- buffering timeout)
+ &key external-format buffering timeout)
(declare (ignore buffering timeout))
+ (setq external-format (or external-format :iso-latin-1-unix))
(socket:socket-accept socket
:buffered nil ;; XXX should be t
:element-type 'character
@@ -239,7 +239,7 @@
(let* (;;(sys::*break-count* (1+ sys::*break-count*))
;;(sys::*driver* debugger-loop-fn)
;;(sys::*fasoutput-stream* nil)
- (*sldb-backtrace* (nthcdr 6 (sldb-backtrace))))
+ (*sldb-backtrace* (nthcdr 5 (sldb-backtrace))))
(funcall debugger-loop-fn)))
(defun nth-frame (index)
@@ -363,11 +363,9 @@
(sys::redo-eval-frame (car (nth-frame index))))
(defimplementation frame-source-location-for-emacs (index)
- (let ((f (car (nth-frame index))))
- (list :error (format nil "Cannot find source for frame: ~A ~A ~A"
- f
- (sys::eval-frame-p f)
- (sys::the-frame)))))
+ `(:error
+ ,(format nil "frame-source-location not implemented. (frame: ~A)"
+ (car (nth-frame index)))))
;;; Profiling
--- /project/slime/cvsroot/slime/swank-lispworks.lisp 2006/08/09 16:55:48 1.84
+++ /project/slime/cvsroot/slime/swank-lispworks.lisp 2006/08/10 11:53:35 1.85
@@ -66,10 +66,9 @@
(comm::close-socket (socket-fd socket)))
(defimplementation accept-connection (socket
- &key (external-format :iso-latin-1-unix)
- buffering timeout)
+ &key external-format buffering timeout)
(declare (ignore buffering timeout))
- (assert (eq external-format :iso-latin-1-unix))
+ (assert (member external-format '(nil :iso-latin-1-unix)))
(let* ((fd (comm::get-fd-from-socket socket)))
(assert (/= fd -1))
(make-instance 'comm:socket-stream :socket fd :direction :io
--- /project/slime/cvsroot/slime/swank-corman.lisp 2006/08/09 17:01:13 1.8
+++ /project/slime/cvsroot/slime/swank-corman.lisp 2006/08/10 11:53:35 1.9
@@ -238,10 +238,9 @@
(close socket))
(defimplementation accept-connection (socket
- &key (external-format :iso-latin-1-unix)
- buffering timeout)
+ &key external-format buffering timeout)
(declare (ignore buffering timeout))
- (ecase external-format
+ (ecase (or external-format :iso-latin-1-unix)
(:iso-latin-1-unix
(sockets:make-socket-stream (sockets:accept-socket socket)))))
--- /project/slime/cvsroot/slime/swank-scl.lisp 2006/08/09 17:01:13 1.9
+++ /project/slime/cvsroot/slime/swank-scl.lisp 2006/08/10 11:53:35 1.10
@@ -36,11 +36,10 @@
(defimplementation close-socket (socket)
(ext:close-socket (socket-fd socket)))
-(defimplementation accept-connection (socket &key
- (external-format :iso-latin-1-unix)
- (buffering :full)
- (timeout nil))
+(defimplementation accept-connection (socket
+ &key external-format buffering timeout)
(let ((external-format (or external-format :iso-latin-1-unix))
+ (buffering (or buffering :full))
(fd (socket-fd socket)))
(loop
(let ((ready (sys:wait-until-fd-usable fd :input timeout)))
@@ -1168,21 +1167,19 @@
(list symbol))))
((:defined)
(ext:info :alien-type :definition symbol))
- (:unknown
- (return-from describe-definition
- (format nil "Unknown alien type: ~S" symbol))))))))
+ (:unknown :unknown))))))
;;;;; Argument lists
-(defimplementation arglist ((name symbol))
- (cond ((and (symbolp name) (macro-function name))
- (arglist (macro-function name)))
- ((fboundp name)
- (arglist (fdefinition name)))
+(defimplementation arglist (fun)
+ (cond ((and (symbolp fun) (macro-function fun))
+ (arglist (macro-function fun)))
+ ((fboundp fun)
+ (function-arglist (fdefinition fun)))
(t
:not-available)))
-(defimplementation arglist ((fun function))
+(defun function-arglist (fun function)
(flet ((compiled-function-arglist (x)
(let ((args (kernel:%function-arglist x)))
(if args
@@ -1588,6 +1585,7 @@
(values :initarg :values :reader breakpoint.values))
(:report (lambda (c stream) (princ (breakpoint.message c) stream))))
+#+nil
(defimplementation condition-extras ((c breakpoint))
;; simply pop up the source buffer
`((:short-frame-source 0)))
@@ -1933,10 +1931,11 @@
(incf *thread-id-counter*)))))
(defimplementation find-thread (id)
- (thread:map-over-threads
- #'(lambda (thread)
- (when (eql (getf (thread:thread-plist thread) 'id) id)
- (return-from find-thread thread)))))
+ (block find-thread
+ (thread:map-over-threads
+ #'(lambda (thread)
+ (when (eql (getf (thread:thread-plist thread) 'id) id)
+ (return-from find-thread thread))))))
(defimplementation thread-name (thread)
(princ-to-string (thread:thread-name thread)))
--- /project/slime/cvsroot/slime/swank-abcl.lisp 2006/08/09 17:01:13 1.39
+++ /project/slime/cvsroot/slime/swank-abcl.lisp 2006/08/10 11:53:35 1.40
@@ -134,9 +134,9 @@
(ext:server-socket-close socket))
(defimplementation accept-connection (socket
- &key (external-format :iso-latin-1-unix) buffering timeout)
+ &key external-format buffering timeout)
(declare (ignore buffering timeout))
- (assert (eq external-format :iso-latin-1-unix))
+ (assert (member external-format '(nil :iso-latin-1-unix)))
(ext:get-socket-stream (ext:socket-accept socket)))
;;;; Unix signals
@@ -159,12 +159,11 @@
;;;; Misc
-
-(defimplementation arglist ((symbol t))
- (multiple-value-bind (arglist present)
- (sys::arglist symbol)
- (if present arglist :not-available)))
-
+(defimplementation arglist (fun)
+ (cond ((symbolp fun)
+ (multiple-value-bind (arglist present) (sys::arglist fun)
+ (if present arglist :not-available)))
+ (t :not-available)))
(defimplementation function-name (function)
(nth-value 2 (function-lambda-expression function)))
--- /project/slime/cvsroot/slime/swank-ecl.lisp 2006/03/22 16:40:01 1.5
+++ /project/slime/cvsroot/slime/swank-ecl.lisp 2006/08/10 11:53:35 1.6
@@ -15,11 +15,6 @@
:specializer-direct-methods
:compute-applicable-methods-using-classes))
-#+nil
-(ffi:clines "
-#include <unistd.h>
-#include <sys/types.h>")
-
;;;; TCP Server
@@ -45,7 +40,7 @@
(sb-bsd-sockets:socket-close socket))
(defimplementation accept-connection (socket
- &key (external-format :iso-latin-1-unix)
+ &key external-format
buffering timeout)
(declare (ignore buffering timeout))
(assert (eq external-format :iso-latin-1-unix))
@@ -166,7 +161,7 @@
(t :not-available)))))
:not-available))
-(defimplementation function-name ((f function))
+(defimplementation function-name (f)
(si:compiled-function-name f))
(defimplementation macroexpand-all (form)
--- /project/slime/cvsroot/slime/swank.lisp 2006/08/09 16:46:10 1.388
+++ /project/slime/cvsroot/slime/swank.lisp 2006/08/10 11:53:35 1.389
@@ -1457,7 +1457,7 @@
(let ((index 0)
(need-space nil))
(labels ((print-arg (arg)
- (etypecase arg
+ (typecase arg
(arglist ; destructuring pattern
(print-arglist arg))
(optional-arg
@@ -2236,9 +2236,8 @@
(let* ((p (find-package :swank))
(actual (arglist-to-string list p)))
(unless (string= actual string)
- (format *debug-io*
- "Test failed: ~S => ~S~% Expected: ~S"
- list actual string)))))
+ (warn "Test failed: ~S => ~S~% Expected: ~S"
+ list actual string)))))
(test '(function cons) "(function cons)")
(test '(quote cons) "(quote cons)")
(test '(&key (function #'+)) "(&key (function #'+))")
@@ -3422,7 +3421,7 @@
Once a word has been completely matched, the chunks are pushed
onto the special variable *ALL-CHUNKS* and the function returns."
- (declare (optimize speed)
+ (declare ;;(optimize speed)
(fixnum short-index initial-full-index)
(simple-string short full)
(special *all-chunks*))
More information about the slime-cvs
mailing list