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