March 2004 - movitz-cvs@common-lisp.net - mailman3.common-lisp.net

[movitz-cvs] CVS update: movitz/losp/muerte/lists.lisp
by Frode Vatvedt Fjeld 18 Mar '04

18 Mar '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv22982 Modified Files: lists.lisp Log Message: Have nthcdr bail out when nil is encountered. Date: Thu Mar 18 04:24:23 2004 Author: ffjeld Index: movitz/losp/muerte/lists.lisp diff -u movitz/losp/muerte/lists.lisp:1.3 movitz/losp/muerte/lists.lisp:1.4 --- movitz/losp/muerte/lists.lisp:1.3 Tue Feb 3 04:57:49 2004 +++ movitz/losp/muerte/lists.lisp Thu Mar 18 04:24:23 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Tue Dec 5 18:40:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: lists.lisp,v 1.3 2004/02/03 09:57:49 ffjeld Exp $ +;;;; $Id: lists.lisp,v 1.4 2004/03/18 09:24:23 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -133,7 +133,7 @@ (defun nthcdr (n list) (do () - ((= 0 n) list) + ((or (null list) (not (plusp n))) list) (decf n) (setf list (cdr list)))) @@ -200,10 +200,10 @@ (defun copy-list (list) (if (null list) nil - (do* ((new-list (cons (pop list) nil)) - (new-tail new-list (cdr new-tail))) - ((null list) new-list) - (setf (cdr new-tail) (cons (pop list) nil))))) + (let ((new-list (cons (pop list) nil))) + (do ((new-tail new-list (cdr new-tail))) + ((null list) new-list) + (setf (cdr new-tail) (cons (pop list) nil)))))) (defun list (&rest objects) (numargs-case

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/run-time-context.lisp
by Frode Vatvedt Fjeld 18 Mar '04

18 Mar '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv5600 Modified Files: run-time-context.lisp Log Message: Tune-up of %run-time-context-slot. Date: Thu Mar 18 04:23:02 2004 Author: ffjeld Index: movitz/losp/muerte/run-time-context.lisp diff -u movitz/losp/muerte/run-time-context.lisp:1.1.1.1 movitz/losp/muerte/run-time-context.lisp:1.2 --- movitz/losp/muerte/run-time-context.lisp:1.1.1.1 Tue Jan 13 06:05:06 2004 +++ movitz/losp/muerte/run-time-context.lisp Thu Mar 18 04:23:01 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Nov 12 18:33:02 2003 ;;;; -;;;; $Id: run-time-context.lisp,v 1.1.1.1 2004/01/13 11:05:06 ffjeld Exp $ +;;;; $Id: run-time-context.lisp,v 1.2 2004/03/18 09:23:01 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -67,13 +67,18 @@ form (let ((slot-name (movitz::eval-form slot-name env))) (ecase (bt:binary-slot-type 'movitz::movitz-constant-block (intern (symbol-name slot-name) :movitz)) - (movitz::word + (movitz:word `(with-inline-assembly (:returns :eax) (:compile-form (:result-mode :eax) ,value) (:locally (:movl :eax (:edi (:edi-offset ,slot-name)))))) - (movitz::lu32 + (movitz:lu32 `(with-inline-assembly (:returns :untagged-fixnum-ecx) (:compile-form (:result-mode :untagged-fixnum-ecx) ,value) + (:locally (:movl :ecx (:edi (:edi-offset ,slot-name)))))) + (movitz:code-vector-word + `(with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :eax) ,value) + (:leal (:eax ,(bt:slot-offset 'movitz:movitz-vector 'movitz::data)) :ecx) (:locally (:movl :ecx (:edi (:edi-offset ,slot-name)))))))))) (defun (setf %run-time-context-slot) (value slot-name &optional (context (current-run-time-context))) @@ -83,6 +88,8 @@ (word (setf (memref context -6 (third slot) :lisp) value)) (lu32 + (setf (memref context -6 (third slot) :unsigned-byte32) value)) + (code-vector-word (setf (memref context -6 (third slot) :unsigned-byte32) value))))) (defun %run-time-context-segment-base (slot-name

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/primitive-functions.lisp
by Frode Vatvedt Fjeld 18 Mar '04

18 Mar '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv28802 Modified Files: primitive-functions.lisp Log Message: Minor optimizations regarding register usage. Date: Thu Mar 18 04:21:18 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.4 movitz/losp/muerte/primitive-functions.lisp:1.5 --- movitz/losp/muerte/primitive-functions.lisp:1.4 Thu Feb 26 08:43:51 2004 +++ movitz/losp/muerte/primitive-functions.lisp Thu Mar 18 04:21:17 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.4 2004/02/26 13:43:51 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.5 2004/03/18 09:21:17 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -466,9 +466,8 @@ (:shrl 1 :eax))) (define-primitive-function fast-cons () - "Call with car in eax and cdr in ebx. Preserves EDX." + "Allocate a cons cell. Call with car in eax and cdr in ebx." (with-inline-assembly (:returns :multiple-values) - (:pushl :edx) (:xchgl :eax :ecx) (:locally (:movl (:edi (:edi-offset malloc-buffer)) :eax)) (:movl (:eax 4) :edx) @@ -483,24 +482,21 @@ (:movl :ecx (:eax)) (:movl :ebx (:eax 4)) (:incl :eax) - (:popl :edx) (:ret))) (define-primitive-function ensure-heap-cons-variable () "Call with lended variable (a cons) in EAX. Preserves EDX." (with-inline-assembly (:returns :multiple-values) - ;; (:movl (:ebp :ecx) :eax) ; stack-frame variable's content into eax (:cmpl :ebp :eax) ; is cons above stack-frame? (:jge 'return-ok) (:cmpl :esp :eax) ; is cons below stack-frame? (:jl 'return-ok) ;; must migrate cell onto heap + (:pushl :edx) (:movl (:eax 3) :ebx) ; cdr (:movl (:eax -1) :eax) ; car - ;; (:pushl :ecx) (:locally (:call (:edi (:edi-offset fast-cons)))) - ;; (:popl :ecx) - ;; (:movl :eax (:ebx :ecx)) + (:popl :edx) return-ok (:ret)))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp
by Frode Vatvedt Fjeld 18 Mar '04

18 Mar '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv18618 Modified Files: arrays.lisp Log Message: Aref tune-up. Date: Thu Mar 18 04:19:45 2004 Author: ffjeld Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.5 movitz/losp/muerte/arrays.lisp:1.6 --- movitz/losp/muerte/arrays.lisp:1.5 Mon Mar 8 09:33:52 2004 +++ movitz/losp/muerte/arrays.lisp Thu Mar 18 04:19:45 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.5 2004/03/08 14:33:52 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.6 2004/03/18 09:19:45 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -230,13 +230,13 @@ not-u8 (:cmpl #.(movitz:vector-type-tag :u16) :ecx) - (:je 'not-u16) + (:jne 'not-u16) (:movzxw (:eax (:ebx 2) 2) :eax) ; u16 (:jmp 'done) not-u16 (:cmpl #.(movitz:vector-type-tag :u32) :ecx) - (:je 'not-u32) + (:jne 'not-u32) (:movl (:eax (:ebx 4) 2) :ecx) ; u32 (:cmpl #.movitz::+movitz-most-positive-fixnum+ :ecx) (:jg '(:sub-program (:overflowing-u32)

1 0

[movitz-cvs] CVS update: movitz/storage-types.lisp
by Frode Vatvedt Fjeld 18 Mar '04

18 Mar '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv24919 Modified Files: storage-types.lisp Log Message: Added function vector-type-tag. Date: Thu Mar 18 04:16:38 2004 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.9 movitz/storage-types.lisp:1.10 --- movitz/storage-types.lisp:1.9 Fri Feb 13 10:25:34 2004 +++ movitz/storage-types.lisp Thu Mar 18 04:16:38 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: storage-types.lisp,v 1.9 2004/02/13 15:25:34 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.10 2004/03/18 09:16:38 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -362,6 +362,11 @@ :initarg :symbolic-data :accessor movitz-vector-symbolic-data)) (:slot-align type -2)) + +(defun vector-type-tag (element-type) + (dpb (enum-value 'movitz-vector-element-type element-type) + (byte 8 8) + (enum-value 'other-type-byte :vector))) (define-binary-class movitz-new-vector (movitz-heap-object-other) ((length

1 0

[movitz-cvs] CVS update: movitz/packages.lisp
by Frode Vatvedt Fjeld 17 Mar '04

17 Mar '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv6535 Modified Files: packages.lisp Log Message: Various symbols added and removed. Date: Wed Mar 17 11:36:36 2004 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.6 movitz/packages.lisp:1.7 --- movitz/packages.lisp:1.6 Thu Feb 26 06:31:31 2004 +++ movitz/packages.lisp Wed Mar 17 11:36:36 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.6 2004/02/26 11:31:31 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.7 2004/03/17 16:36:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1118,7 +1118,7 @@ #:package-object-use-list #:package-object-internal-symbols #:package-object-external-symbols - + vector-element-type vector-element-size with-subvector-accessor @@ -1268,6 +1268,8 @@ #:code-vector%1op #:code-vector%2op #:code-vector%3op + #:code-vector-word + #:lu32 #:+movitz-fixnum-factor+ #:+movitz-fixnum-shift+ @@ -1280,6 +1282,7 @@ #:movitz-vector-num-elements #:movitz-vector-element-type #:movitz-vector-symbolic-data + #:vector-type-tag #:movitz-symbol #:movitz-string

1 0

[movitz-cvs] CVS update: movitz/slime-movitz.el
by Frode Vatvedt Fjeld 17 Mar '04

17 Mar '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv32571 Added Files: slime-movitz.el Log Message: >From Aleksandar Bakic. Date: Wed Mar 17 03:26:50 2004 Author: ffjeld

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/conditions.lisp
by Frode Vatvedt Fjeld 12 Mar '04

12 Mar '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv15616 Modified Files: conditions.lisp Log Message: Improved error message in signal-simple. Date: Fri Mar 12 06:47:42 2004 Author: ffjeld Index: movitz/losp/muerte/conditions.lisp diff -u movitz/losp/muerte/conditions.lisp:1.2 movitz/losp/muerte/conditions.lisp:1.3 --- movitz/losp/muerte/conditions.lisp:1.2 Mon Jan 19 06:23:46 2004 +++ movitz/losp/muerte/conditions.lisp Fri Mar 12 06:47:41 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Nov 20 15:47:04 2002 ;;;; -;;;; $Id: conditions.lisp,v 1.2 2004/01/19 11:23:46 ffjeld Exp $ +;;;; $Id: conditions.lisp,v 1.3 2004/03/12 11:47:41 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -250,7 +250,8 @@ (declare (dynamic-extent arguments)) (let* ((class (etypecase datum (symbol - (find-class datum)) + (or (find-class datum nil) + (error "No condition class named ~S." datum))) (string (find-class default-type)) (condition

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp
by Frode Vatvedt Fjeld 08 Mar '04

08 Mar '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv9248 Modified Files: arrays.lisp Log Message: Fixed stupid bug in aref in previous check-in. Date: Mon Mar 8 09:33:52 2004 Author: ffjeld Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.4 movitz/losp/muerte/arrays.lisp:1.5 --- movitz/losp/muerte/arrays.lisp:1.4 Mon Mar 8 09:26:13 2004 +++ movitz/losp/muerte/arrays.lisp Mon Mar 8 09:33:52 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.4 2004/03/08 14:26:13 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.5 2004/03/08 14:33:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -199,7 +199,7 @@ (:compile-form (:result-mode :ignore) (error "Not a vector: ~S" vector)))) -;;; (:shrl #.movitz::+movitz-fixnum-shift+ :ebx) + (:shrl #.movitz::+movitz-fixnum-shift+ :ebx) (:movzxw (:eax -2) :ecx) (:cmpw (:eax #.(bt:slot-offset 'movitz:movitz-vector 'movitz::num-elements)) :bx) @@ -209,13 +209,12 @@ (:cmpl #.(movitz:vector-type-tag :any-t) :ecx) (:jne 'not-any-t) - (:movl (:eax :ebx 2) :eax) + (:movl (:eax (:ebx 4) 2) :eax) (:jmp 'done) not-any-t (:cmpl #.(movitz:vector-type-tag :character) :ecx) (:jne 'not-character) - (:shrl #.movitz::+movitz-fixnum-shift+ :ebx) (:movb (:eax :ebx 2) :bl) (:xorl :eax :eax) (:movb :bl :ah) @@ -225,7 +224,6 @@ not-character (:cmpl #.(movitz:vector-type-tag :u8) :ecx) (:jne 'not-u8) - (:shrl #.movitz::+movitz-fixnum-shift+ :ebx) (:movzxb (:eax :ebx 2) :eax) ; u8 (:shll #.movitz::+movitz-fixnum-shift+ :eax) (:jmp 'done) @@ -233,14 +231,13 @@ not-u8 (:cmpl #.(movitz:vector-type-tag :u16) :ecx) (:je 'not-u16) - (:shrl #.(cl:1- movitz::+movitz-fixnum-shift+) :ebx) - (:movzxw (:eax :ebx 2) :eax) ; u16 + (:movzxw (:eax (:ebx 2) 2) :eax) ; u16 (:jmp 'done) not-u16 (:cmpl #.(movitz:vector-type-tag :u32) :ecx) (:je 'not-u32) - (:movl (:eax :ebx 2) :ecx) ; u32 + (:movl (:eax (:ebx 4) 2) :ecx) ; u32 (:cmpl #.movitz::+movitz-most-positive-fixnum+ :ecx) (:jg '(:sub-program (:overflowing-u32) (:int 107)))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp
by Frode Vatvedt Fjeld 08 Mar '04

08 Mar '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv20499 Modified Files: arrays.lisp Log Message: Minor fixes to aref and (setf aref). Date: Mon Mar 8 09:26:13 2004 Author: ffjeld Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.3 movitz/losp/muerte/arrays.lisp:1.4 --- movitz/losp/muerte/arrays.lisp:1.3 Mon Mar 8 08:17:38 2004 +++ movitz/losp/muerte/arrays.lisp Mon Mar 8 09:26:13 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.3 2004/03/08 13:17:38 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.4 2004/03/08 14:26:13 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -183,141 +183,163 @@ done)) -(defun aref (vector index) - (with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) vector) - (:compile-form (:result-mode :ebx) index) - (:leal (:eax #.(cl:- (movitz::tag :other))) :ecx) - (:testb #.movitz::+movitz-fixnum-zmask+ :bl) - (:jnz '(:sub-program (not-fixnum) (:int 107))) ; index not fixnum - (:andl #.(cl:ash #x000ffff movitz::+movitz-fixnum-shift+) :ebx) - (:testb 7 :cl) - (:jnz '(:sub-program () (:int 60))) ; not other-type - (:shrl #.movitz::+movitz-fixnum-shift+ :ebx) - (:movw (:eax -2) :cx) - (:cmpb #.(movitz::tag :vector) :cl) - (:jne '(:sub-program () (:int 60) (:jmp (:pc+ -4)))) ; not vector-type - (:cmpw (:eax -4) :bx) - (:jae '(:sub-program () - (:movzxw :bx :eax) - (:int 61) (:jmp (:pc+ -4)))) ; index out of bounds - (:testb :ch :ch) ; element-type 0? - (:jnz 'not-any-t) - (:movl (:eax (:ebx 4) 2) :eax) - (:jmp 'done) - - not-any-t - (:decb :ch) ; element-type 1? - (:jnz 'not-character) - (:movb (:eax :ebx 2) :bl) - (:xorl :eax :eax) - (:movb :bl :ah) - (:movb #.(movitz::tag :character) :al) ; character - (:jmp 'done) - - not-character - (:decb :ch) - (:jnz 'not-u8) - (:movzxb (:eax :ebx 2) :eax) ; u8 - (:shll #.movitz::+movitz-fixnum-shift+ :eax) - (:jmp 'done) - - not-u8 - (:decb :ch) - (:jnz 'not-u16) - (:movzxw (:eax (:ebx 2) 2) :eax) ; u16 - (:jmp 'done) - - not-u16 - (:decb :ch) - (:jnz 'not-u32) - (:movl (:eax (:ebx 4) 2) :ecx) ; u32 - (:cmpl #.movitz::+movitz-most-positive-fixnum+ :ecx) - (:jg '(:sub-program (:overflowing-u32) - (:int 107))) - (:leal ((:ecx #.movitz::+movitz-fixnum-factor+)) :eax) - (:jmp 'done) - - not-u32 - (:int 107) - - done)) - -(defun (setf aref) (value vector index) - (with-inline-assembly (:returns :ebx) - (:compile-form (:result-mode :ebx) value) - (:compile-form (:result-mode :eax) vector) - - (:leal (:eax #.(cl:- (movitz::tag :other))) :ecx) - (:testb 7 :cl) - (:jnz '(:sub-program () (:int 60) (:jmp (:pc+ -4)))) ; not other-type - (:movzxw (:eax -2) :edx) - - (:compile-form (:result-mode :ecx) index) - (:testb #.movitz::+movitz-fixnum-zmask+ :cl) - (:jnz '(:sub-program () (:int 107))) ; index not fixnum - (:andl #.(cl:ash #xffff movitz::+movitz-fixnum-shift+) :ecx) - (:shrl #.movitz::+movitz-fixnum-shift+ :ecx) - - (:cmpw (:eax -4) :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) - - (: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-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) - - 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)) +(defun aref (vector &rest subscripts) + (numargs-case + (2 (vector index) + (with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :eax) vector) + (:compile-form (:result-mode :ebx) index) + (:leal (:eax #.(cl:- (movitz::tag :other))) :ecx) + (:testb #.movitz::+movitz-fixnum-zmask+ :bl) + (:jnz '(:sub-program (not-fixnum) (:int 107))) ; index not fixnum + (:andl #.(cl:ash #x000ffff movitz::+movitz-fixnum-shift+) :ebx) + + (:testb 7 :cl) + (:jnz '(:sub-program () + (:compile-form (:result-mode :ignore) + (error "Not a vector: ~S" vector)))) + +;;; (:shrl #.movitz::+movitz-fixnum-shift+ :ebx) + (:movzxw (:eax -2) :ecx) + + (:cmpw (:eax #.(bt:slot-offset 'movitz:movitz-vector 'movitz::num-elements)) :bx) + (:jae '(:sub-program () + (:compile-form (:result-mode :ignore) + (error "Index ~D out of bounds ~D." index (length vector))))) + + (:cmpl #.(movitz:vector-type-tag :any-t) :ecx) + (:jne 'not-any-t) + (:movl (:eax :ebx 2) :eax) + (:jmp 'done) + + not-any-t + (:cmpl #.(movitz:vector-type-tag :character) :ecx) + (:jne 'not-character) + (:shrl #.movitz::+movitz-fixnum-shift+ :ebx) + (: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) + (:jne 'not-u8) + (:shrl #.movitz::+movitz-fixnum-shift+ :ebx) + (:movzxb (:eax :ebx 2) :eax) ; u8 + (:shll #.movitz::+movitz-fixnum-shift+ :eax) + (:jmp 'done) + + not-u8 + (:cmpl #.(movitz:vector-type-tag :u16) :ecx) + (:je 'not-u16) + (:shrl #.(cl:1- movitz::+movitz-fixnum-shift+) :ebx) + (:movzxw (:eax :ebx 2) :eax) ; u16 + (:jmp 'done) + + not-u16 + (:cmpl #.(movitz:vector-type-tag :u32) :ecx) + (:je 'not-u32) + (:movl (:eax :ebx 2) :ecx) ; u32 + (:cmpl #.movitz::+movitz-most-positive-fixnum+ :ecx) + (:jg '(:sub-program (:overflowing-u32) + (:int 107))) + (:leal ((:ecx #.movitz::+movitz-fixnum-factor+)) :eax) + (:jmp 'done) + + not-u32 + (:compile-form (:result-mode :ignore) + (error "Not a vector: ~S" vector)) + + done)) + (t (vector &rest subscripts) + (declare (dynamic-extent subscripts) + (ignore vector subscripts)) + (error "Multi-dimensional arrays not implemented.")))) + +(defun (setf aref) (value vector &rest subscripts) + (numargs-case + (3 (value vector index) + (with-inline-assembly (:returns :ebx) + (:compile-form (:result-mode :ebx) value) + (:compile-form (:result-mode :eax) vector) + + (:leal (:eax #.(cl:- (movitz::tag :other))) :ecx) + (:testb 7 :cl) + (:jnz '(:sub-program () + (:compile-form (:result-mode :ignore) + (error "Not a vector: ~S" vector)))) + (:movzxw (:eax -2) :edx) + + (:compile-form (:result-mode :ecx) index) + (:testb #.movitz::+movitz-fixnum-zmask+ :cl) + (:jnz '(:sub-program () (:int 107))) ; index not fixnum + (:andl #.(cl:ash #xffff movitz::+movitz-fixnum-shift+) :ecx) + (:shrl #.movitz::+movitz-fixnum-shift+ :ecx) + + (: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) + + (: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-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) + + 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)) + (t (value vector &rest subscripts) + (declare (dynamic-extent subscripts) + (ignore value vector subscripts)) + (error "Multi-dimensional arrays not implemented.")))) ;;; simple-vector accessors @@ -329,7 +351,9 @@ `(setf (memref ,simple-vector 2 ,index :lisp) ,value)) (defun svref%unsafe (simple-vector index) - (svref%unsafe simple-vector index)) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) simple-vector index) + (:movl (:eax :ebx #.(bt:slot-offset 'movitz:movitz-vector 'movitz::data)) :eax))) (defun (setf svref%unsafe) (value simple-vector index) (setf (svref%unsafe simple-vector index) value)) @@ -447,10 +471,6 @@ (values #'u8ref%unsafe #'(setf u8ref%unsafe))) (#.(bt:enum-value 'movitz::movitz-vector-element-type :u32) (values #'u32ref%unsafe #'(setf u32ref%unsafe))) -;;; (#.(bt:enum-value 'movitz::movitz-vector-element-type :u16) -;;; '(unsigned-byte 16)) -;;; (#.(bt:enum-value 'movitz::movitz-vector-element-type :u32) -;;; '(unsigned-byte 32)) (t (warn "don't know about vector's element-type: ~S" vector) (values #'aref #'(setf aref)))))

1 0