1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
|
;;; swank-util.lisp --- stuff of questionable utility
;;
;; License: public domain
(in-package :swank)
(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 ,@body))))))
(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 ((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)))
(provide :swank-util)
|
