diff options
author | Jim Blandy <jimb@red-bean.com> | 1996-07-25 22:56:11 +0000 |
---|---|---|
committer | Jim Blandy <jimb@red-bean.com> | 1996-07-25 22:56:11 +0000 |
commit | 0f2d19dd46f83f41177f61d585732b32a866d613 (patch) | |
tree | 86bf67b8c05d36d8181d393e7d706785a74ee777 /libguile/eval.c | |
download | guile-0f2d19dd46f83f41177f61d585732b32a866d613.tar.gz |
maintainer changed: was lord, now jimb; first import
Diffstat (limited to 'libguile/eval.c')
-rw-r--r-- | libguile/eval.c | 2513 |
1 files changed, 2513 insertions, 0 deletions
diff --git a/libguile/eval.c b/libguile/eval.c new file mode 100644 index 000000000..7b2f3600e --- /dev/null +++ b/libguile/eval.c @@ -0,0 +1,2513 @@ +/* Copyright (C) 1995,1996 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. + */ + + +/* This file is read twice in order to produce a second debugging + * version of scm_ceval called scm_deval. scm_deval is produced when + * we define the preprocessor macro DEVAL. + */ + +#ifndef DEVAL + +#include <stdio.h> +#include "_scm.h" + + + +#define EVALCELLCAR(x, env) (SCM_SYMBOLP (SCM_CAR(x)) \ + ? *scm_lookupcar(x, env) \ + : SCM_CEVAL(SCM_CAR(x), env)) + +#ifdef MEMOIZE_LOCALS +#define EVALIMP(x, env) (SCM_ILOCP(x)?*scm_ilookup((x), env):x) +#else +#define EVALIMP(x, env) x +#endif +#define EVALCAR(x, env) (SCM_NCELLP(SCM_CAR(x))\ + ? (SCM_IMP(SCM_CAR(x)) \ + ? EVALIMP(SCM_CAR(x), env) \ + : SCM_GLOC_VAL(SCM_CAR(x))) \ + : EVALCELLCAR(x, env)) +#ifdef DEBUG_EXTENSIONS +#define XEVALCAR(x, env) (SCM_NCELLP(SCM_CAR(x)) \ + ? (SCM_IMP(SCM_CAR(x)) \ + ? EVALIMP(SCM_CAR(x), env) \ + : SCM_GLOC_VAL(SCM_CAR(x))) \ + : (SCM_SYMBOLP(SCM_CAR(x)) \ + ? *scm_lookupcar(x, env) \ + : (*scm_ceval_ptr) (SCM_CAR(x), env))) +#else +#define XEVALCAR(x, env) EVALCAR(x, env) +#endif + +#define EXTEND_SCM_ENV SCM_EXTEND_SCM_ENV + +#ifdef MEMOIZE_LOCALS +#ifdef __STDC__ +SCM * +scm_ilookup (SCM iloc, SCM env) +#else +SCM * +scm_ilookup (iloc, env) + SCM iloc; + SCM env; +#endif +{ + register int ir = SCM_IFRAME (iloc); + register SCM er = env; + for (; 0 != ir; --ir) + er = SCM_CDR (er); + er = SCM_CAR (er); + for (ir = SCM_IDIST (iloc); 0 != ir; --ir) + er = SCM_CDR (er); + if (SCM_ICDRP (iloc)) + return &SCM_CDR (er); + return &SCM_CAR (SCM_CDR (er)); +} +#endif + +#ifdef __STDC__ +SCM * +scm_lookupcar (SCM vloc, SCM genv) +#else +SCM * +scm_lookupcar (vloc, genv) + SCM vloc; + SCM genv; +#endif +{ + SCM env = genv; + register SCM *al, fl, var = SCM_CAR (vloc); +#ifdef MEMOIZE_LOCALS + register SCM iloc = SCM_ILOC00; +#endif + for (; SCM_NIMP (env); env = SCM_CDR (env)) + { + if (SCM_BOOL_T == scm_procedure_p (SCM_CAR (env))) + break; + al = &SCM_CAR (env); + for (fl = SCM_CAR (*al); SCM_NIMP (fl); fl = SCM_CDR (fl)) + { + if (SCM_NCONSP (fl)) + if (fl == var) + { +#ifdef MEMOIZE_LOCALS + SCM_CAR (vloc) = iloc + SCM_ICDR; +#endif + return &SCM_CDR (*al); + } + else + break; + al = &SCM_CDR (*al); + if (SCM_CAR (fl) == var) + { +#ifdef MEMOIZE_LOCALS +#ifndef RECKLESS /* letrec inits to SCM_UNDEFINED */ + if (SCM_UNBNDP (SCM_CAR (*al))) + { + env = SCM_EOL; + goto errout; + } +#endif + SCM_CAR (vloc) = iloc; +#endif + return &SCM_CAR (*al); + } +#ifdef MEMOIZE_LOCALS + iloc += SCM_IDINC; +#endif + } +#ifdef MEMOIZE_LOCALS + iloc = (~SCM_IDSTMSK) & (iloc + SCM_IFRINC); +#endif + } + { + SCM top_thunk, vcell; + if (SCM_NIMP(env)) + { + top_thunk = SCM_CAR(env); /* env now refers to a top level env thunk */ + env = SCM_CDR (env); + } + else + top_thunk = SCM_BOOL_F; + vcell = scm_sym2vcell (var, top_thunk, SCM_BOOL_F); + if (vcell == SCM_BOOL_F) + goto errout; + else + var = vcell; + } +#ifndef RECKLESS + if (SCM_NNULLP (env) || SCM_UNBNDP (SCM_CDR (var))) + { + var = SCM_CAR (var); + errout: + scm_everr (vloc, genv, var, + (SCM_NULLP (env) + ? "unbound variable: " + : "damaged environment"), + ""); + } +#endif + SCM_CAR (vloc) = var + 1; + /* Except wait...what if the var is not a vcell, + * but syntax or something.... + */ + return &SCM_CDR (var); +} + +#define unmemocar scm_unmemocar +#ifdef __STDC__ +SCM +scm_unmemocar (SCM form, SCM env) +#else +SCM +scm_unmemocar (form, env) + SCM form; + SCM env; +#endif +{ + register int ir; + SCM c; + + if (SCM_IMP (form)) + return form; + c = SCM_CAR (form); + if (1 == (c & 7)) + SCM_CAR (form) = SCM_CAR (c - 1); +#ifdef MEMOIZE_LOCALS + else if (SCM_ILOCP (c)) + { + for (ir = SCM_IFRAME (c); ir != 0; --ir) + env = SCM_CDR (env); + env = SCM_CAR (SCM_CAR (env)); + for (ir = SCM_IDIST (c); ir != 0; --ir) + env = SCM_CDR (env); + SCM_CAR (form) = SCM_ICDRP (c) ? env : SCM_CAR (env); + } +#endif + return form; +} + +#ifdef __STDC__ +SCM +scm_eval_car (SCM pair, SCM env) +#else +SCM +scm_eval_car (pair, env) + SCM pair; + SCM env; +#endif +{ + return EVALCAR (pair, env); +} + + +/* + * 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))scm_wta(_arg, (char *)_pos, _subr); + +SCM scm_i_dot, scm_i_quote, scm_i_quasiquote, scm_i_lambda, scm_i_let, + scm_i_arrow, scm_i_else, scm_i_unquote, scm_i_uq_splicing, scm_i_apply; +SCM scm_i_name; +#ifdef DEBUG_EXTENSIONS +static SCM enter_frame_sym, exit_frame_sym; +#endif +static char s_quasiquote[] = "quasiquote"; +static char s_delay[] = "delay"; + +#define ASRTSYNTAX(cond_, msg_) if(!(cond_))scm_wta(xorig, (msg_), what); + + +#ifdef __STDC__ +static void +bodycheck (SCM xorig, SCM *bodyloc, char *what) +#else +static void +bodycheck (xorig, bodyloc, what) + SCM xorig; + SCM *bodyloc; + char *what; +#endif +{ + ASRTSYNTAX (scm_ilength (*bodyloc) >= 1, s_expression); +} + + +#ifdef __STDC__ +SCM +scm_m_quote (SCM xorig, SCM env) +#else +SCM +scm_m_quote (xorig, env) + SCM xorig; + SCM env; +#endif +{ + ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, xorig, s_expression, "quote"); + return scm_cons (SCM_IM_QUOTE, SCM_CDR (xorig)); +} + + +#ifdef __STDC__ +SCM +scm_m_begin (SCM xorig, SCM env) +#else +SCM +scm_m_begin (xorig, env) + SCM xorig; + SCM env; +#endif +{ + ASSYNT (scm_ilength (SCM_CDR (xorig)) >= 1, xorig, s_expression, "begin"); + return scm_cons (SCM_IM_BEGIN, SCM_CDR (xorig)); +} + + +#ifdef __STDC__ +SCM +scm_m_if (SCM xorig, SCM env) +#else +SCM +scm_m_if (xorig, env) + SCM xorig; + SCM env; +#endif +{ + int len = scm_ilength (SCM_CDR (xorig)); + ASSYNT (len >= 2 && len <= 3, xorig, s_expression, "if"); + return scm_cons (SCM_IM_IF, SCM_CDR (xorig)); +} + + +#ifdef __STDC__ +SCM +scm_m_set (SCM xorig, SCM env) +#else +SCM +scm_m_set (xorig, env) + SCM xorig; + SCM env; +#endif +{ + SCM x; + int len; + + x = SCM_CDR (xorig); + len = scm_ilength (x); + ASSYNT ((len > 0) && !(len & 1), xorig, s_expression, "set!"); + + { + SCM y; + y = x; + while (len) + { + ASSYNT (SCM_NIMP (SCM_CAR (y)) && SCM_SYMBOLP (SCM_CAR (y)), + xorig, s_variable, "set!"); + y = SCM_CDR (SCM_CDR (x)); + len -= 2; + } + } + return scm_cons (SCM_IM_SET, x); +} + + +#if 0 +#ifdef __STDC__ +SCM +scm_m_vref (SCM xorig, SCM env) +#else +SCM +scm_m_vref (xorig, env) + SCM xorig; + SCM env; +#endif +{ + SCM x = SCM_CDR (xorig); + ASSYNT (1 == scm_ilength (x), xorig, s_expression, s_vref); + if (SCM_NIMP(x) && UDSCM_VARIABLEP (SCM_CAR (x))) + { + scm_everr (SCM_UNDEFINED, env, SCM_CAR(SCM_CDR(x)), s_variable, + "global variable reference"); + } + ASSYNT (SCM_NIMP(x) && DEFSCM_VARIABLEP (SCM_CAR (x)), + xorig, s_variable, s_vref); + return + return scm_cons (IM_VREF, x); +} + + +#ifdef __STDC__ +SCM +scm_m_vset (SCM xorig, SCM env) +#else +SCM +scm_m_vset (xorig, env) + SCM xorig; + SCM env; +#endif +{ + SCM x = SCM_CDR (xorig); + ASSYNT (3 == scm_ilength (x), xorig, s_expression, s_vset); + ASSYNT (( DEFSCM_VARIABLEP (SCM_CAR (x)) + || UDSCM_VARIABLEP (SCM_CAR (x))), + xorig, s_variable, s_vset); + return scm_cons (IM_VSET, x); +} +#endif + + +#ifdef __STDC__ +SCM +scm_m_and (SCM xorig, SCM env) +#else +SCM +scm_m_and (xorig, env) + SCM xorig; + SCM env; +#endif +{ + int len = scm_ilength (SCM_CDR (xorig)); + ASSYNT (len >= 0, xorig, s_test, "and"); + if (len >= 1) + return scm_cons (SCM_IM_AND, SCM_CDR (xorig)); + else + return SCM_BOOL_T; +} + + +#ifdef __STDC__ +SCM +scm_m_or (SCM xorig, SCM env) +#else +SCM +scm_m_or (xorig, env) + SCM xorig; + SCM env; +#endif +{ + int len = scm_ilength (SCM_CDR (xorig)); + ASSYNT (len >= 0, xorig, s_test, "or"); + if (len >= 1) + return scm_cons (SCM_IM_OR, SCM_CDR (xorig)); + else + return SCM_BOOL_F; +} + + +#ifdef __STDC__ +SCM +scm_m_case (SCM xorig, SCM env) +#else +SCM +scm_m_case (xorig, env) + SCM xorig; + SCM env; +#endif +{ + SCM proc, x = SCM_CDR (xorig); + ASSYNT (scm_ilength (x) >= 2, xorig, s_clauses, "case"); + while (SCM_NIMP (x = SCM_CDR (x))) + { + proc = SCM_CAR (x); + ASSYNT (scm_ilength (proc) >= 2, xorig, s_clauses, "case"); + ASSYNT (scm_ilength (SCM_CAR (proc)) >= 0 || scm_i_else == SCM_CAR (proc), + xorig, s_clauses, "case"); + } + return scm_cons (SCM_IM_CASE, SCM_CDR (xorig)); +} + + +#ifdef __STDC__ +SCM +scm_m_cond (SCM xorig, SCM env) +#else +SCM +scm_m_cond (xorig, env) + SCM xorig; + SCM env; +#endif +{ + SCM arg1, x = SCM_CDR (xorig); + int len = scm_ilength (x); + ASSYNT (len >= 1, xorig, s_clauses, "cond"); + while (SCM_NIMP (x)) + { + arg1 = SCM_CAR (x); + len = scm_ilength (arg1); + ASSYNT (len >= 1, xorig, s_clauses, "cond"); + if (scm_i_else == SCM_CAR (arg1)) + { + ASSYNT (SCM_NULLP (SCM_CDR (x)) && len >= 2, xorig, "bad ELSE clause", "cond"); + SCM_CAR (arg1) = SCM_BOOL_T; + } + if (len >= 2 && scm_i_arrow == SCM_CAR (SCM_CDR (arg1))) + ASSYNT (3 == len && SCM_NIMP (SCM_CAR (SCM_CDR (SCM_CDR (arg1)))), + xorig, "bad recipient", "cond"); + x = SCM_CDR (x); + } + return scm_cons (SCM_IM_COND, SCM_CDR (xorig)); +} + + +#ifdef __STDC__ +SCM +scm_m_lambda (SCM xorig, SCM env) +#else +SCM +scm_m_lambda (xorig, env) + SCM xorig; + SCM env; +#endif +{ + SCM proc, x = SCM_CDR (xorig); + if (scm_ilength (x) < 2) + goto badforms; + proc = SCM_CAR (x); + if SCM_NULLP + (proc) goto memlambda; + if SCM_IMP + (proc) goto badforms; + if SCM_SYMBOLP + (proc) goto memlambda; + if SCM_NCONSP + (proc) goto badforms; + while SCM_NIMP + (proc) + { + if SCM_NCONSP + (proc) + if (!SCM_SYMBOLP (proc)) + goto badforms; + else + goto memlambda; + if (!(SCM_NIMP (SCM_CAR (proc)) && SCM_SYMBOLP (SCM_CAR (proc)))) + goto badforms; + proc = SCM_CDR (proc); + } + if SCM_NNULLP + (proc) + badforms:scm_wta (xorig, s_formals, "lambda"); +memlambda: + bodycheck (xorig, &SCM_CDR (x), "lambda"); + return scm_cons (SCM_IM_LAMBDA, SCM_CDR (xorig)); +} + + +#ifdef __STDC__ +SCM +scm_m_letstar (SCM xorig, SCM env) +#else +SCM +scm_m_letstar (xorig, env) + SCM xorig; + SCM env; +#endif +{ + SCM x = SCM_CDR (xorig), arg1, proc, vars = SCM_EOL, *varloc = &vars; + int len = scm_ilength (x); + ASSYNT (len >= 2, xorig, s_body, "let*"); + proc = SCM_CAR (x); + ASSYNT (scm_ilength (proc) >= 0, xorig, s_bindings, "let*"); + while SCM_NIMP + (proc) + { + arg1 = SCM_CAR (proc); + ASSYNT (2 == scm_ilength (arg1), xorig, s_bindings, "let*"); + ASSYNT (SCM_NIMP (SCM_CAR (arg1)) && SCM_SYMBOLP (SCM_CAR (arg1)), xorig, s_variable, "let*"); + *varloc = scm_cons2 (SCM_CAR (arg1), SCM_CAR (SCM_CDR (arg1)), SCM_EOL); + varloc = &SCM_CDR (SCM_CDR (*varloc)); + proc = SCM_CDR (proc); + } + x = scm_cons (vars, SCM_CDR (x)); + bodycheck (xorig, &SCM_CDR (x), "let*"); + return scm_cons (SCM_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 + */ + + +#ifdef __STDC__ +SCM +scm_m_do (SCM xorig, SCM env) +#else +SCM +scm_m_do (xorig, env) + SCM xorig; + SCM env; +#endif +{ + SCM x = SCM_CDR (xorig), arg1, proc; + SCM vars = SCM_EOL, inits = SCM_EOL, steps = SCM_EOL; + SCM *initloc = &inits, *steploc = &steps; + int len = scm_ilength (x); + ASSYNT (len >= 2, xorig, s_test, "do"); + proc = SCM_CAR (x); + ASSYNT (scm_ilength (proc) >= 0, xorig, s_bindings, "do"); + while SCM_NIMP + (proc) + { + arg1 = SCM_CAR (proc); + len = scm_ilength (arg1); + ASSYNT (2 == len || 3 == len, xorig, s_bindings, "do"); + ASSYNT (SCM_NIMP (SCM_CAR (arg1)) && SCM_SYMBOLP (SCM_CAR (arg1)), xorig, s_variable, "do"); + /* vars reversed here, inits and steps reversed at evaluation */ + vars = scm_cons (SCM_CAR (arg1), vars); /* variable */ + arg1 = SCM_CDR (arg1); + *initloc = scm_cons (SCM_CAR (arg1), SCM_EOL); /* init */ + initloc = &SCM_CDR (*initloc); + arg1 = SCM_CDR (arg1); + *steploc = scm_cons (SCM_IMP (arg1) ? SCM_CAR (vars) : SCM_CAR (arg1), SCM_EOL); /* step */ + steploc = &SCM_CDR (*steploc); + proc = SCM_CDR (proc); + } + x = SCM_CDR (x); + ASSYNT (scm_ilength (SCM_CAR (x)) >= 1, xorig, s_test, "do"); + x = scm_cons2 (SCM_CAR (x), SCM_CDR (x), steps); + x = scm_cons2 (vars, inits, x); + bodycheck (xorig, &SCM_CAR (SCM_CDR (SCM_CDR (x))), "do"); + return scm_cons (SCM_IM_DO, x); +} + +/* evalcar is small version of inline EVALCAR when we don't care about speed */ +#ifdef __STDC__ +static SCM +evalcar (SCM x, SCM env) +#else +static SCM +evalcar (x, env) + SCM x; + SCM env; +#endif +{ + return XEVALCAR (x, env); +} + +#ifdef __STDC__ +static SCM +iqq (SCM form, SCM env, int depth) +#else +static SCM +iqq (form, env, depth) + SCM form; + SCM env; + int depth; +#endif +{ + SCM tmp; + int edepth = depth; + if SCM_IMP + (form) return form; + if (SCM_VECTORP (form)) + { + long i = SCM_LENGTH (form); + SCM *data = SCM_VELTS (form); + tmp = SCM_EOL; + for (; --i >= 0;) + tmp = scm_cons (data[i], tmp); + return scm_vector (iqq (tmp, env, depth)); + } + if SCM_NCONSP + (form) return form; + tmp = SCM_CAR (form); + if (scm_i_quasiquote == tmp) + { + depth++; + goto label; + } + if (scm_i_unquote == tmp) + { + --depth; + label: + form = SCM_CDR (form); + /* !!! might need a check here to be sure that form isn't a struct. */ + SCM_ASSERT (SCM_NIMP (form) && SCM_ECONSP (form) && SCM_NULLP (SCM_CDR (form)), + form, SCM_ARG1, s_quasiquote); + if (0 == depth) + return evalcar (form, env); + return scm_cons2 (tmp, iqq (SCM_CAR (form), env, depth), SCM_EOL); + } + if (SCM_NIMP (tmp) && (scm_i_uq_splicing == SCM_CAR (tmp))) + { + tmp = SCM_CDR (tmp); + if (0 == --edepth) + return scm_append (scm_cons2 (evalcar (tmp, env), iqq (SCM_CDR (form), env, depth), SCM_EOL)); + } + return scm_cons (iqq (SCM_CAR (form), env, edepth), iqq (SCM_CDR (form), env, depth)); +} + +/* Here are acros which return values rather than code. */ + +#ifdef __STDC__ +SCM +scm_m_quasiquote (SCM xorig, SCM env) +#else +SCM +scm_m_quasiquote (xorig, env) + SCM xorig; + SCM env; +#endif +{ + SCM x = SCM_CDR (xorig); + ASSYNT (scm_ilength (x) == 1, xorig, s_expression, s_quasiquote); + return iqq (SCM_CAR (x), env, 1); +} + +#ifdef __STDC__ +SCM +scm_m_delay (SCM xorig, SCM env) +#else +SCM +scm_m_delay (xorig, env) + SCM xorig; + SCM env; +#endif +{ + ASSYNT (scm_ilength (xorig) == 2, xorig, s_expression, s_delay); + xorig = SCM_CDR (xorig); + return scm_makprom (scm_closure (scm_cons2 (SCM_EOL, SCM_CAR (xorig), SCM_CDR (xorig)), + env)); +} + +#ifdef __STDC__ +static SCM +env_top_level (SCM env) +#else +static SCM +env_top_level (env) + SCM env; +#endif +{ + while (SCM_NIMP(env)) + { + if (SCM_BOOL_T == scm_procedure_p (SCM_CAR(env))) + return SCM_CAR(env); + env = SCM_CDR (env); + } + return SCM_BOOL_F; +} + +#ifdef __STDC__ +SCM +scm_m_define (SCM x, SCM env) +#else +SCM +scm_m_define (x, env) + SCM x; + SCM env; +#endif +{ + SCM proc, arg1 = x; + x = SCM_CDR (x); + /* ASSYNT(SCM_NULLP(env), x, "bad placement", s_define);*/ + ASSYNT (scm_ilength (x) >= 2, arg1, s_expression, "define"); + proc = SCM_CAR (x); + x = SCM_CDR (x); + while (SCM_NIMP (proc) && SCM_CONSP (proc)) + { /* nested define syntax */ + x = scm_cons (scm_cons2 (scm_i_lambda, SCM_CDR (proc), x), SCM_EOL); + proc = SCM_CAR (proc); + } + ASSYNT (SCM_NIMP (proc) && SCM_SYMBOLP (proc), arg1, s_variable, "define"); + ASSYNT (1 == scm_ilength (x), arg1, s_expression, "define"); + if (SCM_TOP_LEVEL (env)) + { + x = evalcar (x, env); + arg1 = scm_sym2vcell (proc, env_top_level (env), SCM_BOOL_T); +#if 0 +#ifndef RECKLESS + if (SCM_NIMP (SCM_CDR (arg1)) && ((SCM) SCM_SNAME (SCM_CDR (arg1)) == proc) + && (SCM_CDR (arg1) != x)) + scm_warn ("redefining built-in ", SCM_CHARS (proc)); + else +#endif + if (5 <= scm_verbose && SCM_UNDEFINED != SCM_CDR (arg1)) + scm_warn ("redefining ", SCM_CHARS (proc)); +#endif +#ifdef DEBUG_EXTENSIONS + if (RECORD_PROCNAMES && SCM_NIMP (x) && SCM_CLOSUREP (x)) + scm_set_procedure_property_x (x, scm_i_name, proc); +#endif + SCM_CDR (arg1) = x; +#ifdef SICP + return scm_cons2 (scm_i_quote, SCM_CAR (arg1), SCM_EOL); +#else + return SCM_UNSPECIFIED; +#endif + } + return scm_cons2 (SCM_IM_DEFINE, proc, x); +} +/* end of acros */ + +#ifdef __STDC__ +SCM +scm_m_letrec (SCM xorig, SCM env) +#else +SCM +scm_m_letrec (xorig, env) + SCM xorig; + SCM env; +#endif +{ + SCM cdrx = SCM_CDR (xorig); /* locally mutable version of form */ + char *what = SCM_CHARS (SCM_CAR (xorig)); + SCM x = cdrx, proc, arg1; /* structure traversers */ + SCM vars = SCM_EOL, inits = SCM_EOL, *initloc = &inits; + + ASRTSYNTAX (scm_ilength (x) >= 2, s_body); + proc = SCM_CAR (x); + if SCM_NULLP + (proc) return scm_m_letstar (xorig, env); /* null binding, let* faster */ + ASRTSYNTAX (scm_ilength (proc) >= 1, s_bindings); + do + { + /* vars scm_list reversed here, inits reversed at evaluation */ + arg1 = SCM_CAR (proc); + ASRTSYNTAX (2 == scm_ilength (arg1), s_bindings); + ASRTSYNTAX (SCM_NIMP (SCM_CAR (arg1)) && SCM_SYMBOLP (SCM_CAR (arg1)), s_variable); + vars = scm_cons (SCM_CAR (arg1), vars); + *initloc = scm_cons (SCM_CAR (SCM_CDR (arg1)), SCM_EOL); + initloc = &SCM_CDR (*initloc); + } + while SCM_NIMP + (proc = SCM_CDR (proc)); + cdrx = scm_cons2 (vars, inits, SCM_CDR (x)); + bodycheck (xorig, &SCM_CDR (SCM_CDR (cdrx)), what); + return scm_cons (SCM_IM_LETREC, cdrx); +} + +#ifdef __STDC__ +SCM +scm_m_let (SCM xorig, SCM env) +#else +SCM +scm_m_let (xorig, env) + SCM xorig; + SCM env; +#endif +{ + SCM cdrx = SCM_CDR (xorig); /* locally mutable version of form */ + SCM x = cdrx, proc, arg1, name; /* structure traversers */ + SCM vars = SCM_EOL, inits = SCM_EOL, *varloc = &vars, *initloc = &inits; + + ASSYNT (scm_ilength (x) >= 2, xorig, s_body, "let"); + proc = SCM_CAR (x); + if (SCM_NULLP (proc) + || (SCM_NIMP (proc) && SCM_CONSP (proc) + && SCM_NIMP (SCM_CAR (proc)) && SCM_CONSP (SCM_CAR (proc)) && SCM_NULLP (SCM_CDR (proc)))) + return scm_m_letstar (xorig, env); /* null or single binding, let* is faster */ + ASSYNT (SCM_NIMP (proc), xorig, s_bindings, "let"); + if (SCM_CONSP (proc)) /* plain let, proc is <bindings> */ + return scm_cons (SCM_IM_LET, SCM_CDR (scm_m_letrec (xorig, env))); + if (!SCM_SYMBOLP (proc)) + scm_wta (xorig, s_bindings, "let"); /* bad let */ + name = proc; /* named let, build equiv letrec */ + x = SCM_CDR (x); + ASSYNT (scm_ilength (x) >= 2, xorig, s_body, "let"); + proc = SCM_CAR (x); /* bindings scm_list */ + ASSYNT (scm_ilength (proc) >= 0, xorig, s_bindings, "let"); + while SCM_NIMP + (proc) + { /* vars and inits both in order */ + arg1 = SCM_CAR (proc); + ASSYNT (2 == scm_ilength (arg1), xorig, s_bindings, "let"); + ASSYNT (SCM_NIMP (SCM_CAR (arg1)) && SCM_SYMBOLP (SCM_CAR (arg1)), xorig, s_variable, "let"); + *varloc = scm_cons (SCM_CAR (arg1), SCM_EOL); + varloc = &SCM_CDR (*varloc); + *initloc = scm_cons (SCM_CAR (SCM_CDR (arg1)), SCM_EOL); + initloc = &SCM_CDR (*initloc); + proc = SCM_CDR (proc); + } + return + scm_m_letrec (scm_cons2 (scm_i_let, + scm_cons (scm_cons2 (name, scm_cons2 (scm_i_lambda, vars, SCM_CDR (x)), SCM_EOL), SCM_EOL), + scm_acons (name, inits, SCM_EOL)), /* body */ + env); +} + + +#ifdef __STDC__ +SCM +scm_m_apply (SCM xorig, SCM env) +#else +SCM +scm_m_apply (xorig, env) + SCM xorig; + SCM env; +#endif +{ + ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2, xorig, s_expression, "@apply"); + return scm_cons (SCM_IM_APPLY, SCM_CDR (xorig)); +} + +#define s_atcall_cc (SCM_ISYMSCM_CHARS(SCM_IM_CONT)+1) + +#ifdef __STDC__ +SCM +scm_m_cont (SCM xorig, SCM env) +#else +SCM +scm_m_cont (xorig, env) + SCM xorig; + SCM env; +#endif +{ + ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, xorig, s_expression, "@call-with-current-continuation"); + return scm_cons (SCM_IM_CONT, SCM_CDR (xorig)); +} + +#ifndef RECKLESS +#ifdef __STDC__ +int +scm_badargsp (SCM formals, SCM args) +#else +int +scm_badargsp (formals, args) + SCM formals; + SCM args; +#endif +{ + while SCM_NIMP + (formals) + { + if SCM_NCONSP + (formals) return 0; + if SCM_IMP + (args) return 1; + formals = SCM_CDR (formals); + args = SCM_CDR (args); + } + return SCM_NNULLP (args) ? 1 : 0; +} +#endif + + + +long scm_tc16_macro; + +#endif /* !DEVAL */ + +#ifdef DEVAL +#undef SCM_EVAL_ARGS +#define SCM_EVAL_ARGS scm_deval_args +#undef SCM_CEVAL +#define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */ +#undef SCM_APPLY +#define SCM_APPLY scm_dapply +#undef RETURN +#define RETURN(e) {proc = (e); goto exit;} +#else +#define SCM_EVAL_ARGS scm_eval_args +#define RETURN(x) return x; +#endif + +SCM +SCM_EVAL_ARGS (l, env) + SCM l, env; +{ + SCM res = SCM_EOL, *lloc = &res; + while (SCM_NIMP (l)) + { + *lloc = scm_cons (EVALCAR (l, env), SCM_EOL); + lloc = &SCM_CDR (*lloc); + l = SCM_CDR (l); + } + return res; +} + +#if 0 +#ifdef __STDC__ +SCM +scm_ceval (SCM x, SCM env) +#else +SCM +scm_ceval (x, env) + SCM x; + SCM env; +#endif +{} +#endif +#if 0 +#ifdef __STDC__ +SCM +scm_deval (SCM x, SCM env) +#else +SCM +scm_deval (x, env) + SCM x; + SCM env; +#endif +{} +#endif + +#ifdef SCM_FLOATS +#define CHECK_EQVISH(A,B) (((A) == (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B))))) +#else +#define CHECK_EQVISH(A,B) ((A) == (B)) +#endif + + +SCM +SCM_CEVAL (x, env) + SCM x; + SCM env; +{ + union + { + SCM *lloc; + SCM arg1; + } t; + SCM proc; + SCM arg2; + + SCM_CHECK_STACK; + + loop: + SCM_ASYNC_TICK; + + switch (SCM_TYP7 (x)) + { + case scm_tcs_symbols: + /* Only happens when called at top level. + */ + x = scm_cons (x, SCM_UNDEFINED); + goto retval; + + case (127 & SCM_IM_AND): + x = SCM_CDR (x); + t.arg1 = x; + while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1))) + if (SCM_FALSEP (EVALCAR (x, env))) + { + RETURN (SCM_BOOL_F); + } + else + x = t.arg1; + goto carloop; + + case (127 & SCM_IM_BEGIN): + + cdrxbegin: + x = SCM_CDR (x); + + begin: + t.arg1 = x; + while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1))) + { + SIDEVAL (SCM_CAR (x), env); + x = t.arg1; + } + + carloop: /* scm_eval car of last form in list */ + if (SCM_NCELLP (SCM_CAR (x))) + { + x = SCM_CAR (x); + RETURN (SCM_IMP (x) ? EVALIMP (x, env) : SCM_GLOC_VAL (x)); + } + + if (SCM_SYMBOLP (SCM_CAR (x))) + { + retval: + RETURN (*scm_lookupcar (x, env)); + } + + x = SCM_CAR (x); + goto loop; /* tail recurse */ + + + case (127 & SCM_IM_CASE): + x = SCM_CDR (x); + t.arg1 = EVALCAR (x, env); + while (SCM_NIMP (x = SCM_CDR (x))) + { + proc = SCM_CAR (x); + if (scm_i_else == SCM_CAR (proc)) + { + x = SCM_CDR (proc); + goto begin; + } + proc = SCM_CAR (proc); + while (SCM_NIMP (proc)) + { + if (CHECK_EQVISH (SCM_CAR (proc), t.arg1)) + { + x = SCM_CDR (SCM_CAR (x)); + goto begin; + } + proc = SCM_CDR (proc); + } + } + RETURN (SCM_UNSPECIFIED); + + + case (127 & SCM_IM_COND): + while (SCM_NIMP (x = SCM_CDR (x))) + { + proc = SCM_CAR (x); + t.arg1 = EVALCAR (proc, env); + if (SCM_NFALSEP (t.arg1)) + { + x = SCM_CDR (proc); + if (SCM_NULLP (x)) + { + RETURN (t.arg1); + } + if (scm_i_arrow != SCM_CAR (x)) + goto begin; + proc = SCM_CDR (x); + proc = EVALCAR (proc, env); + SCM_ASRTGO (SCM_NIMP (proc), badfun); + goto evap1; + } + } + RETURN (SCM_UNSPECIFIED); + + + case (127 & SCM_IM_DO): + x = SCM_CDR (x); + proc = SCM_CAR (SCM_CDR (x)); /* inits */ + t.arg1 = SCM_EOL; /* values */ + while (SCM_NIMP (proc)) + { + t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1); + proc = SCM_CDR (proc); + } + env = EXTEND_SCM_ENV (SCM_CAR (x), t.arg1, env); + x = SCM_CDR (SCM_CDR (x)); + while (proc = SCM_CAR (x), SCM_FALSEP (EVALCAR (proc, env))) + { + for (proc = SCM_CAR (SCM_CDR (x)); SCM_NIMP (proc); proc = SCM_CDR (proc)) + { + t.arg1 = SCM_CAR (proc); /* body */ + SIDEVAL (t.arg1, env); + } + for (t.arg1 = SCM_EOL, proc = SCM_CDR (SCM_CDR (x)); SCM_NIMP (proc); proc = SCM_CDR (proc)) + t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1); /* steps */ + env = EXTEND_SCM_ENV (SCM_CAR (SCM_CAR (env)), t.arg1, SCM_CDR (env)); + } + x = SCM_CDR (proc); + if (SCM_NULLP (x)) + { + RETURN (SCM_UNSPECIFIED); + } + goto begin; + + + case (127 & SCM_IM_IF): + x = SCM_CDR (x); + if (SCM_NFALSEP (EVALCAR (x, env))) + x = SCM_CDR (x); + else if (SCM_IMP (x = SCM_CDR (SCM_CDR (x)))) + { + RETURN (SCM_UNSPECIFIED); + } + goto carloop; + + + case (127 & SCM_IM_LET): + x = SCM_CDR (x); + proc = SCM_CAR (SCM_CDR (x)); + t.arg1 = SCM_EOL; + do + { + t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1); + } + while (SCM_NIMP (proc = SCM_CDR (proc))); + env = EXTEND_SCM_ENV (SCM_CAR (x), t.arg1, env); + x = SCM_CDR (x); + goto cdrxbegin; + + + case (127 & SCM_IM_LETREC): + x = SCM_CDR (x); + env = EXTEND_SCM_ENV (SCM_CAR (x), scm_undefineds, env); + x = SCM_CDR (x); + proc = SCM_CAR (x); + t.arg1 = SCM_EOL; + do + { + t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1); + } + while (SCM_NIMP (proc = SCM_CDR (proc))); + SCM_CDR (SCM_CAR (env)) = t.arg1; + goto cdrxbegin; + + + case (127 & SCM_IM_LETSTAR): + x = SCM_CDR (x); + proc = SCM_CAR (x); + if (SCM_IMP (proc)) + { + env = EXTEND_SCM_ENV (SCM_EOL, SCM_EOL, env); + goto cdrxbegin; + } + do + { + t.arg1 = SCM_CAR (proc); + proc = SCM_CDR (proc); + env = EXTEND_SCM_ENV (t.arg1, EVALCAR (proc, env), env); + } + while (SCM_NIMP (proc = SCM_CDR (proc))); + goto cdrxbegin; + + case (127 & SCM_IM_OR): + x = SCM_CDR (x); + t.arg1 = x; + while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1))) + { + x = EVALCAR (x, env); + if (SCM_NFALSEP (x)) + { + RETURN (x); + } + x = t.arg1; + } + goto carloop; + + + case (127 & SCM_IM_LAMBDA): + RETURN (scm_closure (SCM_CDR (x), env)); + + + case (127 & SCM_IM_QUOTE): + RETURN (SCM_CAR (SCM_CDR (x))); + + + case (127 & SCM_IM_SET): + set_some_more: + x = SCM_CDR (x); + proc = SCM_CAR (x); + switch (7 & (int)proc) + { + case 0: + t.lloc = scm_lookupcar (x, env); + break; + case 1: + t.lloc = &SCM_GLOC_VAL (proc); + break; +#ifdef MEMOIZE_LOCALS + case 4: + t.lloc = scm_ilookup (proc, env); + break; +#endif + } + x = SCM_CDR (x); + *t.lloc = EVALCAR (x, env); + if (!SCM_NULLP (SCM_CDR(x))) + goto set_some_more; +#ifdef SICP + RETURN (*t.lloc); +#else + RETURN (SCM_UNSPECIFIED); +#endif + + + case (127 & SCM_IM_DEFINE): /* only for internal defines */ + x = SCM_CDR (x); + proc = SCM_CAR (x); + x = SCM_CDR (x); + x = evalcar (x, env); + env = SCM_CAR (env); + SCM_DEFER_INTS; + SCM_CAR (env) = scm_cons (proc, SCM_CAR (env)); + SCM_CDR (env) = scm_cons (x, SCM_CDR (env)); + SCM_ALLOW_INTS; + RETURN (SCM_UNSPECIFIED); + + + + /* new syntactic forms go here. */ + case (127 & SCM_MAKISYM (0)): + proc = SCM_CAR (x); + SCM_ASRTGO (SCM_ISYMP (proc), badfun); + switch SCM_ISYMNUM (proc) + { +#if 0 + case (SCM_ISYMNUM (IM_VREF)): + { + SCM var; + var = SCM_CAR (SCM_CDR (x)); + RETURN (SCM_CDR(var)); + } + case (SCM_ISYMNUM (IM_VSET)): + SCM_CDR (SCM_CAR ( SCM_CDR (x))) = EVALCAR( SCM_CDR ( SCM_CDR (x)), env); + SCM_CAR (SCM_CAR ( SCM_CDR (x))) = scm_tc16_variable; + RETURN (SCM_UNSPECIFIED); +#endif + + case (SCM_ISYMNUM (SCM_IM_APPLY)): + proc = SCM_CDR (x); + proc = EVALCAR (proc, env); + SCM_ASRTGO (SCM_NIMP (proc), badfun); + if (SCM_CLOSUREP (proc)) + { + t.arg1 = SCM_CDR (SCM_CDR (x)); + t.arg1 = EVALCAR (t.arg1, env); +#ifndef RECKLESS + if (scm_badargsp (SCM_CAR (SCM_CODE (proc)), t.arg1)) + goto wrongnumargs; +#endif + env = EXTEND_SCM_ENV (SCM_CAR (SCM_CODE (proc)), t.arg1, SCM_ENV (proc)); + x = SCM_CODE (proc); + goto cdrxbegin; + } + proc = scm_i_apply; + goto evapply; + + case (SCM_ISYMNUM (SCM_IM_CONT)): + scm_make_cont (&t.arg1); + if (setjmp (SCM_JMPBUF (t.arg1))) + { + SCM val; + val = SCM_THROW_VALUE (t.arg1); + RETURN (val);; + } + proc = SCM_CDR (x); + proc = evalcar (proc, env); + SCM_ASRTGO (SCM_NIMP (proc), badfun); + goto evap1; + + default: + goto badfun; + } + + default: + proc = x; + badfun: + scm_everr (x, env, proc, "Wrong type to apply: ", ""); + + case scm_tc7_vector: + case scm_tc7_wvect: + case scm_tc7_bvect: + case scm_tc7_byvect: + case scm_tc7_svect: + case scm_tc7_ivect: + case scm_tc7_uvect: + case scm_tc7_fvect: + case scm_tc7_dvect: + case scm_tc7_cvect: +#ifdef LONGLONGS + case scm_tc7_llvect: +#endif + case scm_tc7_string: + case scm_tc7_mb_string: + case scm_tc7_substring: + case scm_tc7_mb_substring: + case scm_tc7_smob: + case scm_tcs_closures: + case scm_tcs_subrs: + RETURN (x); + +#ifdef MEMOIZE_LOCALS + case (127 & SCM_ILOC00): + proc = *scm_ilookup (SCM_CAR (x), env); + SCM_ASRTGO (SCM_NIMP (proc), badfun); +#ifndef RECKLESS +#ifdef CAUTIOUS + goto checkargs; +#endif +#endif + break; +#endif /* ifdef MEMOIZE_LOCALS */ + + + case scm_tcs_cons_gloc: + proc = SCM_GLOC_VAL (SCM_CAR (x)); + SCM_ASRTGO (SCM_NIMP (proc), badfun); +#ifndef RECKLESS +#ifdef CAUTIOUS + goto checkargs; +#endif +#endif + break; + + + case scm_tcs_cons_nimcar: + if (SCM_SYMBOLP (SCM_CAR (x))) + { + proc = *scm_lookupcar (x, env); + if (SCM_IMP (proc)) + { + unmemocar (x, env); + goto badfun; + } + if (scm_tc16_macro == SCM_TYP16 (proc)) + { + unmemocar (x, env); + + handle_a_macro: + t.arg1 = SCM_APPLY (SCM_CDR (proc), x, scm_cons (env, scm_listofnull)); + switch ((int) (SCM_CAR (proc) >> 16)) + { + case 2: + if (scm_ilength (t.arg1) <= 0) + t.arg1 = scm_cons2 (SCM_IM_BEGIN, t.arg1, SCM_EOL); + SCM_DEFER_INTS; + SCM_CAR (x) = SCM_CAR (t.arg1); + SCM_CDR (x) = SCM_CDR (t.arg1); + SCM_ALLOW_INTS; + goto loop; + case 1: + if (SCM_NIMP (x = t.arg1)) + goto loop; + case 0: + RETURN (t.arg1); + } + } + } + else + proc = SCM_CEVAL (SCM_CAR (x), env); + SCM_ASRTGO (SCM_NIMP (proc), badfun); +#ifndef RECKLESS +#ifdef CAUTIOUS + checkargs: +#endif + if (SCM_CLOSUREP (proc)) + { + arg2 = SCM_CAR (SCM_CODE (proc)); + t.arg1 = SCM_CDR (x); + while (SCM_NIMP (arg2)) + { + if (SCM_NCONSP (arg2)) + goto evapply; + if (SCM_IMP (t.arg1)) + goto umwrongnumargs; + arg2 = SCM_CDR (arg2); + t.arg1 = SCM_CDR (t.arg1); + } + if (SCM_NNULLP (t.arg1)) + goto umwrongnumargs; + } + else if (scm_tc16_macro == SCM_TYP16 (proc)) + goto handle_a_macro; +#endif + } + + + evapply: + if (SCM_NULLP (SCM_CDR (x))) + switch (SCM_TYP7 (proc)) + { /* no arguments given */ + case scm_tc7_subr_0: + RETURN (SCM_SUBRF (proc) ()); + case scm_tc7_subr_1o: + RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED)); + case scm_tc7_lsubr: + RETURN (SCM_SUBRF (proc) (SCM_EOL)); + case scm_tc7_rpsubr: + RETURN (SCM_BOOL_T); + case scm_tc7_asubr: + RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED)); + case scm_tc7_cclo: + t.arg1 = proc; + proc = SCM_CCLO_SUBR (proc); + goto evap1; + case scm_tcs_closures: + x = SCM_CODE (proc); + env = EXTEND_SCM_ENV (SCM_CAR (x), SCM_EOL, SCM_ENV (proc)); + goto cdrxbegin; + case scm_tc7_contin: + case scm_tc7_subr_1: + case scm_tc7_subr_2: + case scm_tc7_subr_2o: + case scm_tc7_cxr: + case scm_tc7_subr_3: + case scm_tc7_lsubr_2: + umwrongnumargs: + unmemocar (x, env); + wrongnumargs: + scm_everr (x, env, proc, (char *) SCM_WNA, ""); + default: + /* handle macros here */ + goto badfun; + } + + + /* must handle macros by here */ + x = SCM_CDR (x); +#ifdef CAUTIOUS + if (SCM_IMP (x)) + goto wrongnumargs; +#endif + t.arg1 = EVALCAR (x, env); + x = SCM_CDR (x); + if (SCM_NULLP (x)) + { + evap1: + switch (SCM_TYP7 (proc)) + { /* have one argument in t.arg1 */ + case scm_tc7_subr_2o: + RETURN (SCM_SUBRF (proc) (t.arg1, SCM_UNDEFINED)); + case scm_tc7_subr_1: + case scm_tc7_subr_1o: + RETURN (SCM_SUBRF (proc) (t.arg1)); + case scm_tc7_cxr: +#ifdef SCM_FLOATS + if (SCM_SUBRF (proc)) + { + if (SCM_INUMP (t.arg1)) + { + RETURN (scm_makdbl (SCM_DSUBRF (proc) ((double) SCM_INUM (t.arg1)), + 0.0)); + } + SCM_ASRTGO (SCM_NIMP (t.arg1), floerr); + if (SCM_REALP (t.arg1)) + { + RETURN (scm_makdbl (SCM_DSUBRF (proc) (SCM_REALPART (t.arg1)), 0.0)); + } +#ifdef SCM_BIGDIG + if (SCM_BIGP (t.arg1)) + { + RETURN (scm_makdbl (SCM_DSUBRF (proc) (scm_big2dbl (t.arg1)), 0.0)); + } +#endif + floerr: + scm_wta (t.arg1, (char *) SCM_ARG1, SCM_CHARS (SCM_SNAME (proc))); + } +#endif + proc = (SCM) SCM_SNAME (proc); + { + char *chrs = SCM_CHARS (proc) + SCM_LENGTH (proc) - 1; + while ('c' != *--chrs) + { + SCM_ASSERT (SCM_NIMP (t.arg1) && SCM_CONSP (t.arg1), + t.arg1, SCM_ARG1, SCM_CHARS (proc)); + t.arg1 = ('a' == *chrs) ? SCM_CAR (t.arg1) : SCM_CDR (t.arg1); + } + RETURN (t.arg1); + } + case scm_tc7_rpsubr: + RETURN (SCM_BOOL_T); + case scm_tc7_asubr: + RETURN (SCM_SUBRF (proc) (t.arg1, SCM_UNDEFINED)); + case scm_tc7_lsubr: +#ifdef DEVAL + RETURN (SCM_SUBRF (proc) (dbg_info.args)); +#else + RETURN (SCM_SUBRF (proc) (scm_cons (t.arg1, SCM_EOL))); +#endif + case scm_tc7_cclo: + arg2 = t.arg1; + t.arg1 = proc; + proc = SCM_CCLO_SUBR (proc); + goto evap2; + case scm_tcs_closures: + x = SCM_CODE (proc); +#ifdef DEVAL + env = EXTEND_SCM_ENV (SCM_CAR (x), dbg_info.args, SCM_ENV (proc)); +#else + env = EXTEND_SCM_ENV (SCM_CAR (x), scm_cons (t.arg1, SCM_EOL), SCM_ENV (proc)); +#endif + goto cdrxbegin; + case scm_tc7_contin: + scm_call_continuation (proc, t.arg1); + case scm_tc7_subr_2: + case scm_tc7_subr_0: + case scm_tc7_subr_3: + case scm_tc7_lsubr_2: + goto wrongnumargs; + default: + goto badfun; + } + } +#ifdef CAUTIOUS + if (SCM_IMP (x)) + goto wrongnumargs; +#endif + { /* have two or more arguments */ + arg2 = EVALCAR (x, env); + x = SCM_CDR (x); + if (SCM_NULLP (x)) { +#ifdef CCLO + evap2: +#endif +#ifdef DEVAL + dbg_info.args = scm_cons2 (t.arg1, arg2, SCM_EOL); +#endif + switch SCM_TYP7 + (proc) + { /* have two arguments */ + case scm_tc7_subr_2: + case scm_tc7_subr_2o: + RETURN (SCM_SUBRF (proc) (t.arg1, arg2)); + case scm_tc7_lsubr: +#ifdef DEVAL + RETURN (SCM_SUBRF (proc) (dbg_info.args)); +#else + RETURN (SCM_SUBRF (proc) (scm_cons2 (t.arg1, arg2, SCM_EOL))); +#endif + case scm_tc7_lsubr_2: + RETURN (SCM_SUBRF (proc) (t.arg1, arg2, SCM_EOL)); + case scm_tc7_rpsubr: + case scm_tc7_asubr: + RETURN (SCM_SUBRF (proc) (t.arg1, arg2)); +#ifdef CCLO + cclon: case scm_tc7_cclo: + RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), proc, + scm_cons2 (t.arg1, arg2, scm_cons (SCM_EVAL_ARGS (x, env), SCM_EOL)))); + /* case scm_tc7_cclo: + x = scm_cons(arg2, scm_eval_args(x, env)); + arg2 = t.arg1; + t.arg1 = proc; + proc = SCM_CCLO_SUBR(proc); + goto evap3; */ +#endif + case scm_tc7_subr_0: + case scm_tc7_cxr: + case scm_tc7_subr_1o: + case scm_tc7_subr_1: + case scm_tc7_subr_3: + case scm_tc7_contin: + goto wrongnumargs; + default: + goto badfun; + case scm_tcs_closures: +#ifdef DEVAL + env = EXTEND_SCM_ENV (SCM_CAR (SCM_CODE (proc)), dbg_info.args, SCM_ENV (proc)); +#else + env = EXTEND_SCM_ENV (SCM_CAR (SCM_CODE (proc)), scm_cons2 (t.arg1, arg2, SCM_EOL), SCM_ENV (proc)); +#endif + x = SCM_CODE (proc); + goto cdrxbegin; + } + } +#ifdef DEVAL + dbg_info.args = scm_cons2 (t.arg1, arg2, scm_deval_args (x, env)); +#endif + switch SCM_TYP7 + (proc) + { /* have 3 or more arguments */ +#ifdef DEVAL + case scm_tc7_subr_3: + SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs); + RETURN (SCM_SUBRF (proc) (t.arg1, arg2, SCM_CAR (SCM_CDR (SCM_CDR (dbg_info.args))))); + case scm_tc7_asubr: + /* t.arg1 = SCM_SUBRF(proc)(t.arg1, arg2); + while SCM_NIMP(x) { + t.arg1 = SCM_SUBRF(proc)(t.arg1, EVALCAR(x, env)); + x = SCM_CDR(x); + } + RETURN (t.arg1) */ + case scm_tc7_rpsubr: + RETURN (SCM_APPLY (proc, t.arg1, scm_acons (arg2, SCM_CDR (SCM_CDR (dbg_info.args)), SCM_EOL))); + case scm_tc7_lsubr_2: + RETURN (SCM_SUBRF (proc) (t.arg1, arg2, SCM_CDR (SCM_CDR (dbg_info.args)))); + case scm_tc7_lsubr: + RETURN (SCM_SUBRF (proc) (dbg_info.args)); +#ifdef CCLO + case scm_tc7_cclo: + goto cclon; +#endif + case scm_tcs_closures: + env = EXTEND_SCM_ENV (SCM_CAR (SCM_CODE (proc)), + dbg_info.args, + SCM_ENV (proc)); + x = SCM_CODE (proc); + goto cdrxbegin; +#else + case scm_tc7_subr_3: + SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs); + RETURN (SCM_SUBRF (proc) (t.arg1, arg2, EVALCAR (x, env))); + case scm_tc7_asubr: + /* t.arg1 = SCM_SUBRF(proc)(t.arg1, arg2); + while SCM_NIMP(x) { + t.arg1 = SCM_SUBRF(proc)(t.arg1, EVALCAR(x, env)); + x = SCM_CDR(x); + } + RETURN (t.arg1) */ + case scm_tc7_rpsubr: + RETURN (SCM_APPLY (proc, t.arg1, scm_acons (arg2, scm_eval_args (x, env), SCM_EOL))); + case scm_tc7_lsubr_2: + RETURN (SCM_SUBRF (proc) (t.arg1, arg2, scm_eval_args (x, env))); + case scm_tc7_lsubr: + RETURN (SCM_SUBRF (proc) (scm_cons2 (t.arg1, arg2, scm_eval_args (x, env)))); +#ifdef CCLO + case scm_tc7_cclo: + goto cclon; +#endif + case scm_tcs_closures: + env = EXTEND_SCM_ENV (SCM_CAR (SCM_CODE (proc)), + scm_cons2 (t.arg1, arg2, scm_eval_args (x, env)), + SCM_ENV (proc)); + x = SCM_CODE (proc); + goto cdrxbegin; +#endif /* DEVAL */ + case scm_tc7_subr_2: + case scm_tc7_subr_1o: + case scm_tc7_subr_2o: + case scm_tc7_subr_0: + case scm_tc7_cxr: + case scm_tc7_subr_1: + case scm_tc7_contin: + goto wrongnumargs; + default: + goto badfun; + } + } +#ifdef DEVAL + exit: + if (CHECK_SCM_EXIT) + { + /* if (SINGLE_STEP) ... but this is always fulfilled. */ + SINGLE_STEP = 0; + scm_make_cont (&t.arg1); + if (setjmp (SCM_JMPBUF (t.arg1))) + { + proc = SCM_THROW_VALUE(t.arg1); + goto ret; + } + scm_ithrow (exit_frame_sym, proc, 0); + } + ret: + last_debug_info_frame = dbg_info.prev; + return proc; +#endif +} + +#ifndef DEVAL + +SCM_PROC(s_procedure_documentation, "procedure-documentation", 1, 0, 0, scm_procedure_documentation); +#ifdef __STDC__ +SCM +scm_procedure_documentation (SCM proc) +#else +SCM +scm_procedure_documentation (proc) + SCM proc; +#endif +{ + SCM code; + SCM_ASSERT (SCM_BOOL_T == scm_procedure_p (proc) && SCM_NIMP (proc) && SCM_TYP7 (proc) != scm_tc7_contin, + proc, SCM_ARG1, s_procedure_documentation); + switch (SCM_TYP7 (proc)) + { + case scm_tcs_closures: + code = SCM_CDR (SCM_CODE (proc)); + if (SCM_IMP (SCM_CDR (code))) + return SCM_BOOL_F; + code = SCM_CAR (code); + if (SCM_IMP (code)) + return SCM_BOOL_F; + if (SCM_STRINGP (code)) + return code; + default: + return SCM_BOOL_F; +/* + case scm_tcs_subrs: +#ifdef CCLO + case scm_tc7_cclo: +#endif +*/ + } +} + +/* This code is for scm_apply. it is destructive on multiple args. + * This will only screw you if you do (scm_apply scm_apply '( ... )) + */ +SCM_PROC(s_nconc2last, "apply:nconc2last", 1, 0, 0, scm_nconc2last); +#ifdef __STDC__ +SCM +scm_nconc2last (SCM lst) +#else +SCM +scm_nconc2last (lst) + SCM lst; +#endif +{ + SCM *lloc; + if (SCM_EOL == lst) + return lst; + SCM_ASSERT (SCM_NIMP (lst) && SCM_CONSP (lst), lst, SCM_ARG1, s_nconc2last); + lloc = &lst; + while (SCM_NNULLP (SCM_CDR (*lloc))) + { + lloc = &SCM_CDR (*lloc); + SCM_ASSERT (SCM_NIMP (*lloc) && SCM_CONSP (*lloc), lst, SCM_ARG1, s_nconc2last); + } + *lloc = SCM_CAR (*lloc); + return lst; +} + +#endif /* !DEVAL */ + +#if 0 +#ifdef __STDC__ +SCM +scm_apply (SCM proc, SCM arg1, SCM args) +#else +SCM +scm_apply (proc, arg1, args) + SCM proc; + SCM arg1; + SCM args; +#endif +{} +#endif + +#if 0 +#ifdef __STDC__ +SCM +scm_dapply (SCM proc, SCM arg1, SCM args) +#else +SCM +scm_dapply (proc, arg1, args) + SCM proc; + SCM arg1; + SCM args; +#endif +{} +#endif + + + +#ifdef __STDC__ +SCM +SCM_APPLY (SCM proc, SCM arg1, SCM args) +#else +SCM +SCM_APPLY (proc, arg1, args) + SCM proc; + SCM arg1; + SCM args; +#endif +{ +#ifdef DEBUG_EXTENSIONS +#ifdef DEVAL + debug_info dbg_info; + dbg_info.prev = last_debug_info_frame; + dbg_info.exp = SCM_UNDEFINED; + dbg_info.proc = proc; + dbg_info.args = SCM_UNDEFINED; + last_debug_info_frame = &dbg_info; +#else + if (DEBUGGINGP) + return scm_dapply (proc, arg1, args); +#endif +#endif + + SCM_ASRTGO (SCM_NIMP (proc), badproc); + if (SCM_NULLP (args)) + { + if (SCM_NULLP (arg1)) + arg1 = SCM_UNDEFINED; + else + { + args = SCM_CDR (arg1); + arg1 = SCM_CAR (arg1); + } + } + else + { + /* SCM_ASRTGO(SCM_NIMP(args) && SCM_CONSP(args), wrongnumargs); */ + args = scm_nconc2last (args); + } +#ifdef CCLO + tail: +#endif +#ifdef DEVAL + dbg_info.args = scm_cons (arg1, args); +#endif + switch (SCM_TYP7 (proc)) + { + case scm_tc7_subr_2o: + args = SCM_NULLP (args) ? SCM_UNDEFINED : SCM_CAR (args); + RETURN (SCM_SUBRF (proc) (arg1, args)) + case scm_tc7_subr_2: + SCM_ASRTGO (SCM_NULLP (SCM_CDR (args)), wrongnumargs); + args = SCM_CAR (args); + RETURN (SCM_SUBRF (proc) (arg1, args)) + case scm_tc7_subr_0: + SCM_ASRTGO (SCM_UNBNDP (arg1), wrongnumargs); + RETURN (SCM_SUBRF (proc) ()) + case scm_tc7_subr_1: + case scm_tc7_subr_1o: + SCM_ASRTGO (SCM_NULLP (args), wrongnumargs); + RETURN (SCM_SUBRF (proc) (arg1)) + case scm_tc7_cxr: + SCM_ASRTGO (SCM_NULLP (args), wrongnumargs); +#ifdef SCM_FLOATS + if (SCM_SUBRF (proc)) + { + if SCM_INUMP + (arg1) + RETURN (scm_makdbl (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1)), 0.0)) + SCM_ASRTGO (SCM_NIMP (arg1), floerr); + if SCM_REALP + (arg1) + RETURN (scm_makdbl (SCM_DSUBRF (proc) (SCM_REALPART (arg1)), 0.0)) +#ifdef SCM_BIGDIG + if SCM_BIGP + (arg1) + RETURN (scm_makdbl (SCM_DSUBRF (proc) (scm_big2dbl (arg1)), 0.0)) +#endif + floerr: + scm_wta (arg1, (char *) SCM_ARG1, SCM_CHARS (SCM_SNAME (proc))); + } +#endif + proc = (SCM) SCM_SNAME (proc); + { + char *chrs = SCM_CHARS (proc) + SCM_LENGTH (proc) - 1; + while ('c' != *--chrs) + { + SCM_ASSERT (SCM_NIMP (arg1) && SCM_CONSP (arg1), + arg1, SCM_ARG1, SCM_CHARS (proc)); + arg1 = ('a' == *chrs) ? SCM_CAR (arg1) : SCM_CDR (arg1); + } + RETURN (arg1) + } + case scm_tc7_subr_3: + RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CAR (SCM_CDR (args)))) + case scm_tc7_lsubr: +#ifdef DEVAL + RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : dbg_info.args)) +#else + RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args))) +#endif + case scm_tc7_lsubr_2: + SCM_ASRTGO (SCM_NIMP (args) && SCM_CONSP (args), wrongnumargs); + RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CDR (args))) + case scm_tc7_asubr: + if (SCM_NULLP (args)) + RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED)) + while (SCM_NIMP (args)) + { + SCM_ASSERT (SCM_CONSP (args), args, SCM_ARG2, "apply"); + arg1 = SCM_SUBRF (proc) (arg1, SCM_CAR (args)); + args = SCM_CDR (args); + } + RETURN (arg1); + case scm_tc7_rpsubr: + if (SCM_NULLP (args)) + RETURN (SCM_BOOL_T); + while (SCM_NIMP (args)) + { + SCM_ASSERT (SCM_CONSP (args), args, SCM_ARG2, "apply"); + if (SCM_FALSEP (SCM_SUBRF (proc) (arg1, SCM_CAR (args)))) + RETURN (SCM_BOOL_F); + arg1 = SCM_CAR (args); + args = SCM_CDR (args); + } + RETURN (SCM_BOOL_T); + case scm_tcs_closures: +#ifdef DEVAL + arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : dbg_info.args); +#else + arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args)); +#endif +#ifndef RECKLESS + if (scm_badargsp (SCM_CAR (SCM_CODE (proc)), arg1)) + goto wrongnumargs; +#endif + args = EXTEND_SCM_ENV (SCM_CAR (SCM_CODE (proc)), arg1, SCM_ENV (proc)); + proc = SCM_CODE (proc); + while (SCM_NNULLP (proc = SCM_CDR (proc))) + arg1 = EVALCAR (proc, args); + RETURN (arg1); + case scm_tc7_contin: + SCM_ASRTGO (SCM_NULLP (args), wrongnumargs); + scm_call_continuation (proc, arg1); +#ifdef CCLO + case scm_tc7_cclo: +#ifdef DEVAL + args = (SCM_UNBNDP(arg1) ? SCM_EOL : dbg_info.args); +#else + args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args)); +#endif + arg1 = proc; + proc = SCM_CCLO_SUBR (proc); + goto tail; +#endif + wrongnumargs: + scm_wta (proc, (char *) SCM_WNA, "apply"); + default: + badproc: + scm_wta (proc, (char *) SCM_ARG1, "apply"); + RETURN (arg1); + } +#ifdef DEVAL + exit: + if (CHECK_SCM_EXIT) + { + /* if (SINGLE_STEP) ... but this is always fulfilled. */ + SINGLE_STEP = 0; + scm_make_cont (&arg1); + if (setjmp (SCM_JMPBUF (arg1))) + { + proc = SCM_THROW_VALUE(arg1); + goto ret; + } + scm_ithrow (exit_frame_sym, proc, 0); + } + ret: + last_debug_info_frame = dbg_info.prev; + return proc; +#endif +} + +#ifndef DEVAL + +SCM_PROC(s_map, "map", 2, 0, 1, scm_map); +#ifdef __STDC__ +SCM +scm_map (SCM proc, SCM arg1, SCM args) +#else +SCM +scm_map (proc, arg1, args) + SCM proc; + SCM arg1; + SCM args; +#endif +{ + long i; + SCM res = SCM_EOL; + SCM *pres = &res; + SCM *ve = &args; /* Keep args from being optimized away. */ + + if (SCM_NULLP (arg1)) + return res; + SCM_ASSERT (SCM_NIMP (arg1), arg1, SCM_ARG2, s_map); + if (SCM_NULLP (args)) + { + while (SCM_NIMP (arg1)) + { + SCM_ASSERT (SCM_CONSP (arg1), arg1, SCM_ARG2, s_map); + *pres = scm_cons (scm_apply (proc, SCM_CAR (arg1), scm_listofnull), SCM_EOL); + pres = &SCM_CDR (*pres); + arg1 = SCM_CDR (arg1); + } + return res; + } + args = scm_vector (scm_cons (arg1, args)); + ve = SCM_VELTS (args); +#ifndef RECKLESS + for (i = SCM_LENGTH (args) - 1; i >= 0; i--) + SCM_ASSERT (SCM_NIMP (ve[i]) && SCM_CONSP (ve[i]), args, SCM_ARG2, s_map); +#endif + while (1) + { + arg1 = SCM_EOL; + for (i = SCM_LENGTH (args) - 1; i >= 0; i--) + { + if SCM_IMP + (ve[i]) return res; + arg1 = scm_cons (SCM_CAR (ve[i]), arg1); + ve[i] = SCM_CDR (ve[i]); + } + *pres = scm_cons (scm_apply (proc, arg1, SCM_EOL), SCM_EOL); + pres = &SCM_CDR (*pres); + } +} + + +SCM_PROC(s_for_each, "for-each", 2, 0, 1, scm_for_each); +#ifdef __STDC__ +SCM +scm_for_each (SCM proc, SCM arg1, SCM args) +#else +SCM +scm_for_each (proc, arg1, args) + SCM proc; + SCM arg1; + SCM args; +#endif +{ + SCM *ve = &args; /* Keep args from being optimized away. */ + long i; + if SCM_NULLP (arg1) + return SCM_UNSPECIFIED; + SCM_ASSERT (SCM_NIMP (arg1), arg1, SCM_ARG2, s_for_each); + if SCM_NULLP (args) + { + while SCM_NIMP (arg1) + { + SCM_ASSERT (SCM_CONSP (arg1), arg1, SCM_ARG2, s_for_each); + scm_apply (proc, SCM_CAR (arg1), scm_listofnull); + arg1 = SCM_CDR (arg1); + } + return SCM_UNSPECIFIED; + } + args = scm_vector (scm_cons (arg1, args)); + ve = SCM_VELTS (args); +#ifndef RECKLESS + for (i = SCM_LENGTH (args) - 1; i >= 0; i--) + SCM_ASSERT (SCM_NIMP (ve[i]) && SCM_CONSP (ve[i]), args, SCM_ARG2, s_for_each); +#endif + while (1) + { + arg1 = SCM_EOL; + for (i = SCM_LENGTH (args) - 1; i >= 0; i--) + { + if SCM_IMP + (ve[i]) return SCM_UNSPECIFIED; + arg1 = scm_cons (SCM_CAR (ve[i]), arg1); + ve[i] = SCM_CDR (ve[i]); + } + scm_apply (proc, arg1, SCM_EOL); + } +} + + +#ifdef __STDC__ +SCM +scm_closure (SCM code, SCM env) +#else +SCM +scm_closure (code, env) + SCM code; + SCM env; +#endif +{ + register SCM z; + SCM_NEWCELL (z); + SCM_SETCODE (z, code); + SCM_ENV (z) = env; + return z; +} + + +long scm_tc16_promise; +#ifdef __STDC__ +SCM +scm_makprom (SCM code) +#else +SCM +scm_makprom (code) + SCM code; +#endif +{ + register SCM z; + SCM_NEWCELL (z); + SCM_CDR (z) = code; + SCM_CAR (z) = scm_tc16_promise; + return z; +} + + +#ifdef __STDC__ +static int +prinprom (SCM exp, SCM port, int writing) +#else +static int +prinprom (exp, port, writing) + SCM exp; + SCM port; + int writing; +#endif +{ + scm_gen_puts (scm_regular_string, "#<promise ", port); + scm_iprin1 (SCM_CDR (exp), port, writing); + scm_gen_putc ('>', port); + return !0; +} + + +SCM_PROC(s_makacro, "procedure->syntax", 1, 0, 0, scm_makacro); +#ifdef __STDC__ +SCM +scm_makacro (SCM code) +#else +SCM +scm_makacro (code) + SCM code; +#endif +{ + register SCM z; + SCM_NEWCELL (z); + SCM_CDR (z) = code; + SCM_CAR (z) = scm_tc16_macro; + return z; +} + + +SCM_PROC(s_makmacro, "procedure->macro", 1, 0, 0, scm_makmacro); +#ifdef __STDC__ +SCM +scm_makmacro (SCM code) +#else +SCM +scm_makmacro (code) + SCM code; +#endif +{ + register SCM z; + SCM_NEWCELL (z); + SCM_CDR (z) = code; + SCM_CAR (z) = scm_tc16_macro | (1L << 16); + return z; +} + + +SCM_PROC(s_makmmacro, "procedure->memoizing-macro", 1, 0, 0, scm_makmmacro); +#ifdef __STDC__ +SCM +scm_makmmacro (SCM code) +#else +SCM +scm_makmmacro (code) + SCM code; +#endif +{ + register SCM z; + SCM_NEWCELL (z); + SCM_CDR (z) = code; + SCM_CAR (z) = scm_tc16_macro | (2L << 16); + return z; +} + + +#ifdef __STDC__ +static int +prinmacro (SCM exp, SCM port, int writing) +#else +static int +prinmacro (exp, port, writing) + SCM exp; + SCM port; + int writing; +#endif +{ + if (SCM_CAR (exp) & (3L << 16)) + scm_gen_puts (scm_regular_string, "#<macro", port); + else + scm_gen_puts (scm_regular_string, "#<syntax", port); + if (SCM_CAR (exp) & (2L << 16)) + scm_gen_putc ('!', port); + scm_gen_putc (' ', port); + scm_iprin1 (SCM_CDR (exp), port, writing); + scm_gen_putc ('>', port); + return !0; +} + +SCM_PROC(s_force, "force", 1, 0, 0, scm_force); +#ifdef __STDC__ +SCM +scm_force (SCM x) +#else +SCM +scm_force (x) + SCM x; +#endif +{ + SCM_ASSERT ((SCM_TYP16 (x) == scm_tc16_promise), x, SCM_ARG1, s_force); + if (!((1L << 16) & SCM_CAR (x))) + { + SCM ans = scm_apply (SCM_CDR (x), SCM_EOL, SCM_EOL); + if (!((1L << 16) & SCM_CAR (x))) + { + SCM_DEFER_INTS; + SCM_CDR (x) = ans; + SCM_CAR (x) |= (1L << 16); + SCM_ALLOW_INTS; + } + } + return SCM_CDR (x); +} + +SCM_PROC (s_promise_p, "promise?", 1, 0, 0, scm_promise_p); +#ifdef __STDC__ +SCM +scm_promise_p (SCM x) +#else +SCM +scm_promise_p (x) + SCM x; +#endif +{ + return ((SCM_NIMP (x) && (SCM_TYP16 (x) == scm_tc16_promise)) + ? SCM_BOOL_T + : SCM_BOOL_F); +} + +SCM_PROC(s_copy_tree, "copy-tree", 1, 0, 0, scm_copy_tree); +#ifdef __STDC__ +SCM +scm_copy_tree (SCM obj) +#else +SCM +scm_copy_tree (obj) + SCM obj; +#endif +{ + SCM ans, tl; + if SCM_IMP + (obj) return obj; + if (SCM_VECTORP (obj)) + { + scm_sizet i = SCM_LENGTH (obj); + ans = scm_make_vector (SCM_MAKINUM (i), SCM_UNSPECIFIED, SCM_UNDEFINED); + while (i--) + SCM_VELTS (ans)[i] = scm_copy_tree (SCM_VELTS (obj)[i]); + return ans; + } + if SCM_NCONSP (obj) + return obj; +/* return scm_cons(scm_copy_tree(SCM_CAR(obj)), scm_copy_tree(SCM_CDR(obj))); */ + ans = tl = scm_cons (scm_copy_tree (SCM_CAR (obj)), SCM_UNSPECIFIED); + while (SCM_NIMP (obj = SCM_CDR (obj)) && SCM_CONSP (obj)) + tl = (SCM_CDR (tl) = scm_cons (scm_copy_tree (SCM_CAR (obj)), SCM_UNSPECIFIED)); + SCM_CDR (tl) = obj; + return ans; +} + +#ifdef __STDC__ +SCM +scm_eval_3 (SCM obj, int copyp, SCM env) +#else +SCM +scm_eval_3 (obj, copyp, env) + SCM obj; + int copyp; + SCM env; +#endif +{ + if (SCM_NIMP (SCM_CDR (scm_system_transformer))) + obj = scm_apply (SCM_CDR (scm_system_transformer), obj, scm_listofnull); + else if (copyp) + obj = scm_copy_tree (obj); + return EVAL (obj, env); +} + +#ifdef __STDC__ +SCM +scm_top_level_env (SCM thunk) +#else +SCM +scm_top_level_env (thunk) + SCM thunk; +#endif +{ + if (SCM_IMP(thunk)) + return SCM_EOL; + else + return scm_cons(thunk, (SCM)SCM_EOL); +} + +SCM_PROC(s_eval2, "eval2", 2, 0, 0, scm_eval2); +#ifdef __STDC__ +SCM +scm_eval2 (SCM obj, SCM env_thunk) +#else +SCM +scm_eval2 (obj, env_thunk) + SCM obj; + SCM env_thunk; +#endif +{ + return scm_eval_3 (obj, 1, scm_top_level_env(env_thunk)); +} + +SCM_PROC(s_eval, "eval", 1, 0, 0, scm_eval); +#ifdef __STDC__ +SCM +scm_eval (SCM obj) +#else +SCM +scm_eval (obj) + SCM obj; +#endif +{ + return + scm_eval_3(obj, 1, scm_top_level_env(SCM_CDR(scm_top_level_lookup_thunk_var))); +} + +SCM_PROC(s_eval_x, "eval!", 1, 0, 0, scm_eval_x); +#ifdef __STDC__ +SCM +scm_eval_x (SCM obj) +#else +SCM +scm_eval_x (obj) + SCM obj; +#endif +{ + return + scm_eval_3(obj, + 0, + scm_top_level_env (SCM_CDR (scm_top_level_lookup_thunk_var))); +} + +SCM_PROC (s_macro_eval_x, "macro-eval!", 2, 0, 0, scm_macro_eval_x); +#ifdef __STDC__ +SCM +scm_macro_eval_x (SCM exp, SCM env) +#else +SCM +scm_macro_eval_x (exp, env) + SCM exp; + SCM env; +#endif +{ + return scm_eval_3 (exp, 0, env); +} + +#ifdef __STDC__ +SCM +scm_definedp (SCM x, SCM env) +#else +SCM +scm_definedp (x, env) + SCM x; + SCM env; +#endif +{ + SCM proc = SCM_CAR (x = SCM_CDR (x)); + if (SCM_ISYMP (proc)) + return SCM_BOOL_T; + else if(SCM_IMP(proc) || !SCM_SYMBOLP(proc)) + return SCM_BOOL_F; + else + { + SCM vcell = scm_sym2vcell(proc, env_top_level(env), SCM_BOOL_F); + return (vcell == SCM_BOOL_F || SCM_UNBNDP(SCM_CDR(vcell))) ? SCM_BOOL_F : SCM_BOOL_T; + } +} + +static scm_smobfuns promsmob = +{scm_markcdr, scm_free0, prinprom}; + +static scm_smobfuns macrosmob = +{scm_markcdr, scm_free0, prinmacro}; + +#ifdef __STDC__ +SCM +scm_make_synt (char *name, SCM (*macroizer) (), SCM (*fcn) ()) +#else +SCM +scm_make_synt (name, macroizer, fcn) + char *name; + SCM (*macroizer) (); + SCM (*fcn) (); +#endif +{ + SCM symcell = scm_sysintern (name, SCM_UNDEFINED); + long tmp = ((((SCM_CELLPTR) (SCM_CAR (symcell))) - scm_heap_org) << 8); + register SCM z; + if ((tmp >> 8) != ((SCM_CELLPTR) (SCM_CAR (symcell)) - scm_heap_org)) + tmp = 0; + SCM_NEWCELL (z); + SCM_SUBRF (z) = fcn; + SCM_CAR (z) = tmp + scm_tc7_subr_2; + SCM_CDR (symcell) = macroizer (z); + return SCM_CAR (symcell); +} + +#ifdef DEBUG_EXTENSIONS +# ifndef DEVAL +# define DEVAL +# include "eval.c" +# endif +#endif + + +#ifdef __STDC__ +void +scm_init_eval (void) +#else +void +scm_init_eval () +#endif +{ +#ifdef DEBUG_EXTENSIONS + enter_frame_sym = SCM_CAR (scm_sysintern ("enter-frame", SCM_UNDEFINED)); + exit_frame_sym = SCM_CAR (scm_sysintern ("exit-frame", SCM_UNDEFINED)); +#endif + scm_tc16_promise = scm_newsmob (&promsmob); + scm_tc16_macro = scm_newsmob (¯osmob); + scm_i_apply = scm_make_subr ("apply", scm_tc7_lsubr_2, scm_apply); + scm_system_transformer = scm_sysintern ("scm:eval-transformer", SCM_UNDEFINED); + scm_i_dot = SCM_CAR (scm_sysintern (".", SCM_UNDEFINED)); + scm_i_arrow = SCM_CAR (scm_sysintern ("=>", SCM_UNDEFINED)); + scm_i_else = SCM_CAR (scm_sysintern ("else", SCM_UNDEFINED)); + scm_i_unquote = SCM_CAR (scm_sysintern ("unquote", SCM_UNDEFINED)); + scm_i_uq_splicing = SCM_CAR (scm_sysintern ("unquote-splicing", SCM_UNDEFINED)); + + /* acros */ + scm_i_quasiquote = scm_make_synt (s_quasiquote, scm_makacro, scm_m_quasiquote); + scm_make_synt ("define", scm_makmmacro, scm_m_define); + scm_make_synt (s_delay, scm_makacro, scm_m_delay); + /* end of acros */ + + scm_top_level_lookup_thunk_var = + scm_sysintern("*top-level-lookup-thunk*", SCM_BOOL_F); + + scm_make_synt ("and", scm_makmmacro, scm_m_and); + scm_make_synt ("begin", scm_makmmacro, scm_m_begin); + scm_make_synt ("case", scm_makmmacro, scm_m_case); + scm_make_synt ("cond", scm_makmmacro, scm_m_cond); + scm_make_synt ("do", scm_makmmacro, scm_m_do); + scm_make_synt ("if", scm_makmmacro, scm_m_if); + scm_i_lambda = scm_make_synt ("lambda", scm_makmmacro, scm_m_lambda); + scm_i_let = scm_make_synt ("let", scm_makmmacro, scm_m_let); + scm_make_synt ("letrec", scm_makmmacro, scm_m_letrec); + scm_make_synt ("let*", scm_makmmacro, scm_m_letstar); + scm_make_synt ("or", scm_makmmacro, scm_m_or); + scm_i_quote = scm_make_synt ("quote", scm_makmmacro, scm_m_quote); + scm_make_synt ("set!", scm_makmmacro, scm_m_set); + scm_make_synt ("@apply", scm_makmmacro, scm_m_apply); + scm_make_synt ("@call-with-current-continuation", scm_makmmacro, scm_m_cont); + scm_make_synt ("defined?", scm_makmmacro, scm_definedp); + scm_i_name = SCM_CAR (scm_sysintern ("name", SCM_UNDEFINED)); + scm_permanent_object (scm_i_name); +#include "eval.x" +} +#endif /* !DEVAL */ + |