[slime-cvs] CVS slime

[CVS User heller]

Update of /project/slime/cvsroot/slime
In directory tiger.common-lisp.net:/tmp/cvs-serv20947

Modified Files:
	ChangeLog swank.lisp 
Log Message:
* swank.lisp (do-symbols*, classify-symbol)
(symbol-classification-string): Moved to contrib/swank-util.lisp.

--- /project/slime/cvsroot/slime/ChangeLog	2011/11/29 19:50:15	1.2251
+++ /project/slime/cvsroot/slime/ChangeLog	2011/12/01 16:48:21	1.2252
@@ -1,9 +1,15 @@
 2011-11-29  Helmut Eller  <heller at common-lisp.net>
 
+	* swank.lisp (do-symbols*, classify-symbol)
+	(symbol-classification-string): Moved to contrib/swank-util.lisp.
+
+2011-11-29  Helmut Eller  <heller at common-lisp.net>
+
 	* swank.lisp (to-line): Increase default limit to 512.
 	(frame-locals-for-emacs): Let *print-right-margin* override
 	default line width.
 
+
 2011-11-27  Helmut Eller  <heller at common-lisp.net>
 
 	* swank.lisp (create-server): Add a :backlog argument.
--- /project/slime/cvsroot/slime/swank.lisp	2011/11/29 19:50:16	1.765
+++ /project/slime/cvsroot/slime/swank.lisp	2011/12/01 16:48:21	1.766
@@ -540,15 +540,6 @@
                       `(,getter ,',var))))
          , at body))))
 
-(defmacro do-symbols* ((var &optional (package '*package*) result-form) &body body)
-  "Just like do-symbols, but makes sure a symbol is visited only once."
-  (let ((seen-ht (gensym "SEEN-HT")))
-    `(let ((,seen-ht (make-hash-table :test #'eq)))
-      (do-symbols (,var ,package ,result-form)
-        (unless (gethash ,var ,seen-ht)
-          (setf (gethash ,var ,seen-ht) t)
-          (tagbody , at body))))))
-
 (defmacro define-special (name doc)
   "Define a special variable NAME with doc string DOC.
 This is like defvar, but NAME will not be initialized."
@@ -650,57 +641,6 @@
 If PACKAGE is not specified, the home package of SYMBOL is used."
   (eq (symbol-status symbol package) :external))
 
-
-(defun classify-symbol (symbol)
-  "Returns a list of classifiers that classify SYMBOL according to its
-underneath objects (e.g. :BOUNDP if SYMBOL constitutes a special
-variable.) The list may contain the following classification
-keywords: :BOUNDP, :FBOUNDP, :CONSTANT, :GENERIC-FUNCTION,
-:TYPESPEC, :CLASS, :MACRO, :SPECIAL-OPERATOR, and/or :PACKAGE"
-  (check-type symbol symbol)
-  (flet ((type-specifier-p (s)
-           (or (documentation s 'type)
-               (not (eq (type-specifier-arglist s) :not-available)))))
-    (let (result)
-      (when (boundp symbol)             (push (if (constantp symbol)
-                                                  :constant :boundp) result))
-      (when (fboundp symbol)            (push :fboundp result))
-      (when (type-specifier-p symbol)   (push :typespec result))
-      (when (find-class symbol nil)     (push :class result))
-      (when (macro-function symbol)     (push :macro result))
-      (when (special-operator-p symbol) (push :special-operator result))
-      (when (find-package symbol)       (push :package result))
-      (when (and (fboundp symbol)
-                 (typep (ignore-errors (fdefinition symbol))
-                        'generic-function))
-        (push :generic-function result))
-
-      result)))
-
-(defun symbol-classification-string (symbol)
-  "Return a string in the form -f-c---- where each letter stands for
-boundp fboundp generic-function class macro special-operator package"
-  (let ((letters "bfgctmsp")
-        (result (copy-seq "--------")))
-    (flet ((type-specifier-p (s)
-             (or (documentation s 'type)
-                 (not (eq (type-specifier-arglist s) :not-available))))
-           (flip (letter)
-             (setf (char result (position letter letters))
-                   letter)))
-      (when (boundp symbol) (flip #\b))
-      (when (fboundp symbol)
-        (flip #\f)
-        (when (typep (ignore-errors (fdefinition symbol))
-                     'generic-function)
-          (flip #\g)))
-      (when (type-specifier-p symbol) (flip #\t))
-      (when (find-class symbol nil)   (flip #\c) )
-      (when (macro-function symbol)   (flip #\m))
-      (when (special-operator-p symbol) (flip #\s))
-      (when (find-package symbol)       (flip #\p))
-      result)))
-
 
 ;;;; TCP Server
 
@@ -1862,7 +1802,8 @@
        ,(cond ((and stream object)
                (let ((gstream (gensym "STREAM+")))
                  `(let ((,gstream ,stream))
-                    (print-unreadable-object (,object ,gstream :type t :identity t)
+                    (print-unreadable-object (,object ,gstream :type t 
+                                                      :identity t)
                       (write-string ,msg ,gstream)))))
               (stream
                `(write-string ,msg ,stream))
@@ -2675,7 +2616,7 @@
 
 (defun frame-locals-for-emacs (index)
   (with-bindings *backtrace-printer-bindings*
-    (loop for var in (frame-locals index) collect 
+    (loop for var in (frame-locals index) collect
           (destructuring-bind (&key name id value) var
             (list :name (prin1-to-string name)
                   :id id
@@ -2703,7 +2644,8 @@
             (setq *sldb-stepping-p* t)
             (continue))
            (t
-            (error "Not currently single-stepping, and no continue restart available.")))))
+            (error "Not currently single-stepping, ~
+and no continue restart available.")))))
 
 (define-stepper-function sldb-step sldb-step-into)
 (define-stepper-function sldb-next sldb-step-next)