X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-type.lisp;h=3a9a2897a9da9c7008b43cec9296039774ac2b6f;hb=860543cc7ba0266e41e1d41ac9b6a208f3795f1a;hp=b904176ffaf6315df04bb86772ae38788999e571;hpb=086927c64682b73e00cb5090ec72e1a72fb30ece;p=sbcl.git

diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp
index b904176..3a9a289 100644
--- a/src/code/early-type.lisp
+++ b/src/code/early-type.lisp
@@ -67,23 +67,146 @@
   ;; true if other &KEY arguments are allowed
   (allowp nil :type boolean))
 
+(defun canonicalize-args-type-args (required optional rest)
+  (when (eq rest *empty-type*)
+    ;; or vice-versa?
+    (setq rest nil))
+  (loop with last-not-rest = nil
+        for i from 0
+        for opt in optional
+        do (cond ((eq opt *empty-type*)
+                  (return (values required (subseq optional i) rest)))
+                 ((neq opt rest)
+                  (setq last-not-rest i)))
+        finally (return (values required
+                                (if last-not-rest
+                                    (subseq optional 0 (1+ last-not-rest))
+                                    nil)
+                                rest))))
+
+(defun args-types (lambda-list-like-thing)
+  (multiple-value-bind
+	(required optional restp rest keyp keys allowp auxp aux
+                  morep more-context more-count llk-p)
+      (parse-lambda-list-like-thing lambda-list-like-thing)
+    (declare (ignore aux morep more-context more-count))
+    (when auxp
+      (error "&AUX in a FUNCTION or VALUES type: ~S." lambda-list-like-thing))
+    (let ((required (mapcar #'single-value-specifier-type required))
+	  (optional (mapcar #'single-value-specifier-type optional))
+	  (rest (when restp (single-value-specifier-type rest)))
+	  (keywords
+	   (collect ((key-info))
+	     (dolist (key keys)
+	       (unless (proper-list-of-length-p key 2)
+		 (error "Keyword type description is not a two-list: ~S." key))
+	       (let ((kwd (first key)))
+		 (when (find kwd (key-info) :key #'key-info-name)
+		   (error "~@<repeated keyword ~S in lambda list: ~2I~_~S~:>"
+			  kwd lambda-list-like-thing))
+		 (key-info
+		  (make-key-info
+		   :name kwd
+		   :type (single-value-specifier-type (second key))))))
+	     (key-info))))
+      (multiple-value-bind (required optional rest)
+	  (canonicalize-args-type-args required optional rest)
+	(values required optional rest keyp keywords allowp llk-p)))))
+
 (defstruct (values-type
 	    (:include args-type
 		      (class-info (type-class-or-lose 'values)))
             (:constructor %make-values-type)
 	    (:copier nil)))
-(define-cached-synonym make-values-type)
+
+(defun-cached (make-values-type-cached
+               :hash-bits 8
+               :hash-function (lambda (req opt rest allowp)
+                                (logand (logxor
+                                         (type-list-cache-hash req)
+                                         (type-list-cache-hash opt)
+                                         (if rest
+                                             (type-hash-value rest)
+                                             42)
+                                         (sxhash allowp))
+                                        #xFF)))
+    ((required equal-but-no-car-recursion)
+     (optional equal-but-no-car-recursion)
+     (rest eq)
+     (allowp eq))
+  (%make-values-type :required required
+                     :optional optional
+                     :rest rest
+                     :allowp allowp))
+
+;;; FIXME: ANSI VALUES has a short form (without lambda list
+;;; keywords), which should be translated into a long one.
+(defun make-values-type (&key (args nil argsp)
+                         required optional rest allowp)
+  (if argsp
+      (if (eq args '*)
+	  *wild-type*
+	  (multiple-value-bind (required optional rest keyp keywords allowp
+                                llk-p)
+	      (args-types args)
+            (declare (ignore keywords))
+            (when keyp
+              (error "&KEY appeared in a VALUES type specifier ~S."
+                     `(values ,@args)))
+            (if llk-p
+                (make-values-type :required required
+                                  :optional optional
+                                  :rest rest
+                                  :allowp allowp)
+                (make-short-values-type required))))
+      (multiple-value-bind (required optional rest)
+          (canonicalize-args-type-args required optional rest)
+        (cond ((and (null required)
+                    (null optional)
+                    (eq rest *universal-type*))
+               *wild-type*)
+              ((memq *empty-type* required)
+               *empty-type*)
+              (t (make-values-type-cached required optional
+                                          rest allowp))))))
 
 (!define-type-class values)
 
 ;;; (SPECIFIER-TYPE 'FUNCTION) and its subtypes
 (defstruct (fun-type (:include args-type
-			       (class-info (type-class-or-lose 'function))))
+			       (class-info (type-class-or-lose 'function)))
+                     (:constructor %make-fun-type))
   ;; true if the arguments are unrestrictive, i.e. *
   (wild-args nil :type boolean)
   ;; type describing the return values. This is a values type
   ;; when multiple values were specified for the return.
   (returns (missing-arg) :type ctype))
+(defun make-fun-type (&rest initargs
+		      &key (args nil argsp) returns &allow-other-keys)
+  (if argsp
+      (if (eq args '*)
+	  (if (eq returns *wild-type*)
+	      (specifier-type 'function)
+	      (%make-fun-type :wild-args t :returns returns))
+	  (multiple-value-bind (required optional rest keyp keywords allowp)
+	      (args-types args)
+	    (if (and (null required)
+		     (null optional)
+		     (eq rest *universal-type*)
+		     (not keyp))
+		(if (eq returns *wild-type*)
+		    (specifier-type 'function)
+		    (%make-fun-type :wild-args t :returns returns))
+		(%make-fun-type :required required
+				:optional optional
+				:rest rest
+				:keyp keyp
+				:keywords keywords
+				:allowp allowp
+				:returns returns))))
+      ;; FIXME: are we really sure that we won't make something that
+      ;; looks like a completely wild function here?
+      (apply #'%make-fun-type initargs)))
 
 ;;; The CONSTANT-TYPE structure represents a use of the CONSTANT-ARG
 ;;; "type specifier", which is only meaningful in function argument
@@ -176,22 +299,6 @@
 		     (if (consp high)
 			 (1- (type-bound-number high))
 			 high)))
-	    #!+negative-zero-is-not-zero
-	    (float
-	     ;; Canonicalize a low bound of (-0.0) to 0.0, and a high
-	     ;; bound of (+0.0) to -0.0.
-	     (values (if (and (consp low)
-			      (floatp (car low))
-			      (zerop (car low))
-			      (minusp (float-sign (car low))))
-			 (float 0.0 (car low))
-			 low)
-		     (if (and (consp high)
-			      (floatp (car high))
-			      (zerop (car high))
-			      (plusp (float-sign (car high))))
-			 (float -0.0 (car high))
-			 high)))
 	    (t 
 	     ;; no canonicalization necessary
 	     (values low high)))
@@ -258,22 +365,22 @@
   ;; canonicalize to (DOUBLE-FLOAT 0.0d0 0.0d0), because numeric
   ;; ranges are compared by arithmetic operators (while MEMBERship is
   ;; compared by EQL).  -- CSR, 2003-04-23
-  (let ((singlep (subsetp '(-0.0f0 0.0f0) members))
-	(doublep (subsetp '(-0.0d0 0.0d0) members))
+  (let ((singlep (subsetp `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0) members))
+	(doublep (subsetp `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0) members))
 	#!+long-float
-	(longp (subsetp '(-0.0l0 0.0l0) members)))
+	(longp (subsetp `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0) members)))
     (if (or singlep doublep #!+long-float longp)
 	(let (union-types)
 	  (when singlep
 	    (push (ctype-of 0.0f0) union-types)
-	    (setf members (set-difference members '(-0.0f0 0.0f0))))
+	    (setf members (set-difference members `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0))))
 	  (when doublep
 	    (push (ctype-of 0.0d0) union-types)
-	    (setf members (set-difference members '(-0.0d0 0.0d0))))
+	    (setf members (set-difference members `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0))))
 	  #!+long-float
 	  (when longp
 	    (push (ctype-of 0.0l0) union-types)
-	    (setf members (set-difference members '(-0.0l0 0.0l0))))
+	    (setf members (set-difference members `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0))))
 	  (aver (not (null union-types)))
 	  (make-union-type t
 			   (if (null members)
@@ -333,17 +440,8 @@
 ;;; A CONS-TYPE is used to represent a CONS type.
 (defstruct (cons-type (:include ctype (class-info (type-class-or-lose 'cons)))
 		      (:constructor
-		       ;; ANSI says that for CAR and CDR subtype
-		       ;; specifiers '* is equivalent to T. In order
-		       ;; to avoid special cases in SUBTYPEP and
-		       ;; possibly elsewhere, we slam all CONS-TYPE
-		       ;; objects into canonical form w.r.t. this
-		       ;; equivalence at creation time.
-		       %make-cons-type (car-raw-type
-					cdr-raw-type
-					&aux
-					(car-type (type-*-to-t car-raw-type))
-					(cdr-type (type-*-to-t cdr-raw-type))))
+		       %make-cons-type (car-type
+					cdr-type))
 		      (:copier nil))
   ;; the CAR and CDR element types (to support ANSI (CONS FOO BAR) types)
   ;;
@@ -351,6 +449,8 @@
   (car-type (missing-arg) :type ctype :read-only t)
   (cdr-type (missing-arg) :type ctype :read-only t))
 (defun make-cons-type (car-type cdr-type)
+  (aver (not (or (eq car-type *wild-type*)
+                 (eq cdr-type *wild-type*))))
   (if (or (eq car-type *empty-type*)
 	  (eq cdr-type *empty-type*))
       *empty-type*
@@ -414,15 +514,17 @@
 ;;; never return a VALUES type.
 (defun specifier-type (x)
   (let ((res (values-specifier-type x)))
-    (when (values-type-p res)
+    (when (or (values-type-p res)
+              ;; bootstrap magic :-(
+              (and (named-type-p res)
+                   (eq (named-type-name res) '*)))
       (error "VALUES type illegal in this context:~%  ~S" x))
     res))
 
 (defun single-value-specifier-type (x)
-  (let ((res (specifier-type x)))
-    (if (eq res *wild-type*)
-        *universal-type*
-        res)))
+  (if (eq x '*)
+      *universal-type*
+      (specifier-type x)))
 
 ;;; Similar to MACROEXPAND, but expands DEFTYPEs. We don't bother
 ;;; returning a second value.
@@ -444,5 +546,6 @@
   (when (boundp 'sb!kernel::*values-specifier-type-cache-vector*)
     (values-specifier-type-cache-clear))
   (values))
+
 
 (!defun-from-collected-cold-init-forms !early-type-cold-init)