From 4ee88498a9c546f5ac7a4ead4539ae71c2e2cf59 Mon Sep 17 00:00:00 2001
From: Abdulaziz Ghuloum <aghuloum@cs.indiana.edu>
Date: Sat, 26 Jul 2008 14:11:22 -0700
Subject: [PATCH] fixes quasisyntax bugs, making them more conforming to the
 r6rs test suite.

---
 scheme/ikarus.exceptions.ss |  8 ++-----
 scheme/ikarus.numerics.ss   |  9 +++----
 scheme/last-revision        |  2 +-
 scheme/psyntax.expander.ss  | 47 ++++++++++++++++++++++---------------
 4 files changed, 36 insertions(+), 30 deletions(-)

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 ()