diff options
author | Marc Nieper-Wißkirchen <marc@nieper-wisskirchen.de> | 2021-11-30 20:43:37 +0100 |
---|---|---|
committer | Marc Nieper-Wißkirchen <marc@nieper-wisskirchen.de> | 2021-11-30 20:43:37 +0100 |
commit | db7480e743be3132a2281a96a653da9ff3d40b3c (patch) | |
tree | 08c080dfad7e5ab41f8648fd31d596e2102164b9 | |
parent | 6e636594a5a1b7c7fabff3551f6c6726c0314e7a (diff) |
Implement SRFI 229: Tagged Proceduressrfi-229
-rw-r--r-- | eval.c | 26 | ||||
-rw-r--r-- | include/chibi/eval.h | 3 | ||||
-rw-r--r-- | include/chibi/features.h | 7 | ||||
-rw-r--r-- | include/chibi/sexp.h | 11 | ||||
-rw-r--r-- | lib/chibi/ast.c | 28 | ||||
-rw-r--r-- | lib/chibi/ast.sld | 1 | ||||
-rw-r--r-- | lib/srfi/229.sld | 38 | ||||
-rw-r--r-- | lib/srfi/229/test.sld | 43 | ||||
-rw-r--r-- | sexp.c | 10 | ||||
-rw-r--r-- | tests/lib-tests.scm | 2 | ||||
-rw-r--r-- | vm.c | 14 |
11 files changed, 170 insertions, 13 deletions
@@ -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)))))) @@ -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); diff --git a/tests/lib-tests.scm b/tests/lib-tests.scm index e66a6480..a1380a77 100644 --- a/tests/lib-tests.scm +++ b/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) @@ -292,7 +292,7 @@ static void generate_ref (sexp ctx, sexp ref, int unboxp) { /* global ref */ if (unboxp) { sexp_emit(ctx, (sexp_cdr(sexp_ref_cell(ref)) == SEXP_UNDEF) - ? SEXP_OP_GLOBAL_REF : SEXP_OP_GLOBAL_KNOWN_REF); + ? SEXP_OP_GLOBAL_REF : SEXP_OP_GLOBAL_KNOWN_REF); sexp_emit_word(ctx, (sexp_uint_t)sexp_ref_cell(ref)); bytecode_preserve(ctx, sexp_ref_cell(ref)); } else @@ -489,8 +489,8 @@ static void generate_opcode_app (sexp ctx, sexp app) { if (sexp_opcode_static_param_p(op)) for (ls=sexp_cdr(app); sexp_pairp(ls); ls=sexp_cdr(ls)) sexp_emit_word(ctx, sexp_unbox_fixnum(sexp_litp(sexp_car(ls)) ? - sexp_lit_value(sexp_car(ls)) : - sexp_car(ls))); + sexp_lit_value(sexp_car(ls)) : + sexp_car(ls))); if (sexp_opcode_return_type(op) == SEXP_VOID && sexp_opcode_class(op) != SEXP_OPC_FOREIGN) @@ -549,8 +549,8 @@ static void generate_tail_jump (sexp ctx, sexp name, sexp loc, sexp lam, sexp ap sexp_emit(ctx, SEXP_OP_JUMP); sexp_context_align_pos(ctx); sexp_emit_word(ctx, (sexp_uint_t) (-sexp_unbox_fixnum(sexp_context_pos(ctx)) + - (sexp_pairp(sexp_lambda_locals(lam)) - ? 1 + sizeof(sexp) : 0))); + (sexp_pairp(sexp_lambda_locals(lam)) + ? 1 + sizeof(sexp) : 0))); sexp_context_tailp(ctx) = 1; sexp_gc_release3(ctx); @@ -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); @@ -1915,7 +1915,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { } else if (sexp_flonump(tmp1) && sexp_flonump(tmp2)) { i = sexp_flonum_value(tmp1) < sexp_flonum_value(tmp2); } else if (sexp_flonump(tmp1) && sexp_fixnump(tmp2)) { - i = sexp_flonum_value(tmp1) < (double)sexp_unbox_fixnum(tmp2); + i = sexp_flonum_value(tmp1) < (double)sexp_unbox_fixnum(tmp2); } else if (sexp_fixnump(tmp1) && sexp_flonump(tmp2)) { i = (double)sexp_unbox_fixnum(tmp1) < sexp_flonum_value(tmp2); #endif |