Support identifier-syntax in (chibi syntax-case)

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);

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!

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:

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)