[slime-cvs] CVS slime
trittweiler
trittweiler at common-lisp.net
Tue Aug 28 21:13:57 UTC 2007
Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv28259
Modified Files:
swank.lisp
Log Message:
* swank.lisp (classify-symbol, symbol-classification->string):
Resurrected in swank.lisp. (I was bitten by cvs-pcl which
committed (2007-08-27) my locally changed `contribs/swank-fuzzy.lisp'
where I already removed these functions from.)
--- /project/slime/cvsroot/slime/swank.lisp 2007/08/28 20:44:41 1.504
+++ /project/slime/cvsroot/slime/swank.lisp 2007/08/28 21:13:57 1.505
@@ -282,7 +282,9 @@
(emacs-connected))
-;;;; Helper macros
+;;;; Utilities
+
+;;;;; Helper macros
(defmacro with-io-redirection ((connection) &body body)
"Execute BODY I/O redirection to CONNECTION.
@@ -338,6 +340,18 @@
(unwind-protect (progn , at body)
(delete-package ,var))))
+(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)
+ , at body)))))
+
+
+;;;;; Logging
+
(defvar *log-events* nil)
(defvar *log-output* *error-output*)
(defvar *event-history* (make-array 40 :initial-element nil)
@@ -392,6 +406,9 @@
(defun ascii-char-p (c)
(<= (char-code c) 127))
+
+;;;;; Misc
+
(defun length= (seq n)
"Test for whether SEQ contains N number of elements. I.e. it's equivalent
to (= (LENGTH SEQ) N), but besides being more concise, it may also be more
@@ -426,14 +443,116 @@
(setq found v))))
found))
-(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)
- , at body)))))
+
+;;;;; Symbols
+
+(defun symbol-status (symbol &optional (package (symbol-package symbol)))
+ "Returns one of
+
+ :INTERNAL if the symbol is _present_ in PACKAGE as an _internal_ symbol,
+
+ :EXTERNAL if the symbol is _present_ in PACKAGE as an _external_ symbol,
+
+ :INHERITED if the symbol is _inherited_ by PACKAGE through USE-PACKAGE,
+ but is not _present_ in PACKAGE,
+
+ or NIL if SYMBOL is not _accessible_ in PACKAGE.
+
+
+Be aware not to get confused with :INTERNAL and how \"internal
+symbols\" are defined in the spec; there is a slight mismatch of
+definition with the Spec and what's commonly meant when talking
+about internal symbols most times. As the spec says:
+
+ In a package P, a symbol S is
+
+ _accessible_ if S is either _present_ in P itself or was
+ inherited from another package Q (which implies
+ that S is _external_ in Q.)
+
+ You can check that with: (AND (SYMBOL-STATUS S P) T)
+
+
+ _present_ if either P is the /home package/ of S or S has been
+ imported into P or exported from P by IMPORT, or
+ EXPORT respectively.
+
+ Or more simply, if S is not _inherited_.
+
+ You can check that with: (LET ((STATUS (SYMBOL-STATUS S P)))
+ (AND STATUS
+ (NOT (EQ STATUS :INHERITED))))
+
+
+ _external_ if S is going to be inherited into any package that
+ /uses/ P by means of USE-PACKAGE, MAKE-PACKAGE, or
+ DEFPACKAGE.
+
+ Note that _external_ implies _present_, since to
+ make a symbol _external_, you'd have to use EXPORT
+ which will automatically make the symbol _present_.
+
+ You can check that with: (EQ (SYMBOL-STATUS S P) :EXTERNAL)
+
+
+ _internal_ if S is _accessible_ but not _external_.
+
+ You can check that with: (LET ((STATUS (SYMBOL-STATUS S P)))
+ (AND STATUS
+ (NOT (EQ STATUS :EXTERNAL))))
+
+
+ Notice that this is *different* to
+ (EQ (SYMBOL-STATUS S P) :INTERNAL)
+ because what the spec considers _internal_ is split up into two
+ explicit pieces: :INTERNAL, and :INHERITED; just as, for instance,
+ CL:FIND-SYMBOL does.
+
+ The rationale is that most times when you speak about \"internal\"
+ symbols, you're actually not including the symbols inherited
+ from other packages, but only about the symbols directly specific
+ to the package in question.
+"
+ (when package ; may be NIL when symbol is completely uninterned.
+ (check-type symbol symbol) (check-type package package)
+ (multiple-value-bind (present-symbol status)
+ (find-symbol (symbol-name symbol) package)
+ (and (eq symbol present-symbol) status))))
+
+(defun symbol-external-p (symbol &optional (package (symbol-package symbol)))
+ "True if SYMBOL is external in PACKAGE.
+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, :GENERIC-FUNCTION, :CLASS, :MACRO,
+:SPECIAL-OPERATOR, and/or :PACKAGE"
+ (check-type symbol symbol)
+ (let (result)
+ (when (boundp symbol) (push :boundp result))
+ (when (fboundp symbol) (push :fboundp 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 (typep (ignore-errors (fdefinition symbol))
+ 'generic-function)
+ (push :generic-function result))
+ result))
+
+(defun symbol-classification->string (flags)
+ (format nil "~A~A~A~A~A~A~A"
+ (if (member :boundp flags) "b" "-")
+ (if (member :fboundp flags) "f" "-")
+ (if (member :generic-function flags) "g" "-")
+ (if (member :class flags) "c" "-")
+ (if (member :macro flags) "m" "-")
+ (if (member :special-operator flags) "s" "-")
+ (if (member :package flags) "p" "-")))
;;;; TCP Server
@@ -3497,85 +3616,6 @@
append (package-nicknames package))))))
-(defun symbol-status (symbol &optional (package (symbol-package symbol)))
- "Returns one of
-
- :INTERNAL if the symbol is _present_ in PACKAGE as an _internal_ symbol,
-
- :EXTERNAL if the symbol is _present_ in PACKAGE as an _external_ symbol,
-
- :INHERITED if the symbol is _inherited_ by PACKAGE through USE-PACKAGE,
- but is not _present_ in PACKAGE,
-
- or NIL if SYMBOL is not _accessible_ in PACKAGE.
-
-
-Be aware not to get confused with :INTERNAL and how \"internal
-symbols\" are defined in the spec; there is a slight mismatch of
-definition with the Spec and what's commonly meant when talking
-about internal symbols most times. As the spec says:
-
- In a package P, a symbol S is
-
- _accessible_ if S is either _present_ in P itself or was
- inherited from another package Q (which implies
- that S is _external_ in Q.)
-
- You can check that with: (AND (SYMBOL-STATUS S P) T)
-
-
- _present_ if either P is the /home package/ of S or S has been
- imported into P or exported from P by IMPORT, or
- EXPORT respectively.
-
- Or more simply, if S is not _inherited_.
-
- You can check that with: (LET ((STATUS (SYMBOL-STATUS S P)))
- (AND STATUS
- (NOT (EQ STATUS :INHERITED))))
-
-
- _external_ if S is going to be inherited into any package that
- /uses/ P by means of USE-PACKAGE, MAKE-PACKAGE, or
- DEFPACKAGE.
-
- Note that _external_ implies _present_, since to
- make a symbol _external_, you'd have to use EXPORT
- which will automatically make the symbol _present_.
-
- You can check that with: (EQ (SYMBOL-STATUS S P) :EXTERNAL)
-
-
- _internal_ if S is _accessible_ but not _external_.
-
- You can check that with: (LET ((STATUS (SYMBOL-STATUS S P)))
- (AND STATUS
- (NOT (EQ STATUS :EXTERNAL))))
-
-
- Notice that this is *different* to
- (EQ (SYMBOL-STATUS S P) :INTERNAL)
- because what the spec considers _internal_ is split up into two
- explicit pieces: :INTERNAL, and :INHERITED; just as, for instance,
- CL:FIND-SYMBOL does.
-
- The rationale is that most times when you speak about \"internal\"
- symbols, you're actually not including the symbols inherited
- from other packages, but only about the symbols directly specific
- to the package in question.
-"
- (when package ; may be NIL when symbol is completely uninterned.
- (check-type symbol symbol) (check-type package package)
- (multiple-value-bind (present-symbol status)
- (find-symbol (symbol-name symbol) package)
- (and (eq symbol present-symbol) status))))
-
-(defun symbol-external-p (symbol &optional (package (symbol-package symbol)))
- "True if SYMBOL is external in PACKAGE.
-If PACKAGE is not specified, the home package of SYMBOL is used."
- (eq (symbol-status symbol package) :external))
-
-
;; PARSE-COMPLETION-ARGUMENTS return table:
;;
;; user behaviour | NAME | PACKAGE-NAME | PACKAGE
More information about the slime-cvs
mailing list