May 2006 - movitz-cvs@common-lisp.net - mailman3.common-lisp.net

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 05 May '06

05 May '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv16015 Modified Files: more-macros.lisp Log Message: Fixed bug in member compiler-macro: Order of arguments to test was reversed. --- /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2006/05/02 20:03:47 1.33 +++ /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2006/05/05 18:33:08 1.34 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.33 2006/05/02 20:03:47 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.34 2006/05/05 18:33:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -155,14 +155,14 @@ `(do ((item ,item) (p ,list (cdr p))) ((endp p) nil) - (when (,test (car p) item) + (when (,test item (car p)) (return p)))) ((and test (symbolp test) key (symbolp key)) `(do ((item ,item) (p ,list (cdr p))) ((endp p) nil) - (when (,test (car p) (,key item)) + (when (,test (,key item) (car p)) (return p)))) (t form))))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 05 May '06

05 May '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv12742 Modified Files: arrays.lisp Log Message: Added bitref%unsafe accessor. --- /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2006/05/02 20:00:20 1.58 +++ /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2006/05/05 18:14:41 1.59 @@ -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.58 2006/05/02 20:00:20 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.59 2006/05/05 18:14:41 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -694,6 +694,26 @@ (declare (ignore vector subscripts)) (error "Multi-dimensional arrays not implemented.")))) +(defun bitref%unsafe (array index) + (macrolet + ((do-it () + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) array index) + (:testb ,movitz:+movitz-fixnum-zmask+ :bl) + (:jnz '(:sub-program (illegal-index) + (:compile-form (:result-mode :ignore) + (error "Illegal index: ~S." index)))) + :bit + (:movl :ebx :ecx) + (:movl :eax :ebx) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:xorl :eax :eax) + (:btl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))) + (:jnc 'return) + (:addl ,movitz:+movitz-fixnum-factor+ :eax) + return))) + (do-it))) + (defun (setf bit) (value vector &rest subscripts) (numargs-case @@ -767,6 +787,30 @@ (declare (ignore value vector subscripts)) (error "Multi-dimensional arrays not implemented.")))) +(defun (setf bitref%unsafe) (value vector index) + (macrolet + ((do-it () + `(progn + (check-type value bit) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) value vector) + (:compile-form (:result-mode :edx) index) + (:testb ,movitz:+movitz-fixnum-zmask+ :dl) + (:jnz '(:sub-program (not-an-index) + (:compile-form (:result-mode :ignore) + (error "Not a vector index: ~S." index)))) + (:movl :edx :ecx) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + + (:testl :eax :eax) + (:jnz 'set-one-bit) + (:btrl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))) + (:jmp 'return) + set-one-bit + (:btsl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))) + return)))) + (do-it))) + ;;; u8 accessors (define-compiler-macro u8ref%unsafe (vector index) @@ -830,7 +874,9 @@ (#.(bt:enum-value 'movitz::movitz-vector-element-type :u32) (values vector #'u32ref%unsafe #'(setf u32ref%unsafe))) (#.(bt:enum-value 'movitz::movitz-vector-element-type :code) - (values vector #'u8ref%unsafe #'(setf u8ref%unsafe))) + (values vector #'u8ref%unsafe #'(setf u8ref%unsafe))) + (#.(bt:enum-value 'movitz::movitz-vector-element-type :bit) + (values vector #'bitref%unsafe #'(setf bitref%unsafe))) (t (warn "don't know about vector's element-type: ~S" vector) (values vector #'aref #'(setf aref)))))))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 03 May '06

03 May '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv26386 Modified Files: lists.lisp Log Message: Fix member to accept nil key. Fix copy-list to accept dotted list. --- /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2006/04/29 11:41:34 1.14 +++ /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp 2006/05/03 22:20:02 1.15 @@ -9,7 +9,7 @@ ;;;; Created at: Tue Dec 5 18:40:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: lists.lisp,v 1.14 2006/04/29 11:41:34 ffjeld Exp $ +;;;; $Id: lists.lisp,v 1.15 2006/05/03 22:20:02 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -112,20 +112,21 @@ ;; That fact justifies this implementation.) (when (and (eq fast slow) (> n 0)) (return nil)))) -(defun member (item list &key (key 'identity) (test 'eql)) +(defun member (item list &key key (test 'eql)) (numargs-case (2 (item list) (do ((p list (cdr p))) ((endp p) nil) (when (eql item (car p)) (return p)))) - (t (item list &key (key 'identity) (test 'eql)) - (with-funcallable (key) - (with-funcallable (test) - (do ((p list (cdr p))) - ((endp p) nil) - (when (test item (key (car p))) - (return p)))))))) + (t (item list &key key (test 'eql)) + (let ((key (or key 'identity))) + (with-funcallable (key) + (with-funcallable (test) + (do ((p list (cdr p))) + ((endp p) nil) + (when (test item (key (car p))) + (return p))))))))) (defun last (list &optional (n 1)) ;; from the hyperspec.. @@ -198,10 +199,10 @@ (defun copy-list (list) (if (null list) nil - (let ((new-list (cons (pop list) nil))) + (let ((new-list (cons (pop list) list))) (do ((new-tail new-list (cdr new-tail))) - ((null list) new-list) - (setf (cdr new-tail) (cons (pop list) nil)))))) + ((atom list) new-list) + (setf (cdr new-tail) (cons (pop list) list)))))) (defun list (&rest objects) (numargs-case

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 02 May '06

02 May '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv16773 Modified Files: print.lisp Log Message: Fix write-to-string to actually return string. --- /project/movitz/cvsroot/movitz/losp/muerte/print.lisp 2006/04/07 21:54:23 1.22 +++ /project/movitz/cvsroot/movitz/losp/muerte/print.lisp 2006/05/02 20:04:15 1.23 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Sep 3 11:48:19 2001 ;;;; -;;;; $Id: print.lisp,v 1.22 2006/04/07 21:54:23 ffjeld Exp $ +;;;; $Id: print.lisp,v 1.23 2006/05/02 20:04:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -203,9 +203,9 @@ (defun write-to-string (object &rest args) (declare (dynamic-extent args)) - (apply 'write object - :stream (make-array 24 :element-type 'character :fill-pointer 0 :adjustable t) - args)) + (let ((string (make-array 24 :element-type 'character :fill-pointer 0 :adjustable t))) + (apply 'write object :stream string args) + string)) (defun internal-write (object) (let ((stream *standard-output*))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 02 May '06

02 May '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv16739 Modified Files: more-macros.lisp Log Message: Improve pushnew to accept test-not. --- /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2006/04/28 23:21:32 1.32 +++ /project/movitz/cvsroot/movitz/losp/muerte/more-macros.lisp 2006/05/02 20:03:47 1.33 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.32 2006/04/28 23:21:32 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.33 2006/05/02 20:03:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -63,22 +63,27 @@ `(setq ,place (cons ,item ,place)) form)) -(defmacro pushnew (&environment env item place &key (key ''identity) (test ''eq) test-not) - (when test-not - (error "Test-not not supported.")) - (multiple-value-bind (tmp-vars tmp-var-init-forms store-vars setter-form getter-form) - (get-setf-expansion place env) - (assert (= 1 (length store-vars)) () - "Can't pushnew a place with ~D cells." (length store-vars)) - (let ((store-var (first store-vars)) - (item-var (gensym "push-item-"))) - `(let ((,item-var ,item) - ,@(mapcar #'list tmp-vars tmp-var-init-forms)) - (let ((old-value ,getter-form)) - (if (not (member ,item-var old-value :key ,key :test ,test)) - (let ((,store-var (cons ,item-var old-value))) - ,setter-form) - old-value)))))) +(defmacro pushnew (&environment env item place &key (key nil keyp) (test nil testp) (test-not nil test-notp)) + (let ((testing + (cond + (testp (list :test test)) + (test-notp (list :test-not test-not)))) + (keying + (cond + (keyp (list :key key))))) + (multiple-value-bind (tmp-vars tmp-var-init-forms store-vars setter-form getter-form) + (get-setf-expansion place env) + (assert (= 1 (length store-vars)) () + "Can't pushnew a place with ~D cells." (length store-vars)) + (let ((store-var (first store-vars)) + (item-var (gensym "push-item-"))) + `(let ((,item-var ,item) + ,@(mapcar #'list tmp-vars tmp-var-init-forms)) + (let ((old-value ,getter-form)) + (if (not (member ,item-var old-value ,@keying ,@testing)) + (let ((,store-var (cons ,item-var old-value))) + ,setter-form) + old-value))))))) (defmacro remf (&environment env place indicator) (multiple-value-bind (tmp-vars tmp-var-init-forms store-vars setter-form getter-form)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 02 May '06

02 May '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv16690 Modified Files: interrupt.lisp Log Message: Map int 101 to "illegal keyword argument" error. --- /project/movitz/cvsroot/movitz/losp/muerte/interrupt.lisp 2005/09/01 22:53:53 1.49 +++ /project/movitz/cvsroot/movitz/losp/muerte/interrupt.lisp 2006/05/02 20:03:15 1.50 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.49 2005/09/01 22:53:53 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.50 2006/05/02 20:03:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -391,6 +391,10 @@ (ldb (byte 8 24) (dit-frame-ref nil dit-frame :ecx :unsigned-byte32)) code)))) + (101 + (error 'program-error + :format-control "Illegal keyword argument [eax: ~S]" + :format-arguments (list (dereference $eax)))) (108 (error 'throw-error :tag (dereference $eax))) (110

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 02 May '06

02 May '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv16528 Modified Files: integers.lisp Log Message: Added realp. --- /project/movitz/cvsroot/movitz/losp/muerte/integers.lisp 2006/04/07 21:35:32 1.121 +++ /project/movitz/cvsroot/movitz/losp/muerte/integers.lisp 2006/05/02 20:02:09 1.122 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.121 2006/04/07 21:35:32 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.122 2006/05/02 20:02:09 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -2260,3 +2260,6 @@ (defun rational (number) number) + +(defun realp (x) + (typep x 'real))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 02 May '06

02 May '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv16336 Modified Files: functions.lisp Log Message: Fix constantly compiler-macro. --- /project/movitz/cvsroot/movitz/losp/muerte/functions.lisp 2006/04/07 21:52:17 1.30 +++ /project/movitz/cvsroot/movitz/losp/muerte/functions.lisp 2006/05/02 20:01:46 1.31 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Mar 12 22:58:54 2002 ;;;; -;;;; $Id: functions.lisp,v 1.30 2006/04/07 21:52:17 ffjeld Exp $ +;;;; $Id: functions.lisp,v 1.31 2006/05/02 20:01:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -44,17 +44,11 @@ (case (translate-program value :muerte.cl :cl) ((t) `(function constantly-true)) ((nil) `(function constantly-false)) - (t `(make-prototyped-function (constantly ,value) - constantly-prototype - (value ,value)))))) - (t (let ((value-var (gensym "constantly-value-"))) - `(let ((,value-var ,value-form)) - (lambda (&rest ignore) - (declare (ignore ignore)) - ,value-var)))))) + (t form)))) + (t form))) (defun constantly (x) - (compiler-macro-call constantly x)) + (lambda () x)) (defun complement-prototype (&rest args) (declare (dynamic-extent args))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 02 May '06

02 May '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv16294 Modified Files: cons.lisp Log Message: Added the subst family of functions. --- /project/movitz/cvsroot/movitz/losp/muerte/cons.lisp 2006/05/02 17:12:20 1.14 +++ /project/movitz/cvsroot/movitz/losp/muerte/cons.lisp 2006/05/02 20:01:01 1.15 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 15:25:45 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: cons.lisp,v 1.14 2006/05/02 17:12:20 ffjeld Exp $ +;;;; $Id: cons.lisp,v 1.15 2006/05/02 20:01:01 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -288,7 +288,7 @@ ((atom subtree) subtree) (t (let ((car (s (car subtree))) (cdr (s (cdr subtree)))) - (if (and (eq car (car subtreE)) + (if (and (eq car (car subtree)) (eq cdr (cdr subtree))) subtree (cons car cdr)))))))) @@ -310,7 +310,68 @@ (if (setq temp (assoc (funcall key subtree) alist :test test)) (setf (cdr last) (cdr temp)))) (if (setq temp (assoc (funcall key subtree) alist :test test)) - (return (setf (Cdr last) (Cdr temp))) + (return (setf (Cdr last) (cdr temp))) (setf (car subtree) (s (car subtree))))) subtree)))) (s tree)))) + +(defun subst (new old tree &key key (test 'eql) test-not) + "=> new-tree" + (let ((test (if test-not (complement test-not) test)) + (key (or key 'identity))) + (labels ((do-subst (subtree) + (cond + ((funcall test old (funcall key subtree)) + new) + ((atom subtree) + subtree) + (t (cons (do-subst (car subtree)) + (do-subst (cdr subtree))))))) + (do-subst tree)))) + +(defun subst-if (new predicate tree &key key) + "=> new-tree" + (let ((key (or key 'identity))) + (labels ((do-subst (subtree) + (cond + ((funcall predicate (funcall key subtree)) + new) + ((atom subtree) + subtree) + (t (cons (do-subst (car subtree)) + (do-subst (cdr subtree))))))) + (do-subst tree)))) + +(defun subst-if-not (new predicate tree &key key) + (subst-if new (complement predicate) tree :key key)) + +(defun nsubst (new old tree &key key (test 'eql) test-not) + (let ((test (if test-not (complement test-not) test)) + (key (or key 'identity))) + (labels ((do-subst (subtree) + (cond + ((funcall test old (funcall key subtree)) + new) + ((atom subtree) + subtree) + (t (setf (car subtree) (do-subst (car subtree)) + (cdr subtree) (do-subst (cdr subtree))) + subtree)))) + (do-subst tree)))) + +(defun nsubst-if (new predicate tree &key key) + "=> new-tree" + (let ((key (or key 'identity))) + (labels ((do-subst (subtree) + (cond + ((funcall predicate (funcall key subtree)) + new) + ((atom subtree) + subtree) + (t (setf (car subtree) (do-subst (car subtree)) + (cdr subtree) (do-subst (cdr subtree))) + subtree)))) + (do-subst tree)))) + +(defun nsubst-if-not (new predicate tree &key key) + (nsubst-if new (complement predicate) tree :key key))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 02 May '06

02 May '06

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv16035 Modified Files: arrays.lisp Log Message: Added bit and sbit accessors. --- /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2006/04/07 21:47:44 1.57 +++ /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2006/05/02 20:00:20 1.58 @@ -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.57 2006/04/07 21:47:44 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.58 2006/05/02 20:00:20 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -620,6 +620,153 @@ (defun (setf char%unsafe) (value string index) (setf (char%unsafe string index) value)) +;;; bit accessors + +(defun bit (array &rest subscripts) + (numargs-case + (2 (array index) + (etypecase array + (indirect-vector + (with-indirect-vector (indirect array :check-type nil) + (aref (indirect displaced-to) (+ index (indirect displaced-offset))))) + (simple-bit-vector + (macrolet + ((do-it () + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) array index) + (:testb ,movitz:+movitz-fixnum-zmask+ :bl) + (:jnz '(:sub-program (illegal-index) + (:compile-form (:result-mode :ignore) + (error "Illegal index: ~S." index)))) + (:cmpl :ebx + (:eax ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements))) + (:jbe '(:sub-program (out-of-bounds) + (:compile-form (:result-mode :ignore) + (error "Index ~D is beyond vector length ~D." + index + (memref array + (movitz-type-slot-offset 'movitz-basic-vector 'num-elements)))))) + :bit + (:movl :ebx :ecx) + (:movl :eax :ebx) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:xorl :eax :eax) + (:btl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))) + (:jnc 'return) + (:addl ,movitz:+movitz-fixnum-factor+ :eax) + return))) + (do-it))))) + (t (vector &rest subscripts) + (declare (ignore vector subscripts)) + (error "Multi-dimensional arrays not implemented.")))) + +(defun sbit (array &rest subscripts) + (numargs-case + (2 (array index) + (check-type array simple-bit-vector) + (macrolet + ((do-it () + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) array index) + (:testb ,movitz:+movitz-fixnum-zmask+ :bl) + (:jnz '(:sub-program (illegal-index) + (:compile-form (:result-mode :ignore) + (error "Illegal index: ~S." index)))) + (:cmpl :ebx + (:eax ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements))) + (:jbe '(:sub-program (out-of-bounds) + (:compile-form (:result-mode :ignore) + (error "Index ~D is beyond vector length ~D." + index + (memref array + (movitz-type-slot-offset 'movitz-basic-vector 'num-elements)))))) + :bit + (:movl :ebx :ecx) + (:movl :eax :ebx) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:xorl :eax :eax) + (:btl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))) + (:jnc 'return) + (:addl ,movitz:+movitz-fixnum-factor+ :eax) + return))) + (do-it))) + (t (vector &rest subscripts) + (declare (ignore vector subscripts)) + (error "Multi-dimensional arrays not implemented.")))) + + +(defun (setf bit) (value vector &rest subscripts) + (numargs-case + (3 (value vector index) + (check-type value bit) + (etypecase vector + (indirect-vector + (with-indirect-vector (indirect vector :check-type nil) + (setf (aref (indirect displaced-to) (+ index (indirect displaced-offset))) + value))) + (simple-bit-vector + (macrolet + ((do-it () + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) value vector) + (:compile-form (:result-mode :edx) index) + (:testb ,movitz:+movitz-fixnum-zmask+ :dl) + (:jnz '(:sub-program (not-an-index) + (:compile-form (:result-mode :ignore) + (error "Not a vector index: ~S." index)))) + (:cmpl (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)) + :edx) + (:jnc '(:sub-program (illegal-index) + (:compile-form (:result-mode :ignore) + (error "Index ~S out of range." index)))) + (:movl :edx :ecx) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + + (:testl :eax :eax) + (:jnz 'set-one-bit) + (:btrl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))) + (:jmp 'return) + set-one-bit + (:btsl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))) + return))) + (do-it))))) + (t (value vector &rest subscripts) + (declare (ignore value vector subscripts)) + (error "Multi-dimensional arrays not implemented.")))) + +(defun (setf sbit) (value vector &rest subscripts) + (numargs-case + (3 (value vector index) + (check-type value bit) + (macrolet + ((do-it () + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) value vector) + (:compile-form (:result-mode :edx) index) + (:testb ,movitz:+movitz-fixnum-zmask+ :dl) + (:jnz '(:sub-program (not-an-index) + (:compile-form (:result-mode :ignore) + (error "Not a vector index: ~S." index)))) + (:cmpl (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)) + :edx) + (:jnc '(:sub-program (illegal-index) + (:compile-form (:result-mode :ignore) + (error "Index ~S out of range." index)))) + (:movl :edx :ecx) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + + (:testl :eax :eax) + (:jnz 'set-one-bit) + (:btrl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))) + (:jmp 'return) + set-one-bit + (:btsl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data))) + return))) + (do-it))) + (t (value vector &rest subscripts) + (declare (ignore value vector subscripts)) + (error "Multi-dimensional arrays not implemented.")))) + ;;; u8 accessors (define-compiler-macro u8ref%unsafe (vector index)

1 0