diff options
author | Andy Wingo <wingo@pobox.com> | 2009-12-04 19:20:11 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2009-12-04 19:20:11 +0100 |
commit | 314b87163eac1358923cb84e7f2c87d06aa03756 (patch) | |
tree | e8c0a077e3f4c4d0920c4e2586e79b18277c09c7 | |
parent | f36878ba2d04427e76b85a9e91fce71f56ba7c7f (diff) | |
download | guile-314b87163eac1358923cb84e7f2c87d06aa03756.tar.gz |
eval.c closures are now applicable smobs, not tc3s
* libguile/debug.c (scm_procedure_name): Remove a SCM_CLOSUREP case and
some dead code.
(scm_procedure_module): Remove. This was introduced a few months ago
for the hygienic expander, but now it is no longer needed, as the
expander keeps track of this information itself.
* libguile/debug.h: Remove scm_procedure_module.
* libguile/eval.c: Instead of using tc3 closures, define a "boot
closure" applicable smob type, and represent closures with that. The
advantage is that after eval.scm is compiled, boot closures take up no
address space (besides a smob number) in the runtime, and require no
special cases in procedure dispatch.
* libguile/eval.h: Remove the internal functions scm_i_call_closure_0
and scm_closure_apply, and the public function scm_closure.
* libguile/gc.c (scm_storage_prehistory): No tc3_closure displacement
registration.
(scm_i_tag_name): Remove closure case, and a dead cclo case.
* libguile/vm.c (apply_foreign):
* libguile/print.c (iprin1):
* libguile/procs.c (scm_procedure_p, scm_procedure_documentation);
* libguile/evalext.c (scm_self_evaluating_p):
* libguile/goops.c (scm_class_of): Remove tc3_closure/tcs_closure cases.
* libguile/hash.c (scm_hasher):
* libguile/hooks.c (scm_add_hook_x): Use new scm_i_procedure_arity.
* libguile/macros.c (macro_print): Print all macros using the same code.
(scm_macro_transformer): Return any procedure, not just programs.
* libguile/procprop.h:
* libguile/procprop.c (scm_i_procedure_arity): Instead of returning a
list that the caller has to parse, have the same prototype as
scm_i_program_arity. An incompatible change, but it's an internal
function anyway.
(scm_procedure_properties, scm_set_procedure_properties)
(scm_procedure_property, scm_set_procedure_property): Remove closure
cases, and use scm_i_program_arity for arity.
* libguile/procs.h (SCM_CLOSUREP, SCM_CLOSCAR, SCM_CODE)
(SCM_CLOSURE_NUM_REQUIRED_ARGS, SCM_CLOSURE_HAS_REST_ARGS)
(SCM_CLOSURE_BODY, SCM_PROCPROPS, SCM_SETPROCPROPS, SCM_ENV)
(SCM_TOP_LEVEL): Remove these macros that pertain to boot closures
only. Only eval.c should know abut boot closures.
* libguile/procs.c (scm_closure_p): Remove this function. There is a
simple stub in deprecated.scm now.
(scm_thunk_p): Use scm_i_program_arity.
* libguile/tags.h (scm_tc3_closure): Remove. Yay, another tc3 to play
with!
(scm_tcs_closures): Remove.
* libguile/validate.h (SCM_VALIDATE_CLOSURE): Remove.
* module/ice-9/deprecated.scm (closure?): Add stub.
* module/ice-9/documentation.scm (object-documentation)
* module/ice-9/session.scm (help-doc, arity)
* module/oop/goops.scm (compute-getters-n-setters)
* module/oop/goops/describe.scm (describe)
* module/system/repl/describe.scm (display-object, display-type):
Remove calls to closure?.
-rw-r--r-- | libguile/debug.c | 29 | ||||
-rw-r--r-- | libguile/debug.h | 1 | ||||
-rw-r--r-- | libguile/eval.c | 128 | ||||
-rw-r--r-- | libguile/eval.h | 3 | ||||
-rw-r--r-- | libguile/evalext.c | 1 | ||||
-rw-r--r-- | libguile/gc.c | 8 | ||||
-rw-r--r-- | libguile/goops.c | 4 | ||||
-rw-r--r-- | libguile/hash.c | 2 | ||||
-rw-r--r-- | libguile/hooks.c | 11 | ||||
-rw-r--r-- | libguile/macros.c | 60 | ||||
-rw-r--r-- | libguile/print.c | 18 | ||||
-rw-r--r-- | libguile/procprop.c | 133 | ||||
-rw-r--r-- | libguile/procprop.h | 2 | ||||
-rw-r--r-- | libguile/procs.c | 58 | ||||
-rw-r--r-- | libguile/procs.h | 15 | ||||
-rw-r--r-- | libguile/tags.h | 22 | ||||
-rw-r--r-- | libguile/validate.h | 2 | ||||
-rw-r--r-- | libguile/vm.c | 8 | ||||
-rw-r--r-- | module/ice-9/deprecated.scm | 4 | ||||
-rw-r--r-- | module/ice-9/documentation.scm | 3 | ||||
-rw-r--r-- | module/ice-9/session.scm | 16 | ||||
-rw-r--r-- | module/oop/goops.scm | 28 | ||||
-rw-r--r-- | module/oop/goops/describe.scm | 7 | ||||
-rw-r--r-- | module/system/repl/describe.scm | 21 |
24 files changed, 191 insertions, 393 deletions
diff --git a/libguile/debug.c b/libguile/debug.c index 0310ffbe1..b220efd8b 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -143,14 +143,6 @@ SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0, default: { SCM name = scm_procedure_property (proc, scm_sym_name); -#if 0 - /* Source property scm_sym_procname not implemented yet... */ - SCM name = scm_source_property (SCM_CAR (SCM_CLOSURE_BODY (proc)), scm_sym_procname); - if (scm_is_false (name)) - name = scm_procedure_property (proc, scm_sym_name); -#endif - if (scm_is_false (name) && SCM_CLOSUREP (proc)) - name = scm_reverse_lookup (SCM_ENV (proc), proc); if (scm_is_false (name) && SCM_PROGRAM_P (proc)) name = scm_program_name (proc); return name; @@ -193,27 +185,6 @@ SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_procedure_module, "procedure-module", 1, 0, 0, - (SCM proc), - "Return the module that was current when @var{proc} was defined.") -#define FUNC_NAME s_scm_procedure_module -{ - SCM_VALIDATE_PROC (SCM_ARG1, proc); - - if (scm_is_true (scm_program_p (proc))) - return scm_program_module (proc); - else if (SCM_CLOSUREP (proc)) - { - SCM env = SCM_ENV (proc); - while (scm_is_pair (env)) - env = scm_cdr (env); - return env; - } - else - return SCM_BOOL_F; -} -#undef FUNC_NAME - diff --git a/libguile/debug.h b/libguile/debug.h index 2ca0b529a..6a1ee5a61 100644 --- a/libguile/debug.h +++ b/libguile/debug.h @@ -43,7 +43,6 @@ typedef union scm_t_debug_info SCM_API SCM scm_reverse_lookup (SCM env, SCM data); SCM_API SCM scm_sys_start_stack (SCM info_id, SCM thunk); -SCM_API SCM scm_procedure_module (SCM proc); SCM_API SCM scm_procedure_source (SCM proc); SCM_API SCM scm_procedure_name (SCM proc); SCM_API SCM scm_with_traps (SCM thunk); diff --git a/libguile/eval.c b/libguile/eval.c index b68c0ca82..4525e4faa 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -97,6 +97,21 @@ */ +/* Boot closures. We only see these when compiling eval.scm, because once + eval.scm is in the house, closures are standard VM closures. + */ + +static scm_t_bits scm_tc16_boot_closure; +#define RETURN_BOOT_CLOSURE(code, env) SCM_RETURN_NEWSMOB2 (scm_tc16_boot_closure, (code), (env)) +#define BOOT_CLOSURE_P(obj) SCM_TYP16_PREDICATE (scm_tc16_boot_closure, (obj)) +#define BOOT_CLOSURE_CODE(x) SCM_SMOB_OBJECT (x) +#define BOOT_CLOSURE_ENV(x) SCM_SMOB_OBJECT_2 (x) +#define BOOT_CLOSURE_NUM_REQUIRED_ARGS(x) SCM_I_INUM (CAR (BOOT_CLOSURE_CODE (x))) +#define BOOT_CLOSURE_HAS_REST_ARGS(x) scm_is_true (CADR (BOOT_CLOSURE_CODE (x))) +#define BOOT_CLOSURE_BODY(x) CDDR (BOOT_CLOSURE_CODE (x)) + + + #if 0 #define CAR(x) SCM_CAR(x) #define CDR(x) SCM_CDR(x) @@ -192,7 +207,7 @@ eval (SCM x, SCM env) } case SCM_M_LAMBDA: - return scm_closure (mx, CAPTURE_ENV (env)); + RETURN_BOOT_CLOSURE (mx, CAPTURE_ENV (env)); case SCM_M_QUOTE: return mx; @@ -210,11 +225,11 @@ eval (SCM x, SCM env) apply_proc: /* Go here to tail-apply a procedure. PROC is the procedure and * ARGS is the list of arguments. */ - if (SCM_CLOSUREP (proc)) + if (BOOT_CLOSURE_P (proc)) { - int nreq = SCM_CLOSURE_NUM_REQUIRED_ARGS (proc); - SCM new_env = SCM_ENV (proc); - if (SCM_CLOSURE_HAS_REST_ARGS (proc)) + int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc); + SCM new_env = BOOT_CLOSURE_ENV (proc); + if (BOOT_CLOSURE_HAS_REST_ARGS (proc)) { if (SCM_UNLIKELY (scm_ilength (args) < nreq)) scm_wrong_num_args (proc); @@ -229,7 +244,7 @@ eval (SCM x, SCM env) for (; scm_is_pair (args); args = CDR (args)) new_env = scm_cons (CAR (args), new_env); } - x = SCM_CLOSURE_BODY (proc); + x = BOOT_CLOSURE_BODY (proc); env = new_env; goto loop; } @@ -242,11 +257,11 @@ eval (SCM x, SCM env) mx = CDR (mx); - if (SCM_CLOSUREP (proc)) + if (BOOT_CLOSURE_P (proc)) { - int nreq = SCM_CLOSURE_NUM_REQUIRED_ARGS (proc); - SCM new_env = SCM_ENV (proc); - if (SCM_CLOSURE_HAS_REST_ARGS (proc)) + int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc); + SCM new_env = BOOT_CLOSURE_ENV (proc); + if (BOOT_CLOSURE_HAS_REST_ARGS (proc)) { if (SCM_UNLIKELY (scm_ilength (mx) < nreq)) scm_wrong_num_args (proc); @@ -267,7 +282,7 @@ eval (SCM x, SCM env) if (SCM_UNLIKELY (nreq != 0)) scm_wrong_num_args (proc); } - x = SCM_CLOSURE_BODY (proc); + x = BOOT_CLOSURE_BODY (proc); env = new_env; goto loop; } @@ -390,42 +405,6 @@ eval (SCM x, SCM env) } } -SCM -scm_closure_apply (SCM proc, SCM args) -{ - unsigned int nargs; - int nreq; - SCM env; - - /* Args contains a list of all args. */ - { - int ilen = scm_ilength (args); - if (ilen < 0) - scm_wrong_num_args (proc); - nargs = ilen; - } - - nreq = SCM_CLOSURE_NUM_REQUIRED_ARGS (proc); - env = SCM_ENV (proc); - if (SCM_CLOSURE_HAS_REST_ARGS (proc)) - { - if (SCM_UNLIKELY (scm_ilength (args) < nreq)) - scm_wrong_num_args (proc); - for (; nreq; nreq--, args = CDR (args)) - env = scm_cons (CAR (args), env); - env = scm_cons (args, env); - } - else - { - for (; scm_is_pair (args); args = CDR (args), nreq--) - env = scm_cons (CAR (args), env); - if (SCM_UNLIKELY (nreq != 0)) - scm_wrong_num_args (proc); - } - return eval (SCM_CLOSURE_BODY (proc), env); -} - - scm_t_option scm_eval_opts[] = { { SCM_OPTION_INTEGER, "stack", 22000, "Size of thread stacks (in machine words)." }, { 0 } @@ -814,18 +793,6 @@ scm_for_each (SCM proc, SCM arg1, SCM args) #undef FUNC_NAME -SCM -scm_closure (SCM code, SCM env) -{ - SCM z; - SCM closcar = scm_cons (code, SCM_EOL); - z = scm_immutable_cell (SCM_UNPACK (closcar) + scm_tc3_closure, - (scm_t_bits) env); - scm_remember_upto_here (closcar); - return z; -} - - static SCM scm_c_primitive_eval (SCM exp) { @@ -907,6 +874,45 @@ scm_apply (SCM proc, SCM arg1, SCM args) } +static SCM +boot_closure_apply (SCM closure, SCM args) +{ + int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (closure); + SCM new_env = BOOT_CLOSURE_ENV (closure); + if (BOOT_CLOSURE_HAS_REST_ARGS (closure)) + { + if (SCM_UNLIKELY (scm_ilength (args) < nreq)) + scm_wrong_num_args (closure); + for (; nreq; nreq--, args = CDR (args)) + new_env = scm_cons (CAR (args), new_env); + new_env = scm_cons (args, new_env); + } + else + { + if (SCM_UNLIKELY (scm_ilength (args) != nreq)) + scm_wrong_num_args (closure); + for (; scm_is_pair (args); args = CDR (args)) + new_env = scm_cons (CAR (args), new_env); + } + return eval (BOOT_CLOSURE_BODY (closure), new_env); +} + +static int +boot_closure_print (SCM closure, SCM port, scm_print_state *pstate) +{ + SCM args; + scm_puts ("#<boot-closure ", port); + scm_uintprint ((unsigned long)SCM2PTR (closure), 16, port); + scm_putc (' ', port); + args = scm_make_list (scm_from_int (BOOT_CLOSURE_NUM_REQUIRED_ARGS (closure)), + scm_from_locale_symbol ("_")); + if (BOOT_CLOSURE_HAS_REST_ARGS (closure)) + args = scm_cons_star (scm_from_locale_symbol ("_"), args); + scm_display (args, port); + scm_putc ('>', port); + return 1; +} + void scm_init_eval () { @@ -922,6 +928,10 @@ scm_init_eval () f_apply = scm_c_define_gsubr ("apply", 2, 0, 1, scm_apply); scm_permanent_object (f_apply); + scm_tc16_boot_closure = scm_make_smob_type ("boot-closure", 0); + scm_set_smob_apply (scm_tc16_boot_closure, boot_closure_apply, 0, 0, 1); + scm_set_smob_print (scm_tc16_boot_closure, boot_closure_print); + primitive_eval = scm_c_make_gsubr ("primitive-eval", 1, 0, 0, scm_c_primitive_eval); var_primitive_eval = scm_define (SCM_SUBR_NAME (primitive_eval), diff --git a/libguile/eval.h b/libguile/eval.h index 62b84c11b..6341f14b4 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -73,14 +73,11 @@ SCM_API SCM scm_apply_0 (SCM proc, SCM args); SCM_API SCM scm_apply_1 (SCM proc, SCM arg1, SCM args); SCM_API SCM scm_apply_2 (SCM proc, SCM arg1, SCM arg2, SCM args); SCM_API SCM scm_apply_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM args); -SCM_INTERNAL SCM scm_i_call_closure_0 (SCM proc); SCM_API SCM scm_nconc2last (SCM lst); SCM_API SCM scm_apply (SCM proc, SCM arg1, SCM args); -SCM_INTERNAL SCM scm_closure_apply (SCM proc, SCM args); #define scm_dapply(proc,arg1,args) scm_apply (proc, arg1, args) SCM_API SCM scm_map (SCM proc, SCM arg1, SCM args); SCM_API SCM scm_for_each (SCM proc, SCM arg1, SCM args); -SCM_API SCM scm_closure (SCM code, SCM env); SCM_API SCM scm_primitive_eval (SCM exp); #define scm_primitive_eval_x(exp) scm_primitive_eval (exp) SCM_API SCM scm_eval (SCM exp, SCM module); diff --git a/libguile/evalext.c b/libguile/evalext.c index 1d5aa9319..27dd98506 100644 --- a/libguile/evalext.c +++ b/libguile/evalext.c @@ -75,7 +75,6 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0, 0, case scm_tc3_cons: switch (SCM_TYP7 (obj)) { - case scm_tcs_closures: case scm_tc7_vector: case scm_tc7_wvect: case scm_tc7_number: diff --git a/libguile/gc.c b/libguile/gc.c index 15f424ab3..6a702507c 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -631,7 +631,7 @@ scm_storage_prehistory () pointer to an 8-octet aligned region). For `scm_tc3_struct', this is handled in `scm_alloc_struct ()'. */ GC_REGISTER_DISPLACEMENT (scm_tc3_cons); - GC_REGISTER_DISPLACEMENT (scm_tc3_closure); + /* GC_REGISTER_DISPLACEMENT (scm_tc3_unused); */ /* Sanity check. */ if (!GC_is_visible (scm_sys_protects)) @@ -754,18 +754,12 @@ scm_i_tag_name (scm_t_bits tag) return "cons (immediate car)"; case scm_tcs_cons_nimcar: return "cons (non-immediate car)"; - case scm_tcs_closures: - return "closures"; case scm_tc7_pws: return "pws"; case scm_tc7_wvect: return "weak vector"; case scm_tc7_vector: return "vector"; -#ifdef CCLO - case scm_tc7_cclo: - return "compiled closure"; -#endif case scm_tc7_number: switch (tag) { diff --git a/libguile/goops.c b/libguile/goops.c index 76ca14b28..f6b18ace5 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -205,8 +205,6 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, { case scm_tcs_cons_nimcar: return scm_class_pair; - case scm_tcs_closures: - return scm_class_procedure; case scm_tc7_symbol: return scm_class_symbol; case scm_tc7_vector: @@ -292,7 +290,7 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, case scm_tc3_struct: case scm_tc3_tc7_1: case scm_tc3_tc7_2: - case scm_tc3_closure: + /* case scm_tc3_unused: */ /* Never reached */ break; } diff --git a/libguile/hash.c b/libguile/hash.c index e352b1c25..e56fab0b6 100644 --- a/libguile/hash.c +++ b/libguile/hash.c @@ -169,7 +169,7 @@ scm_hasher(SCM obj, unsigned long n, size_t d) else return 1; case scm_tc7_port: return ((SCM_RDNG & SCM_CELL_WORD_0 (obj)) ? 260 : 261) % n; - case scm_tcs_closures: + /* case scm_tcs_closures: */ case scm_tc7_gsubr: return 262 % n; } diff --git a/libguile/hooks.c b/libguile/hooks.c index c6541fadd..d7bf018be 100644 --- a/libguile/hooks.c +++ b/libguile/hooks.c @@ -203,16 +203,13 @@ SCM_DEFINE (scm_add_hook_x, "add-hook!", 2, 1, 0, "procedure is not specified.") #define FUNC_NAME s_scm_add_hook_x { - SCM arity, rest; - int n_args; + SCM rest; + int n_args, p_req, p_opt, p_rest; SCM_VALIDATE_HOOK (1, hook); - SCM_ASSERT (scm_is_true (arity = scm_i_procedure_arity (proc)), + SCM_ASSERT (scm_i_procedure_arity (proc, &p_req, &p_opt, &p_rest), proc, SCM_ARG2, FUNC_NAME); n_args = SCM_HOOK_ARITY (hook); - if (scm_to_int (SCM_CAR (arity)) > n_args - || (scm_is_false (SCM_CADDR (arity)) - && (scm_to_int (SCM_CAR (arity)) + scm_to_int (SCM_CADR (arity)) - < n_args))) + if (p_req > n_args || (!p_rest && p_req + p_opt < n_args)) scm_wrong_type_arg (FUNC_NAME, 2, proc); rest = scm_delq_x (proc, SCM_HOOK_PROCEDURES (hook)); SCM_SET_HOOK_PROCEDURES (hook, diff --git a/libguile/macros.c b/libguile/macros.c index d7c054e72..0d714000c 100644 --- a/libguile/macros.c +++ b/libguile/macros.c @@ -46,46 +46,42 @@ static int macro_print (SCM macro, SCM port, scm_print_state *pstate) { SCM code = SCM_MACRO_CODE (macro); - if (!SCM_CLOSUREP (code) - || scm_is_false (scm_procedure_p (SCM_PRINT_CLOSURE)) - || scm_is_false (scm_printer_apply (SCM_PRINT_CLOSURE, - macro, port, pstate))) - { - scm_puts ("#<", port); - if (SCM_MACRO_TYPE (macro) < 4 && SCM_MACRO_IS_EXTENDED (macro)) - scm_puts ("extended-", port); + scm_puts ("#<", port); + + if (SCM_MACRO_TYPE (macro) < 4 && SCM_MACRO_IS_EXTENDED (macro)) + scm_puts ("extended-", port); - if (!SCM_CLOSUREP (code) && !SCM_PROGRAM_P (code)) - scm_puts ("primitive-", port); + /* FIXME: doesn't catch boot closures; but do we care? */ + if (!SCM_PROGRAM_P (code)) + scm_puts ("primitive-", port); - if (SCM_MACRO_TYPE (macro) == 0) - scm_puts ("syntax", port); + if (SCM_MACRO_TYPE (macro) == 0) + scm_puts ("syntax", port); #if SCM_ENABLE_DEPRECATED == 1 - if (SCM_MACRO_TYPE (macro) == 1) - scm_puts ("macro", port); + if (SCM_MACRO_TYPE (macro) == 1) + scm_puts ("macro", port); #endif - if (SCM_MACRO_TYPE (macro) == 2) - scm_puts ("macro!", port); - if (SCM_MACRO_TYPE (macro) == 3) - scm_puts ("builtin-macro!", port); - if (SCM_MACRO_TYPE (macro) == 4) - scm_puts ("syncase-macro", port); - - scm_putc (' ', port); - scm_iprin1 (scm_macro_name (macro), port, pstate); + if (SCM_MACRO_TYPE (macro) == 2) + scm_puts ("macro!", port); + if (SCM_MACRO_TYPE (macro) == 3) + scm_puts ("builtin-macro!", port); + if (SCM_MACRO_TYPE (macro) == 4) + scm_puts ("syncase-macro", port); - if (SCM_MACRO_IS_EXTENDED (macro)) - { - scm_putc (' ', port); - scm_write (SCM_SMOB_OBJECT_2 (macro), port); - scm_putc (' ', port); - scm_write (SCM_SMOB_OBJECT_3 (macro), port); - } + scm_putc (' ', port); + scm_iprin1 (scm_macro_name (macro), port, pstate); - scm_putc ('>', port); + if (SCM_MACRO_IS_EXTENDED (macro)) + { + scm_putc (' ', port); + scm_write (SCM_SMOB_OBJECT_2 (macro), port); + scm_putc (' ', port); + scm_write (SCM_SMOB_OBJECT_3 (macro), port); } + scm_putc ('>', port); + return 1; } @@ -273,7 +269,7 @@ SCM_DEFINE (scm_macro_transformer, "macro-transformer", 1, 0, 0, SCM_VALIDATE_SMOB (1, m, macro); data = SCM_PACK (SCM_SMOB_DATA (m)); - if (SCM_CLOSUREP (data) || SCM_PROGRAM_P (data)) + if (scm_is_true (scm_procedure_p (data))) return data; else return SCM_BOOL_F; diff --git a/libguile/print.c b/libguile/print.c index 9d737c8e2..a268a0c23 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -428,7 +428,6 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) { switch (SCM_ITAG3 (exp)) { - case scm_tc3_closure: case scm_tc3_tc7_1: case scm_tc3_tc7_2: /* These tc3 tags should never occur in an immediate value. They are @@ -561,22 +560,6 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) circref: print_circref (port, pstate, exp); break; - case scm_tcs_closures: - if (scm_is_false (scm_procedure_p (SCM_PRINT_CLOSURE)) - || scm_is_false (scm_printer_apply (SCM_PRINT_CLOSURE, - exp, port, pstate))) - { - scm_puts ("#<procedure", port); - scm_putc (' ', port); - scm_iprin1 (scm_procedure_name (exp), port, pstate); - scm_putc (' ', port); - scm_iprin1 - (scm_cons (SCM_I_MAKINUM (SCM_CLOSURE_NUM_REQUIRED_ARGS (exp)), - scm_from_bool (SCM_CLOSURE_HAS_REST_ARGS (exp))), - port, pstate); - scm_putc ('>', port); - } - break; case scm_tc7_number: switch SCM_TYP16 (exp) { case scm_tc16_big: @@ -820,6 +803,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) EXIT_NESTED_DATA (pstate); break; default: + /* case scm_tcs_closures: */ punk: scm_ipruk ("type", exp, port); } diff --git a/libguile/procprop.c b/libguile/procprop.c index c69dbd238..c452c28d7 100644 --- a/libguile/procprop.c +++ b/libguile/procprop.c @@ -41,65 +41,49 @@ SCM_GLOBAL_SYMBOL (scm_sym_system_procedure, "system-procedure"); SCM_GLOBAL_SYMBOL (scm_sym_arity, "arity"); -static SCM non_closure_props; -static scm_i_pthread_mutex_t non_closure_props_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER; +static SCM props; +static scm_i_pthread_mutex_t props_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER; -SCM -scm_i_procedure_arity (SCM proc) +int +scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest) { - int a = 0, o = 0, r = 0; if (SCM_IMP (proc)) - return SCM_BOOL_F; + return 0; loop: switch (SCM_TYP7 (proc)) { case scm_tc7_program: - if (scm_i_program_arity (proc, &a, &o, &r)) - break; - else - return SCM_BOOL_F; + return scm_i_program_arity (proc, req, opt, rest); case scm_tc7_smob: if (SCM_SMOB_APPLICABLE_P (proc)) { int type = SCM_SMOB_DESCRIPTOR (proc).gsubr_type; - a += SCM_GSUBR_REQ (type); - o = SCM_GSUBR_OPT (type); - r = SCM_GSUBR_REST (type); - break; + *req = SCM_GSUBR_REQ (type); + *opt = SCM_GSUBR_OPT (type); + *rest = SCM_GSUBR_REST (type); + return 1; } else - { - return SCM_BOOL_F; - } + return 0; case scm_tc7_gsubr: { unsigned int type = SCM_GSUBR_TYPE (proc); - a = SCM_GSUBR_REQ (type); - o = SCM_GSUBR_OPT (type); - r = SCM_GSUBR_REST (type); - break; + *req = SCM_GSUBR_REQ (type); + *opt = SCM_GSUBR_OPT (type); + *rest = SCM_GSUBR_REST (type); + return 1; } case scm_tc7_pws: proc = SCM_PROCEDURE (proc); goto loop; - case scm_tcs_closures: - a = SCM_CLOSURE_NUM_REQUIRED_ARGS (proc); - r = SCM_CLOSURE_HAS_REST_ARGS (proc) ? 1 : 0; - break; case scm_tcs_struct: - if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) - { - r = 1; - break; - } - else if (!SCM_STRUCT_APPLICABLE_P (proc)) - return SCM_BOOL_F; + if (!SCM_STRUCT_APPLICABLE_P (proc)) + return 0; proc = SCM_STRUCT_PROCEDURE (proc); goto loop; default: - return SCM_BOOL_F; + return 0; } - return scm_list_3 (scm_from_int (a), scm_from_int (o), scm_from_bool(r)); } /* FIXME: instead of the weak hash, perhaps for some kinds of procedures, use @@ -111,18 +95,22 @@ SCM_DEFINE (scm_procedure_properties, "procedure-properties", 1, 0, 0, "Return @var{obj}'s property list.") #define FUNC_NAME s_scm_procedure_properties { - SCM props; + SCM ret; + int req, opt, rest; SCM_VALIDATE_PROC (1, proc); - if (SCM_CLOSUREP (proc)) - props = SCM_PROCPROPS (proc); - else - { - scm_i_pthread_mutex_lock (&non_closure_props_lock); - props = scm_hashq_ref (non_closure_props, proc, SCM_EOL); - scm_i_pthread_mutex_unlock (&non_closure_props_lock); - } - return scm_acons (scm_sym_arity, scm_i_procedure_arity (proc), props); + + scm_i_pthread_mutex_lock (&props_lock); + ret = scm_hashq_ref (props, proc, SCM_EOL); + scm_i_pthread_mutex_unlock (&props_lock); + + scm_i_procedure_arity (proc, &req, &opt, &rest); + + return scm_acons (scm_sym_arity, + scm_list_3 (scm_from_int (req), + scm_from_int (opt), + scm_from_bool (rest)), + ret); } #undef FUNC_NAME @@ -133,14 +121,10 @@ SCM_DEFINE (scm_set_procedure_properties_x, "set-procedure-properties!", 2, 0, 0 { SCM_VALIDATE_PROC (1, proc); - if (SCM_CLOSUREP (proc)) - SCM_SETPROCPROPS (proc, alist); - else - { - scm_i_pthread_mutex_lock (&non_closure_props_lock); - scm_hashq_set_x (non_closure_props, proc, alist); - scm_i_pthread_mutex_unlock (&non_closure_props_lock); - } + scm_i_pthread_mutex_lock (&props_lock); + scm_hashq_set_x (props, proc, alist); + scm_i_pthread_mutex_unlock (&props_lock); + return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -154,19 +138,22 @@ SCM_DEFINE (scm_procedure_property, "procedure-property", 2, 0, 0, if (scm_is_eq (key, scm_sym_arity)) /* avoid a cons in this case */ - return scm_i_procedure_arity (proc); + { + int req, opt, rest; + scm_i_procedure_arity (proc, &req, &opt, &rest); + return scm_list_3 (scm_from_int (req), + scm_from_int (opt), + scm_from_bool (rest)); + } else { - SCM props; - if (SCM_CLOSUREP (proc)) - props = SCM_PROCPROPS (proc); - else - { - scm_i_pthread_mutex_lock (&non_closure_props_lock); - props = scm_hashq_ref (non_closure_props, proc, SCM_EOL); - scm_i_pthread_mutex_unlock (&non_closure_props_lock); - } - return scm_assq_ref (props, key); + SCM ret; + + scm_i_pthread_mutex_lock (&props_lock); + ret = scm_hashq_ref (props, proc, SCM_EOL); + scm_i_pthread_mutex_unlock (&props_lock); + + return scm_assq_ref (ret, key); } } #undef FUNC_NAME @@ -182,18 +169,12 @@ SCM_DEFINE (scm_set_procedure_property_x, "set-procedure-property!", 3, 0, 0, if (scm_is_eq (key, scm_sym_arity)) SCM_MISC_ERROR ("arity is a read-only property", SCM_EOL); - if (SCM_CLOSUREP (proc)) - SCM_SETPROCPROPS (proc, - scm_assq_set_x (SCM_PROCPROPS (proc), key, val)); - else - { - scm_i_pthread_mutex_lock (&non_closure_props_lock); - scm_hashq_set_x (non_closure_props, proc, - scm_assq_set_x (scm_hashq_ref (non_closure_props, proc, - SCM_EOL), - key, val)); - scm_i_pthread_mutex_unlock (&non_closure_props_lock); - } + scm_i_pthread_mutex_lock (&props_lock); + scm_hashq_set_x (props, proc, + scm_assq_set_x (scm_hashq_ref (props, proc, + SCM_EOL), + key, val)); + scm_i_pthread_mutex_unlock (&props_lock); return SCM_UNSPECIFIED; } @@ -205,7 +186,7 @@ SCM_DEFINE (scm_set_procedure_property_x, "set-procedure-property!", 3, 0, 0, void scm_init_procprop () { - non_closure_props = scm_make_weak_key_hash_table (SCM_UNDEFINED); + props = scm_make_weak_key_hash_table (SCM_UNDEFINED); #include "libguile/procprop.x" } diff --git a/libguile/procprop.h b/libguile/procprop.h index 7a1131489..50f04b261 100644 --- a/libguile/procprop.h +++ b/libguile/procprop.h @@ -33,7 +33,7 @@ SCM_API SCM scm_sym_system_procedure; -SCM_INTERNAL SCM scm_i_procedure_arity (SCM proc); +SCM_INTERNAL int scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest); SCM_API SCM scm_procedure_properties (SCM proc); SCM_API SCM scm_set_procedure_properties_x (SCM proc, SCM alist); SCM_API SCM scm_procedure_property (SCM proc, SCM key); diff --git a/libguile/procs.c b/libguile/procs.c index c163bf6f1..71d50bdd7 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -100,7 +100,6 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0, if (!((SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_PURE_GENERIC) || SCM_STRUCT_APPLICABLE_P (obj))) break; - case scm_tcs_closures: case scm_tc7_gsubr: case scm_tc7_pws: case scm_tc7_program: @@ -114,45 +113,14 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_closure_p, "closure?", 1, 0, 0, - (SCM obj), - "Return @code{#t} if @var{obj} is a closure.") -#define FUNC_NAME s_scm_closure_p -{ - return scm_from_bool (SCM_CLOSUREP (obj)); -} -#undef FUNC_NAME - SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0, (SCM obj), "Return @code{#t} if @var{obj} is a thunk.") #define FUNC_NAME s_scm_thunk_p { - if (SCM_NIMP (obj)) - { - again: - switch (SCM_TYP7 (obj)) - { - case scm_tcs_closures: - return scm_from_bool (SCM_CLOSURE_NUM_REQUIRED_ARGS (obj) == 0); - case scm_tc7_gsubr: - return scm_from_bool (SCM_GSUBR_REQ (SCM_GSUBR_TYPE (obj)) == 0); - case scm_tc7_program: - { - int a, o, r; - if (scm_i_program_arity (obj, &a, &o, &r)) - return scm_from_bool (a == 0); - else - return SCM_BOOL_F; - } - case scm_tc7_pws: - obj = SCM_PROCEDURE (obj); - goto again; - default: - return SCM_BOOL_F; - } - } - return SCM_BOOL_F; + int req, opt, rest; + return scm_from_bool (scm_i_procedure_arity (obj, &req, &opt, &rest) + && req == 0); } #undef FUNC_NAME @@ -181,25 +149,11 @@ SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0, "documentation for that procedure.") #define FUNC_NAME s_scm_procedure_documentation { - SCM code; - SCM_ASSERT (scm_is_true (scm_procedure_p (proc)), - proc, SCM_ARG1, FUNC_NAME); + SCM_VALIDATE_PROC (SCM_ARG1, proc); if (SCM_PROGRAM_P (proc)) return scm_assq_ref (scm_program_properties (proc), sym_documentation); - switch (SCM_TYP7 (proc)) - { - case scm_tcs_closures: - code = SCM_CLOSURE_BODY (proc); - if (scm_is_null (SCM_CDR (code))) - return SCM_BOOL_F; - code = SCM_CAR (code); - if (scm_is_string (code)) - return code; - else - return SCM_BOOL_F; - default: - return SCM_BOOL_F; - } + else + return SCM_BOOL_F; } #undef FUNC_NAME diff --git a/libguile/procs.h b/libguile/procs.h index 369d9e142..cb19e4c4b 100644 --- a/libguile/procs.h +++ b/libguile/procs.h @@ -47,20 +47,6 @@ -/* Closures - */ - -#define SCM_CLOSUREP(x) (!SCM_IMP(x) && (SCM_TYP3 (x) == scm_tc3_closure)) -#define SCM_CLOSCAR(x) SCM_PACK (SCM_CELL_WORD_0 (x) - scm_tc3_closure) -#define SCM_CODE(x) SCM_CAR (SCM_CLOSCAR (x)) -#define SCM_CLOSURE_NUM_REQUIRED_ARGS(x) SCM_I_INUM (SCM_CAR (SCM_CODE (x))) -#define SCM_CLOSURE_HAS_REST_ARGS(x) scm_is_true (SCM_CADR (SCM_CODE (x))) -#define SCM_CLOSURE_BODY(x) SCM_CDDR (SCM_CODE (x)) -#define SCM_PROCPROPS(x) SCM_CDR (SCM_CLOSCAR (x)) -#define SCM_SETPROCPROPS(x, p) SCM_SETCDR (SCM_CLOSCAR (x), p) -#define SCM_ENV(x) SCM_CELL_OBJECT_1 (x) -#define SCM_TOP_LEVEL(ENV) (scm_is_null (ENV) || (scm_is_true (scm_procedure_p (SCM_CAR (ENV))))) - /* Procedure-with-setter Four representations for procedure-with-setters were @@ -122,7 +108,6 @@ SCM_API SCM scm_c_define_subr (const char *name, long type, SCM (*fcn)()); SCM_API SCM scm_c_define_subr_with_generic (const char *name, long type, SCM (*fcn)(), SCM *gf); SCM_API SCM scm_procedure_p (SCM obj); -SCM_API SCM scm_closure_p (SCM obj); SCM_API SCM scm_thunk_p (SCM obj); SCM_API int scm_subr_p (SCM obj); SCM_API SCM scm_procedure_documentation (SCM proc); diff --git a/libguile/tags.h b/libguile/tags.h index 19260c301..915f6f3ed 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -386,7 +386,7 @@ typedef scm_t_uintptr scm_t_bits; #define scm_tc3_cons 0 #define scm_tc3_struct 1 #define scm_tc3_int_1 (scm_tc2_int + 0) -#define scm_tc3_closure 3 +#define scm_tc3_unused 3 #define scm_tc3_imm24 4 #define scm_tc3_tc7_1 5 #define scm_tc3_int_2 (scm_tc2_int + 4) @@ -652,26 +652,6 @@ enum scm_tc8_tags case scm_tc3_struct + 112:\ case scm_tc3_struct + 120 -/* For closures - */ -#define scm_tcs_closures \ - scm_tc3_closure + 0:\ - case scm_tc3_closure + 8:\ - case scm_tc3_closure + 16:\ - case scm_tc3_closure + 24:\ - case scm_tc3_closure + 32:\ - case scm_tc3_closure + 40:\ - case scm_tc3_closure + 48:\ - case scm_tc3_closure + 56:\ - case scm_tc3_closure + 64:\ - case scm_tc3_closure + 72:\ - case scm_tc3_closure + 80:\ - case scm_tc3_closure + 88:\ - case scm_tc3_closure + 96:\ - case scm_tc3_closure + 104:\ - case scm_tc3_closure + 112:\ - case scm_tc3_closure + 120 - /* For subrs */ #define scm_tcs_subrs \ diff --git a/libguile/validate.h b/libguile/validate.h index be4ed484b..094565812 100644 --- a/libguile/validate.h +++ b/libguile/validate.h @@ -296,8 +296,6 @@ #define SCM_VALIDATE_MEMOIZED(pos, obj) SCM_MAKE_VALIDATE_MSG (pos, obj, MEMOIZED_P, "memoized code") -#define SCM_VALIDATE_CLOSURE(pos, obj) SCM_MAKE_VALIDATE_MSG (pos, obj, CLOSUREP, "closure") - #define SCM_VALIDATE_PROC(pos, proc) \ do { \ SCM_ASSERT (scm_is_true (scm_procedure_p (proc)), proc, pos, FUNC_NAME); \ diff --git a/libguile/vm.c b/libguile/vm.c index fdca9ea54..37f74e582 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -269,14 +269,6 @@ apply_foreign (SCM proc, SCM *args, int nargs, int headroom) switch (SCM_TYP7 (proc)) { - case scm_tcs_closures: - /* FIXME: pre-boot closures should be smobs */ - { - SCM arglist = SCM_EOL; - while (nargs--) - arglist = scm_cons (args[nargs], arglist); - return scm_closure_apply (proc, arglist); - } case scm_tc7_smob: if (!SCM_SMOB_APPLICABLE_P (proc)) goto badproc; diff --git a/module/ice-9/deprecated.scm b/module/ice-9/deprecated.scm index 3176ebc53..0d632b2c8 100644 --- a/module/ice-9/deprecated.scm +++ b/module/ice-9/deprecated.scm @@ -224,3 +224,7 @@ (define ($sinh z) (sinh z)) (define ($cosh z) (cosh z)) (define ($tanh z) (tanh z)) +(define (closure? x) + (issue-deprecation-warning + "`closure?' is deprecated. Use `procedure?' instead.") + (procedure? x)) diff --git a/module/ice-9/documentation.scm b/module/ice-9/documentation.scm index bbd6713f6..37c3bf73f 100644 --- a/module/ice-9/documentation.scm +++ b/module/ice-9/documentation.scm @@ -1,4 +1,4 @@ -;;;; Copyright (C) 2000,2001, 2002, 2003, 2006 Free Software Foundation, Inc. +;;;; Copyright (C) 2000,2001, 2002, 2003, 2006, 2009 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -201,7 +201,6 @@ OBJECT can be a procedure, macro or any object that has its (and (macro? object) (object-documentation (macro-transformer object))) (and (procedure? object) - (not (closure? object)) (procedure-name object) (let ((docstring (search-documentation-files (procedure-name object)))) diff --git a/module/ice-9/session.scm b/module/ice-9/session.scm index 70708c310..f6cad46b0 100644 --- a/module/ice-9/session.scm +++ b/module/ice-9/session.scm @@ -163,10 +163,8 @@ You don't seem to have regular expressions installed.\n") (cons (list module name (try-value-help name object) - (cond ((closure? object) + (cond ((procedure? object) "a procedure") - ((procedure? object) - "a primitive procedure") (else "an object"))) data)) @@ -498,17 +496,7 @@ It is an image under the mapping EXTRACT." (= (car arity) 1) (<= (cadr arity) 1)) (display " argument") - (display " arguments")) - (if (closure? obj) - (let ((formals (cadr (procedure-source obj)))) - (cond - ((pair? formals) - (display ": ") - (display-arg-list formals)) - (else - (display " in `") - (display formals) - (display #\')))))))) + (display " arguments"))))) (display ".\n")) diff --git a/module/oop/goops.scm b/module/oop/goops.scm index 0195036b0..50d982895 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -1161,20 +1161,15 @@ ;;; compute-getters-n-setters ;;; -;; FIXME!!! -(define (make-thunk thunk) - (lambda () (thunk))) - (define (compute-getters-n-setters class slots) (define (compute-slot-init-function name s) (or (let ((thunk (slot-definition-init-thunk s))) (and thunk - (cond ((not (thunk? thunk)) - (goops-error "Bad init-thunk for slot `~S' in ~S: ~S" - name class thunk)) - ((closure? thunk) thunk) - (else (make-thunk thunk))))) + (if (thunk? thunk) + thunk + (goops-error "Bad init-thunk for slot `~S' in ~S: ~S" + name class thunk)))) (let ((init (slot-definition-init-value s))) (and (not (unbound? init)) (lambda () init))))) @@ -1187,18 +1182,11 @@ (else (let ((get (car l)) (set (cadr l))) - ;; note that we allow non-closures; we only check arity on - ;; the closures, though, because we inline their dispatch - ;; in %get-slot-value / %set-slot-value. - (if (or (not (procedure? get)) - (and (closure? get) - (not (= (car (procedure-property get 'arity)) 1)))) - (goops-error "Bad getter closure for slot `~S' in ~S: ~S" + (if (not (procedure? get)) + (goops-error "Bad getter closure for slot `~S' in ~S: ~S" slot class get)) - (if (or (not (procedure? set)) - (and (closure? set) - (not (= (car (procedure-property set 'arity)) 2)))) - (goops-error "Bad setter closure for slot `~S' in ~S: ~S" + (if (not (procedure? set)) + (goops-error "Bad setter closure for slot `~S' in ~S: ~S" slot class set)))))) (map (lambda (s) diff --git a/module/oop/goops/describe.scm b/module/oop/goops/describe.scm index fa7bc466c..86b2d2ce4 100644 --- a/module/oop/goops/describe.scm +++ b/module/oop/goops/describe.scm @@ -1,6 +1,6 @@ ;;; installed-scm-file -;;;; Copyright (C) 1998, 1999, 2001, 2006, 2008 Free Software Foundation, Inc. +;;;; Copyright (C) 1998, 1999, 2001, 2006, 2008, 2009 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -67,10 +67,7 @@ (display x)) (display " is ") (display (if name #\a "an anonymous")) - (display (cond ((closure? x) " procedure") - ((not (struct? x)) " primitive procedure") - ((entity? x) " entity") - (else " operator"))) + (display " procedure") (display " with ") (arity x))) diff --git a/module/system/repl/describe.scm b/module/system/repl/describe.scm index 590d2235a..7077f3766 100644 --- a/module/system/repl/describe.scm +++ b/module/system/repl/describe.scm @@ -1,6 +1,6 @@ ;;; Describe objects -;; Copyright (C) 2001 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Lesser General Public @@ -200,17 +200,7 @@ (define-method (display-object (obj <procedure>)) (cond - ((closure? obj) - ;; Construct output from the source. - (display "(") - (display (procedure-name obj)) - (let ((args (cadr (procedure-source obj)))) - (cond ((null? args) (display ")")) - ((pair? args) - (let ((str (with-output-to-string (lambda () (display args))))) - (format #t " ~a" (string-upcase! (substring str 1))))) - (else - (format #t " . ~a)" (string-upcase! (symbol->string args))))))) + ;; FIXME: VM programs, ... (else ;; Primitive procedure. Let's lookup the dictionary. (and-let* ((entry (lookup-procedure obj))) @@ -240,10 +230,8 @@ (define-method (display-type (obj <procedure>)) (cond ((and (thunk? obj) (not (procedure-name obj))) (display "a thunk")) - ((closure? obj) (display-class <procedure> "a procedure")) ((procedure-with-setter? obj) (display-class <procedure-with-setter> "a procedure with setter")) - ((not (struct? obj)) (display "a primitive procedure")) (else (display-class <procedure> "a procedure"))) (display ".\n")) @@ -252,9 +240,8 @@ (display-file (entry-file entry)))) (define-method (display-documentation (obj <procedure>)) - (cond ((cond ((closure? obj) (procedure-documentation obj)) - ((lookup-procedure obj) => entry-text) - (else #f)) + (cond ((or (procedure-documentation obj) + (and=> (lookup-procedure obj) entry-text)) => format-documentation) (else (next-method)))) |