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

Modified Files:
	arrays.lisp 
Log Message:
Made array-element-type recognize bit-vectors.
Wrote upgraded-array-element-type, and array-dimensions.
Added a typep for array.

Date: Wed Jul 21 15:33:55 2004
Author: ffjeld

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.38 movitz/losp/muerte/arrays.lisp:1.39
--- movitz/losp/muerte/arrays.lisp:1.38	Wed Jul 21 04:47:49 2004
+++ movitz/losp/muerte/arrays.lisp	Wed Jul 21 15:33:55 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.38 2004/07/21 11:47:49 lgorrie Exp $
+;;;; $Id: arrays.lisp,v 1.39 2004/07/21 22:33:55 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -65,15 +65,61 @@
        '(unsigned-byte 16))
     (#.(bt:enum-value 'movitz::movitz-vector-element-type :u32)
        '(unsigned-byte 32))
+    (#.(bt:enum-value 'movitz::movitz-vector-element-type :bit)
+       'bit)
     (#.(bt:enum-value 'movitz::movitz-vector-element-type :code)
        'code)))
 
+(defun upgraded-array-element-type (type-specifier &optional environment)
+  "=> upgraded-type-specifier"
+  ;; We're in dire need of subtypep..
+  (cond
+   ((symbolp type-specifier)
+    (case type-specifier
+      ((character base-char standard-char)
+       'character)
+      ((code)
+       'code)
+      (t (let ((deriver (gethash type-specifier *derived-typespecs*)))
+	   (if (not deriver)
+	       t
+	     (upgraded-array-element-type (funcall deriver)))))))
+   ((null type-specifier)
+    t)
+   ((consp type-specifier)
+    (case (car type-specifier)
+      ((integer)
+       (let* ((q (cdr type-specifier))
+	      (min (if q (pop q) '*))
+	      (max (if q (pop q) '*)))
+	 (cond
+	  ((or (eq min '*) (eq max '*))
+	   t)
+	  ((<= 0 min max 1)
+	   'bit)
+	  ((<= 0 min max #xff)
+	   '(unsigned-byte 8))
+	  ((<= 0 min max #xffff)
+	   '(unsigned-byte 16))
+	  ((<= 0 min max #xffffffff)
+	   '(unsigned-byte 32)))))
+      (t (let ((deriver (gethash (car type-specifier) *derived-typespecs*)))
+	   (if (not deriver)
+	       t
+	     (upgraded-array-element-type (apply deriver (cdr type-specifier)) environment))))))
+   (t t)))
+    
+
 (defun array-dimension (array axis-number)
   (etypecase array
-    (simple-array
+    ((simple-array * 1)
      (assert (zerop axis-number))
      (movitz-accessor array movitz-basic-vector num-elements))))
 
+(defun array-dimensions (array)
+  (check-type array array)
+  1)
+
 (defun shrink-vector (vector new-size)
   (setf-movitz-accessor (vector movitz-basic-vector num-elements) new-size)
   vector)
@@ -772,3 +818,19 @@
 (defun bvref-u16 (vector offset index)
   "View <vector> as an sequence of octets, access the big-endian 16-bit word at position <index> + <offset>."
   (bvref-u16 vector offset index))
+
+(define-typep array (x &optional (element-type '*) (dimension-spec '*))
+  (and (typep x 'array)
+       (or (eq element-type '*)
+	   (eq element-type t)
+	   (equalp (array-element-type x)
+		   (upgraded-array-element-type element-type)))
+       (or (eq dimension-spec '*)
+	   (and (integerp dimension-spec)
+		(= dimension-spec (array-dimensions x)))
+	   (and (listp dimension-spec)
+		(do ((d 0 (1+ d))
+		     (q dimension-spec))
+		    ((null q) t)
+		  (unless (= (pop q) (array-dimension x d))
+		    (return nil)))))))