summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-12-07 09:56:58 +0100
committerAndy Wingo <wingo@pobox.com>2009-12-07 09:56:58 +0100
commitea68d342f18c3d2082ce6a4fb39bd38b6af932cc (patch)
tree4042d77651542b93ab97b203167183db651df35b
parentce65df9f09577e4f566b467ee8647617204b9b40 (diff)
downloadguile-ea68d342f18c3d2082ce6a4fb39bd38b6af932cc.tar.gz
procedures-with-setters implemented in terms of structs
* libguile/tags.h (scm_tc7_pws): No more. * libguile/procs.c (scm_procedure_with_setter_p) (scm_make_procedure_with_setter, scm_procedure, scm_setter): Implement procedures-with-setters in terms of applicable structs with setters. * libguile/procs.h: Remove a big, outdated comment, and the deprecated macros. * libguile/deprecated.h (SCM_PROCEDURE_WITH_SETTER_P, SCM_PROCEDURE) (SCM_SETTER): Deprecate these. SCM_PROCEDURE and SCM_SETTER are bad names. * libguile/evalext.c (scm_self_evaluating_p): * libguile/gc.c (scm_i_tag_name): * libguile/goops.c: (scm_class_of): * libguile/print.c (iprin1): * libguile/procprop.c (scm_i_procedure_arity): * libguile/procs.c (scm_procedure_p): * libguile/debug.c (scm_procedure_source): Remove a tc7_pws case. * libguile/goops.h: * libguile/goops.c (scm_class_procedure_with_setter): Remove this class; it is subsumed by applicable_struct_with_setter. * libguile/struct.h: Update a comment. * libguile/vm-i-system.c (call, goto/args, mv-call): Remove PWS cases.
-rw-r--r--libguile/debug.c3
-rw-r--r--libguile/deprecated.h8
-rw-r--r--libguile/evalext.c1
-rw-r--r--libguile/gc.c2
-rw-r--r--libguile/goops.c6
-rw-r--r--libguile/goops.h1
-rw-r--r--libguile/print.c12
-rw-r--r--libguile/procprop.c3
-rw-r--r--libguile/procs.c65
-rw-r--r--libguile/procs.h53
-rw-r--r--libguile/struct.h2
-rw-r--r--libguile/tags.h2
-rw-r--r--libguile/vm-i-system.c16
13 files changed, 40 insertions, 134 deletions
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, "<procedure>",
scm_class_procedure_class, scm_class_applicable, SCM_EOL);
- make_stdcls (&scm_class_procedure_with_setter, "<procedure-with-setter>",
- scm_class_procedure_class, scm_class_procedure, SCM_EOL);
make_stdcls (&scm_class_primitive_generic, "<primitive-generic>",
scm_class_procedure_class, scm_class_procedure, SCM_EOL);
make_stdcls (&scm_class_port, "<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 ("#<procedure-with-setter", port);
- {
- SCM name = scm_procedure_name (exp);
- if (scm_is_true (name))
- {
- scm_putc (' ', port);
- scm_display (name, port);
- }
- }
- scm_putc ('>', 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 ("<applicable-struct-with-setter-vtable>"));
+ 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
@@ -47,59 +47,6 @@
-/* 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
- <procedure-with-setter>, 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)());
SCM_API SCM scm_c_make_subr_with_generic (const char *name, long type,
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
*/