From 0e18163366c2f2a0caecde18241dbd7987b4db7c Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Thu, 19 Dec 2013 13:22:50 -0500
Subject: [PATCH] Implement R7RS 'syntax-error'.

* module/ice-9/psyntax.scm (syntax-error): New macro.
  (syntax-rules): Handle 'syntax-error' templates specially
  for improved error reporting.

* module/ice-9/psyntax-pp.scm: Regenerate.

* doc/ref/api-macros.texi (Syntax Rules): Add new subsection "Reporting
  Syntax Errors in Macros".

* test-suite/tests/syntax.test: Add tests.
---
 doc/ref/api-macros.texi      | 24 ++++++++++
 module/ice-9/psyntax-pp.scm  | 90 ++++++++++++++++++++++++++++--------
 module/ice-9/psyntax.scm     | 38 +++++++++++++--
 test-suite/tests/syntax.test | 41 ++++++++++++++++
 4 files changed, 172 insertions(+), 21 deletions(-)

diff --git a/doc/ref/api-macros.texi b/doc/ref/api-macros.texi
index 0d604004f..030daedb0 100644
--- a/doc/ref/api-macros.texi
+++ b/doc/ref/api-macros.texi
@@ -363,6 +363,30 @@ Cast into this form, our @code{when} example is significantly shorter:
   (if c (begin e ...)))
 @end example
 
+@subsubsection Reporting Syntax Errors in Macros
+
+@deffn {Syntax} syntax-error message [arg ...]
+Report an error at macro-expansion time.  @var{message} must be a string
+literal, and the optional @var{arg} operands can be arbitrary expressions
+providing additional information.
+@end deffn
+
+@code{syntax-error} is intended to be used within @code{syntax-rules}
+templates.  For example:
+
+@example
+(define-syntax simple-let
+  (syntax-rules ()
+    ((_ (head ... ((x . y) val) . tail)
+        body1 body2 ...)
+     (syntax-error
+      "expected an identifier but got"
+      (x . y)))
+    ((_ ((name val) ...) body1 body2 ...)
+     ((lambda (name ...) body1 body2 ...)
+      val ...))))
+@end example
+
 @subsubsection Specifying a Custom Ellipsis Identifier
 
 When writing macros that generate macro definitions, it is convenient to
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index 36cf45c1c..d6547aa09 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -2585,18 +2585,85 @@
                       "source expression failed to match any pattern"
                       tmp)))))))))))
 
+(define syntax-error
+  (make-syntax-transformer
+    'syntax-error
+    'macro
+    (lambda (x)
+      (let ((tmp-1 x))
+        (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any . each-any))))
+          (if (if tmp
+                (apply (lambda (keyword operands message arg)
+                         (string? (syntax->datum message)))
+                       tmp)
+                #f)
+            (apply (lambda (keyword operands message arg)
+                     (syntax-violation
+                       (syntax->datum keyword)
+                       (string-join
+                         (cons (syntax->datum message)
+                               (map (lambda (x) (object->string (syntax->datum x))) arg)))
+                       (if (syntax->datum keyword) (cons keyword operands) #f)))
+                   tmp)
+            (let ((tmp ($sc-dispatch tmp-1 '(_ any . each-any))))
+              (if (if tmp
+                    (apply (lambda (message arg) (string? (syntax->datum message))) tmp)
+                    #f)
+                (apply (lambda (message arg)
+                         (cons '#(syntax-object syntax-error ((top)) (hygiene guile))
+                               (cons '(#f) (cons message arg))))
+                       tmp)
+                (syntax-violation
+                  #f
+                  "source expression failed to match any pattern"
+                  tmp-1)))))))))
+
 (define syntax-rules
   (make-syntax-transformer
     'syntax-rules
     'macro
     (lambda (xx)
       (letrec*
-        ((expand-syntax-rules
+        ((expand-clause
+           (lambda (clause)
+             (let ((tmp-1 clause))
+               (let ((tmp ($sc-dispatch
+                            tmp-1
+                            '((any . any)
+                              (#(free-id #(syntax-object syntax-error ((top)) (hygiene guile)))
+                               any
+                               .
+                               each-any)))))
+                 (if (if tmp
+                       (apply (lambda (keyword pattern message arg)
+                                (string? (syntax->datum message)))
+                              tmp)
+                       #f)
+                   (apply (lambda (keyword pattern message arg)
+                            (list (cons '#(syntax-object dummy ((top)) (hygiene guile)) pattern)
+                                  (list '#(syntax-object syntax ((top)) (hygiene guile))
+                                        (cons '#(syntax-object syntax-error ((top)) (hygiene guile))
+                                              (cons (cons '#(syntax-object dummy ((top)) (hygiene guile)) pattern)
+                                                    (cons message arg))))))
+                          tmp)
+                   (let ((tmp ($sc-dispatch tmp-1 '((any . any) any))))
+                     (if tmp
+                       (apply (lambda (keyword pattern template)
+                                (list (cons '#(syntax-object dummy ((top)) (hygiene guile)) pattern)
+                                      (list '#(syntax-object syntax ((top)) (hygiene guile)) template)))
+                              tmp)
+                       (syntax-violation
+                         #f
+                         "source expression failed to match any pattern"
+                         tmp-1))))))))
+         (expand-syntax-rules
            (lambda (dots keys docstrings clauses)
-             (let ((tmp-1 (list keys docstrings clauses)))
-               (let ((tmp ($sc-dispatch tmp-1 '(each-any each-any #(each ((any . any) any))))))
+             (let ((tmp-1 (list keys docstrings clauses (map expand-clause clauses))))
+               (let ((tmp ($sc-dispatch
+                            tmp-1
+                            '(each-any each-any #(each ((any . any) any)) each-any))))
                  (if tmp
-                   (apply (lambda (k docstring keyword pattern template)
+                   (apply (lambda (k docstring keyword pattern template clause)
                             (let ((tmp (cons '#(syntax-object lambda ((top)) (hygiene guile))
                                              (cons '(#(syntax-object x ((top)) (hygiene guile)))
                                                    (append
@@ -2609,20 +2676,7 @@
                                                                    pattern))
                                                            (cons '#(syntax-object syntax-case ((top)) (hygiene guile))
                                                                  (cons '#(syntax-object x ((top)) (hygiene guile))
-                                                                       (cons k
-                                                                             (map (lambda (tmp-1 tmp)
-                                                                                    (list (cons '#(syntax-object
-                                                                                                   dummy
-                                                                                                   ((top))
-                                                                                                   (hygiene guile))
-                                                                                                tmp)
-                                                                                          (list '#(syntax-object
-                                                                                                   syntax
-                                                                                                   ((top))
-                                                                                                   (hygiene guile))
-                                                                                                tmp-1)))
-                                                                                  template
-                                                                                  pattern))))))))))
+                                                                       (cons k clause)))))))))
                               (let ((form tmp))
                                 (if dots
                                   (let ((tmp dots))
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 69d336017..5a805c5fd 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -2841,21 +2841,53 @@
           #'(syntax-case (list in ...) ()
               ((out ...) (let () e1 e2 ...)))))))
 
+(define-syntax syntax-error
+  (lambda (x)
+    (syntax-case x ()
+      ;; Extended internal syntax which provides the original form
+      ;; as the first operand, for improved error reporting.
+      ((_ (keyword . operands) message arg ...)
+       (string? (syntax->datum #'message))
+       (syntax-violation (syntax->datum #'keyword)
+                         (string-join (cons (syntax->datum #'message)
+                                            (map (lambda (x)
+                                                   (object->string
+                                                    (syntax->datum x)))
+                                                 #'(arg ...))))
+                         (and (syntax->datum #'keyword)
+                              #'(keyword . operands))))
+      ;; Standard R7RS syntax
+      ((_ message arg ...)
+       (string? (syntax->datum #'message))
+       #'(syntax-error (#f) message arg ...)))))
+
 (define-syntax syntax-rules
   (lambda (xx)
+    (define (expand-clause clause)
+      ;; Convert a 'syntax-rules' clause into a 'syntax-case' clause.
+      (syntax-case clause (syntax-error)
+        ;; If the template is a 'syntax-error' form, use the extended
+        ;; internal syntax, which adds the original form as the first
+        ;; operand for improved error reporting.
+        (((keyword . pattern) (syntax-error message arg ...))
+         (string? (syntax->datum #'message))
+         #'((dummy . pattern) #'(syntax-error (dummy . pattern) message arg ...)))
+        ;; Normal case
+        (((keyword . pattern) template)
+         #'((dummy . pattern) #'template))))
     (define (expand-syntax-rules dots keys docstrings clauses)
       (with-syntax
           (((k ...) keys)
            ((docstring ...) docstrings)
-           ((((keyword . pattern) template) ...) clauses))
+           ((((keyword . pattern) template) ...) clauses)
+           ((clause ...) (map expand-clause clauses)))
         (with-syntax
             ((form #'(lambda (x)
                        docstring ...        ; optional docstring
                        #((macro-type . syntax-rules)
                          (patterns pattern ...)) ; embed patterns as procedure metadata
                        (syntax-case x (k ...)
-                         ((dummy . pattern) #'template)
-                         ...))))
+                         clause ...))))
           (if dots
               (with-syntax ((dots dots))
                 #'(with-ellipsis dots form))
diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test
index c68a66a58..5c2a703d8 100644
--- a/test-suite/tests/syntax.test
+++ b/test-suite/tests/syntax.test
@@ -1211,6 +1211,47 @@
       (define-syntax bar (foo x y z))
       (bar a b c))))
 
+(with-test-prefix "syntax-error"
+
+  (pass-if-syntax-error "outside of macro without args"
+    "test error"
+    (eval '(syntax-error "test error")
+          (interaction-environment)))
+
+  (pass-if-syntax-error "outside of macro with args"
+    "test error x \\(y z\\)"
+    (eval '(syntax-error "test error" x (y z))
+          (interaction-environment)))
+
+  (pass-if-equal "within macro"
+      '(simple-let
+        "expected an identifier but got (z1 z2)"
+        (simple-let ((y (* x x))
+                     ((z1 z2) (values x x)))
+          (+ y 1)))
+    (catch 'syntax-error
+      (lambda ()
+        (eval '(let ()
+                 (define-syntax simple-let
+                   (syntax-rules ()
+                     ((_ (head ... ((x . y) val) . tail)
+                         body1 body2 ...)
+                      (syntax-error
+                       "expected an identifier but got"
+                       (x . y)))
+                     ((_ ((name val) ...) body1 body2 ...)
+                      ((lambda (name ...) body1 body2 ...)
+                       val ...))))
+                 (define (foo x)
+                   (simple-let ((y (* x x))
+                                ((z1 z2) (values x x)))
+                     (+ y 1)))
+                 foo)
+              (interaction-environment))
+        (error "expected syntax-error exception"))
+      (lambda (k who what where form . maybe-subform)
+        (list who what form)))))
+
 (with-test-prefix "syntax-case"
   
   (pass-if-syntax-error "duplicate pattern variable"
-- 
2.20.1