movitz-cvs

movitz-cvs@common-lisp.net

2595 discussions

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

12 Oct '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv26496 Modified Files: symbols.lisp Log Message: Fixed some symbol accessors to use memref rather than inline assembly. Date: Tue Oct 12 16:45:17 2004 Author: ffjeld Index: movitz/losp/muerte/symbols.lisp diff -u movitz/losp/muerte/symbols.lisp:1.20 movitz/losp/muerte/symbols.lisp:1.21 --- movitz/losp/muerte/symbols.lisp:1.20 Mon Oct 11 15:53:28 2004 +++ movitz/losp/muerte/symbols.lisp Tue Oct 12 16:45:16 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.20 2004/10/11 13:53:28 ffjeld Exp $ +;;;; $Id: symbols.lisp,v 1.21 2004/10/12 14:45:16 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -211,19 +211,16 @@ (etypecase symbol (null #.(bt:enum-value 'movitz::movitz-symbol-flags '(:constant-variable))) (symbol - (with-inline-assembly (:returns :untagged-fixnum-eax) - (:compile-form (:result-mode :eax) symbol) - (:movzxw (:eax #.(bt:slot-offset 'movitz::movitz-symbol 'movitz::flags)) :eax))))) + (memref symbol (movitz-type-slot-offset 'movitz-symbol 'flags) + :type :unsigned-byte16)))) (defun (setf symbol-flags) (flags symbol) (etypecase symbol (null (error "Can't set NIL's flags.")) (symbol - (with-inline-assembly (:returns :nothing) - (:compile-form (:result-mode :ebx) symbol) - (:compile-form (:result-mode :untagged-fixnum-eax) flags) - (:movw :ax (:ebx #.(bt:slot-offset 'movitz::movitz-symbol 'movitz::flags)))) - flags))) + (setf (memref symbol (movitz-type-slot-offset 'movitz-symbol 'flags) + :type :unsigned-byte16) + flags)))) (defun symbol-special-variable-p (symbol) (logbitp 3 (symbol-flags symbol)))

1 0

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

12 Oct '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv26225 Modified Files: integers.lisp Log Message: Fixed incredibly stupid bug in ratio multiplication. Date: Tue Oct 12 16:43:56 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.99 movitz/losp/muerte/integers.lisp:1.100 --- movitz/losp/muerte/integers.lisp:1.99 Tue Oct 12 12:51:47 2004 +++ movitz/losp/muerte/integers.lisp Tue Oct 12 16:43:55 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.99 2004/10/12 10:51:47 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.100 2004/10/12 14:43:55 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1152,7 +1152,7 @@ (incf r (ash (* x (ldb (byte 29 i) y)) i))))) ((ratio ratio) (make-rational (* (ratio-numerator x) (ratio-numerator y)) - (* (ratio-denominator x) (ratio-denominator x)))) + (* (ratio-denominator x) (ratio-denominator y)))) ((ratio t) (make-rational (* y (ratio-numerator x)) (ratio-denominator x)))

1 0

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

12 Oct '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv26193 Modified Files: functions.lisp Log Message: Removed some usage of the deprecated mode :untagged-fixnum-eax. Date: Tue Oct 12 16:43:28 2004 Author: ffjeld Index: movitz/losp/muerte/functions.lisp diff -u movitz/losp/muerte/functions.lisp:1.22 movitz/losp/muerte/functions.lisp:1.23 --- movitz/losp/muerte/functions.lisp:1.22 Mon Oct 11 15:52:34 2004 +++ movitz/losp/muerte/functions.lisp Tue Oct 12 16:43:27 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Mar 12 22:58:54 2002 ;;;; -;;;; $Id: functions.lisp,v 1.22 2004/10/11 13:52:34 ffjeld Exp $ +;;;; $Id: functions.lisp,v 1.23 2004/10/12 14:43:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -166,15 +166,14 @@ (:compile-form (:result-mode :ebx) funobj) (:compile-form (:result-mode :eax) code-vector) (:addl 2 :eax) ; this cell stores word+2 - (:movl :eax (:ebx #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:code-vector%1op))))) + (:movl :eax (:ebx (:offset movitz-funobj code-vector%1op))))) (integer (with-inline-assembly (:returns :nothing) (:compile-form (:result-mode :ebx) funobj) - (:movl (:ebx #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:code-vector)) :eax) - (:movl :eax (:ebx #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:code-vector%1op))) - (:compile-form (:result-mode :untagged-fixnum-eax) code-vector) - (:addl :eax (:ebx #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:code-vector%1op))) - (:xorl :eax :eax)))) + (:movl (:ebx (:offset movitz-funobj code-vector)) :eax) + (:movl :eax (:ebx (:offset movitz-funobj code-vector%1op))) + (:compile-form (:result-mode :untagged-fixnum-ecx) code-vector) + (:addl :ecx (:ebx (:offset movitz-funobj code-vector%1op)))))) code-vector) (defun funobj-code-vector%2op (funobj) @@ -227,15 +226,14 @@ (:compile-form (:result-mode :ebx) funobj) (:compile-form (:result-mode :eax) code-vector) (:addl 2 :eax) ; this cell stores word+2 - (:movl :eax (:ebx #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:code-vector%2op))))) + (:movl :eax (:ebx (:offset movitz-funobj code-vector%2op))))) (integer (with-inline-assembly (:returns :nothing) (:compile-form (:result-mode :ebx) funobj) - (:movl (:ebx #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:code-vector)) :eax) - (:movl :eax (:ebx #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:code-vector%2op))) - (:compile-form (:result-mode :untagged-fixnum-eax) code-vector) - (:addl :eax (:ebx #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:code-vector%2op))) - (:xorl :eax :eax)))) + (:movl (:ebx (:offset movitz-funobj code-vector)) :eax) + (:movl :eax (:ebx (:offset movitz-funobj code-vector%2op))) + (:compile-form (:result-mode :untagged-fixnum-ecx) code-vector) + (:addl :ecx (:ebx (:offset movitz-funobj code-vector%2op)))))) code-vector) (defun funobj-code-vector%3op (funobj) @@ -288,15 +286,14 @@ (:compile-form (:result-mode :ebx) funobj) (:compile-form (:result-mode :eax) code-vector) (:addl 2 :eax) ; this cell stores word+2 - (:movl :eax (:ebx #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:code-vector%3op))))) + (:movl :eax (:ebx (:offset movitz-funobj code-vector%3op))))) (integer (with-inline-assembly (:returns :nothing) (:compile-form (:result-mode :ebx) funobj) - (:movl (:ebx #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:code-vector)) :eax) - (:movl :eax (:ebx #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:code-vector%3op))) - (:compile-form (:result-mode :untagged-fixnum-eax) code-vector) - (:addl :eax (:ebx #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:code-vector%3op))) - (:xorl :eax :eax)))) + (:movl (:ebx (:offset movitz-funobj code-vector)) :eax) + (:movl :eax (:ebx (:offset movitz-funobj code-vector%3op))) + (:compile-form (:result-mode :untagged-fixnum-ecx) code-vector) + (:addl :ecx (:ebx (:offset movitz-funobj code-vector%3op)))))) code-vector) (defun funobj-name (funobj)

1 0

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

12 Oct '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv26161 Modified Files: format.lisp Log Message: Fixed format-float (used by ~F) to handle negative numbers. Date: Tue Oct 12 16:42:42 2004 Author: ffjeld Index: movitz/losp/muerte/format.lisp diff -u movitz/losp/muerte/format.lisp:1.7 movitz/losp/muerte/format.lisp:1.8 --- movitz/losp/muerte/format.lisp:1.7 Sat Jul 31 00:15:23 2004 +++ movitz/losp/muerte/format.lisp Tue Oct 12 16:42:41 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.7 2004/07/30 22:15:23 ffjeld Exp $ +;;;; $Id: format.lisp,v 1.8 2004/10/12 14:42:41 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -60,26 +60,29 @@ (write x)))) (defun format-float (x &optional at-sign-p colon-p w d (k 0) overflowchar padchar) - (declare (ignore w overflowchar padchar at-sign-p colon-p)) - (if (eql 0 d) - (write-integer (round x) *standard-output* 10 nil) - (multiple-value-bind (integer-part decimal-part) - (truncate x) - (write-integer integer-part *standard-output* 10 nil) - (dotimes (i k) - (write-char #\0)) - (write-char #\.) - (do ((remainder decimal-part) - (last-i (if d (1- d) 15)) - (i 0 (1+ i))) - ((or (and (not d) (plusp i) (zerop remainder)) - (> i last-i))) - (multiple-value-bind (next-digit next-remainder) - (if (= i last-i) - (round (* 10 remainder)) - (truncate (* 10 remainder))) - (setf remainder next-remainder) - (write-digit next-digit *standard-output*)))))) + (cond + ((eql 0 d) + (write-integer (round x) *standard-output* 10 nil)) + ((minusp x) + (write-char #\-) + (format-float (- x) at-sign-p colon-p w d k overflowchar padchar)) + (t (multiple-value-bind (integer-part decimal-part) + (truncate x) + (write-integer integer-part *standard-output* 10 nil) + (dotimes (i k) + (write-char #\0)) + (write-char #\.) + (do ((remainder decimal-part) + (last-i (if d (1- d) 15)) + (i 0 (1+ i))) + ((or (and (not d) (plusp i) (zerop remainder)) + (> i last-i))) + (multiple-value-bind (next-digit next-remainder) + (if (= i last-i) + (round (* 10 remainder)) + (truncate (* 10 remainder))) + (setf remainder next-remainder) + (write-digit next-digit *standard-output*))))))) (defun find-directive (string i directive &optional recursive-skip-start (recursive-skip-end directive))

1 0

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

12 Oct '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv11825 Modified Files: integers.lisp Log Message: Fixed one-operand - and two-operand / on ratios. Date: Tue Oct 12 12:51:47 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.98 movitz/losp/muerte/integers.lisp:1.99 --- movitz/losp/muerte/integers.lisp:1.98 Mon Oct 11 15:52:50 2004 +++ movitz/losp/muerte/integers.lisp Tue Oct 12 12:51:47 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.98 2004/10/11 13:52:50 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.99 2004/10/12 10:51:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -688,44 +688,23 @@ (declare (dynamic-extent subtrahends)) (numargs-case (1 (x) - (macrolet - ((do-it () - `(with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) x) - (:testb ,movitz:+movitz-fixnum-zmask+ :al) - (:jnz '(:sub-program (not-fixnum) - (:leal (:eax ,(- (movitz:tag :other))) :ecx) - (:testb 7 :cl) - (:jnz '(:sub-program (not-a-number) - (:compile-form (:result-mode :ignore) - (if (typep x 'ratio) - (make-rational (- (%ratio-numerator x)) - (%ratio-denominator x)) - (error 'type-error :expected-type 'number :datum x))))) - (:movl (:eax ,movitz:+other-type-offset+) :ecx) - (:cmpb ,(movitz:tag :bignum) :cl) - (:jne 'not-a-number) - (:cmpl ,(dpb 4 (byte 16 16) (movitz:tag :bignum 0)) :ecx) - (:jne 'not-most-negative-fixnum) - (:cmpl ,(- most-negative-fixnum) (:eax (:offset movitz-bignum bigit0))) - (:jne 'not-most-negative-fixnum) - (:movl ,(ldb (byte 32 0) - (* most-negative-fixnum movitz::+movitz-fixnum-factor+)) - :eax) - (:jmp 'fix-ok) - not-most-negative-fixnum - (:compile-form (:result-mode :eax) - (copy-bignum x)) - (:notb (:eax (:offset movitz-bignum sign))) - (:jmp 'fix-ok))) - (:negl :eax) - (:jo '(:sub-program (fix-overflow) - (:compile-form (:result-mode :eax) - ,(1+ movitz:+movitz-most-positive-fixnum+)) - (:jmp 'fix-ok))) - fix-ok - ))) - (do-it))) + (etypecase x + (fixnum + (macrolet + ((do-it () + `(with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :eax) x) + (:negl :eax) + (:jo '(:sub-program (fix-overflow) + (:compile-form (:result-mode :eax) + ,(1+ movitz:+movitz-most-positive-fixnum+)) + (:jmp 'fix-ok))) + fix-ok))) + (do-it))) + (bignum + (%bignum-negate (copy-bignum x))) + (ratio + (make-ratio (- (ratio-numerator x)) (ratio-denominator x))))) (2 (minuend subtrahend) (macrolet ((do-it () @@ -1421,9 +1400,11 @@ (2 (x y) (multiple-value-bind (q r) (truncate x y) - (if (= 0 r) - q - (make-rational x y)))) + (cond + ((= 0 r) + q) + (t (make-rational (* (numerator x) (denominator y)) + (* (denominator x) (numerator y))))))) (t (number &rest denominators) (declare (dynamic-extent denominators)) (cond

1 0

[movitz-cvs] CVS update: ia-x86/proglist.lisp
by Frode Vatvedt Fjeld 12 Oct '04

12 Oct '04

Update of /project/movitz/cvsroot/ia-x86 In directory common-lisp.net:/tmp/cvs-serv7116 Modified Files: proglist.lisp Log Message: Removed warning about "assumption bigger than.." Date: Tue Oct 12 11:37:25 2004 Author: ffjeld Index: ia-x86/proglist.lisp diff -u ia-x86/proglist.lisp:1.5 ia-x86/proglist.lisp:1.6 --- ia-x86/proglist.lisp:1.5 Thu Sep 2 11:02:40 2004 +++ ia-x86/proglist.lisp Tue Oct 12 11:37:24 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Mon May 15 13:43:55 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: proglist.lisp,v 1.5 2004/09/02 09:02:40 ffjeld Exp $ +;;;; $Id: proglist.lisp,v 1.6 2004/10/12 09:37:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -101,7 +101,6 @@ :current-pc referring-pc) optimize-teo))) (when (< (imagpart cdatum) assumed-length) - (warn "Assumption ~D bigger than actual ~D" assumed-length (imagpart cdatum)) (setf cdatum (instruction-encode instruction (make-assemble-env :symtab (assemble-env-symtab env)

1 0

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

11 Oct '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv30856 Modified Files: symbols.lisp Log Message: Changed the signature of memref and (setf memref) to use keywords also for the index and type arguments. Date: Mon Oct 11 15:53:28 2004 Author: ffjeld Index: movitz/losp/muerte/symbols.lisp diff -u movitz/losp/muerte/symbols.lisp:1.19 movitz/losp/muerte/symbols.lisp:1.20 --- movitz/losp/muerte/symbols.lisp:1.19 Wed Sep 22 20:49:24 2004 +++ movitz/losp/muerte/symbols.lisp Mon Oct 11 15:53:28 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.19 2004/09/22 18:49:24 ffjeld Exp $ +;;;; $Id: symbols.lisp,v 1.20 2004/10/11 13:53:28 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -74,13 +74,13 @@ (setf (symbol-value symbol) value)) (define-compiler-macro %symbol-global-value (symbol) - `(memref ,symbol ,(bt:slot-offset 'movitz:movitz-symbol 'movitz::value) 0 :lisp)) + `(memref ,symbol ,(bt:slot-offset 'movitz:movitz-symbol 'movitz::value))) (defun %symbol-global-value (symbol) (%symbol-global-value symbol)) (define-compiler-macro (setf %symbol-global-value) (value symbol) - `(setf (memref ,symbol ,(bt:slot-offset 'movitz:movitz-symbol 'movitz::value) 0 :lisp) + `(setf (memref ,symbol ,(bt:slot-offset 'movitz:movitz-symbol 'movitz::value)) ,value)) (defun (setf %symbol-global-value) (value symbol) @@ -94,7 +94,8 @@ (defun %unbounded-symbol-function (symbol) (check-type symbol symbol) - (movitz-accessor symbol movitz-symbol function-value)) + (memref symbol (movitz-type-slot-offset 'movitz-symbol 'function-value))) + ;; (movitz-accessor symbol movitz-symbol function-value)) (defun (setf symbol-function) (value symbol) (check-type symbol symbol) @@ -109,7 +110,8 @@ (null (error "Can't change the name of NIL.")) (symbol - (setf-movitz-accessor (symbol movitz-symbol name) value)))) + (setf (memref symbol (movitz-type-slot-offset 'movitz-symbol 'name)) + value)))) (defun symbol-plist (symbol) (get-symbol-slot symbol plist)) @@ -119,7 +121,8 @@ (null (error "Can't change the plist of NIL.")) (symbol - (setf-movitz-accessor (symbol movitz-symbol plist) value)))) + (setf (memref symbol (movitz-type-slot-offset 'movitz-symbol 'plist)) + value)))) (defun symbol-package (symbol) (get-symbol-slot symbol package))

1 0

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

11 Oct '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv30831 Modified Files: scavenge.lisp Log Message: Changed the signature of memref and (setf memref) to use keywords also for the index and type arguments. Date: Mon Oct 11 15:53:25 2004 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.32 movitz/losp/muerte/scavenge.lisp:1.33 --- movitz/losp/muerte/scavenge.lisp:1.32 Tue Sep 21 15:56:32 2004 +++ movitz/losp/muerte/scavenge.lisp Mon Oct 11 15:53:25 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.32 2004/09/21 13:56:32 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.33 2004/10/11 13:53:25 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -49,7 +49,7 @@ (with-simple-restart (continue-map-heap-words "Continue map-heap-words at location ~S." (1+ scan)) (let ((*scan* scan) - (x (memref scan 0 0 :unsigned-byte16))) + (x (memref scan 0 :type :unsigned-byte16))) (declare (special *scan*)) (when verbose (format *terminal-io* " [at ~S: ~S]" scan x)) @@ -65,7 +65,7 @@ (assert (evenp scan) () "Scanned bignum-header ~S at odd location #x~X." x scan) ;; Just skip the bigits - (let* ((bigits (memref scan 0 1 :unsigned-byte14)) + (let* ((bigits (memref scan 0 :index 1 :type :unsigned-byte14)) (delta (logior bigits 1))) (setf *scan-last* (%word-offset scan #.(movitz:tag :other))) (incf scan delta))) @@ -76,7 +76,7 @@ ((scavenge-typep x :funobj) (assert (evenp scan) () "Scanned funobj-header ~S at odd location #x~X." - (memref scan 0 0 :unsigned-byte32) scan) + (memref scan 0 :type :unsigned-byte32) scan) (setf *scan-last* (%word-offset scan #.(movitz:tag :other))) ;; Process code-vector pointers specially.. (let* ((funobj (%word-offset scan #.(movitz:tag :other))) @@ -88,7 +88,7 @@ (check-type new-code-vector code-vector) (unless (eq code-vector new-code-vector) (error "Code-vector migration is not implemented.") - (setf (memref scan 0 -1 :lisp) (%word-offset new-code-vector 2)) + (setf (memref scan 0 :index -1) (%word-offset new-code-vector 2)) ;; Do more stuff here to update code-vectors and jumpers )) (incf scan (+ 7 num-jumpers)))) ; Don't scan the jumpers. @@ -104,21 +104,21 @@ #.(bt:enum-value 'movitz:movitz-vector-element-type :code))) (assert (evenp scan) () "Scanned u8-vector-header ~S at odd location #x~X." x scan) - (let ((len (memref scan 0 1 :lisp))) + (let ((len (memref scan 0 :index 1 :type :lisp))) (check-type len positive-fixnum) (setf *scan-last* (%word-offset scan #.(movitz:tag :other))) (incf scan (1+ (* 2 (truncate (+ 7 len) 8)))))) ((scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u16)) (assert (evenp scan) () "Scanned u16-vector-header ~S at odd location #x~X." x scan) - (let ((len (memref scan 0 1 :lisp))) + (let ((len (memref scan 0 :index 1))) (check-type len positive-fixnum) (setf *scan-last* (%word-offset scan #.(movitz:tag :other))) (incf scan (1+ (* 2 (truncate (+ 3 len) 4)))))) ((scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u32)) (assert (evenp scan) () "Scanned u32-vector-header ~S at odd location #x~X." x scan) - (let ((len (memref scan 0 1 :lisp))) + (let ((len (memref scan 4))) (assert (typep len 'positive-fixnum) () "Scanned basic-vector at ~S with illegal length ~S." scan len) (setf *scan-last* (%word-offset scan #.(movitz:tag :other))) @@ -133,17 +133,17 @@ ((eq x 3) (setf *scan-last* scan) (incf scan) - (let ((delta (memref scan 0 0 :lisp))) + (let ((delta (memref scan 0))) (check-type delta positive-fixnum) ;; (warn "at ~S skipping ~S to ~S." scan delta (+ scan delta)) (incf scan delta))) (t ;; (typep x 'pointer) - (let* ((old (memref scan 0 0 :lisp)) + (let* ((old (memref scan 0)) (new (funcall function old scan))) (when verbose (format *terminal-io* " [~Z => ~Z]" old new)) (unless (eq old new) - (setf (memref scan 0 0 :lisp) new))))))))) + (setf (memref scan 0) new))))))))) (values)) (defun map-stack-words (function stack start-frame) @@ -229,14 +229,14 @@ (dit-frame-ref stack dit-frame :eip :location)) (cond ((let ((x0-tag (ldb (byte 3 0) - (memref interrupted-esp 0 0 :unsigned-byte8)))) + (memref interrupted-esp 0 :type :unsigned-byte8)))) (and (member x0-tag '(1 5 6 7)) (location-in-object-p casf-code-vector - (memref interrupted-esp 0 0 :location)))) + (memref interrupted-esp 0 :type :location)))) ;; When code-vector migration is implemented... (warn "Scanning at ~S X0 call ~S in ~S." (dit-frame-ref stack dit-frame :eip :unsigned-byte32) - (memref interrupted-esp 0 0 :unsigned-byte32) + (memref interrupted-esp 0 :type :unsigned-byte32) (funobj-name casf-funobj)) #+ignore (map-heap-words function (+ interrupted-esp 1) frame) (when (eq 0 (stack-frame-ref stack frame -1)) @@ -244,14 +244,14 @@ (setf next-frame frame next-nether-frame (+ interrupted-esp 1 -2))) ((let ((x1-tag (ldb (byte 3 0) - (memref interrupted-esp 4 0 :unsigned-byte8)))) + (memref interrupted-esp 4 :type :unsigned-byte8)))) (and (member x1-tag '(1 5 6 7)) (location-in-object-p casf-code-vector - (memref interrupted-esp 0 1 :location)))) + (memref interrupted-esp 4 :type :location)))) ;; When code-vector migration is implemented... (warn "Scanning at ~S X1 call ~S in ~S." (dit-frame-ref stack dit-frame :eip :unsigned-byte32) - (memref interrupted-esp 0 1 :unsigned-byte32) + (memref interrupted-esp 4 :type :unsigned-byte32) (funobj-name casf-funobj)) (when (eq 0 (stack-frame-ref stack frame -1)) (break "X1 call in DIT-frame.")) @@ -263,10 +263,10 @@ (setf next-frame frame next-nether-frame (- interrupted-esp 2)) ))) - ((eq casf-frame (memref interrupted-esp 0 0 :location)) + ((eq casf-frame (memref interrupted-esp 0 :type :location)) ;; Situation ii. esp(0)=CASF, esp(1)=code-vector (assert (location-in-object-p casf-code-vector - (memref interrupted-esp 0 1 :location)) + (memref interrupted-esp 4 :type :location)) () "Stack discipline situation ii. invariant broken. CASF=#x~X, ESP=~S, EBP=~S" casf-frame interrupted-esp interrupted-ebp) @@ -275,7 +275,7 @@ next-nether-frame (+ interrupted-esp 2 -2))) (t ;; Situation iii. esp(0)=code-vector. (assert (location-in-object-p casf-code-vector - (memref interrupted-esp 0 0 :location)) + (memref interrupted-esp 0 :type :location)) () "Stack discipline situation iii. invariant broken. CASF=#x~X" casf-frame) #+ignore (map-heap-words function (+ interrupted-esp 1) frame)

1 0

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

11 Oct '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv30804 Modified Files: run-time-context.lisp Log Message: Changed the signature of memref and (setf memref) to use keywords also for the index and type arguments. Date: Mon Oct 11 15:53:20 2004 Author: ffjeld Index: movitz/losp/muerte/run-time-context.lisp diff -u movitz/losp/muerte/run-time-context.lisp:1.14 movitz/losp/muerte/run-time-context.lisp:1.15 --- movitz/losp/muerte/run-time-context.lisp:1.14 Mon Sep 27 10:54:53 2004 +++ movitz/losp/muerte/run-time-context.lisp Mon Oct 11 15:53:19 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Nov 12 18:33:02 2003 ;;;; -;;;; $Id: run-time-context.lisp,v 1.14 2004/09/27 08:54:53 ffjeld Exp $ +;;;; $Id: run-time-context.lisp,v 1.15 2004/10/11 13:53:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -35,11 +35,11 @@ (let ((slot (find-run-time-context-slot context slot-name))) (ecase (second slot) (word - (memref context -6 (third slot) :lisp)) + (memref context -6 :index (third slot))) (code-vector-word - (memref context -6 (third slot) :code-vector)) + (memref context -6 :index (third slot) :type :code-vector)) (lu32 - (memref context -6 (third slot) :unsigned-byte32))))) + (memref context -6 :index (third slot) :type :unsigned-byte32))))) (define-compiler-macro (setf %run-time-context-slot) (&whole form &environment env value slot-name &optional (context '(current-run-time-context))) @@ -67,11 +67,11 @@ (let ((slot (find-run-time-context-slot context slot-name))) (ecase (second slot) (word - (setf (memref context -6 (third slot) :lisp) value)) + (setf (memref context -6 :index (third slot)) value)) (lu32 - (setf (memref context -6 (third slot) :unsigned-byte32) value)) + (setf (memref context -6 :index (third slot) :type :unsigned-byte32) value)) (code-vector-word - (setf (memref context -6 (third slot) :code-vector) value))))) + (setf (memref context -6 :index (third slot) :type :code-vector) value))))) (defun %run-time-context-segment-base (slot-name &optional (context (current-run-time-context))) @@ -81,9 +81,9 @@ (segment-descriptor (let ((index8 (* 4 (third slot))) (index16 (* 2 (third slot)))) - (+ (memref context (+ -6 2) index16 :unsigned-byte16) - (ash (memref context (+ -6 4) index8 :unsigned-byte8) 16) - (ash (memref context (+ -6 7) index8 :unsigned-byte8) 24))))))) + (+ (memref context (+ -6 2) :index index16 :type :unsigned-byte16) + (ash (memref context (+ -6 4) :index index8 :type :unsigned-byte8) 16) + (ash (memref context (+ -6 7) :index index8 :type :unsigned-byte8) 24))))))) (defun (setf %run-time-context-segment-base) (value slot-name &optional (context (current-run-time-context))) @@ -93,9 +93,9 @@ (segment-descriptor (let ((index8 (* 4 (third slot))) (index16 (* 2 (third slot)))) - (setf (memref context (+ -6 2) index16 :unsigned-byte16) (ldb (byte 16 0) value) - (memref context (+ -6 4) index8 :unsigned-byte8) (ldb (byte 8 16) value) - (memref context (+ -6 7) index8 :unsigned-byte8) (ldb (byte 6 24) value))))) + (setf (memref context (+ -6 2) :index index16 :type :unsigned-byte16) (ldb (byte 16 0) value) + (memref context (+ -6 4) :index index8 :type :unsigned-byte8) (ldb (byte 8 16) value) + (memref context (+ -6 7) :index index8 :type :unsigned-byte8) (ldb (byte 6 24) value))))) value)) (defun %run-time-context-ref (edi-offset)

1 0

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

11 Oct '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv30787 Modified Files: read.lisp Log Message: Changed the signature of memref and (setf memref) to use keywords also for the index and type arguments. Date: Mon Oct 11 15:53:11 2004 Author: ffjeld Index: movitz/losp/muerte/read.lisp diff -u movitz/losp/muerte/read.lisp:1.10 movitz/losp/muerte/read.lisp:1.11 --- movitz/losp/muerte/read.lisp:1.10 Tue Sep 21 15:10:40 2004 +++ movitz/losp/muerte/read.lisp Mon Oct 11 15:53:11 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Oct 17 21:50:42 2001 ;;;; -;;;; $Id: read.lisp,v 1.10 2004/09/21 13:10:40 ffjeld Exp $ +;;;; $Id: read.lisp,v 1.11 2004/10/11 13:53:11 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -93,6 +93,7 @@ (digit-char-p (schar string (1+ start)) *read-base*) 0))) (denominator nil) + (decimal nil) (i (1+ start) (1+ i))) ((or (>= i end) (member (schar string i) +simple-token-terminators+)) @@ -103,19 +104,19 @@ integer)) (when (and integer denominator (plusp denominator)) denominator))) - (when (char= #\: (schar string i)) - (setf colon-position i)) - (setf almost-integer integer) - (when integer - (if (and (not denominator) - (char= #\/ (schar string i))) - (setf denominator 0) - (let ((digit (digit-char-p (schar string i) *read-base*))) + (let ((c (schar string i))) + (when (char= #\: c) + (setf colon-position i)) + (setf almost-integer integer) + (when integer + (let ((digit (digit-char-p c *read-base*))) (cond - ((and denominator (not digit)) - (setf integer nil)) (denominator - (setf denominator (+ (* denominator *read-base*) digit))) + (if (not digit) + (setf integer nil) + (setf denominator (+ (* denominator *read-base*) digit)))) + ((char= #\/ c) + (setf denominator 0)) (t (setf integer (and digit (+ (* integer *read-base*) digit))))))))) (cond (token-denominator @@ -123,14 +124,19 @@ token-end)) (token-integer (values token-integer token-end)) - ((and almost-integer ; check for base 10 <n>. notation. + ((and (char= #\. (schar string (1- token-end))) ; check for base-10 <n>. notation. (> token-end start) - (char= #\. (schar string (1- token-end)))) - (if (= *read-base* 10) - (values almost-integer token-end) - (values (parse-integer string :start start :end (1- token-end) - :junk-allowed nil) - token-end))) + (or almost-integer + (and (< *read-base* 10) + (do ((i start (1+ i))) + ((>= i (1- token-end)) t) + (unless (digit-char-p (schar string i) 10) + (return nil)))))) + (let ((x (if (= *read-base* 10) + almost-integer + (parse-integer string :start start :end (1- token-end) + :junk-allowed nil)))) + (values x token-end))) ((not colon-position) (values (intern-string string *package* :start start :end token-end :key #'char-upcase) token-end))

1 0

Jump to page:

2025

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

movitz-cvs