Raymond Toy pushed to branch master at cmucl / cmucl

Commits:

5 changed files:

Changes:

  • 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,6 +291,9 @@
    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 
    +    (kernel::standard-char-type
    295 
    +     (and (characterp object)
    296 
    +	  (standard-char-p object)))
    294 297 
         (unknown-type
    295 298 
          ;; Parse it again to make sure it's really undefined.
    296 299 
          (let ((reparse (specifier-type (unknown-type-specifier type))))

  • src/code/type.lisp
    ... ... @@ -52,6 +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)
    55 56
    56 57 
     ;;; The Args-Type structure is used both to represent Values types and
    57 58 
     ;;; and Function types.
    ... ... @@ -363,6 +364,16 @@
    363 364 
           *empty-type*
    364 365 
           (%make-cons-type car-type cdr-type)))
    365 366
    367 
    +(defstruct (standard-char-type
    368 
    +	    (:include ctype
    369 
    +	     (class-info (type-class-or-lose 'standard-char))
    370 
    +	     (:enumerable t))
    371 
    +	    (:constructor %make-standard-char-type ())
    372 
    +	    (:copier nil)
    373 
    +	    (:print-function %print-type)))
    374 
    +
    375 
    +(defun make-standard-char-type ()
    376 
    +  (%make-standard-char-type))
    366 377
    367 378
    368 379 
     ;;;
    ... ... @@ -3293,6 +3304,121 @@
    3293 3304 
     					      (cons-type-car-type type2))
    3294 3305 
     			   cdr-int2)))))
    3295 3306
    3307 
    +
    3308 
    +;;;; Standard-char type
    3309 
    +(def-type-translator standard-char ()
    3310 
    +  (make-standard-char-type))
    3311 
    +
    3312 
    +(define-type-method (standard-char :unparse) (type)
    3313 
    +  (declare (ignore type))
    3314 
    +  'standard-char)
    3315 
    +
    3316 
    +(define-type-method (standard-char :simple-=) (type1 type2)
    3317 
    +  (declare (ignore type1 type2))
    3318 
    +  (values t t))
    3319 
    +
    3320 
    +(define-type-method (standard-char :simple-subtypep) (type1 type2)
    3321 
    +  (declare (ignore type1 type2))
    3322 
    +  (values t t))
    3323 
    +
    3324 
    +(defconstant +standard-chars+
    3325 
    +  '(#\NEWLINE #\SPACE #\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\,
    3326 
    +    #\- #\. #\/ #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\: #\; #\< #\=
    3327 
    +    #\> #\?  #\@ #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M
    3328 
    +    #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z #\[ #\\ #\]
    3329 
    +    #\^ #\_ #\` #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m
    3330 
    +    #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\{
    3331 
    +    #\| #\} #\~)
    3332 
    +  "The set of characters in the STANDARD-CHAR type")
    3333 
    +
    3334 
    +(define-type-method (standard-char :simple-union) (type1 type2)
    3335 
    +  (declare (ignore type2))
    3336 
    +  type1)
    3337 
    +
    3338 
    +(define-type-method (standard-char :simple-intersection) (type1 type2)
    3339 
    +  (declare (ignore type2))
    3340 
    +  type1)
    3341 
    +
    3342 
    +;; (subtype standard-char other)
    3343 
    +(define-type-method (standard-char :complex-subtypep-arg1) (type1 type2)
    3344 
    +  (declare (ignore type1))
    3345 
    +  (cond ((csubtypep (specifier-type 'character) type2)
    3346 
    +	 ;; STANDARD-CHAR is a subtype of CHARACTER/BASE-CHAR
    3347 
    +	 (values t t))
    3348 
    +	((member-type-p type2)
    3349 
    +	 ;; If TYPE2 is a member-type, check whether it contains all standard-chars
    3350 
    +	 (values (let ((members (member-type-members type2)))
    3351 
    +		   (every #'(lambda (c)
    3352 
    +			    (member c members))
    3353 
    +			+standard-chars+))
    3354 
    +		 t))
    3355 
    +	(t
    3356 
    +	 (values nil t))))
    3357 
    +
    3358 
    +;; (subtypep other standard-char)
    3359 
    +(define-type-method (standard-char :complex-subtypep-arg2) (type1 type2)
    3360 
    +  (declare (ignore type2))
    3361 
    +  (cond ((member-type-p type1)
    3362 
    +	 ;; If TYPE1 is a member-type, check whether it contains all
    3363 
    +	 ;; standard-chars.
    3364 
    +	 (values (every #'(lambda (c)
    3365 
    +			    (member c +standard-chars+))
    3366 
    +			(member-type-members type1))
    3367 
    +		 t))
    3368 
    +	(t
    3369 
    +	 (values nil t))))
    3370 
    +
    3371 
    +(define-type-method (standard-char :complex-union) (type1 type2)
    3372 
    +  ;; The standard-char type could be in type1 or type2.  Figure out
    3373 
    +  ;; which one is a standard-char.
    3374 
    +  (multiple-value-bind (sc other)
    3375 
    +      (if (standard-char-type-p type1)
    3376 
    +	  (values type1 type2)
    3377 
    +	  (values type2 type1))
    3378 
    +    (cond
    3379 
    +      ((csubtypep (specifier-type 'character) other)
    3380 
    +       other)
    3381 
    +      ((and (member-type-p other)
    3382 
    +	    ;; Check to see every member of OTHER is a STANDARD-CHAR.
    3383 
    +	    (every #'(lambda (c)
    3384 
    +		       (member c +standard-chars+))
    3385 
    +		   (member-type-members other)))
    3386 
    +       sc)
    3387 
    +      (t nil))))
    3388 
    +
    3389 
    +(define-type-method (standard-char :complex-intersection) (type1 type2)
    3390 
    +  ;; The standard-char type could be in type1 or type2.  Figure out
    3391 
    +  ;; which one is a standard-char.
    3392 
    +  (multiple-value-bind (sc other)
    3393 
    +      (if (standard-char-type-p type1)
    3394 
    +	  (values type1 type2)
    3395 
    +	  (values type2 type1))
    3396 
    +    (cond
    3397 
    +      ((csubtypep (specifier-type 'character) other)
    3398 
    +       ;; STANDARD-CHAR intersect any super-type of CHARACTER is a
    3399 
    +       ;; STANDARD-CHAR.
    3400 
    +       sc)
    3401 
    +      (t
    3402 
    +       (block punt
    3403 
    +	 ;; Look through OTHER and find OTHER contains any standard
    3404 
    +	 ;; character.  If so, collect them all.  If there are, the
    3405 
    +	 ;; intersection is a member-type of the collected characters.
    3406 
    +         (collect ((members))
    3407 
    +           (dolist (ch +standard-chars+)
    3408 
    +             (multiple-value-bind (val win)
    3409 
    +		 (ctypep ch other)
    3410 
    +               (unless win
    3411 
    +		 (return-from punt nil))
    3412 
    +               (when val
    3413 
    +		 (members ch))))
    3414 
    +           (cond ((null (members))
    3415 
    +		  c::*empty-type*)
    3416 
    +                 ((= (length (members))
    3417 
    +		     (length +standard-chars+))
    3418 
    +		  sc)
    3419 
    +                 (t
    3420 
    +		  (make-member-type :members (members))))))))))
    3421 
    +
    3296 3422
    3297 3423 
     ;;; TYPE-DIFFERENCE  --  Interface
    3298 3424 
     ;;;
    ... ... @@ -3379,7 +3505,8 @@
    3379 3505 
       (declare (type ctype type))
    3380 3506 
       (etypecase type
    3381 3507 
         ((or numeric-type named-type member-type array-type
    3382 
    -	 kernel::built-in-class cons-type)
    3508 
    +	 kernel::built-in-class cons-type
    3509 
    +	 standard-char-type)
    3383 3510 
          (values (%typep obj type) t))
    3384 3511 
         (class
    3385 3512 
          (if (if (csubtypep type (specifier-type 'funcallable-instance))
    ... ... @@ -3520,16 +3647,6 @@
    3520 3647 
       "Type of characters that aren't base-char's.  None in CMU CL."
    3521 3648 
       '(and character (not base-char)))
    3522 3649
    3523 
    -(deftype standard-char ()
    3524 
    -  "Type corresponding to the charaters required by the standard."
    3525 
    -  '(member #\NEWLINE #\SPACE #\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\,
    3526 
    -	   #\- #\. #\/ #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\: #\; #\< #\=
    3527 
    -	   #\> #\?  #\@ #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M
    3528 
    -	   #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z #\[ #\\ #\]
    3529 
    -	   #\^ #\_ #\` #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m
    3530 
    -	   #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\{
    3531 
    -	   #\| #\} #\~))
    3532 
    -
    3533 3650 
     (deftype keyword ()
    3534 3651 
       "Type for any keyword symbol."
    3535 3652 
       '(and symbol (satisfies keywordp)))

  • src/i18n/locale/cmucl.pot
    No preview for this file type
  • 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 
    +;; For the following tests, we generally want to use
    9 
    +;; kernel::type-intersection and kernel::type-union directly to make
    10 
    +;; sure we test the intersection and union methods for standard-char.
    11 
    +
    12 
    +(define-test standard-char.typep
    13 
    +  (:tag :issues)
    14 
    +  (assert-true (typep #\a 'standard-char))
    15 
    +  (assert-false (typep #\tab 'standard-char))
    16 
    +  (assert-true (typep #\Z 'standard-char))
    17 
    +  (assert-true (typep #\Space 'standard-char))
    18 
    +  (assert-true (typep #\Newline 'standard-char))
    19 
    +  (assert-false (typep #\Rubout 'standard-char))
    20 
    +  (assert-false (typep 5 'standard-char))
    21 
    +  (assert-false (typep "hello" 'standard-char))
    22 
    +  (assert-false (typep nil 'standard-char))
    23 
    +  (assert-false (typep t 'standard-char))
    24 
    +
    25 
    +  (assert-equal (values t t)
    26 
    +		(subtypep 'standard-char 'character))
    27 
    +  (assert-equal (values nil t)
    28 
    +		(subtypep 'character 'standard-char))
    29 
    +  (assert-equal (values t t)
    30 
    +		(subtypep 'standard-char 'base-char))
    31 
    +  (assert-equal (values nil t)
    32 
    +		(subtypep 'base-char 'standard-char)))
    33 
    +
    34 
    +(define-test standard-char.etypecase-15
    35 
    +    (:tag :issues)
    36 
    +  (assert-equal (values t t)
    37 
    +		(c::type=
    38 
    +		 (c::specifier-type
    39 
    +		  '(not (or pathname boolean standard-char standard-object character file-error)))
    40 
    +		 (c::specifier-type
    41 
    +		  '(not (or file-error character standard-object standard-char boolean pathname))))))
    42 
    +
    43 
    +(define-test standard-char.identity
    44 
    +    (:tag :issues)
    45 
    +  (let ((a (c::specifier-type 'standard-char))
    46 
    +	(b (c::specifier-type 'standard-char)))
    47 
    +    ;; Should be EQ due to internal caching.
    48 
    +    (assert-eq a b)))
    49 
    +
    50 
    +(define-test standard-char.parsing
    51 
    +    (:tag :issues)
    52 
    +  (assert-eq 'standard-char
    53 
    +	     (c::type-specifier (c::specifier-type 'standard-char))))
    54 
    +
    55 
    +(define-test standard-char.predicate
    56 
    +    (:tag :issues)
    57 
    +  (assert-true (c::standard-char-type-p (c::specifier-type 'standard-char))))
    58 
    +
    59 
    +(define-test standard-char.simple-subtypep
    60 
    +    (:tag :issues)
    61 
    +  (assert-equal (values t t)
    62 
    +		(c::type= (c::specifier-type 'standard-char)
    63 
    +			  (c::specifier-type 'standard-char)))
    64 
    +  (assert-equal (values t t)
    65 
    +		(subtypep 'standard-char 'standard-char)))
    66 
    +
    67 
    +(define-test standard-char.complex-subtype-arg1
    68 
    +    (:tag :issues)
    69 
    +  ;; STANDARD-CHAR is a subtype of CHARACTER and T.
    70 
    +  (assert-equal (values t t)
    71 
    +		(subtypep 'standard-char 'character))
    72 
    +  (assert-equal (values t t)
    73 
    +		(subtypep 'standard-char t))
    74 
    +
    75 
    +  ;; Not a subtype of disjoint types.
    76 
    +  (assert-equal (values nil t)
    77 
    +		(subtypep 'standard-char 'integer))
    78 
    +  (assert-equal (values nil t)
    79 
    +		(subtypep 'standard-char 'symbol))
    80 
    +  (assert-equal (values nil t)
    81 
    +		(subtypep 'standard-char 'pathname))
    82 
    +
    83 
    +  ;; Subtype of a member-type that contains all standard chars.
    84 
    +  (assert-equal (values t t)
    85 
    +		(subtypep 'standard-char
    86 
    +			  `(member ,@kernel::+standard-chars+)))
    87 
    +  ;; Not a subtype of a member-type missing even one standard char.
    88 
    +  (assert-equal (values nil t)
    89 
    +		(subtypep 'standard-char '(member #\a))))
    90 
    +
    91 
    +(define-test standard-char.complex-subtypep-arg
    92 
    +    (:tag :issues)
    93 
    +  ;; All standard chars: subtype.
    94 
    +  (assert-equal (values t t)
    95 
    +		(subtypep '(member #\a) 'standard-char))
    96 
    +  (assert-equal (values t t)
    97 
    +		(subtypep '(member #\Space #\Newline) 'standard-char))
    98 
    +
    99 
    +  ;; Mixed — character but not standard.
    100 
    +  (assert-equal (values nil t)
    101 
    +		(subtypep '(member #\Tab) 'standard-char))
    102 
    +  (assert-equal (values nil t)
    103 
    +		(subtypep '(member #\Rubout) 'standard-char))
    104 
    +
    105 
    +  ;; Mixed — non-character members. This was the crash case.
    106 
    +  (assert-equal (values nil t)
    107 
    +		(subtypep '(member t) 'standard-char))
    108 
    +  (assert-equal (values nil t)
    109 
    +		(subtypep '(member t nil) 'standard-char))
    110 
    +
    111 
    +  ;; Mixed — some standard, some not.
    112 
    +  (assert-equal (values nil t)
    113 
    +		(subtypep '(member #\a #\Tab) 'standard-char))
    114 
    +  (assert-equal (values nil t)
    115 
    +		(subtypep '(member #\a t) 'standard-char))
    116 
    +
    117 
    +  ;; CHARACTER is not a subtype of STANDARD-CHAR (non-standard chars exist).
    118 
    +  (assert-equal (values nil t)
    119 
    +		(subtypep 'character 'standard-char)))
    120 
    +
    121 
    +(define-test standard-char.complex-union
    122 
    +    (:tag :issues)
    123 
    +  ;; Absorbed by supertype.
    124 
    +  (assert-equal (values t t)
    125 
    +		(c::type= (c::type-union (c::specifier-type 'standard-char)
    126 
    +					 (c::specifier-type 'character))
    127 
    +			  (c::specifier-type 'character)))
    128 
    +
    129 
    +  (assert-equal (values t t)
    130 
    +		(c::type= (c::type-union (c::specifier-type 'standard-char)
    131 
    +					 (c::specifier-type 't))
    132 
    +			  (c::specifier-type 't)))
    133 
    +
    134 
    +  ;; All-standard-chars member-type absorbed back into STANDARD-CHAR.
    135 
    +  (assert-equal (values t t)
    136 
    +		(c::type= (c::type-union (c::specifier-type 'standard-char)
    137 
    +					 (c::specifier-type '(member #\a #\b)))
    138 
    +			  (c::specifier-type 'standard-char)))
    139 
    +
    140 
    +  ;; Disjoint type stays as a union (the bug-fix case).
    141 
    +  ;; The result should NOT be a single member-type containing
    142 
    +  ;; T, NIL, and 96 standard chars.
    143 
    +  (let ((result (c::specifier-type '(or boolean standard-char))))
    144 
    +    (assert-true (c::union-type-p result))
    145 
    +    (assert-equal 2 (length (c::union-type-types result)))
    146 
    +    (assert-true (notany (lambda (m)
    147 
    +			   (and (c::member-type-p m)
    148 
    +				(some #'characterp (c::member-type-members m))
    149 
    +				(some (complement #'characterp)
    150 
    +				      (c::member-type-members m))))
    151 
    +			 (c::union-type-types result))))
    152 
    +
    153 
    +
    154 
    +  ;; Permutation invariance — the original etypecase.15 trigger.
    155 
    +  (assert-equal (values t t)
    156 
    +		(c::type= (c::specifier-type '(or boolean standard-char))
    157 
    +			  (c::specifier-type '(or standard-char boolean))))
    158 
    +
    159 
    +  (assert-equal (values t t)
    160 
    +		(c::type= (c::specifier-type
    161 
    +			   '(not (or pathname boolean standard-char standard-object character file-error)))
    162 
    +			  (c::specifier-type
    163 
    +			   '(not (or file-error character standard-object standard-char boolean pathname)))))
    164 
    +
    165 
    +  ;; Member-type with non-standard chars — kept symbolically separate.
    166 
    +  (let ((result (c::type-union (c::specifier-type 'standard-char)
    167 
    +                               (c::specifier-type '(member #\Tab)))))
    168 
    +    ;; Should not collapse into a 97-element MEMBER.
    169 
    +    (assert-false (c::member-type-p result))
    170 
    +    (assert-true (c::union-type-p result))))
    171 
    +
    172 
    +(define-test standard-char.complex-intersection
    173 
    +    (:tag :issues)
    174 
    +  ;; Intersection with supertype is STANDARD-CHAR.
    175 
    +  (assert-equal (values t t)
    176 
    +		(c::type= (c::type-intersection (c::specifier-type 'standard-char)
    177 
    +						(c::specifier-type 'character))
    178 
    +			  (c::specifier-type 'standard-char)))
    179 
    +
    180 
    +  (assert-equal (values t t)
    181 
    +		(c::type= (c::type-intersection (c::specifier-type 'standard-char)
    182 
    +						(c::specifier-type 't))
    183 
    +			  (c::specifier-type 'standard-char)))
    184 
    +
    185 
    +  ;; Intersection with disjoint type is empty.
    186 
    +  (assert-equal (values t t)
    187 
    +		(c::type= (c::type-intersection (c::specifier-type 'standard-char)
    188 
    +						(c::specifier-type 'integer))
    189 
    +			  c::*empty-type*))
    190 
    +
    191 
    +  (assert-equal (values t t)
    192 
    +		(c::type= (c::type-intersection (c::specifier-type 'standard-char)
    193 
    +						(c::specifier-type 'symbol))
    194 
    +			  c::*empty-type*))
    195 
    +
    196 
    +  ;; Intersection with member-type — filtered to standard chars.
    197 
    +  (assert-equal (values t t)
    198 
    +		(c::type= (c::type-intersection (c::specifier-type 'standard-char)
    199 
    +						(c::specifier-type '(member #\a #\Tab #\b)))
    200 
    +			  (c::specifier-type '(member #\a #\b))))
    201 
    +
    202 
    +  ;; All-non-standard members → empty.
    203 
    +  (assert-equal (values t t)
    204 
    +		(c::type= (c::type-intersection (c::specifier-type 'standard-char)
    205 
    +						(c::specifier-type '(member #\Tab #\Rubout)))
    206 
    +			  c::*empty-type*))
    207 
    +
    208 
    +  ;; All-standard members → that member-type unchanged.
    209 
    +  (assert-equal (values t t)
    210 
    +		(c::type= (c::type-intersection (c::specifier-type 'standard-char)
    211 
    +						(c::specifier-type '(member #\a)))
    212 
    +			  (c::specifier-type '(member #\a)))))
    213 
    +
    214 
    +
    215 
    +
    216 
    +(define-test standard-char.negation
    217 
    +    (:tag :issues)
    218 
    +  ;; NOT STANDARD-CHAR catches non-standard characters.
    219 
    +  (assert-true (typep #\Tab '(not standard-char)))
    220 
    +  (assert-false (typep #\a '(not standard-char)))
    221 
    +
    222 
    +  ;; AND CHARACTER (NOT STANDARD-CHAR) is the non-standard chars.
    223 
    +  (assert-true (typep #\Tab '(and character (not standard-char))))
    224 
    +  (assert-false (typep #\a '(and character (not standard-char))))
    225 
    +  (assert-false (typep 5 '(and character (not standard-char))))
    226 
    +
    227 
    +  ;; Permutation invariance with negation, multiple types.
    228 
    +  (assert-equal (values t t)
    229 
    +		(c::type= (c::specifier-type '(and standard-char (not (member #\a))))
    230 
    +			  (c::specifier-type '(and (not (member #\a)) standard-char)))))
    231 
    +
    232 
    +(define-test standard-char.etypecase
    233 
    +    (:tag :issues)
    234 
    +  ;; Test that etypecase works using ASCII characters which will cover
    235 
    +  ;; standard-char values and other characters.
    236 
    +  (dotimes (k 128)
    237 
    +    (let* ((ch (code-char k))
    238 
    +	   (expected (if (standard-char-p ch)
    239 
    +			 :is-standard :is-other))
    240 
    +	   (actual (handler-case
    241 
    +		       (etypecase ch
    242 
    +			 (standard-char :is-standard)
    243 
    +			 (character :is-other))
    244 
    +		     (error ()
    245 
    +		       :error))))
    246 
    +      (assert-eql expected actual ch))))
    247 
    +
    248 
    +(define-test standard-char.intersection-character-both-orderings
    249 
    +    (:tag :issues)
    250 
    +  ;; Standard-char intersect character = standard-char, regardless of argument order.
    251 
    +  (assert-equal (values t t)
    252 
    +		(kernel::type=
    253 
    +		 (kernel::specifier-type 'standard-char)
    254 
    +		 (kernel::type-intersection (kernel::specifier-type 'standard-char)
    255 
    +					    (kernel::specifier-type 'character))))
    256 
    +  (assert-equal (values t t)
    257 
    +		(kernel::type=
    258 
    +		 (kernel::specifier-type 'standard-char)
    259 
    +		 (kernel::type-intersection (kernel::specifier-type 'character)
    260 
    +					    (kernel::specifier-type 'standard-char)))))
    261 
    +
    262 
    +(define-test standard-char.intersection-disjoint-both-orderings
    263 
    +    (:tag :issues)
    264 
    +  (assert-equal (values t t)
    265 
    +		(kernel::type=
    266 
    +		 kernel::*empty-type*
    267 
    +		 (kernel::type-intersection (kernel::specifier-type 'standard-char)
    268 
    +					    (kernel::specifier-type 'integer))))
    269 
    +  (assert-equal (values t t)
    270 
    +		(kernel::type=
    271 
    +		 kernel::*empty-type*
    272 
    +		 (kernel::type-intersection (kernel::specifier-type 'integer)
    273 
    +					    (kernel::specifier-type 'standard-char)))))
    274 
    +
    275 
    +(define-test standard-char.intersection-member-both-orderings
    276 
    +    (:tag :issues)
    277 
    +  ;; Filter member-type to standard chars only.
    278 
    +  (assert-equal (values t t)
    279 
    +		(kernel::type=
    280 
    +		 (kernel::specifier-type '(member #\a #\b))
    281 
    +		 (kernel::type-intersection (kernel::specifier-type 'standard-char)
    282 
    +					    (kernel::specifier-type '(member #\a #\Tab #\b)))))
    283 
    +  (assert-equal (values t t)
    284 
    +		(kernel::type=
    285 
    +		 (kernel::specifier-type '(member #\a #\b))
    286 
    +		 (kernel::type-intersection (kernel::specifier-type '(member #\a #\Tab #\b))
    287 
    +					    (kernel::specifier-type 'standard-char)))))
    288 
    +
    289 
    +(define-test standard-char.union-character-both-orderings
    290 
    +    (:tag :issues)
    291 
    +  ;; Standard-char union character = character.
    292 
    +  (assert-equal (values t t)
    293 
    +		(kernel::type=
    294 
    +		 (kernel::specifier-type 'character)
    295 
    +		 (kernel::type-union (kernel::specifier-type 'standard-char)
    296 
    +				     (kernel::specifier-type 'character))))
    297 
    +  (assert-equal (values t t)
    298 
    +		(kernel::type=
    299 
    +		 (kernel::specifier-type 'character)
    300 
    +		 (kernel::type-union (kernel::specifier-type 'character)
    301 
    +				     (kernel::specifier-type 'standard-char)))))
    302 
    +
    303 
    +(define-test standard-char.union-member-of-standard-both-orderings
    304 
    +    (:tag :issues)
    305 
    +  ;; Standard-char absorbs all-standard member-type.
    306 
    +  (assert-equal (values t t)
    307 
    +		(kernel::type=
    308 
    +		 (kernel::specifier-type 'standard-char)
    309 
    +		 (kernel::type-union (kernel::specifier-type 'standard-char)
    310 
    +				     (kernel::specifier-type '(member #\a #\b)))))
    311 
    +  (assert-equal (values t t)
    312 
    +		(kernel::type=
    313 
    +		 (kernel::specifier-type 'standard-char)
    314 
    +		 (kernel::type-union (kernel::specifier-type '(member #\a #\b))
    315 
    +				     (kernel::specifier-type 'standard-char)))))
    316 
    +
    317 
    +(define-test standard-char.union-disjoint-stays-symbolic-both-orderings
    318 
    +    (:tag :issues)
    319 
    +  ;; (or boolean standard-char) and reverse — both should stay symbolic
    320 
    +  ;; rather than collapsing into a giant member-type.
    321 
    +  (let ((r1 (kernel::specifier-type '(or boolean standard-char)))
    322 
    +        (r2 (kernel::specifier-type '(or standard-char boolean))))
    323 
    +    (assert-true (kernel::union-type-p r1))
    324 
    +    (assert-true (kernel::union-type-p r2))
    325 
    +    (assert-equal (values t t)
    326 
    +		  (kernel::type= r1 r2))
    327 
    +    ;; Neither should contain a member-type with both characters
    328 
    +    ;; and non-characters.
    329 
    +    (dolist (m (kernel::union-type-types r1))
    330 
    +      (assert-false (and (kernel::member-type-p m)
    331 
    +                         (some #'characterp (kernel::member-type-members m))
    332 
    +                         (some (complement #'characterp)
    333 
    +                               (kernel::member-type-members m)))))))
    334 
    +
    335 
    +(defun assert-commutative-union (type-a-spec type-b-spec)
    336 
    +  "Assert that union(A, B) and union(B, A) produce type= results."
    337 
    +  (assert-equal (values t t)
    338 
    +		(kernel::type=
    339 
    +		 (kernel::type-union (kernel::specifier-type type-a-spec)
    340 
    +				     (kernel::specifier-type type-b-spec))
    341 
    +		 (kernel::type-union (kernel::specifier-type type-b-spec)
    342 
    +				     (kernel::specifier-type type-a-spec)))))
    343 
    +
    344 
    +(defun assert-commutative-intersection (type-a-spec type-b-spec)
    345 
    +  (assert-equal (values t t)
    346 
    +		(kernel::type=
    347 
    +		 (kernel::type-intersection (kernel::specifier-type type-a-spec)
    348 
    +					    (kernel::specifier-type type-b-spec))
    349 
    +		 (kernel::type-intersection (kernel::specifier-type type-b-spec)
    350 
    +					    (kernel::specifier-type type-a-spec)))))
    351 
    +
    352 
    +(define-test standard-char.commutativity
    353 
    +    (:tag :issues)
    354 
    +  (assert-commutative-union 'standard-char 'character)
    355 
    +  (assert-commutative-union 'standard-char 'integer)
    356 
    +  (assert-commutative-union 'standard-char '(member #\a #\b))
    357 
    +  (assert-commutative-union 'standard-char '(member #\Tab))
    358 
    +  (assert-commutative-union 'standard-char 'boolean)
    359 
    +  (assert-commutative-union 'standard-char '(not character))
    360 
    +  (assert-commutative-union 'standard-char 't)
    361 
    +  (assert-commutative-intersection 'standard-char 'character)
    362 
    +  (assert-commutative-intersection 'standard-char 'integer)
    363 
    +  (assert-commutative-intersection 'standard-char '(member #\a #\b))
    364 
    +  (assert-commutative-intersection 'standard-char '(member #\Tab))
    365 
    +  (assert-commutative-intersection 'standard-char 'boolean)
    366 
    +  (assert-commutative-intersection 'standard-char '(not character))
    367 
    +  (assert-commutative-intersection 'standard-char 't))

    • —
    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/47971b155ca22c2637a0d39b7059ad066adde552...06740b4098b7d3f22bb8ea30e01f1472730e9999 at 1782492977