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