[Git][cmucl/cmucl][master] 2 commits: Fix #318: Add standard-char type

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