summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMikael Djurfeldt <djurfeldt@nada.kth.se>2003-03-19 08:57:47 +0000
committerMikael Djurfeldt <djurfeldt@nada.kth.se>2003-03-19 08:57:47 +0000
commit74b6d6e4565199ad868af57288316deb21742da6 (patch)
tree0f11afde780e9a0a8afddc1acaaee8cab3f46f0c
parent5c9e7dad75a4b17581a64dcbee1a3e7dbcddaa84 (diff)
downloadguile-74b6d6e4565199ad868af57288316deb21742da6.tar.gz
* goops.c (make_class_from_template): New fourth arg:
applicablep. (scm_class_extended_generic_with_setter, scm_class_self): Fixed cpls. * smob.c (scm_set_smob_apply): Call scm_i_inherit_applicable. * goops.c, objects.c, objects.h (scm_make_extended_class): New second arg: applicablep. (scm_i_inherit_applicable): New function. * goops.c, goops.h (scm_class_applicable, scm_class_extended_accessor): New classes.
-rw-r--r--libguile/ChangeLog16
-rw-r--r--libguile/goops.c114
-rw-r--r--libguile/goops.h2
-rw-r--r--libguile/objects.c5
-rw-r--r--libguile/objects.h5
-rw-r--r--libguile/smob.c7
6 files changed, 126 insertions, 23 deletions
diff --git a/libguile/ChangeLog b/libguile/ChangeLog
index ea3cf9d04..635b8179b 100644
--- a/libguile/ChangeLog
+++ b/libguile/ChangeLog
@@ -1,3 +1,19 @@
+2003-03-19 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * goops.c (make_class_from_template): New fourth arg:
+ applicablep.
+ (scm_class_extended_generic_with_setter, scm_class_self): Fixed
+ cpls.
+
+ * smob.c (scm_set_smob_apply): Call scm_i_inherit_applicable.
+
+ * goops.c, objects.c, objects.h (scm_make_extended_class): New
+ second arg: applicablep.
+ (scm_i_inherit_applicable): New function.
+
+ * goops.c, goops.h (scm_class_applicable,
+ scm_class_extended_accessor): New classes.
+
2003-03-18 Dirk Herrmann <D.Herrmann@tu-bs.de>
* procs.c (scm_procedure_documentation): Removed redundant
diff --git a/libguile/goops.c b/libguile/goops.c
index 6b2f65c3e..356af8624 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -135,10 +135,12 @@ static SCM scm_goops_lookup_closure;
/* Some classes are defined in libguile/objects.c. */
SCM scm_class_top, scm_class_object, scm_class_class;
+SCM scm_class_applicable;
SCM scm_class_entity, scm_class_entity_with_setter;
SCM scm_class_generic, scm_class_generic_with_setter;
SCM scm_class_accessor;
SCM scm_class_extended_generic, scm_class_extended_generic_with_setter;
+SCM scm_class_extended_accessor;
SCM scm_class_method;
SCM scm_class_simple_method, scm_class_accessor_method;
SCM scm_class_procedure_class;
@@ -2240,6 +2242,26 @@ SCM_DEFINE (scm_sys_method_more_specific_p, "%method-more-specific?", 3, 0, 0,
*
******************************************************************************/
+static void
+fix_cpl (SCM c, SCM before, SCM after)
+{
+ SCM cpl = SCM_SLOT (c, scm_si_cpl);
+ SCM ls = scm_c_memq (after, cpl);
+ SCM tail = scm_delq1_x (before, SCM_CDR (ls));
+ if (SCM_FALSEP (ls))
+ /* if this condition occurs, fix_cpl should not be applied this way */
+ abort ();
+ SCM_SETCAR (ls, before);
+ SCM_SETCDR (ls, scm_cons (after, tail));
+ {
+ SCM dslots = SCM_SLOT (c, scm_si_direct_slots);
+ SCM slots = build_slots_list (maplist (dslots), cpl);
+ SCM g_n_s = compute_getters_n_setters (slots);
+ SCM_SET_SLOT (c, scm_si_slots, slots);
+ SCM_SET_SLOT (c, scm_si_getters_n_setters, g_n_s);
+ }
+}
+
static void
make_stdcls (SCM *var, char *name, SCM meta, SCM super, SCM slots)
@@ -2299,7 +2321,7 @@ create_standard_classes (void)
scm_class_class, scm_class_foreign_slot, SCM_EOL);
make_stdcls (&scm_class_self, "<self-slot>",
scm_class_class,
- scm_list_2 (scm_class_foreign_slot, scm_class_read_only),
+ scm_class_read_only,
SCM_EOL);
make_stdcls (&scm_class_protected_opaque, "<protected-opaque-slot>",
scm_class_class,
@@ -2356,8 +2378,12 @@ create_standard_classes (void)
make_stdcls (&scm_class_accessor_method, "<accessor-method>",
scm_class_class, scm_class_simple_method, amethod_slots);
SCM_SET_CLASS_FLAGS (scm_class_accessor_method, SCM_CLASSF_ACCESSOR_METHOD);
+ make_stdcls (&scm_class_applicable, "<applicable>",
+ scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&scm_class_entity, "<entity>",
- scm_class_entity_class, scm_class_object, SCM_EOL);
+ scm_class_entity_class,
+ scm_list_2 (scm_class_object, scm_class_applicable),
+ SCM_EOL);
make_stdcls (&scm_class_entity_with_setter, "<entity-with-setter>",
scm_class_entity_class, scm_class_entity, SCM_EOL);
make_stdcls (&scm_class_generic, "<generic>",
@@ -2377,11 +2403,19 @@ create_standard_classes (void)
make_stdcls (&scm_class_extended_generic_with_setter,
"<extended-generic-with-setter>",
scm_class_entity_class,
- scm_list_2 (scm_class_extended_generic,
- scm_class_entity_with_setter),
+ scm_list_2 (scm_class_generic_with_setter,
+ scm_class_extended_generic),
SCM_EOL);
SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter,
SCM_CLASSF_PURE_GENERIC);
+ make_stdcls (&scm_class_extended_accessor, "<extended-accessor>",
+ scm_class_entity_class,
+ scm_list_2 (scm_class_accessor,
+ scm_class_extended_generic_with_setter),
+ SCM_EOL);
+ fix_cpl (scm_class_extended_accessor,
+ scm_class_extended_generic, scm_class_generic);
+ SCM_SET_CLASS_FLAGS (scm_class_extended_accessor, SCM_CLASSF_PURE_GENERIC);
/* Primitive types classes */
make_stdcls (&scm_class_boolean, "<boolean>",
@@ -2413,7 +2447,7 @@ create_standard_classes (void)
make_stdcls (&scm_class_unknown, "<unknown>",
scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&scm_class_procedure, "<procedure>",
- scm_class_procedure_class, scm_class_top, SCM_EOL);
+ 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>",
@@ -2437,7 +2471,7 @@ create_standard_classes (void)
**********************************************************************/
static SCM
-make_class_from_template (char *template, char *type_name, SCM supers)
+make_class_from_template (char *template, char *type_name, SCM supers, int applicablep)
{
SCM class, name;
if (type_name)
@@ -2449,7 +2483,9 @@ make_class_from_template (char *template, char *type_name, SCM supers)
else
name = SCM_GOOPS_UNBOUND;
- class = scm_permanent_object (scm_basic_make_class (scm_class_class,
+ class = scm_permanent_object (scm_basic_make_class (applicablep
+ ? scm_class_procedure_class
+ : scm_class_class,
name,
supers,
SCM_EOL));
@@ -2462,11 +2498,49 @@ make_class_from_template (char *template, char *type_name, SCM supers)
}
SCM
-scm_make_extended_class (char *type_name)
+scm_make_extended_class (char *type_name, int applicablep)
{
return make_class_from_template ("<%s>",
type_name,
- scm_list_1 (scm_class_top));
+ scm_list_1 (applicablep
+ ? scm_class_applicable
+ : scm_class_top),
+ applicablep);
+}
+
+void
+scm_i_inherit_applicable (SCM c)
+{
+ if (!SCM_SUBCLASSP (c, scm_class_applicable))
+ {
+ SCM dsupers = SCM_SLOT (c, scm_si_direct_supers);
+ SCM cpl = SCM_SLOT (c, scm_si_cpl);
+ /* patch scm_class_applicable into direct-supers */
+ SCM top = scm_c_memq (scm_class_top, dsupers);
+ if (SCM_FALSEP (top))
+ dsupers = scm_append (scm_list_2 (dsupers,
+ scm_list_1 (scm_class_applicable)));
+ else
+ {
+ SCM_SETCAR (top, scm_class_applicable);
+ SCM_SETCDR (top, scm_cons (scm_class_top, SCM_CDR (top)));
+ }
+ SCM_SET_SLOT (c, scm_si_direct_supers, dsupers);
+ /* patch scm_class_applicable into cpl */
+ top = scm_c_memq (scm_class_top, cpl);
+ if (SCM_FALSEP (top))
+ abort ();
+ else
+ {
+ SCM_SETCAR (top, scm_class_applicable);
+ SCM_SETCDR (top, scm_cons (scm_class_top, SCM_CDR (top)));
+ }
+ /* add class to direct-subclasses of scm_class_applicable */
+ SCM_SET_SLOT (scm_class_applicable,
+ scm_si_direct_subclasses,
+ scm_cons (c, SCM_SLOT (scm_class_applicable,
+ scm_si_direct_subclasses)));
+ }
}
static void
@@ -2485,7 +2559,8 @@ create_smob_classes (void)
for (i = 0; i < scm_numsmob; ++i)
if (!scm_smob_class[i])
- scm_smob_class[i] = scm_make_extended_class (SCM_SMOBNAME (i));
+ scm_smob_class[i] = scm_make_extended_class (SCM_SMOBNAME (i),
+ scm_smobs[i].apply != 0);
}
void
@@ -2493,20 +2568,24 @@ scm_make_port_classes (long ptobnum, char *type_name)
{
SCM c, class = make_class_from_template ("<%s-port>",
type_name,
- scm_list_1 (scm_class_port));
+ scm_list_1 (scm_class_port),
+ 0);
scm_port_class[SCM_IN_PCLASS_INDEX + ptobnum]
= make_class_from_template ("<%s-input-port>",
type_name,
- scm_list_2 (class, scm_class_input_port));
+ scm_list_2 (class, scm_class_input_port),
+ 0);
scm_port_class[SCM_OUT_PCLASS_INDEX + ptobnum]
= make_class_from_template ("<%s-output-port>",
type_name,
- scm_list_2 (class, scm_class_output_port));
+ scm_list_2 (class, scm_class_output_port),
+ 0);
scm_port_class[SCM_INOUT_PCLASS_INDEX + ptobnum]
= c
= make_class_from_template ("<%s-input-output-port>",
type_name,
- scm_list_2 (class, scm_class_input_output_port));
+ scm_list_2 (class, scm_class_input_output_port),
+ 0);
/* Patch cpl (since this tree is too complex for the C level compute-cpl) */
SCM_SET_SLOT (c, scm_si_cpl,
scm_cons2 (c, class, SCM_SLOT (scm_class_input_output_port, scm_si_cpl)));
@@ -2526,13 +2605,14 @@ create_port_classes (void)
}
static SCM
-make_struct_class (void *closure SCM_UNUSED, SCM key SCM_UNUSED,
- SCM data, SCM prev SCM_UNUSED)
+make_struct_class (void *closure SCM_UNUSED,
+ SCM vtable, SCM data, SCM prev SCM_UNUSED)
{
if (!SCM_FALSEP (SCM_STRUCT_TABLE_NAME (data)))
SCM_SET_STRUCT_TABLE_CLASS (data,
scm_make_extended_class
- (SCM_SYMBOL_CHARS (SCM_STRUCT_TABLE_NAME (data))));
+ (SCM_SYMBOL_CHARS (SCM_STRUCT_TABLE_NAME (data)),
+ SCM_CLASS_FLAGS (vtable) & SCM_CLASSF_OPERATOR));
return SCM_UNSPECIFIED;
}
diff --git a/libguile/goops.h b/libguile/goops.h
index d4e848083..35fff1bf7 100644
--- a/libguile/goops.h
+++ b/libguile/goops.h
@@ -184,6 +184,7 @@ typedef struct scm_t_method {
SCM_API SCM scm_class_top;
SCM_API SCM scm_class_object;
SCM_API SCM scm_class_class;
+SCM_API SCM scm_class_applicable;
SCM_API SCM scm_class_entity;
SCM_API SCM scm_class_entity_with_setter;
SCM_API SCM scm_class_generic;
@@ -191,6 +192,7 @@ SCM_API SCM scm_class_generic_with_setter;
SCM_API SCM scm_class_accessor;
SCM_API SCM scm_class_extended_generic;
SCM_API SCM scm_class_extended_generic_with_setter;
+SCM_API SCM scm_class_extended_accessor;
SCM_API SCM scm_class_method;
SCM_API SCM scm_class_simple_method;
SCM_API SCM scm_class_accessor_method;
diff --git a/libguile/objects.c b/libguile/objects.c
index 4c22626c6..fe4b8b388 100644
--- a/libguile/objects.c
+++ b/libguile/objects.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1999,2000,2001 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1999,2000,2001, 2003 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -190,7 +190,8 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
SCM name = SCM_STRUCT_TABLE_NAME (SCM_CDR (handle));
SCM class = scm_make_extended_class (!SCM_FALSEP (name)
? SCM_SYMBOL_CHARS (name)
- : 0);
+ : 0,
+ SCM_I_OPERATORP (x));
SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle), class);
return class;
}
diff --git a/libguile/objects.h b/libguile/objects.h
index 5bf79fc9b..a10ea9af7 100644
--- a/libguile/objects.h
+++ b/libguile/objects.h
@@ -3,7 +3,7 @@
#ifndef SCM_OBJECTS_H
#define SCM_OBJECTS_H
-/* Copyright (C) 1996,1999,2000,2001 Free Software Foundation, Inc.
+/* Copyright (C) 1996,1999,2000,2001, 2003 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -221,7 +221,8 @@ SCM_API SCM *scm_smob_class;
SCM_API SCM scm_no_applicable_method;
/* Goops functions. */
-SCM_API SCM scm_make_extended_class (char *type_name);
+SCM_API SCM scm_make_extended_class (char *type_name, int applicablep);
+SCM_API void scm_i_inherit_applicable (SCM c);
SCM_API void scm_make_port_classes (long ptobnum, char *type_name);
SCM_API void scm_change_object_class (SCM, SCM, SCM);
SCM_API SCM scm_memoize_method (SCM x, SCM args);
diff --git a/libguile/smob.c b/libguile/smob.c
index 5853e3abc..eb173091c 100644
--- a/libguile/smob.c
+++ b/libguile/smob.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998,1999,2000,2001 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -313,7 +313,7 @@ scm_make_smob_type (char *name, size_t size)
/* Make a class object if Goops is present. */
if (scm_smob_class)
- scm_smob_class[new_smob] = scm_make_extended_class (name);
+ scm_smob_class[new_smob] = scm_make_extended_class (name, 0);
return scm_tc7_smob + new_smob * 256;
}
@@ -452,6 +452,9 @@ scm_set_smob_apply (scm_t_bits tc, SCM (*apply) (),
scm_smobs[SCM_TC2SMOBNUM (tc)].apply_2 = apply_2;
scm_smobs[SCM_TC2SMOBNUM (tc)].apply_3 = apply_3;
scm_smobs[SCM_TC2SMOBNUM (tc)].gsubr_type = type;
+
+ if (scm_smob_class)
+ scm_i_inherit_applicable (scm_smob_class[SCM_TC2SMOBNUM (tc)]);
}
SCM