From 3022a31f84dbc16d574e5bf9de26be91b31fa65b Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <tunes@google.com> Date: Sat, 25 Apr 2015 23:12:05 -0400 Subject: [PATCH] uiop/utility: add standard-case-symbol-name and find-standard-case-symbol --- uiop/package.lisp | 2 +- uiop/utility.lisp | 21 ++++++++++++++++++++- 2 files changed, 21 insertions(+), 2 deletions(-) diff --git a/uiop/package.lisp b/uiop/package.lisp index 8f7b0547..cd713944 100644 --- a/uiop/package.lisp +++ b/uiop/package.lisp @@ -37,7 +37,7 @@ (t nil)))) (defun find-symbol* (name package-designator &optional (error t)) "Find a symbol in a package of given string'ified NAME; -unless CL:FIND-SYMBOL, work well with 'modern' case sensitive syntax +unlike CL:FIND-SYMBOL, work well with 'modern' case sensitive syntax by letting you supply a symbol or keyword for the name; also works well when the package is not present. If optional ERROR argument is NIL, return NIL instead of an error diff --git a/uiop/utility.lisp b/uiop/utility.lisp index 6bc4ff47..adc217cd 100644 --- a/uiop/utility.lisp +++ b/uiop/utility.lisp @@ -24,6 +24,7 @@ #:base-string-p #:strings-common-element-type #:reduce/strcat #:strcat ;; strings #:first-char #:last-char #:split-string #:stripln #:+cr+ #:+lf+ #:+crlf+ #:string-prefix-p #:string-enclosed-p #:string-suffix-p + #:standard-case-symbol-name #:find-standard-case-symbol #:coerce-class ;; CLOS #:stamp< #:stamps< #:stamp*< #:stamp<= ;; stamps #:earlier-stamp #:stamps-earliest #:earliest-stamp @@ -312,7 +313,7 @@ starting the separation from the end, e.g. when called with arguments (defun string-enclosed-p (prefix string suffix) "Does STRING begin with PREFIX and end with SUFFIX?" (and (string-prefix-p prefix string) - (string-suffix-p string suffix)))) + (string-suffix-p string suffix))) (defvar +cr+ (coerce #(#\Return) 'string)) (defvar +lf+ (coerce #(#\Linefeed) 'string)) @@ -330,6 +331,24 @@ the two results passed to STRCAT always reconstitute the original string" (return (values (subseq x 0 (- (length x) (length end))) end))))) (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." + (cond + ;; 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. +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))) + error))) ;;; stamps: a REAL or a boolean where NIL=-infinity, T=+infinity (eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) -- GitLab