;;; Ikarus Scheme -- A compiler for R6RS Scheme. ;;; Copyright (C) 2008,2009 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 . (library (ikarus.string-to-number) (export string->number define-string->number-parser) (import (except (ikarus) 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 EOF-ERROR Ca)] [(_ C Ca [(eof) then] . rest) then] [(_ C Ca other . rest) (gen-empty C Ca . rest)])) (define-syntax gen-delimiter (syntax-rules (eof) [(_ C Ca c) (C GEN-DELIM-TEST c (C FAIL Ca) (C FAIL Ca c))] [(_ C Ca c [(eof) then] . rest) (C GEN-DELIM-TEST c then (C FAIL Ca c))] [(_ C Ca c other . rest) (gen-delimiter C Ca c . rest)])) (define-syntax gen-char (syntax-rules (eof =>) [(_ C Ca c dc) dc] [(_ C Ca c dc [(eof) then] . rest) (gen-char C Ca c dc . rest)] [(_ C Ca c dc [(test . args) => result then] . rest) (cond [(test c . args) => (lambda (result) then)] [else (gen-char C Ca c dc . rest)])] [(_ C Ca c dc [ls then] . rest) (if (memv c 'ls) then (gen-char C Ca c dc . rest))])) (define-syntax gen-clause (syntax-rules () [(_ (Ca ...) C next fail name (arg* ...) (clause* ...)) (define (name Ca ... arg* ...) (C GEN-TEST c next fail (Ca ...) (gen-empty C (Ca ...) clause* ...) (gen-char C (Ca ...) c (gen-delimiter C (Ca ...) c clause* ...) 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** ...] ...) (with-syntax ([(mapped-entries ...) (map (lookup (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 #'(name* ...))]) #'(define-syntax definer (syntax-rules () [(_ config (entries (... ...))) (define-parser^ (entries (... ...)) config next fail orig* [name* (arg** ...) clause** ...] ...)])))])))) (define-parser define-string->number-parser 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)))] [(#\@) (if (= ac 0) (fail) (let ([mag (do-sn/ex sn ex (/ num ac))]) (next polar r mag ex)))] [(#\i) (if (= ac 0) (fail) (next im:done (make-rectangular 0 (do-sn/ex sn ex (/ num ac)))))]) (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)))))]) (im:done (n) [(eof) n]) (ratio (r ex sn num) [(digit r) => d (next ratio+ r ex sn num d)]) (im:ratio (r real ex sn num) [(digit r) => d (next im:ratio+ r real 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)))))] [(#\+) (let ([real (do-dec-sn/ex sn ex (* ac (expt 10 (+ exp1 (* exp2 exp-sign)))))]) (next im:sign r real ex +1))] [(#\-) (let ([real (do-dec-sn/ex sn ex (* ac (expt 10 (+ exp1 (* exp2 exp-sign)))))]) (next im:sign r real ex -1))] [(#\@) (let ([mag (do-dec-sn/ex sn ex (* ac (expt 10 (+ exp1 (* exp2 exp-sign)))))]) (next polar r mag ex))] [(digit r) => d (next exponent+digit r ex sn ac exp1 (+ (* exp2 r) d) exp-sign)] [(#\i) (let ([n (do-dec-sn/ex sn ex (* ac (expt 10 (+ exp1 (* exp2 exp-sign)))))]) (next im:done (make-rectangular 0 n)))]) (polar (r mag ex) [(digit r) => d (next polar+digit r mag ex d 1)] [(#\.) (if (= r 10) (next polar+dot r mag ex +1) (fail))]) (polar+dot (r mag ex sn) [(digit r) => d (next polar+digit+dot r mag ex d sn -1)]) (polar+digit (r mag ex ang sn) [(eof) (make-polar mag (* ang sn))] [(digit r) => d (next polar+digit r mag ex (+ (* r ang) d) sn)] [(#\.) (if (= r 10) (next polar+digit+dot r mag ex ang sn 0) (fail))]) (polar+digit+dot (r mag ex ang sn exp) [(eof) (let ([ang (* ang sn (expt 10 exp))]) (make-polar mag ang))] [(digit r) => d (next polar+digit+dot r mag ex (+ (* r ang) d) sn (- exp 1))]) (im:exponent+digit (r real ex sn ac exp1 exp2 exp-sign) [(digit r) => d (next im:exponent+digit r real ex sn ac exp1 (+ (* exp2 r) d) exp-sign)] [(#\i) (let ([imag (do-dec-sn/ex sn ex (* ac (expt 10 (+ exp1 (* exp2 exp-sign)))))]) (next im:done (make-rectangular real imag)))]) (exponent+sign (r ex sn ac exp1 exp-sign) [(digit r) => d (next exponent+digit r ex sn ac exp1 d exp-sign)]) (im:exponent+sign (r real ex sn ac exp1 exp-sign) [(digit r) => d (next im:exponent+digit r real ex sn ac exp1 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)]) (im:exponent (r real ex sn ac exp1) [(digit r) => d (next im:exponent+digit r real ex sn ac exp1 d +1)] [(#\+) (next im:exponent+sign r real ex sn ac exp1 +1)] [(#\-) (next im:exponent+sign r real ex sn ac exp1 -1)]) (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))] [(#\@) (let ([mag (do-dec-sn/ex sn ex (* ac (expt 10 exp)))]) (next polar r mag ex))] [(#\i) (let ([real (do-dec-sn/ex sn ex (* ac (expt 10 exp)))]) (next im:done (make-rectangular 0.0 real)))] [(#\e #\E #\s #\S #\f #\F #\d #\D #\l #\L) (if (fx=? r 10) (next exponent r ex sn ac exp) (fail))]) (im:digit+dot (r real ex sn ac exp) [(eof) (do-dec-sn/ex sn ex (* ac (expt 10 exp)))] [(digit r) => d (next im:digit+dot r real ex sn (+ (* ac r) d) (- exp 1))] [(#\i) (let ([imag (do-dec-sn/ex sn ex (* ac (expt 10 exp)))]) (next im:done (make-rectangular real imag)))] [(#\e #\E #\s #\S #\f #\F #\d #\D #\l #\L) (next im:exponent r real ex sn ac exp)]) (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))] [(#\@) (let ([mag (do-sn/ex sn ex ac)]) (next polar r mag ex))] [(#\i) (next im:done (make-rectangular 0 (do-sn/ex sn ex ac)))] [(#\e #\E #\s #\S #\f #\F #\d #\D #\l #\L) (if (fx=? r 10) (next exponent r ex sn ac 0) (fail))]) (im:digit+ (r real ex sn ac) [(digit r) => d (next im:digit+ r real ex sn (+ (* ac r) d))] [(#\.) (if (fx=? r 10) (next im:digit+dot r real ex sn ac 0) (fail))] [(#\/) (next im:ratio r real ex sn ac)] [(#\i) (next im:done (make-rectangular real (do-sn/ex sn ex ac)))] [(#\e #\E #\s #\S #\f #\F #\d #\D #\l #\L) (if (fx=? r 10) (next im:exponent r real 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 ex sn)]) (sign-in (r ex sn) [(#\f) (next sign-inf r ex sn)]) (sign-inf (r ex sn) [(#\.) (next sign-inf. r ex sn)]) (sign-inf. (r ex sn) [(#\0) (next sign-inf.0 r ex sn)]) (sign-inf.0 (r ex sn) [(eof) (* sn +inf.0)] [(#\+) (next im:sign r (* sn +inf.0) ex +1)] [(#\-) (next im:sign r (* sn +inf.0) ex -1)] [(#\@) (next polar r (* sn +inf.0) ex)] [(#\i) (next im:done (make-rectangular 0.0 (* sn +inf.0)))]) (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-n (n) [(#\a) (next im:sign-na n)]) (im:sign-na (n) [(#\n) (next im:sign-nan n)]) (im:sign-nan (n) [(#\.) (next im:sign-nan. n)]) (im:sign-nan. (n) [(#\0) (next im:sign-nan.0 n)]) (im:sign-nan.0 (n) [(#\i) (next im:done n)]) (dot (r ex sn) [(digit r) => d (next digit+dot r ex sn d -1)]) (im:dot (r real ex sn) [(digit r) => d (next im:digit+dot r real ex sn d -1)]) (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)] [(#\n) (next im:sign-n (make-rectangular real +nan.0))] [(#\.) (if (fx=? r 10) (next im:dot r real ex sn) (fail))]) (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 r ex)]) (sign-n (r ex) [(#\a) (next sign-na r ex)]) (sign-na (r ex) [(#\n) (next sign-nan r ex)]) (sign-nan (r ex) [(#\.) (next sign-nan. r ex)]) (sign-nan. (r ex) [(#\0) (next sign-nan.0 r ex)]) (sign-nan.0 (r ex) [(eof) +nan.0] [(#\+) (next im:sign r +nan.0 ex +1)] [(#\-) (next im:sign r +nan.0 ex -1)] [(#\@) (next polar r +nan.0 ex)] [(#\i) (next sign-nan.0i r ex)]) (sign-nan.0i (r ex) [(eof) (make-rectangular 0.0 +nan.0)]) (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))]) (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 (EOF-ERROR GEN-TEST GEN-ARGS FAIL GEN-DELIM-TEST) [(_ GEN-ARGS k . rest) (k (s n i) . rest)] [(_ FAIL (s n i) c) #f] [(_ FAIL (s n i)) #f] [(_ EOF-ERROR (s n i)) #f] [(_ GEN-DELIM-TEST c sk fk) #f] [(_ GEN-TEST var next fail (s n i) sk fk) (let () (define-syntax fail (syntax-rules () [(_) #f])) (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)])) ) ;;; ::= ;;; | ;;; | ;;; | ;;; ::= ;;; ::= ;;; | "@" ;;; | "+" "i" ;;; | "-" "i" ;;; | "+" "i" ;;; | "-" "i" ;;; | "+" "i" ;;; | "-" "i" ;;; | "+" "i" ;;; | "-" "i" ;;; | "+" "i" ;;; | "-" "i" ;;; | "+" "i" ;;; | "-" "i" ;;; ::= ;;; | "+" ;;; | "-" ;;; ::= "nan.0" ;;; | "inf.0" ;;; | ;;; | "/" ;;; | ;;; ::= ;;; | "." + ;;; | + "." * ;;; | + "." ;;; ::= + ;;; | ;;; | ;;; ::= epsilon ;;; | + ;;; ::= "e" ;;; | "E" ;;; | "s" ;;; | "S" ;;; | "f" ;;; | "F" ;;; | "d" ;;; | "D" ;;; | "l" ;;; | "L" ;;; ::= epsilon ;;; | "|" ;;; ::= epsilon ;;; | "+" ;;; | "-" ;;; ::= epsilon ;;; | "#i" ;;; | "#I" ;;; | "#e" ;;; | "#E" ;;; ::= "#b" ;;; | "#B" ;;; ::= "#o" ;;; | "#O" ;;; ::= epsilon ;;; | "#d" ;;; | "#D" ;;; ::= "#x" ;;; | "#X" ;;; ::= "0" ;;; | "1" ;;; ::= "0" ;;; | "1" ;;; | "2" ;;; | "3" ;;; | "4" ;;; | "5" ;;; | "6" ;;; | "7" ;;; ::= ;;; ::= ;;; ::= "0" ;;; | "1" ;;; | "2" ;;; | "3" ;;; | "4" ;;; | "5" ;;; | "6" ;;; | "7" ;;; | "8" ;;; | "9" ;;; ::= ;;; | "A" ;;; | "B" ;;; | "C" ;;; | "D" ;;; | "E" ;;; | "F" ;;; | "a" ;;; | "b" ;;; | "c" ;;; | "d" ;;; | "e" ;;; | "f"