diff --git a/scheme/ikarus.exceptions.ss b/scheme/ikarus.exceptions.ss index 2bdf7cc..971110d 100644 --- a/scheme/ikarus.exceptions.ss +++ b/scheme/ikarus.exceptions.ss @@ -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) diff --git a/scheme/ikarus.numerics.ss b/scheme/ikarus.numerics.ss index c1dcb40..2492c0e 100644 --- a/scheme/ikarus.numerics.ss +++ b/scheme/ikarus.numerics.ss @@ -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] diff --git a/scheme/last-revision b/scheme/last-revision index 9d7a590..78c9168 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1555 +1556 diff --git a/scheme/psyntax.expander.ss b/scheme/psyntax.expander.ss index 6131409..7e2ef4c 100644 --- a/scheme/psyntax.expander.ss +++ b/scheme/psyntax.expander.ss @@ -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 ()