[movitz-cvs] CVS update: movitz/losp/muerte/read.lisp

[Frode Vatvedt Fjeld]

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 at 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))