#include <stdio.h>
#include "_scm.h"
#include "genio.h"
+#include "procprop.h"
#include "gsubr.h"
\f
#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;
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);
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;
}
}
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));
#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