*** empty log message ***

[bpt/guile.git] / libguile / procprop.c

diff --git a/libguile/procprop.c b/libguile/procprop.c
index d436f7f..d3ff6da 100644 (file)
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -1,4 +1,4 @@
-/*     Copyright (C) 1995,1996 Free Software Foundation, Inc.
+/*     Copyright (C) 1995,1996,1998 Free Software Foundation, Inc.
  * 
  * This program is free software; you can redistribute it and/or modify
  * it under the terms of the GNU General Public License as published by
@@ -42,12 +42,104 @@
 
 #include <stdio.h>
 #include "_scm.h"
+
 #include "alist.h"
 #include "eval.h"
+#include "procs.h"
+#include "gsubr.h"
+#include "objects.h"
 
 #include "procprop.h"
 \f
 
+SCM_GLOBAL_SYMBOL (scm_sym_system_procedure, "system-procedure");
+SCM_GLOBAL_SYMBOL (scm_sym_arity, "arity");
+
+SCM
+scm_i_procedure_arity (SCM proc)
+{
+  int a = 0, o = 0, r = 0;
+  if (SCM_IMP (proc))
+    return SCM_BOOL_F;
+ loop:
+  switch (SCM_TYP7 (proc))
+    {
+    case scm_tc7_subr_1o:
+      o = 1;
+    case scm_tc7_subr_0:
+      break;
+    case scm_tc7_subr_2o:
+      o = 1;
+    case scm_tc7_subr_1:
+    case scm_tc7_cxr:
+    case scm_tc7_contin:
+      a += 1;
+      break;
+    case scm_tc7_subr_2:
+      a += 2;
+      break;
+    case scm_tc7_subr_3:
+      a += 3;
+      break;
+    case scm_tc7_asubr:
+    case scm_tc7_rpsubr:
+    case scm_tc7_lsubr:
+      r = 1;
+      break;
+    case scm_tc7_lsubr_2:
+      a += 2;
+      r = 1;
+      break;
+#ifdef CCLO
+    case scm_tc7_cclo:
+      if (SCM_CCLO_SUBR (proc) == scm_f_gsubr_apply)
+       {
+         int type = SCM_INUM (SCM_GSUBR_TYPE (proc));
+         a += SCM_GSUBR_REQ (type);
+         o = SCM_GSUBR_OPT (type);
+         r = SCM_GSUBR_REST (type);
+         break;
+       }
+      proc = SCM_CCLO_SUBR (proc);
+      a -= 1;
+      goto loop;
+#endif
+    case scm_tc7_pws:
+      proc = SCM_PROCEDURE (proc);
+      goto loop;
+    case scm_tcs_closures:
+      proc = SCM_CAR (SCM_CODE (proc));
+      if (SCM_IMP (proc))
+       break;
+      while (SCM_NIMP (proc) && SCM_CONSP (proc))
+       {
+         ++a;
+         proc = SCM_CDR (proc);
+       }
+      if (SCM_NIMP (proc))
+       r = 1;
+      break;
+    case scm_tcs_cons_gloc:
+      if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
+       {
+         r = 1;
+         break;
+       }
+      else if (!SCM_I_OPERATORP (proc))
+       return SCM_BOOL_F;
+      proc = (SCM_I_ENTITYP (proc)
+             ? SCM_ENTITY_PROCEDURE (proc)
+             : SCM_OPERATOR_PROCEDURE (proc));
+      a -= 1;
+      goto loop;
+    default:
+      return SCM_BOOL_F;
+    }
+  return SCM_LIST3 (SCM_MAKINUM (a),
+                   SCM_MAKINUM (o),
+                   r ? SCM_BOOL_T : SCM_BOOL_F);
+}
+
 static SCM
 scm_stand_in_scm_proc(proc)
      SCM proc;
@@ -74,9 +166,10 @@ scm_procedure_properties (proc)
 {
   SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (proc)),
              proc, SCM_ARG1, s_procedure_properties);
-  if (!(SCM_NIMP (proc) && SCM_CLOSUREP (proc)))
-    proc = scm_stand_in_scm_proc(proc);
-  return SCM_PROCPROPS (proc);
+  return scm_acons (scm_sym_arity, scm_i_procedure_arity (proc),
+                   SCM_PROCPROPS (SCM_NIMP (proc) && SCM_CLOSUREP (proc)
+                                  ? proc
+                                  : scm_stand_in_scm_proc (proc)));
 }
 
 SCM_PROC(s_set_procedure_properties_x, "set-procedure-properties!", 2, 0, 0, scm_set_procedure_properties_x);
@@ -101,11 +194,19 @@ scm_procedure_property (p, k)
      SCM k;
 {
   SCM assoc;
-  if (!(SCM_NIMP (p) && SCM_CLOSUREP (p)))
-    p = scm_stand_in_scm_proc(p);
+  if (k == scm_sym_arity)
+    {
+      SCM arity;
+      SCM_ASSERT (SCM_NFALSEP (arity = scm_i_procedure_arity (p)),
+                 p, SCM_ARG1, s_procedure_property);
+      return arity;
+    }
   SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (p)),
              p, SCM_ARG1, s_procedure_property);
-  assoc = scm_sloppy_assq (k, SCM_PROCPROPS (p));
+  assoc = scm_sloppy_assq (k,
+                          SCM_PROCPROPS (SCM_NIMP (p) && SCM_CLOSUREP (p)
+                                         ? p
+                                         : scm_stand_in_scm_proc (p)));
   return (SCM_NIMP (assoc) ? SCM_CDR (assoc) : SCM_BOOL_F);
 }
 
@@ -121,6 +222,10 @@ scm_set_procedure_property_x (p, k, v)
   if (!(SCM_NIMP (p) && SCM_CLOSUREP (p)))
     p = scm_stand_in_scm_proc(p);
   SCM_ASSERT (SCM_NIMP (p) && SCM_CLOSUREP (p), p, SCM_ARG1, s_set_procedure_property_x);
+  if (k == scm_sym_arity)
+    scm_misc_error (s_set_procedure_property_x,
+                   "arity is a read-only property",
+                   SCM_EOL);
   assoc = scm_sloppy_assq (k, SCM_PROCPROPS (p));
   if (SCM_NIMP (assoc))
     SCM_SETCDR (assoc, v);