[patch] First round (request for discussion)

[Daniel Skarda]

Hello,

  few days ago I sent two emails about extending generalized set! with setters
for used defined smobs. Because I am not too familiar with guile eval/apply
functions (long function with many ifdefs scares me :) I hoped to make some
noise so someone more experienced starts coding :)
 
  But nobody replied so I started to play with guile source code - I tried to
not shoot myself in foot and finally it is working!

  I had to say that I made two big errors:

    * I modified code I do not really understand :) (so it is possible I shot
      myself in the foot but I have not noticed it yet :)

    * I introduced new (handy) features, but it is likely that some Scheme
      hackers will not like it because the features make it very easy to write
      code, which is not easily portable to other Schemes.

  So my patch modifies generalized set! macro, replaces `setter' call by
`setter-apply' and you can do this:

   (define s "Foo")
   (s 2)
     -=> #\o
   (set! (s 2) #\O)
   s
     -=> "FoO"    

   (define v (vector 1 2 3))
   (v 2)
     -=> 3
   (set! (v 2) s)
   s
     -=> #(1 2 "FoO")

   ; if you create new smob, you can use scm_set_smob_setter/getter functions:

   (define m (make-matrix-identity))
   (m 2 2)
      -=> 1
   (set! (m 2 2) 10)
   
   ... and so on...

  I know my patch has few deficiencies:

    * I think that further work is required for goops. Now you can modify
      apply-setter to work with your goops class:

        (define-class <test> ())
        (define-method (apply-setter (x <test>) . ...)
        (define t (make <test>))
        (set! (t 'foo) 'bar) 
   
      But it is not possible to write (t 'foo)

    * Because not everybody is going to love new features (strings and vectors -
      for example), I think that they should be off by default.

    * I do not know if everything is correct :)

Best regards,
Dan Skarda

Index: libguile/eval.c
===================================================================
RCS file: /cvs/guile/guile-core/libguile/eval.c,v
retrieving revision 1.226
diff -u -r1.226 eval.c
--- libguile/eval.c     2001/05/27 22:00:03     1.226
+++ libguile/eval.c     2001/05/28 00:50:07
@@ -100,6 +100,7 @@
 #include "libguile/vectors.h"
 #include "libguile/fluids.h"
 #include "libguile/values.h"
+#include "libguile/strings.h"
 
 #include "libguile/validate.h"
 #include "libguile/eval.h"
@@ -2831,6 +2832,10 @@
          if (!SCM_SMOB_APPLICABLE_P (proc))
            goto badfun;
          RETURN (SCM_SMOB_APPLY_1 (proc, t.arg1));
+       case scm_tc7_vector:
+         RETURN (scm_vector_ref (proc, t.arg1));
+       case scm_tc7_string:
+         RETURN (scm_string_ref (proc, t.arg1));
        case scm_tc7_cclo:
          arg2 = t.arg1;
          t.arg1 = proc;
@@ -3758,6 +3763,46 @@
 }
 #undef FUNC_NAME
 
+#define SCM_LIST2P(X)  (SCM_CONSP (X) && SCM_CONSP (SCM_CDR (X)) && SCM_NULLP 
(SCM_CDDR (X)))
+
+SCM_GPROC (s_apply_setter, "apply-setter", 0, 0, 1, scm_apply_setter, 
g_apply_setter);
+
+SCM
+scm_apply_setter (SCM args)
+{
+  SCM          x;
+  SCM          rest;
+
+  SCM_GASSERTn (SCM_CONSP (args), g_apply_setter, args, SCM_WNA, 
s_apply_setter);
+  x = SCM_CAR (args);
+  rest = SCM_CDR (args);
+  SCM_GASSERTn (SCM_NIMP (x), g_apply_setter, args, SCM_ARG1, s_apply_setter);
+
+  if (SCM_TYP7 (x) == scm_tc7_smob && SCM_SMOB_SETTER (x) != SCM_BOOL_F)
+    return scm_apply (SCM_SMOB_SETTER (x), args, SCM_EOL);
+  else if (SCM_VECTORP (x) && SCM_LIST2P (rest))
+    return scm_vector_set_x (x, SCM_CAR (rest), SCM_CADR (rest));
+  else if (SCM_STRINGP (x) && SCM_LIST2P (rest))
+    return scm_string_set_x (x, SCM_CAR (rest), SCM_CADR (rest));
+  else if (SCM_PROCEDURE_WITH_SETTER_P (x))
+    return scm_apply (SCM_SETTER (x), rest, SCM_EOL);
+  else
+    {
+      SCM setter;
+
+      SCM_GASSERTn (SCM_I_OPERATORP (x),
+                   g_apply_setter, args, SCM_ARG1, s_apply_setter);
+      setter = (SCM_I_ENTITYP (x)
+               ? SCM_ENTITY_SETTER (x)
+               : SCM_OPERATOR_SETTER (x));
+      if (SCM_NIMP (setter))
+       return scm_apply (setter, rest, SCM_EOL);
+      /* fall through */
+    }
+
+  SCM_WTA_DISPATCH_n (g_apply_setter, args, SCM_ARG1, s_apply_setter);
+  return SCM_BOOL_F; /* not reached */
+}
 
 SCM 
 scm_closure (SCM code, SCM env)
Index: libguile/eval.h
===================================================================
RCS file: /cvs/guile/guile-core/libguile/eval.h,v
retrieving revision 1.57
diff -u -r1.57 eval.h
--- libguile/eval.h     2001/05/27 22:00:03     1.57
+++ libguile/eval.h     2001/05/28 00:50:09
@@ -232,6 +232,7 @@
 extern SCM scm_ceval (SCM x, SCM env);
 extern SCM scm_deval (SCM x, SCM env);
 extern SCM scm_nconc2last (SCM lst);
+extern SCM scm_apply_setter (SCM args);
 extern SCM scm_apply (SCM proc, SCM arg1, SCM args);
 extern SCM scm_dapply (SCM proc, SCM arg1, SCM args);
 extern SCM scm_m_expand_body (SCM xorig, SCM env);
Index: libguile/evalext.c
===================================================================
RCS file: /cvs/guile/guile-core/libguile/evalext.c,v
retrieving revision 1.33
diff -u -r1.33 evalext.c
--- libguile/evalext.c  2001/05/15 14:57:21     1.33
+++ libguile/evalext.c  2001/05/28 00:50:10
@@ -53,7 +53,7 @@
 #include "libguile/validate.h"
 #include "libguile/evalext.h"
 
-SCM_SYMBOL (scm_sym_setter, "setter");
+SCM_SYMBOL (scm_sym_apply_setter, "apply-setter");
 
 SCM 
 scm_m_generalized_set_x (SCM xorig, SCM env)
@@ -63,8 +63,8 @@
   if (SCM_SYMBOLP (SCM_CAR (x)))
     return scm_cons (SCM_IM_SET_X, x);
   else if (SCM_CONSP (SCM_CAR (x)))
-    return scm_cons (SCM_LIST2 (scm_sym_setter, SCM_CAAR (x)),
-                    scm_append (SCM_LIST2 (SCM_CDAR (x), SCM_CDR (x))));
+    return scm_cons2 (scm_sym_apply_setter, SCM_CAAR (x),
+                     scm_append (SCM_LIST2 (SCM_CDAR (x), SCM_CDR (x)))) ;
   else
     scm_misc_error (scm_s_set_x, scm_s_variable, SCM_EOL);
 }
Index: libguile/procs.c
===================================================================
RCS file: /cvs/guile/guile-core/libguile/procs.c,v
retrieving revision 1.59
diff -u -r1.59 procs.c
--- libguile/procs.c    2001/05/26 20:51:21     1.59
+++ libguile/procs.c    2001/05/28 00:50:14
@@ -54,6 +54,7 @@
 
 #include "libguile/validate.h"
 #include "libguile/procs.h"
+#include "libguile/eval.h"
 
 
 
@@ -369,6 +370,8 @@
   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_TYP7 (proc) == scm_tc7_smob && SCM_SMOB_SETTER (proc) != 
SCM_BOOL_F)
+    return SCM_SMOB_SETTER (proc);
   else if (SCM_STRUCTP (proc))
     {
       SCM setter;
Index: libguile/smob.c
===================================================================
RCS file: /cvs/guile/guile-core/libguile/smob.c,v
retrieving revision 1.44
diff -u -r1.44 smob.c
--- libguile/smob.c     2001/05/26 20:51:21     1.44
+++ libguile/smob.c     2001/05/28 00:50:19
@@ -57,6 +57,7 @@
 #endif
 
 #include "libguile/smob.h"
+#include "strings.h"
 
 
 
@@ -450,6 +451,29 @@
   scm_smobs[SCM_TC2SMOBNUM (tc)].gsubr_type = type;
 }
 
+void
+scm_set_smob_setter (scm_bits_t tc, SCM (*setter) (),
+                    unsigned int req, unsigned int opt, unsigned int rst)
+{
+  SCM   tmp;
+  char*  subr_name;
+  int   length;
+  int   smobnum;
+  
+  smobnum = SCM_TC2SMOBNUM (tc);
+  length =  SCM_SMOBNAME (smobnum) ?  strlen (SCM_SMOBNAME (smobnum)) : 0;
+  tmp = scm_allocate_string (length + 1 + 7);
+  subr_name = SCM_STRING_CHARS (tmp);
+
+  subr_name [0] = '%';
+  if (length)
+    memcpy (subr_name + 1, SCM_SMOBNAME (smobnum), length * sizeof (char));
+  memcpy (subr_name + 1 + length, "-setter", 7 * sizeof (char));
+
+  scm_smobs [smobnum].setter = scm_c_make_gsubr (subr_name, req,  opt, rst, 
setter);
+  scm_permanent_object (scm_smobs [smobnum].setter);
+}
+
 SCM
 scm_make_smob (scm_bits_t tc)
 {
@@ -544,6 +568,7 @@
       scm_smobs[i].apply_2    = 0;
       scm_smobs[i].apply_3    = 0;
       scm_smobs[i].gsubr_type = 0;
+      scm_smobs[i].setter     = SCM_BOOL_F;
     }
 
   /* WARNING: These scm_make_smob_type calls must be done in this order */
Index: libguile/smob.h
===================================================================
RCS file: /cvs/guile/guile-core/libguile/smob.h,v
retrieving revision 1.41
diff -u -r1.41 smob.h
--- libguile/smob.h     2001/05/26 20:51:21     1.41
+++ libguile/smob.h     2001/05/28 00:50:20
@@ -62,6 +62,7 @@
   SCM (*apply_1) (SCM, SCM);
   SCM (*apply_2) (SCM, SCM, SCM);
   SCM (*apply_3) (SCM, SCM, SCM, SCM);
+  SCM setter;
   int gsubr_type; /* Used in procprop.c */
 } scm_smob_descriptor;
 
@@ -123,6 +124,7 @@
 #define SCM_SMOB_APPLY_1(x,a1)         (SCM_SMOB_DESCRIPTOR (x).apply_1 (x, 
(a1)))
 #define SCM_SMOB_APPLY_2(x,a1,a2)      (SCM_SMOB_DESCRIPTOR (x).apply_2 (x, 
(a1), (a2)))
 #define SCM_SMOB_APPLY_3(x,a1,a2,rst)  (SCM_SMOB_DESCRIPTOR (x).apply_3 (x, 
(a1), (a2), (rst)))
+#define SCM_SMOB_SETTER(x)             (SCM_SMOB_DESCRIPTOR (x).setter)
 
 extern long scm_numsmob;
 extern scm_smob_descriptor scm_smobs[];
@@ -155,6 +157,11 @@
                                unsigned int req,
                                unsigned int opt,
                                unsigned int rst);
+extern void scm_set_smob_setter (scm_bits_t tc,
+                                SCM (*setter) (),
+                                unsigned int req,
+                                unsigned int opt,
+                                unsigned int rst);
 
 /* Function for creating smobs */