diff --git a/scheme/ikarus.reader.ss b/scheme/ikarus.reader.ss index 7e35fb1..57671d3 100644 --- a/scheme/ikarus.reader.ss +++ b/scheme/ikarus.reader.ss @@ -20,6 +20,7 @@ annotation-expression annotation-source annotation-stripped) (import + (only (ikarus.string-to-number) define-string->number-parser) (ikarus system $chars) (ikarus system $fx) (ikarus system $pairs) @@ -255,8 +256,8 @@ (die/p p 'tokenize "invalid syntax" (string-append ".." (string c)))]))] [else - (cons 'datum - (tokenize-decimal-no-digits p '(#\.) #f))])))) + (cons 'datum + (dot p '(#\.) 10 #f #f))])))) (define tokenize-char* (lambda (i str p d) (cond @@ -566,17 +567,17 @@ [else (die/p p 'tokenize (format "invalid sequence #v~a" c))]))] [(memq c '(#\e #\E)) - (cons 'datum (tokenize-exactness-mark p (list c #\#) 'e))] + (cons 'datum (parse-string p (list c #\#) 10 #f 'e))] [(memq c '(#\i #\I)) - (cons 'datum (tokenize-exactness-mark p (list c #\#) 'i))] + (cons 'datum (parse-string p (list c #\#) 10 #f 'i))] [(memq c '(#\b #\B)) - (cons 'datum (tokenize-radix-mark p (list c #\#) 2))] + (cons 'datum (parse-string p (list c #\#) 2 2 #f))] [(memq c '(#\x #\X)) - (cons 'datum (tokenize-radix-mark p (list c #\#) 16))] + (cons 'datum (parse-string p (list c #\#) 16 16 #f))] [(memq c '(#\o #\O)) - (cons 'datum (tokenize-radix-mark p (list c #\#) 8))] + (cons 'datum (parse-string p (list c #\#) 8 8 #f))] [(memq c '(#\d #\D)) - (cons 'datum (tokenize-radix-mark p (list c #\#) 10))] + (cons 'datum (parse-string p (list c #\#) 10 10 #f))] [($char= #\@ c) (when (eq? (port-mode p) 'r6rs-mode) (die/p-1 p 'tokenize "fasl syntax is invalid in #!r6rs mode" @@ -586,233 +587,30 @@ [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) - (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))] - [else (num-error p "invalid sequence" (cons c ls))]))) - (define (tokenize-denom p ls exact? radix num ac) - (let ([c (peek-char p)]) - (cond - [(eof-object? c) - (read-char p) - (if (= ac 0) - (num-error p "zero denominator" ls) - (convert/exact exact? (/ num ac)))] - [(radix-digit c radix) => - (lambda (d) - (read-char p) - (tokenize-denom p (cons c ls) exact? radix num - (+ (* radix ac) d)))] - [(delimiter? c) - (if (= ac 0) - (num-error p "zero denominator" ls) - (convert/exact exact? (/ num ac)))] - [else (num-error p "invalid sequence" (cons c ls))]))) - (let ([c (peek-char p)]) - (cond - [(eof-object? c) (convert/exact exact? ac)] - [(radix-digit c radix) => - (lambda (d) - (read-char p) - (tokenize-integer p (cons c ls) exact? radix - (+ (* ac radix) d)))] - [(char=? c #\.) - (unless (= radix 10) - (num-error p "invalid decimal" (cons c ls))) - (read-char p) - (tokenize-decimal p (cons c ls) exact? ac 0)] - [(char=? c #\/) - (read-char p) - (tokenize-denom-start p (cons #\/ ls) exact? radix ac)] - [(memv c '(#\e #\E)) ; exponent - (read-char p) - (unless (= radix 10) - (num-error p "invalid decimal" (cons c ls))) - (let ([ex (tokenize-exponent-start p (cons c ls))]) - (convert/exact (or exact? 'i) - (* ac (expt radix ex))))] - [(delimiter? c) - (convert/exact exact? ac)] - [else (num-error p "invalid sequence" (cons c ls))]))) - (define (tokenize-exponent-start p ls) - (define (tokenize-exponent-no-digits p ls) - (let ([c (read-char p)]) - (cond - [(eof-object? c) (num-error p "eof object" ls)] - [(radix-digit c 10) => - (lambda (d) - (tokenize-exponent p (cons c ls) d))] - [else (num-error p "invalid sequence" (cons c ls))]))) - (define (tokenize-exponent p ls ac) - (let ([c (peek-char p)]) - (cond - [(eof-object? c) ac] - [(radix-digit c 10) => - (lambda (d) - (read-char p) - (tokenize-exponent p (cons c ls) - (+ (* ac 10) d)))] - [(delimiter? c) ac] - [else (num-error p "invalid sequence" (cons c ls))]))) - (let ([c (read-char p)]) - (cond - [(eof-object? c) (num-error p "eof object" ls)] - [(radix-digit c 10) => - (lambda (d) - (tokenize-exponent p (cons c ls) d))] - [(char=? c #\-) - (- (tokenize-exponent-no-digits p (cons c ls)))] - [(char=? c #\+) - (tokenize-exponent-no-digits p (cons c ls))] - [else (num-error p "invalid sequence" (cons c ls))]))) - (define (tokenize-decimal p ls exact? ac exp) - (let ([c (peek-char p)]) - (cond - [(eof-object? c) - (let ([ac (* ac (expt 10 exp))]) - (convert/exact (or exact? 'i) ac))] - [(radix-digit c 10) => - (lambda (d) - (read-char p) - (tokenize-decimal p (cons c ls) exact? - (+ (* ac 10) d) (- exp 1)))] - [(memv c '(#\e #\E)) - (read-char p) - (let ([ex (tokenize-exponent-start p (cons c ls))]) - (let ([ac (* ac (expt 10 (+ exp ex)))]) - (convert/exact (or exact? 'i) ac)))] - [(delimiter? c) - (let ([ac (* ac (expt 10 exp))]) - (convert/exact (or exact? 'i) ac))] - [else (num-error p "invalid sequence" (cons c ls))]))) - (define (tokenize-decimal-no-digits 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-decimal p (cons c ls) exact? d -1))] - [else (num-error p "invalid sequence" (cons c ls))]))) - (define (convert/exact exact? n) - (if (eq? exact? 'i) - (exact->inexact n) - n)) - (define (radix-digit c radix) - (case radix - [(10) - (cond - [(char<=? #\0 c #\9) - (fx- (char->integer c) (char->integer #\0))] - [else #f])] - [(16) - (cond - [(char<=? #\0 c #\9) - (fx- (char->integer c) (char->integer #\0))] - [(char<=? #\a c #\f) - (fx- (char->integer c) (fx- (char->integer #\a) 10))] - [(char<=? #\A c #\F) - (fx- (char->integer c) (fx- (char->integer #\A) 10))] - [else #f])] - [(8) - (cond - [(char<=? #\0 c #\7) - (fx- (char->integer c) (char->integer #\0))] - [else #f])] - [(2) - (case c - [(#\0) 0] - [(#\1) 1] - [else #f])] - [else (die 'radix-digit "invalid radix" radix)])) + + (define (num-error p str ls) + (die/p-1 p 'read "invalid numeric sequence" + (list->string (reverse ls)))) + + (define-syntax port-config + (syntax-rules (GEN-TEST GEN-ARGS FAIL) + [(_ GEN-ARGS k . rest) (k (p ac) . rest)] + [(_ FAIL (p ac)) + (num-error p "invalid numeric sequence" ac)] + [(_ GEN-TEST var next (p ac) eof-case char-case) + (let ([c (peek-char p)]) + (if (or (eof-object? c) (delimiter? c)) + eof-case + (let ([var c]) + (define-syntax next + (syntax-rules () + [(_ who args (... ...)) + (who p (cons (get-char p) ac) args (... ...))])) + char-case)))])) + + (define-string->number-parser port-config + (parse-string digit+ sign dot)) + (define (read-char* p ls str who ci? delimited?) (let f ([i 0] [ls ls]) (cond @@ -836,37 +634,6 @@ (die/p-1 p 'tokenize (format "invalid ~a: ~s" who (list->string (reverse (cons c ls)))))]))]))) - (define (tokenize-integer/nan/inf-no-digits p ls) - (let ([c (read-char p)]) - (cond - [(eof-object? c) (num-error p "invalid eof" ls)] - [(radix-digit c 10) => - (lambda (d) - (tokenize-integer p (cons c ls) #f 10 d))] - [(char=? c #\.) - (tokenize-decimal-no-digits p (cons c ls) #f)] - [(memv c '(#\i #\I)) - (read-char* p (cons #\i ls) "nf.0" "number sequence" #t #t) - +inf.0] - [(memv c '(#\n #\N)) - (read-char* p (cons #\i ls) "an.0" "number sequence" #t #t) - +nan.0] - [else (num-error p "invalid sequence" (cons c ls))]))) - (define (tokenize-integer-no-digits p ls exact? radix?) - (let ([c (read-char p)]) - (cond - [(eof-object? c) (num-error p "invalid eof" ls)] - [(radix-digit c (or radix? 10)) => - (lambda (d) - (tokenize-integer p (cons c ls) exact? (or radix? 10) d))] - [(char=? c #\.) - (when (and radix? (not (= radix? 10))) - (num-error p "invalid decimal" (cons c ls))) - (tokenize-decimal-no-digits p (cons c ls) exact?)] - [else (num-error p "invalid sequence" (cons c ls))]))) - (define (num-error p str ls) - (die/p-1 p 'read "invalid numeric sequence" - (list->string (reverse ls)))) (define (tokenize-hashnum p n) (let ([c (read-char p)]) (cond @@ -948,10 +715,10 @@ '(macro . unquote-splicing)] [else '(macro . unquote)]))] [($char= #\# c) (tokenize-hash p)] - [(radix-digit c 10) => - (lambda (d) + [(char<=? #\0 c #\9) + (let ([d (fx- (char->integer c) (char->integer #\0))]) (cons 'datum - (tokenize-integer p (list c) #f 10 d)))] + (digit+ p (list c) 10 #f +1 d)))] [(initial? c) (let ([ls (reverse (tokenize-identifier (cons c '()) p))]) (cons 'datum (string->symbol (list->string ls))))] @@ -965,7 +732,7 @@ [(delimiter? c) '(datum . +)] [else (cons 'datum - (tokenize-integer/nan/inf-no-digits p '(#\+)))]))] + (sign p '(#\+) 10 #f +1))]))] [(memq c '(#\-)) (let ([c (peek-char p)]) (cond @@ -978,7 +745,7 @@ (cons 'datum (string->symbol str))))] [else (cons 'datum - (- (tokenize-integer/nan/inf-no-digits p '(#\-))))]))] + (sign p '(#\-) 10 #f -1))]))] [($char= #\. c) (tokenize-dot p)] [($char= #\| c) diff --git a/scheme/ikarus.string-to-number.ss b/scheme/ikarus.string-to-number.ss index dff5c2b..b1334ba 100755 --- a/scheme/ikarus.string-to-number.ss +++ b/scheme/ikarus.string-to-number.ss @@ -1,283 +1,324 @@ (library (ikarus.string-to-number) - (export string->number) + (export string->number define-string->number-parser) (import (except (ikarus) string->number)) - (module (string->number) - (define who 'string->number) - (define (do-sn/ex sn ex ac) - (* sn (if (eq? ex 'i) (inexact ac) ac))) - (define (do-dec-sn/ex sn ex ac) - (* sn (if (eq? ex 'e) ac (inexact ac)))) - (define (digit c r) - (let ([n (fx- (char->integer c) (char->integer #\0))]) - (cond - [(and (fx>=? n 0) (fx< n r)) n] - [(eqv? r 16) - (let ([n (fx- (char->integer c) (char->integer #\a))]) - (cond - [(and (fx>=? n 0) (fx< n 6)) (+ n 10)] - [else - (let ([n (fx- (char->integer c) (char->integer #\A))]) - (cond - [(and (fx>=? n 0) (fx< n 6)) (+ n 10)] - [else #f]))]))] - [else #f]))) - - (module (define-parser) - (define-syntax gen-empty - (syntax-rules (eof) - [(_ C Ca) (C FAIL Ca)] - [(_ C Ca [(eof) then] . rest) then] - [(_ C Ca other . rest) (gen-empty C Ca . rest)])) - (define-syntax gen-char - (syntax-rules (eof =>) - [(_ C Ca c) (C FAIL Ca)] - [(_ C Ca c [(eof) then] . rest) - (gen-char C Ca c . rest)] - [(_ C Ca c [(test . args) => result then] . rest) + (define who 'string->number) + (define (do-sn/ex sn ex ac) + (* sn (if (eq? ex 'i) (inexact ac) ac))) + (define (do-dec-sn/ex sn ex ac) + (* sn (if (eq? ex 'e) ac (inexact ac)))) + (define (digit c r) + (let ([n (fx- (char->integer c) (char->integer #\0))]) + (cond + [(and (fx>=? n 0) (fx< n r)) n] + [(eqv? r 16) + (let ([n (fx- (char->integer c) (char->integer #\a))]) (cond - [(test c . args) => - (lambda (result) then)] - [else (gen-char C Ca c . rest)])] - [(_ C Ca c [ls then] . rest) - (if (memv c 'ls) - then - (gen-char C Ca c . rest))])) - (define-syntax gen-clause - (syntax-rules () - [(_ (Ca ...) C next fail name (arg* ...) (clause* ...)) - (define (name Ca ... arg* ...) - (define-syntax fail - (syntax-rules () - [(_) (C FAIL (Ca ...))])) - (cond - [(C GEN-EOF? (Ca ...)) - (gen-empty C (Ca ...) clause* ...)] - [else - (let ([c (C GEN-REF (Ca ...))]) - (define-syntax next - (syntax-rules () - [(_ who args (... ...)) - (C GEN-NEXT (Ca ...) who args (... ...))])) - (gen-char C (Ca ...) c clause* ...))]))])) - (define-syntax define-parser - (syntax-rules () + [(and (fx>=? n 0) (fx< n 6)) (+ n 10)] + [else + (let ([n (fx- (char->integer c) (char->integer #\A))]) + (cond + [(and (fx>=? n 0) (fx< n 6)) (+ n 10)] + [else #f]))]))] + [else #f]))) + + (module (define-parser) + (define-syntax gen-empty + (syntax-rules (eof) + [(_ C Ca) (C FAIL Ca)] + [(_ C Ca [(eof) then] . rest) then] + [(_ C Ca other . rest) (gen-empty C Ca . rest)])) + (define-syntax gen-char + (syntax-rules (eof =>) + [(_ C Ca c) (C FAIL Ca)] + [(_ C Ca c [(eof) then] . rest) + (gen-char C Ca c . rest)] + [(_ C Ca c [(test . args) => result then] . rest) + (cond + [(test c . args) => + (lambda (result) then)] + [else (gen-char C Ca c . rest)])] + [(_ C Ca c [ls then] . rest) + (if (memv c 'ls) + then + (gen-char C Ca c . rest))])) + (define-syntax gen-clause + (syntax-rules () + [(_ (Ca ...) C next fail name (arg* ...) (clause* ...)) + (define (name Ca ... arg* ...) + (define-syntax fail + (syntax-rules () + [(_) (C FAIL (Ca ...))])) + (C GEN-TEST c next (Ca ...) + (gen-empty C (Ca ...) clause* ...) + (gen-char C (Ca ...) c clause* ...)))])) + (define-syntax define-parser^ + (lambda (x) + (define (lookup ls1 ls2) + (lambda (var) + (let f ([ls1 ls1] [ls2 ls2]) + (cond + [(null? ls1) + (error 'define-parser "cannot find" var)] + [(bound-identifier=? var (car ls1)) + (car ls2)] + [else (f (cdr ls1) (cdr ls2))])))) + (syntax-case x () [(_ (entries ...) config next fail + orig* [name* (arg** ...) clause** ...] ...) - (begin - (module M (entries ...) - (config GEN-ARGS - gen-clause config next fail name* - (arg** ...) - (clause** ...)) - ...) - (import M))]))) + (with-syntax ([(mapped-entries ...) + (map + (lookup + (car (syntax->datum #'orig*)) + #'(name* ...)) + #'(entries ...))]) + #'(begin + (config GEN-ARGS + gen-clause config next fail name* + (arg** ...) + (clause** ...)) + ... + (define entries mapped-entries) + ...))]))) + (define-syntax define-parser + (lambda (x) + (syntax-case x () + [(_ definer next fail [name* (arg** ...) clause** ...] ...) + (with-syntax ([orig* + (datum->syntax #'foo (list #'(name* ...)))]) + #'(define-syntax definer + (syntax-rules () + [(_ config (entries (... ...))) + (define-parser^ (entries (... ...)) config next fail + orig* + [name* (arg** ...) clause** ...] ...)])))])))) - (define-syntax string-config - (syntax-rules (GEN-EOF? GEN-REF GEN-ARGS GEN-NEXT FAIL) - [(_ GEN-EOF? (s n i)) (fx=? i n)] - [(_ GEN-REF (s n i)) (string-ref s i)] - [(_ GEN-ARGS k . rest) (k (s n i) . rest)] - [(_ GEN-NEXT (s n i) who . rest) - (who s n (fx+ i 1) . rest)] - [(_ FAIL (s n i)) #f])) - (define-parser (do-parse) string-config next fail - (ratio+ (r ex sn num ac) - [(eof) - (if (= ac 0) - (fail) - (do-sn/ex sn ex (/ num ac)))] - [(digit r) => d - (next ratio+ r ex sn num (+ (* ac r) d))] - [(#\+) - (if (= ac 0) - (fail) - (let ([real (do-sn/ex sn ex (/ num ac))]) - (next im:sign r real ex +1)))] - [(#\-) - (if (= ac 0) - (fail) - (let ([real (do-sn/ex sn ex (/ num ac))]) - (next im:sign r real ex -1)))] - [(#\i) - (if (= ac 0) - (fail) - (make-rectangular 0 (do-sn/ex sn ex (/ num ac))))]) + (define-parser define-string->number-parser next fail - (im:ratio+ (r real ex sn num ac) - [(digit r) => d - (next im:ratio+ r real ex sn num (+ (* ac r) d))] - [(#\i) - (if (= ac 0) - (fail) - (next im:done - (make-rectangular real (do-sn/ex sn ex (/ num ac)))))]) + (ratio+ (r ex sn num ac) + [(eof) + (if (= ac 0) + (fail) + (do-sn/ex sn ex (/ num ac)))] + [(digit r) => d + (next ratio+ r ex sn num (+ (* ac r) d))] + [(#\+) + (if (= ac 0) + (fail) + (let ([real (do-sn/ex sn ex (/ num ac))]) + (next im:sign r real ex +1)))] + [(#\-) + (if (= ac 0) + (fail) + (let ([real (do-sn/ex sn ex (/ num ac))]) + (next im:sign r real ex -1)))] + [(#\i) + (if (= ac 0) + (fail) + (make-rectangular 0 (do-sn/ex sn ex (/ num ac))))]) - (im:done (n) - [(eof) n]) + (im:ratio+ (r real ex sn num ac) + [(digit r) => d + (next im:ratio+ r real ex sn num (+ (* ac r) d))] + [(#\i) + (if (= ac 0) + (fail) + (next im:done + (make-rectangular real (do-sn/ex sn ex (/ num ac)))))]) - (ratio (r ex sn num) - [(digit r) => d - (next ratio+ r ex sn num d)]) + (im:done (n) + [(eof) n]) - (im:ratio (r real ex sn num) - [(digit r) => d - (next im:ratio+ r real ex sn num d)]) + (ratio (r ex sn num) + [(digit r) => d + (next ratio+ r ex sn num d)]) - (exponent+digit (r ex sn ac exp1 exp2 exp-sign) - [(eof) - (do-dec-sn/ex sn ex (* ac (expt 10 (+ exp1 (* exp2 exp-sign)))))] - [(digit r) => d - (next exponent+digit r ex sn ac exp1 (+ (* exp2 r) d) exp-sign)]) + (im:ratio (r real ex sn num) + [(digit r) => d + (next im:ratio+ r real ex sn num d)]) - (exponent+sign (r ex sn ac exp1 exp-sign) - [(digit r) => d - (next exponent+digit r ex sn ac exp1 d exp-sign)]) + (exponent+digit (r ex sn ac exp1 exp2 exp-sign) + [(eof) + (do-dec-sn/ex sn ex (* ac (expt 10 (+ exp1 (* exp2 exp-sign)))))] + [(digit r) => d + (next exponent+digit r ex sn ac exp1 (+ (* exp2 r) d) exp-sign)]) - (exponent (r ex sn ac exp1) - [(digit r) => d - (next exponent+digit r ex sn ac exp1 d +1)] - [(#\+) (next exponent+sign r ex sn ac exp1 +1)] - [(#\-) (next exponent+sign r ex sn ac exp1 -1)]) + (exponent+sign (r ex sn ac exp1 exp-sign) + [(digit r) => d + (next exponent+digit r ex sn ac exp1 d exp-sign)]) - (digit+dot (r ex sn ac exp) - [(eof) - (do-dec-sn/ex sn ex (* ac (expt 10 exp)))] - [(digit r) => d - (next digit+dot r ex sn (+ (* ac r) d) (- exp 1))] - [(#\+) - (let ([real (do-dec-sn/ex sn ex (* ac (expt 10 exp)))]) - (next im:sign r real ex +1))] - [(#\-) - (let ([real (do-dec-sn/ex sn ex (* ac (expt 10 exp)))]) - (next im:sign r real ex -1))] - [(#\i) - (let ([real (do-dec-sn/ex sn ex (* ac (expt 10 exp)))]) - (next im:done (make-rectangular 0.0 real)))] - [(#\e) - (if (fx=? r 10) - (next exponent r ex sn ac exp) - (fail))]) + (exponent (r ex sn ac exp1) + [(digit r) => d + (next exponent+digit r ex sn ac exp1 d +1)] + [(#\+) (next exponent+sign r ex sn ac exp1 +1)] + [(#\-) (next exponent+sign r ex sn ac exp1 -1)]) - (digit+ (r ex sn ac) - [(eof) (do-sn/ex sn ex ac)] - [(digit r) => d - (next digit+ r ex sn (+ (* ac r) d))] - [(#\/) (next ratio r ex sn ac)] - [(#\.) - (if (fx=? r 10) - (next digit+dot r ex sn ac 0) - (fail))] - [(#\+) - (let ([real (do-sn/ex sn ex ac)]) - (next im:sign r real ex +1))] - [(#\-) - (let ([real (do-sn/ex sn ex ac)]) - (next im:sign r real ex -1))] - [(#\i) - (make-rectangular 0 (do-sn/ex sn ex ac))] - [(#\e) - (if (fx=? r 10) - (next exponent r ex sn ac 0) - (fail))]) + (digit+dot (r ex sn ac exp) + [(eof) + (do-dec-sn/ex sn ex (* ac (expt 10 exp)))] + [(digit r) => d + (next digit+dot r ex sn (+ (* ac r) d) (- exp 1))] + [(#\+) + (let ([real (do-dec-sn/ex sn ex (* ac (expt 10 exp)))]) + (next im:sign r real ex +1))] + [(#\-) + (let ([real (do-dec-sn/ex sn ex (* ac (expt 10 exp)))]) + (next im:sign r real ex -1))] + [(#\i) + (let ([real (do-dec-sn/ex sn ex (* ac (expt 10 exp)))]) + (next im:done (make-rectangular 0.0 real)))] + [(#\e) + (if (fx=? r 10) + (next exponent r ex sn ac exp) + (fail))]) - (im:digit+ (r real ex sn ac) - [(digit r) => d - (next im:digit+ r real ex sn (+ (* ac r) d))] - [(#\/) - (next im:ratio r real ex sn ac)] - [(#\i) - (next im:done (make-rectangular real (do-sn/ex sn ex ac)))]) + (digit+ (r ex sn ac) + [(eof) (do-sn/ex sn ex ac)] + [(digit r) => d + (next digit+ r ex sn (+ (* ac r) d))] + [(#\/) (next ratio r ex sn ac)] + [(#\.) + (if (fx=? r 10) + (next digit+dot r ex sn ac 0) + (fail))] + [(#\+) + (let ([real (do-sn/ex sn ex ac)]) + (next im:sign r real ex +1))] + [(#\-) + (let ([real (do-sn/ex sn ex ac)]) + (next im:sign r real ex -1))] + [(#\i) + (make-rectangular 0 (do-sn/ex sn ex ac))] + [(#\e) + (if (fx=? r 10) + (next exponent r ex sn ac 0) + (fail))]) - (sign-i (r ex sn) - [(eof) - (make-rectangular - (if (eq? ex 'i) 0.0 0) - sn)] - [(#\n) (next sign-in r sn)]) - (sign-in (r sn) - [(#\f) (next sign-inf r sn)]) - (sign-inf (r sn) - [(#\.) (next sign-inf. r sn)]) - (sign-inf. (r sn) - [(#\0) (next sign-inf.0 r sn)]) - (sign-inf.0 (r sn) - [(eof) (* sn +inf.0)] - [(#\i) - (next im:done (make-rectangular 0.0 (* sn +inf.0)))]) + (im:digit+ (r real ex sn ac) + [(digit r) => d + (next im:digit+ r real ex sn (+ (* ac r) d))] + [(#\/) + (next im:ratio r real ex sn ac)] + [(#\i) + (next im:done (make-rectangular real (do-sn/ex sn ex ac)))]) - (im:sign-i (real ex sn) - [(eof) (make-rectangular real (do-sn/ex sn ex 1))] - [(#\n) (next im:sign-in (make-rectangular real (* sn +inf.0)))]) - (im:sign-in (n) - [(#\f) (next im:sign-inf n)]) - (im:sign-inf (n) - [(#\.) (next im:sign-inf. n)]) - (im:sign-inf. (n) - [(#\0) (next im:sign-inf.0 n)]) - (im:sign-inf.0 (n) - [(#\i) (next im:done n)]) + (sign-i (r ex sn) + [(eof) + (make-rectangular + (if (eq? ex 'i) 0.0 0) + sn)] + [(#\n) (next sign-in r sn)]) + (sign-in (r sn) + [(#\f) (next sign-inf r sn)]) + (sign-inf (r sn) + [(#\.) (next sign-inf. r sn)]) + (sign-inf. (r sn) + [(#\0) (next sign-inf.0 r sn)]) + (sign-inf.0 (r sn) + [(eof) (* sn +inf.0)] + [(#\i) + (next im:done (make-rectangular 0.0 (* sn +inf.0)))]) - (dot (r ex sn) - [(digit r) => d - (next digit+dot r ex sn d -1)]) + (im:sign-i (real ex sn) + [(eof) (make-rectangular real (do-sn/ex sn ex 1))] + [(#\n) (next im:sign-in (make-rectangular real (* sn +inf.0)))]) + (im:sign-in (n) + [(#\f) (next im:sign-inf n)]) + (im:sign-inf (n) + [(#\.) (next im:sign-inf. n)]) + (im:sign-inf. (n) + [(#\0) (next im:sign-inf.0 n)]) + (im:sign-inf.0 (n) + [(#\i) (next im:done n)]) - (im:sign (r real ex sn) - [(digit r) => d - (next im:digit+ r real ex sn d)] - [(#\i) - (next im:sign-i real ex sn)]) - - (sign (r ex sn) - [(digit r) => d - (next digit+ r ex sn d)] - [(#\i) - (next sign-i r ex sn)] - [(#\.) - (if (fx=? r 10) - (next dot r ex sn) - (fail))]) + (dot (r ex sn) + [(digit r) => d + (next digit+dot r ex sn d -1)]) - (do-parse-h (dr r ex) - [(#\x #\X) - (if r (fail) (next do-parse 16 16 ex))] - [(#\o #\O) - (if r (fail) (next do-parse 8 8 ex))] - [(#\b #\B) - (if r (fail) (next do-parse 2 2 ex))] - [(#\d #\D) - (if r (fail) (next do-parse 10 10 ex))] - [(#\e #\E) - (if ex (fail) (next do-parse dr r 'e))] - [(#\i #\I) - (if ex (fail) (next do-parse dr r 'i))]) + (im:sign (r real ex sn) + [(digit r) => d + (next im:digit+ r real ex sn d)] + [(#\i) + (next im:sign-i real ex sn)]) + + (sign (r ex sn) + [(digit r) => d + (next digit+ r ex sn d)] + [(#\i) + (next sign-i r ex sn)] + [(#\.) + (if (fx=? r 10) + (next dot r ex sn) + (fail))] + [(#\n) + (next sign-n)]) + (sign-n () [(#\a) (next sign-na)]) + (sign-na () [(#\n) (next sign-nan)]) + (sign-nan () [(#\.) (next sign-nan.)]) + (sign-nan. () [(#\0) (next sign-nan.0)]) + (sign-nan.0 () + [(eof) +nan.0] + [(#\i) (next sign-nan.0i)]) + (sign-nan.0i () + [(eof) (make-rectangular 0.0 +nan.0)]) - (do-parse (dr r ex) - [(#\#) (next do-parse-h dr r ex)] - [(#\+) (next sign dr ex +1)] - [(#\-) (next sign dr ex -1)] - [(#\.) - (if (fx=? dr 10) - (next dot dr ex +1) - (fail))] - [(digit dr) => d - (next digit+ dr ex +1 d)]) - ) + (parse-string-h (dr r ex) + [(#\x #\X) + (if r (fail) (next parse-string 16 16 ex))] + [(#\o #\O) + (if r (fail) (next parse-string 8 8 ex))] + [(#\b #\B) + (if r (fail) (next parse-string 2 2 ex))] + [(#\d #\D) + (if r (fail) (next parse-string 10 10 ex))] + [(#\e #\E) + (if ex (fail) (next parse-string dr r 'e))] + [(#\i #\I) + (if ex (fail) (next parse-string dr r 'i))]) - (define string->number - (case-lambda - [(s) - (unless (string? s) (die who "not a string" s)) - (do-parse s (string-length s) 0 10 #f #f)] - [(s r) - (unless (string? s) (die who "not a string" s)) - (unless (memv r '(10 16 2 8)) (die who "invalid radix" r)) - (do-parse s (string-length s) 0 r #f #f)])) - - )) + (parse-string (dr r ex) + [(#\#) (next parse-string-h dr r ex)] + [(#\+) (next sign dr ex +1)] + [(#\-) (next sign dr ex -1)] + [(#\.) + (if (fx=? dr 10) + (next dot dr ex +1) + (fail))] + [(digit dr) => d + (next digit+ dr ex +1 d)]) + ) + + (define-syntax string-config + (syntax-rules (GEN-TEST GEN-ARGS FAIL) + [(_ GEN-ARGS k . rest) (k (s n i) . rest)] + [(_ FAIL (s n i)) #f] + [(_ GEN-TEST var next (s n i) sk fk) + (if (fx=? i n) + sk + (let ([var (string-ref s i)]) + (define-syntax next + (syntax-rules () + [(_ who args (... ...)) + (who s n (fx+ i 1) args (... ...))])) + fk))])) + + (define-string->number-parser string-config (parse-string)) + + (define string->number + (case-lambda + [(s) + (unless (string? s) (die who "not a string" s)) + (parse-string s (string-length s) 0 10 #f #f)] + [(s r) + (unless (string? s) (die who "not a string" s)) + (unless (memv r '(10 16 2 8)) (die who "invalid radix" r)) + (parse-string s (string-length s) 0 r #f #f)])) + +) diff --git a/scheme/last-revision b/scheme/last-revision index 9d877e1..5d030fe 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1494 +1495 diff --git a/scheme/makefile.ss b/scheme/makefile.ss index 99765de..8979255 100755 --- a/scheme/makefile.ss +++ b/scheme/makefile.ss @@ -82,9 +82,7 @@ "ikarus.intel-assembler.ss" "ikarus.trace.ss" "ikarus.fasl.write.ss" -;;; HERE "ikarus.fasl.ss" - "ikarus.compiler.ss" "psyntax.compat.ss" "psyntax.library-manager.ss" @@ -92,7 +90,6 @@ "psyntax.config.ss" "psyntax.builders.ss" "psyntax.expander.ss" - "ikarus.load.ss" "ikarus.pretty-print.ss" "ikarus.cafe.ss"