Commit 503ba006 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

UIOP: support LispWorks 7's new character type hierarchy.

Also, while testing, rename the default lispworks binary to lispworks-console
in accord with the latest version of lisp-invocation.
parent 9278f28a
...@@ -260,7 +260,7 @@ case "$lisp" in ...@@ -260,7 +260,7 @@ case "$lisp" in
nodebug="-batch" nodebug="-batch"
eval="-eval" ;; eval="-eval" ;;
lispworks) lispworks)
command="${LISPWORKS:-lispworks}" command="${LISPWORKS:-lispworks-console}"
# If you have a licensed copy of lispworks, # If you have a licensed copy of lispworks,
# you can obtain the "lispworks" binary with, e.g. # you can obtain the "lispworks" binary with, e.g.
# echo '(hcl:save-image "/lispworks" :environment nil)' > /tmp/build.lisp ; # echo '(hcl:save-image "/lispworks" :environment nil)' > /tmp/build.lisp ;
......
...@@ -8,8 +8,8 @@ ...@@ -8,8 +8,8 @@
:ensure-directory t)) :ensure-directory t))
(chdir *asdf-directory*) (chdir *asdf-directory*)
(assert-pathname-equal *asdf-directory* (getcwd))) (assert-pathname-equal *asdf-directory* (getcwd))
(assert-pathname-equal *asdf-directory* (getcwd-from-run-program))) (assert-pathname-equal *asdf-directory* (getcwd-from-run-program))
(assert (probe-file* "asdf.asd")) (assert (probe-file* "asdf.asd"))
(chdir *test-directory*) (chdir *test-directory*)
...@@ -270,6 +270,7 @@ ...@@ -270,6 +270,7 @@
#+non-base-chars-exist-p #+non-base-chars-exist-p
(progn (progn
(assert (= 0 (character-type-index #\a)))
(assert (not (base-string-p *last-char-string*))) (assert (not (base-string-p *last-char-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"))))
...@@ -278,7 +279,19 @@ ...@@ -278,7 +279,19 @@
(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 *last-char* (unbasify "d"))))) (assert (not (base-string-p (strcat (basify "ab") #\c *last-char* (unbasify "d")))))
(assert (base-string-p (strcat (basify "ab") #\c #\d)))) (assert (base-string-p (strcat (basify "ab") #\c #\d)))
(when (< 256 char-code-limit)
(let* ((lambda-char (code-char 955))
(lambda-string (string lambda-char)))
(assert (= 1 (character-type-index lambda-char)))
(assert-equal (strings-common-element-type (list #\a nil (strcat "hello, " lambda-string "world")))
#-lispworks 'character #+lispworks7 'lw:bmp-char #+(and lispworks (not lispworks7)) 'lw:simple-char)
(when (< 65536 char-code-limit)
(let* ((amagi (format nil "~a~a" (code-char #x120BC) (code-char #x12104))))
(assert (= #+lispworks7 2 #-lispworks7 1 (character-type-index (first-char amagi))))
(assert-equal (strings-common-element-type (list #\a nil amagi lambda-string))
#+(or (not lispworks) lispworks7) 'character
#+(and lispworks (not lispworks7)) 'lw:simple-char))))))
(assert-equal +crlf+ (map 'string 'code-char '(13 10))) (assert-equal +crlf+ (map 'string 'code-char '(13 10)))
(assert-equal +lf+ (map 'string 'code-char '(10))) (assert-equal +lf+ (map 'string 'code-char '(10)))
......
...@@ -195,15 +195,24 @@ Returns two values: \(A B C\) and \(1 2 3\)." ...@@ -195,15 +195,24 @@ Returns two values: \(A B C\) and \(1 2 3\)."
;;; Characters ;;; Characters
(with-upgradability () ;; base-char != character on ECL, LW, SBCL, Genera. LW also has SIMPLE-CHAR.
(defconstant +non-base-chars-exist-p+ #.(not (subtypep 'character 'base-char)))
#-scl ;; In SCL, all characters seem to be 16-bit base-char, but this flag gets set somehow???
(when +non-base-chars-exist-p+ (pushnew :non-base-chars-exist-p *features*)))
(with-upgradability () (with-upgradability ()
;; base-char != character on ECL, LW, SBCL, Genera.
;; NB: We assume a total order on character types.
;; If that's not true... this code will need to be updated.
(defparameter +character-types+ ;; assuming a simple hierarchy (defparameter +character-types+ ;; assuming a simple hierarchy
#(#+non-base-chars-exist-p base-char #+lispworks lw:simple-char character)) #.(coerce (loop* :for (type next) :on
(defparameter +max-character-type-index+ (1- (length +character-types+)))) '(;; In SCL, all characters seem to be 16-bit base-char
;; Yet somehow character fails to be a subtype of base-char
#-scl base-char
;; LW6 has BASE-CHAR < SIMPLE-CHAR < CHARACTER
;; LW7 has BASE-CHAR < BMP-CHAR < SIMPLE-CHAR = CHARACTER
#+lispworks7 lw:bmp-char #+lispworks lw:simple-char
character)
:unless (and next (subtypep next type))
:collect type) 'vector))
(defparameter +max-character-type-index+ (1- (length +character-types+)))
(defconstant +non-base-chars-exist-p+ (plusp +max-character-type-index+))
(when +non-base-chars-exist-p+ (pushnew :non-base-chars-exist-p *features*)))
(with-upgradability () (with-upgradability ()
(defun character-type-index (x) (defun character-type-index (x)
...@@ -215,7 +224,7 @@ Returns two values: \(A B C\) and \(1 2 3\)." ...@@ -215,7 +224,7 @@ Returns two values: \(A B C\) and \(1 2 3\)."
(symbol (if (subtypep x 'base-char) 0 1)))) (symbol (if (subtypep x 'base-char) 0 1))))
(otherwise (otherwise
'(or (position-if (etypecase x '(or (position-if (etypecase x
(character #'(lambda (type) (typep x type))) (character #'(lambda (type) (typep x type)))
(symbol #'(lambda (type) (subtypep x type)))) (symbol #'(lambda (type) (subtypep x type))))
+character-types+) +character-types+)
(error "Not a character or character type: ~S" x)))))) (error "Not a character or character type: ~S" x))))))
...@@ -234,14 +243,20 @@ Returns two values: \(A B C\) and \(1 2 3\)." ...@@ -234,14 +243,20 @@ Returns two values: \(A B C\) and \(1 2 3\)."
#.(if +non-base-chars-exist-p+ #.(if +non-base-chars-exist-p+
`(aref +character-types+ `(aref +character-types+
(loop :with index = 0 :for s :in strings :do (loop :with index = 0 :for s :in strings :do
(cond (flet ((consider (i)
((= index ,+max-character-type-index+) (return index)) (cond ((= i ,+max-character-type-index+) (return i))
((emptyp s)) ;; NIL or empty string ,@(when (> +max-character-type-index+ 1) `(((> i index) (setf index i)))))))
((characterp s) (setf index (max index (character-type-index s)))) (cond
((stringp s) (unless (>= index (character-type-index (array-element-type s))) ((emptyp s)) ;; NIL or empty string
(setf index (reduce 'max s :key #'character-type-index ((characterp s) (consider (character-type-index s)))
:initial-value index)))) ((stringp s) (let ((string-type-index
(t (error "Invalid string designator ~S for ~S" s 'strings-common-element-type))) (character-type-index (array-element-type s))))
(unless (>= index string-type-index)
(loop :for c :across s :for i = (character-type-index c)
:do (consider i)
,@(when (> +max-character-type-index+ 1)
`((when (= i string-type-index) (return))))))))
(t (error "Invalid string designator ~S for ~S" s 'strings-common-element-type))))
:finally (return index))) :finally (return index)))
''character)) ''character))
......
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