diff options
author | Mikael Djurfeldt <djurfeldt@nada.kth.se> | 2003-03-19 08:57:47 +0000 |
---|---|---|
committer | Mikael Djurfeldt <djurfeldt@nada.kth.se> | 2003-03-19 08:57:47 +0000 |
commit | 74b6d6e4565199ad868af57288316deb21742da6 (patch) | |
tree | 0f11afde780e9a0a8afddc1acaaee8cab3f46f0c | |
parent | 5c9e7dad75a4b17581a64dcbee1a3e7dbcddaa84 (diff) | |
download | guile-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/ChangeLog | 16 | ||||
-rw-r--r-- | libguile/goops.c | 114 | ||||
-rw-r--r-- | libguile/goops.h | 2 | ||||
-rw-r--r-- | libguile/objects.c | 5 | ||||
-rw-r--r-- | libguile/objects.h | 5 | ||||
-rw-r--r-- | libguile/smob.c | 7 |
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 |