mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-17 17:20:29 +02:00
Code Activity

eval.c closures are now applicable smobs, not tc3s

Browse source 
* 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?.
This commit is contained in:
Andy Wingo 2009-12-04 19:20:11 +01:00
parent f36878ba2d
commit 314b87163e
24 changed files with 191 additions and 393 deletions
Download patch file Download diff file Expand all files Collapse all files

29
libguile/debug.c
View file

@ -143,14 +143,6 @@ SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
default: default:
{ {
SCM name = scm_procedure_property (proc, scm_sym_name); 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)) if (scm_is_false (name) && SCM_PROGRAM_P (proc))
name = scm_program_name (proc); name = scm_program_name (proc);
return name; return name;
@ -193,27 +185,6 @@ SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
} }
#undef FUNC_NAME #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

1
libguile/debug.h
View file

@ -43,7 +43,6 @@ typedef union scm_t_debug_info
SCM_API SCM scm_reverse_lookup (SCM env, SCM data); 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_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_source (SCM proc);
SCM_API SCM scm_procedure_name (SCM proc); SCM_API SCM scm_procedure_name (SCM proc);
SCM_API SCM scm_with_traps (SCM thunk); SCM_API SCM scm_with_traps (SCM thunk);

128
libguile/eval.c
View file

@ -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 #if 0
#define CAR(x) SCM_CAR(x) #define CAR(x) SCM_CAR(x)
#define CDR(x) SCM_CDR(x) #define CDR(x) SCM_CDR(x)
@ -192,7 +207,7 @@ eval (SCM x, SCM env)
} }
case SCM_M_LAMBDA: case SCM_M_LAMBDA:
return scm_closure (mx, CAPTURE_ENV (env)); RETURN_BOOT_CLOSURE (mx, CAPTURE_ENV (env));
case SCM_M_QUOTE: case SCM_M_QUOTE:
return mx; return mx;
@ -210,11 +225,11 @@ eval (SCM x, SCM env)
apply_proc: apply_proc:
/* Go here to tail-apply a procedure. PROC is the procedure and /* Go here to tail-apply a procedure. PROC is the procedure and
* ARGS is the list of arguments. */ * ARGS is the list of arguments. */
if (SCM_CLOSUREP (proc)) if (BOOT_CLOSURE_P (proc))
{ {
int nreq = SCM_CLOSURE_NUM_REQUIRED_ARGS (proc); int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc);
SCM new_env = SCM_ENV (proc); SCM new_env = BOOT_CLOSURE_ENV (proc);
if (SCM_CLOSURE_HAS_REST_ARGS (proc)) if (BOOT_CLOSURE_HAS_REST_ARGS (proc))
{ {
if (SCM_UNLIKELY (scm_ilength (args) < nreq)) if (SCM_UNLIKELY (scm_ilength (args) < nreq))
scm_wrong_num_args (proc); scm_wrong_num_args (proc);
@ -229,7 +244,7 @@ eval (SCM x, SCM env)
for (; scm_is_pair (args); args = CDR (args)) for (; scm_is_pair (args); args = CDR (args))
new_env = scm_cons (CAR (args), new_env); new_env = scm_cons (CAR (args), new_env);
} }
x = SCM_CLOSURE_BODY (proc); x = BOOT_CLOSURE_BODY (proc);
env = new_env; env = new_env;
goto loop; goto loop;
} }
@ -242,11 +257,11 @@ eval (SCM x, SCM env)
mx = CDR (mx); mx = CDR (mx);
if (SCM_CLOSUREP (proc)) if (BOOT_CLOSURE_P (proc))
{ {
int nreq = SCM_CLOSURE_NUM_REQUIRED_ARGS (proc); int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc);
SCM new_env = SCM_ENV (proc); SCM new_env = BOOT_CLOSURE_ENV (proc);
if (SCM_CLOSURE_HAS_REST_ARGS (proc)) if (BOOT_CLOSURE_HAS_REST_ARGS (proc))
{ {
if (SCM_UNLIKELY (scm_ilength (mx) < nreq)) if (SCM_UNLIKELY (scm_ilength (mx) < nreq))
scm_wrong_num_args (proc); scm_wrong_num_args (proc);
@ -267,7 +282,7 @@ eval (SCM x, SCM env)
if (SCM_UNLIKELY (nreq != 0)) if (SCM_UNLIKELY (nreq != 0))
scm_wrong_num_args (proc); scm_wrong_num_args (proc);
} }
x = SCM_CLOSURE_BODY (proc); x = BOOT_CLOSURE_BODY (proc);
env = new_env; env = new_env;
goto loop; 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_t_option scm_eval_opts[] = {
{ SCM_OPTION_INTEGER, "stack", 22000, "Size of thread stacks (in machine words)." }, { SCM_OPTION_INTEGER, "stack", 22000, "Size of thread stacks (in machine words)." },
{ 0 } { 0 }
@ -814,18 +793,6 @@ scm_for_each (SCM proc, SCM arg1, SCM args)
#undef FUNC_NAME #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 static SCM
scm_c_primitive_eval (SCM exp) 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 void
scm_init_eval () scm_init_eval ()
{ {
@ -922,6 +928,10 @@ scm_init_eval ()
f_apply = scm_c_define_gsubr ("apply", 2, 0, 1, scm_apply); f_apply = scm_c_define_gsubr ("apply", 2, 0, 1, scm_apply);
scm_permanent_object (f_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, primitive_eval = scm_c_make_gsubr ("primitive-eval", 1, 0, 0,
scm_c_primitive_eval); scm_c_primitive_eval);
var_primitive_eval = scm_define (SCM_SUBR_NAME (primitive_eval), var_primitive_eval = scm_define (SCM_SUBR_NAME (primitive_eval),

3
libguile/eval.h
View file

@ -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_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_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_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_nconc2last (SCM lst);
SCM_API SCM scm_apply (SCM proc, SCM arg1, SCM args); 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) #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_map (SCM proc, SCM arg1, SCM args);
SCM_API SCM scm_for_each (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); SCM_API SCM scm_primitive_eval (SCM exp);
#define scm_primitive_eval_x(exp) scm_primitive_eval (exp) #define scm_primitive_eval_x(exp) scm_primitive_eval (exp)
SCM_API SCM scm_eval (SCM exp, SCM module); SCM_API SCM scm_eval (SCM exp, SCM module);

1
libguile/evalext.c
View file

@ -75,7 +75,6 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0, 0,
case scm_tc3_cons: case scm_tc3_cons:
switch (SCM_TYP7 (obj)) switch (SCM_TYP7 (obj))
{ {
case scm_tcs_closures:
case scm_tc7_vector: case scm_tc7_vector:
case scm_tc7_wvect: case scm_tc7_wvect:
case scm_tc7_number: case scm_tc7_number:

8
libguile/gc.c
View file

@ -631,7 +631,7 @@ scm_storage_prehistory ()
pointer to an 8-octet aligned region). For `scm_tc3_struct', this is pointer to an 8-octet aligned region). For `scm_tc3_struct', this is
handled in `scm_alloc_struct ()'. */ handled in `scm_alloc_struct ()'. */
GC_REGISTER_DISPLACEMENT (scm_tc3_cons); GC_REGISTER_DISPLACEMENT (scm_tc3_cons);
GC_REGISTER_DISPLACEMENT (scm_tc3_closure); /* GC_REGISTER_DISPLACEMENT (scm_tc3_unused); */
/* Sanity check. */ /* Sanity check. */
if (!GC_is_visible (scm_sys_protects)) if (!GC_is_visible (scm_sys_protects))
@ -754,18 +754,12 @@ scm_i_tag_name (scm_t_bits tag)
return "cons (immediate car)"; return "cons (immediate car)";
case scm_tcs_cons_nimcar: case scm_tcs_cons_nimcar:
return "cons (non-immediate car)"; return "cons (non-immediate car)";
case scm_tcs_closures:
return "closures";
case scm_tc7_pws: case scm_tc7_pws:
return "pws"; return "pws";
case scm_tc7_wvect: case scm_tc7_wvect:
return "weak vector"; return "weak vector";
case scm_tc7_vector: case scm_tc7_vector:
return "vector"; return "vector";
#ifdef CCLO
case scm_tc7_cclo:
return "compiled closure";
#endif
case scm_tc7_number: case scm_tc7_number:
switch (tag) switch (tag)
{ {

4
libguile/goops.c
View file

@ -205,8 +205,6 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
{ {
case scm_tcs_cons_nimcar: case scm_tcs_cons_nimcar:
return scm_class_pair; return scm_class_pair;
case scm_tcs_closures:
return scm_class_procedure;
case scm_tc7_symbol: case scm_tc7_symbol:
return scm_class_symbol; return scm_class_symbol;
case scm_tc7_vector: 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_struct:
case scm_tc3_tc7_1: case scm_tc3_tc7_1:
case scm_tc3_tc7_2: case scm_tc3_tc7_2:
case scm_tc3_closure: /* case scm_tc3_unused: */
/* Never reached */ /* Never reached */
break; break;
} }

2
libguile/hash.c
View file

@ -169,7 +169,7 @@ scm_hasher(SCM obj, unsigned long n, size_t d)
else return 1; else return 1;
case scm_tc7_port: case scm_tc7_port:
return ((SCM_RDNG & SCM_CELL_WORD_0 (obj)) ? 260 : 261) % n; return ((SCM_RDNG & SCM_CELL_WORD_0 (obj)) ? 260 : 261) % n;
case scm_tcs_closures: /* case scm_tcs_closures: */
case scm_tc7_gsubr: case scm_tc7_gsubr:
return 262 % n; return 262 % n;
} }

11
libguile/hooks.c
View file

@ -203,16 +203,13 @@ SCM_DEFINE (scm_add_hook_x, "add-hook!", 2, 1, 0,
"procedure is not specified.") "procedure is not specified.")
#define FUNC_NAME s_scm_add_hook_x #define FUNC_NAME s_scm_add_hook_x
{ {
SCM arity, rest; SCM rest;
int n_args; int n_args, p_req, p_opt, p_rest;
SCM_VALIDATE_HOOK (1, hook); 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); proc, SCM_ARG2, FUNC_NAME);
n_args = SCM_HOOK_ARITY (hook); n_args = SCM_HOOK_ARITY (hook);
if (scm_to_int (SCM_CAR (arity)) > n_args if (p_req > n_args || (!p_rest && p_req + p_opt < n_args))
|| (scm_is_false (SCM_CADDR (arity))
&& (scm_to_int (SCM_CAR (arity)) + scm_to_int (SCM_CADR (arity))
< n_args)))
scm_wrong_type_arg (FUNC_NAME, 2, proc); scm_wrong_type_arg (FUNC_NAME, 2, proc);
rest = scm_delq_x (proc, SCM_HOOK_PROCEDURES (hook)); rest = scm_delq_x (proc, SCM_HOOK_PROCEDURES (hook));
SCM_SET_HOOK_PROCEDURES (hook, SCM_SET_HOOK_PROCEDURES (hook,

60
libguile/macros.c
View file

@ -46,46 +46,42 @@ static int
macro_print (SCM macro, SCM port, scm_print_state *pstate) macro_print (SCM macro, SCM port, scm_print_state *pstate)
{ {
SCM code = SCM_MACRO_CODE (macro); 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 ("#<", port);
scm_puts ("extended-", port);
if (!SCM_CLOSUREP (code) && !SCM_PROGRAM_P (code)) if (SCM_MACRO_TYPE (macro) < 4 && SCM_MACRO_IS_EXTENDED (macro))
scm_puts ("primitive-", port); scm_puts ("extended-", port);
if (SCM_MACRO_TYPE (macro) == 0) /* FIXME: doesn't catch boot closures; but do we care? */
scm_puts ("syntax", port); if (!SCM_PROGRAM_P (code))
scm_puts ("primitive-", port);
if (SCM_MACRO_TYPE (macro) == 0)
scm_puts ("syntax", port);
#if SCM_ENABLE_DEPRECATED == 1 #if SCM_ENABLE_DEPRECATED == 1
if (SCM_MACRO_TYPE (macro) == 1) if (SCM_MACRO_TYPE (macro) == 1)
scm_puts ("macro", port); scm_puts ("macro", port);
#endif #endif
if (SCM_MACRO_TYPE (macro) == 2) if (SCM_MACRO_TYPE (macro) == 2)
scm_puts ("macro!", port); scm_puts ("macro!", port);
if (SCM_MACRO_TYPE (macro) == 3) if (SCM_MACRO_TYPE (macro) == 3)
scm_puts ("builtin-macro!", port); scm_puts ("builtin-macro!", port);
if (SCM_MACRO_TYPE (macro) == 4) if (SCM_MACRO_TYPE (macro) == 4)
scm_puts ("syncase-macro", port); scm_puts ("syncase-macro", port);
scm_putc (' ', port);
scm_iprin1 (scm_macro_name (macro), port, pstate);
if (SCM_MACRO_IS_EXTENDED (macro))
{
scm_putc (' ', port); scm_putc (' ', port);
scm_iprin1 (scm_macro_name (macro), port, pstate); scm_write (SCM_SMOB_OBJECT_2 (macro), port);
scm_putc (' ', port);
if (SCM_MACRO_IS_EXTENDED (macro)) scm_write (SCM_SMOB_OBJECT_3 (macro), port);
{
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_putc ('>', port);
return 1; return 1;
} }
@ -273,7 +269,7 @@ SCM_DEFINE (scm_macro_transformer, "macro-transformer", 1, 0, 0,
SCM_VALIDATE_SMOB (1, m, macro); SCM_VALIDATE_SMOB (1, m, macro);
data = SCM_PACK (SCM_SMOB_DATA (m)); 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; return data;
else else
return SCM_BOOL_F; return SCM_BOOL_F;

18
libguile/print.c
View file

@ -428,7 +428,6 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
{ {
switch (SCM_ITAG3 (exp)) switch (SCM_ITAG3 (exp))
{ {
case scm_tc3_closure:
case scm_tc3_tc7_1: case scm_tc3_tc7_1:
case scm_tc3_tc7_2: case scm_tc3_tc7_2:
/* These tc3 tags should never occur in an immediate value. They are /* 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: circref:
print_circref (port, pstate, exp); print_circref (port, pstate, exp);
break; 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: case scm_tc7_number:
switch SCM_TYP16 (exp) { switch SCM_TYP16 (exp) {
case scm_tc16_big: case scm_tc16_big:
@ -820,6 +803,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
EXIT_NESTED_DATA (pstate); EXIT_NESTED_DATA (pstate);
break; break;
default: default:
/* case scm_tcs_closures: */
punk: punk:
scm_ipruk ("type", exp, port); scm_ipruk ("type", exp, port);
} }

133
libguile/procprop.c
View file

@ -41,65 +41,49 @@
SCM_GLOBAL_SYMBOL (scm_sym_system_procedure, "system-procedure"); SCM_GLOBAL_SYMBOL (scm_sym_system_procedure, "system-procedure");
SCM_GLOBAL_SYMBOL (scm_sym_arity, "arity"); SCM_GLOBAL_SYMBOL (scm_sym_arity, "arity");
static SCM non_closure_props; static SCM props;
static scm_i_pthread_mutex_t non_closure_props_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER; static scm_i_pthread_mutex_t props_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
SCM int
scm_i_procedure_arity (SCM proc) scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest)
{ {
int a = 0, o = 0, r = 0;
if (SCM_IMP (proc)) if (SCM_IMP (proc))
return SCM_BOOL_F; return 0;
loop: loop:
switch (SCM_TYP7 (proc)) switch (SCM_TYP7 (proc))
{ {
case scm_tc7_program: case scm_tc7_program:
if (scm_i_program_arity (proc, &a, &o, &r)) return scm_i_program_arity (proc, req, opt, rest);
break;
else
return SCM_BOOL_F;
case scm_tc7_smob: case scm_tc7_smob:
if (SCM_SMOB_APPLICABLE_P (proc)) if (SCM_SMOB_APPLICABLE_P (proc))
{ {
int type = SCM_SMOB_DESCRIPTOR (proc).gsubr_type; int type = SCM_SMOB_DESCRIPTOR (proc).gsubr_type;
a += SCM_GSUBR_REQ (type); *req = SCM_GSUBR_REQ (type);
o = SCM_GSUBR_OPT (type); *opt = SCM_GSUBR_OPT (type);
r = SCM_GSUBR_REST (type); *rest = SCM_GSUBR_REST (type);
break; return 1;
} }
else else
{ return 0;
return SCM_BOOL_F;
}
case scm_tc7_gsubr: case scm_tc7_gsubr:
{ {
unsigned int type = SCM_GSUBR_TYPE (proc); unsigned int type = SCM_GSUBR_TYPE (proc);
a = SCM_GSUBR_REQ (type); *req = SCM_GSUBR_REQ (type);
o = SCM_GSUBR_OPT (type); *opt = SCM_GSUBR_OPT (type);
r = SCM_GSUBR_REST (type); *rest = SCM_GSUBR_REST (type);
break; return 1;
} }
case scm_tc7_pws: case scm_tc7_pws:
proc = SCM_PROCEDURE (proc); proc = SCM_PROCEDURE (proc);
goto loop; 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: case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) if (!SCM_STRUCT_APPLICABLE_P (proc))
{ return 0;
r = 1;
break;
}
else if (!SCM_STRUCT_APPLICABLE_P (proc))
return SCM_BOOL_F;
proc = SCM_STRUCT_PROCEDURE (proc); proc = SCM_STRUCT_PROCEDURE (proc);
goto loop; goto loop;
default: 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 /* 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.") "Return @var{obj}'s property list.")
#define FUNC_NAME s_scm_procedure_properties #define FUNC_NAME s_scm_procedure_properties
{ {
SCM props; SCM ret;
int req, opt, rest;
SCM_VALIDATE_PROC (1, proc); SCM_VALIDATE_PROC (1, proc);
if (SCM_CLOSUREP (proc))
props = SCM_PROCPROPS (proc); scm_i_pthread_mutex_lock (&props_lock);
else ret = scm_hashq_ref (props, proc, SCM_EOL);
{ scm_i_pthread_mutex_unlock (&props_lock);
scm_i_pthread_mutex_lock (&non_closure_props_lock);
props = scm_hashq_ref (non_closure_props, proc, SCM_EOL); scm_i_procedure_arity (proc, &req, &opt, &rest);
scm_i_pthread_mutex_unlock (&non_closure_props_lock);
} return scm_acons (scm_sym_arity,
return scm_acons (scm_sym_arity, scm_i_procedure_arity (proc), props); scm_list_3 (scm_from_int (req),
scm_from_int (opt),
scm_from_bool (rest)),
ret);
} }
#undef FUNC_NAME #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); SCM_VALIDATE_PROC (1, proc);
if (SCM_CLOSUREP (proc)) scm_i_pthread_mutex_lock (&props_lock);
SCM_SETPROCPROPS (proc, alist); scm_hashq_set_x (props, proc, alist);
else scm_i_pthread_mutex_unlock (&props_lock);
{
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);
}
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }
#undef FUNC_NAME #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)) if (scm_is_eq (key, scm_sym_arity))
/* avoid a cons in this case */ /* 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 else
{ {
SCM props; SCM ret;
if (SCM_CLOSUREP (proc))
props = SCM_PROCPROPS (proc); scm_i_pthread_mutex_lock (&props_lock);
else ret = scm_hashq_ref (props, proc, SCM_EOL);
{ scm_i_pthread_mutex_unlock (&props_lock);
scm_i_pthread_mutex_lock (&non_closure_props_lock);
props = scm_hashq_ref (non_closure_props, proc, SCM_EOL); return scm_assq_ref (ret, key);
scm_i_pthread_mutex_unlock (&non_closure_props_lock);
}
return scm_assq_ref (props, key);
} }
} }
#undef FUNC_NAME #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)) if (scm_is_eq (key, scm_sym_arity))
SCM_MISC_ERROR ("arity is a read-only property", SCM_EOL); SCM_MISC_ERROR ("arity is a read-only property", SCM_EOL);
if (SCM_CLOSUREP (proc)) scm_i_pthread_mutex_lock (&props_lock);
SCM_SETPROCPROPS (proc, scm_hashq_set_x (props, proc,
scm_assq_set_x (SCM_PROCPROPS (proc), key, val)); scm_assq_set_x (scm_hashq_ref (props, proc,
else SCM_EOL),
{ key, val));
scm_i_pthread_mutex_lock (&non_closure_props_lock); scm_i_pthread_mutex_unlock (&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);
}
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }
@ -205,7 +186,7 @@ SCM_DEFINE (scm_set_procedure_property_x, "set-procedure-property!", 3, 0, 0,
void void
scm_init_procprop () 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" #include "libguile/procprop.x"
} }

2
libguile/procprop.h
View file

@ -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_procedure_properties (SCM proc);
SCM_API SCM scm_set_procedure_properties_x (SCM proc, SCM alist); SCM_API SCM scm_set_procedure_properties_x (SCM proc, SCM alist);
SCM_API SCM scm_procedure_property (SCM proc, SCM key); SCM_API SCM scm_procedure_property (SCM proc, SCM key);

58
libguile/procs.c
View file

@ -100,7 +100,6 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0,
if (!((SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_PURE_GENERIC) if (!((SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_PURE_GENERIC)
|| SCM_STRUCT_APPLICABLE_P (obj))) || SCM_STRUCT_APPLICABLE_P (obj)))
break; break;
case scm_tcs_closures:
case scm_tc7_gsubr: case scm_tc7_gsubr:
case scm_tc7_pws: case scm_tc7_pws:
case scm_tc7_program: case scm_tc7_program:
@ -114,45 +113,14 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0,
} }
#undef FUNC_NAME #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_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0,
(SCM obj), (SCM obj),
"Return @code{#t} if @var{obj} is a thunk.") "Return @code{#t} if @var{obj} is a thunk.")
#define FUNC_NAME s_scm_thunk_p #define FUNC_NAME s_scm_thunk_p
{ {
if (SCM_NIMP (obj)) int req, opt, rest;
{ return scm_from_bool (scm_i_procedure_arity (obj, &req, &opt, &rest)
again: && req == 0);
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;
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -181,25 +149,11 @@ SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0,
"documentation for that procedure.") "documentation for that procedure.")
#define FUNC_NAME s_scm_procedure_documentation #define FUNC_NAME s_scm_procedure_documentation
{ {
SCM code; SCM_VALIDATE_PROC (SCM_ARG1, proc);
SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
proc, SCM_ARG1, FUNC_NAME);
if (SCM_PROGRAM_P (proc)) if (SCM_PROGRAM_P (proc))
return scm_assq_ref (scm_program_properties (proc), sym_documentation); return scm_assq_ref (scm_program_properties (proc), sym_documentation);
switch (SCM_TYP7 (proc)) else
{ return SCM_BOOL_F;
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;
}
} }
#undef FUNC_NAME #undef FUNC_NAME

15
libguile/procs.h
View file

@ -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 /* Procedure-with-setter
Four representations for procedure-with-setters were 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_API SCM scm_c_define_subr_with_generic (const char *name, long type,
SCM (*fcn)(), SCM *gf); SCM (*fcn)(), SCM *gf);
SCM_API SCM scm_procedure_p (SCM obj); 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 SCM scm_thunk_p (SCM obj);
SCM_API int scm_subr_p (SCM obj); SCM_API int scm_subr_p (SCM obj);
SCM_API SCM scm_procedure_documentation (SCM proc); SCM_API SCM scm_procedure_documentation (SCM proc);

22
libguile/tags.h
View file

@ -386,7 +386,7 @@ typedef scm_t_uintptr scm_t_bits;
#define scm_tc3_cons 0 #define scm_tc3_cons 0
#define scm_tc3_struct 1 #define scm_tc3_struct 1
#define scm_tc3_int_1 (scm_tc2_int + 0) #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_imm24 4
#define scm_tc3_tc7_1 5 #define scm_tc3_tc7_1 5
#define scm_tc3_int_2 (scm_tc2_int + 4) #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 + 112:\
case scm_tc3_struct + 120 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 /* For subrs
*/ */
#define scm_tcs_subrs \ #define scm_tcs_subrs \

2
libguile/validate.h
View file

@ -296,8 +296,6 @@
#define SCM_VALIDATE_MEMOIZED(pos, obj) SCM_MAKE_VALIDATE_MSG (pos, obj, MEMOIZED_P, "memoized code") #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) \ #define SCM_VALIDATE_PROC(pos, proc) \
do { \ do { \
SCM_ASSERT (scm_is_true (scm_procedure_p (proc)), proc, pos, FUNC_NAME); \ SCM_ASSERT (scm_is_true (scm_procedure_p (proc)), proc, pos, FUNC_NAME); \

8
libguile/vm.c
View file

@ -269,14 +269,6 @@ apply_foreign (SCM proc, SCM *args, int nargs, int headroom)
switch (SCM_TYP7 (proc)) 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: case scm_tc7_smob:
if (!SCM_SMOB_APPLICABLE_P (proc)) if (!SCM_SMOB_APPLICABLE_P (proc))
goto badproc; goto badproc;

4
module/ice-9/deprecated.scm
View file

@ -224,3 +224,7 @@
(define ($sinh z) (sinh z)) (define ($sinh z) (sinh z))
(define ($cosh z) (cosh z)) (define ($cosh z) (cosh z))
(define ($tanh z) (tanh z)) (define ($tanh z) (tanh z))
(define (closure? x)
(issue-deprecation-warning
"`closure?' is deprecated. Use `procedure?' instead.")
(procedure? x))

3
module/ice-9/documentation.scm
View file

@ -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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; 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) (and (macro? object)
(object-documentation (macro-transformer object))) (object-documentation (macro-transformer object)))
(and (procedure? object) (and (procedure? object)
(not (closure? object))
(procedure-name object) (procedure-name object)
(let ((docstring (search-documentation-files (let ((docstring (search-documentation-files
(procedure-name object)))) (procedure-name object))))

16
module/ice-9/session.scm
View file

@ -163,10 +163,8 @@ You don't seem to have regular expressions installed.\n")
(cons (list module (cons (list module
name name
(try-value-help name object) (try-value-help name object)
(cond ((closure? object) (cond ((procedure? object)
"a procedure") "a procedure")
((procedure? object)
"a primitive procedure")
(else (else
"an object"))) "an object")))
data)) data))
@ -498,17 +496,7 @@ It is an image under the mapping EXTRACT."
(= (car arity) 1) (= (car arity) 1)
(<= (cadr arity) 1)) (<= (cadr arity) 1))
(display " argument") (display " argument")
(display " arguments")) (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 ".\n")) (display ".\n"))

28
module/oop/goops.scm
View file

@ -1161,20 +1161,15 @@
;;; compute-getters-n-setters ;;; compute-getters-n-setters
;;; ;;;
;; FIXME!!!
(define (make-thunk thunk)
(lambda () (thunk)))
(define (compute-getters-n-setters class slots) (define (compute-getters-n-setters class slots)
(define (compute-slot-init-function name s) (define (compute-slot-init-function name s)
(or (let ((thunk (slot-definition-init-thunk s))) (or (let ((thunk (slot-definition-init-thunk s)))
(and thunk (and thunk
(cond ((not (thunk? thunk)) (if (thunk? thunk)
(goops-error "Bad init-thunk for slot `~S' in ~S: ~S" thunk
name class thunk)) (goops-error "Bad init-thunk for slot `~S' in ~S: ~S"
((closure? thunk) thunk) name class thunk))))
(else (make-thunk thunk)))))
(let ((init (slot-definition-init-value s))) (let ((init (slot-definition-init-value s)))
(and (not (unbound? init)) (and (not (unbound? init))
(lambda () init))))) (lambda () init)))))
@ -1187,18 +1182,11 @@
(else (else
(let ((get (car l)) (let ((get (car l))
(set (cadr l))) (set (cadr l)))
;; note that we allow non-closures; we only check arity on (if (not (procedure? get))
;; the closures, though, because we inline their dispatch (goops-error "Bad getter closure for slot `~S' in ~S: ~S"
;; 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"
slot class get)) slot class get))
(if (or (not (procedure? set)) (if (not (procedure? set))
(and (closure? set) (goops-error "Bad setter closure for slot `~S' in ~S: ~S"
(not (= (car (procedure-property set 'arity)) 2))))
(goops-error "Bad setter closure for slot `~S' in ~S: ~S"
slot class set)))))) slot class set))))))
(map (lambda (s) (map (lambda (s)

7
module/oop/goops/describe.scm
View file

@ -1,6 +1,6 @@
;;; installed-scm-file ;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -67,10 +67,7 @@
(display x)) (display x))
(display " is ") (display " is ")
(display (if name #\a "an anonymous")) (display (if name #\a "an anonymous"))
(display (cond ((closure? x) " procedure") (display " procedure")
((not (struct? x)) " primitive procedure")
((entity? x) " entity")
(else " operator")))
(display " with ") (display " with ")
(arity x))) (arity x)))

21
module/system/repl/describe.scm
View file

@ -1,6 +1,6 @@
;;; Describe objects ;;; 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 ;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public ;;; modify it under the terms of the GNU Lesser General Public
@ -200,17 +200,7 @@
(define-method (display-object (obj <procedure>)) (define-method (display-object (obj <procedure>))
(cond (cond
((closure? obj) ;; FIXME: VM programs, ...
;; 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)))))))
(else (else
;; Primitive procedure. Let's lookup the dictionary. ;; Primitive procedure. Let's lookup the dictionary.
(and-let* ((entry (lookup-procedure obj))) (and-let* ((entry (lookup-procedure obj)))
@ -240,10 +230,8 @@
(define-method (display-type (obj <procedure>)) (define-method (display-type (obj <procedure>))
(cond (cond
((and (thunk? obj) (not (procedure-name obj))) (display "a thunk")) ((and (thunk? obj) (not (procedure-name obj))) (display "a thunk"))
((closure? obj) (display-class <procedure> "a procedure"))
((procedure-with-setter? obj) ((procedure-with-setter? obj)
(display-class <procedure-with-setter> "a procedure with setter")) (display-class <procedure-with-setter> "a procedure with setter"))
((not (struct? obj)) (display "a primitive procedure"))
(else (display-class <procedure> "a procedure"))) (else (display-class <procedure> "a procedure")))
(display ".\n")) (display ".\n"))
@ -252,9 +240,8 @@
(display-file (entry-file entry)))) (display-file (entry-file entry))))
(define-method (display-documentation (obj <procedure>)) (define-method (display-documentation (obj <procedure>))
(cond ((cond ((closure? obj) (procedure-documentation obj)) (cond ((or (procedure-documentation obj)
((lookup-procedure obj) => entry-text) (and=> (lookup-procedure obj) entry-text))
(else #f))
=> format-documentation) => format-documentation)
(else (next-method)))) (else (next-method))))