diff --git a/eval.c b/eval.c index 68e7c562..165205bf 100644 --- a/eval.c +++ b/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) { diff --git a/include/chibi/eval.h b/include/chibi/eval.h index ebbad05d..4f874000 100644 --- a/include/chibi/eval.h +++ b/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 { diff --git a/include/chibi/features.h b/include/chibi/features.h index a4c22954..2d707b8f 100644 --- a/include/chibi/features.h +++ b/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 diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 86435616..a96eef96 100644 --- a/include/chibi/sexp.h +++ b/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)) diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c index fa40f323..46c17a89 100644 --- a/lib/chibi/ast.c +++ b/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); diff --git a/lib/chibi/ast.sld b/lib/chibi/ast.sld index f23ed0a5..f17bba0e 100644 --- a/lib/chibi/ast.sld +++ b/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! diff --git a/lib/srfi/229.sld b/lib/srfi/229.sld new file mode 100644 index 00000000..ccd2cc94 --- /dev/null +++ b/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)))))))) diff --git a/lib/srfi/229/test.sld b/lib/srfi/229/test.sld new file mode 100644 index 00000000..6b99d2d0 --- /dev/null +++ b/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)))))) diff --git a/sexp.c b/sexp.c index 5b355312..4c433f7d 100644 --- a/sexp.c +++ b/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, "#