Merge commit 'e20d7001c3f7150400169fecb0bf0eefdf122fe2' into vm-check

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

diff --git a/libguile/procs.c b/libguile/procs.c
index e36e7ca..8230e07 100644 (file)
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -31,6 +31,9 @@
 
 #include "libguile/validate.h"
 #include "libguile/procs.h"
+#include "libguile/procprop.h"
+#include "libguile/objcodes.h"
+#include "libguile/programs.h"
 \f
 
 
@@ -38,19 +41,13 @@
  */
 
 
-/* libguile contained approx. 700 primitive procedures on 24 Aug 1999. */
-
-/* Increased to 800 on 2001-05-07 -- Guile now has 779 primitives on
-   startup, 786 with guile-readline.  'martin */
-
 SCM
 scm_c_make_subr (const char *name, long type, SCM (*fcn) ())
 {
   register SCM z;
   SCM *meta_info;
 
-  meta_info = scm_gc_malloc (2 * sizeof (* meta_info),
-                            "subr meta-info");
+  meta_info = scm_gc_malloc (2 * sizeof (*meta_info), "subr meta-info");
   meta_info[0] = scm_from_locale_symbol (name);
   meta_info[1] = SCM_EOL;  /* properties */
 
@@ -96,39 +93,6 @@ scm_c_define_subr_with_generic (const char *name,
 }
 
 
-#ifdef CCLO
-SCM 
-scm_makcclo (SCM proc, size_t len)
-{
-  scm_t_bits *base = scm_gc_malloc (len * sizeof (scm_t_bits),
-                                   "compiled closure");
-  unsigned long i;
-  SCM s;
-
-  for (i = 0; i < len; ++i)
-    base [i] = SCM_UNPACK (SCM_UNSPECIFIED);
-
-  s = scm_cell (SCM_MAKE_CCLO_TAG (len), (scm_t_bits) base);
-  SCM_SET_CCLO_SUBR (s, proc);
-  return s;
-}
-
-/* Undocumented debugging procedure */
-#ifdef GUILE_DEBUG
-SCM_DEFINE (scm_make_cclo, "make-cclo", 2, 0, 0,
-            (SCM proc, SCM len),
-           "Create a compiled closure for @var{proc}, which reserves\n"
-           "@var{len} objects for its usage.")
-#define FUNC_NAME s_scm_make_cclo
-{
-  return scm_makcclo (proc, scm_to_size_t (len));
-}
-#undef FUNC_NAME
-#endif
-#endif
-
-
-
 SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0, 
            (SCM obj),
            "Return @code{#t} if @var{obj} is a procedure.")
@@ -142,9 +106,6 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0,
          break;
       case scm_tcs_closures:
       case scm_tcs_subrs:
-#ifdef CCLO
-      case scm_tc7_cclo:
-#endif
       case scm_tc7_pws:
        return SCM_BOOL_T;
       case scm_tc7_smob:
@@ -182,15 +143,16 @@ SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0,
        case scm_tc7_lsubr:
        case scm_tc7_rpsubr:
        case scm_tc7_asubr:
-#ifdef CCLO
-       case scm_tc7_cclo:
-#endif
          return SCM_BOOL_T;
+       case scm_tc7_gsubr:
+         return scm_from_bool (SCM_GSUBR_REQ (SCM_GSUBR_TYPE (obj)) == 0);
        case scm_tc7_pws:
          obj = SCM_PROCEDURE (obj);
          goto again;
        default:
-         ;
+          if (SCM_PROGRAM_P (obj) && SCM_PROGRAM_DATA (obj)->nargs == 0)
+            return SCM_BOOL_T;
+          /* otherwise fall through */
        }
     }
   return SCM_BOOL_F;
@@ -236,12 +198,6 @@ SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0,
        return SCM_BOOL_F;
     default:
       return SCM_BOOL_F;
-/*
-  case scm_tcs_subrs:
-#ifdef CCLO
-  case scm_tc7_cclo:
-#endif
-*/
     }
 }
 #undef FUNC_NAME
@@ -266,11 +222,25 @@ SCM_DEFINE (scm_make_procedure_with_setter, "make-procedure-with-setter", 2, 0,
            "with the associated setter @var{setter}.")
 #define FUNC_NAME s_scm_make_procedure_with_setter
 {
+  SCM name, ret;
   SCM_VALIDATE_PROC (1, procedure);
   SCM_VALIDATE_PROC (2, setter);
-  return scm_double_cell (scm_tc7_pws,
-                         SCM_UNPACK (procedure),
-                         SCM_UNPACK (setter), 0);
+  ret = scm_double_cell (scm_tc7_pws,
+                         SCM_UNPACK (procedure),
+                         SCM_UNPACK (setter), 0);
+  /* don't use procedure_name, because don't care enough to do a reverse
+     lookup */
+  switch (SCM_TYP7 (procedure)) {
+  case scm_tcs_subrs:
+    name = SCM_SNAME (procedure);
+    break;
+  default:
+    name = scm_procedure_property (procedure, scm_sym_name);
+    break;
+  }
+  if (scm_is_true (name))
+    scm_set_procedure_property_x (ret, scm_sym_name, name);
+  return ret;
 }
 #undef FUNC_NAME