diff --git a/libguile/debug.c b/libguile/debug.c index b220efd8b..0f83ea012 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -172,9 +172,6 @@ SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0, break; proc = SCM_STRUCT_PROCEDURE (proc); continue; - case scm_tc7_pws: - proc = SCM_PROCEDURE (proc); - continue; default: break; } diff --git a/libguile/deprecated.h b/libguile/deprecated.h index 3643a80ee..be56d3798 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -600,6 +600,14 @@ SCM_DEPRECATED scm_t_trampoline_1 scm_trampoline_1 (SCM proc); SCM_DEPRECATED scm_t_trampoline_2 scm_trampoline_2 (SCM proc); + +/* Deprecated 2009-12-06, use the procedures instead */ +#define SCM_PROCEDURE_WITH_SETTER_P(obj) (scm_is_true (scm_procedure_with_setter_p (obj))) +#define SCM_PROCEDURE(obj) SCM_STRUCT_PROCEDURE (obj, 0) +#define SCM_SETTER(obj) SCM_STRUCT_SETTER (obj, 1) + + + void scm_i_init_deprecated (void); #endif diff --git a/libguile/evalext.c b/libguile/evalext.c index 9af83838f..84218b35f 100644 --- a/libguile/evalext.c +++ b/libguile/evalext.c @@ -83,7 +83,6 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0, 0, case scm_tc7_number: case scm_tc7_string: case scm_tc7_smob: - case scm_tc7_pws: case scm_tc7_program: case scm_tc7_bytevector: case scm_tc7_gsubr: diff --git a/libguile/gc.c b/libguile/gc.c index 4bd1d5d7e..38051e11d 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -749,8 +749,6 @@ scm_i_tag_name (scm_t_bits tag) return "cons (immediate car)"; case scm_tcs_cons_nimcar: return "cons (non-immediate car)"; - case scm_tc7_pws: - return "pws"; case scm_tc7_hashtable: return "hashtable"; case scm_tc7_fluid: diff --git a/libguile/goops.c b/libguile/goops.c index f3a28d93d..1472e4700 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -132,7 +132,7 @@ static scm_t_rstate *goops_rstate; /* These variables are filled in by the object system when loaded. */ SCM scm_class_boolean, scm_class_char, scm_class_pair; SCM scm_class_procedure, scm_class_string, scm_class_symbol; -SCM scm_class_procedure_with_setter, scm_class_primitive_generic; +SCM scm_class_primitive_generic; SCM scm_class_vector, scm_class_null; SCM scm_class_integer, scm_class_real, scm_class_complex, scm_class_fraction; SCM scm_class_unknown; @@ -240,8 +240,6 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, return scm_class_procedure; case scm_tc7_program: return scm_class_procedure; - case scm_tc7_pws: - return scm_class_procedure_with_setter; case scm_tc7_smob: { @@ -2419,8 +2417,6 @@ create_standard_classes (void) scm_class_class, scm_class_top, SCM_EOL); make_stdcls (&scm_class_procedure, "", scm_class_procedure_class, scm_class_applicable, SCM_EOL); - make_stdcls (&scm_class_procedure_with_setter, "", - scm_class_procedure_class, scm_class_procedure, SCM_EOL); make_stdcls (&scm_class_primitive_generic, "", scm_class_procedure_class, scm_class_procedure, SCM_EOL); make_stdcls (&scm_class_port, "", diff --git a/libguile/goops.h b/libguile/goops.h index 48b94a158..b775ae3d8 100644 --- a/libguile/goops.h +++ b/libguile/goops.h @@ -177,7 +177,6 @@ SCM_API SCM scm_class_pair; SCM_API SCM scm_class_procedure; SCM_API SCM scm_class_string; SCM_API SCM scm_class_symbol; -SCM_API SCM scm_class_procedure_with_setter; SCM_API SCM scm_class_primitive_generic; SCM_API SCM scm_class_vector; SCM_API SCM scm_class_null; diff --git a/libguile/print.c b/libguile/print.c index 8d2db1349..efb30813d 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -785,18 +785,6 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) scm_putc ('>', port); break; } - case scm_tc7_pws: - scm_puts ("#', port); - break; case scm_tc7_port: { register long i = SCM_PTOBNUM (exp); diff --git a/libguile/procprop.c b/libguile/procprop.c index c452c28d7..7cfd2e64f 100644 --- a/libguile/procprop.c +++ b/libguile/procprop.c @@ -73,9 +73,6 @@ scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest) *rest = SCM_GSUBR_REST (type); return 1; } - case scm_tc7_pws: - proc = SCM_PROCEDURE (proc); - goto loop; case scm_tcs_struct: if (!SCM_STRUCT_APPLICABLE_P (proc)) return 0; diff --git a/libguile/procs.c b/libguile/procs.c index 71d50bdd7..f62006372 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -101,7 +101,6 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0, || SCM_STRUCT_APPLICABLE_P (obj))) break; case scm_tc7_gsubr: - case scm_tc7_pws: case scm_tc7_program: return SCM_BOOL_T; case scm_tc7_smob: @@ -161,13 +160,16 @@ SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0, /* Procedure-with-setter */ +static SCM pws_vtable; + + SCM_DEFINE (scm_procedure_with_setter_p, "procedure-with-setter?", 1, 0, 0, (SCM obj), "Return @code{#t} if @var{obj} is a procedure with an\n" "associated setter procedure.") #define FUNC_NAME s_scm_procedure_with_setter_p { - return scm_from_bool(SCM_PROCEDURE_WITH_SETTER_P (obj)); + return scm_from_bool (SCM_STRUCTP (obj) && SCM_STRUCT_SETTER_P (obj)); } #undef FUNC_NAME @@ -180,9 +182,9 @@ SCM_DEFINE (scm_make_procedure_with_setter, "make-procedure-with-setter", 2, 0, SCM name, ret; SCM_VALIDATE_PROC (1, procedure); SCM_VALIDATE_PROC (2, setter); - ret = scm_double_cell (scm_tc7_pws, - SCM_UNPACK (procedure), - SCM_UNPACK (setter), 0); + ret = scm_make_struct (pws_vtable, SCM_INUM0, + scm_list_2 (procedure, setter)); + /* don't use procedure_name, because don't care enough to do a reverse lookup */ switch (SCM_TYP7 (procedure)) { @@ -201,51 +203,42 @@ SCM_DEFINE (scm_make_procedure_with_setter, "make-procedure-with-setter", 2, 0, SCM_DEFINE (scm_procedure, "procedure", 1, 0, 0, (SCM proc), - "Return the procedure of @var{proc}, which must be either a\n" - "procedure with setter, or an applicable struct.") + "Return the procedure of @var{proc}, which must be an\n" + "applicable struct.") #define FUNC_NAME s_scm_procedure { SCM_VALIDATE_NIM (1, proc); - if (SCM_PROCEDURE_WITH_SETTER_P (proc)) - return SCM_PROCEDURE (proc); - else if (SCM_STRUCTP (proc)) - { - SCM_ASSERT (SCM_PUREGENERICP (proc) || SCM_STRUCT_APPLICABLE_P (proc), - proc, SCM_ARG1, FUNC_NAME); - return proc; - } - SCM_WRONG_TYPE_ARG (1, proc); - return SCM_BOOL_F; /* not reached */ + SCM_ASSERT (SCM_STRUCT_APPLICABLE_P (proc), proc, SCM_ARG1, FUNC_NAME); + return SCM_STRUCT_PROCEDURE (proc); } #undef FUNC_NAME -SCM_GPROC (s_setter, "setter", 1, 0, 0, scm_setter, g_setter); - -SCM -scm_setter (SCM proc) +SCM_PRIMITIVE_GENERIC (scm_setter, "setter", 1, 0, 0, + (SCM proc), + "Return the setter of @var{proc}, which must be an\n" + "applicable struct with a setter.") +#define FUNC_NAME s_scm_setter { - SCM_GASSERT1 (SCM_NIMP (proc), g_setter, proc, SCM_ARG1, s_setter); - if (SCM_PROCEDURE_WITH_SETTER_P (proc)) - return SCM_SETTER (proc); - else if (SCM_STRUCTP (proc)) - { - SCM setter = SCM_BOOL_F; - if (SCM_PUREGENERICP (proc)) - setter = SCM_GENERIC_SETTER (proc); - else if (SCM_STRUCT_SETTER_P (proc)) - setter = SCM_STRUCT_SETTER (proc); - if (SCM_NIMP (setter)) - return setter; - /* fall through */ - } - SCM_WTA_DISPATCH_1 (g_setter, proc, SCM_ARG1, s_setter); + SCM_GASSERT1 (SCM_STRUCTP (proc), g_scm_setter, proc, SCM_ARG1, FUNC_NAME); + if (SCM_STRUCT_SETTER_P (proc)) + return SCM_STRUCT_SETTER (proc); + if (SCM_PUREGENERICP (proc)) + /* FIXME: might not be an accessor */ + return SCM_GENERIC_SETTER (proc); + SCM_WTA_DISPATCH_1 (g_scm_setter, proc, SCM_ARG1, FUNC_NAME); return SCM_BOOL_F; /* not reached */ } +#undef FUNC_NAME void scm_init_procs () { + SCM setter_vtable_vtable = + scm_variable_ref (scm_c_lookup ("")); + pws_vtable = scm_make_struct (setter_vtable_vtable, SCM_INUM0, + scm_list_1 (scm_from_locale_symbol ("pwpw"))); + #include "libguile/procs.x" } diff --git a/libguile/procs.h b/libguile/procs.h index cb19e4c4b..a832cd06f 100644 --- a/libguile/procs.h +++ b/libguile/procs.h @@ -46,59 +46,6 @@ (scm_tc7_gsubr | (SCM_GSUBR_MAKTYPE (req, opt, rest) << 8U)) - -/* Procedure-with-setter - - Four representations for procedure-with-setters were - considered before selecting this one: - - 1. A closure where the CODE and ENV slots are used to represent - the getter and a new SETTER slot is used for the setter. The - original getter is stored as a `getter' procedure property. For - closure getters, the CODE and ENV slots contains a copy of the - getter's CODE and ENV slots. For subr getters, the CODE contains - a call to the subr. - - 2. A compiled closure with a call to the getter in the cclo - procedure. The getter and setter are stored in slots 1 and 2. - - 3. An entity (i.e. a struct with an associated procedure) with a - call to the getter in the entity procedure and the setter stored - in slot 0. The original getter is stored in slot 1. - - 4. A new primitive procedure type supported in the evaluator. The - getter and setter are stored in a GETTER and SETTER slot. A call - to this procedure type results in a retrieval of the getter and a - jump back to the correct eval dispatcher. - - Representation 4 was selected because of efficiency and - simplicity. - - Rep 1 has the advantage that there is zero penalty for closure - getters, but primitive getters will get considerable overhead - because the procedure-with-getter will be a closure which calls - the getter. - - Rep 3 has the advantage that a GOOPS accessor can be a subclass of - , but together with rep 2 it suffers from a - three level dispatch for non-GOOPS getters: - - cclo/struct --> dispatch proc --> getter - - This is because the dispatch procedure must take an extra initial - argument (cclo for rep 2, struct for rep 3). - - Rep 4 has the single disadvantage that it uses up one tc7 type - code, but the plan for uniform vectors will very likely free tc7 - codes, so this is probably no big problem. Also note that the - GETTER and SETTER slots can live directly on the heap, using the - new four-word cells. */ - -#define SCM_PROCEDURE_WITH_SETTER_P(obj) (!SCM_IMP(obj) && (SCM_TYP7 (obj) == scm_tc7_pws)) -#define SCM_PROCEDURE(obj) SCM_CELL_OBJECT_1 (obj) -#define SCM_SETTER(obj) SCM_CELL_OBJECT_2 (obj) - - SCM_API SCM scm_c_make_subr (const char *name, long type, SCM (*fcn)()); diff --git a/libguile/struct.h b/libguile/struct.h index 1e80fc188..5955e5928 100644 --- a/libguile/struct.h +++ b/libguile/struct.h @@ -35,7 +35,7 @@ I would like to write this all up here, but for now: - http://wingolog.org/pub/goops-class-redefinition-3.png + http://wingolog.org/archives/2009/11/09/class-redefinition-in-guile */ /* All vtables have the following fields. */ diff --git a/libguile/tags.h b/libguile/tags.h index 50207755d..e1e0913fe 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -411,7 +411,7 @@ typedef scm_t_uintptr scm_t_bits; #define scm_tc7_stringbuf 39 #define scm_tc7_bytevector 77 -#define scm_tc7_pws 31 +#define scm_tc7_unused_1 31 #define scm_tc7_hashtable 29 #define scm_tc7_fluid 37 #define scm_tc7_dynamic_state 45 diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index 6d32a6ccd..d7523ccb2 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -766,11 +766,6 @@ VM_DEFINE_INSTRUCTION (53, call, "call", 1, -1, 1) sp[-nargs] = SCM_STRUCT_PROCEDURE (x); goto vm_call; } - else if (SCM_PROCEDURE_WITH_SETTER_P (x)) - { - sp[-nargs] = SCM_PROCEDURE (x); - goto vm_call; - } /* * Other interpreted or compiled call */ @@ -850,12 +845,6 @@ VM_DEFINE_INSTRUCTION (54, goto_args, "goto/args", 1, -1, 1) sp[-nargs] = SCM_STRUCT_PROCEDURE (x); goto vm_goto_args; } - else if (SCM_PROCEDURE_WITH_SETTER_P (x)) - { - sp[-nargs] = SCM_PROCEDURE (x); - goto vm_goto_args; - } - /* * Other interpreted or compiled call */ @@ -943,11 +932,6 @@ VM_DEFINE_INSTRUCTION (57, mv_call, "mv-call", 4, -1, 1) sp[-nargs] = SCM_STRUCT_PROCEDURE (x); goto vm_mv_call; } - else if (SCM_PROCEDURE_WITH_SETTER_P (x)) - { - sp[-nargs] = SCM_PROCEDURE (x); - goto vm_mv_call; - } /* * Other interpreted or compiled call */