mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 19:50:24 +02:00
Code Activity

* gsubr.h, gsubr.c: Moved macros from gsubr.c to gsubr.h and added

Browse source 
prefix SCM_; Made f_gsubr_apply global and added prefix scm_.
This commit is contained in:
Mikael Djurfeldt 1998-05-04 11:32:05 +00:00
parent 65e417214c
commit dc0938d8a4
2 changed files with 33 additions and 31 deletions
Download patch file Download diff file Expand all files Collapse all files

53
libguile/gsubr.c
View file

@ -57,18 +57,9 @@
#define GSUBR_TEST 1 #define GSUBR_TEST 1
#define GSUBR_MAKTYPE(req, opt, rst) ((req)|((opt)<<4)|((rst)<<8))
#define GSUBR_REQ(x) ((int)(x)&0xf)
#define GSUBR_OPT(x) (((int)(x)&0xf0)>>4)
#define GSUBR_REST(x) ((int)(x)>>8)
#define GSUBR_MAX 10
#define GSUBR_TYPE(cclo) (SCM_VELTS(cclo)[1])
#define GSUBR_PROC(cclo) (SCM_VELTS(cclo)[2])
SCM scm_i_name; SCM scm_i_name;
SCM scm_i_inner_name; SCM scm_i_inner_name;
static SCM f_gsubr_apply; SCM scm_f_gsubr_apply;
SCM SCM
scm_make_gsubr(name, req, opt, rst, fcn) scm_make_gsubr(name, req, opt, rst, fcn)
@ -78,21 +69,21 @@ scm_make_gsubr(name, req, opt, rst, fcn)
int rst; int rst;
SCM (*fcn)(); SCM (*fcn)();
{ {
switch GSUBR_MAKTYPE(req, opt, rst) { switch SCM_GSUBR_MAKTYPE(req, opt, rst) {
case GSUBR_MAKTYPE(0, 0, 0): return scm_make_subr(name, scm_tc7_subr_0, fcn); case SCM_GSUBR_MAKTYPE(0, 0, 0): return scm_make_subr(name, scm_tc7_subr_0, fcn);
case GSUBR_MAKTYPE(1, 0, 0): return scm_make_subr(name, scm_tc7_subr_1, fcn); case SCM_GSUBR_MAKTYPE(1, 0, 0): return scm_make_subr(name, scm_tc7_subr_1, fcn);
case GSUBR_MAKTYPE(0, 1, 0): return scm_make_subr(name, scm_tc7_subr_1o, fcn); case SCM_GSUBR_MAKTYPE(0, 1, 0): return scm_make_subr(name, scm_tc7_subr_1o, fcn);
case GSUBR_MAKTYPE(1, 1, 0): return scm_make_subr(name, scm_tc7_subr_2o, fcn); case SCM_GSUBR_MAKTYPE(1, 1, 0): return scm_make_subr(name, scm_tc7_subr_2o, fcn);
case GSUBR_MAKTYPE(2, 0, 0): return scm_make_subr(name, scm_tc7_subr_2, fcn); case SCM_GSUBR_MAKTYPE(2, 0, 0): return scm_make_subr(name, scm_tc7_subr_2, fcn);
case GSUBR_MAKTYPE(3, 0, 0): return scm_make_subr(name, scm_tc7_subr_3, fcn); case SCM_GSUBR_MAKTYPE(3, 0, 0): return scm_make_subr(name, scm_tc7_subr_3, fcn);
case GSUBR_MAKTYPE(0, 0, 1): return scm_make_subr(name, scm_tc7_lsubr, fcn); case SCM_GSUBR_MAKTYPE(0, 0, 1): return scm_make_subr(name, scm_tc7_lsubr, fcn);
case GSUBR_MAKTYPE(2, 0, 1): return scm_make_subr(name, scm_tc7_lsubr_2, fcn); case SCM_GSUBR_MAKTYPE(2, 0, 1): return scm_make_subr(name, scm_tc7_lsubr_2, fcn);
default: default:
{ {
SCM symcell = scm_sysintern(name, SCM_UNDEFINED); SCM symcell = scm_sysintern(name, SCM_UNDEFINED);
SCM z, cclo = scm_makcclo(f_gsubr_apply, 3L); SCM z, cclo = scm_makcclo(scm_f_gsubr_apply, 3L);
long tmp = ((((SCM_CELLPTR)(SCM_CAR(symcell)))-scm_heap_org)<<8); long tmp = ((((SCM_CELLPTR)(SCM_CAR(symcell)))-scm_heap_org)<<8);
if (GSUBR_MAX < req + opt + rst) { if (SCM_GSUBR_MAX < req + opt + rst) {
fputs("ERROR in scm_make_gsubr: too many args\n", stderr); fputs("ERROR in scm_make_gsubr: too many args\n", stderr);
exit (1); exit (1);
} }
@ -101,8 +92,8 @@ scm_make_gsubr(name, req, opt, rst, fcn)
SCM_NEWCELL(z); SCM_NEWCELL(z);
SCM_SUBRF(z) = fcn; SCM_SUBRF(z) = fcn;
SCM_SETCAR (z, tmp + scm_tc7_subr_0); SCM_SETCAR (z, tmp + scm_tc7_subr_0);
GSUBR_PROC(cclo) = z; SCM_GSUBR_PROC(cclo) = z;
GSUBR_TYPE(cclo) = SCM_MAKINUM(GSUBR_MAKTYPE(req, opt, rst)); SCM_GSUBR_TYPE(cclo) = SCM_MAKINUM(SCM_GSUBR_MAKTYPE(req, opt, rst));
SCM_SETCDR (symcell, cclo); SCM_SETCDR (symcell, cclo);
#ifdef DEBUG_EXTENSIONS #ifdef DEBUG_EXTENSIONS
if (SCM_REC_PROCNAMES_P) if (SCM_REC_PROCNAMES_P)
@ -121,24 +112,24 @@ scm_gsubr_apply(args)
SCM args; SCM args;
{ {
SCM self = SCM_CAR(args); SCM self = SCM_CAR(args);
SCM (*fcn)() = SCM_SUBRF(GSUBR_PROC(self)); SCM (*fcn)() = SCM_SUBRF(SCM_GSUBR_PROC(self));
SCM v[10]; /* must agree with greatest supported arity */ SCM v[10]; /* must agree with greatest supported arity */
int typ = SCM_INUM(GSUBR_TYPE(self)); int typ = SCM_INUM(SCM_GSUBR_TYPE(self));
int i, n = GSUBR_REQ(typ) + GSUBR_OPT(typ) + GSUBR_REST(typ); int i, n = SCM_GSUBR_REQ(typ) + SCM_GSUBR_OPT(typ) + SCM_GSUBR_REST(typ);
#if 0 #if 0
SCM_ASSERT(n <= sizeof(v)/sizeof(SCM), SCM_ASSERT(n <= sizeof(v)/sizeof(SCM),
self, "internal programming error", s_gsubr_apply); self, "internal programming error", s_gsubr_apply);
#endif #endif
args = SCM_CDR(args); args = SCM_CDR(args);
for (i = 0; i < GSUBR_REQ(typ); i++) { for (i = 0; i < SCM_GSUBR_REQ(typ); i++) {
#ifndef RECKLESS #ifndef RECKLESS
if (SCM_IMP(args)) if (SCM_IMP(args))
wnargs: scm_wrong_num_args (SCM_SNAME(GSUBR_PROC(self))); wnargs: scm_wrong_num_args (SCM_SNAME(SCM_GSUBR_PROC(self)));
#endif #endif
v[i] = SCM_CAR(args); v[i] = SCM_CAR(args);
args = SCM_CDR(args); args = SCM_CDR(args);
} }
for (; i < GSUBR_REQ(typ) + GSUBR_OPT(typ); i++) { for (; i < SCM_GSUBR_REQ(typ) + SCM_GSUBR_OPT(typ); i++) {
if (SCM_NIMP(args)) { if (SCM_NIMP(args)) {
v[i] = SCM_CAR(args); v[i] = SCM_CAR(args);
args = SCM_CDR(args); args = SCM_CDR(args);
@ -146,7 +137,7 @@ scm_gsubr_apply(args)
else else
v[i] = SCM_UNDEFINED; v[i] = SCM_UNDEFINED;
} }
if (GSUBR_REST(typ)) if (SCM_GSUBR_REST(typ))
v[i] = args; v[i] = args;
else else
SCM_ASRTGO(SCM_NULLP(args), wnargs); SCM_ASRTGO(SCM_NULLP(args), wnargs);
@ -191,7 +182,7 @@ gsubr_21l(req1, req2, opt, rst)
void void
scm_init_gsubr() scm_init_gsubr()
{ {
f_gsubr_apply = scm_make_subr(s_gsubr_apply, scm_tc7_lsubr, scm_gsubr_apply); scm_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_i_name = SCM_CAR (scm_sysintern ("name", SCM_UNDEFINED));
scm_permanent_object (scm_i_name); scm_permanent_object (scm_i_name);
scm_i_inner_name = SCM_CAR (scm_sysintern ("inner-name", SCM_UNDEFINED)); scm_i_inner_name = SCM_CAR (scm_sysintern ("inner-name", SCM_UNDEFINED));

11
libguile/gsubr.h
View file

@ -48,6 +48,17 @@
#define SCM_GSUBR_MAKTYPE(req, opt, rst) ((req)|((opt)<<4)|((rst)<<8))
#define SCM_GSUBR_REQ(x) ((int)(x)&0xf)
#define SCM_GSUBR_OPT(x) (((int)(x)&0xf0)>>4)
#define SCM_GSUBR_REST(x) ((int)(x)>>8)
#define SCM_GSUBR_MAX 10
#define SCM_GSUBR_TYPE(cclo) (SCM_VELTS(cclo)[1])
#define SCM_GSUBR_PROC(cclo) (SCM_VELTS(cclo)[2])
extern SCM scm_f_gsubr_apply;
extern SCM scm_make_gsubr SCM_P ((char *name, int req, int opt, int rst, SCM (*fcn)())); extern SCM scm_make_gsubr SCM_P ((char *name, int req, int opt, int rst, SCM (*fcn)()));
extern SCM scm_gsubr_apply SCM_P ((SCM args)); extern SCM scm_gsubr_apply SCM_P ((SCM args));
extern void scm_init_gsubr SCM_P ((void)); extern void scm_init_gsubr SCM_P ((void));