;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id$
-;;;;
-;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of KMRCL, is Copyright (c) 2002-2010 by Kevin M. Rosenberg
;;;;
;;;; KMRCL users are granted the rights to distribute and use this software
;;;; as governed by the terms of the Lisp Lesser GNU Public License
(in-package #:kmrcl)
-(defun cl-symbols ()
- (append (cl-variables) (cl-functions)))
+;;; Symbol functions
-(defun cl-variables ()
+(defun cl-symbol-list (test-fn)
(let ((vars '()))
(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))
- (boundp sym))
+ (funcall test-fn sym))
(push sym vars))))
(nreverse vars)))
+(defun cl-variables ()
+ (cl-symbol-list #'boundp))
+
(defun cl-functions ()
- (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))
-;;; Symbol functions
+(defun cl-symbols ()
+ (nconc (cl-variables) (cl-functions)))
(eval-when (:compile-toplevel :load-toplevel :execute)
(when (char= #\a (schar (symbol-name '#:a) 0))
- (pushnew :kmrcl-lowercase-reader *features*))
+ (pushnew 'kmrcl::kmrcl-lowercase-reader *features*))
(when (not (string= (symbol-name '#:a)
(symbol-name '#:A)))
- (pushnew :kmrcl-case-sensitive *features*)))
+ (pushnew 'kmrcl::kmrcl-case-sensitive *features*)))
(defun string-default-case (str)
- #+(and (not kmrcl-lowercase-reader)) (string-upcase str)
- #+(and kmrcl-lowercase-reader) (string-downcase str))
+ #+(and (not kmrcl::kmrcl-lowercase-reader)) (string-upcase str)
+ #+(and kmrcl::kmrcl-lowercase-reader) (string-downcase str))
(eval-when (:compile-toplevel :load-toplevel :execute)
- (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*)))
(defun concat-symbol-pkg (pkg &rest args)
(declare (dynamic-extent args))
(:variables (show-variables package))
(:functions (show-functions package))))
-(defun show-variables (package)
+(defun print-symbols (package test-fn value-fn &optional (stream *standard-output*))
(do-symbols (s package)
(multiple-value-bind (sym status)
(find-symbol (symbol-name s) package)
(when (and (or (eq status :external)
(eq status :internal))
- (boundp sym))
- (format t "~&Symbol ~S~T -> ~S~%"
+ (funcall test-fn sym))
+ (format stream "~&Symbol ~S~T -> ~S~%"
sym
- (symbol-value sym))))))
+ (funcall value-fn sym))))))
-(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
(nreverse res)))
(defun run-tests-for-instance (instance)
- (dolist (gf-name(find-test-generic-functions instance))
+ (dolist (gf-name (find-test-generic-functions instance))
(funcall gf-name instance))
(values))