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

Accommodate for lw:simple-char.

parent b96ddb6a
......@@ -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")))
......
......@@ -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))
......@@ -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*
......
......@@ -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.
......
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