Refactoring improvements

[kmrcl.git] / symbols.lisp

diff --git a/symbols.lisp b/symbols.lisp
index d14f4f28bfc1e6a03e6efece890489a4e339869b..802deb31bd8235b47075ff580356530206815290 100644 (file)
--- a/symbols.lisp
+++ b/symbols.lisp
@@ -7,9 +7,7 @@
 ;;;; 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
@@ -18,47 +16,42 @@
 
 (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))
@@ -96,27 +89,22 @@
     (: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
@@ -142,6 +130,6 @@ class of an instance and whose name begins with the string 'test-'"
     (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))