Improve date/time display

[kmrcl.git] / symbols.lisp

diff --git a/symbols.lisp b/symbols.lisp
index f4e3b6dda0d35612da9659696eba8942cf2c0ab0..d14f4f28bfc1e6a03e6efece890489a4e339869b 100644 (file)
--- a/symbols.lisp
+++ b/symbols.lisp
@@ -25,37 +25,40 @@
   (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))
-         (push sym vars))))
+          (find-symbol (symbol-name s) 'common-lisp)
+        (when (and (or (eq status :external)
+                       (eq status :internal))
+                   (boundp sym))
+          (push sym vars))))
     (nreverse vars)))
 
 (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))))
+        (find-symbol (symbol-name s) 'common-lisp)
+        (when (and (or (eq status :external)
+                       (eq status :internal))
+                   (fboundp sym))
+          (push sym funcs))))
     (nreverse funcs)))
 
 ;;; Symbol functions
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (when (char= #\a (schar (symbol-name '#:a) 0))
-    (pushnew :lowercase-reader *features*)))
+    (pushnew :kmrcl-lowercase-reader *features*))
+  (when (not (string= (symbol-name '#:a)
+                      (symbol-name '#:A)))
+    (pushnew :kmrcl-case-sensitive *features*)))
 
 (defun string-default-case (str)
-   #+(and (not case-sensitive) (not lowercase-reader))
-   (string-upcase str)
-   #+(and (not case-sensitive) lowercase-reader)
-   (string-downcase str)
-   #+case-sensitive
-   str)
+  #+(and (not kmrcl-lowercase-reader)) (string-upcase str)
+  #+(and 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*)))
 
 (defun concat-symbol-pkg (pkg &rest args)
   (declare (dynamic-extent args))
@@ -66,8 +69,8 @@
              (symbol
               (symbol-name arg)))))
     (let ((str (apply #'concatenate 'string (mapcar #'stringify args))))
-      (intern (string-default-case str)
-             (if pkg pkg *package*)))))
+      (nth-value 0 (intern (string-default-case str)
+                           (if pkg pkg *package*))))))
 
 
 (defun concat-symbol (&rest args)
@@ -77,8 +80,16 @@
   "Returns keyword for a name"
   (etypecase name
     (keyword name)
-    (string (intern (string-default-case name) :keyword))
-    (symbol (intern (symbol-name name) :keyword))))
+    (string (nth-value 0 (intern (string-default-case name) :keyword)))
+    (symbol (nth-value 0 (intern (symbol-name name) :keyword)))))
+
+(defun ensure-keyword-upcase (desig)
+  (nth-value 0 (intern (string-upcase
+                        (symbol-name (ensure-keyword desig))) :keyword)))
+
+(defun ensure-keyword-default-case (desig)
+  (nth-value 0 (intern (string-default-case
+                        (symbol-name (ensure-keyword desig))) :keyword)))
 
 (defun show (&optional (what :variables) (package *package*))
   (ecase what
@@ -88,46 +99,46 @@
 (defun show-variables (package)
   (do-symbols (s package)
     (multiple-value-bind (sym status)
-       (find-symbol (symbol-name s) package)
+        (find-symbol (symbol-name s) package)
       (when (and (or (eq status :external)
-                    (eq status :internal))
-                (boundp sym))
-       (format t "~&Symbol ~S~T -> ~S~%"
-               sym
-               (symbol-value sym))))))
+                     (eq status :internal))
+                 (boundp sym))
+        (format t "~&Symbol ~S~T -> ~S~%"
+                sym
+                (symbol-value sym))))))
 
 (defun show-functions (package)
   (do-symbols (s package)
     (multiple-value-bind (sym status)
-       (find-symbol (symbol-name s) package)
+        (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))))))
+                     (eq status :internal))
+                 (fboundp sym))
+        (format t "~&Function ~S~T -> ~S~%"
+                sym
+                (symbol-function sym))))))
 
 (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)
-       (package (symbol-package (class-name (class-of instance)))))
+        (package (symbol-package (class-name (class-of instance)))))
     (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)
-                  (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))))
     (nreverse res)))
 
 (defun run-tests-for-instance (instance)