[Sbcl-commits] CVS: sbcl/src/code early-type.lisp,1.28.2.2,1.28.2.3 late-type.lisp,1.68.2.2,1.68.2.3
From: Alexey D. <ade...@us...> - 2003-03-21 17:13:35
|
Update of /cvsroot/sbcl/sbcl/src/code In directory sc8-pr-cvs1:/tmp/cvs-serv32422/src/code Modified Files: Tag: apd-0-7-cast early-type.lisp late-type.lisp Log Message: 0.7.13.30-cast.5: * CAST's VALUE is annotated with its primitive types, but the number is that of CAST-CONT; * type canonicalization: (VALUES ... NIL ...) => NIL; * fixed stupid errors: type (VALUES) in a single-value context means NULL; restored doc/clean.sh. Index: early-type.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/early-type.lisp,v retrieving revision 1.28.2.2 retrieving revision 1.28.2.3 diff -u -d -r1.28.2.2 -r1.28.2.3 --- early-type.lisp 20 Mar 2003 10:18:01 -0000 1.28.2.2 +++ early-type.lisp 21 Mar 2003 17:13:32 -0000 1.28.2.3 @@ -75,12 +75,14 @@ (defun maybe-wild-type (type) (declare (type values-type type)) - (if (and (null (values-type-required type)) - (null (values-type-optional type)) - (eq (values-type-rest type) *universal-type*) - (not (values-type-keyp type))) - *wild-type* - type)) + (cond ((memq *empty-type* (values-type-required type)) + *empty-type*) + ((and (null (values-type-required type)) + (null (values-type-optional type)) + (eq (values-type-rest type) *universal-type*) + (not (values-type-keyp type))) + *wild-type*) + (t type))) (defun-cached (make-values-type-cached :hash-bits 8 @@ -98,12 +100,14 @@ (subseq optional 0 (1+ last-real)) nil))) -(defun make-values-type (&rest args &key optional rest keyp +(defun make-values-type (&rest args &key required optional rest keyp &allow-other-keys) (let ((args (if (and rest (not keyp)) `(:optional ,(values-adjust-optional optional rest) ,@args) args))) - (make-values-type-cached args))) + (if (memq *empty-type* required) + *empty-type* + (make-values-type-cached args)))) (!define-type-class values) Index: late-type.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/late-type.lisp,v retrieving revision 1.68.2.2 retrieving revision 1.68.2.3 diff -u -d -r1.68.2.2 -r1.68.2.3 --- late-type.lisp 20 Mar 2003 10:18:01 -0000 1.68.2.2 +++ late-type.lisp 21 Mar 2003 17:13:32 -0000 1.68.2.3 @@ -385,7 +385,7 @@ (or (car (args-type-required type)) (car (args-type-optional type)) (args-type-rest type) - *empty-type*)) + (specifier-type 'null))) ((eq type *wild-type*) *universal-type*) (t @@ -556,6 +556,8 @@ (type2 (coerce-to-values type2))) (cond ((eq type1 *wild-type*) (values type2 t)) ((eq type2 *wild-type*) (values type1 t)) + ((or (eq type1 *empty-type*) (eq type2 *empty-type*)) + *empty-type*) (t (args-type-op type1 type2 #'type-intersection @@ -589,10 +591,12 @@ (csubtypep type1 type2) (let ((type1 (coerce-to-values type1)) (type2 (coerce-to-values type2))) - (cond ((eq type2 *wild-type*) (values t t)) + (cond ((or (eq type2 *wild-type*) (eq type1 *empty-type*)) + (values t t)) ((eq type1 *wild-type*) (values (eq type2 *wild-type*) t)) - ((not (values-types-equal-or-intersect type1 type2)) + ((or (eq type2 *empty-type*) + (not (values-types-equal-or-intersect type1 type2))) (values nil t)) (t (multiple-value-bind (types1 rest1) (values-type-types type1) (multiple-value-bind (types2 rest2) (values-type-types type2) |