diff options
Diffstat (limited to 'eval.c')
| -rw-r--r-- | eval.c | 191 |
1 files changed, 104 insertions, 87 deletions
@@ -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: |