X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Freader.lisp;h=41226cbc060399990f140619d9444dfc70a7a628;hb=1bbb76fcfb9baddf0dc96412c87575d8aeb69c6d;hp=7dcc7ea3c72d12e4b60463fca10ea6917a5706a3;hpb=143edab8d233c784cde14bce6c5165219ea84bf4;p=sbcl.git diff --git a/src/code/reader.lisp b/src/code/reader.lisp index 7dcc7ea..41226cb 100644 --- a/src/code/reader.lisp +++ b/src/code/reader.lisp @@ -69,16 +69,28 @@ (char-code char)) newvalue)) -;;; FIXME: could be SB!XC:DEFMACRO inside EVAL-WHEN (COMPILE EVAL) -(defmacro get-cmt-entry (char rt) - `(the function - (elt (the simple-vector (character-macro-table ,rt)) - (char-code ,char)))) - -(defun set-cmt-entry (char newvalue &optional (rt *readtable*)) - (setf (elt (the simple-vector (character-macro-table rt)) - (char-code char)) - (coerce newvalue 'function))) +;;; the value actually stored in the character macro table. As per +;;; ANSI #'GET-MACRO-CHARACTER and #'SET-MACRO-CHARACTER, this can +;;; be either a function or NIL. +(eval-when (:compile-toplevel :execute) + (sb!xc:defmacro get-raw-cmt-entry (char readtable) + `(svref (character-macro-table ,readtable) + (char-code ,char)))) + +;;; the value represented by whatever is stored in the character macro +;;; table. As per ANSI #'GET-MACRO-CHARACTER and #'SET-MACRO-CHARACTER, +;;; a function value represents itself, and a NIL value represents the +;;; default behavior. +(defun get-coerced-cmt-entry (char readtable) + (the function + (or (get-raw-cmt-entry char readtable) + #'read-token))) + +(defun set-cmt-entry (char new-value-designator &optional (rt *readtable*)) + (setf (svref (character-macro-table rt) + (char-code char)) + (and new-value-designator + (%coerce-callable-to-fun new-value-designator)))) (defun undefined-macro-char (stream char) (unless *read-suppress* @@ -154,17 +166,20 @@ ;;;; readtable operations (defun copy-readtable (&optional (from-readtable *readtable*) - (to-readtable (make-readtable))) - (let ((really-from-readtable (or from-readtable *standard-readtable*))) - (replace (character-attribute-table to-readtable) + to-readtable) + (let ((really-from-readtable (or from-readtable *standard-readtable*)) + (really-to-readtable (or to-readtable (make-readtable)))) + (replace (character-attribute-table really-to-readtable) (character-attribute-table really-from-readtable)) - (replace (character-macro-table to-readtable) + (replace (character-macro-table really-to-readtable) (character-macro-table really-from-readtable)) - (setf (dispatch-tables to-readtable) - (mapcar #'(lambda (pair) (cons (car pair) - (copy-seq (cdr pair)))) + (setf (dispatch-tables really-to-readtable) + (mapcar (lambda (pair) (cons (car pair) + (copy-seq (cdr pair)))) (dispatch-tables really-from-readtable))) - to-readtable)) + (setf (readtable-case really-to-readtable) + (readtable-case really-from-readtable)) + really-to-readtable)) (defun set-syntax-from-char (to-char from-char &optional (to-readtable *readtable*) @@ -175,7 +190,7 @@ FROM-TABLE defaults to the standard Lisp readtable when NIL." (let ((really-from-readtable (or from-readtable *standard-readtable*))) ;; Copy FROM-CHAR entries to TO-CHAR entries, but make sure that if - ;; from char is a constituent you don't copy non-movable secondary + ;; FROM-CHAR is a constituent you don't copy non-movable secondary ;; attributes (constituent types), and that said attributes magically ;; appear if you transform a non-constituent to a constituent. (let ((att (get-cat-entry from-char really-from-readtable))) @@ -183,47 +198,57 @@ (setq att (get-secondary-attribute to-char))) (set-cat-entry to-char att to-readtable) (set-cmt-entry to-char - (get-cmt-entry from-char really-from-readtable) + (get-raw-cmt-entry from-char really-from-readtable) to-readtable))) t) (defun set-macro-character (char function &optional - (non-terminatingp nil) (rt *readtable*)) + (non-terminatingp nil) + (readtable *readtable*)) #!+sb-doc - "Causes char to be a macro character which invokes function when - seen by the reader. The non-terminatingp flag can be used to - make the macro character non-terminating. The optional readtable - argument defaults to the current readtable. Set-macro-character - returns T." - (if non-terminatingp - (set-cat-entry char (get-secondary-attribute char) rt) - (set-cat-entry char +char-attr-terminating-macro+ rt)) - (set-cmt-entry char function rt) - T) - -(defun get-macro-character (char &optional (rt *readtable*)) + "Causes CHAR to be a macro character which invokes FUNCTION when seen + by the reader. The NON-TERMINATINGP flag can be used to make the macro + character non-terminating, i.e. embeddable in a symbol name." + (let ((designated-readtable (or readtable *standard-readtable*))) + (set-cat-entry char + (if non-terminatingp + (get-secondary-attribute char) + +char-attr-terminating-macro+) + designated-readtable) + (set-cmt-entry char function designated-readtable) + t)) ; (ANSI-specified return value) + +(defun get-macro-character (char &optional (readtable *readtable*)) #!+sb-doc - "Returns the function associated with the specified char which is a macro - character. The optional readtable argument defaults to the current - readtable." - (let ((rt (or rt *standard-readtable*))) - ;; Check macro syntax, return associated function if it's there. - ;; Returns a value for all constituents. - (cond ((constituentp char) - (values (get-cmt-entry char rt) t)) - ((terminating-macrop char) - (values (get-cmt-entry char rt) nil)) - (t nil)))) + "Return the function associated with the specified CHAR which is a macro + character, or NIL if there is no such function. As a second value, return + T if CHAR is a macro character which is non-terminating, i.e. which can + be embedded in a symbol name." + (let* ((designated-readtable (or readtable *standard-readtable*)) + ;; the first return value: a FUNCTION if CHAR is a macro + ;; character, or NIL otherwise + (fun-value (get-raw-cmt-entry char designated-readtable))) + (values fun-value + ;; NON-TERMINATING-P return value: + (if fun-value + (or (constituentp char) + (not (terminating-macrop char))) + ;; ANSI's definition of GET-MACRO-CHARACTER says this + ;; value is NIL when CHAR is not a macro character. + ;; I.e. this value means not just "non-terminating + ;; character?" but "non-terminating macro character?". + nil)))) ;;;; definitions to support internal programming conventions -(defmacro eofp (char) `(eq ,char *eof-object*)) +(defmacro eofp (char) + `(eq ,char *eof-object*)) (defun flush-whitespace (stream) ;; This flushes whitespace chars, returning the last char it read (a ;; non-white one). It always gets an error on end-of-file. (let ((stream (in-synonym-of stream))) - (if (lisp-stream-p stream) + (if (ansi-stream-p stream) (prepare-for-fast-read-char stream (do ((attribute-table (character-attribute-table *readtable*)) (char (fast-read-char t) (fast-read-char t))) @@ -245,27 +270,31 @@ (defun !cold-init-standard-readtable () (setq *standard-readtable* (make-readtable)) - ;; All characters default to "constituent" in MAKE-READTABLE. - ;; *** un-constituent-ize some of these *** + ;; All characters get boring defaults in MAKE-READTABLE. Now we + ;; override the boring defaults on characters which need more + ;; interesting behavior. (let ((*readtable* *standard-readtable*)) - (set-cat-entry (code-char tab-char-code) +char-attr-whitespace+) - (set-cat-entry #\linefeed +char-attr-whitespace+) - (set-cat-entry #\space +char-attr-whitespace+) - (set-cat-entry (code-char form-feed-char-code) +char-attr-whitespace+) - (set-cat-entry (code-char return-char-code) +char-attr-whitespace+) + + (flet ((whitespaceify (char) + (set-cat-entry char +char-attr-whitespace+))) + (whitespaceify (code-char tab-char-code)) + (whitespaceify #\linefeed) + (whitespaceify #\space) + (whitespaceify (code-char form-feed-char-code)) + (whitespaceify (code-char return-char-code))) + (set-cat-entry #\\ +char-attr-escape+) (set-cmt-entry #\\ #'read-token) - (set-cat-entry (code-char rubout-char-code) +char-attr-whitespace+) - (set-cmt-entry #\: #'read-token) - (set-cmt-entry #\| #'read-token) - ;; macro definitions + + ;; Easy macro-character definitions are in this source file. (set-macro-character #\" #'read-string) - ;; * # macro (set-macro-character #\' #'read-quote) (set-macro-character #\( #'read-list) (set-macro-character #\) #'read-right-paren) (set-macro-character #\; #'read-comment) - ;; * backquote + ;; (The hairier macro-character definitions, for #\# and #\`, are + ;; defined elsewhere, in their own source files.) + ;; all constituents (do ((ichar 0 (1+ ichar)) (char)) @@ -273,7 +302,7 @@ (setq char (code-char ichar)) (when (constituentp char *standard-readtable*) (set-cat-entry char (get-secondary-attribute char)) - (set-cmt-entry char #'read-token))))) + (set-cmt-entry char nil))))) ;;;; implementation of the read buffer @@ -374,56 +403,61 @@ (eof-value nil) (recursivep nil)) #!+sb-doc - "Reads from stream and returns the object read, preserving the whitespace + "Read from STREAM and return the value read, preserving any whitespace that followed the object." - (cond - (recursivep + (if recursivep ;; a loop for repeating when a macro returns nothing (loop (let ((char (read-char stream eof-error-p *eof-object*))) (cond ((eofp char) (return eof-value)) ((whitespacep char)) (t - (let* ((macrofun (get-cmt-entry char *readtable*)) + (let* ((macrofun (get-coerced-cmt-entry char *readtable*)) (result (multiple-value-list (funcall macrofun stream char)))) ;; Repeat if macro returned nothing. - (if result (return (car result))))))))) - (t + (if result (return (car result)))))))) (let ((*sharp-equal-alist* nil)) - (read-preserving-whitespace stream eof-error-p eof-value t))))) + (read-preserving-whitespace stream eof-error-p eof-value t)))) ;;; Return NIL or a list with one thing, depending. ;;; ;;; for functions that want comments to return so that they can look -;;; past them. Assumes char is not whitespace. +;;; past them. We assume CHAR is not whitespace. (defun read-maybe-nothing (stream char) (let ((retval (multiple-value-list - (funcall (get-cmt-entry char *readtable*) stream char)))) + (funcall (get-coerced-cmt-entry char *readtable*) + stream + char)))) (if retval (rplacd retval nil)))) -(defun read (&optional (stream *standard-input*) (eof-error-p t) - (eof-value ()) (recursivep ())) +(defun read (&optional (stream *standard-input*) + (eof-error-p t) + (eof-value ()) + (recursivep ())) #!+sb-doc - "Reads in the next object in the stream, which defaults to - *standard-input*. For details see the I/O chapter of - the manual." - (prog1 - (read-preserving-whitespace stream eof-error-p eof-value recursivep) - (let ((whitechar (read-char stream nil *eof-object*))) - (if (and (not (eofp whitechar)) - (or (not (whitespacep whitechar)) - recursivep)) - (unread-char whitechar stream))))) + "Read the next Lisp value from STREAM, and return it." + (let ((result (read-preserving-whitespace stream + eof-error-p + eof-value + recursivep))) + ;; (This function generally discards trailing whitespace. If you + ;; don't want to discard trailing whitespace, call + ;; CL:READ-PRESERVING-WHITESPACE instead.) + (unless (or (eql result eof-value) recursivep) + (let ((next-char (read-char stream nil nil))) + (unless (or (null next-char) + (whitespacep next-char)) + (unread-char next-char stream)))) + result)) ;;; (This is a COMMON-LISP exported symbol.) (defun read-delimited-list (endchar &optional (input-stream *standard-input*) recursive-p) #!+sb-doc - "Reads objects from input-stream until the next character after an - object's representation is endchar. A list of those objects read - is returned." + "Read Lisp values from INPUT-STREAM until the next character after a + value's representation is ENDCHAR, and return the objects as a list." (declare (ignore recursive-p)) (do ((char (flush-whitespace input-stream) (flush-whitespace input-stream)) @@ -433,8 +467,8 @@ ;;;; basic readmacro definitions ;;;; -;;;; Large, hairy subsets of readmacro definitions (backquotes and sharp -;;;; macros) are not here, but in their own source files. +;;;; Some large, hairy subsets of readmacro definitions (backquotes +;;;; and sharp macros) are not here, but in their own source files. (defun read-quote (stream ignore) (declare (ignore ignore)) @@ -443,7 +477,7 @@ (defun read-comment (stream ignore) (declare (ignore ignore)) (let ((stream (in-synonym-of stream))) - (if (lisp-stream-p stream) + (if (ansi-stream-p stream) (prepare-for-fast-read-char stream (do ((char (fast-read-char nil nil) (fast-read-char nil nil))) @@ -506,7 +540,7 @@ ;; For a very long string, this could end up bloating the read buffer. (reset-read-buffer) (let ((stream (in-synonym-of stream))) - (if (lisp-stream-p stream) + (if (ansi-stream-p stream) (prepare-for-fast-read-char stream (do ((char (fast-read-char t) (fast-read-char t))) ((char= char closech) @@ -632,11 +666,11 @@ (defvar *read-suppress* nil #!+sb-doc - "Suppresses most interpreting of the reader when T") + "Suppress most interpreting in the reader when T.") (defvar *read-base* 10 #!+sb-doc - "The radix that Lisp reads numbers in.") + "the radix that Lisp reads numbers in") (declaim (type (integer 2 36) *read-base*)) ;;; Modify the read buffer according to READTABLE-CASE, ignoring @@ -661,7 +695,7 @@ (declare (fixnum esc)) (cond ((< esc i) t) (t - (assert (= esc i)) + (aver (= esc i)) (pop escapes) nil)))) (let ((ch (schar *read-buffer* i))) @@ -766,13 +800,13 @@ RIGHTDIGIT ; saw "[sign] {digit}* dot {digit}+" (ouch-read-buffer char) (setq char (read-char stream nil nil)) - (unless char (return (make-float))) + (unless char (return (make-float stream))) (case (char-class char attribute-table) (#.+char-attr-constituent-digit+ (go RIGHTDIGIT)) (#.+char-attr-constituent-expt+ (go EXPONENT)) (#.+char-attr-delimiter+ (unread-char char stream) - (return (make-float))) + (return (make-float stream))) (#.+char-attr-escape+ (go ESCAPE)) (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) (#.+char-attr-package-delimiter+ (go COLON)) @@ -825,12 +859,12 @@ EXPTDIGIT ; got to EXPONENT, saw "[sign] {digit}+" (ouch-read-buffer char) (setq char (read-char stream nil nil)) - (unless char (return (make-float))) + (unless char (return (make-float stream))) (case (char-class char attribute-table) (#.+char-attr-constituent-digit+ (go EXPTDIGIT)) (#.+char-attr-delimiter+ (unread-char char stream) - (return (make-float))) + (return (make-float stream))) (#.+char-attr-escape+ (go ESCAPE)) (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) (#.+char-attr-package-delimiter+ (go COLON)) @@ -849,12 +883,12 @@ RATIODIGIT ; saw "[sign] {digit}+ slash {digit}+" (ouch-read-buffer char) (setq char (read-char stream nil nil)) - (unless char (return (make-ratio))) + (unless char (return (make-ratio stream))) (case (char-class2 char attribute-table) (#.+char-attr-constituent-digit+ (go RATIODIGIT)) (#.+char-attr-delimiter+ (unread-char char stream) - (return (make-ratio))) + (return (make-ratio stream))) (#.+char-attr-escape+ (go ESCAPE)) (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) (#.+char-attr-package-delimiter+ (go COLON)) @@ -874,7 +908,7 @@ (t (go SYMBOL))) SYMBOL ; not a dot, dots, or number (let ((stream (in-synonym-of stream))) - (if (lisp-stream-p stream) + (if (ansi-stream-p stream) (prepare-for-fast-read-char stream (prog () SYMBOL-LOOP @@ -1113,7 +1147,7 @@ (the index (* num base)))))))) (setq number (+ num (* number base-power))))))) -(defun make-float () +(defun make-float (stream) ;; Assume that the contents of *read-buffer* are a legal float, with nothing ;; else after it. (read-unwind-read-buffer) @@ -1147,7 +1181,8 @@ (cond ((eofp char) ;; If not, we've read the whole number. (let ((num (make-float-aux number divisor - *read-default-float-format*))) + *read-default-float-format* + stream))) (return-from make-float (if negative-fraction (- num) num)))) ((exponent-letterp char) (setq float-char char) @@ -1165,7 +1200,7 @@ ((not dig) (setq exponent (if negative-exponent (- exponent) exponent))) (setq exponent (+ (* exponent 10) dig))) - ;; Generate and return the float, depending on float-char: + ;; Generate and return the float, depending on FLOAT-CHAR: (let* ((float-format (case (char-upcase float-char) (#\E *read-default-float-format*) (#\S 'short-float) @@ -1173,35 +1208,34 @@ (#\D 'double-float) (#\L 'long-float))) num) - ;; toy@rtp.ericsson.se: We need to watch out if the + ;; Raymond Toy writes: We need to watch out if the ;; exponent is too small or too large. We add enough to ;; EXPONENT to make it within range and scale NUMBER ;; appropriately. This should avoid any unnecessary ;; underflow or overflow problems. (multiple-value-bind (min-expo max-expo) - ;; FIXME: These #. forms are broken w.r.t. - ;; cross-compilation portability. Maybe expressions - ;; like - ;; (LOG SB!XC:MOST-POSITIVE-SHORT-FLOAT 10s0) - ;; could be used instead? Or perhaps some sort of - ;; load-time-form magic? + ;; FIXME: These forms are broken w.r.t. + ;; cross-compilation portability, as the + ;; cross-compiler will call the host's LOG function + ;; while attempting to constant-fold. Maybe some sort + ;; of load-time-form magic could be used instead? (case float-format (short-float (values - #.(log least-positive-normalized-short-float 10s0) - #.(log most-positive-short-float 10s0))) + (log sb!xc:least-positive-normalized-short-float 10s0) + (log sb!xc:most-positive-short-float 10s0))) (single-float (values - #.(log least-positive-normalized-single-float 10f0) - #.(log most-positive-single-float 10f0))) + (log sb!xc:least-positive-normalized-single-float 10f0) + (log sb!xc:most-positive-single-float 10f0))) (double-float (values - #.(log least-positive-normalized-double-float 10d0) - #.(log most-positive-double-float 10d0))) + (log sb!xc:least-positive-normalized-double-float 10d0) + (log sb!xc:most-positive-double-float 10d0))) (long-float (values - #.(log least-positive-normalized-long-float 10L0) - #.(log most-positive-long-float 10L0)))) + (log sb!xc:least-positive-normalized-long-float 10L0) + (log sb!xc:most-positive-long-float 10L0)))) (let ((correction (cond ((<= exponent min-expo) (ceiling (- min-expo exponent))) ((>= exponent max-expo) @@ -1210,18 +1244,23 @@ 0)))) (incf exponent correction) (setf number (/ number (expt 10 correction))) - (setq num (make-float-aux number divisor float-format)) + (setq num (make-float-aux number divisor float-format stream)) (setq num (* num (expt 10 exponent))) (return-from make-float (if negative-fraction (- num) num)))))) - ;; should never happen: - (t (error "internal error in floating point reader"))))) - -(defun make-float-aux (number divisor float-format) - (coerce (/ number divisor) float-format)) - -(defun make-ratio () + ;; should never happen + (t (bug "bad fallthrough in floating point reader"))))) + +(defun make-float-aux (number divisor float-format stream) + (handler-case + (coerce (/ number divisor) float-format) + (type-error (c) + (error 'reader-impossible-number-error + :error c :stream stream + :format-control "failed to build float")))) + +(defun make-ratio (stream) ;; Assume *READ-BUFFER* contains a legal ratio. Build the number from ;; the string. ;; @@ -1245,7 +1284,12 @@ (dig ())) ((or (eofp ch) (not (setq dig (digit-char-p ch *read-base*))))) (setq denominator (+ (* denominator *read-base*) dig))) - (let ((num (/ numerator denominator))) + (let ((num (handler-case + (/ numerator denominator) + (arithmetic-error (c) + (error 'reader-impossible-number-error + :error c :stream stream + :format-control "failed to build ratio"))))) (if negative-number (- num) num)))) ;;;; cruft for dispatch macros @@ -1273,7 +1317,8 @@ (error "The dispatch character ~S already exists." char)) (t (setf (dispatch-tables rt) - (push (cons char (make-char-dispatch-table)) dalist)))))) + (push (cons char (make-char-dispatch-table)) dalist))))) + t) (defun set-dispatch-macro-character (disp-char sub-char function &optional (rt *readtable*)) @@ -1285,6 +1330,7 @@ (when (digit-char-p sub-char) (error "SUB-CHAR must not be a decimal digit: ~S" sub-char)) (let* ((sub-char (char-upcase sub-char)) + (rt (or rt *standard-readtable*)) (dpair (find disp-char (dispatch-tables rt) :test #'char= :key #'car))) (if dpair @@ -1296,17 +1342,22 @@ (defun get-dispatch-macro-character (disp-char sub-char &optional (rt *readtable*)) #!+sb-doc - "Returns the macro character function for sub-char under disp-char - or nil if there is no associated function." - (unless (digit-char-p sub-char) - (let* ((sub-char (char-upcase sub-char)) - (rt (or rt *standard-readtable*)) - (dpair (find disp-char (dispatch-tables rt) - :test #'char= :key #'car))) - (if dpair - (elt (the simple-vector (cdr dpair)) - (char-code sub-char)) - (error "~S is not a dispatch char." disp-char))))) + "Return the macro character function for SUB-CHAR under DISP-CHAR + or NIL if there is no associated function." + (let* ((sub-char (char-upcase sub-char)) + (rt (or rt *standard-readtable*)) + (dpair (find disp-char (dispatch-tables rt) + :test #'char= :key #'car))) + (if dpair + (let ((dispatch-fun (elt (the simple-vector (cdr dpair)) + (char-code sub-char)))) + ;; Digits are also initialized in a dispatch table to + ;; #'dispatch-char-error; READ-DISPATCH-CHAR handles them + ;; separately. - CSR, 2002-04-12 + (if (eq dispatch-fun #'dispatch-char-error) + nil + dispatch-fun)) + (error "~S is not a dispatch char." disp-char)))) (defun read-dispatch-char (stream char) ;; Read some digits. @@ -1349,9 +1400,10 @@ and the lisp object built by the reader is returned. Macro chars will take effect." (declare (string string)) + (with-array-data ((string string) (start start) - (end (or end (length string)))) + (end (%check-vector-sequence-bounds string start end))) (unless *read-from-string-spares* (push (internal-make-string-input-stream "" 0 0) *read-from-string-spares*)) @@ -1374,51 +1426,55 @@ (default to the beginning and end of the string) It skips over whitespace characters and then tries to parse an integer. The radix parameter must be between 2 and 36." - (with-array-data ((string string) - (start start) - (end (or end (length string)))) - (let ((index (do ((i start (1+ i))) - ((= i end) - (if junk-allowed - (return-from parse-integer (values nil end)) - (error "no non-whitespace characters in number"))) - (declare (fixnum i)) - (unless (whitespacep (char string i)) (return i)))) - (minusp nil) - (found-digit nil) - (result 0)) - (declare (fixnum index)) - (let ((char (char string index))) - (cond ((char= char #\-) - (setq minusp t) - (incf index)) - ((char= char #\+) - (incf index)))) - (loop - (when (= index end) (return nil)) - (let* ((char (char string index)) - (weight (digit-char-p char radix))) - (cond (weight - (setq result (+ weight (* result radix)) - found-digit t)) - (junk-allowed (return nil)) - ((whitespacep char) - (do ((jndex (1+ index) (1+ jndex))) - ((= jndex end)) - (declare (fixnum jndex)) - (unless (whitespacep (char string jndex)) - (error "junk in string ~S" string))) - (return nil)) - (t - (error "junk in string ~S" string)))) - (incf index)) - (values - (if found-digit - (if minusp (- result) result) - (if junk-allowed - nil - (error "no digits in string ~S" string))) - index)))) + (macrolet ((parse-error (format-control) + `(error 'simple-parse-error + :format-control ,format-control + :format-arguments (list string)))) + (with-array-data ((string string) + (start start) + (end (%check-vector-sequence-bounds string start end))) + (let ((index (do ((i start (1+ i))) + ((= i end) + (if junk-allowed + (return-from parse-integer (values nil end)) + (parse-error "no non-whitespace characters in string ~S."))) + (declare (fixnum i)) + (unless (whitespacep (char string i)) (return i)))) + (minusp nil) + (found-digit nil) + (result 0)) + (declare (fixnum index)) + (let ((char (char string index))) + (cond ((char= char #\-) + (setq minusp t) + (incf index)) + ((char= char #\+) + (incf index)))) + (loop + (when (= index end) (return nil)) + (let* ((char (char string index)) + (weight (digit-char-p char radix))) + (cond (weight + (setq result (+ weight (* result radix)) + found-digit t)) + (junk-allowed (return nil)) + ((whitespacep char) + (do ((jndex (1+ index) (1+ jndex))) + ((= jndex end)) + (declare (fixnum jndex)) + (unless (whitespacep (char string jndex)) + (parse-error "junk in string ~S"))) + (return nil)) + (t + (parse-error "junk in string ~S")))) + (incf index)) + (values + (if found-digit + (if minusp (- result) result) + (if junk-allowed + nil + (parse-error "no digits in string ~S"))) + index))))) ;;;; reader initialization code