;;;;
;;;; KMRCL users are granted the rights to distribute and use this software
;;;; as governed by the terms of the Lisp Lesser GNU Public License
;;;;
;;;; KMRCL users are granted the rights to distribute and use this software
;;;; as governed by the terms of the Lisp Lesser GNU Public License
- (let ((funcs '()))
- (do-symbols (s 'common-lisp)
- (multiple-value-bind (sym status)
- (find-symbol (symbol-name s) 'common-lisp)
- (when (and (or (eq status :external)
- (eq status :internal))
- (fboundp sym))
- (push sym funcs))))
- (nreverse funcs)))
+ (cl-symbol-list #'fboundp))
(eval-when (:compile-toplevel :load-toplevel :execute)
(when (char= #\a (schar (symbol-name '#:a) 0))
(eval-when (:compile-toplevel :load-toplevel :execute)
(when (char= #\a (schar (symbol-name '#:a) 0))
- #+kmrcl-case-sensitive str
- #+(and (not kmrcl-case-sensitive) (not kmrcl-lowercase-reader)) (string-upcase str)
- #+(and (not kmrcl-case-sensitive) kmrcl-lowercase-reader) (string-downcase str))
+ #+(and (not kmrcl::kmrcl-lowercase-reader)) (string-upcase str)
+ #+(and kmrcl::kmrcl-lowercase-reader) (string-downcase str))
- (setq cl:*features* (delete :kmrcl-lowercase-reader *features*))
- (setq cl:*features* (delete :kmrcl-case-sensitive *features*)))
+ (setq cl:*features* (delete 'kmrcl::kmrcl-lowercase-reader *features*))
+ (setq cl:*features* (delete 'kmrcl::kmrcl-case-sensitive *features*)))
(symbol-name arg)))))
(let ((str (apply #'concatenate 'string (mapcar #'stringify args))))
(nth-value 0 (intern (string-default-case str)
(symbol-name arg)))))
(let ((str (apply #'concatenate 'string (mapcar #'stringify args))))
(nth-value 0 (intern (string-default-case str)
(defun show (&optional (what :variables) (package *package*))
(ecase what
(:variables (show-variables package))
(:functions (show-functions package))))
(defun show (&optional (what :variables) (package *package*))
(ecase what
(:variables (show-variables package))
(:functions (show-functions package))))
-(defun show-functions (package)
- (do-symbols (s package)
- (multiple-value-bind (sym status)
- (find-symbol (symbol-name s) package)
- (when (and (or (eq status :external)
- (eq status :internal))
- (fboundp sym))
- (format t "~&Function ~S~T -> ~S~%"
- sym
- (symbol-function sym))))))
+(defun show-variables (&optional (package *package*) (stream *standard-output*))
+ (print-symbols package 'boundp 'symbol-value stream))
+
+(defun show-functions (&optional (package *package*) (stream *standard-output*))
+ (print-symbols package 'fboundp 'symbol-function stream))
(defun find-test-generic-functions (instance)
"Return a list of symbols for generic functions specialized on the
class of an instance and whose name begins with the string 'test-'"
(let ((res)
(defun find-test-generic-functions (instance)
"Return a list of symbols for generic functions specialized on the
class of an instance and whose name begins with the string 'test-'"
(let ((res)
- (find-symbol (symbol-name s) package)
- (when (and (or (eq status :external)
- (eq status :internal))
- (fboundp sym)
- (eq (symbol-package sym) package)
- (> (length (symbol-name sym)) 5)
- (string-equal "test-" (subseq (symbol-name sym) 0 5))
- (typep (symbol-function sym) 'generic-function)
- (plusp
- (length
- (compute-applicable-methods
- (ensure-generic-function sym)
- (list instance)))))
- (push sym res))))
+ (find-symbol (symbol-name s) package)
+ (when (and (or (eq status :external)
+ (eq status :internal))
+ (fboundp sym)
+ (eq (symbol-package sym) package)
+ (> (length (symbol-name sym)) 5)
+ (string-equal "test-" (subseq (symbol-name sym) 0 5))
+ (typep (symbol-function sym) 'generic-function)
+ (plusp
+ (length
+ (compute-applicable-methods
+ (ensure-generic-function sym)
+ (list instance)))))
+ (push sym res))))