[movitz-cvs] CVS update: movitz/compiler-types.lisp

[Frode Vatvedt Fjeld]

Update of /project/movitz/cvsroot/movitz
In directory common-lisp.net:/tmp/cvs-serv27008

Modified Files:
	compiler-types.lisp 
Log Message:
Added encoded-type-singleton, and small changes to encoded-subtypep.

Date: Sat Feb 14 17:11:36 2004
Author: ffjeld

Index: movitz/compiler-types.lisp
diff -u movitz/compiler-types.lisp:1.6 movitz/compiler-types.lisp:1.7
--- movitz/compiler-types.lisp:1.6	Sat Feb 14 08:56:19 2004
+++ movitz/compiler-types.lisp	Sat Feb 14 17:11:36 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Sep 10 00:40:07 2003
 ;;;;                
-;;;; $Id: compiler-types.lisp,v 1.6 2004/02/14 13:56:19 ffjeld Exp $
+;;;; $Id: compiler-types.lisp,v 1.7 2004/02/14 22:11:36 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -56,47 +56,8 @@
 (defun type-specifier-singleton (type-specifier)
   "If type-specifier is a singleton type, return a singleton list
 with the single member of <type-specifier>."
-  (let ((old-result (cond
-		     ((eq 'null type-specifier)
-		      ;; The type NULL is a singleton.
-		      (list (movitz-read nil)))
-		     ((listp type-specifier)
-		      (case (car type-specifier)
-			(eql
-			 (cdr type-specifier))
-			(member
-			 (when (= 1 (length (cdr type-specifier)))
-			   (cdr type-specifier)))
-			(integer
-			 (when (and (integerp (second type-specifier))
-				    (integerp (third type-specifier))
-				    (= (second type-specifier)
-				       (third type-specifier)))
-			   (second type-specifier)))))))
-	(new-result
-	 (multiple-value-bind (code intscope members include complement)
-	     (type-specifier-encode type-specifier)
-	   (cond
-	    ((or complement include (not (= 0 code)))
-	     nil)
-	    ((= 1 (length members))
-	     members)
-	    ((and (= 1 (length intscope))
-		  (caar intscope)
-		  (eql (caar intscope)
-		       (cdar intscope)))
-	     (list (movitz-read (caar intscope))))))))
-    (check-type old-result list)
-    (check-type new-result list)
-    (cond
-     ((and old-result new-result)
-      (assert (movitz-eql (car old-result) (car new-result)))
-      new-result)
-     ((and (not old-result) (not new-result))
-      nil)
-     (t (warn "ts-singleton different result: old ~S, new: ~S"
-	      old-result new-result)
-	new-result))))
+  (multiple-value-call #'encoded-type-singleton
+    (type-specifier-encode type-specifier)))
       
 ;;;
 
@@ -444,7 +405,16 @@
 			 (union members0 members1 :test #'movitz-eql))
 	      (union include0 include1 :test #'equal)
 	      nil)))
-   (t (error "Not implemented"))))
+   ((and (not complement0) complement1)
+    (values code0
+	    integer-range0
+	    members0
+	    (cons (encoded-type-decode code1 integer-range1 members1 include1 complement1)
+		  include0)
+	    nil))
+   (t (error "Not implemented: ~S or ~S"
+	     (encoded-type-decode code0 integer-range0 members0 include0 complement0)
+	     (encoded-type-decode code1 integer-range1 members1 include1 complement1)))))
 
 
 (defun type-specifier-encode (type-specifier)
@@ -583,13 +553,13 @@
        ((encoded-allp code1 integer-range1 members1 include1 complement1)
 	;; type1 is t.
 	(result-is t t))
-       ((and (encoded-emptyp code1 integer-range1 members1 include1 complement1)
-	     (not (encoded-emptyp code0 integer-range0 members0 include0 complement0)))
-	;; type1 is nil and type0 isn't.
-	(result-is nil t))
        ((encoded-emptyp code0 integer-range0 members0 include0 complement0)
 	;; type0 is nil, which is a subtype of anything.
 	(result-is t t))
+       ((and (encoded-emptyp code1 integer-range1 members1 include1 complement1)
+	     #+ignore (not (encoded-emptyp code0 integer-range0 members0 include0 complement0)))
+	;; type1 is nil and type0 isn't.
+	(result-is nil t))
        ((and (encoded-allp code0 integer-range0 members0 include0 complement0)
 	     (multiple-value-bind (all1 confident)
 		 (encoded-allp code1 integer-range1 members1 include1 complement1)
@@ -611,14 +581,29 @@
 	    ((:unknown)
 	     (result-is nil nil))
 	    ((t) nil)))
-	(when include0
-	  (result-is nil nil))
-	(result-is t t))
+	(if include0
+	    (result-is nil nil)
+	  (result-is t t)))
        ((and complement0 complement1)
 	(encoded-subtypep code1 integer-range1 members1 include1 nil
 			  code0 integer-range0 members0 include0 nil))
        (t (result-is nil nil))))))
-			
+
+(defun encoded-type-singleton (code intscope members include complement)
+  "If the encoded type is a singleton, return that element in a list."
+  (cond
+   ((or complement include (not (= 0 code)))
+    nil)
+   ((= 1 (length members))
+    members)
+   ((and (= 1 (length intscope))
+	 (caar intscope)
+	 (eql (caar intscope)
+	      (cdar intscope)))
+    (list (movitz-read (caar intscope))))
+   ((and (null members) (null intscope))
+    (warn "Not singleton, nulloton."))))
+
 (defun movitz-subtypep (type1 type2)
   "Compile-time subtypep."
   (multiple-value-call #'encoded-subtypep