From 1b8bb0bef1990d5fb6eff10e5d19b8ebdf05cbd2 Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Sun, 5 Jul 2009 09:42:38 +0200 Subject: [PATCH] Implemented TYPE-AND for multiple value types --- src/cmp/cmptype.lsp | 122 ++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 113 insertions(+), 9 deletions(-) diff --git a/src/cmp/cmptype.lsp b/src/cmp/cmptype.lsp index ba24e5e3d..4d6a486e7 100644 --- a/src/cmp/cmptype.lsp +++ b/src/cmp/cmptype.lsp @@ -157,6 +157,109 @@ (cmpwarn "Unknown type ~S. Assuming it is T." t2) t1)))) +(defun values-type-primary-type (type) + (when (and (consp type) (eq (first type) 'VALUES)) + (let ((subtype (second type))) + (when (or (eq subtype '&optional) (eq subtype '&rest)) + (setf subtype (third (c1form-type form))) + (when (eq subtype '&optional) + (cmperr "Syntax error in type expression ~S" type))) + (when (eq subtype '&rest) + (cmperr "Syntax error in type expression ~S" type)) + (setf type subtype))) + type) + +(defun values-type-and (t1 t2) + (labels ((values-type-p (type) + (and (consp type) (eq (first type) 'VALUES))) + (values-and-ordinary (v type) + (let* ((v (rest v)) + (first-type (first v))) + (cond ((or (eq first-type '&optional) (eq first-type '&rest)) + (type-and (second v) type)) + ((null (rest v)) + (type-and first-type type)) + (t + (return-from values-type-and nil))))) + (type-error (type) + (error "Invalid type ~A" type)) + (do-values-type-and (t1-orig t2-orig) + (do* ((t1 (rest t1-orig)) + (t2 (rest t2-orig)) + (i1 (first t1)) + (i2 (first t2)) + (phase1 nil) + (phase2 nil) + (phase3 nil) + (output (list 'VALUES))) + ((or (null t1) (null t2)) + (if (or (eq t1 t2) + (eq i1 '&rest) (eq i1 '&optional) + (eq i2 '&rest) (eq i2 '&optional)) + (nreverse output) + nil)) + (print (list i1 i2 t1 t2 phase1 phase2 phase3 output)) + (cond ((eq i1 '&optional) + (when phase1 (type-error t1-orig)) + (setf phase1 '&optional) + (setf t1 (rest t1) i1 (first t1)) + (unless t1 (type-error t1-orig))) + ((eq i1 '&rest) + (when (eq phase1 '&rest) (type-error t1-orig)) + (setf phase1 '&rest) + (setf t1 (rest t1) i1 (first t1)) + (when (or (null t1) (rest t1)) (type-error t1-orig)))) + (cond ((eq i2 '&optional) + (when phase2 (type-error t2-orig)) + (setf phase2' &optional) + (setf t2 (rest t2) i2 (first t2)) + (unless t2 (type-error t2-orig))) + ((eq i2 '&rest) + (when (eq phase2 '&rest) (type-error t2-orig)) + (setf phase2 '&rest) + (setf t2 (rest t2) i2 (first t2)) + (when (or (null t2) (rest t2)) (type-error t2-orig)))) + (cond ((and (null phase1) (null phase2)) + (push (type-and i1 i2) output) + (setf t1 (rest t1) i1 (first t1) + t2 (rest t2) i2 (first t2))) + ((null phase2) + (push (type-and i1 i2) output) + (unless (eq phase1 '&rest) + (setf t1 (rest t1) i1 (first t1))) + (setf t2 (rest t2) i2 (first t2))) + ((null phase1) + (push (type-and i1 i2) output) + (unless (eq phase2 '&rest) + (setf t2 (rest t2) i2 (first t2))) + (setf t1 (rest t1) i1 (first t1))) + ((eq phase1 phase2) + (unless (eq phase3 phase2) + (push (setf phase3 phase2) output)) + (push (type-and i1 i2) output) + (cond ((eq phase1 '&rest) (setf t1 nil t2 nil)) + (t (setf t1 (rest t1) i1 (first t1) + t2 (rest t2) i2 (first t2))))) + ((eq phase1 '&optional) + (unless (eq phase3 phase1) + (push (setf phase3 phase1) output)) + (push (type-and i1 i2) output) + (setf t1 (rest t1) i1 (first t1))) + ((eq phase2 '&optional) + (unless (eq phase3 phase2) + (push (setf phase3 phase2) output)) + (push (type-and i1 i2) output) + (setf t2 (rest t2) i2 (first t2))))))) + (if (equal t1 t2) + t1 + (if (values-type-p t1) + (if (values-type-p t2) + (do-values-type-and t1 t2) + (values-and-ordinary t1 t2)) + (if (values-type-p t2) + (values-and-ordinary t2 t1) + (type-and t1 t2)))))) + (defun type-or (t1 t2) ;; FIXME! Should we allow "*" as type name??? (when (or (eq t1 t2) (eq t2 '*)) @@ -420,15 +523,16 @@ (unless in-optionals (cmpwarn "Too few arguments for proclaimed function ~A" fname)) (return)) - (let* ((form (first fl)) - (lisp-form (first al)) - (old-type (c1form-type form))) - (and-form-type expected-type form lisp-form - :safe "In the argument ~d of a call to ~a" i fname) - ;; In safe mode, we cannot assume that the type of the - ;; argument is going to be the right one. - (unless (zerop (cmp-env-optimization 'safety)) - (setf (c1form-type form) old-type)))))) + (when lisp-forms + (let* ((form (first fl)) + (lisp-form (first al)) + (old-type (c1form-type form))) + (and-form-type expected-type form lisp-form + :safe "In the argument ~d of a call to ~a" i fname) + ;; In safe mode, we cannot assume that the type of the + ;; argument is going to be the right one. + (unless (zerop (cmp-env-optimization 'safety)) + (setf (c1form-type form) old-type))))))) return-type)) (defmacro def-type-propagator (fname lambda-list &body body)