[Guile-commits] GNU Guile branch, master, updated. release_1-9-5-106-gea68d34

[Andy Wingo]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=ea68d342f18c3d2082ce6a4fb39bd38b6af932cc

The branch, master has been updated
       via  ea68d342f18c3d2082ce6a4fb39bd38b6af932cc (commit)
      from  ce65df9f09577e4f566b467ee8647617204b9b40 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit ea68d342f18c3d2082ce6a4fb39bd38b6af932cc
Author: Andy Wingo <address@hidden>
Date:   Mon Dec 7 09:56:58 2009 +0100

    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.

-----------------------------------------------------------------------

Summary of changes:
 libguile/debug.c       |    3 --
 libguile/deprecated.h  |    8 ++++++
 libguile/evalext.c     |    1 -
 libguile/gc.c          |    2 -
 libguile/goops.c       |    6 +---
 libguile/goops.h       |    1 -
 libguile/print.c       |   12 ---------
 libguile/procprop.c    |    3 --
 libguile/procs.c       |   65 +++++++++++++++++++++--------------------------
 libguile/procs.h       |   53 ---------------------------------------
 libguile/struct.h      |    2 +-
 libguile/tags.h        |    2 +-
 libguile/vm-i-system.c |   16 ------------
 13 files changed, 40 insertions(+), 134 deletions(-)

diff --git a/libguile/debug.c b/libguile/debug.c
index b220efd..0f83ea0 100644
--- a/libguile/debug.c
+++ b/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;
       }
diff --git a/libguile/deprecated.h b/libguile/deprecated.h
index 3643a80..be56d37 100644
--- a/libguile/deprecated.h
+++ b/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
diff --git a/libguile/evalext.c b/libguile/evalext.c
index 9af8383..84218b3 100644
--- a/libguile/evalext.c
+++ b/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:
diff --git a/libguile/gc.c b/libguile/gc.c
index 4bd1d5d..38051e1 100644
--- a/libguile/gc.c
+++ b/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:
diff --git a/libguile/goops.c b/libguile/goops.c
index f3a28d9..1472e47 100644
--- a/libguile/goops.c
+++ b/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>",
diff --git a/libguile/goops.h b/libguile/goops.h
index 48b94a1..b775ae3 100644
--- a/libguile/goops.h
+++ b/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;
diff --git a/libguile/print.c b/libguile/print.c
index 8d2db13..efb3081 100644
--- a/libguile/print.c
+++ b/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);
diff --git a/libguile/procprop.c b/libguile/procprop.c
index c452c28..7cfd2e6 100644
--- a/libguile/procprop.c
+++ b/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;
diff --git a/libguile/procs.c b/libguile/procs.c
index 71d50bd..f620063 100644
--- a/libguile/procs.c
+++ b/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;
-      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);
+  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))
+    /* 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"
 }
 
diff --git a/libguile/procs.h b/libguile/procs.h
index cb19e4c..a832cd0 100644
--- a/libguile/procs.h
+++ b/libguile/procs.h
@@ -47,59 +47,6 @@
 
 
 
-/* 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)());
 SCM_API SCM scm_c_make_subr_with_generic (const char *name, long type,
diff --git a/libguile/struct.h b/libguile/struct.h
index 1e80fc1..5955e59 100644
--- a/libguile/struct.h
+++ b/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. */
diff --git a/libguile/tags.h b/libguile/tags.h
index 5020775..e1e0913 100644
--- a/libguile/tags.h
+++ b/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
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 6d32a6c..d7523cc 100644
--- a/libguile/vm-i-system.c
+++ b/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
    */


hooks/post-receive
-- 
GNU Guile