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

Diff of /slime/swank.lisp

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

revision 1.134 by heller, Wed Mar 3 20:52:40 2004 UTC revision 1.135 by heller, Thu Mar 4 22:12:44 2004 UTC
# Line 299  determined at compile time." Line 299  determined at compile time."
299  (defvar *active-threads* '())  (defvar *active-threads* '())
300  (defvar *thread-counter* 0)  (defvar *thread-counter* 0)
301    
302    (defun remove-dead-threads ()
303      (setq *active-threads*
304            (remove-if-not #'thread-alive-p *active-threads*)))
305    
306  (defun add-thread (thread)  (defun add-thread (thread)
307    (let ((id (mod (1+ *thread-counter*) most-positive-fixnum)))    (let ((id (mod (1+ *thread-counter*) most-positive-fixnum)))
308      (setq *active-threads* (acons id thread *active-threads*)      (setq *active-threads* (acons id thread *active-threads*)
# Line 324  element." Line 328  element."
328      (assert pair)      (assert pair)
329      (car pair)))      (car pair)))
330    
331    (defvar *lookup-counter* nil
332      "A simple counter used to remove dead threads from *active-threads*.")
333    
334  (defun lookup-thread (thread)  (defun lookup-thread (thread)
335      (when (zerop (decf *lookup-counter*))
336        (setf *lookup-counter* 50)
337        (remove-dead-threads))
338    (let ((probe (rassoc thread *active-threads*)))    (let ((probe (rassoc thread *active-threads*)))
339      (cond (probe (car probe))      (cond (probe (car probe))
340            (t (add-thread thread)))))            (t (add-thread thread)))))
# Line 338  element." Line 348  element."
348  (defun dispatch-loop (socket-io connection)  (defun dispatch-loop (socket-io connection)
349    (let ((*emacs-connection* connection)    (let ((*emacs-connection* connection)
350          (*active-threads* '())          (*active-threads* '())
351          (*thread-counter* 0))          (*thread-counter* 0)
352            (*lookup-counter* 50))
353      (loop (with-simple-restart (abort "Retstart dispatch loop.")      (loop (with-simple-restart (abort "Retstart dispatch loop.")
354              (loop (dispatch-event (receive) socket-io))))))              (loop (dispatch-event (receive) socket-io))))))
355    
# Line 718  Call LAMBDA-LIST-FN with the symbol corr Line 729  Call LAMBDA-LIST-FN with the symbol corr
729          (let ((symbol (find-symbol-or-lose function-name)))          (let ((symbol (find-symbol-or-lose function-name)))
730            (values (funcall lambda-list-fn symbol))))            (values (funcall lambda-list-fn symbol))))
731      (cond (condition (format nil "(-- ~A)" condition))      (cond (condition (format nil "(-- ~A)" condition))
732            (t (if (null arglist)            (t (if (null arglist)
733                   "()"                   "()"
734                   (let ((*print-case* :downcase)                   (print-arglist-to-string arglist))))))
735                         (*print-level* nil)  
736                         (*print-length* nil))  (defun print-arglist-to-string (arglist)
737                     (princ-to-string arglist)))))))    (with-output-to-string (*standard-output*)
738        (print-arglist arglist)))
739    
740    (defun print-arglist (arglist)
741      (let ((*print-case* :downcase)
742            (*print-pretty* t))
743        (pprint-logical-block (*standard-output* arglist :prefix "(" :suffix ")")
744          (loop
745           (let ((arg (pprint-pop)))
746             (etypecase arg
747               (symbol (princ arg))
748               (cons (pprint-logical-block (*standard-output* arg :prefix "("
749                                                              :suffix ")")
750                       (princ (car arg))
751                       (write-char #\space)
752                       (pprint-fill *standard-output* (cdr arg) nil))))
753             (pprint-exit-if-list-exhausted)
754             (write-char #\space)
755             (pprint-newline :fill))))))
756    
757    (defun test-print-arglist (list string)
758      (string= (print-arglist-to-string list) string))
759    
760    (assert (test-print-arglist '(function cons) "(function cons)"))
761    (assert (test-print-arglist '(quote cons) "(quote cons)"))
762    ;; (assert (test-print-arglist '(&key (function #'f)) "(&key (function #'f))"))
763    ;; (assert (test-print-arglist '(&key ((function f))) "(&key ((function f)))"))
764    
765    
766  ;;;; Debugger  ;;;; Debugger
# Line 1519  nil if there's no second element." Line 1556  nil if there's no second element."
1556                (push (cons (string 'rest) in-list) reversed-elements)                (push (cons (string 'rest) in-list) reversed-elements)
1557                (done "The object is an improper list of length ~S.~%")))))))                (done "The object is an improper list of length ~S.~%")))))))
1558    
1559    (defmethod inspected-parts ((o hash-table))
1560      (values (format nil "~A~%   is a ~A" o (class-of o))
1561              (list*
1562               (cons "Test" (hash-table-test o))
1563               (cons "Count" (hash-table-count o))
1564               (cons "Size" (hash-table-size o))
1565               (cons "Rehash-Threshold" (hash-table-rehash-threshold o))
1566               (cons "Rehash-Size" (hash-table-rehash-size o))
1567               (cons "---" :---)
1568               (let ((pairs '()))
1569                 (maphash (lambda (key value)
1570                            (push (cons (to-string key) value)
1571                                  pairs))
1572                          o)
1573                 pairs))))
1574    
1575  (defslimefun inspect-in-frame (string index)  (defslimefun inspect-in-frame (string index)
1576    (reset-inspector)    (reset-inspector)
1577    (inspect-object (eval-in-frame (from-string string) index)))    (inspect-object (eval-in-frame (from-string string) index)))

Legend:
Removed from v.1.134  
changed lines
  Added in v.1.135

  ViewVC Help
Powered by ViewVC 1.1.5