the reader now understands some complex numbers.
This commit is contained in:
Abdulaziz Ghuloum
parent
a492d318e1
commit
be37f629c5
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)]))
|
||||
|
||||
)
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
1494
|
||||
1495
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
Loading…
Reference in New Issue