Implement SRFI 229: Tagged Procedures

eval.c

@@ -388,6 +388,9 @@ sexp sexp_make_procedure_op (sexp ctx, sexp self, sexp_sint_t n, sexp flags,
   sexp_procedure_num_args(proc) = sexp_unbox_fixnum(num_args);
   sexp_procedure_code(proc) = bc;
   sexp_procedure_vars(proc) = vars;
+#if SEXP_USE_TAGGED_PROCEDURES
+  sexp_procedure_tag(proc) = SEXP_VOID;
+#endif
   return proc;
 }
 
@@ -431,6 +434,7 @@ sexp sexp_make_lambda (sexp ctx, sexp params) {
   sexp_lambda_defs(res) = SEXP_NULL;
   sexp_lambda_return_type(res) = SEXP_FALSE;
   sexp_lambda_param_types(res) = SEXP_NULL;
+  sexp_lambda_flags(res) = (char) (sexp_uint_t) 0;
   return res;
 }
 
@@ -811,7 +815,7 @@ static sexp analyze_set (sexp ctx, sexp x, int depth) {
 
 #define sexp_return(res, val) do {res=val; goto cleanup;} while (0)
 
-static sexp analyze_lambda (sexp ctx, sexp x, int depth) {
+static sexp analyze_lambda (sexp ctx, sexp x, int depth, int generative) {
   int trailing_non_procs, verify_duplicates_p;
   sexp name, ls, ctx3;
   sexp_gc_var6(res, body, tmp, value, defs, ctx2);
@@ -834,6 +838,10 @@ static sexp analyze_lambda (sexp ctx, sexp x, int depth) {
   /* build lambda and analyze body */
   res = sexp_make_lambda(ctx, tmp=sexp_copy_list(ctx, sexp_cadr(x)));
   if (sexp_exceptionp(res)) sexp_return(res, res);
+#ifdef SEXP_USE_TAGGED_PROCEDURES
+  if (generative)
+    sexp_lambda_flags(res) = sexp_make_fixnum(SEXP_LAMBDA_GENERATIVE);
+#endif
   sexp_lambda_source(res) = sexp_pair_source(x);
   if (! (sexp_lambda_source(res) && sexp_pairp(sexp_lambda_source(res))))
     sexp_lambda_source(res) = sexp_pair_source(sexp_cdr(x));
@@ -858,7 +866,7 @@ static sexp analyze_lambda (sexp ctx, sexp x, int depth) {
       tmp = sexp_cons(ctx3, sexp_cdaar(tmp), sexp_cdar(tmp));
       tmp = sexp_cons(ctx3, SEXP_VOID, tmp);
       sexp_pair_source(tmp) = sexp_pair_source(sexp_caar(ls));
-      value = analyze_lambda(ctx3, tmp, depth);
+      value = analyze_lambda(ctx3, tmp, depth, 0);
     } else {
       name = sexp_caar(tmp);
       value = analyze(ctx3, sexp_cadar(tmp), depth, 0);
@@ -940,7 +948,7 @@ static sexp analyze_define (sexp ctx, sexp x, int depth) {
         tmp = sexp_cons(ctx, sexp_cdadr(x), sexp_cddr(x));
         tmp = sexp_cons(ctx, SEXP_VOID, tmp);
         sexp_pair_source(tmp) = sexp_pair_source(x);
-        value = analyze_lambda(ctx, tmp, depth);
+        value = analyze_lambda(ctx, tmp, depth, 0);
       } else
         value = analyze(ctx, sexp_caddr(x), depth, 0);
       tmp = sexp_env_cell_loc(ctx, env, name, 0, &varenv);
@@ -1077,7 +1085,11 @@ static sexp analyze (sexp ctx, sexp object, int depth, int defok) {
           case SEXP_CORE_SET:
             res = analyze_set(ctx, x, depth); break;
           case SEXP_CORE_LAMBDA:
-            res = analyze_lambda(ctx, x, depth); break;
+            res = analyze_lambda(ctx, x, depth, 0); break;
+#ifdef SEXP_USE_TAGGED_PROCEDURES
+          case SEXP_CORE_GENERATIVE_LAMBDA:
+            res = analyze_lambda(ctx, x, depth, 1); break;
+#endif
           case SEXP_CORE_IF:
             res = analyze_if(ctx, x, depth); break;
           case SEXP_CORE_BEGIN:
@@ -2206,7 +2218,11 @@ static struct sexp_core_form_struct core_forms[] = {
   {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_LETREC_SYNTAX, (sexp)"letrec-syntax"}
+#ifdef SEXP_USE_TAGGED_PROCEDURES
+  , {SEXP_CORE_GENERATIVE_LAMBDA, (sexp)"lambda/generative"}
+#else
+#endif
 };
 
 sexp sexp_make_env_op (sexp ctx, sexp self, sexp_sint_t n) {

include/chibi/eval.h

@@ -29,6 +29,9 @@ enum sexp_core_form_names {
   SEXP_CORE_DEFINE_SYNTAX,
   SEXP_CORE_LET_SYNTAX,
   SEXP_CORE_LETREC_SYNTAX
+#ifdef SEXP_USE_TAGGED_PROCEDURES
+  , SEXP_CORE_GENERATIVE_LAMBDA
+#endif
 };
 
 enum sexp_opcode_classes {

include/chibi/features.h

@@ -213,6 +213,9 @@
 /*   non-immediate symbols in a single list. */
 /* #define SEXP_USE_HASH_SYMS 0 */
 
+/* uncomment this to disable procedure tags as defined in SRFI 229 */
+/* #define SEXP_USE_TAGGED_PROCEDURES 0 */
+
 /* uncomment this to disable extended char names as defined in R7RS */
 /* #define SEXP_USE_EXTENDED_CHAR_NAMES 0 */
 
@@ -729,6 +732,10 @@
 #define SEXP_USE_UNBOXED_LOCALS 0
 #endif
 
+#ifndef SEXP_USE_TAGGED_PROCEDURES
+#define SEXP_USE_TAGGED_PROCEDURES 1
+#endif
+
 #ifndef SEXP_USE_DEBUG_VM
 #define SEXP_USE_DEBUG_VM 0
 #endif

include/chibi/sexp.h

@@ -266,11 +266,14 @@ typedef int sexp_sint_t;
 #define sexp_heap_chunks(n) (sexp_heap_align(n)>>4)
 #endif
 
+/* lambda flags */
+#define SEXP_LAMBDA_GENERATIVE ((sexp_uint_t)1)
+
 /* procedure flags */
 #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_TAGGED ((sexp_uint_t)4)
 
 #ifdef SEXP_USE_INTTYPES
 #ifdef PLAN9
@@ -538,6 +541,9 @@ struct sexp_struct {
     } bytecode;
     struct {
       sexp bc, vars;
+#if SEXP_USE_TAGGED_PROCEDURES
+      sexp tag;
+#endif
       char flags;
       sexp_proc_num_args_t num_args;
     } procedure;
@@ -1146,8 +1152,10 @@ 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_tagged_p(x)   (sexp_unbox_fixnum(sexp_procedure_flags(x)) & SEXP_PROC_TAGGED)
 #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_tag(x)        (sexp_field(x, procedure, SEXP_PROCEDURE, tag))
 #define sexp_procedure_source(x)     sexp_bytecode_source(sexp_procedure_code(x))
 
 #define sexp_bytes_length(x)  (sexp_field(x, bytes, SEXP_BYTES, length))
@@ -1329,6 +1337,7 @@ enum sexp_uniform_vector_type {
 #define sexp_lambda_return_type(x) (sexp_field(x, lambda, SEXP_LAMBDA, ret))
 #define sexp_lambda_param_types(x) (sexp_field(x, lambda, SEXP_LAMBDA, types))
 #define sexp_lambda_source(x)      (sexp_field(x, lambda, SEXP_LAMBDA, source))
+#define sexp_lambda_generative_p(x) (sexp_unbox_fixnum(sexp_lambda_flags(x)) & SEXP_LAMBDA_GENERATIVE)
 
 #define sexp_cnd_test(x)      (sexp_field(x, cnd, SEXP_CND, test))
 #define sexp_cnd_pass(x)      (sexp_field(x, cnd, SEXP_CND, pass))

lib/chibi/ast.c

@@ -98,11 +98,36 @@ 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_tagged_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_tagged_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_get_procedure_tag (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
+  sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
+#if SEXP_USE_TAGGED_PROCEDURES
+  return (sexp_procedure_tagged_p(proc)) ? sexp_procedure_tag(proc) : SEXP_VOID;
+#else
+  return SEXP_VOID;
+#endif
+}
+
+sexp sexp_set_procedure_tag (sexp ctx, sexp self, sexp_sint_t n, sexp proc, sexp tag) {
+  sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
+#if SEXP_USE_TAGGED_PROCEDURES
+  sexp_procedure_flags(proc)
+    = (char) (sexp_uint_t) sexp_make_fixnum(sexp_unbox_fixnum(sexp_procedure_flags(proc))
+                                            | SEXP_PROC_TAGGED);
+  sexp_procedure_tag(proc) = tag;
+#endif
+  return SEXP_VOID;
+}
+
 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);
@@ -693,7 +718,10 @@ 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-tagged?", 1, sexp_get_procedure_tagged_p);
   sexp_define_foreign(ctx, env, "procedure-flags", 1, sexp_get_procedure_flags);
+  sexp_define_foreign(ctx, env, "procedure-tag", 1, sexp_get_procedure_tag);
+  sexp_define_foreign(ctx, env, "procedure-tag-set!", 2, sexp_set_procedure_tag);
   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.sld

@@ -29,6 +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-flags
+   procedure-tagged? procedure-tag procedure-tag-set!
    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/srfi/229.sld

@@ -0,0 +1,38 @@
+(define-library (srfi 229)
+  (export procedure/tag? procedure-tag lambda/tag
+          case-lambda/tag)
+  (import (scheme base)
+          (only (chibi) lambda/generative length*)
+          (only (chibi ast)
+                Procedure type-of
+                procedure-tag
+                procedure-tag-set!
+                procedure-tagged?))
+  (begin
+    (define-syntax lambda/tag
+      (syntax-rules ()
+        ((lambda/tag tag-expr formals body1 ... body2)
+         (let ((proc (lambda/generative formals body1 ... body2)))
+           (procedure-tag-set! proc tag-expr)
+           proc))))
+    (define (procedure/tag? obj)
+      (and (eq? (type-of obj) Procedure)
+           (procedure-tagged? obj)))
+   (define-syntax %case
+     (syntax-rules ()
+       ((%case args len n p ((params ...) . body) . rest)
+        (if (= len (length '(params ...)))
+            (apply (lambda (params ...) . body) args)
+            (%case args len 0 () . rest)))
+       ((%case args len n (p ...) ((x . y) . body) . rest)
+        (%case args len (+ n 1) (p ... x) (y . body) . rest))
+       ((%case args len n (p ...) (y . body) . rest)
+        (if (>= len n)
+            (apply (lambda (p ... . y) . body) args)
+            (%case args len 0 () . rest)))
+       ((%case args len n p)
+        (error "case-lambda/tag: no cases matched"))))
+   (define-syntax case-lambda/tag
+     (syntax-rules ()
+       ((case-lambda tag-expr . clauses)
+        (lambda/tag tag-expr args (let ((len (length* args))) (%case args len 0 () . clauses))))))))

lib/srfi/229/test.sld

@@ -0,0 +1,43 @@
+(define-library (srfi 229 test)
+  (export run-tests)
+  (import (scheme base)
+          (chibi test)
+          (srfi 229))
+  (begin
+    (define (run-tests)
+      (test-group
+       "srfi-229: tagged procedures"
+
+       (define f
+         (lambda/tag 42
+             (x)
+           (* x x)))
+
+       (define f*
+         (lambda/tag 43
+             (x)
+           (* x x)))
+
+       (define g
+         (let ((y 10))
+           (lambda/tag y ()
+             (set! y (+ y 1))
+             y)))
+
+       (define h
+         (let ((box (vector #f)))
+           (case-lambda/tag box
+            (() (vector-ref box 0))
+            ((val) (vector-set! box 0 val)))))
+
+       (test #t (procedure/tag? f))
+       (test 9 (f 3))
+       (test 42 (procedure-tag f))
+       (test #f (eqv? f f*))
+       (test 10 (procedure-tag g))
+       (test 10 (let ((y 9)) (procedure-tag g)))
+       (test 11 (g))
+       (test 10 (procedure-tag g))
+       (h 1)
+       (test 1 (vector-ref (procedure-tag h) 0))
+       (test 1 (h))))))

sexp.c

@@ -280,7 +280,11 @@ static struct sexp_type_struct _sexp_type_specs[] = {
   {(sexp)"Output-Port", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, SEXP_FINALIZE_PORTN, SEXP_OPORT, sexp_offsetof(port, name), 3, 3, 0, 0, sexp_sizeof(port), 0, 0, 0, 0, 0, 0, 0, 0, SEXP_FINALIZE_PORT},
   {(sexp)"File-Descriptor", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, SEXP_FINALIZE_FILENON, SEXP_FILENO, 0, 0, 0, 0, 0, sexp_sizeof(fileno), 0, 0, 0, 0, 0, 0, 0, 0, SEXP_FINALIZE_FILENO},
   {(sexp)"Exception", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL, SEXP_EXCEPTION, sexp_offsetof(exception, kind), 6, 6, 0, 0, sexp_sizeof(exception), 0, 0, 0, 0, 0, 0, 0, 0, NULL},
+#ifdef SEXP_USE_TAGGED_PROCEDURES
+  {(sexp)"Procedure", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, SEXP_PROCEDURE, sexp_offsetof(procedure, bc), 3, 3, 0, 0, sexp_sizeof(procedure), 0, 0, 0, 0, 0, 0, 0, 0, NULL},
+#else
   {(sexp)"Procedure", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, SEXP_PROCEDURE, sexp_offsetof(procedure, bc), 2, 2, 0, 0, sexp_sizeof(procedure), 0, 0, 0, 0, 0, 0, 0, 0, NULL},
+#endif
   {(sexp)"Macro", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, SEXP_MACRO, sexp_offsetof(macro, proc), 4, 4, 0, 0, sexp_sizeof(macro), 0, 0, 0, 0, 0, 0, 0, 0, NULL},
   {(sexp)"Sc", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL, NULL, SEXP_SYNCLO, sexp_offsetof(synclo, env), 4, 4, 0, 0, sexp_sizeof(synclo), 0, 0, 0, 0, 0, 0, 0, 0, NULL},
   {(sexp)"Environment", SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, NULL, NULL, NULL, SEXP_ENV, sexp_offsetof(env, parent), 3+(SEXP_USE_STABLE_ABI||SEXP_USE_RENAME_BINDINGS), 3+(SEXP_USE_STABLE_ABI||SEXP_USE_RENAME_BINDINGS), 0, 0, sexp_sizeof(env), 0, 0, 0, 0, 0, 0, 0, 0, NULL},
@@ -2192,6 +2196,12 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out, sexp_sint_t bound) {
       sexp_write_string(ctx, "#<procedure ", out);
       x = sexp_bytecode_name(sexp_procedure_code(obj));
       sexp_write_one(ctx, sexp_synclop(x) ? sexp_synclo_expr(x): x, out, bound+1);
+#if SEXP_USE_TAGGED_PROCEDURES
+      if (sexp_procedure_tagged_p(obj)) {
+        sexp_write_string(ctx, " ", out);
+        sexp_write(ctx, sexp_procedure_tag(obj), out);
+      }
+#endif
 #if SEXP_USE_DEBUG_VM
       if (sexp_procedure_source(obj)) {
         sexp_write_string(ctx, " ", out);

tests/lib-tests.scm

@@ -35,6 +35,7 @@
         (rename (srfi 160 test) (run-tests run-srfi-160-tests))
         (rename (srfi 166 test) (run-tests run-srfi-166-tests))
         (rename (srfi 219 test) (run-tests run-srfi-219-tests))
+        (rename (srfi 229 test) (run-tests run-srfi-229-tests))
         (rename (scheme bytevector-test) (run-tests run-scheme-bytevector-tests))
         (rename (chibi assert-test) (run-tests run-assert-tests))
         (rename (chibi base64-test) (run-tests run-base64-tests))
@@ -106,6 +107,7 @@
 (run-srfi-160-tests)
 (run-srfi-166-tests)
 (run-srfi-219-tests)
+(run-srfi-229-tests)
 (run-scheme-bytevector-tests)
 (run-assert-tests)
 (run-base64-tests)

vm.c

@@ -725,7 +725,7 @@ static void generate_lambda (sexp ctx, sexp name, sexp loc, sexp lam, sexp lambd
     sexp_context_exception(ctx) = bc;
   } else {
   sexp_bytecode_name(bc) = sexp_lambda_name(lambda);
-  if (sexp_nullp(fv)) {
+  if (sexp_nullp(fv) && !sexp_lambda_generative_p(lambda)) {
     /* shortcut, no free vars */
     tmp = sexp_make_vector(ctx2, SEXP_ZERO, SEXP_VOID);
     tmp = sexp_make_procedure(ctx2, flags, len, bc, tmp);