diff --git a/libguile/debug.c b/libguile/debug.c index 5b42dddd9..c277c1398 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -356,7 +356,7 @@ SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0, } } case scm_tcs_struct: - if (!SCM_I_OPERATORP (proc)) + if (!SCM_I_ENTITYP (proc)) break; goto procprop; case scm_tc7_smob: diff --git a/libguile/eval.c b/libguile/eval.c index cdb90423a..317be4042 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -3270,7 +3270,7 @@ 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_OPERATORP (proc)) + else if (SCM_I_ENTITYP (proc)) trampoline = scm_call_0; else return NULL; @@ -3396,7 +3396,7 @@ 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_OPERATORP (proc)) + else if (SCM_I_ENTITYP (proc)) trampoline = scm_call_1; else return NULL; @@ -3493,7 +3493,7 @@ 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_OPERATORP (proc)) + else if (SCM_I_ENTITYP (proc)) trampoline = scm_call_2; else return NULL; diff --git a/libguile/eval.i.c b/libguile/eval.i.c index 03eb2cd82..2eba83e86 100644 --- a/libguile/eval.i.c +++ b/libguile/eval.i.c @@ -1031,12 +1031,10 @@ dispatch: arg1 = SCM_EOL; goto type_dispatch; } - else if (SCM_I_OPERATORP (proc)) + else if (SCM_I_ENTITYP (proc)) { arg1 = proc; - proc = (SCM_I_ENTITYP (proc) - ? SCM_ENTITY_PROCEDURE (proc) - : SCM_OPERATOR_PROCEDURE (proc)); + proc = SCM_ENTITY_PROCEDURE (proc); #ifdef DEVAL debug.info->a.proc = proc; debug.info->a.args = scm_list_1 (arg1); @@ -1164,13 +1162,11 @@ dispatch: #endif goto type_dispatch; } - else if (SCM_I_OPERATORP (proc)) + else if (SCM_I_ENTITYP (proc)) { arg2 = arg1; arg1 = proc; - proc = (SCM_I_ENTITYP (proc) - ? SCM_ENTITY_PROCEDURE (proc) - : SCM_OPERATOR_PROCEDURE (proc)); + proc = SCM_ENTITY_PROCEDURE (proc); #ifdef DEVAL debug.info->a.args = scm_cons (arg1, debug.info->a.args); debug.info->a.proc = proc; @@ -1245,19 +1241,15 @@ dispatch: #endif goto type_dispatch; } - else if (SCM_I_OPERATORP (proc)) + else if (SCM_I_ENTITYP (proc)) { operatorn: #ifdef DEVAL - RETURN (SCM_APPLY (SCM_I_ENTITYP (proc) - ? SCM_ENTITY_PROCEDURE (proc) - : SCM_OPERATOR_PROCEDURE (proc), + RETURN (SCM_APPLY (SCM_ENTITY_PROCEDURE (proc), scm_cons (proc, debug.info->a.args), SCM_EOL)); #else - RETURN (SCM_APPLY (SCM_I_ENTITYP (proc) - ? SCM_ENTITY_PROCEDURE (proc) - : SCM_OPERATOR_PROCEDURE (proc), + RETURN (SCM_APPLY (SCM_ENTITY_PROCEDURE (proc), scm_cons2 (proc, arg1, scm_cons (arg2, scm_ceval_args (x, @@ -1475,7 +1467,7 @@ dispatch: x = SCM_ENTITY_PROCEDURE (proc); goto type_dispatch; } - else if (SCM_I_OPERATORP (proc)) + else if (SCM_I_ENTITYP (proc)) goto operatorn; else goto badfun; @@ -1780,7 +1772,7 @@ tail: #endif RETURN (scm_apply_generic (proc, args)); } - else if (SCM_I_OPERATORP (proc)) + else if (SCM_I_ENTITYP (proc)) { /* operator */ #ifdef DEVAL @@ -1789,9 +1781,7 @@ tail: args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args)); #endif arg1 = proc; - proc = (SCM_I_ENTITYP (proc) - ? SCM_ENTITY_PROCEDURE (proc) - : SCM_OPERATOR_PROCEDURE (proc)); + proc = SCM_ENTITY_PROCEDURE (proc); #ifdef DEVAL debug.vect[0].a.proc = proc; debug.vect[0].a.args = scm_cons (arg1, args); diff --git a/libguile/goops.c b/libguile/goops.c index 24a823f28..0e9d04494 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -145,7 +145,6 @@ SCM scm_class_extended_accessor; SCM scm_class_method; SCM scm_class_simple_method, scm_class_accessor_method; SCM scm_class_procedure_class; -SCM scm_class_operator_class, scm_class_operator_with_setter_class; SCM scm_class_entity_class; SCM scm_class_number, scm_class_list; SCM scm_class_keyword; @@ -289,8 +288,7 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, name = scm_string_to_symbol (scm_nullstr); class = - scm_make_extended_class_from_symbol (name, - SCM_I_OPERATORP (x)); + scm_make_extended_class_from_symbol (name, SCM_I_ENTITYP (x)); SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle), class); return class; } @@ -831,10 +829,7 @@ 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_OPERATOR | SCM_CLASSF_ENTITY) - : class == scm_class_operator_class - ? SCM_CLASSF_GOOPS_OR_VALID | SCM_CLASSF_OPERATOR : SCM_CLASSF_GOOPS_OR_VALID)); return z; } @@ -1600,9 +1595,7 @@ SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0, SCM_SET_SLOT (z, i, SCM_GOOPS_UNBOUND); if (SCM_SUBCLASSP (class, scm_class_entity_class)) - SCM_SET_CLASS_FLAGS (z, SCM_CLASSF_OPERATOR | SCM_CLASSF_ENTITY); - else if (SCM_SUBCLASSP (class, scm_class_operator_class)) - SCM_SET_CLASS_FLAGS (z, SCM_CLASSF_OPERATOR); + SCM_SET_CLASS_FLAGS (z, SCM_CLASSF_ENTITY); return z; } @@ -1620,16 +1613,11 @@ 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_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR) - || SCM_I_ENTITYP (obj)), + SCM_ASSERT (SCM_STRUCTP (obj) && SCM_I_ENTITYP (obj), obj, SCM_ARG1, FUNC_NAME); - if (SCM_I_ENTITYP (obj)) - SCM_SET_ENTITY_SETTER (obj, setter); - else - SCM_OPERATOR_CLASS (obj)->setter = setter; + SCM_SET_ENTITY_SETTER (obj, setter); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -2557,11 +2545,6 @@ create_standard_classes (void) scm_class_class, scm_class_class, SCM_EOL); make_stdcls (&scm_class_entity_class, "", scm_class_class, scm_class_procedure_class, SCM_EOL); - make_stdcls (&scm_class_operator_class, "", - scm_class_class, scm_class_procedure_class, SCM_EOL); - make_stdcls (&scm_class_operator_with_setter_class, - "", - scm_class_class, scm_class_operator_class, SCM_EOL); make_stdcls (&scm_class_method, "", scm_class_class, scm_class_object, method_slots); make_stdcls (&scm_class_simple_method, "", @@ -2835,7 +2818,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_OPERATOR; + int applicablep = SCM_CLASS_FLAGS (vtable) & SCM_CLASSF_ENTITY; SCM_SET_STRUCT_TABLE_CLASS (data, scm_make_extended_class_from_symbol (sym, applicablep)); diff --git a/libguile/goops.h b/libguile/goops.h index 8d138237a..1e3ed535f 100644 --- a/libguile/goops.h +++ b/libguile/goops.h @@ -189,8 +189,6 @@ SCM_API SCM scm_class_method; SCM_API SCM scm_class_simple_method; SCM_API SCM scm_class_accessor_method; SCM_API SCM scm_class_procedure_class; -SCM_API SCM scm_class_operator_class; -SCM_API SCM scm_class_operator_with_setter_class; SCM_API SCM scm_class_entity_class; SCM_API SCM scm_class_number; SCM_API SCM scm_class_list; diff --git a/libguile/objects.c b/libguile/objects.c index f686c3a00..5889c1bf6 100644 --- a/libguile/objects.c +++ b/libguile/objects.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1999,2000,2001, 2003, 2004, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1999,2000,2001, 2003, 2004, 2006, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -50,7 +50,6 @@ SCM scm_metaclass_standard; -SCM scm_metaclass_operator; /* The cache argument for scm_mcache_lookup_cmethod has one of two possible * formats: @@ -209,17 +208,6 @@ SCM_DEFINE (scm_entity_p, "entity?", 1, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_operator_p, "operator?", 1, 0, 0, - (SCM obj), - "Return @code{#t} if @var{obj} is an operator.") -#define FUNC_NAME s_scm_operator_p -{ - return scm_from_bool(SCM_STRUCTP (obj) - && SCM_I_OPERATORP (obj) - && !SCM_I_ENTITYP (obj)); -} -#undef FUNC_NAME - /* XXX - What code requires the object procedure to be only of certain types? */ @@ -249,22 +237,18 @@ SCM_DEFINE (scm_valid_object_procedure_p, "valid-object-procedure?", 1, 0, 0, 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 either an entity or an operator.") + "@var{obj} must be an entity.") #define FUNC_NAME s_scm_set_object_procedure_x { SCM_ASSERT (SCM_STRUCTP (obj) - && ((SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR) - || (SCM_I_ENTITYP (obj) - && !(SCM_OBJ_CLASS_FLAGS (obj) - & SCM_CLASSF_PURE_GENERIC))), + && (SCM_I_ENTITYP (obj) + && !(SCM_OBJ_CLASS_FLAGS (obj) + & SCM_CLASSF_PURE_GENERIC)), obj, SCM_ARG1, FUNC_NAME); SCM_ASSERT (scm_valid_object_procedure_p (proc), proc, SCM_ARG2, FUNC_NAME); - if (SCM_I_ENTITYP (obj)) - SCM_SET_ENTITY_PROCEDURE (obj, proc); - else - SCM_OPERATOR_CLASS (obj)->procedure = proc; +SCM_SET_ENTITY_PROCEDURE (obj, proc); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -273,16 +257,12 @@ SCM_DEFINE (scm_set_object_procedure_x, "set-object-procedure!", 2, 0, 0, SCM_DEFINE (scm_object_procedure, "object-procedure", 1, 0, 0, (SCM obj), "Return the object procedure of @var{obj}. @var{obj} must be\n" - "an entity or an operator.") + "an entity.") #define FUNC_NAME s_scm_object_procedure { - SCM_ASSERT (SCM_STRUCTP (obj) - && ((SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR) - || SCM_I_ENTITYP (obj)), + SCM_ASSERT (SCM_STRUCTP (obj) && SCM_I_ENTITYP (obj), obj, SCM_ARG1, FUNC_NAME); - return (SCM_I_ENTITYP (obj) - ? SCM_ENTITY_PROCEDURE (obj) - : SCM_OPERATOR_CLASS (obj)->procedure); + return SCM_ENTITY_PROCEDURE (obj); } #undef FUNC_NAME #endif /* GUILE_DEBUG */ @@ -315,8 +295,6 @@ SCM_DEFINE (scm_make_class_object, "make-class-object", 2, 0, 0, unsigned long flags = 0; SCM_VALIDATE_STRUCT (1, metaclass); SCM_VALIDATE_STRING (2, layout); - if (scm_is_eq (metaclass, scm_metaclass_operator)) - flags = SCM_CLASSF_OPERATOR; return scm_i_make_class_object (metaclass, layout, flags); } #undef FUNC_NAME @@ -345,10 +323,6 @@ scm_init_objects () SCM mt = scm_make_vtable_vtable (ms, SCM_INUM0, scm_list_3 (SCM_BOOL_F, SCM_EOL, SCM_EOL)); - SCM os = scm_from_locale_string (SCM_METACLASS_OPERATOR_LAYOUT); - SCM ot = scm_make_vtable_vtable (os, 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, @@ -356,9 +330,7 @@ scm_init_objects () scm_c_define ("", mt); scm_metaclass_standard = mt; - scm_c_define ("", ot); - scm_metaclass_operator = ot; - SCM_SET_CLASS_FLAGS (et, SCM_CLASSF_OPERATOR | SCM_CLASSF_ENTITY); + SCM_SET_CLASS_FLAGS (et, SCM_CLASSF_ENTITY); scm_c_define ("", et); #include "libguile/objects.x" diff --git a/libguile/objects.h b/libguile/objects.h index 914a7ea74..b4c42b7d8 100644 --- a/libguile/objects.h +++ b/libguile/objects.h @@ -52,18 +52,6 @@ #define SCM_CLASSF_MASK SCM_STRUCTF_MASK #define SCM_CLASSF_ENTITY SCM_STRUCTF_ENTITY -/* Operator classes need to be identified in the evaluator. - (Entities also have SCM_CLASSF_OPERATOR set in their vtable.) */ -#define SCM_CLASSF_OPERATOR (1L << 29) - -#define SCM_I_OPERATORP(obj)\ - ((SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR) != 0) -#define SCM_OPERATOR_CLASS(obj)\ -((struct scm_metaclass_operator *) SCM_STRUCT_DATA (obj)) -#define SCM_OBJ_OPERATOR_CLASS(obj)\ -((struct scm_metaclass_operator *) SCM_STRUCT_VTABLE_DATA (obj)) -#define SCM_OPERATOR_PROCEDURE(obj) (SCM_OBJ_OPERATOR_CLASS (obj)->procedure) -#define SCM_OPERATOR_SETTER(obj) (SCM_OBJ_OPERATOR_CLASS (obj)->setter) #define SCM_I_ENTITYP(obj)\ ((SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_ENTITY) != 0) @@ -80,38 +68,6 @@ (SCM_STRUCT_DATA (c)[scm_struct_i_size] \ = (SCM_STRUCT_DATA (c) [scm_struct_i_size] & SCM_STRUCTF_MASK) | s) -/* {Operator classes} - * - * Instances of operator classes can work as operators, i. e., they - * can be applied to arguments just as if they were ordinary - * procedures. - * - * For instances of operator classes, the procedures to be applied are - * stored in four dedicated slots in the associated class object. - * Which one is selected depends on the number of arguments in the - * application. - * - * If zero arguments are passed, the first will be selected. - * If one argument is passed, the second will be selected. - * If two arguments are passed, the third will be selected. - * If three or more arguments are passed, the fourth will be selected. - * - * This is complicated and may seem gratuitous but has to do with the - * architecture of the evaluator. Using only one procedure would - * result in a great deal less efficient application, loss of - * tail-recursion and would be difficult to reconcile with the - * debugging evaluator. - * - * Also, using this "forked" application in low-level code has the - * advantage of speeding up some code. An example is method dispatch - * for generic operators applied to few arguments. On the user level, - * the "forked" application will be hidden by mechanisms in the GOOPS - * package. - * - * Operator classes have the metaclass . - * - * An example of an operator class is the class . - */ #define SCM_METACLASS_STANDARD_LAYOUT "" struct scm_metaclass_standard { SCM layout; @@ -120,21 +76,10 @@ struct scm_metaclass_standard { SCM print; }; -#define SCM_METACLASS_OPERATOR_LAYOUT "popo" -struct scm_metaclass_operator { - SCM layout; - SCM vcell; - SCM vtable; - SCM print; - SCM procedure; - SCM setter; -}; - /* {Entity classes} * * For instances of entity classes (entities), the procedures to be - * applied are stored in the instance itself rather than in the class - * object as is the case for instances of operator classes (see above). + * applied are stored in the instance itself. * * An example of an entity class is the class of generic methods. */ @@ -178,7 +123,6 @@ typedef struct scm_effective_slot_definition { /* Plugin proxy classes for basic types. */ SCM_API SCM scm_metaclass_standard; -SCM_API SCM scm_metaclass_operator; /* Goops functions. */ SCM_API SCM scm_make_extended_class (char const *type_name, int applicablep); @@ -197,7 +141,6 @@ 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_operator_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); #ifdef GUILE_DEBUG diff --git a/libguile/procprop.c b/libguile/procprop.c index dcbfba794..c461edd73 100644 --- a/libguile/procprop.c +++ b/libguile/procprop.c @@ -127,11 +127,9 @@ scm_i_procedure_arity (SCM proc) r = 1; break; } - else if (!SCM_I_OPERATORP (proc)) + else if (!SCM_I_ENTITYP (proc)) return SCM_BOOL_F; - proc = (SCM_I_ENTITYP (proc) - ? SCM_ENTITY_PROCEDURE (proc) - : SCM_OPERATOR_PROCEDURE (proc)); + proc = SCM_ENTITY_PROCEDURE (proc); a -= 1; goto loop; default: diff --git a/libguile/procs.c b/libguile/procs.c index 5de2f33f1..d0e7fbd26 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -98,7 +98,7 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0, switch (SCM_TYP7 (obj)) { case scm_tcs_struct: - if (!SCM_I_OPERATORP (obj)) + if (!SCM_I_ENTITYP (obj)) break; case scm_tcs_closures: case scm_tcs_subrs: @@ -262,7 +262,7 @@ SCM_DEFINE (scm_procedure, "procedure", 1, 0, 0, return SCM_PROCEDURE (proc); else if (SCM_STRUCTP (proc)) { - SCM_ASSERT (SCM_I_OPERATORP (proc), proc, SCM_ARG1, FUNC_NAME); + SCM_ASSERT (SCM_I_ENTITYP (proc), proc, SCM_ARG1, FUNC_NAME); return proc; } SCM_WRONG_TYPE_ARG (1, proc); @@ -281,11 +281,9 @@ scm_setter (SCM proc) else if (SCM_STRUCTP (proc)) { SCM setter; - SCM_GASSERT1 (SCM_I_OPERATORP (proc), + SCM_GASSERT1 (SCM_I_ENTITYP (proc), g_setter, proc, SCM_ARG1, s_setter); - setter = (SCM_I_ENTITYP (proc) - ? SCM_ENTITY_SETTER (proc) - : SCM_OPERATOR_SETTER (proc)); + setter = SCM_ENTITY_SETTER (proc); if (SCM_NIMP (setter)) return setter; /* fall through */ diff --git a/module/oop/goops.scm b/module/oop/goops.scm index 7871c2f7f..00a5d68d3 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -73,7 +73,7 @@ primitive-generic-generic enable-primitive-generic! method-procedure accessor-method-slot-definition slot-exists? make find-method get-keyword) - :replace ( ) + :replace ( ) :no-backtrace) (define *goops-module* (current-module)) @@ -1484,14 +1484,6 @@ (set-object-procedure! object (lambda args (apply proc args))))))) -(define-method (initialize (class ) initargs) - (next-method) - (initialize-object-procedure class initargs)) - -(define-method (initialize (owsc ) initargs) - (next-method) - (%set-object-setter! owsc (get-keyword #:setter initargs #f))) - (define-method (initialize (entity ) initargs) (next-method) (initialize-object-procedure entity initargs))