summaryrefslogtreecommitdiffstats
path: root/eval.c
diff options
context:
space:
mode:
authorJames LewisMoss <dres@debian.org>2000-03-12 09:04:17 -0500
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:26 -0800
commit8cfce36c6a4fc2e0a0ab6ef2db66a23cbe462693 (patch)
tree17427e4f777ca85990a449fe939fbae29770b346 /eval.c
parenta47af30d2f0e96afcd1f14b1984575c359faa3d6 (diff)
parent3278b75942bdbe706f7a0fba87729bb1e935b68b (diff)
downloadscm-8cfce36c6a4fc2e0a0ab6ef2db66a23cbe462693.tar.gz
scm-8cfce36c6a4fc2e0a0ab6ef2db66a23cbe462693.zip
Import Debian changes 5d2-3debian/5d2-3
scm (5d2-3) unstable frozen; urgency=low * Fix libncurses4-dev -> libncurses5-dev build depend (Closes: #58435) * Fix libreadline2-dev -> libreadline4-dev build depend. * Fix license location in copyright file (lintian warning) * Add tetex-bin as a build depend (needs makeinfo) (Closes: #53197) * Add -isp option to dpkg-gencontrol (lintian error) * Move scm to section interpreters. scm (5d2-2) unstable; urgency=low * Apply patch from upstream for bug in eval.c. (Picked up from comp.lang.scheme) * Add Build-Depends on slib, librx1g-dev, libncurses4-dev, libreadlineg2-dev. * Up standards version. * Correct description: this is an R5RS implementation now * Make sure no optimizations are done on m68k. (Closes: #52434) scm (5d2-1) unstable; urgency=low * New upstream. scm (5d1-2) unstable; urgency=low * Remove TAGS on clean (cut the diff back down to reasonable size). scm (5d1-1) unstable; urgency=low * New upstream. * move stuff to /usr/share. scm (5d0-3) unstable; urgency=low * Change scmlit call to ./scmlit call (missed one) (Fixes bugs #37455 and #35545) * Change man file permissions to 644 (fixes lintian warning) scm (5d0-2) unstable; urgency=low * Removed call to add_final in init_crs. lendwin doesn't do anything and scm was crashing when quit everytime in final_scm. * Changed copyright to reflect new source. scm (5d0-1) unstable; urgency=low * New upstream. * Changed (terms) to access "/usr/doc/copyright/GPL". * Changed regex to use -lrx scm (5c3-6) unstable; urgency=low * New maintainer.
Diffstat (limited to 'eval.c')
-rw-r--r--eval.c1356
1 files changed, 910 insertions, 446 deletions
diff --git a/eval.c b/eval.c
index 335be3b..fdb3683 100644
--- a/eval.c
+++ b/eval.c
@@ -1,18 +1,18 @@
-/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997 Free Software Foundation, Inc.
- *
+/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997, 1998, 1999 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
* the Free Software Foundation; either version 2, or (at your option)
* any later version.
- *
+ *
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
- *
+ *
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
*
* As a special exception, the Free Software Foundation gives permission
* for additional uses of the text contained in its release of GUILE.
@@ -36,7 +36,7 @@
*
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
+ * If you do not wish that, delete this exception notice.
*/
/* "eval.c" eval and apply.
@@ -69,7 +69,7 @@
arguments to C functions, or to return them from C functions, since
such objects may be moved by the ecache gc. Ecache gc may happen
anywhere interrupts are not deferred, because some interrupt
- handlers may evaluate Scheme code and then return.
+ handlers may evaluate Scheme code and then return.
Interrupts may be deferred with DEFER_INTS_EGC: This will prevent
interrupts until an ALLOW_INTS or ALLOW_INTS_EGC, which may happen
@@ -100,24 +100,30 @@ SCM scm_env = EOL, scm_env_tmp = UNSPECIFIED;
long tc16_env; /* Type code for environments passed to macro
transformers. */
SCM nconc2copy P((SCM x));
-SCM copy_list P((SCM x));
+SCM copy_list P((SCM x, int minlen));
+SCM scm_v2lst P((long argc, SCM *argv));
SCM rename_ident P((SCM id, SCM env));
+SCM *lookupcar P((SCM vloc, int check));
SCM eqv P((SCM x, SCM y));
-void scm_dynthrow P((CONTINUATION *cont, SCM val));
+SCM scm_multi_set P((SCM syms, SCM vals));
+SCM eval_args P((SCM x));
+void scm_dynthrow P((SCM cont, SCM val));
void scm_egc P((void));
-void scm_estk_grow P((sizet inc));
+void scm_estk_grow P((void));
void scm_estk_shrink P((void));
int badargsp P((SCM proc, SCM args));
+static SCM asubr_apply P((SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM args));
static SCM ceval_1 P((SCM x));
static SCM evalatomcar P((SCM x));
static SCM evalcar P((SCM x));
static SCM id2sym P((SCM id));
static SCM iqq P((SCM form));
static SCM m_body P((SCM op, SCM xorig, char *what));
+static SCM m_expand_body P((SCM xorig));
static SCM m_iqq P((SCM form, int depth, SCM env));
static SCM m_letrec1 P((SCM op, SCM imm, SCM xorig, SCM env));
-static SCM macroexp1 P((SCM x, int check));
+static SCM macroexp1 P((SCM x, SCM defs));
static SCM unmemocar P((SCM x));
static SCM wrapenv P((void));
static SCM *id_denote P((SCM var));
@@ -125,24 +131,31 @@ static int prinenv P((SCM exp, SCM port, int writing));
static int prinid P((SCM exp, SCM port, int writing));
static int prinmacro P((SCM exp, SCM port, int writing));
static int prinprom P((SCM exp, SCM port, int writing));
-static void bodycheck P((SCM xorig, SCM *bodyloc, char *what));
static void unpaint P((SCM *p));
+static void ecache_evalx P((SCM x));
+static int ecache_eval_args P((SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM x));
+static int varcheck P((SCM xorig, SCM vars, char *op, char *what));
#ifdef CAREFUL_INTS
static void debug_env_warn P((char *fnam, long line, char *what));
+static void debug_env_save P((char *fnam, long line));
#endif
/* Flush global variable state to estk. */
-#define ENV_SAVE {scm_estk_ptr[0]=scm_env; scm_estk_ptr[1]=scm_env_tmp;}
+#ifdef CAREFUL_INTS
+# define ENV_SAVE debug_env_save(__FILE__, __LINE__)
+#else
+# define ENV_SAVE {scm_estk_ptr[0]=scm_env; scm_estk_ptr[1]=scm_env_tmp;}
+#endif
/* Make global variable state consistent with estk. */
#define ENV_RESTORE {scm_env=scm_estk_ptr[0]; scm_env_tmp=scm_estk_ptr[1];}
#define ENV_PUSH {DEFER_INTS_EGC; ENV_SAVE;\
- if (INUM0==scm_estk_ptr[SCM_ESTK_FRLEN]) scm_estk_grow(20);\
+ if (UNDEFINED==scm_estk_ptr[SCM_ESTK_FRLEN]) scm_estk_grow();\
else scm_estk_ptr += SCM_ESTK_FRLEN;}
#define ENV_POP {DEFER_INTS_EGC;\
- if (INUM0==scm_estk_ptr[-SCM_ESTK_FRLEN]) scm_estk_shrink();\
+ if (UNDEFINED==scm_estk_ptr[-1]) scm_estk_shrink();\
else scm_estk_ptr -= SCM_ESTK_FRLEN; ENV_RESTORE;}
#ifdef NO_ENV_CACHE
@@ -159,13 +172,20 @@ static void debug_env_warn P((char *fnam, long line, char *what));
# endif
#endif
+#ifdef CAUTIOUS
+SCM scm_trace = UNDEFINED;
+#endif
#define ENV_MAY_POP(p, guard) if (p>0 && !(guard)) {ENV_POP; p=-1;}
#define ENV_MAY_PUSH(p) if (p<=0) {ENV_PUSH; p=1;}
#define SIDEVAL_1(x) if NIMP(x) ceval_1(x)
#ifdef CAUTIOUS
-# define TRACE(x) scm_estk_ptr[2]=(x)
+# define TRACE(x) {scm_estk_ptr[2]=(x);}
+# define TOP_TRACE(x) {scm_trace=(x);}
+# define PUSH_TRACE TRACE(scm_trace)
#else
# define TRACE(x) /**/
+# define TOP_TRACE(x) /**/
+# define PUSH_TRACE /**/
#endif
#define EVALIMP(x) (ILOCP(x)?*ilookup(x):x)
@@ -181,7 +201,6 @@ static char s_escaped[] = "escaped synthetic identifier";
# define M_IDENTP(x) (tc16_ident==TYP16(x))
# define M_IDENT_LEXP(x) ((tc16_ident | (1L<<16))==CAR(x))
# define IDENTP(x) (SYMBOLP(x) || M_IDENTP(x))
-# define IDENT_LEXP (1L<<16)
# define IDENT_PARENT(x) (M_IDENT_LEXP(x) ? CAR(CDR(x)) : CDR(x))
# define IDENT_MARK(x) (M_IDENT_LEXP(x) ? CDR(CDR(x)) : BOOL_F)
# define ENV_MARK BOOL_T
@@ -239,7 +258,7 @@ SCM scm_profile(resetp)
/* Inhibit warnings for ARGC, is not changed by egc. */
# undef ARGC
# define ARGC(x) ((6L & (((cell *)(SCM2PTR(x)))->cdr))>>1)
-#include <signal.h>
+# include <signal.h>
SCM test_ints(x)
SCM x;
{
@@ -302,6 +321,18 @@ SCM *debug_env_cdr(x, fnam, line)
debug_env_warn(fnam, line, "CAR");
return ret;
}
+static void debug_env_save(fnam, line)
+ char *fnam;
+ long line;
+{
+ if (NIMP(scm_env) && (!scm_cell_p(scm_env)))
+ debug_env_warn(fnam, line, "ENV_SAVE (env)");
+ if (NIMP(scm_env_tmp) && (!scm_cell_p(scm_env_tmp)))
+ debug_env_warn(fnam, line, "ENV_SAVE (tmp)");
+ scm_estk_ptr[0]=scm_env;
+ scm_estk_ptr[1]=scm_env_tmp;
+}
+
#endif /* CAREFUL_INTS */
SCM *ilookup(iloc)
@@ -338,14 +369,17 @@ SCM *farlookup(farloc)
static char s_badkey[] = "Use of keyword as variable",
s_unbnd[] = "unbound variable: ", s_wtap[] = "Wrong type to apply: ";
-/* check is logical OR of LOOKUP_UNDEFP and LOOKUP_MACROP */
-#define LOOKUP_UNDEFP 1
-#define LOOKUP_MACROP 2
+/* check is logical OR of LOOKUP_MEMOIZE, LOOKUP_UNDEFP, and LOOKUP_MACROP,
+ if check is zero then memoization will not be done. */
+#define LOOKUP_MEMOIZE 1
+#define LOOKUP_UNDEFP 2
+#define LOOKUP_MACROP 4
SCM *lookupcar(vloc, check)
SCM vloc;
int check;
{
SCM env;
+ long icdr = 0L;
register SCM *al, fl, var = CAR(vloc);
register unsigned int idist, iframe = 0;
#ifdef MACRO
@@ -353,52 +387,65 @@ SCM *lookupcar(vloc, check)
#endif
DEFER_INTS_EGC;
env = scm_env;
+ if (NIMP(env) && ENVP(env))
+ env = CDR(env);
for(; NIMP(env); env = CDR(env)) {
idist = 0;
al = &CAR(env);
- for(fl = CAR(*al);NIMP(fl);fl = CDR(fl)) {
+ fl = CAR(*al);
#ifdef MACRO
- if (fl==mark) {
- var = IDENT_PARENT(var);
- mark = IDENT_MARK(var);
- }
+ if (fl==mark) {
+ var = IDENT_PARENT(var);
+ mark = IDENT_MARK(var);
+ }
#endif
+/* constant environment section -- not used as yet.
+ if (BOOL_T==fl) {
+ fl = assq(var, CDR(fl));
+ if FALSEP(fl) break;
+ var = fl;
+ goto gloc_out;
+ }
+*/
+ for(;NIMP(fl);fl = CDR(fl)) {
if NCONSP(fl)
if (fl==var) {
+ icdr = ICDR;
#ifndef RECKLESS
- if ((check & LOOKUP_UNDEFP)
- && UNBNDP(CDR(*al))) { env = EOL; goto errout; }
-# ifdef MACRO
- if ((check & LOOKUP_MACROP)
- && (NIMP(CDR(*al)) && MACROP(CDR(*al)))) goto badkey;
-# endif
+ fl = CDR(*al);
#endif
-#ifndef TEST_FARLOC
- if (iframe < 4096 && idist < (1L<<(LONG_BIT-20)))
- CAR(vloc) = MAKILOC(iframe, idist) + ICDR;
- else
-#endif
- CAR(vloc) = cons2(IM_FARLOC_CDR, MAKINUM(iframe), MAKINUM(idist));
- return &CDR(*al);
+ goto local_out;
}
else break;
al = &CDR(*al);
if (CAR(fl)==var) {
#ifndef RECKLESS /* letrec inits to UNDEFINED */
+ fl = CAR(*al);
+ local_out:
if ((check & LOOKUP_UNDEFP)
- && UNBNDP(CAR(*al))) {env = EOL; goto errout;}
+ && UNBNDP(fl)) {env = EOL; goto errout;}
# ifdef MACRO
if ((check & LOOKUP_MACROP)
- && NIMP(CAR(*al)) && MACROP(CAR(*al))) goto badkey;
+ && NIMP(fl) && MACROP(fl)) goto badkey;
# endif
+ if ((check) && NIMP(scm_env) && ENVP(scm_env))
+ everr(vloc, scm_env, var,
+ "run-time reference", "");
+#else /* ndef RECKLESS */
+ local_out:
+#endif
+#ifdef MEMOIZE_LOCALS
+ if (check) {
+# ifndef TEST_FARLOC
+ if (iframe < 4096 && idist < (1L<<(LONG_BIT-20)))
+ CAR(vloc) = MAKILOC(iframe, idist) + icdr;
+ else
+# endif
+ CAR(vloc) = cons2(icdr ? IM_FARLOC_CDR : IM_FARLOC_CAR,
+ MAKINUM(iframe), MAKINUM(idist));
+ }
#endif
-#ifndef TEST_FARLOC
- if (iframe < 4096 && idist < (1L<<(LONG_BIT-20)))
- CAR(vloc) = MAKILOC(iframe, idist);
- else
-#endif
- CAR(vloc) = cons2(IM_FARLOC_CAR, MAKINUM(iframe), MAKINUM(idist));
- return &CAR(*al);
+ return icdr ? &CDR(*al) : &CAR(*al);
}
idist++;
}
@@ -411,11 +458,12 @@ SCM *lookupcar(vloc, check)
}
#endif
var = sym2vcell(var);
+ gloc_out:
#ifndef RECKLESS
if (NNULLP(env) || ((check & LOOKUP_UNDEFP) && UNBNDP(CDR(var)))) {
var = CAR(var);
errout:
- everr(vloc, wrapenv() /*scm_env*/, var,
+ everr(vloc, wrapenv(), var,
# ifdef MACRO
M_IDENTP(var) ? s_escaped :
# endif
@@ -424,11 +472,11 @@ SCM *lookupcar(vloc, check)
# ifdef MACRO
if ((check & LOOKUP_MACROP) && NIMP(CDR(var)) && MACROP(CDR(var))) {
var = CAR(var);
- badkey: everr(vloc, wrapenv()/*scm_env*/, var, s_badkey, "");
+ badkey: everr(vloc, wrapenv(), var, s_badkey, "");
}
# endif
#endif
- CAR(vloc) = var + 1;
+ if (check) CAR(vloc) = var + 1;
return &CDR(var);
}
@@ -439,6 +487,7 @@ static SCM unmemocar(form)
register int ir;
DEFER_INTS_EGC;
env = scm_env;
+ if (NIMP(env) && ENVP(env)) env = CDR(env);
if IMP(form) return form;
if (1==TYP3(form))
CAR(form) = I_SYM(CAR(form));
@@ -458,13 +507,13 @@ static SCM evalatomcar(x)
SCM r;
switch TYP7(CAR(x)) {
default:
- everr(x, wrapenv() /*scm_env*/, CAR(x), "Cannot evaluate: ", "");
+ everr(x, wrapenv(), CAR(x), "Cannot evaluate: ", "");
case tcs_symbols:
lookup:
return *lookupcar(x, LOOKUP_UNDEFP|LOOKUP_MACROP);
case tc7_vector:
#ifndef RECKLESS
- if (2 <= verbose) warn("unquoted ", s_vector);
+ if (2 <= verbose) scm_warn("unquoted ", s_vector);
#endif
r = cons2(IM_QUOTE, CAR(x), EOL);
CAR(x) = r;
@@ -474,13 +523,39 @@ static SCM evalatomcar(x)
if M_IDENTP(CAR(x)) goto lookup;
#endif
/* fall through */
- case tc7_string:
- case tc7_bvect: case tc7_ivect: case tc7_uvect:
- case tc7_fvect: case tc7_dvect: case tc7_cvect:
+ case tcs_uves:
return CAR(x);
}
}
+SCM scm_multi_set(syms, vals)
+ SCM syms, vals;
+{
+ SCM res = EOL, *pres = &res;
+ SCM *loc;
+ do {
+ ASSERT(NIMP(vals) && CONSP(vals), vals, WNA, s_set);
+ switch (7 & (int)(CAR(syms))) {
+ case 0:
+ loc = lookupcar(syms, LOOKUP_UNDEFP|LOOKUP_MACROP);
+ break;
+ case 1:
+ loc = &(I_VAL(CAR(syms)));
+ break;
+ case 4:
+ loc = ilookup(CAR(syms));
+ break;
+ }
+ *pres = cons(*loc, EOL);
+ pres = &CDR(*pres);
+ *loc = CAR(vals);
+ syms = CDR(syms);
+ vals = CDR(vals);
+ } while (NIMP(syms));
+ ASSERT(NULLP(vals) && NULLP(syms), vals, WNA, s_set);
+ return res;
+}
+
SCM eval_args(l)
SCM l;
{
@@ -493,6 +568,75 @@ SCM eval_args(l)
return res;
}
+static void ecache_evalx(x)
+ SCM x;
+{
+ SCM argv[10];
+ int i = 0, imax = sizeof(argv)/sizeof(SCM);
+ scm_env_tmp = EOL;
+ while NIMP(x) {
+ if (imax==i) {
+ ecache_evalx(x);
+ break;
+ }
+ argv[i++] = EVALCAR(x);
+ x = CDR(x);
+ }
+ scm_env_v2lst(i, argv);
+}
+
+/* result is 1 if right number of arguments, 0 otherwise,
+ environment frame is put in scm_env_tmp */
+static int ecache_eval_args(proc, arg1, arg2, arg3, x)
+ SCM proc, arg1, arg2, arg3, x;
+{
+ SCM argv[3];
+ argv[0] = arg1;
+ argv[1] = arg2;
+ argv[2] = arg3;
+ if (NIMP(x))
+ ecache_evalx(x);
+ else
+ scm_env_tmp = EOL;
+ scm_env_v2lst(3, argv);
+#ifndef RECKLESS
+ proc = CAR(CODE(proc));
+ proc = CDR(proc);
+ proc = CDR(proc);
+ proc = CDR(proc);
+ for (; NIMP(proc); proc=CDR(proc)) {
+ if IMP(x) return 0;
+ x = CDR(x);
+ }
+ if NIMP(x) return 0;
+#endif
+ return 1;
+}
+
+static SCM asubr_apply(proc, arg1, arg2, arg3, args)
+ SCM proc, arg1, arg2, arg3, args;
+{
+ switch TYP7(proc) {
+ case tc7_asubr:
+ arg1 = SUBRF(proc)(arg1, arg2);
+ arg1 = SUBRF(proc)(arg1, arg3);
+ while NIMP(args) {
+ arg1 = SUBRF(proc)(arg1, CAR(args));
+ args = CDR(args);
+ }
+ return arg1;
+ case tc7_rpsubr:
+ if FALSEP(SUBRF(proc)(arg1, arg2)) return BOOL_F;
+ while (!0) {
+ if FALSEP(SUBRF(proc)(arg2, arg3)) return BOOL_F;
+ if IMP(args) return BOOL_T;
+ arg2 = arg3;
+ arg3 = CAR(args);
+ args = CDR(args);
+ }
+ }
+}
+
/* the following rewrite expressions and
* some memoized forms have different syntax */
@@ -531,6 +675,7 @@ static SCM *id_denote(var)
SCM env, mark = IDENT_MARK(var);
DEFER_INTS_EGC;
env = scm_env;
+ if (NIMP(env) && ENVP(env)) env = CDR(env);
for(;NIMP(env); env = CDR(env)) {
al = &CAR(env);
for(fl = CAR(*al);NIMP(fl);fl = CDR(fl)) {
@@ -545,6 +690,12 @@ static SCM *id_denote(var)
if (CAR(fl)==var) return &CAR(*al);
}
}
+# ifndef RECKLESS
+ while M_IDENTP(var) {
+ ASSERT(IMP(IDENT_MARK(var)), var, s_escaped, "");
+ var = IDENT_PARENT(var);
+ }
+# endif
return (SCM *)0;
}
@@ -556,7 +707,7 @@ static void unpaint(p)
if CONSP(x) {
if NIMP(CAR(x)) unpaint(&CAR(x));
p = &CDR(*p);
- }
+ }
else if VECTORP(x) {
sizet i = LENGTH(x);
if (0==i) return;
@@ -575,18 +726,11 @@ static void unpaint(p)
# define TOPRENAME(v) (v)
#endif
-static void bodycheck(xorig, bodyloc, what)
- SCM xorig, *bodyloc;
- char *what;
-{
- ASRTSYNTAX(ilength(*bodyloc) >= 1, s_expression);
-}
-
static SCM m_body(op, xorig, what)
SCM op, xorig;
char *what;
{
- ASRTSYNTAX(ilength(xorig) >= 1, s_expression);
+ ASRTSYNTAX(ilength(xorig) >= 1, s_expression);
/* Don't add another ISYM if one is present already. */
if ISYMP(CAR(xorig)) return xorig;
/* Retain possible doc string. */
@@ -631,8 +775,10 @@ SCM m_set(xorig, env)
{
SCM x = CDR(xorig);
ASSYNT(2==ilength(x), xorig, s_expression, s_set);
- ASSYNT(NIMP(CAR(x)) && IDENTP(CAR(x)),
- xorig, s_variable, s_set);
+ varcheck(xorig,
+ (NIMP(CAR(x)) && IDENTP(CAR(x))) ? CAR(x) :
+ (ilength(CAR(x)) > 0) ? CAR(x) : UNDEFINED,
+ s_set, s_variable);
return cons(IM_SET, x);
}
@@ -641,8 +787,11 @@ SCM m_and(xorig, env)
{
int len = ilength(CDR(xorig));
ASSYNT(len >= 0, xorig, s_test, s_and);
- if (len >= 1) return cons(IM_AND, CDR(xorig));
- else return BOOL_T;
+ switch (len) {
+ default: return cons(IM_AND, CDR(xorig));
+ case 1: return CAR(CDR(xorig));
+ case 0: return BOOL_T;
+ }
}
SCM m_or(xorig, env)
@@ -650,8 +799,11 @@ SCM m_or(xorig, env)
{
int len = ilength(CDR(xorig));
ASSYNT(len >= 0, xorig, s_test, s_or);
- if (len >= 1) return cons(IM_OR, CDR(xorig));
- else return BOOL_F;
+ switch (len) {
+ default: return cons(IM_OR, CDR(xorig));
+ case 1: return CAR(CDR(xorig));
+ case 0: return BOOL_F;
+ }
}
#ifdef INUMS_ONLY
@@ -660,11 +812,11 @@ SCM m_or(xorig, env)
SCM m_case(xorig, env)
SCM xorig, env;
{
- SCM clause, cdrx = copy_list(CDR(xorig)), x = cdrx;
+ SCM clause, cdrx = copy_list(CDR(xorig), 2), x = cdrx;
#ifndef RECKLESS
SCM s, keys = EOL;
#endif
- ASSYNT(ilength(x) >= 2, xorig, s_clauses, s_case);
+ ASSYNT(!UNBNDP(cdrx), xorig, s_clauses, s_case);
while(NIMP(x = CDR(x))) {
clause = CAR(x);
ASSYNT(ilength(clause) >= 2, xorig, s_clauses, s_case);
@@ -673,19 +825,22 @@ SCM m_case(xorig, env)
CAR(x) = cons(IM_ELSE, CDR(clause));
}
else {
- ASSYNT(ilength(CAR(clause)) >= 0, xorig, s_clauses, s_case);
#ifdef MACRO
- clause = cons(copy_list(CAR(clause)), CDR(clause));
+ SCM c = copy_list(CAR(clause), 0);
+ ASSYNT(!UNBNDP(c), xorig, s_clauses, s_case);
+ clause = cons(c, CDR(clause));
DEFER_INTS;
unpaint(&CAR(clause));
ALLOW_INTS;
CAR(x) = clause;
+#else
+ ASSYNT(ilength(CAR(clause)) >= 0, xorig, s_clauses, s_case);
#endif
#ifndef RECKLESS
for (s = CAR(clause); NIMP(s); s = CDR(s))
ASSYNT(FALSEP(memv(CAR(s),keys)), xorig, "duplicate key value", s_case);
keys = append(cons2(CAR(clause), keys, EOL));
-#endif
+#endif
}
}
return cons(IM_CASE, cdrx);
@@ -694,9 +849,9 @@ SCM m_case(xorig, env)
SCM m_cond(xorig, env)
SCM xorig, env;
{
- SCM arg1, cdrx = copy_list(CDR(xorig)), x = cdrx;
+ SCM arg1, cdrx = copy_list(CDR(xorig), 1), x = cdrx;
int len = ilength(x);
- ASSYNT(len >= 1, xorig, s_clauses, s_cond);
+ ASSYNT(!UNBNDP(cdrx), xorig, s_clauses, s_cond);
while(NIMP(x)) {
arg1 = CAR(x);
len = ilength(arg1);
@@ -717,30 +872,39 @@ SCM m_cond(xorig, env)
return cons(IM_COND, cdrx);
}
-SCM m_lambda(xorig, env)
- SCM xorig, env;
+static int varcheck(xorig, vars, op, what)
+ SCM xorig, vars;
+ char *op, *what;
{
- SCM proc, x = CDR(xorig);
- int argc = 0; /* Number of required args */
- if (ilength(x) < 2) goto badforms;
- proc = CAR(x);
- if NULLP(proc) goto memlambda;
- if (IM_LET==proc) goto memlambda; /* named let */
- if IMP(proc) goto badforms;
- if IDENTP(proc) goto memlambda;
- if NCONSP(proc) goto badforms;
- while NIMP(proc) {
- if NCONSP(proc)
- if (!IDENTP(proc)) goto badforms;
- else goto memlambda;
- if (!(NIMP(CAR(proc)) && IDENTP(CAR(proc)))) goto badforms;
- proc = CDR(proc);
+ SCM v1, vs;
+ int argc = 0;
+ for (; NIMP(vars) && CONSP(vars); vars = CDR(vars)) {
argc++;
+#ifndef RECKLESS
+ v1 = CAR(vars);
+ if (IMP(v1) || !IDENTP(v1))
+ badvar: wta(xorig, what, op);
+ for (vs = CDR(vars); NIMP(vs) && CONSP(vs); vs = CDR(vs)) {
+ if (v1==CAR(vs))
+ nonuniq: wta(xorig, "non-unique bindings", op);
+ }
+ if (v1==vs) goto nonuniq;
+#endif
}
- if (NNULLP(proc) && (IM_LET != proc)) /* IM_LET inserted by named let. */
- badforms: wta(xorig, s_formals, s_lambda);
- memlambda:
- return cons2(ISYMSETVAL(IM_LAMBDA, argc), CAR(x),
+ /* argc of 3 means no rest argument, 3+ required arguments */
+ if (NULLP(vars) || ISYMP(vars)) return argc > 3 ? 3 : argc;
+ ASRTGO(NIMP(vars) && IDENTP(vars), badvar);
+ return argc > 2 ? 2 : argc;
+}
+SCM m_lambda(xorig, env)
+ SCM xorig, env;
+{
+ SCM x = CDR(xorig);
+ int argc;
+ ASSERT(ilength(x) > 1, xorig, s_formals, s_lambda);
+ argc = varcheck(xorig, CAR(x), s_lambda, s_formals);
+ if (argc > 3) argc = 3;
+ return cons2(MAKISYMVAL(IM_LAMBDA, argc), CAR(x),
m_body(IM_LAMBDA, CDR(x), s_lambda));
}
SCM m_letstar(xorig, env)
@@ -771,17 +935,16 @@ SCM m_letstar(xorig, env)
<body>)
;; becomes
(do_mem (varn ... var2 var1)
- (<init1> <init2> ... <initn>)
+ (<initn> ... <init2> <init1>)
(<test> <return>)
(<body>)
- <step1> <step2> ... <stepn>) ;; missing steps replaced by var
+ <stepn> ... <step2> <step1>) ;; missing steps replaced by var
*/
SCM m_do(xorig, env)
SCM xorig, env;
{
SCM x = CDR(xorig), arg1, proc;
SCM vars = IM_DO, inits = EOL, steps = EOL;
- SCM *initloc = &inits, *steploc = &steps;
int len = ilength(x);
ASSYNT(len >= 2, xorig, s_test, s_do);
proc = CAR(x);
@@ -790,22 +953,20 @@ SCM m_do(xorig, env)
arg1 = CAR(proc);
len = ilength(arg1);
ASSYNT(2==len || 3==len, xorig, s_bindings, s_do);
- ASSYNT(NIMP(CAR(arg1)) && IDENTP(CAR(arg1)), xorig, s_variable, s_do);
/* vars reversed here, inits and steps reversed at evaluation */
vars = cons(CAR(arg1), vars); /* variable */
arg1 = CDR(arg1);
- *initloc = cons(CAR(arg1), EOL); /* init */
- initloc = &CDR(*initloc);
+ inits = cons(CAR(arg1), inits);
arg1 = CDR(arg1);
- *steploc = cons(IMP(arg1)?CAR(vars):CAR(arg1), EOL); /* step */
- steploc = &CDR(*steploc);
+ steps = cons(IMP(arg1)?CAR(vars):CAR(arg1), steps);
proc = CDR(proc);
}
x = CDR(x);
ASSYNT(ilength(CAR(x)) >= 1, xorig, s_test, s_do);
+ ASSYNT(ilength(CDR(x))>=0, xorig, s_expression, s_do);
+ varcheck(xorig, vars, s_do, s_variable);
x = cons2(CAR(x), CDR(x), steps);
x = cons2(vars, inits, x);
- bodycheck(xorig, &CAR(CDR(CDR(x))), s_do);
return cons(IM_DO, x);
}
@@ -832,7 +993,7 @@ static SCM iqq(form)
}
if NCONSP(form) return form;
tmp = CAR(form);
- if (IM_UNQUOTE==tmp)
+ if (IM_UNQUOTE==tmp)
return evalcar(CDR(form));
if (NIMP(tmp) && IM_UQ_SPLICING==CAR(tmp))
return append(cons2(evalcar(CDR(tmp)), iqq(CDR(form)), EOL));
@@ -877,7 +1038,7 @@ static SCM m_iqq(form, depth, env)
}
if (i_unquote==tmp && TOPLEVELP(CAR(form), env)) {
--depth;
- if (0==depth) CAR(form) = IM_UNQUOTE;
+ if (0==depth) CAR(form) = IM_UNQUOTE;
label:
tmp = CDR(form);
ASSERT(NIMP(tmp) && ECONSP(tmp) && NULLP(CDR(tmp)),
@@ -917,6 +1078,20 @@ SCM m_delay(xorig, env)
return cons2(IM_DELAY, EOL, CDR(xorig));
}
+static int built_inp(name, x)
+ SCM name, x;
+{
+ if NIMP(x) {
+ tail:
+ switch TYP7(x) {
+ case tcs_subrs: return CHARS(name)==SNAME(x);
+ case tc7_smob: if MACROP(x) {x = CDR(x); goto tail;}
+ /* else fall through */
+ }
+ }
+ return 0;
+}
+
SCM m_define(x, env)
SCM x, env;
{
@@ -930,7 +1105,7 @@ SCM m_define(x, env)
}
ASSYNT(NIMP(proc) && IDENTP(proc), arg1, s_variable, s_define);
ASSYNT(1==ilength(x), arg1, s_expression, s_define);
- if (NIMP(env) && tc16_env==CAR(env)) {
+ if (NIMP(env) && ENVP(env)) {
DEFER_INTS_EGC;
env = CDR(env);
}
@@ -945,15 +1120,13 @@ SCM m_define(x, env)
arg1 = sym2vcell(proc);
#ifndef RECKLESS
if (2 <= verbose &&
- NIMP(CDR(arg1)) &&
- (proc ==
- ((SCM) SNAME(MACROP(CDR(arg1)) ? CDR(CDR(arg1)) : CDR(arg1))))
+ built_inp(proc, CDR(arg1))
&& (CDR(arg1) != x))
- warn("redefining built-in ", CHARS(proc));
+ scm_warn("redefining built-in ", CHARS(proc));
else
#endif
if (5 <= verbose && UNDEFINED != CDR(arg1))
- warn("redefining ", CHARS(proc));
+ scm_warn("redefining ", CHARS(proc));
CDR(arg1) = x;
#ifdef SICP
return m_quote(cons2(i_quote, CAR(arg1), EOL), EOL);
@@ -962,7 +1135,6 @@ SCM m_define(x, env)
#endif
}
return cons2(IM_DEFINE, proc, x);
- /* return cons2(IM_DEFINE, cons(proc,CAR(CAR(env))), x); */
}
/* end of acros */
@@ -972,24 +1144,17 @@ static SCM m_letrec1(op, imm, xorig, env)
SCM cdrx = CDR(xorig); /* locally mutable version of form */
char *what = CHARS(CAR(xorig));
SCM x = cdrx, proc, arg1; /* structure traversers */
- SCM vars = imm, inits = EOL, *initloc = &inits;
-
+ SCM vars = imm, inits = EOL;
/* ASRTSYNTAX(ilength(x) >= 2, s_body); */
proc = CAR(x);
-#if 0
- if NULLP(proc) /* null binding, let* faster */
- return m_letstar(cons2(CAR(xorig), EOL, m_body(imm, CDR(x), what)), env);
-#endif
ASRTSYNTAX(ilength(proc) >= 1, s_bindings);
do {
- /* vars list reversed here, inits reversed at evaluation */
arg1 = CAR(proc);
ASRTSYNTAX(2==ilength(arg1), s_bindings);
- ASRTSYNTAX(NIMP(CAR(arg1)) && IDENTP(CAR(arg1)), s_variable);
vars = cons(CAR(arg1), vars);
- *initloc = cons(CAR(CDR(arg1)), EOL);
- initloc = &CDR(*initloc);
+ inits = cons(CAR(CDR(arg1)), inits);
} while NIMP(proc = CDR(proc));
+ varcheck(xorig, vars, what, s_variable);
return cons2(op, vars, cons(inits, m_body(imm, CDR(x), what)));
}
@@ -1039,9 +1204,8 @@ SCM m_let(xorig, env)
proc = CDR(proc);
}
proc = cons2(TOPRENAME(i_lambda), vars, m_body(IM_LET, CDR(x), s_let));
- proc = cons2(i_let, cons(cons2(name, proc, EOL), EOL),
- acons(name, inits, EOL));
- return m_letrec1(IM_LETREC, IM_LET, proc, env);
+ proc = cons2(i_let, cons(cons2(name, proc, EOL), EOL), cons(name, EOL));
+ return cons(m_letrec1(IM_LETREC, IM_LET, proc, env), inits);
}
#define s_atapply (ISYMCHARS(IM_APPLY)+1)
@@ -1053,7 +1217,7 @@ SCM m_apply(xorig, env)
return cons(IM_APPLY, CDR(xorig));
}
-SCM m_expand_body(xorig)
+static SCM m_expand_body(xorig)
SCM xorig;
{
SCM form, x = CDR(xorig), defs = EOL;
@@ -1063,7 +1227,7 @@ SCM m_expand_body(xorig)
if (IMP(form) || NCONSP(form)) break;
if IMP(CAR(form)) break;
if (! IDENTP(CAR(form))) break;
- form = macroexp1(cons(CAR(form), CDR(form)), 0);
+ form = macroexp1(form, defs);
if (IM_DEFINE==CAR(form)) {
defs = cons(CDR(form), defs);
x = CDR(x);
@@ -1091,109 +1255,59 @@ SCM m_expand_body(xorig)
return xorig;
}
-static SCM macroexp1(x, check)
- SCM x;
- int check;
+static SCM macroexp1(x, defs)
+ SCM x, defs;
{
- SCM res, proc;
+ SCM res = UNDEFINED, proc = CAR(x);
int argc;
- ASRTGO(IDENTP(CAR(x)), badfun);
+ ASRTGO(IDENTP(proc), badfun);
macro_tail:
- proc = *lookupcar(x, 0);
+ res = CAR(x);
+ proc = *lookupcar(x, IMP(defs) ? LOOKUP_UNDEFP : 0);
if (NIMP(proc) && MACROP(proc)) {
- unmemocar(x);
- res = apply(CDR(proc), cons2(x, wrapenv(), EOL), EOL);
+ CAR(x) = res;
+ res = cons2(x, wrapenv(), EOL);
switch ((int)(CAR(proc)>>16) & 0x7f) {
- case 2: /* mmacro */
- if (ilength(res) <= 0)
- res = cons2(IM_BEGIN, res, EOL);
- DEFER_INTS;
- CAR(x) = CAR(res);
- CDR(x) = CDR(res);
- ALLOW_INTS;
- break;
- case 1: /* macro */
+ case 2: case 6: /* mmacro */
+ if (IMP(defs)) {
+ res = apply(CDR(proc), res, EOL);
+ if (ilength(res) <= 0)
+ res = cons2(IM_BEGIN, res, EOL);
+ DEFER_INTS;
+ CAR(x) = CAR(res);
+ CDR(x) = CDR(res);
+ ALLOW_INTS;
+ break;
+ }
+ /* else fall through */
+ case 1: case 5: /* macro */
+ res = apply(CDR(proc), res, EOL);
x = NIMP(res) ? res : cons2(IM_BEGIN, res, EOL);
break;
- case 0: /* acro */
+ case 0: case 4: /* acro */
+ res = IMP(defs) ? apply(CDR(proc), res, EOL) : UNSPECIFIED;
return cons2(IM_QUOTE, res, EOL);
}
if (NIMP(CAR(x)) && IDENTP(CAR(x))) goto macro_tail;
#ifndef RECKLESS
- if (check && IM_DEFINE==CAR(x))
- everr(x, wrapenv() /*scm_env*/, i_define, "Bad placement", "");
+ if (UNBNDP(defs) && IM_DEFINE==CAR(x))
+ everr(x, wrapenv(), i_define, "Bad placement", "");
#endif
return x;
}
- else if (!check) {
- unmemocar(x);
- return x;
- }
-#ifdef RECKLESS
- return x;
-#else
- ASRTGO(NIMP(proc), badfun);
- argc = ilength(CDR(x));
-# ifdef CCLO
- cclo_tail:
-# endif
- switch TYP7(proc) {
- default:
- badfun:
- unmemocar(x);
- everr(x, wrapenv(), UNBNDP(proc) ? CAR(x) : proc,
- UNBNDP(proc) ? s_unbnd : s_wtap, "");
- case tc7_lsubr:
- case tc7_rpsubr:
- case tc7_asubr:
- return x;
- case tc7_subr_0:
- ASRTGO(0==argc, wrongnumargs);
- return x;
- case tc7_contin:
- case tc7_subr_1:
- case tc7_cxr:
- ASRTGO(1==argc, wrongnumargs);
- return x;
- case tc7_subr_2:
- ASRTGO(2==argc, wrongnumargs);
- return x;
- case tc7_subr_3:
- ASRTGO(3==argc, wrongnumargs);
- return x;
- case tc7_subr_1o:
- ASRTGO(0==argc || 1==argc, wrongnumargs);
- return x;
- case tc7_subr_2o:
- ASRTGO(1==argc || 2==argc, wrongnumargs);
- return x;
- case tc7_lsubr_2:
- ASRTGO(2<=argc, wrongnumargs);
- return x;
- case tc7_specfun:
- switch TYP16(proc) {
- case tc16_apply:
- ASRTGO(2<=argc, wrongnumargs);
- return x;
- case tc16_call_cc:
- ASRTGO(1==argc, wrongnumargs);
- return x;
-# ifdef CCLO
- case tc16_cclo:
- proc = CCLO_SUBR(proc);
- argc++;
- goto cclo_tail;
-# endif
+#ifndef RECKLESS
+ if (IMP(defs)) {
+ if (! scm_arity_check(proc, ilength(CDR(x)), (char *)0)) {
+ badfun:
+ if (!UNBNDP(res)) CAR(x) = res;
+ everr(x, wrapenv(), UNBNDP(proc) ? CAR(x) : proc,
+ UNBNDP(proc) ? s_unbnd :
+ (FALSEP(procedurep(proc)) ? s_wtap : (char *)WNA),
+ "");
}
- case tcs_closures:
- if (badargsp(proc, CDR(x))) {
- wrongnumargs:
- unmemocar(x);
- everr(x, wrapenv()/*scm_env*/, proc, (char *)WNA, "");
- }
- return x;
}
#endif /* ndef RECKLESS */
+ return x;
}
#ifndef RECKLESS
@@ -1209,6 +1323,62 @@ int badargsp(proc, args)
}
return NNULLP(args) ? 1 : 0;
}
+/* If what is null, signals error instead of returning false. */
+int scm_arity_check(proc, argc, what)
+ SCM proc;
+ long argc;
+ char *what;
+{
+ SCM p = proc;
+ if (IMP(p))
+ return 0;
+ cclo_tail:
+ switch TYP7(p) {
+ default:
+ badproc:
+ if (what) wta(proc, (char *)ARG1, what);
+ return 0;
+ wrongnumargs:
+ if (what) wta(proc, (char *)WNA, what);
+ return 0;
+ case tc7_subr_0: ASRTGO(0==argc, wrongnumargs) return !0;
+ case tc7_cxr:
+ case tc7_contin:
+ case tc7_subr_1: ASRTGO(1==argc, wrongnumargs) return !0;
+ case tc7_subr_1o: ASRTGO(0==argc || 1==argc, wrongnumargs) return !0;
+ case tc7_subr_2: ASRTGO(2==argc, wrongnumargs) return !0;
+ case tc7_subr_2o: ASRTGO( 1==argc || 2==argc, wrongnumargs) return !0;
+ case tc7_subr_3: ASRTGO(3==argc, wrongnumargs) return !0;
+ case tc7_rpsubr:
+ case tc7_asubr:
+ case tc7_lsubr: return !0;
+ case tc7_lsubr_2: ASRTGO(2<=argc, wrongnumargs) return !0;
+ case tc7_specfun:
+ switch TYP16(proc) {
+ case tc16_apply: ASRTGO(2<=argc, wrongnumargs) return !0;
+ case tc16_call_cc:
+ case tc16_eval: ASRTGO(1==argc, wrongnumargs) return !0;
+# ifdef CCLO
+ case tc16_cclo:
+ p = CCLO_SUBR(p);
+ argc++;
+ goto cclo_tail;
+# endif
+ }
+ case tcs_closures:
+ {
+ SCM formals = CAR(CODE(p));
+ while (argc--) {
+ if IMP(formals) goto wrongnumargs;
+ if (CONSP(formals))
+ formals = CDR(formals);
+ else
+ return !0;
+ }
+ ASRTGO(IMP(formals) || NCONSP(formals), wrongnumargs);
+ }
+ }
+}
#endif
char s_map[] = "map", s_for_each[] = "for-each", s_eval[] = "eval";
@@ -1219,19 +1389,23 @@ static SCM wrapenv()
register SCM z;
NEWCELL(z);
DEFER_INTS_EGC;
+ if (NIMP(scm_env) && ENVP(scm_env))
+ return scm_env;
CDR(z) = scm_env;
CAR(z) = tc16_env;
- EGC_ROOT(z);
+ EGC_ROOT(z);
return z;
}
SCM ceval(x, env)
SCM x, env;
{
- DEFER_INTS_EGC;
ENV_PUSH;
- scm_env = env;
+#ifdef CAUTIOUS
+ scm_trace = UNSPECIFIED;
+#endif
TRACE(x);
+ scm_env = env;
x = ceval_1(x);
ENV_POP;
ALLOW_INTS_EGC;
@@ -1245,9 +1419,14 @@ static SCM ceval_1(x)
SCM proc, arg2, arg3;
int envpp = 0; /* 1 means an environment has been pushed in this
invocation of ceval_1, -1 means pushed and then popped. */
+#ifdef CAUTIOUS
+ SCM xorig;
+#endif
CHECK_STACK;
loop: POLL;
- TRACE(x);
+#ifdef CAUTIOUS
+ xorig = x;
+#endif
#ifdef SCM_PROFILE
eval_cases[TYP7(x)]++;
#endif
@@ -1283,18 +1462,17 @@ static SCM ceval_1(x)
if NCELLP(CAR(x)) {
x = CAR(x);
x = IMP(x) ? EVALIMP(x) : I_VAL(x);
- goto retx;
}
-
- if ATOMP(CAR(x)) {
+ else if ATOMP(CAR(x))
x = evalatomcar(x);
- retx:
- ENV_MAY_POP(envpp, 0);
- ALLOW_INTS_EGC;
- return x;
+ else {
+ x = CAR(x);
+ goto loop; /* tail recurse */
}
- x = CAR(x);
- goto loop; /* tail recurse */
+ retx:
+ ENV_MAY_POP(envpp, 0);
+ ALLOW_INTS_EGC;
+ return x;
case (127 & IM_CASE):
x = CDR(x);
@@ -1321,10 +1499,8 @@ static SCM ceval_1(x)
proc = CDR(proc);
}
}
- retunspec:
- ENV_MAY_POP(envpp, 0);
- ALLOW_INTS_EGC;
- return UNSPECIFIED;
+ x = UNSPECIFIED;
+ goto retx;
case (127 & IM_COND):
while(NIMP(x = CDR(x))) {
proc = CAR(x);
@@ -1342,16 +1518,13 @@ static SCM ceval_1(x)
goto evap1;
}
}
- goto retunspec;
+ x = UNSPECIFIED;
+ goto retx;
case (127 & IM_DO):
ENV_MAY_PUSH(envpp);
+ TRACE(x);
x = CDR(x);
- proc = CAR(CDR(x)); /* inits */
- scm_env_tmp = EOL; /* values */
- while NIMP(proc) {
- scm_env_cons_tmp(EVALCAR(proc));
- proc = CDR(proc);
- }
+ ecache_evalx(CAR(CDR(x))); /* inits */
EXTEND_ENV(CAR(x));
x = CDR(CDR(x));
while (proc = CAR(x), FALSEP(EVALCAR(proc))) {
@@ -1359,51 +1532,42 @@ static SCM ceval_1(x)
t.arg1 = CAR(proc); /* body */
SIDEVAL_1(t.arg1);
}
- scm_env_tmp = EOL;
- for(proc = CDR(CDR(x)); NIMP(proc); proc = CDR(proc)) {
- scm_env_cons_tmp(EVALCAR(proc)); /* steps */
- }
- DEFER_INTS_EGC;
+ ecache_evalx(CDR(CDR(x))); /* steps */
t.arg1 = CAR(CAR(scm_env));
scm_env = CDR(scm_env);
EXTEND_ENV(t.arg1);
}
x = CDR(proc);
- if NULLP(x) goto retunspec;
+ if NULLP(x) {x = UNSPECIFIED; goto retx;}
goto begin;
case (127 & IM_IF):
x = CDR(x);
if NFALSEP(EVALCAR(x)) x = CDR(x);
- else if IMP(x = CDR(CDR(x))) goto retunspec;
+ else if IMP(x = CDR(CDR(x))) {x = UNSPECIFIED; goto retx;}
goto carloop;
case (127 & IM_LET):
ENV_MAY_PUSH(envpp);
+ TRACE(x);
x = CDR(x);
- proc = CAR(CDR(x));
- scm_env_tmp = EOL;
- do {
- scm_env_cons_tmp(EVALCAR(proc));
- } while NIMP(proc = CDR(proc));
+ ecache_evalx(CAR(CDR(x)));
EXTEND_ENV(CAR(x));
x = CDR(x);
goto cdrxbegin;
case (127 & IM_LETREC):
ENV_MAY_PUSH(envpp);
+ TRACE(x);
x = CDR(x);
scm_env_tmp = undefineds;
EXTEND_ENV(CAR(x));
x = CDR(x);
- proc = CAR(x);
- scm_env_tmp = EOL;
- do {
- scm_env_cons_tmp(EVALCAR(proc));
- } while NIMP(proc = CDR(proc));
+ ecache_evalx(CAR(x));
EGC_ROOT(CAR(scm_env));
CDR(CAR(scm_env)) = scm_env_tmp;
scm_env_tmp = EOL;
goto cdrxbegin;
case (127 & IM_LETSTAR):
ENV_MAY_PUSH(envpp);
+ TRACE(x);
x = CDR(x);
proc = CAR(x);
if IMP(proc) {
@@ -1439,10 +1603,13 @@ static SCM ceval_1(x)
proc = CAR(x);
switch (7 & (int)proc) {
case 0:
- if CONSP(proc)
- *farlookup(proc) = arg2;
- else
- *lookupcar(x, LOOKUP_UNDEFP|LOOKUP_MACROP) = arg2;
+ if ECONSP(proc)
+ if ISYMP(CAR(proc)) *farlookup(proc) = arg2;
+ else {
+ x = scm_multi_set(proc, arg2);
+ goto retx;
+ }
+ else *lookupcar(x, LOOKUP_UNDEFP|LOOKUP_MACROP) = arg2;
break;
case 1:
I_VAL(proc) = arg2;
@@ -1453,26 +1620,12 @@ static SCM ceval_1(x)
}
#ifdef SICP
x = arg2;
- goto retx;
+#else
+ x = UNSPECIFIED;
#endif
- goto retunspec;
+ goto retx;
case (127 & IM_DEFINE): /* only for internal defines */
goto badfun;
-#if 0
- x = CDR(x);
- proc = CAR(x);
- x = CDR(x);
- x = evalcar(x);
- DEFER_INTS_EGC;
- scm_env_tmp = CDR(CAR(scm_env));
- scm_env_cons_tmp(x);
- EGC_ROOT(CAR(scm_env));
- /* DEFER_INTS; */
- CAR(CAR(scm_env)) = proc;
- CDR(CAR(scm_env)) = scm_env_tmp;
- /* ALLOW_INTS; */
- goto retunspec;
-#endif
/* new syntactic forms go here. */
case (127 & MAKISYM(0)):
proc = CAR(x);
@@ -1482,13 +1635,13 @@ static SCM ceval_1(x)
#endif
switch ISYMNUM(proc) {
case (ISYMNUM(IM_APPLY)):
- proc = CDR(x);
- proc = EVALCAR(proc);
+ x = CDR(x);
+ proc = evalcar(x);
ASRTGO(NIMP(proc), badfun);
- t.arg1 = CDR(CDR(x));
- t.arg1 = EVALCAR(t.arg1);
+ t.arg1 = evalcar(CDR(x));
if (CLOSUREP(proc)) {
ENV_MAY_PUSH(envpp);
+ TRACE(x);
scm_env_tmp = t.arg1;
#ifndef RECKLESS
goto clo_checked;
@@ -1497,7 +1650,7 @@ static SCM ceval_1(x)
#endif
}
x = apply(proc, t.arg1, EOL);
- goto retx;
+ goto retx;
case (ISYMNUM(IM_DELAY)):
x = makprom(closure(CDR(x), 0));
goto retx;
@@ -1515,11 +1668,12 @@ static SCM ceval_1(x)
default:
proc = x;
badfun:
- everr(x, wrapenv() /*scm_env*/, proc, s_wtap, "");
+#ifdef CAUTIOUS
+ scm_trace = UNDEFINED;
+#endif
+ everr(x, wrapenv(), proc, s_wtap, "");
case tc7_vector:
- case tc7_bvect: case tc7_ivect: case tc7_uvect:
- case tc7_fvect: case tc7_dvect: case tc7_cvect:
- case tc7_string:
+ case tcs_uves:
case tc7_smob:
goto retx;
case (127 & ILOC00):
@@ -1530,18 +1684,28 @@ static SCM ceval_1(x)
break;
case tcs_cons_nimcar:
if ATOMP(CAR(x)) {
- x = macroexp1(x, !0);
+ TOP_TRACE(x);
+#ifdef MEMOIZE_LOCALS
+ x = macroexp1(x, UNDEFINED);
goto loop;
+#else
+ proc = *lookupcar(x, 0);
+ if (NIMP(proc) && MACROP(proc)) {
+ x = macroexp1(x, UNDEFINED);
+ goto loop;
+ }
+#endif
}
- proc = ceval_1(CAR(x));
+ else proc = ceval_1(CAR(x));
/* At this point proc is the evaluated procedure from the function
position and x has the form which is being evaluated. */
}
ASRTGO(NIMP(proc), badfun);
- *scm_estk_ptr = scm_env; /* For error reporting at wrongnumargs. */
+ scm_estk_ptr[0] = scm_env; /* For error reporting at wrongnumargs. */
if NULLP(CDR(x)) {
evap0:
ENV_MAY_POP(envpp, CLOSUREP(proc));
+ TOP_TRACE(xorig);
ALLOW_INTS_EGC;
switch TYP7(proc) { /* no arguments given */
case tc7_subr_0:
@@ -1582,6 +1746,7 @@ static SCM ceval_1(x)
x = CODE(proc);
scm_env = ENV(proc);
EXTEND_ENV(CAR(x));
+ TRACE(CDR(x));
goto cdrxbegin;
case tc7_specfun:
#ifdef CCLO
@@ -1603,9 +1768,10 @@ static SCM ceval_1(x)
wrongnumargs:
if (envpp < 0) {
scm_estk_ptr += SCM_ESTK_FRLEN;
- scm_env = *scm_estk_ptr;
+ scm_env = scm_estk_ptr[0];
}
- everr(x, wrapenv()/*scm_env*/, proc, (char *)WNA, "");
+ TOP_TRACE(UNDEFINED);
+ everr(x, wrapenv(), proc, (char *)WNA, "");
default:
goto badfun;
}
@@ -1619,6 +1785,7 @@ static SCM ceval_1(x)
if NULLP(x) {
evap1:
ENV_MAY_POP(envpp, CLOSUREP(proc));
+ TOP_TRACE(xorig);
ALLOW_INTS_EGC;
switch TYP7(proc) { /* have one argument in t.arg1 */
case tc7_subr_2o:
@@ -1639,16 +1806,19 @@ evap1:
return makdbl(DSUBRF(proc)(big2dbl(t.arg1)), 0.0);
# endif
floerr:
- wta(t.arg1, (char *)ARG1, CHARS(SNAME(proc)));
+ wta(t.arg1, (char *)ARG1, SNAME(proc));
}
#endif
- proc = (SCM)SNAME(proc);
{
- char *chrs = CHARS(proc)+LENGTH(proc)-1;
- while('c' != *--chrs) {
+ int op = CXR_OP(proc);
+#ifndef RECKLESS
+ x = t.arg1;
+#endif
+ while (op) {
ASSERT(NIMP(t.arg1) && CONSP(t.arg1),
- t.arg1, ARG1, CHARS(proc));
- t.arg1 = ('a'==*chrs)?CAR(t.arg1):CDR(t.arg1);
+ x, ARG1, SNAME(proc));
+ t.arg1 = (1 & op ? CAR(t.arg1) : CDR(t.arg1));
+ op >>= 2;
}
return t.arg1;
}
@@ -1672,7 +1842,7 @@ evap1:
goto clo_checked;
}
case tc7_contin:
- scm_dynthrow(CONT(proc), t.arg1);
+ scm_dynthrow(proc, t.arg1);
case tc7_specfun:
switch TYP16(proc) {
case tc16_call_cc:
@@ -1684,10 +1854,19 @@ evap1:
#ifdef SHORT_INT
x = (SCM)thrown_value;
#endif
+#ifdef CHEAP_CONTINUATIONS
+ envpp = 0;
+#endif
goto retx;
}
ASRTGO(NIMP(proc), badfun);
goto evap1;
+ case tc16_eval:
+ ENV_MAY_PUSH(envpp);
+ TRACE(x);
+ scm_env = EOL;
+ x = cons(copytree(t.arg1), EOL);
+ goto begin;
#ifdef CCLO
case tc16_cclo:
arg2 = t.arg1;
@@ -1714,6 +1893,7 @@ evap1:
if NULLP(x) { /* have two arguments */
evap2:
ENV_MAY_POP(envpp, CLOSUREP(proc));
+ TOP_TRACE(xorig);
ALLOW_INTS_EGC;
switch TYP7(proc) {
case tc7_subr_2:
@@ -1745,9 +1925,12 @@ evap1:
apply4:
if NULLP(x) goto evap2;
ASRTGO(NIMP(x) && CONSP(x), badlst);
- arg3 = CAR(x);
- ASRTGO(0 <= ilength(x), badlst);
- x = copy_list(CDR(x));
+ arg3 = x;
+ x = copy_list(CDR(x), 0);
+#ifndef RECKLESS
+ if UNBNDP(x) {x = arg3; goto badlst;}
+#endif
+ arg3 = CAR(arg3);
goto evap3;
#ifdef CCLO
case tc16_cclo: cclon:
@@ -1775,15 +1958,15 @@ evap1:
eval_clo_cases[2][ARGC(proc)]++;
#endif
switch ARGC(proc) {
- case 2:
+ case 2:
scm_env_cons2(t.arg1, arg2, EOL);
goto clo_unchecked;
case 1:
scm_env_cons(t.arg1, cons(arg2, EOL));
goto clo_checked;
- case 0:
+ case 0:
case 3: /* Error, will be caught at clo_checked: */
- scm_env_tmp = cons2(t.arg1, arg2, EOL);
+ scm_env_tmp = cons2(t.arg1, arg2, EOL);
goto clo_checked;
}
}
@@ -1791,23 +1974,27 @@ evap1:
{ /* have 3 or more arguments */
arg3 = EVALCAR(x);
x = CDR(x);
- if NIMP(x) x = eval_args(x);
+ if NIMP(x) {
+ if (CLOSUREP(proc) && 3==ARGC(proc)) {
+ ENV_MAY_PUSH(envpp);
+ if (ecache_eval_args(proc, t.arg1, arg2, arg3, x))
+ goto clo_unchecked;
+ goto umwrongnumargs;
+ }
+ x = eval_args(x);
+ }
evap3:
- ENV_MAY_POP(envpp, CLOSUREP(proc));
+ ENV_MAY_POP(envpp, CLOSUREP(proc));
+ TOP_TRACE(xorig);
ALLOW_INTS_EGC;
switch TYP7(proc) {
case tc7_subr_3:
ASRTGO(NULLP(x), wrongnumargs);
return SUBRF(proc)(t.arg1, arg2, arg3);
case tc7_asubr:
- /* t.arg1 = SUBRF(proc)(t.arg1, arg2);
- while NIMP(x) {
- t.arg1 = SUBRF(proc)(t.arg1, EVALCAR(x, env));
- x = CDR(x);
- }
- return t.arg1; */
case tc7_rpsubr:
- return apply(proc, cons2(t.arg1, arg2, cons(arg3, x)), EOL);
+ return asubr_apply(proc, t.arg1, arg2, arg3, x);
+ /* return apply(proc, cons2(t.arg1, arg2, cons(arg3, x)), EOL); */
case tc7_lsubr_2:
return SUBRF(proc)(t.arg1, arg2, cons(arg3, x));
case tc7_lsubr:
@@ -1928,22 +2115,35 @@ SCM nconc2copy(lst)
}
return lst;
}
-/* Shallow copy */
-SCM copy_list(lst)
+/* Shallow copy. If LST is not a proper list of length at least
+ MINLEN, returns UNDEFINED */
+SCM copy_list(lst, minlen)
SCM lst;
+ int minlen;
{
SCM res, *lloc = &res;
res = EOL;
- for(; NIMP(lst); lst = CDR(lst)) {
+ for(; NIMP(lst) && CONSP(lst); lst = CDR(lst)) {
*lloc = cons(CAR(lst), EOL);
lloc = &CDR(*lloc);
+ minlen--;
}
+ if (NULLP(lst) && minlen <= 0)
+ return res;
+ return UNDEFINED;
+}
+SCM scm_v2lst(n, v)
+ long n;
+ SCM *v;
+{
+ SCM res = EOL;
+ for(n--; n >= 0; n--) res = cons(v[n], res);
return res;
}
+static SCM f_apply_closure;
SCM apply(proc, arg1, args)
SCM proc, arg1, args;
{
- apply_tail:
ASRTGO(NIMP(proc), badproc);
if NULLP(args)
if NULLP(arg1) arg1 = UNDEFINED;
@@ -1951,13 +2151,16 @@ SCM apply(proc, arg1, args)
args = CDR(arg1);
arg1 = CAR(arg1);
}
- else {
- /* ASRTGO(NIMP(args) && CONSP(args), wrongnumargs); */
+ else
args = nconc2copy(args);
- }
cc_tail:
ALLOW_INTS_EGC;
switch TYP7(proc) {
+ default:
+ badproc:
+ wta(proc, (char *)ARG1, s_apply);
+ wrongnumargs:
+ wta(proc, (char *)WNA, s_apply);
case tc7_subr_2o:
if NULLP(args) {
args = UNDEFINED;
@@ -1992,13 +2195,16 @@ SCM apply(proc, arg1, args)
wta(arg1, (char *)ARG1, CHARS(SNAME(proc)));
}
#endif
- proc = (SCM)SNAME(proc);
{
- char *chrs = CHARS(proc)+LENGTH(proc)-1;
- while('c' != *--chrs) {
+ int op = CXR_OP(proc);
+#ifndef RECKLESS
+ args = arg1;
+#endif
+ while (op) {
ASSERT(NIMP(arg1) && CONSP(arg1),
- arg1, ARG1, CHARS(proc));
- arg1 = ('a'==*chrs)?CAR(arg1):CDR(arg1);
+ args, ARG1, SNAME(proc));
+ arg1 = (1 & op ? CAR(arg1) : CDR(arg1));
+ op >>= 2;
}
return arg1;
}
@@ -2033,134 +2239,275 @@ SCM apply(proc, arg1, args)
#ifndef RECKLESS
if (badargsp(proc, arg1)) goto wrongnumargs;
#endif
- DEFER_INTS_EGC;
ENV_PUSH;
- TRACE(proc);
+ PUSH_TRACE;
scm_env_tmp = arg1;
scm_env = ENV(proc);
- EXTEND_ENV(CAR(CODE(proc)));
proc = CODE(proc);
- arg1 = ceval_1(cons(IM_BEGIN, CDR(proc)));
- /* while NNULLP(proc = CDR(proc)) arg1 = EVALCAR(proc); */
+ EXTEND_ENV(CAR(proc));
+ proc = CDR(proc);
+ while NNULLP(proc) {
+ if (IMP(CAR(proc)) && ISYMP(CAR(proc))) {
+ proc = m_expand_body(proc);
+ continue;
+ }
+ arg1 = EVALCAR(proc);
+ proc = CDR(proc);
+ }
ENV_POP;
+ ALLOW_INTS_EGC;
return arg1;
case tc7_contin:
ASRTGO(NULLP(args), wrongnumargs);
- scm_dynthrow(CONT(proc), arg1);
+ scm_dynthrow(proc, arg1);
case tc7_specfun:
- switch TYP16(proc) {
- case tc16_apply:
- ASRTGO(!UNBNDP(arg1), wrongnumargs);
- proc = arg1;
- arg1 = args;
- args = EOL;
- goto apply_tail;
- case tc16_call_cc:
- ASRTGO(NULLP(args), wrongnumargs);
- proc = arg1;
- ASRTGO(NIMP(proc), badproc);
- DEFER_INTS_EGC;
- arg1 = scm_make_cont();
- EGC_ROOT(arg1);
- if ((args = setjump(CONT(arg1)->jmpbuf))) {
-#ifdef SHORT_INT
- args = (SCM)thrown_value;
+ args = UNBNDP(arg1) ? EOL : cons(arg1, args);
+ arg1 = proc;
+#ifdef CCLO
+ proc = (TYP16(proc)==tc16_cclo ? CCLO_SUBR(proc) : f_apply_closure);
+#else
+ proc = f_apply_closure;
+#endif
+ goto cc_tail;
+ }
+}
+
+/* This function does not check that proc is a procedure, nor the
+ number of arguments, call scm_arity_check to do that. */
+SCM scm_cvapply(proc, n, argv)
+ SCM proc, *argv;
+ long n;
+{
+ SCM res;
+ long i;
+ tail:
+ ALLOW_INTS_EGC;
+ switch TYP7(proc) {
+ default: return UNSPECIFIED;
+ case tc7_subr_2o:
+ if (1==n) return SUBRF(proc)(argv[0], UNDEFINED);
+ /* Fall through */
+ case tc7_subr_2:
+ return SUBRF(proc)(argv[0], argv[1]);
+ case tc7_subr_0:
+ subr0:
+ return SUBRF(proc)();
+ case tc7_subr_1o:
+ if (0==n) return SUBRF(proc)(UNDEFINED);
+ /* Fall through */
+ case tc7_subr_1:
+ return SUBRF(proc)(argv[0]);
+ case tc7_cxr:
+#ifdef FLOATS
+ if SUBRF(proc) {
+ if INUMP(argv[0])
+ return makdbl(DSUBRF(proc)((double) INUM(argv[0])), 0.0);
+ ASRTGO(NIMP(argv[0]), floerr);
+ if REALP(argv[0])
+ return makdbl(DSUBRF(proc)(REALPART(argv[0])), 0.0);
+# ifdef BIGDIG
+ if BIGP(argv[0])
+ return makdbl(DSUBRF(proc)(big2dbl(argv[0])), 0.0);
+# endif
+ floerr:
+ wta(argv[0], (char *)ARG1, CHARS(SNAME(proc)));
+ }
#endif
- return args;
+ {
+ int op = CXR_OP(proc);
+ res = argv[0];
+ while (op) {
+ ASSERT(NIMP(res) && CONSP(res),
+ argv[0], ARG1, SNAME(proc));
+ res = (1 & op ? CAR(res) : CDR(res));
+ op >>= 2;
}
- args = EOL;
- goto cc_tail;
-#ifdef CCLO
- case tc16_cclo:
- args = (UNBNDP(arg1) ? EOL : cons(arg1, args));
- arg1 = proc;
- proc = CCLO_SUBR(proc);
- goto cc_tail;
+ return res;
+ }
+ case tc7_subr_3:
+ return SUBRF(proc)(argv[0], argv[1], argv[2]);
+ case tc7_lsubr:
+ return SUBRF(proc)(0==n ? EOL : scm_v2lst(n, argv));
+ case tc7_lsubr_2:
+ return SUBRF(proc)(argv[0], argv[1],
+ 2==n ? EOL : scm_v2lst(n-2, &argv[2]));
+ case tc7_asubr:
+ if (1 >= n) return SUBRF(proc)(0==n ? UNDEFINED : argv[0], UNDEFINED);
+ res = argv[0];
+ for (i = 1; i < n; i++)
+ res = SUBRF(proc)(res, argv[i]);
+ return res;
+ case tc7_rpsubr:
+ if (1 >= n) return BOOL_T;
+ for (i = 0; i < n-1; i++)
+ if FALSEP(SUBRF(proc)(argv[i], argv[i+1])) return BOOL_F;
+ return BOOL_T;
+ case tcs_closures:
+ ENV_PUSH;
+ PUSH_TRACE;
+ i = ARGC(proc);
+ if (3==i) {
+ scm_env_tmp = EOL;
+ scm_env_v2lst((int)n, argv);
+ }
+ else {
+ scm_env_tmp = (i < n) ? scm_v2lst(n-i, &argv[i]) : EOL;
+ if (i>0)
+ scm_env_v2lst((int)i, argv);
+ }
+ scm_env = ENV(proc);
+ proc = CODE(proc);
+ EXTEND_ENV(CAR(proc));
+ proc = CDR(proc);
+ while NNULLP(proc) {
+ if (IMP(CAR(proc)) && ISYMP(CAR(proc))) {
+ proc = m_expand_body(proc);
+ continue;
+ }
+ res = EVALCAR(proc);
+ proc = CDR(proc);
+ }
+ ENV_POP;
+ ALLOW_INTS_EGC;
+ return res;
+ case tc7_contin:
+ scm_dynthrow(proc, argv[0]);
+ case tc7_specfun:
+ if (tc16_apply==TYP16(proc)) {
+ proc = argv[0];
+ argv++;
+ n--;
+#ifndef RECKLESS
+ scm_arity_check(proc, n, s_apply);
#endif
+ goto tail;
}
- goto badproc;
- wrongnumargs:
- wta(proc, (char *)WNA, s_apply);
- default:
- badproc:
- wta(proc, (char *)ARG1, s_apply);
- return arg1;
+ res = cons(proc, 0==n ? EOL : scm_v2lst(n, argv));
+#ifdef CCLO
+ proc = (TYP16(proc)==tc16_cclo ? CCLO_SUBR(proc) : f_apply_closure);
+#else
+ proc = f_apply_closure;
+#endif
+ return apply(proc, res, EOL);
}
}
SCM map(proc, arg1, args)
SCM proc, arg1, args;
{
- long i;
- SCM res = EOL, *pres = &res;
- SCM *ve;
- scm_protect_temp(&args); /* Keep args from being optimized away. */
- if NULLP(arg1) return res;
- ASSERT(NIMP(arg1), arg1, ARG2, s_map);
- if NULLP(args) {
- while NIMP(arg1) {
- ASSERT(CONSP(arg1), arg1, ARG2, s_map);
- *pres = cons(apply(proc, CAR(arg1), listofnull), EOL);
- pres = &CDR(*pres);
- arg1 = CDR(arg1);
- }
- return res;
- }
- args = vector(cons(arg1, args));
- ve = VELTS(args);
+ SCM res = EOL, *pres = &res;
+ SCM heap_ve, auto_ve[5], auto_ave[5];
+ SCM *ve = auto_ve, *ave = auto_ave;
+ long i, n = ilength(args) + 1;
+ scm_protect_temp(&heap_ve); /* Keep heap_ve from being optimized away. */
+ if NULLP(arg1) return res;
+#ifdef CAUTIOUS
+ ENV_PUSH;
+ PUSH_TRACE;
+#endif
#ifndef RECKLESS
- for(i = LENGTH(args)-1; i >= 0; i--)
- ASSERT(NIMP(ve[i]) && CONSP(ve[i]), args, ARG2, s_map);
-#endif
- while (1) {
- arg1 = EOL;
- for (i = LENGTH(args)-1;i >= 0;i--) {
- if IMP(ve[i]) return res;
- arg1 = cons(CAR(ve[i]), arg1);
- ve[i] = CDR(ve[i]);
- }
- *pres = cons(apply(proc, arg1, EOL), EOL);
- pres = &CDR(*pres);
- }
+ scm_arity_check(proc, n, s_map);
+#endif
+ ASSERT(NIMP(arg1), arg1, ARG2, s_map);
+#ifdef CCLO
+ if (tc16_cclo==TYP16(proc)) {
+ args = cons(arg1, args);
+ arg1 = cons(proc, EOL);
+ SETCDR(arg1, arg1); /* circular list */
+ proc = CCLO_SUBR(proc);
+ n++;
+ }
+#endif
+ if (n > 5) {
+ heap_ve = make_vector(MAKINUM(2*n), BOOL_F);
+ ve = VELTS(heap_ve);
+ ave = &(ve[n]);
+ }
+ ve[0] = arg1;
+ ASSERT(NIMP(ve[0]) && CONSP(ve[0]), arg1, ARG2, s_map);
+ for (i = 1; i < n; i++) {
+ ve[i] = CAR(args);
+ ASSERT(NIMP(ve[i]) && CONSP(ve[i]), args, ARGn, s_map);
+ args = CDR(args);
+ }
+ while (1) {
+ arg1 = EOL;
+ for (i = n-1;i >= 0;i--) {
+ if IMP(ve[i]) {
+#ifdef CAUTIOUS
+ ENV_POP;
+#endif
+ return res;
+ }
+ ave[i] = CAR(ve[i]);
+ ve[i] = CDR(ve[i]);
+ }
+ *pres = cons(scm_cvapply(proc, n, ave), EOL);
+ pres = &CDR(*pres);
+ }
}
SCM for_each(proc, arg1, args)
SCM proc, arg1, args;
{
- SCM *ve;
- long i;
- scm_protect_temp(&args); /* Keep args from being optimized away. */
- if NULLP(arg1) return UNSPECIFIED;
- ASSERT(NIMP(arg1), arg1, ARG2, s_for_each);
- if NULLP(args) {
- while NIMP(arg1) {
- ASSERT(CONSP(arg1), arg1, ARG2, s_for_each);
- apply(proc, CAR(arg1), listofnull);
- arg1 = CDR(arg1);
- }
- return UNSPECIFIED;
- }
- args = vector(cons(arg1, args));
- ve = VELTS(args);
- while (1) {
- arg1 = EOL;
- for (i = LENGTH(args)-1;i >= 0;i--) {
- if IMP(ve[i]) return UNSPECIFIED;
- arg1 = cons(CAR(ve[i]), arg1);
- ve[i] = CDR(ve[i]);
- }
- apply(proc, arg1, EOL);
- }
+ SCM heap_ve, auto_ve[5], auto_ave[5];
+ SCM *ve = auto_ve, *ave = auto_ave;
+ long i, n = ilength(args) + 1;
+ scm_protect_temp(&heap_ve); /* Keep heap_ve from being optimized away. */
+ if NULLP(arg1) return UNSPECIFIED;
+#ifdef CAUTIOUS
+ ENV_PUSH;
+ PUSH_TRACE;
+#endif
+#ifndef RECKLESS
+ scm_arity_check(proc, n, s_map);
+#endif
+ ASSERT(NIMP(arg1), arg1, ARG2, s_for_each);
+#ifdef CCLO
+ if (tc16_cclo==TYP16(proc)) {
+ args = cons(arg1, args);
+ arg1 = cons(proc, EOL);
+ SETCDR(arg1, arg1); /* circular list */
+ proc = CCLO_SUBR(proc);
+ n++;
+ }
+#endif
+ if (n > 5) {
+ heap_ve = make_vector(MAKINUM(2*n), BOOL_F);
+ ve = VELTS(heap_ve);
+ ave = &(ve[n]);
+ }
+ ve[0] = arg1;
+ ASSERT(NIMP(ve[0]) && CONSP(ve[0]), arg1, ARG2, s_for_each);
+ for (i = 1; i < n; i++) {
+ ve[i] = CAR(args);
+ ASSERT(NIMP(ve[i]) && CONSP(ve[i]), args, ARGn, s_for_each);
+ args = CDR(args);
+ }
+ while (1) {
+ arg1 = EOL;
+ for (i = n-1;i >= 0;i--) {
+ if IMP(ve[i]) {
+#ifdef CAUTIOUS
+ ENV_POP;
+#endif
+ return UNSPECIFIED;
+ }
+ ave[i] = CAR(ve[i]);
+ ve[i] = CDR(ve[i]);
+ }
+ scm_cvapply(proc, n, ave);
+ }
}
/* The number of required arguments up to 3 is encoded in the cdr of the
- closure. This information is used to make sure that rest args are not
+ closure. A value 3 means no rest argument, 3 or more required arguments.
+ This information is used to make sure that rest args are not
allocated in the environment cache. */
SCM closure(code, argc)
SCM code;
int argc;
{
register SCM z;
- if (argc > 3) argc = 3;
NEWCELL(z);
SETCODE(z, code);
DEFER_INTS_EGC;
@@ -2194,40 +2541,135 @@ static int prinprom(exp, port, writing)
return !0;
}
+static char s_makacro[] = "procedure->syntax";
SCM makacro(code)
SCM code;
{
register SCM z;
+ ASSERT(scm_arity_check(code, 2L, (char *)0), code, ARG1, s_makacro);
NEWCELL(z);
CDR(z) = code;
CAR(z) = tc16_macro;
return z;
}
+static char s_makmacro[] = "procedure->macro";
SCM makmacro(code)
SCM code;
{
register SCM z;
+ ASSERT(scm_arity_check(code, 2L, (char *)0), code, ARG1, s_makmacro);
NEWCELL(z);
CDR(z) = code;
CAR(z) = tc16_macro | (1L<<16);
return z;
}
+static char s_makmmacro[] = "procedure->memoizing-macro";
SCM makmmacro(code)
SCM code;
{
register SCM z;
+ ASSERT(scm_arity_check(code, 2L, (char *)0), code, ARG1, s_makmmacro);
NEWCELL(z);
CDR(z) = code;
CAR(z) = tc16_macro | (2L<<16);
return z;
}
+#ifdef MACRO
+/* Functions for (eventual) smart expansion */
+static char s_macroexpand1[] = "@macroexpand1";
+SCM scm_macroexpand1(x, env)
+ SCM x, env;
+{
+ SCM res, proc;
+ if (IMP(x) || NCONSP(x)) return x;
+ res = CAR(x);
+ if (IMP(res) || !IDENTP(res)) return x;
+ ENV_PUSH;
+ PUSH_TRACE;
+ if (NULLP(env))
+ scm_env = env;
+ else {
+ ASSERT(NIMP(env) && ENVP(env), env, ARG2, s_macroexpand1);
+ scm_env = CDR(env);
+ }
+ proc = *lookupcar(x, 0);
+ ENV_POP;
+ ALLOW_INTS_EGC;
+ if (NIMP(proc) && MACROP(proc)) {
+ SCM argv[2];
+ switch ((int)(CAR(proc)>>16) & 0x7f) {
+ default: return x; /* Primitive macro invocation. */
+ case 2: case 1:
+ argv[0] = x;
+ argv[1] = env;
+ res = scm_cvapply(CDR(proc), 2L, argv);
+ if (res==x) return cons(CAR(x), CDR(x));
+ return res;
+ case 0: case 4: /* Acros, primitive or not. */
+ argv[0] = x;
+ argv[1] = env;
+ return cons2(TOPRENAME(i_quote),
+ scm_cvapply(CDR(proc), 2L, argv),
+ EOL);
+ }
+ }
+ return x;
+}
+static char s_env_ref[] = "environment-ref";
+SCM scm_env_ref(env, ident)
+ SCM env, ident;
+{
+ SCM *p, ret;
+ if NULLP(env) return BOOL_F;
+ ASSERT(NIMP(env) && ENVP(env), env, ARG1, s_env_ref);
+ ASSERT(NIMP(ident) && IDENTP(ident), ident, ARG2, s_env_ref);
+ ENV_PUSH;
+ PUSH_TRACE;
+ scm_env = CDR(env);
+ p = id_denote(ident);
+ ret = p ? *p : BOOL_F;
+ ENV_POP;
+ ALLOW_INTS_EGC;
+ return ret;
+}
+static char s_extended_env[] = "extended-environment";
+SCM scm_extended_env(names, vals, env)
+ SCM names, vals, env;
+{
+ SCM z, nenv;
+# ifndef RECKLESS
+ SCM v = vals;
+ z = names;
+ for (z = names; NIMP(z) && CONSP(z); z = CDR(z)) {
+ ASSERT(NIMP(v) && CONSP(v), vals, ARG2, s_extended_env);
+ v = CDR(v);
+ }
+ ASSERT(NNULLP(z) || NULLP(v), vals, ARG2, s_extended_env);
+# endif
+ nenv = acons(names, vals, env2tree(env));
+ NEWCELL(z);
+ CDR(z) = nenv;
+ CAR(z) = tc16_env | (1L << 16);
+ return z;
+}
+static char s_eval_syntax[] = "eval-syntax";
+SCM scm_eval_syntax(x, env)
+ SCM x, env;
+{
+ ASSERT(IMP(env) ? NULLP(env) : ENVP(env), env, ARG2, s_eval_syntax);
+ return EVAL(x, env);
+}
+#endif /* MACRO */
+
static int prinmacro(exp, port, writing)
SCM exp;
SCM port;
int writing;
{
- if (CAR(exp) & (3L<<16)) lputs("#<macro", port);
- else lputs("#<syntax", port);
+ if (CAR(exp) & (4L<<16)) lputs("#<primitive-", port);
+ else lputs("#<", port);
+ if (CAR(exp) & (3L<<16)) lputs("macro", port);
+ else lputs("syntax", port);
if (CAR(exp) & (2L<<16)) lputc('!', port);
lputc(' ', port);
iprin1(CDR(exp), port, writing);
@@ -2267,7 +2709,7 @@ SCM force(x)
{
ASSERT(NIMP(x) && (TYP16(x)==tc16_promise), x, ARG1, s_force);
if (!((1L<<16) & CAR(x))) {
- SCM ans = apply(CDR(x), EOL, EOL);
+ SCM ans = scm_cvapply(CDR(x), 0L, (SCM *)0);
if (!((1L<<16) & CAR(x))) {
DEFER_INTS;
CDR(x) = ans;
@@ -2330,7 +2772,6 @@ SCM ident_eqp(id1, id2, env)
SCM id1, id2, env;
{
SCM s1 = id1, s2 = id2, ret;
-
# ifndef RECKLESS
if IMP(id1)
badarg1: wta(id1, (char *)ARG1, s_ident_eqp);
@@ -2343,10 +2784,14 @@ SCM ident_eqp(id1, id2, env)
ASRTGO(SYMBOLP(s1), badarg1);
ASRTGO(SYMBOLP(s2), badarg2);
if (s1 != s2) return BOOL_F;
- DEFER_INTS_EGC;
ENV_PUSH;
- scm_env = (NIMP(env) && tc16_env==CAR(env)) ? CDR(env) : env;
- ret = (id_denote(id1)==id_denote(id2)) ? BOOL_T : BOOL_F;
+ PUSH_TRACE;
+ if NULLP(env) scm_env = env;
+ else {
+ ASSERT(NIMP(env) && tc16_env==TYP16(env), env, ARG3, s_ident_eqp);
+ scm_env = CDR(env);
+ }
+ ret = (id_denote(id1)==id_denote(id2)) ? BOOL_T : BOOL_F;
ENV_POP;
return ret;
}
@@ -2367,7 +2812,7 @@ SCM renamed_ident(id, env)
SCM z;
ASSERT(NIMP(id) && IDENTP(id), id, ARG1, s_renamed_ident);
if NIMP(env) {
- ASSERT(tc16_env==CAR(env), env, ARG2, s_renamed_ident);
+ ASSERT(ENVP(env), env, ARG2, s_renamed_ident);
DEFER_INTS_EGC;
env = CDR(env);
}
@@ -2402,7 +2847,7 @@ SCM m_atlet_syntax(xorig, env)
{
SCM mark;
DEFER_INTS_EGC;
- if (tc16_env==CAR(env))
+ if (NIMP(env) && ENVP(env))
env = CDR(env);
if NULLP(env) return m_let(xorig, env);
mark = CAR(CAR(env));
@@ -2435,16 +2880,21 @@ SCM env2tree(env)
{
SCM ans, a, *lloc;
if NULLP(env) return env;
- ASSERT(NIMP(env) && tc16_env==CAR(env), env, ARG1, s_env2tree);
- DEFER_INTS_EGC;
- if IMP(CDR(env)) return env;
+ ASSERT(NIMP(env) && ENVP(env), env, ARG1, s_env2tree);
+ if ((1L << 16) & CAR(env)) return CDR(env);
+ if IMP(CDR(env)) return CDR(env);
ENV_PUSH;
+ PUSH_TRACE;
scm_env = CDR(env);
ans = a = cons(UNSPECIFIED, UNSPECIFIED);
while (!0) {
scm_env_tmp = CAR(scm_env);
lloc = &CAR(a);
while (NIMP(scm_env_tmp) && CONSP(scm_env_tmp)) {
+ if (undefineds==*lloc) {
+ *lloc = BOOL_F;
+ break;
+ }
*lloc = cons(CAR(scm_env_tmp), CDR(scm_env_tmp));
lloc = &CDR(*lloc);
DEFER_INTS_EGC;
@@ -2459,12 +2909,14 @@ SCM env2tree(env)
}
ENV_POP;
ALLOW_INTS_EGC;
+ CDR(env) = ans; /* Memoize migrated environment. */
+ CAR(env) |= (1L << 16);
return ans;
}
static iproc subr1s[] = {
{"@copy-tree", copytree},
- {s_eval, eval},
+/* {s_eval, eval}, now a (tail recursive) specfun */
{s_force, force},
{s_proc_doc, l_proc_doc},
{"procedure->syntax", makacro},
@@ -2482,8 +2934,20 @@ static iproc lsubr2s[] = {
/* {s_apply, apply}, now explicity initted */
{s_map, map},
{s_for_each, for_each},
+#ifdef MACRO
+ {s_macroexpand1, scm_macroexpand1},
+ {s_env_ref, scm_env_ref},
+ {s_eval_syntax, scm_eval_syntax},
+#endif
{0, 0}};
+static iproc subr3s[] = {
+#ifdef MACRO
+ {s_ident_eqp, ident_eqp},
+ {s_extended_env, scm_extended_env},
+#endif
+ {0, 0}};
+
static smobfuns promsmob = {markcdr, free0, prinprom};
static smobfuns macrosmob = {markcdr, free0, prinmacro};
static smobfuns envsmob = {markcdr, free0, prinenv};
@@ -2492,19 +2956,14 @@ static smobfuns idsmob = {markcdr, free0, prinid};
#endif
SCM make_synt(name, macroizer, fcn)
- char *name;
+ const char *name;
SCM (*macroizer)();
SCM (*fcn)();
{
SCM symcell = sysintern(name, UNDEFINED);
- long tmp = ((((CELLPTR)(CAR(symcell)))-heap_org)<<8);
- register SCM z;
- if ((tmp>>8) != ((CELLPTR)(CAR(symcell))-heap_org))
- tmp = 0;
- NEWCELL(z);
- SUBRF(z) = fcn;
- CAR(z) = tmp + tc7_subr_2;
- CDR(symcell) = macroizer(z);
+ SCM z = macroizer(scm_maksubr(name, tc7_subr_2, fcn));
+ CAR(z) |= (4L << 16); /* Flags result as primitive macro. */
+ CDR(symcell) = z;
return CAR(symcell);
}
SCM make_specfun(name, typ)
@@ -2526,11 +2985,13 @@ void init_eval()
tc16_env = newsmob(&envsmob);
init_iprocs(subr1s, tc7_subr_1);
init_iprocs(lsubr2s, tc7_lsubr_2);
+ init_iprocs(subr3s, tc7_subr_3);
#ifdef SCM_PROFILE
make_subr("scm:profile", tc7_subr_1o, scm_profile);
#endif
make_specfun(s_apply, tc16_apply);
make_specfun(s_call_cc, tc16_call_cc);
+ make_specfun(s_eval, tc16_eval);
i_dot = CAR(sysintern(".", UNDEFINED));
i_arrow = CAR(sysintern("=>", UNDEFINED));
@@ -2561,10 +3022,13 @@ void init_eval()
make_synt(s_atapply, makmmacro, m_apply);
/* make_synt(s_atcall_cc, makmmacro, m_cont); */
+ f_apply_closure =
+ CDR(sysintern(" apply-closure",
+ scm_evstr("(let ((ap apply)) (lambda (p . a) (ap p a)))")));
+
#ifdef MACRO
tc16_ident = newsmob(&idsmob);
make_subr(s_renamed_ident, tc7_subr_2, renamed_ident);
- make_subr(s_ident_eqp, tc7_subr_3, ident_eqp);
make_synt(s_syn_quote, makmmacro, m_syn_quote);
make_synt("@let-syntax", makmmacro, m_atlet_syntax);
/* This doesn't do anything special, but might in the future. */