From 8d82b3ca2062a352d072de614a0c7446f07d89a9 Mon Sep 17 00:00:00 2001
From: dtc <dtc>
Date: Thu, 6 Jul 2000 04:35:35 +0000
Subject: [PATCH] Correct single-value-type to return the union with the null
 type for an optional or rest argument, and enhance it to return the
 *null-type* if there are no values. Also no longer inline this function as it
 is becoming more complex.

---
 code/type.lisp | 27 ++++++++++++++++++++-------
 1 file changed, 20 insertions(+), 7 deletions(-)

diff --git a/code/type.lisp b/code/type.lisp
index f6248935b..2a4da6c05 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.34 2000/06/27 16:31:52 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type.lisp,v 1.35 2000/07/06 04:35:35 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -198,6 +198,8 @@
 		      (:class-info (type-class-or-lose 'values)))
 	    (:print-function %print-type)))
 
+(declaim (freeze-type values-type))
+
 (define-type-method (values :unparse) (type)
   (cons 'values (unparse-args-types type)))
 
@@ -413,16 +415,27 @@
 ;;; Single-Value-Type  --  Interface
 ;;;
 ;;;    Return the type of the first value indicated by Type.  This is used by
-;;; people who don't want to have to deal with values types.
+;;; people who don't want to have to deal with values types. If the first
+;;; values is an optional or rest argument then return the union with the null
+;;; type. If the first values is a keyword then give up and return the
+;;; universal type.
 ;;;
-(declaim (freeze-type values-type) (inline single-value-type))
 (defun single-value-type (type)
   (declare (type ctype type))
   (cond ((values-type-p type)
-	 (or (car (args-type-required type))
-	     (car (args-type-optional type))
-	     (args-type-rest type)
-	     *universal-type*))
+	 (let ((required (args-type-required type)))
+	   (if required
+	       (first required)
+	       (let ((otype (args-type-optional type)))
+		 (cond (otype
+			(type-union (first otype) *null-type*))
+		       ((or (args-type-keyp type) (args-type-allowp type))
+			*universal-type*)
+		       (t
+			(let ((rest (args-type-rest type)))
+			  (if rest
+			      (type-union rest *null-type*)
+			      *null-type*))))))))
 	((eq type *wild-type*)
 	 *universal-type*)
 	(t
-- 
GitLab