From 6cafda8916e8f8a996ce286ec0964f6208f470cc Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 10 Aug 2021 23:19:35 +0900 Subject: [PATCH] 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 | 6 +-- lib/chibi/syntax-case-test.sld | 2 +- lib/chibi/syntax-case.scm | 59 ++++++++++++++++++++++++++++-- lib/chibi/syntax-case.sld | 17 ++++++--- lib/init-7.scm | 61 +++++-------------------------- lib/meta-7.scm | 4 +- lib/srfi/139.scm | 51 +++++++++++++------------- lib/srfi/99/records/syntactic.sld | 2 +- opcodes.c | 3 -- 9 files changed, 109 insertions(+), 96 deletions(-) diff --git a/eval.c b/eval.c index 043adeb6..e440e005 100644 --- 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) { diff --git a/lib/chibi/syntax-case-test.sld b/lib/chibi/syntax-case-test.sld index 54ba1bc0..a72277c8 100644 --- 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 diff --git a/lib/chibi/syntax-case.scm b/lib/chibi/syntax-case.scm index ddc32b7f..45a7065b 100644 --- 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: diff --git a/lib/chibi/syntax-case.sld b/lib/chibi/syntax-case.sld index dc3b4262..0033d735 100644 --- 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")) diff --git a/lib/init-7.scm b/lib/init-7.scm index 4a4c5321..422b65bc 100644 --- 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) diff --git a/lib/meta-7.scm b/lib/meta-7.scm index b112ee75..c9b41e64 100644 --- 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 diff --git a/lib/srfi/139.scm b/lib/srfi/139.scm index 3fad4fd0..1b1a82d9 100644 --- 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))))) diff --git a/lib/srfi/99/records/syntactic.sld b/lib/srfi/99/records/syntactic.sld index 5ddc00c6..6a62db99 100644 --- 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")) diff --git a/opcodes.c b/opcodes.c index dac2278c..552fc698 100644 --- 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),