summaryrefslogtreecommitdiffstats
path: root/eval.c
diff options
context:
space:
mode:
Diffstat (limited to 'eval.c')
-rw-r--r--eval.c1494
1 files changed, 1494 insertions, 0 deletions
diff --git a/eval.c b/eval.c
new file mode 100644
index 0000000..2cf04fe
--- /dev/null
+++ b/eval.c
@@ -0,0 +1,1494 @@
+/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995 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.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * 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.
+ */
+
+/* "eval.c" eval and apply.
+ Authors: Aubrey Jaffer & Hugh E. Secker-Walker. */
+
+#include "scm.h"
+#include "setjump.h"
+
+#define I_SYM(x) (CAR((x)-1L))
+#define I_VAL(x) (CDR((x)-1L))
+#define EVALCELLCAR(x, env) SYMBOLP(CAR(x))?*lookupcar(x, env):ceval(CAR(x), env)
+#ifdef MEMOIZE_LOCALS
+# define EVALIMP(x, env) (ILOCP(x)?*ilookup((x), env):x)
+#else
+# define EVALIMP(x, env) x
+#endif
+#define EVALCAR(x, env) (NCELLP(CAR(x))?(IMP(CAR(x))?EVALIMP(CAR(x), env):\
+ I_VAL(CAR(x))):EVALCELLCAR(x, env))
+#define EXTEND_ENV acons
+
+#ifdef MEMOIZE_LOCALS
+SCM *ilookup(iloc, env)
+ SCM iloc, env;
+{
+ register int ir = IFRAME(iloc);
+ register SCM er = env;
+ for(;0 != ir;--ir) er = CDR(er);
+ er = CAR(er);
+ for(ir = IDIST(iloc);0 != ir;--ir) er = CDR(er);
+ if ICDRP(iloc) return &CDR(er);
+ return &CAR(CDR(er));
+}
+#endif
+SCM *lookupcar(vloc, genv)
+ SCM vloc, genv;
+{
+ SCM env = genv;
+ register SCM *al, fl, var = CAR(vloc);
+#ifdef MEMOIZE_LOCALS
+ register SCM iloc = ILOC00;
+#endif
+ for(;NIMP(env);env = CDR(env)) {
+ al = &CAR(env);
+ for(fl = CAR(*al);NIMP(fl);fl = CDR(fl)) {
+ if NCONSP(fl)
+ if (fl==var) {
+#ifdef MEMOIZE_LOCALS
+ CAR(vloc) = iloc + ICDR;
+#endif
+ return &CDR(*al);
+ }
+ else break;
+ al = &CDR(*al);
+ if (CAR(fl)==var) {
+#ifdef MEMOIZE_LOCALS
+# ifndef RECKLESS /* letrec inits to UNDEFINED */
+ if UNBNDP(CAR(*al)) {env = EOL; goto errout;}
+# endif
+ CAR(vloc) = iloc;
+#endif
+ return &CAR(*al);
+ }
+#ifdef MEMOIZE_LOCALS
+ iloc += IDINC;
+#endif
+ }
+#ifdef MEMOIZE_LOCALS
+ iloc = (~IDSTMSK) & (iloc + IFRINC);
+#endif
+ }
+ var = sym2vcell(var);
+#ifndef RECKLESS
+ if (NNULLP(env) || UNBNDP(CDR(var))) {
+ var = CAR(var);
+ errout:
+ everr(vloc, genv, var,
+ NULLP(env)?"unbound variable: ":"damaged environment", "");
+ }
+#endif
+ CAR(vloc) = var + 1;
+ return &CDR(var);
+}
+static SCM unmemocar(form, env)
+ SCM form, env;
+{
+ register int ir;
+ if IMP(form) return form;
+ if (1==TYP3(form))
+ CAR(form) = I_SYM(CAR(form));
+#ifdef MEMOIZE_LOCALS
+ else if ILOCP(CAR(form)) {
+ for(ir = IFRAME(CAR(form)); ir != 0; --ir) env = CDR(env);
+ env = CAR(CAR(env));
+ for(ir = IDIST(CAR(form));ir != 0;--ir) env = CDR(env);
+ CAR(form) = ICDRP(CAR(form)) ? env : CAR(env);
+ }
+#endif
+ return form;
+}
+
+SCM eval_args(l, env)
+ SCM l, env;
+{
+ SCM res = EOL, *lloc = &res;
+ while NIMP(l) {
+ *lloc = cons(EVALCAR(l, env), EOL);
+ lloc = &CDR(*lloc);
+ l = CDR(l);
+ }
+ return res;
+}
+
+ /* the following rewrite expressions and
+ * some memoized forms have different syntax */
+
+static char s_expression[] = "missing or extra expression";
+static char s_test[] = "bad test";
+static char s_body[] = "bad body";
+static char s_bindings[] = "bad bindings";
+static char s_variable[] = "bad variable";
+static char s_clauses[] = "bad or missing clauses";
+static char s_formals[] = "bad formals";
+#define ASSYNT(_cond, _arg, _pos, _subr) if(!(_cond))wta(_arg, (char *)_pos, _subr);
+
+SCM i_dot, i_quote, i_quasiquote, i_lambda,
+ i_let, i_arrow, i_else, i_unquote, i_uq_splicing, i_apply;
+static char s_quasiquote[] = "quasiquote";
+static char s_delay[] = "delay";
+
+#define ASRTSYNTAX(cond_, msg_) if(!(cond_))wta(xorig, (msg_), what);
+
+static void bodycheck(xorig, bodyloc, what)
+ SCM xorig, *bodyloc;
+ char *what;
+{
+ ASRTSYNTAX(ilength(*bodyloc) >= 1, s_expression);
+}
+
+SCM m_quote(xorig, env)
+ SCM xorig, env;
+{
+ ASSYNT(ilength(CDR(xorig))==1, xorig, s_expression, s_quote);
+ return cons(IM_QUOTE, CDR(xorig));
+}
+
+SCM m_begin(xorig, env)
+ SCM xorig, env;
+{
+ ASSYNT(ilength(CDR(xorig)) >= 1, xorig, s_expression, s_begin);
+ return cons(IM_BEGIN, CDR(xorig));
+}
+
+SCM m_if(xorig, env)
+ SCM xorig, env;
+{
+ int len = ilength(CDR(xorig));
+ ASSYNT(len >= 2 && len <= 3, xorig, s_expression, s_if);
+ return cons(IM_IF, CDR(xorig));
+}
+
+SCM m_set(xorig, env)
+ SCM xorig, env;
+{
+ SCM x = CDR(xorig);
+ ASSYNT(2==ilength(x), xorig, s_expression, s_set);
+ ASSYNT(NIMP(CAR(x)) && SYMBOLP(CAR(x)),
+ xorig, s_variable, s_set);
+ return cons(IM_SET, x);
+}
+
+SCM m_and(xorig, env)
+ SCM 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;
+}
+
+SCM m_or(xorig, env)
+ SCM 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;
+}
+
+SCM m_case(xorig, env)
+ SCM xorig, env;
+{
+ SCM proc, x = CDR(xorig);
+ ASSYNT(ilength(x) >= 2, xorig, s_clauses, s_case);
+ while(NIMP(x = CDR(x))) {
+ proc = CAR(x);
+ ASSYNT(ilength(proc) >= 2, xorig, s_clauses, s_case);
+ ASSYNT(ilength(CAR(proc)) >= 0 || i_else==CAR(proc),
+ xorig, s_clauses, s_case);
+ }
+ return cons(IM_CASE, CDR(xorig));
+}
+
+SCM m_cond(xorig, env)
+ SCM xorig, env;
+{
+ SCM arg1, x = CDR(xorig);
+ int len = ilength(x);
+ ASSYNT(len >= 1, xorig, s_clauses, s_cond);
+ while(NIMP(x)) {
+ arg1 = CAR(x);
+ len = ilength(arg1);
+ ASSYNT(len >= 1, xorig, s_clauses, s_cond);
+ if (i_else==CAR(arg1)) {
+ ASSYNT(NULLP(CDR(x)) && len >= 2, xorig, "bad ELSE clause", s_cond);
+ CAR(arg1) = BOOL_T;
+ }
+ if (len >= 2 && i_arrow==CAR(CDR(arg1)))
+ ASSYNT(3==len && NIMP(CAR(CDR(CDR(arg1)))),
+ xorig, "bad recipient", s_cond);
+ x = CDR(x);
+ }
+ return cons(IM_COND, CDR(xorig));
+}
+
+SCM m_lambda(xorig, env)
+ SCM xorig, env;
+{
+ SCM proc, x = CDR(xorig);
+ if (ilength(x) < 2) goto badforms;
+ proc = CAR(x);
+ if NULLP(proc) goto memlambda;
+ if IMP(proc) goto badforms;
+ if SYMBOLP(proc) goto memlambda;
+ if NCONSP(proc) goto badforms;
+ while NIMP(proc) {
+ if NCONSP(proc)
+ if (!SYMBOLP(proc)) goto badforms;
+ else goto memlambda;
+ if (!(NIMP(CAR(proc)) && SYMBOLP(CAR(proc)))) goto badforms;
+ proc = CDR(proc);
+ }
+ if NNULLP(proc)
+ badforms: wta(xorig, s_formals, s_lambda);
+ memlambda:
+ bodycheck(xorig, &CDR(x), s_lambda);
+ return cons(IM_LAMBDA, CDR(xorig));
+}
+SCM m_letstar(xorig, env)
+ SCM xorig, env;
+{
+ SCM x = CDR(xorig), arg1, proc, vars = EOL, *varloc = &vars;
+ int len = ilength(x);
+ ASSYNT(len >= 2, xorig, s_body, s_letstar);
+ proc = CAR(x);
+ ASSYNT(ilength(proc) >= 0, xorig, s_bindings, s_letstar);
+ while NIMP(proc) {
+ arg1 = CAR(proc);
+ ASSYNT(2==ilength(arg1), xorig, s_bindings, s_letstar);
+ ASSYNT(NIMP(CAR(arg1)) && SYMBOLP(CAR(arg1)), xorig, s_variable, s_letstar);
+ *varloc = cons2(CAR(arg1), CAR(CDR(arg1)), EOL);
+ varloc = &CDR(CDR(*varloc));
+ proc = CDR(proc);
+ }
+ x = cons(vars, CDR(x));
+ bodycheck(xorig, &CDR(x), s_letstar);
+ return cons(IM_LETSTAR, x);
+}
+
+/* DO gets the most radically altered syntax
+ (do ((<var1> <init1> <step1>)
+ (<var2> <init2>)
+ ... )
+ (<test> <return>)
+ <body>)
+ ;; becomes
+ (do_mem (varn ... var2 var1)
+ (<init1> <init2> ... <initn>)
+ (<test> <return>)
+ (<body>)
+ <step1> <step2> ... <stepn>) ;; missing steps replaced by var
+ */
+SCM m_do(xorig, env)
+ SCM xorig, env;
+{
+ SCM x = CDR(xorig), arg1, proc;
+ SCM vars = EOL, inits = EOL, steps = EOL;
+ SCM *initloc = &inits, *steploc = &steps;
+ int len = ilength(x);
+ ASSYNT(len >= 2, xorig, s_test, s_do);
+ proc = CAR(x);
+ ASSYNT(ilength(proc) >= 0, xorig, s_bindings, s_do);
+ while NIMP(proc) {
+ arg1 = CAR(proc);
+ len = ilength(arg1);
+ ASSYNT(2==len || 3==len, xorig, s_bindings, s_do);
+ ASSYNT(NIMP(CAR(arg1)) && SYMBOLP(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);
+ arg1 = CDR(arg1);
+ *steploc = cons(IMP(arg1)?CAR(vars):CAR(arg1), EOL); /* step */
+ steploc = &CDR(*steploc);
+ proc = CDR(proc);
+ }
+ x = CDR(x);
+ ASSYNT(ilength(CAR(x)) >= 1, xorig, s_test, s_do);
+ 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);
+}
+
+/* evalcar is small version of inline EVALCAR when we don't care about speed */
+static SCM evalcar(x, env)
+ SCM x, env;
+{
+ return EVALCAR(x, env);
+}
+
+static SCM iqq(form, env, depth)
+ SCM form, env;
+ int depth;
+{
+ SCM tmp;
+ int edepth = depth;
+ if IMP(form) return form;
+ if VECTORP(form) {
+ long i = LENGTH(form);
+ SCM *data = VELTS(form);
+ tmp = EOL;
+ for(;--i >= 0;) tmp = cons(data[i], tmp);
+ return vector(iqq(tmp, env, depth));
+ }
+ if NCONSP(form) return form;
+ tmp = CAR(form);
+ if (i_quasiquote==tmp) {
+ depth++;
+ goto label;
+ }
+ if (i_unquote==tmp) {
+ --depth;
+ label:
+ form = CDR(form);
+ ASSERT(NIMP(form) && ECONSP(form) && NULLP(CDR(form)),
+ form, ARG1, s_quasiquote);
+ if (0==depth) return evalcar(form, env);
+ return cons2(tmp, iqq(CAR(form), env, depth), EOL);
+ }
+ if (NIMP(tmp) && (i_uq_splicing==CAR(tmp))) {
+ tmp = CDR(tmp);
+ if (0==--edepth)
+ return append(cons2(evalcar(tmp, env), iqq(CDR(form), env, depth), EOL));
+ }
+ return cons(iqq(CAR(form), env, edepth), iqq(CDR(form), env, depth));
+}
+
+/* Here are acros which return values rather than code. */
+
+SCM m_quasiquote(xorig, env)
+ SCM xorig, env;
+{
+ SCM x = CDR(xorig);
+ ASSYNT(ilength(x)==1, xorig, s_expression, s_quasiquote);
+ return iqq(CAR(x), env, 1);
+}
+
+SCM m_delay(xorig, env)
+ SCM xorig, env;
+{
+ ASSYNT(ilength(xorig)==2, xorig, s_expression, s_delay);
+ xorig = CDR(xorig);
+ return makprom(closure(cons2(EOL, CAR(xorig), CDR(xorig)), env));
+}
+
+extern int verbose;
+SCM m_define(x, env)
+ SCM x, env;
+{
+ SCM proc, arg1 = x; x = CDR(x);
+ /* ASSYNT(NULLP(env), x, "bad placement", s_define);*/
+ ASSYNT(ilength(x) >= 2, arg1, s_expression, s_define);
+ proc = CAR(x); x = CDR(x);
+ while (NIMP(proc) && CONSP(proc)) { /* nested define syntax */
+ x = cons(cons2(i_lambda, CDR(proc), x), EOL);
+ proc = CAR(proc);
+ }
+ ASSYNT(NIMP(proc) && SYMBOLP(proc), arg1, s_variable, s_define);
+ ASSYNT(1==ilength(x), arg1, s_expression, s_define);
+ if NULLP(env) {
+ x = evalcar(x, env);
+ arg1 = sym2vcell(proc);
+#ifndef RECKLESS
+ if (NIMP(CDR(arg1)) && ((SCM) SNAME(CDR(arg1))==proc)
+ && (CDR(arg1) != x))
+ warn("redefining built-in ", CHARS(proc));
+ else
+#endif
+ if (5 <= verbose && UNDEFINED != CDR(arg1))
+ warn("redefining ", CHARS(proc));
+ CDR(arg1) = x;
+#ifdef SICP
+ return cons2(i_quote, CAR(arg1), EOL);
+#else
+ return UNSPECIFIED;
+#endif
+ }
+ return cons2(IM_DEFINE, proc, x);
+}
+/* end of acros */
+
+SCM m_letrec(xorig, env)
+ SCM 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 = EOL, inits = EOL, *initloc = &inits;
+
+ ASRTSYNTAX(ilength(x) >= 2, s_body);
+ proc = CAR(x);
+ if NULLP(proc) return m_letstar(xorig, env); /* null binding, let* faster */
+ 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)) && SYMBOLP(CAR(arg1)), s_variable);
+ vars = cons(CAR(arg1), vars);
+ *initloc = cons(CAR(CDR(arg1)), EOL);
+ initloc = &CDR(*initloc);
+ } while NIMP(proc = CDR(proc));
+ cdrx = cons2(vars, inits, CDR(x));
+ bodycheck(xorig, &CDR(CDR(cdrx)), what);
+ return cons(IM_LETREC, cdrx);
+}
+
+SCM m_let(xorig, env)
+ SCM xorig, env;
+{
+ SCM cdrx = CDR(xorig); /* locally mutable version of form */
+ SCM x = cdrx, proc, arg1, name; /* structure traversers */
+ SCM vars = EOL, inits = EOL, *varloc = &vars, *initloc = &inits;
+
+ ASSYNT(ilength(x) >= 2, xorig, s_body, s_let);
+ proc = CAR(x);
+ if (NULLP(proc)
+ || (NIMP(proc) && CONSP(proc)
+ && NIMP(CAR(proc)) && CONSP(CAR(proc)) && NULLP(CDR(proc))))
+ return m_letstar(xorig, env); /* null or single binding, let* is faster */
+ ASSYNT(NIMP(proc), xorig, s_bindings, s_let);
+ if CONSP(proc) /* plain let, proc is <bindings> */
+ return cons(IM_LET, CDR(m_letrec(xorig, env)));
+ if (!SYMBOLP(proc)) wta(xorig, s_bindings, s_let); /* bad let */
+ name = proc; /* named let, build equiv letrec */
+ x = CDR(x);
+ ASSYNT(ilength(x) >= 2, xorig, s_body, s_let);
+ proc = CAR(x); /* bindings list */
+ ASSYNT(ilength(proc) >= 0, xorig, s_bindings, s_let);
+ while NIMP(proc) { /* vars and inits both in order */
+ arg1 = CAR(proc);
+ ASSYNT(2==ilength(arg1), xorig, s_bindings, s_let);
+ ASSYNT(NIMP(CAR(arg1)) && SYMBOLP(CAR(arg1)), xorig, s_variable, s_let);
+ *varloc = cons(CAR(arg1), EOL);
+ varloc = &CDR(*varloc);
+ *initloc = cons(CAR(CDR(arg1)), EOL);
+ initloc = &CDR(*initloc);
+ proc = CDR(proc);
+ }
+ return
+ m_letrec(cons2(i_let,
+ cons(cons2(name, cons2(i_lambda, vars, CDR(x)), EOL), EOL),
+ acons(name, inits, EOL)), /* body */
+ env);
+}
+
+#define s_atapply (ISYMCHARS(IM_APPLY)+1)
+
+SCM m_apply(xorig, env)
+ SCM xorig, env;
+{
+ ASSYNT(ilength(CDR(xorig))==2, xorig, s_expression, s_atapply);
+ return cons(IM_APPLY, CDR(xorig));
+}
+
+#define s_atcall_cc (ISYMCHARS(IM_CONT)+1)
+
+SCM m_cont(xorig, env)
+ SCM xorig, env;
+{
+ ASSYNT(ilength(CDR(xorig))==1, xorig, s_expression, s_atcall_cc);
+ return cons(IM_CONT, CDR(xorig));
+}
+
+#ifndef RECKLESS
+int badargsp(formals, args)
+ SCM formals, args;
+{
+ while NIMP(formals) {
+ if NCONSP(formals) return 0;
+ if IMP(args) return 1;
+ formals = CDR(formals);
+ args = CDR(args);
+ }
+ return NNULLP(args) ? 1 : 0;
+}
+#endif
+
+char s_map[] = "map", s_for_each[] = "for-each", s_eval[] = "eval";
+SCM eqv P((SCM x, SCM y));
+long tc16_macro; /* Type code for macros */
+#ifdef CAUTIOUS
+static char s_bottom[] = "stacktrace bottommed out";
+#endif
+
+SCM ceval(x, env)
+ SCM x, env;
+{
+ union {SCM *lloc; SCM arg1;} t;
+ SCM proc, arg2;
+ CHECK_STACK;
+ loop: POLL;
+ switch TYP7(x) {
+ case tcs_symbols:
+ /* only happens when called at top level */
+ x = cons(x, UNDEFINED);
+ goto retval;
+ case (127 & IM_AND):
+ x = CDR(x);
+ t.arg1 = x;
+ while(NNULLP(t.arg1 = CDR(t.arg1)))
+ if FALSEP(EVALCAR(x, env)) return BOOL_F;
+ else x = t.arg1;
+ goto carloop;
+ cdrtcdrxbegin:
+#ifdef CAUTIOUS
+ ASSERT(NIMP(stacktrace), EOL, s_bottom, s_eval);
+ stacktrace = CDR(stacktrace);
+#endif
+ cdrxbegin:
+ case (127 & IM_BEGIN):
+ x = CDR(x);
+ begin:
+ t.arg1 = x;
+ while(NNULLP(t.arg1 = CDR(t.arg1))) {
+ SIDEVAL(CAR(x), env);
+ x = t.arg1;
+ }
+ carloop: /* eval car of last form in list */
+ if NCELLP(CAR(x)) {
+ x = CAR(x);
+ return IMP(x)?EVALIMP(x, env):I_VAL(x);
+ }
+ if SYMBOLP(CAR(x)) {
+ retval:
+ return *lookupcar(x, env);
+ }
+ x = CAR(x);
+ goto loop; /* tail recurse */
+
+ case (127 & IM_CASE):
+ x = CDR(x);
+ t.arg1 = EVALCAR(x, env);
+ while(NIMP(x = CDR(x))) {
+ proc = CAR(x);
+ if (i_else==CAR(proc)) {
+ x = CDR(proc);
+ goto begin;
+ }
+ proc = CAR(proc);
+ while NIMP(proc) {
+ if (CAR(proc)==t.arg1
+#ifdef FLOATS
+ || NFALSEP(eqv(CAR(proc), t.arg1))
+#endif
+ ) {
+ x = CDR(CAR(x));
+ goto begin;
+ }
+ proc = CDR(proc);
+ }
+ }
+ return UNSPECIFIED;
+ case (127 & IM_COND):
+ while(NIMP(x = CDR(x))) {
+ proc = CAR(x);
+ t.arg1 = EVALCAR(proc, env);
+ if NFALSEP(t.arg1) {
+ x = CDR(proc);
+ if NULLP(x) return t.arg1;
+ if (i_arrow != CAR(x)) goto begin;
+ proc = CDR(x);
+ proc = EVALCAR(proc, env);
+ ASRTGO(NIMP(proc), badfun);
+#ifdef CAUTIOUS
+ if CLOSUREP(proc) goto checkargs1;
+#endif
+ goto evap1;
+ }
+ }
+ return UNSPECIFIED;
+ case (127 & IM_DO):
+ x = CDR(x);
+ proc = CAR(CDR(x)); /* inits */
+ t.arg1 = EOL; /* values */
+ while NIMP(proc) {
+ t.arg1 = cons(EVALCAR(proc, env), t.arg1);
+ proc = CDR(proc);
+ }
+ env = EXTEND_ENV(CAR(x), t.arg1, env);
+ x = CDR(CDR(x));
+ while (proc = CAR(x), FALSEP(EVALCAR(proc, env))) {
+ for(proc = CAR(CDR(x));NIMP(proc);proc = CDR(proc)) {
+ t.arg1 = CAR(proc); /* body */
+ SIDEVAL(t.arg1, env);
+ }
+ for(t.arg1 = EOL, proc = CDR(CDR(x)); NIMP(proc); proc = CDR(proc))
+ t.arg1 = cons(EVALCAR(proc, env), t.arg1); /* steps */
+ env = EXTEND_ENV(CAR(CAR(env)), t.arg1, CDR(env));
+ }
+ x = CDR(proc);
+ if NULLP(x) return UNSPECIFIED;
+ goto begin;
+ case (127 & IM_IF):
+ x = CDR(x);
+ if NFALSEP(EVALCAR(x, env)) x = CDR(x);
+ else if IMP(x = CDR(CDR(x))) return UNSPECIFIED;
+ goto carloop;
+ case (127 & IM_LET):
+ x = CDR(x);
+ proc = CAR(CDR(x));
+ t.arg1 = EOL;
+ do {
+ t.arg1 = cons(EVALCAR(proc, env), t.arg1);
+ } while NIMP(proc = CDR(proc));
+ env = EXTEND_ENV(CAR(x), t.arg1, env);
+ x = CDR(x);
+ goto cdrxbegin;
+ case (127 & IM_LETREC):
+ x = CDR(x);
+ env = EXTEND_ENV(CAR(x), undefineds, env);
+ x = CDR(x);
+ proc = CAR(x);
+ t.arg1 = EOL;
+ do {
+ t.arg1 = cons(EVALCAR(proc, env), t.arg1);
+ } while NIMP(proc = CDR(proc));
+ CDR(CAR(env)) = t.arg1;
+ goto cdrxbegin;
+ case (127 & IM_LETSTAR):
+ x = CDR(x);
+ proc = CAR(x);
+ if IMP(proc) {
+ env = EXTEND_ENV(EOL, EOL, env);
+ goto cdrxbegin;
+ }
+ do {
+ t.arg1 = CAR(proc);
+ proc = CDR(proc);
+ env = EXTEND_ENV(t.arg1, EVALCAR(proc, env), env);
+ } while NIMP(proc = CDR(proc));
+ goto cdrxbegin;
+ case (127 & IM_OR):
+ x = CDR(x);
+ t.arg1 = x;
+ while(NNULLP(t.arg1 = CDR(t.arg1))) {
+ x = EVALCAR(x, env);
+ if NFALSEP(x) return x;
+ x = t.arg1;
+ }
+ goto carloop;
+ case (127 & IM_LAMBDA):
+ return closure(CDR(x), env);
+ case (127 & IM_QUOTE):
+ return CAR(CDR(x));
+ case (127 & IM_SET):
+ x = CDR(x);
+ proc = CAR(x);
+ switch (7 & (int)proc) {
+ case 0:
+ t.lloc = lookupcar(x, env);
+ break;
+ case 1:
+ t.lloc = &I_VAL(proc);
+ break;
+#ifdef MEMOIZE_LOCALS
+ case 4:
+ t.lloc = ilookup(proc, env);
+ break;
+#endif
+ }
+ x = CDR(x);
+ *t.lloc = EVALCAR(x, env);
+#ifdef SICP
+ return *t.lloc;
+#else
+ return UNSPECIFIED;
+#endif
+ case (127 & IM_DEFINE): /* only for internal defines */
+ x = CDR(x);
+ proc = CAR(x);
+ x = CDR(x);
+ x = evalcar(x, env);
+ env = CAR(env);
+ DEFER_INTS;
+ CAR(env) = cons(proc, CAR(env));
+ CDR(env) = cons(x, CDR(env));
+ ALLOW_INTS;
+ return UNSPECIFIED;
+ /* new syntactic forms go here. */
+ case (127 & MAKISYM(0)):
+ proc = CAR(x);
+ ASRTGO(ISYMP(proc), badfun);
+ switch ISYMNUM(proc) {
+ case (ISYMNUM(IM_APPLY)):
+ proc = CDR(x);
+ proc = EVALCAR(proc, env);
+ ASRTGO(NIMP(proc), badfun);
+ if (CLOSUREP(proc)) {
+ t.arg1 = CDR(CDR(x));
+ t.arg1 = EVALCAR(t.arg1, env);
+#ifndef RECKLESS
+ if (badargsp(CAR(CODE(proc)), t.arg1)) goto wrongnumargs;
+#endif
+ env = EXTEND_ENV(CAR(CODE(proc)), t.arg1, ENV(proc));
+ x = CODE(proc);
+ goto cdrxbegin;
+ }
+ proc = i_apply;
+ goto evapply;
+ case (ISYMNUM(IM_CONT)):
+ t.arg1 = scm_make_cont();
+ if (proc = setjmp(CONT(t.arg1)->jmpbuf))
+#ifdef SHORT_INT
+ return (SCM)thrown_value;
+#else
+ return (SCM)proc;
+#endif
+ proc = CDR(x);
+ proc = evalcar(proc, env);
+ ASRTGO(NIMP(proc), badfun);
+#ifdef CAUTIOUS
+ if CLOSUREP(proc) {
+ checkargs1:
+ stacktrace = cons(x, stacktrace);
+ /* Check that argument list of proc can match 1 arg. */
+ arg2 = CAR(CODE(proc));
+ ASRTGO(NIMP(arg2), wrongnumargs);
+ if NCONSP(arg2) goto evap1;
+ arg2 = CDR(arg2);
+ ASRTGO(NULLP(arg2) || NCONSP(arg2), wrongnumargs);
+ }
+#endif
+ goto evap1;
+ default:
+ goto badfun;
+ }
+ default:
+ proc = x;
+ badfun:
+ everr(x, env, proc, "Wrong type to apply: ", "");
+ 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 tc7_smob:
+ return x;
+#ifdef MEMOIZE_LOCALS
+ case (127 & ILOC00):
+ proc = *ilookup(CAR(x), env);
+ ASRTGO(NIMP(proc), badfun);
+# ifndef RECKLESS
+# ifdef CAUTIOUS
+ goto checkargs;
+# endif
+# endif
+ break;
+#endif /* ifdef MEMOIZE_LOCALS */
+ case tcs_cons_gloc:
+ proc = I_VAL(CAR(x));
+ ASRTGO(NIMP(proc), badfun);
+#ifndef RECKLESS
+# ifdef CAUTIOUS
+ goto checkargs;
+# endif
+#endif
+ break;
+ case tcs_cons_nimcar:
+ if SYMBOLP(CAR(x)) {
+ proc = *lookupcar(x, env);
+ if IMP(proc) {unmemocar(x, env); goto badfun;}
+ if (tc16_macro==TYP16(proc)) {
+ unmemocar(x, env);
+ t.arg1 = apply(CDR(proc), x, cons(env, listofnull));
+ switch ((int)(CAR(proc)>>16)) {
+ case 2:
+ if (ilength(t.arg1) <= 0)
+ t.arg1 = cons2(IM_BEGIN, t.arg1, EOL);
+ DEFER_INTS;
+ CAR(x) = CAR(t.arg1);
+ CDR(x) = CDR(t.arg1);
+ ALLOW_INTS;
+ goto loop;
+ case 1:
+ if NIMP(x = t.arg1) goto loop;
+ case 0:
+ return t.arg1;
+ }
+ }
+ }
+ else proc = ceval(CAR(x), env);
+ ASRTGO(NIMP(proc), badfun);
+#ifndef RECKLESS
+# ifdef CAUTIOUS
+ checkargs:
+# endif
+ /* At this point proc is the evaluated procedure from the function
+ position and x has the form which is being evaluated. */
+ if CLOSUREP(proc) {
+# ifdef CAUTIOUS
+ stacktrace = cons(x, stacktrace);
+# endif
+ arg2 = CAR(CODE(proc));
+ t.arg1 = CDR(x);
+ while NIMP(arg2) {
+ if NCONSP(arg2) {
+ goto evapply;
+ }
+ if IMP(t.arg1) goto umwrongnumargs;
+ arg2 = CDR(arg2);
+ t.arg1 = CDR(t.arg1);
+ }
+ if NNULLP(t.arg1) goto umwrongnumargs;
+ }
+#endif
+ }
+ evapply:
+ if NULLP(CDR(x)) switch TYP7(proc) { /* no arguments given */
+ case tc7_subr_0:
+ return SUBRF(proc)();
+ case tc7_subr_1o:
+ return SUBRF(proc) (UNDEFINED);
+ case tc7_lsubr:
+ return SUBRF(proc)(EOL);
+ case tc7_rpsubr:
+ return BOOL_T;
+ case tc7_asubr:
+ return SUBRF(proc)(UNDEFINED, UNDEFINED);
+#ifdef CCLO
+ case tc7_cclo:
+ t.arg1 = proc;
+ proc = CCLO_SUBR(proc);
+ goto evap1;
+#endif
+ case tcs_closures:
+ x = CODE(proc);
+ env = EXTEND_ENV(CAR(x), EOL, ENV(proc));
+ goto cdrtcdrxbegin;
+ case tc7_contin:
+ case tc7_subr_1:
+ case tc7_subr_2:
+ case tc7_subr_2o:
+ case tc7_cxr:
+ case tc7_subr_3:
+ case tc7_lsubr_2:
+ umwrongnumargs:
+ unmemocar(x, env);
+ wrongnumargs:
+ everr(x, env, proc, (char *)WNA, "");
+ default:
+ goto badfun;
+ }
+ x = CDR(x);
+#ifdef CAUTIOUS
+ if (IMP(x)) goto wrongnumargs;
+#endif
+ t.arg1 = EVALCAR(x, env);
+ x = CDR(x);
+ if NULLP(x)
+evap1: switch TYP7(proc) { /* have one argument in t.arg1 */
+ case tc7_subr_2o:
+ return SUBRF(proc)(t.arg1, UNDEFINED);
+ case tc7_subr_1:
+ case tc7_subr_1o:
+ return SUBRF(proc)(t.arg1);
+ case tc7_cxr:
+#ifdef FLOATS
+ if SUBRF(proc) {
+ if INUMP(t.arg1)
+ return makdbl(DSUBRF(proc)((double) INUM(t.arg1)), 0.0);
+ ASRTGO(NIMP(t.arg1), floerr);
+ if REALP(t.arg1)
+ return makdbl(DSUBRF(proc)(REALPART(t.arg1)), 0.0);
+# ifdef BIGDIG
+ if BIGP(t.arg1)
+ return makdbl(DSUBRF(proc)(big2dbl(t.arg1)), 0.0);
+# endif
+ floerr:
+ wta(t.arg1, (char *)ARG1, CHARS(SNAME(proc)));
+ }
+#endif
+ proc = (SCM)SNAME(proc);
+ {
+ char *chrs = CHARS(proc)+LENGTH(proc)-1;
+ while('c' != *--chrs) {
+ ASSERT(NIMP(t.arg1) && CONSP(t.arg1),
+ t.arg1, ARG1, CHARS(proc));
+ t.arg1 = ('a'==*chrs)?CAR(t.arg1):CDR(t.arg1);
+ }
+ return t.arg1;
+ }
+ case tc7_rpsubr:
+ return BOOL_T;
+ case tc7_asubr:
+ return SUBRF(proc)(t.arg1, UNDEFINED);
+ case tc7_lsubr:
+ return SUBRF(proc)(cons(t.arg1, EOL));
+#ifdef CCLO
+ case tc7_cclo:
+ arg2 = t.arg1;
+ t.arg1 = proc;
+ proc = CCLO_SUBR(proc);
+ goto evap2;
+#endif
+ case tcs_closures:
+ x = CODE(proc);
+ env = EXTEND_ENV(CAR(x), cons(t.arg1, EOL), ENV(proc));
+ goto cdrtcdrxbegin;
+ case tc7_contin:
+ scm_dynthrow(CONT(proc), t.arg1);
+ case tc7_subr_2:
+ case tc7_subr_0:
+ case tc7_subr_3:
+ case tc7_lsubr_2:
+ goto wrongnumargs;
+ default:
+ goto badfun;
+ }
+#ifdef CAUTIOUS
+ if (IMP(x)) goto wrongnumargs;
+#endif
+ { /* have two or more arguments */
+ arg2 = EVALCAR(x, env);
+ x = CDR(x);
+ if NULLP(x)
+#ifdef CCLO
+ evap2:
+#endif
+ switch TYP7(proc) { /* have two arguments */
+ case tc7_subr_2:
+ case tc7_subr_2o:
+ return SUBRF(proc)(t.arg1, arg2);
+ case tc7_lsubr:
+ return SUBRF(proc)(cons2(t.arg1, arg2, EOL));
+ case tc7_lsubr_2:
+ return SUBRF(proc)(t.arg1, arg2, EOL);
+ case tc7_rpsubr:
+ case tc7_asubr:
+ return SUBRF(proc)(t.arg1, arg2);
+#ifdef CCLO
+ cclon: case tc7_cclo:
+ return apply(CCLO_SUBR(proc), proc,
+ cons2(t.arg1, arg2, cons(eval_args(x, env), EOL)));
+/* case tc7_cclo:
+ x = cons(arg2, eval_args(x, env));
+ arg2 = t.arg1;
+ t.arg1 = proc;
+ proc = CCLO_SUBR(proc);
+ goto evap3; */
+#endif
+ case tc7_subr_0:
+ case tc7_cxr:
+ case tc7_subr_1o:
+ case tc7_subr_1:
+ case tc7_subr_3:
+ case tc7_contin:
+ goto wrongnumargs;
+ default:
+ goto badfun;
+ case tcs_closures:
+ env = EXTEND_ENV(CAR(CODE(proc)), cons2(t.arg1, arg2, EOL), ENV(proc));
+ x = CODE(proc);
+ goto cdrtcdrxbegin;
+ }
+ switch TYP7(proc) { /* have 3 or more arguments */
+ case tc7_subr_3:
+ ASRTGO(NULLP(CDR(x)), wrongnumargs);
+ return SUBRF(proc)(t.arg1, arg2, EVALCAR(x, env));
+ 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, t.arg1, acons(arg2, eval_args(x, env), EOL));
+ case tc7_lsubr_2:
+ return SUBRF(proc)(t.arg1, arg2, eval_args(x, env));
+ case tc7_lsubr:
+ return SUBRF(proc)(cons2(t.arg1, arg2, eval_args(x, env)));
+#ifdef CCLO
+ case tc7_cclo: goto cclon;
+#endif
+ case tcs_closures:
+ env = EXTEND_ENV(CAR(CODE(proc)),
+ cons2(t.arg1, arg2, eval_args(x, env)),
+ ENV(proc));
+ x = CODE(proc);
+ goto cdrtcdrxbegin;
+ case tc7_subr_2:
+ case tc7_subr_1o:
+ case tc7_subr_2o:
+ case tc7_subr_0:
+ case tc7_cxr:
+ case tc7_subr_1:
+ case tc7_contin:
+ goto wrongnumargs;
+ default:
+ goto badfun;
+ }
+ }
+}
+
+SCM procedurep(obj)
+ SCM obj;
+{
+ if NIMP(obj) switch TYP7(obj) {
+ case tcs_closures:
+ case tc7_contin:
+ case tcs_subrs:
+#ifdef CCLO
+ case tc7_cclo:
+#endif
+ return BOOL_T;
+ }
+ return BOOL_F;
+}
+
+static char s_proc_doc[] = "procedure-documentation";
+SCM l_proc_doc(proc)
+ SCM proc;
+{
+ SCM code;
+ ASSERT(BOOL_T==procedurep(proc) && NIMP(proc) && TYP7(proc) != tc7_contin,
+ proc, ARG1, s_proc_doc);
+ switch TYP7(proc) {
+ case tcs_closures:
+ code = CDR(CODE(proc));
+ if IMP(CDR(code)) return BOOL_F;
+ code = CAR(code);
+ if IMP(code) return BOOL_F;
+ if STRINGP(code) return code;
+ default:
+ return BOOL_F;
+/*
+ case tcs_subrs:
+#ifdef CCLO
+ case tc7_cclo:
+#endif
+*/
+ }
+}
+
+/* This code is for apply. it is destructive on multiple args.
+ This will only screw you if you do (apply apply '( ... )) */
+SCM nconc2last(lst)
+ SCM lst;
+{
+ SCM *lloc = &lst;
+#ifdef CAUTIOUS
+ ASSERT(ilength(lst) >= 1, lst, WNA, s_apply);
+#endif
+ while NNULLP(CDR(*lloc)) lloc = &CDR(*lloc);
+#ifdef CAUTIOUS
+ ASSERT(ilength(CAR(*lloc)) >= 0, lst, ARGn, s_apply);
+#endif
+ *lloc = CAR(*lloc);
+ return lst;
+}
+
+
+SCM apply(proc, arg1, args)
+ SCM proc, arg1, args;
+{
+ ASRTGO(NIMP(proc), badproc);
+ if NULLP(args)
+ if NULLP(arg1) arg1 = UNDEFINED;
+ else {
+ args = CDR(arg1);
+ arg1 = CAR(arg1);
+ }
+ else {
+ /* ASRTGO(NIMP(args) && CONSP(args), wrongnumargs); */
+ args = nconc2last(args);
+ }
+#ifdef CCLO
+ tail:
+#endif
+ switch TYP7(proc) {
+ case tc7_subr_2o:
+ args = NULLP(args)?UNDEFINED:CAR(args);
+ return SUBRF(proc)(arg1, args);
+ case tc7_subr_2:
+ ASRTGO(NULLP(CDR(args)), wrongnumargs);
+ args = CAR(args);
+ return SUBRF(proc)(arg1, args);
+ case tc7_subr_0:
+ ASRTGO(UNBNDP(arg1), wrongnumargs);
+ return SUBRF(proc)();
+ case tc7_subr_1:
+ case tc7_subr_1o:
+ ASRTGO(NULLP(args), wrongnumargs);
+ 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, CHARS(SNAME(proc)));
+ }
+#endif
+ proc = (SCM)SNAME(proc);
+ {
+ char *chrs = CHARS(proc)+LENGTH(proc)-1;
+ while('c' != *--chrs) {
+ ASSERT(NIMP(arg1) && CONSP(arg1),
+ arg1, ARG1, CHARS(proc));
+ arg1 = ('a'==*chrs)?CAR(arg1):CDR(arg1);
+ }
+ return arg1;
+ }
+ case tc7_subr_3:
+ return SUBRF(proc)(arg1, CAR(args), CAR(CDR(args)));
+ case tc7_lsubr:
+ return SUBRF(proc)(UNBNDP(arg1) ? EOL : cons(arg1, args));
+ case tc7_lsubr_2:
+ ASRTGO(NIMP(args) && CONSP(args), wrongnumargs);
+ return SUBRF(proc)(arg1, CAR(args), CDR(args));
+ case tc7_asubr:
+ if NULLP(args) return SUBRF(proc)(arg1, UNDEFINED);
+ while NIMP(args) {
+ ASSERT(CONSP(args), args, ARG2, s_apply);
+ arg1 = SUBRF(proc)(arg1, CAR(args));
+ args = CDR(args);
+ }
+ return arg1;
+ case tc7_rpsubr:
+ if NULLP(args) return BOOL_T;
+ while NIMP(args) {
+ ASSERT(CONSP(args), args, ARG2, s_apply);
+ if FALSEP(SUBRF(proc)(arg1, CAR(args))) return BOOL_F;
+ arg1 = CAR(args);
+ args = CDR(args);
+ }
+ return BOOL_T;
+ case tcs_closures:
+ arg1 = (UNBNDP(arg1) ? EOL : cons(arg1, args));
+#ifndef RECKLESS
+ if (badargsp(CAR(CODE(proc)), arg1)) goto wrongnumargs;
+#endif
+ args = EXTEND_ENV(CAR(CODE(proc)), arg1, ENV(proc));
+ proc = CODE(proc);
+ while NNULLP(proc = CDR(proc)) arg1 = EVALCAR(proc, args);
+ return arg1;
+ case tc7_contin:
+ ASRTGO(NULLP(args), wrongnumargs);
+ scm_dynthrow(CONT(proc), arg1);
+#ifdef CCLO
+ case tc7_cclo:
+ args = (UNBNDP(arg1) ? EOL : cons(arg1, args));
+ arg1 = proc;
+ proc = CCLO_SUBR(proc);
+ goto tail;
+#endif
+ wrongnumargs:
+ wta(proc, (char *)WNA, s_apply);
+ default:
+ badproc:
+ wta(proc, (char *)ARG1, s_apply);
+ return arg1;
+ }
+}
+
+SCM map(proc, arg1, args)
+ SCM proc, arg1, args;
+{
+ long i;
+ SCM res = EOL, *pres = &res;
+ SCM *ve = &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);
+#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 for_each(proc, arg1, args)
+ SCM proc, arg1, args;
+{
+ SCM *ve = &args; /* Keep args from being optimized away. */
+ long i;
+ 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 closure(code, env)
+ SCM code, env;
+{
+ register SCM z;
+ NEWCELL(z);
+ SETCODE(z, code);
+ ENV(z) = env;
+ return z;
+}
+
+long tc16_promise;
+SCM makprom(code)
+ SCM code;
+{
+ register SCM z;
+ NEWCELL(z);
+ CDR(z) = code;
+ CAR(z) = tc16_promise;
+ return z;
+}
+static int prinprom(exp, port, writing)
+ SCM exp;
+ SCM port;
+ int writing;
+{
+ lputs("#<promise ", port);
+ iprin1(CDR(exp), port, writing);
+ lputc('>', port);
+ return !0;
+}
+
+SCM makacro(code)
+ SCM code;
+{
+ register SCM z;
+ NEWCELL(z);
+ CDR(z) = code;
+ CAR(z) = tc16_macro;
+ return z;
+}
+SCM makmacro(code)
+ SCM code;
+{
+ register SCM z;
+ NEWCELL(z);
+ CDR(z) = code;
+ CAR(z) = tc16_macro | (1L<<16);
+ return z;
+}
+SCM makmmacro(code)
+ SCM code;
+{
+ register SCM z;
+ NEWCELL(z);
+ CDR(z) = code;
+ CAR(z) = tc16_macro | (2L<<16);
+ return z;
+}
+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) & (2L<<16)) lputc('!', port);
+ lputc(' ', port);
+ iprin1(CDR(exp), port, writing);
+ lputc('>', port);
+ return !0;
+}
+
+char s_force[] = "force";
+SCM force(x)
+ SCM x;
+{
+ ASSERT((TYP16(x)==tc16_promise), x, ARG1, s_force);
+ if (!((1L<<16) & CAR(x))) {
+ SCM ans = apply(CDR(x), EOL, EOL);
+ if (!((1L<<16) & CAR(x))) {
+ DEFER_INTS;
+ CDR(x) = ans;
+ CAR(x) |= (1L<<16);
+ ALLOW_INTS;
+ }
+ }
+ return CDR(x);
+}
+
+SCM copytree(obj)
+ SCM obj;
+{
+ SCM ans, tl;
+ if IMP(obj) return obj;
+ if VECTORP(obj) {
+ sizet i = LENGTH(obj);
+ ans = make_vector(MAKINUM(i), UNSPECIFIED);
+ while(i--) VELTS(ans)[i] = copytree(VELTS(obj)[i]);
+ return ans;
+ }
+ if NCONSP(obj) return obj;
+/* return cons(copytree(CAR(obj)), copytree(CDR(obj))); */
+ ans = tl = cons(copytree(CAR(obj)), UNSPECIFIED);
+ while(NIMP(obj = CDR(obj)) && CONSP(obj))
+ tl = (CDR(tl) = cons(copytree(CAR(obj)), UNSPECIFIED));
+ CDR(tl) = obj;
+ return ans;
+}
+SCM eval(obj)
+ SCM obj;
+{
+ obj = copytree(obj);
+ return EVAL(obj, (SCM)EOL);
+}
+
+SCM definedp(x, env)
+ SCM x, env;
+{
+ SCM proc = CAR(x = CDR(x));
+ return (ISYMP(proc)
+ || (NIMP(proc) && SYMBOLP(proc)
+ && !UNBNDP(CDR(sym2vcell(proc)))))?
+ (SCM)BOOL_T : (SCM)BOOL_F;
+}
+
+static iproc subr1s[] = {
+ {"copy-tree", copytree},
+ {s_eval, eval},
+ {s_force, force},
+ {s_proc_doc, l_proc_doc},
+ {"procedure->syntax", makacro},
+ {"procedure->macro", makmacro},
+ {"procedure->memoizing-macro", makmmacro},
+ {"apply:nconc-to-last", nconc2last},
+ {0, 0}};
+
+static iproc lsubr2s[] = {
+/* {s_apply, apply}, now explicity initted */
+ {s_map, map},
+ {s_for_each, for_each},
+ {0, 0}};
+
+static smobfuns promsmob = {markcdr, free0, prinprom};
+static smobfuns macrosmob = {markcdr, free0, prinmacro};
+
+SCM make_synt(name, macroizer, fcn)
+ 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);
+ return CAR(symcell);
+}
+
+void init_eval()
+{
+ tc16_promise = newsmob(&promsmob);
+ tc16_macro = newsmob(&macrosmob);
+ init_iprocs(subr1s, tc7_subr_1);
+ init_iprocs(lsubr2s, tc7_lsubr_2);
+ i_apply = make_subr(s_apply, tc7_lsubr_2, apply);
+ i_dot = CAR(sysintern(".", UNDEFINED));
+ i_arrow = CAR(sysintern("=>", UNDEFINED));
+ i_else = CAR(sysintern("else", UNDEFINED));
+ i_unquote = CAR(sysintern("unquote", UNDEFINED));
+ i_uq_splicing = CAR(sysintern("unquote-splicing", UNDEFINED));
+
+ /* acros */
+ i_quasiquote = make_synt(s_quasiquote, makacro, m_quasiquote);
+ make_synt(s_define, makmmacro, m_define);
+ make_synt(s_delay, makacro, m_delay);
+ /* end of acros */
+
+ make_synt(s_and, makmmacro, m_and);
+ make_synt(s_begin, makmmacro, m_begin);
+ make_synt(s_case, makmmacro, m_case);
+ make_synt(s_cond, makmmacro, m_cond);
+ make_synt(s_do, makmmacro, m_do);
+ make_synt(s_if, makmmacro, m_if);
+ i_lambda = make_synt(s_lambda, makmmacro, m_lambda);
+ i_let = make_synt(s_let, makmmacro, m_let);
+ make_synt(s_letrec, makmmacro, m_letrec);
+ make_synt(s_letstar, makmmacro, m_letstar);
+ make_synt(s_or, makmmacro, m_or);
+ i_quote = make_synt(s_quote, makmmacro, m_quote);
+ make_synt(s_set, makmmacro, m_set);
+ make_synt(s_atapply, makmmacro, m_apply);
+ make_synt(s_atcall_cc, makmmacro, m_cont);
+
+ make_synt("defined?", makacro, definedp);
+}
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-22 02:59:32 +0000