* eval.c (SCM_CEVAL, scm_apply): Completed GOOPS support code;

Some indentation fixes.

* objects.h (SCM_METACLASS_STANDARD_LAYOUT): Printer field is no
longer a user field; New field: class_flags.

* objets.c, objects.h: New metaclass: scm_metaclass_operator.

libguile/ChangeLog

@@ -1,3 +1,15 @@
+Sun Oct 12 14:41:39 1997  Mikael Djurfeldt  <mdj@kenneth>
+
+	* ports.h: #include "libguile/print.h"
+
+	* eval.c (SCM_CEVAL, scm_apply): Completed GOOPS support code;
+ 	Some indentation fixes.
+
+	* objects.h (SCM_METACLASS_STANDARD_LAYOUT): Printer field is no
+	longer a user field; New field: class_flags.
+
+	* objets.c, objects.h: New metaclass: scm_metaclass_operator.
+
 Tue Oct  7 09:37:24 1997  Mark Galassi  <rosalia@cygnus.com>
 
 	* gh_data.c (gh_bool2scm): new function which replaces

libguile/eval.c

@@ -2099,6 +2099,27 @@ evapply:
 	x = SCM_CODE (proc);
 	env = EXTEND_ENV (SCM_CAR (x), SCM_EOL, SCM_ENV (proc));
 	goto cdrxbegin;
+      case scm_tcs_cons_gloc:
+	if (SCM_I_OPERATORP (proc))
+	  {
+	    x = (SCM_I_ENTITYP (proc)
+		 ? SCM_ENTITY_PROC_0 (proc)
+		 : SCM_OPERATOR_PROC_0 (proc));
+	    if (SCM_NIMP (x))
+	      if (SCM_TYP7 (x) == scm_tc7_subr_1)
+		RETURN (SCM_SUBRF (x) (proc))
+	      else if (SCM_CLOSUREP (x))
+		{
+		  t.arg1 = proc;
+		  proc = x;
+#ifdef DEVAL
+		  debug.info->a.args = scm_cons (t.arg1, SCM_EOL);
+		  debug.info->a.proc = proc;
+#endif
+		  goto clos1;
+		}
+	    /* Fall through. */
+	  }
       case scm_tc7_contin:
       case scm_tc7_subr_1:
       case scm_tc7_subr_2:
@@ -2196,6 +2217,7 @@ evapply:
 	  goto evap2;
 #endif
 	case scm_tcs_closures:
+	clos1:
 	  x = SCM_CODE (proc);
 #ifdef DEVAL
 	  env = EXTEND_ENV (SCM_CAR (x), debug.info->a.args, SCM_ENV (proc));
@@ -2203,12 +2225,13 @@ evapply:
 	  env = EXTEND_ENV (SCM_CAR (x), scm_cons (t.arg1, SCM_EOL), SCM_ENV (proc));
 #endif
 	  goto cdrxbegin;
-	case scm_tc7_contin:
-	  scm_call_continuation (proc, t.arg1);
 	case scm_tcs_cons_gloc:
-	  if (SCM_I_ENTITYP (proc))
+	  if (SCM_I_OPERATORP (proc))
 	    {
-	      x = SCM_ENTITY_PROC_1 (proc);
+	      x = (SCM_I_ENTITYP (proc)
+		   ? SCM_ENTITY_PROC_1 (proc)
+		   : SCM_OPERATOR_PROC_1 (proc));
+	      if (SCM_NIMP (x))
 		if (SCM_TYP7 (x) == scm_tc7_subr_2)
 		  RETURN (SCM_SUBRF (x) (proc, t.arg1))
 	        else if (SCM_CLOSUREP (x))
@@ -2224,6 +2247,8 @@ evapply:
 		  }
 	      /* Fall through. */
 	    }
+	case scm_tc7_contin:
+	  scm_call_continuation (proc, t.arg1);
 	case scm_tc7_subr_2:
 	case scm_tc7_subr_0:
 	case scm_tc7_subr_3:
@@ -2273,7 +2298,8 @@ evapply:
 #else
 	  RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), proc,
 			     scm_cons2 (t.arg1, arg2,
-					scm_cons (scm_eval_args (x, env), SCM_EOL))));
+					scm_cons (scm_eval_args (x, env),
+						  SCM_EOL))));
 #endif
 	  /*    case scm_tc7_cclo:
 		x = scm_cons(arg2, scm_eval_args(x, env));
@@ -2283,9 +2309,12 @@ evapply:
 		goto evap3; */
 #endif
 	case scm_tcs_cons_gloc:
-	  if (SCM_I_ENTITYP (proc))
+	  if (SCM_I_OPERATORP (proc))
 	    {
-	      x = SCM_ENTITY_PROC_2 (proc);
+	      x = (SCM_I_ENTITYP (proc)
+		   ? SCM_ENTITY_PROC_2 (proc)
+		   : SCM_OPERATOR_PROC_2 (proc));
+	      if (SCM_NIMP (x))
 		if (SCM_TYP7 (x) == scm_tc7_subr_3)
 		  RETURN (SCM_SUBRF (x) (proc, t.arg1, arg2))
 		else if (SCM_CLOSUREP (x))
@@ -2298,8 +2327,8 @@ evapply:
 		    env = EXTEND_ENV (SCM_CAR (SCM_CODE (x)),
 				      scm_cons2 (proc, t.arg1,
 						 scm_cons (arg2, env)),
-				    SCM_ENV (proc));
+				      SCM_ENV (x));
-		  x = SCM_CODE (proc);
+		    x = SCM_CODE (x);
 		    goto cdrxbegin;
 		  }
 	      /* Fall through. */
@@ -2316,9 +2345,12 @@ evapply:
 	case scm_tcs_closures:
 	clos2:
 #ifdef DEVAL
-	  env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), debug.info->a.args, SCM_ENV (proc));
+	  env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)),
+			    debug.info->a.args,
+			    SCM_ENV (proc));
 #else
-	  env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), scm_cons2 (t.arg1, arg2, SCM_EOL), SCM_ENV (proc));
+	  env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)),
+			    scm_cons2 (t.arg1, arg2, SCM_EOL), SCM_ENV (proc));
 #endif
 	  x = SCM_CODE (proc);
 	  goto cdrxbegin;
@@ -2329,21 +2361,23 @@ evapply:
       scm_deval_args (x, env, SCM_CDRLOC (SCM_CDR (debug.info->a.args))));
 #endif
     ENTER_APPLY;
-  evap3:
     switch (SCM_TYP7 (proc))
       {			/* have 3 or more arguments */
 #ifdef DEVAL
       case scm_tc7_subr_3:
 	SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs);
-	RETURN (SCM_SUBRF (proc) (t.arg1, arg2, SCM_CAR (SCM_CDR (SCM_CDR (debug.info->a.args)))));
+	RETURN (SCM_SUBRF (proc) (t.arg1, arg2,
+				  SCM_CADDR (debug.info->a.args)));
       case scm_tc7_asubr:
 #ifdef BUILTIN_RPASUBR
 	t.arg1 = SCM_SUBRF(proc)(t.arg1, arg2);
 	arg2 = SCM_CDR (SCM_CDR (debug.info->a.args));
-	do {
+	do
+	  {
 	    t.arg1 = SCM_SUBRF(proc)(t.arg1, SCM_CAR (arg2));
 	    arg2 = SCM_CDR (arg2);
-	} while (SCM_NIMP (arg2));
+	  }
+	while (SCM_NIMP (arg2));
 	RETURN (t.arg1)
 #endif /* BUILTIN_RPASUBR */
       case scm_tc7_rpsubr:
@@ -2351,18 +2385,24 @@ evapply:
 	if (SCM_FALSEP (SCM_SUBRF (proc) (t.arg1, arg2)))
 	  RETURN (SCM_BOOL_F)
 	t.arg1 = SCM_CDR (SCM_CDR (debug.info->a.args));
-	do {
+	do
+	  {
 	    if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, SCM_CAR (t.arg1))))
 	      RETURN (SCM_BOOL_F)
 		arg2 = SCM_CAR (t.arg1);
 	    t.arg1 = SCM_CDR (t.arg1);
-	} while (SCM_NIMP (t.arg1));
+	  }
+	while (SCM_NIMP (t.arg1));
 	RETURN (SCM_BOOL_T)
 #else /* BUILTIN_RPASUBR */
-	RETURN (SCM_APPLY (proc, t.arg1, scm_acons (arg2, SCM_CDR (SCM_CDR (debug.info->a.args)), SCM_EOL)))
+	RETURN (SCM_APPLY (proc, t.arg1,
+			   scm_acons (arg2,
+				      SCM_CDR (SCM_CDR (debug.info->a.args)),
+				      SCM_EOL)))
 #endif /* BUILTIN_RPASUBR */
       case scm_tc7_lsubr_2:
-	RETURN (SCM_SUBRF (proc) (t.arg1, arg2, SCM_CDR (SCM_CDR (debug.info->a.args))))
+	RETURN (SCM_SUBRF (proc) (t.arg1, arg2,
+				  SCM_CDR (SCM_CDR (debug.info->a.args))))
       case scm_tc7_lsubr:
 	RETURN (SCM_SUBRF (proc) (debug.info->a.args))
 #ifdef CCLO
@@ -2382,27 +2422,32 @@ evapply:
 	RETURN (SCM_SUBRF (proc) (t.arg1, arg2, EVALCAR (x, env)));
       case scm_tc7_asubr:
 #ifdef BUILTIN_RPASUBR
-	t.arg1 = SCM_SUBRF(proc)(t.arg1, arg2);
+	t.arg1 = SCM_SUBRF (proc) (t.arg1, arg2);
-	do {
+	do
+	  {
 	    t.arg1 = SCM_SUBRF(proc)(t.arg1, EVALCAR(x, env));
 	    x = SCM_CDR(x);
-	} while (SCM_NIMP (x));
+	  }
+	while (SCM_NIMP (x));
 	RETURN (t.arg1)
 #endif /* BUILTIN_RPASUBR */
       case scm_tc7_rpsubr:
 #ifdef BUILTIN_RPASUBR
 	if (SCM_FALSEP (SCM_SUBRF (proc) (t.arg1, arg2)))
 	  RETURN (SCM_BOOL_F)
-	do {
+	do
+	  {
 	    t.arg1 = EVALCAR (x, env);
 	    if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, t.arg1)))
 	      RETURN (SCM_BOOL_F)
 		arg2 = t.arg1;
 	    x = SCM_CDR (x);
-	} while (SCM_NIMP (x));
+	  }
+	while (SCM_NIMP (x));
 	RETURN (SCM_BOOL_T)
 #else /* BUILTIN_RPASUBR */
-	RETURN (SCM_APPLY (proc, t.arg1, scm_acons (arg2, scm_eval_args (x, env), SCM_EOL)));
+	RETURN (SCM_APPLY (proc, t.arg1,
+			   scm_acons (arg2, scm_eval_args (x, env), SCM_EOL)));
 #endif /* BUILTIN_RPASUBR */
       case scm_tc7_lsubr_2:
 	RETURN (SCM_SUBRF (proc) (t.arg1, arg2, scm_eval_args (x, env)));
@@ -2423,8 +2468,44 @@ evapply:
 	goto cdrxbegin;
 #endif /* DEVAL */
       case scm_tcs_cons_gloc:
-	if (SCM_I_ENTITYP (proc))
+	if (SCM_I_OPERATORP (proc))
-	  ;
+	  {
+	    SCM p = (SCM_I_ENTITYP (proc)
+		     ? SCM_ENTITY_PROC_3 (proc)
+		     : SCM_OPERATOR_PROC_3 (proc));
+	    if (SCM_NIMP (p))
+	      if (SCM_TYP7 (p) == scm_tc7_lsubr_2)
+#ifdef DEVAL
+		RETURN (SCM_SUBRF (p) (proc, t.arg1,
+				       scm_cons (arg2, SCM_CDDR (debug.info->a.args))))
+#else
+		RETURN (SCM_SUBRF (p) (proc, t.arg1,
+				       scm_cons (arg2,
+						 scm_eval_args (x, env))))
+#endif
+	      else if (SCM_CLOSUREP (p))
+		{
+#ifdef DEVAL
+		  SCM_SET_ARGSREADY (debug);
+		  debug.info->a.args = scm_cons (proc, debug.info->a.args);
+		  debug.info->a.proc = p;
+		  env = EXTEND_ENV (SCM_CAR (SCM_CODE (p)),
+				    scm_cons2 (proc, t.arg1,
+					       scm_cons (arg2,
+							 SCM_CDDDR (debug.info->a.args))),
+				    SCM_ENV (p));
+#else
+		  env = EXTEND_ENV (SCM_CAR (SCM_CODE (p)),
+				    scm_cons2 (proc, t.arg1,
+					       scm_cons (arg2,
+							 scm_eval_args (x, env))),
+				    SCM_ENV (p));
+#endif
+		  x = SCM_CODE (p);
+		  goto cdrxbegin;
+		}
+	    /* Fall through. */
+	  }
       case scm_tc7_subr_2:
       case scm_tc7_subr_1o:
       case scm_tc7_subr_2o:
@@ -2777,8 +2858,35 @@ tail:
       goto tail;
 #endif
     case scm_tcs_cons_gloc:
-      if (SCM_I_ENTITYP (proc))
+      if (SCM_I_OPERATORP (proc))
-	;
+	{
+#ifdef DEVAL
+	  args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
+#else
+	  args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
+#endif
+	  arg1 = proc;
+	  proc = (SCM_NULLP (args)
+		  ? (SCM_I_ENTITYP (proc)
+		     ? SCM_ENTITY_PROC_0 (proc)
+		     : SCM_OPERATOR_PROC_0 (proc))
+		  : SCM_NULLP (SCM_CDR (args))
+		  ? (SCM_I_ENTITYP (proc)
+		     ? SCM_ENTITY_PROC_1 (proc)
+		     : SCM_OPERATOR_PROC_1 (proc))
+		  : SCM_NULLP (SCM_CDDR (args))
+		  ? (SCM_I_ENTITYP (proc)
+		     ? SCM_ENTITY_PROC_2 (proc)
+		     : SCM_OPERATOR_PROC_2 (proc))
+		  : (SCM_I_ENTITYP (proc)
+		     ? SCM_ENTITY_PROC_3 (proc)
+		     : SCM_OPERATOR_PROC_3 (proc)));
+#ifdef DEVAL
+	  debug.vect[0].a.proc = proc;
+	  debug.vect[0].a.args = scm_cons (arg1, args);
+#endif
+	  goto tail;
+	}
     wrongnumargs:
       scm_wrong_num_args (proc);
     default:

libguile/objects.c

@@ -40,9 +40,9 @@
  * If you do not wish that, delete this exception notice.  */
 
 
-/* This file contains those minimal pieces of the Guile Object
+/* This file and objects.h contains those minimal pieces of the Guile
- * Oriented Programming System which needs to be included in
+ * Object Oriented Programming System which need to be included in
- * libguile.
+ * libguile.  See the comments in objects.h.
  */
 
 #include "_scm.h"
@@ -53,7 +53,7 @@
 
 
 SCM scm_metaclass_standard;
-SCM *scm_entity_vtable;
+SCM scm_metaclass_operator;
 
 void
 scm_init_objects ()
@@ -63,6 +63,11 @@ scm_init_objects ()
   SCM mt = scm_make_vtable_vtable (ml, SCM_INUM0,
 				   SCM_LIST3 (SCM_BOOL_F, SCM_EOL, SCM_EOL));
   
+  SCM os = scm_makfrom0str (SCM_METACLASS_OPERATOR_LAYOUT);
+  SCM ol = scm_make_struct_layout (os);
+  SCM ot = scm_make_vtable_vtable (ol, SCM_INUM0,
+				   SCM_LIST3 (SCM_BOOL_F, SCM_EOL, SCM_EOL));
+  
   SCM es = scm_makfrom0str (SCM_ENTITY_LAYOUT);
   SCM el = scm_make_struct_layout (es);
   SCM et = scm_make_struct (mt, SCM_INUM0,
@@ -70,6 +75,8 @@ scm_init_objects ()
 
   scm_sysintern ("<standard-metaclass>", mt);
   scm_metaclass_standard = mt;
+  scm_sysintern ("<operator-metaclass>", ot);
+  scm_metaclass_operator = ot;
+  SCM_SET_CLASS_FLAGS (et, SCM_CLASSF_OPERATOR | SCM_CLASSF_ENTITY);
   scm_sysintern ("<entity-class>", et);
-  scm_entity_vtable = SCM_STRUCT_DATA (et);
 }

libguile/objects.h

@@ -45,20 +45,92 @@
  * If you do not wish that, delete this exception notice.  */
 
 
+/* This file and objects.c contains those minimal pieces of the Guile
+ * Object Oriented Programming System which need to be included in
+ * libguile.
+ *
+ * {Objects and structs}
+ *
+ * Objects are currently based upon structs.  Although the struct
+ * implementation will change thoroughly in the future, objects will
+ * still be based upon structs.
+ */
+
 #include "libguile/__scm.h"
 #include "libguile/struct.h"
 
 
 
-#define SCM_I_ENTITYP(OBJ)\
+/* {Class flags}
-(SCM_STRUCT_VTABLE_DATA (OBJ) == scm_entity_vtable)
+ *
-#define SCM_ENTITY(OBJ) ((scm_entity*) SCM_STRUCT_DATA (OBJ))
+ * These are used for efficient identification of instances of a
-#define SCM_ENTITY_PROC_0(OBJ) (SCM_ENTITY (OBJ)->proc0)
+ * certain class or its subclasses when traversal of the inheritance
-#define SCM_ENTITY_PROC_1(OBJ) (SCM_ENTITY (OBJ)->proc1)
+ * graph would be too costly.
-#define SCM_ENTITY_PROC_2(OBJ) (SCM_ENTITY (OBJ)->proc2)
+ */
-#define SCM_ENTITY_PROC_3(OBJ) (SCM_ENTITY (OBJ)->proc3)
+#define SCM_CLASS_FLAGS(class) (SCM_STRUCT_DATA (class)[scm_struct_i_tag])
+#define SCM_OBJ_CLASS_FLAGS(obj)\
+(SCM_STRUCT_VTABLE_DATA (obj)[scm_struct_i_tag])
+#define SCM_SET_CLASS_FLAGS(c, f) (SCM_CLASS_FLAGS (c) |= (f))
+#define SCM_CLEAR_CLASS_FLAGS(c, f) (SCM_CLASS_FLAGS (c) &= ~(f))
+#define SCM_CLASSF_MASK (0xFF << 24)
 
-#define SCM_METACLASS_STANDARD_LAYOUT "pwpwpw"
+/* Operator classes need to be identified in the evaluator. */
+#define SCM_CLASSF_OPERATOR	(1L << 30)
+/* Entities also have SCM_CLASSF_OPERATOR set in their vtable. */
+#define SCM_CLASSF_ENTITY	(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_PROC_0(obj) (SCM_OBJ_OPERATOR_CLASS (obj)->proc0)
+#define SCM_OPERATOR_PROC_1(obj) (SCM_OBJ_OPERATOR_CLASS (obj)->proc1)
+#define SCM_OPERATOR_PROC_2(obj) (SCM_OBJ_OPERATOR_CLASS (obj)->proc2)
+#define SCM_OPERATOR_PROC_3(obj) (SCM_OBJ_OPERATOR_CLASS (obj)->proc3)
+
+#define SCM_I_ENTITYP(obj)\
+((SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_ENTITY) != 0)
+#define SCM_ENTITY(obj) ((scm_entity*) SCM_STRUCT_DATA (obj))
+#define SCM_ENTITY_PROC_0(obj) (SCM_ENTITY (obj)->proc0)
+#define SCM_ENTITY_PROC_1(obj) (SCM_ENTITY (obj)->proc1)
+#define SCM_ENTITY_PROC_2(obj) (SCM_ENTITY (obj)->proc2)
+#define SCM_ENTITY_PROC_3(obj) (SCM_ENTITY (obj)->proc3)
+
+/* {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 "pwpw"
 struct scm_metaclass_standard {
   SCM layout;
   SCM vcell;
@@ -68,6 +140,28 @@ struct scm_metaclass_standard {
   SCM direct_slots;
 };
 
+#define SCM_METACLASS_OPERATOR_LAYOUT "pwpwpwpwpwpw"
+struct scm_metaclass_operator {
+  SCM layout;
+  SCM vcell;
+  SCM vtable;
+  SCM print;
+  SCM direct_supers;
+  SCM direct_slots;
+  SCM proc0;
+  SCM proc1;
+  SCM proc2;
+  SCM proc3;
+};
+
+/* {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).
+ *
+ * An example of an entity class is the class of generic methods.
+ */
 #define SCM_ENTITY_LAYOUT "pwpwpwpw"
 typedef struct scm_entity {
   SCM proc0;
@@ -77,7 +171,7 @@ typedef struct scm_entity {
 } scm_entity;
 
 extern SCM scm_metaclass_standard;
-extern SCM *scm_entity_vtable;
+extern SCM scm_metaclass_operator;
 
 extern void scm_init_objects SCM_P ((void));