summaryrefslogtreecommitdiffstats
path: root/eval.c
diff options
context:
space:
mode:
authorThomas Bushnell <tb@debian.org>2006-10-23 23:31:59 -0700
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:35 -0800
commit906cc4f0899080f1b832af98b7ccbcc257b8a64e (patch)
tree14e3ec231debdca4da9c1a3ccc0536033c1c8a4b /eval.c
parent3d573fa54db0fdcae8b2a20356faa46c8e335206 (diff)
parent50eb784bfcf15ee3c6b0b53d747db92673395040 (diff)
downloadscm-906cc4f0899080f1b832af98b7ccbcc257b8a64e.tar.gz
scm-906cc4f0899080f1b832af98b7ccbcc257b8a64e.zip
Import Debian changes 5e3-1debian/5e3-1
scm (5e3-1) unstable; urgency=low * New upstream release. * debian/control (Architecture): Add ia64 to list of supported archs. Now everything but s390 is listed. (Closes: #335980) (Build-Depends): Require at least version 3a4 of slib. * Change to continue.h from version 5e1-2 repeated here. * Change to xgen.scm from version 5e2-4 repeated here. * Change to scm.1 from version 5e2-4 repeated here.
Diffstat (limited to 'eval.c')
-rw-r--r--eval.c191
1 files changed, 104 insertions, 87 deletions
diff --git a/eval.c b/eval.c
index 778d7e4..e616382 100644
--- a/eval.c
+++ b/eval.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997, 1998, 1999, 2002 Free Software Foundation, Inc.
+/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997, 1998, 1999, 2002, 2006 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
@@ -781,6 +781,12 @@ SCM eval_args(l)
return res;
}
+/*
+ Evaluate each expression in argument list x,
+ and return a list allocated in the ecache of the
+ results.
+ The result is left in scm_env_tmp.
+*/
static void ecache_evalx(x)
SCM x;
{
@@ -798,6 +804,34 @@ static void ecache_evalx(x)
ENV_V2LST((long)i, argv);
}
+/*
+ Allocate a list of UNDEFINED in the ecache, one
+ for each element of the argument list x.
+ The result is left in scm_env_tmp.
+*/
+static void ecache_undefs(x)
+ SCM x;
+{
+ static SCM argv[10] = {UNDEFINED, UNDEFINED, UNDEFINED,
+ UNDEFINED, UNDEFINED, UNDEFINED,
+ UNDEFINED, UNDEFINED, UNDEFINED,
+ UNDEFINED};
+
+ int imax = sizeof(argv)/sizeof(SCM);
+ int i = 0;
+
+ scm_env_tmp = EOL;
+ while NIMP(x) {
+ if (imax==i) {
+ ecache_undefs(x);
+ break;
+ }
+ i++;
+ x = CDR(x);
+ }
+ ENV_V2LST((long)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)
@@ -1645,11 +1679,7 @@ static SCM m_body(xorig, env, ctxt)
break;
}
}
-#ifdef CAUTIOUS
- ASSYNT(ilength(x) > 0, xorig, s_body, what);
-#else
ASSYNT(ilength(x) > 0, xorig, s_body, what);
-#endif
if (IMP(defs)) return x;
return cons(m_letrec1(IM_DEFINE, cons2(i_define, defs, x), env, ctxt), EOL);
}
@@ -2046,6 +2076,48 @@ SCM scm_eval_values(x, env, valenv)
return res;
}
+SCM scm_apply_cxr(proc, arg1)
+ SCM proc, arg1;
+{
+ double y;
+#ifdef FLOATS
+ if (SUBRF(proc)) {
+ if (INUMP(arg1)) {
+ y = DSUBRF(proc)((double) INUM(arg1));
+ goto ret;
+ }
+ ASRTGO(NIMP(arg1), floerr);
+ if (REALP(arg1)) {
+ y = DSUBRF(proc)(REALPART(arg1));
+ ret:
+ if (y==y) return makdbl(y, 0.0);
+ goto floerr;
+ }
+# ifdef BIGDIG
+ if (BIGP(arg1)) {
+ y = DSUBRF(proc)(big2dbl(arg1));
+ goto ret;
+ }
+# endif
+ floerr:
+ wta(arg1, (char *)ARG1, SNAME(proc));
+ }
+#endif
+ {
+ int op = CXR_OP(proc);
+#ifndef RECKLESS
+ SCM x = arg1;
+#endif
+ while (op) {
+ ASRTER(NIMP(arg1) && CONSP(arg1),
+ x, ARG1, SNAME(proc));
+ arg1 = (1 & op ? CAR(arg1) : CDR(arg1));
+ op >>= 2;
+ }
+ return arg1;
+ }
+}
+
#ifdef __GNUC__
# define GCC_VERSION (__GNUC__ * 100 + __GNUC_MINOR__)
/* __GNUC_PATCHLEVEL__ */
@@ -2184,12 +2256,30 @@ static SCM ceval_1(x)
TRACE(x);
x = CDR(x);
STATIC_ENV = CAR(x);
+#if 0 /*
+ The block below signals an error if any variable
+ bound in a LETREC is referenced in any init.
+ */
scm_env_tmp = undefineds;
EXTEND_VALENV;
x = CDR(x);
ecache_evalx(CAR(x));
EGC_ROOT(scm_env);
CAR(scm_env) = scm_env_tmp;
+
+#else /* The block below implements LETREC* */
+ ecache_undefs(CAR(CAR(x)));
+ EXTEND_VALENV;
+ x = CDR(x);
+ proc = CAR(x);
+ while (NIMP(proc)) {
+ arg1 = EVALCAR(proc);
+ proc = CDR(proc);
+ DEFER_INTS_EGC;
+ CAR(scm_env_tmp) = arg1;
+ scm_env_tmp = CDR(scm_env_tmp);
+ }
+#endif
scm_env_tmp = EOL;
goto cdrxbegin;
case (127 & IM_LETSTAR):
@@ -2308,7 +2398,13 @@ static SCM ceval_1(x)
x = acro_call(x, STATIC_ENV);
goto loop;
case (ISYMNUM(IM_LINUM)):
+#ifndef MEMOIZE_LOCALS
+ x = CDR(x); /* For non-memoizing case,
+ just throw away line number. */
+ goto loop;
+#else
goto expand;
+#endif
case (ISYMNUM(IM_DEFINE)):
x = toplevel_define(x, STATIC_ENV);
goto retx;
@@ -2459,34 +2555,7 @@ evap1:
case tc7_subr_1o:
return SUBRF(proc)(arg1);
case tc7_cxr:
-#ifdef FLOATS
- if (SUBRF(proc)) {
- if (INUMP(arg1))
- return makdbl(DSUBRF(proc)((double) INUM(arg1)), 0.0);
- ASRTGO(NIMP(arg1), floerr);
- if (REALP(arg1))
- return makdbl(DSUBRF(proc)(REALPART(arg1)), 0.0);
-# ifdef BIGDIG
- if (BIGP(arg1))
- return makdbl(DSUBRF(proc)(big2dbl(arg1)), 0.0);
-# endif
- floerr:
- wta(arg1, (char *)ARG1, SNAME(proc));
- }
-#endif
- {
- int op = CXR_OP(proc);
-#ifndef RECKLESS
- x = arg1;
-#endif
- while (op) {
- ASRTER(NIMP(arg1) && CONSP(arg1),
- x, ARG1, SNAME(proc));
- arg1 = (1 & op ? CAR(arg1) : CDR(arg1));
- op >>= 2;
- }
- return arg1;
- }
+ return scm_apply_cxr(proc, arg1);
case tc7_rpsubr:
return BOOL_T;
case tc7_asubr:
@@ -2873,34 +2942,7 @@ SCM apply(proc, arg1, args)
return SUBRF(proc)(arg1);
case tc7_cxr:
ASRTGO(NULLP(args), wrongnumargs);
-#ifdef FLOATS
- if (SUBRF(proc)) {
- if (INUMP(arg1))
- return makdbl(DSUBRF(proc)((double) INUM(arg1)), 0.0);
- ASRTGO(NIMP(arg1), floerr);
- if (REALP(arg1))
- return makdbl(DSUBRF(proc)(REALPART(arg1)), 0.0);
-# ifdef BIGDIG
- if (BIGP(arg1))
- return makdbl(DSUBRF(proc)(big2dbl(arg1)), 0.0);
-# endif
- floerr:
- wta(arg1, (char *)ARG1, SNAME(proc));
- }
-#endif
- {
- int op = CXR_OP(proc);
-#ifndef RECKLESS
- args = arg1;
-#endif
- while (op) {
- ASRTER(NIMP(arg1) && CONSP(arg1),
- args, ARG1, SNAME(proc));
- arg1 = (1 & op ? CAR(arg1) : CDR(arg1));
- op >>= 2;
- }
- return arg1;
- }
+ return scm_apply_cxr(proc, arg1);
case tc7_subr_3:
ASRTGO(NIMP(args) && NIMP(CDR(args)) && NULLP(CDR(CDR(args))),
wrongnumargs);
@@ -2977,32 +3019,7 @@ SCM scm_cvapply(proc, n, argv)
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, SNAME(proc));
- }
-#endif
- {
- int op = CXR_OP(proc);
- res = argv[0];
- while (op) {
- ASRTER(NIMP(res) && CONSP(res),
- argv[0], ARG1, SNAME(proc));
- res = (1 & op ? CAR(res) : CDR(res));
- op >>= 2;
- }
- return res;
- }
+ return scm_apply_cxr(proc, argv[0]);
case tc7_subr_3:
return SUBRF(proc)(argv[0], argv[1], argv[2]);
case tc7_lsubr: