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

[Frode Vatvedt Fjeld]

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

Modified Files:
	arrays.lisp 
Log Message:
Improved array-element-type, make-array, and array typep.

Date: Wed Jul 21 18:09:44 2004
Author: ffjeld

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.39 movitz/losp/muerte/arrays.lisp:1.40
--- movitz/losp/muerte/arrays.lisp:1.39	Wed Jul 21 15:33:55 2004
+++ movitz/losp/muerte/arrays.lisp	Wed Jul 21 18:09:44 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sun Feb 11 23:14:04 2001
 ;;;;                
-;;;; $Id: arrays.lisp,v 1.39 2004/07/21 22:33:55 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.40 2004/07/22 01:09:44 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -60,7 +60,7 @@
     (#.(bt:enum-value 'movitz::movitz-vector-element-type :character)
        'character)
     (#.(bt:enum-value 'movitz::movitz-vector-element-type :u8)
-       'muerte::u8)
+       '(unsigned-byte 8))
     (#.(bt:enum-value 'movitz::movitz-vector-element-type :u16)
        '(unsigned-byte 16))
     (#.(bt:enum-value 'movitz::movitz-vector-element-type :u32)
@@ -737,19 +737,20 @@
                      (car dimensions))
                     (t
                      (error "Multi-dimensional arrays not supported.")))))
-    (cond
-      ;; These should be replaced by subtypep sometime.
-      ((eq element-type 'character)
-       (make-basic-vector%character size fill-pointer initial-element initial-contents))
-      ((member element-type '(bit (unsigned-byte 1)) :test #'equal)
-       (make-basic-vector%bit size fill-pointer initial-element initial-contents))
-      ((member element-type '(u8 (unsigned-byte 8)) :test #'equal)
-       (make-basic-vector%u8 size fill-pointer initial-element initial-contents))
-      ((member element-type '(u32 (unsigned-byte 32)) :test #'equal)
-       (make-basic-vector%u32 size fill-pointer initial-element initial-contents))
-      ((eq element-type 'code)
-       (make-basic-vector%code size fill-pointer initial-element initial-contents))
-      (t (make-basic-vector%t size fill-pointer initial-element initial-contents)))))
+    (let ((upgraded-element-type (upgraded-array-element-type element-type)))
+      (cond
+       ;; These should be replaced by subtypep sometime.
+       ((eq upgraded-element-type 'character)
+	(make-basic-vector%character size fill-pointer initial-element initial-contents))
+       ((eq upgraded-element-type 'bit)
+	(make-basic-vector%bit size fill-pointer initial-element initial-contents))
+       ((member upgraded-element-type '(u8 (unsigned-byte 8)) :test #'equal)
+	(make-basic-vector%u8 size fill-pointer initial-element initial-contents))
+       ((member upgraded-element-type '(u32 (unsigned-byte 32)) :test #'equal)
+	(make-basic-vector%u32 size fill-pointer initial-element initial-contents))
+       ((eq upgraded-element-type 'code)
+	(make-basic-vector%code size fill-pointer initial-element initial-contents))
+       (t (make-basic-vector%t size fill-pointer initial-element initial-contents))))))
 
 (defun vector (&rest objects)
   "=> vector"
@@ -829,8 +830,14 @@
 	   (and (integerp dimension-spec)
 		(= dimension-spec (array-dimensions x)))
 	   (and (listp dimension-spec)
-		(do ((d 0 (1+ d))
+		(do ((array-rank (array-dimensions x))
+		     (d 0 (1+ d))
 		     (q dimension-spec))
-		    ((null q) t)
-		  (unless (= (pop q) (array-dimension x d))
-		    (return nil)))))))
+		    ((null q) (= d array-rank))
+		  (let ((dim (pop q)))
+		    (cond
+		     ((>= d array-rank)
+		      (return nil))
+		     ((eq dim '*))
+		     ((= dim (array-dimension x d)))
+		     (t (return nil)))))))))