From 1e1ae77a17a3e03aef130119186297d80efe1200 Mon Sep 17 00:00:00 2001 From: Matthias Benkard <code@mail.matthias.benkard.de> Date: Tue, 5 Feb 2008 17:59:08 +0100 Subject: Simplify SLOT-NAME->FOREIGN-SLOT-NAME. darcs-hash:f106034cce0323b22f0aa80b43bccf9d60e471f7 --- Lisp/name-conversion.lisp | 31 +++++++++++++++++-------------- 1 file changed, 17 insertions(+), 14 deletions(-) diff --git a/Lisp/name-conversion.lisp b/Lisp/name-conversion.lisp index 55ea829..70fd919 100644 --- a/Lisp/name-conversion.lisp +++ b/Lisp/name-conversion.lisp @@ -117,17 +117,20 @@ (defun slot-name->foreign-slot-name (slot-name) - (let* ((string (symbol-name slot-name)) - (case-converted-slot-name - (ecase (readtable-case *readtable*) - (:preserve string) - (:invert (cond ((notany #'lower-case-p string) - (string-downcase string)) - ((notany #'upper-case-p string) - (string-upcase string)) - (t string))) - (:upcase (if (notany #'lower-case-p string) - (string-downcase string) - string)) - (:downcase string)))) - (substitute #\_ #\- case-converted-slot-name))) + (substitute #\_ #\- (name->lower-case (symbol-name slot-name)))) + + +(defun name->lower-case (string) + (cond ((name-typed-in-canonical-case-p) (string-downcase string)) + ((and (eq (readtable-case *readtable*) :invert) + (notany #'upper-case-p string)) + (string-upcase string)) + (t string))) + + +(defun name-typed-in-canonical-case-p (string) + (or (and (member (readtable-case *readtable*) + '(:downcase :invert :preserve)) + (notany #'upper-case-p string)) + (and (member (readtable-case *readtable*)) + (notany #'lower-case-p string)))) -- cgit v1.2.3