August 2005 - movitz-cvs@common-lisp.net - mailman3.common-lisp.net

[movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp
by ffjeld＠common-lisp.net 26 Aug '05

26 Aug '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv9123 Modified Files: inspect.lisp Log Message: Teach shallow-copy about ratios. Date: Sat Aug 27 00:38:08 2005 Author: ffjeld Index: movitz/losp/muerte/inspect.lisp diff -u movitz/losp/muerte/inspect.lisp:1.55 movitz/losp/muerte/inspect.lisp:1.56 --- movitz/losp/muerte/inspect.lisp:1.55 Sat Jun 11 02:02:04 2005 +++ movitz/losp/muerte/inspect.lisp Sat Aug 27 00:38:07 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Oct 24 09:50:41 2003 ;;;; -;;;; $Id: inspect.lisp,v 1.55 2005/06/11 00:02:04 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.56 2005/08/26 22:38:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -262,6 +262,9 @@ (copy-funobj old)) (structure-object (copy-structure old)) + (ratio + (make-ratio (%ratio-numerator old) + (%ratio-denominator old))) (run-time-context (%shallow-copy-object old (movitz-type-word-size 'movitz-run-time-context)))))

1 0

[movitz-cvs] CVS update: movitz/losp/x86-pc/textmode.lisp
by ffjeld＠common-lisp.net 26 Aug '05

26 Aug '05

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv4712 Modified Files: textmode.lisp Log Message: Tweaked textmode-scroll-down. Date: Fri Aug 26 23:42:40 2005 Author: ffjeld Index: movitz/losp/x86-pc/textmode.lisp diff -u movitz/losp/x86-pc/textmode.lisp:1.14 movitz/losp/x86-pc/textmode.lisp:1.15 --- movitz/losp/x86-pc/textmode.lisp:1.14 Wed Nov 24 17:24:36 2004 +++ movitz/losp/x86-pc/textmode.lisp Fri Aug 26 23:42:39 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2000-2004, +;;;; Copyright (C) 2000-2005, ;;;; Department of Computer Science, University of Tromso, Norway ;;;; ;;;; Filename: textmode.lisp @@ -9,7 +9,7 @@ ;;;; Created at: Thu Nov 9 15:38:56 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: textmode.lisp,v 1.14 2004/11/24 16:24:36 ffjeld Exp $ +;;;; $Id: textmode.lisp,v 1.15 2005/08/26 21:42:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -100,6 +100,7 @@ (move-vga-cursor (setf *cursor-x* (1+ x)) y)))) nil) +#+ignore (defun textmode-copy-line (destination source count) (check-type count (and (integer 0 511) (satisfies evenp))) (check-type source (unsigned-byte 20)) @@ -125,12 +126,36 @@ (defun textmode-scroll-down () (declare (special muerte.lib::*scroll-offset*)) (incf muerte.lib::*scroll-offset*) - (loop with stride = (* 2 *screen-stride*) - for y below (1- *screen-height*) - as src from (+ *screen* stride) by stride - as dst from *screen* by stride - do (textmode-copy-line dst src *screen-width*) - finally (textmode-clear-line 0 (1- *screen-height*))) + (macrolet ((copy-line (destination source count) + `(let ((destination ,destination) + (source ,source) + (count ,count)) + (with-inline-assembly (:returns :nothing) + (:compile-form (:result-mode :edx) destination) + (:compile-form (:result-mode :eax) source) + (:compile-form (:result-mode :ebx) count) + (:std) ; Only EBX is now (potential) GC root + (:andl #x-8 :ebx) ; ..so make sure EBX is a fixnum + (:shrl 2 :eax) + (:shrl 2 :edx) + (:shrl 1 :ebx) + (:jz 'end-copy-loop) + copy-loop + (#.movitz:*compiler-physical-segment-prefix* :movl (:eax :ebx -4) :ecx) + (#.movitz:*compiler-physical-segment-prefix* :movl :ecx (:edx :ebx -4)) + (:subl 4 :ebx) + (:ja 'copy-loop) + end-copy-loop + (:cld))))) + (loop with screen = (check-the fixnum *screen*) + with stride = (* 2 *screen-stride*) + with width = (check-the fixnum *screen-width*) + with height = (1- (check-the fixnum *screen-height*)) + repeat height + as src of-type fixnum from (+ screen stride) by stride + as dst of-type fixnum from screen by stride + do (copy-line dst src width) + finally (textmode-clear-line 0 height))) (signal 'newline)) (defun textmode-clear-line (from-column line)

1 0

[movitz-cvs] CVS update: movitz/compiler.lisp
by ffjeld＠common-lisp.net 26 Aug '05

26 Aug '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv4697 Modified Files: compiler.lisp Log Message: Fixed bug in peephole optimizer that would erroneously regard some stack-frame locations as unused. Date: Fri Aug 26 23:42:08 2005 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.159 movitz/compiler.lisp:1.160 --- movitz/compiler.lisp:1.159 Fri Aug 26 21:43:32 2005 +++ movitz/compiler.lisp Fri Aug 26 23:42:08 2005 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.159 2005/08/26 19:43:32 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.160 2005/08/26 21:42:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -567,6 +567,13 @@ (when (and (not (null (type-analysis-thunks analysis))) (not (apply #'encoded-allp (type-analysis-declared-encoded-type analysis)))) + #+ignore + (warn "Trusting ~S, was ~S, because ~S [~S]" + binding + (type-analysis-encoded-type analysis) + (type-analysis-thunks analysis) + (loop for (thunk . thunk-args) in (type-analysis-thunks analysis) + collect (mapcar #'binding-resolved-p thunk-args))) (setf (type-analysis-encoded-type analysis) (type-analysis-declared-encoded-type analysis)) (setf (type-analysis-thunks analysis) nil))) ; Ignore remaining thunks. @@ -1742,6 +1749,8 @@ (stack-frame-operand (twop-dst c op))) (read-stack-frame-p (c) (or (load-stack-frame-p c :movl) + (load-stack-frame-p c :addl) + (load-stack-frame-p c :subl) (load-stack-frame-p c :cmpl) (store-stack-frame-p c :cmpl) (and (consp c) @@ -7044,6 +7053,7 @@ but it's requested to be in ~S." destreg) (let ((srcloc (new-binding-location (binding-target src) frame-map))) + (unless (eql srcloc loc1) (break)) (if (integerp srcloc) `((:addl (:ebp ,(stack-frame-offset srcloc)) ,destreg)

1 0

[movitz-cvs] CVS update: movitz/packages.lisp
by ffjeld＠common-lisp.net 26 Aug '05

26 Aug '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv4667 Modified Files: packages.lisp Log Message: Export muerte:check-the. Date: Fri Aug 26 23:40:29 2005 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.52 movitz/packages.lisp:1.53 --- movitz/packages.lisp:1.52 Thu Aug 11 23:32:55 2005 +++ movitz/packages.lisp Fri Aug 26 23:40:28 2005 @@ -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.52 2005/08/11 21:32:55 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.53 2005/08/26 21:40:28 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1098,6 +1098,7 @@ #:read-key #:fixnump #:newline + #:check-the #:*print-safely*

1 0

[movitz-cvs] CVS update: movitz/compiler.lisp
by ffjeld＠common-lisp.net 26 Aug '05

26 Aug '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv29112 Modified Files: compiler.lisp Log Message: Comment out debug message.. Date: Fri Aug 26 21:43:32 2005 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.158 movitz/compiler.lisp:1.159 --- movitz/compiler.lisp:1.158 Fri Aug 26 21:41:32 2005 +++ movitz/compiler.lisp Fri Aug 26 21:43:32 2005 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.158 2005/08/26 19:41:32 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.159 2005/08/26 19:43:32 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -6808,7 +6808,7 @@ (loc1 (new-binding-location (binding-target term1) frame-map :default nil))) #+ignore (warn "add: ~A for ~A" instruction result-type) - + #+ignore (warn "add for: ~S is ~A, from ~A/~A and ~A/~A." destination result-type term0 loc0

1 0

[movitz-cvs] CVS update: movitz/compiler.lisp
by ffjeld＠common-lisp.net 26 Aug '05

26 Aug '05

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv29091 Modified Files: compiler.lisp Log Message: Compile (add <fixnum> <fixnum>) to addl x y, into. So rely on the interrupt handler to deal with overflows. Date: Fri Aug 26 21:41:33 2005 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.157 movitz/compiler.lisp:1.158 --- movitz/compiler.lisp:1.157 Wed Aug 24 09:30:45 2005 +++ movitz/compiler.lisp Fri Aug 26 21:41:32 2005 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.157 2005/08/24 07:30:45 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.158 2005/08/26 19:41:32 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -2870,6 +2870,7 @@ "Try to locate binding in a register. Return a register, or nil and :not-now, or :never. This function is factored out from assign-bindings." + (assert (not (typep binding 'forwarding-binding))) (let* ((count-init-pc (gethash binding var-counts)) (count (car count-init-pc)) (init-pc (second count-init-pc))) @@ -2898,9 +2899,12 @@ (when pos (return (values i (nth pos read-destinations) distance))))))) (declare (ignore load-instruction)) - ;; (warn "load: ~S, dist: ~S, dest: ~S" load-instruction distance binding-destination) (multiple-value-bind (free-registers more-later-p) (and distance (compute-free-registers (cdr init-pc) distance funobj frame-map)) + #+ignore + (when (string= 'num-jumpers (binding-name binding)) + (warn "load: ~S, dist: ~S, dest: ~S" load-instruction distance binding-destination) + (warn "free: ~S, more: ~S" free-registers more-later-p)) (let ((free-registers-no-ecx (remove :ecx free-registers))) (cond ((member binding-destination free-registers-no-ecx) @@ -6804,7 +6808,7 @@ (loc1 (new-binding-location (binding-target term1) frame-map :default nil))) #+ignore (warn "add: ~A for ~A" instruction result-type) - #+ignore + (warn "add for: ~S is ~A, from ~A/~A and ~A/~A." destination result-type term0 loc0 @@ -6817,7 +6821,14 @@ term1 loc1 (binding-extent-env (binding-target term1))) (print-code 'load-term1 (make-load-lexical term1 :eax funobj nil frame-map)) (print-code 'load-dest (make-load-lexical destination :eax funobj nil frame-map))) - (flet ((make-default-add () + (flet ((make-store (source destination) + (cond + ((eq source destination) + nil) + ((member destination '(:eax :ebx :ecx :edx)) + `((:movl ,source ,destination))) + (t (make-store-lexical destination source nil funobj frame-map)))) + (make-default-add () (when (movitz-subtypep result-type '(unsigned-byte 32)) (warn "Defaulting u32 ADD: ~A/~S = ~A/~S + ~A/~S" destination-location @@ -6852,9 +6863,11 @@ (binding (make-store-lexical destination :eax nil funobj frame-map)))))) (let ((constant0 (let ((x (type-specifier-singleton type0))) - (when x (movitz-immediate-value (car x))))) + (when (and x (typep (car x) 'movitz-fixnum)) + (movitz-immediate-value (car x))))) (constant1 (let ((x (type-specifier-singleton type1))) - (when x (movitz-immediate-value (car x)))))) + (when (and x (typep (car x) 'movitz-fixnum)) + (movitz-immediate-value (car x)))))) (cond ((type-specifier-singleton result-type) ;; (break "constant add: ~S" instruction) @@ -7023,20 +7036,27 @@ (binding-lended-p (binding-target term1))))) (t (warn "Unknown fixnum add: ~S" instruction) (make-default-add)))) - ((and (movitz-subtypep result-type '(unsigned-byte 32)) - (movitz-subtypep type0 'fixnum) + ((and (movitz-subtypep type0 'fixnum) (movitz-subtypep type1 'fixnum)) - (flet ((mkadd (src srcloc destreg) - (if (integerp srcloc) - `((:addl (:ebp ,(stack-frame-offset srcloc)) - ,destreg)) - (ecase (operator srcloc) - ((:eax :ebx :ecx :edx) - `((:addl ,srcloc ,destreg))) - ((:argument-stack) - `((:addl (:ebx ,(argument-stack-offset src)) - ,destreg))) - )))) + (flet ((mkadd-into (src destreg) + (assert (eq destreg :eax) (destreg) + "Movitz' INTO protocol says the overflowed value must be in EAX, ~ +but it's requested to be in ~S." + destreg) + (let ((srcloc (new-binding-location (binding-target src) frame-map))) + (if (integerp srcloc) + `((:addl (:ebp ,(stack-frame-offset srcloc)) + ,destreg) + (:into)) + (ecase (operator srcloc) + ((:eax :ebx :ecx :edx) + `((:addl ,srcloc ,destreg) + (:into))) + ((:argument-stack) + `((:addl (:ebx ,(argument-stack-offset src)) + ,destreg) + (:into))) + ))))) (cond ((and (not constant0) (not constant1) @@ -7045,26 +7065,22 @@ (not (and (bindingp destination) (binding-lended-p (binding-target destination))))) (cond -;;; ((and (not (eq loc0 :untagged-fixnum-ecx)) -;;; (not (eq loc1 :untagged-fixnum-ecx)) -;;; (not (eq destination-location :untagged-fixnum-ecx))) -;;; (let ((tmpreg (cond -;;; ((member destination-location '(:eax :ebx :ecx :edx)) -;;; destination-location) -;;; ((some (lambda (x) (and (not (eq x loc0)) (not (eq x loc1)))) -;;; '(:ecx :edx :eax :ebx))) -;;; (t :ecx))) -;;; (no-overflow (gensym "no-overflow-"))) -;;; (append (make-load-lexical term0 :eax funobj nil frame-map) -;;; (mkadd term1 loc1 :eax) -;;; `((:jnc ',no-overflow) -;;; (:movl :eax :ecx) -;;; (:rcrl 1 :ecx) -;;; (:shrl 1 :ecx) -;;; (,*compiler-local-segment-prefix* -;;; :call (:edi ,(global-constant-offset 'box-u32-ecx))) -;;; ,no-overflow)) - (t (make-default-add) + ((and (not (eq loc0 :untagged-fixnum-ecx)) + (not (eq loc1 :untagged-fixnum-ecx)) + (not (eq destination-location :untagged-fixnum-ecx))) + (append (cond + ((and (eq loc0 :eax) (eq loc1 :eax)) + `((:addl :eax :eax) + (:into))) + ((eq loc0 :eax) + (mkadd-into term1 :eax)) + ((eq loc1 :eax) + (mkadd-into term0 :eax)) + (t (append (make-load-lexical term0 :eax funobj nil frame-map + :protect-registers (list loc1)) + (mkadd-into term1 :eax)))) + (make-store :eax destination))) + (t (make-default-add) #+ignore (append (make-load-lexical term0 :untagged-fixnum-ecx funobj nil frame-map) `((,*compiler-local-segment-prefix*

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp
by ffjeld＠common-lisp.net 26 Aug '05

26 Aug '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv29076 Modified Files: interrupt.lisp Log Message: Handle into exception after fixnum addition. Date: Fri Aug 26 21:40:33 2005 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.47 movitz/losp/muerte/interrupt.lisp:1.48 --- movitz/losp/muerte/interrupt.lisp:1.47 Fri Aug 12 22:28:30 2005 +++ movitz/losp/muerte/interrupt.lisp Fri Aug 26 21:40:32 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.47 2005/08/12 20:28:30 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.48 2005/08/26 19:40:32 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -276,9 +276,9 @@ (defun interrupt-default-handler (vector dit-frame) (declare (without-check-stack-limit)) - (macrolet ((dereference (fixnum-address &optional (type :lisp)) + (macrolet ((dereference (location &optional (type :lisp)) "Dereference the fixnum-address." - `(memref ,fixnum-address 0 :type ,type))) + `(memref ,location 0 :type ,type))) (let (($eip (+ dit-frame (dit-frame-index :eip))) ($eax (+ dit-frame (dit-frame-index :eax))) ($ebx (+ dit-frame (dit-frame-index :ebx))) @@ -290,14 +290,24 @@ (case vector (0 (error 'division-by-zero)) (3 (break "Break instruction at ~@Z." $eip)) - (4 (if (not (eq (load-global-constant new-unbound-value) - (dereference $eax))) - (error "Primitive overflow assertion failed.") + (4 (cond + ((eq (load-global-constant new-unbound-value) + (dereference $eax)) (let ((name (dereference $ebx))) (with-simple-restart (new-value "Set the value of ~S." name) (error 'unbound-variable :name name)) (format *query-io* "~&Enter a value for ~S: " name) - (setf (dereference $eax) (read *query-io*))))) + (setf (dereference $eax) (read *query-io*)))) + ((typep (dereference $eax) 'fixnum) + (let ((eax (dereference $eax))) + (setf (dereference $eax) + (if (plusp eax) + (- most-negative-fixnum + 1 (- most-positive-fixnum eax)) + (+ most-positive-fixnum + 1 (- eax most-negative-fixnum)))) + (warn "Overflow: ~S -> ~S" eax (dereference $eax)))) + (t (error "Primitive overflow assertion failed.")))) (6 (error "Illegal instruction at ~@Z." $eip)) (13 (error "General protection error. EIP=~@Z, error-code: #x~X, EAX: ~@Z, EBX: ~@Z, ECX: ~@Z" $eip

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/more-macros.lisp
by ffjeld＠common-lisp.net 26 Aug '05

26 Aug '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv29045 Modified Files: more-macros.lisp Log Message: Add some type declarations. Date: Fri Aug 26 21:39:27 2005 Author: ffjeld Index: movitz/losp/muerte/more-macros.lisp diff -u movitz/losp/muerte/more-macros.lisp:1.28 movitz/losp/muerte/more-macros.lisp:1.29 --- movitz/losp/muerte/more-macros.lisp:1.28 Tue May 24 08:33:40 2005 +++ movitz/losp/muerte/more-macros.lisp Fri Aug 26 21:39:26 2005 @@ -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.28 2005/05/24 06:33:40 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.29 2005/08/26 19:39:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -117,8 +117,8 @@ ,@declarations-and-body ,result-form)) (t `(do ((,var 0 (1+ ,var))) - ((>= ,var ,count-form) ,result-form) - (declare (type (integer 0 ,count-form) ,var)) + ((>= ,var ,count) ,result-form) + (declare (type (integer 0 ,count) ,var)) ,@declarations-and-body)))))) (defmacro dotimes ((var count-form &optional result-form) &body declarations-and-body)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/basic-functions.lisp
by ffjeld＠common-lisp.net 26 Aug '05

26 Aug '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv29030 Modified Files: basic-functions.lisp Log Message: Add some type declarations. Date: Fri Aug 26 21:39:20 2005 Author: ffjeld Index: movitz/losp/muerte/basic-functions.lisp diff -u movitz/losp/muerte/basic-functions.lisp:1.19 movitz/losp/muerte/basic-functions.lisp:1.20 --- movitz/losp/muerte/basic-functions.lisp:1.19 Tue May 24 08:33:19 2005 +++ movitz/losp/muerte/basic-functions.lisp Fri Aug 26 21:39:20 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 4 18:41:57 2001 ;;;; -;;;; $Id: basic-functions.lisp,v 1.19 2005/05/24 06:33:19 ffjeld Exp $ +;;;; $Id: basic-functions.lisp,v 1.20 2005/08/26 19:39:20 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -389,42 +389,46 @@ (ecase type (:unsigned-byte8 (let ((vector (make-array length :element-type '(unsigned-byte 8)))) - (let ((i index)) - (dotimes (j length) + (let ((i (check-the index index))) + (declare (index i)) + (dotimes (j (check-the index length)) + (declare (index j)) (setf (aref vector j) (memref object offset :index i :type :unsigned-byte8)) (incf i))) vector)))) (defun (setf memrange) (value object offset index length type) - (ecase type - (:unsigned-byte8 - (etypecase value - ((unsigned-byte 8) - (do ((end (+ index length)) - (i index (1+ i))) - ((>= i end)) - (setf (memref object offset :index i :type :unsigned-byte8) value))) - (vector - (do ((end (+ index length)) - (i index (1+ i)) - (j 0 (1+ j))) - ((or (>= i end) (>= j (length value)))) - (setf (memref object offset :index i :type :unsigned-byte8) - (aref value j)))))) - (:character - (etypecase value - (character - (do ((end (+ index length)) - (i index (1+ i))) - ((>= i end)) - (setf (memref object offset :index i :type :character) value))) - (string - (do ((end (+ index length)) - (i index (1+ i)) - (j 0 (1+ j))) - ((or (>= i end) (>= j (length value)))) - (setf (memref object offset :index i :type :character) - (char value j))))))) + (let* ((index (check-the index index)) + (end (check-the index (+ index length)))) + (ecase type + (:unsigned-byte8 + (etypecase value + ((unsigned-byte 8) + (do ((i index (1+ i))) + ((>= i end)) + (declare (index i)) + (setf (memref object offset :index i :type :unsigned-byte8) value))) + (vector + (do ((i index (1+ i)) + (j 0 (1+ j))) + ((or (>= i end) (>= j (length value)))) + (declare (index i j)) + (setf (memref object offset :index i :type :unsigned-byte8) + (aref value j)))))) + (:character + (etypecase value + (character + (do ((i index (1+ i))) + ((>= i end)) + (declare (index i)) + (setf (memref object offset :index i :type :character) value))) + (string + (do ((i index (1+ i)) + (j 0 (1+ j))) + ((or (>= i end) (>= j (length value)))) + (declare (index i j)) + (setf (memref object offset :index i :type :character) + (char value j)))))))) value)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp
by ffjeld＠common-lisp.net 26 Aug '05

26 Aug '05

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv29014 Modified Files: integers.lisp Log Message: Add some type declarations. Date: Fri Aug 26 21:39:14 2005 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.108 movitz/losp/muerte/integers.lisp:1.109 --- movitz/losp/muerte/integers.lisp:1.108 Wed Aug 24 09:31:40 2005 +++ movitz/losp/muerte/integers.lisp Fri Aug 26 21:39:14 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.108 2005/08/24 07:31:40 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.109 2005/08/26 19:39:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -803,6 +803,7 @@ (let ((result (%make-bignum (1+ (ceiling result-length 32))))) (let ((src-max-bigit (* 2 (%bignum-bigits integer)))) (dotimes (i (* 2 (%bignum-bigits result))) + (declare (index i)) (let ((src (+ i long))) (setf (memref result -2 :index i :type :unsigned-byte16) (if (< src src-max-bigit)

1 0