guile/guile-core/libguile objects.h objects.c

[Marius Vollmer]

CVSROOT:        /cvs
Module name:    guile
Changes by:     Marius Vollmer <address@hidden> 01/05/05 12:05:47

Modified files:
        guile-core/libguile: objects.h objects.c 

Log message:
        (scm_valid_object_procedure_p): New.
        (scm_set_object_procedure_x): Use it to check argument.  Fix
        docstring.

CVSWeb URLs:
http://savannah.gnu.org/cgi-bin/viewcvs/guile/guile-core/libguile/objects.h.diff?cvsroot=OldCVS&tr1=1.30&tr2=1.31&r1=text&r2=text
http://savannah.gnu.org/cgi-bin/viewcvs/guile/guile-core/libguile/objects.c.diff?cvsroot=OldCVS&tr1=1.55&tr2=1.56&r1=text&r2=text

Patches:
Index: guile/guile-core/libguile/objects.c
diff -u guile/guile-core/libguile/objects.c:1.55 
guile/guile-core/libguile/objects.c:1.56
--- guile/guile-core/libguile/objects.c:1.55    Fri Feb 16 07:02:35 2001
+++ guile/guile-core/libguile/objects.c Sat May  5 12:05:47 2001
@@ -374,9 +374,35 @@
 }
 #undef FUNC_NAME
 
+/* XXX - What code requires the object procedure to be only of certain
+         types? */
+
+SCM_DEFINE (scm_valid_object_procedure_p, "valid-object-procedure?", 1, 0, 0,
+           (SCM proc),
+           "Return @code{#t} iff @var{proc} is a procedure that can be used "
+           "with @code{set-object-procedure}.  It is always valid to use "
+            "a closure constructed by @code{lambda}.")
+#define FUNC_NAME s_scm_valid_object_procedure_p
+{
+  if (SCM_IMP (proc))
+    return SCM_BOOL_F;
+  switch (SCM_TYP7 (proc))
+    {
+    default:
+      return SCM_BOOL_F;
+    case scm_tcs_closures:
+    case scm_tc7_subr_1:
+    case scm_tc7_subr_2:
+    case scm_tc7_subr_3:
+    case scm_tc7_lsubr_2:
+      return SCM_BOOL_T;
+    }
+}
+#undef FUNC_NAME
+
 SCM_DEFINE (scm_set_object_procedure_x, "set-object-procedure!", 2, 0, 0, 
             (SCM obj, SCM proc),
-           "Return the object procedure of @var{obj} to @var{proc}.\n"
+           "Set the object procedure of @var{obj} to @var{proc}.\n"
            "@var{obj} must be either an entity or an operator.")
 #define FUNC_NAME s_scm_set_object_procedure_x
 {
@@ -388,7 +414,7 @@
              obj,
              SCM_ARG1,
               FUNC_NAME);
-  SCM_VALIDATE_PROC (2,proc);
+  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
Index: guile/guile-core/libguile/objects.h
diff -u guile/guile-core/libguile/objects.h:1.30 
guile/guile-core/libguile/objects.h:1.31
--- guile/guile-core/libguile/objects.h:1.30    Thu Jan 11 13:03:18 2001
+++ guile/guile-core/libguile/objects.h Sat May  5 12:05:47 2001
@@ -230,7 +230,8 @@
 extern SCM scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3);
 extern SCM scm_entity_p (SCM obj);
 extern SCM scm_operator_p (SCM obj);
-extern SCM scm_set_object_procedure_x (SCM obj, SCM procs);
+extern SCM scm_valid_object_procedure_p (SCM proc);
+extern SCM scm_set_object_procedure_x (SCM obj, SCM proc);
 #ifdef GUILE_DEBUG
 extern SCM scm_object_procedure (SCM obj);
 #endif