diff options
Diffstat (limited to 'libguile/eval.c')
-rw-r--r-- | libguile/eval.c | 1889 |
1 files changed, 1212 insertions, 677 deletions
diff --git a/libguile/eval.c b/libguile/eval.c index 7b2f3600e..b8c8e1b1f 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997 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 @@ -40,36 +40,116 @@ */ -/* 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. +/* This file is read twice in order to produce debugging versions of + * scm_ceval and scm_apply. These functions, scm_deval and + * scm_dapply, are produced when we define the preprocessor macro + * DEVAL. The file is divided into sections which are treated + * differently with respect to DEVAL. The heads of these sections are + * marked with the string "SECTION:". + */ + + +/* SECTION: This code is compiled once. */ #ifndef DEVAL +/* AIX requires this to be the first thing in the file. The #pragma + directive is indented so pre-ANSI compilers will ignore it, rather + than choke on it. */ +#ifndef __GNUC__ +# if HAVE_ALLOCA_H +# include <alloca.h> +# else +# ifdef _AIX + #pragma alloca +# else +# ifndef alloca /* predefined by HP cc +Olibcalls */ +char *alloca (); +# endif +# endif +# endif +#endif + #include <stdio.h> #include "_scm.h" +#include "debug.h" +#include "append.h" +#include "alist.h" +#include "sequences.h" +#include "eq.h" +#include "continuations.h" +#include "throw.h" +#include "smob.h" +#include "markers.h" +#include "procprop.h" +#include "hashtab.h" +#include "hash.h" +#ifdef DEBUG_EXTENSIONS +#include "debug.h" +#endif /* DEBUG_EXTENSIONS */ + +#include "srcprop.h" +#include "stackchk.h" + +#include "eval.h" +/* The evaluator contains a plethora of EVAL symbols. + * This is an attempt at explanation. + * + * The following macros should be used in code which is read twice + * (where the choice of evaluator is hard soldered): + * + * SCM_CEVAL is the symbol used within one evaluator to call itself. + * Originally, it is defined to scm_ceval, but is redefined to + * scm_deval during the second pass. + * + * SIDEVAL corresponds to SCM_CEVAL, but is used in situations where + * only side effects of expressions matter. All immediates are + * ignored. + * + * EVALIM is used when it is known that the expression is an + * immediate. (This macro never calls an evaluator.) + * + * EVALCAR evaluates the car of an expression. + * + * EVALCELLCAR is like EVALCAR, but is used when it is known that the + * car is a lisp cell. + * + * The following macros should be used in code which is read once + * (where the choice of evaluator is dynamic): + * + * XEVAL takes care of immediates without calling an evaluator. It + * then calls scm_ceval *or* scm_deval, depending on the debugging + * mode. + * + * XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval + * depending on the debugging mode. + * + * The main motivation for keeping this plethora is efficiency + * together with maintainability (=> locality of code). + */ + #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) +#define EVALIM(x, env) (SCM_ILOCP(x)?*scm_ilookup((x), env):x) #else -#define EVALIMP(x, env) x +#define EVALIM(x, env) x #endif #define EVALCAR(x, env) (SCM_NCELLP(SCM_CAR(x))\ ? (SCM_IMP(SCM_CAR(x)) \ - ? EVALIMP(SCM_CAR(x), env) \ + ? EVALIM(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) \ + ? EVALIM(SCM_CAR(x), env) \ : SCM_GLOC_VAL(SCM_CAR(x))) \ : (SCM_SYMBOLP(SCM_CAR(x)) \ ? *scm_lookupcar(x, env) \ @@ -78,18 +158,14 @@ #define XEVALCAR(x, env) EVALCAR(x, env) #endif -#define EXTEND_SCM_ENV SCM_EXTEND_SCM_ENV +#define EXTEND_ENV SCM_EXTEND_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; @@ -99,20 +175,16 @@ scm_ilookup (iloc, env) 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)); + return SCM_CDRLOC (er); + return SCM_CARLOC (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); @@ -123,20 +195,20 @@ scm_lookupcar (vloc, genv) { if (SCM_BOOL_T == scm_procedure_p (SCM_CAR (env))) break; - al = &SCM_CAR (env); + al = SCM_CARLOC (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; + SCM_SETCAR (vloc, iloc + SCM_ICDR); #endif - return &SCM_CDR (*al); + return SCM_CDRLOC (*al); } else break; - al = &SCM_CDR (*al); + al = SCM_CDRLOC (*al); if (SCM_CAR (fl) == var) { #ifdef MEMOIZE_LOCALS @@ -147,9 +219,9 @@ scm_lookupcar (vloc, genv) goto errout; } #endif - SCM_CAR (vloc) = iloc; + SCM_SETCAR (vloc, iloc); #endif - return &SCM_CAR (*al); + return SCM_CARLOC (*al); } #ifdef MEMOIZE_LOCALS iloc += SCM_IDINC; @@ -179,40 +251,40 @@ scm_lookupcar (vloc, genv) { var = SCM_CAR (var); errout: - scm_everr (vloc, genv, var, - (SCM_NULLP (env) - ? "unbound variable: " - : "damaged environment"), - ""); + /* scm_everr (vloc, genv,...) */ + scm_misc_error (NULL, + SCM_NULLP (env) + ? "Unbound variable: %S" + : "Damaged environment: %S", + scm_listify (var, SCM_UNDEFINED)); } #endif - SCM_CAR (vloc) = var + 1; + SCM_SETCAR (vloc, var + 1); /* Except wait...what if the var is not a vcell, * but syntax or something.... */ - return &SCM_CDR (var); + return SCM_CDRLOC (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 { +#ifdef DEBUG_EXTENSIONS register int ir; +#endif SCM c; if (SCM_IMP (form)) return form; c = SCM_CAR (form); if (1 == (c & 7)) - SCM_CAR (form) = SCM_CAR (c - 1); + SCM_SETCAR (form, SCM_CAR (c - 1)); #ifdef MEMOIZE_LOCALS +#ifdef DEBUG_EXTENSIONS else if (SCM_ILOCP (c)) { for (ir = SCM_IFRAME (c); ir != 0; --ir) @@ -220,23 +292,20 @@ scm_unmemocar (form, 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); + SCM_SETCAR (form, SCM_ICDRP (c) ? env : SCM_CAR (env)); } #endif +#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); + return XEVALCAR (pair, env); } @@ -256,70 +325,60 @@ static char s_formals[] = "bad formals"; 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 +SCM scm_i_define, scm_i_and, scm_i_begin, scm_i_case, scm_i_cond, + scm_i_do, scm_i_if, scm_i_let, scm_i_letrec, scm_i_letstar, + scm_i_or, scm_i_set, scm_i_atapply, scm_i_atcall_cc; static char s_quasiquote[] = "quasiquote"; static char s_delay[] = "delay"; +static char s_undefine[] = "undefine"; +#ifdef DEBUG_EXTENSIONS +SCM scm_i_enter_frame, scm_i_apply_frame, scm_i_exit_frame; +SCM scm_i_trace; +#endif #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 SCM_P ((SCM xorig, SCM *bodyloc, char *what)); + 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"); @@ -327,55 +386,35 @@ scm_m_if (xorig, env) } -#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; - } - } + SCM x = SCM_CDR (xorig); + ASSYNT (2 == scm_ilength (x), xorig, s_expression, "set!"); + ASSYNT (SCM_NIMP (SCM_CAR (x)) && SCM_SYMBOLP (SCM_CAR (x)), + xorig, s_variable, "set!"); 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"); + /* scm_everr (SCM_UNDEFINED, env,..., "global variable reference") */ + scm_misc_error (NULL, + "Bad variable: %S", + scm_listify (SCM_CAR (SCM_CDR (x)), SCM_UNDEFINED)); } ASSYNT (SCM_NIMP(x) && DEFSCM_VARIABLEP (SCM_CAR (x)), xorig, s_variable, s_vref); @@ -384,15 +423,11 @@ scm_m_vref (xorig, env) } -#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); @@ -404,15 +439,11 @@ scm_m_vset (xorig, env) #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"); @@ -423,15 +454,11 @@ scm_m_and (xorig, env) } -#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"); @@ -442,15 +469,11 @@ scm_m_or (xorig, env) } -#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"); @@ -465,15 +488,11 @@ scm_m_case (xorig, env) } -#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); @@ -486,7 +505,7 @@ scm_m_cond (xorig, env) 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; + SCM_SETCAR (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)))), @@ -497,15 +516,11 @@ scm_m_cond (xorig, env) } -#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) @@ -536,38 +551,33 @@ scm_m_lambda (xorig, env) (proc) badforms:scm_wta (xorig, s_formals, "lambda"); memlambda: - bodycheck (xorig, &SCM_CDR (x), "lambda"); + bodycheck (xorig, SCM_CDRLOC (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) + 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)); + varloc = SCM_CDRLOC (SCM_CDR (*varloc)); proc = SCM_CDR (proc); } x = scm_cons (vars, SCM_CDR (x)); - bodycheck (xorig, &SCM_CDR (x), "let*"); + bodycheck (xorig, SCM_CDRLOC (x), "let*"); return scm_cons (SCM_IM_LETSTAR, x); } @@ -586,15 +596,11 @@ scm_m_letstar (xorig, env) */ -#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; @@ -614,44 +620,33 @@ scm_m_do (xorig, env) 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); + initloc = SCM_CDRLOC (*initloc); arg1 = SCM_CDR (arg1); *steploc = scm_cons (SCM_IMP (arg1) ? SCM_CAR (vars) : SCM_CAR (arg1), SCM_EOL); /* step */ - steploc = &SCM_CDR (*steploc); + steploc = SCM_CDRLOC (*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"); + bodycheck (xorig, SCM_CARLOC (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); -} +/* evalcar is small version of inline EVALCAR when we don't care about + * speed + */ +#define evalcar scm_eval_car + + +static SCM iqq SCM_P ((SCM form, SCM env, int depth)); -#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; @@ -679,7 +674,6 @@ iqq (form, env, depth) --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) @@ -697,30 +691,22 @@ iqq (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); @@ -728,14 +714,12 @@ scm_m_delay (xorig, env) env)); } -#ifdef __STDC__ -static SCM -env_top_level (SCM env) -#else + +static SCM env_top_level SCM_P ((SCM env)); + static SCM env_top_level (env) SCM env; -#endif { while (SCM_NIMP(env)) { @@ -746,15 +730,11 @@ env_top_level (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); @@ -772,6 +752,10 @@ scm_m_define (x, env) if (SCM_TOP_LEVEL (env)) { x = evalcar (x, env); +#ifdef DEBUG_EXTENSIONS + if (SCM_REC_PROCNAMES_P && SCM_NIMP (x) && SCM_CLOSUREP (x)) + scm_set_procedure_property_x (x, scm_i_name, proc); +#endif arg1 = scm_sym2vcell (proc, env_top_level (env), SCM_BOOL_T); #if 0 #ifndef RECKLESS @@ -783,11 +767,7 @@ scm_m_define (x, env) 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; + SCM_SETCDR (arg1, x); #ifdef SICP return scm_cons2 (scm_i_quote, SCM_CAR (arg1), SCM_EOL); #else @@ -796,17 +776,45 @@ scm_m_define (x, env) } return scm_cons2 (SCM_IM_DEFINE, proc, x); } -/* end of acros */ -#ifdef __STDC__ -SCM -scm_m_letrec (SCM xorig, SCM env) +SCM +scm_m_undefine (x, env) + SCM x, env; +{ + SCM arg1 = x; + x = SCM_CDR (x); + ASSYNT (SCM_TOP_LEVEL (env), arg1, "bad placement ", s_undefine); + ASSYNT (SCM_NIMP (x) && SCM_CONSP (x) && SCM_CDR (x) == SCM_EOL, + arg1, s_expression, s_undefine); + x = SCM_CAR (x); + ASSYNT (SCM_NIMP (x) && SCM_SYMBOLP (x), arg1, s_variable, s_undefine); + arg1 = scm_sym2vcell (x, env_top_level (env), SCM_BOOL_F); + ASSYNT (SCM_NFALSEP (arg1) && !SCM_UNBNDP (SCM_CDR (arg1)), + x, "variable already unbound ", s_undefine); +#if 0 +#ifndef RECKLESS + if (SCM_NIMP (SCM_CDR (arg1)) && ((SCM) SCM_SNAME (SCM_CDR (arg1)) == x)) + scm_warn ("undefining built-in ", SCM_CHARS (x)); + else +#endif + if (5 <= scm_verbose && SCM_UNDEFINED != SCM_CDR (arg1)) + scm_warn ("redefining ", SCM_CHARS (x)); +#endif + SCM_SETCDR (arg1, SCM_UNDEFINED); +#ifdef SICP + return SCM_CAR (arg1); #else + return SCM_UNSPECIFIED; +#endif +} + +/* end of acros */ + + 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)); @@ -826,24 +834,20 @@ scm_m_letrec (xorig, env) 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); + initloc = SCM_CDRLOC (*initloc); } while SCM_NIMP (proc = SCM_CDR (proc)); cdrx = scm_cons2 (vars, inits, SCM_CDR (x)); - bodycheck (xorig, &SCM_CDR (SCM_CDR (cdrx)), what); + bodycheck (xorig, SCM_CDRLOC (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 */ @@ -872,9 +876,9 @@ scm_m_let (xorig, env) 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); + varloc = SCM_CDRLOC (*varloc); *initloc = scm_cons (SCM_CAR (SCM_CDR (arg1)), SCM_EOL); - initloc = &SCM_CDR (*initloc); + initloc = SCM_CDRLOC (*initloc); proc = SCM_CDR (proc); } return @@ -885,46 +889,238 @@ scm_m_let (xorig, 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) +#define s_atcall_cc (SCM_ISYMCHARS(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)); } +/* scm_unmemocopy takes a memoized expression together with its + * environment and rewrites it to its original form. Thus, it is the + * inversion of the rewrite rules above. The procedure is not + * optimized for speed. It's used in scm_iprin1 when printing the + * code of a closure, in scm_procedure_source, in display_frame when + * generating the source for a stackframe in a backtrace, and in + * display_expression. + */ + +static SCM unmemocopy SCM_P ((SCM x, SCM env)); + +static SCM +unmemocopy (x, env) + SCM x; + SCM env; +{ + SCM ls, z; +#ifdef DEBUG_EXTENSIONS + SCM p; +#endif + if (SCM_NCELLP (x) || SCM_NECONSP (x)) + return x; +#ifdef DEBUG_EXTENSIONS + p = scm_whash_lookup (scm_source_whash, x); +#endif + switch (SCM_TYP7 (x)) + { + case (127 & SCM_IM_AND): + ls = z = scm_cons (scm_i_and, SCM_UNSPECIFIED); + break; + case (127 & SCM_IM_BEGIN): + ls = z = scm_cons (scm_i_begin, SCM_UNSPECIFIED); + break; + case (127 & SCM_IM_CASE): + ls = z = scm_cons (scm_i_case, SCM_UNSPECIFIED); + break; + case (127 & SCM_IM_COND): + ls = z = scm_cons (scm_i_cond, SCM_UNSPECIFIED); + break; + case (127 & SCM_IM_DO): + ls = scm_cons (scm_i_do, SCM_UNSPECIFIED); + goto transform; + case (127 & SCM_IM_IF): + ls = z = scm_cons (scm_i_if, SCM_UNSPECIFIED); + break; + case (127 & SCM_IM_LET): + ls = scm_cons (scm_i_let, SCM_UNSPECIFIED); + goto transform; + case (127 & SCM_IM_LETREC): + { + SCM f, v, e, s; + ls = scm_cons (scm_i_letrec, SCM_UNSPECIFIED); + transform: + x = SCM_CDR (x); + f = v = SCM_CAR (x); + x = SCM_CDR (x); + z = EXTEND_ENV (f, SCM_EOL, env); + e = scm_reverse (unmemocopy (SCM_CAR (x), + SCM_CAR (ls) == scm_i_letrec ? z : env)); + env = z; + s = SCM_CAR (ls) == scm_i_do + ? scm_reverse (unmemocopy (SCM_CDR (SCM_CDR (SCM_CDR (x))), env)) + : f; + z = SCM_EOL; + do + { + z = scm_acons (SCM_CAR (v), + scm_cons (SCM_CAR (e), + SCM_CAR (s) == SCM_CAR (v) + ? SCM_EOL + : scm_cons (SCM_CAR (s), SCM_EOL)), + z); + v = SCM_CDR (v); + e = SCM_CDR (e); + s = SCM_CDR (s); + } + while SCM_NIMP (v); + z = scm_cons (z, SCM_UNSPECIFIED); + SCM_SETCDR (ls, z); + if (SCM_CAR (ls) == scm_i_do) + { + x = SCM_CDR (x); + SCM_SETCDR (z, scm_cons (unmemocopy (SCM_CAR (x), env), + SCM_UNSPECIFIED)); + z = SCM_CDR (z); + x = (SCM) (SCM_CARLOC (SCM_CDR (x)) - 1); + } + break; + } + case (127 & SCM_IM_LETSTAR): + { + SCM b, y; + x = SCM_CDR (x); + b = SCM_CAR (x); + y = SCM_EOL; + if SCM_IMP (b) + { + env = EXTEND_ENV (SCM_EOL, SCM_EOL, env); + goto letstar; + } + y = z = scm_acons (SCM_CAR (b), + unmemocar ( + scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b)), env), SCM_EOL), env), + SCM_UNSPECIFIED); + env = EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env); + b = SCM_CDR (SCM_CDR (b)); + if (SCM_IMP (b)) + { + SCM_SETCDR (y, SCM_EOL); + ls = scm_cons (scm_i_let, z = scm_cons (y, SCM_UNSPECIFIED)); + break; + } + do + { + SCM_SETCDR (z, scm_acons (SCM_CAR (b), + unmemocar ( + scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b)), env), SCM_EOL), env), + SCM_UNSPECIFIED)); + z = SCM_CDR (z); + env = EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env); + b = SCM_CDR (SCM_CDR (b)); + } + while SCM_NIMP (b); + SCM_SETCDR (z, SCM_EOL); + letstar: + ls = scm_cons (scm_i_letstar, z = scm_cons (y, SCM_UNSPECIFIED)); + break; + } + case (127 & SCM_IM_OR): + ls = z = scm_cons (scm_i_or, SCM_UNSPECIFIED); + break; + case (127 & SCM_IM_LAMBDA): + x = SCM_CDR (x); + ls = scm_cons (scm_i_lambda, + z = scm_cons (SCM_CAR (x), SCM_UNSPECIFIED)); + env = EXTEND_ENV (SCM_CAR (x), SCM_EOL, env); + break; + case (127 & SCM_IM_QUOTE): + ls = z = scm_cons (scm_i_quote, SCM_UNSPECIFIED); + break; + case (127 & SCM_IM_SET): + ls = z = scm_cons (scm_i_set, SCM_UNSPECIFIED); + break; + case (127 & SCM_IM_DEFINE): + { + SCM n; + x = SCM_CDR (x); + ls = scm_cons (scm_i_define, + z = scm_cons (n = SCM_CAR (x), SCM_UNSPECIFIED)); + if (SCM_NNULLP (env)) + SCM_SETCAR (SCM_CAR (env), scm_cons (n, SCM_CAR (SCM_CAR (env)))); + break; + } + case (127 & SCM_MAKISYM (0)): + z = SCM_CAR (x); + if (!SCM_ISYMP (z)) + goto unmemo; + switch SCM_ISYMNUM (z) + { + case (SCM_ISYMNUM (SCM_IM_APPLY)): + ls = z = scm_cons (scm_i_atapply, SCM_UNSPECIFIED); + goto loop; + case (SCM_ISYMNUM (SCM_IM_CONT)): + ls = z = scm_cons (scm_i_atcall_cc, SCM_UNSPECIFIED); + goto loop; + default: + /* appease the Sun compiler god: */ ; + } + unmemo: + default: + ls = z = unmemocar (scm_cons (unmemocopy (SCM_CAR (x), env), + SCM_UNSPECIFIED), + env); + } +loop: + while (SCM_CELLP (x = SCM_CDR (x)) && SCM_ECONSP (x)) + { + SCM_SETCDR (z, unmemocar (scm_cons (unmemocopy (SCM_CAR (x), env), + SCM_UNSPECIFIED), + env)); + z = SCM_CDR (z); + } + SCM_SETCDR (z, x); +#ifdef DEBUG_EXTENSIONS + if (SCM_NFALSEP (p)) + scm_whash_insert (scm_source_whash, ls, p); +#endif + return ls; +} + + +SCM +scm_unmemocopy (x, env) + SCM x; + SCM env; +{ + if (SCM_NNULLP (env)) + /* Make a copy of the lowest frame to protect it from + modifications by SCM_IM_DEFINE */ + return unmemocopy (x, scm_cons (SCM_CAR (env), SCM_CDR (env))); + else + return unmemocopy (x, env); +} + #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) @@ -944,69 +1140,224 @@ scm_badargsp (formals, args) long scm_tc16_macro; + +SCM +scm_eval_args (l, env) + SCM l; + SCM env; +{ + SCM res = SCM_EOL, *lloc = &res; + while (SCM_NIMP (l)) + { + *lloc = scm_cons (EVALCAR (l, env), SCM_EOL); + lloc = SCM_CDRLOC (*lloc); + l = SCM_CDR (l); + } + return res; +} + + +/* The SCM_CEVAL and SCM_APPLY functions use this function instead of + calling setjmp directly, to make sure that local variables don't + have their values clobbered by a longjmp. + + According to Harbison & Steele, "Automatic variables local to the + function containing setjmp are guaranteed to have their correct + value in ANSI C only if they have a volatile-qualified type or if + their values were not changed between the original call to setjmp + and the corresponding longjmp call." + + SCM_CEVAL and SCM_APPLY are too complex for me to see how to meet + the second condition, and making x and env volatile would be a + speed problem, so we'll just trivially meet the first, by having no + "automatic variables local to the function containing setjmp." */ + +/* Actually, this entire approach is bogus, because setjmp ends up + capturing the stack frame of the wrapper function, which then + returns, rendering the jump buffer invalid. Duh. Gotta find a + better way... -JimB */ +#define safe_setjmp(x) setjmp (x) +static int +unsafe_setjmp (jmp_buf env) +{ + /* I think ANSI requires us to write the function this way, instead + of just saying "return setjmp (env)". Maybe I'm being silly. + See Harbison & Steele, third edition, p. 353. */ + int val; + val = setjmp (env); + return val; +} + + #endif /* !DEVAL */ -#ifdef DEVAL -#undef SCM_EVAL_ARGS -#define SCM_EVAL_ARGS scm_deval_args + +/* SECTION: This code is specific for the debugging support. One + * branch is read when DEVAL isn't defined, the other when DEVAL is + * defined. + */ + +#ifndef DEVAL + +#define SCM_APPLY scm_apply +#define PREP_APPLY(proc, args) +#define ENTER_APPLY +#define RETURN(x) return x; +#ifdef STACK_CHECKING +#ifndef NO_CEVAL_STACK_CHECKING +#define EVAL_STACK_CHECKING +#endif +#endif + +#else /* !DEVAL */ + #undef SCM_CEVAL #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */ #undef SCM_APPLY #define SCM_APPLY scm_dapply +#undef PREP_APPLY +#define PREP_APPLY(p, l) \ +{ ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; } +#undef ENTER_APPLY +#define ENTER_APPLY \ +{\ + SCM_SET_ARGSREADY (debug);\ + if (CHECK_APPLY)\ + if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\ + {\ + SCM tmp, tail = SCM_TRACED_FRAME_P (debug) ? SCM_BOOL_T : SCM_BOOL_F;\ + SCM_SET_TRACED_FRAME (debug); \ + SCM_APPLY_FRAME_P = 0; \ + SCM_TRACE_P = 0; \ + SCM_RESET_DEBUG_MODE; \ + if (SCM_CHEAPTRAPS_P)\ + {\ + tmp = scm_make_debugobj (&debug);\ + scm_ithrow (scm_i_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\ + }\ + else\ + {\ + scm_make_cont (&tmp);\ + if (!safe_setjmp (SCM_JMPBUF (tmp)))\ + scm_ithrow (scm_i_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\ + }\ + }\ +} #undef RETURN #define RETURN(e) {proc = (e); goto exit;} -#else -#define SCM_EVAL_ARGS scm_eval_args -#define RETURN(x) return x; +#ifdef STACK_CHECKING +#ifndef EVAL_STACK_CHECKING +#define EVAL_STACK_CHECKING +#endif #endif -SCM -SCM_EVAL_ARGS (l, env) - SCM l, env; +/* scm_ceval_ptr points to the currently selected evaluator. + * *fixme*: Although efficiency is important here, this state variable + * should probably not be a global. It should be related to the + * current repl. + */ + + +SCM (*scm_ceval_ptr) SCM_P ((SCM x, SCM env)); + +/* scm_last_debug_frame contains a pointer to the last debugging + * information stack frame. It is accessed very often from the + * debugging evaluator, so it should probably not be indirectly + * addressed. Better to save and restore it from the current root at + * any stack swaps. + */ + +#ifndef USE_THREADS +scm_debug_frame *scm_last_debug_frame; +#endif + +/* scm_debug_eframe_size is the number of slots available for pseudo + * stack frames at each real stack frame. + */ + +int scm_debug_eframe_size; + +int scm_debug_mode, scm_check_entry_p, scm_check_apply_p, scm_check_exit_p; + +scm_option scm_debug_opts[] = { + { SCM_OPTION_BOOLEAN, "cheap", 1, + "*Flyweight representation of the stack at traps." }, + { SCM_OPTION_BOOLEAN, "breakpoints", 0, "*Check for breakpoints." }, + { SCM_OPTION_BOOLEAN, "trace", 0, "*Trace mode." }, + { SCM_OPTION_BOOLEAN, "procnames", 1, + "Record procedure names at definition." }, + { SCM_OPTION_BOOLEAN, "backwards", 0, + "Display backtrace in anti-chronological order." }, + { SCM_OPTION_INTEGER, "indent", 10, "Maximal indentation in backtrace." }, + { SCM_OPTION_INTEGER, "frames", 3, + "Maximum number of tail-recursive frames in backtrace." }, + { SCM_OPTION_INTEGER, "maxdepth", 1000, + "Maximal number of stored backtrace frames." }, + { SCM_OPTION_INTEGER, "depth", 20, "Maximal length of printed backtrace." }, + { SCM_OPTION_BOOLEAN, "backtrace", 0, "Show backtrace on error." }, + { SCM_OPTION_BOOLEAN, "debug", 0, "Use the debugging evaluator." }, + { SCM_OPTION_INTEGER, "stack", 20000, "Stack size limit (0 = no check)." } +}; + +scm_option scm_evaluator_trap_table[] = { + { SCM_OPTION_BOOLEAN, "enter-frame", 0, "Trap when eval enters new frame." }, + { SCM_OPTION_BOOLEAN, "apply-frame", 0, "Trap when entering apply." }, + { SCM_OPTION_BOOLEAN, "exit-frame", 0, "Trap when exiting eval or apply." } +}; + +SCM +scm_deval_args (l, env, lloc) + SCM l, env, *lloc; { - SCM res = SCM_EOL, *lloc = &res; + SCM *res = lloc; while (SCM_NIMP (l)) { *lloc = scm_cons (EVALCAR (l, env), SCM_EOL); - lloc = &SCM_CDR (*lloc); + lloc = SCM_CDRLOC (*lloc); l = SCM_CDR (l); } - return res; + return *res; } -#if 0 -#ifdef __STDC__ -SCM -scm_ceval (SCM x, SCM env) +#endif /* !DEVAL */ + + +/* SECTION: Some local definitions for the evaluator. + */ + +#ifndef DEVAL +#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 +#endif /* DEVAL */ + +#define BUILTIN_RPASUBR /* Handle rpsubrs and asubrs without calling apply */ + +/* SECTION: This is the evaluator. Like any real monster, it has + * three heads. This code is compiled twice. + */ + +#if 0 + 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 SCM_CEVAL (x, env) SCM x; SCM env; @@ -1016,14 +1367,80 @@ SCM_CEVAL (x, env) SCM *lloc; SCM arg1; } t; - SCM proc; - SCM arg2; - - SCM_CHECK_STACK; - - loop: + SCM proc, arg2; +#ifdef DEVAL + scm_debug_frame debug; + scm_debug_info *debug_info_end; + debug.prev = scm_last_debug_frame; + debug.status = scm_debug_eframe_size; + debug.vect = (scm_debug_info *) alloca (scm_debug_eframe_size + * sizeof (debug.vect[0])); + debug.info = debug.vect; + debug_info_end = debug.vect + scm_debug_eframe_size; + scm_last_debug_frame = &debug; +#endif +#ifdef EVAL_STACK_CHECKING + if (SCM_STACK_OVERFLOW_P ((SCM_STACKITEM *) &proc) + && scm_stack_checking_enabled_p) + { +#ifdef DEVAL + debug.info->e.exp = x; + debug.info->e.env = env; +#endif + scm_report_stack_overflow (); + } +#endif +#ifdef DEVAL + goto start; +#endif +loopnoap: + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); +loop: +#ifdef DEVAL + SCM_CLEAR_ARGSREADY (debug); + if (SCM_OVERFLOWP (debug)) + --debug.info; + else if (++debug.info >= debug_info_end) + { + SCM_SET_OVERFLOW (debug); + debug.info -= 2; + } +start: + debug.info->e.exp = x; + debug.info->e.env = env; + if (CHECK_ENTRY) + if (SCM_ENTER_FRAME_P || (SCM_BREAKPOINTS_P && SRCBRKP (x))) + { + SCM tail = SCM_TAILRECP (debug) ? SCM_BOOL_T : SCM_BOOL_F; + SCM_SET_TAILREC (debug); + SCM_ENTER_FRAME_P = 0; + SCM_RESET_DEBUG_MODE; + if (SCM_CHEAPTRAPS_P) + t.arg1 = scm_make_debugobj (&debug); + else + { + scm_make_cont (&t.arg1); + if (safe_setjmp (SCM_JMPBUF (t.arg1))) + { + x = SCM_THROW_VALUE (t.arg1); + if (SCM_IMP (x)) + { + RETURN (x); + } + else + /* This gives the possibility for the debugger to + modify the source expression before evaluation. */ + goto dispatch; + } + } + scm_ithrow (scm_i_enter_frame, + scm_cons2 (t.arg1, tail, + scm_cons (scm_unmemocopy (x, env), SCM_EOL)), + 0); + } +dispatch: +#endif SCM_ASYNC_TICK; - switch (SCM_TYP7 (x)) { case scm_tcs_symbols: @@ -1042,10 +1459,12 @@ SCM_CEVAL (x, env) } else x = t.arg1; + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto carloop; case (127 & SCM_IM_BEGIN): - + cdrxnoap: + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); cdrxbegin: x = SCM_CDR (x); @@ -1061,13 +1480,13 @@ SCM_CEVAL (x, env) if (SCM_NCELLP (SCM_CAR (x))) { x = SCM_CAR (x); - RETURN (SCM_IMP (x) ? EVALIMP (x, env) : SCM_GLOC_VAL (x)); + RETURN (SCM_IMP (x) ? EVALIM (x, env) : SCM_GLOC_VAL (x)) } if (SCM_SYMBOLP (SCM_CAR (x))) { retval: - RETURN (*scm_lookupcar (x, env)); + RETURN (*scm_lookupcar (x, env)) } x = SCM_CAR (x); @@ -1083,6 +1502,7 @@ SCM_CEVAL (x, env) if (scm_i_else == SCM_CAR (proc)) { x = SCM_CDR (proc); + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto begin; } proc = SCM_CAR (proc); @@ -1091,12 +1511,13 @@ SCM_CEVAL (x, env) if (CHECK_EQVISH (SCM_CAR (proc), t.arg1)) { x = SCM_CDR (SCM_CAR (x)); + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto begin; } proc = SCM_CDR (proc); } } - RETURN (SCM_UNSPECIFIED); + RETURN (SCM_UNSPECIFIED) case (127 & SCM_IM_COND): @@ -1107,19 +1528,24 @@ SCM_CEVAL (x, env) if (SCM_NFALSEP (t.arg1)) { x = SCM_CDR (proc); - if (SCM_NULLP (x)) + if SCM_NULLP (x) { - RETURN (t.arg1); + RETURN (t.arg1) } if (scm_i_arrow != SCM_CAR (x)) - goto begin; + { + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); + goto begin; + } proc = SCM_CDR (x); proc = EVALCAR (proc, env); SCM_ASRTGO (SCM_NIMP (proc), badfun); + PREP_APPLY (proc, scm_cons (t.arg1, SCM_EOL)); + ENTER_APPLY; goto evap1; } } - RETURN (SCM_UNSPECIFIED); + RETURN (SCM_UNSPECIFIED) case (127 & SCM_IM_DO): @@ -1131,7 +1557,7 @@ SCM_CEVAL (x, env) t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1); proc = SCM_CDR (proc); } - env = EXTEND_SCM_ENV (SCM_CAR (x), t.arg1, env); + env = EXTEND_ENV (SCM_CAR (x), t.arg1, env); x = SCM_CDR (SCM_CDR (x)); while (proc = SCM_CAR (x), SCM_FALSEP (EVALCAR (proc, env))) { @@ -1142,13 +1568,12 @@ SCM_CEVAL (x, 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)); + env = EXTEND_ENV (SCM_CAR (SCM_CAR (env)), t.arg1, SCM_CDR (env)); } x = SCM_CDR (proc); if (SCM_NULLP (x)) - { - RETURN (SCM_UNSPECIFIED); - } + RETURN (SCM_UNSPECIFIED); + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto begin; @@ -1160,6 +1585,7 @@ SCM_CEVAL (x, env) { RETURN (SCM_UNSPECIFIED); } + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto carloop; @@ -1172,14 +1598,14 @@ SCM_CEVAL (x, env) 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); + env = EXTEND_ENV (SCM_CAR (x), t.arg1, env); x = SCM_CDR (x); - goto cdrxbegin; + goto cdrxnoap; case (127 & SCM_IM_LETREC): x = SCM_CDR (x); - env = EXTEND_SCM_ENV (SCM_CAR (x), scm_undefineds, env); + env = EXTEND_ENV (SCM_CAR (x), scm_undefineds, env); x = SCM_CDR (x); proc = SCM_CAR (x); t.arg1 = SCM_EOL; @@ -1188,8 +1614,8 @@ SCM_CEVAL (x, env) 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; + SCM_SETCDR (SCM_CAR (env), t.arg1); + goto cdrxnoap; case (127 & SCM_IM_LETSTAR): @@ -1197,17 +1623,17 @@ SCM_CEVAL (x, env) proc = SCM_CAR (x); if (SCM_IMP (proc)) { - env = EXTEND_SCM_ENV (SCM_EOL, SCM_EOL, env); - goto cdrxbegin; + env = EXTEND_ENV (SCM_EOL, SCM_EOL, env); + goto cdrxnoap; } do { t.arg1 = SCM_CAR (proc); proc = SCM_CDR (proc); - env = EXTEND_SCM_ENV (t.arg1, EVALCAR (proc, env), env); + env = EXTEND_ENV (t.arg1, EVALCAR (proc, env), env); } while (SCM_NIMP (proc = SCM_CDR (proc))); - goto cdrxbegin; + goto cdrxnoap; case (127 & SCM_IM_OR): x = SCM_CDR (x); @@ -1221,6 +1647,7 @@ SCM_CEVAL (x, env) } x = t.arg1; } + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto carloop; @@ -1233,16 +1660,15 @@ SCM_CEVAL (x, env) case (127 & SCM_IM_SET): - set_some_more: x = SCM_CDR (x); proc = SCM_CAR (x); - switch (7 & (int)proc) + switch (7 & (int) proc) { case 0: t.lloc = scm_lookupcar (x, env); break; case 1: - t.lloc = &SCM_GLOC_VAL (proc); + t.lloc = SCM_GLOC_VAL_LOC (proc); break; #ifdef MEMOIZE_LOCALS case 4: @@ -1252,8 +1678,6 @@ SCM_CEVAL (x, env) } 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 @@ -1266,15 +1690,18 @@ SCM_CEVAL (x, env) proc = SCM_CAR (x); x = SCM_CDR (x); x = evalcar (x, env); +#ifdef DEBUG_EXTENSIONS + if (SCM_REC_PROCNAMES_P && SCM_NIMP (x) && SCM_CLOSUREP (x)) + scm_set_procedure_property_x (x, scm_i_name, proc); +#endif 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_SETCAR (env, scm_cons (proc, SCM_CAR (env))); + SCM_SETCDR (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); @@ -1291,7 +1718,7 @@ SCM_CEVAL (x, env) 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); + RETURN (SCM_UNSPECIFIED) #endif case (SCM_ISYMNUM (SCM_IM_APPLY)): @@ -1300,13 +1727,17 @@ SCM_CEVAL (x, env) SCM_ASRTGO (SCM_NIMP (proc), badfun); if (SCM_CLOSUREP (proc)) { + PREP_APPLY (proc, SCM_EOL); t.arg1 = SCM_CDR (SCM_CDR (x)); t.arg1 = EVALCAR (t.arg1, env); +#ifdef DEVAL + debug.info->a.args = t.arg1; +#endif #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)); + env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), t.arg1, SCM_ENV (proc)); x = SCM_CODE (proc); goto cdrxbegin; } @@ -1315,15 +1746,17 @@ SCM_CEVAL (x, env) case (SCM_ISYMNUM (SCM_IM_CONT)): scm_make_cont (&t.arg1); - if (setjmp (SCM_JMPBUF (t.arg1))) + if (safe_setjmp (SCM_JMPBUF (t.arg1))) { SCM val; val = SCM_THROW_VALUE (t.arg1); - RETURN (val);; + RETURN (val); } proc = SCM_CDR (x); proc = evalcar (proc, env); SCM_ASRTGO (SCM_NIMP (proc), badfun); + PREP_APPLY (proc, scm_cons (t.arg1, SCM_EOL)); + ENTER_APPLY; goto evap1; default: @@ -1333,8 +1766,10 @@ SCM_CEVAL (x, env) default: proc = x; badfun: - scm_everr (x, env, proc, "Wrong type to apply: ", ""); - + /* scm_everr (x, env,...) */ + scm_misc_error (NULL, + "Wrong type to apply: %S", + scm_listify (proc, SCM_UNDEFINED)); case scm_tc7_vector: case scm_tc7_wvect: case scm_tc7_bvect: @@ -1401,14 +1836,37 @@ SCM_CEVAL (x, env) case 2: if (scm_ilength (t.arg1) <= 0) t.arg1 = scm_cons2 (SCM_IM_BEGIN, t.arg1, SCM_EOL); +#ifdef DEVAL + if (!SCM_CLOSUREP (SCM_CDR (proc))) + { +#if 0 /* Top-level defines doesn't very often occur in backtraces */ + if (scm_m_define == SCM_SUBRF (SCM_CDR (proc)) && SCM_TOP_LEVEL (env)) + /* Prevent memoizing result of define macro */ + { + debug.info->e.exp = scm_cons (SCM_CAR (x), SCM_CDR (x)); + scm_set_source_properties_x (debug.info->e.exp, + scm_source_properties (x)); + } +#endif + SCM_DEFER_INTS; + SCM_SETCAR (x, SCM_CAR (t.arg1)); + SCM_SETCDR (x, SCM_CDR (t.arg1)); + SCM_ALLOW_INTS; + goto dispatch; + } + /* Prevent memoizing of debug info expression. */ + debug.info->e.exp = scm_cons (SCM_CAR (x), SCM_CDR (x)); + scm_set_source_properties_x (debug.info->e.exp, + scm_source_properties (x)); +#endif SCM_DEFER_INTS; - SCM_CAR (x) = SCM_CAR (t.arg1); - SCM_CDR (x) = SCM_CDR (t.arg1); + SCM_SETCAR (x, SCM_CAR (t.arg1)); + SCM_SETCDR (x, SCM_CDR (t.arg1)); SCM_ALLOW_INTS; - goto loop; + goto loopnoap; case 1: if (SCM_NIMP (x = t.arg1)) - goto loop; + goto loopnoap; case 0: RETURN (t.arg1); } @@ -1443,8 +1901,10 @@ SCM_CEVAL (x, env) } - evapply: - if (SCM_NULLP (SCM_CDR (x))) +evapply: + PREP_APPLY (proc, SCM_EOL); + if (SCM_NULLP (SCM_CDR (x))) { + ENTER_APPLY; switch (SCM_TYP7 (proc)) { /* no arguments given */ case scm_tc7_subr_0: @@ -1457,13 +1917,19 @@ SCM_CEVAL (x, env) RETURN (SCM_BOOL_T); case scm_tc7_asubr: RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED)); +#ifdef CCLO case scm_tc7_cclo: t.arg1 = proc; proc = SCM_CCLO_SUBR (proc); +#ifdef DEVAL + debug.info->a.proc = proc; + debug.info->a.args = scm_cons (t.arg1, SCM_EOL); +#endif goto evap1; +#endif case scm_tcs_closures: x = SCM_CODE (proc); - env = EXTEND_SCM_ENV (SCM_CAR (x), SCM_EOL, SCM_ENV (proc)); + env = EXTEND_ENV (SCM_CAR (x), SCM_EOL, SCM_ENV (proc)); goto cdrxbegin; case scm_tc7_contin: case scm_tc7_subr_1: @@ -1475,12 +1941,13 @@ SCM_CEVAL (x, env) umwrongnumargs: unmemocar (x, env); wrongnumargs: - scm_everr (x, env, proc, (char *) SCM_WNA, ""); + /* scm_everr (x, env,...) */ + scm_wrong_num_args (proc); default: /* handle macros here */ goto badfun; } - + } /* must handle macros by here */ x = SCM_CDR (x); @@ -1489,12 +1956,16 @@ SCM_CEVAL (x, env) goto wrongnumargs; #endif t.arg1 = EVALCAR (x, env); +#ifdef DEVAL + debug.info->a.args = scm_cons (t.arg1, SCM_EOL); +#endif x = SCM_CDR (x); if (SCM_NULLP (x)) { + ENTER_APPLY; evap1: switch (SCM_TYP7 (proc)) - { /* have one argument in t.arg1 */ + { /* have one argument in t.arg1 */ case scm_tc7_subr_2o: RETURN (SCM_SUBRF (proc) (t.arg1, SCM_UNDEFINED)); case scm_tc7_subr_1: @@ -1541,21 +2012,27 @@ SCM_CEVAL (x, env) RETURN (SCM_SUBRF (proc) (t.arg1, SCM_UNDEFINED)); case scm_tc7_lsubr: #ifdef DEVAL - RETURN (SCM_SUBRF (proc) (dbg_info.args)); + RETURN (SCM_SUBRF (proc) (debug.info->a.args)) #else RETURN (SCM_SUBRF (proc) (scm_cons (t.arg1, SCM_EOL))); #endif +#ifdef CCLO case scm_tc7_cclo: arg2 = t.arg1; t.arg1 = proc; proc = SCM_CCLO_SUBR (proc); +#ifdef DEVAL + debug.info->a.args = scm_cons (t.arg1, debug.info->a.args); + debug.info->a.proc = proc; +#endif goto evap2; +#endif case scm_tcs_closures: x = SCM_CODE (proc); #ifdef DEVAL - env = EXTEND_SCM_ENV (SCM_CAR (x), dbg_info.args, SCM_ENV (proc)); + env = EXTEND_ENV (SCM_CAR (x), debug.info->a.args, SCM_ENV (proc)); #else - env = EXTEND_SCM_ENV (SCM_CAR (x), scm_cons (t.arg1, SCM_EOL), SCM_ENV (proc)); + env = EXTEND_ENV (SCM_CAR (x), scm_cons (t.arg1, SCM_EOL), SCM_ENV (proc)); #endif goto cdrxbegin; case scm_tc7_contin: @@ -1575,165 +2052,216 @@ SCM_CEVAL (x, env) #endif { /* have two or more arguments */ arg2 = EVALCAR (x, env); +#ifdef DEVAL + debug.info->a.args = scm_cons2 (t.arg1, arg2, SCM_EOL); +#endif x = SCM_CDR (x); if (SCM_NULLP (x)) { + ENTER_APPLY; #ifdef CCLO evap2: #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 - dbg_info.args = scm_cons2 (t.arg1, arg2, SCM_EOL); + RETURN (SCM_SUBRF (proc) (debug.info->a.args)) +#else + RETURN (SCM_SUBRF (proc) (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: + 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: #ifdef DEVAL - RETURN (SCM_SUBRF (proc) (dbg_info.args)); + RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), proc, + scm_cons (debug.info->a.args, SCM_EOL))); #else - RETURN (SCM_SUBRF (proc) (scm_cons2 (t.arg1, arg2, SCM_EOL))); + RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), proc, + scm_cons2 (t.arg1, arg2, + scm_cons (scm_eval_args (x, env), 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: + /* 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)); + env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), debug.info->a.args, SCM_ENV (proc)); #else - env = EXTEND_SCM_ENV (SCM_CAR (SCM_CODE (proc)), scm_cons2 (t.arg1, arg2, SCM_EOL), SCM_ENV (proc)); + env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), scm_cons2 (t.arg1, arg2, SCM_EOL), SCM_ENV (proc)); #endif - x = SCM_CODE (proc); - goto cdrxbegin; - } + x = SCM_CODE (proc); + goto cdrxbegin; + } } #ifdef DEVAL - dbg_info.args = scm_cons2 (t.arg1, arg2, scm_deval_args (x, env)); + debug.info->a.args = scm_cons2 (t.arg1, arg2, + scm_deval_args (x, env, SCM_CDRLOC (SCM_CDR (debug.info->a.args)))); #endif - switch SCM_TYP7 - (proc) - { /* have 3 or more arguments */ + ENTER_APPLY; + 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)); + 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 (debug.info->a.args))))); + case scm_tc7_asubr: +#ifdef BUILTIN_RPASUBR + t.arg1 = SCM_SUBRF(proc)(t.arg1, arg2); + arg2 = SCM_CDR (SCM_CDR (debug.info->a.args)); + do { + t.arg1 = SCM_SUBRF(proc)(t.arg1, SCM_CAR (arg2)); + arg2 = SCM_CDR (arg2); + } while (SCM_NIMP (arg2)); + RETURN (t.arg1) +#endif /* BUILTIN_RPASUBR */ + case scm_tc7_rpsubr: +#ifdef BUILTIN_RPASUBR + if (SCM_FALSEP (SCM_SUBRF (proc) (t.arg1, arg2))) + RETURN (SCM_BOOL_F) + t.arg1 = SCM_CDR (SCM_CDR (debug.info->a.args)); + do { + if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, SCM_CAR (t.arg1)))) + RETURN (SCM_BOOL_F) + arg2 = SCM_CAR (t.arg1); + t.arg1 = SCM_CDR (t.arg1); + } while (SCM_NIMP (t.arg1)); + RETURN (SCM_BOOL_T) +#else /* BUILTIN_RPASUBR */ + RETURN (SCM_APPLY (proc, t.arg1, scm_acons (arg2, SCM_CDR (SCM_CDR (debug.info->a.args)), SCM_EOL))) +#endif /* BUILTIN_RPASUBR */ + case scm_tc7_lsubr_2: + RETURN (SCM_SUBRF (proc) (t.arg1, arg2, SCM_CDR (SCM_CDR (debug.info->a.args)))) + case scm_tc7_lsubr: + RETURN (SCM_SUBRF (proc) (debug.info->a.args)) #ifdef CCLO - case scm_tc7_cclo: - goto cclon; + 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)))); + case scm_tcs_closures: + SCM_SET_ARGSREADY (debug); + env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), + debug.info->a.args, + SCM_ENV (proc)); + x = SCM_CODE (proc); + goto cdrxbegin; +#else /* DEVAL */ + 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: +#ifdef BUILTIN_RPASUBR + t.arg1 = SCM_SUBRF(proc)(t.arg1, arg2); + do { + t.arg1 = SCM_SUBRF(proc)(t.arg1, EVALCAR(x, env)); + x = SCM_CDR(x); + } while (SCM_NIMP (x)); + RETURN (t.arg1) +#endif /* BUILTIN_RPASUBR */ + case scm_tc7_rpsubr: +#ifdef BUILTIN_RPASUBR + if (SCM_FALSEP (SCM_SUBRF (proc) (t.arg1, arg2))) + RETURN (SCM_BOOL_F) + do { + t.arg1 = EVALCAR (x, env); + if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, t.arg1))) + RETURN (SCM_BOOL_F) + arg2 = t.arg1; + x = SCM_CDR (x); + } while (SCM_NIMP (x)); + RETURN (SCM_BOOL_T) +#else /* BUILTIN_RPASUBR */ + RETURN (SCM_APPLY (proc, t.arg1, scm_acons (arg2, scm_eval_args (x, env), SCM_EOL))); +#endif /* BUILTIN_RPASUBR */ + 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; + 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; + case scm_tcs_closures: +#ifdef DEVAL + SCM_SET_ARGSREADY (debug); +#endif + env = EXTEND_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; - } + 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; +exit: + if (CHECK_EXIT) + if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug))) + { + SCM_EXIT_FRAME_P = 0; + SCM_TRACE_P = 0; + SCM_RESET_DEBUG_MODE; + SCM_CLEAR_TRACED_FRAME (debug); + if (SCM_CHEAPTRAPS_P) + t.arg1 = scm_make_debugobj (&debug); + else + { + scm_make_cont (&t.arg1); + if (safe_setjmp (SCM_JMPBUF (t.arg1))) + { + proc = SCM_THROW_VALUE (t.arg1); + goto ret; + } + } + scm_ithrow (scm_i_exit_frame, scm_cons2 (t.arg1, proc, SCM_EOL), 0); + } +ret: + scm_last_debug_frame = debug.prev; return proc; #endif } + +/* SECTION: This code is compiled once. + */ + #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, @@ -1760,111 +2288,162 @@ scm_procedure_documentation (proc) } } -/* This code is for scm_apply. it is destructive on multiple args. - * This will only screw you if you do (scm_apply scm_apply '( ... )) - */ +/* This code processes the arguments to apply: + + (apply PROC ARG1 ... ARGS) + + Given a list (ARG1 ... ARGS), this function conses the ARG1 + ... arguments onto the front of ARGS, and returns the resulting + list. Note that ARGS is a list; thus, the argument to this + function is a list whose last element is a list. + + Apply calls this function, and applies PROC to the elements of the + result. apply:nconc2last takes care of building the list of + arguments, given (ARG1 ... ARGS). + + Rather than do new consing, apply:nconc2last destroys its argument. + On that topic, this code came into my care with the following + beautifully cryptic comment on that topic: "This will only screw + you if you do (scm_apply scm_apply '( ... ))" If you know what + they're referring to, send me a patch to this comment. */ + 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); + SCM_ASSERT (scm_ilength (lst) > 0, 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_CDRLOC (*lloc); + SCM_ASSERT (scm_ilength (SCM_CAR (*lloc)) >= 0, lst, SCM_ARG1, s_nconc2last); *lloc = SCM_CAR (*lloc); return lst; } #endif /* !DEVAL */ + +/* SECTION: When DEVAL is defined this code yields scm_dapply. + * It is compiled twice. + */ + #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 +/* Apply a function to a list of arguments. + + This function is exported to the Scheme level as taking two + required arguments and a tail argument, as if it were: + (lambda (proc arg1 . args) ...) + Thus, if you just have a list of arguments to pass to a procedure, + pass the list as ARG1, and '() for ARGS. If you have some fixed + args, pass the first as ARG1, then cons any remaining fixed args + onto the front of your argument list, and pass that as ARGS. */ -#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) + scm_debug_frame debug; + scm_debug_info debug_vect_body; + debug.prev = scm_last_debug_frame; + debug.status = SCM_APPLYFRAME; + debug.vect = &debug_vect_body; + debug.vect[0].a.proc = proc; + debug.vect[0].a.args = SCM_EOL; + scm_last_debug_frame = &debug; +#else + if (SCM_DEBUGGINGP) return scm_dapply (proc, arg1, args); #endif #endif SCM_ASRTGO (SCM_NIMP (proc), badproc); + + /* If ARGS is the empty list, then we're calling apply with only two + arguments --- ARG1 is the list of arguments for PROC. Whatever + the case, futz with things so that ARG1 is the first argument to + give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the + rest. + + Setting the debug apply frame args this way is pretty messy. + Perhaps we should store arg1 and args directly in the frame as + received, and let scm_frame_arguments unpack them, because that's + a relatively rare operation. This works for now; if the Guile + developer archives are still around, see Mikael's post of + 11-Apr-97. */ if (SCM_NULLP (args)) { if (SCM_NULLP (arg1)) - arg1 = SCM_UNDEFINED; + { + arg1 = SCM_UNDEFINED; +#ifdef DEVAL + debug.vect[0].a.args = SCM_EOL; +#endif + } else { +#ifdef DEVAL + debug.vect[0].a.args = arg1; +#endif args = SCM_CDR (arg1); arg1 = SCM_CAR (arg1); } } else { - /* SCM_ASRTGO(SCM_NIMP(args) && SCM_CONSP(args), wrongnumargs); */ + /* SCM_ASRTGO(SCM_NIMP(args) && SCM_CONSP(args), wrongnumargs); */ args = scm_nconc2last (args); - } -#ifdef CCLO - tail: +#ifdef DEVAL + debug.vect[0].a.args = scm_cons (arg1, args); #endif + } #ifdef DEVAL - dbg_info.args = scm_cons (arg1, args); + if (SCM_ENTER_FRAME_P) + { + SCM tmp; + SCM_ENTER_FRAME_P = 0; + SCM_RESET_DEBUG_MODE; + if (SCM_CHEAPTRAPS_P) + tmp = scm_make_debugobj (&debug); + else + { + scm_make_cont (&tmp); + if (safe_setjmp (SCM_JMPBUF (tmp))) + goto entap; + } + scm_ithrow (scm_i_enter_frame, scm_cons (tmp, SCM_EOL), 0); + } +entap: + ENTER_APPLY; +#endif +#ifdef CCLO +tail: #endif switch (SCM_TYP7 (proc)) { @@ -1887,13 +2466,15 @@ SCM_APPLY (proc, arg1, args) #ifdef SCM_FLOATS if (SCM_SUBRF (proc)) { - if SCM_INUMP - (arg1) - RETURN (scm_makdbl (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1)), 0.0)) + 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)) + if (SCM_REALP (arg1)) + { + RETURN (scm_makdbl (SCM_DSUBRF (proc) (SCM_REALPART (arg1)), 0.0)); + } #ifdef SCM_BIGDIG if SCM_BIGP (arg1) @@ -1918,7 +2499,7 @@ SCM_APPLY (proc, arg1, args) 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)) + RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args)) #else RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args))) #endif @@ -1949,7 +2530,7 @@ SCM_APPLY (proc, arg1, args) RETURN (SCM_BOOL_T); case scm_tcs_closures: #ifdef DEVAL - arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : dbg_info.args); + arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args); #else arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args)); #endif @@ -1957,7 +2538,7 @@ SCM_APPLY (proc, arg1, args) 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)); + args = EXTEND_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); @@ -1968,54 +2549,65 @@ SCM_APPLY (proc, arg1, args) #ifdef CCLO case scm_tc7_cclo: #ifdef DEVAL - args = (SCM_UNBNDP(arg1) ? SCM_EOL : dbg_info.args); + args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args); + arg1 = proc; + proc = SCM_CCLO_SUBR (proc); + debug.vect[0].a.proc = proc; + debug.vect[0].a.args = scm_cons (arg1, args); #else args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args)); -#endif arg1 = proc; proc = SCM_CCLO_SUBR (proc); +#endif goto tail; #endif wrongnumargs: - scm_wta (proc, (char *) SCM_WNA, "apply"); + scm_wrong_num_args (proc); 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; +exit: + if (CHECK_EXIT) + if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug))) + { + SCM_EXIT_FRAME_P = 0; + SCM_RESET_DEBUG_MODE; + SCM_CLEAR_TRACED_FRAME (debug); + if (SCM_CHEAPTRAPS_P) + arg1 = scm_make_debugobj (&debug); + else + { + scm_make_cont (&arg1); + if (safe_setjmp (SCM_JMPBUF (arg1))) + { + proc = SCM_THROW_VALUE (arg1); + goto ret; + } + } + scm_ithrow (scm_i_exit_frame, scm_cons2 (arg1, proc, SCM_EOL), 0); + } +ret: + scm_last_debug_frame = debug.prev; return proc; #endif } + +/* SECTION: The rest of this file is only read once. + */ + #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; @@ -2031,7 +2623,7 @@ scm_map (proc, arg1, args) { 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); + pres = SCM_CDRLOC (*pres); arg1 = SCM_CDR (arg1); } return res; @@ -2053,22 +2645,18 @@ scm_map (proc, arg1, args) ve[i] = SCM_CDR (ve[i]); } *pres = scm_cons (scm_apply (proc, arg1, SCM_EOL), SCM_EOL); - pres = &SCM_CDR (*pres); + pres = SCM_CDRLOC (*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; @@ -2106,125 +2694,105 @@ scm_for_each (proc, arg1, args) } -#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; + SCM_SETENV (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; + SCM_SETCDR (z, code); + SCM_SETCAR (z, scm_tc16_promise); return z; } -#ifdef __STDC__ -static int -prinprom (SCM exp, SCM port, int writing) -#else + +static int prinprom SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); + static int -prinprom (exp, port, writing) +prinprom (exp, port, pstate) SCM exp; SCM port; - int writing; -#endif + scm_print_state *pstate; { + int writingp = SCM_WRITINGP (pstate); scm_gen_puts (scm_regular_string, "#<promise ", port); - scm_iprin1 (SCM_CDR (exp), port, writing); + SCM_SET_WRITINGP (pstate, 1); + scm_iprin1 (SCM_CDR (exp), port, pstate); + SCM_SET_WRITINGP (pstate, writingp); 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; + SCM_SETCDR (z, code); + SCM_SETCAR (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); + SCM_SETCDR (z, code); + SCM_SETCAR (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); + SCM_SETCDR (z, code); + SCM_SETCAR (z, scm_tc16_macro | (2L << 16)); return z; } -#ifdef __STDC__ -static int -prinmacro (SCM exp, SCM port, int writing) -#else + +static int prinmacro SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); + static int -prinmacro (exp, port, writing) +prinmacro (exp, port, pstate) SCM exp; SCM port; - int writing; -#endif + scm_print_state *pstate; { + int writingp = SCM_WRITINGP (pstate); if (SCM_CAR (exp) & (3L << 16)) scm_gen_puts (scm_regular_string, "#<macro", port); else @@ -2232,20 +2800,18 @@ prinmacro (exp, port, writing) if (SCM_CAR (exp) & (2L << 16)) scm_gen_putc ('!', port); scm_gen_putc (' ', port); - scm_iprin1 (SCM_CDR (exp), port, writing); + SCM_SET_WRITINGP (pstate, 1); + scm_iprin1 (SCM_CDR (exp), port, pstate); + SCM_SET_WRITINGP (pstate, writingp); 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))) @@ -2254,8 +2820,8 @@ scm_force (x) if (!((1L << 16) & SCM_CAR (x))) { SCM_DEFER_INTS; - SCM_CDR (x) = ans; - SCM_CAR (x) |= (1L << 16); + SCM_SETCDR (x, ans); + SCM_SETOR_CAR (x, (1L << 16)); SCM_ALLOW_INTS; } } @@ -2263,14 +2829,10 @@ scm_force (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 @@ -2278,14 +2840,10 @@ scm_promise_p (x) } 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 @@ -2303,37 +2861,33 @@ scm_copy_tree (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; + { + SCM_SETCDR (tl, scm_cons (scm_copy_tree (SCM_CAR (obj)), + SCM_UNSPECIFIED)); + tl = SCM_CDR (tl); + } + SCM_SETCDR (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); + return XEVAL (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; @@ -2342,83 +2896,66 @@ scm_top_level_env (thunk) } 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_eval_3(obj, 1, scm_top_level_env(SCM_CDR(scm_top_level_lookup_closure_var))); } -SCM_PROC(s_eval_x, "eval!", 1, 0, 0, scm_eval_x); -#ifdef __STDC__ -SCM -scm_eval_x (SCM obj) -#else +/* SCM_PROC(s_eval_x, "eval!", 1, 0, 0, scm_eval_x); */ + 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_top_level_env (SCM_CDR (scm_top_level_lookup_closure_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_PROC (s_definedp, "defined?", 1, 0, 0, scm_definedp); + SCM -scm_definedp (x, env) - SCM x; - SCM env; -#endif +scm_definedp (sym) + SCM sym; { - SCM proc = SCM_CAR (x = SCM_CDR (x)); - if (SCM_ISYMP (proc)) + SCM vcell; + + if (SCM_ISYMP (sym)) 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; - } + + SCM_ASSERT (SCM_NIMP (sym) && SCM_SYMBOLP (sym), sym, SCM_ARG1, s_definedp); + + vcell = scm_sym2vcell(sym, + SCM_CDR (scm_top_level_lookup_closure_var), + SCM_BOOL_F); + return (vcell == SCM_BOOL_F || SCM_UNBNDP(SCM_CDR(vcell))) ? + SCM_BOOL_F : SCM_BOOL_T; } static scm_smobfuns promsmob = @@ -2427,16 +2964,12 @@ static scm_smobfuns promsmob = 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); @@ -2445,31 +2978,25 @@ scm_make_synt (name, macroizer, fcn) tmp = 0; SCM_NEWCELL (z); SCM_SUBRF (z) = fcn; - SCM_CAR (z) = tmp + scm_tc7_subr_2; - SCM_CDR (symcell) = macroizer (z); + SCM_SETCAR (z, tmp + scm_tc7_subr_2); + SCM_SETCDR (symcell, macroizer (z)); return SCM_CAR (symcell); } + +/* At this point, scm_deval and scm_dapply are generated. + */ + #ifdef DEBUG_EXTENSIONS -# ifndef DEVAL -# define DEVAL -# include "eval.c" -# endif +# define DEVAL +# include "eval.c" #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); @@ -2482,32 +3009,40 @@ scm_init_eval () /* 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_undefine, scm_makacro, scm_m_undefine); 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_top_level_lookup_closure_var = + scm_sysintern("*top-level-lookup-closure*", SCM_BOOL_F); + scm_can_use_top_level_lookup_closure_var = 1; + + scm_i_and = scm_make_synt ("and", scm_makmmacro, scm_m_and); + scm_i_begin = scm_make_synt ("begin", scm_makmmacro, scm_m_begin); + scm_i_case = scm_make_synt ("case", scm_makmmacro, scm_m_case); + scm_i_cond = scm_make_synt ("cond", scm_makmmacro, scm_m_cond); + scm_i_define = scm_make_synt ("define", scm_makmmacro, scm_m_define); + scm_i_do = scm_make_synt ("do", scm_makmmacro, scm_m_do); + scm_i_if = 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_letrec = scm_make_synt ("letrec", scm_makmmacro, scm_m_letrec); + scm_i_letstar = scm_make_synt ("let*", scm_makmmacro, scm_m_letstar); + scm_i_or = 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); + scm_i_set = scm_make_synt ("set!", scm_makmmacro, scm_m_set); + scm_i_atapply = scm_make_synt ("@apply", scm_makmmacro, scm_m_apply); + scm_i_atcall_cc = scm_make_synt ("@call-with-current-continuation", + scm_makmmacro, scm_m_cont); + +#ifdef DEBUG_EXTENSIONS + scm_i_enter_frame = SCM_CAR (scm_sysintern ("enter-frame", SCM_UNDEFINED)); + scm_i_apply_frame = SCM_CAR (scm_sysintern ("apply-frame", SCM_UNDEFINED)); + scm_i_exit_frame = SCM_CAR (scm_sysintern ("exit-frame", SCM_UNDEFINED)); + scm_i_trace = SCM_CAR (scm_sysintern ("trace", SCM_UNDEFINED)); +#endif + #include "eval.x" } -#endif /* !DEVAL */ +#endif /* !DEVAL */ |