movitz-cvs

movitz-cvs@common-lisp.net

2595 discussions

[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

[movitz-cvs] CVS update: movitz/losp/muerte/format.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-serv28999 Modified Files: format.lisp Log Message: Add some type declarations. Date: Fri Aug 26 21:39:07 2005 Author: ffjeld Index: movitz/losp/muerte/format.lisp diff -u movitz/losp/muerte/format.lisp:1.11 movitz/losp/muerte/format.lisp:1.12 --- movitz/losp/muerte/format.lisp:1.11 Fri Jun 10 20:35:28 2005 +++ movitz/losp/muerte/format.lisp Fri Aug 26 21:39:06 2005 @@ -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.11 2005/06/10 18:35:28 ffjeld Exp $ +;;;; $Id: format.lisp,v 1.12 2005/08/26 19:39:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -79,6 +79,7 @@ (i 0 (1+ i))) ((or (and (not d) (plusp i) (zerop remainder)) (> i last-i))) + (declare (index i)) (multiple-value-bind (next-digit next-remainder) (if (= i last-i) (round (* 10 remainder))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/equalp.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-serv28981 Modified Files: equalp.lisp Log Message: Add some type declarations. Date: Fri Aug 26 21:38:56 2005 Author: ffjeld Index: movitz/losp/muerte/equalp.lisp diff -u movitz/losp/muerte/equalp.lisp:1.6 movitz/losp/muerte/equalp.lisp:1.7 --- movitz/losp/muerte/equalp.lisp:1.6 Thu Jul 22 03:07:38 2004 +++ movitz/losp/muerte/equalp.lisp Fri Aug 26 21:38:56 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001, 2003-2004, +;;;; Copyright (C) 2001, 2003-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Mar 13 17:09:08 2001 ;;;; -;;;; $Id: equalp.lisp,v 1.6 2004/07/22 01:07:38 ffjeld Exp $ +;;;; $Id: equalp.lisp,v 1.7 2005/08/26 19:38:56 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -55,6 +55,7 @@ (and (= length (length y)) (do ((i 0 (1+ i))) ((= i length) t) + (declare (index i)) (unless (equalp (aref x i) (aref y i)) (return nil))))))) (structure-object

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/hash-tables.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-serv28965 Modified Files: hash-tables.lisp Log Message: Add some type declarations. Date: Fri Aug 26 21:38:51 2005 Author: ffjeld Index: movitz/losp/muerte/hash-tables.lisp diff -u movitz/losp/muerte/hash-tables.lisp:1.10 movitz/losp/muerte/hash-tables.lisp:1.11 --- movitz/losp/muerte/hash-tables.lisp:1.10 Wed Aug 24 09:19:37 2005 +++ movitz/losp/muerte/hash-tables.lisp Fri Aug 26 21:38:50 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Feb 19 19:09:05 2001 ;;;; -;;;; $Id: hash-tables.lisp,v 1.10 2005/08/24 07:19:37 ffjeld Exp $ +;;;; $Id: hash-tables.lisp,v 1.11 2005/08/26 19:38:50 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -191,6 +191,7 @@ (hash-table-count hash-table) 0) (do ((i 0 (+ i 2))) ((>= i bucket-length)) + (declare ((index 2) i)) (let ((old-key (svref%unsafe bucket i))) (unless (eq old-key '--no-hash-key--) (setf (gethash old-key hash-table) @@ -206,7 +207,9 @@ (setf index2 0)))))) (defun gethash-string (key-string start end hash-table &optional default (key 'identity)) - (let ((bucket (hash-table-bucket hash-table))) + (let ((start (check-the index start)) + (end (check-the index end)) + (bucket (hash-table-bucket hash-table))) (with-subvector-accessor (key-string-ref key-string start end) (do* ((bucket-length (length bucket)) (index2 (rem (* 2 (sxhash-subvector key-string start end 8)) @@ -222,6 +225,7 @@ (do ((bs-index 0 (1+ bs-index)) (key-index start (1+ key-index))) ((>= key-index end) t) + (declare (index bs-index key-index)) (unless (and (< bs-index bs-length) (char= (funcall key (key-string-ref key-index)) (schar bs bs-index))) @@ -235,6 +239,7 @@ (rem (+ 2 index2) bucket-length)) (i 0 (+ i 2))) ((>= i bucket-length) nil) + (declare ((index 2) i index2)) (let ((x (svref bucket index2))) (when (or (eq x '--no-hash-key--) (funcall (hash-table-test hash-table) x key)) @@ -245,6 +250,7 @@ (do ((i (rem (+ index2 2) bucket-length) (rem (+ i 2) bucket-length))) ((= i index2)) + (declare ((index 2) i)) (let ((k (svref bucket i))) (when (eq x '--no-hash-key--) (return)) @@ -259,6 +265,7 @@ (bucket-length (length bucket)) (i 0 (+ i 2))) ((>= i bucket-length)) + (declare ((index 2) i)) (setf (svref bucket i) '--no-hash-key--)) hash-table)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/print.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-serv28944 Modified Files: print.lisp Log Message: Add some type declarations. Date: Fri Aug 26 21:38:42 2005 Author: ffjeld Index: movitz/losp/muerte/print.lisp diff -u movitz/losp/muerte/print.lisp:1.20 movitz/losp/muerte/print.lisp:1.21 --- movitz/losp/muerte/print.lisp:1.20 Sun Aug 14 14:13:51 2005 +++ movitz/losp/muerte/print.lisp Fri Aug 26 21:38:41 2005 @@ -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.20 2005/08/14 12:13:51 ffjeld Exp $ +;;;; $Id: print.lisp,v 1.21 2005/08/26 19:38:41 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -95,6 +95,7 @@ (do ((i (+ pos 1 (if sign-char 1 0) (if comma-interval (truncate pos comma-interval) 0)) (1+ i))) ((>= i mincol)) + (declare (index i)) (write-char padchar stream))) (when sign-char (write-char sign-char stream))) @@ -159,6 +160,7 @@ (with-subvector-accessor (string-ref string start end) (do ((i start (1+ i))) ((>= i end)) + (declare (index i)) (write-char (string-ref i) stream))) #+ignore (stream-write-string (output-stream-designator stream) string start end))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/read.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-serv28926 Modified Files: read.lisp Log Message: Add some type declarations. Date: Fri Aug 26 21:38:36 2005 Author: ffjeld Index: movitz/losp/muerte/read.lisp diff -u movitz/losp/muerte/read.lisp:1.12 movitz/losp/muerte/read.lisp:1.13 --- movitz/losp/muerte/read.lisp:1.12 Fri Jun 10 20:35:01 2005 +++ movitz/losp/muerte/read.lisp Fri Aug 26 21:38:35 2005 @@ -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.12 2005/06/10 18:35:01 ffjeld Exp $ +;;;; $Id: read.lisp,v 1.13 2005/08/26 19:38:35 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -84,7 +84,9 @@ (return i)))) (defun simple-read-token (string &key (start 0) (end (length string))) - (let ((colon-position (and (char= #\: (schar string start)) start)) + (let ((start (check-the index start)) + (end (check-the index end)) + (colon-position (and (char= #\: (schar string start)) start)) (almost-integer nil)) (multiple-value-bind (token-end token-integer token-denominator) (do ((integer (or (digit-char-p (schar string start) *read-base*) @@ -104,6 +106,7 @@ integer)) (when (and integer denominator (plusp denominator)) denominator))) + (declare (index i)) (let ((c (schar string i))) (when (char= #\: c) (setf colon-position i)) @@ -130,6 +133,7 @@ (and (< *read-base* 10) (do ((i start (1+ i))) ((>= i (1- token-end)) t) + (declare (index i)) (unless (digit-char-p (schar string i) 10) (return nil)))))) (let ((x (if (= *read-base* 10) @@ -181,48 +185,51 @@ (defun simple-read-delimited-list (delimiter string start end &key (tail-delimiter #\.) list) "=> list, new-position, new-string, new-end." - (multiple-value-bind (next-string next-start next-end) - (catch 'next-line - (restart-bind - ((next-line (lambda (next-string &optional (next-start 0) - (next-end (length next-string))) - (throw 'next-line - (values next-string next-start next-end))))) - (do ((i start (1+ i))) - ((>= i end) - (error 'missing-delimiter - :delimiter delimiter - :start-position start)) - (let ((char (schar string i))) - (cond - ((char= delimiter char) - (return-from simple-read-delimited-list - (values (nreverse list) (1+ i) string end))) - ((eq tail-delimiter char) - (unless list - (error "Nothing before ~C in list." tail-delimiter)) - (multiple-value-bind (cdr-list cdr-end cdr-string cdr-string-end) - (simple-read-delimited-list #\) string (1+ i) end - :tail-delimiter tail-delimiter) - (unless (endp (cdr cdr-list)) - (error "Too many objects after ~C in list: ~S" - tail-delimiter (cdr cdr-list))) - (setf list (nreverse list) - (cdr (last list)) (car cdr-list)) + (let ((start (check-the index start)) + (end (check-the index end))) + (multiple-value-bind (next-string next-start next-end) + (catch 'next-line + (restart-bind + ((next-line (lambda (next-string &optional (next-start 0) + (next-end (length next-string))) + (throw 'next-line + (values next-string next-start next-end))))) + (do ((i start (1+ i))) + ((>= i end) + (error 'missing-delimiter + :delimiter delimiter + :start-position start)) + (declare (index i)) + (let ((char (schar string i))) + (cond + ((char= delimiter char) (return-from simple-read-delimited-list - (values list cdr-end cdr-string cdr-string-end)))) - ((char-whitespace-p char)) - (t (multiple-value-bind (element element-end next-string next-string-end) - (simple-read-from-string string t t :start i :end end) - (when next-string - (assert next-string-end) - (setf string next-string - end next-string-end)) - (setf i (1- element-end)) - (push element list)))))))) - (simple-read-delimited-list delimiter next-string next-start next-end - :tail-delimiter tail-delimiter - :list list))) + (values (nreverse list) (1+ i) string end))) + ((eq tail-delimiter char) + (unless list + (error "Nothing before ~C in list." tail-delimiter)) + (multiple-value-bind (cdr-list cdr-end cdr-string cdr-string-end) + (simple-read-delimited-list #\) string (1+ i) end + :tail-delimiter tail-delimiter) + (unless (endp (cdr cdr-list)) + (error "Too many objects after ~C in list: ~S" + tail-delimiter (cdr cdr-list))) + (setf list (nreverse list) + (cdr (last list)) (car cdr-list)) + (return-from simple-read-delimited-list + (values list cdr-end cdr-string cdr-string-end)))) + ((char-whitespace-p char)) + (t (multiple-value-bind (element element-end next-string next-string-end) + (simple-read-from-string string t t :start i :end end) + (when next-string + (assert next-string-end) + (setf string next-string + end next-string-end)) + (setf i (1- element-end)) + (push element list)))))))) + (simple-read-delimited-list delimiter next-string next-start next-end + :tail-delimiter tail-delimiter + :list list)))) (defun position-with-escape (char string start end &optional (errorp t)) (with-subvector-accessor (string-ref string start end) @@ -231,6 +238,7 @@ ((>= i end) (when errorp (error "Missing terminating character ~C." char))) + (declare (index i)) (let ((c (string-ref i))) (cond ((char= char c) @@ -240,108 +248,114 @@ (incf i))))))) (defun escaped-string-copy (string start end num-escapes) - (do* ((length (- end start num-escapes)) - (new-string (make-string length)) - (p 0 (1+ p)) - (q start (1+ q))) - ((>= p length) new-string) - (when (char= (char string q) #\\) - (incf q)) - (setf (char new-string p) (char string q)))) + (let ((start (check-the index start)) + (end (check-the index end))) + (do* ((length (- end start num-escapes)) + (new-string (make-string length)) + (p 0 (1+ p)) + (q start (1+ q))) + ((>= p length) new-string) + (declare (index p q)) + (when (char= (char string q) #\\) + (incf q)) + (setf (char new-string p) (char string q))))) (defun simple-read-from-string (string &optional eof-error-p eof-value &key (start 0) (end (length string))) "=> object, new-position, new-string, new-end." - (do ((i start (1+ i))) - ((>= i end) (if eof-error-p - (error "EOF") - (values eof-value i))) - (case (schar string i) - ((#\space #\tab #\newline)) - (#$ (return-from simple-read-from-string - (simple-read-delimited-list #$ string (1+ i) end :tail-delimiter #\.))) - (#\) (warn "Ignoring extra ~C." (schar string i)) - (incf i)) - (#\' (multiple-value-bind (quoted-form form-end) - (simple-read-from-string string eof-error-p eof-value :start (1+ i) :end end) - (return-from simple-read-from-string - (values (list 'quote quoted-form) form-end string end)))) - (#\" (incf i) - (multiple-value-bind (string-end num-escapes) - (position-with-escape #\" string i end) - (return-from simple-read-from-string - (values (escaped-string-copy string i string-end num-escapes) - (1+ string-end) - string end)))) - (#\| (incf i) - (multiple-value-bind (symbol-end num-escapes) - (position-with-escape #\| string i end) - (return-from simple-read-from-string - (values (if (= 0 num-escapes) - (intern-string string *package* :start i :end symbol-end) - (intern (escaped-string-copy string i symbol-end num-escapes))) - (1+ symbol-end) - string end)))) - (#\# (assert (< (incf i) end) (string) - "End of string after #: ~S." (substring string start end)) - (multiple-value-bind (parameter parameter-end) - (parse-integer string :start i :end end :radix 10 :junk-allowed t) - (setf i parameter-end) - (return-from simple-read-from-string - (ecase (char-downcase (char string i)) - (#\b (simple-read-integer string (1+ i) end 2)) - (#\o (simple-read-integer string (1+ i) end 8)) - (#\x (simple-read-integer string (1+ i) end 16)) - (#\r (check-type parameter (integer 2 36)) - (simple-read-integer string (1+ i) end parameter)) - (#\' (multiple-value-bind (quoted-form form-end) - (simple-read-from-string string eof-error-p eof-value :start (1+ i) :end end) - (values (list 'function quoted-form) form-end string end))) - (#$ (multiple-value-bind (contents-list form-end) - (simple-read-delimited-list #$ string (1+ i) end) - (values (replace (make-array (or parameter (length contents-list)) - :initial-element (car (last contents-list))) - contents-list) - form-end - string end))) - (#\* (let* ((token-end (find-token-end string :start (incf i) :end end)) - (bit-vector (make-array (or parameter (- token-end i)) - :element-type 'bit))) - (do ((p i (1+ p)) - (q 0 (1+ q)) - (bit nil)) - ((>= q (length bit-vector))) - (when (< p token-end) - (setf bit (schar string p))) - (case bit - (#\0 (setf (aref bit-vector q) 0)) - (#\1 (setf (aref bit-vector q) 1)) - (t (error "Illegal bit-vector element: ~S" bit)))) - (values bit-vector - token-end - string end))) - (#\s (multiple-value-bind (struct-form form-end) - (simple-read-from-string string eof-error-p eof-value :start (1+ i) :end end) - (check-type struct-form list) - (let* ((struct-name (car struct-form)) - (struct-args (cdr struct-form))) - (check-type struct-name symbol "A structure name.") - (values (apply #'make-structure struct-name struct-args) - form-end string end)))) - (#\: (let* ((token-end (find-token-end string :start (incf i) :end end)) - (symbol-name (string-upcase string :start i :end token-end))) - (values (make-symbol symbol-name) - token-end string end))) - (#\\ (let* ((token-end (find-token-end string :start (incf i) :end end)) - (char (name-char string i token-end))) - (cond - (char (values char token-end)) - ((>= 1 (- token-end i)) - (values (char string i) (1+ i) string end)) - (t (error "Don't know this character: ~S" - (substring string i token-end)))))))))) - (t (return-from simple-read-from-string - (simple-read-token string :start i :end end)))))) + (let ((start (check-the index start)) + (end (check-the index end))) + (do ((i start (1+ i))) + ((>= i end) (if eof-error-p + (error "EOF") + (values eof-value i))) + (declare (index i)) + (case (schar string i) + ((#\space #\tab #\newline)) + (#$ (return-from simple-read-from-string + (simple-read-delimited-list #$ string (1+ i) end :tail-delimiter #\.))) + (#\) (warn "Ignoring extra ~C." (schar string i)) + (incf i)) + (#\' (multiple-value-bind (quoted-form form-end) + (simple-read-from-string string eof-error-p eof-value :start (1+ i) :end end) + (return-from simple-read-from-string + (values (list 'quote quoted-form) form-end string end)))) + (#\" (incf i) + (multiple-value-bind (string-end num-escapes) + (position-with-escape #\" string i end) + (return-from simple-read-from-string + (values (escaped-string-copy string i string-end num-escapes) + (1+ string-end) + string end)))) + (#\| (incf i) + (multiple-value-bind (symbol-end num-escapes) + (position-with-escape #\| string i end) + (return-from simple-read-from-string + (values (if (= 0 num-escapes) + (intern-string string *package* :start i :end symbol-end) + (intern (escaped-string-copy string i symbol-end num-escapes))) + (1+ symbol-end) + string end)))) + (#\# (assert (< (incf i) end) (string) + "End of string after #: ~S." (substring string start end)) + (multiple-value-bind (parameter parameter-end) + (parse-integer string :start i :end end :radix 10 :junk-allowed t) + (setf i parameter-end) + (return-from simple-read-from-string + (ecase (char-downcase (char string i)) + (#\b (simple-read-integer string (1+ i) end 2)) + (#\o (simple-read-integer string (1+ i) end 8)) + (#\x (simple-read-integer string (1+ i) end 16)) + (#\r (check-type parameter (integer 2 36)) + (simple-read-integer string (1+ i) end parameter)) + (#\' (multiple-value-bind (quoted-form form-end) + (simple-read-from-string string eof-error-p eof-value :start (1+ i) :end end) + (values (list 'function quoted-form) form-end string end))) + (#$ (multiple-value-bind (contents-list form-end) + (simple-read-delimited-list #$ string (1+ i) end) + (values (replace (make-array (or parameter (length contents-list)) + :initial-element (car (last contents-list))) + contents-list) + form-end + string end))) + (#\* (let* ((token-end (find-token-end string :start (incf i) :end end)) + (bit-vector (make-array (or parameter (- token-end i)) + :element-type 'bit))) + (do ((p i (1+ p)) + (q 0 (1+ q)) + (bit nil)) + ((>= q (length bit-vector))) + (when (< p token-end) + (setf bit (schar string p))) + (case bit + (#\0 (setf (aref bit-vector q) 0)) + (#\1 (setf (aref bit-vector q) 1)) + (t (error "Illegal bit-vector element: ~S" bit)))) + (values bit-vector + token-end + string end))) + (#\s (multiple-value-bind (struct-form form-end) + (simple-read-from-string string eof-error-p eof-value :start (1+ i) :end end) + (check-type struct-form list) + (let* ((struct-name (car struct-form)) + (struct-args (cdr struct-form))) + (check-type struct-name symbol "A structure name.") + (values (apply #'make-structure struct-name struct-args) + form-end string end)))) + (#\: (let* ((token-end (find-token-end string :start (incf i) :end end)) + (symbol-name (string-upcase string :start i :end token-end))) + (values (make-symbol symbol-name) + token-end string end))) + (#\\ (let* ((token-end (find-token-end string :start (incf i) :end end)) + (char (name-char string i token-end))) + (cond + (char (values char token-end)) + ((>= 1 (- token-end i)) + (values (char string i) (1+ i) string end)) + (t (error "Don't know this character: ~S" + (substring string i token-end)))))))))) + (t (return-from simple-read-from-string + (simple-read-token string :start i :end end))))))) (defun read-from-string (&rest args) (declare (dynamic-extent args))

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

movitz-cvs