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)