* * backtrace.c (scm_display_application): New procedure:

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

diff --git a/libguile/gsubr.c b/libguile/gsubr.c
index 5f0a3e9..b69a6c4 100644 (file)
--- a/libguile/gsubr.c
+++ b/libguile/gsubr.c
@@ -43,6 +43,7 @@
 #include <stdio.h>
 #include "_scm.h"
 #include "genio.h"
+#include "procprop.h"
 
 #include "gsubr.h"
 \f
@@ -65,11 +66,9 @@
 #define GSUBR_TYPE(cclo) (SCM_VELTS(cclo)[1])
 #define GSUBR_PROC(cclo) (SCM_VELTS(cclo)[2])
 
+SCM scm_i_name;
 static SCM f_gsubr_apply;
-#ifdef __STDC__
-SCM
-scm_make_gsubr(char *name, int req, int opt, int rst, SCM (*fcn)())
-#else
+
 SCM
 scm_make_gsubr(name, req, opt, rst, fcn)
      char *name;
@@ -77,7 +76,6 @@ scm_make_gsubr(name, req, opt, rst, fcn)
      int opt;
      int rst;
      SCM (*fcn)();
-#endif
 {
   switch GSUBR_MAKTYPE(req, opt, rst) {
   case GSUBR_MAKTYPE(0, 0, 0): return scm_make_subr(name, scm_tc7_subr_0, fcn);
@@ -101,10 +99,14 @@ scm_make_gsubr(name, req, opt, rst, fcn)
        tmp = 0;
       SCM_NEWCELL(z);
       SCM_SUBRF(z) = fcn;
-      SCM_CAR(z) = tmp + scm_tc7_subr_0;
+      SCM_SETCAR (z, tmp + scm_tc7_subr_0);
       GSUBR_PROC(cclo) = z;
       GSUBR_TYPE(cclo) = SCM_MAKINUM(GSUBR_MAKTYPE(req, opt, rst));
-      SCM_CDR(symcell) = cclo;
+      SCM_SETCDR (symcell, cclo);
+#ifdef DEBUG_EXTENSIONS
+      if (SCM_REC_PROCNAMES_P)
+       scm_set_procedure_property_x (cclo, scm_i_name, SCM_CAR (symcell));
+#endif
       return cclo;
     }
   }
@@ -112,14 +114,10 @@ scm_make_gsubr(name, req, opt, rst, fcn)
 
 
 SCM_PROC(s_gsubr_apply, "gsubr-apply", 0, 0, 1, scm_gsubr_apply);
-#ifdef __STDC__
-SCM
-scm_gsubr_apply(SCM args)
-#else
+
 SCM
 scm_gsubr_apply(args)
      SCM args;
-#endif
 {
   SCM self = SCM_CAR(args);
   SCM (*fcn)() = SCM_SUBRF(GSUBR_PROC(self));
@@ -130,7 +128,7 @@ scm_gsubr_apply(args)
   for (i = 0; i < GSUBR_REQ(typ); i++) {
 #ifndef RECKLESS
     if (SCM_IMP(args))
-      scm_wta(SCM_UNDEFINED, (char *)SCM_WNA, SCM_CHARS(SCM_SNAME(GSUBR_PROC(self))));
+      scm_wrong_num_args (SCM_SNAME(GSUBR_PROC(self)));
 #endif
     v[i] = SCM_CAR(args);
     args = SCM_CDR(args);
@@ -182,15 +180,13 @@ gsubr_21l(req1, req2, opt, rst)
 #endif
 
 
-#ifdef __STDC__
-void
-scm_init_gsubr(void)
-#else
+
 void
 scm_init_gsubr()
-#endif
 {
   f_gsubr_apply = scm_make_subr(s_gsubr_apply, scm_tc7_lsubr, scm_gsubr_apply);
+  scm_i_name = SCM_CAR (scm_sysintern ("name", SCM_UNDEFINED));
+  scm_permanent_object (scm_i_name);
 #ifdef GSUBR_TEST
   scm_make_gsubr("gsubr-2-1-l", 2, 1, 1, gsubr_21l); /* example */
 #endif