From cf8298138312b03c524cc7e1451be877551dac19 Mon Sep 17 00:00:00 2001
From: Abdulaziz Ghuloum <aghuloum@cs.indiana.edu>
Date: Fri, 7 Dec 2007 03:00:25 -0500
Subject: [PATCH] Fixes bug 174497: syntax-error should not be in (rnrs) and
 syntax-violation not completed

---
 scheme/ikarus.compiler.ss  |  4 +++-
 scheme/last-revision       |  2 +-
 scheme/makefile.ss         |  2 +-
 scheme/psyntax.expander.ss | 32 ++++++++++++++++++++++++++++++--
 4 files changed, 35 insertions(+), 5 deletions(-)

diff --git a/scheme/ikarus.compiler.ss b/scheme/ikarus.compiler.ss
index d6f4a67..8c5e1db 100644
--- a/scheme/ikarus.compiler.ss
+++ b/scheme/ikarus.compiler.ss
@@ -2148,7 +2148,9 @@
                  (or v* (error 'name* "uninitialized label"))) ...
                (define (refresh)
                  (define-syntax name* 
-                   (lambda (stx) (syntax-error stx "cannot use label before it is defined")))
+                   (lambda (stx)
+                     (syntax-error stx 
+                        "cannot use label before it is defined")))
                  ...
                  (let* ([name* (let ([label (let () b* b** ...)])
                                  (set! v* label)
diff --git a/scheme/last-revision b/scheme/last-revision
index 8cdd21d..9f7893c 100644
--- a/scheme/last-revision
+++ b/scheme/last-revision
@@ -1 +1 @@
-1192
+1193
diff --git a/scheme/makefile.ss b/scheme/makefile.ss
index 2b91432..138f1b7 100755
--- a/scheme/makefile.ss
+++ b/scheme/makefile.ss
@@ -1298,7 +1298,7 @@
     [module                                      i cm]
     [library                                     i]
     [syntax-dispatch                             ]
-    [syntax-error                                i r sc]
+    [syntax-error                                i]
     [$transcoder->data                           $transc]
     [$data->transcoder                           $transc]
     [file-options-spec                           i]
diff --git a/scheme/psyntax.expander.ss b/scheme/psyntax.expander.ss
index f1d310c..6167a3f 100644
--- a/scheme/psyntax.expander.ss
+++ b/scheme/psyntax.expander.ss
@@ -22,6 +22,7 @@
   (export identifier? syntax-dispatch environment environment?
           eval expand generate-temporaries free-identifier=?
           bound-identifier=? datum->syntax syntax-error
+          syntax-violation
           syntax->datum make-variable-transformer
           eval-r6rs-top-level boot-library-expand eval-top-level
           null-environment scheme-report-environment)
@@ -30,7 +31,7 @@
       environment environment? identifier?
       eval generate-temporaries free-identifier=?
       bound-identifier=? datum->syntax syntax-error
-      syntax->datum make-variable-transformer
+      syntax-violation syntax->datum make-variable-transformer
       null-environment scheme-report-environment)
     (rnrs base)
     (rnrs lists)
@@ -3427,7 +3428,6 @@
         (error 'syntax-error "invalid argument" args))
       (raise 
         (condition 
-          ;(make-who-condition 'expander)
           (make-message-condition
             (if (null? args) 
                 "invalid syntax"
@@ -3436,6 +3436,34 @@
             (stx->datum x)
             'none)))))
 
+  (define syntax-violation
+    (case-lambda
+      [(who msg form) 
+       (syntax-violation who msg form #f)]
+      [(who msg form subform) 
+       (unless (string? msg) 
+         (error 'syntax-violation "message is not a string" msg))
+       (let ([who
+              (cond
+                [(or (string? who) (symbol? who)) who]
+                [(not who) 
+                 (syntax-match form ()
+                   [id (id? id) (syntax->datum id)]
+                   [(id . rest) (id? id) (syntax->datum id)]
+                   [_  #f])]
+                [else
+                 (error 'syntax-violation 
+                    "invalid who argument" who)])])
+         (raise 
+           (condition
+             (if who 
+                 (make-who-condition who)
+                 (condition))
+             (make-message-condition msg)
+             (make-syntax-violation 
+               (syntax->datum form)
+               (syntax->datum subform)))))]))
+
   (define identifier? (lambda (x) (id? x)))
   
   (define datum->syntax