From 32214ff60855eb195943a8313d20b59a05c1570c Mon Sep 17 00:00:00 2001
From: Jan Nieuwenhuizen <janneke@gnu.org>
Date: Sun, 30 Oct 2016 20:41:49 +0100
Subject: [PATCH] Add syntax-case based syntax-rules.

* module/mes/psyntax-1.mes (syntax-rules): New syntax transformer,
  based on syntax-case.
  (define-syntax-rule): New macro.
  (let-syntax): New macro, for syntax-case.
* tests/let-syntax.test: Switch to syntax-case.
* tests/psyntax.test: Add syntax-rules and syntax-rule test.
---
 module/mes/psyntax-1.mes | 26 ++++++++++++++++++++++++++
 tests/let-syntax.test    |  5 +++--
 tests/psyntax.test       | 22 +++++++++++++++++++++-
 3 files changed, 50 insertions(+), 3 deletions(-)

diff --git a/module/mes/psyntax-1.mes b/module/mes/psyntax-1.mes
index 77656425..204dca6c 100644
--- a/module/mes/psyntax-1.mes
+++ b/module/mes/psyntax-1.mes
@@ -35,3 +35,29 @@
          (syntax-object->datum
           (,transformer (cons ,macro-name args)))
          (current-module)))))
+
+(define-syntax syntax-rules
+  (lambda (x)
+    (syntax-case x ()
+      ((_ (k ...) ((keyword . pattern) template) ...)
+       (syntax (lambda (x)
+                (syntax-case x (k ...)
+                  ((dummy . pattern) (syntax template))
+                  ...)))))))
+
+(define-macro (define-syntax-rule id-pattern . template)
+  `(define-syntax ,(car id-pattern)
+     (syntax-rules ()
+       ((,(car id-pattern) . ,(cdr id-pattern)) ,@template))))
+
+(define-macro (let-syntax bindings . rest)
+  `((lambda ()
+      ,@(map (lambda (binding)
+               `(define-macro ,(car binding)
+                  `(lambda args
+                     (eval
+                      (syntax-object->datum
+                       (,(cadr binding) (cons ',(car binding) args)))
+                      (current-module)))))
+             bindings)
+      ,@rest)))
diff --git a/tests/let-syntax.test b/tests/let-syntax.test
index 95eec9bc..db90afff 100755
--- a/tests/let-syntax.test
+++ b/tests/let-syntax.test
@@ -30,8 +30,9 @@ exit $?
 (mes-use-module (mes quasiquote))
 (mes-use-module (mes let))
 (mes-use-module (mes scm))
-(mes-use-module (mes syntax))
-(mes-use-module (mes let-syntax))
+(mes-use-module (mes psyntax-0))
+(mes-use-module (mes psyntax-pp))
+(mes-use-module (mes psyntax-1))
 (mes-use-module (mes test))
 
 (pass-if "first dummy" #t)
diff --git a/tests/psyntax.test b/tests/psyntax.test
index 7fc3b7d5..49711f47 100755
--- a/tests/psyntax.test
+++ b/tests/psyntax.test
@@ -119,5 +119,25 @@ exit $?
        (list foo bar)))
    (list "bar" "foo")))
 
-(result 'report)
+(pass-if "define-syntax sr:when [syntax-rules]"
+  (sequal?
+   (let ()
+     (define-syntax sr:when
+       (syntax-rules ()
+         ((sc:when condition exp ...)
+          (if condition
+              (begin exp ...)))))
+     (let ()
+       (sr:when #t "if not now, then?")))
+   "if not now, then?"))
 
+(pass-if "define-syntax-rule"
+  (sequal?
+   (let ()
+     (define-syntax-rule (sre:when c e ...)
+       (if c (begin e ...)))
+     (let ()
+       (sre:when #t "if not now, then?")))
+   "if not now, then?"))
+
+(result 'report)