[slime-cvs] CVS slime
dcrosher
dcrosher at common-lisp.net
Tue Sep 23 04:57:52 UTC 2008
Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv20249
Modified Files:
ChangeLog swank-scl.lisp swank.lisp
Log Message:
* Update for the Scieneer CL 1.3.8 release.
--- /project/slime/cvsroot/slime/ChangeLog 2008/09/22 22:56:18 1.1539
+++ /project/slime/cvsroot/slime/ChangeLog 2008/09/23 04:57:51 1.1540
@@ -1,3 +1,11 @@
+2008-09-23 Douglas Crosher <dcrosher at common-lisp.net>
+
+ * swank-scl.lisp: update for Scieneer CL 1.3.8.
+
+ * swank.lisp (ed-in-emacs): customize for the SCL.
+
+ * swank.lisp (signal-interrupt): fix typo.
+
2008-09-22 Nikodemus Siivola <nikodemus at random-state.net>
* swank.lisp (guess-package): Return NIL if string designator is
--- /project/slime/cvsroot/slime/swank-scl.lisp 2008/09/17 06:19:49 1.25
+++ /project/slime/cvsroot/slime/swank-scl.lisp 2008/09/23 04:57:51 1.26
@@ -217,6 +217,9 @@
(defclass slime-output-stream (ext:character-output-stream)
((output-fn :initarg :output-fn :type function)
+ (output-buffer :initarg :output-buffer :type simple-string)
+ (buffer-tail :initarg :buffer-tail :initform 0 :type kernel:index)
+ (last-write :initarg :last-write)
(column :initform 0 :type kernel:index)
(interactive :initform nil :type (member nil t))
(position :initform 0 :type integer)))
@@ -225,8 +228,11 @@
(declare (function output-fn))
(make-instance 'slime-output-stream
:in-buffer ""
- :out-buffer (make-string 256)
- :output-fn output-fn))
+ :out-buffer ""
+ :output-buffer (make-string 256)
+ :output-fn output-fn
+ :last-write (get-internal-real-time)
+ ))
(defmethod print-object ((s slime-output-stream) stream)
(print-unreadable-object (s stream :type t)))
@@ -241,18 +247,31 @@
(unless abort
(finish-output stream))
(setf (ext:stream-open-p stream) nil)
- (setf (ext:stream-out-buffer stream) " ")
+ (setf (slot-value stream 'output-buffer) "")
t))
;;; No 'stream-clear-input method.
(defmethod ext:stream-finish-output ((stream slime-output-stream))
+ (let ((buffer-tail (slot-value stream 'buffer-tail)))
+ (declare (type kernel:index buffer-tail))
+ (when (> buffer-tail 0)
+ (let ((output-fn (slot-value stream 'output-fn))
+ (output-buffer (slot-value stream 'output-buffer)))
+ (declare (function output-fn)
+ (simple-string output-buffer))
+ (funcall output-fn (subseq output-buffer 0 buffer-tail))
+ (setf (slot-value stream 'buffer-tail) 0))
+ (setf (slot-value stream 'last-write) (get-internal-real-time))))
nil)
(defmethod ext:stream-force-output ((stream slime-output-stream))
+ (ext:stream-finish-output stream)
nil)
(defmethod ext:stream-clear-output ((stream slime-output-stream))
+ (decf (slot-value stream 'position) (slot-value stream 'buffer-tail))
+ (setf (slot-value stream 'buffer-tail) 0)
nil)
;;; Use default 'stream-element-type method for 'character-stream which
@@ -280,12 +299,14 @@
(cond ((= target-position current-position)
t)
((> target-position current-position)
+ (ext:stream-finish-output stream)
(let ((output-fn (slot-value stream 'output-fn))
(fill-size (- target-position current-position)))
(declare (function output-fn))
(funcall output-fn (make-string fill-size
:initial-element #\space))
(setf (slot-value stream 'position) target-position))
+ (setf (slot-value stream 'last-write) (get-internal-real-time))
t)
(t
nil))))
@@ -297,12 +318,58 @@
;;; Use the default 'character-output-stream 'file-string-length method.
-;;; stream-write-chars
+;;; stream-write-char -- internal
;;;
-;;; The stream out-buffer is typically large enough that there is little point
-;;; growing the stream output 'string large than the total size. For typical
-;;; usage this reduces consing. As the string grows larger then grow to
-;;; reduce the cost of copying strings around.
+(defmethod ext:stream-write-char ((stream slime-output-stream) character)
+ (declare (type character character)
+ (optimize (speed 3)))
+ (unless (ext:stream-open-p stream)
+ (error 'kernel:simple-stream-error
+ :stream stream
+ :format-control "Stream closed."))
+ ;;
+ ;; Fill the output buffer.
+ (let* ((buffer-tail (slot-value stream 'buffer-tail))
+ (output-buffer (slot-value stream 'output-buffer))
+ (buffer-length (length output-buffer)))
+ (declare (type kernel:index buffer-tail)
+ (simple-string output-buffer))
+ (when (>= buffer-tail buffer-length)
+ ;; Flush the output buffer to make room.
+ (let ((output-fn (slot-value stream 'output-fn)))
+ (declare (function output-fn))
+ (funcall output-fn output-buffer)
+ (setf buffer-tail 0)
+ (setf (slot-value stream 'last-write) (get-internal-real-time))))
+ (setf (aref output-buffer buffer-tail) character)
+ (incf buffer-tail)
+ (setf (slot-value stream 'buffer-tail) buffer-tail)
+ ;;
+ (let ((newline (char= character #\newline)))
+ (when (or newline
+ (let ((last-write (slot-value stream 'last-write)))
+ (declare (type integer last-write))
+ (> (get-internal-real-time)
+ (+ last-write (* 5 internal-time-units-per-second)))))
+ ;; Flush the output buffer.
+ (let ((output-fn (slot-value stream 'output-fn)))
+ (declare (function output-fn))
+ (funcall output-fn (subseq output-buffer 0 buffer-tail))
+ (setf buffer-tail 0)
+ (setf (slot-value stream 'buffer-tail) buffer-tail)
+ (setf (slot-value stream 'last-write) (get-internal-real-time))))
+ ;;
+ (setf (slot-value stream 'column)
+ (if newline
+ 0
+ (let ((line-column (slot-value stream 'column)))
+ (declare (type kernel:index line-column))
+ (+ line-column 1))))
+ (incf (slot-value stream 'position))
+ ))
+ character)
+
+;;; stream-write-chars
;;;
(defmethod ext:stream-write-chars ((stream slime-output-stream)
string start end waitp)
@@ -334,7 +401,8 @@
(- end last-newline 1)
(let ((column (slot-value stream 'column)))
(declare (type kernel:index column))
- (+ column (- end start))))))))
+ (+ column (- end start))))))
+ (incf (slot-value stream 'position) length)))
(- end start))
;;;
@@ -1163,35 +1231,9 @@
;;;;; Argument lists
(defimplementation arglist (fun)
- (etypecase fun
- (function (function-arglist fun))
- (symbol (function-arglist (or (macro-function fun)
- (symbol-function fun))))))
-
-(defun function-arglist (fun)
- (flet ((compiled-function-arglist (x)
- (let ((args (kernel:%function-arglist x)))
- (if args
- (read-arglist x)
- :not-available))))
- (case (kernel:get-type fun)
- (#.vm:closure-header-type
- (compiled-function-arglist
- (kernel:%closure-function fun)))
- ((#.vm:function-header-type #.vm:closure-function-header-type)
- (compiled-function-arglist fun))
- (#.vm:funcallable-instance-header-type
- (typecase fun
- (kernel:byte-function
- :not-available)
- (kernel:byte-closure
- :not-available)
- (eval:interpreted-function
- (eval:interpreted-function-arglist fun))
- (otherwise
- (clos::generic-function-lambda-list fun))))
- (t
- :non-available))))
+ (multiple-value-bind (args winp)
+ (ext:function-arglist fun)
+ (if winp args :not-available)))
(defimplementation function-name (function)
(cond ((eval:interpreted-function-p function)
@@ -1202,20 +1244,6 @@
(c::byte-function-name function))
(t (kernel:%function-name (kernel:%function-self function)))))
-;;; A simple case: the arglist is available as a string that we can
-;;; `read'.
-
-(defun read-arglist (fn)
- "Parse the arglist-string of the function object FN."
- (let ((string (kernel:%function-arglist
- (kernel:%function-self fn)))
- (package (find-package
- (c::compiled-debug-info-package
- (kernel:%code-debug-info
- (vm::find-code-object fn))))))
- (with-standard-io-syntax
- (let ((*package* (or package *package*)))
- (read-from-string string)))))
;;; A harder case: an approximate arglist is derived from available
;;; debugging information.
@@ -1262,54 +1290,6 @@
(values (debug-function-arglist (di::function-debug-function fn))
(kernel:%function-arglist (kernel:%function-self fn)))))
-;;; Deriving arglists for byte-compiled functions:
-;;;
-(defun byte-code-function-arglist (fn)
- ;; There doesn't seem to be much arglist information around for
- ;; byte-code functions. Use the arg-count and return something like
- ;; (arg0 arg1 ...)
- (etypecase fn
- (c::simple-byte-function
- (loop for i from 0 below (c::simple-byte-function-num-args fn)
- collect (make-arg-symbol i)))
- (c::hairy-byte-function
- (hairy-byte-function-arglist fn))
- (c::byte-closure
- (byte-code-function-arglist (c::byte-closure-function fn)))))
-
-(defun make-arg-symbol (i)
- (make-symbol (format nil "~A~D" (string 'arg) i)))
-
-;;; A "hairy" byte-function is one that takes a variable number of
-;;; arguments. `hairy-byte-function' is a type from the bytecode
-;;; interpreter.
-;;;
-(defun hairy-byte-function-arglist (fn)
- (let ((counter -1))
- (flet ((next-arg () (make-arg-symbol (incf counter))))
- (with-struct (c::hairy-byte-function- min-args max-args rest-arg-p
- keywords-p keywords) fn
- (let ((arglist '())
- (optional (- max-args min-args)))
- ;; XXX isn't there a better way to write this?
- ;; (Looks fine to me. -luke)
- (dotimes (i min-args)
- (push (next-arg) arglist))
- (when (plusp optional)
- (push '&optional arglist)
- (dotimes (i optional)
- (push (next-arg) arglist)))
- (when rest-arg-p
- (push '&rest arglist)
- (push (next-arg) arglist))
- (when keywords-p
- (push '&key arglist)
- (loop for (key _ __) in keywords
- do (push key arglist))
- (when (eq keywords-p :allow-others)
- (push '&allow-other-keys arglist)))
- (nreverse arglist))))))
-
;;;; Miscellaneous.
@@ -1941,7 +1921,7 @@
(defimplementation thread-alive-p (thread)
(not (zerop (thread::thread-dynamic-values thread))))
-(defvar *mailbox-lock* (thread:make-lock "Mailbox lock"))
+(defvar *mailbox-lock* (thread:make-lock "Mailbox lock" :interruptible nil))
(defstruct (mailbox)
(lock (thread:make-lock "Thread mailbox" :type :error-check
@@ -1951,32 +1931,38 @@
(defun mailbox (thread)
"Return 'thread's mailbox."
- (thread:with-lock-held (*mailbox-lock*)
- (or (getf (thread:thread-plist thread) 'mailbox)
- (setf (getf (thread:thread-plist thread) 'mailbox) (make-mailbox)))))
+ (sys:without-interrupts
+ (thread:with-lock-held (*mailbox-lock*)
+ (or (getf (thread:thread-plist thread) 'mailbox)
+ (setf (getf (thread:thread-plist thread) 'mailbox) (make-mailbox))))))
(defimplementation send (thread message)
(let* ((mbox (mailbox thread))
(lock (mailbox-lock mbox)))
- (thread:with-lock-held (lock "Mailbox Send")
- (setf (mailbox-queue mbox) (nconc (mailbox-queue mbox)
- (list message))))
+ (sys:without-interrupts
+ (thread:with-lock-held (lock "Mailbox Send")
+ (setf (mailbox-queue mbox) (nconc (mailbox-queue mbox)
+ (list message)))))
(mp:process-wakeup thread)))
+#+nil
(defimplementation receive ()
(receive-if (constantly t)))
-(defimplementation receive-if (test)
+(defimplementation receive-if (test &optional timeout)
(let ((mbox (mailbox thread:*thread*)))
+ (assert (or (not timeout) (eq timeout t)))
(loop
(check-slime-interrupts)
- (mp:with-lock-held ((mailbox-lock mbox))
- (let* ((q (mailbox-queue mbox))
- (tail (member-if test q)))
- (when tail
- (setf (mailbox-queue mbox)
- (nconc (ldiff q tail) (cdr tail)))
- (return (car tail)))))
+ (sys:without-interrupts
+ (mp:with-lock-held ((mailbox-lock mbox))
+ (let* ((q (mailbox-queue mbox))
+ (tail (member-if test q)))
+ (when tail
+ (setf (mailbox-queue mbox)
+ (nconc (ldiff q tail) (cdr tail)))
+ (return (car tail))))))
+ (when (eq timeout t) (return (values nil t)))
(mp:process-wait-with-timeout
"Mailbox read wait" 0.5 (lambda () (some test (mailbox-queue mbox)))))))
--- /project/slime/cvsroot/slime/swank.lisp 2008/09/22 22:56:18 1.595
+++ /project/slime/cvsroot/slime/swank.lisp 2008/09/23 04:57:51 1.596
@@ -1121,7 +1121,7 @@
(t (dispatch-event event))))
(defun signal-interrupt (thread interrupt)
- (log-event "singal-interrupt~%")
+ (log-event "signal-interrupt~%")
(cond ((use-threads-p) (interrupt-thread thread interrupt))
(t (funcall interrupt))))
@@ -2088,7 +2088,9 @@
(flet ((pathname-or-string-p (thing)
(or (pathnamep thing) (typep thing 'string)))
(canonicalize-filename (filename)
- (namestring (or (probe-file filename) filename))))
+ (let ((file-name (or (probe-file filename) filename)))
+ #-scl (namestring file-name)
+ #+scl (ext:unix-namestring file-name nil))))
(let ((target
(cond ((and (listp what) (pathname-or-string-p (first what)))
(cons (canonicalize-filename (car what)) (cdr what)))
More information about the slime-cvs
mailing list