June 2026 - cmucl-cvs - mailman3.common-lisp.net

[Git][cmucl/cmucl][master] 2 commits: Fix #318: Add standard-char type
by Raymond Toy (＠rtoy) 26 Jun '26

26 Jun '26

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 2aa2eff9 by Raymond Toy at 2026-06-26T09:56:12-07:00 Fix #318: Add standard-char type - - - - - 06740b40 by Raymond Toy at 2026-06-26T09:56:13-07:00 Merge branch 'issue-318-add-concrete-standard-char-type' into 'master' Fix #318: Add standard-char type Closes #318 See merge request cmucl/cmucl!377 - - - - - 5 changed files: - src/code/exports.lisp - src/code/pred.lisp - src/code/type.lisp - src/i18n/locale/cmucl.pot - + tests/standard-char.lisp Changes: ===================================== src/code/exports.lisp ===================================== @@ -2190,7 +2190,11 @@ "STANDARD-PPRINT-DISPATCH-TABLE-MODIFIED-ERROR" "%IEEE754-REM-PI/2" - "%SINCOS") + "%SINCOS" + + "STANDARD-CHAR-TYPE" + "MAKE-STANDARD-CHAR-TYPE" + "STANDARD-CHAR-TYPE-P") #+heap-overflow-check (:export "DYNAMIC-SPACE-OVERFLOW-WARNING-HIT" "DYNAMIC-SPACE-OVERFLOW-ERROR-HIT" ===================================== src/code/pred.lisp ===================================== @@ -291,6 +291,9 @@ (and (consp object) (%%typep (car object) (cons-type-car-type type)) (%%typep (cdr object) (cons-type-cdr-type type)))) + (kernel::standard-char-type + (and (characterp object) + (standard-char-p object))) (unknown-type ;; Parse it again to make sure it's really undefined. (let ((reparse (specifier-type (unknown-type-specifier type)))) ===================================== src/code/type.lisp ===================================== @@ -52,6 +52,7 @@ (define-type-class intersection) (define-type-class alien) (define-type-class cons) +(define-type-class standard-char) ;;; The Args-Type structure is used both to represent Values types and ;;; and Function types. @@ -363,6 +364,16 @@ *empty-type* (%make-cons-type car-type cdr-type))) +(defstruct (standard-char-type + (:include ctype + (class-info (type-class-or-lose 'standard-char)) + (:enumerable t)) + (:constructor %make-standard-char-type ()) + (:copier nil) + (:print-function %print-type))) + +(defun make-standard-char-type () + (%make-standard-char-type)) ;;; @@ -3293,6 +3304,121 @@ (cons-type-car-type type2)) cdr-int2))))) + +;;;; Standard-char type +(def-type-translator standard-char () + (make-standard-char-type)) + +(define-type-method (standard-char :unparse) (type) + (declare (ignore type)) + 'standard-char) + +(define-type-method (standard-char :simple-=) (type1 type2) + (declare (ignore type1 type2)) + (values t t)) + +(define-type-method (standard-char :simple-subtypep) (type1 type2) + (declare (ignore type1 type2)) + (values t t)) + +(defconstant +standard-chars+ + '(#\NEWLINE #\SPACE #\! #\" #\# #\$ #\% #\& #\' #$ #$ #\* #\+ #\, + #\- #\. #\/ #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\: #\; #\< #\= + #\> #\? #\@ #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M + #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z #\[ #\\ #\] + #\^ #\_ #\` #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m + #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\{ + #\| #\} #\~) + "The set of characters in the STANDARD-CHAR type") + +(define-type-method (standard-char :simple-union) (type1 type2) + (declare (ignore type2)) + type1) + +(define-type-method (standard-char :simple-intersection) (type1 type2) + (declare (ignore type2)) + type1) + +;; (subtype standard-char other) +(define-type-method (standard-char :complex-subtypep-arg1) (type1 type2) + (declare (ignore type1)) + (cond ((csubtypep (specifier-type 'character) type2) + ;; STANDARD-CHAR is a subtype of CHARACTER/BASE-CHAR + (values t t)) + ((member-type-p type2) + ;; If TYPE2 is a member-type, check whether it contains all standard-chars + (values (let ((members (member-type-members type2))) + (every #'(lambda (c) + (member c members)) + +standard-chars+)) + t)) + (t + (values nil t)))) + +;; (subtypep other standard-char) +(define-type-method (standard-char :complex-subtypep-arg2) (type1 type2) + (declare (ignore type2)) + (cond ((member-type-p type1) + ;; If TYPE1 is a member-type, check whether it contains all + ;; standard-chars. + (values (every #'(lambda (c) + (member c +standard-chars+)) + (member-type-members type1)) + t)) + (t + (values nil t)))) + +(define-type-method (standard-char :complex-union) (type1 type2) + ;; The standard-char type could be in type1 or type2. Figure out + ;; which one is a standard-char. + (multiple-value-bind (sc other) + (if (standard-char-type-p type1) + (values type1 type2) + (values type2 type1)) + (cond + ((csubtypep (specifier-type 'character) other) + other) + ((and (member-type-p other) + ;; Check to see every member of OTHER is a STANDARD-CHAR. + (every #'(lambda (c) + (member c +standard-chars+)) + (member-type-members other))) + sc) + (t nil)))) + +(define-type-method (standard-char :complex-intersection) (type1 type2) + ;; The standard-char type could be in type1 or type2. Figure out + ;; which one is a standard-char. + (multiple-value-bind (sc other) + (if (standard-char-type-p type1) + (values type1 type2) + (values type2 type1)) + (cond + ((csubtypep (specifier-type 'character) other) + ;; STANDARD-CHAR intersect any super-type of CHARACTER is a + ;; STANDARD-CHAR. + sc) + (t + (block punt + ;; Look through OTHER and find OTHER contains any standard + ;; character. If so, collect them all. If there are, the + ;; intersection is a member-type of the collected characters. + (collect ((members)) + (dolist (ch +standard-chars+) + (multiple-value-bind (val win) + (ctypep ch other) + (unless win + (return-from punt nil)) + (when val + (members ch)))) + (cond ((null (members)) + c::*empty-type*) + ((= (length (members)) + (length +standard-chars+)) + sc) + (t + (make-member-type :members (members)))))))))) + ;;; TYPE-DIFFERENCE -- Interface ;;; @@ -3379,7 +3505,8 @@ (declare (type ctype type)) (etypecase type ((or numeric-type named-type member-type array-type - kernel::built-in-class cons-type) + kernel::built-in-class cons-type + standard-char-type) (values (%typep obj type) t)) (class (if (if (csubtypep type (specifier-type 'funcallable-instance)) @@ -3520,16 +3647,6 @@ "Type of characters that aren't base-char's. None in CMU CL." '(and character (not base-char))) -(deftype standard-char () - "Type corresponding to the charaters required by the standard." - '(member #\NEWLINE #\SPACE #\! #\" #\# #\$ #\% #\& #\' #$ #$ #\* #\+ #\, - #\- #\. #\/ #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\: #\; #\< #\= - #\> #\? #\@ #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M - #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z #\[ #\\ #\] - #\^ #\_ #\` #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m - #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\{ - #\| #\} #\~)) - (deftype keyword () "Type for any keyword symbol." '(and symbol (satisfies keywordp))) ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -1225,11 +1225,11 @@ msgid "Array dimensions is not a list, integer or *:~% ~S" msgstr "" #: src/code/type.lisp -msgid "Type of characters that aren't base-char's. None in CMU CL." +msgid "The set of characters in the STANDARD-CHAR type" msgstr "" #: src/code/type.lisp -msgid "Type corresponding to the charaters required by the standard." +msgid "Type of characters that aren't base-char's. None in CMU CL." msgstr "" #: src/code/type.lisp ===================================== tests/standard-char.lisp ===================================== @@ -0,0 +1,367 @@ +;;; Tests for standard-char + +(defpackage :standard-char-tests + (:use :cl :lisp-unit)) + +(in-package "STANDARD-CHAR-TESTS") + +;; For the following tests, we generally want to use +;; kernel::type-intersection and kernel::type-union directly to make +;; sure we test the intersection and union methods for standard-char. + +(define-test standard-char.typep + (:tag :issues) + (assert-true (typep #\a 'standard-char)) + (assert-false (typep #\tab 'standard-char)) + (assert-true (typep #\Z 'standard-char)) + (assert-true (typep #\Space 'standard-char)) + (assert-true (typep #\Newline 'standard-char)) + (assert-false (typep #\Rubout 'standard-char)) + (assert-false (typep 5 'standard-char)) + (assert-false (typep "hello" 'standard-char)) + (assert-false (typep nil 'standard-char)) + (assert-false (typep t 'standard-char)) + + (assert-equal (values t t) + (subtypep 'standard-char 'character)) + (assert-equal (values nil t) + (subtypep 'character 'standard-char)) + (assert-equal (values t t) + (subtypep 'standard-char 'base-char)) + (assert-equal (values nil t) + (subtypep 'base-char 'standard-char))) + +(define-test standard-char.etypecase-15 + (:tag :issues) + (assert-equal (values t t) + (c::type= + (c::specifier-type + '(not (or pathname boolean standard-char standard-object character file-error))) + (c::specifier-type + '(not (or file-error character standard-object standard-char boolean pathname)))))) + +(define-test standard-char.identity + (:tag :issues) + (let ((a (c::specifier-type 'standard-char)) + (b (c::specifier-type 'standard-char))) + ;; Should be EQ due to internal caching. + (assert-eq a b))) + +(define-test standard-char.parsing + (:tag :issues) + (assert-eq 'standard-char + (c::type-specifier (c::specifier-type 'standard-char)))) + +(define-test standard-char.predicate + (:tag :issues) + (assert-true (c::standard-char-type-p (c::specifier-type 'standard-char)))) + +(define-test standard-char.simple-subtypep + (:tag :issues) + (assert-equal (values t t) + (c::type= (c::specifier-type 'standard-char) + (c::specifier-type 'standard-char))) + (assert-equal (values t t) + (subtypep 'standard-char 'standard-char))) + +(define-test standard-char.complex-subtype-arg1 + (:tag :issues) + ;; STANDARD-CHAR is a subtype of CHARACTER and T. + (assert-equal (values t t) + (subtypep 'standard-char 'character)) + (assert-equal (values t t) + (subtypep 'standard-char t)) + + ;; Not a subtype of disjoint types. + (assert-equal (values nil t) + (subtypep 'standard-char 'integer)) + (assert-equal (values nil t) + (subtypep 'standard-char 'symbol)) + (assert-equal (values nil t) + (subtypep 'standard-char 'pathname)) + + ;; Subtype of a member-type that contains all standard chars. + (assert-equal (values t t) + (subtypep 'standard-char + `(member ,@kernel::+standard-chars+))) + ;; Not a subtype of a member-type missing even one standard char. + (assert-equal (values nil t) + (subtypep 'standard-char '(member #\a)))) + +(define-test standard-char.complex-subtypep-arg + (:tag :issues) + ;; All standard chars: subtype. + (assert-equal (values t t) + (subtypep '(member #\a) 'standard-char)) + (assert-equal (values t t) + (subtypep '(member #\Space #\Newline) 'standard-char)) + + ;; Mixed — character but not standard. + (assert-equal (values nil t) + (subtypep '(member #\Tab) 'standard-char)) + (assert-equal (values nil t) + (subtypep '(member #\Rubout) 'standard-char)) + + ;; Mixed — non-character members. This was the crash case. + (assert-equal (values nil t) + (subtypep '(member t) 'standard-char)) + (assert-equal (values nil t) + (subtypep '(member t nil) 'standard-char)) + + ;; Mixed — some standard, some not. + (assert-equal (values nil t) + (subtypep '(member #\a #\Tab) 'standard-char)) + (assert-equal (values nil t) + (subtypep '(member #\a t) 'standard-char)) + + ;; CHARACTER is not a subtype of STANDARD-CHAR (non-standard chars exist). + (assert-equal (values nil t) + (subtypep 'character 'standard-char))) + +(define-test standard-char.complex-union + (:tag :issues) + ;; Absorbed by supertype. + (assert-equal (values t t) + (c::type= (c::type-union (c::specifier-type 'standard-char) + (c::specifier-type 'character)) + (c::specifier-type 'character))) + + (assert-equal (values t t) + (c::type= (c::type-union (c::specifier-type 'standard-char) + (c::specifier-type 't)) + (c::specifier-type 't))) + + ;; All-standard-chars member-type absorbed back into STANDARD-CHAR. + (assert-equal (values t t) + (c::type= (c::type-union (c::specifier-type 'standard-char) + (c::specifier-type '(member #\a #\b))) + (c::specifier-type 'standard-char))) + + ;; Disjoint type stays as a union (the bug-fix case). + ;; The result should NOT be a single member-type containing + ;; T, NIL, and 96 standard chars. + (let ((result (c::specifier-type '(or boolean standard-char)))) + (assert-true (c::union-type-p result)) + (assert-equal 2 (length (c::union-type-types result))) + (assert-true (notany (lambda (m) + (and (c::member-type-p m) + (some #'characterp (c::member-type-members m)) + (some (complement #'characterp) + (c::member-type-members m)))) + (c::union-type-types result)))) + + + ;; Permutation invariance — the original etypecase.15 trigger. + (assert-equal (values t t) + (c::type= (c::specifier-type '(or boolean standard-char)) + (c::specifier-type '(or standard-char boolean)))) + + (assert-equal (values t t) + (c::type= (c::specifier-type + '(not (or pathname boolean standard-char standard-object character file-error))) + (c::specifier-type + '(not (or file-error character standard-object standard-char boolean pathname))))) + + ;; Member-type with non-standard chars — kept symbolically separate. + (let ((result (c::type-union (c::specifier-type 'standard-char) + (c::specifier-type '(member #\Tab))))) + ;; Should not collapse into a 97-element MEMBER. + (assert-false (c::member-type-p result)) + (assert-true (c::union-type-p result)))) + +(define-test standard-char.complex-intersection + (:tag :issues) + ;; Intersection with supertype is STANDARD-CHAR. + (assert-equal (values t t) + (c::type= (c::type-intersection (c::specifier-type 'standard-char) + (c::specifier-type 'character)) + (c::specifier-type 'standard-char))) + + (assert-equal (values t t) + (c::type= (c::type-intersection (c::specifier-type 'standard-char) + (c::specifier-type 't)) + (c::specifier-type 'standard-char))) + + ;; Intersection with disjoint type is empty. + (assert-equal (values t t) + (c::type= (c::type-intersection (c::specifier-type 'standard-char) + (c::specifier-type 'integer)) + c::*empty-type*)) + + (assert-equal (values t t) + (c::type= (c::type-intersection (c::specifier-type 'standard-char) + (c::specifier-type 'symbol)) + c::*empty-type*)) + + ;; Intersection with member-type — filtered to standard chars. + (assert-equal (values t t) + (c::type= (c::type-intersection (c::specifier-type 'standard-char) + (c::specifier-type '(member #\a #\Tab #\b))) + (c::specifier-type '(member #\a #\b)))) + + ;; All-non-standard members → empty. + (assert-equal (values t t) + (c::type= (c::type-intersection (c::specifier-type 'standard-char) + (c::specifier-type '(member #\Tab #\Rubout))) + c::*empty-type*)) + + ;; All-standard members → that member-type unchanged. + (assert-equal (values t t) + (c::type= (c::type-intersection (c::specifier-type 'standard-char) + (c::specifier-type '(member #\a))) + (c::specifier-type '(member #\a))))) + + + +(define-test standard-char.negation + (:tag :issues) + ;; NOT STANDARD-CHAR catches non-standard characters. + (assert-true (typep #\Tab '(not standard-char))) + (assert-false (typep #\a '(not standard-char))) + + ;; AND CHARACTER (NOT STANDARD-CHAR) is the non-standard chars. + (assert-true (typep #\Tab '(and character (not standard-char)))) + (assert-false (typep #\a '(and character (not standard-char)))) + (assert-false (typep 5 '(and character (not standard-char)))) + + ;; Permutation invariance with negation, multiple types. + (assert-equal (values t t) + (c::type= (c::specifier-type '(and standard-char (not (member #\a)))) + (c::specifier-type '(and (not (member #\a)) standard-char))))) + +(define-test standard-char.etypecase + (:tag :issues) + ;; Test that etypecase works using ASCII characters which will cover + ;; standard-char values and other characters. + (dotimes (k 128) + (let* ((ch (code-char k)) + (expected (if (standard-char-p ch) + :is-standard :is-other)) + (actual (handler-case + (etypecase ch + (standard-char :is-standard) + (character :is-other)) + (error () + :error)))) + (assert-eql expected actual ch)))) + +(define-test standard-char.intersection-character-both-orderings + (:tag :issues) + ;; Standard-char intersect character = standard-char, regardless of argument order. + (assert-equal (values t t) + (kernel::type= + (kernel::specifier-type 'standard-char) + (kernel::type-intersection (kernel::specifier-type 'standard-char) + (kernel::specifier-type 'character)))) + (assert-equal (values t t) + (kernel::type= + (kernel::specifier-type 'standard-char) + (kernel::type-intersection (kernel::specifier-type 'character) + (kernel::specifier-type 'standard-char))))) + +(define-test standard-char.intersection-disjoint-both-orderings + (:tag :issues) + (assert-equal (values t t) + (kernel::type= + kernel::*empty-type* + (kernel::type-intersection (kernel::specifier-type 'standard-char) + (kernel::specifier-type 'integer)))) + (assert-equal (values t t) + (kernel::type= + kernel::*empty-type* + (kernel::type-intersection (kernel::specifier-type 'integer) + (kernel::specifier-type 'standard-char))))) + +(define-test standard-char.intersection-member-both-orderings + (:tag :issues) + ;; Filter member-type to standard chars only. + (assert-equal (values t t) + (kernel::type= + (kernel::specifier-type '(member #\a #\b)) + (kernel::type-intersection (kernel::specifier-type 'standard-char) + (kernel::specifier-type '(member #\a #\Tab #\b))))) + (assert-equal (values t t) + (kernel::type= + (kernel::specifier-type '(member #\a #\b)) + (kernel::type-intersection (kernel::specifier-type '(member #\a #\Tab #\b)) + (kernel::specifier-type 'standard-char))))) + +(define-test standard-char.union-character-both-orderings + (:tag :issues) + ;; Standard-char union character = character. + (assert-equal (values t t) + (kernel::type= + (kernel::specifier-type 'character) + (kernel::type-union (kernel::specifier-type 'standard-char) + (kernel::specifier-type 'character)))) + (assert-equal (values t t) + (kernel::type= + (kernel::specifier-type 'character) + (kernel::type-union (kernel::specifier-type 'character) + (kernel::specifier-type 'standard-char))))) + +(define-test standard-char.union-member-of-standard-both-orderings + (:tag :issues) + ;; Standard-char absorbs all-standard member-type. + (assert-equal (values t t) + (kernel::type= + (kernel::specifier-type 'standard-char) + (kernel::type-union (kernel::specifier-type 'standard-char) + (kernel::specifier-type '(member #\a #\b))))) + (assert-equal (values t t) + (kernel::type= + (kernel::specifier-type 'standard-char) + (kernel::type-union (kernel::specifier-type '(member #\a #\b)) + (kernel::specifier-type 'standard-char))))) + +(define-test standard-char.union-disjoint-stays-symbolic-both-orderings + (:tag :issues) + ;; (or boolean standard-char) and reverse — both should stay symbolic + ;; rather than collapsing into a giant member-type. + (let ((r1 (kernel::specifier-type '(or boolean standard-char))) + (r2 (kernel::specifier-type '(or standard-char boolean)))) + (assert-true (kernel::union-type-p r1)) + (assert-true (kernel::union-type-p r2)) + (assert-equal (values t t) + (kernel::type= r1 r2)) + ;; Neither should contain a member-type with both characters + ;; and non-characters. + (dolist (m (kernel::union-type-types r1)) + (assert-false (and (kernel::member-type-p m) + (some #'characterp (kernel::member-type-members m)) + (some (complement #'characterp) + (kernel::member-type-members m))))))) + +(defun assert-commutative-union (type-a-spec type-b-spec) + "Assert that union(A, B) and union(B, A) produce type= results." + (assert-equal (values t t) + (kernel::type= + (kernel::type-union (kernel::specifier-type type-a-spec) + (kernel::specifier-type type-b-spec)) + (kernel::type-union (kernel::specifier-type type-b-spec) + (kernel::specifier-type type-a-spec))))) + +(defun assert-commutative-intersection (type-a-spec type-b-spec) + (assert-equal (values t t) + (kernel::type= + (kernel::type-intersection (kernel::specifier-type type-a-spec) + (kernel::specifier-type type-b-spec)) + (kernel::type-intersection (kernel::specifier-type type-b-spec) + (kernel::specifier-type type-a-spec))))) + +(define-test standard-char.commutativity + (:tag :issues) + (assert-commutative-union 'standard-char 'character) + (assert-commutative-union 'standard-char 'integer) + (assert-commutative-union 'standard-char '(member #\a #\b)) + (assert-commutative-union 'standard-char '(member #\Tab)) + (assert-commutative-union 'standard-char 'boolean) + (assert-commutative-union 'standard-char '(not character)) + (assert-commutative-union 'standard-char 't) + (assert-commutative-intersection 'standard-char 'character) + (assert-commutative-intersection 'standard-char 'integer) + (assert-commutative-intersection 'standard-char '(member #\a #\b)) + (assert-commutative-intersection 'standard-char '(member #\Tab)) + (assert-commutative-intersection 'standard-char 'boolean) + (assert-commutative-intersection 'standard-char '(not character)) + (assert-commutative-intersection 'standard-char 't)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/47971b155ca22c2637a0d3… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/47971b155ca22c2637a0d3… You're receiving this email because of your account on gitlab.common-lisp.net. Manage all notifications: https://gitlab.common-lisp.net/-/profile/notifications | Help: https://gitlab.common-lisp.net/help

1 0

[Git][cmucl/cmucl][issue-318-add-concrete-standard-char-type] Don't need bootfile anymore
by Raymond Toy (＠rtoy) 26 Jun '26

26 Jun '26

Raymond Toy pushed to branch issue-318-add-concrete-standard-char-type at cmucl / cmucl Commits: 33c5bacb by Raymond Toy at 2026-06-26T08:54:51-07:00 Don't need bootfile anymore - - - - - 1 changed file: - .gitlab-ci.yml Changes: ===================================== .gitlab-ci.yml ===================================== @@ -7,7 +7,7 @@ variables: download_url: "https://common-lisp.net/project/cmucl/downloads/release/$release" version: "$release-x86" tar_ext: "xz" - bootstrap: "-B boot-21f" + bootstrap: "" workflow: rules: View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/33c5bacb79cdc9cb65fdfa6… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/33c5bacb79cdc9cb65fdfa6… You're receiving this email because of your account on gitlab.common-lisp.net. Manage all notifications: https://gitlab.common-lisp.net/-/profile/notifications | Help: https://gitlab.common-lisp.net/help

1 0

[Git][cmucl/cmucl][issue-318-add-concrete-standard-char-type] 5 commits: Remove defypte of standard-char from code/type.lisp
by Raymond Toy (＠rtoy) 26 Jun '26

26 Jun '26

Raymond Toy pushed to branch issue-318-add-concrete-standard-char-type at cmucl / cmucl Commits: 3dfca652 by Raymond Toy at 2026-06-26T08:51:40-07:00 Remove defypte of standard-char from code/type.lisp It's not needed now that we have a separate concrete standard-char type. - - - - - 7d0efaa6 by Raymond Toy at 2026-06-26T08:51:40-07:00 Bootfile is not needed to build this change Not sure why we had this originally, but I just did a normal build without specifying a -B option, and everything built fine and the standard-char test ran fine. - - - - - 2302c6bc by Raymond Toy at 2026-06-26T08:51:40-07:00 Address review comment Reverse subtype args to verify that we're computing the correct result. - - - - - fecdd641 by Raymond Toy at 2026-06-26T08:51:40-07:00 Address review comment Replace `subsetp` with `every` to determine subtype relationship between standard-char and member types. There were two places that were updated. - - - - - a4842b2f by Raymond Toy at 2026-06-26T08:51:40-07:00 Address review comment Forgot to replace one `subsetp` with `every`. - - - - - 4 changed files: - bin/build.sh - − src/bootfiles/21f/boot-21f.lisp - src/code/type.lisp - tests/standard-char.lisp Changes: ===================================== bin/build.sh ===================================== @@ -38,7 +38,7 @@ ENABLE2="yes" ENABLE3="yes" ENABLE4="yes" -version=21f +version=21e SRCDIR=src BINDIR=bin TOOLDIR=$BINDIR ===================================== src/bootfiles/21f/boot-21f.lisp deleted ===================================== @@ -1,14 +0,0 @@ -;; For #318. Define new standard-char type. -(in-package "KERNEL") -(ext:without-package-locks -(define-type-class standard-char) -(defstruct (standard-char-type - (:include ctype - (class-info (type-class-or-lose 'standard-char)) - (:enumerable t)) - (:constructor %make-standard-char-type ()) - (:copier nil))) - -(defun make-standard-char-type () - (%make-standard-char-type)) -) ===================================== src/code/type.lisp ===================================== @@ -3347,7 +3347,10 @@ (values t t)) ((member-type-p type2) ;; If TYPE2 is a member-type, check whether it contains all standard-chars - (values (subsetp +standard-chars+ (member-type-members type2)) + (values (let ((members (member-type-members type2))) + (every #'(lambda (c) + (member c members)) + +standard-chars+)) t)) (t (values nil t)))) @@ -3358,7 +3361,9 @@ (cond ((member-type-p type1) ;; If TYPE1 is a member-type, check whether it contains all ;; standard-chars. - (values (subsetp (member-type-members type1) +standard-chars+) + (values (every #'(lambda (c) + (member c +standard-chars+)) + (member-type-members type1)) t)) (t (values nil t)))) @@ -3374,8 +3379,10 @@ ((csubtypep (specifier-type 'character) other) other) ((and (member-type-p other) - (subsetp (member-type-members other) - +standard-chars+)) + ;; Check to see every member of OTHER is a STANDARD-CHAR. + (every #'(lambda (c) + (member c +standard-chars+)) + (member-type-members other))) sc) (t nil)))) @@ -3640,16 +3647,6 @@ "Type of characters that aren't base-char's. None in CMU CL." '(and character (not base-char))) -#+nil -(deftype standard-char () - "Type corresponding to the charaters required by the standard." - '(member #\NEWLINE #\SPACE #\! #\" #\# #\$ #\% #\& #\' #$ #$ #\* #\+ #\, - #\- #\. #\/ #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\: #\; #\< #\= - #\> #\? #\@ #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M - #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z #\[ #\\ #\] - #\^ #\_ #\` #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m - #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\{ - #\| #\} #\~)) (deftype keyword () "Type for any keyword symbol." '(and symbol (satisfies keywordp))) ===================================== tests/standard-char.lisp ===================================== @@ -10,7 +10,7 @@ ;; sure we test the intersection and union methods for standard-char. (define-test standard-char.typep - (:tag :issues) + (:tag :issues) (assert-true (typep #\a 'standard-char)) (assert-false (typep #\tab 'standard-char)) (assert-true (typep #\Z 'standard-char)) @@ -24,8 +24,12 @@ (assert-equal (values t t) (subtypep 'standard-char 'character)) + (assert-equal (values nil t) + (subtypep 'character 'standard-char)) (assert-equal (values t t) - (subtypep 'standard-char 'base-char))) + (subtypep 'standard-char 'base-char)) + (assert-equal (values nil t) + (subtypep 'base-char 'standard-char))) (define-test standard-char.etypecase-15 (:tag :issues) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/95fb934cafa3ccd4a65de6… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/95fb934cafa3ccd4a65de6… You're receiving this email because of your account on gitlab.common-lisp.net. Manage all notifications: https://gitlab.common-lisp.net/-/profile/notifications | Help: https://gitlab.common-lisp.net/help

1 0

[Git][cmucl/cmucl][rtoy-unicode-collation-ducet] Add case-insensitive comparison functions
by Raymond Toy (＠rtoy) 17 Jun '26

17 Jun '26

Raymond Toy pushed to branch rtoy-unicode-collation-ducet at cmucl / cmucl Commits: d555c487 by Raymond Toy at 2026-06-17T14:03:47-07:00 Add case-insensitive comparison functions Add a STRENGTH parameter to the collation comparison path -- :PRIMARY, :SECONDARY, :TERTIARY (the default), or :QUATERNARY -- bounding the weight levels included in the sort key, and hence the distinctions the comparison makes. A lower strength makes more strings compare equal: :SECONDARY ignores case, :PRIMARY also ignores accents. COLLATION-SORT-KEY and COLLATION-COMPARE take it, and it is threaded through the UNICODE comparison functions. Add the case-insensitive comparison functions, the Unicode analogs of the COMMON-LISP -EQUAL / -LESSP family: STRING-EQUAL, STRING-NOT-EQUAL, STRING-LESSP, STRING-GREATERP, STRING-NOT-GREATERP, and STRING-NOT-LESSP. They default to :SECONDARY strength, so they ignore case (and other tertiary distinctions) while remaining sensitive to base letters and accents. Shadow and export the six in the UNICODE package. Add tests for the public comparison functions: the boolean result of each predicate, the four strength levels, the case-insensitive variants, string-designator and START/END handling, and the variable-weighting option. - - - - - 3 changed files: - src/code/exports.lisp - src/code/unicode-collation.lisp - tests/unicode-collation.lisp Changes: ===================================== src/code/exports.lisp ===================================== @@ -2313,7 +2313,13 @@ "STRING=" "STRING/=" "STRING>" - "STRING>=") + "STRING>=" + "STRING-EQUAL" + "STRING-NOT-EQUAL" + "STRING-LESSP" + "STRING-GREATERP" + "STRING-NOT-GREATERP" + "STRING-NOT-LESSP") (:import-from "LISP" "CODEPOINT" "SURROGATES" @@ -2337,6 +2343,12 @@ "STRING=" "STRING/=" "STRING>" - "STRING>=")) + "STRING>=" + "STRING-EQUAL" + "STRING-NOT-EQUAL" + "STRING-LESSP" + "STRING-GREATERP" + "STRING-NOT-GREATERP" + "STRING-NOT-LESSP")) ===================================== src/code/unicode-collation.lisp ===================================== @@ -467,18 +467,28 @@ is no fourth level. See COLLATION-WEIGHTS." (unless (zerop te) (push te l3)))) (values (nreverse l1) (nreverse l2) (nreverse l3) nil))) -(defun collation-sort-key (d string &optional (variable-weighting :shifted)) +(defun collation-sort-key (d string &optional (variable-weighting :shifted) + (strength :tertiary)) "Compute the UTS #10 sort key for STRING under DUCET D. Returns a -(simple-array (unsigned-byte 16) (*)) holding the level-1 weights, a 0000 -separator, the level-2 weights, 0000, the level-3 weights, and -- for the -:SHIFTED option -- a further 0000 separator and the level-4 weights. -Binary comparison of two such keys yields the collation order of their -strings. VARIABLE-WEIGHTING is as in COLLATION-WEIGHTS." +(simple-array (unsigned-byte 16) (*)) holding the weight levels separated +by 0000: level 1, level 2, level 3, and -- under the :SHIFTED option -- +level 4. Binary comparison of two such keys yields the collation order +of their strings. VARIABLE-WEIGHTING is as in COLLATION-WEIGHTS. + +STRENGTH bounds the levels included in the key, and hence the +distinctions the comparison makes: :PRIMARY (base letters only), +:SECONDARY (also accents), :TERTIARY (also case; the default), or +:QUATERNARY (also the level-4 weights, which exist only under the +:SHIFTED option and otherwise add nothing). A lower strength makes +more strings compare equal; for example :SECONDARY ignores case." (multiple-value-bind (l1 l2 l3 l4) (collation-weights d string variable-weighting) - (let* ((weights (if (eq variable-weighting :non-ignorable) - (append l1 (list 0) l2 (list 0) l3) - (append l1 (list 0) l2 (list 0) l3 (list 0) l4))) + (let* ((weights (ecase strength + (:primary l1) + (:secondary (append l1 (list 0) l2)) + (:tertiary (append l1 (list 0) l2 (list 0) l3)) + (:quaternary + (append l1 (list 0) l2 (list 0) l3 (list 0) l4)))) (key (make-array (length weights) :element-type '(unsigned-byte 16)))) (loop for w in weights @@ -486,12 +496,13 @@ strings. VARIABLE-WEIGHTING is as in COLLATION-WEIGHTS." do (setf (aref key k) w)) key))) -(defun collation-compare (d s1 s2 &optional (variable-weighting :shifted)) +(defun collation-compare (d s1 s2 &optional (variable-weighting :shifted) + (strength :tertiary)) "Compare strings S1 and S2 under DUCET D. Returns -1, 0, or 1 like a three-way comparison: negative if S1 sorts before S2, zero if equal, 1 -if after. VARIABLE-WEIGHTING is as in COLLATION-WEIGHTS." - (let ((k1 (collation-sort-key d s1 variable-weighting)) - (k2 (collation-sort-key d s2 variable-weighting))) +if after. VARIABLE-WEIGHTING and STRENGTH are as in COLLATION-SORT-KEY." + (let ((k1 (collation-sort-key d s1 variable-weighting strength)) + (k2 (collation-sort-key d s2 variable-weighting strength))) (let ((n (min (length k1) (length k2)))) (dotimes (i n) (let ((a (aref k1 i)) (b (aref k2 i))) @@ -615,7 +626,7 @@ collation section of unidata.bin on first use." (setf *collation-table* (lisp::unidata-ducet)))) (defun %collation-compare (string1 string2 start1 end1 start2 end2 - variable-weighting) + variable-weighting strength) "Three-way collation comparison of the designated substrings of STRING1 and STRING2: returns a negative integer, zero, or a positive integer as the first sorts before, equal to, or after the second." @@ -625,47 +636,87 @@ integer as the first sorts before, equal to, or after the second." (setf s1 (subseq s1 start1 end1))) (when (or (/= start2 0) end2) (setf s2 (subseq s2 start2 end2))) - (lisp::collation-compare (collation-table) s1 s2 variable-weighting))) + (lisp::collation-compare (collation-table) s1 s2 + variable-weighting strength))) -(defmacro %def-collation-predicate (name test docstring) +(defmacro %def-collation-predicate (name test default-strength docstring) "Define a collation comparison predicate NAME whose result is (TEST c) -where c is the three-way comparison of the two string arguments." +where c is the three-way comparison of the two string arguments. +DEFAULT-STRENGTH is the default value of the STRENGTH keyword." `(defun ,name (string1 string2 &key (start1 0) end1 (start2 0) end2 - (variable-weighting :shifted)) + (variable-weighting :shifted) + (strength ,default-strength)) ,docstring (let ((c (%collation-compare string1 string2 start1 end1 start2 end2 - variable-weighting))) + variable-weighting strength))) (,test c)))) -(%def-collation-predicate string= zerop +(%def-collation-predicate string= zerop :tertiary "Return true if STRING1 and STRING2 collate as equal under the Unicode Collation Algorithm. Note that this is collation equality, not code-point identity: canonically equivalent strings, and strings that differ only in collation-ignorable ways, compare equal. START1, END1, -START2 and END2 bound the substrings compared; VARIABLE-WEIGHTING is -:SHIFTED (the default) or :NON-IGNORABLE.") +START2 and END2 bound the substrings compared. VARIABLE-WEIGHTING is +:SHIFTED (the default) or :NON-IGNORABLE. STRENGTH is :PRIMARY, +:SECONDARY, :TERTIARY (the default), or :QUATERNARY, as in +LISP::COLLATION-SORT-KEY; a lower strength makes more strings compare +equal -- :SECONDARY, for instance, ignores case.") -(%def-collation-predicate string/= (lambda (c) (not (zerop c))) +(%def-collation-predicate string/= (lambda (c) (not (zerop c))) :tertiary "Return true if STRING1 and STRING2 do not collate as equal. See UNICODE:STRING= for the meaning of the keyword arguments.") -(%def-collation-predicate string< minusp +(%def-collation-predicate string< minusp :tertiary "Return true if STRING1 collates before STRING2 under the Unicode Collation Algorithm. See UNICODE:STRING= for the meaning of the keyword arguments.") -(%def-collation-predicate string> plusp +(%def-collation-predicate string> plusp :tertiary "Return true if STRING1 collates after STRING2 under the Unicode Collation Algorithm. See UNICODE:STRING= for the meaning of the keyword arguments.") -(%def-collation-predicate string<= (lambda (c) (not (plusp c))) +(%def-collation-predicate string<= (lambda (c) (not (plusp c))) :tertiary "Return true if STRING1 collates before or equal to STRING2 under the Unicode Collation Algorithm. See UNICODE:STRING= for the meaning of the keyword arguments.") -(%def-collation-predicate string>= (lambda (c) (not (minusp c))) +(%def-collation-predicate string>= (lambda (c) (not (minusp c))) :tertiary "Return true if STRING1 collates after or equal to STRING2 under the Unicode Collation Algorithm. See UNICODE:STRING= for the meaning of the keyword arguments.") + +;;; The case-insensitive comparison functions, the Unicode analogs of +;;; the COMMON-LISP -EQUAL/-LESSP/... family. They default to :SECONDARY +;;; strength, which drops the tertiary level where case is encoded, so +;;; they ignore case (and other tertiary distinctions, such as width) +;;; while remaining sensitive to base letters and accents. This is the +;;; closest collation analog of case-folded comparison; the Unicode +;;; Collation Algorithm has no operation that folds case alone. + +(%def-collation-predicate string-equal zerop :secondary + "Return true if STRING1 and STRING2 collate as equal ignoring case, +under the Unicode Collation Algorithm. Like UNICODE:STRING= but +defaulting to :SECONDARY strength; see it for the keyword arguments.") + +(%def-collation-predicate string-not-equal (lambda (c) (not (zerop c))) :secondary + "Return true if STRING1 and STRING2 do not collate as equal ignoring +case. See UNICODE:STRING-EQUAL for the keyword arguments.") + +(%def-collation-predicate string-lessp minusp :secondary + "Return true if STRING1 collates before STRING2 ignoring case, under +the Unicode Collation Algorithm. See UNICODE:STRING-EQUAL for the +keyword arguments.") + +(%def-collation-predicate string-greaterp plusp :secondary + "Return true if STRING1 collates after STRING2 ignoring case. See +UNICODE:STRING-EQUAL for the keyword arguments.") + +(%def-collation-predicate string-not-greaterp (lambda (c) (not (plusp c))) :secondary + "Return true if STRING1 collates before or equal to STRING2 ignoring +case. See UNICODE:STRING-EQUAL for the keyword arguments.") + +(%def-collation-predicate string-not-lessp (lambda (c) (not (minusp c))) :secondary + "Return true if STRING1 collates after or equal to STRING2 ignoring +case. See UNICODE:STRING-EQUAL for the keyword arguments.") ===================================== tests/unicode-collation.lisp ===================================== @@ -145,6 +145,83 @@ must match the expected key in the line's comment." (run-collation-conformance (ducet) *collation-non-ignorable-test* :non-ignorable)) +;;; Tests for the public UNICODE comparison functions. The conformance +;;; tests above already validate the collation weights themselves; these +;;; check the thin wrappers -- that each predicate maps the comparison to +;;; the right boolean, and that the STRENGTH and VARIABLE-WEIGHTING +;;; options and the case-insensitive variants behave as documented. + +(define-test unicode.string-predicates + "The six case-sensitive comparison predicates map the collation order +of a known pair to the correct boolean, including the reflexive case." + (:tag :unicode) + (assert-true (unicode:string< "a" "b")) + (assert-false (unicode:string< "b" "a")) + (assert-false (unicode:string< "a" "a")) + (assert-true (unicode:string> "b" "a")) + (assert-false (unicode:string> "a" "b")) + (assert-true (unicode:string<= "a" "b")) + (assert-true (unicode:string<= "a" "a")) + (assert-false (unicode:string<= "b" "a")) + (assert-true (unicode:string>= "b" "a")) + (assert-true (unicode:string>= "a" "a")) + (assert-false (unicode:string>= "a" "b")) + (assert-true (unicode:string= "a" "a")) + (assert-false (unicode:string= "a" "b")) + (assert-true (unicode:string/= "a" "b")) + (assert-false (unicode:string/= "a" "a"))) + +(define-test unicode.string-designators-and-bounds + "Comparison accepts string designators (characters, symbols) like the +COMMON-LISP functions, and honors START/END substring bounds." + (:tag :unicode) + (assert-true (unicode:string= #\a #\a)) + (assert-true (unicode:string= 'abc "ABC")) + (assert-true (unicode:string= "xab" "yab" :start1 1 :start2 1)) + (assert-false (unicode:string= "xab" "yzb" :start1 1 :start2 1))) + +(define-test unicode.string-strength + "STRENGTH bounds the distinctions made: case is a tertiary difference, +an accent a secondary one." + (:tag :unicode) + ;; Default (tertiary): case matters. Lowercase sorts before uppercase. + (assert-true (unicode:string< "abc" "ABC")) + (assert-false (unicode:string< "ABC" "abc")) + (assert-false (unicode:string= "ABC" "abc")) + ;; Secondary: case ignored, but accents still distinguish. + (assert-true (unicode:string= "ABC" "abc" :strength :secondary)) + (assert-false (unicode:string= "café" "cafe" :strength :secondary)) + ;; Primary: accents ignored too. + (assert-true (unicode:string= "café" "cafe" :strength :primary)) + ;; Quaternary: under the default :SHIFTED option the level-4 weights + ;; make variable elements (here the hyphen) break an otherwise equal + ;; comparison, where :TERTIARY ignores them. + (assert-true (unicode:string= "co-op" "coop")) + (assert-false (unicode:string= "co-op" "coop" :strength :quaternary))) + +(define-test unicode.string-case-insensitive + "The case-insensitive family ignores case (secondary strength) while +remaining sensitive to accents." + (:tag :unicode) + (assert-true (unicode:string-equal "ABC" "abc")) + (assert-false (unicode:string-not-equal "ABC" "abc")) + (assert-false (unicode:string-lessp "ABC" "abc")) + (assert-false (unicode:string-greaterp "ABC" "abc")) + (assert-true (unicode:string-not-greaterp "ABC" "abc")) + (assert-true (unicode:string-not-lessp "ABC" "abc")) + ;; An accent is a secondary difference, so it still distinguishes. + (assert-false (unicode:string-equal "café" "cafe"))) + +(define-test unicode.string-variable-weighting + "Under the default :SHIFTED option variable elements (punctuation) are +ignored; under :NON-IGNORABLE they are significant." + (:tag :unicode) + ;; Shifted (default): the hyphen is ignored, so the strings collate equal. + (assert-true (unicode:string= "co-op" "coop")) + ;; Non-ignorable: the hyphen counts, so they are not equal. + (assert-false (unicode:string= "co-op" "coop" + :variable-weighting :non-ignorable))) + ;; A DEFINE-TEST body is stored as source and run interpreted, and the ;; test runner (tests/run-tests.lisp) loads this file as source, so its ;; functions would otherwise run interpreted. The per-line parsing and View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/d555c487cbc28742ca2967d… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/d555c487cbc28742ca2967d… You're receiving this email because of your account on gitlab.common-lisp.net. Manage all notifications: https://gitlab.common-lisp.net/-/profile/notifications | Help: https://gitlab.common-lisp.net/help

1 0

[Git][cmucl/cmucl][rtoy-unicode-collation-ducet] Serialize the DUCET into unidata.bin
by Raymond Toy (＠rtoy) 17 Jun '26

17 Jun '26

Raymond Toy pushed to branch rtoy-unicode-collation-ducet at cmucl / cmucl Commits: 6a425efa by Raymond Toy at 2026-06-17T13:30:01-07:00 Serialize the DUCET into unidata.bin The collation table was loaded at runtime by parsing allkeys.txt. Store it in unidata.bin instead, as a new section (index 19), and bump the file format version to 2. The section holds the collation elements in three parallel arrays (primary u16, secondary u16, tertiary u8 with the variable flag in bit 7), a single-codepoint index as an ntrie32 mapping a codepoint to a packed (offset << 6) | count into those arrays, a contraction table (four 32-bit words per entry), and the @implicitweights ranges. build-unidata.lisp reads allkeys.txt and builds the section; unidata.lisp reads it back (loader for section 19, plus the COLLATION struct and slot). UNIDATA-DUCET in unicode-collation.lisp builds the runtime DUCET from the loaded section -- structurally identical to one from LOAD-DUCET, so the sort-key construction code is unchanged -- and COLLATION-TABLE now uses it. LOAD-DUCET is kept for regenerating data and cross-checking. The collation conformance tests build the DUCET from unidata.bin and still pass all 437930 assertions. unidata.bin updated with the new collation data. - - - - - 4 changed files: - src/code/unicode-collation.lisp - src/code/unidata.lisp - src/i18n/unidata.bin - tests/unicode-collation.lisp Changes: ===================================== src/code/unicode-collation.lisp ===================================== @@ -518,6 +518,85 @@ if after. VARIABLE-WEIGHTING is as in COLLATION-WEIGHTS." ;;; no meaningful character index of the first difference to return. ;;; ------------------------------------------------------------------- + +;;; ------------------------------------------------------------------- +;;; Building the runtime DUCET from the collation section of +;;; unidata.bin. The resulting table is structurally identical to one +;;; built by LOAD-DUCET from allkeys.txt -- the same MAP / SINGLE / +;;; STARTERS hashes and implicit ranges -- so the sort-key construction +;;; code uses it unchanged. This replaces the runtime use of LOAD-DUCET +;;; (which is kept for regenerating data and for cross-checking). +;;; ------------------------------------------------------------------- + +(defun unidata-ducet () + "Build a DUCET from the collation section of unidata.bin, loading the +section first if necessary." + (unless (unidata-collation *unicode-data*) + (load-collation)) + (let* ((c (unidata-collation *unicode-data*)) + (primv (collation-primv c)) + (secv (collation-secv c)) + (terv (collation-terv c)) + (contractions (collation-contractions c)) + (ranges (collation-ranges c)) + (d (make-ducet :version (format nil "~D.~D.~D" + +unicode-major-version+ + +unicode-minor-version+ + +unicode-update-version+))) + (maxvar 0) + (maxkey 1)) + (flet ((ces-at (packed) + ;; Slice the parallel arrays into a simple-vector of + ;; collation-elements for the packed (offset << 6) | count. + (let* ((off (ash packed -6)) + (n (logand packed #x3f)) + (v (make-array n))) + (dotimes (i n) + (let* ((j (+ off i)) + (te (aref terv j)) + (var (logbitp 7 te)) + (p (aref primv j))) + (when (and var (> p maxvar)) + (setf maxvar p)) + (setf (aref v i) + (make-ce p (aref secv j) (logand te #x7f) var)))) + v))) + ;; Single-codepoint entries: walk the codepoint space and pull the + ;; non-zero values out of the index trie. (Many keys are astral, + ;; so the walk must cover the full range, not just the BMP.) + (dotimes (cp #x110000) + (let ((packed (qref32 c cp))) + (unless (zerop packed) + (let ((ces (ces-at packed))) + (setf (gethash cp (ducet-single d)) ces) + (setf (gethash (make-array 1 :initial-element cp) (ducet-map d)) + ces))))) + ;; Contractions: four 32-bit words each. + (loop for i from 0 below (length contractions) by 4 do + (let* ((cp1 (aref contractions i)) + (cp2 (aref contractions (+ i 1))) + (cp3 (aref contractions (+ i 2))) + (packed (aref contractions (+ i 3))) + (key (if (= cp3 #xFFFFFFFF) + (make-array 2 :initial-contents (list cp1 cp2)) + (make-array 3 :initial-contents (list cp1 cp2 cp3))))) + (setf (gethash key (ducet-map d)) (ces-at packed)) + (setf (gethash cp1 (ducet-starters d)) t) + (setf maxkey (max maxkey (length key))))) + ;; Implicit-weight ranges: four 32-bit words each (start, end, + ;; base, base-origin). + (let ((rl nil)) + (loop for i from 0 below (length ranges) by 4 do + (let ((r (make-implicit-range (aref ranges i) + (aref ranges (+ i 1)) + (aref ranges (+ i 2))))) + (setf (implicit-range-base-origin r) (aref ranges (+ i 3))) + (push r rl))) + (setf (ducet-implicit-ranges d) (nreverse rl))) + (setf (ducet-max-key-length d) maxkey + (ducet-max-variable-primary d) maxvar) + d))) + (in-package "UNICODE") (defvar *collation-table-path* "ext-formats:allkeys.txt" @@ -530,10 +609,10 @@ loaded. Loaded lazily from *COLLATION-TABLE-PATH* the first time a collation function needs it. Set to NIL to force a reload.") (defun collation-table () - "Return the default Unicode collation table, loading it from -*COLLATION-TABLE-PATH* on first use." + "Return the default Unicode collation table, building it from the +collation section of unidata.bin on first use." (or *collation-table* - (setf *collation-table* (lisp::load-ducet *collation-table-path*)))) + (setf *collation-table* (lisp::unidata-ducet)))) (defun %collation-compare (string1 string2 start1 end1 start2 end2 variable-weighting) ===================================== src/code/unidata.lisp ===================================== @@ -56,6 +56,7 @@ case-fold-simple case-fold-full word-break + collation ) (defvar *unicode-data* (make-unidata)) @@ -65,7 +66,7 @@ (defconstant +unicode-magic-number+ #x2A554344) ;; The format version for the unidata.bin file. -(defconstant +unicode-format-version+ 1) +(defconstant +unicode-format-version+ 2) ;; The expected Unicode version. This needs to be synced with ;; build-unidata.lisp. @@ -292,6 +293,27 @@ (defstruct (case-fold-full (:include decomp))) +(defstruct (collation (:include ntrie32)) + ;; Parallel collation-element arrays shared by the single-codepoint + ;; index (whose LVEC packs (offset << 6) | count into these) and the + ;; contraction table. TERV holds the tertiary weight in its low 7 + ;; bits and the variable flag in bit 7. + (primv (ext:required-argument) :read-only t + :type (simple-array (unsigned-byte 16) (*))) + (secv (ext:required-argument) :read-only t + :type (simple-array (unsigned-byte 16) (*))) + (terv (ext:required-argument) :read-only t + :type (simple-array (unsigned-byte 8) (*))) + ;; Contraction table: four 32-bit words per entry -- cp1, cp2, cp3 + ;; (or #xFFFFFFFF when the key has only two codepoints), and the + ;; packed (offset << 6) | count into the collation-element arrays. + (contractions (ext:required-argument) :read-only t + :type (simple-array (unsigned-byte 32) (*))) + ;; @implicitweights ranges: four 32-bit words per entry -- start, + ;; end, base, and base-origin (smallest start sharing the base). + (ranges (ext:required-argument) :read-only t + :type (simple-array (unsigned-byte 32) (*)))) + (defstruct (bidi (:include ntrie16)) (tabl (ext:required-argument) :read-only t :type (simple-array (unsigned-byte 16) (*)))) @@ -718,6 +740,29 @@ (read-ntrie 4 stm) (setf (unidata-word-break *unicode-data*) (make-ntrie4 :split split :hvec hvec :mvec mvec :lvec lvec)))) +(defloader load-collation (stm 19) + (multiple-value-bind (split hvec mvec lvec) + (read-ntrie 32 stm) + (let* ((nce (read32 stm)) + (primv (make-array nce :element-type '(unsigned-byte 16))) + (secv (make-array nce :element-type '(unsigned-byte 16))) + (terv (make-array nce :element-type '(unsigned-byte 8)))) + (read-vector primv stm :endian-swap :network-order) + (read-vector secv stm :endian-swap :network-order) + (read-vector terv stm :endian-swap :network-order) + (let* ((ncontr (read32 stm)) + (contractions (make-array (* 4 ncontr) + :element-type '(unsigned-byte 32)))) + (read-vector contractions stm :endian-swap :network-order) + (let* ((nrange (read-byte stm)) + (ranges (make-array (* 4 nrange) + :element-type '(unsigned-byte 32)))) + (read-vector ranges stm :endian-swap :network-order) + (setf (unidata-collation *unicode-data*) + (make-collation :split split :hvec hvec :mvec mvec :lvec lvec + :primv primv :secv secv :terv terv + :contractions contractions + :ranges ranges))))))) ;;; Accessor functions. @@ -1657,4 +1702,5 @@ unidata.bin." (unidata-case-fold-simple *unicode-data*) (unidata-case-fold-full *unicode-data*) (unidata-word-break *unicode-data*) + (unidata-collation *unicode-data*) t)) ===================================== src/i18n/unidata.bin ===================================== Binary files a/src/i18n/unidata.bin and b/src/i18n/unidata.bin differ ===================================== tests/unicode-collation.lisp ===================================== @@ -19,9 +19,10 @@ "The Default Unicode Collation Element Table, loaded on first use.") (defun ducet () - "Return the DUCET, loading it from *COLLATION-ALLKEYS* the first time." + "Return the DUCET, built from the collation section of unidata.bin on +first use." (or *ducet* - (setf *ducet* (lisp::load-ducet *collation-allkeys*)))) + (setf *ducet* (lisp::unidata-ducet)))) (defun collation-hex-list (string) "Parse all space-separated hexadecimal numbers in STRING into a list of View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/6a425efa239f6911e1b1fc0… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/6a425efa239f6911e1b1fc0… You're receiving this email because of your account on gitlab.common-lisp.net. Manage all notifications: https://gitlab.common-lisp.net/-/profile/notifications | Help: https://gitlab.common-lisp.net/help

1 0

[Git][cmucl/cmucl][rtoy-unicode-collation-ducet] Update build-unidata to build the collation table
by Raymond Toy (＠rtoy) 17 Jun '26

17 Jun '26

Raymond Toy pushed to branch rtoy-unicode-collation-ducet at cmucl / cmucl Commits: b021b2a8 by Raymond Toy at 2026-06-17T13:04:12-07:00 Update build-unidata to build the collation table This reads allkeys.txt and builds the collation table as part of unidata.bin. - - - - - 1 changed file: - src/tools/build-unidata.lisp Changes: ===================================== src/tools/build-unidata.lisp ===================================== @@ -44,6 +44,7 @@ case-fold-full case-fold-simple word-break + collation ) (defvar *unicode-data* (make-unidata)) @@ -146,6 +147,27 @@ (tabl (ext:required-argument) :read-only t :type (simple-array (unsigned-byte 16) (*)))) +(defstruct (collation (:include ntrie32)) + ;; Parallel collation-element arrays shared by the single-codepoint + ;; index (whose LVEC packs (offset << 6) | count into these) and the + ;; contraction table. TERV holds the tertiary weight in its low 7 + ;; bits and the variable flag in bit 7. + (primv (ext:required-argument) :read-only t + :type (simple-array (unsigned-byte 16) (*))) + (secv (ext:required-argument) :read-only t + :type (simple-array (unsigned-byte 16) (*))) + (terv (ext:required-argument) :read-only t + :type (simple-array (unsigned-byte 8) (*))) + ;; Contraction table: four 32-bit words per entry -- cp1, cp2, cp3 + ;; (or #xFFFFFFFF when the key has only two codepoints), and the + ;; packed (offset << 6) | count into the collation-element arrays. + (contractions (ext:required-argument) :read-only t + :type (simple-array (unsigned-byte 32) (*))) + ;; @implicitweights ranges: four 32-bit words per entry -- start, + ;; end, base, and base-origin (smallest start sharing the base). + (ranges (ext:required-argument) :read-only t + :type (simple-array (unsigned-byte 32) (*)))) + (defstruct (bidi (:include ntrie16)) (tabl (ext:required-argument) :read-only t :type (simple-array (unsigned-byte 16) (*)))) @@ -535,11 +557,11 @@ :element-type '(unsigned-byte 8)) ;; The length of the index array is the number of sections to be ;; written. See below for each section. - (let ((index (make-array 19 :fill-pointer 0))) + (let ((index (make-array 20 :fill-pointer 0))) ;; File header (write32 +unicode-magic-number+ stm) ; identification "magic" - ;; File format version (1: dictionary nextv de-packed, keypv added) - (write-byte 1 stm) + ;; File format version (2: collation/DUCET section added) + (write-byte 2 stm) ;; Unicode version (write-byte +unicode-major-version+ stm) (write-byte +unicode-minor-version+ stm) @@ -638,6 +660,18 @@ (let ((data (unidata-word-break *unicode-data*))) (update-index (file-position stm) index) (write-ntrie4 data stm)) + ;; 19. Collation (DUCET) + (let ((data (unidata-collation *unicode-data*))) + (update-index (file-position stm) index) + (write-ntrie32 data stm) + (write32 (length (collation-primv data)) stm) + (write-vector (collation-primv data) stm :endian-swap :network-order) + (write-vector (collation-secv data) stm :endian-swap :network-order) + (write-vector (collation-terv data) stm :endian-swap :network-order) + (write32 (truncate (length (collation-contractions data)) 4) stm) + (write-vector (collation-contractions data) stm :endian-swap :network-order) + (write-byte (truncate (length (collation-ranges data)) 4) stm) + (write-vector (collation-ranges data) stm :endian-swap :network-order)) ;; All components saved. Patch up index table now. (file-position stm 8) (dotimes (i (length index)) @@ -1016,6 +1050,140 @@ ;; ucd-directory should be the directory where UnicodeData.txt is ;; located. +(defun parse-collation-key (string) + "Parse the space-separated hexadecimal codepoints in STRING (the part +of an allkeys.txt line before the semicolon) into a list of integers." + (let ((result nil) (i 0) (n (length string))) + (loop + (loop while (and (< i n) (not (digit-char-p (char string i) 16))) + do (incf i)) + (when (>= i n) (return)) + (let ((j i)) + (loop while (and (< j n) (digit-char-p (char string j) 16)) + do (incf j)) + (push (parse-integer string :start i :end j :radix 16) result) + (setf i j))) + (nreverse result))) + +(defun parse-collation-elements (string) + "Parse the collation elements [.pppp.ssss.tttt] (or [*pppp...] for a +variable element) from STRING into a list of (primary secondary tertiary +variablep) lists." + (let ((result nil) (i 0)) + (loop + (let ((open (position #\[ string :start i))) + (unless open (return)) + (let* ((var (char= (char string (1+ open)) #\*)) + (close (position #\] string :start open)) + (body (subseq string (+ open 2) close)) + (d1 (position #\. body)) + (d2 (position #\. body :start (1+ d1)))) + (push (list (parse-integer body :end d1 :radix 16) + (parse-integer body :start (1+ d1) :end d2 :radix 16) + (parse-integer body :start (1+ d2) :radix 16) + var) + result) + (setf i (1+ close))))) + (nreverse result))) + +(defun build-collation (ucd range ucd-directory) + "Read allkeys.txt (the DUCET) from UCD-DIRECTORY and build the +collation section: the parallel collation-element arrays, the +single-codepoint index (an ntrie32 mapping a codepoint to a packed +(offset << 6) | count into those arrays), the contraction table, and the +@implicitweights ranges." + (let ((path (make-pathname :name "allkeys" :type "txt" :defaults ucd-directory)) + (primv (make-array 65536 :element-type '(unsigned-byte 16) + :adjustable t :fill-pointer 0)) + (secv (make-array 65536 :element-type '(unsigned-byte 16) + :adjustable t :fill-pointer 0)) + (terv (make-array 65536 :element-type '(unsigned-byte 8) + :adjustable t :fill-pointer 0)) + (single (make-hash-table)) + (contractions nil) + (raw-ranges nil)) + (flet ((emit (ces) + ;; Append CES to the parallel arrays; return the packed + ;; (offset << 6) | count referring to them. + (let ((offset (fill-pointer primv)) + (count (length ces))) + (dolist (ce ces) + (destructuring-bind (p s te var) ce + (vector-push-extend p primv) + (vector-push-extend s secv) + (vector-push-extend (logior te (if var #x80 0)) terv))) + (logior (ash offset 6) count)))) + (with-open-file (s path :direction :input :external-format :utf-8) + (loop for line = (read-line s nil) while line do + (cond + ((zerop (length line))) + ((char= (char line 0) #\#)) + ((eql 0 (search "@implicitweights" line)) + (let* ((semi (position #\; line)) + (dd (search ".." line)) + (start (parse-integer line :start (length "@implicitweights") + :end dd :radix 16 :junk-allowed t)) + (end (parse-integer line :start (+ dd 2) :end semi + :radix 16 :junk-allowed t)) + (base (parse-integer line :start (1+ semi) + :radix 16 :junk-allowed t))) + (push (list start end base) raw-ranges))) + ((char= (char line 0) #\@)) + (t + (let ((semi (position #\; line))) + (when semi + (let* ((hash (position #\# line)) + (key (parse-collation-key (subseq line 0 semi))) + (ces (parse-collation-elements + (subseq line (1+ semi) hash))) + (packed (emit ces))) + (if (= (length key) 1) + (setf (gethash (first key) single) packed) + (push (list (first key) (second key) (third key) packed) + contractions)))))))))) + ;; base-origin: smallest start among ranges sharing a base. + (let ((origin (make-hash-table))) + (dolist (r raw-ranges) + (destructuring-bind (start end base) r + (declare (ignore end)) + (when (or (null (gethash base origin)) + (< start (gethash base origin))) + (setf (gethash base origin) start)))) + (let* ((rl (nreverse raw-ranges)) + (rvec (make-array (* 4 (length rl)) :element-type '(unsigned-byte 32))) + (cl (nreverse contractions)) + (cvec (make-array (* 4 (length cl)) :element-type '(unsigned-byte 32))) + (i 0)) + (dolist (r rl) + (destructuring-bind (start end base) r + (setf (aref rvec i) start + (aref rvec (+ i 1)) end + (aref rvec (+ i 2)) base + (aref rvec (+ i 3)) (gethash base origin)) + (incf i 4))) + (setf i 0) + (dolist (c cl) + (destructuring-bind (cp1 cp2 cp3 packed) c + (setf (aref cvec i) cp1 + (aref cvec (+ i 1)) cp2 + (aref cvec (+ i 2)) (or cp3 #xFFFFFFFF) + (aref cvec (+ i 3)) packed) + (incf i 4))) + (multiple-value-bind (hvec mvec lvec) + (pack ucd range + (lambda (ent) (gethash (ucdent-code ent) single 0)) + 0 32 #x54) + (make-collation + :split #x54 :hvec hvec :mvec mvec :lvec lvec + :primv (make-array (length primv) :element-type '(unsigned-byte 16) + :initial-contents primv) + :secv (make-array (length secv) :element-type '(unsigned-byte 16) + :initial-contents secv) + :terv (make-array (length terv) :element-type '(unsigned-byte 8) + :initial-contents terv) + :contractions cvec + :ranges rvec)))))) + (defun build-unidata (&optional (ucd-directory "target:i18n/")) (format t "~&Reading data from ~S~%" (probe-file ucd-directory)) (force-output) @@ -1216,4 +1384,9 @@ 0 4 split) (setf (unidata-word-break *unicode-data*) (make-ntrie4 :split split :hvec hvec :mvec mvec :lvec lvec)))) + + (format t "~&Building collation table~%") + (force-output) + (setf (unidata-collation *unicode-data*) + (build-collation ucd range ucd-directory)) nil)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/b021b2a8b48c87ee5203741… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/b021b2a8b48c87ee5203741… You're receiving this email because of your account on gitlab.common-lisp.net. Manage all notifications: https://gitlab.common-lisp.net/-/profile/notifications | Help: https://gitlab.common-lisp.net/help

1 0

[Git][cmucl/cmucl][rtoy-unicode-collation-ducet] Add UNICODE string comparison functions (case-sensitive)
by Raymond Toy (＠rtoy) 17 Jun '26

17 Jun '26

Raymond Toy pushed to branch rtoy-unicode-collation-ducet at cmucl / cmucl Commits: f05b7f0e by Raymond Toy at 2026-06-17T07:11:52-07:00 Add UNICODE string comparison functions (case-sensitive) Add Unicode-aware equivalents of the COMMON-LISP string comparison functions in the UNICODE package: STRING=, STRING/=, STRING<, STRING>, STRING<=, and STRING>=. These compare by the Unicode Collation Algorithm rather than code-unit order, using the collation code in unicode-collation.lisp. They take the usual START1/END1/START2/END2 keywords plus a VARIABLE-WEIGHTING keyword (:SHIFTED by default), and return a generalized boolean rather than a mismatch index, since the comparison is on sort keys derived from the whole normalized string. The Default Unicode Collation Element Table is loaded lazily from allkeys.txt (ext-formats: search list) on first use, pending its serialization into unidata.bin. Shadow and export the six comparison symbols in the UNICODE package. - - - - - 2 changed files: - src/code/exports.lisp - src/code/unicode-collation.lisp Changes: ===================================== src/code/exports.lisp ===================================== @@ -2307,7 +2307,13 @@ (:use "COMMON-LISP") (:shadow "STRING-CAPITALIZE" "STRING-DOWNCASE" - "STRING-UPCASE") + "STRING-UPCASE" + "STRING<" + "STRING<=" + "STRING=" + "STRING/=" + "STRING>" + "STRING>=") (:import-from "LISP" "CODEPOINT" "SURROGATES" @@ -2325,6 +2331,12 @@ (:export "STRING-CAPITALIZE" "STRING-DOWNCASE" "STRING-UPCASE" - "STRING-NEXT-WORD-BREAK")) + "STRING-NEXT-WORD-BREAK" + "STRING<" + "STRING<=" + "STRING=" + "STRING/=" + "STRING>" + "STRING>=")) ===================================== src/code/unicode-collation.lisp ===================================== @@ -500,3 +500,93 @@ if after. VARIABLE-WEIGHTING is as in COLLATION-WEIGHTS." (cond ((< (length k1) (length k2)) -1) ((> (length k1) (length k2)) 1) (t 0))))) + + +;;; ------------------------------------------------------------------- +;;; Public collation API (UNICODE package): the Unicode-aware +;;; equivalents of the COMMON-LISP string comparison functions. +;;; +;;; These compare strings by the Unicode Collation Algorithm rather than +;;; by code-point order, so the result reflects linguistic sort order +;;; (after NFD normalization, with contractions, expansions and the +;;; chosen variable-weighting option). The Default Unicode Collation +;;; Element Table is loaded lazily on first use. +;;; +;;; Unlike the COMMON-LISP functions, these return a generalized boolean +;;; (T or NIL) rather than a mismatch index: the comparison is performed +;;; on sort keys derived from the whole normalized string, so there is +;;; no meaningful character index of the first difference to return. +;;; ------------------------------------------------------------------- + +(in-package "UNICODE") + +(defvar *collation-table-path* "ext-formats:allkeys.txt" + "Pathname of the DUCET data file (allkeys.txt) from which the default +collation table is loaded on first use.") + +(defvar *collation-table* nil + "The default Unicode collation table, or NIL if it has not yet been +loaded. Loaded lazily from *COLLATION-TABLE-PATH* the first time a +collation function needs it. Set to NIL to force a reload.") + +(defun collation-table () + "Return the default Unicode collation table, loading it from +*COLLATION-TABLE-PATH* on first use." + (or *collation-table* + (setf *collation-table* (lisp::load-ducet *collation-table-path*)))) + +(defun %collation-compare (string1 string2 start1 end1 start2 end2 + variable-weighting) + "Three-way collation comparison of the designated substrings of +STRING1 and STRING2: returns a negative integer, zero, or a positive +integer as the first sorts before, equal to, or after the second." + (let ((s1 (string string1)) + (s2 (string string2))) + (when (or (/= start1 0) end1) + (setf s1 (subseq s1 start1 end1))) + (when (or (/= start2 0) end2) + (setf s2 (subseq s2 start2 end2))) + (lisp::collation-compare (collation-table) s1 s2 variable-weighting))) + +(defmacro %def-collation-predicate (name test docstring) + "Define a collation comparison predicate NAME whose result is (TEST c) +where c is the three-way comparison of the two string arguments." + `(defun ,name (string1 string2 &key (start1 0) end1 (start2 0) end2 + (variable-weighting :shifted)) + ,docstring + (let ((c (%collation-compare string1 string2 + start1 end1 start2 end2 + variable-weighting))) + (,test c)))) + +(%def-collation-predicate string= zerop + "Return true if STRING1 and STRING2 collate as equal under the Unicode +Collation Algorithm. Note that this is collation equality, not +code-point identity: canonically equivalent strings, and strings that +differ only in collation-ignorable ways, compare equal. START1, END1, +START2 and END2 bound the substrings compared; VARIABLE-WEIGHTING is +:SHIFTED (the default) or :NON-IGNORABLE.") + +(%def-collation-predicate string/= (lambda (c) (not (zerop c))) + "Return true if STRING1 and STRING2 do not collate as equal. See +UNICODE:STRING= for the meaning of the keyword arguments.") + +(%def-collation-predicate string< minusp + "Return true if STRING1 collates before STRING2 under the Unicode +Collation Algorithm. See UNICODE:STRING= for the meaning of the keyword +arguments.") + +(%def-collation-predicate string> plusp + "Return true if STRING1 collates after STRING2 under the Unicode +Collation Algorithm. See UNICODE:STRING= for the meaning of the keyword +arguments.") + +(%def-collation-predicate string<= (lambda (c) (not (plusp c))) + "Return true if STRING1 collates before or equal to STRING2 under the +Unicode Collation Algorithm. See UNICODE:STRING= for the meaning of the +keyword arguments.") + +(%def-collation-predicate string>= (lambda (c) (not (minusp c))) + "Return true if STRING1 collates after or equal to STRING2 under the +Unicode Collation Algorithm. See UNICODE:STRING= for the meaning of the +keyword arguments.") View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/f05b7f0e709186eefd49b5d… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/f05b7f0e709186eefd49b5d… You're receiving this email because of your account on gitlab.common-lisp.net. Manage all notifications: https://gitlab.common-lisp.net/-/profile/notifications | Help: https://gitlab.common-lisp.net/help

1 0

[Git][cmucl/cmucl][rtoy-unicode-collation-ducet] Speed up collation conformance tests
by Raymond Toy (＠rtoy) 17 Jun '26

17 Jun '26

Raymond Toy pushed to branch rtoy-unicode-collation-ducet at cmucl / cmucl Commits: ca615266 by Raymond Toy at 2026-06-16T19:34:27-07:00 Speed up collation conformance tests The tests ran in ~110s, dominated by COLLATION-HEX-LIST: profiling showed it consing 3.5 GB across 2.2M calls, almost all of it inside PARSE-INTEGER. Accumulate the (16-bit, fixnum) hex values directly instead. The suite now runs in ~14s with identical results. Also compile all the helper functions because they do a lot of processing of the test file and the each test file has over 200K tests. - - - - - 1 changed file: - tests/unicode-collation.lisp Changes: ===================================== tests/unicode-collation.lisp ===================================== @@ -26,16 +26,26 @@ (defun collation-hex-list (string) "Parse all space-separated hexadecimal numbers in STRING into a list of integers, in order. Non-hex runs are skipped." - (let ((result nil) (i 0) (n (length string))) + (let ((result nil) + (i 0) + (n (length string))) (loop - (loop while (and (< i n) (not (digit-char-p (char string i) 16))) + ;; Skip any non-hexadecimal characters. + (loop while (and (< i n) + (null (digit-char-p (char string i) 16))) do (incf i)) (when (>= i n) (return)) - (let ((j i)) - (loop while (and (< j n) (digit-char-p (char string j) 16)) - do (incf j)) - (push (parse-integer string :start i :end j :radix 16) result) - (setf i j))) + ;; Accumulate one hexadecimal number. PARSE-INTEGER is avoided + ;; here because it conses, and this runs several times per line + ;; over hundreds of thousands of conformance lines; the values are + ;; 16-bit and fit in a fixnum. + (let ((val 0) + (d nil)) + (loop while (and (< i n) + (setf d (digit-char-p (char string i) 16))) + do (setf val (+ (* val 16) d)) + (incf i)) + (push val result))) (nreverse result))) (defun collation-split-on-bar (string) @@ -133,3 +143,18 @@ must match the expected key in the line's comment." (:tag :unicode) (run-collation-conformance (ducet) *collation-non-ignorable-test* :non-ignorable)) + +;; A DEFINE-TEST body is stored as source and run interpreted, and the +;; test runner (tests/run-tests.lisp) loads this file as source, so its +;; functions would otherwise run interpreted. The per-line parsing and +;; string building run on every one of several hundred thousand +;; conformance lines, so interpreted they make the suite about ten times +;; slower. Compile the hot functions on load. +(eval-when (:load-toplevel :execute) + (dolist (name '(collation-hex-list + collation-split-on-bar + collation-parse-expected-key + collation-parse-test-line + collation-test-string + run-collation-conformance)) + (compile name))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/ca615266d431bc6f92022a1… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/ca615266d431bc6f92022a1… You're receiving this email because of your account on gitlab.common-lisp.net. Manage all notifications: https://gitlab.common-lisp.net/-/profile/notifications | Help: https://gitlab.common-lisp.net/help

1 0

[Git][cmucl/cmucl][rtoy-unicode-collation-ducet] Run collation conformance tests compiled, not interpreted
by Raymond Toy (＠rtoy) 17 Jun '26

17 Jun '26

Raymond Toy pushed to branch rtoy-unicode-collation-ducet at cmucl / cmucl Commits: 49a6cb37 by Raymond Toy at 2026-06-16T18:04:38-07:00 Run collation conformance tests compiled, not interpreted A DEFINE-TEST body is stored as source and run through the interpreter, so the per-line loop over a quarter-million conformance lines ran interpreted -- ~115s for the suite. Move the loop into a compiled helper, RUN-COLLATION-CONFORMANCE, called from the test bodies; the suite now runs in ~10s with identical coverage (437930 assertions). Previously it took 115s. - - - - - 1 changed file: - tests/unicode-collation.lisp Changes: ===================================== tests/unicode-collation.lisp ===================================== @@ -89,26 +89,40 @@ the BMP as UTF-16 surrogate pairs." (vector-push-extend (code-char cp) out))) (coerce out 'simple-string))) +(defun run-collation-conformance (ducet file weighting) + "Check every line of the UCA conformance FILE: the four sort-key levels +produced by LISP::COLLATION-WEIGHTS under WEIGHTING must match the +expected key parsed from the line's comment. Each line is a separate +LISP-UNIT assertion. + +This is a plain function rather than inline in the DEFINE-TESTs below +because a DEFINE-TEST body is stored as source and run interpreted; the +per-line work over a quarter-million lines must run compiled, so it +lives here and the tests just call it." + (with-open-file (s file :direction :input :external-format :utf-8) + (loop for line = (read-line s nil nil) + while line + do + (multiple-value-bind (cps e1 e2 e3 e4) + (collation-parse-test-line line) + (when cps + (multiple-value-bind (g1 g2 g3 g4) + (lisp::collation-weights ducet (collation-test-string cps) + weighting) + ;; For :NON-IGNORABLE the comment has no fourth level + ;; and COLLATION-WEIGHTS returns NIL for L4, so the + ;; same four-level comparison serves both options. + (assert-equalp (list e1 e2 e3 e4) + (list g1 g2 g3 g4) + cps))))))) + (define-test unicode.collation-shifted "Test UTS #10 collation sort keys against the UCA SHIFTED conformance data. For each line, the four sort-key levels produced by LISP::COLLATION-WEIGHTS must match the expected key in the line's comment." (:tag :unicode) - (let ((ducet (ducet))) - (with-open-file (s *collation-shifted-test* :direction :input - :external-format :utf-8) - (loop for line = (read-line s nil nil) - while line - do - (multiple-value-bind (cps e1 e2 e3 e4) - (collation-parse-test-line line) - (when cps - (multiple-value-bind (g1 g2 g3 g4) - (lisp::collation-weights ducet (collation-test-string cps)) - (assert-equalp (list e1 e2 e3 e4) - (list g1 g2 g3 g4) - cps)))))))) + (run-collation-conformance (ducet) *collation-shifted-test* :shifted)) (define-test unicode.collation-non-ignorable "Test UTS #10 collation sort keys against the UCA NON_IGNORABLE @@ -117,18 +131,5 @@ their weights and there is no fourth level, so for each line the three weight levels produced by LISP::COLLATION-WEIGHTS with :NON-IGNORABLE must match the expected key in the line's comment." (:tag :unicode) - (let ((ducet (ducet))) - (with-open-file (s *collation-non-ignorable-test* :direction :input - :external-format :utf-8) - (loop for line = (read-line s nil nil) - while line - do - (multiple-value-bind (cps e1 e2 e3) - (collation-parse-test-line line) - (when cps - (multiple-value-bind (g1 g2 g3) - (lisp::collation-weights ducet (collation-test-string cps) - :non-ignorable) - (assert-equalp (list e1 e2 e3) - (list g1 g2 g3) - cps)))))))) + (run-collation-conformance (ducet) *collation-non-ignorable-test* + :non-ignorable)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/49a6cb375555be2f71453f6… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/49a6cb375555be2f71453f6… You're receiving this email because of your account on gitlab.common-lisp.net. Manage all notifications: https://gitlab.common-lisp.net/-/profile/notifications | Help: https://gitlab.common-lisp.net/help

1 0

[Git][cmucl/cmucl][rtoy-unicode-collation-ducet] Add Non-ignorable variable weighting and speed up element lookup
by Raymond Toy (＠rtoy) 16 Jun '26

16 Jun '26

Raymond Toy pushed to branch rtoy-unicode-collation-ducet at cmucl / cmucl Commits: 2bfd281e by Raymond Toy at 2026-06-16T13:59:12-07:00 Add Non-ignorable variable weighting and speed up element lookup Add the Non-ignorable variable-weighting option to the collation code alongside the existing Shifted option. COLLATION-WEIGHTS, COLLATION-SORT-KEY, and COLLATION-COMPARE take an optional VARIABLE-WEIGHTING argument (default :SHIFTED); :NON-IGNORABLE treats variable elements like ordinary elements and produces no fourth level. Both options pass the full UCA conformance suite (CollationTest_SHIFTED and CollationTest_NON_IGNORABLE). In LOAD-DUCET, derive two fast-path tables from the main map: SINGLE, mapping a single codepoint directly to its collation elements, and STARTERS, the set of codepoints that begin a multi-codepoint key. DUCET-ELEMENT-ARRAY uses these so that a codepoint which is not a contraction starter skips the longest-match scan and the discontiguous look-ahead, taking one fixnum-keyed lookup instead. Add tests/unicode-collation.lisp tests for both weighting options. - - - - - 2 changed files: - src/code/unicode-collation.lisp - tests/unicode-collation.lisp Changes: ===================================== src/code/unicode-collation.lisp ===================================== @@ -55,6 +55,15 @@ ;; of collation-elements. Single characters and contractions share ;; this table; the key length distinguishes them. (map (make-hash-table :test 'equalp) :type hash-table) + ;; Fast paths derived from MAP at load time. SINGLE maps a single + ;; codepoint (a fixnum) directly to its collation elements, avoiding an + ;; EQUALP probe with a one-element key for the common case. STARTERS + ;; holds every codepoint that begins some multi-codepoint key; a + ;; codepoint not in STARTERS can neither begin a contraction nor be the + ;; base of a discontiguous match, so the contraction machinery is + ;; skipped for it entirely. + (single (make-hash-table :test 'eql) :type hash-table) + (starters (make-hash-table :test 'eql) :type hash-table) ;; Implicit-weight ranges, in file order. (implicit-ranges nil :type list) ;; Longest key (in codepoints) present in MAP; bounds the contraction @@ -180,6 +189,13 @@ returning an IMPLICIT-RANGE, or NIL if it does not parse." do (setf (ducet-max-variable-primary d) (ce-primary ce)))))))))))) (setf (ducet-implicit-ranges d) (nreverse (ducet-implicit-ranges d))) + ;; Build the fast-path tables: SINGLE for one-codepoint keys, and + ;; STARTERS for the first codepoint of every multi-codepoint key. + (maphash (lambda (key ces) + (if (= (length key) 1) + (setf (gethash (aref key 0) (ducet-single d)) ces) + (setf (gethash (aref key 0) (ducet-starters d)) t))) + (ducet-map d)) ;; Compute, for each base, the smallest range start sharing it, and ;; record it as the BBBB offset origin on every range with that base. (let ((origin (make-hash-table))) @@ -298,74 +314,106 @@ the blocking threshold for later non-starters." (consumed (make-array (max 1 (length cps)) :initial-element nil)) (i 0) (n (length cps)) - (maxlen (ducet-max-key-length d))) + (maxlen (ducet-max-key-length d)) + (map (ducet-map d)) + (single (ducet-single d)) + (starters (ducet-starters d))) (loop while (< i n) do (cond ((aref consumed i) (incf i)) ; folded in by a discontiguous match (t - (let ((best-key nil) (best-len 0) (best-ces nil)) - ;; S2.1: longest contiguous match starting at I, over positions - ;; not already consumed by an earlier discontiguous fold. A - ;; multi-codepoint key may only match an unbroken run of - ;; still-present codepoints, so a span containing a consumed - ;; position (a "hole" left by a fold) is rejected. - (loop for len from (min maxlen (- n i)) downto 1 do - (when (loop for j from i below (+ i len) - never (aref consumed j)) - (let* ((key (subseq cps i (+ i len))) - (ces (gethash key (ducet-map d)))) - (when ces - (setf best-key key best-len len best-ces ces) - (return))))) + (let* ((cp (aref cps i)) + (starter (gethash cp starters)) + (best-key nil) (best-len 0) (best-ces nil)) + ;; S2.1: longest contiguous match starting at I. Only a + ;; codepoint that begins some multi-codepoint key (a STARTER) + ;; can match a contraction, so the multi-length scan is done + ;; only for those; every other codepoint takes the SINGLE + ;; fast path. The scan rejects any span containing a position + ;; already consumed by an earlier discontiguous fold. + (when starter + (loop for len from (min maxlen (- n i)) downto 2 do + (when (loop for j from i below (+ i len) + never (aref consumed j)) + (let* ((key (subseq cps i (+ i len))) + (ces (gethash key map))) + (when ces + (setf best-key key best-len len best-ces ces) + (return)))))) + (unless best-ces + (let ((ces (gethash cp single))) + (when ces + (setf best-ces ces best-len 1) + ;; BEST-KEY is needed only to extend by discontiguous + ;; folds, which apply only to starters. + (when starter + (setf best-key (make-array 1 :initial-element cp)))))) (cond - (best-key + (best-ces ;; S2.1.1-S2.1.3: extend by unblocked following non-starters. + ;; A codepoint that is not a STARTER can begin no multi-key, + ;; so no fold is possible and the scan is skipped entirely. ;; MAXCCC is the highest combining class among still-present ;; codepoints passed since the end of the contiguous match. - (let ((maxccc 0)) - (loop for k from (+ i best-len) below n do - (unless (aref consumed k) - (let ((ccc (lisp::unicode-combining-class (aref cps k)))) - (cond - ((zerop ccc) - (return)) ; starter blocks all further - ((> ccc maxccc) ; unblocked candidate - (let* ((cand (collation-extend-key - best-key (aref cps k))) - (ces (gethash cand (ducet-map d)))) - (if ces - ;; Fold C in and remove it; MAXCCC unchanged - ;; since C is no longer present. - (setf best-key cand - best-ces ces - (aref consumed k) t) - ;; No match: C stays and becomes a blocker. - (setf maxccc ccc)))) - (t - ;; Blocked (ccc <= maxccc): C stays; MAXCCC already - ;; covers it. - nil)))))) + (when (and starter best-key) + (let ((maxccc 0)) + (loop for k from (+ i best-len) below n do + (unless (aref consumed k) + (let ((ccc (lisp::unicode-combining-class (aref cps k)))) + (cond + ((zerop ccc) + (return)) ; starter blocks all further + ((> ccc maxccc) ; unblocked candidate + (let* ((cand (collation-extend-key + best-key (aref cps k))) + (ces (gethash cand map))) + (if ces + ;; Fold C in and remove it; MAXCCC + ;; unchanged since C is no longer present. + (setf best-key cand + best-ces ces + (aref consumed k) t) + ;; No match: C stays and becomes a blocker. + (setf maxccc ccc)))) + (t + ;; Blocked (ccc <= maxccc): C stays; MAXCCC + ;; already covers it. + nil))))))) (loop for ce across best-ces do (push ce result)) (incf i best-len)) (t ;; No entry: derive implicit weights (Section 10.1). - (dolist (ce (derive-implicit-elements d (aref cps i))) + (dolist (ce (derive-implicit-elements d cp)) (push ce result)) (incf i))))))) (nreverse result))) -(defun collation-weights (d string) +(defun collation-weights (d string &optional (variable-weighting :shifted)) "Return four values -- the level-1, level-2, level-3 and level-4 weight -lists for STRING under DUCET D, using the Shifted variable-weighting -option (UTS #10 Section 4). Under Shifted: a variable element con- -tributes nothing at levels 1-3 and its primary at level 4; a non- -variable element takes a level-4 weight of FFFF when it carries level-2 -or level-3 content, but none when it is a primary-only continuation -element ([.XXXX.0000.0000], e.g. the second half of an implicit weight -pair or an expansion tail); a completely ignorable element -([.0000.0000.0000]) contributes nothing anywhere; and a primary- -ignorable element that follows a variable element is shifted away -entirely." +lists for STRING under DUCET D. VARIABLE-WEIGHTING selects the UTS #10 +Section 4 option: + + :SHIFTED (the default) -- a variable element contributes nothing at + levels 1-3 and its primary at level 4; a non-variable element takes + a level-4 weight of FFFF when it carries level-2 or level-3 content, + but none when it is a primary-only continuation element + ([.XXXX.0000.0000], e.g. the second half of an implicit weight pair + or an expansion tail); a completely ignorable element + ([.0000.0000.0000]) contributes nothing anywhere; and a primary- + ignorable element that follows a variable element is shifted away + entirely. + + :NON-IGNORABLE -- variable elements are not treated specially: every + element contributes its non-zero weights at levels 1-3 just like any + other element, and there is no fourth level (the returned L4 is + always NIL)." + (ecase variable-weighting + (:shifted (collation-weights-shifted d string)) + (:non-ignorable (collation-weights-non-ignorable d string)))) + +(defun collation-weights-shifted (d string) + "Compute the four weight levels for STRING under the Shifted option. +See COLLATION-WEIGHTS." (let ((ces (ducet-element-array d (string-to-collation-codepoints string))) (l1 nil) (l2 nil) (l3 nil) (l4 nil) (after-variable nil)) @@ -402,14 +450,35 @@ entirely." (setf after-variable nil))))) (values (nreverse l1) (nreverse l2) (nreverse l3) (nreverse l4)))) -(defun collation-sort-key (d string) - "Compute the UTS #10 sort key for STRING under DUCET D (Shifted -option). Returns a (simple-array (unsigned-byte 16) (*)) holding the -level-1 weights, a 0000 separator, the level-2 weights, 0000, the -level-3 weights, 0000, and the level-4 weights. Binary comparison of -two such keys yields the collation order of their strings." - (multiple-value-bind (l1 l2 l3 l4) (collation-weights d string) - (let* ((weights (append l1 (list 0) l2 (list 0) l3 (list 0) l4)) +(defun collation-weights-non-ignorable (d string) + "Compute the weight levels for STRING under the Non-ignorable option. +Variable elements are treated exactly like ordinary elements, and there +is no fourth level. See COLLATION-WEIGHTS." + (let ((ces (ducet-element-array d (string-to-collation-codepoints string))) + (l1 nil) (l2 nil) (l3 nil)) + (dolist (ce ces) + (let ((p (ce-primary ce)) + (s (ce-secondary ce)) + (te (ce-tertiary ce))) + ;; Every element -- variable or not -- contributes its non-zero + ;; weights at each level; zero weights are passed over. + (unless (zerop p) (push p l1)) + (unless (zerop s) (push s l2)) + (unless (zerop te) (push te l3)))) + (values (nreverse l1) (nreverse l2) (nreverse l3) nil))) + +(defun collation-sort-key (d string &optional (variable-weighting :shifted)) + "Compute the UTS #10 sort key for STRING under DUCET D. Returns a +(simple-array (unsigned-byte 16) (*)) holding the level-1 weights, a 0000 +separator, the level-2 weights, 0000, the level-3 weights, and -- for the +:SHIFTED option -- a further 0000 separator and the level-4 weights. +Binary comparison of two such keys yields the collation order of their +strings. VARIABLE-WEIGHTING is as in COLLATION-WEIGHTS." + (multiple-value-bind (l1 l2 l3 l4) + (collation-weights d string variable-weighting) + (let* ((weights (if (eq variable-weighting :non-ignorable) + (append l1 (list 0) l2 (list 0) l3) + (append l1 (list 0) l2 (list 0) l3 (list 0) l4))) (key (make-array (length weights) :element-type '(unsigned-byte 16)))) (loop for w in weights @@ -417,12 +486,12 @@ two such keys yields the collation order of their strings." do (setf (aref key k) w)) key))) -(defun collation-compare (d s1 s2) +(defun collation-compare (d s1 s2 &optional (variable-weighting :shifted)) "Compare strings S1 and S2 under DUCET D. Returns -1, 0, or 1 like a three-way comparison: negative if S1 sorts before S2, zero if equal, 1 -if after." - (let ((k1 (collation-sort-key d s1)) - (k2 (collation-sort-key d s2))) +if after. VARIABLE-WEIGHTING is as in COLLATION-WEIGHTS." + (let ((k1 (collation-sort-key d s1 variable-weighting)) + (k2 (collation-sort-key d s2 variable-weighting))) (let ((n (min (length k1) (length k2)))) (dotimes (i n) (let ((a (aref k1 i)) (b (aref k2 i))) ===================================== tests/unicode-collation.lisp ===================================== @@ -12,6 +12,8 @@ (defvar *collation-allkeys* "target:i18n/allkeys.txt") (defvar *collation-shifted-test* "target:i18n/CollationTest/CollationTest_SHIFTED.txt") +(defvar *collation-non-ignorable-test* + "target:i18n/CollationTest/CollationTest_NON_IGNORABLE.txt") (defvar *ducet* nil "The Default Unicode Collation Element Table, loaded on first use.") @@ -107,3 +109,26 @@ comment." (assert-equalp (list e1 e2 e3 e4) (list g1 g2 g3 g4) cps)))))))) + +(define-test unicode.collation-non-ignorable + "Test UTS #10 collation sort keys against the UCA NON_IGNORABLE +conformance data. Under the Non-ignorable option variable elements keep +their weights and there is no fourth level, so for each line the three +weight levels produced by LISP::COLLATION-WEIGHTS with :NON-IGNORABLE +must match the expected key in the line's comment." + (:tag :unicode) + (let ((ducet (ducet))) + (with-open-file (s *collation-non-ignorable-test* :direction :input + :external-format :utf-8) + (loop for line = (read-line s nil nil) + while line + do + (multiple-value-bind (cps e1 e2 e3) + (collation-parse-test-line line) + (when cps + (multiple-value-bind (g1 g2 g3) + (lisp::collation-weights ducet (collation-test-string cps) + :non-ignorable) + (assert-equalp (list e1 e2 e3) + (list g1 g2 g3) + cps)))))))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/2bfd281ed61a2ab06cb89a0… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/2bfd281ed61a2ab06cb89a0… You're receiving this email because of your account on gitlab.common-lisp.net. Manage all notifications: https://gitlab.common-lisp.net/-/profile/notifications | Help: https://gitlab.common-lisp.net/help

1 0