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

Diff of /slime/swank-scl.lisp

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

revision 1.25 by heller, Wed Sep 17 06:19:49 2008 UTC revision 1.26 by dcrosher, Tue Sep 23 04:57:51 2008 UTC
# Line 217  Line 217 
217    
218  (defclass slime-output-stream (ext:character-output-stream)  (defclass slime-output-stream (ext:character-output-stream)
219    ((output-fn :initarg :output-fn :type function)    ((output-fn :initarg :output-fn :type function)
220       (output-buffer :initarg :output-buffer :type simple-string)
221       (buffer-tail :initarg :buffer-tail :initform 0 :type kernel:index)
222       (last-write :initarg :last-write)
223     (column :initform 0 :type kernel:index)     (column :initform 0 :type kernel:index)
224     (interactive :initform nil :type (member nil t))     (interactive :initform nil :type (member nil t))
225     (position :initform 0 :type integer)))     (position :initform 0 :type integer)))
# Line 225  Line 228 
228    (declare (function output-fn))    (declare (function output-fn))
229    (make-instance 'slime-output-stream    (make-instance 'slime-output-stream
230                   :in-buffer ""                   :in-buffer ""
231                   :out-buffer (make-string 256)                   :out-buffer ""
232                   :output-fn output-fn))                   :output-buffer (make-string 256)
233                     :output-fn output-fn
234                     :last-write (get-internal-real-time)
235                     ))
236    
237  (defmethod print-object ((s slime-output-stream) stream)  (defmethod print-object ((s slime-output-stream) stream)
238    (print-unreadable-object (s stream :type t)))    (print-unreadable-object (s stream :type t)))
# Line 241  Line 247 
247      (unless abort      (unless abort
248        (finish-output stream))        (finish-output stream))
249      (setf (ext:stream-open-p stream) nil)      (setf (ext:stream-open-p stream) nil)
250      (setf (ext:stream-out-buffer stream) " ")      (setf (slot-value stream 'output-buffer) "")
251      t))      t))
252    
253  ;;; No 'stream-clear-input method.  ;;; No 'stream-clear-input method.
254    
255  (defmethod ext:stream-finish-output ((stream slime-output-stream))  (defmethod ext:stream-finish-output ((stream slime-output-stream))
256      (let ((buffer-tail (slot-value stream 'buffer-tail)))
257        (declare (type kernel:index buffer-tail))
258        (when (> buffer-tail 0)
259          (let ((output-fn (slot-value stream 'output-fn))
260                (output-buffer (slot-value stream 'output-buffer)))
261            (declare (function output-fn)
262                     (simple-string output-buffer))
263            (funcall output-fn (subseq output-buffer 0 buffer-tail))
264            (setf (slot-value stream 'buffer-tail) 0))
265          (setf (slot-value stream 'last-write) (get-internal-real-time))))
266    nil)    nil)
267    
268  (defmethod ext:stream-force-output ((stream slime-output-stream))  (defmethod ext:stream-force-output ((stream slime-output-stream))
269      (ext:stream-finish-output stream)
270    nil)    nil)
271    
272  (defmethod ext:stream-clear-output ((stream slime-output-stream))  (defmethod ext:stream-clear-output ((stream slime-output-stream))
273      (decf (slot-value stream 'position) (slot-value stream 'buffer-tail))
274      (setf (slot-value stream 'buffer-tail) 0)
275    nil)    nil)
276    
277  ;;; Use default 'stream-element-type method for 'character-stream which  ;;; Use default 'stream-element-type method for 'character-stream which
# Line 280  Line 299 
299             (cond ((= target-position current-position)             (cond ((= target-position current-position)
300                    t)                    t)
301                   ((> target-position current-position)                   ((> target-position current-position)
302                      (ext:stream-finish-output stream)
303                    (let ((output-fn (slot-value stream 'output-fn))                    (let ((output-fn (slot-value stream 'output-fn))
304                          (fill-size (- target-position current-position)))                          (fill-size (- target-position current-position)))
305                      (declare (function output-fn))                      (declare (function output-fn))
306                      (funcall output-fn (make-string fill-size                      (funcall output-fn (make-string fill-size
307                                                      :initial-element #\space))                                                      :initial-element #\space))
308                      (setf (slot-value stream 'position) target-position))                      (setf (slot-value stream 'position) target-position))
309                      (setf (slot-value stream 'last-write) (get-internal-real-time))
310                    t)                    t)
311                   (t                   (t
312                    nil))))                    nil))))
# Line 297  Line 318 
318    
319  ;;; Use the default 'character-output-stream 'file-string-length method.  ;;; Use the default 'character-output-stream 'file-string-length method.
320    
321  ;;; stream-write-chars  ;;; stream-write-char -- internal
322  ;;;  ;;;
323  ;;; The stream out-buffer is typically large enough that there is little point  (defmethod ext:stream-write-char ((stream slime-output-stream) character)
324  ;;; growing the stream output 'string large than the total size.  For typical    (declare (type character character)
325  ;;; usage this reduces consing.  As the string grows larger then grow to             (optimize (speed 3)))
326  ;;; reduce the cost of copying strings around.    (unless (ext:stream-open-p stream)
327        (error 'kernel:simple-stream-error
328               :stream stream
329               :format-control "Stream closed."))
330      ;;
331      ;; Fill the output buffer.
332      (let* ((buffer-tail (slot-value stream 'buffer-tail))
333             (output-buffer (slot-value stream 'output-buffer))
334             (buffer-length (length output-buffer)))
335        (declare (type kernel:index buffer-tail)
336                 (simple-string output-buffer))
337        (when (>= buffer-tail buffer-length)
338          ;; Flush the output buffer to make room.
339          (let ((output-fn (slot-value stream 'output-fn)))
340            (declare (function output-fn))
341            (funcall output-fn output-buffer)
342            (setf buffer-tail 0)
343            (setf (slot-value stream 'last-write) (get-internal-real-time))))
344        (setf (aref output-buffer buffer-tail) character)
345        (incf buffer-tail)
346        (setf (slot-value stream 'buffer-tail) buffer-tail)
347        ;;
348        (let ((newline (char= character #\newline)))
349          (when (or newline
350                    (let ((last-write (slot-value stream 'last-write)))
351                      (declare (type integer last-write))
352                      (> (get-internal-real-time)
353                         (+ last-write (* 5 internal-time-units-per-second)))))
354            ;; Flush the output buffer.
355            (let ((output-fn (slot-value stream 'output-fn)))
356              (declare (function output-fn))
357              (funcall output-fn (subseq output-buffer 0 buffer-tail))
358              (setf buffer-tail 0)
359              (setf (slot-value stream 'buffer-tail) buffer-tail)
360              (setf (slot-value stream 'last-write) (get-internal-real-time))))
361          ;;
362          (setf (slot-value stream 'column)
363                (if newline
364                    0
365                    (let ((line-column (slot-value stream 'column)))
366                      (declare (type kernel:index line-column))
367                      (+ line-column 1))))
368          (incf (slot-value stream 'position))
369          ))
370      character)
371    
372    ;;; stream-write-chars
373  ;;;  ;;;
374  (defmethod ext:stream-write-chars ((stream slime-output-stream)  (defmethod ext:stream-write-chars ((stream slime-output-stream)
375                                     string start end waitp)                                     string start end waitp)
# Line 334  Line 401 
401                    (- end last-newline 1)                    (- end last-newline 1)
402                    (let ((column (slot-value stream 'column)))                    (let ((column (slot-value stream 'column)))
403                      (declare (type kernel:index column))                      (declare (type kernel:index column))
404                      (+ column (- end start))))))))                      (+ column (- end start))))))
405          (incf (slot-value stream 'position) length)))
406    (- end start))    (- end start))
407    
408  ;;;  ;;;
# Line 1163  Signal an error if no constructor can be Line 1231  Signal an error if no constructor can be
1231  ;;;;; Argument lists  ;;;;; Argument lists
1232    
1233  (defimplementation arglist (fun)  (defimplementation arglist (fun)
1234    (etypecase fun    (multiple-value-bind (args winp)
1235      (function (function-arglist fun))        (ext:function-arglist fun)
1236      (symbol (function-arglist (or (macro-function fun)      (if winp args :not-available)))
                                   (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))))  
1237    
1238  (defimplementation function-name (function)  (defimplementation function-name (function)
1239    (cond ((eval:interpreted-function-p function)    (cond ((eval:interpreted-function-p function)
# Line 1202  Signal an error if no constructor can be Line 1244  Signal an error if no constructor can be
1244           (c::byte-function-name function))           (c::byte-function-name function))
1245          (t (kernel:%function-name (kernel:%function-self function)))))          (t (kernel:%function-name (kernel:%function-self function)))))
1246    
 ;;; 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)))))  
1247    
1248  ;;; A harder case: an approximate arglist is derived from available  ;;; A harder case: an approximate arglist is derived from available
1249  ;;; debugging information.  ;;; debugging information.
# Line 1262  Signal an error if no constructor can be Line 1290  Signal an error if no constructor can be
1290      (values (debug-function-arglist (di::function-debug-function fn))      (values (debug-function-arglist (di::function-debug-function fn))
1291              (kernel:%function-arglist (kernel:%function-self fn)))))              (kernel:%function-arglist (kernel:%function-self fn)))))
1292    
 ;;; 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))))))  
   
1293    
1294  ;;;; Miscellaneous.  ;;;; Miscellaneous.
1295    
# Line 1941  The `symbol-value' of each element is a Line 1921  The `symbol-value' of each element is a
1921  (defimplementation thread-alive-p (thread)  (defimplementation thread-alive-p (thread)
1922    (not (zerop (thread::thread-dynamic-values thread))))    (not (zerop (thread::thread-dynamic-values thread))))
1923    
1924  (defvar *mailbox-lock* (thread:make-lock "Mailbox lock"))  (defvar *mailbox-lock* (thread:make-lock "Mailbox lock" :interruptible nil))
1925    
1926  (defstruct (mailbox)  (defstruct (mailbox)
1927    (lock (thread:make-lock "Thread mailbox" :type :error-check    (lock (thread:make-lock "Thread mailbox" :type :error-check
# Line 1951  The `symbol-value' of each element is a Line 1931  The `symbol-value' of each element is a
1931    
1932  (defun mailbox (thread)  (defun mailbox (thread)
1933    "Return 'thread's mailbox."    "Return 'thread's mailbox."
1934    (thread:with-lock-held (*mailbox-lock*)    (sys:without-interrupts
1935      (or (getf (thread:thread-plist thread) 'mailbox)      (thread:with-lock-held (*mailbox-lock*)
1936          (setf (getf (thread:thread-plist thread) 'mailbox) (make-mailbox)))))        (or (getf (thread:thread-plist thread) 'mailbox)
1937              (setf (getf (thread:thread-plist thread) 'mailbox) (make-mailbox))))))
1938    
1939  (defimplementation send (thread message)  (defimplementation send (thread message)
1940    (let* ((mbox (mailbox thread))    (let* ((mbox (mailbox thread))
1941           (lock (mailbox-lock mbox)))           (lock (mailbox-lock mbox)))
1942      (thread:with-lock-held (lock "Mailbox Send")      (sys:without-interrupts
1943        (setf (mailbox-queue mbox) (nconc (mailbox-queue mbox)        (thread:with-lock-held (lock "Mailbox Send")
1944                                          (list message))))          (setf (mailbox-queue mbox) (nconc (mailbox-queue mbox)
1945                                              (list message)))))
1946      (mp:process-wakeup thread)))      (mp:process-wakeup thread)))
1947    
1948    #+nil
1949  (defimplementation receive ()  (defimplementation receive ()
1950    (receive-if (constantly t)))    (receive-if (constantly t)))
1951    
1952  (defimplementation receive-if (test)  (defimplementation receive-if (test &optional timeout)
1953    (let ((mbox (mailbox thread:*thread*)))    (let ((mbox (mailbox thread:*thread*)))
1954        (assert (or (not timeout) (eq timeout t)))
1955      (loop      (loop
1956       (check-slime-interrupts)       (check-slime-interrupts)
1957       (mp:with-lock-held ((mailbox-lock mbox))       (sys:without-interrupts
1958         (let* ((q (mailbox-queue mbox))         (mp:with-lock-held ((mailbox-lock mbox))
1959                (tail (member-if test q)))           (let* ((q (mailbox-queue mbox))
1960           (when tail                  (tail (member-if test q)))
1961             (setf (mailbox-queue mbox)             (when tail
1962                   (nconc (ldiff q tail) (cdr tail)))               (setf (mailbox-queue mbox)
1963             (return (car tail)))))                     (nconc (ldiff q tail) (cdr tail)))
1964                 (return (car tail))))))
1965         (when (eq timeout t) (return (values nil t)))
1966       (mp:process-wait-with-timeout       (mp:process-wait-with-timeout
1967        "Mailbox read wait" 0.5 (lambda () (some test (mailbox-queue mbox)))))))        "Mailbox read wait" 0.5 (lambda () (some test (mailbox-queue mbox)))))))
1968    

Legend:
Removed from v.1.25  
changed lines
  Added in v.1.26

  ViewVC Help
Powered by ViewVC 1.1.5