mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

remove support for "entities" -- a form of applicable struct

Browse source 
Entities were meant to be a form of applicable struct. Unfortunately,
the implementation is intertwingled with generics. Removing them, for
now, will make it possible to cleanly re-add applicable struct support.

* libguile/struct.h (SCM_STRUCTF_ENTITY): Remove.
  (SCM_STRUCTF_GOOPS_HACK): New flag; sigh.
* libguile/struct.c (scm_make_struct): We make "entity" structs if the
  GOOPS_HACK flag is set. This will be fixed when we rework flags and
  remove hidden words.

* libguile/goops.c (scm_class_of): Structs are not applicable, for now
  at least.
  (scm_sys_inherit_magic_x, scm_basic_basic_make_class)
  (scm_sys_allocate_instance, scm_sys_set_object_setter_x):
  (make_struct_class): Adapt for no more entities (and thus no entity
  flag).
  (create_standard_classes): For some reason, generic functions were
  getting the LIGHT flag set, after the ENTITY flag was removed; so for
  now explicitly clear that flag.
* libguile/goops.h (SCM_GENERIC_SETTER, SCM_SET_GENERIC_SETTER): New
  macros.

* libguile/objects.h:
* libguile/objects.c: Remove code for entities.

* libguile/debug.c: (scm_procedure_source): Only work with generics.

* libguile/eval.c (scm_trampoline_0, scm_trampoline_1)
  (scm_trampoline_2): Only handle generics.

* libguile/eval.i.c (CEVAL): #ifdef out the pieces about entities.

* libguile/procprop.c (scm_i_procedure_arity): Remove support for
  entities.

* libguile/procs.c (scm_procedure_p, scm_procedure, scm_setter): Remove
  entity support.
This commit is contained in:
Andy Wingo 2009-11-01 19:46:27 +01:00
parent 521ac49bde
commit 11561496ba
11 changed files with 51 additions and 132 deletions
Download patch file Download diff file Expand all files Collapse all files

2
libguile/debug.c
View file

@ -356,7 +356,7 @@ SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
}
}
case scm_tcs_struct:
if (!SCM_I_ENTITYP (proc))
if (!(SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC))
break;
goto procprop;
case scm_tc7_smob:

6
libguile/eval.c
View file

@ -3270,8 +3270,6 @@ scm_trampoline_0 (SCM proc)
case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
trampoline = scm_call_generic_0;
else if (SCM_I_ENTITYP (proc))
trampoline = scm_call_0;
else
return NULL;
break;
@ -3396,8 +3394,6 @@ scm_trampoline_1 (SCM proc)
case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
trampoline = scm_call_generic_1;
else if (SCM_I_ENTITYP (proc))
trampoline = scm_call_1;
else
return NULL;
break;
@ -3493,8 +3489,6 @@ scm_trampoline_2 (SCM proc)
case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
trampoline = scm_call_generic_2;
else if (SCM_I_ENTITYP (proc))
trampoline = scm_call_2;
else
return NULL;
break;

10
libguile/eval.i.c
View file

@ -1031,6 +1031,7 @@ dispatch:
arg1 = SCM_EOL;
goto type_dispatch;
}
#if 0
else if (SCM_I_ENTITYP (proc))
{
arg1 = proc;
@ -1041,6 +1042,7 @@ dispatch:
#endif
goto evap1;
}
#endif
else
goto badfun;
case scm_tc7_subr_1:
@ -1162,6 +1164,7 @@ dispatch:
#endif
goto type_dispatch;
}
#if 0
else if (SCM_I_ENTITYP (proc))
{
arg2 = arg1;
@ -1173,6 +1176,7 @@ dispatch:
#endif
goto evap2;
}
#endif
else
goto badfun;
case scm_tc7_subr_2:
@ -1241,6 +1245,7 @@ dispatch:
#endif
goto type_dispatch;
}
#if 0
else if (SCM_I_ENTITYP (proc))
{
operatorn:
@ -1258,6 +1263,7 @@ dispatch:
SCM_EOL));
#endif
}
#endif
else
goto badfun;
case scm_tc7_subr_0:
@ -1467,8 +1473,10 @@ dispatch:
x = SCM_GENERIC_METHOD_CACHE (proc);
goto type_dispatch;
}
#if 0
else if (SCM_I_ENTITYP (proc))
goto operatorn;
#endif
else
goto badfun;
case scm_tc7_subr_2:
@ -1772,6 +1780,7 @@ tail:
#endif
RETURN (scm_apply_generic (proc, args));
}
#if 0
else if (SCM_I_ENTITYP (proc))
{
/* operator */
@ -1791,6 +1800,7 @@ tail:
else
goto badproc;
}
#endif
else
goto badproc;
default:

49
libguile/goops.c
View file

@ -287,8 +287,9 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
if (!scm_is_symbol (name))
name = scm_string_to_symbol (scm_nullstr);
/* FIXME APPLICABLE structs */
class =
scm_make_extended_class_from_symbol (name, SCM_I_ENTITYP (x));
scm_make_extended_class_from_symbol (name, 0);
SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle), class);
return class;
}
@ -752,7 +753,7 @@ SCM_DEFINE (scm_sys_inherit_magic_x, "%inherit-magic!", 2, 0, 0,
}
flags &= SCM_CLASSF_INHERIT;
if (! (flags & SCM_CLASSF_ENTITY))
if (! (flags & SCM_CLASSF_PURE_GENERIC))
{
long n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields));
#if 0
@ -827,10 +828,8 @@ scm_basic_basic_make_class (SCM class, SCM name, SCM dsupers, SCM dslots)
}
/* Support for the underlying structs: */
SCM_SET_CLASS_FLAGS (z, (class == scm_class_entity_class
? (SCM_CLASSF_GOOPS_OR_VALID
| SCM_CLASSF_ENTITY)
: SCM_CLASSF_GOOPS_OR_VALID));
/* FIXME: set entity flag on z if class == entity_class ? */
SCM_SET_CLASS_FLAGS (z, SCM_CLASSF_GOOPS_OR_VALID);
return z;
}
@ -1564,22 +1563,18 @@ SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0,
n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields));
/* Entities */
if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY)
/* FIXME applicable structs */
/* Generic functions */
if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC)
{
SCM gf;
m = (SCM *) scm_alloc_struct (n, scm_struct_entity_n_extra_words,
"entity struct");
"generic function");
m[scm_struct_i_setter] = SCM_BOOL_F;
m[scm_struct_i_procedure] = SCM_BOOL_F;
/* Generic functions */
if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC)
{
SCM gf = wrap_init (class, m, n);
clear_method_cache (gf);
return gf;
}
else
return wrap_init (class, m, n);
gf = wrap_init (class, m, n);
clear_method_cache (gf);
return gf;
}
/* Class objects */
@ -1594,8 +1589,7 @@ SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0,
for (i = scm_si_goops_fields; i < n; i++)
SCM_SET_SLOT (z, i, SCM_GOOPS_UNBOUND);
if (SCM_SUBCLASSP (class, scm_class_entity_class))
SCM_SET_CLASS_FLAGS (z, SCM_CLASSF_ENTITY);
/* FIXME propagate applicable struct flag */
return z;
}
@ -1613,11 +1607,12 @@ SCM_DEFINE (scm_sys_set_object_setter_x, "%set-object-setter!", 2, 0, 0,
"")
#define FUNC_NAME s_scm_sys_set_object_setter_x
{
SCM_ASSERT (SCM_STRUCTP (obj) && SCM_I_ENTITYP (obj),
SCM_ASSERT (SCM_STRUCTP (obj)
&& (SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_PURE_GENERIC),
obj,
SCM_ARG1,
FUNC_NAME);
SCM_SET_ENTITY_SETTER (obj, setter);
SCM_SET_GENERIC_SETTER (obj, setter);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@ -2559,21 +2554,27 @@ create_standard_classes (void)
scm_class_entity_class,
scm_list_2 (scm_class_object, scm_class_applicable),
SCM_EOL);
SCM_CLEAR_CLASS_FLAGS (scm_class_entity, SCM_STRUCTF_LIGHT);
make_stdcls (&scm_class_entity_with_setter, "<entity-with-setter>",
scm_class_entity_class, scm_class_entity, SCM_EOL);
SCM_CLEAR_CLASS_FLAGS (scm_class_entity_with_setter, SCM_STRUCTF_LIGHT);
make_stdcls (&scm_class_generic, "<generic>",
scm_class_entity_class, scm_class_entity, gf_slots);
SCM_CLEAR_CLASS_FLAGS (scm_class_generic, SCM_STRUCTF_LIGHT);
SCM_SET_CLASS_FLAGS (scm_class_generic, SCM_CLASSF_PURE_GENERIC);
make_stdcls (&scm_class_extended_generic, "<extended-generic>",
scm_class_entity_class, scm_class_generic, egf_slots);
SCM_CLEAR_CLASS_FLAGS (scm_class_extended_generic, SCM_STRUCTF_LIGHT);
SCM_SET_CLASS_FLAGS (scm_class_extended_generic, SCM_CLASSF_PURE_GENERIC);
make_stdcls (&scm_class_generic_with_setter, "<generic-with-setter>",
scm_class_entity_class,
scm_list_2 (scm_class_generic, scm_class_entity_with_setter),
SCM_EOL);
SCM_CLEAR_CLASS_FLAGS (scm_class_generic_with_setter, SCM_STRUCTF_LIGHT);
SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter, SCM_CLASSF_PURE_GENERIC);
make_stdcls (&scm_class_accessor, "<accessor>",
scm_class_entity_class, scm_class_generic_with_setter, SCM_EOL);
SCM_CLEAR_CLASS_FLAGS (scm_class_accessor, SCM_STRUCTF_LIGHT);
SCM_SET_CLASS_FLAGS (scm_class_accessor, SCM_CLASSF_PURE_GENERIC);
make_stdcls (&scm_class_extended_generic_with_setter,
"<extended-generic-with-setter>",
@ -2581,6 +2582,7 @@ create_standard_classes (void)
scm_list_2 (scm_class_generic_with_setter,
scm_class_extended_generic),
SCM_EOL);
SCM_CLEAR_CLASS_FLAGS (scm_class_extended_generic_with_setter, SCM_STRUCTF_LIGHT);
SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter,
SCM_CLASSF_PURE_GENERIC);
make_stdcls (&scm_class_extended_accessor, "<extended-accessor>",
@ -2590,6 +2592,7 @@ create_standard_classes (void)
SCM_EOL);
fix_cpl (scm_class_extended_accessor,
scm_class_extended_generic, scm_class_generic);
SCM_CLEAR_CLASS_FLAGS (scm_class_extended_accessor, SCM_STRUCTF_LIGHT);
SCM_SET_CLASS_FLAGS (scm_class_extended_accessor, SCM_CLASSF_PURE_GENERIC);
/* Primitive types classes */
@ -2818,7 +2821,7 @@ make_struct_class (void *closure SCM_UNUSED,
SCM sym = SCM_STRUCT_TABLE_NAME (data);
if (scm_is_true (sym))
{
int applicablep = SCM_CLASS_FLAGS (vtable) & SCM_CLASSF_ENTITY;
int applicablep = 0; /* FIXME SCM_CLASS_FLAGS (vtable) & SCM_CLASSF_ENTITY */
SCM_SET_STRUCT_TABLE_CLASS (data,
scm_make_extended_class_from_symbol (sym, applicablep));

2
libguile/goops.h
View file

@ -135,6 +135,8 @@ typedef struct scm_t_method {
#define SCM_GENERIC_METHOD_CACHE(G) (SCM_PACK (SCM_STRUCT_DATA (G) [scm_struct_i_procedure]))
#define SCM_SET_GENERIC_METHOD_CACHE(G,C) (SCM_STRUCT_DATA (G) [scm_struct_i_procedure] = SCM_UNPACK (C))
#define SCM_GENERIC_SETTER(G) (SCM_PACK (SCM_STRUCT_DATA (G) [scm_struct_i_setter]))
#define SCM_SET_GENERIC_SETTER(G,C) (SCM_STRUCT_DATA (G) [scm_struct_i_setter] = SCM_UNPACK (C))
#define SCM_MCACHE_N_SPECIALIZED(C) SCM_CADDR (C)
#define SCM_SET_MCACHE_N_SPECIALIZED(C, X) SCM_SETCAR (SCM_CDDR (C), X)

69
libguile/objects.c
View file

@ -199,78 +199,9 @@ scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3)
return scm_apply_generic (gf, scm_list_3 (a1, a2, a3));
}
SCM_DEFINE (scm_entity_p, "entity?", 1, 0, 0,
(SCM obj),
"Return @code{#t} if @var{obj} is an entity.")
#define FUNC_NAME s_scm_entity_p
{
return scm_from_bool(SCM_STRUCTP (obj) && SCM_I_ENTITYP (obj));
}
#undef FUNC_NAME
/* XXX - What code requires the object procedure to be only of certain
types? */
SCM_DEFINE (scm_valid_object_procedure_p, "valid-object-procedure?", 1, 0, 0,
(SCM proc),
"Return @code{#t} iff @var{proc} is a procedure that can be used "
"with @code{set-object-procedure}. It is always valid to use "
"a closure constructed by @code{lambda}.")
#define FUNC_NAME s_scm_valid_object_procedure_p
{
if (SCM_IMP (proc))
return SCM_BOOL_F;
switch (SCM_TYP7 (proc))
{
default:
return SCM_BOOL_F;
case scm_tcs_closures:
case scm_tc7_subr_1:
case scm_tc7_subr_2:
case scm_tc7_subr_3:
case scm_tc7_lsubr_2:
return SCM_BOOL_T;
}
}
#undef FUNC_NAME
SCM_DEFINE (scm_set_object_procedure_x, "set-object-procedure!", 2, 0, 0,
(SCM obj, SCM proc),
"Set the object procedure of @var{obj} to @var{proc}.\n"
"@var{obj} must be an entity.")
#define FUNC_NAME s_scm_set_object_procedure_x
{
SCM_ASSERT (SCM_STRUCTP (obj)
&& (SCM_I_ENTITYP (obj)
&& !(SCM_OBJ_CLASS_FLAGS (obj)
& SCM_CLASSF_PURE_GENERIC)),
obj,
SCM_ARG1,
FUNC_NAME);
SCM_SET_ENTITY_PROCEDURE (obj, proc);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
#define SCM_METACLASS_STANDARD_LAYOUT ""
void
scm_init_objects ()
{
SCM ms = scm_from_locale_string (SCM_METACLASS_STANDARD_LAYOUT);
SCM mt = scm_make_vtable_vtable (ms, SCM_INUM0,
scm_list_3 (SCM_BOOL_F, SCM_EOL, SCM_EOL));
SCM es = scm_from_locale_string (SCM_ENTITY_LAYOUT);
SCM el = scm_make_struct_layout (es);
SCM et = scm_make_struct (mt, SCM_INUM0,
scm_list_4 (el, SCM_BOOL_F, SCM_EOL, SCM_EOL));
scm_c_define ("<class>", mt);
scm_metaclass_standard = mt;
SCM_SET_CLASS_FLAGS (et, SCM_CLASSF_ENTITY);
scm_c_define ("<entity>", et);
#include "libguile/objects.x"
}

26
libguile/objects.h
View file

@ -51,32 +51,11 @@
#define SCM_CLEAR_CLASS_FLAGS(c, f) (SCM_CLASS_FLAGS (c) &= ~(f))
#define SCM_CLASSF_MASK SCM_STRUCTF_MASK
#define SCM_CLASSF_ENTITY SCM_STRUCTF_ENTITY
#define SCM_I_ENTITYP(obj)\
((SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_ENTITY) != 0)
#define SCM_ENTITY_PROCEDURE(obj) \
(SCM_PACK (SCM_STRUCT_DATA (obj) [scm_struct_i_procedure]))
#define SCM_SET_ENTITY_PROCEDURE(obj, v) \
(SCM_STRUCT_DATA (obj) [scm_struct_i_procedure] = SCM_UNPACK (v))
#define SCM_ENTITY_SETTER(obj) (SCM_PACK (SCM_STRUCT_DATA (obj)[scm_struct_i_setter]))
#define SCM_SET_ENTITY_SETTER(obj, v) \
(SCM_STRUCT_DATA (obj) [scm_struct_i_setter] = SCM_UNPACK (v))
#define SCM_SET_CLASS_DESTRUCTOR(c, d) SCM_SET_VTABLE_DESTRUCTOR (c, d)
#define SCM_SET_CLASS_INSTANCE_SIZE(c, s) \
(SCM_STRUCT_DATA (c)[scm_struct_i_size] \
= (SCM_STRUCT_DATA (c) [scm_struct_i_size] & SCM_STRUCTF_MASK) | s)
/* {Entity classes}
*
* For instances of entity classes (entities), the procedures to be
* applied are stored in the instance itself.
*
* An example of an entity class is the class of generic methods.
*/
#define SCM_ENTITY_LAYOUT ""
/* {Interface to Goops}
*
* The evaluator contains a multi-method dispatch mechanism.
@ -85,7 +64,7 @@
*/
/* Internal representation of Goops objects. */
#define SCM_CLASSF_PURE_GENERIC (0x010 << 20)
#define SCM_CLASSF_PURE_GENERIC SCM_STRUCTF_GOOPS_HACK
#define SCM_CLASSF_GOOPS_VALID (0x080 << 20)
#define SCM_CLASSF_GOOPS (0x100 << 20)
#define scm_si_redefined 5
@ -119,9 +98,6 @@ SCM_API SCM scm_call_generic_2 (SCM gf, SCM a1, SCM a2);
SCM_API SCM scm_apply_generic (SCM gf, SCM args);
*/
SCM_API SCM scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3);
SCM_API SCM scm_entity_p (SCM obj);
SCM_API SCM scm_valid_object_procedure_p (SCM proc);
SCM_API SCM scm_set_object_procedure_x (SCM obj, SCM proc);
SCM_INTERNAL void scm_init_objects (void);

6
libguile/procprop.c
View file

@ -127,11 +127,13 @@ scm_i_procedure_arity (SCM proc)
r = 1;
break;
}
else if (!SCM_I_ENTITYP (proc))
return SCM_BOOL_F;
/* FIXME applicable structs */
return SCM_BOOL_F;
#if 0
proc = SCM_ENTITY_PROCEDURE (proc);
a -= 1;
goto loop;
#endif
default:
return SCM_BOOL_F;
}

9
libguile/procs.c
View file

@ -98,7 +98,7 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0,
switch (SCM_TYP7 (obj))
{
case scm_tcs_struct:
if (!SCM_I_ENTITYP (obj))
if (!(SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_PURE_GENERIC))
break;
case scm_tcs_closures:
case scm_tcs_subrs:
@ -262,7 +262,8 @@ SCM_DEFINE (scm_procedure, "procedure", 1, 0, 0,
return SCM_PROCEDURE (proc);
else if (SCM_STRUCTP (proc))
{
SCM_ASSERT (SCM_I_ENTITYP (proc), proc, SCM_ARG1, FUNC_NAME);
SCM_ASSERT (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC,
proc, SCM_ARG1, FUNC_NAME);
return proc;
}
SCM_WRONG_TYPE_ARG (1, proc);
@ -281,9 +282,9 @@ scm_setter (SCM proc)
else if (SCM_STRUCTP (proc))
{
SCM setter;
SCM_GASSERT1 (SCM_I_ENTITYP (proc),
SCM_GASSERT1 (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC,
g_setter, proc, SCM_ARG1, s_setter);
setter = SCM_ENTITY_SETTER (proc);
setter = SCM_GENERIC_SETTER (proc);
if (SCM_NIMP (setter))
return setter;
/* fall through */

2
libguile/struct.c
View file

@ -420,7 +420,7 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
need for a lock on the section below, as it does not access or update
any globals, so the critical section has been removed. */
if (c_vtable[scm_struct_i_flags] & SCM_STRUCTF_ENTITY)
if (c_vtable[scm_struct_i_flags] & SCM_STRUCTF_GOOPS_HACK)
{
data = scm_alloc_struct (basic_size + tail_elts,
scm_struct_entity_n_extra_words,

2
libguile/struct.h
View file

@ -51,7 +51,7 @@
typedef void (*scm_t_struct_free) (scm_t_bits * vtable, scm_t_bits * data);
#define SCM_STRUCTF_MASK (0xFFF << 20)
#define SCM_STRUCTF_ENTITY (1L << 30) /* Indicates presence of proc slots */
#define SCM_STRUCTF_GOOPS_HACK (0x010 << 20) /* FIXME -- PURE_GENERIC */
#define SCM_STRUCTF_LIGHT (1L << 31) /* Light representation
(no hidden words) */