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

[Git][cmucl/cmucl][issue-318-add-concrete-standard-char-type] 3 commits: Cleanups
by Raymond Toy (＠rtoy) 04 May '26

04 May '26

Raymond Toy pushed to branch issue-318-add-concrete-standard-char-type at cmucl / cmucl Commits: 65083eba by Raymond Toy at 2026-05-04T11:26:25-07:00 Cleanups In code/type.lisp * Add docstring for `+standard-chars+` * Remove old version standard-char :complex-union In tests/standard-char.lisp * Remove individual tests (asserts) * Remove tests that are duplicated elsewhere - - - - - 5df4f946 by Raymond Toy at 2026-05-04T11:38:52-07:00 Fix silly typo Put the docstring in the wrong place for `+standard-chars+` - - - - - c3f6a944 by Raymond Toy at 2026-05-04T11:40:58-07:00 Update cmucl.pot for new docstring - - - - - 3 changed files: - src/code/type.lisp - src/i18n/locale/cmucl.pot - tests/standard-char.lisp Changes: ===================================== src/code/type.lisp ===================================== @@ -3321,14 +3321,15 @@ (declare (ignore type1 type2)) (values t t)) -(defconstant +standard-chars+ +(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)) @@ -3362,33 +3363,19 @@ (t (values nil t)))) -#+nil -(define-type-method (standard-char :complex-union) (type1 type2) - (cond ((csubtypep (specifier-type 'character) type2) - ;; STANDARD-CHAR union any super-type of CHARACTER is that - ;; super-type. Hence, it's TYPE2. - type2) - ((and (member-type-p type2) - (every #'characterp (member-type-members type2))) - ;; STANDARD-CHAR union MEMBER-TYPE whose members are all - ;; standard-characters is a STANDARD-CHAR. - type1) - ((eq (type-intersection (specifier-type 'standard-char) - type2) - *empty-type*) - ;; STANDARD-CHAR union with disjoint type2 has no simplification. - nil) - (t - ;; No simplification - nil))) - (define-type-method (standard-char :complex-union) (type1 type2) - (let* ((sc (if (standard-char-type-p type1) type1 type2)) - (other (if (eq sc type1) type2 type1))) + ;; 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) + ((csubtypep (specifier-type 'character) other) + other) ((and (member-type-p other) - (subsetp (member-type-members other) kernel::+standard-chars+)) + (subsetp (member-type-members other) + +standard-chars+)) sc) (t nil)))) @@ -3420,7 +3407,7 @@ (cond ((null (members)) c::*empty-type*) ((= (length (members)) - (length kernel::+standard-chars+)) + (length +standard-chars+)) sc) (t (make-member-type :members (members)))))))))) ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -1224,6 +1224,10 @@ msgstr "" msgid "Array dimensions is not a list, integer or *:~% ~S" msgstr "" +#: src/code/type.lisp +msgid "The set of characters in the STANDARD-CHAR type" +msgstr "" + #: src/code/type.lisp msgid "Type of characters that aren't base-char's. None in CMU CL." msgstr "" ===================================== tests/standard-char.lisp ===================================== @@ -13,11 +13,9 @@ (:tag :issues) (assert-true (typep #\a 'standard-char)) (assert-false (typep #\tab 'standard-char)) - (assert-true (typep #\a 'standard-char)) (assert-true (typep #\Z 'standard-char)) (assert-true (typep #\Space 'standard-char)) (assert-true (typep #\Newline 'standard-char)) - (assert-false (typep #\Tab 'standard-char)) (assert-false (typep #\Rubout 'standard-char)) (assert-false (typep 5 'standard-char)) (assert-false (typep "hello" 'standard-char)) @@ -165,10 +163,7 @@ (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)) - #+nil - (not (and (c::member-type-p result) - (>= (length (c::member-type-members result)) 90))))) + (assert-true (c::union-type-p result)))) (define-test standard-char.complex-intersection (:tag :issues) @@ -246,17 +241,6 @@ :error)))) (assert-eql expected actual ch)))) -(define-test standard-char.caching - (:tag :issues) - ;; Multiple specifier-type calls on `standard-char` return EQ. - (assert-eq (c::specifier-type 'standard-char) - (c::specifier-type 'standard-char)) - - ;; And via the deftype expansion. - (assert-eq (c::specifier-type 'standard-char) - (c::specifier-type 'standard-char))) - ; - (define-test standard-char.intersection-character-both-orderings (:tag :issues) ;; Standard-char intersect character = standard-char, regardless of argument order. @@ -333,17 +317,6 @@ (some (complement #'characterp) (kernel::member-type-members m))))))) -(define-test standard-char.subtypep-bidirectional - (:tag :issues) - ;; arg1 path: standard-char subset of X? - (assert-equal (values t t) (subtypep 'standard-char 'character)) - (assert-equal (values nil t) (subtypep 'standard-char 'integer)) - ;; arg2 path: X subset of standard-char? - (assert-equal (values nil t) (subtypep 'character 'standard-char)) - (assert-equal (values nil t) (subtypep 'integer 'standard-char)) - ;; Both reflexively - (assert-equal (values t t) (subtypep 'standard-char 'standard-char))) - (defun assert-commutative-union (type-a-spec type-b-spec) "Assert that union(A, B) and union(B, A) produce type= results." (assert-equality #'kernel::type= View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/6b8a9fb539d9c86227273b… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/6b8a9fb539d9c86227273b… 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 to load type.lisp when cross-compiling.
by Raymond Toy (＠rtoy) 04 May '26

04 May '26

Raymond Toy pushed to branch issue-318-add-concrete-standard-char-type at cmucl / cmucl Commits: 6b8a9fb5 by Raymond Toy at 2026-05-04T08:46:48-07:00 Don't need to load type.lisp when cross-compiling. We don't actually need to do this. Probably a mistake during initial implementation necessitates this, but now that the implementation is done, cross-compile works fine without this, and resulting build is fine too. - - - - - 1 changed file: - src/tools/worldcom.lisp Changes: ===================================== src/tools/worldcom.lisp ===================================== @@ -137,13 +137,7 @@ (:optimize '(optimize (safety 2) (debug 2))) (comf "target:code/class")) -;; When cross-compiling, it's good to have all the type classes -;; defined for code/pred.lisp to use. -#-bootstrap (comf "target:code/type") -#+bootstrap -(comf "target:code/type" :load t) - (comf "target:compiler/generic/vm-type") (comf "target:code/type-init") (comf "target:code/pred") View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/6b8a9fb539d9c86227273bf… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/6b8a9fb539d9c86227273bf… 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] Just test the ASCII characters
by Raymond Toy (＠rtoy) 04 May '26

04 May '26

Raymond Toy pushed to branch issue-318-add-concrete-standard-char-type at cmucl / cmucl Commits: 4173744f by Raymond Toy at 2026-05-04T08:37:08-07:00 Just test the ASCII characters That covers standard-char and others. - - - - - 1 changed file: - tests/standard-char.lisp Changes: ===================================== tests/standard-char.lisp ===================================== @@ -232,21 +232,19 @@ (define-test standard-char.etypecase (:tag :issues) - (let ((*random-state* (make-random-state))) - ;; Test etypecase with standard-char works correctly using random - ;; characters. To make this repeatable, use a fixed random-state, - ;; otherwise, it becomes hard to debug - (dotimes (k 200) - (let* ((ch (code-char (random 128))) - (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))))) + ;; 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.caching (:tag :issues) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/4173744fb861c0ccc275742… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/4173744fb861c0ccc275742… 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] Reduce range of chars for etypecase test
by Raymond Toy (＠rtoy) 04 May '26

04 May '26

Raymond Toy pushed to branch issue-318-add-concrete-standard-char-type at cmucl / cmucl Commits: fc703c66 by Raymond Toy at 2026-05-04T08:25:40-07:00 Reduce range of chars for etypecase test Randomly generating a character from all possible values means we'll almost never test a standard-char. Thus, simplify the test and just do the ASCII chars which covers both standard-char and others. - - - - - 1 changed file: - tests/standard-char.lisp Changes: ===================================== tests/standard-char.lisp ===================================== @@ -237,7 +237,7 @@ ;; characters. To make this repeatable, use a fixed random-state, ;; otherwise, it becomes hard to debug (dotimes (k 200) - (let* ((ch (code-char (random char-code-limit))) + (let* ((ch (code-char (random 128))) (expected (if (standard-char-p ch) :is-standard :is-other)) (actual (handler-case View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/fc703c66b54af4e8e5b0cff… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/fc703c66b54af4e8e5b0cff… 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] 2 commits: Add additional tests
by Raymond Toy (＠rtoy) 04 May '26

04 May '26

Raymond Toy pushed to branch issue-318-add-concrete-standard-char-type at cmucl / cmucl Commits: c4862897 by Raymond Toy at 2026-05-04T08:01:50-07:00 Add additional tests Add checks that intersection and unions are commutative (because they weren't before). - - - - - cc9127da by Raymond Toy at 2026-05-04T08:21:08-07:00 Enable random test using etypecase This is basically the etypecase-15 from ansi-tests. We do it here to make it explicit with the standard-char tests. - - - - - 1 changed file: - tests/standard-char.lisp Changes: ===================================== tests/standard-char.lisp ===================================== @@ -5,7 +5,12 @@ (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 #\a 'standard-char)) @@ -25,6 +30,7 @@ (subtypep 'standard-char 'base-char))) (define-test standard-char.etypecase-15 + (:tag :issues) (assert-equal (values t t) (c::type= (c::specifier-type @@ -32,21 +38,24 @@ (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))) @@ -54,6 +63,7 @@ (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)) @@ -77,6 +87,7 @@ (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)) @@ -106,6 +117,7 @@ (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) @@ -159,6 +171,7 @@ (>= (length (c::member-type-members result)) 90))))) (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) @@ -202,6 +215,7 @@ (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))) @@ -216,19 +230,26 @@ (c::type= (c::specifier-type '(and standard-char (not (member #\a)))) (c::specifier-type '(and (not (member #\a)) standard-char))))) -#+nil (define-test standard-char.etypecase - ;; This is the original failing test family — should now pass reliably. - (loop repeat 100 - always (eql nil - (handler-case - (etypecase #\a - (standard-char :ok) - (number :wrong)) - (error () :error)) - :ok))) + (:tag :issues) + (let ((*random-state* (make-random-state))) + ;; Test etypecase with standard-char works correctly using random + ;; characters. To make this repeatable, use a fixed random-state, + ;; otherwise, it becomes hard to debug + (dotimes (k 200) + (let* ((ch (code-char (random char-code-limit))) + (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.caching + (:tag :issues) ;; Multiple specifier-type calls on `standard-char` return EQ. (assert-eq (c::specifier-type 'standard-char) (c::specifier-type 'standard-char)) @@ -237,3 +258,122 @@ (assert-eq (c::specifier-type 'standard-char) (c::specifier-type 'standard-char))) ; + +(define-test standard-char.intersection-character-both-orderings + (:tag :issues) + ;; Standard-char intersect character = standard-char, regardless of argument order. + (assert-equality #'kernel::type= + (kernel::specifier-type 'standard-char) + (kernel::type-intersection (kernel::specifier-type 'standard-char) + (kernel::specifier-type 'character))) + (assert-equality #'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-equality #'kernel::type= + kernel::*empty-type* + (kernel::type-intersection (kernel::specifier-type 'standard-char) + (kernel::specifier-type 'integer))) + (assert-equality #'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-equality #'kernel::type= + (kernel::specifier-type '(member #\a #\b)) + (kernel::type-intersection (kernel::specifier-type 'standard-char) + (kernel::specifier-type '(member #\a #\Tab #\b)))) + (assert-equality #'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-equality #'kernel::type= + (kernel::specifier-type 'character) + (kernel::type-union (kernel::specifier-type 'standard-char) + (kernel::specifier-type 'character))) + (assert-equality #'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-equality #'kernel::type= + (kernel::specifier-type 'standard-char) + (kernel::type-union (kernel::specifier-type 'standard-char) + (kernel::specifier-type '(member #\a #\b)))) + (assert-equality #'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-equality #'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))))))) + +(define-test standard-char.subtypep-bidirectional + (:tag :issues) + ;; arg1 path: standard-char subset of X? + (assert-equal (values t t) (subtypep 'standard-char 'character)) + (assert-equal (values nil t) (subtypep 'standard-char 'integer)) + ;; arg2 path: X subset of standard-char? + (assert-equal (values nil t) (subtypep 'character 'standard-char)) + (assert-equal (values nil t) (subtypep 'integer 'standard-char)) + ;; Both reflexively + (assert-equal (values t t) (subtypep 'standard-char 'standard-char))) + +(defun assert-commutative-union (type-a-spec type-b-spec) + "Assert that union(A, B) and union(B, A) produce type= results." + (assert-equality #'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-equality #'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/4e124dd235985a855b711b… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/4e124dd235985a855b711b… 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] 4 commits: Fixes to get it to compile
by Raymond Toy (＠rtoy) 04 May '26

04 May '26

Raymond Toy pushed to branch issue-318-add-concrete-standard-char-type at cmucl / cmucl Commits: df2d254b by Raymond Toy at 2026-05-03T16:29:15-07:00 Fixes to get it to compile Compiles, but doesn't seem to be working. standard-char is still a member-type. - - - - - 751cd08f by Raymond Toy at 2026-05-03T18:21:28-07:00 Fixed typo and added printer Fixed stupid typo in :complex-subtypep-arg2. Add a printer for standard-char-type so we don't print out the full structure. Update cmucl.pot for docstring that was removed. - - - - - 96f18c78 by Raymond Toy at 2026-05-04T07:17:04-07:00 Fix standard-char :complex-intersection First, add (:enumerable t) to standard-char-type defstruct. Second, for :complex-intersection don't need a case for a member-type. We can do it all in the default case by using ctypep to see if the other type contains any standard-char. Collect all such characters and return a member-type of the collected characters. - - - - - 4e124dd2 by Raymond Toy at 2026-05-04T07:48:53-07:00 Add bootstrap file and tests We can build the new standard-char by using boot-21f.lisp. Thus, update build.sh to use version/dir 21f to find the boot file. Update .gitlab-ci.yml to use the boot file. Add tests for standard-char. - - - - - 9 changed files: - .gitlab-ci.yml - bin/build.sh - + src/bootfiles/21f/boot-21f.lisp - src/code/exports.lisp - src/code/pred.lisp - src/code/type.lisp - src/i18n/locale/cmucl.pot - src/tools/worldcom.lisp - + tests/standard-char.lisp 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-21f" 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-21f.lisp ===================================== @@ -0,0 +1,14 @@ +;; 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/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,7 +291,7 @@ (and (consp object) (%%typep (car object) (cons-type-car-type type)) (%%typep (cdr object) (cons-type-cdr-type type)))) - (standard-char-type + (kernel::standard-char-type (and (characterp object) (standard-char-p object))) (unknown-type ===================================== src/code/type.lisp ===================================== @@ -52,7 +52,7 @@ (define-type-class intersection) (define-type-class alien) (define-type-class cons) -(define-type-class standard-char named) +(define-type-class standard-char) ;;; The Args-Type structure is used both to represent Values types and ;;; and Function types. @@ -365,9 +365,12 @@ (%make-cons-type car-type cdr-type))) (defstruct (standard-char-type - (:include ctype (class-info (type-class-or-lose 'standard-char))) + (:include ctype + (class-info (type-class-or-lose 'standard-char)) + (:enumerable t)) (:constructor %make-standard-char-type ()) - (:copier nil))) + (:copier nil) + (:print-function %print-type))) (defun make-standard-char-type () (%make-standard-char-type)) @@ -3354,12 +3357,13 @@ (cond ((member-type-p type1) ;; If TYPE1 is a member-type, check whether it contains all ;; standard-chars. - (values (subsetp (member-type-members type2) +standard-chars+) + (values (subsetp (member-type-members type1) +standard-chars+) t)) (t (values nil t)))) - (define-type-method (standard-char :complex-union) (type1 type2) +#+nil +(define-type-method (standard-char :complex-union) (type1 type2) (cond ((csubtypep (specifier-type 'character) type2) ;; STANDARD-CHAR union any super-type of CHARACTER is that ;; super-type. Hence, it's TYPE2. @@ -3378,43 +3382,48 @@ ;; No simplification nil))) +(define-type-method (standard-char :complex-union) (type1 type2) + (let* ((sc (if (standard-char-type-p type1) type1 type2)) + (other (if (eq sc type1) type2 type1))) + (cond + ((csubtypep (specifier-type 'character) other) other) + ((and (member-type-p other) + (subsetp (member-type-members other) kernel::+standard-chars+)) + sc) + (t nil)))) + (define-type-method (standard-char :complex-intersection) (type1 type2) - (cond ((csubtype (specifier-type 'character) type2) - ;; STANDARD-CHAR intersect super-type of CHARACTER is a - ;; STANDARD-CHAR. - type1) - ((member-type-p type2) - ;; STANDARD-CHAR intersect member-type. The result is a - ;; member type with everything removed except the standard - ;; chars. - (let ((common-chars (intersection (member-type-members type2) - +standard-chars+))) - (if common-chars - (make-member-type :members common-chars) - *empty-type*))) - ((negation-type-p type2) - ;; Handle (and standard-char (not stuff)) - (let ((not-neg (negation-type-type type2))) - (cond ((csubtypep type1 not-neg) - ;; If standard-char is a subtype of stuff, the - ;; intersection is empty. - *empty-type*) - ((eq (type-intersection type1 not-neg) - *empty-type*) - ;; If the intersection of standard-char and stuff is - ;; empty, the intersection is standard-char. - type1) - (t nil)))) - ((eq (type-intersection (specifier-type 'standard-char) - type2) - *empty-type*) - ;; STANDARD-CHAR intersect with disjoing TYPE2 results in the - ;; empty type. - *empty-type*) - (t - ;; Default is can't simplify - nil))) - + ;; 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 kernel::+standard-chars+)) + sc) + (t + (make-member-type :members (members)))))))))) ;;; TYPE-DIFFERENCE -- Interface ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -1228,10 +1228,6 @@ msgstr "" msgid "Type of characters that aren't base-char's. None in CMU CL." msgstr "" -#: src/code/type.lisp -msgid "Type corresponding to the charaters required by the standard." -msgstr "" - #: src/code/type.lisp msgid "Type for any keyword symbol." msgstr "" ===================================== src/tools/worldcom.lisp ===================================== @@ -137,7 +137,13 @@ (:optimize '(optimize (safety 2) (debug 2))) (comf "target:code/class")) +;; When cross-compiling, it's good to have all the type classes +;; defined for code/pred.lisp to use. +#-bootstrap (comf "target:code/type") +#+bootstrap +(comf "target:code/type" :load t) + (comf "target:compiler/generic/vm-type") (comf "target:code/type-init") (comf "target:code/pred") ===================================== tests/standard-char.lisp ===================================== @@ -0,0 +1,239 @@ +;;; Tests for standard-char + +(defpackage :standard-char-tests + (:use :cl :lisp-unit)) + +(in-package "STANDARD-CHAR-TESTS") + +(define-test standard-char.typep + (assert-true (typep #\a 'standard-char)) + (assert-false (typep #\tab 'standard-char)) + (assert-true (typep #\a 'standard-char)) + (assert-true (typep #\Z 'standard-char)) + (assert-true (typep #\Space 'standard-char)) + (assert-true (typep #\Newline 'standard-char)) + (assert-false (typep #\Tab '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 t t) + (subtypep 'standard-char 'base-char))) + +(define-test standard-char.etypecase-15 + (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 + (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 + (assert-eq 'standard-char + (c::type-specifier (c::specifier-type 'standard-char)))) + +(define-test standard-char.predicate + (assert-true (c::standard-char-type-p (c::specifier-type 'standard-char)))) + +(define-test standard-char.simple-subtypep + (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 + ;; 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 + ;; 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 + ;; 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)) + #+nil + (not (and (c::member-type-p result) + (>= (length (c::member-type-members result)) 90))))) + +(define-test standard-char.complex-intersection + ;; 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 + ;; 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))))) + +#+nil +(define-test standard-char.etypecase + ;; This is the original failing test family — should now pass reliably. + (loop repeat 100 + always (eql nil + (handler-case + (etypecase #\a + (standard-char :ok) + (number :wrong)) + (error () :error)) + :ok))) + +(define-test standard-char.caching + ;; Multiple specifier-type calls on `standard-char` return EQ. + (assert-eq (c::specifier-type 'standard-char) + (c::specifier-type 'standard-char)) + + ;; And via the deftype expansion. + (assert-eq (c::specifier-type 'standard-char) + (c::specifier-type 'standard-char))) + ; View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/5a78c1a9f7683c1c19c52b… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/5a78c1a9f7683c1c19c52b… 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-318-add-concrete-standard-char-type
by Raymond Toy (＠rtoy) 03 May '26

03 May '26

Raymond Toy pushed new branch issue-318-add-concrete-standard-char-type at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-318-add-concrete-st… 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-499-defmacro-restart-for-locked-packages] Remove old code
by Raymond Toy (＠rtoy) 03 May '26

03 May '26

Raymond Toy pushed to branch issue-499-defmacro-restart-for-locked-packages at cmucl / cmucl Commits: 944ad9bf by Raymond Toy at 2026-05-02T19:36:47-07:00 Remove old code - - - - - 1 changed file: - src/code/macros.lisp Changes: ===================================== src/code/macros.lisp ===================================== @@ -77,30 +77,6 @@ ;;; definition is done by %defmacro which we expand into. ;;; (defmacro defmacro (name lambda-list &body body) - #+nil - (when lisp::*enable-package-locked-errors* - (multiple-value-bind (valid block-name) - (ext:valid-function-name-p name) - (declare (ignore valid)) - (let ((package (symbol-package block-name))) - (when package - (when (ext:package-definition-lock package) - (restart-case - (error 'lisp::package-locked-error - :package package - :format-control (intl:gettext "defining macro ~A") - :format-arguments (list name)) - (continue () - :report (lambda (stream) - (write-string (intl:gettext "Ignore the lock and continue") stream))) - (unlock-package () - :report (lambda (stream) - (write-string (intl:gettext "Disable the package's definition-lock then continue") stream)) - (setf (ext:package-definition-lock package) nil)) - (unlock-all () - :report (lambda (stream) - (write-string (intl:gettext "Unlock all packages, then continue") stream)) - (lisp::unlock-all-packages)))))))) (let ((whole (gensym "WHOLE-")) (environment (gensym "ENV-"))) (multiple-value-bind View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/944ad9bf45255011ff9d1f3… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/944ad9bf45255011ff9d1f3… 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-500-common-package-error-restart-function] Remove old code that was replaced by signal-package-locked-error
by Raymond Toy (＠rtoy) 03 May '26

03 May '26

Raymond Toy pushed to branch issue-500-common-package-error-restart-function at cmucl / cmucl Commits: e7c711a7 by Raymond Toy at 2026-05-02T18:02:25-07:00 Remove old code that was replaced by signal-package-locked-error - - - - - 3 changed files: - src/code/defstruct.lisp - src/code/package.lisp - src/code/type.lisp Changes: ===================================== src/code/defstruct.lisp ===================================== @@ -454,30 +454,9 @@ (pkg (symbol-package name))) (when (and pkg (ext:package-definition-lock pkg)) - (lisp::signal-package-locked-error - pkg :definition - (intl:gettext "defining structure ~A") - name)) - #+nil - (when (and lisp::*enable-package-locked-errors* - pkg - (ext:package-definition-lock pkg)) - (restart-case - (error 'lisp::package-locked-error - :package pkg - :format-control (intl:gettext "defining structure ~A") - :format-arguments (list name)) - (continue () - :report (lambda (stream) - (write-string (intl:gettext "Ignore the lock and continue") stream))) - (unlock-package () - :report (lambda (stream) - (write-string (intl:gettext "Disable package's definition lock then continue") stream)) - (setf (ext:package-definition-lock pkg) nil)) - (unlock-all () - :report (lambda (stream) - (write-string (intl:gettext "Unlock all packages, then continue") stream)) - (lisp::unlock-all-packages)))) + (lisp::signal-package-locked-error pkg :definition + (intl:gettext "defining structure ~A") + name)) (when (info declaration recognized name) (error (intl:gettext "Defstruct already names a declaration: ~S.") name)) (when (stringp (car slot-descriptions)) ===================================== src/code/package.lisp ===================================== @@ -191,10 +191,20 @@ ;;; SIGNAL-PACKAGE-LOCKED-ERROR -- Internal ;;; -;;; This encapsulates signaling of package locked errors. +;;; This encapsulates signaling of package locked errors. LOCK-KIND +;;; should be one of the following which will clear the corresponding +;;; lock when the UNLOCK-PACKAGE restart is selected. +;;; +;;; :definition - resets package-definition-lock +;;; :namespace - resets package-lock +;;; +;;; Error is signaled only if *ENABLE-PACKAGE-LOCKED-ERRORS* is non-NIL. (defun signal-package-locked-error (package lock-kind message-control &rest message-args) - (when (and (boundp 'lisp::*enable-package-locked-errors*) - lisp::*enable-package-locked-errors*) + (declare (type (member :definition :namespace) lock-kind)) + ;; During bootstrap, *ENABLE-PACKAGE-LOCKED-ERRORS* may not be + ;; bound. Treat that is if it were NIL, so nothing is signaled. + (when (and (boundp '*enable-package-locked-errors*) + *enable-package-locked-errors*) (restart-case (error 'lisp::package-locked-error :package package @@ -218,43 +228,8 @@ (write-string (intl:gettext "Unlock all packages, then continue") stream)) (unlock-all-packages))))) -;; trap attempts to redefine a function in a locked package, and +;; Trap attempts to redefine a function in a locked package, and ;; signal a continuable error. -#+nil -(defun redefining-function (function replacement) - (declare (ignore replacement)) - (when *enable-package-locked-errors* - (multiple-value-bind (valid block-name) - (ext:valid-function-name-p function) - (declare (ignore valid)) - (let ((package (symbol-package block-name))) - (when package - (when (package-definition-lock package) - (when (and (consp function) - (member (first function) - '(pcl::slot-accessor - pcl::method - pcl::fast-method - pcl::effective-method - pcl::ctor))) - (return-from redefining-function nil)) - (restart-case - (error 'package-locked-error - :package package - :format-control (intl:gettext "redefining function ~A") - :format-arguments (list function)) - (continue () - :report (lambda (stream) - (write-string (intl:gettext "Ignore the lock and continue") stream))) - (unlock-package () - :report (lambda (stream) - (write-string (intl:gettext "Disable package's definition-lock, then continue") stream)) - (setf (ext:package-definition-lock package) nil)) - (unlock-all () - :report (lambda (stream) - (write-string (intl:gettext "Disable all package locks, then continue") stream)) - (unlock-all-packages))))))))) - (defun redefining-function (function replacement) (declare (ignore replacement)) (when *enable-package-locked-errors* @@ -1491,25 +1466,6 @@ (signal-package-locked-error package :namespace (intl:gettext "uninterning symbol ~A") name)) - #+nil - (when *enable-package-locked-errors* - (when (ext:package-lock package) - (restart-case - (error 'package-locked-error - :package package - :format-control (intl:gettext "uninterning symbol ~A") - :format-arguments (list name)) - (continue () - :report (lambda (stream) - (write-string (intl:gettext "Ignore the lock and continue") stream))) - (unlock-package () - :report (lambda (stream) - (write-string (intl:gettext "Disable package's lock then continue") stream)) - (setf (ext:package-lock package) nil)) - (unlock-all () - :report (lambda (stream) - (write-string (intl:gettext "Unlock all packages, then continue") stream)) - (unlock-all-packages))))) ;; ;; If a name conflict is revealed, give use a chance to shadowing-import ;; one of the accessible symbols. @@ -1678,25 +1634,7 @@ (signal-package-locked-error package :namespace (intl:gettext "unexporting symbols ~A") symbols)) - #+nil - (when *enable-package-locked-errors* - (when (ext:package-lock package) - (restart-case - (error 'package-locked-error - :package package - :format-control (intl:gettext "unexporting symbols ~A") - :format-arguments (list symbols)) - (continue () - :report (lambda (stream) - (write-string (intl:gettext "Ignore the lock and continue") stream))) - (unlock-package () - :report (lambda (stream) - (write-string (intl:gettext "Disable package's lock then continue") stream)) - (setf (ext:package-lock package) nil)) - (unlock-all () - :report (lambda (stream) - (write-string (intl:gettext "Unlock all packages, then continue") stream)) - (unlock-all-packages))))) + (dolist (sym (symbol-listify symbols)) (multiple-value-bind (s w) (find-symbol (symbol-name sym) package) (cond ((or (not w) (not (eq s sym))) ===================================== src/code/type.lisp ===================================== @@ -2950,6 +2950,7 @@ ;;; We don't need a :COMPLEX-UNION, since the only interesting case is a union ;;; type, and the member/union interaction is handled by the union type ;;; method. +#+nil (define-type-method (member :simple-union) (type1 type2) (let ((mem1 (member-type-members type1)) (mem2 (member-type-members type2))) @@ -2958,6 +2959,16 @@ (t (make-member-type :members (union mem1 mem2)))))) +(define-type-method (member :simple-union) (type1 type2) + (let ((mem1 (member-type-members type1)) + (mem2 (member-type-members type2))) + (cond ((subsetp mem1 mem2) type2) + ((subsetp mem2 mem1) type1) + ;; NEW: refuse to merge across character/non-character domains + ((and (some #'characterp mem1) (notevery #'characterp mem2)) nil) + ((and (some #'characterp mem2) (notevery #'characterp mem1)) nil) + (t (make-member-type :members (union mem1 mem2)))))) + (define-type-method (member :simple-=) (type1 type2) (let ((mem1 (member-type-members type1)) (mem2 (member-type-members type2))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/e7c711a7ef9ccad3cfdbf5a… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/e7c711a7ef9ccad3cfdbf5a… 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] Update cmucl.pot for changed docstrings in with-temporary-file
by Raymond Toy (＠rtoy) 02 May '26

02 May '26

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 523b8fc3 by Raymond Toy at 2026-05-02T08:02:19-07:00 Update cmucl.pot for changed docstrings in with-temporary-file These were updated recently and I forgot to update the pot file at the same time. Update them now. No CI needed; we don't check the pot files anyway. [skip-ci] - - - - - 1 changed file: - src/i18n/locale/cmucl.pot Changes: ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -6031,10 +6031,10 @@ msgstr "" #: src/code/extensions.lisp msgid "" "Creates a temporary file with a name bound to Filename which a\n" -" namestring. If Directory is not provided, the temporary file is created\n" -" in a OS-dependent location. The Prefix is a prefix to the file name\n" -" to be created. If not provided a default prefix is used.\n" -" On completion, the file is automatically removed." +" namestring. If Directory is not provided, the temporary file is created\n" +" in a OS-dependent location. The Prefix is a prefix to the file name\n" +" to be created. If not provided a default prefix is used.\n" +" On completion, the file is automatically removed." msgstr "" #: src/code/extensions.lisp @@ -6053,11 +6053,11 @@ msgstr "" #: src/code/extensions.lisp msgid "" "Return a namestring to a temporary directory. If Directory is not\n" -" provided, the directory is created in an OS-dependent location. The\n" -" Prefix is a string that is used as a prefix for the name of the\n" -" temporary directory. If Prefix is not given, a default prefix is\n" -" used. The directory and all its contents are automatically removed\n" -" afterward." +" provided, the directory is created in an OS-dependent location. The\n" +" Prefix is a string that is used as a prefix for the name of the\n" +" temporary directory. If Prefix is not given, a default prefix is\n" +" used. The directory and all its contents are automatically removed\n" +" afterward." msgstr "" #: src/code/ext-code.lisp View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/523b8fc34dfac4b6c91065b… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/523b8fc34dfac4b6c91065b… 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