Commit bd121420 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

Fix find-standard-case-symbol.

Add relevant tests.
parent 9120cf7a
......@@ -347,3 +347,29 @@
#+mkcl (DBG :os i q s (assoc q s))
(assert-equal i (second (assoc q s))))))
(assert-equal (get-optimization-settings) settings))
(DBG :standard-case-symbol-name)
(if (or #+allegro (eq excl:*current-case-mode* :case-sensitive-lower))
(push :modern-syntax *features*)
(setf *features* (remove :modern-syntax *features*)))
(assert-equal (standard-case-symbol-name "foo") #-modern-syntax "FOO" #+modern-syntax "foo")
(assert-equal (standard-case-symbol-name "BaR") #-modern-syntax "BAR" #+modern-syntax "BaR")
(assert-equal (standard-case-symbol-name "BAZ") #-modern-syntax "BAZ" #+modern-syntax "BAZ")
(assert-equal (standard-case-symbol-name :foo) #-modern-syntax "FOO" #+modern-syntax "foo")
(assert-equal (standard-case-symbol-name 'BaR) #-modern-syntax "BAR" #+modern-syntax "BaR")
(assert-equal (standard-case-symbol-name '#:BAZ) #-modern-syntax "BAZ" #+modern-syntax "BAZ")
(assert-equal (standard-case-symbol-name :|foo|) "foo")
(assert-equal (standard-case-symbol-name '|BaR|) "BaR")
(assert-equal (standard-case-symbol-name '#:|BAZ|) "BAZ")
(DBG :find-standard-case-symbol)
(assert-equal 'symbol (find-standard-case-symbol "symbol" "asdf-test"))
(assert-equal 'Symbol (find-standard-case-symbol "Symbol" "asdf-test"))
(assert-equal 'SYMBOL (find-standard-case-symbol "SYMBOL" "asdf-test"))
(assert-equal '|lowercase| (find-standard-case-symbol :|lowercase| :asdf-test))
(assert-equal '|CamelCase| (find-standard-case-symbol :|CamelCase| :asdf-test))
(assert-equal '|UPPER-CASE| (find-standard-case-symbol :|UPPER-CASE| :asdf-test))
(assert-equal #-modern-syntax '|THIS_SYMBOL| #+modern-syntax '|This_Symbol|
(find-standard-case-symbol "This_Symbol" "asdf-test"))
......@@ -332,22 +332,24 @@ the two results passed to STRCAT always reconstitute the original string"
(when x (c +crlf+) (c +lf+) (c +cr+) (values x nil)))))
(defun standard-case-symbol-name (name-designator)
"Given a NAME-DESIGNATOR for a symbol, convert it to a string, using STRING-UPCASE on an ANSI CL
platform, or STRING on a so-called \"modern\" platform such as Allegro with modern syntax."
"Given a NAME-DESIGNATOR for a symbol, if it is a symbol, convert it to a string using STRING;
if it is a string, use STRING-UPCASE on an ANSI CL platform, or STRING on a so-called \"modern\"
platform such as Allegro with modern syntax."
(check-type name-designator (or string symbol))
(cond
((or (symbolp name-designator) #+allegro (eq excl:*current-case-mode* :case-sensitive-lower))
(string name-designator))
;; Should we be doing something on CLISP?
#+allegro ((eq excl:*current-case-mode* :case-sensitive-lower) (string name-designator))
(t (string-upcase name-designator))))
(defun find-standard-case-symbol (name-designator package-designator &optional (error t))
"Find a symbol in a package the name of which is designated by NAME-DESIGNATOR;
NAME-DESIGNATOR and PACKAGE-DESIGNATOR will be converted to a string using STRING-DESIGNATOR on an
ANSI CL platform, or STRING on a so-called \"modern\" platform such as Allegro with modern syntax.
"Find a symbol designated by NAME-DESIGNATOR in a package designated by PACKAGE-DESIGNATOR,
where STANDARD-CASE-SYMBOL-NAME is used to transform them if these designators are strings.
If optional ERROR argument is NIL, return NIL instead of an error when the symbol is not found."
(find-symbol* (standard-case-symbol-name name-designator)
(etypecase package-designator
((or package null) package-designator)
((or string symbol)))
((or package symbol) package-designator)
(string (standard-case-symbol-name package-designator)))
error)))
;;; stamps: a REAL or a boolean where NIL=-infinity, T=+infinity
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment