From 770b4d367bcff6ca91bedac40007177a4ec7541e Mon Sep 17 00:00:00 2001 From: Daphne Preston-Kendal Date: Wed, 29 Dec 2021 23:52:46 +0100 Subject: [PATCH 01/22] Add basic support for identifier macros --- eval.c | 34 +++++++++++++++++++++++++--------- 1 file changed, 25 insertions(+), 9 deletions(-) diff --git a/eval.c b/eval.c index 1b441d2d..15232557 100644 --- a/eval.c +++ b/eval.c @@ -1051,6 +1051,22 @@ static sexp analyze_letrec_syntax (sexp ctx, sexp x, int depth) { return analyze_let_syntax_aux(ctx, x, 1, depth); } +static sexp analyze_macro_once (sexp ctx, sexp x, sexp op, int depth) { + sexp res; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + tmp = sexp_cons(ctx, sexp_macro_env(op), SEXP_NULL); + tmp = sexp_cons(ctx, sexp_context_env(ctx), tmp); + tmp = sexp_cons(ctx, x, tmp); + res = sexp_exceptionp(tmp) ? tmp : sexp_make_child_context(ctx, sexp_context_lambda(ctx)); + if (!sexp_exceptionp(res) && !sexp_exceptionp(sexp_context_exception(ctx))) + res = sexp_apply(res, sexp_macro_proc(op), tmp); + if (sexp_exceptionp(res) && sexp_not(sexp_exception_source(x))) + sexp_exception_source(res) = sexp_pair_source(sexp_car(tmp)); + sexp_gc_release1(ctx); + return res; +} + static sexp analyze (sexp ctx, sexp object, int depth, int defok) { sexp op; sexp_gc_var4(res, tmp, x, cell); @@ -1115,14 +1131,7 @@ static sexp analyze (sexp ctx, sexp object, int depth, int defok) { res = sexp_compile_error(ctx, "unknown core form", op); break; } } else if (sexp_macrop(op)) { - tmp = sexp_cons(ctx, sexp_macro_env(op), SEXP_NULL); - tmp = sexp_cons(ctx, sexp_context_env(ctx), tmp); - tmp = sexp_cons(ctx, x, tmp); - x = sexp_exceptionp(tmp) ? tmp : sexp_make_child_context(ctx, sexp_context_lambda(ctx)); - if (!sexp_exceptionp(x) && !sexp_exceptionp(sexp_context_exception(ctx))) - x = sexp_apply(x, sexp_macro_proc(op), tmp); - if (sexp_exceptionp(x) && sexp_not(sexp_exception_source(x))) - sexp_exception_source(x) = sexp_pair_source(sexp_car(tmp)); + x = analyze_macro_once(ctx, x, op, depth); goto loop; } else if (sexp_opcodep(op)) { res = sexp_length(ctx, sexp_cdr(x)); @@ -1154,7 +1163,14 @@ static sexp analyze (sexp ctx, sexp object, int depth, int defok) { sexp_warn(ctx, "invalid operator in application: ", x); } } else if (sexp_idp(x)) { - res = analyze_var_ref(ctx, x, NULL); + cell = sexp_env_cell(ctx, sexp_context_env(ctx), x, 0); + op = cell ? sexp_cdr(cell) : NULL; + if (op && sexp_macrop(op)) { + x = analyze_macro_once(ctx, x, op, depth); + goto loop; + } else { + res = analyze_var_ref(ctx, x, NULL); + } } else if (sexp_synclop(x)) { tmp = sexp_make_child_context(ctx, sexp_context_lambda(ctx)); if (sexp_pairp(sexp_synclo_free_vars(x))) { From e97a2debe1b4c71190533fb2d76e7ceb59a3b07d Mon Sep 17 00:00:00 2001 From: Daphne Preston-Kendal Date: Thu, 30 Dec 2021 00:10:46 +0100 Subject: [PATCH 02/22] Friendlier error message for misuse of standard macros --- lib/init-7.scm | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/lib/init-7.scm b/lib/init-7.scm index 8a3ea91f..a8c88a74 100644 --- a/lib/init-7.scm +++ b/lib/init-7.scm @@ -143,13 +143,21 @@ (lambda (expr use-env mac-env) (f expr mac-env)))) -(define er-macro-transformer +(define er-macro-transformer* (lambda (f) (lambda (expr use-env mac-env) (f expr (make-renamer mac-env) (lambda (x y) (identifier=? use-env x use-env y)))))) +(define er-macro-transformer + (lambda (f) + (er-macro-transformer* + (lambda (expr rename compare) + (if (not (pair? expr)) + (error "invalid use of non-identifier macro outside operator postion" expr) + (f expr rename compare)))))) + (define-syntax cond (er-macro-transformer (lambda (expr rename compare) From d17764be2900f56121dcb392f1fcf95ba32bf0c7 Mon Sep 17 00:00:00 2001 From: Daphne Preston-Kendal Date: Thu, 30 Dec 2021 10:34:54 +0100 Subject: [PATCH 03/22] Add variable transformers --- eval.c | 92 ++++++++++++++++++++++++++++---------------- include/chibi/eval.h | 1 + include/chibi/sexp.h | 2 + opcodes.c | 1 + sexp.c | 2 + 5 files changed, 64 insertions(+), 34 deletions(-) diff --git a/eval.c b/eval.c index 15232557..6b7dd202 100644 --- a/eval.c +++ b/eval.c @@ -399,6 +399,18 @@ static sexp sexp_make_macro (sexp ctx, sexp p, sexp e) { return mac; } +sexp sexp_make_variable_transformer_op (sexp ctx, sexp self, sexp_sint_t n, sexp base_proc) { + sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, base_proc); + if (sexp_procedure_variable_transformer_p(base_proc)) + return base_proc; + sexp vt_proc = sexp_alloc_type(ctx, procedure, SEXP_PROCEDURE); + sexp_procedure_flags(vt_proc) = (char) (sexp_uint_t) sexp_make_fixnum (sexp_unbox_fixnum(sexp_procedure_flags(base_proc)) | SEXP_PROC_VARIABLE_TRANSFORMER); + sexp_procedure_num_args(vt_proc) = sexp_procedure_num_args(base_proc); + sexp_procedure_code(vt_proc) = sexp_procedure_code(base_proc); + sexp_procedure_vars(vt_proc) = sexp_procedure_vars(base_proc); + return vt_proc; +} + sexp sexp_make_synclo_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp fv, sexp expr) { sexp res; sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); @@ -766,6 +778,22 @@ static sexp analyze_seq (sexp ctx, sexp ls, int depth, int defok) { return res; } +static sexp analyze_macro_once (sexp ctx, sexp x, sexp op, int depth) { + sexp res; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); + tmp = sexp_cons(ctx, sexp_macro_env(op), SEXP_NULL); + tmp = sexp_cons(ctx, sexp_context_env(ctx), tmp); + tmp = sexp_cons(ctx, x, tmp); + res = sexp_exceptionp(tmp) ? tmp : sexp_make_child_context(ctx, sexp_context_lambda(ctx)); + if (!sexp_exceptionp(res) && !sexp_exceptionp(sexp_context_exception(ctx))) + res = sexp_apply(res, sexp_macro_proc(op), tmp); + if (sexp_exceptionp(res) && sexp_not(sexp_exception_source(x))) + sexp_exception_source(res) = sexp_pair_source(sexp_car(tmp)); + sexp_gc_release1(ctx); + return res; +} + static sexp analyze_var_ref (sexp ctx, sexp x, sexp *varenv) { sexp env = sexp_context_env(ctx), res; sexp_gc_var1(cell); @@ -783,31 +811,43 @@ static sexp analyze_var_ref (sexp ctx, sexp x, sexp *varenv) { return res; } -static sexp analyze_set (sexp ctx, sexp x, int depth) { +static sexp analyze_set (sexp ctx, sexp x, int depth, int defok) { sexp res, varenv; - sexp_gc_var2(ref, value); - sexp_gc_preserve2(ctx, ref, value); + sexp_gc_var4(ref, value, cell, op); + sexp_gc_preserve4(ctx, ref, value, cell, op); if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)) && sexp_nullp(sexp_cdddr(x)) && sexp_idp(sexp_cadr(x)))) { res = sexp_compile_error(ctx, "bad set! syntax", x); } else { - ref = analyze_var_ref(ctx, sexp_cadr(x), &varenv); - if (sexp_refp(ref) && sexp_lambdap(sexp_ref_loc(ref))) - sexp_insert(ctx, sexp_lambda_sv(sexp_ref_loc(ref)), sexp_ref_name(ref)); - value = analyze(ctx, sexp_caddr(x), depth, 0); - if (sexp_exceptionp(ref)) { - res = ref; - } else if (sexp_exceptionp(value)) { - res = value; - } else if (sexp_immutablep(sexp_ref_cell(ref)) - || (varenv && sexp_immutablep(varenv))) { - res = sexp_compile_error(ctx, "immutable binding", sexp_cadr(x)); + cell = sexp_env_cell(ctx, sexp_context_env(ctx), sexp_cadr(x), 0); + op = cell ? sexp_cdr(cell) : NULL; + if (op && sexp_macrop(op)) { + if (!sexp_procedure_variable_transformer_p(sexp_macro_proc(op))) { + res = sexp_compile_error(ctx, "can't mutate a syntax keyword", sexp_cadr(x)); + } else { + res = analyze_macro_once(ctx, x, op, depth); + if (!sexp_exceptionp(res)) + res = analyze(ctx, res, depth, defok); + } } else { - res = sexp_make_set(ctx, ref, value); - sexp_set_source(res) = sexp_pair_source(x); + ref = analyze_var_ref(ctx, sexp_cadr(x), &varenv); + if (sexp_refp(ref) && sexp_lambdap(sexp_ref_loc(ref))) + sexp_insert(ctx, sexp_lambda_sv(sexp_ref_loc(ref)), sexp_ref_name(ref)); + value = analyze(ctx, sexp_caddr(x), depth, 0); + if (sexp_exceptionp(ref)) { + res = ref; + } else if (sexp_exceptionp(value)) { + res = value; + } else if (sexp_immutablep(sexp_ref_cell(ref)) + || (varenv && sexp_immutablep(varenv))) { + res = sexp_compile_error(ctx, "immutable binding", sexp_cadr(x)); + } else { + res = sexp_make_set(ctx, ref, value); + sexp_set_source(res) = sexp_pair_source(x); + } } } - sexp_gc_release2(ctx); + sexp_gc_release4(ctx); return res; } @@ -1051,22 +1091,6 @@ static sexp analyze_letrec_syntax (sexp ctx, sexp x, int depth) { return analyze_let_syntax_aux(ctx, x, 1, depth); } -static sexp analyze_macro_once (sexp ctx, sexp x, sexp op, int depth) { - sexp res; - sexp_gc_var1(tmp); - sexp_gc_preserve1(ctx, tmp); - tmp = sexp_cons(ctx, sexp_macro_env(op), SEXP_NULL); - tmp = sexp_cons(ctx, sexp_context_env(ctx), tmp); - tmp = sexp_cons(ctx, x, tmp); - res = sexp_exceptionp(tmp) ? tmp : sexp_make_child_context(ctx, sexp_context_lambda(ctx)); - if (!sexp_exceptionp(res) && !sexp_exceptionp(sexp_context_exception(ctx))) - res = sexp_apply(res, sexp_macro_proc(op), tmp); - if (sexp_exceptionp(res) && sexp_not(sexp_exception_source(x))) - sexp_exception_source(res) = sexp_pair_source(sexp_car(tmp)); - sexp_gc_release1(ctx); - return res; -} - static sexp analyze (sexp ctx, sexp object, int depth, int defok) { sexp op; sexp_gc_var4(res, tmp, x, cell); @@ -1100,7 +1124,7 @@ static sexp analyze (sexp ctx, sexp object, int depth, int defok) { : sexp_compile_error(ctx, "unexpected define", x); break; case SEXP_CORE_SET: - res = analyze_set(ctx, x, depth); break; + res = analyze_set(ctx, x, depth, defok); break; case SEXP_CORE_LAMBDA: res = analyze_lambda(ctx, x, depth); break; case SEXP_CORE_IF: diff --git a/include/chibi/eval.h b/include/chibi/eval.h index ebbad05d..bbd905cf 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -128,6 +128,7 @@ SEXP_API sexp sexp_warn_undefs_op (sexp ctx, sexp self, sexp_sint_t n, sexp from SEXP_API sexp sexp_make_lit (sexp ctx, sexp value); SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1); SEXP_API sexp sexp_make_procedure_op (sexp ctx, sexp self, sexp_sint_t n, sexp flags, sexp num_args, sexp bc, sexp vars); +SEXP_API sexp sexp_make_variable_transformer_op (sexp ctx, sexp self, sexp_sint_t n, sexp base_proc); SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args, int flags, const char *fname, sexp_proc1 f, sexp data); SEXP_API sexp sexp_register_optimization(sexp ctx, sexp self, sexp_sint_t n, sexp f, sexp i); #if SEXP_USE_AUTO_FORCE diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 86435616..3a06fce5 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -270,6 +270,7 @@ typedef int sexp_sint_t; #define SEXP_PROC_NONE ((sexp_uint_t)0) #define SEXP_PROC_VARIADIC ((sexp_uint_t)1) #define SEXP_PROC_UNUSED_REST ((sexp_uint_t)2) +#define SEXP_PROC_VARIABLE_TRANSFORMER ((sexp_uint_t)4) #ifdef SEXP_USE_INTTYPES @@ -1146,6 +1147,7 @@ SEXP_API unsigned long long sexp_bignum_to_uint(sexp x); #define sexp_procedure_flags(x) (sexp_field(x, procedure, SEXP_PROCEDURE, flags)) #define sexp_procedure_variadic_p(x) (sexp_unbox_fixnum(sexp_procedure_flags(x)) & SEXP_PROC_VARIADIC) #define sexp_procedure_unused_rest_p(x) (sexp_unbox_fixnum(sexp_procedure_flags(x)) & SEXP_PROC_UNUSED_REST) +#define sexp_procedure_variable_transformer_p(x) (sexp_unbox_fixnum(sexp_procedure_flags(x)) & SEXP_PROC_VARIABLE_TRANSFORMER) #define sexp_procedure_code(x) (sexp_field(x, procedure, SEXP_PROCEDURE, bc)) #define sexp_procedure_vars(x) (sexp_field(x, procedure, SEXP_PROCEDURE, vars)) #define sexp_procedure_source(x) sexp_bytecode_source(sexp_procedure_code(x)) diff --git a/opcodes.c b/opcodes.c index 552fc698..fc66db3e 100644 --- a/opcodes.c +++ b/opcodes.c @@ -197,6 +197,7 @@ _FN2(_I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_NULL, "memq", 0, sexp_memq_op), _FN2(_I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_NULL, "assq", 0, sexp_assq_op), _FN3(_I(SEXP_SYNCLO), _I(SEXP_ENV), SEXP_NULL, _I(SEXP_OBJECT), "make-syntactic-closure", 0, sexp_make_synclo_op), _FN1(_I(SEXP_OBJECT), _I(SEXP_OBJECT), "strip-syntactic-closures", 0, sexp_strip_synclos), +_FN1(_I(SEXP_PROCEDURE), _I(SEXP_PROCEDURE), "make-variable-transformer", 0, sexp_make_variable_transformer_op), _FN0(_I(SEXP_OPORT), "open-output-string", 0, sexp_open_output_string_op), _FN1(_I(SEXP_IPORT), _I(SEXP_STRING), "open-input-string", 0, sexp_open_input_string_op), _FN1(_I(SEXP_STRING), _I(SEXP_OPORT), "get-output-string", 0, sexp_get_output_string_op), diff --git a/sexp.c b/sexp.c index 2fbdb2f1..4da3b01a 100644 --- a/sexp.c +++ b/sexp.c @@ -2190,6 +2190,8 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out, sexp_sint_t bound) { #endif case SEXP_PROCEDURE: sexp_write_string(ctx, "# Date: Thu, 30 Dec 2021 10:58:26 +0100 Subject: [PATCH 04/22] Support identifier-syntax in (chibi syntax-case) --- lib/chibi/ast.c | 6 ++++++ lib/chibi/ast.sld | 3 ++- lib/chibi/syntax-case.scm | 27 ++++++++++++++++++++++++--- lib/chibi/syntax-case.sld | 9 ++++++--- 4 files changed, 38 insertions(+), 7 deletions(-) diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c index e14f65b9..ab952197 100644 --- a/lib/chibi/ast.c +++ b/lib/chibi/ast.c @@ -98,6 +98,11 @@ sexp sexp_get_procedure_variadic_p (sexp ctx, sexp self, sexp_sint_t n, sexp pro return sexp_make_boolean(sexp_procedure_variadic_p(proc)); } +sexp sexp_get_procedure_variable_transformer_p (sexp ctx, sexp self, sexp_sint_t n, sexp proc) { + sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc); + return sexp_make_boolean(sexp_procedure_variable_transformer_p(proc)); +} + sexp sexp_get_procedure_flags (sexp ctx, sexp self, sexp_sint_t n, sexp proc) { sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc); return sexp_make_fixnum(sexp_procedure_flags(proc)); @@ -694,6 +699,7 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char sexp_define_foreign(ctx, env, "procedure-vars", 1, sexp_get_procedure_vars); sexp_define_foreign(ctx, env, "procedure-arity", 1, sexp_get_procedure_arity); sexp_define_foreign(ctx, env, "procedure-variadic?", 1, sexp_get_procedure_variadic_p); + sexp_define_foreign(ctx, env, "procedure-variable-transformer?", 1, sexp_get_procedure_variable_transformer_p); sexp_define_foreign(ctx, env, "procedure-flags", 1, sexp_get_procedure_flags); sexp_define_foreign(ctx, env, "copy-lambda", 1, sexp_copy_lambda); sexp_define_foreign_opt(ctx, env, "make-lambda", 4, sexp_make_lambda_op, SEXP_NULL); diff --git a/lib/chibi/ast.sld b/lib/chibi/ast.sld index 6d6fef66..8cbcd0af 100644 --- a/lib/chibi/ast.sld +++ b/lib/chibi/ast.sld @@ -28,7 +28,8 @@ opcode-class opcode-code opcode-data opcode-variadic? macro-procedure macro-env macro-source macro-aux macro-aux-set! procedure-code procedure-vars procedure-name procedure-name-set! - procedure-arity procedure-variadic? procedure-flags make-procedure + procedure-arity procedure-variadic? procedure-variable-transformer? + procedure-flags make-procedure bytecode-name bytecode-literals bytecode-source port-line port-line-set! port-source? port-source?-set! extend-env env-parent env-parent-set! env-lambda env-lambda-set! diff --git a/lib/chibi/syntax-case.scm b/lib/chibi/syntax-case.scm index 45a7065b..772ade43 100644 --- a/lib/chibi/syntax-case.scm +++ b/lib/chibi/syntax-case.scm @@ -1,7 +1,5 @@ ;; Written by Marc Nieper-Wißkirchen -;; TODO: make-variable-transformer and identifier-syntax. - ;; TODO: make-synthetic-identifier should return a truly unique (that ;; is not free-identifier=? to any other) identifier. @@ -16,7 +14,7 @@ (let ((env (or (current-usage-environment) (current-environment)))) (identifier=? env x env y))) -(define (make-transformer transformer) +(define (%make-transformer transformer) (cond ((and (= 1 (procedure-arity transformer)) (not (procedure-variadic? transformer))) @@ -40,6 +38,12 @@ (current-renamer old-renamer) result)))))) +(define (make-transformer base-transformer) + (let ((wrapped-transformer (%make-transformer base-transformer))) + (if (procedure-variable-transformer? base-transformer) + (make-variable-transformer wrapped-transformer) + wrapped-transformer))) + (%define-syntax define-syntax (lambda (expr use-env mac-env) (list (close-syntax '%define-syntax mac-env) @@ -377,6 +381,23 @@ (define-current-ellipsis ellipsis) . body)))))) +;; identifier-syntax definition from R6RS Libraries section 12.9 +(define-syntax identifier-syntax + (syntax-rules (set!) + ((_ e) + (lambda (x) + (syntax-case x () + (id (identifier? #'id) #'e) + ((_ x (... ...)) #'(e x (... ...)))))) + ((_ (id exp1) ((set! var val) exp2)) + #;(and (identifier? #'id) (identifier? #'var)) + (make-variable-transformer + (lambda (x) + (syntax-case x (set!) + ((set! var val) #'exp2) + ((id x (... ...)) #'(exp1 x (... ...))) + (id (identifier? #'id) #'exp1))))))) + ;; 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 0033d735..11a24ee7 100644 --- a/lib/chibi/syntax-case.sld +++ b/lib/chibi/syntax-case.sld @@ -4,14 +4,17 @@ datum->syntax syntax->datum generate-temporaries with-syntax syntax-violation with-ellipsis ellipsis-identifier? - define-syntax let-syntax letrec-syntax) + define-syntax let-syntax letrec-syntax + make-variable-transformer identifier-syntax) (import (rename (chibi) (define-syntax %define-syntax) (let-syntax %let-syntax) - (letrec-syntax %letrec-syntax)) + (letrec-syntax %letrec-syntax) + make-variable-transformer) (only (chibi ast) env-cell macro? macro-aux macro-aux-set! - procedure-arity procedure-variadic?) + procedure-arity procedure-variadic? + procedure-variable-transformer?) (only (meta) environment) (srfi 1) (srfi 11) From 83f61aecd22a95541ecacdbcb2f6fe466bab3712 Mon Sep 17 00:00:00 2001 From: Daphne Preston-Kendal Date: Thu, 30 Dec 2021 11:18:39 +0100 Subject: [PATCH 05/22] Document the addition of identifier macros --- doc/chibi.scrbl | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/doc/chibi.scrbl b/doc/chibi.scrbl index a673c52b..9c89e46e 100755 --- a/doc/chibi.scrbl +++ b/doc/chibi.scrbl @@ -261,6 +261,15 @@ introduction to syntactic-closures can be found at \scheme{make-syntactic-closure} and \scheme{strip-syntactic-closures} are also available. +Variable transformers and identifier macros are also supported: macros +created with \scheme{sc-macro-transformer} and \scheme{rsc-macro-transformer} +can match an identifier outside of operator position, and a special +\scheme{er-macro-transformer*} form is provided, otherwise identical +to the usual \scheme{er-macro-transformer}, which can do the same. +\scheme{make-variable-transformer} can be used to create transformer +procedures which expand an instance of \scheme{set!} with their syntax +keywords as their first argument. + \subsection{Types} You can define new record types with From f63348a4d1a6016349a38a2f3c06d1b731203e36 Mon Sep 17 00:00:00 2001 From: Daphne Preston-Kendal Date: Sun, 2 Jan 2022 08:06:38 +0100 Subject: [PATCH 06/22] Iteratively expand variable-transformer set! --- eval.c | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/eval.c b/eval.c index 6b7dd202..6c9ada77 100644 --- a/eval.c +++ b/eval.c @@ -811,7 +811,7 @@ static sexp analyze_var_ref (sexp ctx, sexp x, sexp *varenv) { return res; } -static sexp analyze_set (sexp ctx, sexp x, int depth, int defok) { +static sexp analyze_set (sexp ctx, sexp x, int depth) { sexp res, varenv; sexp_gc_var4(ref, value, cell, op); sexp_gc_preserve4(ctx, ref, value, cell, op); @@ -826,8 +826,6 @@ static sexp analyze_set (sexp ctx, sexp x, int depth, int defok) { res = sexp_compile_error(ctx, "can't mutate a syntax keyword", sexp_cadr(x)); } else { res = analyze_macro_once(ctx, x, op, depth); - if (!sexp_exceptionp(res)) - res = analyze(ctx, res, depth, defok); } } else { ref = analyze_var_ref(ctx, sexp_cadr(x), &varenv); @@ -1124,7 +1122,12 @@ static sexp analyze (sexp ctx, sexp object, int depth, int defok) { : sexp_compile_error(ctx, "unexpected define", x); break; case SEXP_CORE_SET: - res = analyze_set(ctx, x, depth, defok); break; + x = analyze_set(ctx, x, depth); + if (!sexp_exceptionp(x) && !sexp_setp(x)) + goto loop; + else + res = x; + break; case SEXP_CORE_LAMBDA: res = analyze_lambda(ctx, x, depth); break; case SEXP_CORE_IF: From f32d89175cf22b3d8ca7cdd281d25830514b7ad6 Mon Sep 17 00:00:00 2001 From: Daphne Preston-Kendal Date: Sun, 2 Jan 2022 09:37:37 +0100 Subject: [PATCH 07/22] Typo fix. [skip ci] --- lib/init-7.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/init-7.scm b/lib/init-7.scm index a8c88a74..d465bbbb 100644 --- a/lib/init-7.scm +++ b/lib/init-7.scm @@ -155,7 +155,7 @@ (er-macro-transformer* (lambda (expr rename compare) (if (not (pair? expr)) - (error "invalid use of non-identifier macro outside operator postion" expr) + (error "invalid use of non-identifier macro outside operator position" expr) (f expr rename compare)))))) (define-syntax cond From eb8582f5b1bd9402b9708b26498c99d1d4faa7e3 Mon Sep 17 00:00:00 2001 From: Daphne Preston-Kendal Date: Mon, 3 Jan 2022 08:28:40 +0100 Subject: [PATCH 08/22] Use sexp_make_procedure to sexp_make_variable_transformer_op --- eval.c | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/eval.c b/eval.c index 6c9ada77..d7e0bc93 100644 --- a/eval.c +++ b/eval.c @@ -400,15 +400,15 @@ static sexp sexp_make_macro (sexp ctx, sexp p, sexp e) { } sexp sexp_make_variable_transformer_op (sexp ctx, sexp self, sexp_sint_t n, sexp base_proc) { + sexp flags; sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, base_proc); if (sexp_procedure_variable_transformer_p(base_proc)) return base_proc; - sexp vt_proc = sexp_alloc_type(ctx, procedure, SEXP_PROCEDURE); - sexp_procedure_flags(vt_proc) = (char) (sexp_uint_t) sexp_make_fixnum (sexp_unbox_fixnum(sexp_procedure_flags(base_proc)) | SEXP_PROC_VARIABLE_TRANSFORMER); - sexp_procedure_num_args(vt_proc) = sexp_procedure_num_args(base_proc); - sexp_procedure_code(vt_proc) = sexp_procedure_code(base_proc); - sexp_procedure_vars(vt_proc) = sexp_procedure_vars(base_proc); - return vt_proc; + flags = sexp_make_fixnum(sexp_unbox_fixnum(sexp_procedure_flags(base_proc)) | SEXP_PROC_VARIABLE_TRANSFORMER); + return sexp_make_procedure(ctx, flags, + sexp_make_fixnum(sexp_procedure_num_args(base_proc)), + sexp_procedure_code(base_proc), + sexp_procedure_vars(base_proc)); } sexp sexp_make_synclo_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp fv, sexp expr) { From d769a7970c4b54a7c95451fda5493d3ee6990577 Mon Sep 17 00:00:00 2001 From: Daphne Preston-Kendal Date: Mon, 3 Jan 2022 09:50:07 +0100 Subject: [PATCH 09/22] Wrap identifier-syntax output in make-transformer --- lib/chibi/syntax-case.scm | 20 +++++++++++++------- 1 file changed, 13 insertions(+), 7 deletions(-) diff --git a/lib/chibi/syntax-case.scm b/lib/chibi/syntax-case.scm index 772ade43..45811109 100644 --- a/lib/chibi/syntax-case.scm +++ b/lib/chibi/syntax-case.scm @@ -381,22 +381,28 @@ (define-current-ellipsis ellipsis) . body)))))) -;; identifier-syntax definition from R6RS Libraries section 12.9 +;; identifier-syntax adapted from R6RS Libraries section 12.9 +;; (changes: use only round brackets; can't use fenders in Chibi +;; syntax-rules; wrap the transformer procedures in make-transformer +;; so they can be used in Chibi anywhere a syntax transformer is +;; used, not just in {define,let,letrec}-syntax) (define-syntax identifier-syntax (syntax-rules (set!) ((_ e) - (lambda (x) - (syntax-case x () - (id (identifier? #'id) #'e) - ((_ x (... ...)) #'(e x (... ...)))))) + (make-transformer + (lambda (x) + (syntax-case x () + (id (identifier? #'id) #'e) + ((_ x (... ...)) #'(e x (... ...))))))) ((_ (id exp1) ((set! var val) exp2)) #;(and (identifier? #'id) (identifier? #'var)) - (make-variable-transformer + (make-transformer + (make-variable-transformer (lambda (x) (syntax-case x (set!) ((set! var val) #'exp2) ((id x (... ...)) #'(exp1 x (... ...))) - (id (identifier? #'id) #'exp1))))))) + (id (identifier? #'id) #'exp1)))))))) ;; Local variables: ;; eval: (put '%define-syntax 'scheme-indent-function 1) From d55d6c619c23c46a9c18b148f2702d283f55d1ea Mon Sep 17 00:00:00 2001 From: Daphne Preston-Kendal Date: Tue, 1 Feb 2022 11:57:59 +0100 Subject: [PATCH 10/22] Implement identifier-syntax in init-7.scm --- lib/init-7.scm | 71 +++++++++++++++++++++++++++++++++++++++++--------- 1 file changed, 59 insertions(+), 12 deletions(-) diff --git a/lib/init-7.scm b/lib/init-7.scm index d465bbbb..4eeee6c4 100644 --- a/lib/init-7.scm +++ b/lib/init-7.scm @@ -849,12 +849,12 @@ (lambda () (current-output-port old-out))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; syntax-rules +;; syntax-rules and identifier-syntax -(define (syntax-rules-transformer expr rename compare) - (let ((ellipsis-specified? (identifier? (cadr expr))) - (count 0) +(define (syntax-template-transformer rename compare id-syntax? ellipsis ellipsis-specified? lits forms) + (let ((count 0) (_er-macro-transformer (rename 'er-macro-transformer)) + (_er-macro-transformer* (rename 'er-macro-transformer*)) (_lambda (rename 'lambda)) (_let (rename 'let)) (_begin (rename 'begin)) (_if (rename 'if)) (_and (rename 'and)) (_or (rename 'or)) @@ -874,15 +874,12 @@ (_list->vector (rename 'list->vector)) (_cons3 (rename 'cons-source)) (_underscore (rename '_))) - (define ellipsis (if ellipsis-specified? (cadr expr) (rename '...))) - (define lits (if ellipsis-specified? (car (cddr expr)) (cadr expr))) - (define forms (if ellipsis-specified? (cdr (cddr expr)) (cddr expr))) (define (next-symbol s) (set! count (+ count 1)) (rename (string->symbol (string-append s (%number->string count))))) (define (expand-pattern pat tmpl) - (let lp ((p (cdr pat)) - (x (list _cdr _expr)) + (let lp ((p (if id-syntax? pat (cdr pat))) + (x (if id-syntax? _expr (list _cdr _expr))) (dim 0) (vars '()) (k (lambda (vars) @@ -1072,7 +1069,7 @@ ((null? t) (list _quote '())) (else t)))) (list - _er-macro-transformer + (if id-syntax? _er-macro-transformer* _er-macro-transformer) (list _lambda (list _expr _rename _compare) (list _car @@ -1083,7 +1080,7 @@ (lambda (clause) (if (and (list? clause) (= (length clause) 2)) (expand-pattern (car clause) (cadr clause)) - (error "invalid syntax-rules clause, which must be of the form (pattern template) (note fenders are not supported)" + (error "invalid syntax template clause, which must be of the form (pattern template) (note fenders are not supported)" clause))) forms) (list @@ -1095,7 +1092,57 @@ (define-syntax syntax-rules (er-macro-transformer (lambda (expr rename compare) - (syntax-rules-transformer expr rename compare)))) + (let ((ellipsis-specified? (identifier? (cadr expr)))) + (let ((ellipsis (if ellipsis-specified? (cadr expr) (rename '...))) + (lits (if ellipsis-specified? (car (cddr expr)) (cadr expr))) + (forms (if ellipsis-specified? (cdr (cddr expr)) (cddr expr)))) + (syntax-template-transformer rename compare + #f + ellipsis ellipsis-specified? + lits forms)))))) + +(define-syntax identifier-syntax + (er-macro-transformer + (lambda (expr rename compare) + (let ((template (cadr expr)) + (_er-macro-transformer* (rename 'er-macro-transformer*)) + (_lambda (rename 'lambda)) (_expr (rename 'expr)) + (_rename (rename 'rename)) (_compare (rename 'compare)) + (_if (rename 'if)) (_pair? (rename 'pair?)) + (_cons (rename 'cons)) (_cdr (rename 'cdr)) + (_quote (rename 'syntax-quote)) + (_make-variable-transformer (rename 'make-variable-transformer)) + (_set! (rename 'set!)) (_o (rename 'o))) + (cond ((= (length expr) 2) + (list + _er-macro-transformer* + (list _lambda (list _expr _rename _compare) + (list _if (list _pair? _expr) + (list _cons + (list _quote template) + (list _cdr _expr)) + (list _quote template))))) + (else + (let* ((ellipsis-specified? (identifier? (cadr expr))) + (ellipsis (if ellipsis-specified? (cadr expr) (rename '...))) + (forms (if ellipsis-specified? (cddr expr) (cdr expr)))) + (if (not (and (= (length forms) 2) + (identifier? (caar forms)) + (compare (caar (cadr forms)) _set!) + (identifier? (car (cdar (cadr forms)))))) + (error "invalid identifier-syntax clauses" forms) + (list + _make-variable-transformer + (syntax-template-transformer + rename compare + #t + ellipsis ellipsis-specified? + (list _set!) + (list (cadr forms) + (list + (cons (caar forms) _o) + (cons (cadr (car forms)) _o)) + (car forms)))))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; let(rec)-syntax and datum->syntax From bddbdc801d2fba87a221527930f8680461d6e0e0 Mon Sep 17 00:00:00 2001 From: Daphne Preston-Kendal Date: Tue, 1 Feb 2022 13:25:53 +0100 Subject: [PATCH 11/22] Use the exact set! syntactic-closure from the identifier-syntax form MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Without this, set! isn’t recognized correctly as a literal and the set! form erroneously matches any application form with two arguments --- lib/init-7.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/init-7.scm b/lib/init-7.scm index 4eeee6c4..184cf17f 100644 --- a/lib/init-7.scm +++ b/lib/init-7.scm @@ -1137,7 +1137,7 @@ rename compare #t ellipsis ellipsis-specified? - (list _set!) + (list (caar (cadr forms))) (list (cadr forms) (list (cons (caar forms) _o) From aef1a1b3589af9ff8ed911727438bfb8add2724b Mon Sep 17 00:00:00 2001 From: Daphne Preston-Kendal Date: Tue, 1 Feb 2022 13:46:18 +0100 Subject: [PATCH 12/22] Use a less confusing term in the error message for invalid clauses MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Since ‘template’ is technically the second part --- lib/init-7.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/init-7.scm b/lib/init-7.scm index 184cf17f..5e78af65 100644 --- a/lib/init-7.scm +++ b/lib/init-7.scm @@ -1080,7 +1080,7 @@ (lambda (clause) (if (and (list? clause) (= (length clause) 2)) (expand-pattern (car clause) (cadr clause)) - (error "invalid syntax template clause, which must be of the form (pattern template) (note fenders are not supported)" + (error "invalid syntax rule, which must be of the form (pattern template) (note fenders are not supported)" clause))) forms) (list From d6b13db5039d8e7ba8c96f6c151242cb5287b02e Mon Sep 17 00:00:00 2001 From: Daphne Preston-Kendal Date: Fri, 4 Feb 2022 10:33:37 +0100 Subject: [PATCH 13/22] Attempt to improve readability of syntax-template-transformer uses Lipstick on a pig, but seems to be the best option available --- lib/init-7.scm | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/lib/init-7.scm b/lib/init-7.scm index 5e78af65..c84b1ce0 100644 --- a/lib/init-7.scm +++ b/lib/init-7.scm @@ -1097,7 +1097,7 @@ (lits (if ellipsis-specified? (car (cddr expr)) (cadr expr))) (forms (if ellipsis-specified? (cdr (cddr expr)) (cddr expr)))) (syntax-template-transformer rename compare - #f + #f ; not id-syntax? ellipsis ellipsis-specified? lits forms)))))) @@ -1135,14 +1135,17 @@ _make-variable-transformer (syntax-template-transformer rename compare - #t + #t ; id-syntax? ellipsis ellipsis-specified? - (list (caar (cadr forms))) - (list (cadr forms) - (list - (cons (caar forms) _o) - (cons (cadr (car forms)) _o)) - (car forms)))))))))))) + (list ; lits, i.e. (set!) + (caar (cadr forms))) + (list ; forms + (cadr forms) ; set! form + (list ; application form + (cons (caar forms) _o) + (cons (cadr (car forms)) _o)) + (car forms)) ; bare identifier form + )))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; let(rec)-syntax and datum->syntax From 51b0203dc5ac53ffac0dbe7caf79b3f28ecf6b1d Mon Sep 17 00:00:00 2001 From: Daphne Preston-Kendal Date: Fri, 4 Feb 2022 10:35:11 +0100 Subject: [PATCH 14/22] =?UTF-8?q?Ditch=20the=20syntax-case=20version=20of?= =?UTF-8?q?=20identifier-syntax=20now=20it=E2=80=99s=20in=20core?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- lib/chibi/syntax-case.scm | 23 ----------------------- lib/chibi/syntax-case.sld | 3 +-- 2 files changed, 1 insertion(+), 25 deletions(-) diff --git a/lib/chibi/syntax-case.scm b/lib/chibi/syntax-case.scm index 45811109..db66689c 100644 --- a/lib/chibi/syntax-case.scm +++ b/lib/chibi/syntax-case.scm @@ -381,29 +381,6 @@ (define-current-ellipsis ellipsis) . body)))))) -;; identifier-syntax adapted from R6RS Libraries section 12.9 -;; (changes: use only round brackets; can't use fenders in Chibi -;; syntax-rules; wrap the transformer procedures in make-transformer -;; so they can be used in Chibi anywhere a syntax transformer is -;; used, not just in {define,let,letrec}-syntax) -(define-syntax identifier-syntax - (syntax-rules (set!) - ((_ e) - (make-transformer - (lambda (x) - (syntax-case x () - (id (identifier? #'id) #'e) - ((_ x (... ...)) #'(e x (... ...))))))) - ((_ (id exp1) ((set! var val) exp2)) - #;(and (identifier? #'id) (identifier? #'var)) - (make-transformer - (make-variable-transformer - (lambda (x) - (syntax-case x (set!) - ((set! var val) #'exp2) - ((id x (... ...)) #'(exp1 x (... ...))) - (id (identifier? #'id) #'exp1)))))))) - ;; 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 11a24ee7..1b8f261e 100644 --- a/lib/chibi/syntax-case.sld +++ b/lib/chibi/syntax-case.sld @@ -4,8 +4,7 @@ datum->syntax syntax->datum generate-temporaries with-syntax syntax-violation with-ellipsis ellipsis-identifier? - define-syntax let-syntax letrec-syntax - make-variable-transformer identifier-syntax) + define-syntax let-syntax letrec-syntax) (import (rename (chibi) (define-syntax %define-syntax) (let-syntax %let-syntax) From 920ba20a8c839a47d614c094b252b875b1fc2c3b Mon Sep 17 00:00:00 2001 From: Daphne Preston-Kendal Date: Fri, 4 Feb 2022 11:00:27 +0100 Subject: [PATCH 15/22] Document the addition of identifier-syntax to core [skip ci] --- doc/chibi.scrbl | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/doc/chibi.scrbl b/doc/chibi.scrbl index 9c89e46e..304fd48a 100755 --- a/doc/chibi.scrbl +++ b/doc/chibi.scrbl @@ -261,11 +261,12 @@ introduction to syntactic-closures can be found at \scheme{make-syntactic-closure} and \scheme{strip-syntactic-closures} are also available. -Variable transformers and identifier macros are also supported: macros -created with \scheme{sc-macro-transformer} and \scheme{rsc-macro-transformer} -can match an identifier outside of operator position, and a special -\scheme{er-macro-transformer*} form is provided, otherwise identical -to the usual \scheme{er-macro-transformer}, which can do the same. +Identifier macros are also supported with \scheme{identifier-syntax}. +Low-level macros created with \scheme{sc-macro-transformer} and +\scheme{rsc-macro-transformer} can expand as identifiers outside of +operator position, and a special \scheme{er-macro-transformer*} form +is provided, otherwise identical to the usual +\scheme{er-macro-transformer}, which can do the same. \scheme{make-variable-transformer} can be used to create transformer procedures which expand an instance of \scheme{set!} with their syntax keywords as their first argument. From abda243d21e6565b0db406ae43c59876518c3fb4 Mon Sep 17 00:00:00 2001 From: Daphne Preston-Kendal Date: Fri, 4 Feb 2022 11:28:31 +0100 Subject: [PATCH 16/22] Add identifier macro tests to syntax-test.scm --- tests/syntax-tests.scm | 76 +++++++++++++++++++++++++++++++++++++++++- 1 file changed, 75 insertions(+), 1 deletion(-) diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm index 5ee429fc..5eeca5e7 100644 --- a/tests/syntax-tests.scm +++ b/tests/syntax-tests.scm @@ -1,6 +1,9 @@ (cond-expand - (modules (import (chibi) (only (chibi test) test-begin test test-end))) + (modules + (import (chibi) + (only (chibi test) test-begin test test-error test-end) + (only (meta) environment))) (else #f)) (test-begin "syntax") @@ -75,3 +78,74 @@ (test '(2 1) (asd 1 2))) (test-end) + +(cond-expand + ;; can only test identifier-syntax with access to modules (though + ;; this could be fixed in theory) + (modules + (test-begin "identifier syntax") + (define syntax-test-env (environment '(chibi))) + + (eval + '(define-syntax low-level-id-macro + (er-macro-transformer* + (lambda (expr rename compare) + (if (pair? expr) + (list (rename 'quote) 'operator) + (list (rename 'quote) 'operand))))) + syntax-test-env) + + (test 'operator (eval '(low-level-id-macro) syntax-test-env)) + (test 'operand (eval 'low-level-id-macro syntax-test-env)) + (test-error (eval '(set! low-level-id-macro 'foo) syntax-test-env)) + + (eval + '(define-syntax low-level-vt + (make-variable-transformer + (er-macro-transformer* + (lambda (expr rename compare) + (list (rename 'quote) + (if (pair? expr) + (if (compare (car expr) (rename 'set!)) + 'set + 'app) + 'ref)))))) + syntax-test-env) + + (test 'set (eval '(set! low-level-vt 'foo) syntax-test-env)) + (test 'app (eval '(low-level-vt) syntax-test-env)) + (test 'ref (eval 'low-level-vt syntax-test-env)) + + (eval '(define p (cons 1 2)) syntax-test-env) + (eval '(define-syntax p.car (identifier-syntax (car p))) syntax-test-env) + (eval + '(define-syntax p.cdr + (identifier-syntax + (_ (cdr p)) + ((set! _ v) (set-cdr! p v)))) + syntax-test-env) + + (test 1 (eval 'p.car syntax-test-env)) + (test-error (eval '(set! p.car 0) syntax-test-env)) + (test 2 (eval 'p.cdr syntax-test-env)) + (test 3 (eval + '(begin + (set! p.cdr 3) + (cdr p)) + syntax-test-env)) + + ;; weirdnesses: syntax that refers to its own name and uses ellipsis + (eval + '(define-syntax sr-id-macro + (identifier-syntax + (name 'name) + ((set! name (val ...)) (cons 'name '(val ...))))) + syntax-test-env) + + (test 'sr-id-macro (eval 'sr-id-macro syntax-test-env)) + (test '(sr-id-macro 1 2 3) + (eval '(set! sr-id-macro (1 2 3)) + syntax-test-env)) + + (test-end)) + (else #f)) From 70455ed3f8ae3423d4403351558476197e090447 Mon Sep 17 00:00:00 2001 From: Daphne Preston-Kendal Date: Tue, 15 Mar 2022 09:07:11 +0100 Subject: [PATCH 17/22] Revert "Implement identifier-syntax in init-7.scm" This reverts commit d55d6c619c23c46a9c18b148f2702d283f55d1ea. --- lib/init-7.scm | 74 ++++++++------------------------------------------ 1 file changed, 12 insertions(+), 62 deletions(-) diff --git a/lib/init-7.scm b/lib/init-7.scm index c84b1ce0..d465bbbb 100644 --- a/lib/init-7.scm +++ b/lib/init-7.scm @@ -849,12 +849,12 @@ (lambda () (current-output-port old-out))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; syntax-rules and identifier-syntax +;; syntax-rules -(define (syntax-template-transformer rename compare id-syntax? ellipsis ellipsis-specified? lits forms) - (let ((count 0) +(define (syntax-rules-transformer expr rename compare) + (let ((ellipsis-specified? (identifier? (cadr expr))) + (count 0) (_er-macro-transformer (rename 'er-macro-transformer)) - (_er-macro-transformer* (rename 'er-macro-transformer*)) (_lambda (rename 'lambda)) (_let (rename 'let)) (_begin (rename 'begin)) (_if (rename 'if)) (_and (rename 'and)) (_or (rename 'or)) @@ -874,12 +874,15 @@ (_list->vector (rename 'list->vector)) (_cons3 (rename 'cons-source)) (_underscore (rename '_))) + (define ellipsis (if ellipsis-specified? (cadr expr) (rename '...))) + (define lits (if ellipsis-specified? (car (cddr expr)) (cadr expr))) + (define forms (if ellipsis-specified? (cdr (cddr expr)) (cddr expr))) (define (next-symbol s) (set! count (+ count 1)) (rename (string->symbol (string-append s (%number->string count))))) (define (expand-pattern pat tmpl) - (let lp ((p (if id-syntax? pat (cdr pat))) - (x (if id-syntax? _expr (list _cdr _expr))) + (let lp ((p (cdr pat)) + (x (list _cdr _expr)) (dim 0) (vars '()) (k (lambda (vars) @@ -1069,7 +1072,7 @@ ((null? t) (list _quote '())) (else t)))) (list - (if id-syntax? _er-macro-transformer* _er-macro-transformer) + _er-macro-transformer (list _lambda (list _expr _rename _compare) (list _car @@ -1080,7 +1083,7 @@ (lambda (clause) (if (and (list? clause) (= (length clause) 2)) (expand-pattern (car clause) (cadr clause)) - (error "invalid syntax rule, which must be of the form (pattern template) (note fenders are not supported)" + (error "invalid syntax-rules clause, which must be of the form (pattern template) (note fenders are not supported)" clause))) forms) (list @@ -1092,60 +1095,7 @@ (define-syntax syntax-rules (er-macro-transformer (lambda (expr rename compare) - (let ((ellipsis-specified? (identifier? (cadr expr)))) - (let ((ellipsis (if ellipsis-specified? (cadr expr) (rename '...))) - (lits (if ellipsis-specified? (car (cddr expr)) (cadr expr))) - (forms (if ellipsis-specified? (cdr (cddr expr)) (cddr expr)))) - (syntax-template-transformer rename compare - #f ; not id-syntax? - ellipsis ellipsis-specified? - lits forms)))))) - -(define-syntax identifier-syntax - (er-macro-transformer - (lambda (expr rename compare) - (let ((template (cadr expr)) - (_er-macro-transformer* (rename 'er-macro-transformer*)) - (_lambda (rename 'lambda)) (_expr (rename 'expr)) - (_rename (rename 'rename)) (_compare (rename 'compare)) - (_if (rename 'if)) (_pair? (rename 'pair?)) - (_cons (rename 'cons)) (_cdr (rename 'cdr)) - (_quote (rename 'syntax-quote)) - (_make-variable-transformer (rename 'make-variable-transformer)) - (_set! (rename 'set!)) (_o (rename 'o))) - (cond ((= (length expr) 2) - (list - _er-macro-transformer* - (list _lambda (list _expr _rename _compare) - (list _if (list _pair? _expr) - (list _cons - (list _quote template) - (list _cdr _expr)) - (list _quote template))))) - (else - (let* ((ellipsis-specified? (identifier? (cadr expr))) - (ellipsis (if ellipsis-specified? (cadr expr) (rename '...))) - (forms (if ellipsis-specified? (cddr expr) (cdr expr)))) - (if (not (and (= (length forms) 2) - (identifier? (caar forms)) - (compare (caar (cadr forms)) _set!) - (identifier? (car (cdar (cadr forms)))))) - (error "invalid identifier-syntax clauses" forms) - (list - _make-variable-transformer - (syntax-template-transformer - rename compare - #t ; id-syntax? - ellipsis ellipsis-specified? - (list ; lits, i.e. (set!) - (caar (cadr forms))) - (list ; forms - (cadr forms) ; set! form - (list ; application form - (cons (caar forms) _o) - (cons (cadr (car forms)) _o)) - (car forms)) ; bare identifier form - )))))))))) + (syntax-rules-transformer expr rename compare)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; let(rec)-syntax and datum->syntax From 01bd50b6f1f65d9d2ff603c24e29291860069536 Mon Sep 17 00:00:00 2001 From: Daphne Preston-Kendal Date: Tue, 15 Mar 2022 09:07:17 +0100 Subject: [PATCH 18/22] Revert "Document the addition of identifier-syntax to core" This reverts commit 920ba20a8c839a47d614c094b252b875b1fc2c3b. --- doc/chibi.scrbl | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/doc/chibi.scrbl b/doc/chibi.scrbl index 304fd48a..9c89e46e 100755 --- a/doc/chibi.scrbl +++ b/doc/chibi.scrbl @@ -261,12 +261,11 @@ introduction to syntactic-closures can be found at \scheme{make-syntactic-closure} and \scheme{strip-syntactic-closures} are also available. -Identifier macros are also supported with \scheme{identifier-syntax}. -Low-level macros created with \scheme{sc-macro-transformer} and -\scheme{rsc-macro-transformer} can expand as identifiers outside of -operator position, and a special \scheme{er-macro-transformer*} form -is provided, otherwise identical to the usual -\scheme{er-macro-transformer}, which can do the same. +Variable transformers and identifier macros are also supported: macros +created with \scheme{sc-macro-transformer} and \scheme{rsc-macro-transformer} +can match an identifier outside of operator position, and a special +\scheme{er-macro-transformer*} form is provided, otherwise identical +to the usual \scheme{er-macro-transformer}, which can do the same. \scheme{make-variable-transformer} can be used to create transformer procedures which expand an instance of \scheme{set!} with their syntax keywords as their first argument. From 7a4e793e490b2a44ecbb9ab07e1838cb04ed243d Mon Sep 17 00:00:00 2001 From: Daphne Preston-Kendal Date: Tue, 15 Mar 2022 09:25:21 +0100 Subject: [PATCH 19/22] Move make-variable-transformer to (chibi ast) --- eval.c | 12 ------------ include/chibi/eval.h | 1 - lib/chibi/ast.c | 13 +++++++++++++ lib/chibi/ast.sld | 2 +- opcodes.c | 1 - 5 files changed, 14 insertions(+), 15 deletions(-) diff --git a/eval.c b/eval.c index d7e0bc93..017abf6f 100644 --- a/eval.c +++ b/eval.c @@ -399,18 +399,6 @@ static sexp sexp_make_macro (sexp ctx, sexp p, sexp e) { return mac; } -sexp sexp_make_variable_transformer_op (sexp ctx, sexp self, sexp_sint_t n, sexp base_proc) { - sexp flags; - sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, base_proc); - if (sexp_procedure_variable_transformer_p(base_proc)) - return base_proc; - flags = sexp_make_fixnum(sexp_unbox_fixnum(sexp_procedure_flags(base_proc)) | SEXP_PROC_VARIABLE_TRANSFORMER); - return sexp_make_procedure(ctx, flags, - sexp_make_fixnum(sexp_procedure_num_args(base_proc)), - sexp_procedure_code(base_proc), - sexp_procedure_vars(base_proc)); -} - sexp sexp_make_synclo_op (sexp ctx, sexp self, sexp_sint_t n, sexp env, sexp fv, sexp expr) { sexp res; sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); diff --git a/include/chibi/eval.h b/include/chibi/eval.h index bbd905cf..ebbad05d 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -128,7 +128,6 @@ SEXP_API sexp sexp_warn_undefs_op (sexp ctx, sexp self, sexp_sint_t n, sexp from SEXP_API sexp sexp_make_lit (sexp ctx, sexp value); SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1); SEXP_API sexp sexp_make_procedure_op (sexp ctx, sexp self, sexp_sint_t n, sexp flags, sexp num_args, sexp bc, sexp vars); -SEXP_API sexp sexp_make_variable_transformer_op (sexp ctx, sexp self, sexp_sint_t n, sexp base_proc); SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args, int flags, const char *fname, sexp_proc1 f, sexp data); SEXP_API sexp sexp_register_optimization(sexp ctx, sexp self, sexp_sint_t n, sexp f, sexp i); #if SEXP_USE_AUTO_FORCE diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c index ab952197..50b295ca 100644 --- a/lib/chibi/ast.c +++ b/lib/chibi/ast.c @@ -108,6 +108,18 @@ sexp sexp_get_procedure_flags (sexp ctx, sexp self, sexp_sint_t n, sexp proc) { return sexp_make_fixnum(sexp_procedure_flags(proc)); } +sexp sexp_make_variable_transformer_op (sexp ctx, sexp self, sexp_sint_t n, sexp base_proc) { + sexp flags; + sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, base_proc); + if (sexp_procedure_variable_transformer_p(base_proc)) + return base_proc; + flags = sexp_make_fixnum(sexp_unbox_fixnum(sexp_procedure_flags(base_proc)) | SEXP_PROC_VARIABLE_TRANSFORMER); + return sexp_make_procedure(ctx, flags, + sexp_make_fixnum(sexp_procedure_num_args(base_proc)), + sexp_procedure_code(base_proc), + sexp_procedure_vars(base_proc)); +} + sexp sexp_get_opcode_name (sexp ctx, sexp self, sexp_sint_t n, sexp op) { if (! sexp_opcodep(op)) return sexp_type_exception(ctx, self, SEXP_OPCODE, op); @@ -701,6 +713,7 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char sexp_define_foreign(ctx, env, "procedure-variadic?", 1, sexp_get_procedure_variadic_p); sexp_define_foreign(ctx, env, "procedure-variable-transformer?", 1, sexp_get_procedure_variable_transformer_p); sexp_define_foreign(ctx, env, "procedure-flags", 1, sexp_get_procedure_flags); + sexp_define_foreign(ctx, env, "make-variable-transformer", 1, sexp_make_variable_transformer_op); sexp_define_foreign(ctx, env, "copy-lambda", 1, sexp_copy_lambda); sexp_define_foreign_opt(ctx, env, "make-lambda", 4, sexp_make_lambda_op, SEXP_NULL); sexp_define_foreign_opt(ctx, env, "make-cnd", 3, sexp_make_cnd_op, SEXP_VOID); diff --git a/lib/chibi/ast.sld b/lib/chibi/ast.sld index 8cbcd0af..40b99919 100644 --- a/lib/chibi/ast.sld +++ b/lib/chibi/ast.sld @@ -29,7 +29,7 @@ macro-procedure macro-env macro-source macro-aux macro-aux-set! procedure-code procedure-vars procedure-name procedure-name-set! procedure-arity procedure-variadic? procedure-variable-transformer? - procedure-flags make-procedure + procedure-flags make-variable-transformer make-procedure bytecode-name bytecode-literals bytecode-source port-line port-line-set! port-source? port-source?-set! extend-env env-parent env-parent-set! env-lambda env-lambda-set! diff --git a/opcodes.c b/opcodes.c index fc66db3e..552fc698 100644 --- a/opcodes.c +++ b/opcodes.c @@ -197,7 +197,6 @@ _FN2(_I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_NULL, "memq", 0, sexp_memq_op), _FN2(_I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_NULL, "assq", 0, sexp_assq_op), _FN3(_I(SEXP_SYNCLO), _I(SEXP_ENV), SEXP_NULL, _I(SEXP_OBJECT), "make-syntactic-closure", 0, sexp_make_synclo_op), _FN1(_I(SEXP_OBJECT), _I(SEXP_OBJECT), "strip-syntactic-closures", 0, sexp_strip_synclos), -_FN1(_I(SEXP_PROCEDURE), _I(SEXP_PROCEDURE), "make-variable-transformer", 0, sexp_make_variable_transformer_op), _FN0(_I(SEXP_OPORT), "open-output-string", 0, sexp_open_output_string_op), _FN1(_I(SEXP_IPORT), _I(SEXP_STRING), "open-input-string", 0, sexp_open_input_string_op), _FN1(_I(SEXP_STRING), _I(SEXP_OPORT), "get-output-string", 0, sexp_get_output_string_op), From 86e8b56289741b0dfe983926dfef0bc65ac4c53e Mon Sep 17 00:00:00 2001 From: Daphne Preston-Kendal Date: Tue, 15 Mar 2022 09:37:52 +0100 Subject: [PATCH 20/22] Nix er-macro-transformer*, extend syntax-rules for identifier macros --- lib/init-7.scm | 14 +++----------- 1 file changed, 3 insertions(+), 11 deletions(-) diff --git a/lib/init-7.scm b/lib/init-7.scm index d465bbbb..18992857 100644 --- a/lib/init-7.scm +++ b/lib/init-7.scm @@ -143,21 +143,13 @@ (lambda (expr use-env mac-env) (f expr mac-env)))) -(define er-macro-transformer* +(define er-macro-transformer (lambda (f) (lambda (expr use-env mac-env) (f expr (make-renamer mac-env) (lambda (x y) (identifier=? use-env x use-env y)))))) -(define er-macro-transformer - (lambda (f) - (er-macro-transformer* - (lambda (expr rename compare) - (if (not (pair? expr)) - (error "invalid use of non-identifier macro outside operator position" expr) - (f expr rename compare)))))) - (define-syntax cond (er-macro-transformer (lambda (expr rename compare) @@ -881,8 +873,8 @@ (set! count (+ count 1)) (rename (string->symbol (string-append s (%number->string count))))) (define (expand-pattern pat tmpl) - (let lp ((p (cdr pat)) - (x (list _cdr _expr)) + (let lp ((p pat) + (x _expr) (dim 0) (vars '()) (k (lambda (vars) From 9a0212efff991c931b86b7e1e74bcef2af970d2c Mon Sep 17 00:00:00 2001 From: Daphne Preston-Kendal Date: Tue, 15 Mar 2022 10:27:56 +0100 Subject: [PATCH 21/22] Move identifier-syntax to (chibi ast) --- lib/chibi/ast.scm | 28 ++++++++++++++++++++++++++++ lib/chibi/ast.sld | 3 ++- tests/syntax-tests.scm | 6 +++--- 3 files changed, 33 insertions(+), 4 deletions(-) diff --git a/lib/chibi/ast.scm b/lib/chibi/ast.scm index e57e1340..7433f988 100644 --- a/lib/chibi/ast.scm +++ b/lib/chibi/ast.scm @@ -109,6 +109,34 @@ ((opcode? x) (cond ((opcode-name x) => string->symbol) (else x))) (else x))))) +;;> \section{Identifier Macros} + +;;> \procedure{(make-variable-transformer proc)} + +;;> Returns a new procedure wrapping the input procedure \var{proc}. +;;> The returned procedure, if used as a macro transformer procedure, +;;> can expand an instance of \scheme{set!} with its keyword on the +;;> left hand side. + +;;> \macro{(identifier-syntax clauses ...)} + +;;> A high-level form for creating identifier macros. See +;;> \hyperlink["http://www.r6rs.org/final/html/r6rs/r6rs-Z-H-14.html#node_idx_796"]{the R6RS specification.} + +(define-syntax identifier-syntax + (syntax-rules (set!) + ((_ template) + (syntax-rules () + ((_ xs (... ...)) + (template xs (... ...))) + (x template))) + ((_ (id_1 template_1) ((set! id_2 pattern) template_2)) + (make-variable-transformer + (syntax-rules (set!) + ((set! id_2 pattern) template_2) + ((id_1 xs (... ...)) (template_1 xs (... ...))) + (id_1 template_1)))))) + ;;> \section{Types} ;;> All objects have an associated type, and types may have parent diff --git a/lib/chibi/ast.sld b/lib/chibi/ast.sld index 40b99919..ad0367cb 100644 --- a/lib/chibi/ast.sld +++ b/lib/chibi/ast.sld @@ -1,7 +1,8 @@ (define-library (chibi ast) (export - analyze optimize env-cell ast->sexp macroexpand type-of + analyze optimize env-cell ast->sexp macroexpand identifier-syntax + type-of Object Input-Port Output-Port Opcode Procedure Bytecode Macro Env Number Bignum Flonum Integer Complex Char Boolean Symbol String Byte-Vector Vector Pair File-Descriptor diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm index 5eeca5e7..fecf3301 100644 --- a/tests/syntax-tests.scm +++ b/tests/syntax-tests.scm @@ -84,11 +84,11 @@ ;; this could be fixed in theory) (modules (test-begin "identifier syntax") - (define syntax-test-env (environment '(chibi))) + (define syntax-test-env (environment '(chibi) '(chibi ast))) (eval '(define-syntax low-level-id-macro - (er-macro-transformer* + (er-macro-transformer (lambda (expr rename compare) (if (pair? expr) (list (rename 'quote) 'operator) @@ -102,7 +102,7 @@ (eval '(define-syntax low-level-vt (make-variable-transformer - (er-macro-transformer* + (er-macro-transformer (lambda (expr rename compare) (list (rename 'quote) (if (pair? expr) From a4ecace600caf801892c2d2316d0b143450b68ef Mon Sep 17 00:00:00 2001 From: Daphne Preston-Kendal Date: Tue, 15 Mar 2022 10:33:07 +0100 Subject: [PATCH 22/22] Revert "Document the addition of identifier macros" This reverts commit 83f61aecd22a95541ecacdbcb2f6fe466bab3712. [skip ci] --- doc/chibi.scrbl | 9 --------- 1 file changed, 9 deletions(-) diff --git a/doc/chibi.scrbl b/doc/chibi.scrbl index 9c89e46e..a673c52b 100755 --- a/doc/chibi.scrbl +++ b/doc/chibi.scrbl @@ -261,15 +261,6 @@ introduction to syntactic-closures can be found at \scheme{make-syntactic-closure} and \scheme{strip-syntactic-closures} are also available. -Variable transformers and identifier macros are also supported: macros -created with \scheme{sc-macro-transformer} and \scheme{rsc-macro-transformer} -can match an identifier outside of operator position, and a special -\scheme{er-macro-transformer*} form is provided, otherwise identical -to the usual \scheme{er-macro-transformer}, which can do the same. -\scheme{make-variable-transformer} can be used to create transformer -procedures which expand an instance of \scheme{set!} with their syntax -keywords as their first argument. - \subsection{Types} You can define new record types with