X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/48b96f4b0418d2bebeaa5c49a9aa51270ab86415..1bbd0b849f6b90f1ffe57e586e4ee5a884f84a11:/libguile/eval.c diff --git a/libguile/eval.c b/libguile/eval.c index d9129dcbc..f92a3c8de 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998, 1999 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 @@ -12,7 +12,8 @@ * * 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. + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA * * As a special exception, the Free Software Foundation gives permission * for additional uses of the text contained in its release of GUILE. @@ -36,8 +37,11 @@ * * 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. - */ + * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + /* This file is read twice in order to produce debugging versions of @@ -54,12 +58,13 @@ #ifndef DEVAL +/* We need this to get the definitions for HAVE_ALLOCA_H, etc. */ +#include "scmconfig.h" + /* 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. */ -#ifdef __GNUC__ -# define alloca __builtin_alloca -#else +#ifndef __GNUC__ # if HAVE_ALLOCA_H # include # else @@ -76,26 +81,26 @@ char *alloca (); #include #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 "macros.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 "objects.h" +#include "feature.h" +#include "modules.h" +#include "scm_validate.h" #include "eval.h" + +SCM (*scm_memoize_method) (SCM, SCM); + /* The evaluator contains a plethora of EVAL symbols. @@ -112,7 +117,7 @@ char *alloca (); * only side effects of expressions matter. All immediates are * ignored. * - * EVALIM is used when it is known that the expression is an + * SCM_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. @@ -123,42 +128,29 @@ char *alloca (); * 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 + * SCM_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 + * SCM_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 SCM_CEVAL scm_ceval +#define SIDEVAL(x, env) if (SCM_NIMP(x)) SCM_CEVAL((x), (env)) + #define EVALCELLCAR(x, env) (SCM_SYMBOLP (SCM_CAR(x)) \ - ? *scm_lookupcar(x, env) \ + ? *scm_lookupcar(x, env, 1) \ : SCM_CEVAL(SCM_CAR(x), env)) -#ifdef MEMOIZE_LOCALS -#define EVALIM(x, env) (SCM_ILOCP(x)?*scm_ilookup((x), env):x) -#else -#define EVALIM(x, env) x -#endif #define EVALCAR(x, env) (SCM_NCELLP(SCM_CAR(x))\ ? (SCM_IMP(SCM_CAR(x)) \ - ? EVALIM(SCM_CAR(x), env) \ + ? SCM_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)) \ - ? EVALIM(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_ENV SCM_EXTEND_ENV @@ -182,14 +174,101 @@ scm_ilookup (iloc, env) } #endif +#ifdef USE_THREADS + +/* The Lookup Car Race + - by Eva Luator + + Memoization of variables and special forms is done while executing + the code for the first time. As long as there is only one thread + everything is fine, but as soon as two threads execute the same + code concurrently `for the first time' they can come into conflict. + + This memoization includes rewriting variable references into more + efficient forms and expanding macros. Furthermore, macro expansion + includes `compiling' special forms like `let', `cond', etc. into + tree-code instructions. + + There shouldn't normally be a problem with memoizing local and + global variable references (into ilocs and glocs), because all + threads will mutate the code in *exactly* the same way and (if I + read the C code correctly) it is not possible to observe a half-way + mutated cons cell. The lookup procedure can handle this + transparently without any critical sections. + + It is different with macro expansion, because macro expansion + happens outside of the lookup procedure and can't be + undone. Therefore it can't cope with it. It has to indicate + failure when it detects a lost race and hope that the caller can + handle it. Luckily, it turns out that this is the case. + + An example to illustrate this: Suppose that the follwing form will + be memoized concurrently by two threads + + (let ((x 12)) x) + + Let's first examine the lookup of X in the body. The first thread + decides that it has to find the symbol "x" in the environment and + starts to scan it. Then the other thread takes over and actually + overtakes the first. It looks up "x" and substitutes an + appropriate iloc for it. Now the first thread continues and + completes its lookup. It comes to exactly the same conclusions as + the second one and could - without much ado - just overwrite the + iloc with the same iloc. + + But let's see what will happen when the race occurs while looking + up the symbol "let" at the start of the form. It could happen that + the second thread interrupts the lookup of the first thread and not + only substitutes a gloc for it but goes right ahead and replaces it + with the compiled form (#@let* (x 12) x). Now, when the first + thread completes its lookup, it would replace the #@let* with a + gloc pointing to the "let" binding, effectively reverting the form + to (let (x 12) x). This is wrong. It has to detect that it has + lost the race and the evaluator has to reconsider the changed form + completely. + + This race condition could be resolved with some kind of traffic + light (like mutexes) around scm_lookupcar, but I think that it is + best to avoid them in this case. They would serialize memoization + completely and because lookup involves calling arbitrary Scheme + code (via the lookup-thunk), threads could be blocked for an + arbitrary amount of time or even deadlock. But with the current + solution a lot of unnecessary work is potentially done. */ + +/* SCM_LOOKUPCAR1 is was SCM_LOOKUPCAR used to be but is allowed to + return NULL to indicate a failed lookup due to some race conditions + between threads. This only happens when VLOC is the first cell of + a special form that will eventually be memoized (like `let', etc.) + In that case the whole lookup is bogus and the caller has to + reconsider the complete special form. + + SCM_LOOKUPCAR is still there, of course. It just calls + SCM_LOOKUPCAR1 and aborts on recieving NULL. So SCM_LOOKUPCAR + should only be called when it is known that VLOC is not the first + pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check + for NULL. I think I've found the only places where this + applies. */ + +#endif /* USE_THREADS */ + +/* scm_lookupcar returns a pointer to this when a variable could not + be found and it should not throw an error. Never assign to this. +*/ +static scm_cell undef_cell = { SCM_UNDEFINED, SCM_UNDEFINED }; +#ifdef USE_THREADS +static SCM * +scm_lookupcar1 (SCM vloc, SCM genv, int check) +#else SCM * -scm_lookupcar (vloc, genv) - SCM vloc; - SCM genv; +scm_lookupcar (SCM vloc, SCM genv, int check) +#endif { SCM env = genv; register SCM *al, fl, var = SCM_CAR (vloc); +#ifdef USE_THREADS + register SCM var2 = var; +#endif #ifdef MEMOIZE_LOCALS register SCM iloc = SCM_ILOC00; #endif @@ -201,25 +280,35 @@ scm_lookupcar (vloc, genv) for (fl = SCM_CAR (*al); SCM_NIMP (fl); fl = SCM_CDR (fl)) { if (SCM_NCONSP (fl)) + { if (fl == var) { #ifdef MEMOIZE_LOCALS +#ifdef USE_THREADS + if (SCM_CAR (vloc) != var) + goto race; +#endif SCM_SETCAR (vloc, iloc + SCM_ICDR); #endif return SCM_CDRLOC (*al); } - else - break; + else + break; + } al = SCM_CDRLOC (*al); if (SCM_CAR (fl) == var) { #ifdef MEMOIZE_LOCALS -#ifndef RECKLESS /* letrec inits to SCM_UNDEFINED */ +#ifndef SCM_RECKLESS /* letrec inits to SCM_UNDEFINED */ if (SCM_UNBNDP (SCM_CAR (*al))) { env = SCM_EOL; goto errout; } +#endif +#ifdef USE_THREADS + if (SCM_CAR (vloc) != var) + goto race; #endif SCM_SETCAR (vloc, iloc); #endif @@ -248,26 +337,65 @@ scm_lookupcar (vloc, genv) else var = vcell; } -#ifndef RECKLESS +#ifndef SCM_RECKLESS if (SCM_NNULLP (env) || SCM_UNBNDP (SCM_CDR (var))) { var = SCM_CAR (var); errout: /* scm_everr (vloc, genv,...) */ - scm_misc_error (NULL, - SCM_NULLP (env) - ? "Unbound variable: %S" - : "Damaged environment: %S", - scm_listify (var, SCM_UNDEFINED)); + if (check) + scm_misc_error (NULL, + SCM_NULLP (env) + ? "Unbound variable: %S" + : "Damaged environment: %S", + scm_listify (var, SCM_UNDEFINED)); + else + return SCM_CDRLOC (&undef_cell); } #endif +#ifdef USE_THREADS + if (SCM_CAR (vloc) != var2) + { + /* Some other thread has changed the very cell we are working + on. In effect, it must have done our job or messed it up + completely. */ + race: + var = SCM_CAR (vloc); + if ((var & 7) == 1) + return SCM_GLOC_VAL_LOC (var); +#ifdef MEMOIZE_LOCALS + if ((var & 127) == (127 & SCM_ILOC00)) + return scm_ilookup (var, genv); +#endif + /* We can't cope with anything else than glocs and ilocs. When + a special form has been memoized (i.e. `let' into `#@let') we + return NULL and expect the calling function to do the right + thing. For the evaluator, this means going back and redoing + the dispatch on the car of the form. */ + return NULL; + } +#endif /* USE_THREADS */ + SCM_SETCAR (vloc, var + 1); /* Except wait...what if the var is not a vcell, - * but syntax or something.... - */ + * but syntax or something.... */ return SCM_CDRLOC (var); } +#ifdef USE_THREADS +SCM * +scm_lookupcar (vloc, genv, check) + SCM vloc; + SCM genv; + int check; +{ + SCM *loc = scm_lookupcar1 (vloc, genv, check); + if (loc == NULL) + abort (); + return loc; +} +#endif + #define unmemocar scm_unmemocar SCM @@ -307,7 +435,7 @@ scm_eval_car (pair, env) SCM pair; SCM env; { - return XEVALCAR (pair, env); + return SCM_XEVALCAR (pair, env); } @@ -316,66 +444,108 @@ scm_eval_car (pair, env) * 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_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"; +const char scm_s_expression[] = "missing or extra expression"; +const char scm_s_test[] = "bad test"; +const char scm_s_body[] = "bad body"; +const char scm_s_bindings[] = "bad bindings"; +const char scm_s_variable[] = "bad variable"; +const char scm_s_clauses[] = "bad or missing clauses"; +const char scm_s_formals[] = "bad formals"; + +SCM scm_sym_dot, scm_sym_arrow, scm_sym_else; +SCM scm_sym_unquote, scm_sym_uq_splicing, scm_sym_apply; + +SCM scm_f_apply; + #ifdef DEBUG_EXTENSIONS -SCM scm_i_enter_frame, scm_i_apply_frame, scm_i_exit_frame; -SCM scm_i_trace; +SCM scm_sym_enter_frame, scm_sym_apply_frame, scm_sym_exit_frame; +SCM scm_sym_trace; #endif #define ASRTSYNTAX(cond_, msg_) if(!(cond_))scm_wta(xorig, (msg_), what); -static void bodycheck SCM_P ((SCM xorig, SCM *bodyloc, char *what)); +static void bodycheck SCM_P ((SCM xorig, SCM *bodyloc, const char *what)); static void bodycheck (xorig, bodyloc, what) SCM xorig; SCM *bodyloc; - char *what; + const char *what; { - ASRTSYNTAX (scm_ilength (*bodyloc) >= 1, s_expression); + ASRTSYNTAX (scm_ilength (*bodyloc) >= 1, scm_s_expression); } +/* Check that the body denoted by XORIG is valid and rewrite it into + its internal form. The internal form of a body is just the body + itself, but prefixed with an ISYM that denotes to what kind of + outer construct this body belongs. A lambda body starts with + SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET, + etc. The one exception is a body that belongs to a letrec that has + been formed by rewriting internal defines: it starts with + SCM_IM_DEFINE. */ + +/* XXX - Besides controlling the rewriting of internal defines, the + additional ISYM could be used for improved error messages. + This is not done yet. */ +static SCM +scm_m_body (op, xorig, what) + SCM op; + SCM xorig; + char *what; +{ + ASRTSYNTAX (scm_ilength (xorig) >= 1, scm_s_expression); + + /* Don't add another ISYM if one is present already. */ + if (SCM_ISYMP (SCM_CAR (xorig))) + return xorig; + + /* Retain possible doc string. */ + if (SCM_IMP (SCM_CAR(xorig)) || SCM_NCONSP (SCM_CAR (xorig))) + { + if (SCM_NNULLP (SCM_CDR(xorig))) + return scm_cons (SCM_CAR (xorig), + scm_m_body (op, SCM_CDR(xorig), what)); + return xorig; + } + + return scm_cons2 (op, SCM_CAR (xorig), SCM_CDR(xorig)); +} + +SCM_SYNTAX(s_quote,"quote", scm_makmmacro, scm_m_quote); +SCM_GLOBAL_SYMBOL(scm_sym_quote, s_quote); SCM scm_m_quote (xorig, env) SCM xorig; SCM env; { - ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, xorig, s_expression, "quote"); - return scm_cons (SCM_IM_QUOTE, SCM_CDR (xorig)); + SCM x = scm_copy_tree (SCM_CDR (xorig)); + + SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, + xorig, scm_s_expression, s_quote); + return scm_cons (SCM_IM_QUOTE, x); } +SCM_SYNTAX(s_begin, "begin", scm_makmmacro, scm_m_begin); +SCM_GLOBAL_SYMBOL(scm_sym_begin, s_begin); + SCM scm_m_begin (xorig, env) SCM xorig; SCM env; { - ASSYNT (scm_ilength (SCM_CDR (xorig)) >= 1, xorig, s_expression, "begin"); + SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) >= 1, + xorig, scm_s_expression, s_begin); return scm_cons (SCM_IM_BEGIN, SCM_CDR (xorig)); } - +SCM_SYNTAX(s_if, "if", scm_makmmacro, scm_m_if); +SCM_GLOBAL_SYMBOL(scm_sym_if, s_if); SCM scm_m_if (xorig, env) @@ -383,22 +553,26 @@ scm_m_if (xorig, env) SCM env; { int len = scm_ilength (SCM_CDR (xorig)); - ASSYNT (len >= 2 && len <= 3, xorig, s_expression, "if"); + SCM_ASSYNT (len >= 2 && len <= 3, xorig, scm_s_expression, "if"); return scm_cons (SCM_IM_IF, SCM_CDR (xorig)); } +/* Will go into the RnRS module when Guile is factorized. +SCM_SYNTAX(scm_s_set_x,"set!", scm_makmmacro, scm_m_set_x); */ +const char scm_s_set_x[] = "set!"; +SCM_GLOBAL_SYMBOL(scm_sym_set_x, scm_s_set_x); SCM -scm_m_set (xorig, env) +scm_m_set_x (xorig, env) SCM xorig; SCM env; { 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); + SCM_ASSYNT (2 == scm_ilength (x), xorig, scm_s_expression, scm_s_set_x); + SCM_ASSYNT (SCM_NIMP (SCM_CAR (x)) && SCM_SYMBOLP (SCM_CAR (x)), + xorig, scm_s_variable, scm_s_set_x); + return scm_cons (SCM_IM_SET_X, x); } @@ -410,7 +584,7 @@ scm_m_vref (xorig, env) SCM env; { SCM x = SCM_CDR (xorig); - ASSYNT (1 == scm_ilength (x), xorig, s_expression, s_vref); + SCM_ASSYNT (1 == scm_ilength (x), xorig, scm_s_expression, s_vref); if (SCM_NIMP(x) && UDSCM_VARIABLEP (SCM_CAR (x))) { /* scm_everr (SCM_UNDEFINED, env,..., "global variable reference") */ @@ -418,9 +592,8 @@ scm_m_vref (xorig, env) "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); - return + SCM_ASSYNT (SCM_NIMP(x) && DEFSCM_VARIABLEP (SCM_CAR (x)), + xorig, scm_s_variable, s_vref); return scm_cons (IM_VREF, x); } @@ -432,15 +605,17 @@ scm_m_vset (xorig, env) SCM env; { 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); + SCM_ASSYNT (3 == scm_ilength (x), xorig, scm_s_expression, s_vset); + SCM_ASSYNT ((DEFSCM_VARIABLEP (SCM_CAR (x)) + || UDSCM_VARIABLEP (SCM_CAR (x))), + xorig, scm_s_variable, s_vset); return scm_cons (IM_VSET, x); } #endif +SCM_SYNTAX(s_and, "and", scm_makmmacro, scm_m_and); +SCM_GLOBAL_SYMBOL(scm_sym_and, s_and); SCM scm_m_and (xorig, env) @@ -448,14 +623,15 @@ scm_m_and (xorig, env) SCM env; { int len = scm_ilength (SCM_CDR (xorig)); - ASSYNT (len >= 0, xorig, s_test, "and"); + SCM_ASSYNT (len >= 0, xorig, scm_s_test, s_and); if (len >= 1) return scm_cons (SCM_IM_AND, SCM_CDR (xorig)); else return SCM_BOOL_T; } - +SCM_SYNTAX(s_or,"or", scm_makmmacro, scm_m_or); +SCM_GLOBAL_SYMBOL(scm_sym_or,s_or); SCM scm_m_or (xorig, env) @@ -463,7 +639,7 @@ scm_m_or (xorig, env) SCM env; { int len = scm_ilength (SCM_CDR (xorig)); - ASSYNT (len >= 0, xorig, s_test, "or"); + SCM_ASSYNT (len >= 0, xorig, scm_s_test, s_or); if (len >= 1) return scm_cons (SCM_IM_OR, SCM_CDR (xorig)); else @@ -471,53 +647,61 @@ scm_m_or (xorig, env) } +SCM_SYNTAX(s_case, "case", scm_makmmacro, scm_m_case); +SCM_GLOBAL_SYMBOL(scm_sym_case, s_case); SCM scm_m_case (xorig, env) SCM xorig; SCM env; { - SCM proc, x = SCM_CDR (xorig); - ASSYNT (scm_ilength (x) >= 2, xorig, s_clauses, "case"); + SCM proc, cdrx = scm_list_copy (SCM_CDR (xorig)), x = cdrx; + SCM_ASSYNT (scm_ilength (x) >= 2, xorig, scm_s_clauses, s_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"); + SCM_ASSYNT (scm_ilength (proc) >= 2, xorig, scm_s_clauses, s_case); + SCM_ASSYNT (scm_ilength (SCM_CAR (proc)) >= 0 + || scm_sym_else == SCM_CAR (proc), + xorig, scm_s_clauses, s_case); } - return scm_cons (SCM_IM_CASE, SCM_CDR (xorig)); + return scm_cons (SCM_IM_CASE, cdrx); } +SCM_SYNTAX(s_cond, "cond", scm_makmmacro, scm_m_cond); +SCM_GLOBAL_SYMBOL(scm_sym_cond, s_cond); + SCM scm_m_cond (xorig, env) SCM xorig; SCM env; { - SCM arg1, x = SCM_CDR (xorig); + SCM arg1, cdrx = scm_list_copy (SCM_CDR (xorig)), x = cdrx; int len = scm_ilength (x); - ASSYNT (len >= 1, xorig, s_clauses, "cond"); + SCM_ASSYNT (len >= 1, xorig, scm_s_clauses, s_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)) + SCM_ASSYNT (len >= 1, xorig, scm_s_clauses, s_cond); + if (scm_sym_else == SCM_CAR (arg1)) { - ASSYNT (SCM_NULLP (SCM_CDR (x)) && len >= 2, xorig, "bad ELSE clause", "cond"); + SCM_ASSYNT (SCM_NULLP (SCM_CDR (x)) && len >= 2, + xorig, "bad ELSE clause", s_cond); 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)))), - xorig, "bad recipient", "cond"); + if (len >= 2 && scm_sym_arrow == SCM_CAR (SCM_CDR (arg1))) + SCM_ASSYNT (3 == len && SCM_NIMP (SCM_CAR (SCM_CDR (SCM_CDR (arg1)))), + xorig, "bad recipient", s_cond); x = SCM_CDR (x); } - return scm_cons (SCM_IM_COND, SCM_CDR (xorig)); + return scm_cons (SCM_IM_COND, cdrx); } - +SCM_SYNTAX(s_lambda, "lambda", scm_makmmacro, scm_m_lambda); +SCM_GLOBAL_SYMBOL(scm_sym_lambda, s_lambda); SCM scm_m_lambda (xorig, env) @@ -528,35 +712,42 @@ scm_m_lambda (xorig, env) 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_NULLP (proc)) + goto memlambda; + if (SCM_IM_LET == proc) /* named let */ + 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_NCONSP (proc)) + { if (!SCM_SYMBOLP (proc)) - goto badforms; - else - goto memlambda; + 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_CDRLOC (x), "lambda"); - return scm_cons (SCM_IM_LAMBDA, SCM_CDR (xorig)); + if (SCM_NNULLP (proc)) + { + badforms: + scm_wta (xorig, scm_s_formals, s_lambda); + } + + memlambda: + return scm_cons2 (SCM_IM_LAMBDA, SCM_CAR (x), + scm_m_body (SCM_IM_LAMBDA, SCM_CDR (x), s_lambda)); } +SCM_SYNTAX(s_letstar,"let*", scm_makmmacro, scm_m_letstar); +SCM_GLOBAL_SYMBOL(scm_sym_letstar,s_letstar); SCM @@ -566,21 +757,23 @@ scm_m_letstar (xorig, env) { SCM x = SCM_CDR (xorig), arg1, proc, vars = SCM_EOL, *varloc = &vars; int len = scm_ilength (x); - ASSYNT (len >= 2, xorig, s_body, "let*"); + SCM_ASSYNT (len >= 2, xorig, scm_s_body, s_letstar); proc = SCM_CAR (x); - ASSYNT (scm_ilength (proc) >= 0, xorig, s_bindings, "let*"); - while SCM_NIMP (proc) + SCM_ASSYNT (scm_ilength (proc) >= 0, xorig, scm_s_bindings, s_letstar); + 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*"); + SCM_ASSYNT (2 == scm_ilength (arg1), xorig, scm_s_bindings, s_letstar); + SCM_ASSYNT (SCM_NIMP (SCM_CAR (arg1)) && SCM_SYMBOLP (SCM_CAR (arg1)), + xorig, scm_s_variable, s_letstar); *varloc = scm_cons2 (SCM_CAR (arg1), SCM_CAR (SCM_CDR (arg1)), SCM_EOL); varloc = SCM_CDRLOC (SCM_CDR (*varloc)); proc = SCM_CDR (proc); } x = scm_cons (vars, SCM_CDR (x)); - bodycheck (xorig, SCM_CDRLOC (x), "let*"); - return scm_cons (SCM_IM_LETSTAR, x); + + return scm_cons2 (SCM_IM_LETSTAR, SCM_CAR (x), + scm_m_body (SCM_IM_LETSTAR, SCM_CDR (x), s_letstar)); } /* DO gets the most radically altered syntax @@ -597,7 +790,8 @@ scm_m_letstar (xorig, env) ... ) ;; missing steps replaced by var */ - +SCM_SYNTAX(s_do, "do", scm_makmmacro, scm_m_do); +SCM_GLOBAL_SYMBOL(scm_sym_do, s_do); SCM scm_m_do (xorig, env) @@ -608,16 +802,16 @@ scm_m_do (xorig, env) 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"); + SCM_ASSYNT (len >= 2, xorig, scm_s_test, "do"); proc = SCM_CAR (x); - ASSYNT (scm_ilength (proc) >= 0, xorig, s_bindings, "do"); - while SCM_NIMP - (proc) + SCM_ASSYNT (scm_ilength (proc) >= 0, xorig, scm_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"); + SCM_ASSYNT (2 == len || 3 == len, xorig, scm_s_bindings, "do"); + SCM_ASSYNT (SCM_NIMP (SCM_CAR (arg1)) && SCM_SYMBOLP (SCM_CAR (arg1)), + xorig, scm_s_variable, "do"); /* vars reversed here, inits and steps reversed at evaluation */ vars = scm_cons (SCM_CAR (arg1), vars); /* variable */ arg1 = SCM_CDR (arg1); @@ -629,7 +823,7 @@ scm_m_do (xorig, env) proc = SCM_CDR (proc); } x = SCM_CDR (x); - ASSYNT (scm_ilength (SCM_CAR (x)) >= 1, xorig, s_test, "do"); + SCM_ASSYNT (scm_ilength (SCM_CAR (x)) >= 1, xorig, scm_s_test, "do"); x = scm_cons2 (SCM_CAR (x), SCM_CDR (x), steps); x = scm_cons2 (vars, inits, x); bodycheck (xorig, SCM_CARLOC (SCM_CDR (SCM_CDR (x))), "do"); @@ -642,18 +836,29 @@ scm_m_do (xorig, env) #define evalcar scm_eval_car -static SCM iqq SCM_P ((SCM form, SCM env, int depth)); +static SCM iqq (SCM form, SCM env, int depth); -static SCM -iqq (form, env, depth) - SCM form; +SCM_SYNTAX(s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote); +SCM_GLOBAL_SYMBOL(scm_sym_quasiquote, s_quasiquote); + +SCM +scm_m_quasiquote (xorig, env) + SCM xorig; SCM env; - int depth; +{ + SCM x = SCM_CDR (xorig); + SCM_ASSYNT (scm_ilength (x) == 1, xorig, scm_s_expression, s_quasiquote); + return iqq (SCM_CAR (x), env, 1); +} + + +static SCM +iqq (SCM form,SCM env,int depth) { SCM tmp; int edepth = depth; - if SCM_IMP - (form) return form; + if (SCM_IMP(form)) + return form; if (SCM_VECTORP (form)) { long i = SCM_LENGTH (form); @@ -663,27 +868,26 @@ iqq (form, env, depth) tmp = scm_cons (data[i], tmp); return scm_vector (iqq (tmp, env, depth)); } - if SCM_NCONSP - (form) return form; + if (SCM_NCONSP(form)) + return form; tmp = SCM_CAR (form); - if (scm_i_quasiquote == tmp) + if (scm_sym_quasiquote == tmp) { depth++; goto label; } - if (scm_i_unquote == tmp) + if (scm_sym_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))) + if (SCM_NIMP (tmp) && (scm_sym_uq_splicing == SCM_CAR (tmp))) { tmp = SCM_CDR (tmp); if (0 == --edepth) @@ -694,45 +898,21 @@ iqq (form, env, depth) /* Here are acros which return values rather than code. */ - -SCM -scm_m_quasiquote (xorig, env) - SCM xorig; - SCM env; -{ - SCM x = SCM_CDR (xorig); - ASSYNT (scm_ilength (x) == 1, xorig, s_expression, s_quasiquote); - return iqq (SCM_CAR (x), env, 1); -} - +SCM_SYNTAX (s_delay, "delay", scm_makmmacro, scm_m_delay); +SCM_GLOBAL_SYMBOL (scm_sym_delay, s_delay); SCM scm_m_delay (xorig, env) SCM xorig; SCM env; { - 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)); + SCM_ASSYNT (scm_ilength (xorig) == 2, xorig, scm_s_expression, s_delay); + return scm_cons2 (SCM_IM_DELAY, SCM_EOL, SCM_CDR (xorig)); } -static SCM env_top_level SCM_P ((SCM env)); - -static SCM -env_top_level (env) - SCM env; -{ - 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; -} - +SCM_SYNTAX(s_define, "define", scm_makmmacro, scm_m_define); +SCM_GLOBAL_SYMBOL(scm_sym_define, s_define); SCM scm_m_define (x, env) @@ -741,27 +921,41 @@ scm_m_define (x, env) { 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"); + /* SCM_ASSYNT(SCM_NULLP(env), x, "bad placement", s_define);*/ + SCM_ASSYNT (scm_ilength (x) >= 2, arg1, scm_s_expression, s_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); + x = scm_cons (scm_cons2 (scm_sym_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"); + SCM_ASSYNT (SCM_NIMP (proc) && SCM_SYMBOLP (proc), + arg1, scm_s_variable, s_define); + SCM_ASSYNT (1 == scm_ilength (x), arg1, scm_s_expression, s_define); if (SCM_TOP_LEVEL (env)) { x = evalcar (x, env); #ifdef DEBUG_EXTENSIONS - if (SCM_REC_PROCNAMES_P) - scm_set_procedure_property_x (x, scm_i_name, proc); + if (SCM_REC_PROCNAMES_P && SCM_NIMP (x)) + { + arg1 = x; + proc: + if (SCM_CLOSUREP (arg1) + /* Only the first definition determines the name. */ + && scm_procedure_property (arg1, scm_sym_name) == SCM_BOOL_F) + scm_set_procedure_property_x (arg1, scm_sym_name, proc); + else if (SCM_TYP16 (arg1) == scm_tc16_macro + && SCM_CDR (arg1) != arg1) + { + arg1 = SCM_CDR (arg1); + goto proc; + } + } #endif - arg1 = scm_sym2vcell (proc, env_top_level (env), SCM_BOOL_T); + arg1 = scm_sym2vcell (proc, scm_env_top_level (env), SCM_BOOL_T); #if 0 -#ifndef RECKLESS +#ifndef SCM_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)); @@ -772,7 +966,7 @@ scm_m_define (x, env) #endif SCM_SETCDR (arg1, x); #ifdef SICP - return scm_cons2 (scm_i_quote, SCM_CAR (arg1), SCM_EOL); + return scm_cons2 (scm_sym_quote, SCM_CAR (arg1), SCM_EOL); #else return SCM_UNSPECIFIED; #endif @@ -780,42 +974,12 @@ scm_m_define (x, env) return scm_cons2 (SCM_IM_DEFINE, proc, x); } -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) +static SCM +scm_m_letrec1 (op, imm, xorig, env) + SCM op; + SCM imm; SCM xorig; SCM env; { @@ -824,28 +988,48 @@ scm_m_letrec (xorig, env) 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); + ASRTSYNTAX (scm_ilength (proc) >= 1, scm_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); + ASRTSYNTAX (2 == scm_ilength (arg1), scm_s_bindings); + ASRTSYNTAX (SCM_NIMP (SCM_CAR (arg1)) && SCM_SYMBOLP (SCM_CAR (arg1)), + scm_s_variable); vars = scm_cons (SCM_CAR (arg1), vars); *initloc = scm_cons (SCM_CAR (SCM_CDR (arg1)), SCM_EOL); initloc = SCM_CDRLOC (*initloc); } - while SCM_NIMP - (proc = SCM_CDR (proc)); - cdrx = scm_cons2 (vars, inits, SCM_CDR (x)); - bodycheck (xorig, SCM_CDRLOC (SCM_CDR (cdrx)), what); - return scm_cons (SCM_IM_LETREC, cdrx); + while (SCM_NIMP (proc = SCM_CDR (proc))); + + return scm_cons2 (op, vars, + scm_cons (inits, scm_m_body (imm, SCM_CDR (x), what))); +} + +SCM_SYNTAX(s_letrec, "letrec", scm_makmmacro, scm_m_letrec); +SCM_GLOBAL_SYMBOL(scm_sym_letrec, s_letrec); + +SCM +scm_m_letrec (xorig, env) + SCM xorig; + SCM env; +{ + SCM x = SCM_CDR (xorig); + SCM_ASSYNT (scm_ilength (x) >= 2, xorig, scm_s_body, s_letrec); + + if (SCM_NULLP (SCM_CAR (x))) /* null binding, let* faster */ + return scm_m_letstar (scm_cons2 (SCM_CAR (xorig), SCM_EOL, + scm_m_body (SCM_IM_LETREC, + SCM_CDR (x), + s_letrec)), + env); + else + return scm_m_letrec1 (SCM_IM_LETREC, SCM_IM_LETREC, xorig, env); } +SCM_SYNTAX(s_let, "let", scm_makmmacro, scm_m_let); +SCM_GLOBAL_SYMBOL(scm_sym_let, s_let); SCM scm_m_let (xorig, env) @@ -856,53 +1040,74 @@ scm_m_let (xorig, env) 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"); + SCM_ASSYNT (scm_ilength (x) >= 2, xorig, scm_s_body, s_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 */ - return scm_cons (SCM_IM_LET, SCM_CDR (scm_m_letrec (xorig, env))); + && SCM_NIMP (SCM_CAR (proc)) + && SCM_CONSP (SCM_CAR (proc)) && SCM_NULLP (SCM_CDR (proc)))) + { + /* null or single binding, let* is faster */ + return scm_m_letstar (scm_cons2 (SCM_CAR (xorig), proc, + scm_m_body (SCM_IM_LET, + SCM_CDR (x), + s_let)), + env); + } + + SCM_ASSYNT (SCM_NIMP (proc), xorig, scm_s_bindings, s_let); + if (SCM_CONSP (proc)) + { + /* plain let, proc is */ + return scm_m_letrec1 (SCM_IM_LET, SCM_IM_LET, xorig, env); + } + if (!SCM_SYMBOLP (proc)) - scm_wta (xorig, s_bindings, "let"); /* bad let */ + scm_wta (xorig, scm_s_bindings, s_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) + SCM_ASSYNT (scm_ilength (x) >= 2, xorig, scm_s_body, s_let); + proc = SCM_CAR (x); /* bindings list */ + SCM_ASSYNT (scm_ilength (proc) >= 0, xorig, scm_s_bindings, s_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"); + SCM_ASSYNT (2 == scm_ilength (arg1), xorig, scm_s_bindings, s_let); + SCM_ASSYNT (SCM_NIMP (SCM_CAR (arg1)) && SCM_SYMBOLP (SCM_CAR (arg1)), + xorig, scm_s_variable, s_let); *varloc = scm_cons (SCM_CAR (arg1), SCM_EOL); varloc = SCM_CDRLOC (*varloc); *initloc = scm_cons (SCM_CAR (SCM_CDR (arg1)), SCM_EOL); initloc = SCM_CDRLOC (*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); + + proc = scm_cons2 (scm_sym_lambda, vars, + scm_m_body (SCM_IM_LET, SCM_CDR (x), "let")); + proc = scm_cons2 (scm_sym_let, scm_cons (scm_cons2 (name, proc, SCM_EOL), + SCM_EOL), + scm_acons (name, inits, SCM_EOL)); + return scm_m_letrec1 (SCM_IM_LETREC, SCM_IM_LET, proc, env); } +SCM_SYNTAX (s_atapply,"@apply", scm_makmmacro, scm_m_apply); +SCM_GLOBAL_SYMBOL (scm_sym_atapply, s_atapply); +SCM_GLOBAL_SYMBOL (scm_sym_apply, s_atapply + 1); SCM scm_m_apply (xorig, env) SCM xorig; SCM env; { - ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2, xorig, s_expression, "@apply"); + SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2, + xorig, scm_s_expression, s_atapply); return scm_cons (SCM_IM_APPLY, SCM_CDR (xorig)); } -#define s_atcall_cc (SCM_ISYMCHARS(SCM_IM_CONT)+1) + +SCM_SYNTAX(s_atcall_cc,"@call-with-current-continuation", scm_makmmacro, scm_m_cont); +SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc,s_atcall_cc); SCM @@ -910,25 +1115,245 @@ scm_m_cont (xorig, env) SCM xorig; SCM env; { - ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, xorig, s_expression, "@call-with-current-continuation"); + SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, + xorig, scm_s_expression, s_atcall_cc); return scm_cons (SCM_IM_CONT, SCM_CDR (xorig)); } +/* Multi-language support */ + +SCM scm_nil; +SCM scm_t; + +SCM_SYNTAX (s_nil_cond, "nil-cond", scm_makmmacro, scm_m_nil_cond); + +SCM +scm_m_nil_cond (SCM xorig, SCM env) +{ + int len = scm_ilength (SCM_CDR (xorig)); + SCM_ASSYNT (len >= 1 && (len & 1) == 1, xorig, + scm_s_expression, "nil-cond"); + return scm_cons (SCM_IM_NIL_COND, SCM_CDR (xorig)); +} + +SCM_SYNTAX (s_nil_ify, "nil-ify", scm_makmmacro, scm_m_nil_ify); + +SCM +scm_m_nil_ify (SCM xorig, SCM env) +{ + SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, + xorig, scm_s_expression, "nil-ify"); + return scm_cons (SCM_IM_NIL_IFY, SCM_CDR (xorig)); +} + +SCM_SYNTAX (s_t_ify, "t-ify", scm_makmmacro, scm_m_t_ify); + +SCM +scm_m_t_ify (SCM xorig, SCM env) +{ + SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, + xorig, scm_s_expression, "t-ify"); + return scm_cons (SCM_IM_T_IFY, SCM_CDR (xorig)); +} + +SCM_SYNTAX (s_0_cond, "0-cond", scm_makmmacro, scm_m_0_cond); + +SCM +scm_m_0_cond (SCM xorig, SCM env) +{ + int len = scm_ilength (SCM_CDR (xorig)); + SCM_ASSYNT (len >= 1 && (len & 1) == 1, xorig, + scm_s_expression, "0-cond"); + return scm_cons (SCM_IM_0_COND, SCM_CDR (xorig)); +} + +SCM_SYNTAX (s_0_ify, "0-ify", scm_makmmacro, scm_m_0_ify); + +SCM +scm_m_0_ify (SCM xorig, SCM env) +{ + SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, + xorig, scm_s_expression, "0-ify"); + return scm_cons (SCM_IM_0_IFY, SCM_CDR (xorig)); +} + +SCM_SYNTAX (s_1_ify, "1-ify", scm_makmmacro, scm_m_1_ify); + +SCM +scm_m_1_ify (SCM xorig, SCM env) +{ + SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, + xorig, scm_s_expression, "1-ify"); + return scm_cons (SCM_IM_1_IFY, SCM_CDR (xorig)); +} + +SCM_SYNTAX (s_atfop, "@fop", scm_makmmacro, scm_m_atfop); + +SCM +scm_m_atfop (SCM xorig, SCM env) +{ + SCM x = SCM_CDR (xorig), vcell; + SCM_ASSYNT (scm_ilength (x) >= 1, xorig, scm_s_expression, "@fop"); + vcell = scm_symbol_fref (SCM_CAR (x)); + SCM_ASSYNT (SCM_NIMP (vcell) && SCM_CONSP (vcell), x, + "Symbol's function definition is void", NULL); + SCM_SETCAR (x, vcell + 1); + return x; +} + +SCM_SYNTAX (s_atbind, "@bind", scm_makmmacro, scm_m_atbind); + +SCM +scm_m_atbind (SCM xorig, SCM env) +{ + SCM x = SCM_CDR (xorig); + SCM_ASSYNT (scm_ilength (x) > 1, xorig, scm_s_expression, "@bind"); + + if (SCM_IMP (env)) + env = SCM_BOOL_F; + else + { + while (SCM_NIMP (SCM_CDR (env))) + env = SCM_CDR (env); + env = SCM_CAR (env); + if (SCM_CONSP (env)) + env = SCM_BOOL_F; + } + + x = SCM_CAR (x); + while (SCM_NIMP (x)) + { + SCM_SETCAR (x, scm_sym2vcell (SCM_CAR (x), env, SCM_BOOL_T) + 1); + x = SCM_CDR (x); + } + return scm_cons (SCM_IM_BIND, SCM_CDR (xorig)); +} + +SCM +scm_m_expand_body (SCM xorig, SCM env) +{ + SCM form, x = SCM_CDR (xorig), defs = SCM_EOL; + char *what = SCM_ISYMCHARS (SCM_CAR (xorig)) + 2; + + while (SCM_NIMP (x)) + { + form = SCM_CAR (x); + if (SCM_IMP (form) || SCM_NCONSP (form)) + break; + if (SCM_IMP (SCM_CAR (form))) + break; + if (!SCM_SYMBOLP (SCM_CAR (form))) + break; + + form = scm_macroexp (scm_cons_source (form, + SCM_CAR (form), + SCM_CDR (form)), + env); + + if (SCM_IM_DEFINE == SCM_CAR (form)) + { + defs = scm_cons (SCM_CDR (form), defs); + x = SCM_CDR(x); + } + else if (SCM_NIMP(defs)) + { + break; + } + else if (SCM_IM_BEGIN == SCM_CAR (form)) + { + x = scm_append (scm_cons2 (SCM_CDR (form), SCM_CDR (x), SCM_EOL)); + } + else + { + x = scm_cons (form, SCM_CDR(x)); + break; + } + } + + SCM_ASSYNT (SCM_NIMP (x), SCM_CDR (xorig), scm_s_body, what); + if (SCM_NIMP (defs)) + { + x = scm_cons (scm_m_letrec1 (SCM_IM_LETREC, + SCM_IM_DEFINE, + scm_cons2 (scm_sym_define, defs, x), + env), + SCM_EOL); + } + + SCM_DEFER_INTS; + SCM_SETCAR (xorig, SCM_CAR (x)); + SCM_SETCDR (xorig, SCM_CDR (x)); + SCM_ALLOW_INTS; + + return xorig; +} + +SCM +scm_macroexp (SCM x, SCM env) +{ + SCM res, proc; + + /* Don't bother to produce error messages here. We get them when we + eventually execute the code for real. */ + + macro_tail: + if (SCM_IMP (SCM_CAR (x)) || !SCM_SYMBOLP (SCM_CAR (x))) + return x; + +#ifdef USE_THREADS + { + SCM *proc_ptr = scm_lookupcar1 (x, env, 0); + if (proc_ptr == NULL) + { + /* We have lost the race. */ + goto macro_tail; + } + proc = *proc_ptr; + } +#else + proc = *scm_lookupcar (x, env, 0); +#endif + + /* Only handle memoizing macros. `Acros' and `macros' are really + special forms and should not be evaluated here. */ + + if (SCM_IMP (proc) + || scm_tc16_macro != SCM_TYP16 (proc) + || (int) (SCM_CAR (proc) >> 16) != 2) + return x; + + unmemocar (x, env); + res = scm_apply (SCM_CDR (proc), x, scm_cons (env, scm_listofnull)); + + if (scm_ilength (res) <= 0) + res = scm_cons2 (SCM_IM_BEGIN, res, SCM_EOL); + + SCM_DEFER_INTS; + SCM_SETCAR (x, SCM_CAR (res)); + SCM_SETCDR (x, SCM_CDR (res)); + SCM_ALLOW_INTS; + + goto macro_tail; +} + /* 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 and in scm_expr_stack - * when generating the source for a stackframe. + * 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)); +/* We should introduce an anti-macro interface so that it is possible + * to plug in transformers in both directions from other compilation + * units. unmemocopy could then dispatch to anti-macro transformers. + * (Those transformers could perhaps be written in slightly more + * readable style... :) + */ static SCM -unmemocopy (x, env) - SCM x; - SCM env; +unmemocopy (SCM x, SCM env) { SCM ls, z; #ifdef DEBUG_EXTENSIONS @@ -942,41 +1367,45 @@ unmemocopy (x, env) switch (SCM_TYP7 (x)) { case (127 & SCM_IM_AND): - ls = z = scm_cons (scm_i_and, SCM_UNSPECIFIED); + ls = z = scm_cons (scm_sym_and, SCM_UNSPECIFIED); break; case (127 & SCM_IM_BEGIN): - ls = z = scm_cons (scm_i_begin, SCM_UNSPECIFIED); + ls = z = scm_cons (scm_sym_begin, SCM_UNSPECIFIED); break; case (127 & SCM_IM_CASE): - ls = z = scm_cons (scm_i_case, SCM_UNSPECIFIED); + ls = z = scm_cons (scm_sym_case, SCM_UNSPECIFIED); break; case (127 & SCM_IM_COND): - ls = z = scm_cons (scm_i_cond, SCM_UNSPECIFIED); + ls = z = scm_cons (scm_sym_cond, SCM_UNSPECIFIED); break; case (127 & SCM_IM_DO): - ls = scm_cons (scm_i_do, SCM_UNSPECIFIED); + ls = scm_cons (scm_sym_do, SCM_UNSPECIFIED); goto transform; case (127 & SCM_IM_IF): - ls = z = scm_cons (scm_i_if, SCM_UNSPECIFIED); + ls = z = scm_cons (scm_sym_if, SCM_UNSPECIFIED); break; case (127 & SCM_IM_LET): - ls = scm_cons (scm_i_let, SCM_UNSPECIFIED); + ls = scm_cons (scm_sym_let, SCM_UNSPECIFIED); goto transform; case (127 & SCM_IM_LETREC): { SCM f, v, e, s; - ls = scm_cons (scm_i_letrec, SCM_UNSPECIFIED); + ls = scm_cons (scm_sym_letrec, SCM_UNSPECIFIED); transform: x = SCM_CDR (x); + /* binding names */ f = v = SCM_CAR (x); x = SCM_CDR (x); z = EXTEND_ENV (f, SCM_EOL, env); + /* inits */ e = scm_reverse (unmemocopy (SCM_CAR (x), - SCM_CAR (ls) == scm_i_letrec ? z : env)); + SCM_CAR (ls) == scm_sym_letrec ? z : env)); env = z; - s = SCM_CAR (ls) == scm_i_do + /* increments */ + s = SCM_CAR (ls) == scm_sym_do ? scm_reverse (unmemocopy (SCM_CDR (SCM_CDR (SCM_CDR (x))), env)) : f; + /* build transformed binding list */ z = SCM_EOL; do { @@ -990,16 +1419,19 @@ unmemocopy (x, env) e = SCM_CDR (e); s = SCM_CDR (s); } - while SCM_NIMP (v); + while (SCM_NIMP (v)); z = scm_cons (z, SCM_UNSPECIFIED); SCM_SETCDR (ls, z); - if (SCM_CAR (ls) == scm_i_do) + if (SCM_CAR (ls) == scm_sym_do) { x = SCM_CDR (x); + /* test clause */ SCM_SETCDR (z, scm_cons (unmemocopy (SCM_CAR (x), env), SCM_UNSPECIFIED)); z = SCM_CDR (z); x = (SCM) (SCM_CARLOC (SCM_CDR (x)) - 1); + /* body forms are now to be found in SCM_CDR (x) + (this is how *real* code look like! :) */ } break; } @@ -1023,7 +1455,7 @@ unmemocopy (x, env) if (SCM_IMP (b)) { SCM_SETCDR (y, SCM_EOL); - ls = scm_cons (scm_i_let, z = scm_cons (y, SCM_UNSPECIFIED)); + ls = scm_cons (scm_sym_let, z = scm_cons (y, SCM_UNSPECIFIED)); break; } do @@ -1036,32 +1468,32 @@ unmemocopy (x, env) env = EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env); b = SCM_CDR (SCM_CDR (b)); } - while SCM_NIMP (b); + while (SCM_NIMP (b)); SCM_SETCDR (z, SCM_EOL); letstar: - ls = scm_cons (scm_i_letstar, z = scm_cons (y, SCM_UNSPECIFIED)); + ls = scm_cons (scm_sym_letstar, z = scm_cons (y, SCM_UNSPECIFIED)); break; } case (127 & SCM_IM_OR): - ls = z = scm_cons (scm_i_or, SCM_UNSPECIFIED); + ls = z = scm_cons (scm_sym_or, SCM_UNSPECIFIED); break; case (127 & SCM_IM_LAMBDA): x = SCM_CDR (x); - ls = scm_cons (scm_i_lambda, + ls = scm_cons (scm_sym_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); + ls = z = scm_cons (scm_sym_quote, SCM_UNSPECIFIED); break; - case (127 & SCM_IM_SET): - ls = z = scm_cons (scm_i_set, SCM_UNSPECIFIED); + case (127 & SCM_IM_SET_X): + ls = z = scm_cons (scm_sym_set_x, SCM_UNSPECIFIED); break; case (127 & SCM_IM_DEFINE): { SCM n; x = SCM_CDR (x); - ls = scm_cons (scm_i_define, + ls = scm_cons (scm_sym_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)))); @@ -1071,13 +1503,17 @@ unmemocopy (x, env) z = SCM_CAR (x); if (!SCM_ISYMP (z)) goto unmemo; - switch SCM_ISYMNUM (z) + switch (SCM_ISYMNUM (z)) { case (SCM_ISYMNUM (SCM_IM_APPLY)): - ls = z = scm_cons (scm_i_atapply, SCM_UNSPECIFIED); + ls = z = scm_cons (scm_sym_atapply, SCM_UNSPECIFIED); goto loop; case (SCM_ISYMNUM (SCM_IM_CONT)): - ls = z = scm_cons (scm_i_atcall_cc, SCM_UNSPECIFIED); + ls = z = scm_cons (scm_sym_atcall_cc, SCM_UNSPECIFIED); + goto loop; + case (SCM_ISYMNUM (SCM_IM_DELAY)): + ls = z = scm_cons (scm_sym_delay, SCM_UNSPECIFIED); + x = SCM_CDR (x); goto loop; default: /* appease the Sun compiler god: */ ; @@ -1091,6 +1527,9 @@ unmemocopy (x, env) loop: while (SCM_CELLP (x = SCM_CDR (x)) && SCM_ECONSP (x)) { + if (SCM_IMP (SCM_CAR (x)) && SCM_ISYMP (SCM_CAR (x))) + /* skip body markers */ + continue; SCM_SETCDR (z, unmemocar (scm_cons (unmemocopy (SCM_CAR (x), env), SCM_UNSPECIFIED), env)); @@ -1118,20 +1557,19 @@ scm_unmemocopy (x, env) return unmemocopy (x, env); } -#ifndef RECKLESS +#ifndef SCM_RECKLESS int scm_badargsp (formals, args) SCM formals; SCM args; { - while SCM_NIMP - (formals) + while (SCM_NIMP (formals)) { - if SCM_NCONSP - (formals) return 0; - if SCM_IMP - (args) return 1; + if (SCM_NCONSP (formals)) + return 0; + if (SCM_IMP(args)) + return 1; formals = SCM_CDR (formals); args = SCM_CDR (args); } @@ -1141,23 +1579,73 @@ scm_badargsp (formals, args) -long scm_tc16_macro; - - SCM -scm_eval_args (l, env) +scm_eval_args (l, env, proc) SCM l; SCM env; + SCM proc; { - SCM res = SCM_EOL, *lloc = &res; + SCM results = SCM_EOL, *lloc = &results, res; while (SCM_NIMP (l)) { - *lloc = scm_cons (EVALCAR (l, env), SCM_EOL); +#ifdef SCM_CAUTIOUS + if (SCM_IMP (l)) + goto wrongnumargs; + else if (SCM_CONSP (l)) + { + if (SCM_IMP (SCM_CAR (l))) + res = SCM_EVALIM (SCM_CAR (l), env); + else + res = EVALCELLCAR (l, env); + } + else if (SCM_TYP3 (l) == 1) + { + if ((res = SCM_GLOC_VAL (SCM_CAR (l))) == 0) + res = SCM_CAR (l); /* struct planted in code */ + } + else + goto wrongnumargs; +#else + res = EVALCAR (l, env); +#endif + *lloc = scm_cons (res, SCM_EOL); lloc = SCM_CDRLOC (*lloc); l = SCM_CDR (l); } - return res; +#ifdef SCM_CAUTIOUS + if (SCM_NNULLP (l)) + { + wrongnumargs: + scm_wrong_num_args (proc); + } +#endif + return results; +} + +SCM +scm_eval_body (SCM code, SCM env) +{ + SCM next; + again: + next = code; + while (SCM_NNULLP (next = SCM_CDR (next))) + { + if (SCM_IMP (SCM_CAR (code))) + { + if (SCM_ISYMP (SCM_CAR (code))) + { + code = scm_m_expand_body (code, env); + goto again; + } + } + else + SCM_XEVAL (SCM_CAR (code), env); + code = next; + } + return SCM_XEVALCAR (code, env); } + + #endif /* !DEVAL */ @@ -1191,21 +1679,21 @@ scm_eval_args (l, env) #define ENTER_APPLY \ {\ SCM_SET_ARGSREADY (debug);\ - if (CHECK_APPLY)\ + if (CHECK_APPLY && SCM_TRAPS_P)\ 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_SET_TRACED_FRAME (debug); \ if (SCM_CHEAPTRAPS_P)\ {\ tmp = scm_make_debugobj (&debug);\ - scm_ithrow (scm_i_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\ - }\ + scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\ + }\ else\ {\ scm_make_cont (&tmp);\ if (!setjmp (SCM_JMPBUF (tmp)))\ - scm_ithrow (scm_i_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\ + scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\ }\ }\ } @@ -1224,7 +1712,7 @@ scm_eval_args (l, env) */ -SCM (*scm_ceval_ptr) SCM_P ((SCM x, SCM env)); +SCM (*scm_ceval_ptr) (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 @@ -1245,6 +1733,12 @@ int scm_debug_eframe_size; int scm_debug_mode, scm_check_entry_p, scm_check_apply_p, scm_check_exit_p; +int scm_eval_stack; + +scm_option scm_eval_opts[] = { + { SCM_OPTION_INTEGER, "stack", 22000, "Size of thread stacks (in machine words)." } +}; + scm_option scm_debug_opts[] = { { SCM_OPTION_BOOLEAN, "cheap", 1, "*Flyweight representation of the stack at traps." }, @@ -1254,6 +1748,7 @@ scm_option scm_debug_opts[] = { "Record procedure names at definition." }, { SCM_OPTION_BOOLEAN, "backwards", 0, "Display backtrace in anti-chronological order." }, + { SCM_OPTION_INTEGER, "width", 79, "Maximal width of backtrace." }, { SCM_OPTION_INTEGER, "indent", 10, "Maximal indentation in backtrace." }, { SCM_OPTION_INTEGER, "frames", 3, "Maximum number of tail-recursive frames in backtrace." }, @@ -1262,27 +1757,89 @@ scm_option scm_debug_opts[] = { { 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_INTEGER, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." } }; scm_option scm_evaluator_trap_table[] = { + { SCM_OPTION_BOOLEAN, "traps", 0, "Enable evaluator traps." }, { 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." } }; +GUILE_PROC (scm_eval_options_interface, "eval-options-interface", 0, 1, 0, + (SCM setting), +"") +#define FUNC_NAME s_scm_eval_options_interface +{ + SCM ans; + SCM_DEFER_INTS; + ans = scm_options (setting, + scm_eval_opts, + SCM_N_EVAL_OPTIONS, + FUNC_NAME); + scm_eval_stack = SCM_EVAL_STACK * sizeof (void *); + SCM_ALLOW_INTS; + return ans; +} +#undef FUNC_NAME + +GUILE_PROC (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0, + (SCM setting), +"") +#define FUNC_NAME s_scm_evaluator_traps +{ + SCM ans; + SCM_DEFER_INTS; + ans = scm_options (setting, + scm_evaluator_trap_table, + SCM_N_EVALUATOR_TRAPS, + FUNC_NAME); + SCM_RESET_DEBUG_MODE; + SCM_ALLOW_INTS; + return ans; +} +#undef FUNC_NAME + SCM -scm_deval_args (l, env, lloc) - SCM l, env, *lloc; +scm_deval_args (l, env, proc, lloc) + SCM l, env, proc, *lloc; { - SCM *res = lloc; + SCM *results = lloc, res; while (SCM_NIMP (l)) { - *lloc = scm_cons (EVALCAR (l, env), SCM_EOL); +#ifdef SCM_CAUTIOUS + if (SCM_IMP (l)) + goto wrongnumargs; + else if (SCM_CONSP (l)) + { + if (SCM_IMP (SCM_CAR (l))) + res = SCM_EVALIM (SCM_CAR (l), env); + else + res = EVALCELLCAR (l, env); + } + else if (SCM_TYP3 (l) == 1) + { + if ((res = SCM_GLOC_VAL (SCM_CAR (l))) == 0) + res = SCM_CAR (l); /* struct planted in code */ + } + else + goto wrongnumargs; +#else + res = EVALCAR (l, env); +#endif + *lloc = scm_cons (res, SCM_EOL); lloc = SCM_CDRLOC (*lloc); l = SCM_CDR (l); } - return *res; +#ifdef SCM_CAUTIOUS + if (SCM_NNULLP (l)) + { + wrongnumargs: + scm_wrong_num_args (proc); + } +#endif + return *results; } #endif /* !DEVAL */ @@ -1299,6 +1856,7 @@ scm_deval_args (l, env, lloc) #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. @@ -1307,37 +1865,36 @@ scm_deval_args (l, env, lloc) #if 0 SCM -scm_ceval (x, env) - SCM x; - SCM env; +scm_ceval (SCM x, SCM env) {} #endif #if 0 SCM -scm_deval (x, env) - SCM x; - SCM env; +scm_deval (SCM x, SCM env) {} #endif - SCM -SCM_CEVAL (x, env) - SCM x; - SCM env; +SCM_CEVAL (SCM x, SCM env) { union { SCM *lloc; SCM arg1; - } t; + } t; 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; + /* + * The debug.vect contains twice as much scm_debug_info frames as the + * user has specified with (debug-set! frames ). + * + * Even frames are eval frames, odd frames are apply frames. + */ debug.vect = (scm_debug_info *) alloca (scm_debug_eframe_size * sizeof (debug.vect[0])); debug.info = debug.vect; @@ -1362,24 +1919,19 @@ loopnoap: PREP_APPLY (SCM_UNDEFINED, SCM_EOL); loop: #ifdef DEVAL -#if 0 /* This will probably never have any practical use ... */ - if (CHECK_EXIT) - { - if (SINGLE_STEP || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug))) - { - SINGLE_STEP = 0; - SCM_RESET_DEBUG_MODE; - SCM_CLEAR_TRACED_FRAME (debug); - scm_make_cont (&t.arg1); - if (!setjmp (SCM_JMPBUF (t.arg1))) - scm_ithrow (scm_i_exit_tail, scm_cons (t.arg1, SCM_EOL), 0); - } - } -nextframe: -#endif SCM_CLEAR_ARGSREADY (debug); if (SCM_OVERFLOWP (debug)) --debug.info; + /* + * In theory, this should be the only place where it is necessary to + * check for space in debug.vect since both eval frames and + * available space are even. + * + * For this to be the case, however, it is necessary that primitive + * special forms which jump back to `loop', `begin' or some similar + * label call PREP_APPLY. A convenient way to do this is to jump to + * `loopnoap' or `cdrxnoap'. + */ else if (++debug.info >= debug_info_end) { SCM_SET_OVERFLOW (debug); @@ -1388,13 +1940,11 @@ nextframe: start: debug.info->e.exp = x; debug.info->e.env = env; - if (CHECK_ENTRY) + if (CHECK_ENTRY && SCM_TRAPS_P) 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 @@ -1413,14 +1963,16 @@ start: goto dispatch; } } - scm_ithrow (scm_i_enter_frame, + scm_ithrow (scm_sym_enter_frame, scm_cons2 (t.arg1, tail, scm_cons (scm_unmemocopy (x, env), SCM_EOL)), 0); } +#endif +#if defined (USE_THREADS) || defined (DEVAL) dispatch: #endif - SCM_ASYNC_TICK; + SCM_TICK; switch (SCM_TYP7 (x)) { case scm_tcs_symbols: @@ -1452,7 +2004,16 @@ dispatch: t.arg1 = x; while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1))) { - SIDEVAL (SCM_CAR (x), env); + if (SCM_IMP (SCM_CAR (x))) + { + if (SCM_ISYMP (SCM_CAR (x))) + { + x = scm_m_expand_body (x, env); + goto begin; + } + } + else + SCM_CEVAL (SCM_CAR (x), env); x = t.arg1; } @@ -1460,13 +2021,13 @@ dispatch: if (SCM_NCELLP (SCM_CAR (x))) { x = SCM_CAR (x); - RETURN (SCM_IMP (x) ? EVALIM (x, env) : SCM_GLOC_VAL (x)) + RETURN (SCM_IMP (x) ? SCM_EVALIM (x, env) : SCM_GLOC_VAL (x)) } if (SCM_SYMBOLP (SCM_CAR (x))) { retval: - RETURN (*scm_lookupcar (x, env)) + RETURN (*scm_lookupcar (x, env, 1)) } x = SCM_CAR (x); @@ -1479,7 +2040,7 @@ dispatch: while (SCM_NIMP (x = SCM_CDR (x))) { proc = SCM_CAR (x); - if (scm_i_else == SCM_CAR (proc)) + if (scm_sym_else == SCM_CAR (proc)) { x = SCM_CDR (proc); PREP_APPLY (SCM_UNDEFINED, SCM_EOL); @@ -1512,7 +2073,7 @@ dispatch: { RETURN (t.arg1) } - if (scm_i_arrow != SCM_CAR (x)) + if (scm_sym_arrow != SCM_CAR (x)) { PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto begin; @@ -1541,12 +2102,14 @@ dispatch: 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)) + for (proc = SCM_CADR (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)) + for (t.arg1 = SCM_EOL, proc = SCM_CDDR (x); + SCM_NIMP (proc); + proc = SCM_CDR (proc)) t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1); /* steps */ env = EXTEND_ENV (SCM_CAR (SCM_CAR (env)), t.arg1, SCM_CDR (env)); } @@ -1639,13 +2202,13 @@ dispatch: RETURN (SCM_CAR (SCM_CDR (x))); - case (127 & SCM_IM_SET): + case (127 & SCM_IM_SET_X): x = SCM_CDR (x); proc = SCM_CAR (x); switch (7 & (int) proc) { case 0: - t.lloc = scm_lookupcar (x, env); + t.lloc = scm_lookupcar (x, env, 1); break; case 1: t.lloc = SCM_GLOC_VAL_LOC (proc); @@ -1666,21 +2229,7 @@ dispatch: 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); -#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_SETCAR (env, scm_cons (proc, SCM_CAR (env))); - SCM_SETCDR (env, scm_cons (x, SCM_CDR (env))); - SCM_ALLOW_INTS; - RETURN (SCM_UNSPECIFIED); - + scm_misc_error (NULL, "Bad define placement", SCM_EOL); /* new syntactic forms go here. */ case (127 & SCM_MAKISYM (0)): @@ -1707,21 +2256,39 @@ dispatch: SCM_ASRTGO (SCM_NIMP (proc), badfun); if (SCM_CLOSUREP (proc)) { + SCM argl, tl; 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 +#ifndef SCM_RECKLESS if (scm_badargsp (SCM_CAR (SCM_CODE (proc)), t.arg1)) goto wrongnumargs; #endif - env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), t.arg1, SCM_ENV (proc)); + ENTER_APPLY; + /* Copy argument list */ + if (SCM_IMP (t.arg1)) + argl = t.arg1; + else + { + argl = tl = scm_cons (SCM_CAR (t.arg1), SCM_UNSPECIFIED); + while (SCM_NIMP (t.arg1 = SCM_CDR (t.arg1)) + && SCM_CONSP (t.arg1)) + { + SCM_SETCDR (tl, scm_cons (SCM_CAR (t.arg1), + SCM_UNSPECIFIED)); + tl = SCM_CDR (tl); + } + SCM_SETCDR (tl, t.arg1); + } + + env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), argl, SCM_ENV (proc)); x = SCM_CODE (proc); goto cdrxbegin; } - proc = scm_i_apply; + proc = scm_f_apply; goto evapply; case (SCM_ISYMNUM (SCM_IM_CONT)): @@ -1730,7 +2297,7 @@ dispatch: { SCM val; val = SCM_THROW_VALUE (t.arg1); - RETURN (val); + RETURN (val) } proc = SCM_CDR (x); proc = evalcar (proc, env); @@ -1739,6 +2306,211 @@ dispatch: ENTER_APPLY; goto evap1; + case (SCM_ISYMNUM (SCM_IM_DELAY)): + RETURN (scm_makprom (scm_closure (SCM_CDR (x), env))) + + case (SCM_ISYMNUM (SCM_IM_DISPATCH)): + proc = SCM_CADR (x); /* unevaluated operands */ + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); + if (SCM_IMP (proc)) + arg2 = *scm_ilookup (proc, env); + else if (SCM_NCONSP (proc)) + { + if (SCM_NCELLP (proc)) + arg2 = SCM_GLOC_VAL (proc); + else + arg2 = *scm_lookupcar (SCM_CDR (x), env, 1); + } + else + { + arg2 = scm_cons (EVALCAR (proc, env), SCM_EOL); + t.lloc = SCM_CDRLOC (arg2); + while (SCM_NIMP (proc = SCM_CDR (proc))) + { + *t.lloc = scm_cons (EVALCAR (proc, env), SCM_EOL); + t.lloc = SCM_CDRLOC (*t.lloc); + } + } + + type_dispatch: + /* The type dispatch code is duplicated here + * (c.f. objects.c:scm_mcache_compute_cmethod) since that + * cuts down execution time for type dispatch to 50%. + */ + { + int i, n, end, mask; + SCM z = SCM_CDDR (x); + n = SCM_INUM (SCM_CAR (z)); /* maximum number of specializers */ + proc = SCM_CADR (z); + + if (SCM_NIMP (proc)) + { + /* Prepare for linear search */ + mask = -1; + i = 0; + end = SCM_LENGTH (proc); + } + else + { + /* Compute a hash value */ + int hashset = SCM_INUM (proc); + int j = n; + mask = SCM_INUM (SCM_CAR (z = SCM_CDDR (z))); + proc = SCM_CADR (z); + i = 0; + t.arg1 = arg2; + if (SCM_NIMP (t.arg1)) + do + { + i += (SCM_STRUCT_DATA (scm_class_of (SCM_CAR (t.arg1))) + [scm_si_hashsets + hashset]); + t.arg1 = SCM_CDR (t.arg1); + } + while (--j && SCM_NIMP (t.arg1)); + i &= mask; + end = i; + } + + /* Search for match */ + do + { + int j = n; + z = SCM_VELTS (proc)[i]; + t.arg1 = arg2; /* list of arguments */ + if (SCM_NIMP (t.arg1)) + do + { + /* More arguments than specifiers => CLASS != ENV */ + if (scm_class_of (SCM_CAR (t.arg1)) != SCM_CAR (z)) + goto next_method; + t.arg1 = SCM_CDR (t.arg1); + z = SCM_CDR (z); + } + while (--j && SCM_NIMP (t.arg1)); + /* Fewer arguments than specifiers => CAR != ENV */ + if (!(SCM_IMP (SCM_CAR (z)) || SCM_CONSP (SCM_CAR (z)))) + goto next_method; + apply_cmethod: + env = EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (z)), + arg2, + SCM_CMETHOD_ENV (z)); + x = SCM_CMETHOD_CODE (z); + goto cdrxbegin; + next_method: + i = (i + 1) & mask; + } while (i != end); + + z = scm_memoize_method (x, arg2); + goto apply_cmethod; + } + + case (SCM_ISYMNUM (SCM_IM_SLOT_REF)): + x = SCM_CDR (x); + t.arg1 = EVALCAR (x, env); + RETURN (SCM_STRUCT_DATA (t.arg1)[SCM_INUM (SCM_CADR (x))]); + + case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X)): + x = SCM_CDR (x); + t.arg1 = EVALCAR (x, env); + x = SCM_CDR (x); + proc = SCM_CDR (x); + SCM_STRUCT_DATA (t.arg1)[SCM_INUM (SCM_CAR (x))] + = EVALCAR (proc, env); + RETURN (SCM_UNSPECIFIED); + + case (SCM_ISYMNUM (SCM_IM_NIL_COND)): + proc = SCM_CDR (x); + while (SCM_NIMP (x = SCM_CDR (proc))) + { + if (!(SCM_FALSEP (t.arg1 = EVALCAR (proc, env)) + || t.arg1 == scm_nil)) + { + if (SCM_CAR (x) == SCM_UNSPECIFIED) + RETURN (t.arg1); + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); + goto carloop; + } + proc = SCM_CDR (x); + } + x = proc; + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); + goto carloop; + + case (SCM_ISYMNUM (SCM_IM_NIL_IFY)): + x = SCM_CDR (x); + RETURN ((SCM_FALSEP (proc = EVALCAR (x, env)) || SCM_NULLP (proc)) + ? scm_nil + : proc) + + case (SCM_ISYMNUM (SCM_IM_T_IFY)): + x = SCM_CDR (x); + RETURN (SCM_NFALSEP (EVALCAR (x, env)) ? scm_t : scm_nil) + + case (SCM_ISYMNUM (SCM_IM_0_COND)): + proc = SCM_CDR (x); + while (SCM_NIMP (x = SCM_CDR (proc))) + { + if (!(SCM_FALSEP (t.arg1 = EVALCAR (proc, env)) + || t.arg1 == SCM_INUM0)) + { + if (SCM_CAR (x) == SCM_UNSPECIFIED) + RETURN (t.arg1); + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); + goto carloop; + } + proc = SCM_CDR (x); + } + x = proc; + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); + goto carloop; + + case (SCM_ISYMNUM (SCM_IM_0_IFY)): + x = SCM_CDR (x); + RETURN (SCM_FALSEP (proc = EVALCAR (x, env)) + ? SCM_INUM0 + : proc) + + case (SCM_ISYMNUM (SCM_IM_1_IFY)): + x = SCM_CDR (x); + RETURN (SCM_NFALSEP (EVALCAR (x, env)) + ? SCM_MAKINUM (1) + : SCM_INUM0) + + case (SCM_ISYMNUM (SCM_IM_BIND)): + x = SCM_CDR (x); + + t.arg1 = SCM_CAR (x); + arg2 = SCM_CDAR (env); + while (SCM_NIMP (arg2)) + { + proc = SCM_GLOC_VAL (SCM_CAR (t.arg1)); + SCM_SETCDR (SCM_CAR (t.arg1) - 1L, SCM_CAR (arg2)); + SCM_SETCAR (arg2, proc); + t.arg1 = SCM_CDR (t.arg1); + arg2 = SCM_CDR (arg2); + } + t.arg1 = SCM_CAR (x); + scm_dynwinds = scm_acons (t.arg1, SCM_CDAR (env), scm_dynwinds); + + arg2 = x = SCM_CDR (x); + while (SCM_NNULLP (arg2 = SCM_CDR (arg2))) + { + SIDEVAL (SCM_CAR (x), env); + x = arg2; + } + proc = EVALCAR (x, env); + + scm_dynwinds = SCM_CDR (scm_dynwinds); + arg2 = SCM_CDAR (env); + while (SCM_NIMP (arg2)) + { + SCM_SETCDR (SCM_CAR (t.arg1) - 1L, SCM_CAR (arg2)); + t.arg1 = SCM_CDR (t.arg1); + arg2 = SCM_CDR (arg2); + } + + RETURN (proc) + default: goto badfun; } @@ -1752,6 +2524,7 @@ dispatch: scm_listify (proc, SCM_UNDEFINED)); case scm_tc7_vector: case scm_tc7_wvect: +#ifdef HAVE_ARRAYS case scm_tc7_bvect: case scm_tc7_byvect: case scm_tc7_svect: @@ -1760,15 +2533,18 @@ dispatch: case scm_tc7_fvect: case scm_tc7_dvect: case scm_tc7_cvect: -#ifdef LONGLONGS +#ifdef HAVE_LONG_LONGS case scm_tc7_llvect: +#endif #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: +#ifdef CCLO + case scm_tc7_cclo: +#endif + case scm_tc7_pws: case scm_tcs_subrs: RETURN (x); @@ -1776,8 +2552,8 @@ dispatch: case (127 & SCM_ILOC00): proc = *scm_ilookup (SCM_CAR (x), env); SCM_ASRTGO (SCM_NIMP (proc), badfun); -#ifndef RECKLESS -#ifdef CAUTIOUS +#ifndef SCM_RECKLESS +#ifdef SCM_CAUTIOUS goto checkargs; #endif #endif @@ -1787,9 +2563,12 @@ dispatch: case scm_tcs_cons_gloc: proc = SCM_GLOC_VAL (SCM_CAR (x)); + if (proc == 0) + /* This is a struct implanted in the code, not a gloc. */ + RETURN (x); SCM_ASRTGO (SCM_NIMP (proc), badfun); -#ifndef RECKLESS -#ifdef CAUTIOUS +#ifndef SCM_RECKLESS +#ifdef SCM_CAUTIOUS goto checkargs; #endif #endif @@ -1799,7 +2578,18 @@ dispatch: case scm_tcs_cons_nimcar: if (SCM_SYMBOLP (SCM_CAR (x))) { - proc = *scm_lookupcar (x, env); +#ifdef USE_THREADS + t.lloc = scm_lookupcar1 (x, env, 1); + if (t.lloc == NULL) + { + /* we have lost the race, start again. */ + goto dispatch; + } + proc = *t.lloc; +#else + proc = *scm_lookupcar (x, env, 1); +#endif + if (SCM_IMP (proc)) { unmemocar (x, env); @@ -1810,7 +2600,17 @@ dispatch: unmemocar (x, env); handle_a_macro: - t.arg1 = SCM_APPLY (SCM_CDR (proc), x, scm_cons (env, scm_listofnull)); +#ifdef DEVAL + /* Set a flag during macro expansion so that macro + application frames can be deleted from the backtrace. */ + SCM_SET_MACROEXP (debug); +#endif + t.arg1 = SCM_APPLY (SCM_CDR (proc), x, + scm_cons (env, scm_listofnull)); + +#ifdef DEVAL + SCM_CLEAR_MACROEXP (debug); +#endif switch ((int) (SCM_CAR (proc) >> 16)) { case 2: @@ -1819,6 +2619,7 @@ dispatch: #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 */ @@ -1835,9 +2636,9 @@ dispatch: 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)); + debug.info->e.exp = scm_cons_source (debug.info->e.exp, + SCM_CAR (x), + SCM_CDR (x)); #endif SCM_DEFER_INTS; SCM_SETCAR (x, SCM_CAR (t.arg1)); @@ -1855,8 +2656,8 @@ dispatch: else proc = SCM_CEVAL (SCM_CAR (x), env); SCM_ASRTGO (SCM_NIMP (proc), badfun); -#ifndef RECKLESS -#ifdef CAUTIOUS +#ifndef SCM_RECKLESS +#ifdef SCM_CAUTIOUS checkargs: #endif if (SCM_CLOSUREP (proc)) @@ -1885,6 +2686,7 @@ evapply: PREP_APPLY (proc, SCM_EOL); if (SCM_NULLP (SCM_CDR (x))) { ENTER_APPLY; + evap0: switch (SCM_TYP7 (proc)) { /* no arguments given */ case scm_tc7_subr_0: @@ -1907,10 +2709,40 @@ evapply: #endif goto evap1; #endif + case scm_tc7_pws: + proc = SCM_PROCEDURE (proc); +#ifdef DEVAL + debug.info->a.proc = proc; +#endif + goto evap0; case scm_tcs_closures: x = SCM_CODE (proc); env = EXTEND_ENV (SCM_CAR (x), SCM_EOL, SCM_ENV (proc)); goto cdrxbegin; + case scm_tcs_cons_gloc: + if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) + { + x = SCM_ENTITY_PROCEDURE (proc); + arg2 = SCM_EOL; + goto type_dispatch; + } + else if (!SCM_I_OPERATORP (proc)) + goto badfun; + else + { + t.arg1 = proc; + proc = (SCM_I_ENTITYP (proc) + ? SCM_ENTITY_PROCEDURE (proc) + : SCM_OPERATOR_PROCEDURE (proc)); +#ifdef DEVAL + debug.info->a.proc = proc; + debug.info->a.args = scm_cons (t.arg1, SCM_EOL); +#endif + if (SCM_NIMP (proc)) + goto evap1; + else + goto badfun; + } case scm_tc7_contin: case scm_tc7_subr_1: case scm_tc7_subr_2: @@ -1931,11 +2763,26 @@ evapply: /* must handle macros by here */ x = SCM_CDR (x); -#ifdef CAUTIOUS +#ifdef SCM_CAUTIOUS if (SCM_IMP (x)) goto wrongnumargs; -#endif + else if (SCM_CONSP (x)) + { + if (SCM_IMP (SCM_CAR (x))) + t.arg1 = SCM_EVALIM (SCM_CAR (x), env); + else + t.arg1 = EVALCELLCAR (x, env); + } + else if (SCM_TYP3 (x) == 1) + { + if ((t.arg1 = SCM_GLOC_VAL (SCM_CAR (x))) == 0) + t.arg1 = SCM_CAR (x); /* struct planted in code */ + } + else + goto wrongnumargs; +#else t.arg1 = EVALCAR (x, env); +#endif #ifdef DEVAL debug.info->a.args = scm_cons (t.arg1, SCM_EOL); #endif @@ -1972,7 +2819,8 @@ evapply: } #endif floerr: - scm_wta (t.arg1, (char *) SCM_ARG1, SCM_CHARS (SCM_SNAME (proc))); + SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), t.arg1, + SCM_ARG1, SCM_CHARS (SCM_SNAME (proc))); } #endif proc = (SCM) SCM_SNAME (proc); @@ -2007,7 +2855,14 @@ evapply: #endif goto evap2; #endif + case scm_tc7_pws: + proc = SCM_PROCEDURE (proc); +#ifdef DEVAL + debug.info->a.proc = proc; +#endif + goto evap1; case scm_tcs_closures: + /* clos1: */ x = SCM_CODE (proc); #ifdef DEVAL env = EXTEND_ENV (SCM_CAR (x), debug.info->a.args, SCM_ENV (proc)); @@ -2017,6 +2872,35 @@ evapply: goto cdrxbegin; case scm_tc7_contin: scm_call_continuation (proc, t.arg1); + case scm_tcs_cons_gloc: + if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) + { + x = SCM_ENTITY_PROCEDURE (proc); +#ifdef DEVAL + arg2 = debug.info->a.args; +#else + arg2 = scm_cons (t.arg1, SCM_EOL); +#endif + goto type_dispatch; + } + else if (!SCM_I_OPERATORP (proc)) + goto badfun; + else + { + arg2 = t.arg1; + t.arg1 = proc; + proc = (SCM_I_ENTITYP (proc) + ? SCM_ENTITY_PROCEDURE (proc) + : SCM_OPERATOR_PROCEDURE (proc)); +#ifdef DEVAL + debug.info->a.args = scm_cons (t.arg1, debug.info->a.args); + debug.info->a.proc = proc; +#endif + if (SCM_NIMP (proc)) + goto evap2; + else + goto badfun; + } case scm_tc7_subr_2: case scm_tc7_subr_0: case scm_tc7_subr_3: @@ -2026,12 +2910,27 @@ evapply: goto badfun; } } -#ifdef CAUTIOUS +#ifdef SCM_CAUTIOUS if (SCM_IMP (x)) goto wrongnumargs; + else if (SCM_CONSP (x)) + { + if (SCM_IMP (SCM_CAR (x))) + arg2 = SCM_EVALIM (SCM_CAR (x), env); + else + arg2 = EVALCELLCAR (x, env); + } + else if (SCM_TYP3 (x) == 1) + { + if ((arg2 = SCM_GLOC_VAL (SCM_CAR (x))) == 0) + arg2 = SCM_CAR (x); /* struct planted in code */ + } + else + goto wrongnumargs; +#else + arg2 = EVALCAR (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 @@ -2061,12 +2960,17 @@ evapply: cclon: case scm_tc7_cclo: #ifdef DEVAL - RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), proc, - scm_cons (debug.info->a.args, SCM_EOL))); + RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), + scm_cons (proc, debug.info->a.args), + SCM_EOL)); #else - RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), proc, - scm_cons2 (t.arg1, arg2, - scm_cons (scm_eval_args (x, env), SCM_EOL)))); + RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), + scm_cons2 (proc, t.arg1, + scm_cons (arg2, + scm_eval_args (x, + env, + proc))), + SCM_EOL)); #endif /* case scm_tc7_cclo: x = scm_cons(arg2, scm_eval_args(x, env)); @@ -2075,6 +2979,46 @@ evapply: proc = SCM_CCLO_SUBR(proc); goto evap3; */ #endif + case scm_tc7_pws: + proc = SCM_PROCEDURE (proc); +#ifdef DEVAL + debug.info->a.proc = proc; +#endif + goto evap2; + case scm_tcs_cons_gloc: + if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) + { + x = SCM_ENTITY_PROCEDURE (proc); +#ifdef DEVAL + arg2 = debug.info->a.args; +#else + arg2 = scm_cons2 (t.arg1, arg2, SCM_EOL); +#endif + goto type_dispatch; + } + else if (!SCM_I_OPERATORP (proc)) + goto badfun; + else + { + operatorn: +#ifdef DEVAL + RETURN (SCM_APPLY (SCM_I_ENTITYP (proc) + ? SCM_ENTITY_PROCEDURE (proc) + : SCM_OPERATOR_PROCEDURE (proc), + scm_cons (proc, debug.info->a.args), + SCM_EOL)); +#else + RETURN (SCM_APPLY (SCM_I_ENTITYP (proc) + ? SCM_ENTITY_PROCEDURE (proc) + : SCM_OPERATOR_PROCEDURE (proc), + scm_cons2 (proc, t.arg1, + scm_cons (arg2, + scm_eval_args (x, + env, + proc))), + SCM_EOL)); +#endif + } case scm_tc7_subr_0: case scm_tc7_cxr: case scm_tc7_subr_1o: @@ -2085,43 +3029,82 @@ evapply: default: goto badfun; case scm_tcs_closures: + /* clos2: */ #ifdef DEVAL - env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), debug.info->a.args, SCM_ENV (proc)); + env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), + debug.info->a.args, + SCM_ENV (proc)); #else - env = EXTEND_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; } } +#ifdef SCM_CAUTIOUS + if (SCM_IMP (x) || SCM_NECONSP (x)) + goto wrongnumargs; +#endif #ifdef DEVAL debug.info->a.args = scm_cons2 (t.arg1, arg2, - scm_deval_args (x, env, SCM_CDRLOC (SCM_CDR (debug.info->a.args)))); + scm_deval_args (x, env, proc, + SCM_CDRLOC (SCM_CDR (debug.info->a.args)))); #endif ENTER_APPLY; + evap3: 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 (debug.info->a.args))))); + RETURN (SCM_SUBRF (proc) (t.arg1, arg2, + SCM_CADDR (debug.info->a.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) */ +#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: - RETURN (SCM_APPLY (proc, t.arg1, scm_acons (arg2, SCM_CDR (SCM_CDR (debug.info->a.args)), SCM_EOL))) - 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 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; #endif + case scm_tc7_pws: + proc = SCM_PROCEDURE (proc); + debug.info->a.proc = proc; + goto evap3; case scm_tcs_closures: SCM_SET_ARGSREADY (debug); env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), @@ -2134,32 +3117,76 @@ evapply: 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) */ +#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: - RETURN (SCM_APPLY (proc, t.arg1, scm_acons (arg2, scm_eval_args (x, env), SCM_EOL))); +#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, proc), + SCM_EOL))); +#endif /* BUILTIN_RPASUBR */ case scm_tc7_lsubr_2: - RETURN (SCM_SUBRF (proc) (t.arg1, arg2, scm_eval_args (x, env))); + RETURN (SCM_SUBRF (proc) (t.arg1, arg2, scm_eval_args (x, env, proc))); case scm_tc7_lsubr: - RETURN (SCM_SUBRF (proc) (scm_cons2 (t.arg1, arg2, scm_eval_args (x, env)))); + RETURN (SCM_SUBRF (proc) (scm_cons2 (t.arg1, + arg2, + scm_eval_args (x, env, proc)))); #ifdef CCLO case scm_tc7_cclo: goto cclon; #endif + case scm_tc7_pws: + proc = SCM_PROCEDURE (proc); + goto evap3; 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_cons2 (t.arg1, + arg2, + scm_eval_args (x, env, proc)), SCM_ENV (proc)); x = SCM_CODE (proc); goto cdrxbegin; #endif /* DEVAL */ + case scm_tcs_cons_gloc: + if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) + { +#ifdef DEVAL + arg2 = debug.info->a.args; +#else + arg2 = scm_cons2 (t.arg1, arg2, scm_eval_args (x, env, proc)); +#endif + x = SCM_ENTITY_PROCEDURE (proc); + goto type_dispatch; + } + else if (!SCM_I_OPERATORP (proc)) + goto badfun; + else + goto operatorn; case scm_tc7_subr_2: case scm_tc7_subr_1o: case scm_tc7_subr_2o: @@ -2174,11 +3201,9 @@ evapply: } #ifdef DEVAL exit: - if (CHECK_EXIT) + if (CHECK_EXIT && SCM_TRAPS_P) 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) t.arg1 = scm_make_debugobj (&debug); @@ -2191,7 +3216,7 @@ exit: goto ret; } } - scm_ithrow (scm_i_exit_frame, scm_cons2 (t.arg1, proc, SCM_EOL), 0); + scm_ithrow (scm_sym_exit_frame, scm_cons2 (t.arg1, proc, SCM_EOL), 0); } ret: scm_last_debug_frame = debug.prev; @@ -2205,67 +3230,40 @@ ret: #ifndef DEVAL -SCM_PROC(s_procedure_documentation, "procedure-documentation", 1, 0, 0, scm_procedure_documentation); - -SCM -scm_procedure_documentation (proc) - SCM proc; -{ - 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 processes the 'arg ...' parameters to apply. +/* This code processes the arguments to apply: (apply PROC ARG1 ... ARGS) - The ARG1 ... arguments are consed on to the front of ARGS (which - must be a list), and then PROC is applied to the elements of the + 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). - 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); + 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 -scm_nconc2last (lst) - SCM lst; +GUILE_PROC(scm_nconc2last, "apply:nconc2last", 1, 0, 0, + (SCM lst), +"") +#define FUNC_NAME s_scm_nconc2last { SCM *lloc; - SCM_ASSERT (scm_ilength (lst) > 0, lst, SCM_ARG1, s_nconc2last); + SCM_VALIDATE_LIST(1,lst); lloc = &lst; while (SCM_NNULLP (SCM_CDR (*lloc))) lloc = SCM_CDRLOC (*lloc); - SCM_ASSERT (scm_ilength (SCM_CAR (*lloc)) >= 0, lst, SCM_ARG1, s_nconc2last); + SCM_ASSERT (scm_ilength (SCM_CAR (*lloc)) >= 0, lst, SCM_ARG1, FUNC_NAME); *lloc = SCM_CAR (*lloc); return lst; } +#undef FUNC_NAME #endif /* !DEVAL */ @@ -2295,11 +3293,18 @@ scm_dapply (proc, arg1, args) #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. */ + SCM -SCM_APPLY (proc, arg1, args) - SCM proc; - SCM arg1; - SCM args; +SCM_APPLY (SCM proc, SCM arg1, SCM args) { #ifdef DEBUG_EXTENSIONS #ifdef DEVAL @@ -2318,28 +3323,49 @@ SCM_APPLY (proc, arg1, args) #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 DEVAL + debug.vect[0].a.args = scm_cons (arg1, args); +#endif } #ifdef DEVAL - debug.vect[0].a.args = scm_cons (arg1, args); - if (SCM_ENTER_FRAME_P) + if (SCM_ENTER_FRAME_P && SCM_TRAPS_P) { SCM tmp; - SCM_ENTER_FRAME_P = 0; - SCM_RESET_DEBUG_MODE; if (SCM_CHEAPTRAPS_P) tmp = scm_make_debugobj (&debug); else @@ -2348,7 +3374,7 @@ SCM_APPLY (proc, arg1, args) if (setjmp (SCM_JMPBUF (tmp))) goto entap; } - scm_ithrow (scm_i_enter_frame, scm_cons (tmp, SCM_EOL), 0); + scm_ithrow (scm_sym_enter_frame, scm_cons (tmp, SCM_EOL), 0); } entap: ENTER_APPLY; @@ -2362,7 +3388,8 @@ tail: 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); + SCM_ASRTGO (SCM_NNULLP (args) && SCM_NULLP (SCM_CDR (args)), + wrongnumargs); args = SCM_CAR (args); RETURN (SCM_SUBRF (proc) (arg1, args)) case scm_tc7_subr_0: @@ -2387,12 +3414,12 @@ tail: RETURN (scm_makdbl (SCM_DSUBRF (proc) (SCM_REALPART (arg1)), 0.0)); } #ifdef SCM_BIGDIG - if SCM_BIGP - (arg1) + 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))); + SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1, + SCM_ARG1, SCM_CHARS (SCM_SNAME (proc))); } #endif proc = (SCM) SCM_SNAME (proc); @@ -2445,15 +3472,46 @@ tail: #else arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args)); #endif -#ifndef RECKLESS +#ifndef SCM_RECKLESS if (scm_badargsp (SCM_CAR (SCM_CODE (proc)), arg1)) goto wrongnumargs; #endif - 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); - RETURN (arg1); + + /* Copy argument list */ + if (SCM_IMP (arg1)) + args = arg1; + else + { + SCM tl = args = scm_cons (SCM_CAR (arg1), SCM_UNSPECIFIED); + while (SCM_NIMP (arg1 = SCM_CDR (arg1)) + && SCM_CONSP (arg1)) + { + SCM_SETCDR (tl, scm_cons (SCM_CAR (arg1), + SCM_UNSPECIFIED)); + tl = SCM_CDR (tl); + } + SCM_SETCDR (tl, arg1); + } + + args = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), args, SCM_ENV (proc)); + proc = SCM_CDR (SCM_CODE (proc)); + again: + arg1 = proc; + while (SCM_NNULLP (arg1 = SCM_CDR (arg1))) + { + if (SCM_IMP (SCM_CAR (proc))) + { + if (SCM_ISYMP (SCM_CAR (proc))) + { + proc = scm_m_expand_body (proc, args); + goto again; + } + } + else + SCM_CEVAL (SCM_CAR (proc), args); + proc = arg1; + } + RETURN (EVALCAR (proc, args)); case scm_tc7_contin: SCM_ASRTGO (SCM_NULLP (args), wrongnumargs); scm_call_continuation (proc, arg1); @@ -2472,6 +3530,44 @@ tail: #endif goto tail; #endif + case scm_tc7_pws: + proc = SCM_PROCEDURE (proc); +#ifdef DEVAL + debug.vect[0].a.proc = proc; +#endif + goto tail; + case scm_tcs_cons_gloc: + if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) + { +#ifdef DEVAL + args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args); +#else + args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args)); +#endif + RETURN (scm_apply_generic (proc, args)); + } + else if (!SCM_I_OPERATORP (proc)) + goto badproc; + else + { +#ifdef DEVAL + args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args); +#else + args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args)); +#endif + arg1 = proc; + proc = (SCM_I_ENTITYP (proc) + ? SCM_ENTITY_PROCEDURE (proc) + : SCM_OPERATOR_PROCEDURE (proc)); +#ifdef DEVAL + debug.vect[0].a.proc = proc; + debug.vect[0].a.args = scm_cons (arg1, args); +#endif + if (SCM_NIMP (proc)) + goto tail; + else + goto badproc; + } wrongnumargs: scm_wrong_num_args (proc); default: @@ -2481,11 +3577,9 @@ tail: } #ifdef DEVAL exit: - if (CHECK_EXIT) + if (CHECK_EXIT && SCM_TRAPS_P) 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); @@ -2498,7 +3592,7 @@ exit: goto ret; } } - scm_ithrow (scm_i_exit_frame, scm_cons2 (arg1, proc, SCM_EOL), 0); + scm_ithrow (scm_sym_exit_frame, scm_cons2 (arg1, proc, SCM_EOL), 0); } ret: scm_last_debug_frame = debug.prev; @@ -2512,46 +3606,88 @@ ret: #ifndef DEVAL -SCM_PROC(s_map, "map", 2, 0, 1, scm_map); +/* Typechecking for multi-argument MAP and FOR-EACH. + + Verify that each element of the vector ARGV, except for the first, + is a proper list whose length is LEN. Attribute errors to WHO, + and claim that the i'th element of ARGV is WHO's i+2'th argument. */ +static inline void +check_map_args (SCM argv, + long len, + SCM gf, + SCM proc, + SCM args, + const char *who) +{ + SCM *ve = SCM_VELTS (argv); + int i; + + for (i = SCM_LENGTH (argv) - 1; i >= 1; i--) + { + int elt_len = scm_ilength (ve[i]); + + if (elt_len < 0) + { + if (gf) + scm_apply_generic (gf, scm_cons (proc, args)); + else + scm_wrong_type_arg (who, i + 2, ve[i]); + } + + if (elt_len != len) + scm_out_of_range (who, ve[i]); + } + + scm_remember (&argv); +} + + +SCM_GPROC (s_map, "map", 2, 0, 1, scm_map, g_map); + +/* Note: Currently, scm_map applies PROC to the argument list(s) + sequentially, starting with the first element(s). This is used in + evalext.c where the Scheme procedure `serial-map', which guarantees + sequential behaviour, is implemented using scm_map. If the + behaviour changes, we need to update `serial-map'. +*/ SCM -scm_map (proc, arg1, args) - SCM proc; - SCM arg1; - SCM args; +scm_map (SCM proc, SCM arg1, SCM args) { - long i; + long i, len; 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); + len = scm_ilength (arg1); + SCM_GASSERTn (len >= 0, + g_map, scm_cons2 (proc, arg1, args), 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); + SCM_GASSERT2 (SCM_CONSP (arg1), g_map, proc, arg1, SCM_ARG2, s_map); + *pres = scm_cons (scm_apply (proc, SCM_CAR (arg1), scm_listofnull), + SCM_EOL); pres = SCM_CDRLOC (*pres); arg1 = SCM_CDR (arg1); } return res; } - args = scm_vector (scm_cons (arg1, args)); + args = scm_vector (arg1 = 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); +#ifndef SCM_RECKLESS + check_map_args (args, len, g_map, proc, arg1, s_map); #endif while (1) { arg1 = SCM_EOL; for (i = SCM_LENGTH (args) - 1; i >= 0; i--) { - if SCM_IMP - (ve[i]) return res; + if (SCM_IMP (ve[i])) + return res; arg1 = scm_cons (SCM_CAR (ve[i]), arg1); ve[i] = SCM_CDR (ve[i]); } @@ -2561,34 +3697,33 @@ scm_map (proc, arg1, args) } -SCM_PROC(s_for_each, "for-each", 2, 0, 1, scm_for_each); +SCM_GPROC (s_for_each, "for-each", 2, 0, 1, scm_for_each, g_for_each); SCM -scm_for_each (proc, arg1, args) - SCM proc; - SCM arg1; - SCM args; +scm_for_each (SCM proc, SCM arg1, SCM args) { SCM *ve = &args; /* Keep args from being optimized away. */ - long i; + long i, len; if SCM_NULLP (arg1) return SCM_UNSPECIFIED; - SCM_ASSERT (SCM_NIMP (arg1), arg1, SCM_ARG2, s_for_each); + len = scm_ilength (arg1); + SCM_GASSERTn (len >= 0, g_for_each, scm_cons2 (proc, arg1, args), + 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_GASSERT2 (SCM_CONSP (arg1), + g_for_each, proc, 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)); + args = scm_vector (arg1 = 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); +#ifndef SCM_RECKLESS + check_map_args (args, len, g_for_each, proc, arg1, s_for_each); #endif while (1) { @@ -2625,106 +3760,30 @@ SCM scm_makprom (code) SCM code; { - register SCM z; - SCM_NEWCELL (z); - SCM_SETCDR (z, code); - SCM_SETCAR (z, scm_tc16_promise); - return z; + SCM_RETURN_NEWSMOB (scm_tc16_promise, code); } -static int prinprom SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); - static int -prinprom (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; +prinprom (SCM exp,SCM port,scm_print_state *pstate) { int writingp = SCM_WRITINGP (pstate); - scm_gen_puts (scm_regular_string, "#', port); + scm_putc ('>', port); return !0; } -SCM_PROC(s_makacro, "procedure->syntax", 1, 0, 0, scm_makacro); - -SCM -scm_makacro (code) - SCM code; -{ - register SCM z; - SCM_NEWCELL (z); - SCM_SETCDR (z, code); - SCM_SETCAR (z, scm_tc16_macro); - return z; -} - - -SCM_PROC(s_makmacro, "procedure->macro", 1, 0, 0, scm_makmacro); - -SCM -scm_makmacro (code) - SCM code; -{ - register SCM z; - SCM_NEWCELL (z); - 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); - -SCM -scm_makmmacro (code) - SCM code; +GUILE_PROC(scm_force, "force", 1, 0, 0, + (SCM x), +"") +#define FUNC_NAME s_scm_force { - register SCM z; - SCM_NEWCELL (z); - SCM_SETCDR (z, code); - SCM_SETCAR (z, scm_tc16_macro | (2L << 16)); - return z; -} - - - -static int prinmacro SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); - -static int -prinmacro (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; -{ - int writingp = SCM_WRITINGP (pstate); - if (SCM_CAR (exp) & (3L << 16)) - scm_gen_puts (scm_regular_string, "#', port); - return !0; -} - -SCM_PROC(s_force, "force", 1, 0, 0, scm_force); - -SCM -scm_force (x) - SCM x; -{ - SCM_ASSERT ((SCM_TYP16 (x) == scm_tc16_promise), x, SCM_ARG1, s_force); + SCM_VALIDATE_SMOB(1,x,promise); if (!((1L << 16) & SCM_CAR (x))) { SCM ans = scm_apply (SCM_CDR (x), SCM_EOL, SCM_EOL); @@ -2738,39 +3797,56 @@ scm_force (x) } return SCM_CDR (x); } +#undef FUNC_NAME -SCM_PROC (s_promise_p, "promise?", 1, 0, 0, scm_promise_p); - -SCM -scm_promise_p (x) - SCM x; +GUILE_PROC (scm_promise_p, "promise?", 1, 0, 0, + (SCM x), +"") +#define FUNC_NAME s_scm_promise_p { - return ((SCM_NIMP (x) && (SCM_TYP16 (x) == scm_tc16_promise)) - ? SCM_BOOL_T - : SCM_BOOL_F); + return SCM_BOOL(SCM_NIMP (x) && (SCM_TYP16 (x) == scm_tc16_promise)); } +#undef FUNC_NAME -SCM_PROC(s_copy_tree, "copy-tree", 1, 0, 0, scm_copy_tree); +GUILE_PROC (scm_cons_source, "cons-source", 3, 0, 0, + (SCM xorig, SCM x, SCM y), +"") +#define FUNC_NAME s_scm_cons_source +{ + SCM p, z; + SCM_NEWCELL (z); + SCM_SETCAR (z, x); + SCM_SETCDR (z, y); + /* Copy source properties possibly associated with xorig. */ + p = scm_whash_lookup (scm_source_whash, xorig); + if (SCM_NIMP (p)) + scm_whash_insert (scm_source_whash, z, p); + return z; +} +#undef FUNC_NAME -SCM -scm_copy_tree (obj) - SCM obj; +GUILE_PROC (scm_copy_tree, "copy-tree", 1, 0, 0, + (SCM obj), +"") +#define FUNC_NAME s_scm_copy_tree { SCM ans, tl; - if SCM_IMP - (obj) return obj; + 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); + ans = scm_make_vector (SCM_MAKINUM (i), SCM_UNSPECIFIED); while (i--) SCM_VELTS (ans)[i] = scm_copy_tree (SCM_VELTS (obj)[i]); return ans; } - if SCM_NCONSP (obj) + 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); + ans = tl = scm_cons_source (obj, + scm_copy_tree (SCM_CAR (obj)), + SCM_UNSPECIFIED); while (SCM_NIMP (obj = SCM_CDR (obj)) && SCM_CONSP (obj)) { SCM_SETCDR (tl, scm_cons (scm_copy_tree (SCM_CAR (obj)), @@ -2780,118 +3856,51 @@ scm_copy_tree (obj) SCM_SETCDR (tl, obj); return ans; } +#undef FUNC_NAME SCM -scm_eval_3 (obj, copyp, env) - SCM obj; - int copyp; - SCM env; +scm_eval_3 (SCM obj, int copyp, SCM env) { 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 XEVAL (obj, env); + return SCM_XEVAL (obj, env); } - -SCM -scm_top_level_env (thunk) - SCM thunk; +GUILE_PROC(scm_eval2, "eval2", 2, 0, 0, + (SCM obj, SCM env_thunk), +"") +#define FUNC_NAME s_scm_eval2 { - if (SCM_IMP(thunk)) - return SCM_EOL; - else - return scm_cons(thunk, (SCM)SCM_EOL); + return scm_eval_3 (obj, 1, scm_top_level_env (env_thunk)); } +#undef FUNC_NAME -SCM_PROC(s_eval2, "eval2", 2, 0, 0, scm_eval2); - -SCM -scm_eval2 (obj, env_thunk) - SCM obj; - SCM env_thunk; +GUILE_PROC(scm_eval, "eval", 1, 0, 0, + (SCM obj), +"") +#define FUNC_NAME s_scm_eval { - return scm_eval_3 (obj, 1, scm_top_level_env(env_thunk)); + return scm_eval_3 (obj, + 1, + scm_top_level_env + (SCM_CDR (scm_top_level_lookup_closure_var))); } +#undef FUNC_NAME -SCM_PROC(s_eval, "eval", 1, 0, 0, scm_eval); - -SCM -scm_eval (obj) - SCM obj; -{ - return - 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); */ - -SCM -scm_eval_x (obj) - SCM obj; -{ - return - scm_eval_3(obj, - 0, - 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); +/* +SCM_REGISTER_PROC(s_eval_x, "eval!", 1, 0, 0, scm_eval_x); +*/ SCM -scm_macro_eval_x (exp, env) - SCM exp; - SCM env; -{ - return scm_eval_3 (exp, 0, env); -} - - -SCM_PROC (s_definedp, "defined?", 1, 0, 0, scm_definedp); - -SCM -scm_definedp (sym) - SCM sym; -{ - SCM vcell; - - if (SCM_ISYMP (sym)) - return 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 = -{scm_markcdr, scm_free0, prinprom}; - -static scm_smobfuns macrosmob = -{scm_markcdr, scm_free0, prinmacro}; - - -SCM -scm_make_synt (name, macroizer, fcn) - char *name; - SCM (*macroizer) (); - SCM (*fcn) (); +scm_eval_x (SCM obj) { - 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_SETCAR (z, tmp + scm_tc7_subr_2); - SCM_SETCDR (symcell, macroizer (z)); - return SCM_CAR (symcell); + return scm_eval_3 (obj, + 0, + scm_top_level_env + (SCM_CDR (scm_top_level_lookup_closure_var))); } @@ -2908,52 +3917,49 @@ scm_make_synt (name, macroizer, fcn) void scm_init_eval () { - 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_init_opts (scm_evaluator_traps, + scm_evaluator_trap_table, + SCM_N_EVALUATOR_TRAPS); + scm_init_opts (scm_eval_options_interface, + scm_eval_opts, + SCM_N_EVAL_OPTIONS); + + scm_tc16_promise = scm_make_smob_type ("promise", 0); + scm_set_smob_mark (scm_tc16_promise, scm_markcdr); + scm_set_smob_print (scm_tc16_promise, prinprom); + + scm_f_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)); - + scm_sym_dot = SCM_CAR (scm_sysintern (".", SCM_UNDEFINED)); + scm_sym_arrow = SCM_CAR (scm_sysintern ("=>", SCM_UNDEFINED)); + scm_sym_else = SCM_CAR (scm_sysintern ("else", SCM_UNDEFINED)); + scm_sym_unquote = SCM_CAR (scm_sysintern ("unquote", SCM_UNDEFINED)); + scm_sym_uq_splicing = SCM_CAR (scm_sysintern ("unquote-splicing", SCM_UNDEFINED)); + + scm_nil = scm_sysintern ("nil", SCM_UNDEFINED); + SCM_SETCDR (scm_nil, SCM_CAR (scm_nil)); + scm_nil = SCM_CAR (scm_nil); + scm_t = scm_sysintern ("t", SCM_UNDEFINED); + SCM_SETCDR (scm_t, SCM_CAR (scm_t)); + scm_t = SCM_CAR (scm_t); + /* acros */ - scm_i_quasiquote = scm_make_synt (s_quasiquote, scm_makacro, scm_m_quasiquote); - 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_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_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_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)); + scm_sym_enter_frame = SCM_CAR (scm_sysintern ("enter-frame", SCM_UNDEFINED)); + scm_sym_apply_frame = SCM_CAR (scm_sysintern ("apply-frame", SCM_UNDEFINED)); + scm_sym_exit_frame = SCM_CAR (scm_sysintern ("exit-frame", SCM_UNDEFINED)); + scm_sym_trace = SCM_CAR (scm_sysintern ("trace", SCM_UNDEFINED)); #endif #include "eval.x" + + scm_add_feature ("delay"); } #endif /* !DEVAL */