diff --git a/code/type.lisp b/code/type.lisp index 7e8580346d6349a4a613ff281c7acdcb9e306ef6..25db44972a9a8c77450de799ff2b17b6dcba2062 100644 --- a/code/type.lisp +++ b/code/type.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type.lisp,v 1.61 2003/04/27 14:52:27 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type.lisp,v 1.62 2003/05/08 14:52:04 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -766,6 +766,13 @@ (def-type-translator values (&rest values) (let ((res (make-values-type))) (parse-args-types values res) + ;; + ;; Signal an error if the spec has &KEY or &ALLOW-OTHER-KEYS. + ;; Actually, CLHS lists &ALLOW-OTHER-KEYS without listing &KEYS, + ;; but keys clearly don't make any sense. + (when (or (values-type-keyp res) (values-type-allowp res)) + (simple-program-error "&KEY or &ALLOW-OTHER-KEYS in values type: ~s" + res)) res)) @@ -879,13 +886,13 @@ ;;; Coerce-To-Values -- Internal ;;; ;;; If Type isn't a values type, then make it into one: -;;; <type> ==> (values type &rest t) +;;; <type> ==> (values type) ;;; (defun coerce-to-values (type) (declare (type ctype type)) (if (values-type-p type) type - (make-values-type :required (list type) :rest *universal-type*))) + (make-values-type :required (list type)))) ;;; Args-Type-Op -- Internal ;;; diff --git a/compiler/checkgen.lisp b/compiler/checkgen.lisp index 7b9466886240d42200dd31a86eacbfedcffbbc26..e7af2db27471f53a199e98feb25a1034962bf44a 100644 --- a/compiler/checkgen.lisp +++ b/compiler/checkgen.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/checkgen.lisp,v 1.32 2003/04/29 11:58:17 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/checkgen.lisp,v 1.33 2003/05/08 14:52:04 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -153,44 +153,58 @@ ;;; (defun values-types-asserted (atype ptype) (declare (type ctype atype ptype)) - (cond ((eq atype *wild-type*) - (values nil :unknown)) - ((not (values-type-p atype)) - (values (list atype) 1)) - ((or (args-type-keyp atype) - (args-type-allowp atype)) - (values nil :unknown)) - (t - ;; - ;; This converted PTYPE with COERCE-TO-VALUES originally, but - ;; that function was changed to return (VALUES PTYPE &REST T) - ;; instead of (VALUES PTYPE) with the port of subtypep fixes - ;; from SBCL. The new &REST would confuse the logic here. - (multiple-value-bind (preq popt prest) - (if (values-type-p ptype) - (values (args-type-required ptype) - (args-type-optional ptype) - (args-type-rest ptype)) - (values (list ptype) nil nil)) - (collect ((types)) - (do ((args (args-type-required atype) (rest args))) - ((endp args)) - (if (or (pop preq) (pop popt) prest) - (types (single-value-type (first args))) - (return-from values-types-asserted (values nil :unknown)))) - (do ((args (args-type-optional atype) (rest args))) - ((endp args)) - (if (pop preq) - (types (single-value-type (first args))) - (return-from values-types-asserted (values nil :unknown)))) - (let ((arest (args-type-rest atype))) - (when arest - (do ((arg (pop preq) (pop preq))) - ((null arg)) - (types (single-value-type arest))) - (when (or popt prest) - (return-from values-types-asserted (values nil :unknown))))) - (values (types) (length (types)))))))) + (flet ((give-up () + (return-from values-types-asserted (values nil :unknown)))) + (cond ((eq atype *wild-type*) + (give-up)) + ((not (values-type-p atype)) + (values (list atype) 1)) + ((or (values-type-keyp atype) + (values-type-allowp atype)) + (give-up)) + ;; + ;; FIXME: Values type checking is done with a form like + ;; + ;; (multiple-value-bind (x y z) <form> + ;; <type checks for x y z> + ;; (values x y z)) + ;; + ;; see Make-Type-Check-Form. This has the unfortunate + ;; effect of chopping values when <form> actually returns + ;; more values than are being checked. The downside of + ;; including this is that it produces a lot of notes. + #+nil + ((or (eq *wild-type* ptype) + (and (values-type-p ptype) + (or (values-type-optional ptype) + (values-type-rest ptype)))) + (give-up)) + (t + (let* ((ptype (kernel::coerce-to-values ptype)) + (preq (values-type-required ptype)) + (popt (values-type-optional ptype)) + (prest (values-type-rest ptype))) + ;; + ;; FIXME: ptype = * is not handled right, I think + ;; because * = (VALUES &REST T). It never was + ;; handled right. Gerd 2003-05-08. + (collect ((types)) + (dolist (type (values-type-required atype)) + (if (or (pop preq) (pop popt) prest) + (types (single-value-type type)) + (give-up))) + (dolist (type (values-type-optional atype)) + (if (pop preq) + (types (single-value-type type)) + (give-up))) + (let ((arest (values-type-rest atype))) + (when arest + (loop with rest-type = (single-value-type arest) + for arg = (pop preq) while arg do + (types rest-type)) + (when (or popt prest) + (give-up)))) + (values (types) (length (types))))))))) ;;; Switch to disable check complementing, for evaluation. @@ -293,10 +307,11 @@ (defun continuation-check-types (cont &optional force-hairy) (declare (type continuation cont)) (let ((atype (continuation-asserted-type cont)) - (dest (continuation-dest cont))) + (dest (continuation-dest cont)) + (proven (continuation-proven-type cont))) (assert (not (eq atype *wild-type*))) (multiple-value-bind (types count) - (values-types-asserted atype (continuation-proven-type cont)) + (values-types-asserted atype proven) (cond ((not (eq count :unknown)) (let ((types (no-function-types types))) (if (or (exit-p dest) @@ -308,6 +323,9 @@ (eq count :unknown)))) (maybe-negate-check cont types t) (maybe-negate-check cont types force-hairy)))) + #+nil + ((eq *wild-type* proven) + (values :too-hairy nil)) ((and (mv-combination-p dest) (eq (basic-combination-kind dest) :local)) (assert (values-type-p atype)) diff --git a/compiler/ir1tran.lisp b/compiler/ir1tran.lisp index 1272e120e435b3e1f61fb14d31541db23bc59ad0..2803b4f60e69b9bfa17464d4fa28a17447f6896e 100644 --- a/compiler/ir1tran.lisp +++ b/compiler/ir1tran.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.149 2003/04/30 07:25:15 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.150 2003/05/08 14:52:03 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -3013,14 +3013,24 @@ Assert that Form evaluates to the specified type (which may be a VALUES type.)" (let ((ctype (values-specifier-type type))) - (unless (values-type-p ctype) - (setf ctype (make-values-type :optional (list ctype) - :rest *universal-type*))) + (cond ((values-type-p ctype) + (flet ((or-null (type) + (specifier-type `(or null ,(type-specifier type))))) + (setq ctype + (make-values-type + :required (mapcar #'or-null (values-type-required ctype)) + :optional (values-type-optional ctype) + :rest (or (values-type-rest ctype) *universal-type*))))) + ((csubtypep (specifier-type 'null) ctype) + (setq ctype (make-values-type :optional (list ctype) + :rest *universal-type*))) + (t + (setq ctype (make-values-type :required (list ctype) + :rest *universal-type*)))) (let ((*lexical-environment* (do-the-stuff ctype cont *lexical-environment* 'the))) (ir1-convert start cont value)))) - ;;; Truly-The IR1 convert -- Internal ;;; ;;; Since the Continuation-Derived-Type is computed as the union of its @@ -3090,7 +3100,7 @@ (defun set-variable (start cont var value) (declare (type continuation start cont) (type basic-var var)) (let ((dest (make-continuation)) - (opt-type (make-values-type :optional (list (leaf-type var)) + (opt-type (make-values-type :required (list (leaf-type var)) :rest *universal-type*))) (setf (continuation-asserted-type dest) opt-type) (ir1-convert start dest value) diff --git a/general-info/release-19a.txt b/general-info/release-19a.txt index 187cdf64dc3034c9a7789c804f360c7ccaaf017c..7e62a4db5c1e3c7107cc64e8f6b61ac0d0fda447 100644 --- a/general-info/release-19a.txt +++ b/general-info/release-19a.txt @@ -59,6 +59,8 @@ New in this release: - Stricter checking of keyword argument list in CLOS methods. - &ENVIRONMENT variable bound bound before other vars, regardless of where it appears in a lambda-list. + - VALUES types no longer accepting &KEY or &ALLOW-OTHER-KEYS. + - THE conforming to ANSI. * Numerous bugfixes: - NSET-EXCLUSIVE-OR returns the same results as SET-EXCLUSIVE-OR