diff --git a/code/hash-new.lisp b/code/hash-new.lisp index 1b5012ae6b3f85f4f04e4c7a4f73558c8907f45a..ef8a6fd0363ec884a8745938ad0e1e46ecdb6287 100644 --- a/code/hash-new.lisp +++ b/code/hash-new.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/hash-new.lisp,v 1.14 2000/07/06 05:41:27 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/hash-new.lisp,v 1.15 2000/07/06 18:36:36 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -863,12 +863,13 @@ (let ((data (gensym)) (start (gensym)) (end (gensym))) - `(with-array-data ((,data (the string ,sequence)) + `(with-array-data ((,data (the (values string &rest t) ,sequence)) (,start) (,end)) (if (zerop ,start) (%sxhash-simple-substring ,data ,end) - (sxhash-simple-string (coerce (the string ,sequence) + (sxhash-simple-string (coerce (the (values string &rest t) + ,sequence) 'simple-string)))))) (defmacro sxhash-list (sequence depth &key (equalp nil)) diff --git a/code/hash.lisp b/code/hash.lisp index cc6d93e4e668fd6513ee315692ca7b63326f9d1f..9306f590c47e77d26f9ceca1212528a8259fbca6 100644 --- a/code/hash.lisp +++ b/code/hash.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/hash.lisp,v 1.38 2000/07/06 05:41:27 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/hash.lisp,v 1.39 2000/07/06 18:36:37 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -831,12 +831,13 @@ (let ((data (gensym)) (start (gensym)) (end (gensym))) - `(with-array-data ((,data (the string ,sequence)) + `(with-array-data ((,data (the (values string &rest t) ,sequence)) (,start) (,end)) (if (zerop ,start) (%sxhash-simple-substring ,data ,end) - (sxhash-simple-string (coerce (the string ,sequence) + (sxhash-simple-string (coerce (the (values string &rest t) + ,sequence) 'simple-string)))))) (defmacro sxhash-list (sequence depth &key (equalp nil)) diff --git a/code/macros.lisp b/code/macros.lisp index 06cc4edf8757f7767240b093d50cc4400e6d470c..e9cfc3a85cc184dde58e672892890351cfece25c 100644 --- a/code/macros.lisp +++ b/code/macros.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/macros.lisp,v 1.61 2000/04/14 03:50:24 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.62 2000/07/06 18:36:38 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -497,11 +497,12 @@ (declare (ignore ,@dummy-list)) ,keeper)) (once-only ((n n)) - `(case (the fixnum ,n) + `(case (the (values fixnum &rest t) ,n) (0 (nth-value 0 ,form)) (1 (nth-value 1 ,form)) (2 (nth-value 2 ,form)) - (T (nth (the fixnum ,n) (multiple-value-list ,form))))))) + (T (nth (the (values fixnum &rest t) ,n) + (multiple-value-list ,form))))))) ;;;; SETF and friends. diff --git a/code/type.lisp b/code/type.lisp index 2a4da6c05492f632fd192c49722d082b99b17cfb..47f797969ecdb979394a3b7cbc67bfaacb3d53e4 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.35 2000/07/06 04:35:35 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type.lisp,v 1.36 2000/07/06 18:36:40 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -524,13 +524,24 @@ ;;; 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)))) + + +;;; Make-canonical-values-type -- Internal +;;; +;;; Make a single value type is possible, otherwise a values-type. +;;; (values type) ==> <type> +;;; +(defun make-canonical-values-type (required optional rest) + (if (and required (endp (rest required)) (not optional) (not rest)) + (first required) + (make-values-type :required required :optional optional :rest rest))) ;;; Args-Type-Op -- Internal @@ -587,12 +598,12 @@ :from-end t))) (if (find *empty-type* required :test #'type=) (values *empty-type* t) - (values (make-values-type - :required required - :optional (if opt-last - (subseq opt 0 (1+ opt-last)) - ()) - :rest (if (eq rest *empty-type*) nil rest)) + (values (make-canonical-values-type + required + (if opt-last + (subseq opt 0 (1+ opt-last)) + ()) + (if (eq rest *empty-type*) nil rest)) (and rest-exact res-exact))))))))) (funcall operation type1 type2))) diff --git a/compiler/array-tran.lisp b/compiler/array-tran.lisp index f89ed3675c2cf4c5ce18be2e96091686b767e7ae..d37325ab34892cdd2f75d84fbca7e10d081a9a6a 100644 --- a/compiler/array-tran.lisp +++ b/compiler/array-tran.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/array-tran.lisp,v 1.27 1998/07/24 17:22:26 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/array-tran.lisp,v 1.28 2000/07/06 18:37:00 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -58,7 +58,8 @@ (defun assert-new-value-type (new-value array) (let ((type (continuation-type array))) (when (array-type-p type) - (assert-continuation-type new-value (array-type-element-type type)))) + (assert-continuation-optional-type new-value + (array-type-element-type type)))) (continuation-type new-value)) ;;; Unsupplied-Or-NIL -- Internal @@ -193,7 +194,7 @@ (initial-element #\NULL)) (if (byte-compiling) (values nil t) - `(make-array (the index ,length) + `(make-array (the (values index &rest t) ,length) :element-type ,element-type :initial-element ,initial-element))) diff --git a/compiler/checkgen.lisp b/compiler/checkgen.lisp index 132aab0cac5c44a33bd4104e202451c3ae5eb408..0fd0d37d96b7d66769f81c2af9331c5a9be9dc1a 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.28 2000/07/06 12:56:19 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/checkgen.lisp,v 1.29 2000/07/06 18:37:00 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -140,6 +140,47 @@ types)) +;;; Values-types-asserted -- Internal +;;; +;;; Like values-types, but when an argument is proven to be delivered, +;;; convert asserted optional and rest arguments to required arguments. This +;;; makes it clear that these required arguments may all be type checked. +;;; +(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 + (let* ((ptype (kernel::coerce-to-values ptype)) + (preq (args-type-required ptype)) + (popt (args-type-optional ptype)) + (prest (args-type-rest ptype))) + (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)))))))) + + ;;; Switch to disable check complementing, for evaluation. ;;; (defvar *complement-type-checks* t) @@ -239,7 +280,7 @@ (dest (continuation-dest cont))) (assert (not (eq atype *wild-type*))) (multiple-value-bind (types count) - (values-types atype) + (values-types-asserted atype (continuation-proven-type cont)) (cond ((not (eq count :unknown)) (let ((types (no-function-types types))) (if (or (exit-p dest) diff --git a/compiler/ir1opt.lisp b/compiler/ir1opt.lisp index 1ff7dda41e264620251b9105cf8b745c44a8f4c0..85e8a2498fb89e8bac109739bd7d81bae969b0a1 100644 --- a/compiler/ir1opt.lisp +++ b/compiler/ir1opt.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/ir1opt.lisp,v 1.69 2000/07/06 18:06:01 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1opt.lisp,v 1.70 2000/07/06 18:37:01 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -200,7 +200,8 @@ (reoptimize-continuation (node-cont node)))))) (undefined-value)) -(declaim (start-block assert-continuation-type assert-call-type)) +(declaim (start-block assert-continuation-type + assert-continuation-optional-type assert-call-type)) ;;; Assert-Continuation-Type -- Interface ;;; @@ -224,6 +225,18 @@ (undefined-value)) +;;; Assert-continuation-optional-type -- Interface +;;; +;;; Similar to Assert-Continuation-Type, but asserts that the type is +;;; for an optional argument and that other arguments may be received. +;;; +(defun assert-continuation-optional-type (cont type) + (declare (type continuation cont) (type ctype type)) + (let ((opt-type (make-values-type :optional (list type) + :rest *universal-type*))) + (assert-continuation-type cont opt-type))) + + ;;; Assert-Call-Type -- Interface ;;; ;;; Assert that Call is to a function of the specified Type. It is assumed @@ -236,23 +249,23 @@ (dolist (req (function-type-required type)) (when (null args) (return-from assert-call-type)) (let ((arg (pop args))) - (assert-continuation-type arg req))) + (assert-continuation-optional-type arg req))) (dolist (opt (function-type-optional type)) (when (null args) (return-from assert-call-type)) (let ((arg (pop args))) - (assert-continuation-type arg opt))) + (assert-continuation-optional-type arg opt))) (let ((rest (function-type-rest type))) (when rest (dolist (arg args) - (assert-continuation-type arg rest)))) + (assert-continuation-optional-type arg rest)))) (dolist (key (function-type-keywords type)) (let ((name (key-info-name key))) (do ((arg args (cddr arg))) ((null arg)) (when (eq (continuation-value (first arg)) name) - (assert-continuation-type + (assert-continuation-optional-type (second arg) (key-info-type key))))))) (undefined-value)) @@ -538,9 +551,8 @@ (return-from find-result-type (undefined-value))))) (t (use-union (node-derived-type use))))) - (let ((int (values-type-intersection - (continuation-asserted-type result) - (use-union)))) + (let ((int (values-type-intersection (continuation-asserted-type result) + (use-union)))) (setf (return-result-type node) int)))) (undefined-value)) diff --git a/compiler/ir1tran.lisp b/compiler/ir1tran.lisp index a4f228a9b8dcfeb109b4e7e89d0c45942a2e47d4..93a39cb74842f8f531f0766bdaa6933512240834 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.114 2000/06/18 15:45:30 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.115 2000/07/06 18:37:02 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -745,8 +745,8 @@ (declare (type continuation fun-cont cont) (list args)) (let ((node (make-combination fun-cont))) (setf (continuation-dest fun-cont) node) - (assert-continuation-type fun-cont - (specifier-type '(or function symbol))) + (assert-continuation-type + fun-cont (values-specifier-type '(values (or function symbol) &rest t))) (collect ((arg-conts)) (let ((this-start fun-cont)) (dolist (arg args) @@ -1138,9 +1138,9 @@ (if *suppress-values-declaration* res (let ((types (cdr spec))) - (do-the-stuff (if (eql (length types) 1) - (car types) - `(values ,@types)) + (do-the-stuff (values-specifier-type (if (eql (length types) 1) + (car types) + `(values ,@types))) cont res 'values)))) (dynamic-extent (when (policy nil (> speed brevity)) @@ -2470,7 +2470,8 @@ (def-ir1-translator %funcall ((function &rest args) start cont) (let ((fun-cont (make-continuation))) (ir1-convert start fun-cont function) - (assert-continuation-type fun-cont (specifier-type 'function)) + (assert-continuation-type + fun-cont (values-specifier-type '(values function &rest t))) (ir1-convert-combination-args fun-cont cont args))) ;;; This source transform exists to reduce the amount of work for the compiler. @@ -2884,7 +2885,7 @@ ;;; ;;; This is somewhat involved, since a type assertion may only be made on a ;;; continuation, not on a node. We can't just set the continuation asserted -;;; type and let it go at that, since there may be paralell THE's for the same +;;; type and let it go at that, since there may be parallel THE's for the same ;;; continuation, i.e.: ;;; (if ... ;;; (the foo ...) @@ -2908,10 +2909,9 @@ ;;; COND branches. We can't do it here, since we don't know how many branches ;;; there are going to be. ;;; -(defun do-the-stuff (type cont lexenv name) - (declare (type continuation cont) (type lexenv lexenv)) - (let* ((ctype (values-specifier-type type)) - (old-type (or (lexenv-find cont type-restrictions) +(defun do-the-stuff (ctype cont lexenv name) + (declare (type ctype ctype) (type continuation cont) (type lexenv lexenv)) + (let* ((old-type (or (lexenv-find cont type-restrictions) *wild-type*)) (intersects (values-types-intersect old-type ctype)) (int (values-type-intersection old-type ctype)) @@ -2929,13 +2929,21 @@ ;;; THE IR1 Convert -- Internal ;;; +;;; A THE declaration for a single value type is internally converted +;;; into (values &optional type &rest t) as this is the commonly +;;; expected behavior. +;;; (def-ir1-translator the ((type value) start cont) "THE Type Form Assert that Form evaluates to the specified type (which may be a VALUES type.)" - (let ((*lexical-environment* - (do-the-stuff type cont *lexical-environment* 'the))) - (ir1-convert start cont value))) + (let ((ctype (values-specifier-type type))) + (unless (values-type-p ctype) + (setf ctype (make-values-type :optional (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 @@ -3006,8 +3014,10 @@ ;;; (defun set-variable (start cont var value) (declare (type continuation start cont) (type basic-var var)) - (let ((dest (make-continuation))) - (setf (continuation-asserted-type dest) (leaf-type var)) + (let ((dest (make-continuation)) + (opt-type (make-values-type :optional (list (leaf-type var)) + :rest *universal-type*))) + (setf (continuation-asserted-type dest) opt-type) (ir1-convert start dest value) (let ((res (make-set :var var :value dest))) (setf (continuation-dest dest) res) @@ -3168,8 +3178,8 @@ ,fun (%coerce-to-function ,fun))))) (setf (continuation-dest fun-cont) node) - (assert-continuation-type fun-cont - (specifier-type '(or function symbol))) + (assert-continuation-type + fun-cont (values-specifier-type '(values (or function symbol) &rest t))) (collect ((arg-conts)) (let ((this-start fun-cont)) (dolist (arg args) @@ -3481,7 +3491,7 @@ ;;; ;;; Check a new global function definition for consistency with previous ;;; declaration or definition, and assert argument/result types if appropriate. -;;; This this assertion is suppressed by the EXPLICIT-CHECK attribute, which is +;;; This assertion is suppressed by the EXPLICIT-CHECK attribute, which is ;;; specified on functions that check their argument types as a consequence of ;;; type dispatching. This avoids redundant checks such as NUMBERP on the args ;;; to +, etc. diff --git a/compiler/ir2tran.lisp b/compiler/ir2tran.lisp index b6fbaf9535202ace3187a4321fe135f1250a4268..1643d79fa8ed6ad530d614ce0047e7a2c99ccf0d 100644 --- a/compiler/ir2tran.lisp +++ b/compiler/ir2tran.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/ir2tran.lisp,v 1.67 1999/02/25 13:03:07 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir2tran.lisp,v 1.68 2000/07/06 18:37:03 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -599,7 +599,7 @@ ;;; ;;; Return a list of TNs usable in a Call to Template delivering values to ;;; Cont. As an efficiency hack, we pick off the common case where the -;;; contiuation is fixed values and has locations that satisfy the result +;;; continuation is fixed values and has locations that satisfy the result ;;; restrictions. This can fail when there is a type check or a values count ;;; mismatch. ;;; diff --git a/compiler/locall.lisp b/compiler/locall.lisp index 73156e4c23f9e537fce2cc03643d639772d9576a..f6f1bfca4c264af76513a79c652a584f4fede639 100644 --- a/compiler/locall.lisp +++ b/compiler/locall.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/locall.lisp,v 1.48 1999/12/03 16:28:28 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/locall.lisp,v 1.49 2000/07/06 18:37:03 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -46,7 +46,7 @@ (let ((arg (car args)) (var (car vars))) (cond ((leaf-refs var) - (assert-continuation-type arg (leaf-type var))) + (assert-continuation-optional-type arg (leaf-type var))) (t (flush-dest arg) (setf (car args) nil))))) diff --git a/compiler/srctran.lisp b/compiler/srctran.lisp index a580559c14010af3995ba681f58d0f3c8780e7de..b04624360a9d9370517b0e02c9e155c1d9c73b85 100644 --- a/compiler/srctran.lisp +++ b/compiler/srctran.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/srctran.lisp,v 1.99 2000/06/21 17:01:48 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.100 2000/07/06 18:37:04 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -32,7 +32,8 @@ ;;; ;;; Endp is just NULL with a List assertion. ;;; -(def-source-transform endp (x) `(null (the list ,x))) +(def-source-transform endp (x) + `(null (the (values &optional list &rest t) ,x))) ;;; We turn Identity into Prog1 so that it is obvious that it just returns the ;;; first value of its argument. Ditto for Values with one arg. @@ -206,13 +207,13 @@ ;;; use a primitive to handle the cell access case. ;;; (def-source-transform numerator (num) - (once-only ((n-num `(the rational ,num))) + (once-only ((n-num `(the (values rational &rest t) ,num))) `(if (ratiop ,n-num) (%numerator ,n-num) ,n-num))) ;;; (def-source-transform denominator (num) - (once-only ((n-num `(the rational ,num))) + (once-only ((n-num `(the (values rational &rest t) ,num))) `(if (ratiop ,n-num) (%denominator ,n-num) 1))) @@ -3662,14 +3663,14 @@ (def-source-transform gcd (&rest args) (case (length args) (0 0) - (1 `(abs (the integer ,(first args)))) + (1 `(abs (the (values integer &rest t) ,(first args)))) (2 (values nil t)) (t (associate-arguments 'gcd (first args) (rest args))))) (def-source-transform lcm (&rest args) (case (length args) (0 1) - (1 `(abs (the integer ,(first args)))) + (1 `(abs (the (values integer &rest t) ,(first args)))) (2 (values nil t)) (t (associate-arguments 'lcm (first args) (rest args)))))