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)
(if who (make-who-condition who) (condition))
(make-message-condition msg)
(if (null? irritants)
(condition)
(make-irritants-condition irritants)))))
(make-irritants-condition irritants))))
(define (assertion-violation who msg . irritants)
(unless (string? msg)
@ -80,9 +78,7 @@
(make-assertion-violation)
(if who (make-who-condition who) (condition))
(make-message-condition msg)
(if (null? irritants)
(condition)
(make-irritants-condition irritants)))))
(make-irritants-condition irritants))))
(define die assertion-violation)

9
scheme/ikarus.numerics.ss
View File

@ -340,9 +340,7 @@
(define (fllog x)
(if (flonum? x)
(if ($fl>= x 0.0)
(foreign-call "ikrt_fl_log" x)
(die 'fllog "argument should not be negative" x))
(foreign-call "ikrt_fl_log" x)
(die 'fllog "not a flonum" x)))
(define (flexpt x y)
@ -2379,7 +2377,10 @@
[(ratnum? n)
($make-ratnum (expt ($ratnum-n n) m) (expt ($ratnum-d n) m))]
[else (fxexpt n m)])
(/ 1 (expt n (- m))))]
(let ([v (expt n (- m))])
(if (eq? v 0)
0
(/ 1 v))))]
[(bignum? m)
(cond
[(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)))))
(unsyntax (= lev 0)
(stx-error p "incorrect use of unsyntax"))
(((unsyntax-splicing p) . q)
(((unsyntax p* ...) . q)
(let-values (((lhs* rhs* q) (quasi q lev)))
(if (= lev 0)
(let ((g (gensym)))
(let ((g* (map (lambda (x) (gensym)) p*)))
(values
(cons `(,g ...) lhs*)
(cons p rhs*)
`(,g ... . ,q)))
(let-values (((lhs2* rhs2* p) (quasi p (- lev 1))))
(append g* lhs*)
(append p* rhs*)
(append g* q)))
(let-values (((lhs2* rhs2* p*) (quasi p* (- lev 1))))
(values
(append lhs2* lhs*)
(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)
(stx-error p "incorrect use of unsyntax-splicing"))
((quasisyntax p)
@ -1742,18 +1760,9 @@
(values (append lhs2* lhs*)
(append rhs2* rhs*)
(cons p q))))
(#(x ...) (not (stx? p))
(let-values (((lhs* rhs* x*)
(let f ((x 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*))))
(#(x* ...)
(let-values (((lhs* rhs* x*) (quasi x* lev)))
(values lhs* rhs* (list->vector x*))))
(_ (values '() '() p)))))
(lambda (x)
(syntax-match x ()