From 3f9b567a5babd1332aabb310de3d17139bdff3e8 Mon Sep 17 00:00:00 2001
From: Abdulaziz Ghuloum <aghuloum@cs.indiana.edu>
Date: Sat, 3 May 2008 06:23:35 -0400
Subject: [PATCH] with-syntax now gives more informative error messages:

> (with-syntax ([(x y) #'(a 1)] [(q) #'(a b c)]) 12)
Unhandled exception
 Condition components:
   1. &assertion
   2. &who: with-syntax
   3. &message: "pattern does not match value"
   4. &irritants: ((q) #<syntax (a b c)>)

instead of the previous behavior:

> (with-syntax ([(x y) #'(a 1)] [(q) #'(a b c)]) 12)
Unhandled exception
 Condition components:
    1. &message: "invalid syntax"
    2. &syntax:
        form: ((a 1) (a b c))
        subform: #f
---
 scheme/last-revision       |  2 +-
 scheme/psyntax.expander.ss | 31 +++++++++++++++++++++++++------
 2 files changed, 26 insertions(+), 7 deletions(-)

diff --git a/scheme/last-revision b/scheme/last-revision
index c7edfd5..f488b51 100644
--- a/scheme/last-revision
+++ b/scheme/last-revision
@@ -1 +1 @@
-1465
+1466
diff --git a/scheme/psyntax.expander.ss b/scheme/psyntax.expander.ss
index ef3e4a6..f1ed79c 100644
--- a/scheme/psyntax.expander.ss
+++ b/scheme/psyntax.expander.ss
@@ -29,6 +29,7 @@
           interaction-environment
           ellipsis-map)
   (import
+    (only (ikarus) printf)
     (except (rnrs) 
       environment environment? identifier?
       eval generate-temporaries free-identifier=?
@@ -1121,11 +1122,29 @@
   (define with-syntax-macro
     (lambda (e)
       (syntax-match e ()
-        ((_ ((fml* expr*) ...) b b* ...)
-         (bless
-           `(syntax-case (list . ,expr*) ()
-              (,fml* (begin ,b . ,b*))))))))
-  
+        ((_ ((pat* expr*) ...) b b* ...)
+         (let ([idn*
+                (let f ([pat* pat*])
+                  (cond
+                    [(null? pat*) '()]
+                    [else
+                     (let-values ([(pat idn*) (convert-pattern (car pat*) '())])
+                       (append idn* (f (cdr pat*))))]))])
+           (verify-formals (map car idn*) e)
+           (let ([t* (generate-temporaries expr*)])
+             (bless 
+               `(let ,(map list t* expr*)
+                  ,(let f ([pat* pat*] [t* t*])
+                     (cond
+                       [(null? pat*) `(begin #f ,b . ,b*)]
+                       [else
+                        `(syntax-case ,(car t*) ()
+                           [,(car pat*) ,(f (cdr pat*) (cdr t*))]
+                           [_ (assertion-violation 'with-syntax
+                                "pattern does not match value"
+                                ',(car pat*)
+                                ,(car t*))])]))))))))))
+
   (define (invalid-fmls-error stx fmls)
     (syntax-match fmls ()
       [(id* ... . last) 
@@ -3767,7 +3786,7 @@
               (assertion-violation 'bound-identifier=? "not an identifier" y))
           (assertion-violation 'bound-identifier=? "not an identifier" x))))
   
-  (define (extract-position-condition x) 
+  (define (extract-position-condition x)
     (define-condition-type &source-information &condition
       make-source-condition source-condition?
       (file-name source-filename)