[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-serv11392

Modified Files:
	typep.lisp 
Log Message:
Slightly more correct dealing with simple-array type.

Date: Thu Jul  8 14:50:03 2004
Author: ffjeld

Index: movitz/losp/muerte/typep.lisp
diff -u movitz/losp/muerte/typep.lisp:1.24 movitz/losp/muerte/typep.lisp:1.25
--- movitz/losp/muerte/typep.lisp:1.24	Thu Jul  8 11:54:01 2004
+++ movitz/losp/muerte/typep.lisp	Thu Jul  8 14:50:03 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  8 11:07:53 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: typep.lisp,v 1.24 2004/07/08 18:54:01 ffjeld Exp $
+;;;; $Id: typep.lisp,v 1.25 2004/07/08 21:50:03 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -260,15 +260,20 @@
 		    `(typep ,object ',(apply deriver-function (cdr type)))
 		  (case (car type)
 		    ((simple-array)
-		     (let ((et (cadr type)))
-		       (cond
-			((movitz:movitz-subtypep et '(unsigned-byte 8))
-			 (make-basic-vector-typep :u8))
-			((movitz:movitz-subtypep et '(unsigned-byte 32))
-			 (make-basic-vector-typep :u32))
-			((movitz:movitz-subtypep et 'character)
-			 (make-basic-vector-typep :character))
-			(t (make-basic-vector-typep :any-t)))))
+		     (let ((et (second type))
+			   (dim (if (listp (third type))
+				    (length (third type))
+				  (or (third type) '*))))
+		       (if (not (eql dim 1))
+			   form
+			 (cond
+			  ((movitz:movitz-subtypep et '(unsigned-byte 8))
+			   (make-basic-vector-typep :u8))
+			  ((movitz:movitz-subtypep et '(unsigned-byte 32))
+			   (make-basic-vector-typep :u32))
+			  ((movitz:movitz-subtypep et 'character)
+			   (make-basic-vector-typep :character))
+			  (t (make-basic-vector-typep :any-t))))))
 		    ((integer)
 		     (destructuring-bind (&optional (lower-limit '*) (upper-limit '*))
 			 (cdr type)