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

[Frode Vatvedt Fjeld]

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

Modified Files:
	compiler-types.lisp 
Log Message:
Factored out function member-type-encode, which encodes a member
type-specifier from a set of objects.

Date: Thu Feb 12 06:32:56 2004
Author: ffjeld

Index: movitz/compiler-types.lisp
diff -u movitz/compiler-types.lisp:1.3 movitz/compiler-types.lisp:1.4
--- movitz/compiler-types.lisp:1.3	Wed Feb 11 13:01:40 2004
+++ movitz/compiler-types.lisp	Thu Feb 12 06:32:56 2004
@@ -6,11 +6,11 @@
 ;;;;    For distribution policy, see the accompanying file COPYING.
 ;;;; 
 ;;;; Filename:      compiler-types.lisp
-;;;; Description:   
+;;;; Description:   Compile-time type computation and manipulation.
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Sep 10 00:40:07 2003
 ;;;;                
-;;;; $Id: compiler-types.lisp,v 1.3 2004/02/11 18:01:40 ffjeld Exp $
+;;;; $Id: compiler-types.lisp,v 1.4 2004/02/12 11:32:56 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -475,15 +475,9 @@
 	(satisfies
 	 (type-values () :include (list type-specifier)))
 	(member
-	 (type-values () :members (cdr type-specifier)))
+	 (apply #'member-type-encode (cdr type-specifier)))
 	(eql
-	 (let ((x (second type-specifier)))
-	   (etypecase x
-	     (movitz-fixnum
-	      (type-values () :integer-range (make-numscope (movitz-fixnum-value x)
-							    (movitz-fixnum-value x))))
-	     (movitz-object
-	      (type-values () :members (list x))))))
+	 (member-type-encode (second type-specifier)))
 	(and
 	 (if (not (cdr type-specifier))
 	     (type-values t)
@@ -535,6 +529,22 @@
 	     (assert deriver (type-specifier)
 	       "Unknown type ~S." type-specifier)
 	     (type-specifier-encode (apply deriver (cdr type-specifier))))))))))
+
+(defun member-type-encode (&rest member-objects)
+  (declare (dynamic-extent members))
+  (multiple-value-bind (code integer-range members include complement)
+      (type-specifier-encode nil)
+    (dolist (x member-objects)
+      (multiple-value-setq (code integer-range members include complement)
+	(multiple-value-call #'encoded-types-or
+	  code integer-range members include complement
+	  (etypecase x
+	    (movitz-fixnum
+	     (type-values () :integer-range (make-numscope (movitz-fixnum-value x)
+							   (movitz-fixnum-value x))))
+	    (movitz-object
+	     (type-values () :members (list x)))))))
+    (values code integer-range members include complement)))
 
 (defun encoded-emptyp (code integer-range members include complement)
   "Return wether we know the encoded type is the empty set.