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/4e124dd235985a855b711b9... -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/4e124dd235985a855b711b9... 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