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

[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

[Git][cmucl/cmucl] Pushed new branch rtoy-unicode-collation-ducet
by Raymond Toy (＠rtoy) 16 Jun '26

16 Jun '26

Raymond Toy pushed new branch rtoy-unicode-collation-ducet at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/rtoy-unicode-collation-du… 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-317-string-compare-by-code-unit] Use issue-317 branch for the new expected failures
by Raymond Toy (＠rtoy) 12 Jun '26

12 Jun '26

Raymond Toy pushed to branch issue-317-string-compare-by-code-unit at cmucl / cmucl Commits: d051b51a by Raymond Toy at 2026-06-12T07:33:08-07:00 Use issue-317 branch for the new expected failures Issue #317 fixes RANDOM-STRING-COMPARISON-TESTS, so use the correct ansi-test branch that removes this test from the expected failures list. - - - - - 1 changed file: - bin/run-ansi-tests.sh Changes: ===================================== bin/run-ansi-tests.sh ===================================== @@ -36,7 +36,7 @@ shift $((OPTIND - 1)) # Use branch cmucl-expected-failures in general since this branch # generally has the list of expected failures. This is the branch to # use on cmucl master in general. -BRANCH=cmucl-expected-failures +BRANCH=cmucl-expected-failures-issue-317 set -x if [ -d ../ansi-test ]; then View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/d051b51a054ffd8eb58db94… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/d051b51a054ffd8eb58db94… 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][master] 2 commits: Fix #512: CI retries select stages
by Raymond Toy (＠rtoy) 03 Jun '26

03 Jun '26

Raymond Toy pushed to branch master at cmucl / cmucl Commits: fad6dd9e by Raymond Toy at 2026-06-02T17:03:21-07:00 Fix #512: CI retries select stages - - - - - 47971b15 by Raymond Toy at 2026-06-02T17:03:21-07:00 Merge branch 'issue-512-ci-retries-select-stages' into 'master' Fix #512: CI retries select stages Closes #512 See merge request cmucl/cmucl!386 - - - - - 1 changed file: - .gitlab-ci.yml Changes: ===================================== .gitlab-ci.yml ===================================== @@ -29,6 +29,7 @@ workflow: # for building. .install: stage: install + retry: 1 artifacts: paths: - snapshot/ @@ -89,6 +90,7 @@ workflow: when: always paths: - ansi-test.out + retry: 1 script: - bin/run-ansi-tests.sh -l dist/bin/lisp after_script: @@ -99,6 +101,7 @@ workflow: # Default configuration for running unit tests. .unit-test: stage: test + retry: 1 artifacts: paths: - test.log View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/1b0a461cae6966caacc626… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/1b0a461cae6966caacc626… 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] Pushed new branch issue-512-ci-retries-select-stages
by Raymond Toy (＠rtoy) 02 Jun '26

02 Jun '26

Raymond Toy pushed new branch issue-512-ci-retries-select-stages at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-512-ci-retries-sele… 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-511-update-unicode-tests] Cross build needs bootstrap file too
by Raymond Toy (＠rtoy) 02 Jun '26

02 Jun '26

Raymond Toy pushed to branch issue-511-update-unicode-tests at cmucl / cmucl Commits: 4ddcc0c7 by Raymond Toy at 2026-06-02T11:26:06-07:00 Cross build needs bootstrap file too - - - - - 1 changed file: - .gitlab-ci.yml Changes: ===================================== .gitlab-ci.yml ===================================== @@ -7,7 +7,8 @@ variables: download_url: "https://common-lisp.net/project/cmucl/downloads/release/$release" version: "$release-x86" tar_ext: "xz" - bootstrap: "-B boot-2026-06-1" + bootstrap_name: "boot-2026-06-1" + bootstrap: "-B $bootstrap_name" workflow: rules: @@ -229,7 +230,7 @@ linux:cross-build: script: - bin/create-target.sh xtarget $CONFIG - bin/create-target.sh xcross $CONFIG - - bin/cross-build-world.sh -crl xtarget xcross src/tools/cross-scripts/cross-x86-x86.lisp snapshot/bin/lisp + - bin/cross-build-world.sh -B src/bootfiles/21f/$bootstrap_name -crl xtarget xcross src/tools/cross-scripts/cross-x86-x86.lisp snapshot/bin/lisp - bin/build.sh -b xlinux $bootstrap -R -C $CONFIG -o "xtarget/lisp/lisp -lib xtarget/lisp" - bin/make-dist.sh -I xdist xlinux-4 View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/4ddcc0c731480b1ba01cfd2… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/4ddcc0c731480b1ba01cfd2… 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-511-update-unicode-tests] Fix typo in bootfile name
by Raymond Toy (＠rtoy) 02 Jun '26

02 Jun '26

Raymond Toy pushed to branch issue-511-update-unicode-tests at cmucl / cmucl Commits: 418f8372 by Raymond Toy at 2026-06-02T09:49:49-07:00 Fix typo in bootfile name - - - - - 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-2026-06-01" + bootstrap: "-B boot-2026-06-1" workflow: rules: View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/418f83725d9eb0798a99fdc… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/418f83725d9eb0798a99fdc… 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-511-update-unicode-tests] Fix up comments preceding string-next-word-break
by Raymond Toy (＠rtoy) 02 Jun '26

02 Jun '26

Raymond Toy pushed to branch issue-511-update-unicode-tests at cmucl / cmucl Commits: 7fcf5249 by Raymond Toy at 2026-06-02T09:46:57-07:00 Fix up comments preceding string-next-word-break These no longer apply since the algorithm is completely different now. - - - - - 1 changed file: - src/code/unicode.lisp Changes: ===================================== src/code/unicode.lisp ===================================== @@ -200,39 +200,12 @@ (string-downcase-full string :start start :end end)))) -;;; -;;; This is a Lisp translation of the Scheme code from William -;;; D. Clinger that implements the word-breaking algorithm. This is -;;; used with permission. -;;; -;;; This version is modified from the original at -;;; http://www.ccs.neu.edu/home/will/R6RS/ to conform to CMUCL's -;;; implementation of the word break properties. -;;; -;;; -;;; Copyright statement and original comments: -;;; -;;;-------------------------------------------------------------------------------- - -;; Copyright 2006 William D Clinger. -;; -;; Permission to copy this software, in whole or in part, to use this -;; software for any lawful purpose, and to redistribute this software -;; is granted subject to the restriction that all copies made of this -;; software must include this copyright and permission notice in full. -;; -;; I also request that you send me a copy of any improvements that you -;; make to this software so that they may be incorporated within it to -;; the benefit of the Scheme community. - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Word-breaking as defined by Unicode Standard Annex #29. ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Implementation notes. -;; ;; The string-foldcase, string-downcase, and string-titlecase ;; procedures rely on the notion of a word, which is defined ;; by Unicode Standard Annex 29. @@ -247,64 +220,11 @@ ;; ;; Hence the performance of the word-breaking algorithm should ;; not matter too much for this reference implementation. -;; Word-breaking is more generally useful, however, so I tried -;; to make this implementation reasonably efficient. -;; -;; Word boundaries are defined by 14 different rules in -;; Unicode Standard Annex #29, and by GraphemeBreakProperty.txt -;; and WordBreakProperty.txt. See also WordBreakTest.html. -;; -;; My original implementation of those specifications failed -;; 6 of the 494 tests in auxiliary/WordBreakTest.txt, but it -;; appeared to me that those tests were inconsistent with the -;; word-breaking rules in UAX #29. John Cowan forwarded my -;; bug report to the Unicode experts, and Mark Davis responded -;; on 29 May 2007: -;; -;; Thanks for following up on this. I think you have found a problem in the -;; formulation of word break, not the test. The intention was to break after a -;; Sep character, as is done in Sentence break. So my previous suggestion was -;; incorrect; instead, what we need is a new rule: -;; -;; *Break after paragraph separators.* -;; WB3a. Sep -;; I'll make a propose to the UTC for this. -;; -;; Here is Will's translation of those rules (including WB3a) -;; into a finite state machine that searches forward within a -;; string, looking for the next position at which a word break -;; is allowed. The current state consists of an index i into -;; the string and a summary of the left context whose rightmost -;; character is at index i. The left context is usually -;; determined by the character at index i, but there are three -;; complications: -;; -;; Extend and Format characters are ignored unless they -;; follow a separator or the beginning of the text. -;; ALetter followed by MidLetter is treated specially. -;; Numeric followed by MidNum is treated specially. -;; -;; In the implementation below, the left context ending at i -;; is encoded by the following symbols: -;; -;; CR -;; Sep (excluding CR) -;; ALetter -;; MidLetter -;; ALetterMidLetter (ALetter followed by MidLetter) -;; Numeric -;; MidNum -;; NumericMidNum (Numeric followed by MidNum) -;; Katakana -;; ExtendNumLet -;; other (none of the above) +;; Word-breaking is more generally useful, however. ;; -;; Given a string s and an exact integer i (which need not be -;; a valid index into s), returns the index of the next character -;; that is not part of the word containing the character at i, -;; or the length of s if the word containing the character at i -;; extends through the end of s. If i is negative or a valid -;; index into s, then the returned value will be greater than i. +;; Word boundaries are defined by different rules in Unicode Standard +;; Annex #29, and by GraphemeBreakProperty.txt and +;; WordBreakProperty.txt. See also WordBreakTest.html. ;; ;;;-------------------------------------------------------------------------------- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/7fcf5249d079811b967b959… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/7fcf5249d079811b967b959… 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-511-update-unicode-tests] Implement Unicode 17.0 word break algorithm (UAX #29)
by Raymond Toy (＠rtoy) 02 Jun '26

02 Jun '26

Raymond Toy pushed to branch issue-511-update-unicode-tests at cmucl / cmucl Commits: 1dec5699 by Raymond Toy at 2026-06-02T09:04:22-07:00 Implement Unicode 17.0 word break algorithm (UAX #29) Rewrite string-next-word-break to follow the Unicode 17.0 word boundary rules. The previous implementation predated several rules and had a dead branch (:extendorformat vs :extend-or-format). Decode the string into codepoints and word-break classes, then scan boundaries applying the WB rules in order. Extend/Format/ZWJ are treated as ignorable (WB4) by comparing against the nearest significant element on each side. New rule support: WB3c (ZWJ x Extended_Pictographic, via unicode-extended-pictographic-p), WB3d (WSegSpace), WB7a/b/c (Hebrew_Letter with quotes), and WB15/16 (Regional_Indicator pair counting). Import unicode-extended-pictographic-p into the UNICODE package, with a bootfile to intern the symbol so the building lisp can read the new package definition. Need a new, very simple, bootstrap file (bootstrap-2026-06-1) to build this. Update .gitlab-ci to use the bootstrap file. All 1944 WordBreakTest.txt cases pass. - - - - - 6 changed files: - .gitlab-ci.yml - bin/build.sh - + src/bootfiles/21f/boot-2026-06-1.lisp - src/code/exports.lisp - src/code/unicode.lisp - src/i18n/locale/cmucl.pot 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: "" + bootstrap: "-B boot-2026-06-01" workflow: rules: ===================================== bin/build.sh ===================================== @@ -38,7 +38,7 @@ ENABLE2="yes" ENABLE3="yes" ENABLE4="yes" -version=21e +version=21f SRCDIR=src BINDIR=bin TOOLDIR=$BINDIR ===================================== src/bootfiles/21f/boot-2026-06-1.lisp ===================================== @@ -0,0 +1,13 @@ +;; Bootstrap file for adding the Extended_Pictographic word-break +;; support (Unicode 17.0 word-break rule WB3c). +;; +;; The new function LISP::UNICODE-EXTENDED-PICTOGRAPHIC-P is imported +;; into the UNICODE package by code/exports.lisp. When the new +;; exports.lisp is compiled by the bootstrapping lisp, that symbol does +;; not yet exist in the LISP package, so the (:import-from "LISP" ...) +;; clause would fail. Intern it here first so the package definition +;; can be read. + +(in-package :lisp) + +(intern "UNICODE-EXTENDED-PICTOGRAPHIC-P" "LISP") ===================================== src/code/exports.lisp ===================================== @@ -2321,7 +2321,8 @@ "+UNICODE-CATEGORY-UPPER+" "+UNICODE-CATEGORY-TITLE+" "UNICODE-UPPER" - "UNICODE-WORD-BREAK") + "UNICODE-WORD-BREAK" + "UNICODE-EXTENDED-PICTOGRAPHIC-P") (:export "STRING-CAPITALIZE" "STRING-DOWNCASE" "STRING-UPCASE" ===================================== src/code/unicode.lisp ===================================== @@ -315,178 +315,155 @@ character extends to the end of S. If the index is negative or valid index into S, the returned value will be strictly greater than the index." + ;; Implements the word-boundary rules of UAX #29 (Unicode 17.0). + ;; + ;; Decode S into codepoints (collapsing UTF-16 surrogate pairs), + ;; classify each by its word-break property, then scan boundaries + ;; left to right applying the WB rules, returning the first boundary + ;; whose string index is strictly greater than I. + ;; + ;; WB4 makes Extend, Format and ZWJ "ignorable": they attach to the + ;; preceding context, so most rules compare a candidate against the + ;; nearest non-ignorable element on each side rather than the literal + ;; neighbour. ZWJ is also significant for WB3c, and Extend can sit + ;; between paired Regional_Indicators, so those rules look past + ;; ignorables explicitly. + (declare (type simple-string s)) (let ((n (length s))) - (labels - ((char-word-break-category (c) - ;; Map our unicode word break property into what this - ;; algorithm wants. - (let ((cat (unicode-word-break c))) - (case cat - ((:lf :cr :newline) - :sep) - ((:extend :format) - :extend-or-format) - (otherwise cat)))) - (left-context (i) - ;; Given a valid index i into s, returns the left context - ;; at i. - (multiple-value-bind (c widep) - (codepoint s i n) - (let* ((back - ;; If we're at a regular character or a leading - ;; surrogate, decrementing by 1 gets us the to - ;; previous character. But for a trailing - ;; surrogate, we need to decrement by 2! - (if (eql widep -1) - 2 - 1)) - (cat (char-word-break-category c))) - (case cat - ((:sep) - (if (= c (char-code #\return)) :cr cat)) - ((:midletter :midnumlet) - (let ((i-1 (- i back))) - (if (and (<= 0 i-1) - (eq (left-context i-1) :aletter)) - :aletter-midletter - cat))) - ((:midnum :midnumlet) - (let ((i-1 (- i back))) - (if (and (<= 0 i-1) - (eq (left-context i-1) :numeric)) - :numeric-midnum - cat))) - ((:extendorformat) - (if (< 0 i) - (left-context (- i back)) - :other)) - (otherwise cat))))) - - (index-of-previous-non-ignored (j) - ;; Returns the index of the last non-Extend, non-Format - ;; character within (substring s 0 j). Should not be - ;; called unless such a character exists. - - (let* ((j1 (- j 1))) - (multiple-value-bind (c widep) - (codepoint s j1) - (when (eql widep -1) - ;; Back up one more if we're at the trailing - ;; surrogate. - (decf j1)) - (let ((cat (char-word-break-category c))) - (case cat - ((:extend-or-format) - (index-of-previous-non-ignored j1)) - (otherwise j1)))))) - - (lookup (j context) - ;; Given j and the context to the left of (not including) j, - ;; returns the index at the start of the next word - ;; (or before which a word break is permitted). - - (if (>= j n) - (case context - ((:aletter-midletter :numeric-midnum) - (let ((j (index-of-previous-non-ignored n))) - (if (< i j) j n))) - (otherwise n)) - (multiple-value-bind (c widep) - (codepoint s j) - (let* ((next-j - ;; The next character is either 1 or 2 code - ;; units away. For a leading surrogate, it's - ;; 2; Otherwise just 1. - (if (eql widep 1) - 2 - 1)) - (cat (char-word-break-category c))) - (case cat - ((:extend-or-format) - (case context - ((:cr :sep) j) - (otherwise (lookup (+ j next-j) context)))) - (otherwise - (case context - ((:cr) - (if (= c (char-code #\linefeed)) - ;; Rule WB3: Don't break CRLF, continue looking - (lookup (+ j next-j) cat) - j)) - ((:aletter) - (case cat - ((:aletter :numeric :extendnumlet) - ;; Rules WB5, WB9, ? - (lookup (+ j next-j) cat)) - ((:midletter :midnumlet) - ;; Rule WB6, need to keep looking - (lookup (+ j next-j) :aletter-midletter)) - (otherwise j))) - ((:aletter-midletter) - (case cat - ((:aletter) - ;; Rule WB7 - (lookup (+ j next-j) cat)) - (otherwise - ;; Rule WB6 and WB7 were extended, but the - ;; region didn't end with :aletter. So - ;; backup and break at that point. - (let ((j2 (index-of-previous-non-ignored j))) - (if (< i j2) j2 j))))) - ((:numeric) - (case cat - ((:numeric :aletter :extendnumlet) - ;; Rules WB8, WB10, ? - (lookup (+ j next-j) cat)) - ((:midnum :midnumlet) - ;; Rules WB11, need to keep looking - (lookup (+ j next-j) :numeric-midnum)) - (otherwise j))) - ((:numeric-midnum) - (case cat - ((:numeric) - ;; Rule WB11, keep looking - (lookup (+ j next-j) cat)) - (otherwise - ;; Rule WB11, WB12 were extended, but the - ;; region didn't end with :numeric, so - ;; backup and break at that point. - (let ((j2 (index-of-previous-non-ignored j))) - (if (< i j2) j2 j))))) - ((:midletter :midnum :midnumlet) - ;; Rule WB14 - j) - ((:katakana) - (case cat - ((:katakana :extendnumlet) - ;; Rule WB13, WB13a - (lookup (+ j next-j) cat)) - (otherwise j))) - ((:extendnumlet) - (case cat - ((:extendnumlet :aletter :numeric :katakana) - ;; Rule WB13a, WB13b - (lookup (+ j next-j) cat)) - (otherwise j))) - ((:regional_indicator) - (case cat - ((:regional_indicator) - ;; Rule WB13c - (lookup (+ j next-j) cat)) - (otherwise j))) - (otherwise j))))))))) - (declare (notinline lookup left-context)) - (cond ((< i 0) - ;; Rule WB1 - 0) - ((<= n i) - ;; Rule WB2 - n) - (t - (multiple-value-bind (c widep) - (codepoint s i) - (declare (ignore c)) - (lookup (+ i (if (eql widep 1) 2 1)) (left-context i)))))))) + (cond + ((< i 0) 0) ; Rule WB1 (start of text) + ((>= i n) n) ; Rule WB2 (end of text) + (t + (let ((cls (make-array 16 :fill-pointer 0 :adjustable t)) + (idx (make-array 16 :fill-pointer 0 :adjustable t))) + ;; Decode codepoints and record the string index of each. + (let ((k 0)) + (loop while (< k n) do + (multiple-value-bind (cp widep) (codepoint s k) + (vector-push-extend (unicode-word-break cp) cls) + (vector-push-extend k idx) + (incf k (if (eql widep 1) 2 1))))) + (let ((m (fill-pointer cls))) + (labels + ((class (j) (aref cls j)) + (ah-letter-p (c) (or (eq c :aletter) (eq c :hebrew_letter))) + (mid-letter-q-p (c) ; (MidLetter | MidNumLetQ) + (or (eq c :midletter) (eq c :midnumlet) (eq c :single_quote))) + (mid-num-q-p (c) ; (MidNum | MidNumLetQ) + (or (eq c :midnum) (eq c :midnumlet) (eq c :single_quote))) + (ignorable (c) ; WB4: Extend | Format | ZWJ + (or (eq c :extend) (eq c :format) (eq c :zwj))) + (ext-pict-at (j) + (unicode-extended-pictographic-p (codepoint s (aref idx j)))) + (prev-significant (j) ; last non-ignorable element < J, or -1 + (loop for p from (1- j) downto 0 + unless (ignorable (class p)) return p + finally (return -1))) + (next-significant (j) ; first non-ignorable element > J, or -1 + (loop for q from (1+ j) below m + unless (ignorable (class q)) return q + finally (return -1))) + (ri-count-left (j) + ;; Number of significant Regional_Indicator elements + ;; immediately to the left of J (stopping at the first + ;; non-RI significant element; ignorables are skipped). + (let ((count 0)) + (loop for p = (prev-significant j) then (prev-significant p) + while (and (>= p 0) (eq (class p) :regional_indicator)) + do (incf count)) + count)) + (break-before-p (j) + ;; Does the algorithm allow a break immediately before + ;; element J (1 <= J < M)? + (let* ((c (class j)) + (lit (class (1- j))) ; literal previous element + (pj (prev-significant j))) + (cond + ;; WB3: CR x LF + ((and (eq lit :cr) (eq c :lf)) nil) + ;; WB3a: (Newline | CR | LF) div + ((member lit '(:newline :cr :lf)) t) + ;; WB3b: div (Newline | CR | LF) + ((member c '(:newline :cr :lf)) t) + ;; WB3c: ZWJ x \p{Extended_Pictographic} + ((and (eq lit :zwj) (ext-pict-at j)) nil) + ;; WB3d: WSegSpace x WSegSpace + ((and (eq lit :wsegspace) (eq c :wsegspace)) nil) + ;; WB4: x (Extend | Format | ZWJ): never break before + ;; an ignorable (covers ignorables after sot or after + ;; another ignorable too). + ((ignorable c) nil) + ;; Nothing significant to the left: break. + ((< pj 0) t) + (t + (let ((p (class pj))) + (cond + ;; WB5: AHLetter x AHLetter + ((and (ah-letter-p p) (ah-letter-p c)) nil) + ;; WB6: AHLetter x (MidLetter|MidNumLetQ) AHLetter + ((and (ah-letter-p p) (mid-letter-q-p c) + (let ((nx (next-significant j))) + (and (>= nx 0) (ah-letter-p (class nx))))) + nil) + ;; WB7: AHLetter (MidLetter|MidNumLetQ) x AHLetter + ((and (ah-letter-p c) (mid-letter-q-p p) + (let ((pp (prev-significant pj))) + (and (>= pp 0) (ah-letter-p (class pp))))) + nil) + ;; WB7a: Hebrew_Letter x Single_Quote + ((and (eq p :hebrew_letter) (eq c :single_quote)) nil) + ;; WB7b: Hebrew_Letter x Double_Quote Hebrew_Letter + ((and (eq p :hebrew_letter) (eq c :double_quote) + (let ((nx (next-significant j))) + (and (>= nx 0) (eq (class nx) :hebrew_letter)))) + nil) + ;; WB7c: Hebrew_Letter Double_Quote x Hebrew_Letter + ((and (eq c :hebrew_letter) (eq p :double_quote) + (let ((pp (prev-significant pj))) + (and (>= pp 0) (eq (class pp) :hebrew_letter)))) + nil) + ;; WB8: Numeric x Numeric + ((and (eq p :numeric) (eq c :numeric)) nil) + ;; WB9: AHLetter x Numeric + ((and (ah-letter-p p) (eq c :numeric)) nil) + ;; WB10: Numeric x AHLetter + ((and (eq p :numeric) (ah-letter-p c)) nil) + ;; WB11: Numeric (MidNum|MidNumLetQ) x Numeric + ((and (eq c :numeric) (mid-num-q-p p) + (let ((pp (prev-significant pj))) + (and (>= pp 0) (eq (class pp) :numeric)))) + nil) + ;; WB12: Numeric x (MidNum|MidNumLetQ) Numeric + ((and (eq p :numeric) (mid-num-q-p c) + (let ((nx (next-significant j))) + (and (>= nx 0) (eq (class nx) :numeric)))) + nil) + ;; WB13: Katakana x Katakana + ((and (eq p :katakana) (eq c :katakana)) nil) + ;; WB13a: (AHLetter|Numeric|Katakana|ExtendNumLet) x ExtendNumLet + ((and (member p '(:aletter :hebrew_letter :numeric + :katakana :extendnumlet)) + (eq c :extendnumlet)) + nil) + ;; WB13b: ExtendNumLet x (AHLetter|Numeric|Katakana) + ((and (eq p :extendnumlet) + (or (ah-letter-p c) + (member c '(:numeric :katakana)))) + nil) + ;; WB15/WB16: in a Regional_Indicator run, break + ;; only between pairs: break before J iff an even + ;; number of RIs precede it. + ((and (eq p :regional_indicator) + (eq c :regional_indicator)) + (evenp (ri-count-left j))) + ;; WB999: otherwise break. + (t t)))))))) + ;; Find the first allowed boundary whose string index is > I. + (loop for j from 1 below m + when (and (> (aref idx j) i) (break-before-p j)) + do (return-from string-next-word-break (aref idx j))) + ;; WB2: otherwise the word extends to end of text. + n))))))) (defun char-titlecase (char) "Returns CHAR converted to title-case if that is possible." ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -2019,8 +2019,8 @@ msgstr "" msgid "Vector of all callbacks." msgstr "" -#: src/compiler/tn.lisp src/compiler/main.lisp src/code/describe.lisp -#: src/code/debug-int.lisp src/code/debug-info.lisp +#: src/compiler/tn.lisp src/compiler/main.lisp src/code/unicode.lisp +#: src/code/describe.lisp src/code/debug-int.lisp src/code/debug-info.lisp #: src/code/foreign-linkage.lisp src/code/reader.lisp src/code/stream.lisp #: src/code/hash-new.lisp src/code/array.lisp src/code/alien-callback.lisp msgid "~S is not an array with a fill-pointer." View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/1dec5699a176f10dd48fa16… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/1dec5699a176f10dd48fa16… 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