From f5df120eff98c753d238a64c2db19c9665bc50c5 Mon Sep 17 00:00:00 2001 From: Andreas Fuchs <asf@boinkor.net> Date: Thu, 23 Sep 2010 06:38:03 -0700 Subject: [PATCH] Support case-sensitive lisps. * Alter `format-symbol` to accept a string designator as the format control. * Use uninterned symbols as format control for type names in type.lisp to get the correct names in case-sensitive lisps. --- symbols.lisp | 12 ++++++------ types.lisp | 10 +++++----- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/symbols.lisp b/symbols.lisp index 44c0d71..e612afc 100644 --- a/symbols.lisp +++ b/symbols.lisp @@ -21,12 +21,12 @@ Example: (declaim (inline format-symbol)) (defun format-symbol (package control &rest arguments) - "Constructs a string by applying ARGUMENTS to CONTROL as if by FORMAT, and -then creates a symbol named by that string. If PACKAGE is NIL, returns an -uninterned symbol, if package is T, returns a symbol interned in the current -package, and otherwise returns a symbol interned in the package designated by -PACKAGE." - (maybe-intern (apply #'format nil control arguments) package)) + "Constructs a string by applying ARGUMENTS to string designator +CONTROL as if by FORMAT, and then creates a symbol named by that +string. If PACKAGE is NIL, returns an uninterned symbol, if package is +T, returns a symbol interned in the current package, and otherwise +returns a symbol interned in the package designated by PACKAGE." + (maybe-intern (apply #'format nil (string control) arguments) package)) (defun make-keyword (name) "Interns the string designated by NAME in the KEYWORD package." diff --git a/types.lisp b/types.lisp index dd354f3..b806c0d 100644 --- a/types.lisp +++ b/types.lisp @@ -24,7 +24,7 @@ ARRAY-DIMENSION-LIMIT." (push result subtype-names) result)) (make-predicate-name (sybtype-name) - (let ((result (format-symbol :alexandria "~A-P" + (let ((result (format-symbol :alexandria '#:~A-p (symbol-name sybtype-name)))) (push result predicate-names) result)) @@ -34,10 +34,10 @@ ARRAY-DIMENSION-LIMIT." type (if (equal range-beg ''*) inf (ensure-car range-beg)) (if (equal range-end ''*) inf (ensure-car range-end)))))) - (let* ((negative-name (make-subtype-name "NEGATIVE-~A")) - (non-positive-name (make-subtype-name "NON-POSITIVE-~A")) - (non-negative-name (make-subtype-name "NON-NEGATIVE-~A")) - (positive-name (make-subtype-name "POSITIVE-~A")) + (let* ((negative-name (make-subtype-name '#:negative-~A)) + (non-positive-name (make-subtype-name '#:non-positive-~A)) + (non-negative-name (make-subtype-name '#:non-negative-~A)) + (positive-name (make-subtype-name '#:positive-~A)) (negative-p-name (make-predicate-name negative-name)) (non-positive-p-name (make-predicate-name non-positive-name)) (non-negative-p-name (make-predicate-name non-negative-name)) -- GitLab