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.
2025-05-18 21:29:19 +02:00 · 2021-08-10 23:19:35 +09:00 · 2021-08-10 23:19:35 +09:00 · 6cafda8916
commit 6cafda8916
parent d10ea607e2
9 changed files with 109 additions and 96 deletions
--- a/eval.c
+++ b/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_LET_SYNTAX, (sexp)"%let-syntax"},
-  {SEXP_CORE_LETREC_SYNTAX, (sexp)"%letrec-syntax"},
+  {SEXP_CORE_DEFINE_SYNTAX, (sexp)"define-syntax"},
+  {SEXP_CORE_LET_SYNTAX, (sexp)"let-syntax"},
+  {SEXP_CORE_LETREC_SYNTAX, (sexp)"letrec-syntax"},
 };

 sexp sexp_make_env_op (sexp ctx, sexp self, sexp_sint_t n) {
--- a/lib/chibi/syntax-case-test.sld
+++ b/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
--- a/lib/chibi/syntax-case.scm
+++ b/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))))
-         (macro-aux-set! mac binding))
-       `(,(rename 'begin))))))
+       (let ((cell (env-cell (current-usage-environment) id)))
+         (if cell
+             (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:
--- a/lib/chibi/syntax-case.sld
+++ b/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?)
-  (import (chibi)
-          (chibi ast)
-          (meta)
+          with-ellipsis ellipsis-identifier?
+          define-syntax let-syntax letrec-syntax)
+  (import (rename (chibi)
+                  (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"))
--- a/lib/init-7.scm
+++ b/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)
-      (close-syntax (f expr (current-usage-environment))
-                    (current-transformer-environment)))))
+    (lambda (expr use-env mac-env)
+      (close-syntax (f expr use-env) mac-env))))

 (define rsc-macro-transformer
  (lambda (f)
-    (lambda (expr)
-      (f expr (current-transformer-environment)))))
+    (lambda (expr use-env mac-env)
+      (f expr mac-env))))

 (define er-macro-transformer
  (lambda (f)
-    (lambda (expr)
-      (f expr (current-renamer) free-identifier=?))))
+    (lambda (expr use-env mac-env)
+      (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)
--- a/lib/meta-7.scm
+++ b/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-define define)
+(define-syntax meta-begin begin)
+(define-syntax meta-define define)

 (define define-library-transformer
  (er-macro-transformer
--- a/lib/srfi/139.scm
+++ b/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
-   (lambda (expr use-env mac-env)
-     (let* ((_let (make-syntactic-closure mac-env '() 'let))
-            (_set! (make-syntactic-closure mac-env '() 'set!))
-            (_out (make-syntactic-closure mac-env '() 'out))
-            (_tmp (make-syntactic-closure mac-env '() 'tmp))
-            (bindings (cadr expr))
-            (body (cddr expr))
-            (keywords (map car bindings))
-            (transformers (map cadr bindings))
-            (cells
-             (map (lambda (keyword)
-                    (env-cell use-env keyword))
-                  keywords))
-            (old (map cdr cells))
-            (new (map (lambda (transformer)
-                        (make-macro
-                         (make-transformer
-                          (eval
-                           (make-syntactic-closure use-env '() transformer)))
-                         use-env))
-                      transformers)))
-       (for-each set-cdr! cells new)
-       `(,_let ((,_tmp #f))
-          (,_set! ,_tmp (,_let () ,@body))
-          (,_out ,_tmp ,cells ,old)))))
+(define-syntax syntax-parameterize
+  (lambda (expr use-env mac-env)
+    (let* ((_let (make-syntactic-closure mac-env '() 'let))
+           (_set! (make-syntactic-closure mac-env '() 'set!))
+           (_out (make-syntactic-closure mac-env '() 'out))
+           (_tmp (make-syntactic-closure mac-env '() 'tmp))
+           (bindings (cadr expr))
+           (body (cddr expr))
+           (keywords (map car bindings))
+           (transformers (map cadr bindings))
+           (cells
+            (map (lambda (keyword)
+                   (env-cell use-env keyword))
+                 keywords))
+           (old (map cdr cells))
+           (new (map (lambda (transformer)
+                       (make-macro
+                        (eval
+                         (make-syntactic-closure use-env '() transformer))
+                        use-env))
+                     transformers)))
+      (for-each set-cdr! cells new)
+      `(,_let ((,_tmp #f))
+         (,_set! ,_tmp (,_let () ,@body))
+         (,_out ,_tmp ,cells ,old)))))
--- a/lib/srfi/99/records/syntactic.sld
+++ b/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"))
--- a/opcodes.c
+++ b/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),