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

[movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp
by Frode Vatvedt Fjeld 24 May '04

24 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv27230 Modified Files: integers.lisp Log Message: Renamed normalize-u32-ecx to box-u32-ecx, and added primitive-function box-u32 that does the inverse. Improved aref and (setf aref) of u32-vectors accordingly. Date: Mon May 24 18:38:10 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.11 movitz/losp/muerte/integers.lisp:1.12 --- movitz/losp/muerte/integers.lisp:1.11 Mon May 24 10:58:51 2004 +++ movitz/losp/muerte/integers.lisp Mon May 24 18:38:03 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.11 2004/05/24 14:58:51 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.12 2004/05/24 22:38:03 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -807,7 +807,7 @@ (:movl :edi :eax) (:cld) (:pushl :edx) - (:call-global-constant normalize-u32-ecx) + (:call-global-constant box-u32-ecx) (:popl :ebx) (:jmp 'done) not-size1 @@ -827,7 +827,7 @@ (:movl :edi :eax) (:cld) (:pushl :edx) - (:call-global-constant normalize-u32-ecx) + (:call-global-constant box-u32-ecx) (:popl :ebx) (:jmp 'done) not-size2

1 0

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

24 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv28476 Modified Files: arrays.lisp Log Message: Renamed normalize-u32-ecx to box-u32-ecx, and added primitive-function box-u32 that does the inverse. Improved aref and (setf aref) of u32-vectors accordingly. Date: Mon May 24 17:51:52 2004 Author: ffjeld Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.21 movitz/losp/muerte/arrays.lisp:1.22 --- movitz/losp/muerte/arrays.lisp:1.21 Mon May 24 10:59:15 2004 +++ movitz/losp/muerte/arrays.lisp Mon May 24 17:51: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.21 2004/05/24 14:59:15 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.22 2004/05/24 21:51:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -240,10 +240,7 @@ (:cmpl ,(movitz:vector-type-tag :u32) :ecx) (:jne '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) + (:call-global-constant box-u32-ecx) (:jmp 'done) not-u32 @@ -329,15 +326,13 @@ not-u16 (:cmpl ,(movitz:vector-type-tag :u32) :edx) (:jnz 'not-u32) - (:testl ,(ldb (byte 32 0) - (- -1 (* #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) - (:movl :ebx (:eax (:ecx 4) ,(bt:slot-offset 'movitz:movitz-vector 'movitz::data))) - (:leal ((:ebx ,movitz:+movitz-fixnum-factor+)) :ebx) + ;; EBX=value, EAX=vector, ECX=index + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :edx) + (:xchgl :eax :ebx) + ;; EAX=value, EBX=vector, EDX=index + (:call-global-constant unbox-u32) + (:movl :ecx (:ebx (:edx 1) ,(bt:slot-offset 'movitz:movitz-vector 'movitz::data))) + (:movl :eax :ebx) (:jmp 'done) not-u32

1 0

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

24 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv1344 Modified Files: primitive-functions.lisp Log Message: Renamed normalize-u32-ecx to box-u32-ecx, and added primitive-function box-u32 that does the inverse. Improved aref and (setf aref) of u32-vectors accordingly. Date: Mon May 24 15:34:34 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.18 movitz/losp/muerte/primitive-functions.lisp:1.19 --- movitz/losp/muerte/primitive-functions.lisp:1.18 Mon May 24 10:58:56 2004 +++ movitz/losp/muerte/primitive-functions.lisp Mon May 24 15:34:34 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.18 2004/05/24 14:58:56 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.19 2004/05/24 19:34:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -505,8 +505,8 @@ (:ret))) -(define-primitive-function normalize-u32-ecx () - "Make u32 in ECX into a fixnum or bignum." +(define-primitive-function box-u32-ecx () + "Make u32 in ECX into a fixnum or bignum in EAX." (with-inline-assembly (:returns :multiple-values) (:cmpl #.movitz:+movitz-most-positive-fixnum+ :ecx) (:ja 'not-fixnum) @@ -514,6 +514,32 @@ (:ret) not-fixnum (:int 107))) ; not implemented by default! + +(define-primitive-function unbox-u32 () + "Coerce EAX into a u32 in ECX, or signal type error. +Preserve EAX, EBX, and EDX." + (macrolet + ((do-it () + `(with-inline-assembly (:returns :multiple-values) + (:testl ,(logior #x80000000 movitz:+movitz-fixnum-zmask+) + :eax) + (:jnz 'not-fixnum) + (:movl :eax :ecx) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:ret) + not-fixnum + (:leal (:eax ,(- (movitz:tag :other))) :ecx) + (:testb 7 :cl) + (:jnz 'fail) + (:cmpl ,(dpb 1 (byte 16 16) (movitz:tag :bignum 0)) + (:eax ,movitz:+other-type-offset+)) + (:jne 'fail) + (:movl (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) + :ecx) + (:ret) + fail + (:int 107)))) + (do-it))) ;;;;

1 0

[movitz-cvs] CVS update: movitz/losp/los0-gc.lisp
by Frode Vatvedt Fjeld 24 May '04

24 May '04

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv15649 Modified Files: los0-gc.lisp Log Message: Renamed normalize-u32-ecx to box-u32-ecx, and added primitive-function box-u32 that does the inverse. Improved aref and (setf aref) of u32-vectors accordingly. Date: Mon May 24 15:32:46 2004 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.11 movitz/losp/los0-gc.lisp:1.12 --- movitz/losp/los0-gc.lisp:1.11 Mon May 24 10:58:34 2004 +++ movitz/losp/los0-gc.lisp Mon May 24 15:32:46 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.11 2004/05/24 14:58:34 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.12 2004/05/24 19:32:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -72,7 +72,7 @@ (:movl :ecx (:edx 2)) (:ret))) -(define-primitive-function los0-normalize-u32-ecx () +(define-primitive-function los0-box-u32-ecx () "Make u32 in ECX into a fixnum or bignum." (macrolet ((do-it () @@ -157,9 +157,9 @@ (check-type conser vector) (setf (%run-time-context-slot 'muerte::fast-cons) conser)) - (let ((conser (symbol-value 'los0-normalize-u32-ecx))) + (let ((conser (symbol-value 'los0-box-u32-ecx))) (check-type conser vector) - (setf (%run-time-context-slot 'muerte::normalize-u32-ecx) + (setf (%run-time-context-slot 'muerte::box-u32-ecx) conser)) (let ((old-malloc (symbol-function 'muerte:malloc-clumps))) (setf (symbol-function 'muerte:malloc-clumps)

1 0

[movitz-cvs] CVS update: movitz/compiler.lisp
by Frode Vatvedt Fjeld 24 May '04

24 May '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv10397 Modified Files: compiler.lisp Log Message: Renamed normalize-u32-ecx to box-u32-ecx, and added primitive-function box-u32 that does the inverse. Improved aref and (setf aref) of u32-vectors accordingly. Date: Mon May 24 15:10:13 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.60 movitz/compiler.lisp:1.61 --- movitz/compiler.lisp:1.60 Mon May 24 10:58:00 2004 +++ movitz/compiler.lisp Mon May 24 15:10:12 2004 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.60 2004/05/24 14:58:00 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.61 2004/05/24 19:10:12 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -4788,7 +4788,7 @@ (case (result-mode-type desired-result) ((:eax :single-value) (values (append code - `((:call (:edi ,(global-constant-offset 'normalize-u32-ecx))))) + `((:call (:edi ,(global-constant-offset 'box-u32-ecx))))) desired-result)) (t (make-result-and-returns-glue desired-result :eax (make-result-and-returns-glue :eax :untagged-fixnum-ecx code

1 0

[movitz-cvs] CVS update: movitz/image.lisp
by Frode Vatvedt Fjeld 24 May '04

24 May '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv11810 Modified Files: image.lisp Log Message: Renamed normalize-u32-ecx to box-u32-ecx, and added primitive-function box-u32 that does the inverse. Improved aref and (setf aref) of u32-vectors accordingly. Date: Mon May 24 15:05:59 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.30 movitz/image.lisp:1.31 --- movitz/image.lisp:1.30 Mon May 24 10:58:12 2004 +++ movitz/image.lisp Mon May 24 15:05:59 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.30 2004/05/24 14:58:12 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.31 2004/05/24 19:05:59 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -226,7 +226,12 @@ :map-binary-write 'movitz-intern-code-vector :map-binary-read-delayed 'movitz-word-code-vector :binary-tag :primitive-function) - (normalize-u32-ecx + (box-u32-ecx + :binary-type code-vector-word + :map-binary-write 'movitz-intern-code-vector + :map-binary-read-delayed 'movitz-word-code-vector + :binary-tag :primitive-function) + (unbox-u32 :binary-type code-vector-word :map-binary-write 'movitz-intern-code-vector :map-binary-read-delayed 'movitz-word-code-vector

1 0

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

24 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv3725 Modified Files: arrays.lisp Log Message: Starting to add some bignum support. Date: Mon May 24 10:59:16 2004 Author: ffjeld Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.20 movitz/losp/muerte/arrays.lisp:1.21 --- movitz/losp/muerte/arrays.lisp:1.20 Fri May 21 05:41:58 2004 +++ movitz/losp/muerte/arrays.lisp Mon May 24 10:59:15 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.20 2004/05/21 09:41:58 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.21 2004/05/24 14:59:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -204,34 +204,34 @@ (:shrl ,movitz:+movitz-fixnum-shift+ :ebx) (:movzxw (:eax ,movitz:+other-type-offset+) :ecx) - (:cmpw (:eax #.(bt:slot-offset 'movitz:movitz-vector 'movitz::num-elements)) :bx) + (: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) + (: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) + (: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 + (:movb ,(movitz::tag :character) :al) ; character (:jmp 'done) not-character - (:cmpl #.(movitz:vector-type-tag :u8) :ecx) + (:cmpl ,(movitz:vector-type-tag :u8) :ecx) (:jne 'not-u8) (:movzxb (:eax :ebx 2) :eax) ; u8 - (:shll #.movitz::+movitz-fixnum-shift+ :eax) + (:shll ,movitz::+movitz-fixnum-shift+ :eax) (:jmp 'done) not-u8 - (:cmpl #.(movitz:vector-type-tag :u16) :ecx) + (:cmpl ,(movitz:vector-type-tag :u16) :ecx) (:jne 'not-u16) (:movzxw (:eax (:ebx 2) 2) :eax) ; u16 (:jmp 'done) @@ -265,7 +265,7 @@ (:compile-form (:result-mode :ebx) value) (:compile-form (:result-mode :eax) vector) - (:leal (:eax #.(cl:- (movitz::tag :other))) :ecx) + (:leal (:eax ,(- (movitz:tag :other))) :ecx) (:testb 7 :cl) (:jnz '(:sub-program () (:compile-form (:result-mode :ignore) @@ -273,24 +273,24 @@ (:movzxw (:eax ,movitz:+other-type-offset+) :edx) (:compile-form (:result-mode :ecx) index) - (:testb #.movitz::+movitz-fixnum-zmask+ :cl) + (: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) + (:andl ,(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) + (: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) + (: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) + (:cmpl ,(movitz:vector-type-tag :character) :edx) (:jnz 'not-character) - (:cmpb #.(movitz:tag :character) :bl) + (:cmpb ,(movitz:tag :character) :bl) (:jnz '(:sub-program (not-character-value) (:compile-form (:result-mode :ignore) (error "Value not character: ~S" value)))) @@ -298,40 +298,46 @@ (:jmp 'done) not-character - (:cmpl #.(movitz:vector-type-tag :u8) :edx) + (: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) + (:testl ,(cl:ldb (cl:byte 32 0) + (- -1 (* #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) + (: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) + (: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) + (:testl ,(ldb (byte 32 0) + (- -1 (* #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) + (: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) + (: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) + (:testl ,(ldb (byte 32 0) + (- -1 (* #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) - (:movl :ebx (:eax (:ecx 4) #.(bt:slot-offset 'movitz:movitz-vector 'movitz::data))) - (:leal ((:ebx #.movitz:+movitz-fixnum-factor+)) :ebx) + (:shrl ,movitz:+movitz-fixnum-shift+ :ebx) + (:movl :ebx (:eax (:ecx 4) ,(bt:slot-offset 'movitz:movitz-vector 'movitz::data))) + (:leal ((:ebx ,movitz:+movitz-fixnum-factor+)) :ebx) (:jmp 'done) not-u32

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp
by Frode Vatvedt Fjeld 24 May '04

24 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv3277 Modified Files: los-closette.lisp Log Message: Starting to add some bignum support. Date: Mon May 24 10:59:08 2004 Author: ffjeld Index: movitz/losp/muerte/los-closette.lisp diff -u movitz/losp/muerte/los-closette.lisp:1.10 movitz/losp/muerte/los-closette.lisp:1.11 --- movitz/losp/muerte/los-closette.lisp:1.10 Wed Apr 21 11:07:27 2004 +++ movitz/losp/muerte/los-closette.lisp Mon May 24 10:59:08 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Jul 23 14:29:10 2002 ;;;; -;;;; $Id: los-closette.lisp,v 1.10 2004/04/21 15:07:27 ffjeld Exp $ +;;;; $Id: los-closette.lisp,v 1.11 2004/05/24 14:59:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -908,7 +908,7 @@ (assert slot (slot-name) "No slot named ~S in class ~S." slot-name class) (let ((slot-location (slot-definition-location slot))) - (check-type slot-location (integer 0 *)) + (check-type slot-location (integer 0 #xffff)) (etypecase class (standard-class (if (and (< slot-location (length *standard-effective-slot-readers*))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp
by Frode Vatvedt Fjeld 24 May '04

24 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv27543 Modified Files: typep.lisp Log Message: Starting to add some bignum support. Date: Mon May 24 10:59:02 2004 Author: ffjeld Index: movitz/losp/muerte/typep.lisp diff -u movitz/losp/muerte/typep.lisp:1.11 movitz/losp/muerte/typep.lisp:1.12 --- movitz/losp/muerte/typep.lisp:1.11 Mon Apr 19 15:51:01 2004 +++ movitz/losp/muerte/typep.lisp Mon May 24 10:59:01 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.11 2004/04/19 19:51:01 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.12 2004/05/24 14:59:01 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -170,10 +170,22 @@ ((t) 't) ((nil) 'nil) (null `(not ,object)) - ((fixnum integer number) + ((fixnum) `(with-inline-assembly (:returns :boolean-zf=1) (:compile-form (:result-mode :eax) ,object) (:testb ,movitz::+movitz-fixnum-zmask+ :al))) + ((integer number rational) + `(with-inline-assembly-case () + (do-case (t :boolean-zf=1 :labels (done)) + (:compile-form (:result-mode :eax) ,object) + (:testb ,movitz:+movitz-fixnum-zmask+ :al) + (:jz 'done) + (:leal (:eax ,(- (movitz:tag :other))) :ecx) + (:testb 7 :cl) + (:jnz 'done) + (:cmpb ,(movitz:tag :bignum) + (:eax ,movitz:+other-type-offset+)) + done))) (symbol `(with-inline-assembly (:returns :boolean-zf=1) (:compile-form (:result-mode :eax) ,object) @@ -246,17 +258,59 @@ ((integer) (destructuring-bind (&optional (lower-limit '*) (upper-limit '*)) (cdr type) - (let* ((min movitz:+movitz-most-negative-fixnum+) - (max movitz:+movitz-most-positive-fixnum+) - (lower-limit (if (eq lower-limit '*) min lower-limit)) - (upper-limit (if (eq upper-limit '*) max upper-limit))) - (assert (<= lower-limit upper-limit) () - "The lower limit of an integer type must be smaller than the upper limit.") + (let* ((lower-limit (if (eq lower-limit '*) nil lower-limit)) + (upper-limit (if (eq upper-limit '*) nil upper-limit))) + (assert (or (null lower-limit) + (null upper-limit) + (<= lower-limit upper-limit)) () + "The lower limit must be smaller than the upper limit.") + ;; (warn "upper: ~S, loweR: ~S" upper-limit lower-limit) (cond - ((and (= lower-limit min) (= upper-limit max)) + ((and (null lower-limit) (null upper-limit)) `(typep ,object 'integer)) + ((null lower-limit) + `(let ((x ,object)) + (and (typep x 'integer) (<= x upper-limit)))) + ((and (null upper-limit) + (= (1+ movitz:+movitz-most-positive-fixnum+) lower-limit)) + `(with-inline-assembly-case () + (do-case (t :boolean-zf=1 :labels (plusp-ok)) + (:compile-form (:result-mode :eax) ,object) + (:leal (:eax ,(- (movitz:tag :other))) :ecx) + (:testb 7 :cl) + (:jnz 'plusp-ok) + (:cmpw ,(movitz:tag :bignum 0) + (:eax ,movitz:+other-type-offset+)) + plusp-ok))) + ((and (null upper-limit) (= 0 lower-limit)) + `(with-inline-assembly-case () + (do-case (t :boolean-zf=1 :labels (plusp-ok)) + (:compile-form (:result-mode :eax) ,object) + (:testl ,(logxor #xffffffff + (ash movitz:+movitz-most-positive-fixnum+ + movitz:+movitz-fixnum-shift+)) + :eax) + (:jz 'plusp-ok) + (:leal (:eax ,(- (movitz:tag :other))) :ecx) + (:testb 7 :cl) + (:jnz 'plusp-ok) + (:cmpw ,(movitz:tag :bignum 0) + (:eax ,movitz:+other-type-offset+)) + plusp-ok))) + ((null upper-limit) + `(let ((x ,object)) + (and (typep x 'integer) (>= x ,lower-limit)))) ((= lower-limit upper-limit) `(eql ,object ,lower-limit)) + ((or (not (<= movitz:+movitz-most-negative-fixnum+ + upper-limit + movitz:+movitz-most-positive-fixnum+)) + (not (<= movitz:+movitz-most-negative-fixnum+ + lower-limit + movitz:+movitz-most-positive-fixnum+))) + `(let ((x ,object)) + (and (typep x 'integer) + (<= ,lower-limit x ,upper-limit)))) ((and (= lower-limit 0) (= 1 (logcount (1+ upper-limit)))) `(with-inline-assembly (:returns :boolean-zf=1)

1 0

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

24 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv24737 Modified Files: primitive-functions.lisp Log Message: Starting to add some bignum support. Date: Mon May 24 10:58:56 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.17 movitz/losp/muerte/primitive-functions.lisp:1.18 --- movitz/losp/muerte/primitive-functions.lisp:1.17 Fri May 21 05:41:11 2004 +++ movitz/losp/muerte/primitive-functions.lisp Mon May 24 10:58:56 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.17 2004/05/21 09:41:11 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.18 2004/05/24 14:58:56 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -441,8 +441,8 @@ (defun malloc-initialize (buffer-start buffer-size) "BUFFER-START: the (fixnum) 4K address. BUFFER-SIZE: The size in 4K units." - (check-type buffer-start integer) - (check-type buffer-size integer) + (check-type buffer-start fixnum) + (check-type buffer-size fixnum) (with-inline-assembly (:returns :nothing) (:compile-form (:result-mode :eax) buffer-start) (:shll #.(cl:- 12 movitz::+movitz-fixnum-shift+) :eax) @@ -504,6 +504,17 @@ return-ok (:ret))) + +(define-primitive-function normalize-u32-ecx () + "Make u32 in ECX into a fixnum or bignum." + (with-inline-assembly (:returns :multiple-values) + (:cmpl #.movitz:+movitz-most-positive-fixnum+ :ecx) + (:ja 'not-fixnum) + (:leal ((:ecx #.movitz:+movitz-fixnum-factor+)) :eax) + (:ret) + not-fixnum + (:int 107))) ; not implemented by default! + ;;;; (define-primitive-function fast-class-of-even-fixnum () @@ -566,32 +577,42 @@ (:globally (:movl (:edi (:edi-offset classes)) :ebx)) (:cmpl :edi :eax) (:je 'null) - (:movl (:ebx #.(movitz::class-object-offset 'illegal-object)) :eax) + (:movl (:ebx #.(movitz:class-object-offset 'illegal-object)) :eax) (:jmp 'not-null) null - (:movl (:ebx #.(movitz::class-object-offset 'null)) :eax) + (:movl (:ebx #.(movitz:class-object-offset 'null)) :eax) not-null (:ret))) (define-primitive-function fast-class-of-other () "Return the class of an other object." - (with-inline-assembly (:returns :multiple-values) - (:movl (:eax #.movitz:+other-type-offset+) :ecx) - (:cmpb #.(movitz::tag :std-instance) :cl) - (:jne 'not-std-instance) - (:movl (:eax #.(bt:slot-offset 'movitz::movitz-std-instance 'movitz::class)) :eax) - (:ret) - not-std-instance - (:cmpw #.(cl:+ (movitz::tag :funobj) - (cl:ash (bt:enum-value 'movitz::movitz-funobj-type :generic-function) 8)) - :cx) - (:jne 'not-std-gf-instance) - (:movl (:eax #.(bt:slot-offset 'movitz::movitz-funobj-standard-gf 'movitz::standard-gf-class)) - :eax) - (:ret) - not-std-gf-instance - (:globally (:movl (:edi (:edi-offset complicated-class-of)) :esi)) - (:jmp (:esi #.(bt:slot-offset 'movitz::movitz-funobj 'movitz::code-vector%1op))))) + (macrolet + ((do-it () + `(with-inline-assembly (:returns :multiple-values) + (:movl (:eax ,movitz:+other-type-offset+) :ecx) + (:cmpb ,(movitz:tag :std-instance) :cl) + (:jne 'not-std-instance) + (:movl (:eax ,(bt:slot-offset 'movitz::movitz-std-instance 'movitz::class)) :eax) + (:ret) + not-std-instance + (:cmpw ,(+ (movitz:tag :funobj) + (ash (bt:enum-value 'movitz::movitz-funobj-type :generic-function) 8)) + :cx) + (:jne 'not-std-gf-instance) + (:movl (:eax ,(bt:slot-offset 'movitz::movitz-funobj-standard-gf + 'movitz::standard-gf-class)) + :eax) + (:ret) + not-std-gf-instance + (:globally (:movl (:edi (:edi-offset classes)) :ebx)) + (:cmpb ,(movitz:tag :bignum) :cl) + (:jne 'not-bignum) + (:movl (:ebx ,(movitz:class-object-offset 'integer)) :eax) + (:ret) + not-bignum + (:globally (:movl (:edi (:edi-offset complicated-class-of)) :esi)) + (:jmp (:esi ,(bt:slot-offset 'movitz::movitz-funobj 'movitz::code-vector%1op)))))) + (do-it))) (defun complicated-class-of (object) (typecase object

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp
by Frode Vatvedt Fjeld 24 May '04

24 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv23968 Modified Files: integers.lisp Log Message: Starting to add some bignum support. Date: Mon May 24 10:58:51 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.10 movitz/losp/muerte/integers.lisp:1.11 --- movitz/losp/muerte/integers.lisp:1.10 Wed May 19 11:42:08 2004 +++ movitz/losp/muerte/integers.lisp Mon May 24 10:58:51 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.10 2004/05/19 15:42:08 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.11 2004/05/24 14:58:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -22,6 +22,12 @@ (defconstant most-positive-fixnum #.movitz::+movitz-most-positive-fixnum+) (defconstant most-negative-fixnum #.movitz::+movitz-most-negative-fixnum+) +(deftype positive-fixnum () + `(integer 0 ,movitz:+movitz-most-positive-fixnum+)) + +(deftype positive-bignum () + `(integer ,(1+ movitz:+movitz-most-positive-fixnum+) *)) + (defun fixnump (x) (typep x 'fixnum)) @@ -242,10 +248,26 @@ "Compare real <n1> with fixnum <n2>." (with-inline-assembly (:returns :nothing) ; unspecified (:testb #.movitz::+movitz-fixnum-zmask+ :al) + (:jnz 'not-fixnum) + (:cmpl :ebx :eax) + (:ret) + not-fixnum + (:leal (:eax #.(cl:- (movitz:tag :other))) :ecx) + (:testb 7 :cl) (:jnz '(:sub-program (not-integer) (:int 107) (:jmp 'not-integer))) - (:cmpl :ebx :eax) + (:movl (:eax #.movitz:+other-type-offset+) :ecx) + (:cmpw #.(movitz:tag :bignum 0) :cx) + (:jne 'not-plusbignum) + ;; compare ebx with something bigger + (:cmpl #x-10000000 :edi) + (:ret) + not-plusbignum + (:cmpw #.(movitz:tag :bignum #xff) :cx) + (:jne 'not-integer) + ;; compare ebx with something bigger + (:cmpl #x10000000 :edi) (:ret))) ;;; @@ -256,8 +278,8 @@ (movitz:movitz-constantp max env)) (let ((min (movitz:movitz-eval min env)) (max (movitz:movitz-eval max env))) - (check-type min integer) - (check-type max integer) + (check-type min fixnum) + (check-type max fixnum) ;; (warn "~D -- ~D" min max) (cond ((movitz:movitz-constantp x env) @@ -296,7 +318,7 @@ #+ignore ; this is buggy. ((movitz:movitz-constantp min env) (let ((min (movitz:movitz-eval min env))) - (check-type min integer) + (check-type min fixnum) (cond ((minusp min) `(let ((x ,x)) @@ -372,7 +394,7 @@ (declare (dynamic-extent more-numbers)) (cond ((null more-numbers) - (check-type number integer) + (check-type number fixnum) t) ((not (cdr more-numbers)) (,2op-name number (first more-numbers))) @@ -514,7 +536,7 @@ (if (< number1 number2) number2 number1)) (let ((label (gensym))) - `(with-inline-assembly (:returns :eax :type integer) + `(with-inline-assembly (:returns :eax :type fixnum) (:compile-two-forms (:eax :ebx) ,number1 ,number2) (:movl :ebx :ecx) (:orl :eax :ecx) @@ -650,7 +672,7 @@ `(*%2op ,(movitz:movitz-eval factor2 env) ,factor1)) ((movitz:movitz-constantp factor1 env) (let ((f1 (movitz:movitz-eval factor1 env))) - (check-type f1 integer) + (check-type f1 fixnum) (case f1 (0 `(progn ,factor2 0)) (1 factor2) @@ -708,9 +730,9 @@ `(do-result-mode-case () (:plural (no-macro-call ,@form)) - (t (truncate%2ops%1ret ,number ,divisor)))) + (t (truncate%1ret ,number ,divisor)))) -(defun truncate%2ops%1ret (number divisor) +(defun truncate%1ret (number divisor) (with-inline-assembly (:returns :multiple-values) (:compile-form (:result-mode :eax) number) (:compile-form (:result-mode :ebx) divisor) @@ -723,7 +745,7 @@ (:shll #.movitz::+movitz-fixnum-shift+ :eax) (:clc))) -(define-compiler-macro truncate%2ops%1ret (&whole form &environment env number divisor) +(define-compiler-macro truncate%1ret (&whole form &environment env number divisor) (cond ((movitz:movitz-constantp divisor env) (let ((d (movitz:movitz-eval divisor env))) @@ -731,7 +753,7 @@ (case d (0 (error "Truncate by zero.")) (1 number) - (t `(with-inline-assembly (:returns :eax :type integer) + (t `(with-inline-assembly (:returns :eax :type fixnum) (:compile-form (:result-mode :eax) ,number) (:compile-form (:result-mode :ebx) ,divisor) (:testb #.movitz::+movitz-fixnum-zmask+ :al) @@ -741,26 +763,116 @@ (:shll #.movitz::+movitz-fixnum-shift+ :eax)))))) (t form))) +(defmacro number-double-dispatch ((x y) &rest clauses) + `(let ((x ,x) (y ,y)) + (cond ,@(loop for ((x-type y-type) . then-body) in clauses + collect `((and (typep x ',x-type) (typep y ',y-type)) + ,@then-body)) + (t (error "Not numbers: ~S or ~S." x y))))) + (defun truncate (number &optional (divisor 1)) (numargs-case (1 (number) (values number 0)) (t (number divisor) - (with-inline-assembly (:returns :multiple-values) - (:compile-form (:result-mode :eax) number) - (:compile-form (:result-mode :ebx) divisor) - (:movl :eax :ecx) - (:orl :ebx :ecx) - (:testb #.movitz::+movitz-fixnum-zmask+ :cl) - (:jnz '(:sub-program (not-integer) (:int 107))) - (:cdq :eax :edx) - (:idivl :ebx :eax :edx) - (:shll #.movitz::+movitz-fixnum-shift+ :eax) - (:movl :edx :ebx) - (:xorl :ecx :ecx) - (:movb 2 :cl) ; return values: qutient, remainder. - (:stc))))) - + (number-double-dispatch (number divisor) + ((fixnum fixnum) + (with-inline-assembly (:returns :multiple-values) + (:compile-form (:result-mode :eax) number) + (:compile-form (:result-mode :ebx) divisor) + (:std) + (:cdq :eax :edx) + (:idivl :ebx :eax :edx) + (:shll #.movitz::+movitz-fixnum-shift+ :eax) + (:cld) + (:movl :edx :ebx) + (:xorl :ecx :ecx) + (:movb 2 :cl) ; return values: qutient, remainder. + (:stc))) + ((positive-bignum positive-fixnum) + (let (r n) + (with-inline-assembly (:returns :multiple-values) + (:compile-form (:result-mode :ebx) number) + (:movzxw (:ebx #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx) + (:cmpl 1 :ecx) + (:jne 'not-size1) + (:compile-form (:result-mode :ecx) divisor) + (:shrl #.movitz:+movitz-fixnum-shift+ :ecx) + (:std) + (:movl (:ebx #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) :eax) + (:xorl :edx :edx) + (:divl :ecx :eax :edx) + (:movl :eax :ecx) + (:shll #.movitz:+movitz-fixnum-shift+ :edx) + (:movl :edi :eax) + (:cld) + (:pushl :edx) + (:call-global-constant normalize-u32-ecx) + (:popl :ebx) + (:jmp 'done) + not-size1 + (:cmpl 2 :ecx) + (:jne 'not-size2) + (:compile-form (:result-mode :ecx) divisor) + (:shrl #.movitz:+movitz-fixnum-shift+ :ecx) + (:std) + (:movl (:ebx #.(cl:+ 4 (bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0))) + :edx) + (:cmpl :ecx :edx) + (:jae 'not-size2) + (:movl (:ebx #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0)) :eax) + (:divl :ecx :eax :edx) + (:movl :eax :ecx) + (:shll #.movitz:+movitz-fixnum-shift+ :edx) + (:movl :edi :eax) + (:cld) + (:pushl :edx) + (:call-global-constant normalize-u32-ecx) + (:popl :ebx) + (:jmp 'done) + not-size2 + (:cmpl :ecx (:ebx #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0) + -4 (:ecx 4))) + (:jc 'shrink-not-size2) + not-shrink + (:leal ((:ecx #.movitz:+movitz-fixnum-factor+)) :eax) + (:compile-form (:result-mode :eax) + (malloc-words (with-inline-assembly (:returns :eax)))) + (:store-lexical (:lexical-binding r) :eax :type t) + (:compile-form (:result-mode :ebx) number) + (:movl (:ebx #.movitz:+other-type-offset+) :ecx) + (:movl :ecx (:eax #.movitz:+other-type-offset+)) + (:shrl 16 :ecx) + + (:xorl :edx :edx) ; edx=hi-digit=0 + ; eax=lo-digit=msd(number) + (:std) + (:compile-form (:result-mode :esi) divisor) + (:shrl #.movitz:+movitz-fixnum-shift+ :esi) + + divide-loop + (:load-lexical (:lexical-binding number) :ebx) + (:movl (:ebx #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0) + -4 (:ecx 4)) + :eax) + (:divl :esi :eax :edx) + (:load-lexical (:lexical-binding r) :ebx) + (:movl :eax (:ebx #.(bt:slot-offset 'movitz::movitz-bignum 'movitz::bigit0) + -4 (:ecx 4))) + (:subl 1 :ecx) + (:jnz 'divide-loop) + (:movl :ebx :eax) + (:leal ((:edx #.movitz:+movitz-fixnum-factor+)) :ebx) + (:movl :edi :edx) + (:movl (:ebp -4) :esi) + (:cld) + (:jmp 'done) + shrink-not-size2 + (:int 107) + done + (:movl 2 :ecx) + (:stc)))) + )))) (defun round (number &optional (divisor 1)) "Mathematical rounding." @@ -1147,4 +1259,4 @@ (values q 0)) (t (values (1- q) (+ r divisor)))))) (t (n &optional (divisor 1)) - (floor n divisor)))) \ No newline at end of file + (floor n divisor))))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/print.lisp
by Frode Vatvedt Fjeld 24 May '04

24 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv23769 Modified Files: print.lisp Log Message: Starting to add some bignum support. Date: Mon May 24 10:58:44 2004 Author: ffjeld Index: movitz/losp/muerte/print.lisp diff -u movitz/losp/muerte/print.lisp:1.8 movitz/losp/muerte/print.lisp:1.9 --- movitz/losp/muerte/print.lisp:1.8 Wed Apr 21 11:07:48 2004 +++ movitz/losp/muerte/print.lisp Mon May 24 10:58:44 2004 @@ -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.8 2004/04/21 15:07:48 ffjeld Exp $ +;;;; $Id: print.lisp,v 1.9 2004/05/24 14:58:44 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -83,7 +83,8 @@ (write-digit (rem x base) stream)))) (defun write-lowlevel-integer (x stream base comma-char comma-interval mincol padchar sign-char pos) - (let ((bigit (truncate x base))) + (multiple-value-bind (bigit rem) + (truncate x base) (cond ((zerop bigit) (when mincol @@ -94,8 +95,8 @@ (when sign-char (write-char sign-char stream))) (t (write-lowlevel-integer bigit stream base comma-char comma-interval - mincol padchar sign-char (1+ pos))))) - (write-digit (rem x base) stream) + mincol padchar sign-char (1+ pos)))) + (write-digit rem stream)) (when (and comma-interval (plusp pos) (zerop (rem pos comma-interval))) (write-char comma-char stream)) nil) @@ -239,7 +240,8 @@ (if (and (plusp (length name)) (every (lambda (c) (or (upper-case-p c) - (member c '(#\- #\% #\$ #\* #\@ #\. #\& #\< #\> #\=)) + (member c '(#\+ #\- #\% #\$ #\* #\@ #\. #\& + #\/ #\< #\> #\=)) (digit-char-p c))) name) (not (every (lambda (c)

1 0

[movitz-cvs] CVS update: movitz/losp/los0.lisp
by Frode Vatvedt Fjeld 24 May '04

24 May '04

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv23601 Modified Files: los0.lisp Log Message: Starting to add some bignum support. Date: Mon May 24 10:58:39 2004 Author: ffjeld Index: movitz/losp/los0.lisp diff -u movitz/losp/los0.lisp:1.13 movitz/losp/los0.lisp:1.14 --- movitz/losp/los0.lisp:1.13 Fri Apr 23 11:04:07 2004 +++ movitz/losp/los0.lisp Mon May 24 10:58:39 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 1 18:08:32 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: los0.lisp,v 1.13 2004/04/23 15:04:07 ffjeld Exp $ +;;;; $Id: los0.lisp,v 1.14 2004/05/24 14:58:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -262,6 +262,24 @@ exit (warn "exited: ~S" c))) + +(defun test-bignum () + 123456789123456) + +(defun ff32 () + #xffffffff) + +(defun one32 () + #x100000000) + +(defun test-nbignum () + -123456789123456) + +(defun gt5 (x) + (<= x 5)) + +(defun xplus (x) + (typep x '(integer 0 *))) (defstruct xxx x y (z 'init-z))

1 0

[movitz-cvs] CVS update: movitz/losp/los0-gc.lisp
by Frode Vatvedt Fjeld 24 May '04

24 May '04

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv23392 Modified Files: los0-gc.lisp Log Message: Starting to add some bignum support. Date: Mon May 24 10:58:35 2004 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.10 movitz/losp/los0-gc.lisp:1.11 --- movitz/losp/los0-gc.lisp:1.10 Fri Apr 16 10:44:42 2004 +++ movitz/losp/los0-gc.lisp Mon May 24 10:58:34 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.10 2004/04/16 14:44:42 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.11 2004/05/24 14:58:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -72,6 +72,33 @@ (:movl :ecx (:edx 2)) (:ret))) +(define-primitive-function los0-normalize-u32-ecx () + "Make u32 in ECX into a fixnum or bignum." + (macrolet + ((do-it () + `(with-inline-assembly (:returns :multiple-values) + (:cmpl ,movitz:+movitz-most-positive-fixnum+ :ecx) + (:ja 'not-fixnum) + (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :eax) + (:ret) + not-fixnum + retry-cons + (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) + (:movl (:edx 2) :eax) + (:cmpl #x3fff4 :eax) + (:jge '(:sub-program () + (:int 113) ; This interrupt can be retried. + (:jmp 'retry-cons))) + (:movl ,(dpb 1 (byte 16 16) (movitz:tag :bignum 0)) + (:edx :eax 2)) + (:movl :ecx (:edx :eax 6)) + (:addl 8 :eax) + (:movl :eax (:edx 2)) + (:leal (:edx :eax) :eax) + (:ret) + (:int 107)))) + (do-it))) + (defun los0-malloc-clumps (clumps) (check-type clumps (integer 0 4000)) (with-inline-assembly (:returns :eax) @@ -129,6 +156,10 @@ (let ((conser (symbol-value 'los0-fast-cons))) (check-type conser vector) (setf (%run-time-context-slot 'muerte::fast-cons) + conser)) + (let ((conser (symbol-value 'los0-normalize-u32-ecx))) + (check-type conser vector) + (setf (%run-time-context-slot 'muerte::normalize-u32-ecx) conser)) (let ((old-malloc (symbol-function 'muerte:malloc-clumps))) (setf (symbol-function 'muerte:malloc-clumps)

1 0

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

24 May '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv22784 Modified Files: packages.lisp Log Message: Starting to add some bignum support. Date: Mon May 24 10:58:27 2004 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.22 movitz/packages.lisp:1.23 --- movitz/packages.lisp:1.22 Fri May 21 05:39:40 2004 +++ movitz/packages.lisp Mon May 24 10:58:27 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.22 2004/05/21 09:39:40 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.23 2004/05/24 14:58:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1283,6 +1283,7 @@ (:export #:create-image #:dump-image + #:class-object-offset #:other-type-byte #:+other-type-offset+ #:parse-docstring-and-declarations

1 0

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

24 May '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv22002 Modified Files: storage-types.lisp Log Message: Starting to add some bignum support. Date: Mon May 24 10:58:22 2004 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.17 movitz/storage-types.lisp:1.18 --- movitz/storage-types.lisp:1.17 Fri May 21 05:39:30 2004 +++ movitz/storage-types.lisp Mon May 24 10:58:22 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.17 2004/05/21 09:39:30 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.18 2004/05/24 14:58:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -74,6 +74,7 @@ :run-time-context #x50 :illegal #x13 :infant-object #x23 + :bignum #x4a ;; :simple-vector #x20 ;; :character-vector @@ -84,8 +85,9 @@ (defconstant +fixnum-tags+ '(:even-fixnum :odd-fixnum)) (defparameter +scan-skip-word+ #x00000003) -(defun tag (type) - (bt:enum-value 'other-type-byte type)) +(defun tag (type &optional (wide-tag 0)) + (logior (bt:enum-value 'other-type-byte type) + (ash wide-tag 8))) (defun tag-name (number) (bt:enum-symbolic-value 'other-type-byte number)) @@ -1289,3 +1291,42 @@ :stream stream)))) object) +;;;; + +(define-binary-class movitz-bignum (movitz-heap-object-other) + ((type + :binary-type other-type-byte + :initform :bignum) + (sign + :binary-type u8 + :initarg :sign + :accessor movitz-bignum-sign) + (length + :binary-type lu16 + :initarg :length + :accessor movitz-bignum-length) + (bigit0 :binary-type :label) + (value + :initarg :value + :accessor movitz-bignum-value)) + (:slot-align type #.+other-type-offset+)) + +(defmethod write-binary-record ((obj movitz-bignum) stream) + (let* ((num (movitz-bignum-value obj)) + (length (ceiling (integer-length (abs num)) 32))) + (check-type length (unsigned-byte 16)) + (setf (movitz-bignum-length obj) length + (movitz-bignum-sign obj) (if (minusp num) #xff #x00)) + (+ (call-next-method) ; header + (loop for b from 0 below length + summing (write-binary 'lu32 stream (ldb (byte 32 (* b 32)) (abs num))))))) + +(defun make-movitz-integer (value) + (if (<= +movitz-most-negative-fixnum+ value +movitz-most-positive-fixnum+) + (make-movitz-fixnum value) + (make-instance 'movitz-bignum + :value value))) + +(defmethod sizeof ((obj movitz-bignum)) + (+ (sizeof 'movitz-bignum) + (* 4 (ceiling (integer-length (abs (movitz-bignum-value obj))) 32))))

1 0

[movitz-cvs] CVS update: movitz/movitz-mode.el
by Frode Vatvedt Fjeld 24 May '04

24 May '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv21530 Modified Files: movitz-mode.el Log Message: Starting to add some bignum support. Date: Mon May 24 10:58:17 2004 Author: ffjeld Index: movitz/movitz-mode.el diff -u movitz/movitz-mode.el:1.5 movitz/movitz-mode.el:1.6 --- movitz/movitz-mode.el:1.5 Wed May 19 10:57:46 2004 +++ movitz/movitz-mode.el Mon May 24 10:58:17 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu Sep 27 18:12:17 2001 ;;;; -;;;; $Id: movitz-mode.el,v 1.5 2004/05/19 14:57:46 ffjeld Exp $ +;;;; $Id: movitz-mode.el,v 1.6 2004/05/24 14:58:17 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -301,6 +301,7 @@ (put 'vector-double-dispatch tag '(like case)) (put 'sequence-dispatch tag '(like case)) (put 'sequence-double-dispatch tag '(like case)) + (put 'number-double-dispatch tag '(like case)) (put 'simple-stream-dispatch tag '(like case)) (put 'with-inline-assembly tag '(like prog)) (put 'with-inline-assembly-case tag '(like prog))

1 0

[movitz-cvs] CVS update: movitz/image.lisp
by Frode Vatvedt Fjeld 24 May '04

24 May '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv21343 Modified Files: image.lisp Log Message: Starting to add some bignum support. Date: Mon May 24 10:58:12 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.29 movitz/image.lisp:1.30 --- movitz/image.lisp:1.29 Fri May 21 05:38:52 2004 +++ movitz/image.lisp Mon May 24 10:58:12 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.29 2004/05/21 09:38:52 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.30 2004/05/24 14:58:12 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -226,6 +226,11 @@ :map-binary-write 'movitz-intern-code-vector :map-binary-read-delayed 'movitz-word-code-vector :binary-tag :primitive-function) + (normalize-u32-ecx + :binary-type code-vector-word + :map-binary-write 'movitz-intern-code-vector + :map-binary-read-delayed 'movitz-word-code-vector + :binary-tag :primitive-function) (malloc :binary-type code-vector-word :map-binary-write 'movitz-intern-code-vector @@ -543,6 +548,7 @@ (defmethod image-classes-map ((image symbolic-image)) '(muerte.cl:null muerte.cl:cons muerte.cl:fixnum muerte.cl:symbol muerte.cl:character muerte.cl:function muerte.cl:condition + muerte.cl:integer muerte.cl:ratio muerte.cl:vector muerte.cl:string muerte.cl:array muerte.cl:class muerte.cl:standard-class muerte.cl:standard-generic-function @@ -553,9 +559,10 @@ muerte:illegal-object)) (defun class-object-offset (name) - (+ (bt:slot-offset 'movitz-vector 'data) - (* 4 (1+ (or (position name (image-classes-map *image*)) - (error "No class named ~S in class-map." name)))))) + (let ((name (translate-program name :cl :muerte.cl))) + (+ (bt:slot-offset 'movitz-vector 'data) + (* 4 (1+ (or (position name (image-classes-map *image*)) + (error "No class named ~S in class-map." name))))))) (defun unbound-value () (declare (special *image*)) @@ -1361,7 +1368,7 @@ (null *movitz-nil*) ((member t) (movitz-read 'muerte.cl:t)) (symbol (intern-movitz-symbol expr)) - (integer (make-movitz-fixnum expr)) + (integer (make-movitz-integer expr)) (character (make-movitz-character expr)) (string (or (gethash expr (image-string-constants *image*)) (setf (gethash expr (image-string-constants *image*))

1 0

[movitz-cvs] CVS update: movitz/stream-image.lisp
by Frode Vatvedt Fjeld 24 May '04

24 May '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv21170 Modified Files: stream-image.lisp Log Message: Starting to add some bignum support. Date: Mon May 24 10:58:07 2004 Author: ffjeld Index: movitz/stream-image.lisp diff -u movitz/stream-image.lisp:1.4 movitz/stream-image.lisp:1.5 --- movitz/stream-image.lisp:1.4 Wed Mar 31 11:34:47 2004 +++ movitz/stream-image.lisp Mon May 24 10:58:07 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Aug 27 14:46:50 2001 ;;;; -;;;; $Id: stream-image.lisp,v 1.4 2004/03/31 16:34:47 ffjeld Exp $ +;;;; $Id: stream-image.lisp,v 1.5 2004/05/24 14:58:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -80,7 +80,8 @@ (:other (setf (image-stream-position image) (+ 4 (extract-pointer word))) - (let ((type-tag (read-binary 'other-type-byte (image-stream image)))) + (let* ((type-code (read-binary 'u8 (image-stream image))) + (type-tag (enum-symbolic-value 'other-type-byte type-code))) (setf (image-stream-position image) (extract-pointer word)) (case type-tag @@ -92,7 +93,8 @@ (read-binary 'movitz-struct (image-stream image))) (:std-instance (read-binary 'movitz-std-instance (image-stream image))) - (t (warn "unknown other object: #x~X: ~S" word type-tag) + (t (warn "unknown other object: #x~X: ~S code #x~X." + word type-tag type-code) (make-instance 'movitz-fixnum :value (truncate word 4)))))) (t (make-instance 'movitz-fixnum :value 0))))) (when (typep object 'movitz-heap-object)

1 0

[movitz-cvs] CVS update: movitz/compiler.lisp
by Frode Vatvedt Fjeld 24 May '04

24 May '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv18785 Modified Files: compiler.lisp Log Message: Starting to add some bignum support. Date: Mon May 24 10:58:01 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.59 movitz/compiler.lisp:1.60 --- movitz/compiler.lisp:1.59 Fri Apr 23 10:58:52 2004 +++ movitz/compiler.lisp Mon May 24 10:58:00 2004 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.59 2004/04/23 14:58:52 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.60 2004/05/24 14:58:00 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -4786,12 +4786,9 @@ :provider provider)) (:untagged-fixnum-ecx (case (result-mode-type desired-result) - ((:eax :ebx :ecx :edx) - (values (append code `((:cmpl ,+movitz-most-positive-fixnum+ :ecx) - (:ja '(:sub-program () - (:int 4))) - (:leal ((:ecx ,+movitz-fixnum-factor+) :edi ,(edi-offset)) - ,desired-result))) + ((:eax :single-value) + (values (append code + `((:call (:edi ,(global-constant-offset 'normalize-u32-ecx))))) desired-result)) (t (make-result-and-returns-glue desired-result :eax (make-result-and-returns-glue :eax :untagged-fixnum-ecx code

1 0

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

21 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv26318 Modified Files: arrays.lisp Log Message: The layout of heap objects has been changed such that the type-code is now the "first" byte in the object. Date: Fri May 21 05:41:58 2004 Author: ffjeld Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.19 movitz/losp/muerte/arrays.lisp:1.20 --- movitz/losp/muerte/arrays.lisp:1.19 Thu May 20 13:41:46 2004 +++ movitz/losp/muerte/arrays.lisp Fri May 21 05:41:58 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.19 2004/05/20 17:41:46 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.20 2004/05/21 09:41:58 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -186,69 +186,72 @@ (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)))) + (macrolet + ((do-it () + `(with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :eax) vector) + (:compile-form (:result-mode :ebx) index) + (:leal (:eax ,(- (movitz:tag :other))) :ecx) + (:testb ,movitz::+movitz-fixnum-zmask+ :bl) + (:jnz '(:sub-program (not-fixnum) (:int 107))) ; index not fixnum + (:andl ,(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))))) + (:shrl ,movitz:+movitz-fixnum-shift+ :ebx) + (:movzxw (:eax ,movitz:+other-type-offset+) :ecx) - (: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) + (: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 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) - (:jne 'not-u8) - (:movzxb (:eax :ebx 2) :eax) ; u8 - (:shll #.movitz::+movitz-fixnum-shift+ :eax) - (:jmp 'done) + not-character + (:cmpl #.(movitz:vector-type-tag :u8) :ecx) + (:jne 'not-u8) + (:movzxb (:eax :ebx 2) :eax) ; u8 + (:shll #.movitz::+movitz-fixnum-shift+ :eax) + (:jmp 'done) - not-u8 - (:cmpl #.(movitz:vector-type-tag :u16) :ecx) - (:jne 'not-u16) - (:movzxw (:eax (:ebx 2) 2) :eax) ; u16 - (:jmp 'done) - - not-u16 - (:cmpl #.(movitz:vector-type-tag :u32) :ecx) - (:jne '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 - (:compile-form (:result-mode :ignore) - (error "Not a vector: ~S" vector)) + not-u8 + (:cmpl #.(movitz:vector-type-tag :u16) :ecx) + (:jne 'not-u16) + (:movzxw (:eax (:ebx 2) 2) :eax) ; u16 + (:jmp 'done) + + not-u16 + (:cmpl ,(movitz:vector-type-tag :u32) :ecx) + (:jne '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 + (:compile-form (:result-mode :ignore) + (error "Not a vector: ~S" vector)) - done)) + done))) + (do-it))) (t (vector &rest subscripts) (declare (ignore vector subscripts)) (error "Multi-dimensional arrays not implemented.")))) @@ -256,82 +259,85 @@ (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) + (macrolet + ((do-it () + `(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 ,movitz:+other-type-offset+) :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) + (: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-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) - (:movl :ebx (: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)) + 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) + (:movl :ebx (: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))) + (do-it))) (t (value vector &rest subscripts) (declare (ignore value vector subscripts)) (error "Multi-dimensional arrays not implemented."))))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/defstruct.lisp
by Frode Vatvedt Fjeld 21 May '04

21 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv25760 Modified Files: defstruct.lisp Log Message: The layout of heap objects has been changed such that the type-code is now the "first" byte in the object. Date: Fri May 21 05:41:39 2004 Author: ffjeld Index: movitz/losp/muerte/defstruct.lisp diff -u movitz/losp/muerte/defstruct.lisp:1.7 movitz/losp/muerte/defstruct.lisp:1.8 --- movitz/losp/muerte/defstruct.lisp:1.7 Mon Apr 19 18:38:16 2004 +++ movitz/losp/muerte/defstruct.lisp Fri May 21 05:41:39 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Mon Jan 22 13:10:59 2001 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: defstruct.lisp,v 1.7 2004/04/19 22:38:16 ffjeld Exp $ +;;;; $Id: defstruct.lisp,v 1.8 2004/05/21 09:41:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -44,52 +44,54 @@ (:leal (:eax #.(cl:- (movitz:tag :other))) :ecx) (:testb 7 :cl) (:jnz 'fail) - (:cmpb #.(movitz:tag :defstruct) (-2 :eax)) + (:cmpb #.(movitz:tag :defstruct) (:eax #.movitz:+other-type-offset+)) (:jne 'fail) (:load-constant struct-name :ebx) (:cmpl :ebx (:eax #.(bt:slot-offset 'movitz::movitz-struct 'movitz::name))) fail)) (defun structure-ref (object slot-number) - (macrolet ((do-it () - `(with-inline-assembly (:returns :eax) - ;; type test - (:compile-form (:result-mode :eax) object) - (:leal (:eax ,(- (movitz:tag :other))) :ecx) - (:testb 7 :cl) - (:jne '(:sub-program (type-error) (:int 66))) - (:cmpb ,(movitz:tag :defstruct) (-2 :eax)) - (:jne '(:sub-program (type-error) (:int 66))) - ;; type test passed, read slot - ,@(if (= 4 movitz::+movitz-fixnum-factor+) - `((:compile-form (:result-mode :ebx) slot-number) - (:movl (:eax :ebx #.(bt:slot-offset 'movitz::movitz-struct 'movitz::slot0)) - :eax)) - `((:compile-form (:result-mode :untagged-fixnum-ecx) slot-number) - (:movl (:eax (:ecx 4) #.(bt:slot-offset 'movitz::movitz-struct 'movitz::slot0)) - :eax)))))) + (macrolet + ((do-it () + `(with-inline-assembly (:returns :eax) + ;; type test + (:compile-form (:result-mode :eax) object) + (:leal (:eax ,(- (movitz:tag :other))) :ecx) + (:testb 7 :cl) + (:jne '(:sub-program (type-error) (:int 66))) + (:cmpb ,(movitz:tag :defstruct) (:eax ,movitz:+other-type-offset+)) + (:jne '(:sub-program (type-error) (:int 66))) + ;; type test passed, read slot + ,@(if (= 4 movitz::+movitz-fixnum-factor+) + `((:compile-form (:result-mode :ebx) slot-number) + (:movl (:eax :ebx #.(bt:slot-offset 'movitz::movitz-struct 'movitz::slot0)) + :eax)) + `((:compile-form (:result-mode :untagged-fixnum-ecx) slot-number) + (:movl (:eax (:ecx 4) #.(bt:slot-offset 'movitz::movitz-struct 'movitz::slot0)) + :eax)))))) (do-it))) (defun (setf structure-ref) (value object slot-number) - (macrolet ((do-it () - (assert (= 4 movitz::+movitz-fixnum-factor+)) - `(with-inline-assembly (:returns :eax) - ;; type test - (:compile-two-forms (:eax :ebx) object slot-number) - (:leal (:eax ,(- (movitz:tag :other))) :ecx) - (:testb 7 :cl) - (:jne '(:sub-program (type-error) (:int 66))) - (:cmpb ,(movitz:tag :defstruct) (-2 :eax)) - (:jne '(:sub-program (type-error) (:int 66))) - (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-struct 'movitz::length)) :ecx) - (:leal ((:ecx ,movitz::+movitz-fixnum-factor+)) :ecx) - (:testb ,movitz::+movitz-fixnum-zmask+ :bl) - (:jnz '(:sub-program (not-fixnum) (:int 107))) - (:cmpl :ecx :ebx) - (:jae '(:sub-program (out-of-range) (:int 61))) - ;; type test passed, read slot - (:compile-form (:result-mode :ecx) value) - (:movl :ecx (:eax :ebx #.(bt:slot-offset 'movitz::movitz-struct 'movitz::slot0)))))) + (macrolet + ((do-it () + (assert (= 4 movitz::+movitz-fixnum-factor+)) + `(with-inline-assembly (:returns :eax) + ;; type test + (:compile-two-forms (:eax :ebx) object slot-number) + (:leal (:eax ,(- (movitz:tag :other))) :ecx) + (:testb 7 :cl) + (:jne '(:sub-program (type-error) (:int 66))) + (:cmpb ,(movitz:tag :defstruct) (:eax ,movitz:+other-type-offset+)) + (:jne '(:sub-program (type-error) (:int 66))) + (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-struct 'movitz::length)) :ecx) + (:leal ((:ecx ,movitz::+movitz-fixnum-factor+)) :ecx) + (:testb ,movitz::+movitz-fixnum-zmask+ :bl) + (:jnz '(:sub-program (not-fixnum) (:int 107))) + (:cmpl :ecx :ebx) + (:jae '(:sub-program (out-of-range) (:int 61))) + ;; type test passed, read slot + (:compile-form (:result-mode :ecx) value) + (:movl :ecx (:eax :ebx #.(bt:slot-offset 'movitz::movitz-struct 'movitz::slot0)))))) (do-it))) (defun struct-accessor-prototype (object) @@ -100,7 +102,7 @@ (:leal (:eax #.(cl:- (movitz:tag :other))) :ecx) (:testb 7 :cl) (:jne '(:sub-program (type-error) (:int 66))) - (:cmpb #.(movitz:tag :defstruct) (-2 :eax)) + (:cmpb #.(movitz:tag :defstruct) (:eax #.movitz:+other-type-offset+)) (:jne '(:sub-program (type-error) (:int 66))) (:load-constant struct-name :ebx) (:cmpl :ebx (:eax #.(bt:slot-offset 'movitz::movitz-struct 'movitz::name))) @@ -119,7 +121,7 @@ (:leal (:ebx #.(cl:- (movitz:tag :other))) :ecx) (:testb 7 :cl) (:jnz '(:sub-program (type-error) (:int 66))) - (:cmpb #.(movitz:tag :defstruct) (-2 :ebx)) + (:cmpb #.(movitz:tag :defstruct) (:ebx #.movitz:+other-type-offset+)) (:jne '(:sub-program (type-error) (:int 66))) (:load-constant struct-name :ecx) (:cmpl :ecx (:ebx #.(bt:slot-offset 'movitz::movitz-struct 'movitz::name)))

1 0

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

21 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv23841 Modified Files: primitive-functions.lisp Log Message: The layout of heap objects has been changed such that the type-code is now the "first" byte in the object. Date: Fri May 21 05:41:12 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.16 movitz/losp/muerte/primitive-functions.lisp:1.17 --- movitz/losp/muerte/primitive-functions.lisp:1.16 Wed Apr 21 11:08:36 2004 +++ movitz/losp/muerte/primitive-functions.lisp Fri May 21 05:41:11 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.16 2004/04/21 15:08:36 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.17 2004/05/21 09:41:11 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -576,7 +576,7 @@ (define-primitive-function fast-class-of-other () "Return the class of an other object." (with-inline-assembly (:returns :multiple-values) - (:movl (:eax -2) :ecx) + (:movl (:eax #.movitz:+other-type-offset+) :ecx) (:cmpb #.(movitz::tag :std-instance) :cl) (:jne 'not-std-instance) (:movl (:eax #.(bt:slot-offset 'movitz::movitz-std-instance 'movitz::class)) :eax)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp
by Frode Vatvedt Fjeld 21 May '04

21 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv20961 Modified Files: basic-macros.lisp Log Message: The layout of heap objects has been changed such that the type-code is now the "first" byte in the object. Date: Fri May 21 05:40:48 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.18 movitz/losp/muerte/basic-macros.lisp:1.19 --- movitz/losp/muerte/basic-macros.lisp:1.18 Thu May 20 13:43:46 2004 +++ movitz/losp/muerte/basic-macros.lisp Fri May 21 05:40:48 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: basic-macros.lisp,v 1.18 2004/05/20 17:43:46 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.19 2004/05/21 09:40:48 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -522,9 +522,10 @@ (:globally (:call (:edi (:edi-offset malloc)))) (:addl ,(if (integerp tag) tag (movitz::tag tag)) :eax) ,@(when (and (eq tag :other) other-tag (not wide-other-tag)) - `((:movb ,(movitz::tag other-tag) (:eax -2)))) + `((:movb ,(movitz::tag other-tag) (:eax ,movitz:+other-type-offset+)))) ,@(when (and (eq tag :other) other-tag wide-other-tag) - `((:movw ,(dpb wide-other-tag (byte 8 8) (movitz::tag other-tag)) (:eax -2)))))) + `((:movw ,(dpb wide-other-tag (byte 8 8) (movitz:tag other-tag)) + (:eax ,movitz:+other-type-offset+)))))) (defmacro check-type (place type &optional type-string) (if (not (stringp type-string)) @@ -693,7 +694,7 @@ (:cmpb 7 :cl) (:jne '(:sub-program (not-funobj) (:int 69))) - (:cmpb ,(movitz::tag :funobj) (:edx -2)) + (:cmpb ,(movitz:tag :funobj) (:edx ,movitz:+other-type-offset+)) (:jne 'not-funobj) (:movl :edx :esi) funobj-ok @@ -743,7 +744,7 @@ (:testb 7 :cl) (:jne '(:sub-program (not-funobj) (:int 69))) - (:cmpb ,(movitz::tag :funobj) (:edx -2)) + (:cmpb ,(movitz::tag :funobj) (:edx ,movitz:+other-type-offset+)) (:jne 'not-funobj) (:movl :edx :esi) funobj-ok @@ -765,7 +766,7 @@ (:cmpb 7 :cl) (:jnz '(:sub-program (not-funobj) (:int 69))) - (:cmpb ,(movitz::tag :funobj) (:edx -2)) + (:cmpb ,(movitz::tag :funobj) (:edx ,movitz:+other-type-offset+)) (:jne 'not-funobj) (:movl :edx :esi) funobj-ok @@ -787,7 +788,7 @@ (:cmpb 7 :cl) (:jnz '(:sub-program (not-funobj) (:int 69))) - (:cmpb ,(movitz::tag :funobj) (:edx -2)) + (:cmpb ,(movitz::tag :funobj) (:edx ,movitz:+other-type-offset+)) (:jne 'not-funobj) (:movl :edx :esi) funobj-ok

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp
by Frode Vatvedt Fjeld 21 May '04

21 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv19808 Modified Files: scavenge.lisp Log Message: The layout of heap objects has been changed such that the type-code is now the "first" byte in the object. Date: Fri May 21 05:40:20 2004 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.6 movitz/losp/muerte/scavenge.lisp:1.7 --- movitz/losp/muerte/scavenge.lisp:1.6 Tue Apr 6 20:34:52 2004 +++ movitz/losp/muerte/scavenge.lisp Fri May 21 05:40:19 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.6 2004/04/07 00:34:52 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.7 2004/05/21 09:40:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -54,10 +54,11 @@ (error "Illegal word ~Z at ~S." x scan)) ((scavenge-typep x :funobj) ;; Process code-vector pointer specially.. - (let ((code-vector (%word-offset (memref scan 0 -1 :lisp) -2)) - (num-jumpers (ldb (byte 14 0) (memref scan 0 6 :lisp)))) + (let* ((funobj (%word-offset scan #.(movitz:tag :other))) + (code-vector (funobj-code-vector funobj)) + (num-jumpers (funobj-num-jumpers funobj))) (check-type code-vector vector-u8) - (map-heap-words function (+ scan 4) (+ scan 6)) ; scan funobj's lambda-list and name fields + (map-heap-words function (+ scan 5) (+ scan 7)) ; scan funobj's lambda-list and name (let ((new-code-vector (funcall function code-vector scan))) (check-type new-code-vector vector-u8) (unless (eq code-vector new-code-vector) @@ -65,21 +66,21 @@ (setf (memref scan 0 -1 :lisp) (%word-offset new-code-vector 2)) ;; Do more stuff here to update code-vectors and jumpers )) - (incf scan (+ 6 num-jumpers)))) ; Don't scan the jumpers. + (incf scan (+ 7 num-jumpers)))) ; Don't scan the jumpers. ((scavenge-typep x :infant-object) (error "Scanning an infant object ~Z at ~S." x scan)) ((or (scavenge-wide-typep x :vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u8)) (scavenge-wide-typep x :vector #.(bt:enum-value 'movitz:movitz-vector-element-type :character))) - (let ((len (memref scan -2 0 :unsigned-byte16))) - (incf scan (* 2 (truncate (+ 7 len) 8))))) + (let ((len (memref scan 2 0 :unsigned-byte16))) + (incf scan (1+ (* 2 (truncate (+ 7 len) 8)))))) ((scavenge-wide-typep x :vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u16)) - (let ((len (memref scan -2 0 :unsigned-byte16))) - (incf scan (* 2 (truncate (+ 3 len) 4))))) + (let ((len (memref scan 2 0 :unsigned-byte16))) + (incf scan (1+ (* 2 (truncate (+ 3 len) 4)))))) ((scavenge-wide-typep x :vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u32)) - (let ((len (memref scan -2 0 :unsigned-byte16))) - (incf scan (* 2 (truncate (+ 1 len) 2))))) + (let ((len (memref scan 2 0 :unsigned-byte16))) + (incf scan (1+ (* 2 (truncate (+ 1 len) 2)))))) ((eq x (fixnum-word 3)) (incf scan) (incf scan (memref scan 0 0 :lisp)))

1 0

[movitz-cvs] CVS update: movitz/bochsrc.txt
by Frode Vatvedt Fjeld 21 May '04

21 May '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv15841 Modified Files: bochsrc.txt Log Message: The layout of heap objects has been changed such that the type-code is now the "first" byte in the object. Date: Fri May 21 05:40:09 2004 Author: ffjeld Index: movitz/bochsrc.txt diff -u movitz/bochsrc.txt:1.1.1.1 movitz/bochsrc.txt:1.2 --- movitz/bochsrc.txt:1.1.1.1 Tue Jan 13 06:04:59 2004 +++ movitz/bochsrc.txt Fri May 21 05:40:09 2004 @@ -36,5 +36,5 @@ error: action=report # debug: action=report -ips: 3000000 +ips: 2000000 # com1: dev=/dev/ptypv

1 0

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

21 May '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv6114 Modified Files: packages.lisp Log Message: The layout of heap objects has been changed such that the type-code is now the "first" byte in the object. Date: Fri May 21 05:39:42 2004 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.21 movitz/packages.lisp:1.22 --- movitz/packages.lisp:1.21 Wed Apr 21 12:00:25 2004 +++ movitz/packages.lisp Fri May 21 05:39:40 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.21 2004/04/21 16:00:25 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.22 2004/05/21 09:39:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1284,6 +1284,7 @@ #:dump-image #:other-type-byte + #:+other-type-offset+ #:parse-docstring-and-declarations #:global-constant-offset #:tag #:tag-name

1 0

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

21 May '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv3712 Modified Files: storage-types.lisp Log Message: The layout of heap objects has been changed such that the type-code is now the "first" byte in the object. Date: Fri May 21 05:39:30 2004 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.16 movitz/storage-types.lisp:1.17 --- movitz/storage-types.lisp:1.16 Wed Apr 21 12:22:56 2004 +++ movitz/storage-types.lisp Fri May 21 05:39:30 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.16 2004/04/21 16:22:56 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.17 2004/05/21 09:39:30 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -84,7 +84,6 @@ (defconstant +fixnum-tags+ '(:even-fixnum :odd-fixnum)) (defparameter +scan-skip-word+ #x00000003) - (defun tag (type) (bt:enum-value 'other-type-byte type)) @@ -165,12 +164,14 @@ ;;; Fixnums (eval-when (:compile-toplevel :execute :load-toplevel) -(defconstant +movitz-fixnum-bits+ 30) -(defconstant +movitz-fixnum-shift+ (- 32 +movitz-fixnum-bits+)) -(defconstant +movitz-fixnum-factor+ (expt 2 +movitz-fixnum-shift+)) -(defconstant +movitz-fixnum-zmask+ (1- +movitz-fixnum-factor+)) -(defconstant +movitz-most-positive-fixnum+ (1- (expt 2 (1- +movitz-fixnum-bits+)))) -(defconstant +movitz-most-negative-fixnum+ (- (expt 2 (1- +movitz-fixnum-bits+))))) + (defconstant +movitz-fixnum-bits+ 30) + (defconstant +movitz-fixnum-shift+ (- 32 +movitz-fixnum-bits+)) + (defconstant +movitz-fixnum-factor+ (expt 2 +movitz-fixnum-shift+)) + (defconstant +movitz-fixnum-zmask+ (1- +movitz-fixnum-factor+)) + (defconstant +movitz-most-positive-fixnum+ (1- (expt 2 (1- +movitz-fixnum-bits+)))) + (defconstant +movitz-most-negative-fixnum+ (- (expt 2 (1- +movitz-fixnum-bits+)))) + + (defparameter +other-type-offset+ -6)) (defun fixnum-integer (word) "For a Movitz word, that must be a fixnum, return the corresponding @@ -325,24 +326,7 @@ ;;; movitz-vectors (define-binary-class movitz-vector (movitz-heap-object-other) - ((flags - :accessor movitz-vector-flags - :initarg :flags - :initform nil - :binary-type (define-bitfield movitz-vector-flags (u8) - (((:bits) :fill-pointer-p 2 - :code-vector-p 3 - :std-instance-slots-p 4)))) - (alignment-power - :binary-lisp-type u8 ; align to 2^(high-nibble+3) + low-nibble - :initform 0 - :initarg :alignment-power - :reader movitz-vector-alignment-power) - (num-elements - :binary-type lu16 - :initarg :num-elements - :reader movitz-vector-num-elements) - (type + ((type :binary-type other-type-byte :reader movitz-vector-type :initform :vector) @@ -360,43 +344,60 @@ :binary-type lu16 :initarg :fill-pointer :accessor movitz-vector-fill-pointer) + (flags + :accessor movitz-vector-flags + :initarg :flags + :initform nil + :binary-type (define-bitfield movitz-vector-flags (u8) + (((:bits) :fill-pointer-p 2 + :code-vector-p 3 + :std-instance-slots-p 4)))) + (alignment-power + :binary-lisp-type u8 ; align to 2^(high-nibble+3) + low-nibble + :initform 0 + :initarg :alignment-power + :reader movitz-vector-alignment-power) + (num-elements + :binary-type lu16 + :initarg :num-elements + :reader movitz-vector-num-elements) (data :binary-lisp-type :label) ; data follows physically here (symbolic-data :initarg :symbolic-data :accessor movitz-vector-symbolic-data)) - (:slot-align type -2)) + (:slot-align type #.+other-type-offset+)) (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 - :binary-type u32 - :initarg :length - :accessor movitz-simple-vector-length) - (type - :binary-type other-type-byte - :reader movitz-vector-type) - #+ignore - (element-type - :binary-type (define-enum movitz-vector-element-type (u8) - :any-t 0 - :character 1 - :u8 2 - :u16 3 - :u32 4 - :bit 5) - :initarg :element-type - :reader movitz-vector-element-type) - (data - :binary-lisp-type :label) - (symbolic-data - :initarg :symbolic-data - :accessor movitz-vector-symbolic-data)) - (:slot-align type -2)) +;;;(define-binary-class movitz-new-vector (movitz-heap-object-other) +;;; ((length +;;; :binary-type u32 +;;; :initarg :length +;;; :accessor movitz-simple-vector-length) +;;; (type +;;; :binary-type other-type-byte +;;; :reader movitz-vector-type) +;;; #+ignore +;;; (element-type +;;; :binary-type (define-enum movitz-vector-element-type (u8) +;;; :any-t 0 +;;; :character 1 +;;; :u8 2 +;;; :u16 3 +;;; :u32 4 +;;; :bit 5) +;;; :initarg :element-type +;;; :reader movitz-vector-element-type) +;;; (data +;;; :binary-lisp-type :label) +;;; (symbolic-data +;;; :initarg :symbolic-data +;;; :accessor movitz-vector-symbolic-data)) +;;; (:slot-align type #.+other-type-offset+)) (defun movitz-type-word-size (type) (truncate (sizeof (intern (symbol-name type) :movitz)) 4)) @@ -745,14 +746,7 @@ ;;; Compiled funobj (define-binary-class movitz-funobj (movitz-heap-object-other) - ((code-vector - :binary-type code-vector-word - :initform 'muerte::no-code-vector - :initarg :code-vector - :map-binary-write 'movitz-intern-code-vector - :map-binary-read-delayed 'movitz-word-code-vector - :accessor movitz-funobj-code-vector) - (type + ((type :binary-type other-type-byte :initform :funobj) (funobj-type @@ -767,6 +761,13 @@ ;; Bit 5: The code-vector's uses-stack-frame-p. :binary-type 'lu16 :initform 0) + (code-vector + :binary-type code-vector-word + :initform 'muerte::no-code-vector + :initarg :code-vector + :map-binary-write 'movitz-intern-code-vector + :map-binary-read-delayed 'movitz-word-code-vector + :accessor movitz-funobj-code-vector) (code-vector%1op :binary-type code-pointer :initform 'muerte::trampoline-funcall%1op @@ -858,7 +859,7 @@ :initform :default :initarg :entry-protocol :reader funobj-entry-protocol)) - (:slot-align type -2)) + (:slot-align type #.+other-type-offset+)) (defmethod write-binary-record ((obj movitz-funobj) stream) (declare (special *record-all-funobjs*)) @@ -908,12 +909,7 @@ (define-binary-class movitz-funobj-standard-gf (movitz-funobj) ;; This class is binary congruent with movitz-funobj. - ((code-vector - :binary-type code-vector-word - :initform 'muerte::standard-gf-dispatcher - :map-binary-write 'movitz-intern-code-vector - :map-binary-read-delayed 'movitz-word-code-vector) - (type + ((type :binary-type other-type-byte) (funobj-type :binary-type movitz-funobj-type @@ -922,6 +918,11 @@ ;; Bits 0-4: The value of the start-stack-frame-setup label. :binary-type 'lu16 :initform 0) + (code-vector + :binary-type code-vector-word + :initform 'muerte::standard-gf-dispatcher + :map-binary-write 'movitz-intern-code-vector + :map-binary-read-delayed 'movitz-word-code-vector) (code-vector%1op :initform 'muerte::standard-gf-dispatcher%1op :binary-type code-pointer @@ -993,18 +994,11 @@ :map-binary-read-delayed 'movitz-word) (plist :initform nil)) - (:slot-align type -2)) + (:slot-align type #.+other-type-offset+)) (defmethod movitz-funobj-const-list ((funobj movitz-funobj-standard-gf)) nil) -#+ignore -(defun make-movitz-funobj (lambda-list &key (name "")) - (check-type name (or symbol cons)) - (make-instance 'movitz-funobj - :lambda-list lambda-list - :name name)) - (defun make-standard-gf (class slots &key lambda-list (name "unnamed") (function 'muerte::unbound) num-required-arguments @@ -1020,51 +1014,27 @@ ;;; -#+ignore -(define-binary-class movitz-bignum (movitz-heap-object-other) - ((low32 - :binary-lisp-type u32 - :map-binary-write 'movitz-intern - :map-binary-read-delayed 'movitz-word - :initarg :name) - (type - :binary-lisp-type other-type-byte - :initform :bignum) +(define-binary-class movitz-struct (movitz-heap-object-other) + ((type + :binary-type other-type-byte + :initform :defstruct) (pad :binary-lisp-type 1) (length :binary-lisp-type lu16 :initarg :length - :accessor movitz-bignum-length) - (slot0 :binary-lisp-type :label) ; the slot values follows here. - (slot-values - :initform '() - :initarg :slot-values - :accessor movitz-struct-slot-values)) - (:slot-align type -2)) - -;;; - -(define-binary-class movitz-struct (movitz-heap-object-other) - ((name + :accessor movitz-struct-length) + (name :binary-type word :map-binary-write 'movitz-intern :map-binary-read-delayed 'movitz-word :reader movitz-struct-name :initarg :name) - (type - :binary-type other-type-byte - :initform :defstruct) - (pad :binary-lisp-type 1) - (length - :binary-lisp-type lu16 - :initarg :length - :accessor movitz-struct-length) (slot0 :binary-lisp-type :label) ; the slot values follows here. (slot-values :initform '() :initarg :slot-values :accessor movitz-struct-slot-values)) - (:slot-align type -2)) + (:slot-align type #.+other-type-offset+)) (defmethod update-movitz-object ((movitz-struct movitz-struct) lisp-struct) (declare (ignore lisp-struct)) @@ -1271,15 +1241,15 @@ ;;; std-instance (define-binary-class movitz-std-instance (movitz-heap-object-other) - ((dummy + ((type + :binary-type other-type-byte + :initform :std-instance) + (pad :binary-lisp-type 3) + (dummy :binary-type word :initform *movitz-nil* :map-binary-write 'movitz-intern :map-binary-read-delayed 'movitz-word) - (type - :binary-type other-type-byte - :initform :std-instance) - (pad :binary-lisp-type 3) (class :binary-type word :map-binary-write 'movitz-intern @@ -1292,7 +1262,7 @@ :map-binary-read-delayed 'movitz-word :initarg :slots :accessor movitz-std-instance-slots)) - (:slot-align type -2)) + (:slot-align type #.+other-type-offset+)) ;; (defmethod movitz-object-offset ((obj movitz-std-instance)) (- #x1e))

1 0

[movitz-cvs] CVS update: movitz/image.lisp
by Frode Vatvedt Fjeld 21 May '04

21 May '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv25760 Modified Files: image.lisp Log Message: The layout of heap objects has been changed such that the type-code is now the "first" byte in the object. Date: Fri May 21 05:38:52 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.28 movitz/image.lisp:1.29 --- movitz/image.lisp:1.28 Wed May 19 10:59:52 2004 +++ movitz/image.lisp Fri May 21 05:38:52 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.28 2004/05/19 14:59:52 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.29 2004/05/21 09:38:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -569,9 +569,10 @@ (defmethod image-intern-object ((image symbolic-image) object &optional (size (sizeof object))) (assert ; sanity check on "other" storage-types. (or (not (typep object 'movitz-heap-object-other)) - (and (= -6 (slot-offset (type-of object) - (first (binary-record-slot-names (type-of object))))) - (= -2 (slot-offset (type-of object) 'type)))) + (and (= (- (tag :other)) + (slot-offset (type-of object) + (first (binary-record-slot-names (type-of object))))) + (= +other-type-offset+ (slot-offset (type-of object) 'type)))) () "The MOVITZ-HEAP-OBJECT-OTHER type ~A is malformed!" (type-of object)) (etypecase object

1 0

[movitz-cvs] CVS update: movitz/bootblock.lisp
by Frode Vatvedt Fjeld 20 May '04

20 May '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv20607 Modified Files: bootblock.lisp Log Message: Minor edits. Date: Thu May 20 14:25:12 2004 Author: ffjeld Index: movitz/bootblock.lisp diff -u movitz/bootblock.lisp:1.8 movitz/bootblock.lisp:1.9 --- movitz/bootblock.lisp:1.8 Fri Apr 16 15:15:20 2004 +++ movitz/bootblock.lisp Thu May 20 14:25:12 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Mon Oct 9 20:47:19 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: bootblock.lisp,v 1.8 2004/04/16 19:15:20 ffjeld Exp $ +;;;; $Id: bootblock.lisp,v 1.9 2004/05/20 18:25:12 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -155,7 +155,6 @@ (:movw :bx :es) (:xorw :bx :bx) - (:int #x13) ; Call BIOS routine (:jc 'read-error) (:movzxb :al :ecx) @@ -285,7 +284,7 @@ ;; Data welcome (% format 8 "Loading Movitz ~D..~% " ,(incf *bootblock-build*)) - entering (% format 8 ")~% Enter..") + entering (% format 8 "~% Enter..") error (% format 8 "Failed!)") track-start-msg (% format 8 "(") track-end-msg (% format 8 ")")

1 0

[movitz-cvs] CVS update: movitz/losp/x86-pc/serial.lisp
by Frode Vatvedt Fjeld 20 May '04

20 May '04

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv21517 Modified Files: serial.lisp Log Message: Header update. Date: Thu May 20 14:16:13 2004 Author: ffjeld Index: movitz/losp/x86-pc/serial.lisp diff -u movitz/losp/x86-pc/serial.lisp:1.1.1.1 movitz/losp/x86-pc/serial.lisp:1.2 --- movitz/losp/x86-pc/serial.lisp:1.1.1.1 Tue Jan 13 06:05:06 2004 +++ movitz/losp/x86-pc/serial.lisp Thu May 20 14:16:13 2004 @@ -1,16 +1,16 @@ ;;;;------------------------------------------------------------------ ;;;; ;;;; Copyright (C) 2001-2004, -;;;; Department of Computer Science, University of Tromsø, Norway. +;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. ;;;; ;;;; Filename: serial.lisp -;;;; Description: +;;;; Description: Serial port interfacing. ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Oct 11 14:42:12 2002 ;;;; -;;;; $Id: serial.lisp,v 1.1.1.1 2004/01/13 11:05:06 ffjeld Exp $ +;;;; $Id: serial.lisp,v 1.2 2004/05/20 18:16:13 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/streams.lisp
by Frode Vatvedt Fjeld 20 May '04

20 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv15328 Modified Files: streams.lisp Log Message: Also here prefer vector-push-extend over vector-push. Date: Thu May 20 14:13:55 2004 Author: ffjeld Index: movitz/losp/muerte/streams.lisp diff -u movitz/losp/muerte/streams.lisp:1.2 movitz/losp/muerte/streams.lisp:1.3 --- movitz/losp/muerte/streams.lisp:1.2 Mon Jan 19 06:23:47 2004 +++ movitz/losp/muerte/streams.lisp Thu May 20 14:13:55 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Jun 30 14:33:15 2003 ;;;; -;;;; $Id: streams.lisp,v 1.2 2004/01/19 11:23:47 ffjeld Exp $ +;;;; $Id: streams.lisp,v 1.3 2004/05/20 18:13:55 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -24,7 +24,7 @@ (:no-clos-fallback stream-no-clos)) (defmethod stream-write-char ((stream string) character) - (vector-push character stream) + (vector-push-extend character stream) character) (defmethod stream-write-char ((stream function) character) @@ -100,10 +100,10 @@ (string (case (funobj-name *forward-generic-function*) (stream-write-char - (vector-push (car args) stream) + (vector-push-extend (car args) stream) (car args)) (stream-fresh-line - (vector-push #\newline stream) + (vector-push-extend #\newline stream) t))) (function (apply stream (funobj-name *forward-generic-function*) args))))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/simple-streams.lisp
by Frode Vatvedt Fjeld 20 May '04

20 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv18368 Modified Files: simple-streams.lisp Log Message: Use vector-push-extend rather than vector-push when write-char to a string. Date: Thu May 20 13:48:34 2004 Author: ffjeld Index: movitz/losp/muerte/simple-streams.lisp diff -u movitz/losp/muerte/simple-streams.lisp:1.4 movitz/losp/muerte/simple-streams.lisp:1.5 --- movitz/losp/muerte/simple-streams.lisp:1.4 Wed Feb 18 09:39:37 2004 +++ movitz/losp/muerte/simple-streams.lisp Thu May 20 13:48:34 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Aug 29 13:39:43 2003 ;;;; -;;;; $Id: simple-streams.lisp,v 1.4 2004/02/18 14:39:37 ffjeld Exp $ +;;;; $Id: simple-streams.lisp,v 1.5 2004/05/20 17:48:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -427,7 +427,7 @@ (%check stream :output) (funcall-stm-handler-2 j-write-char character (sm melded-stream stream)))) (string - (vector-push character stream)))) + (vector-push-extend character stream)))) (defun %read-line (stream eof-error-p eof-value recursive-p) (declare (ignore recursive-p))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/sequences.lisp
by Frode Vatvedt Fjeld 20 May '04

20 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv5246 Modified Files: sequences.lisp Log Message: Added a simple position-if-not. Date: Thu May 20 13:48:04 2004 Author: ffjeld Index: movitz/losp/muerte/sequences.lisp diff -u movitz/losp/muerte/sequences.lisp:1.7 movitz/losp/muerte/sequences.lisp:1.8 --- movitz/losp/muerte/sequences.lisp:1.7 Fri Apr 23 11:02:20 2004 +++ movitz/losp/muerte/sequences.lisp Thu May 20 13:48:04 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 11 14:19:23 2001 ;;;; -;;;; $Id: sequences.lisp,v 1.7 2004/04/23 15:02:20 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.8 2004/05/20 17:48:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -290,6 +290,9 @@ (let ((next-i (position-if predicate p :key key :from-end t))) (if next-i (+ i 1 next-i) i))))))))))))))) +(defun position-if-not (predicate sequence &rest key-args) + (declare (dynamic-extent key-args)) + (apply #'position-if (complement predicate) sequence key-args)) (defun nreverse (sequence) (sequence-dispatch sequence

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/format.lisp
by Frode Vatvedt Fjeld 20 May '04

20 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv3082 Modified Files: format.lisp Log Message: For (format nil ...) make initial output string somewhat longer. Date: Thu May 20 13:47:24 2004 Author: ffjeld Index: movitz/losp/muerte/format.lisp diff -u movitz/losp/muerte/format.lisp:1.4 movitz/losp/muerte/format.lisp:1.5 --- movitz/losp/muerte/format.lisp:1.4 Tue Apr 13 10:21:57 2004 +++ movitz/losp/muerte/format.lisp Thu May 20 13:47:24 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Mar 23 01:18:36 2002 ;;;; -;;;; $Id: format.lisp,v 1.4 2004/04/13 14:21:57 ffjeld Exp $ +;;;; $Id: format.lisp,v 1.5 2004/05/20 17:47:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -30,7 +30,7 @@ (declare (dynamic-extent args)) (let ((destination (case destination - ((nil) (make-array (* 2 (length control)) + ((nil) (make-array (* 3 (length control)) :element-type 'character :fill-pointer 0)) ((t) *standard-output*)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp
by Frode Vatvedt Fjeld 20 May '04

20 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv31939 Modified Files: basic-macros.lisp Log Message: Make defpackage :use list translate the common-lisp package to the muerte.common-lisp package, so as to better support movitz-compiling the same code as normal. Date: Thu May 20 13:43:47 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.17 movitz/losp/muerte/basic-macros.lisp:1.18 --- movitz/losp/muerte/basic-macros.lisp:1.17 Mon Apr 19 11:06:26 2004 +++ movitz/losp/muerte/basic-macros.lisp Thu May 20 13:43:46 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: basic-macros.lisp,v 1.17 2004/04/19 15:06:26 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.18 2004/05/20 17:43:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -65,12 +65,19 @@ (defmacro defpackage (package-name &rest options) (pushnew '(:use) options :key #'car) (let ((uses (cdr (assoc :use options)))) + (setf uses (mapcar (lambda (use) + (if (member use '(:cl :common-lisp) :test #'string=) + :muerte.cl + use)) + uses)) (when (or (null uses) (member :muerte.cl uses :test #'string=) (member :muerte.common-lisp uses :test #'string=)) - (push '(:shadowing-import-from :common-lisp nil) options))) - `(eval-when (:compile-toplevel) - (defpackage ,package-name ,@options))) + (push '(:shadowing-import-from :common-lisp nil) options)) + (let ((movitz-options (cons (cons :use uses) + (remove :use options :key #'car)))) + `(eval-when (:compile-toplevel) + (defpackage ,package-name ,@movitz-options))))) (defmacro cond (&rest clauses) (if (null clauses)

1 0

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

20 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv23259 Modified Files: arrays.lisp Log Message: A slightly improved vector-push-extend. Date: Thu May 20 13:41:46 2004 Author: ffjeld Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.18 movitz/losp/muerte/arrays.lisp:1.19 --- movitz/losp/muerte/arrays.lisp:1.18 Fri Apr 23 10:59:55 2004 +++ movitz/losp/muerte/arrays.lisp Thu May 20 13:41:46 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.18 2004/04/23 14:59:55 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.19 2004/05/20 17:41:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -611,7 +611,16 @@ (defun vector-push-extend (new-element vector &optional extension) (declare (ignore extension)) - (vector-push new-element vector)) + (check-type vector vector) + (let ((p (vector-fill-pointer vector))) + (declare (type (unsigned-byte 16) p)) + (cond + ((< p (vector-dimension vector)) + (setf (aref vector p) new-element + (fill-pointer vector) (1+ p))) + (t (error "Vector-push extending not implemented yet."))) + p)) + (define-compiler-macro bvref-u16 (&whole form vector offset index &environment env) (let ((actual-index (and (movitz:movitz-constantp index env)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp
by Frode Vatvedt Fjeld 19 May '04

19 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv1920 Modified Files: integers.lisp Log Message: Added floor. Date: Wed May 19 11:42:08 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.9 movitz/losp/muerte/integers.lisp:1.10 --- movitz/losp/muerte/integers.lisp:1.9 Wed May 19 11:09:05 2004 +++ movitz/losp/muerte/integers.lisp Wed May 19 11:42:08 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.9 2004/05/19 15:09:05 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.10 2004/05/19 15:42:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1132,3 +1132,19 @@ (gcd gcd (car rest))) (rest (cdr numbers) (cdr rest))) ((null rest) gcd))))) + +(defun floor (n &optional (divisor 1)) + "This is floor written in terms of truncate." + (numargs-case + (1 (n) n) + (2 (n divisor) + (multiple-value-bind (q r) + (truncate n divisor) + (cond + ((<= 0 q) + (values q r)) + ((= 0 r) + (values q 0)) + (t (values (1- q) (+ r divisor)))))) + (t (n &optional (divisor 1)) + (floor n divisor)))) \ No newline at end of file

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp
by Frode Vatvedt Fjeld 19 May '04

19 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv24256 Modified Files: integers.lisp Log Message: Added gcd, mainly borrowed from cmucl. Date: Wed May 19 11:09:07 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.8 movitz/losp/muerte/integers.lisp:1.9 --- movitz/losp/muerte/integers.lisp:1.8 Fri Apr 23 09:02:22 2004 +++ movitz/losp/muerte/integers.lisp Wed May 19 11:09:05 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.8 2004/04/23 13:02:22 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.9 2004/05/19 15:09:05 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1103,3 +1103,32 @@ (defun minus-if (x y) (if (integerp x) (- x y) x)) +(defun gcd (&rest numbers) + (numargs-case + (1 (u) u) + (2 (u v) + ;; Code borrowed from CMUCL. + (do ((k 0 (1+ k)) + (u (abs u) (ash u -1)) + (v (abs v) (ash v -1))) + ((oddp (logior u v)) + (do ((temp (if (oddp u) (- v) (ash u -1)) + (ash temp -1))) + (nil) + (declare (fixnum temp)) + (when (oddp temp) + (if (plusp temp) + (setq u temp) + (setq v (- temp))) + (setq temp (- u v)) + (when (zerop temp) + (let ((res (ash u k))) + (declare (type (signed-byte 31) res) + (optimize (inhibit-warnings 3))) + (return res)))))))) + (t (&rest numbers) + (declare (dynamic-extent numbers)) + (do ((gcd (car numbers) + (gcd gcd (car rest))) + (rest (cdr numbers) (cdr rest))) + ((null rest) gcd)))))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/los-closette-compiler.lisp
by Frode Vatvedt Fjeld 19 May '04

19 May '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv4421 Modified Files: los-closette-compiler.lisp Log Message: Accept (but ignore) the :documentation class option. Date: Wed May 19 11:02:50 2004 Author: ffjeld Index: movitz/losp/muerte/los-closette-compiler.lisp diff -u movitz/losp/muerte/los-closette-compiler.lisp:1.12 movitz/losp/muerte/los-closette-compiler.lisp:1.13 --- movitz/losp/muerte/los-closette-compiler.lisp:1.12 Mon Apr 19 18:38:22 2004 +++ movitz/losp/muerte/los-closette-compiler.lisp Wed May 19 11:02:50 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu Aug 29 13:15:11 2002 ;;;; -;;;; $Id: los-closette-compiler.lisp,v 1.12 2004/04/19 22:38:22 ffjeld Exp $ +;;;; $Id: los-closette-compiler.lisp,v 1.13 2004/05/19 15:02:50 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -674,8 +674,9 @@ (apply #'initialize-class-object class all-keys))) (defun make-instance-standard-class (metaclass &key name direct-superclasses direct-slots - default-initargs-function) - (declare (ignore metaclass)) + default-initargs-function + documentation) + (declare (ignore metaclass documentation)) (let ((class (std-allocate-instance *the-class-standard-class*))) (setf (movitz-class-name class) name) (setf (class-direct-subclasses class) ())

1 0

[movitz-cvs] CVS update: movitz/image.lisp
by Frode Vatvedt Fjeld 19 May '04

19 May '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv11878 Modified Files: image.lisp Log Message: Added a small check for the package-name when dumping packages, so as not to blindly dump packages that are native to the host system should a symbol in such a package accidentally be referenced. Date: Wed May 19 10:59:53 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.27 movitz/image.lisp:1.28 --- movitz/image.lisp:1.27 Wed Apr 21 11:06:50 2004 +++ movitz/image.lisp Wed May 19 10:59:52 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.27 2004/04/21 15:06:50 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.28 2004/05/19 14:59:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1065,6 +1065,12 @@ name symbol) name))) (ensure-package (package-name lisp-package) + (assert (not (member (package-name lisp-package) + #+allegro '(excl common-lisp sys aclmop) + #-allegro '(common-lisp) + :test #'string=)) () + "I don't think you really want to dump the package ~A with Movitz." + lisp-package) (setf (gethash lisp-package lisp-to-movitz-package) (or (gethash package-name packages-hash nil) (let ((p (funcall 'muerte::make-package-object

1 0

[movitz-cvs] CVS update: movitz/movitz-mode.el
by Frode Vatvedt Fjeld 19 May '04

19 May '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv27298 Modified Files: movitz-mode.el Log Message: File-header edits. Date: Wed May 19 10:57:46 2004 Author: ffjeld Index: movitz/movitz-mode.el diff -u movitz/movitz-mode.el:1.4 movitz/movitz-mode.el:1.5 --- movitz/movitz-mode.el:1.4 Wed May 19 10:56:46 2004 +++ movitz/movitz-mode.el Wed May 19 10:57:46 2004 @@ -1,16 +1,16 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001, -;;;; Department of Computer Science, University of Tromsø, Norway. +;;;; Copyright (C) 2001, 2004 +;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. ;;;; ;;;; Filename: movitz-mode.el -;;;; Description: +;;;; Description: Modifies Franz' ELI slightly to integrate with Movitz. ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu Sep 27 18:12:17 2001 ;;;; -;;;; $Id: movitz-mode.el,v 1.4 2004/05/19 14:56:46 ffjeld Exp $ +;;;; $Id: movitz-mode.el,v 1.5 2004/05/19 14:57:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------

1 0

[movitz-cvs] CVS update: movitz/movitz-mode.el
by Frode Vatvedt Fjeld 19 May '04

19 May '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv24617 Modified Files: movitz-mode.el Log Message: Don't check for movitz-package in movitz-compile-file. Date: Wed May 19 10:56:46 2004 Author: ffjeld Index: movitz/movitz-mode.el diff -u movitz/movitz-mode.el:1.3 movitz/movitz-mode.el:1.4 --- movitz/movitz-mode.el:1.3 Mon Feb 2 08:31:23 2004 +++ movitz/movitz-mode.el Wed May 19 10:56:46 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu Sep 27 18:12:17 2001 ;;;; -;;;; $Id: movitz-mode.el,v 1.3 2004/02/02 13:31:23 ffjeld Exp $ +;;;; $Id: movitz-mode.el,v 1.4 2004/05/19 14:56:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -113,12 +113,11 @@ (defun movitz-compile-file () (interactive) - (when (in-movitz-package-p) - (save-some-buffers) - (message "Movitz compiling \"%s\"..." (buffer-file-name)) - (fi:eval-in-lisp "(movitz:movitz-compile-file \"%s\")" (buffer-file-name)) - (message "Movitz compiling \"%s\"...done." - (buffer-file-name)))) + (save-some-buffers) + (message "Movitz compiling \"%s\"..." (buffer-file-name)) + (fi:eval-in-lisp "(movitz:movitz-compile-file \"%s\")" (buffer-file-name)) + (message "Movitz compiling \"%s\"...done." + (buffer-file-name))) (defun movitz-eval-in-acl (string msg) (fi::note-background-request nil) @@ -284,6 +283,11 @@ (when (in-movitz-package-p) (message "Switching to Movitz keymap.") (use-local-map (make-movitz-common-lisp-mode-map))))) + +(defun movitz-mode () + "Switch on Movitz-mode." + (interactive) + (use-local-map (make-movitz-common-lisp-mode-map))) (let ((tag 'fi:common-lisp-indent-hook)) (put 'compiler-values tag '(like with-open-file))

1 0

[movitz-cvs] CVS update: movitz/losp/tmp/harddisk.lisp
by Frode Vatvedt Fjeld 11 May '04

11 May '04

Update of /project/movitz/cvsroot/movitz/losp/tmp In directory common-lisp.net:/tmp/cvs-serv3598 Modified Files: harddisk.lisp Log Message: Updates from Peter Minten. Date: Tue May 11 11:05:28 2004 Author: ffjeld Index: movitz/losp/tmp/harddisk.lisp diff -u movitz/losp/tmp/harddisk.lisp:1.3 movitz/losp/tmp/harddisk.lisp:1.4 --- movitz/losp/tmp/harddisk.lisp:1.3 Wed May 5 04:26:14 2004 +++ movitz/losp/tmp/harddisk.lisp Tue May 11 11:05:25 2004 @@ -1,4 +1,4 @@ -;;;; $Id: harddisk.lisp,v 1.3 2004/05/05 08:26:14 ffjeld Exp $ +;;;; $Id: harddisk.lisp,v 1.4 2004/05/11 15:05:25 ffjeld Exp $ (require :lib/named-integers) @@ -7,6 +7,7 @@ (defpackage muerte.x86-pc.harddisk (:use muerte.cl muerte muerte.lib muerte.x86-pc) (:export hdc-reset + hd-identify-device hd-read-sectors hd-write-sectors)) @@ -118,19 +119,35 @@ (setf (lba-low-register hdc) (ldb (byte 8 0) lba)) (setf (lba-mid-register hdc) (ldb (byte 8 8) lba)) (setf (lba-high-register hdc) (ldb (byte 8 16) lba)) - (setf (device-register hdc) (dpb (ash (ldb (byte 4 24) lba) -24) + (setf (device-register hdc) (dpb (ldb (byte 4 24) lba) (byte 4 0) (device-register hdc)))) +(defun set-lba-address-ext (hdc lba) + (setf (lba-low-register hdc) (ldb (byte 8 0) lba)) + (setf (lba-mid-register hdc) (ldb (byte 8 8) lba)) + (setf (lba-high-register hdc) (ldb (byte 8 16) lba)) + + ;; movitz byte function has a restriction, the location must be <= 30 + ;; therefore this workaround + (setf (lba-low-register hdc) (ldb (byte 8 0) (ash lba -24))) + (setf (lba-mid-register hdc) (ldb (byte 8 8) (ash lba -24))) + (setf (lba-high-register hdc) (ldb (byte 8 16) (ash lba -24)))) + (defun set-sector-count (hdc count) (setf (sector-count-register hdc) count)) +(defun set-sector-count-ext (hdc count) + (setf (sector-count-register hdc) (ldb (byte 8 0) count)) + (setf (sector-count-register hdc) (ldb (byte 8 8) count))) + (defun set-command (hdc command) - (let ((command-code (case command - ('read-sectors-with-retry #x20) - ('write-sectors-with-retry #x30) - ('identify-drive #xCE)))) - (setf (command-register hdc) command-code))) + (setf (command-register hdc) (case command + ('identify-drive #xEC) + ('read-sectors #x20) + ('read-sectors-ext #x24) + ('write-sectors #x30) + ('write-sectors-ext #x34)))) ;;; ;;; misc @@ -139,11 +156,7 @@ (/= 0 (ldb (byte 1 number) place))) (defmacro set-bit (number value place) - (let ((gs-number (gensym "number-"))) - `(if ,value - (let ((,gs-number ,number)) - (setf ,place (dpb (ash 1 ,gs-number) (byte 1 ,gs-number) ,place))) - (setf ,place (dpb 0 (byte 1 ,number) ,place))))) + `(setf ,place (dpb (if ,value 1 0) (byte 1 ,number) ,place))) (defmacro while (test &body body) `(do () ((not ,test)) @@ -206,9 +219,57 @@ (loop for x from 1 to 2500) (loop while (reg-bsy hdc)))) +(defun hd-identify-device (hdnr) + "Get device information of hdnr. Returns a (vector 256 (unsigned-byte 16))." + (let ((data (make-array 256 :element-type :unsigned-byte16)) + (offset 0)) + (with-hd-info (hdc drive) hdnr + (tagbody + ;; drive must be ready + ;; drive number must be set + ;; intrq's must not be used + ;; LBA mode must be on + ;; LBA must be set + ;; sector-count must be set + ;; command must be entered + ;; 400 nsec must be waited before checking BSY + (loop until (reg-drdy hdc)) + (loop while (reg-alt-bsy hdc)) + (set-drive-number hdc drive) + (set-intrq-mode hdc nil) + (set-command hdc 'identify-drive) + (dotimes (x 500)) ;aught to be enough waiting + (go :check-status) + ;;;;;;;;;;;;;;;;;; + :check-status + ;; if BSY=0 and DRQ=0 then error + ;; if BSY=0 and DRQ=1 then go transfer-data + ;; if BSY=1 then go check-state + (let ((status (status-register hdc))) + (if (get-bit 7 status) ;if BSY = 1 + (go :check-status) + (if (get-bit 3 status) ;if DRQ = 1 + (go :transfer-data) + (progn + (hdc-error hdc "identify-device" hdnr))))) + ;;;;;;;;;;;;;;;;;; + :transfer-data + ;; read the data register + (setf (aref data offset) (data-register hdc)) + (incf offset) + ;; read the status register to determine if we're done + (if (reg-drq hdc) + (if (< offset 256) + (go :transfer-data) ;data block not completely transfered + (go :check-status)) + (return-from hd-identify-device data)))))) + (defun hd-read-sectors (hdnr start-sector count) + "Read count sectors from hdnr, starting at start-sector. Returns a (vector (* count 512) (unsigned-byte 8)). If start-sector doesn't fit into 28 bits or count doesn't fit into 8 bits an attempt is made to use 48 bits addressing." (let ((data (make-array (* count 512) :element-type :unsigned-byte8)) (offset 0) + (ext-mode (or (>= start-sector #xFFFFFFF) + (>= count #xFF))) input) (with-hd-info (hdc drive) hdnr (tagbody @@ -226,9 +287,20 @@ (set-drive-number hdc drive) (set-intrq-mode hdc nil) (set-lba-mode hdc t) + (if ext-mode + (progn + (puts "using 48 bits addressing") + (set-lba-address-ext hdc start-sector) + (set-sector-count-ext hdc count) + (set-command hdc 'read-sectors-ext)) + (progn + (puts "using 28 bits addressing") + (set-lba-address hdc start-sector) + (set-sector-count hdc count) + (set-command hdc 'read-sectors))) (set-lba-address hdc start-sector) (set-sector-count hdc count) - (set-command hdc 'read-sectors-with-retry) + (set-command hdc 'read-sectors) (dotimes (x 500)) ;aught to be enough waiting (go :check-status) ;;;;;;;;;;;;;;;;;; @@ -266,8 +338,10 @@ (check-type hdnr (integer 0 *)) (check-type start-sector (integer 0 *)) (check-type data vector) - (let ((count (truncate (length data) 512)) - (offset 0)) + (let* ((count (truncate (length data) 512)) + (ext-mode (or (>= start-sector #xFFFFFFF) + (>= count #xFF))) + (offset 0)) (with-hd-info (hdc drive) hdnr (tagbody ; (puts "in entry") @@ -284,9 +358,20 @@ (set-drive-number hdc drive) (set-intrq-mode hdc nil) (set-lba-mode hdc t) + (if ext-mode + (progn + (puts "using 48 bits addressing") + (set-lba-address-ext hdc start-sector) + (set-sector-count-ext hdc count) + (set-command hdc 'write-sectors-ext)) + (progn + (puts "using 28 bits addressing") + (set-lba-address hdc start-sector) + (set-sector-count hdc count) + (set-command hdc 'write-sectors))) (set-lba-address hdc start-sector) (set-sector-count hdc count) - (set-command hdc 'write-sectors-with-retry) + (set-command hdc 'write-sectors) (dotimes (x 500)) ;aught to be enough waiting (go :check-status) ;;;;;;;;;;;;;;;;;; @@ -315,4 +400,4 @@ (progn (alt-status-register hdc) ;read and ignore (go :check-status))) - (return-from hd-write-sectors nil)))))) + (return-from hd-write-sectors nil)))))) \ No newline at end of file

1 0

[movitz-cvs] CVS update: movitz/losp/tmp/harddisk.lisp
by Frode Vatvedt Fjeld 05 May '04

05 May '04

Update of /project/movitz/cvsroot/movitz/losp/tmp In directory common-lisp.net:/tmp/cvs-serv10011 Modified Files: harddisk.lisp Log Message: Checked in new version from Peter Minten. Date: Wed May 5 04:26:14 2004 Author: ffjeld Index: movitz/losp/tmp/harddisk.lisp diff -u movitz/losp/tmp/harddisk.lisp:1.2 movitz/losp/tmp/harddisk.lisp:1.3 --- movitz/losp/tmp/harddisk.lisp:1.2 Sat Apr 24 11:13:26 2004 +++ movitz/losp/tmp/harddisk.lisp Wed May 5 04:26:14 2004 @@ -1,264 +1,318 @@ -;;;; $Id: harddisk.lisp,v 1.2 2004/04/24 15:13:26 ffjeld Exp $ - -(require :lib/named-integers) -(provide :tmp/harddisk) - -(defpackage muerte.x86-pc.harddisk - (:use muerte.cl muerte muerte.lib muerte.x86-pc) - (:export make-512-vector - hd-read-sectors - hd-write-sectors - hd-commands - )) - -(in-package muerte.x86-pc.harddisk) - -;;; -;;; global variables -;;; -(defvar *hd-controllers* (vector (make-instance 'hd-controller)) - "A vector of harddisk controllers.") - -;;; -;;; constants -;;; -(defconstant +hd-default-first-irq+ 14) -(defconstant +hd-default-second-irq+ 15) -(defconstant +hd-default-first-command-base+ #x1F0) -(defconstant +hd-default-second-command-base+ #x170) -(defconstant +hd-default-first-control-base+ #x3F6) -(defconstant +hd-default-second-control-base+ #x376) - -(define-named-integer hd-register-offset - (:only-constants t) - (0 data) - (1 error) - (1 features) - (2 sector-count) - (3 lba-byte-1) ;bits 0-7 - (4 lba-byte-2) ;bits 8-15 - (5 lba-byte-3) ;bits 16-23 - (6 lba-byte-4) ;bits 24-27 - (7 status) - (7 command)) - -(define-named-integer hd-commands - (:only-constants t) - (#x20 read-sectors-with-retry) - (#x30 write-sectors-with-retry)) - -(define-named-integer hd-status-bits - (:only-constants t) - (0 error) - (1 index) - (2 corrected-data) - (3 data-request) - (4 drive-seek-complete) - (5 drive-write-fault) - (6 drive-ready) - (7 busy)) - -;;; -;;; classes -;;; -(defclass hd-controller () - ((command-base :initform +hd-default-first-command-base+ - :initarg :command-base - :type integer) - (control-base :initform +hd-default-first-control-base+ - :initarg :command-base - :type integer))) - -;;; -;;; waiters -;;; -(defun hd-controller-wait-for-drive-ready (hdc) ;wait for DRDY=1 - (with-slots (control-base) hdc - (loop until (/= 0 (logand (io-port control-base :unsigned-byte8) - #x40))))) - -(defun hd-controller-wait-for-ready (hdc) ;wait for BSY=0 - (with-slots (control-base) hdc - (loop until (= 0 (logand (io-port control-base :unsigned-byte8) - #x80))))) - -(defun hd-controller-wait-for-data-request (hdc) ;wait for DRQ=1 - (with-slots (control-base) hdc - (loop until (/= 0 (logand (io-port control-base :unsigned-byte8) - #x08))))) - -;;; -;;; feeders -;;; -(defun hd-controller-feed-lba-mode (hdc) - (setf (io-port (hd-controller-command-register hdc 'lba-byte-4) - :unsigned-byte8) - (logior (io-port (hd-controller-command-register hdc 'lba-byte-4) - :unsigned-byte8) - #b01000000))) - -(defun hd-controller-feed-drive (hdc drive) - (setf (io-port (hd-controller-command-register hdc 'lba-byte-4) - :unsigned-byte8) - (logior (* #b00010000 drive) - (logand (io-port (hd-controller-command-register hdc 'lba-byte-4) - :unsigned-byte8) - #b11101111)))) - -(defun hd-controller-feed-lba-address (hdc lba) - (setf (io-port (hd-controller-command-register hdc 'lba-byte-1) - :unsigned-byte8) - (logand lba #x000000FF)) - (setf (io-port (hd-controller-command-register hdc 'lba-byte-2) - :unsigned-byte8) - (logand lba #x0000FF00)) - (setf (io-port (hd-controller-command-register hdc 'lba-byte-3) - :unsigned-byte8) - (logand lba #x00FF0000)) - (setf (io-port (hd-controller-command-register hdc 'lba-byte-3) - :unsigned-byte8) - (logior (io-port (hd-controller-command-register hdc 'lba-byte-4) - :unsigned-byte8) - (logand lba #x000F0000)))) - -;;; -;;; misc -;;; -(defmacro while (test &body body) - `(do () ((not ,test)) - ,@body)) - -(defun div (a b) - "Floored integer division, the painful way." - (let ((r 0) - (x a)) - (while (>= x 0) - (decf x b) - (incf r)) - (1- r))) - -(defun log2 (n) - (cond ((= n 256) 8) - ((= n 128) 7) - ((= n 64) 6) - ((= n 32) 5) - ((= n 16) 4) - ((= n 8) 3) - ((= n 4) 2) - ((= n 2) 1) - ((= n 1) 0))) - -(defmacro with-hd-info ((hdc drive-number) hd-number &body body) - (let ((gs-hdnr (gensym "hd-number-"))) - `(let* ((,gs-hdnr ,hd-number) - (,hdc (aref *hd-controllers* (div ,hd-number 2))) - (,drive-number (mod ,gs-hdnr 2))) - ,@body))) - -(defun hd-controller-command-register (hdc name) - ;; use a case statement for now, until I learn how to use - ;; named-integer right - (+ (case name - ('data 0) - ('error 1) - ('features 1) - ('sector-count 2) - ('lba-byte-1 3) - ('lba-byte-2 4) - ('lba-byte-3 5) - ('lba-byte-4 6) - ('status 7) - ('command 7) - (else (error "HD command register not found ~A" name))) - (slot-value hdc 'command-base))) - -(defun error-code-meaning (code) - (nth (log2 code) - '("Address Mark Not Found" - "Track 0 Not Found" - "Media Change Requested" - "Aborted Command" - "ID Not Found" - "Media Changed" - "Uncorrectable Data Error" - "Bad Block Detected"))) - - -(defun hd-check-error (hdc command-name hdnr) - "Check and when found signal an error in task." - (when (/= 0 (logand (io-port (slot-value hdc 'control-base) - :unsigned-byte8) - #x01)) - (error "Harddrive command ~A returned error. HD number: ~A. Error message: '~A'." - command-name hdnr - (error-code-meaning - (io-port (hd-controller-command-register hdc 'error) - :unsigned-byte8))))) - -;;; -;;; hd operations -;;; -(defun hd-read-sectors (hdnr start-sector count) - (let ((data (make-array 512 :element-type :unsigned-byte8)) - (offset 0) - (read-data nil)) - (with-hd-info (hdc drive) hdnr - ;; set drive - (hd-controller-feed-drive hdc drive) - ;; set count - (setf (io-port (hd-controller-command-register hdc 'sector-count) - :unsigned-byte8) - count) - ;; set LBA and address - (hd-controller-feed-lba-mode hdc) - (hd-controller-feed-lba-address hdc start-sector) - ;; get going - (setf (io-port (hd-controller-command-register hdc 'command) - :unsigned-byte8) - +hd-commands-read-sectors-with-retry+) - ;; data handling - (while (<= offset (* count 512)) - (hd-controller-wait-for-drive-ready hdc) - (hd-controller-wait-for-ready hdc) - (hd-check-error hdc "read-sectors" hdnr) - (hd-controller-wait-for-data-request hdc) - (dotimes (i 256) - (setf read-data (io-port (hd-controller-command-register hdc 'status) - :unsigned-byte16))) - (setf (aref data offset) (logand read-data #xFF)) - (setf (aref data (1+ offset)) (logand read-data #xFF00)) - (incf offset 2)) - ;; done - data))) - -(defun hd-write-sectors (hdnr start-sector data) - (let ((offset 0) - (write-data nil) - (count (div (length data) 512))) - (with-hd-info (hdc drive) hdnr - ;; set drive - (hd-controller-feed-drive hdc drive) - ;; set count - (setf (io-port (hd-controller-command-register hdc 'sector-count) - :unsigned-byte8) - count) - ;; set LBA and address - (hd-controller-feed-lba-mode hdc) - (hd-controller-feed-lba-address hdc start-sector) - ;; get going - (setf (io-port (hd-controller-command-register hdc 'command) - :unsigned-byte8) - +hd-commands-write-sectors-with-retry+) - ;; data handling - (while (<= offset (* count 512)) - (hd-controller-wait-for-drive-ready hdc) - (hd-controller-wait-for-ready hdc) - (hd-check-error hdc "write-sectors" hdnr) - (hd-controller-wait-for-data-request hdc) - (dotimes (i 256) - (setf write-data (aref data offset)) - (incf write-data (* #xFF (aref data (1+ offset)))) - (setf (io-port (hd-controller-command-register hdc 'data) - :unsigned-byte16) - write-data) - (incf offset 2)))))) \ No newline at end of file +;;;; $Id: harddisk.lisp,v 1.3 2004/05/05 08:26:14 ffjeld Exp $ + +(require :lib/named-integers) + +(provide :tmp/harddisk) + +(defpackage muerte.x86-pc.harddisk + (:use muerte.cl muerte muerte.lib muerte.x86-pc) + (:export hdc-reset + hd-read-sectors + hd-write-sectors)) + +(in-package muerte.x86-pc.harddisk) + +;;; +;;; global variables +;;; +(defvar *hd-controllers* (vector (make-instance 'hd-controller)) + "A vector of harddisk controllers.") + +;;; +;;; constants +;;; +(defconstant +hd-default-first-irq+ 14) +(defconstant +hd-default-second-irq+ 15) +(defconstant +hd-default-first-command-base+ #x1F0) +(defconstant +hd-default-second-command-base+ #x170) +(defconstant +hd-default-first-control-base+ #x3F6) +(defconstant +hd-default-second-control-base+ #x376) + +;;; +;;; classes +;;; +(defclass hd-controller () + ((command-base :initform +hd-default-first-command-base+ + :initarg :command-base + :type integer) + (control-base :initform +hd-default-first-control-base+ + :initarg :command-base + :type integer))) +;;; +;;; accessors +;;; + +(defmacro data-register (hdc) + `(io-port (+ (slot-value ,hdc 'command-base) 0) :unsigned-byte16)) + +(defmacro features-register (hdc) + `(io-port (+ (slot-value ,hdc 'command-base) 1) :unsigned-byte8)) + +(defmacro error-register (hdc) + `(io-port (+ (slot-value ,hdc 'command-base) 1) :unsigned-byte8)) + +(defmacro sector-count-register (hdc) + `(io-port (+ (slot-value ,hdc 'command-base) 2) :unsigned-byte8)) + +(defmacro lba-low-register (hdc) + `(io-port (+ (slot-value ,hdc 'command-base) 3) :unsigned-byte8)) + +(defmacro lba-mid-register (hdc) + `(io-port (+ (slot-value ,hdc 'command-base) 4) :unsigned-byte8)) + +(defmacro lba-high-register (hdc) + `(io-port (+ (slot-value ,hdc 'command-base) 5) :unsigned-byte8)) + +(defmacro device-register (hdc) + `(io-port (+ (slot-value ,hdc 'command-base) 6) :unsigned-byte8)) + +(defmacro command-register (hdc) + `(io-port (+ (slot-value ,hdc 'command-base) 7) :unsigned-byte8)) + +(defmacro status-register (hdc) + `(io-port (+ (slot-value ,hdc 'command-base) 7) :unsigned-byte8)) + +(defmacro alt-status-register (hdc) + `(io-port (slot-value ,hdc 'control-base) :unsigned-byte8)) + +;;; +;;; getters +;;; +(defun reg-bsy (hdc) + (get-bit 7 (status-register hdc))) + +(defun reg-drdy (hdc) + (get-bit 6 (status-register hdc))) + +(defun reg-drq (hdc) + (get-bit 3 (status-register hdc))) + +(defun reg-err (hdc) + (get-bit 0 (status-register hdc))) + +(defun reg-alt-bsy (hdc) + (get-bit 7 (alt-status-register hdc))) + +(defun reg-alt-drdy (hdc) + (get-bit 6 (alt-status-register hdc))) + +(defun reg-alt-drq (hdc) + (get-bit 3 (alt-status-register hdc))) + +(defun reg-alt-err (hdc) + (get-bit 3 (alt-status-register hdc))) + +;;; +;;; setters +;;; +(defun set-drive-number (hdc drive) + (set-bit 4 (/= drive 0) (device-register hdc))) + +(defun set-intrq-mode (hdc mode) + (set-bit 1 (not mode) (device-register hdc))) + +(defun set-lba-mode (hdc mode) + (set-bit 6 mode (device-register hdc))) + +(defun set-lba-address (hdc lba) + (setf (lba-low-register hdc) (ldb (byte 8 0) lba)) + (setf (lba-mid-register hdc) (ldb (byte 8 8) lba)) + (setf (lba-high-register hdc) (ldb (byte 8 16) lba)) + (setf (device-register hdc) (dpb (ash (ldb (byte 4 24) lba) -24) + (byte 4 0) + (device-register hdc)))) + +(defun set-sector-count (hdc count) + (setf (sector-count-register hdc) count)) + +(defun set-command (hdc command) + (let ((command-code (case command + ('read-sectors-with-retry #x20) + ('write-sectors-with-retry #x30) + ('identify-drive #xCE)))) + (setf (command-register hdc) command-code))) + +;;; +;;; misc +;;; +(defun get-bit (number place) + (/= 0 (ldb (byte 1 number) place))) + +(defmacro set-bit (number value place) + (let ((gs-number (gensym "number-"))) + `(if ,value + (let ((,gs-number ,number)) + (setf ,place (dpb (ash 1 ,gs-number) (byte 1 ,gs-number) ,place))) + (setf ,place (dpb 0 (byte 1 ,number) ,place))))) + +(defmacro while (test &body body) + `(do () ((not ,test)) + ,@body)) + +(defun log2 (n) + (cond ((= n 256) 8) + ((= n 128) 7) + ((= n 64) 6) + ((= n 32) 5) + ((= n 16) 4) + ((= n 8) 3) + ((= n 4) 2) + ((= n 2) 1) + ((= n 1) 0))) + +(defmacro with-hd-info ((hdc drive-number) hd-number &body body) + (let ((gs-hdnr (gensym "hd-number-"))) + `(let* ((,gs-hdnr ,hd-number) + (,hdc (aref *hd-controllers* (truncate ,hd-number 2))) + (,drive-number (mod ,gs-hdnr 2))) + ,@body))) + +(defun error-code-meaning (code) + (if (< 0 code 257) + (nth (log2 code) + '("Address Mark Not Found" + "Track 0 Not Found" + "Media Change Requested" + "Aborted Command" + "ID Not Found" + "Media Changed" + "Uncorrectable Data Error" + "Bad Block Detected")) + "No error")) + +(defun hdc-error (hdc command-name hdnr) + (puts "In HDC error") + (error "Harddrive command ~A returned error. HD number: ~A. Error message: '~A'." + command-name hdnr + (error-code-meaning + (io-port (error-register hdc) :unsigned-byte8)))) + +(defun puts (s) + (fresh-line) + (format t s) + (terpri)) + +;;; +;;; hd operations +;;; +(defun hdc-reset (hdcnr) + "Reset the harddisk controller. Must be done at startup to +initialize the harddisk controller." + ;; set SRST + ;; wait > 2ms + ;; continue when BSY=0 + (let ((hdc (aref *hd-controllers* hdcnr))) + (setf (device-register hdc) #x04) + (loop for x from 1 to 2500) + (loop while (reg-bsy hdc)))) + +(defun hd-read-sectors (hdnr start-sector count) + (let ((data (make-array (* count 512) :element-type :unsigned-byte8)) + (offset 0) + input) + (with-hd-info (hdc drive) hdnr + (tagbody +; (puts "in entry") + ;; drive must be ready + ;; drive number must be set + ;; intrq's must not be used + ;; LBA mode must be on + ;; LBA must be set + ;; sector-count must be set + ;; command must be entered + ;; 400 nsec must be waited before checking BSY + (loop until (reg-drdy hdc)) + (loop while (reg-alt-bsy hdc)) + (set-drive-number hdc drive) + (set-intrq-mode hdc nil) + (set-lba-mode hdc t) + (set-lba-address hdc start-sector) + (set-sector-count hdc count) + (set-command hdc 'read-sectors-with-retry) + (dotimes (x 500)) ;aught to be enough waiting + (go :check-status) + ;;;;;;;;;;;;;;;;;; + :check-status +; (puts "in check-status") + ;; if BSY=0 and DRQ=0 then error + ;; if BSY=0 and DRQ=1 then go transfer-data + ;; if BSY=1 then go check-state + (let ((status (status-register hdc))) + (if (get-bit 7 status) ;if BSY = 1 + (go :check-status) + (if (get-bit 3 status) ;if DRQ = 1 + (go :transfer-data) + (progn + (hdc-error hdc "read-sectors" hdnr))))) + ;;;;;;;;;;;;;;;;;; + :transfer-data +; (puts "in transfer-data") + ;; read the data register + (setf input (data-register hdc)) + (setf (aref data offset) (ldb (byte 8 0) input)) + (incf offset) + (setf (aref data offset) (ldb (byte 8 8) input)) + (incf offset) + ;; read the status register to determine if we're done + (if (reg-drq hdc) + (if (/= 0 (mod offset 512)) + (go :transfer-data) ;data block not completely transfered + (progn + (alt-status-register hdc) ;read and ignore + (go :check-status))) + (return-from hd-read-sectors data)))))) + +(defun hd-write-sectors (hdnr start-sector data) + (check-type hdnr (integer 0 *)) + (check-type start-sector (integer 0 *)) + (check-type data vector) + (let ((count (truncate (length data) 512)) + (offset 0)) + (with-hd-info (hdc drive) hdnr + (tagbody +; (puts "in entry") + ;; drive must be ready + ;; drive number must be set + ;; intrq's must not be used + ;; LBA mode must be on + ;; LBA must be set + ;; sector-count must be set + ;; command must be entered + ;; 400 nsec must be waited before checking BSY + (loop until (reg-drdy hdc)) + (loop while (reg-alt-bsy hdc)) + (set-drive-number hdc drive) + (set-intrq-mode hdc nil) + (set-lba-mode hdc t) + (set-lba-address hdc start-sector) + (set-sector-count hdc count) + (set-command hdc 'write-sectors-with-retry) + (dotimes (x 500)) ;aught to be enough waiting + (go :check-status) + ;;;;;;;;;;;;;;;;;; + :check-status +; (puts "in check-status") + ;; if BSY=0 and DRQ=0 then error + ;; if BSY=0 and DRQ=1 then go transfer-data + ;; if BSY=1 then go + (let ((status (status-register hdc))) + (if (get-bit 7 status) ;if BSY = 1 + (go :check-status) + (if (get-bit 3 status) ;if DRQ = 1 + (go :transfer-data) + (hdc-error hdc "write-sectors" hdnr)))) + ;;;;;;;;;;;;;;;;;; + :transfer-data +; (puts "in transfer-data") + ;; read the data register + (setf (data-register hdc) (+ (aref data offset) + (ash (aref data (1+ offset)) 8))) + (incf offset 2) + ;; read the status register to determine if we're done + (if (reg-drq hdc) + (if (/= 0 (mod offset 512)) + (go :transfer-data) ;data block not completely transfered + (progn + (alt-status-register hdc) ;read and ignore + (go :check-status))) + (return-from hd-write-sectors nil))))))

1 0

[movitz-cvs] CVS update: movitz/losp/x86-pc/pci.lisp
by Frode Vatvedt Fjeld 05 May '04

05 May '04

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv3649 Modified Files: pci.lisp Log Message: Changed the with-named-integers-syntax macro a bit, trying to make this mechanism a bit more general and useful. Date: Wed May 5 04:24:38 2004 Author: ffjeld Index: movitz/losp/x86-pc/pci.lisp diff -u movitz/losp/x86-pc/pci.lisp:1.2 movitz/losp/x86-pc/pci.lisp:1.3 --- movitz/losp/x86-pc/pci.lisp:1.2 Fri Apr 23 11:04:17 2004 +++ movitz/losp/x86-pc/pci.lisp Wed May 5 04:24:38 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sun Dec 14 22:33:42 2003 ;;;; -;;;; $Id: pci.lisp,v 1.2 2004/04/23 15:04:17 ffjeld Exp $ +;;;; $Id: pci.lisp,v 1.3 2004/05/05 08:24:38 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -18,7 +18,7 @@ (provide :x86-pc/pci) -(defun bios32-find () +(defun find-bios32 () (loop for bios32 from #xe0000 to #xffff0 by 16 if (and (= (memref-int bios32 0 0 :unsigned-byte16 t) #x335f) (= (memref-int bios32 0 1 :unsigned-byte16 t) #x5f32)

1 0

[movitz-cvs] CVS update: movitz/losp/x86-pc/dp8390.lisp
by Frode Vatvedt Fjeld 05 May '04

05 May '04

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv2985 Modified Files: dp8390.lisp Log Message: Changed the with-named-integers-syntax macro a bit, trying to make this mechanism a bit more general and useful. Date: Wed May 5 04:24:31 2004 Author: ffjeld Index: movitz/losp/x86-pc/dp8390.lisp diff -u movitz/losp/x86-pc/dp8390.lisp:1.6 movitz/losp/x86-pc/dp8390.lisp:1.7 --- movitz/losp/x86-pc/dp8390.lisp:1.6 Thu Feb 26 06:19:17 2004 +++ movitz/losp/x86-pc/dp8390.lisp Wed May 5 04:24:29 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Sep 18 12:21:36 2002 ;;;; -;;;; $Id: dp8390.lisp,v 1.6 2004/02/26 11:19:17 ffjeld Exp $ +;;;; $Id: dp8390.lisp,v 1.7 2004/05/05 08:24:29 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -22,19 +22,20 @@ (in-package muerte.x86-pc.ne2k) (defconstant +page0-read-map+ - #(cr clda0 clda1 bnry tsr ncr fifo isr crda0 crda1 rbcr0 rbcr1 rsr cntr0 cntr1 cntr2)) + '(:enum cr clda0 clda1 bnry tsr ncr fifo isr crda0 crda1 rbcr0 rbcr1 rsr cntr0 cntr1 cntr2)) (defconstant +page0-write-map+ - #(cr pstart pstop bnry tpsr tbcr0 tbcr1 isr rsar0 rsar1 rbcr0 rbcr1 rcr tcr dcr imr)) + '(:enum cr pstart pstop bnry tpsr tbcr0 tbcr1 isr rsar0 rsar1 rbcr0 rbcr1 rcr tcr dcr imr)) (defconstant +page1-read-map+ - #(nil nil nil nil nil nil nil curr)) + '(:enum nil nil nil nil nil nil nil curr)) (defconstant +page1-write-map+ - #(cr par0 par1 par2 par3 par4 par5 curr mar0 mar1 mar2 mar3 mar4 mar5 mar6 mar7)) + '(:enum cr par0 par1 par2 par3 par4 par5 curr mar0 mar1 mar2 mar3 mar4 mar5 mar6 mar7)) (defconstant +command-map+ - '((#b001 . stop) + '(:rassoc + (#b001 . stop) (#b010 . start) (#b100 . transmit) (#o10 . remote-read) @@ -47,7 +48,8 @@ (#xc0 . page-3))) (defconstant +interrupt-status-map+ - #(packet-received + '(:enum + packet-received packet-transmitted receive-error transmit-error @@ -57,7 +59,8 @@ reset-status)) (defconstant +data-config-map+ - '((#x01 . dma-16-bit) + '(:rassoc + (#x01 . dma-16-bit) (#x02 . big-endian) (#x04 . dma-address-32bit) (#x08 . loopback-off) @@ -68,13 +71,15 @@ (#x60 . fifo-threshold-12-bytes))) (defconstant +tx-config-map+ - '((#x00 . loopback-mode-0) + '(:rassoc + (#x00 . loopback-mode-0) (#x02 . loopback-mode-1) (#x04 . loopback-mode-2) (#x06 . loopback-mode-3))) (defconstant +rx-config-map+ - '((#x01 . save-error-packets) + '(:rassoc + (#x01 . save-error-packets) (#x02 . runt-packets) (#x04 . broadcast) (#x08 . multicast) @@ -82,7 +87,7 @@ (#x20 . monitor-mode))) (defconstant +command-bit-map+ - #(stop start transmit)) + '(:enum stop start transmit)) ;;; Convenience syntax

1 0

[movitz-cvs] CVS update: movitz/losp/lib/named-integers.lisp
by Frode Vatvedt Fjeld 05 May '04

05 May '04

Update of /project/movitz/cvsroot/movitz/losp/lib In directory common-lisp.net:/tmp/cvs-serv2468 Modified Files: named-integers.lisp Log Message: Changed the with-named-integers-syntax macro a bit, trying to make this mechanism a bit more general and useful. Date: Wed May 5 04:24:22 2004 Author: ffjeld Index: movitz/losp/lib/named-integers.lisp diff -u movitz/losp/lib/named-integers.lisp:1.3 movitz/losp/lib/named-integers.lisp:1.4 --- movitz/losp/lib/named-integers.lisp:1.3 Mon Jan 19 06:23:44 2004 +++ movitz/losp/lib/named-integers.lisp Wed May 5 04:24:21 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Jan 4 16:13:46 2002 ;;;; -;;;; $Id: named-integers.lisp,v 1.3 2004/01/19 11:23:44 ffjeld Exp $ +;;;; $Id: named-integers.lisp,v 1.4 2004/05/05 08:24:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -20,13 +20,14 @@ (in-package muerte.lib) -(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (:compile-toplevel :load-toplevel) (defun name->integer (map name) (if (integerp name) name - (or (etypecase map - (vector (position name map)) - (list (car (rassoc name map)))) + (or (ecase (car map) + (:enum (position name (cdr map))) + (:assoc (cdr (assoc name (cdr map)))) + (:rassoc (car (rassoc name (cdr map))))) (error "No integer named ~S in ~S." name map)))) (defun names->integer (map &rest names) (declare (dynamic-extent names)) @@ -34,11 +35,13 @@ sum (name->integer map name)))) (defmacro with-named-integers-syntax (name-maps &body body) - `(macrolet ,(mapcar (lambda (name-map) - (destructuring-bind (name map) - name-map - `(,name (&rest names) (apply 'muerte.lib:names->integer ,map names)))) - name-maps) + `(macrolet + ,(mapcar (lambda (name-map) + (destructuring-bind (name map) + name-map + `(,name (&rest names) + (apply 'muerte.lib:names->integer ,map names)))) + name-maps) ,@body)) (define-compile-time-variable *name-to-integer-tables*

1 0