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

remove operators

Browse source
This commit is contained in:
Andy Wingo 2009-10-31 00:28:43 +01:00
parent 352c87d7e4
commit 730d8ad9e6
10 changed files with 37 additions and 163 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_OPERATORP (proc))
if (!SCM_I_ENTITYP (proc))
break;
goto procprop;
case scm_tc7_smob:

6
libguile/eval.c
View file

@ -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;

30
libguile/eval.i.c
View file

@ -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);

27
libguile/goops.c
View file

@ -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, "<entity-class>",
scm_class_class, scm_class_procedure_class, SCM_EOL);
make_stdcls (&scm_class_operator_class, "<operator-class>",
scm_class_class, scm_class_procedure_class, SCM_EOL);
make_stdcls (&scm_class_operator_with_setter_class,
"<operator-with-setter-class>",
scm_class_class, scm_class_operator_class, SCM_EOL);
make_stdcls (&scm_class_method, "<method>",
scm_class_class, scm_class_object, method_slots);
make_stdcls (&scm_class_simple_method, "<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));

2
libguile/goops.h
View file

@ -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;

48
libguile/objects.c
View file

@ -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 ("<class>", mt);
scm_metaclass_standard = mt;
scm_c_define ("<operator-class>", 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 ("<entity>", et);
#include "libguile/objects.x"

59
libguile/objects.h
View file

@ -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 <operator-metaclass>.
*
* An example of an operator class is the class <tk-command>.
*/
#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

6
libguile/procprop.c
View file

@ -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:

10
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_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 */

10
module/oop/goops.scm
View file

@ -73,7 +73,7 @@
primitive-generic-generic enable-primitive-generic!
method-procedure accessor-method-slot-definition
slot-exists? make find-method get-keyword)
:replace (<class> <operator-class> <entity-class> <entity>)
:replace (<class> <entity-class> <entity>)
:no-backtrace)
(define *goops-module* (current-module))
@ -1484,14 +1484,6 @@
(set-object-procedure! object
(lambda args (apply proc args)))))))
(define-method (initialize (class <operator-class>) initargs)
(next-method)
(initialize-object-procedure class initargs))
(define-method (initialize (owsc <operator-with-setter-class>) initargs)
(next-method)
(%set-object-setter! owsc (get-keyword #:setter initargs #f)))
(define-method (initialize (entity <entity>) initargs)
(next-method)
(initialize-object-procedure entity initargs))