;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: symbols.lisp,v 1.5 2003/08/05 23:00:28 kevin Exp $
+;;;; $Id$
;;;;
;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
(eval-when (:compile-toplevel :load-toplevel :execute)
(when (char= #\a (schar (symbol-name '#:a) 0))
- (pushnew :lowercase-reader *features*)))
+ (pushnew :lowercase-reader *features*))
+ (when (not (eql '#:a '#:A))
+ (pushnew :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)
+ #-lowercase-reader
+ (string-upcase str)
+ #+lowercase-reader
+ (string-downcase str))
(defun concat-symbol-pkg (pkg &rest args)
(declare (dynamic-extent args))
(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)
"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