From d1b82f3e8dcf4b6df3fb6bafc4cfb7a808f6d139 Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Wed, 28 Dec 2011 16:32:48 +0100 Subject: [PATCH] When extracting primary types from (VALUES), use NULL. --- src/cmp/cmptype-arith.lsp | 32 +++++++++++++++++--------------- 1 file changed, 17 insertions(+), 15 deletions(-) diff --git a/src/cmp/cmptype-arith.lsp b/src/cmp/cmptype-arith.lsp index 2a49917fa..876a27591 100644 --- a/src/cmp/cmptype-arith.lsp +++ b/src/cmp/cmptype-arith.lsp @@ -107,13 +107,11 @@ (cmpwarn "Unsupported CONS type ~S. Replacing it with T." t2) t1) ((null tag1) - (setf c::*compiler-break-enable* t) - ;(break) + ;(setf c::*compiler-break-enable* t) (break) (cmpnote "Unknown type ~S. Assuming it is T." t1) t2) (t - (setf c::*compiler-break-enable* t) - ;(break) + ;(setf c::*compiler-break-enable* t) (break) (cmpnote "Unknown type ~S. Assuming it is T." t2) t1)))) @@ -129,18 +127,22 @@ (values l l))))) (defun-equal-cached values-type-primary-type (type) + ;; Extract the type of the first value returned by this form. We are + ;; pragmatic and thus (VALUES) => NULL [CHECKME!] (when (and (consp type) (eq (first type) 'VALUES)) - (let ((subtype (second type))) - (when (or (eq subtype '&optional) (eq subtype '&rest)) - (setf type (cddr type)) - (when (or (null type) - (eq (setf subtype (first type)) '&optional) - (eq subtype '&rest)) - (cmperr "Syntax error in type expression ~S" type)) - ;; An &optional or &rest output value might be missing - ;; If this is the case, the the value will be NIL. - (setf subtype (type-or 'null subtype))) - (setf type subtype))) + (if (null (rest type)) + (setf type 'null) + (let ((subtype (second type))) + (when (or (eq subtype '&optional) (eq subtype '&rest)) + (setf type (cddr type)) + (when (or (null type) + (eq (setf subtype (first type)) '&optional) + (eq subtype '&rest)) + (cmperr "Syntax error in type expression ~S" type)) + ;; An &optional or &rest output value might be missing + ;; If this is the case, the the value will be NIL. + (setf subtype (type-or 'null subtype))) + (setf type subtype)))) type) (defun-equal-cached values-type-to-n-types (type length)