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

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
nodebug="-batch"
eval="-eval" ;;
lispworks)
command="${LISPWORKS:-lispworks}"
command="${LISPWORKS:-lispworks-console}"
# If you have a licensed copy of lispworks,
# you can obtain the "lispworks" binary with, e.g.
# echo '(hcl:save-image "/lispworks" :environment nil)' > /tmp/build.lisp ;
......
......@@ -8,8 +8,8 @@
:ensure-directory t))
(chdir *asdf-directory*)
(assert-pathname-equal *asdf-directory* (getcwd)))
(assert-pathname-equal *asdf-directory* (getcwd-from-run-program)))
(assert-pathname-equal *asdf-directory* (getcwd))
(assert-pathname-equal *asdf-directory* (getcwd-from-run-program))
(assert (probe-file* "asdf.asd"))
(chdir *test-directory*)
......@@ -270,6 +270,7 @@
#+non-base-chars-exist-p
(progn
(assert (= 0 (character-type-index #\a)))
(assert (not (base-string-p *last-char-string*)))
(assert (not (base-string-p (make-string 10 :element-type 'character))))
(assert (not (base-string-p (unbasify "abc"))))
......@@ -278,7 +279,19 @@
(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 *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 +lf+ (map 'string 'code-char '(10)))
......
......@@ -195,15 +195,24 @@ Returns two values: \(A B C\) and \(1 2 3\)."
;;; 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 ()
;; 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
#(#+non-base-chars-exist-p base-char #+lispworks lw:simple-char character))
(defparameter +max-character-type-index+ (1- (length +character-types+))))
#.(coerce (loop* :for (type next) :on
'(;; 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 ()
(defun character-type-index (x)
......@@ -215,7 +224,7 @@ Returns two values: \(A B C\) and \(1 2 3\)."
(symbol (if (subtypep x 'base-char) 0 1))))
(otherwise
'(or (position-if (etypecase x
(character #'(lambda (type) (typep x type)))
(character #'(lambda (type) (typep x type)))
(symbol #'(lambda (type) (subtypep x type))))
+character-types+)
(error "Not a character or character type: ~S" x))))))
......@@ -234,14 +243,20 @@ Returns two values: \(A B C\) and \(1 2 3\)."
#.(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)))
(flet ((consider (i)
(cond ((= i ,+max-character-type-index+) (return i))
,@(when (> +max-character-type-index+ 1) `(((> i index) (setf index i)))))))
(cond
((emptyp s)) ;; NIL or empty string
((characterp s) (consider (character-type-index s)))
((stringp s) (let ((string-type-index
(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)))
''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