conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

the reader now understands some complex numbers.

This commit is contained in:
Abdulaziz Ghuloum 2008-06-02 00:01:59 -07:00
parent a492d318e1
commit be37f629c5
4 changed files with 333 additions and 528 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

305
scheme/ikarus.reader.ss
View File

@ -20,6 +20,7 @@
annotation-expression annotation-source annotation-expression annotation-source
annotation-stripped) annotation-stripped)
(import (import
(only (ikarus.string-to-number) define-string->number-parser)
(ikarus system $chars) (ikarus system $chars)
(ikarus system $fx) (ikarus system $fx)
(ikarus system $pairs) (ikarus system $pairs)
@ -256,7 +257,7 @@
(string-append ".." (string c)))]))] (string-append ".." (string c)))]))]
[else [else
(cons 'datum (cons 'datum
(tokenize-decimal-no-digits p '(#\.) #f))])))) (dot p '(#\.) 10 #f #f))]))))
(define tokenize-char* (define tokenize-char*
(lambda (i str p d) (lambda (i str p d)
(cond (cond
@ -566,17 +567,17 @@
[else (die/p p 'tokenize [else (die/p p 'tokenize
(format "invalid sequence #v~a" c))]))] (format "invalid sequence #v~a" c))]))]
[(memq c '(#\e #\E)) [(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)) [(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)) [(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)) [(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)) [(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)) [(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) [($char= #\@ c)
(when (eq? (port-mode p) 'r6rs-mode) (when (eq? (port-mode p) 'r6rs-mode)
(die/p-1 p 'tokenize "fasl syntax is invalid in #!r6rs mode" (die/p-1 p 'tokenize "fasl syntax is invalid in #!r6rs mode"
@ -586,233 +587,30 @@
[else [else
(die/p-1 p 'tokenize (die/p-1 p 'tokenize
(format "invalid syntax #~a" c))]))) (format "invalid syntax #~a" c))])))
(define (tokenize-exactness-mark p ls exact?)
(let ([c (read-char p)]) (define (num-error p str ls)
(cond (die/p-1 p 'read "invalid numeric sequence"
[(eof-object? c) (num-error p "eof object" ls)] (list->string (reverse ls))))
[(radix-digit c 10) =>
(lambda (d) (define-syntax port-config
(tokenize-integer p (cons c ls) exact? 10 d))] (syntax-rules (GEN-TEST GEN-ARGS FAIL)
[(char=? c #\.) [(_ GEN-ARGS k . rest) (k (p ac) . rest)]
(tokenize-decimal-no-digits p (cons c ls) exact?)] [(_ FAIL (p ac))
[(char=? c #\-) (num-error p "invalid numeric sequence" ac)]
(- (tokenize-integer-no-digits p (cons c ls) exact? 10))] [(_ GEN-TEST var next (p ac) eof-case char-case)
[(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)]) (let ([c (peek-char p)])
(cond (if (or (eof-object? c) (delimiter? c))
[(eof-object? c) eof-case
(read-char p) (let ([var c])
(if (= ac 0) (define-syntax next
(num-error p "zero denominator" ls) (syntax-rules ()
(convert/exact exact? (/ num ac)))] [(_ who args (... ...))
[(radix-digit c radix) => (who p (cons (get-char p) ac) args (... ...))]))
(lambda (d) char-case)))]))
(read-char p)
(tokenize-denom p (cons c ls) exact? radix num (define-string->number-parser port-config
(+ (* radix ac) d)))] (parse-string digit+ sign dot))
[(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 (read-char* p ls str who ci? delimited?) (define (read-char* p ls str who ci? delimited?)
(let f ([i 0] [ls ls]) (let f ([i 0] [ls ls])
(cond (cond
@ -836,37 +634,6 @@
(die/p-1 p 'tokenize (die/p-1 p 'tokenize
(format "invalid ~a: ~s" who (format "invalid ~a: ~s" who
(list->string (reverse (cons c ls)))))]))]))) (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) (define (tokenize-hashnum p n)
(let ([c (read-char p)]) (let ([c (read-char p)])
(cond (cond
@ -948,10 +715,10 @@
'(macro . unquote-splicing)] '(macro . unquote-splicing)]
[else '(macro . unquote)]))] [else '(macro . unquote)]))]
[($char= #\# c) (tokenize-hash p)] [($char= #\# c) (tokenize-hash p)]
[(radix-digit c 10) => [(char<=? #\0 c #\9)
(lambda (d) (let ([d (fx- (char->integer c) (char->integer #\0))])
(cons 'datum (cons 'datum
(tokenize-integer p (list c) #f 10 d)))] (digit+ p (list c) 10 #f +1 d)))]
[(initial? c) [(initial? c)
(let ([ls (reverse (tokenize-identifier (cons c '()) p))]) (let ([ls (reverse (tokenize-identifier (cons c '()) p))])
(cons 'datum (string->symbol (list->string ls))))] (cons 'datum (string->symbol (list->string ls))))]
@ -965,7 +732,7 @@
[(delimiter? c) '(datum . +)] [(delimiter? c) '(datum . +)]
[else [else
(cons 'datum (cons 'datum
(tokenize-integer/nan/inf-no-digits p '(#\+)))]))] (sign p '(#\+) 10 #f +1))]))]
[(memq c '(#\-)) [(memq c '(#\-))
(let ([c (peek-char p)]) (let ([c (peek-char p)])
(cond (cond
@ -978,7 +745,7 @@
(cons 'datum (string->symbol str))))] (cons 'datum (string->symbol str))))]
[else [else
(cons 'datum (cons 'datum
(- (tokenize-integer/nan/inf-no-digits p '(#\-))))]))] (sign p '(#\-) 10 #f -1))]))]
[($char= #\. c) [($char= #\. c)
(tokenize-dot p)] (tokenize-dot p)]
[($char= #\| c) [($char= #\| c)

119
scheme/ikarus.string-to-number.ss
View File

@ -1,9 +1,8 @@
(library (ikarus.string-to-number) (library (ikarus.string-to-number)
(export string->number) (export string->number define-string->number-parser)
(import (except (ikarus) string->number)) (import (except (ikarus) string->number))
(module (string->number)
(define who 'string->number) (define who 'string->number)
(define (do-sn/ex sn ex ac) (define (do-sn/ex sn ex ac)
(* sn (if (eq? ex 'i) (inexact ac) ac))) (* sn (if (eq? ex 'i) (inexact ac) ac)))
@ -51,39 +50,54 @@
(define-syntax fail (define-syntax fail
(syntax-rules () (syntax-rules ()
[(_) (C FAIL (Ca ...))])) [(_) (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 (cond
[(C GEN-EOF? (Ca ...)) [(null? ls1)
(gen-empty C (Ca ...) clause* ...)] (error 'define-parser "cannot find" var)]
[else [(bound-identifier=? var (car ls1))
(let ([c (C GEN-REF (Ca ...))]) (car ls2)]
(define-syntax next [else (f (cdr ls1) (cdr ls2))]))))
(syntax-rules () (syntax-case x ()
[(_ who args (... ...))
(C GEN-NEXT (Ca ...) who args (... ...))]))
(gen-char C (Ca ...) c clause* ...))]))]))
(define-syntax define-parser
(syntax-rules ()
[(_ (entries ...) config next fail [(_ (entries ...) config next fail
orig*
[name* (arg** ...) clause** ...] ...) [name* (arg** ...) clause** ...] ...)
(begin (with-syntax ([(mapped-entries ...)
(module M (entries ...) (map
(lookup
(car (syntax->datum #'orig*))
#'(name* ...))
#'(entries ...))])
#'(begin
(config GEN-ARGS (config GEN-ARGS
gen-clause config next fail name* gen-clause config next fail name*
(arg** ...) (arg** ...)
(clause** ...)) (clause** ...))
...) ...
(import M))]))) (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
(define-parser define-string->number-parser next fail
(ratio+ (r ex sn num ac) (ratio+ (r ex sn num ac)
[(eof) [(eof)
@ -239,24 +253,35 @@
[(#\.) [(#\.)
(if (fx=? r 10) (if (fx=? r 10)
(next dot r ex sn) (next dot r ex sn)
(fail))]) (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-h (dr r ex) (parse-string-h (dr r ex)
[(#\x #\X) [(#\x #\X)
(if r (fail) (next do-parse 16 16 ex))] (if r (fail) (next parse-string 16 16 ex))]
[(#\o #\O) [(#\o #\O)
(if r (fail) (next do-parse 8 8 ex))] (if r (fail) (next parse-string 8 8 ex))]
[(#\b #\B) [(#\b #\B)
(if r (fail) (next do-parse 2 2 ex))] (if r (fail) (next parse-string 2 2 ex))]
[(#\d #\D) [(#\d #\D)
(if r (fail) (next do-parse 10 10 ex))] (if r (fail) (next parse-string 10 10 ex))]
[(#\e #\E) [(#\e #\E)
(if ex (fail) (next do-parse dr r 'e))] (if ex (fail) (next parse-string dr r 'e))]
[(#\i #\I) [(#\i #\I)
(if ex (fail) (next do-parse dr r 'i))]) (if ex (fail) (next parse-string dr r 'i))])
(do-parse (dr r ex) (parse-string (dr r ex)
[(#\#) (next do-parse-h dr r ex)] [(#\#) (next parse-string-h dr r ex)]
[(#\+) (next sign dr ex +1)] [(#\+) (next sign dr ex +1)]
[(#\-) (next sign dr ex -1)] [(#\-) (next sign dr ex -1)]
[(#\.) [(#\.)
@ -267,17 +292,33 @@
(next digit+ dr ex +1 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 (define string->number
(case-lambda (case-lambda
[(s) [(s)
(unless (string? s) (die who "not a string" s)) (unless (string? s) (die who "not a string" s))
(do-parse s (string-length s) 0 10 #f #f)] (parse-string s (string-length s) 0 10 #f #f)]
[(s r) [(s r)
(unless (string? s) (die who "not a string" s)) (unless (string? s) (die who "not a string" s))
(unless (memv r '(10 16 2 8)) (die who "invalid radix" r)) (unless (memv r '(10 16 2 8)) (die who "invalid radix" r))
(do-parse s (string-length s) 0 r #f #f)])) (parse-string s (string-length s) 0 r #f #f)]))
)) )

2
scheme/last-revision
View File

@ -1 +1 @@
1494 1495

3
scheme/makefile.ss
View File

@ -82,9 +82,7 @@
"ikarus.intel-assembler.ss" "ikarus.intel-assembler.ss"
"ikarus.trace.ss" "ikarus.trace.ss"
"ikarus.fasl.write.ss" "ikarus.fasl.write.ss"
;;; HERE
"ikarus.fasl.ss" "ikarus.fasl.ss"
"ikarus.compiler.ss" "ikarus.compiler.ss"
"psyntax.compat.ss" "psyntax.compat.ss"
"psyntax.library-manager.ss" "psyntax.library-manager.ss"
@ -92,7 +90,6 @@
"psyntax.config.ss" "psyntax.config.ss"
"psyntax.builders.ss" "psyntax.builders.ss"
"psyntax.expander.ss" "psyntax.expander.ss"
"ikarus.load.ss" "ikarus.load.ss"
"ikarus.pretty-print.ss" "ikarus.pretty-print.ss"
"ikarus.cafe.ss" "ikarus.cafe.ss"