Merge pull request #805 from dpk/identifier-macros

Identifier macros

eval.c

@@ -766,6 +766,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);
@@ -785,29 +801,39 @@ static sexp analyze_var_ref (sexp ctx, sexp x, sexp *varenv) {
 
 static sexp analyze_set (sexp ctx, sexp x, int depth) {
   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);
+      }
     } 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;
 }
 
@@ -1084,7 +1110,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); 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:
@@ -1115,14 +1146,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 +1178,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))) {

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
@@ -1152,6 +1153,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))

lib/chibi/ast.c

@@ -98,11 +98,28 @@ 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));
 }
 
+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);
@@ -694,7 +711,9 @@ 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, "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);

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

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
@@ -28,7 +29,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-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!

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)

lib/chibi/syntax-case.sld

@@ -8,10 +8,12 @@
   (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)

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, "#<procedure ", out);
+      if (sexp_procedure_variable_transformer_p(obj))
+        sexp_write_string(ctx, "(variable-transformer) ", out);
       x = sexp_bytecode_name(sexp_procedure_code(obj));
       sexp_write_one(ctx, sexp_synclop(x) ? sexp_synclo_expr(x): x, out, bound+1);
       sexp_write_string(ctx, " ", out);

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) '(chibi ast)))
+
+  (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))