ikarus/scheme/ikarus.reader.ss

;;; Ikarus Scheme -- A compiler for R6RS Scheme.
;;; Copyright (C) 2006,2007,2008  Abdulaziz Ghuloum
;;; 
;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License version 3 as
;;; published by the Free Software Foundation.
;;; 
;;; This program is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; General Public License for more details.
;;; 
;;; You should have received a copy of the GNU General Public License
;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.


(library (ikarus reader)
  (export read read-initial read-token comment-handler get-datum
          read-annotated read-script-annotated annotation?
          annotation-expression annotation-source
          annotation-stripped 
          read-library-source-file read-script-source-file)
  (import
    (ikarus system $chars)
    (ikarus system $fx)
    (ikarus system $pairs)
    (ikarus system $bytevectors)
    (only (io-spec) open-string-input-port/id)
    (only (ikarus unicode-data) unicode-printable-char?) 
    (except (ikarus) read-char read read-token comment-handler get-datum
      read-annotated read-script-annotated annotation?
      annotation-expression annotation-source annotation-stripped))

  (define (die/pos p off who msg arg*) 
    (define-condition-type &lexical-position &condition
        make-lexical-position-condition lexical-position?
        (file-name lexical-position-filename)
        (character lexical-position-character))
    (raise 
      (condition
        (make-lexical-violation) 
        (make-message-condition msg)
        (if (null? arg*) 
            (condition)
            (make-irritants-condition arg*))
        (make-lexical-position-condition 
          (port-id p) 
          (let ([pos (input-port-byte-position p)])
            (and pos (+ pos off)))))))
        
  (define (die/p p who msg . arg*)
    (die/pos p 0 who msg arg*))
  (define (die/p-1 p who msg . arg*)
    (die/pos p -1 who msg arg*))


  (define (checked-integer->char n ac p) 
    (define (valid-integer-char? n)
      (cond
        [(<= n #xD7FF)   #t]
        [(< n #xE000)    #f]
        [(<= n #x10FFFF) #t]
        [else            #f]))
    (if (valid-integer-char? n) 
        ($fixnum->char n)
        (die/p p 'tokenize 
          "invalid numeric value for character"
          (list->string (reverse ac)))))

  (define-syntax read-char 
    (syntax-rules ()
      [(_ p) (get-char p)]))

  (define delimiter?
    (lambda (c)
      (or (char-whitespace? c)
          (memq c '(#\( #\) #\[ #\] #\" #\# #\;)))))
  (define digit?
    (lambda (c)
      (and ($char<= #\0 c) ($char<= c #\9))))
  (define char->num
    (lambda (c)
      (fx- ($char->fixnum c) ($char->fixnum #\0))))
  (define initial?
    (lambda (c)
      (cond
        [($char<= c ($fixnum->char 127))
         (or (letter? c) (special-initial? c))]
        [else (unicode-printable-char? c)])))
  (define letter? 
    (lambda (c)
      (or (and ($char<= #\a c) ($char<= c #\z))
          (and ($char<= #\A c) ($char<= c #\Z)))))
  (define af? 
    (lambda (c)
      (or (and ($char<= #\a c) ($char<= c #\f))
          (and ($char<= #\A c) ($char<= c #\F)))))
  (define af->num
    (lambda (c)
      (if (and ($char<= #\a c) ($char<= c #\f))
          (fx+ 10 (fx- ($char->fixnum c) ($char->fixnum #\a)))
          (fx+ 10 (fx- ($char->fixnum c) ($char->fixnum #\A))))))
  (define special-initial?
    (lambda (c)
      (memq c '(#\! #\$ #\% #\& #\* #\/ #\: #\< #\= #\> #\? #\^ #\_ #\~))))
  (define subsequent?
    (lambda (c)
      (or (initial? c) (digit? c) (special-subsequent? c))))
  (define special-subsequent?
    (lambda (c)
      (memq c '(#\+ #\- #\. #\@))))
  (define tokenize-identifier
    (lambda (ls p)
      (let ([c (peek-char p)])
        (cond
         [(eof-object? c) ls]
         [(subsequent? c)
          (tokenize-identifier (cons (read-char p) ls) p)]
         [(delimiter? c)
          ls]
         [(char=? c #\\)
          (read-char p)
          (tokenize-backslash ls p)]
         [else
          (die/p p 'tokenize "invalid identifier syntax" 
            (list->string (reverse (cons c ls))))]))))
  (define (tokenize-string ls p)
    (let ([c (read-char p)])
      (cond
        [(eof-object? c) 
         (die/p p 'tokenize "invalid eof inside string")]
        [else (tokenize-string-char ls p c)])))
  (define (tokenize-string-char ls p c)
    (define (intraline-whitespace? c)
      (or (eqv? c #\x9) 
          (eq? (char-general-category c) 'Zs)))
    (define (tokenize-string-continue ls p c)
      (cond
        [(eof-object? c) 
         (die/p p 'tokenize "invalid eof inside string")]
        [(intraline-whitespace? c)
         (let f ()
           (let ([c (read-char p)])
             (cond
               [(eof-object? c) 
                (die/p p 'tokenize "invalid eof inside string")]
               [(intraline-whitespace? c) (f)]
               [else (tokenize-string-char ls p c)])))]
        [else (tokenize-string-char ls p c)]))
    (cond
     [($char= #\" c) ls]
     [($char= #\\ c)
      (let ([c (read-char p)])
        (cond
          [(eof-object? c) 
           (die/p p 'tokenize "invalid eof after string escape")]
          [($char= #\a c) (tokenize-string (cons #\x7 ls) p)]
          [($char= #\b c) (tokenize-string (cons #\x8 ls) p)]
          [($char= #\t c) (tokenize-string (cons #\x9 ls) p)]
          [($char= #\n c) (tokenize-string (cons #\xA ls) p)]
          [($char= #\v c) (tokenize-string (cons #\xB ls) p)]
          [($char= #\f c) (tokenize-string (cons #\xC ls) p)]
          [($char= #\r c) (tokenize-string (cons #\xD ls) p)]
          [($char= #\" c) (tokenize-string (cons #\x22 ls) p)]
          [($char= #\\ c) (tokenize-string (cons #\x5C ls) p)]
          [($char= #\x c) ;;; unicode escape \xXXX;
           (let ([c (read-char p)])
             (cond
               [(eof-object? c) 
                (die/p p 'tokenize "invalid eof inside string")]
               [(hex c) =>
                (lambda (n)
                  (let f ([n n] [ac (cons c '(#\x))])
                    (let ([c (read-char p)])
                      (cond
                        [(eof-object? n) 
                         (die/p p 'tokenize "invalid eof inside string")]
                        [(hex c) =>
                         (lambda (v) (f (+ (* n 16) v) (cons c ac)))]
                        [($char= c #\;) 
                         (tokenize-string
                           (cons (checked-integer->char n ac p) ls) p)]
                        [else
                         (die/p-1 p 'tokenize
                           "invalid char in escape sequence"
                           (list->string (reverse (cons c ac))))]))))]
               [else 
                (die/p-1 p 'tokenize
                  "invalid char in escape sequence" c)]))]
          [(intraline-whitespace? c)
           (let f ()
             (let ([c (read-char p)])
               (cond
                 [(eof-object? c) 
                  (die/p p 'tokenize "invalid eof inside string")]
                 [(intraline-whitespace? c) (f)]
                 [(memv c '(#\xA #\x85 #\x2028)) 
                  (tokenize-string-continue ls p (read-char p))]
                 [(memv c '(#\xD)) 
                  (let ([c (read-char p)])
                    (cond
                      [(memv c '(#\xA #\x85))
                       (tokenize-string-continue ls p (read-char p))]
                      [else 
                       (tokenize-string-continue ls p c)]))]
                 [else
                  (die/p-1 p 'tokenize 
                    "non-whitespace character after escape")])))]
          [(memv c '(#\xA #\x85 #\x2028))
           (tokenize-string-continue ls p (read-char p))]
          [(memv c '(#\xD)) 
           (let ([c (read-char p)])
             (cond
               [(memv c '(#\xA #\x85))
                (tokenize-string-continue ls p (read-char p))]
               [else 
                (tokenize-string-continue ls p c)]))]
          [else (die/p-1 p 'tokenize "invalid string escape" c)]))]
     [(memv c '(#\xA #\x85 #\x2028))
      (tokenize-string (cons #\linefeed ls) p)]
     [(memv c '(#\xD))
      (let ([c (peek-char p)])
        (when (memv c '(#\xA #\x85))
          (read-char p))
        (tokenize-string (cons #\linefeed ls) p))]
     [else
      (tokenize-string (cons c ls) p)]))
  (define skip-comment
    (lambda (p)
      (let ([c (read-char p)])
        (unless (eof-object? c)
          (let ([i ($char->fixnum c)])
            (unless (or (fx= i 10) (fx= i 13))
              (skip-comment p)))))))
  (define tokenize-dot
    (lambda (p)
      (let ([c (peek-char p)])
        (cond
          [(eof-object? c) 'dot]
          [(delimiter? c)  'dot]
          [($char= c #\.)  ; this is second dot
           (read-char p)
           (let ([c (peek-char p)])
             (cond
               [(eof-object? c) 
                (die/p p 'tokenize "invalid syntax .. near end of file")]
               [($char= c #\.) ; this is the third
                (read-char p)
                (let ([c (peek-char p)])
                  (cond
                    [(eof-object? c) '(datum . ...)]
                    [(delimiter? c)  '(datum . ...)]
                    [else 
                     (die/p p 'tokenize "invalid syntax"
                       (string-append "..." (string c)))]))]
               [else
                (die/p p 'tokenize "invalid syntax"
                  (string-append ".." (string c)))]))]
          [else 
           (cons 'datum 
             (tokenize-decimal-no-digits p '(#\.) #f))]))))
  (define tokenize-char* 
    (lambda (i str p d)
      (cond
       [(fx= i (string-length str))
        (let ([c (peek-char p)])
          (cond
           [(eof-object? c) d]
           [(delimiter? c)  d]
           [else (die/p p 'tokenize "invalid character after sequence"
                    (string-append str (string c)))]))]
       [else
        (let ([c (read-char p)])
          (cond
            [(eof-object? c) 
             (die/p p 'tokenize "invalid eof in the middle of expected sequence" str)]
            [($char= c (string-ref str i))
             (tokenize-char* (fxadd1 i) str p d)]
            [else 
             (die/p-1 p 'tokenize
                "invalid char while scanning string"
                 c str)]))])))
  (define tokenize-char-seq
    (lambda (p str d)
      (let ([c (peek-char p)])
        (cond
          [(eof-object? c) (cons 'datum (string-ref str 0))]
          [(delimiter? c)  (cons 'datum (string-ref str 0))]
          [($char= (string-ref str 1) c) 
           (read-char p)
           (tokenize-char*  2 str p d)]
          [else (die/p p 'tokenize "invalid syntax" 
                  (string-ref str 0) c)]))))
  (define tokenize-char
    (lambda (p)
      (let ([c (read-char p)])
        (cond
          [(eof-object? c)
           (die/p p 'tokenize "invalid #\\ near end of file")]
          [(eqv? #\n c) 
           (let ([c (peek-char p)])
             (cond
               [(eof-object? c)
                (read-char p)
                '(datum . #\n)]
               [(eqv? #\u c) 
                (read-char p)
                (tokenize-char-seq p "ul" '(datum . #\x0))]
               [(eqv? #\e c) 
                (read-char p)
                (tokenize-char-seq p "ewline" '(datum . #\xA))]
               [(delimiter? c)
                '(datum . #\n)]
               [else 
                (die/p p 'tokenize "invalid syntax"
                  (string #\# #\\ #\n c))]))]
          [(eqv? #\a c) 
           (tokenize-char-seq p "alarm" '(datum . #\x7))]
          [(eqv? #\b c) 
           (tokenize-char-seq p "backspace" '(datum . #\x8))]
          [(eqv? #\t c)
           (tokenize-char-seq p "tab" '(datum . #\x9))]
          [(eqv? #\l c) 
           (tokenize-char-seq p "linefeed" '(datum . #\xA))]
          [(eqv? #\v c) 
           (tokenize-char-seq p "vtab" '(datum . #\xB))]
          [(eqv? #\p c) 
           (tokenize-char-seq p "page" '(datum . #\xC))]
          [(eqv? #\r c) 
           (tokenize-char-seq p "return" '(datum . #\xD))]
          [(eqv? #\e c) 
           (tokenize-char-seq p "esc" '(datum . #\x1B))]
          [(eqv? #\s c) 
           (tokenize-char-seq p "space" '(datum . #\x20))]
          [(eqv? #\d c)
           (tokenize-char-seq p "delete" '(datum . #\x7F))]
          [(eqv? #\x c) 
           (let ([n (peek-char p)])
             (cond
               [(or (eof-object? n) (delimiter? n))
                '(datum . #\x)]
               [(hex n) =>
                (lambda (v)
                  (read-char p)
                  (let f ([v v] [ac (cons n '(#\x))])
                    (let ([c (peek-char p)])
                      (cond
                        [(eof-object? c)
                         (cons 'datum (checked-integer->char v ac p))]
                        [(delimiter? c)
                         (cons 'datum (checked-integer->char v ac p))]
                        [(hex c) =>
                         (lambda (v0)
                           (read-char p)
                           (f (+ (* v 16) v0) (cons c ac)))]
                        [else
                         (die/p p 'tokenize 
                           "invalid character sequence"
                           (list->string (reverse (cons c ac))))]))))]
               [else
                (die/p p 'tokenize "invalid character sequence"
                       (string-append "#\\" (string n)))]))]
          [else
           (let ([n (peek-char p)])
             (cond
               [(eof-object? n) (cons 'datum c)]
               [(delimiter? n)  (cons 'datum c)]
               [else 
                (die/p p 'tokenize "invalid syntax"
                  (string-append "#\\" (string c n)))]))]))))
  (define (hex x)
    (cond
      [(and ($char<= #\0 x) ($char<= x #\9))
       ($fx- ($char->fixnum x) ($char->fixnum #\0))]
      [(and ($char<= #\a x) ($char<= x #\f))
       ($fx- ($char->fixnum x) 
             ($fx- ($char->fixnum #\a) 10))]
      [(and ($char<= #\A x) ($char<= x #\F))
       ($fx- ($char->fixnum x)
             ($fx- ($char->fixnum #\A) 10))]
      [else #f]))
  (define multiline-error
    (lambda (p)
      (die/p p 'tokenize
         "end of file encountered while inside a #|-style comment")))
  (define apprev
    (lambda (str i ac)
      (cond
        [(fx= i (string-length str)) ac]
        [else
         (apprev str (fx+ i 1) (cons (string-ref str i) ac))])))
  (define multiline-comment
    (lambda (p)
      (define f 
        (lambda (p ac)
          (let ([c (read-char p)])
            (cond
              [(eof-object? c) (multiline-error p)]
              [($char= #\| c) 
               (let g ([c (read-char p)] [ac ac])
                 (cond
                   [(eof-object? c) (multiline-error p)]
                   [($char= #\# c) ac]
                   [($char= #\| c)
                    (g (read-char p) (cons c ac))]
                   [else (f p (cons c ac))]))]
              [($char= #\# c)
               (let ([c (read-char p)])
                 (cond
                   [(eof-object? c) (multiline-error p)]
                   [($char= #\| c)
                    (let ([v (multiline-comment p)])
                      (if (string? v)
                          (f p (apprev v 0 ac))
                          (f p ac)))]
                   [else 
                    (f p (cons c (cons #\# ac)))]))]
              [else (f p (cons c ac))]))))
      (let ([ac (f p '())])
        ((comment-handler)
          (list->string (reverse ac))))))
  (define tokenize-hash
    (lambda (p)
      (tokenize-hash/c (read-char p) p)))
  (define (skip-whitespace p caller)
    (let ([c (read-char p)])
      (cond
        [(eof-object? c)
         (die/p p 'tokenize "invalid eof inside" caller)]
        [(char-whitespace? c)
         (skip-whitespace p caller)]
        [else c])))
  (define tokenize-hash/c
    (lambda (c p)
      (cond
        [(eof-object? c) (die/p p 'tokenize "invalid # near end of file")]
        [(memq c '(#\t #\T)) 
         (let ([c (peek-char p)])
           (cond
             [(eof-object? c) '(datum . #t)]
             [(delimiter? c)  '(datum . #t)]
             [else (die/p p 'tokenize 
                     (format "invalid syntax near #~a" c))]))]
        [(memq c '(#\f #\F)) 
         (let ([c (peek-char p)])
           (cond
             [(eof-object? c) '(datum . #f)]
             [(delimiter? c)  '(datum . #f)]
             [else (die/p p 'tokenize 
                     (format "invalid syntax near #~a" c))]))]
        [($char= #\\ c) (tokenize-char p)]
        [($char= #\( c) 'vparen]
        [($char= #\' c) '(macro . syntax)]
        [($char= #\` c) '(macro . quasisyntax)]
        [($char= #\, c)
         (let ([c (peek-char p)])
           (cond
             [(eqv? c #\@) (read-char p)
              '(macro . unsyntax-splicing)]
             [else '(macro . unsyntax)]))]
        [($char= #\! c) 
         (let ([e (read-char p)])
           (when (eof-object? e)
             (die/p p 'tokenize "invalid eof near #!"))
           (case e
             [(#\e) 
              (when (eq? (port-mode p) 'r6rs-mode)
                (die/p-1 p 'tokenize "invalid syntax: #!e"))
              (read-char* p '(#\e) "of" "eof sequence" #f #f)
              (cons 'datum (eof-object))]
             [(#\r) 
              (read-char* p '(#\r) "6rs" "#!r6rs comment" #f #f)
              (set-port-mode! p 'r6rs-mode)
              (tokenize/1 p)]
             [(#\i) 
              (read-char* p '(#\i) "karus" "#!ikarus comment" #f #f)
              (set-port-mode! p 'ikarus-mode)
              (tokenize/1 p)]
             [else
              (die/p-1 p 'tokenize
                (format "invalid syntax near #!~a" e))]))]
        [(digit? c) 
         (when (eq? (port-mode p) 'r6rs-mode)
           (die/p-1 p 'tokenize "graph syntax is invalid in #!r6rs mode"
              (format "#~a" c)))
         (tokenize-hashnum p (char->num c))]
        [($char= #\: c)
         (when (eq? (port-mode p) 'r6rs-mode)
           (die/p-1 p 'tokenize "gensym syntax is invalid in #!r6rs mode"
              (format "#~a" c)))
         (let* ([c (skip-whitespace p "gensym")]
                [id0 
                 (cond
                   [(initial? c)
                    (list->string
                      (reverse (tokenize-identifier (cons c '()) p)))]
                   [($char= #\| c)
                    (list->string 
                      (reverse (tokenize-bar p '())))]
                   [else 
                    (die/p-1 p 'tokenize
                      "invalid char inside gensym" c)])])
              (cons 'datum (gensym id0)))]
        [($char= #\{ c)
         (when (eq? (port-mode p) 'r6rs-mode)
           (die/p-1 p 'tokenize "gensym syntax is invalid in #!r6rs mode"
              (format "#~a" c)))
         (let* ([c (skip-whitespace p "gensym")]
                [id0 
                 (cond
                   [(initial? c)
                    (list->string
                      (reverse (tokenize-identifier (cons c '()) p)))]
                   [($char= #\| c)
                    (list->string 
                      (reverse (tokenize-bar p '())))]
                   [else 
                    (die/p-1 p 'tokenize
                      "invalid char inside gensym" c)])]
                [c (skip-whitespace p "gensym")])
           (cond
             [($char= #\} c)
              (cons 'datum 
                (foreign-call "ikrt_strings_to_gensym" #f id0))]
             [else
              (let ([id1
                     (cond
                       [(initial? c)
                        (list->string
                         (reverse
                           (tokenize-identifier 
                             (cons c '()) p)))]
                       [($char= #\| c)
                        (list->string 
                          (reverse (tokenize-bar p '())))]
                       [else 
                        (die/p-1 p 'tokenize
                          "invalid char inside gensym" c)])])
                (let ([c (skip-whitespace p "gensym")])
                  (cond
                    [($char= #\} c)
                     (cons 'datum
                      (foreign-call "ikrt_strings_to_gensym" 
                        id0 id1))]
                    [else
                     (die/p-1 p 'tokenize
                        "invalid char inside gensym" c)])))]))]
        [($char= #\v c)
         (let ([c (read-char p)])
           (cond
             [($char= #\u c)
              (let ([c (read-char p)])
                (cond
                  [($char= c #\8)
                   (let ([c (read-char p)])
                     (cond
                       [($char= c #\() 'vu8]
                       [(eof-object? c) 
                        (die/p p 'tokenize "invalid eof object after #vu8")]
                       [else (die/p-1 p 'tokenize 
                               (format "invalid sequence #vu8~a" c))]))]
                  [(eof-object? c) 
                   (die/p p 'tokenize "invalid eof object after #vu")]
                  [else (die/p-1 p 'tokenize 
                           (format "invalid sequence #vu~a" c))]))]
             [(eof-object? c) 
              (die/p p 'tokenize "invalid eof object after #v")]
             [else (die/p p 'tokenize
                     (format "invalid sequence #v~a" c))]))]
        [(memq c '(#\e #\E)) 
         (cons 'datum (tokenize-exactness-mark p (list c #\#) 'e))]
        [(memq c '(#\i #\I)) 
         (cons 'datum (tokenize-exactness-mark p (list c #\#) 'i))]
        [(memq c '(#\b #\B)) 
         (cons 'datum (tokenize-radix-mark p (list c #\#) 2))]
        [(memq c '(#\x #\X)) 
         (cons 'datum (tokenize-radix-mark p (list c #\#) 16))]
        [(memq c '(#\o #\O)) 
         (cons 'datum (tokenize-radix-mark p (list c #\#) 8))]
        [(memq c '(#\d #\D)) 
         (cons 'datum (tokenize-radix-mark p (list c #\#) 10))]
        [($char= #\@ c)
         (when (eq? (port-mode p) 'r6rs-mode)
           (die/p-1 p 'tokenize "fasl syntax is invalid in #!r6rs mode"
              (format "#~a" c)))
         (die/p-1 p 'read "FIXME: fasl read disabled")
         '(cons 'datum ($fasl-read p))]
        [else 
         (die/p-1 p 'tokenize 
            (format "invalid syntax #~a" c))])))
  (define (tokenize-exactness-mark p ls exact?)
    (let ([c (read-char p)])
      (cond
        [(eof-object? c) (num-error p "eof object" ls)]
        [(radix-digit c 10) =>
         (lambda (d) 
           (tokenize-integer p (cons c ls) exact? 10 d))]
        [(char=? c #\.) 
         (tokenize-decimal-no-digits p (cons c ls) exact?)]
        [(char=? c #\-) 
         (- (tokenize-integer-no-digits p (cons c ls) exact? 10))]
        [(char=? c #\+)
         (tokenize-integer-no-digits p (cons c ls) exact? 10)]
        [(char=? c #\#)
         (let ([c1 (read-char p)])
           (cond
             [(eof-object? c1) 
              (num-error p "eof object" (cons c ls))]
             [(memv c1 '(#\b #\B)) 
              (tokenize-radix/exactness-marks p (cons* c1 c ls) exact? 2)]
             [(memv c1 '(#\x #\X)) 
              (tokenize-radix/exactness-marks p (cons* c1 c ls) exact? 16)]
             [(memv c1 '(#\o #\O)) 
              (tokenize-radix/exactness-marks p (cons* c1 c ls) exact? 8)]
             [(memv c1 '(#\d #\D)) 
              (tokenize-radix/exactness-marks p (cons* c1 c ls) exact? 10)]
             [else (num-error p "invalid sequence" (cons* c1 c ls))]))]
        [else (num-error p "invalid sequence" (cons c ls))]))) 
  (define (tokenize-radix-mark p ls radix)
    (let ([c (read-char p)])
      (cond
        [(eof-object? c) (num-error p "eof object" ls)]
        [(radix-digit c radix) =>
         (lambda (d)
           (tokenize-integer p (cons c ls) #f radix d))]
        [(char=? c #\.) 
         (unless (= radix 10)
           (num-error p "invalid decimal" (cons c ls)))
         (tokenize-decimal-no-digits p (cons c ls) #f)]
        [(char=? c #\-)
         (- (tokenize-integer-no-digits p (cons c ls) #f radix))]
        [(char=? c #\+)
         (tokenize-integer-no-digits p (cons c ls) #f radix)]
        [(char=? c #\#)
         (let ([c1 (read-char p)])
           (cond
             [(eof-object? c1) 
              (num-error p "eof object" (cons c ls))]
             [(memv c1 '(#\e #\E)) 
              (tokenize-radix/exactness-marks p (cons c1 (cons c ls))
                'e radix)]
             [(memv c1 '(#\i #\I)) 
              (tokenize-radix/exactness-marks p (cons c1 (cons c ls))
                'i radix)]
             [else (num-error p "invalid sequence" (cons* c1 c ls))]))]
        [else (num-error p "invalid sequence" (cons c ls))])))
  (define (tokenize-radix/exactness-marks p ls exact? radix) 
    (let ([c (read-char p)])
      (cond
        [(eof-object? c) (num-error p "eof object" ls)]
        [(radix-digit c radix) =>
         (lambda (d) 
           (tokenize-integer p (cons c ls) exact? radix d))]
        [(char=? c #\.) 
         (unless (= radix 10)
           (num-error p "invalid decimal" (cons c ls)))
         (tokenize-decimal-no-digits p (cons c ls) exact?)]
        [(char=? c #\-) 
         (- (tokenize-integer-no-digits p (cons c ls) exact? radix))]
        [(char=? c #\+)
         (tokenize-integer-no-digits p (cons c ls) exact? radix)]
        [else (num-error p "invalid sequence" (cons c ls))])))
  (define (tokenize-integer p ls exact? radix ac) 
    (define (tokenize-denom-start p ls exact? radix num)
      (let ([c (read-char p)])
        (cond
          [(eof-object? c) (num-error p "eof object" ls)]
          [(radix-digit c radix) =>
           (lambda (d) 
             (tokenize-denom p (cons c ls) exact? radix num d))]
          [(char=? c #\-)
           (tokenize-denom-no-digits p (cons c ls) exact? radix (- num))]
          [(char=? c #\+)
           (tokenize-denom-no-digits p (cons c ls) exact? radix num)]
          [else (num-error p "invalid sequence" (cons c ls))])))
    (define (tokenize-denom-no-digits p ls exact? radix num)