diff --git a/test/asdf-pathname-test.script b/test/asdf-pathname-test.script index c6a679187aff2173265764b2a2f151dfbfe042cd..aeab9fd0bb159fa3cebfd477ed594e13f1f36e7f 100644 --- a/test/asdf-pathname-test.script +++ b/test/asdf-pathname-test.script @@ -17,7 +17,8 @@ ;;; '/test/{system1,system2}/' ;;; any failure is recorded as a transcript entry which indicates ;;; ( ( system-pathname module-pathname file-pathname ) missing-pathnames ) -;;; where missing pathnames is a list of the component-pathname values which failed to designate an intended file. +;;; where missing pathnames is a list of the component-pathname values +;;; which failed to designate an intended file. ;;; If there, if the pathname is logical, both the logical and physical pathname appears. ;;; where NIL appears, the probe-file succeeded. ;;; @@ -297,7 +298,7 @@ ;; :static-file "module2/static-file.type" collect (make-pathname :directory directory :name "static-file" :type "type" :defaults root) - + ;;; source file pathname variations collect (make-pathname :directory (append directory '("module2")) :name "untyped-file" :type nil :defaults root) @@ -379,7 +380,7 @@ :files files :modules modules :systems systems))))) - + (when delete-host (setf (logical-pathname-translations "ASDFTEST") nil)) (clear-system "test-system"))) diff --git a/test/test-utilities.script b/test/test-utilities.script index 4ca98db63ba445cb82042ea1c6f16133ff19c588..e90e93189ae4ca75636d662b68b9fd85d6125b03 100644 --- a/test/test-utilities.script +++ b/test/test-utilities.script @@ -134,7 +134,7 @@ #+sbcl uiop/lisp-build:sb-grovel-unknown-constant-condition ;; on some implementations only asdf/bundle:bundle-system - asdf/bundle:register-pre-built-system + asdf/bundle:register-pre-built-system asdf/bundle:static-library uiop/os:parse-file-location-info uiop/os:parse-windows-shortcut @@ -211,14 +211,16 @@ (defun unbasify (s) (coerce s '(array character (*)))) ; on ECL, literals are base strings (!) #+non-base-chars-exist-p -(progn +(let* ((limit-char (code-char (1- char-code-limit))) + (limit-string (string limit-char))) + (assert (not (base-string-p limit-string))) (assert (not (base-string-p (make-string 10 :element-type 'character)))) (assert (not (base-string-p (unbasify "abc")))) (assert (base-string-p (basify "abc"))) - (assert (not (base-string-p (strcat "a" nil #\b (unbasify "cd"))))) + (assert (base-string-p (strcat "a" nil #\b (unbasify "cd")))) (assert (base-string-p (reduce/strcat (mapcar 'basify '("a" "b" nil "cd"))))) (assert (base-string-p (strcat (basify "ab") (basify "cd")))) - (assert (not (base-string-p (strcat (basify "ab") #\c (unbasify "d"))))) + (assert (not (base-string-p (strcat (basify "ab") #\c limit-char (unbasify "d"))))) (assert (base-string-p (strcat (basify "ab") #\c #\d)))) (assert-equal +crlf+ (map 'string 'code-char '(13 10))) @@ -239,5 +241,5 @@ (ts "c" +crlf+ (strcat ccr +lf+)) (ts (strcat acrlf "b") +lf+ (strcat acrlf blf))) -(with-temporary-file (:stream s :direction :io :element-type 'character :prefix "LEP") +(with-temporary-file (:stream s :direction :io :prefix "LEP") (println "Hello, World" s)) diff --git a/uiop/stream.lisp b/uiop/stream.lisp index c647812eca78eff0308776a45bc8f8b86958355c..54daba02079be4f138ba3493906ce74ca7f7fc78 100644 --- a/uiop/stream.lisp +++ b/uiop/stream.lisp @@ -33,7 +33,10 @@ (in-package :uiop/stream) (with-upgradability () - (defvar *default-stream-element-type* (or #+(or abcl cmu cormanlisp scl xcl) 'character :default) + (defvar *default-stream-element-type* + (or #+(or abcl cmu cormanlisp scl xcl) 'character + #+lispworks 'lw:simple-char + :default) "default element-type for open (depends on the current CL implementation)") (defvar *stdin* *standard-input* diff --git a/uiop/utility.lisp b/uiop/utility.lisp index a7b515a24bc9996a599bf44c5d631597e940c2ee..4d6db338f1a959419a8cb1c6447bc8d27355787b 100644 --- a/uiop/utility.lisp +++ b/uiop/utility.lisp @@ -19,6 +19,7 @@ #:remove-plist-keys #:remove-plist-key ;; plists #:emptyp ;; sequences #:+non-base-chars-exist-p+ ;; characters + #:+max-character-type-index+ #:character-type-index #:+character-types+ #: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 @@ -187,9 +188,29 @@ Returns two values: \(A B C\) and \(1 2 3\)." ;;; Characters (with-upgradability () - (defconstant +non-base-chars-exist-p+ (not (subtypep 'character 'base-char))) + (defconstant +non-base-chars-exist-p+ (not (subtypep 'character 'base-char))) ;; ECL, LW, SBCL (when +non-base-chars-exist-p+ (pushnew :non-base-chars-exist-p *features*))) +(with-upgradability () + (defparameter +character-types+ ;; assuming a simple hierarchy + #(#+non-base-chars-exist-p base-char #+lispworks lw:simple-char character)) + (defparameter +max-character-type-index+ (1- (length +character-types+)))) + +(with-upgradability () + (defun character-type-index (x) + (declare (ignorable x)) + #.(case +max-character-type-index+ + (0 0) + (1 '(etypecase x + (character (if (typep x 'base-char) 0 1)) + (symbol (if (subtypep x 'base-char) 0 1)))) + (otherwise + '(or (position-if (etypecase x + (character #'(lambda (type) (typep x type))) + (symbol #'(lambda (type) (subtypep x type)))) + +character-types+) + (error "Not a character or character type: ~S" x)))))) + ;;; Strings (with-upgradability () @@ -201,10 +222,19 @@ Returns two values: \(A B C\) and \(1 2 3\)." (defun strings-common-element-type (strings) "What least subtype of CHARACTER can contain all the elements of all the STRINGS?" (declare (ignorable strings)) - #-non-base-chars-exist-p 'character - #+non-base-chars-exist-p - (if (loop :for s :in strings :always (or (null s) (typep s 'base-char) (base-string-p s))) - 'base-char 'character)) + #.(if +non-base-chars-exist-p+ + `(aref +character-types+ + (loop :with index = 0 :for s :in strings :do + (cond + ((= index ,+max-character-type-index+) (return index)) + ((emptyp s)) ;; NIL or empty string + ((characterp s) (setf index (max index (character-type-index s)))) + ((stringp s) (unless (>= index (character-type-index (array-element-type s))) + (setf index (reduce 'max s :key #'character-type-index + :initial-value index)))) + (t (error "Invalid string designator ~S for ~S" s 'strings-common-element-type))) + :finally (return index))) + ''character)) (defun reduce/strcat (strings &key key start end) "Reduce a list as if by STRCAT, accepting KEY START and END keywords like REDUCE.