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

Modified Files:
	arrays.lisp 
Log Message:
Improved (setf aref).

Date: Mon Mar  8 08:17:38 2004
Author: ffjeld

Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.2 movitz/losp/muerte/arrays.lisp:1.3
--- movitz/losp/muerte/arrays.lisp:1.2	Mon Jan 19 06:23:46 2004
+++ movitz/losp/muerte/arrays.lisp	Mon Mar  8 08:17:38 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.2 2004/01/19 11:23:46 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.3 2004/03/08 13:17:38 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -252,8 +252,6 @@
     (:testb 7 :cl)
     (:jnz '(:sub-program () (:int 60) (:jmp (:pc+ -4)))) ; not other-type
     (:movzxw (:eax -2) :edx)
-    (:cmpb #.(movitz::tag :vector) :dl)
-    (:jne '(:sub-program () (:int 60) (:jmp (:pc+ -4)))) ; not vector-type
     
     (:compile-form (:result-mode :ecx) index)
     (:testb #.movitz::+movitz-fixnum-zmask+ :cl)
@@ -262,27 +260,64 @@
     (:shrl #.movitz::+movitz-fixnum-shift+ :ecx)
 
     (:cmpw (:eax -4) :cx)
-    (:jae '(:sub-program () (:int 61) (:jmp (:pc+ -4))))	; index out of bounds
-    (:testb :dh :dh)			; element-type 0?
+    (:jae '(:sub-program () (:int 61) (:jmp (:pc+ -4)))) ; index out of bounds
+
+    (:cmpl #.(movitz:vector-type-tag :any-t) :edx)
     (:jnz 'not-any-t)
 
     (:movl :ebx (:eax (:ecx 4) 2))
     (:jmp 'done)
 
-    not-any-t
-    (:decb :dh)				; element-type 1?
+   not-any-t
+    (:cmpl #.(movitz:vector-type-tag :character) :edx)
     (:jnz 'not-character)
+    (:cmpb #.(movitz:tag :character) :bl)
+    (:jnz '(:sub-program (not-character-value)
+	    (:compile-form (:result-mode :ignore)
+	     (error "Value not character: ~S" value))))
     (:movb :bh (:eax :ecx 2))
     (:jmp 'done)
     
-    not-character
-    (:decb :dh)
-    (:jnz '(:sub-program (not-u8) (:int 62) (:jmp (:pc+ -4))))
-    (:shll #.(cl:- 8 movitz::+movitz-fixnum-shift+) :ebx)
-    (:movb :bh (:eax :ecx 2))
-    (:shrl #.(cl:- 8 movitz::+movitz-fixnum-shift+) :ebx)
+   not-character
+    (:cmpl #.(movitz:vector-type-tag :u8) :edx)
+    (:jnz 'not-u8)
+    (:testl #.(cl:ldb (cl:byte 32 0) (cl:- -1 (cl:* #xff movitz:+movitz-fixnum-factor+))) :ebx)
+    (:jnz '(:sub-program (not-u8-value)
+	    (:compile-form (:result-mode :ignore)
+	     (error "Value not (unsigned-byte 8): ~S" value))))
+    (:shrl #.movitz:+movitz-fixnum-shift+ :ebx)
+    (:movb :bl (:eax (:ecx 1) #.(bt:slot-offset 'movitz:movitz-vector 'movitz::data)))
+    (:leal ((:ebx #.movitz:+movitz-fixnum-factor+)) :ebx)
+    (:jmp 'done)
+    
+    
+   not-u8
+    (:cmpl #.(movitz:vector-type-tag :u16) :edx)
+    (:jnz 'not-u16)
+    (:testl #.(cl:ldb (cl:byte 32 0) (cl:- -1 (cl:* #xffff movitz:+movitz-fixnum-factor+))) :ebx)
+    (:jnz '(:sub-program (not-u16-value)
+	    (:compile-form (:result-mode :ignore)
+	     (error "Value not (unsigned-byte 16): ~S" value))))
+    (:shrl #.movitz:+movitz-fixnum-shift+ :ebx)
+    (:movw :bx (:eax (:ecx 2) #.(bt:slot-offset 'movitz:movitz-vector 'movitz::data)))
+    (:leal ((:ebx #.movitz:+movitz-fixnum-factor+)) :ebx)
+    (:jmp 'done)
 
-    done))
+   not-u16
+    (:cmpl #.(movitz:vector-type-tag :u32) :edx)
+    (:jnz 'not-u32)
+    (:testl #.(cl:ldb (cl:byte 32 0) (cl:- -1 (cl:* #xffffffff movitz:+movitz-fixnum-factor+))) :ebx)
+    (:jnz '(:sub-program (not-u32-value)
+	    (:compile-form (:result-mode :ignore)
+	     (error "Value not (unsigned-byte 32): ~S" value))))
+    (:shrl #.movitz:+movitz-fixnum-shift+ :ebx)
+    (:movw :bx (:eax (:ecx 4) #.(bt:slot-offset 'movitz:movitz-vector 'movitz::data)))
+    (:leal ((:ebx #.movitz:+movitz-fixnum-factor+)) :ebx)
+    (:jmp 'done)
+
+   not-u32
+    (:compile-form (:result-mode :ignore) (error "Not a vector: ~S" vector))
+   done))
 
 
 ;;; simple-vector accessors