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

fixes quasisyntax bugs, making them more conforming to the r6rs test 

suite.
This commit is contained in:
Abdulaziz Ghuloum 2008-07-26 14:11:22 -07:00
parent b3d8a8f9fd
commit 4ee88498a9
4 changed files with 36 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
scheme/ikarus.exceptions.ss
View File

@ -68,9 +68,7 @@
(make-error) (make-error)
(if who (make-who-condition who) (condition)) (if who (make-who-condition who) (condition))
(make-message-condition msg) (make-message-condition msg)
(if (null? irritants) (make-irritants-condition irritants))))
(condition)
(make-irritants-condition irritants)))))
(define (assertion-violation who msg . irritants) (define (assertion-violation who msg . irritants)
(unless (string? msg) (unless (string? msg)
@ -80,9 +78,7 @@
(make-assertion-violation) (make-assertion-violation)
(if who (make-who-condition who) (condition)) (if who (make-who-condition who) (condition))
(make-message-condition msg) (make-message-condition msg)
(if (null? irritants) (make-irritants-condition irritants))))
(condition)
(make-irritants-condition irritants)))))
(define die assertion-violation) (define die assertion-violation)

9
scheme/ikarus.numerics.ss
View File

@ -340,9 +340,7 @@
(define (fllog x) (define (fllog x)
(if (flonum? x) (if (flonum? x)
(if ($fl>= x 0.0) (foreign-call "ikrt_fl_log" x)
(foreign-call "ikrt_fl_log" x)
(die 'fllog "argument should not be negative" x))
(die 'fllog "not a flonum" x))) (die 'fllog "not a flonum" x)))
(define (flexpt x y) (define (flexpt x y)
@ -2379,7 +2377,10 @@
[(ratnum? n) [(ratnum? n)
($make-ratnum (expt ($ratnum-n n) m) (expt ($ratnum-d n) m))] ($make-ratnum (expt ($ratnum-n n) m) (expt ($ratnum-d n) m))]
[else (fxexpt n m)]) [else (fxexpt n m)])
(/ 1 (expt n (- m))))] (let ([v (expt n (- m))])
(if (eq? v 0)
0
(/ 1 v))))]
[(bignum? m) [(bignum? m)
(cond (cond
[(eq? n 0) 0] [(eq? n 0) 0]

2
scheme/last-revision
View File

@ -1 +1 @@
1555 1556

47
scheme/psyntax.expander.ss
View File

@ -1718,19 +1718,37 @@
(values lhs* rhs* (list 'unsyntax p))))) (values lhs* rhs* (list 'unsyntax p)))))
(unsyntax (= lev 0) (unsyntax (= lev 0)
(stx-error p "incorrect use of unsyntax")) (stx-error p "incorrect use of unsyntax"))
(((unsyntax-splicing p) . q) (((unsyntax p* ...) . q)
(let-values (((lhs* rhs* q) (quasi q lev))) (let-values (((lhs* rhs* q) (quasi q lev)))
(if (= lev 0) (if (= lev 0)
(let ((g (gensym))) (let ((g* (map (lambda (x) (gensym)) p*)))
(values (values
(cons `(,g ...) lhs*) (append g* lhs*)
(cons p rhs*) (append p* rhs*)
`(,g ... . ,q))) (append g* q)))
(let-values (((lhs2* rhs2* p) (quasi p (- lev 1)))) (let-values (((lhs2* rhs2* p*) (quasi p* (- lev 1))))
(values (values
(append lhs2* lhs*) (append lhs2* lhs*)
(append rhs2* rhs*) (append rhs2* rhs*)
`((unsyntax-splicing ,p) . ,q)))))) `((unsyntax . ,p*) . ,q))))))
(((unsyntax-splicing p* ...) . q)
(let-values (((lhs* rhs* q) (quasi q lev)))
(if (= lev 0)
(let ((g* (map (lambda (x) (gensym)) p*)))
(values
(append
(map (lambda (g) `(,g ...)) g*)
lhs*)
(append p* rhs*)
(append
(apply append
(map (lambda (g) `(,g ...)) g*))
q)))
(let-values (((lhs2* rhs2* p*) (quasi p* (- lev 1))))
(values
(append lhs2* lhs*)
(append rhs2* rhs*)
`((unsyntax-splicing . ,p*) . ,q))))))
(unsyntax-splicing (= lev 0) (unsyntax-splicing (= lev 0)
(stx-error p "incorrect use of unsyntax-splicing")) (stx-error p "incorrect use of unsyntax-splicing"))
((quasisyntax p) ((quasisyntax p)
@ -1742,18 +1760,9 @@
(values (append lhs2* lhs*) (values (append lhs2* lhs*)
(append rhs2* rhs*) (append rhs2* rhs*)
(cons p q)))) (cons p q))))
(#(x ...) (not (stx? p)) (#(x* ...)
(let-values (((lhs* rhs* x*) (let-values (((lhs* rhs* x*) (quasi x* lev)))
(let f ((x x)) (values lhs* rhs* (list->vector x*))))
(cond
((null? x) (values '() '() '()))
(else
(let-values (((lhs* rhs* a) (quasi (car x) lev)))
(let-values (((lhs2* rhs2* d) (f (cdr x))))
(values (append lhs* lhs2*)
(append rhs* rhs2*)
(cons a d)))))))))
(values lhs* rhs* (list->vector x*))))
(_ (values '() '() p))))) (_ (values '() '() p)))))
(lambda (x) (lambda (x)
(syntax-match x () (syntax-match x ()