Raymond Toy pushed to branch issue-318-add-concrete-standard-char-type at cmucl / cmucl

Commits:

9 changed files:

Changes:

  • .gitlab-ci.yml
    ... ... @@ -7,7 +7,7 @@ variables:
    7 7 
       download_url: "https://common-lisp.net/project/cmucl/downloads/release/$release"
    8 8 
       version: "$release-x86"
    9 9 
       tar_ext: "xz"
    10 
    -  bootstrap: ""
    10 
    +  bootstrap: "-B boot-21f"
    11 11
    12 12 
     workflow:
    13 13 
       rules:

  • bin/build.sh
    ... ... @@ -38,7 +38,7 @@ ENABLE2="yes"
    38 38 
     ENABLE3="yes"
    39 39 
     ENABLE4="yes"
    40 40
    41 
    -version=21e
    41 
    +version=21f
    42 42 
     SRCDIR=src
    43 43 
     BINDIR=bin
    44 44 
     TOOLDIR=$BINDIR

  • src/bootfiles/21f/boot-21f.lisp
    1 
    +;; For #318.  Define new standard-char type.
    2 
    +(in-package "KERNEL")
    3 
    +(ext:without-package-locks
    4 
    +(define-type-class standard-char)
    5 
    +(defstruct (standard-char-type
    6 
    +	    (:include ctype
    7 
    +	     (class-info (type-class-or-lose 'standard-char))
    8 
    +	     (:enumerable t))
    9 
    +	    (:constructor %make-standard-char-type ())
    10 
    +	    (:copier nil)))
    11 
    +
    12 
    +(defun make-standard-char-type ()
    13 
    +  (%make-standard-char-type))
    14 
    +)

  • src/code/exports.lisp
    ... ... @@ -2190,7 +2190,11 @@
    2190 2190 
     	   "STANDARD-PPRINT-DISPATCH-TABLE-MODIFIED-ERROR"
    2191 2191
    2192 2192 
     	   "%IEEE754-REM-PI/2"
    2193 
    -	   "%SINCOS")
    2193 
    +	   "%SINCOS"
    2194 
    +
    2195 
    +	   "STANDARD-CHAR-TYPE"
    2196 
    +	   "MAKE-STANDARD-CHAR-TYPE"
    2197 
    +	   "STANDARD-CHAR-TYPE-P")
    2194 2198 
       #+heap-overflow-check
    2195 2199 
       (:export "DYNAMIC-SPACE-OVERFLOW-WARNING-HIT"
    2196 2200 
     	   "DYNAMIC-SPACE-OVERFLOW-ERROR-HIT"

  • src/code/pred.lisp
    ... ... @@ -291,7 +291,7 @@
    291 291 
          (and (consp object)
    292 292 
     	  (%%typep (car object) (cons-type-car-type type))
    293 293 
     	  (%%typep (cdr object) (cons-type-cdr-type type))))
    294 
    -    (standard-char-type
    294 
    +    (kernel::standard-char-type
    295 295 
          (and (characterp object)
    296 296 
     	  (standard-char-p object)))
    297 297 
         (unknown-type

  • src/code/type.lisp
    ... ... @@ -52,7 +52,7 @@
    52 52 
     (define-type-class intersection)
    53 53 
     (define-type-class alien)
    54 54 
     (define-type-class cons)
    55 
    -(define-type-class standard-char named)
    55 
    +(define-type-class standard-char)
    56 56
    57 57 
     ;;; The Args-Type structure is used both to represent Values types and
    58 58 
     ;;; and Function types.
    ... ... @@ -365,9 +365,12 @@
    365 365 
           (%make-cons-type car-type cdr-type)))
    366 366
    367 367 
     (defstruct (standard-char-type
    368 
    -	    (:include ctype (class-info (type-class-or-lose 'standard-char)))
    368 
    +	    (:include ctype
    369 
    +	     (class-info (type-class-or-lose 'standard-char))
    370 
    +	     (:enumerable t))
    369 371 
     	    (:constructor %make-standard-char-type ())
    370 
    -	    (:copier nil)))
    372 
    +	    (:copier nil)
    373 
    +	    (:print-function %print-type)))
    371 374
    372 375 
     (defun make-standard-char-type ()
    373 376 
       (%make-standard-char-type))
    ... ... @@ -3354,12 +3357,13 @@
    3354 3357 
       (cond ((member-type-p type1)
    3355 3358 
     	 ;; If TYPE1 is a member-type, check whether it contains all
    3356 3359 
     	 ;; standard-chars.
    3357 
    -	 (values (subsetp (member-type-members type2) +standard-chars+)
    3360 
    +	 (values (subsetp (member-type-members type1) +standard-chars+)
    3358 3361 
     		 t))
    3359 3362 
     	(t
    3360 3363 
     	 (values nil t))))
    3361 3364
    3362 
    - (define-type-method (standard-char :complex-union) (type1 type2)
    3365 
    +#+nil
    3366 
    +(define-type-method (standard-char :complex-union) (type1 type2)
    3363 3367 
        (cond ((csubtypep (specifier-type 'character) type2)
    3364 3368 
     	  ;; STANDARD-CHAR union any super-type of CHARACTER is that
    3365 3369 
     	  ;; super-type. Hence, it's TYPE2.
    ... ... @@ -3378,43 +3382,48 @@
    3378 3382 
     	  ;; No simplification
    3379 3383 
     	  nil)))
    3380 3384
    3385 
    +(define-type-method (standard-char :complex-union) (type1 type2)
    3386 
    +  (let* ((sc (if (standard-char-type-p type1) type1 type2))
    3387 
    +         (other (if (eq sc type1) type2 type1)))
    3388 
    +    (cond
    3389 
    +      ((csubtypep (specifier-type 'character) other) other)
    3390 
    +      ((and (member-type-p other)
    3391 
    +            (subsetp (member-type-members other) kernel::+standard-chars+))
    3392 
    +       sc)
    3393 
    +      (t nil))))
    3394 
    +
    3381 3395 
     (define-type-method (standard-char :complex-intersection) (type1 type2)
    3382 
    -  (cond ((csubtype (specifier-type 'character) type2)
    3383 
    -	 ;; STANDARD-CHAR intersect super-type of CHARACTER is a
    3384 
    -	 ;; STANDARD-CHAR.
    3385 
    -	 type1)
    3386 
    -	((member-type-p type2)
    3387 
    -	 ;; STANDARD-CHAR intersect member-type.  The result is a
    3388 
    -	 ;; member type with everything removed except the standard
    3389 
    -	 ;; chars.
    3390 
    -	 (let ((common-chars (intersection (member-type-members type2)
    3391 
    -					   +standard-chars+)))
    3392 
    -	   (if common-chars
    3393 
    -	       (make-member-type :members common-chars)
    3394 
    -	       *empty-type*)))
    3395 
    -	((negation-type-p type2)
    3396 
    -	 ;; Handle (and standard-char (not stuff))
    3397 
    -	 (let ((not-neg (negation-type-type type2)))
    3398 
    -	   (cond ((csubtypep type1 not-neg)
    3399 
    -		  ;; If standard-char is a subtype of stuff, the
    3400 
    -		  ;; intersection is empty.
    3401 
    -		  *empty-type*)
    3402 
    -		 ((eq (type-intersection type1 not-neg)
    3403 
    -		      *empty-type*)
    3404 
    -		  ;; If the intersection of standard-char and stuff is
    3405 
    -		  ;; empty, the intersection is standard-char.
    3406 
    -		  type1)
    3407 
    -		 (t nil))))
    3408 
    -	((eq (type-intersection (specifier-type 'standard-char)
    3409 
    -				type2)
    3410 
    -	     *empty-type*)
    3411 
    -	 ;; STANDARD-CHAR intersect with disjoing TYPE2 results in the
    3412 
    -	 ;; empty type.
    3413 
    -	 *empty-type*)
    3414 
    -	(t
    3415 
    -	 ;; Default is can't simplify
    3416 
    -	 nil)))
    3417 
    -
    3396 
    +  ;; The standard-char type could be in type1 or type2.  Figure out
    3397 
    +  ;; which one is a standard-char.
    3398 
    +  (multiple-value-bind (sc other)
    3399 
    +      (if (standard-char-type-p type1)
    3400 
    +	  (values type1 type2)
    3401 
    +	  (values type2 type1))
    3402 
    +    (cond
    3403 
    +      ((csubtypep (specifier-type 'character) other)
    3404 
    +       ;; STANDARD-CHAR intersect any super-type of CHARACTER is a
    3405 
    +       ;; STANDARD-CHAR.
    3406 
    +       sc)
    3407 
    +      (t
    3408 
    +       (block punt
    3409 
    +	 ;; Look through OTHER and find OTHER contains any standard
    3410 
    +	 ;; character.  If so, collect them all.  If there are, the
    3411 
    +	 ;; intersection is a member-type of the collected characters.
    3412 
    +         (collect ((members))
    3413 
    +           (dolist (ch +standard-chars+)
    3414 
    +             (multiple-value-bind (val win)
    3415 
    +		 (ctypep ch other)
    3416 
    +               (unless win
    3417 
    +		 (return-from punt nil))
    3418 
    +               (when val
    3419 
    +		 (members ch))))
    3420 
    +           (cond ((null (members))
    3421 
    +		  c::*empty-type*)
    3422 
    +                 ((= (length (members))
    3423 
    +		     (length kernel::+standard-chars+))
    3424 
    +		  sc)
    3425 
    +                 (t
    3426 
    +		  (make-member-type :members (members))))))))))
    3418 3427
    3419 3428
    3420 3429 
     ;;; TYPE-DIFFERENCE  --  Interface

  • src/i18n/locale/cmucl.pot
    No preview for this file type
  • src/tools/worldcom.lisp
    ... ... @@ -137,7 +137,13 @@
    137 137 
       (:optimize '(optimize (safety 2) (debug 2)))
    138 138 
       (comf "target:code/class"))
    139 139
    140 
    +;; When cross-compiling, it's good to have all the type classes
    141 
    +;; defined for code/pred.lisp to use.
    142 
    +#-bootstrap
    140 143 
     (comf "target:code/type")
    144 
    +#+bootstrap
    145 
    +(comf "target:code/type" :load t)
    146 
    +
    141 147 
     (comf "target:compiler/generic/vm-type")
    142 148 
     (comf "target:code/type-init")
    143 149 
     (comf "target:code/pred")

  • tests/standard-char.lisp
    1 
    +;;; Tests for standard-char
    2 
    +
    3 
    +(defpackage :standard-char-tests
    4 
    +  (:use :cl :lisp-unit))
    5 
    +
    6 
    +(in-package "STANDARD-CHAR-TESTS")
    7 
    +
    8 
    +(define-test standard-char.typep
    9 
    +  (assert-true (typep #\a 'standard-char))
    10 
    +  (assert-false (typep #\tab 'standard-char))
    11 
    +  (assert-true (typep #\a 'standard-char))
    12 
    +  (assert-true (typep #\Z 'standard-char))
    13 
    +  (assert-true (typep #\Space 'standard-char))
    14 
    +  (assert-true (typep #\Newline 'standard-char))
    15 
    +  (assert-false (typep #\Tab 'standard-char))
    16 
    +  (assert-false (typep #\Rubout 'standard-char))
    17 
    +  (assert-false (typep 5 'standard-char))
    18 
    +  (assert-false (typep "hello" 'standard-char))
    19 
    +  (assert-false (typep nil 'standard-char))
    20 
    +  (assert-false (typep t 'standard-char))
    21 
    +
    22 
    +  (assert-equal (values t t)
    23 
    +		(subtypep 'standard-char 'character))
    24 
    +  (assert-equal (values t t)
    25 
    +		(subtypep 'standard-char 'base-char)))
    26 
    +
    27 
    +(define-test standard-char.etypecase-15
    28 
    +  (assert-equal (values t t)
    29 
    +		(c::type=
    30 
    +		 (c::specifier-type
    31 
    +		  '(not (or pathname boolean standard-char standard-object character file-error)))
    32 
    +		 (c::specifier-type
    33 
    +		  '(not (or file-error character standard-object standard-char boolean pathname))))))
    34 
    +
    35 
    +
    36 
    +(define-test standard-char.identity
    37 
    +  (let ((a (c::specifier-type 'standard-char))
    38 
    +	(b (c::specifier-type 'standard-char)))
    39 
    +    ;; Should be EQ due to internal caching.
    40 
    +    (assert-eq a b)))
    41 
    +
    42 
    +(define-test standard-char.parsing
    43 
    +  (assert-eq 'standard-char
    44 
    +	     (c::type-specifier (c::specifier-type 'standard-char))))
    45 
    +
    46 
    +(define-test standard-char.predicate
    47 
    +  (assert-true (c::standard-char-type-p (c::specifier-type 'standard-char))))
    48 
    +
    49 
    +(define-test standard-char.simple-subtypep
    50 
    +  (assert-equal (values t t)
    51 
    +		(c::type= (c::specifier-type 'standard-char)
    52 
    +			  (c::specifier-type 'standard-char)))
    53 
    +  (assert-equal (values t t)
    54 
    +		(subtypep 'standard-char 'standard-char)))
    55 
    +
    56 
    +(define-test standard-char.complex-subtype-arg1
    57 
    +  ;; STANDARD-CHAR is a subtype of CHARACTER and T.
    58 
    +  (assert-equal (values t t)
    59 
    +		(subtypep 'standard-char 'character))
    60 
    +  (assert-equal (values t t)
    61 
    +		(subtypep 'standard-char t))
    62 
    +
    63 
    +  ;; Not a subtype of disjoint types.
    64 
    +  (assert-equal (values nil t)
    65 
    +		(subtypep 'standard-char 'integer))
    66 
    +  (assert-equal (values nil t)
    67 
    +		(subtypep 'standard-char 'symbol))
    68 
    +  (assert-equal (values nil t)
    69 
    +		(subtypep 'standard-char 'pathname))
    70 
    +
    71 
    +  ;; Subtype of a member-type that contains all standard chars.
    72 
    +  (assert-equal (values t t)
    73 
    +		(subtypep 'standard-char
    74 
    +			  `(member ,@kernel::+standard-chars+)))
    75 
    +  ;; Not a subtype of a member-type missing even one standard char.
    76 
    +  (assert-equal (values nil t)
    77 
    +		(subtypep 'standard-char '(member #\a))))
    78 
    +
    79 
    +(define-test standard-char.complex-subtypep-arg
    80 
    +  ;; All standard chars: subtype.
    81 
    +  (assert-equal (values t t)
    82 
    +		(subtypep '(member #\a) 'standard-char))
    83 
    +  (assert-equal (values t t)
    84 
    +		(subtypep '(member #\Space #\Newline) 'standard-char))
    85 
    +
    86 
    +  ;; Mixed — character but not standard.
    87 
    +  (assert-equal (values nil t)
    88 
    +		(subtypep '(member #\Tab) 'standard-char))
    89 
    +  (assert-equal (values nil t)
    90 
    +		(subtypep '(member #\Rubout) 'standard-char))
    91 
    +
    92 
    +  ;; Mixed — non-character members. This was the crash case.
    93 
    +  (assert-equal (values nil t)
    94 
    +		(subtypep '(member t) 'standard-char))
    95 
    +  (assert-equal (values nil t)
    96 
    +		(subtypep '(member t nil) 'standard-char))
    97 
    +
    98 
    +  ;; Mixed — some standard, some not.
    99 
    +  (assert-equal (values nil t)
    100 
    +		(subtypep '(member #\a #\Tab) 'standard-char))
    101 
    +  (assert-equal (values nil t)
    102 
    +		(subtypep '(member #\a t) 'standard-char))
    103 
    +
    104 
    +  ;; CHARACTER is not a subtype of STANDARD-CHAR (non-standard chars exist).
    105 
    +  (assert-equal (values nil t)
    106 
    +		(subtypep 'character 'standard-char)))
    107 
    +
    108 
    +(define-test standard-char.complex-union
    109 
    +  ;; Absorbed by supertype.
    110 
    +  (assert-equal (values t t)
    111 
    +		(c::type= (c::type-union (c::specifier-type 'standard-char)
    112 
    +					 (c::specifier-type 'character))
    113 
    +			  (c::specifier-type 'character)))
    114 
    +
    115 
    +  (assert-equal (values t t)
    116 
    +		(c::type= (c::type-union (c::specifier-type 'standard-char)
    117 
    +					 (c::specifier-type 't))
    118 
    +			  (c::specifier-type 't)))
    119 
    +
    120 
    +  ;; All-standard-chars member-type absorbed back into STANDARD-CHAR.
    121 
    +  (assert-equal (values t t)
    122 
    +		(c::type= (c::type-union (c::specifier-type 'standard-char)
    123 
    +					 (c::specifier-type '(member #\a #\b)))
    124 
    +			  (c::specifier-type 'standard-char)))
    125 
    +
    126 
    +  ;; Disjoint type stays as a union (the bug-fix case).
    127 
    +  ;; The result should NOT be a single member-type containing
    128 
    +  ;; T, NIL, and 96 standard chars.
    129 
    +  (let ((result (c::specifier-type '(or boolean standard-char))))
    130 
    +    (assert-true (c::union-type-p result))
    131 
    +    (assert-equal 2 (length (c::union-type-types result)))
    132 
    +    (assert-true (notany (lambda (m)
    133 
    +			   (and (c::member-type-p m)
    134 
    +				(some #'characterp (c::member-type-members m))
    135 
    +				(some (complement #'characterp)
    136 
    +				      (c::member-type-members m))))
    137 
    +			 (c::union-type-types result))))
    138 
    +
    139 
    +
    140 
    +  ;; Permutation invariance — the original etypecase.15 trigger.
    141 
    +  (assert-equal (values t t)
    142 
    +		(c::type= (c::specifier-type '(or boolean standard-char))
    143 
    +			  (c::specifier-type '(or standard-char boolean))))
    144 
    +
    145 
    +  (assert-equal (values t t)
    146 
    +		(c::type= (c::specifier-type
    147 
    +			   '(not (or pathname boolean standard-char standard-object character file-error)))
    148 
    +			  (c::specifier-type
    149 
    +			   '(not (or file-error character standard-object standard-char boolean pathname)))))
    150 
    +
    151 
    +  ;; Member-type with non-standard chars — kept symbolically separate.
    152 
    +  (let ((result (c::type-union (c::specifier-type 'standard-char)
    153 
    +                               (c::specifier-type '(member #\Tab)))))
    154 
    +    ;; Should not collapse into a 97-element MEMBER.
    155 
    +    (assert-false (c::member-type-p result))
    156 
    +    (assert-true (c::union-type-p result))
    157 
    +    #+nil
    158 
    +    (not (and (c::member-type-p result)
    159 
    +              (>= (length (c::member-type-members result)) 90)))))
    160 
    +
    161 
    +(define-test standard-char.complex-intersection
    162 
    +  ;; Intersection with supertype is STANDARD-CHAR.
    163 
    +  (assert-equal (values t t)
    164 
    +		(c::type= (c::type-intersection (c::specifier-type 'standard-char)
    165 
    +						(c::specifier-type 'character))
    166 
    +			  (c::specifier-type 'standard-char)))
    167 
    +
    168 
    +  (assert-equal (values t t)
    169 
    +		(c::type= (c::type-intersection (c::specifier-type 'standard-char)
    170 
    +						(c::specifier-type 't))
    171 
    +			  (c::specifier-type 'standard-char)))
    172 
    +
    173 
    +  ;; Intersection with disjoint type is empty.
    174 
    +  (assert-equal (values t t)
    175 
    +		(c::type= (c::type-intersection (c::specifier-type 'standard-char)
    176 
    +						(c::specifier-type 'integer))
    177 
    +			  c::*empty-type*))
    178 
    +
    179 
    +  (assert-equal (values t t)
    180 
    +		(c::type= (c::type-intersection (c::specifier-type 'standard-char)
    181 
    +						(c::specifier-type 'symbol))
    182 
    +			  c::*empty-type*))
    183 
    +
    184 
    +  ;; Intersection with member-type — filtered to standard chars.
    185 
    +  (assert-equal (values t t)
    186 
    +		(c::type= (c::type-intersection (c::specifier-type 'standard-char)
    187 
    +						(c::specifier-type '(member #\a #\Tab #\b)))
    188 
    +			  (c::specifier-type '(member #\a #\b))))
    189 
    +
    190 
    +  ;; All-non-standard members → empty.
    191 
    +  (assert-equal (values t t)
    192 
    +		(c::type= (c::type-intersection (c::specifier-type 'standard-char)
    193 
    +						(c::specifier-type '(member #\Tab #\Rubout)))
    194 
    +			  c::*empty-type*))
    195 
    +
    196 
    +  ;; All-standard members → that member-type unchanged.
    197 
    +  (assert-equal (values t t)
    198 
    +		(c::type= (c::type-intersection (c::specifier-type 'standard-char)
    199 
    +						(c::specifier-type '(member #\a)))
    200 
    +			  (c::specifier-type '(member #\a)))))
    201 
    +
    202 
    +
    203 
    +
    204 
    +(define-test standard-char.negation
    205 
    +  ;; NOT STANDARD-CHAR catches non-standard characters.
    206 
    +  (assert-true (typep #\Tab '(not standard-char)))
    207 
    +  (assert-false (typep #\a '(not standard-char)))
    208 
    +
    209 
    +  ;; AND CHARACTER (NOT STANDARD-CHAR) is the non-standard chars.
    210 
    +  (assert-true (typep #\Tab '(and character (not standard-char))))
    211 
    +  (assert-false (typep #\a '(and character (not standard-char))))
    212 
    +  (assert-false (typep 5 '(and character (not standard-char))))
    213 
    +
    214 
    +  ;; Permutation invariance with negation, multiple types.
    215 
    +  (assert-equal (values t t)
    216 
    +		(c::type= (c::specifier-type '(and standard-char (not (member #\a))))
    217 
    +			  (c::specifier-type '(and (not (member #\a)) standard-char)))))
    218 
    +
    219 
    +#+nil
    220 
    +(define-test standard-char.etypecase
    221 
    +  ;; This is the original failing test family — should now pass reliably.
    222 
    +  (loop repeat 100
    223 
    +	always (eql nil
    224 
    +                    (handler-case
    225 
    +			(etypecase #\a
    226 
    +                          (standard-char :ok)
    227 
    +                          (number :wrong))
    228 
    +		      (error () :error))
    229 
    +                    :ok)))
    230 
    +
    231 
    +(define-test standard-char.caching
    232 
    +  ;; Multiple specifier-type calls on `standard-char` return EQ.
    233 
    +  (assert-eq (c::specifier-type 'standard-char)
    234 
    +	     (c::specifier-type 'standard-char))
    235 
    +
    236 
    +  ;; And via the deftype expansion.
    237 
    +  (assert-eq (c::specifier-type 'standard-char)
    238 
    +	     (c::specifier-type 'standard-char)))
    239 
    +					;

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.common-lisp.net. Manage all notifications · Help Notification message regarding https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/5a78c1a9f7683c1c19c52b5462aa21ccb94c6439...4e124dd235985a855b711b953c1812b3fad9e698 at 1777906245