[movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp

[Frode Vatvedt Fjeld]

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

Modified Files:
	typep.lisp 
Log Message:
Fixed error message for etypecase.
Added non-compiled (typep x '(array ..)).
Tweaked coerce to be somewhat more general.

Date: Sun Aug 14 14:04:06 2005
Author: ffjeld

Index: movitz/losp/muerte/typep.lisp
diff -u movitz/losp/muerte/typep.lisp:1.45 movitz/losp/muerte/typep.lisp:1.46
--- movitz/losp/muerte/typep.lisp:1.45	Fri Jun 10 00:19:10 2005
+++ movitz/losp/muerte/typep.lisp	Sun Aug 14 14:04:05 2005
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  8 11:07:53 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: typep.lisp,v 1.45 2005/06/09 22:19:10 ffjeld Exp $
+;;;; $Id: typep.lisp,v 1.46 2005/08/14 12:04:05 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -42,9 +42,7 @@
 	     (t (error "~S fell through an etypecase where the legal types were ~S."
 		       ,keyform
 		       ',(loop for c in clauses
-			     if (listp (car c))
-			     append (car c)
-			     else collect (car c))))))
+			     collect (car c))))))
 
 (define-compile-time-variable *simple-typespecs*
     ;; map symbol typespecs to typep-functions.
@@ -492,6 +490,17 @@
 	   ',fname))
        (defun ,fname ,lambda , at body))))
 
+(defun expand-type (type-specifier)
+  (typecase type-specifier
+    (symbol
+     (let ((typep-function (gethash type-specifier *derived-typespecs*)))
+       (when typep-function
+	 (funcall typep-function))))
+    (cons
+     (let ((typep-function (gethash (car type-specifier) *derived-typespecs*)))
+       (when typep-function
+	 (apply typep-function (cdr type-specifier)))))))
+
 (defun typep (object type-specifier)
   (block nil
     (typecase type-specifier
@@ -568,7 +577,26 @@
        (or (eq '* cdr) (typep (cdr x) cdr))))
 
 (deftype vector (&optional (element-type '*) (size '*))
-  `(simple-array ,element-type (,size)))
+  (if (eq size '*)
+      `(array ,element-type 1)
+    `(array ,element-type (,size))))
+
+(define-typep array (x &optional (element-type '*) (dimension-spec '*))
+  (and (typep x 'array)
+       (or (eq element-type '*)
+	   (do ((xet (array-element-type x))
+		(aet element-type (expand-type aet)))
+	       ((eq nil aet) nil)
+	     (when (equal xet aet) (return t))))
+       (or (eq dimension-spec '*)
+	   (if (integerp dimension-spec)
+	       (= dimension-spec (array-rank x))
+	     (and (= (length dimension-spec) (array-rank x))
+		  (every (lambda (xdim adim)
+			   (or (eq xdim '*) (= xdim adim)))
+			 dimension-spec
+			 (array-dimensions x)))))))
+      
 
 (define-simple-typep (atom atom) (x)
   (typep x 'atom))
@@ -669,14 +697,22 @@
 
 (defun coerce (object result-type)
   "=> result"
-  (cond
-   ((typep object result-type)
-    object)
-   ((and (eq result-type 'list)
-	 (typep object 'sequence))
-    (map 'list #'identity object))
-   ((and (typep object 'sequence)
-	 (member result-type '(vector array)))
-    (make-array (length object) :initial-contents object))
-   (t (error "Don't know how to coerce ~S to ~S." object result-type))))
+  (flet ((c (object result-type actual-type)
+	   (cond
+	    ((typep object result-type)
+	     object)
+	    ((member result-type '(list array vector))
+	     (map result-type #'identity object))
+	    ((and (consp result-type)
+		  (eq (car result-type) 'vector))
+	     (let* ((p (cdr result-type))
+		    (et (if p (pop p) t))
+		    (size (if p (pop p) nil)))
+	       (make-array (or size (length object))
+			   :initial-contents object
+			   :element-type et)))
+	    ((not (eq nil result-type))
+	     (c object (expand-type result-type) actual-type))
+	    (t (error "Don't know how to coerce ~S to ~S." object actual-type)))))
+    (c object result-type result-type)))