procedures-with-setters implemented in terms of structs

* libguile/tags.h (scm_tc7_pws): No more.

* libguile/procs.c (scm_procedure_with_setter_p)
  (scm_make_procedure_with_setter, scm_procedure, scm_setter): Implement
  procedures-with-setters in terms of applicable structs with setters.

* libguile/procs.h: Remove a big, outdated comment, and the deprecated
  macros.

* libguile/deprecated.h (SCM_PROCEDURE_WITH_SETTER_P, SCM_PROCEDURE)
  (SCM_SETTER): Deprecate these. SCM_PROCEDURE and SCM_SETTER are bad
  names.

* libguile/evalext.c (scm_self_evaluating_p):
* libguile/gc.c (scm_i_tag_name):
* libguile/goops.c: (scm_class_of):
* libguile/print.c (iprin1):
* libguile/procprop.c (scm_i_procedure_arity):
* libguile/procs.c (scm_procedure_p):
* libguile/debug.c (scm_procedure_source): Remove a tc7_pws case.

* libguile/goops.h:
* libguile/goops.c (scm_class_procedure_with_setter): Remove this class;
  it is subsumed by applicable_struct_with_setter.

* libguile/struct.h: Update a comment.

* libguile/vm-i-system.c (call, goto/args, mv-call): Remove PWS cases.

libguile/debug.c

@@ -172,9 +172,6 @@ SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
           break;
         proc = SCM_STRUCT_PROCEDURE (proc);
         continue;
-      case scm_tc7_pws:
-        proc = SCM_PROCEDURE (proc);
-        continue;
       default:
         break;
       }

libguile/deprecated.h

@@ -600,6 +600,14 @@ SCM_DEPRECATED scm_t_trampoline_1 scm_trampoline_1 (SCM proc);
 SCM_DEPRECATED scm_t_trampoline_2 scm_trampoline_2 (SCM proc);
 
 
+
+/* Deprecated 2009-12-06, use the procedures instead */
+#define SCM_PROCEDURE_WITH_SETTER_P(obj) (scm_is_true (scm_procedure_with_setter_p (obj)))
+#define SCM_PROCEDURE(obj) SCM_STRUCT_PROCEDURE (obj, 0)
+#define SCM_SETTER(obj) SCM_STRUCT_SETTER (obj, 1)
+
+
+
 void scm_i_init_deprecated (void);
 
 #endif

libguile/evalext.c

@@ -83,7 +83,6 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0, 0,
 	case scm_tc7_number:
 	case scm_tc7_string:
 	case scm_tc7_smob:
-	case scm_tc7_pws:
 	case scm_tc7_program:
 	case scm_tc7_bytevector:
 	case scm_tc7_gsubr:

libguile/gc.c

@@ -749,8 +749,6 @@ scm_i_tag_name (scm_t_bits tag)
       return "cons (immediate car)";
     case scm_tcs_cons_nimcar:
       return "cons (non-immediate car)";
-    case scm_tc7_pws:
-      return "pws";
     case scm_tc7_hashtable:
       return "hashtable";
     case scm_tc7_fluid:

libguile/goops.c

@@ -132,7 +132,7 @@ static scm_t_rstate *goops_rstate;
 /* These variables are filled in by the object system when loaded. */
 SCM scm_class_boolean, scm_class_char, scm_class_pair;
 SCM scm_class_procedure, scm_class_string, scm_class_symbol;
-SCM scm_class_procedure_with_setter, scm_class_primitive_generic;
+SCM scm_class_primitive_generic;
 SCM scm_class_vector, scm_class_null;
 SCM scm_class_integer, scm_class_real, scm_class_complex, scm_class_fraction;
 SCM scm_class_unknown;
@@ -240,8 +240,6 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
 	    return scm_class_procedure;
 	case scm_tc7_program:
 	  return scm_class_procedure;
-	case scm_tc7_pws:
-	  return scm_class_procedure_with_setter;
 
 	case scm_tc7_smob:
 	  {
@@ -2419,8 +2417,6 @@ create_standard_classes (void)
 	       scm_class_class, scm_class_top,		   SCM_EOL);
   make_stdcls (&scm_class_procedure,	   "<procedure>",
 	       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>",
 	       scm_class_procedure_class, scm_class_procedure, SCM_EOL);
   make_stdcls (&scm_class_port,		   "<port>",

libguile/goops.h

@@ -177,7 +177,6 @@ SCM_API SCM scm_class_pair;
 SCM_API SCM scm_class_procedure;
 SCM_API SCM scm_class_string;
 SCM_API SCM scm_class_symbol;
-SCM_API SCM scm_class_procedure_with_setter;
 SCM_API SCM scm_class_primitive_generic;
 SCM_API SCM scm_class_vector;
 SCM_API SCM scm_class_null;

libguile/print.c

@@ -785,18 +785,6 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
 	    scm_putc ('>', port);
 	    break;
 	  }
-	case scm_tc7_pws:
-	  scm_puts ("#<procedure-with-setter", port);
-	  {
-	    SCM name = scm_procedure_name (exp);
-	    if (scm_is_true (name))
-	      {
-		scm_putc (' ', port);
-		scm_display (name, port);
-	      }
-	  }
-	  scm_putc ('>', port);
-	  break;
 	case scm_tc7_port:
 	  {
 	    register long i = SCM_PTOBNUM (exp);

libguile/procprop.c

@@ -73,9 +73,6 @@ scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest)
 	*rest = SCM_GSUBR_REST (type);
         return 1;
       }
-    case scm_tc7_pws:
-      proc = SCM_PROCEDURE (proc);
-      goto loop;
     case scm_tcs_struct:
       if (!SCM_STRUCT_APPLICABLE_P (proc))
         return 0;

libguile/procs.c

@@ -101,7 +101,6 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0,
               || SCM_STRUCT_APPLICABLE_P (obj)))
 	  break;
       case scm_tc7_gsubr:
-      case scm_tc7_pws:
       case scm_tc7_program:
 	return SCM_BOOL_T;
       case scm_tc7_smob:
@@ -161,13 +160,16 @@ SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0,
 /* Procedure-with-setter
  */
 
+static SCM pws_vtable;
+
+
 SCM_DEFINE (scm_procedure_with_setter_p, "procedure-with-setter?", 1, 0, 0, 
             (SCM obj),
 	    "Return @code{#t} if @var{obj} is a procedure with an\n"
 	    "associated setter procedure.")
 #define FUNC_NAME s_scm_procedure_with_setter_p
 {
-  return scm_from_bool(SCM_PROCEDURE_WITH_SETTER_P (obj));
+  return scm_from_bool (SCM_STRUCTP (obj) && SCM_STRUCT_SETTER_P (obj));
 }
 #undef FUNC_NAME
 
@@ -180,9 +182,9 @@ SCM_DEFINE (scm_make_procedure_with_setter, "make-procedure-with-setter", 2, 0,
   SCM name, ret;
   SCM_VALIDATE_PROC (1, procedure);
   SCM_VALIDATE_PROC (2, setter);
-  ret = scm_double_cell (scm_tc7_pws,
-                         SCM_UNPACK (procedure),
-                         SCM_UNPACK (setter), 0);
+  ret = scm_make_struct (pws_vtable, SCM_INUM0,
+                         scm_list_2 (procedure, setter));
+
   /* don't use procedure_name, because don't care enough to do a reverse
      lookup */
   switch (SCM_TYP7 (procedure)) {
@@ -201,51 +203,42 @@ SCM_DEFINE (scm_make_procedure_with_setter, "make-procedure-with-setter", 2, 0,
 
 SCM_DEFINE (scm_procedure, "procedure", 1, 0, 0, 
             (SCM proc),
-	    "Return the procedure of @var{proc}, which must be either a\n"
-	    "procedure with setter, or an applicable struct.")
+	    "Return the procedure of @var{proc}, which must be an\n"
+	    "applicable struct.")
 #define FUNC_NAME s_scm_procedure
 {
   SCM_VALIDATE_NIM (1, proc);
-  if (SCM_PROCEDURE_WITH_SETTER_P (proc))
-    return SCM_PROCEDURE (proc);
-  else if (SCM_STRUCTP (proc))
-    {
-      SCM_ASSERT (SCM_PUREGENERICP (proc) || SCM_STRUCT_APPLICABLE_P (proc),
-                  proc, SCM_ARG1, FUNC_NAME);
-      return proc;
-    }
-  SCM_WRONG_TYPE_ARG (1, proc);
-  return SCM_BOOL_F; /* not reached */
+  SCM_ASSERT (SCM_STRUCT_APPLICABLE_P (proc), proc, SCM_ARG1, FUNC_NAME);
+  return SCM_STRUCT_PROCEDURE (proc);
 }
 #undef FUNC_NAME
 
-SCM_GPROC (s_setter, "setter", 1, 0, 0, scm_setter, g_setter);
-
-SCM
-scm_setter (SCM proc)
+SCM_PRIMITIVE_GENERIC (scm_setter, "setter", 1, 0, 0,
+                       (SCM proc),
+                       "Return the setter of @var{proc}, which must be an\n"
+                       "applicable struct with a setter.")
+#define FUNC_NAME s_scm_setter
 {
-  SCM_GASSERT1 (SCM_NIMP (proc), g_setter, proc, SCM_ARG1, s_setter);
-  if (SCM_PROCEDURE_WITH_SETTER_P (proc))
-    return SCM_SETTER (proc);
-  else if (SCM_STRUCTP (proc))
-    {
-      SCM setter = SCM_BOOL_F;
+  SCM_GASSERT1 (SCM_STRUCTP (proc), g_scm_setter, proc, SCM_ARG1, FUNC_NAME);
+  if (SCM_STRUCT_SETTER_P (proc))
+    return SCM_STRUCT_SETTER (proc);
   if (SCM_PUREGENERICP (proc))
-        setter = SCM_GENERIC_SETTER (proc);
-      else if (SCM_STRUCT_SETTER_P (proc))
-        setter = SCM_STRUCT_SETTER (proc);
-      if (SCM_NIMP (setter))
-	return setter;
-      /* fall through */
-    }
-  SCM_WTA_DISPATCH_1 (g_setter, proc, SCM_ARG1, s_setter);
+    /* FIXME: might not be an accessor */
+    return SCM_GENERIC_SETTER (proc);
+  SCM_WTA_DISPATCH_1 (g_scm_setter, proc, SCM_ARG1, FUNC_NAME);
   return SCM_BOOL_F; /* not reached */
 }
+#undef FUNC_NAME
 
 
 void
 scm_init_procs ()
 {
+  SCM setter_vtable_vtable =
+    scm_variable_ref (scm_c_lookup ("<applicable-struct-with-setter-vtable>"));
+  pws_vtable = scm_make_struct (setter_vtable_vtable, SCM_INUM0,
+                                scm_list_1 (scm_from_locale_symbol ("pwpw")));
+
 #include "libguile/procs.x"
 }
 

libguile/procs.h

@@ -46,59 +46,6 @@
   (scm_tc7_gsubr | (SCM_GSUBR_MAKTYPE (req, opt, rest) << 8U))
 
 
-
-/* Procedure-with-setter
-
-   Four representations for procedure-with-setters were
-   considered before selecting this one:
-
-   1. A closure where the CODE and ENV slots are used to represent
-   the getter and a new SETTER slot is used for the setter.  The
-   original getter is stored as a `getter' procedure property.  For
-   closure getters, the CODE and ENV slots contains a copy of the
-   getter's CODE and ENV slots.  For subr getters, the CODE contains
-   a call to the subr.
-
-   2. A compiled closure with a call to the getter in the cclo
-   procedure.  The getter and setter are stored in slots 1 and 2.
-
-   3. An entity (i.e. a struct with an associated procedure) with a
-   call to the getter in the entity procedure and the setter stored
-   in slot 0.  The original getter is stored in slot 1.
-
-   4. A new primitive procedure type supported in the evaluator.  The
-   getter and setter are stored in a GETTER and SETTER slot.  A call
-   to this procedure type results in a retrieval of the getter and a
-   jump back to the correct eval dispatcher.
-
-   Representation 4 was selected because of efficiency and
-   simplicity.
-
-   Rep 1 has the advantage that there is zero penalty for closure
-   getters, but primitive getters will get considerable overhead
-   because the procedure-with-getter will be a closure which calls
-   the getter.
-
-   Rep 3 has the advantage that a GOOPS accessor can be a subclass of
-   <procedure-with-setter>, but together with rep 2 it suffers from a
-   three level dispatch for non-GOOPS getters:
-
-     cclo/struct --> dispatch proc --> getter
-
-   This is because the dispatch procedure must take an extra initial
-   argument (cclo for rep 2, struct for rep 3).
-
-   Rep 4 has the single disadvantage that it uses up one tc7 type
-   code, but the plan for uniform vectors will very likely free tc7
-   codes, so this is probably no big problem.  Also note that the
-   GETTER and SETTER slots can live directly on the heap, using the
-   new four-word cells.  */
-
-#define SCM_PROCEDURE_WITH_SETTER_P(obj) (!SCM_IMP(obj) && (SCM_TYP7 (obj) == scm_tc7_pws))
-#define SCM_PROCEDURE(obj) SCM_CELL_OBJECT_1 (obj)
-#define SCM_SETTER(obj) SCM_CELL_OBJECT_2 (obj)
-
-
 
 
 SCM_API SCM scm_c_make_subr (const char *name, long type, SCM (*fcn)());

libguile/struct.h

@@ -35,7 +35,7 @@
 
    I would like to write this all up here, but for now:
 
-   http://wingolog.org/pub/goops-class-redefinition-3.png
+     http://wingolog.org/archives/2009/11/09/class-redefinition-in-guile
  */
 
 /* All vtables have the following fields. */

libguile/tags.h

@@ -411,7 +411,7 @@ typedef scm_t_uintptr scm_t_bits;
 #define scm_tc7_stringbuf       39
 #define scm_tc7_bytevector	77
 
-#define scm_tc7_pws		31
+#define scm_tc7_unused_1	31
 #define scm_tc7_hashtable	29
 #define scm_tc7_fluid		37
 #define scm_tc7_dynamic_state	45

libguile/vm-i-system.c

@@ -766,11 +766,6 @@ VM_DEFINE_INSTRUCTION (53, call, "call", 1, -1, 1)
       sp[-nargs] = SCM_STRUCT_PROCEDURE (x);
       goto vm_call;
     }
-  else if (SCM_PROCEDURE_WITH_SETTER_P (x))
-    {
-      sp[-nargs] = SCM_PROCEDURE (x);
-      goto vm_call;
-    }
   /*
    * Other interpreted or compiled call
    */
@@ -850,12 +845,6 @@ VM_DEFINE_INSTRUCTION (54, goto_args, "goto/args", 1, -1, 1)
       sp[-nargs] = SCM_STRUCT_PROCEDURE (x);
       goto vm_goto_args;
     }
-  else if (SCM_PROCEDURE_WITH_SETTER_P (x))
-    {
-      sp[-nargs] = SCM_PROCEDURE (x);
-      goto vm_goto_args;
-    }
-
   /*
    * Other interpreted or compiled call
    */
@@ -943,11 +932,6 @@ VM_DEFINE_INSTRUCTION (57, mv_call, "mv-call", 4, -1, 1)
       sp[-nargs] = SCM_STRUCT_PROCEDURE (x);
       goto vm_mv_call;
     }
-  else if (SCM_PROCEDURE_WITH_SETTER_P (x))
-    {
-      sp[-nargs] = SCM_PROCEDURE (x);
-      goto vm_mv_call;
-    }
   /*
    * Other interpreted or compiled call
    */