/usr/share/emacs/site-lisp/elpa-src/slime-2.20/contrib/swank-util.lisp is in slime 2:2.20+dfsg-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
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)
|