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

test/run-tests.sh

+1 −1
Original line number Diff line number Diff line
@@ -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 ;

test/test-utilities.script

+16 −3
Original line number Diff line number Diff line
@@ -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)))

uiop/utility.lisp

+31 −16
Original line number Diff line number Diff line
@@ -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)
@@ -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

              (flet ((consider (i)

                       (cond ((= i ,+max-character-type-index+) (return i))

                             ,@(when (> +max-character-type-index+ 1) `(((> i index) (setf index i)))))))

                (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)))

                  ((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))