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