Skip to content
Snippets Groups Projects
Commit a47b0be1 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

Accommodate for lw:simple-char.

parent b96ddb6a
No related branches found
No related tags found
No related merge requests found
...@@ -17,7 +17,8 @@ ...@@ -17,7 +17,8 @@
;;; '/test/{system1,system2}/' ;;; '/test/{system1,system2}/'
;;; any failure is recorded as a transcript entry which indicates ;;; any failure is recorded as a transcript entry which indicates
;;; ( ( system-pathname module-pathname file-pathname ) missing-pathnames ) ;;; ( ( 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. ;;; If there, if the pathname is logical, both the logical and physical pathname appears.
;;; where NIL appears, the probe-file succeeded. ;;; where NIL appears, the probe-file succeeded.
;;; ;;;
...@@ -297,7 +298,7 @@ ...@@ -297,7 +298,7 @@
;; :static-file "module2/static-file.type" ;; :static-file "module2/static-file.type"
collect (make-pathname :directory directory :name "static-file" :type "type" collect (make-pathname :directory directory :name "static-file" :type "type"
:defaults root) :defaults root)
;;; source file pathname variations ;;; source file pathname variations
collect (make-pathname :directory (append directory '("module2")) :name "untyped-file" :type nil collect (make-pathname :directory (append directory '("module2")) :name "untyped-file" :type nil
:defaults root) :defaults root)
...@@ -379,7 +380,7 @@ ...@@ -379,7 +380,7 @@
:files files :files files
:modules modules :modules modules
:systems systems))))) :systems systems)))))
(when delete-host (when delete-host
(setf (logical-pathname-translations "ASDFTEST") nil)) (setf (logical-pathname-translations "ASDFTEST") nil))
(clear-system "test-system"))) (clear-system "test-system")))
......
...@@ -134,7 +134,7 @@ ...@@ -134,7 +134,7 @@
#+sbcl uiop/lisp-build:sb-grovel-unknown-constant-condition #+sbcl uiop/lisp-build:sb-grovel-unknown-constant-condition
;; on some implementations only ;; on some implementations only
asdf/bundle:bundle-system asdf/bundle:bundle-system
asdf/bundle:register-pre-built-system asdf/bundle:register-pre-built-system
asdf/bundle:static-library asdf/bundle:static-library
uiop/os:parse-file-location-info uiop/os:parse-file-location-info
uiop/os:parse-windows-shortcut uiop/os:parse-windows-shortcut
...@@ -211,14 +211,16 @@ ...@@ -211,14 +211,16 @@
(defun unbasify (s) (coerce s '(array character (*)))) ; on ECL, literals are base strings (!) (defun unbasify (s) (coerce s '(array character (*)))) ; on ECL, literals are base strings (!)
#+non-base-chars-exist-p #+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 (make-string 10 :element-type 'character))))
(assert (not (base-string-p (unbasify "abc")))) (assert (not (base-string-p (unbasify "abc"))))
(assert (base-string-p (basify "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 (reduce/strcat (mapcar 'basify '("a" "b" nil "cd")))))
(assert (base-string-p (strcat (basify "ab") (basify "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 (base-string-p (strcat (basify "ab") #\c #\d))))
(assert-equal +crlf+ (map 'string 'code-char '(13 10))) (assert-equal +crlf+ (map 'string 'code-char '(13 10)))
...@@ -239,5 +241,5 @@ ...@@ -239,5 +241,5 @@
(ts "c" +crlf+ (strcat ccr +lf+)) (ts "c" +crlf+ (strcat ccr +lf+))
(ts (strcat acrlf "b") +lf+ (strcat acrlf blf))) (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)) (println "Hello, World" s))
...@@ -33,7 +33,10 @@ ...@@ -33,7 +33,10 @@
(in-package :uiop/stream) (in-package :uiop/stream)
(with-upgradability () (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)") "default element-type for open (depends on the current CL implementation)")
(defvar *stdin* *standard-input* (defvar *stdin* *standard-input*
......
...@@ -19,6 +19,7 @@ ...@@ -19,6 +19,7 @@
#:remove-plist-keys #:remove-plist-key ;; plists #:remove-plist-keys #:remove-plist-key ;; plists
#:emptyp ;; sequences #:emptyp ;; sequences
#:+non-base-chars-exist-p+ ;; characters #:+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 #:base-string-p #:strings-common-element-type #:reduce/strcat #:strcat ;; strings
#:first-char #:last-char #:split-string #:stripln #:+cr+ #:+lf+ #:+crlf+ #:first-char #:last-char #:split-string #:stripln #:+cr+ #:+lf+ #:+crlf+
#:string-prefix-p #:string-enclosed-p #:string-suffix-p #:string-prefix-p #:string-enclosed-p #:string-suffix-p
...@@ -187,9 +188,29 @@ Returns two values: \(A B C\) and \(1 2 3\)." ...@@ -187,9 +188,29 @@ Returns two values: \(A B C\) and \(1 2 3\)."
;;; Characters ;;; Characters
(with-upgradability () (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*))) (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 ;;; Strings
(with-upgradability () (with-upgradability ()
...@@ -201,10 +222,19 @@ Returns two values: \(A B C\) and \(1 2 3\)." ...@@ -201,10 +222,19 @@ Returns two values: \(A B C\) and \(1 2 3\)."
(defun strings-common-element-type (strings) (defun strings-common-element-type (strings)
"What least subtype of CHARACTER can contain all the elements of all the STRINGS?" "What least subtype of CHARACTER can contain all the elements of all the STRINGS?"
(declare (ignorable strings)) (declare (ignorable strings))
#-non-base-chars-exist-p 'character #.(if +non-base-chars-exist-p+
#+non-base-chars-exist-p `(aref +character-types+
(if (loop :for s :in strings :always (or (null s) (typep s 'base-char) (base-string-p s))) (loop :with index = 0 :for s :in strings :do
'base-char 'character)) (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) (defun reduce/strcat (strings &key key start end)
"Reduce a list as if by STRCAT, accepting KEY START and END keywords like REDUCE. "Reduce a list as if by STRCAT, accepting KEY START and END keywords like REDUCE.
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment