Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory common-lisp.net:/tmp/cvs-serv26560/losp/muerte
Modified Files:
arrays.lisp
Log Message:
I've been offline for a while, but working sometimes on this file.
Mostly it's about the migration to the new movitz-basic-vectors.
Date: Tue Jul 6 13:35:36 2004
Author: ffjeld
Index: movitz/losp/muerte/arrays.lisp
diff -u movitz/losp/muerte/arrays.lisp:1.28 movitz/losp/muerte/arrays.lisp:1.29
--- movitz/losp/muerte/arrays.lisp:1.28 Tue Jun 29 16:21:28 2004
+++ movitz/losp/muerte/arrays.lisp Tue Jul 6 13:35:36 2004
@@ -10,7 +10,7 @@
;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org>
;;;; Created at: Sun Feb 11 23:14:04 2001
;;;;
-;;;; $Id: arrays.lisp,v 1.28 2004/06/29 23:21:28 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.29 2004/07/06 20:35:36 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -229,7 +229,7 @@
((do-it ()
`(with-inline-assembly (:returns :eax)
(:declare-label-set basic-vector-dispatcher
- (any-t character u8 unknown
+ (any-t character u8 u32
unknown unknown unknown unknown))
(:compile-two-forms (:eax :ebx) array index)
(:movl (:eax ,movitz:+other-type-offset+) :ecx)
@@ -256,6 +256,11 @@
,(bt:slot-offset 'movitz:movitz-funobj 'movitz::constant0)))
(() () '(:sub-program (unknown) (:int 100)))
+ u32
+ (:movl (:eax :ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))
+ :ecx)
+ (:call-global-constant box-u32-ecx)
+ (:jmp 'return)
u8
(:movl :ebx :ecx)
(:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
@@ -265,9 +270,10 @@
(:jmp 'return)
character
(:movl :ebx :ecx)
+ (:movl :eax :ebx)
(:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
(:movl ,(movitz:tag :character) :eax)
- (:movb (:eax :ecx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))
+ (:movb (:ebx :ecx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))
:ah)
(:jmp 'return)
any-t
@@ -301,19 +307,19 @@
(error "Index ~D out of bounds ~D."
index (array-dimension vector 0)))))
- (:cmpl ,(movitz:vector-type-tag :any-t) :ecx)
- (:jne 'not-any-t)
- (:movl (:eax (:ebx 4) 2) :eax)
- (:jmp 'done)
-
- not-any-t
- (:cmpl ,(movitz:vector-type-tag :character) :ecx)
- (:jne 'not-character)
- (:movb (:eax :ebx 2) :bl)
- (:xorl :eax :eax)
- (:movb :bl :ah)
- (:movb ,(movitz::tag :character) :al) ; character
- (:jmp 'done)
+; (:cmpl ,(movitz:vector-type-tag :any-t) :ecx)
+; (:jne 'not-any-t)
+; (:movl (:eax (:ebx 4) 2) :eax)
+; (:jmp 'done)
+
+; not-any-t
+; (:cmpl ,(movitz:vector-type-tag :character) :ecx)
+; (:jne 'not-character)
+; (:movb (:eax :ebx 2) :bl)
+; (:xorl :eax :eax)
+; (:movb :bl :ah)
+; (:movb ,(movitz::tag :character) :al) ; character
+; (:jmp 'done)
not-character
(:cmpl ,(movitz:vector-type-tag :u8) :ecx)
@@ -363,13 +369,53 @@
(:movl (:ebx ,movitz:+other-type-offset+) :ecx)
(:andl #xffff :ecx)
(:testb ,movitz:+movitz-fixnum-zmask+ :dl)
- (:jnz 'not-a-vector)
+ (:jnz '(:sub-program (not-an-index)
+ (:compile-form (:result-mode :ignore)
+ (error "Not a vector index: ~S" index))))
+ ;; t?
(:cmpl ,(movitz:basic-vector-type-tag :any-t) :ecx)
(:jne 'not-any-t-vector)
(:movl :eax
(:ebx :edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)))
(:jmp 'return)
+
not-any-t-vector
+ ;; Character?
+ (:cmpl ,(movitz:basic-vector-type-tag :character) :ecx)
+ (:jne 'not-character-vector)
+ (:cmpb ,(movitz:tag :character) :al)
+ (:jne '(:sub-program (not-a-character)
+ (:compile-form (:result-mode :ignore)
+ (error "Not a character: ~S" value))))
+ (:movl :edx :ecx)
+ (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+ (:movb :ah (:ebx :ecx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)))
+ (:jmp 'return)
+
+ not-character-vector
+ ;; u8?
+ (:cmpl ,(movitz:basic-vector-type-tag :u8) :ecx)
+ (:jne 'not-u8-vector)
+ (:testl ,(logxor #xffffffff (* #xff movitz:+movitz-fixnum-factor+))
+ :eax)
+ (:jne '(:sub-program (not-an-u8)
+ (:compile-form (:result-mode :ignore)
+ (error "Not an (unsigned-byte 8): ~S" value))))
+ (:shrl ,(- 8 movitz:+movitz-fixnum-shift+) :eax)
+ (:movl :edx :ecx)
+ (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+ (:movb :ah (:ebx :ecx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)))
+ (:jmp 'return)
+
+ not-u8-vector
+ (:cmpl ,(movitz:basic-vector-type-tag :u32) :ecx)
+ (:jne 'not-u32-vector)
+ (:call-global-constant unbox-u32)
+ (:movl :eax
+ (:ebx :edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)))
+ (:jmp 'return)
+
+ not-u32-vector
(:compile-form (:result-mode :ignore)
(error "Not a vector: ~S" vector))
return)
@@ -398,21 +444,21 @@
(:cmpw (:eax ,(bt:slot-offset 'movitz:movitz-vector 'movitz::num-elements)) :cx)
(:jae '(:sub-program () (:int 61) (:jmp (:pc+ -4)))) ; index out of bounds
- (:cmpl ,(movitz:vector-type-tag :any-t) :edx)
- (:jnz 'not-any-t)
+; (:cmpl ,(movitz:vector-type-tag :any-t) :edx)
+; (:jnz 'not-any-t)
- (:movl :ebx (:eax (:ecx 4) 2))
- (:jmp 'done)
+; (:movl :ebx (:eax (:ecx 4) 2))
+; (:jmp 'done)
- 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-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
(:cmpl ,(movitz:vector-type-tag :u8) :edx)
@@ -503,6 +549,7 @@
:eax)
)))
(do-it)))
+ #+ignore
(old-vector
(macrolet
((do-svref ()
@@ -559,6 +606,7 @@
(:movl :eax
(:ebx :edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))))))
(do-it)))
+ #+ignore
(old-vector
(check-type simple-vector simple-vector)
(assert (below index (vector-dimension simple-vector)))
@@ -568,11 +616,12 @@
(defun char (string index)
(check-type string string)
- (assert (below index (vector-dimension string)))
+ (assert (below index (array-dimension string 0)))
(memref string 2 index :character))
(defun (setf char) (value string index)
- (setf (aref string index) value))
+ (assert (below index (array-dimension string 0)))
+ (setf (memref string 2 index :character) value))
(defun schar (string index)
(check-type string string)
@@ -581,6 +630,7 @@
(defun (setf schar) (value string index)
(check-type string string)
+ (assert (below index (length string)))
(setf (aref string index) value))
(define-compiler-macro char%unsafe (string index)
@@ -677,17 +727,14 @@
(error "Multi-dimensional arrays not supported."))
(integer
(cond
- ((equal element-type 'character)
- (let ((array (malloc-data-clumps (truncate (+ dimensions 7 8) 8))))
- (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::flags)
- 0 :unsigned-byte16)
- 0)
- (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::num-elements)
- 0 :unsigned-byte16)
- dimensions)
- (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::type)
- 0 :unsigned-byte16)
- #.(movitz:vector-type-tag :character))
+ ((eq element-type 'character)
+ (let ((array (malloc-data-words (truncate (+ dimensions 3) 4))))
+ (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)
+ 0 :lisp)
+ dimensions)
+ (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::type)
+ 0 :unsigned-byte32)
+ #.(movitz:basic-vector-type-tag :character))
(check-type array string)
(setf (fill-pointer array)
(or fill-pointer dimensions))
@@ -701,24 +748,43 @@
(setf (char array i) (elt initial-contents i)))))
array))
((member element-type '(u8 (unsigned-byte 8)) :test #'equal)
- (let ((array (malloc-data-clumps (truncate (+ dimensions 7 8) 8))))
- (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::flags)
- 0 :unsigned-byte16)
- 0)
- (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::num-elements)
- 0 :unsigned-byte16)
- dimensions)
- (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::type)
- 0 :unsigned-byte16)
- #.(movitz:vector-type-tag :u8))
+ (let ((array (malloc-data-words (truncate (+ dimensions 3) 4))))
+ (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)
+ 0 :lisp)
+ dimensions)
+ (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::type)
+ 0 :unsigned-byte32)
+ #.(movitz:basic-vector-type-tag :u8))
(setf (fill-pointer array)
(or fill-pointer dimensions))
(cond
(initial-element
+ (check-type initial-element (unsigned-byte 8))
(dotimes (i dimensions)
- (setf (aref array i) initial-element)))
+ (setf (u8ref%unsafe array i) initial-element)))
(initial-contents
- (replace array initial-contents)))
+ (dotimes (i dimensions)
+ (setf (u8ref%unsafe array i) (elt initial-contents i)))))
+ array))
+ #+ignore
+ ((eq element-type :x) #+ignore (member element-type '(u32 (unsigned-byte 32)) :test #'equal)
+ (let ((array (malloc-data-words dimensions)))
+ (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)
+ 0 :lisp)
+ dimensions)
+ (setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::type)
+ 0 :unsigned-byte32)
+ #.(movitz:basic-vector-type-tag :u32))
+ (setf (fill-pointer array)
+ (or fill-pointer dimensions))
+ (cond
+ (initial-element
+ ;; (check-type initial-element (unsigned-byte 32))
+ (dotimes (i dimensions)
+ (setf (u32ref%unsafe array i) initial-element)))
+ (initial-contents
+ (dotimes (i dimensions)
+ (setf (u32ref%unsafe array i) (elt initial-contents i)))))
array))
((member element-type '(u32 (unsigned-byte 32)) :test #'equal)
(let ((array (malloc-data-words dimensions)))
@@ -740,8 +806,7 @@
(initial-contents
(replace array initial-contents)))
array))
- (t #+ignore (eq element-type :basic)
- (check-type dimensions (and fixnum (integer 0 *)))
+ (t (check-type dimensions (and fixnum (integer 0 *)))
(let ((array (malloc-words dimensions)))
(setf (memref array #.(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)
0 :lisp)
@@ -753,26 +818,6 @@
(case fill-pointer
((nil t) dimensions)
(t fill-pointer)))
- (cond
- (initial-contents
- (replace array initial-contents))
- (initial-element
- (dotimes (i dimensions)
- (setf (svref%unsafe array i) initial-element))))
- array))
- #+ignore
- (t (let ((array (malloc-words dimensions)))
- (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::flags)
- 0 :unsigned-byte16)
- 0)
- (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::num-elements)
- 0 :unsigned-byte16)
- dimensions)
- (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::type)
- 0 :unsigned-byte16)
- #.(movitz:vector-type-tag :any-t))
- (setf (fill-pointer array)
- (or fill-pointer dimensions))
(cond
(initial-contents
(replace array initial-contents))
