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

[movitz-cvs] CVS update: movitz/losp/muerte/symbols.lisp
by Frode Vatvedt Fjeld 14 Jun '04

14 Jun '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv5940 Modified Files: symbols.lisp Log Message: Changed copy-symbol to just copy the raw words. This is required for shallow-copying, especially during GC. Date: Mon Jun 14 12:40:42 2004 Author: ffjeld Index: movitz/losp/muerte/symbols.lisp diff -u movitz/losp/muerte/symbols.lisp:1.13 movitz/losp/muerte/symbols.lisp:1.14 --- movitz/losp/muerte/symbols.lisp:1.13 Wed Jun 9 10:21:01 2004 +++ movitz/losp/muerte/symbols.lisp Mon Jun 14 12:40:42 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 4 23:55:41 2001 ;;;; -;;;; $Id: symbols.lisp,v 1.13 2004/06/09 17:21:01 ffjeld Exp $ +;;;; $Id: symbols.lisp,v 1.14 2004/06/14 19:40:42 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -141,10 +141,10 @@ (load-global-constant movitz::unbound-function)))))) (defun %create-symbol (name &optional (package nil) - (plist nil) - (value (load-global-constant unbound-value)) - (function (load-global-constant movitz::unbound-function)) - (flags 0)) + (plist nil) + (value (load-global-constant unbound-value)) + (function (load-global-constant movitz::unbound-function)) + (flags 0)) (eval-when (:compile-toplevel) (assert (= 1 (- (movitz:tag :symbol) (movitz:tag :other))))) (let ((symbol (%word-offset (malloc-clumps 3) 1))) @@ -170,12 +170,11 @@ (if (or (eq nil symbol) (not copy-properties)) (%create-symbol (symbol-name symbol)) - (%create-symbol (symbol-name symbol) - nil - (symbol-plist symbol) - (%unbounded-symbol-value symbol) - (%unbounded-symbol-function symbol) - (symbol-flags symbol)))) + (let ((x (%word-offset (malloc-clumps 3) 1))) + (dotimes (i 6) + (setf (memref x #.movitz:+other-type-offset+ i :lisp) + (memref symbol #.movitz:+other-type-offset+ i :lisp))) + x))) (defun symbol-flags (symbol) (etypecase symbol

1 0

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

11 Jun '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv18015 Modified Files: integers.lisp Log Message: Minor fix to logior compiler-macro. Date: Fri Jun 11 16:26:38 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.37 movitz/losp/muerte/integers.lisp:1.38 --- movitz/losp/muerte/integers.lisp:1.37 Thu Jun 10 12:25:05 2004 +++ movitz/losp/muerte/integers.lisp Fri Jun 11 16:26:38 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.37 2004/06/10 19:25:05 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.38 2004/06/11 23:26:38 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1526,13 +1526,13 @@ 0 (reduce #'logior integers))))) -(define-compiler-macro logior (&whole form &rest integers) +(define-compiler-macro logior (&whole form &rest integers &environment env) (let ((constant-folded-integers (loop for x in integers with folded-constant = 0 - if (and (movitz:movitz-constantp x) - (not (zerop (movitz::movitz-eval x)))) + if (and (movitz:movitz-constantp x env) + (not (zerop (movitz:movitz-eval x env)))) do (setf folded-constant - (logior folded-constant (movitz::movitz-eval x))) + (logior folded-constant (movitz:movitz-eval x env))) else collect x into non-constants finally (return (if (= 0 folded-constant) non-constants

1 0

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

11 Jun '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv17833 Modified Files: scavenge.lisp Log Message: Rearranged vector objects a bit. Changed map-heap-words accordingly. Also fixed some serious bugs in map-heap-words. Date: Fri Jun 11 16:26:14 2004 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.9 movitz/losp/muerte/scavenge.lisp:1.10 --- movitz/losp/muerte/scavenge.lisp:1.9 Thu Jun 10 12:29:45 2004 +++ movitz/losp/muerte/scavenge.lisp Fri Jun 11 16:26:14 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.9 2004/06/10 19:29:45 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.10 2004/06/11 23:26:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -42,7 +42,13 @@ (movitz:tag primary)))) `(with-inline-assembly (:returns :boolean-zf=1) (:compile-form (:result-mode :eax) ,x) - (:cmpw ,code :ax))))) + (:cmpw ,code :ax)))) + (word-upper16 (x) + "Consider x as a 32-bit integer, and return the upper 16 bits (as a fixnum)." + `(with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :eax) ,x) + (:andl #xffff0000 :eax) + (:shrl ,(- 16 movitz:+movitz-fixnum-shift+) :eax)))) (do ((scan start-location (1+ scan))) ((>= scan end-location)) (let (;; (*i* i) @@ -53,11 +59,11 @@ ((scavenge-typep x :illegal) (error "Illegal word ~Z at ~S." x scan)) ((scavenge-typep x :bignum) + (assert (evenp scan)) ;; Just skip the bigits - (let* ((bigits (memref scan 2 0 :unsigned-byte16)) - (size (+ 2 (logand bigits -2)))) - (assert (and (plusp bigits) (evenp size))) - (incf scan size))) + (let* ((bigits (word-upper16 x)) + (delta (1+ (logand bigits -2)))) + (incf scan delta))) ((scavenge-typep x :funobj) ;; Process code-vector pointer specially.. (let* ((funobj (%word-offset scan #.(movitz:tag :other))) @@ -79,14 +85,14 @@ #.(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))) + (let ((len (word-upper16 x))) (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))) + (let ((len (word-upper16 x))) (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 (1+ (* 2 (truncate (+ 1 len) 2)))))) + (let ((len (word-upper16 x))) + (incf scan (1+ (logand (1+ len) -2))))) ((eq x (fixnum-word 3)) (incf scan) (incf scan (memref scan 0 0 :lisp)))

1 0

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

11 Jun '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv17656 Modified Files: storage-types.lisp Log Message: Rearranged vector objects a bit. Changed map-heap-words accordingly. Also fixed some serious bugs in map-heap-words. Date: Fri Jun 11 16:26:09 2004 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.19 movitz/storage-types.lisp:1.20 --- movitz/storage-types.lisp:1.19 Wed Jun 9 10:19:24 2004 +++ movitz/storage-types.lisp Fri Jun 11 16:26:09 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.19 2004/06/09 17:19:24 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.20 2004/06/11 23:26:09 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -342,10 +342,10 @@ :bit 5) :initarg :element-type :reader movitz-vector-element-type) - (fill-pointer + (num-elements :binary-type lu16 - :initarg :fill-pointer - :accessor movitz-vector-fill-pointer) + :initarg :num-elements + :reader movitz-vector-num-elements) (flags :accessor movitz-vector-flags :initarg :flags @@ -359,10 +359,10 @@ :initform 0 :initarg :alignment-power :reader movitz-vector-alignment-power) - (num-elements + (fill-pointer :binary-type lu16 - :initarg :num-elements - :reader movitz-vector-num-elements) + :initarg :fill-pointer + :accessor movitz-vector-fill-pointer) (data :binary-lisp-type :label) ; data follows physically here (symbolic-data

1 0

[movitz-cvs] CVS update: movitz/special-operators-cl.lisp
by Frode Vatvedt Fjeld 11 Jun '04

11 Jun '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv5428 Modified Files: special-operators-cl.lisp Log Message: Produce some extra defensive code at catch targets. Date: Fri Jun 11 14:34:02 2004 Author: ffjeld Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.18 movitz/special-operators-cl.lisp:1.19 --- movitz/special-operators-cl.lisp:1.18 Wed Jun 9 10:26:07 2004 +++ movitz/special-operators-cl.lisp Fri Jun 11 14:34:02 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 24 16:31:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: special-operators-cl.lisp,v 1.18 2004/06/09 17:26:07 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.19 2004/06/11 21:34:02 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1165,8 +1165,13 @@ body-code `((:popl :ebp) ; This value is identical to current EBP. ,exit-point - (:leal (:esp ,(+ -8 16)) :esp) - (:locally (:popl (:edi (:edi-offset dynamic-env))))))))) + (:leal (:esp ,(+ -8 16)) :esp)) + (if (not *compiler-produce-defensive-code*) + `((:locally (:popl (:edi (:edi-offset dynamic-env))))) + `((:xchgl :ecx (:esp)) + (:locally (:bound (:edi (:edi-offset stack-bottom)) :ecx)) + (:locally (:movl :ecx (:edi (:edi-offset dynamic-env)))) + (:popl :ecx))))))) (define-special-operator unwind-protect (&all all &form form &env env) (destructuring-bind (protected-form &body cleanup-forms)

1 0

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

10 Jun '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv18655 Modified Files: image.lisp Log Message: Added a scratch register to the run-time-context. Why didn't I do this before? Date: Thu Jun 10 12:31:06 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.38 movitz/image.lisp:1.39 --- movitz/image.lisp:1.38 Wed Jun 9 10:25:03 2004 +++ movitz/image.lisp Thu Jun 10 12:31:06 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.38 2004/06/09 17:25:03 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.39 2004/06/10 19:31:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -17,16 +17,16 @@ (define-binary-class movitz-constant-block (movitz-heap-object) ((constant-block-start :binary-type :label) ; keep this at the top. - (name - :binary-type word - :initform :global - :map-binary-write 'movitz-read-and-intern - :map-binary-read-delayed 'movitz-word) (type :binary-type other-type-byte :initform :run-time-context) (padding :binary-type 3) + (name + :binary-type word + :initform :global + :map-binary-write 'movitz-read-and-intern + :map-binary-read-delayed 'movitz-word) (fast-car :binary-type code-vector-word :initform nil @@ -485,7 +485,9 @@ (bochs-flags :binary-type lu32 :initform 0) - ) + (scratch0 ; A non-GC-root scratch register + :binary-type lu32 + :initform 0)) (:slot-align null-cons -1)) (defun atomically-status-simple-pf (pf-name reset-status-p &rest registers)

1 0

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

10 Jun '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv16752 Modified Files: compiler.lisp Log Message: Added compiler variable *compiler-produce-defensive-code*. Date: Thu Jun 10 12:30:19 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.67 movitz/compiler.lisp:1.68 --- movitz/compiler.lisp:1.67 Thu Jun 10 05:05:56 2004 +++ movitz/compiler.lisp Thu Jun 10 12:30:19 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.67 2004/06/10 12:05:56 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.68 2004/06/10 19:30:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -60,6 +60,9 @@ (defvar *compiler-do-type-inference* t "Spend time and effort performing type inference and optimization.") +(defvar *compiler-produce-defensive-code* t + "Try make code be extra cautious.") + (defvar *compiling-function-name*) (defvar muerte.cl:*compile-file-pathname* nil) @@ -68,6 +71,7 @@ (defvar *extended-code-find-write-binding-and-type* (make-hash-table :test #'eq)) + (defconstant +enter-stack-frame-code+ '((:pushl :ebp)

1 0

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

10 Jun '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv14950 Modified Files: scavenge.lisp Log Message: Added support for bignums in map-heap-words. So now you can GC all those bigguns. Date: Thu Jun 10 12:29:45 2004 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.8 movitz/losp/muerte/scavenge.lisp:1.9 --- movitz/losp/muerte/scavenge.lisp:1.8 Wed Jun 2 07:31:15 2004 +++ movitz/losp/muerte/scavenge.lisp Thu Jun 10 12:29:45 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.8 2004/06/02 14:31:15 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.9 2004/06/10 19:29:45 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -52,6 +52,12 @@ ((typep x '(or null fixnum character))) ((scavenge-typep x :illegal) (error "Illegal word ~Z at ~S." x scan)) + ((scavenge-typep x :bignum) + ;; Just skip the bigits + (let* ((bigits (memref scan 2 0 :unsigned-byte16)) + (size (+ 2 (logand bigits -2)))) + (assert (and (plusp bigits) (evenp size))) + (incf scan size))) ((scavenge-typep x :funobj) ;; Process code-vector pointer specially.. (let* ((funobj (%word-offset scan #.(movitz:tag :other))) @@ -68,7 +74,7 @@ )) (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)) + (error "Scanning an infant object ~Z at ~S (end ~S)." x scan end-location)) ((or (scavenge-wide-typep x :vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u8)) (scavenge-wide-typep x :vector @@ -140,37 +146,57 @@ (values)) (defparameter *primitive-funcall-patterns* - '(#xff #x57 (:function-offset :signed8))) + '((:or + (#xff #x57 (:function-offset :signed8)) ; + (#xff #x97 (:function-offset :signed32))))) ; (defun stack-frame-primitive-funcall (funobj stack-location eip-location) + "Is stack-frame in a primitive-function? +If so, return the primitive-function's code-vector." (let ((return-address (memref stack-location 0 0 :unsigned-byte32)) (code-vector (funobj-code-vector funobj))) (multiple-value-bind (return-location return-delta) (truncate return-address #.movitz:+movitz-fixnum-factor+) (if (not (location-in-object-p code-vector return-location)) - nil - (multiple-value-bind (success-p type code) - (match-code-pattern *primitive-funcall-patterns* - code-vector (+ (* (- return-location - (object-location code-vector)) - #.movitz:+movitz-fixnum-factor+) - return-delta - -3 -8) - :function-offset) - (if (not success-p) - (warn "mismatch in ~S at ~D from #x~X in ~Z." - funobj - (+ (* (- return-location - (object-location code-vector)) - #.movitz:+movitz-fixnum-factor+) - return-delta - -3 -8) - return-address code-vector) - (let* ((offset (ecase type - (:signed8 - (if (not (logbitp 7 code)) code (- code 256))))) - (primitive-function (%word-offset (%run-time-context-ref offset) -2))) - (check-type primitive-function vector-u8) - (if (not (location-in-object-p primitive-function eip-location)) - nil - primitive-function)))))))) + nil ; A PF must have return-address on top of stack. + (dotimes (offset 5 (warn "mismatch in ~S at ~D from #x~X in ~Z." + funobj + (+ (* (- return-location + (object-location code-vector)) + #.movitz:+movitz-fixnum-factor+) + return-delta + -3 -8) + return-address code-vector)) + (multiple-value-bind (success-p type code ip) + (match-code-pattern *primitive-funcall-patterns* + code-vector (+ (* (- return-location + (object-location code-vector)) + #.movitz:+movitz-fixnum-factor+) + return-delta + -3 -8 (- offset)) + :function-offset) + (when success-p + (return + (let* ((offset (case type + (:signed8 + (if (not (logbitp 7 code)) code (- code 256))) + (:signed32 + ;; We must read the unsigned-byte32 that starts at ip + (let ((x (logior (aref code-vector (- ip 1)) + (* (aref code-vector (+ 0 ip)) #x100) + (* (aref code-vector (+ 1 ip)) #x10000) + (* (aref code-vector (+ 2 ip)) #x1000000)))) + (if (not (logbitp 7 (aref code-vector (+ ip 2)))) + x + (break "Negative 32-bit offset.")))) + (t (break "Match fail: vec: ~Z, ip: ~D" + code-vector (+ (* (- return-location + (object-location code-vector)) + #.movitz:+movitz-fixnum-factor+) + return-delta + -3 -8))))) + (primitive-function (%word-offset (%run-time-context-ref offset) -2))) + (check-type primitive-function vector-u8) + (if (not (location-in-object-p primitive-function eip-location)) + nil + primitive-function))))))))))

1 0

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

10 Jun '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv13169 Modified Files: primitive-functions.lisp Log Message: Added some defensive checks in dynamic-load. Date: Thu Jun 10 12:28:19 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.21 movitz/losp/muerte/primitive-functions.lisp:1.22 --- movitz/losp/muerte/primitive-functions.lisp:1.21 Thu Jun 10 05:19:47 2004 +++ movitz/losp/muerte/primitive-functions.lisp Thu Jun 10 12:28:19 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.21 2004/06/10 12:19:47 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.22 2004/06/10 19:28:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -240,11 +240,15 @@ (with-inline-assembly (:returns :multiple-values) (:locally (:movl (:edi (:edi-offset dynamic-env)) :ecx)) (:jecxz 'no-stack-binding) + ;; Be defensive: Verify that ECX is within stack. + (:locally (:bound (:edi (:edi-offset stack-bottom)) :ecx)) (:cmpl :eax (:ecx)) (:je 'success) search-loop (:movl (:ecx 12) :ecx) ; parent (:jecxz 'no-stack-binding) + ;; Be defensive: Verify that ECX is within stack. + (:locally (:bound (:edi (:edi-offset stack-bottom)) :ecx)) (:cmpl :eax (:ecx)) ; compare name (:jne 'search-loop) ;; fall through on success

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/more-macros.lisp
by Frode Vatvedt Fjeld 10 Jun '04

10 Jun '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv12745 Modified Files: more-macros.lisp Log Message: Changed dolist a bit. Date: Thu Jun 10 12:27:36 2004 Author: ffjeld Index: movitz/losp/muerte/more-macros.lisp diff -u movitz/losp/muerte/more-macros.lisp:1.10 movitz/losp/muerte/more-macros.lisp:1.11 --- movitz/losp/muerte/more-macros.lisp:1.10 Wed Jun 9 16:04:26 2004 +++ movitz/losp/muerte/more-macros.lisp Thu Jun 10 12:27:36 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.10 2004/06/09 23:04:26 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.11 2004/06/10 19:27:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -129,15 +129,11 @@ ,@declarations-and-body))) (defmacro dolist ((var list-form &optional result-form) &body declarations-and-body) - (let ((cons-var (gensym (format nil "dolist-cons-var-~A-" var))) - (loop-tag (gensym "dolist-loop-tag-"))) - `(prog ((,cons-var ,list-form)) - ,loop-tag - (when ,cons-var - (let ((,var (pop ,cons-var))) - ,@declarations-and-body) - (go ,loop-tag)) - ,(when result-form `(return ,result-form))))) + (let ((cons-var (gensym "dolist-cons-"))) + `(do ((,cons-var ,list-form)) + ((null ,cons-var) ,result-form) + (let ((,var (pop ,cons-var))) + ,@declarations-and-body)))) (defmacro letf* (bindings &body body &environment env) "Does what one might expect, saving the old values and setting the generalized @@ -315,8 +311,7 @@ (define-compiler-macro %bignum-bigits (x) `(with-inline-assembly (:returns :eax) (:compile-form (:result-mode :eax) ,x) - (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum - 'movitz::length)) + (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-bignum 'movitz::length)) :ecx) (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :eax)))

1 0