Decouple syntax-case from the Chibi core.

This restores third-party (ab)users of the Chibi macro system such
as in https://gist.github.com/baguette/2632464, while allowing us
to break those uses in more interesting ways.

It also keeps the core slightly smaller (both in C and Scheme)
and speeds up the macro expansion process.

eval.c

@@ -2199,9 +2199,9 @@ static struct sexp_core_form_struct core_forms[] = {
   {SEXP_CORE_BEGIN, (sexp)"begin"},
   {SEXP_CORE_QUOTE, (sexp)"quote"},
   {SEXP_CORE_SYNTAX_QUOTE, (sexp)"syntax-quote"},
-  {SEXP_CORE_DEFINE_SYNTAX, (sexp)"%define-syntax"},
+  {SEXP_CORE_DEFINE_SYNTAX, (sexp)"define-syntax"},
-  {SEXP_CORE_LET_SYNTAX, (sexp)"%let-syntax"},
+  {SEXP_CORE_LET_SYNTAX, (sexp)"let-syntax"},
-  {SEXP_CORE_LETREC_SYNTAX, (sexp)"%letrec-syntax"},
+  {SEXP_CORE_LETREC_SYNTAX, (sexp)"letrec-syntax"},
 };
 
 sexp sexp_make_env_op (sexp ctx, sexp self, sexp_sint_t n) {

lib/chibi/syntax-case-test.sld

@@ -1,6 +1,6 @@
 (define-library (chibi syntax-case-test)
   (export run-tests)
-  (import (chibi)
+  (import (except (chibi) define-syntax let-syntax letrec-syntax)
           (chibi syntax-case)
           (chibi test))
   (begin

lib/chibi/syntax-case.scm

@@ -9,14 +9,63 @@
 
 ;; TODO: Write many more tests.
 
+(define current-renamer (make-parameter (lambda (x) x)))
+(define current-usage-environment (make-parameter (current-environment)))
+
+(define (free-identifier=? x y)
+  (let ((env (or (current-usage-environment) (current-environment))))
+    (identifier=? env x env y)))
+
+(define (make-transformer transformer)
+  (cond
+   ((and (= 1 (procedure-arity transformer))
+         (not (procedure-variadic? transformer)))
+    (lambda (expr use-env mac-env)
+      (let ((old-use-env (current-usage-environment))
+            (old-renamer (current-renamer)))
+        (current-usage-environment use-env)
+        (current-renamer (make-renamer mac-env))
+        (let ((result (transformer expr)))
+          (current-usage-environment old-use-env)
+          (current-renamer old-renamer)
+          result))))
+   (else
+    (lambda (expr use-env mac-env)
+      (let ((old-use-env (current-usage-environment))
+            (old-renamer (current-renamer)))
+        (current-usage-environment use-env)
+        (current-renamer (make-renamer mac-env))
+        (let ((result (transformer expr use-env mac-env)))
+          (current-usage-environment old-use-env)
+          (current-renamer old-renamer)
+          result))))))
+
+(%define-syntax define-syntax
+  (lambda (expr use-env mac-env)
+    (list (close-syntax '%define-syntax mac-env)
+          (cadr expr)
+          (list (close-syntax 'make-transformer mac-env)
+                (car (cddr expr))))))
+
+(define-syntax let-syntax
+  (syntax-rules ()
+    ((let-syntax ((keyword transformer) ...) . body)
+     (%let-syntax ((keyword (make-transformer transformer)) ...) . body))))
+
+(define-syntax letrec-syntax
+  (syntax-rules ()
+    ((letrec-syntax ((keyword transformer) ...) . body)
+     (%letrec-syntax ((keyword (make-transformer transformer)) ...) . body))))
+
 (define-syntax define-pattern-variable
   (er-macro-transformer
    (lambda (expr rename compare)
      (let ((id (cadr expr))
            (binding (cddr expr)))
-       (let ((mac (cdr (env-cell (current-usage-environment) id))))
+       (let ((cell (env-cell (current-usage-environment) id)))
-         (macro-aux-set! mac binding))
+         (if cell
-       `(,(rename 'begin))))))
+             (macro-aux-set! (cdr cell) binding)))
+       (rename '(begin))))))
 
 (define (make-pattern-variable pvar)
   (lambda (expr)
@@ -327,3 +376,7 @@
          #'(let-syntax ((current-ellipsis (syntax-rules ())))
              (define-current-ellipsis ellipsis)
              . body))))))
+
+;; Local variables:
+;; eval: (put '%define-syntax 'scheme-indent-function 1)
+;; End:

lib/chibi/syntax-case.sld

@@ -3,10 +3,17 @@
           syntax-case syntax quasisyntax unsyntax unsyntax-splicing
           datum->syntax syntax->datum
           generate-temporaries with-syntax syntax-violation
-          with-ellipsis ellipsis-identifier?)
+          with-ellipsis ellipsis-identifier?
-  (import (chibi)
+          define-syntax let-syntax letrec-syntax)
-          (chibi ast)
+  (import (rename (chibi)
-          (meta)
+                  (define-syntax %define-syntax)
+                  (let-syntax %let-syntax)
+                  (letrec-syntax %letrec-syntax))
+          (only (chibi ast)
+                env-cell macro? macro-aux macro-aux-set!
+                procedure-arity procedure-variadic?)
+          (only (meta) environment)
           (srfi 1)
-          (srfi 11))
+          (srfi 11)
+          (srfi 39))
   (include "syntax-case.scm"))

lib/init-7.scm

@@ -1,5 +1,5 @@
 ;; init-7.scm -- core library procedures for R7RS
-;; Copyright (c) 2009-2019 Alex Shinn.  All rights reserved.
+;; Copyright (c) 2009-2021 Alex Shinn.  All rights reserved.
 ;; BSD-style license: http://synthcode.com/license.txt
 
 (define (caar x) (car (car x)))
@@ -110,8 +110,6 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; syntax
 
-(current-renamer (lambda (x) x))
-
 (define close-syntax
   (lambda (form env)
     (make-syntactic-closure env '() form)))
@@ -135,53 +133,22 @@
        '()))
     rename))
 
-(define make-transformer
-  (lambda (transformer)
-    (lambda (expr use-env mac-env)
-      ((lambda (old-use-env old-mac-env old-renamer)
-         (current-usage-environment use-env)
-         (current-transformer-environment mac-env)
-         (current-renamer (make-renamer mac-env))
-         ((lambda (result)
-            (current-usage-environment old-use-env)
-            (current-transformer-environment old-mac-env)
-            (current-renamer old-renamer)
-            result)
-          (transformer expr)))
-       (current-usage-environment)
-       (current-transformer-environment)
-       (current-renamer)))))
-
-(%define-syntax define-syntax
-  (lambda (expr use-env mac-env)
-    (list (close-syntax '%define-syntax mac-env)
-          (cadr expr)
-          (list (close-syntax 'make-transformer mac-env)
-                (car (cddr expr))))))
-
-(define free-identifier=?
-  (lambda (x y)
-    ((lambda (use-env cur-env)
-       (identifier=? (if use-env use-env cur-env) x
-                     (if use-env use-env cur-env) y))
-     (current-usage-environment)
-     (current-environment))))
-
 (define sc-macro-transformer
   (lambda (f)
-    (lambda (expr)
+    (lambda (expr use-env mac-env)
-      (close-syntax (f expr (current-usage-environment))
+      (close-syntax (f expr use-env) mac-env))))
-                    (current-transformer-environment)))))
 
 (define rsc-macro-transformer
   (lambda (f)
-    (lambda (expr)
+    (lambda (expr use-env mac-env)
-      (f expr (current-transformer-environment)))))
+      (f expr mac-env))))
 
 (define er-macro-transformer
   (lambda (f)
-    (lambda (expr)
+    (lambda (expr use-env mac-env)
-      (f expr (current-renamer) free-identifier=?))))
+      (f expr
+         (make-renamer mac-env)
+         (lambda (x y) (identifier=? use-env x use-env y))))))
 
 (define-syntax cond
   (er-macro-transformer
@@ -1125,16 +1092,6 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; let(rec)-syntax and datum->syntax
 
-(define-syntax let-syntax
-  (syntax-rules ()
-    ((let-syntax ((keyword transformer) ...) . body)
-     (%let-syntax ((keyword (make-transformer transformer)) ...) . body))))
-
-(define-syntax letrec-syntax
-  (syntax-rules ()
-    ((letrec-syntax ((keyword transformer) ...) . body)
-     (%letrec-syntax ((keyword (make-transformer transformer)) ...) . body))))
-
 (define (symbol->identifier id symbol)
   (cond
    ((symbol? id)

lib/meta-7.scm

@@ -246,8 +246,8 @@
         (module-env-set! mod (eval-module name mod)))
     mod))
 
-(%define-syntax meta-begin begin)
+(define-syntax meta-begin begin)
-(%define-syntax meta-define define)
+(define-syntax meta-define define)
 
 (define define-library-transformer
   (er-macro-transformer

lib/srfi/139.scm

@@ -4,29 +4,28 @@
      (for-each set-cdr! (car (cddr expr)) (cadr (cddr expr)))
      (car (cdr expr)))))
 
-(%define-syntax syntax-parameterize
+(define-syntax syntax-parameterize
-   (lambda (expr use-env mac-env)
+  (lambda (expr use-env mac-env)
-     (let* ((_let (make-syntactic-closure mac-env '() 'let))
+    (let* ((_let (make-syntactic-closure mac-env '() 'let))
-            (_set! (make-syntactic-closure mac-env '() 'set!))
+           (_set! (make-syntactic-closure mac-env '() 'set!))
-            (_out (make-syntactic-closure mac-env '() 'out))
+           (_out (make-syntactic-closure mac-env '() 'out))
-            (_tmp (make-syntactic-closure mac-env '() 'tmp))
+           (_tmp (make-syntactic-closure mac-env '() 'tmp))
-            (bindings (cadr expr))
+           (bindings (cadr expr))
-            (body (cddr expr))
+           (body (cddr expr))
-            (keywords (map car bindings))
+           (keywords (map car bindings))
-            (transformers (map cadr bindings))
+           (transformers (map cadr bindings))
-            (cells
+           (cells
-             (map (lambda (keyword)
+            (map (lambda (keyword)
-                    (env-cell use-env keyword))
+                   (env-cell use-env keyword))
-                  keywords))
+                 keywords))
-            (old (map cdr cells))
+           (old (map cdr cells))
-            (new (map (lambda (transformer)
+           (new (map (lambda (transformer)
-                        (make-macro
+                       (make-macro
-                         (make-transformer
+                        (eval
-                          (eval
+                         (make-syntactic-closure use-env '() transformer))
-                           (make-syntactic-closure use-env '() transformer)))
+                        use-env))
-                         use-env))
+                     transformers)))
-                      transformers)))
+      (for-each set-cdr! cells new)
-       (for-each set-cdr! cells new)
+      `(,_let ((,_tmp #f))
-       `(,_let ((,_tmp #f))
+         (,_set! ,_tmp (,_let () ,@body))
-          (,_set! ,_tmp (,_let () ,@body))
+         (,_out ,_tmp ,cells ,old)))))
-          (,_out ,_tmp ,cells ,old)))))

lib/srfi/99/records/syntactic.sld

@@ -1,5 +1,5 @@
 
 (define-library (srfi 99 records syntactic)
   (export define-record-type)
-  (import (chibi) (chibi syntax-case) (srfi 99 records inspection))
+  (import (chibi) (srfi 99 records inspection))
   (include "syntactic.scm"))

opcodes.c

@@ -38,9 +38,6 @@ _PARAM("current-output-port", _I(SEXP_OPORT)),
 _PARAM("current-error-port", _I(SEXP_OPORT)),
 _PARAM("current-exception-handler", _I(SEXP_PROCEDURE)),
 _PARAM("interaction-environment", _I(SEXP_ENV)),
-_PARAM("current-usage-environment", _I(SEXP_ENV)),
-_PARAM("current-transformer-environment", _I(SEXP_ENV)),
-_PARAM("current-renamer", _I(SEXP_PROCEDURE)),
 _PARAM("command-line", SEXP_NULL),
 _OP(SEXP_OPC_GETTER, SEXP_OP_CAR, 1, 0, _I(SEXP_OBJECT), _I(SEXP_PAIR), SEXP_FALSE, SEXP_FALSE, 0, "car", 0, NULL),
 _OP(SEXP_OPC_SETTER, SEXP_OP_SET_CAR, 2, 0, SEXP_VOID, _I(SEXP_PAIR), _I(SEXP_OBJECT), SEXP_FALSE, 0, "set-car!", 0, NULL),