X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/1609038c875931c7b4090fe4a7534735dfa96b4b..d8c40b9f49836a0d8c28b49ff5346033c50e113d:/libguile/eval.c diff --git a/libguile/eval.c b/libguile/eval.c index 0bdc33c41..c17e4787d 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, 96, 97, 98, 99, 2000 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 @@ -38,6 +38,10 @@ * 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. */ + +/* 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 @@ -82,21 +86,25 @@ char *alloca (); #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 "async.h" #include "feature.h" +#include "modules.h" +#include "ports.h" +#include "root.h" +#include "vectors.h" +#include "validate.h" #include "eval.h" + +SCM (*scm_memoize_method) (SCM, SCM); + /* The evaluator contains a plethora of EVAL symbols. @@ -113,7 +121,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. @@ -124,51 +132,36 @@ 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 EVALCELLCAR(x, env) (SCM_SYMBOLP (SCM_CAR(x)) \ - ? *scm_lookupcar(x, env) \ - : SCM_CEVAL(SCM_CAR(x), env)) +#define SCM_CEVAL scm_ceval +#define SIDEVAL(x, env) if (SCM_NIMP (x)) SCM_CEVAL((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_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 EVALCELLCAR(x, env) (SCM_SYMBOLP (SCM_CAR (x)) \ + ? *scm_lookupcar (x, env, 1) \ + : SCM_CEVAL (SCM_CAR (x), env)) + +#define EVALCAR(x, env) (SCM_NCELLP (SCM_CAR (x)) \ + ? (SCM_IMP (SCM_CAR (x)) \ + ? SCM_EVALIM (SCM_CAR (x), env) \ + : SCM_GLOC_VAL (SCM_CAR (x))) \ + : EVALCELLCAR (x, env)) #define EXTEND_ENV SCM_EXTEND_ENV #ifdef MEMOIZE_LOCALS SCM * -scm_ilookup (iloc, env) - SCM iloc; - SCM env; +scm_ilookup (SCM iloc, SCM env) { register int ir = SCM_IFRAME (iloc); register SCM er = env; @@ -255,14 +248,25 @@ scm_ilookup (iloc, env) 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 place where this applies. */ + 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 }; + +SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable"); + +#ifdef USE_THREADS +static SCM * +scm_lookupcar1 (SCM vloc, SCM genv, int check) +#else SCM * -scm_lookupcar1 (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); @@ -274,18 +278,18 @@ scm_lookupcar1 (vloc, genv) #endif for (; SCM_NIMP (env); env = SCM_CDR (env)) { - if (SCM_BOOL_T == scm_procedure_p (SCM_CAR (env))) + if (SCM_TRUE_P (scm_procedure_p (SCM_CAR (env)))) break; al = SCM_CARLOC (env); for (fl = SCM_CAR (*al); SCM_NIMP (fl); fl = SCM_CDR (fl)) { if (SCM_NCONSP (fl)) { - if (fl == var) + if (SCM_EQ_P (fl, var)) { #ifdef MEMOIZE_LOCALS #ifdef USE_THREADS - if (SCM_CAR (vloc) != var) + if (! SCM_EQ_P (SCM_CAR (vloc), var)) goto race; #endif SCM_SETCAR (vloc, iloc + SCM_ICDR); @@ -296,10 +300,10 @@ scm_lookupcar1 (vloc, genv) break; } al = SCM_CDRLOC (*al); - if (SCM_CAR (fl) == var) + if (SCM_EQ_P (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; @@ -319,7 +323,7 @@ scm_lookupcar1 (vloc, genv) #endif } #ifdef MEMOIZE_LOCALS - iloc = (~SCM_IDSTMSK) & (iloc + SCM_IFRINC); + iloc = SCM_PACK ((~SCM_IDSTMSK) & SCM_UNPACK(iloc + SCM_IFRINC)); #endif } { @@ -332,22 +336,28 @@ scm_lookupcar1 (vloc, genv) else top_thunk = SCM_BOOL_F; vcell = scm_sym2vcell (var, top_thunk, SCM_BOOL_F); - if (vcell == SCM_BOOL_F) + if (SCM_FALSEP (vcell)) goto errout; 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) + { + if (SCM_NULLP (env)) + scm_error (scm_unbound_variable_key, NULL, "Unbound variable: ~S", + scm_cons (var, SCM_EOL), SCM_BOOL_F); + else + scm_misc_error (NULL, "Damaged environment: ~S", + scm_cons (var, SCM_EOL)); + } + else + return SCM_CDRLOC (&undef_cell); } #endif #ifdef USE_THREADS @@ -358,10 +368,10 @@ scm_lookupcar1 (vloc, genv) completely. */ race: var = SCM_CAR (vloc); - if ((var & 7) == 1) + if (SCM_ITAG3 (var) == 1) return SCM_GLOC_VAL_LOC (var); #ifdef MEMOIZE_LOCALS - if ((var & 127) == (127 & SCM_ILOC00)) + if ((SCM_UNPACK (var) & 127) == (127 & SCM_UNPACK (SCM_ILOC00))) return scm_ilookup (var, genv); #endif /* We can't cope with anything else than glocs and ilocs. When @@ -381,25 +391,19 @@ scm_lookupcar1 (vloc, genv) #ifdef USE_THREADS SCM * -scm_lookupcar (vloc, genv) - SCM vloc; - SCM genv; +scm_lookupcar (SCM vloc, SCM genv, int check) { - SCM *loc = scm_lookupcar1 (vloc, genv); + SCM *loc = scm_lookupcar1 (vloc, genv, check); if (loc == NULL) abort (); return loc; } -#else /* not USE_THREADS */ -#define scm_lookupcar scm_lookupcar1 #endif #define unmemocar scm_unmemocar SCM -scm_unmemocar (form, env) - SCM form; - SCM env; +scm_unmemocar (SCM form, SCM env) { #ifdef DEBUG_EXTENSIONS register int ir; @@ -409,8 +413,8 @@ scm_unmemocar (form, env) if (SCM_IMP (form)) return form; c = SCM_CAR (form); - if (1 == (c & 7)) - SCM_SETCAR (form, SCM_CAR (c - 1)); + if (1 == (SCM_UNPACK (c) & 7)) + SCM_SETCAR (form, SCM_GLOC_SYM (c)); #ifdef MEMOIZE_LOCALS #ifdef DEBUG_EXTENSIONS else if (SCM_ILOCP (c)) @@ -429,11 +433,9 @@ scm_unmemocar (form, env) SCM -scm_eval_car (pair, env) - SCM pair; - SCM env; +scm_eval_car (SCM pair, SCM env) { - return XEVALCAR (pair, env); + return SCM_XEVALCAR (pair, env); } @@ -442,154 +444,180 @@ 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 xorig, SCM *bodyloc, const char *what); static void -bodycheck (xorig, bodyloc, what) - SCM xorig; - SCM *bodyloc; - char *what; +bodycheck (SCM xorig, SCM *bodyloc, 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 (SCM op, SCM xorig, const 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; +scm_m_quote (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; +scm_m_begin (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) - SCM xorig; - SCM env; +scm_m_if (SCM xorig, 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 xorig; - SCM env; +scm_m_set_x (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_SYMBOLP (SCM_CAR (x)), + xorig, scm_s_variable, scm_s_set_x); + return scm_cons (SCM_IM_SET_X, x); } #if 0 SCM -scm_m_vref (xorig, env) - SCM xorig; - SCM env; +scm_m_vref (SCM xorig, 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") */ scm_misc_error (NULL, - "Bad variable: %S", + "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); } SCM -scm_m_vset (xorig, env) - SCM xorig; - SCM env; +scm_m_vset (SCM xorig, 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) - SCM xorig; - SCM env; +scm_m_and (SCM xorig, 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) - SCM xorig; - SCM env; +scm_m_or (SCM xorig, 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 @@ -597,58 +625,60 @@ 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_m_case (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_EQ_P (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_m_cond (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_EQ_P (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_EQ_P (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) - SCM xorig; - SCM env; +scm_m_lambda (SCM xorig, SCM env) { SCM proc, x = SCM_CDR (xorig); if (scm_ilength (x) < 2) @@ -656,6 +686,8 @@ scm_m_lambda (xorig, env) proc = SCM_CAR (x); if (SCM_NULLP (proc)) goto memlambda; + if (SCM_EQ_P (SCM_IM_LET, proc)) /* named let */ + goto memlambda; if (SCM_IMP (proc)) goto badforms; if (SCM_SYMBOLP (proc)) @@ -671,42 +703,46 @@ scm_m_lambda (xorig, env) else goto memlambda; } - if (!(SCM_NIMP (SCM_CAR (proc)) && SCM_SYMBOLP (SCM_CAR (proc)))) + if (!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 -scm_m_letstar (xorig, env) - SCM xorig; - SCM env; +scm_m_letstar (SCM xorig, SCM 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_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 @@ -723,27 +759,25 @@ 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) - SCM xorig; - SCM env; +scm_m_do (SCM xorig, SCM env) { SCM x = SCM_CDR (xorig), arg1, proc; SCM vars = SCM_EOL, inits = SCM_EOL, steps = SCM_EOL; SCM *initloc = &inits, *steploc = &steps; int len = scm_ilength (x); - ASSYNT (len >= 2, xorig, s_test, "do"); + 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_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); @@ -755,7 +789,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"); @@ -768,18 +802,27 @@ 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); + +SCM_SYNTAX(s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote); +SCM_GLOBAL_SYMBOL(scm_sym_quasiquote, s_quasiquote); + +SCM +scm_m_quasiquote (SCM xorig, SCM env) +{ + 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 (form, env, depth) - SCM form; - SCM env; - int depth; +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); @@ -789,26 +832,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_EQ_P (scm_sym_quasiquote, tmp)) { depth++; goto label; } - if (scm_i_unquote == tmp) + if (SCM_EQ_P (scm_sym_unquote, tmp)) { --depth; label: form = SCM_CDR (form); - SCM_ASSERT (SCM_NIMP (form) && SCM_ECONSP (form) && SCM_NULLP (SCM_CDR (form)), - form, SCM_ARG1, s_quasiquote); + SCM_ASSERT (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_EQ_P (scm_sym_uq_splicing, SCM_CAR (tmp)))) { tmp = SCM_CDR (tmp); if (0 == --edepth) @@ -819,64 +862,37 @@ iqq (form, env, depth) /* Here are acros which return values rather than code. */ +SCM_SYNTAX (s_delay, "delay", scm_makmmacro, scm_m_delay); +SCM_GLOBAL_SYMBOL (scm_sym_delay, s_delay); SCM -scm_m_quasiquote (xorig, env) - SCM xorig; - SCM env; +scm_m_delay (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_ASSYNT (scm_ilength (xorig) == 2, xorig, scm_s_expression, s_delay); + return scm_cons2 (SCM_IM_DELAY, SCM_EOL, SCM_CDR (xorig)); } -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)); -} - - -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) - SCM x; - SCM env; +scm_m_define (SCM x, SCM 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)) + while (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_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); @@ -887,19 +903,19 @@ scm_m_define (x, env) proc: if (SCM_CLOSUREP (arg1) /* Only the first definition determines the name. */ - && scm_procedure_property (arg1, scm_i_name) == SCM_BOOL_F) - scm_set_procedure_property_x (arg1, scm_i_name, proc); + && SCM_FALSEP (scm_procedure_property (arg1, scm_sym_name))) + scm_set_procedure_property_x (arg1, scm_sym_name, proc); else if (SCM_TYP16 (arg1) == scm_tc16_macro - && SCM_CDR (arg1) != arg1) + && !SCM_EQ_P (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)); @@ -910,7 +926,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 @@ -918,140 +934,355 @@ 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) - SCM xorig; - SCM env; +static SCM +scm_m_letrec1 (SCM op, SCM imm, SCM xorig, SCM env) { SCM cdrx = SCM_CDR (xorig); /* locally mutable version of form */ char *what = SCM_CHARS (SCM_CAR (xorig)); SCM x = cdrx, proc, arg1; /* structure traversers */ SCM vars = SCM_EOL, inits = SCM_EOL, *initloc = &inits; - ASRTSYNTAX (scm_ilength (x) >= 2, s_body); proc = SCM_CAR (x); - if SCM_NULLP - (proc) return scm_m_letstar (xorig, env); /* null binding, let* faster */ - ASRTSYNTAX (scm_ilength (proc) >= 1, s_bindings); + 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_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_let (xorig, env) - SCM xorig; - SCM env; +scm_m_letrec (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 (SCM xorig, SCM env) { SCM cdrx = SCM_CDR (xorig); /* locally mutable version of form */ SCM x = cdrx, proc, arg1, name; /* structure traversers */ SCM vars = SCM_EOL, inits = SCM_EOL, *varloc = &vars, *initloc = &inits; - ASSYNT (scm_ilength (x) >= 2, xorig, s_body, "let"); + 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_CONSP (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_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; +scm_m_apply (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 -scm_m_cont (xorig, env) - SCM xorig; - SCM env; +scm_m_cont (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_lisp_nil; +SCM scm_lisp_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_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_EQ_P (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_EQ_P (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_UNPACK_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 @@ -1061,12 +1292,17 @@ scm_m_cont (xorig, env) * 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... :) + */ + +#define SCM_BIT8(x) (127 & SCM_UNPACK (x)) static SCM -unmemocopy (x, env) - SCM x; - SCM env; +unmemocopy (SCM x, SCM env) { SCM ls, z; #ifdef DEBUG_EXTENSIONS @@ -1079,48 +1315,52 @@ unmemocopy (x, env) #endif switch (SCM_TYP7 (x)) { - case (127 & SCM_IM_AND): - ls = z = scm_cons (scm_i_and, SCM_UNSPECIFIED); + case SCM_BIT8(SCM_IM_AND): + ls = z = scm_cons (scm_sym_and, SCM_UNSPECIFIED); break; - case (127 & SCM_IM_BEGIN): - ls = z = scm_cons (scm_i_begin, SCM_UNSPECIFIED); + case SCM_BIT8(SCM_IM_BEGIN): + ls = z = scm_cons (scm_sym_begin, SCM_UNSPECIFIED); break; - case (127 & SCM_IM_CASE): - ls = z = scm_cons (scm_i_case, SCM_UNSPECIFIED); + case SCM_BIT8(SCM_IM_CASE): + ls = z = scm_cons (scm_sym_case, SCM_UNSPECIFIED); break; - case (127 & SCM_IM_COND): - ls = z = scm_cons (scm_i_cond, SCM_UNSPECIFIED); + case SCM_BIT8(SCM_IM_COND): + ls = z = scm_cons (scm_sym_cond, SCM_UNSPECIFIED); break; - case (127 & SCM_IM_DO): - ls = scm_cons (scm_i_do, SCM_UNSPECIFIED); + case SCM_BIT8(SCM_IM_DO): + ls = scm_cons (scm_sym_do, SCM_UNSPECIFIED); goto transform; - case (127 & SCM_IM_IF): - ls = z = scm_cons (scm_i_if, SCM_UNSPECIFIED); + case SCM_BIT8(SCM_IM_IF): + ls = z = scm_cons (scm_sym_if, SCM_UNSPECIFIED); break; - case (127 & SCM_IM_LET): - ls = scm_cons (scm_i_let, SCM_UNSPECIFIED); + case SCM_BIT8(SCM_IM_LET): + ls = scm_cons (scm_sym_let, SCM_UNSPECIFIED); goto transform; - case (127 & SCM_IM_LETREC): + case SCM_BIT8(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_EQ_P (SCM_CAR (ls), scm_sym_letrec) ? z : env)); env = z; - s = SCM_CAR (ls) == scm_i_do + /* increments */ + s = SCM_EQ_P (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 { z = scm_acons (SCM_CAR (v), scm_cons (SCM_CAR (e), - SCM_CAR (s) == SCM_CAR (v) + SCM_EQ_P (SCM_CAR (s), SCM_CAR (v)) ? SCM_EOL : scm_cons (SCM_CAR (s), SCM_EOL)), z); @@ -1128,20 +1368,23 @@ 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_EQ_P (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; } - case (127 & SCM_IM_LETSTAR): + case SCM_BIT8(SCM_IM_LETSTAR): { SCM b, y; x = SCM_CDR (x); @@ -1161,7 +1404,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 @@ -1174,48 +1417,52 @@ 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); + case SCM_BIT8(SCM_IM_OR): + ls = z = scm_cons (scm_sym_or, SCM_UNSPECIFIED); break; - case (127 & SCM_IM_LAMBDA): + case SCM_BIT8(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); + case SCM_BIT8(SCM_IM_QUOTE): + 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 SCM_BIT8(SCM_IM_SET_X): + ls = z = scm_cons (scm_sym_set_x, SCM_UNSPECIFIED); break; - case (127 & SCM_IM_DEFINE): + case SCM_BIT8(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)))); break; } - case (127 & SCM_MAKISYM (0)): + case SCM_BIT8(SCM_MAKISYM (0)): 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: */ ; @@ -1229,6 +1476,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)); @@ -1244,9 +1494,7 @@ loop: SCM -scm_unmemocopy (x, env) - SCM x; - SCM env; +scm_unmemocopy (SCM x, SCM env) { if (SCM_NNULLP (env)) /* Make a copy of the lowest frame to protect it from @@ -1256,20 +1504,17 @@ scm_unmemocopy (x, env) return unmemocopy (x, env); } -#ifndef RECKLESS +#ifndef SCM_RECKLESS int -scm_badargsp (formals, args) - SCM formals; - SCM args; +scm_badargsp (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); } @@ -1279,57 +1524,68 @@ scm_badargsp (formals, args) -long scm_tc16_macro; - - SCM -scm_eval_args (l, env) - SCM l; - SCM env; +scm_eval_args (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; } - -/* The SCM_CEVAL and SCM_APPLY functions use this function instead of - calling setjmp directly, to make sure that local variables don't - have their values clobbered by a longjmp. - - According to Harbison & Steele, "Automatic variables local to the - function containing setjmp are guaranteed to have their correct - value in ANSI C only if they have a volatile-qualified type or if - their values were not changed between the original call to setjmp - and the corresponding longjmp call." - - SCM_CEVAL and SCM_APPLY are too complex for me to see how to meet - the second condition, and making x and env volatile would be a - speed problem, so we'll just trivially meet the first, by having no - "automatic variables local to the function containing setjmp." */ - -/* Actually, this entire approach is bogus, because setjmp ends up - capturing the stack frame of the wrapper function, which then - returns, rendering the jump buffer invalid. Duh. Gotta find a - better way... -JimB */ -#define safe_setjmp(x) setjmp (x) -#if 0 -static int -unsafe_setjmp (jmp_buf env) +SCM +scm_eval_body (SCM code, SCM env) { - /* I think ANSI requires us to write the function this way, instead - of just saying "return setjmp (env)". Maybe I'm being silly. - See Harbison & Steele, third edition, p. 353. */ - int val; - val = setjmp (env); - return val; + 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 #endif /* !DEVAL */ @@ -1363,29 +1619,26 @@ unsafe_setjmp (jmp_buf env) { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; } #undef ENTER_APPLY #define ENTER_APPLY \ -{\ +do { \ 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 tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \ SCM_SET_TRACED_FRAME (debug); \ - SCM_APPLY_FRAME_P = 0; \ - SCM_TRACE_P = 0; \ - SCM_RESET_DEBUG_MODE; \ if (SCM_CHEAPTRAPS_P)\ {\ tmp = scm_make_debugobj (&debug);\ - scm_ithrow (scm_i_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\ - }\ + scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\ + }\ else\ {\ scm_make_cont (&tmp);\ - if (!safe_setjmp (SCM_JMPBUF (tmp)))\ - scm_ithrow (scm_i_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\ + if (!setjmp (SCM_JMPBUF (tmp)))\ + scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\ }\ }\ -} +} while (0) #undef RETURN #define RETURN(e) {proc = (e); goto exit;} #ifdef STACK_CHECKING @@ -1401,7 +1654,7 @@ unsafe_setjmp (jmp_buf 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 @@ -1422,8 +1675,10 @@ 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", 0x10000, "Size of thread stacks." } + { SCM_OPTION_INTEGER, "stack", 22000, "Size of thread stacks (in machine words)." } }; scm_option scm_debug_opts[] = { @@ -1435,6 +1690,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." }, @@ -1443,60 +1699,88 @@ 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." } }; -SCM_PROC (s_eval_options_interface, "eval-options-interface", 0, 1, 0, scm_eval_options_interface); - -SCM -scm_eval_options_interface (setting) - SCM setting; +SCM_DEFINE (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, - s_eval_options_interface); + FUNC_NAME); + scm_eval_stack = SCM_EVAL_STACK * sizeof (void *); SCM_ALLOW_INTS; return ans; } +#undef FUNC_NAME -SCM_PROC (s_evaluator_traps, "evaluator-traps-interface", 0, 1, 0, scm_evaluator_traps); - -SCM -scm_evaluator_traps (setting) - SCM setting; +SCM_DEFINE (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, - s_evaluator_traps); + FUNC_NAME); SCM_RESET_DEBUG_MODE; - SCM_ALLOW_INTS + SCM_ALLOW_INTS; return ans; } +#undef FUNC_NAME SCM -scm_deval_args (l, env, lloc) - SCM l, env, *lloc; +scm_deval_args (SCM l, SCM env, SCM proc, SCM *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 */ @@ -1506,11 +1790,7 @@ scm_deval_args (l, env, lloc) */ #ifndef DEVAL -#ifdef SCM_FLOATS #define CHECK_EQVISH(A,B) (((A) == (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B))))) -#else -#define CHECK_EQVISH(A,B) ((A) == (B)) -#endif #endif /* DEVAL */ #define BUILTIN_RPASUBR /* Handle rpsubrs and asubrs without calling apply */ @@ -1522,24 +1802,18 @@ 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 { @@ -1552,6 +1826,12 @@ SCM_CEVAL (x, env) 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; @@ -1559,8 +1839,8 @@ SCM_CEVAL (x, env) scm_last_debug_frame = &debug; #endif #ifdef EVAL_STACK_CHECKING - if (SCM_STACK_OVERFLOW_P ((SCM_STACKITEM *) &proc) - && scm_stack_checking_enabled_p) + if (scm_stack_checking_enabled_p + && SCM_STACK_OVERFLOW_P ((SCM_STACKITEM *) &proc)) { #ifdef DEVAL debug.info->e.exp = x; @@ -1579,6 +1859,16 @@ loop: 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); @@ -1587,19 +1877,17 @@ loop: 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 tail = SCM_BOOL(SCM_TAILRECP (debug)); SCM_SET_TAILREC (debug); - SCM_ENTER_FRAME_P = 0; - SCM_RESET_DEBUG_MODE; if (SCM_CHEAPTRAPS_P) t.arg1 = scm_make_debugobj (&debug); else { scm_make_cont (&t.arg1); - if (safe_setjmp (SCM_JMPBUF (t.arg1))) + if (setjmp (SCM_JMPBUF (t.arg1))) { x = SCM_THROW_VALUE (t.arg1); if (SCM_IMP (x)) @@ -1612,7 +1900,7 @@ 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); @@ -1630,7 +1918,7 @@ dispatch: x = scm_cons (x, SCM_UNDEFINED); goto retval; - case (127 & SCM_IM_AND): + case SCM_BIT8(SCM_IM_AND): x = SCM_CDR (x); t.arg1 = x; while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1))) @@ -1643,7 +1931,7 @@ dispatch: PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto carloop; - case (127 & SCM_IM_BEGIN): + case SCM_BIT8(SCM_IM_BEGIN): cdrxnoap: PREP_APPLY (SCM_UNDEFINED, SCM_EOL); cdrxbegin: @@ -1653,7 +1941,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; } @@ -1661,26 +1958,26 @@ 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); goto loop; /* tail recurse */ - case (127 & SCM_IM_CASE): + case SCM_BIT8(SCM_IM_CASE): x = SCM_CDR (x); t.arg1 = EVALCAR (x, env); while (SCM_NIMP (x = SCM_CDR (x))) { proc = SCM_CAR (x); - if (scm_i_else == SCM_CAR (proc)) + if (SCM_EQ_P (scm_sym_else, SCM_CAR (proc))) { x = SCM_CDR (proc); PREP_APPLY (SCM_UNDEFINED, SCM_EOL); @@ -1701,7 +1998,7 @@ dispatch: RETURN (SCM_UNSPECIFIED) - case (127 & SCM_IM_COND): + case SCM_BIT8(SCM_IM_COND): while (SCM_NIMP (x = SCM_CDR (x))) { proc = SCM_CAR (x); @@ -1713,7 +2010,7 @@ dispatch: { RETURN (t.arg1) } - if (scm_i_arrow != SCM_CAR (x)) + if (! SCM_EQ_P (scm_sym_arrow, SCM_CAR (x))) { PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto begin; @@ -1729,7 +2026,7 @@ dispatch: RETURN (SCM_UNSPECIFIED) - case (127 & SCM_IM_DO): + case SCM_BIT8(SCM_IM_DO): x = SCM_CDR (x); proc = SCM_CAR (SCM_CDR (x)); /* inits */ t.arg1 = SCM_EOL; /* values */ @@ -1742,12 +2039,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)); } @@ -1758,7 +2057,7 @@ dispatch: goto begin; - case (127 & SCM_IM_IF): + case SCM_BIT8(SCM_IM_IF): x = SCM_CDR (x); if (SCM_NFALSEP (EVALCAR (x, env))) x = SCM_CDR (x); @@ -1770,7 +2069,7 @@ dispatch: goto carloop; - case (127 & SCM_IM_LET): + case SCM_BIT8(SCM_IM_LET): x = SCM_CDR (x); proc = SCM_CAR (SCM_CDR (x)); t.arg1 = SCM_EOL; @@ -1784,7 +2083,7 @@ dispatch: goto cdrxnoap; - case (127 & SCM_IM_LETREC): + case SCM_BIT8(SCM_IM_LETREC): x = SCM_CDR (x); env = EXTEND_ENV (SCM_CAR (x), scm_undefineds, env); x = SCM_CDR (x); @@ -1799,7 +2098,7 @@ dispatch: goto cdrxnoap; - case (127 & SCM_IM_LETSTAR): + case SCM_BIT8(SCM_IM_LETSTAR): x = SCM_CDR (x); proc = SCM_CAR (x); if (SCM_IMP (proc)) @@ -1816,7 +2115,7 @@ dispatch: while (SCM_NIMP (proc = SCM_CDR (proc))); goto cdrxnoap; - case (127 & SCM_IM_OR): + case SCM_BIT8(SCM_IM_OR): x = SCM_CDR (x); t.arg1 = x; while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1))) @@ -1832,21 +2131,21 @@ dispatch: goto carloop; - case (127 & SCM_IM_LAMBDA): + case SCM_BIT8(SCM_IM_LAMBDA): RETURN (scm_closure (SCM_CDR (x), env)); - case (127 & SCM_IM_QUOTE): + case SCM_BIT8(SCM_IM_QUOTE): RETURN (SCM_CAR (SCM_CDR (x))); - case (127 & SCM_IM_SET): + case SCM_BIT8(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); @@ -1866,39 +2165,11 @@ dispatch: #endif - case (127 & SCM_IM_DEFINE): /* only for internal defines */ - x = SCM_CDR (x); - proc = SCM_CAR (x); - x = SCM_CDR (x); - x = evalcar (x, env); -#ifdef DEBUG_EXTENSIONS - if (SCM_REC_PROCNAMES_P && SCM_NIMP (x)) - { - t.arg1 = x; - proc: - if (SCM_CLOSUREP (t.arg1) - /* Only the first definition determines the name. */ - && (scm_procedure_property (t.arg1, scm_i_inner_name) - == SCM_BOOL_F)) - scm_set_procedure_property_x (t.arg1, scm_i_inner_name, proc); - else if (SCM_TYP16 (t.arg1) == scm_tc16_macro - && SCM_CDR (t.arg1) != t.arg1) - { - t.arg1 = SCM_CDR (t.arg1); - goto 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); - + case SCM_BIT8(SCM_IM_DEFINE): /* only for internal defines */ + scm_misc_error (NULL, "Bad define placement", SCM_EOL); /* new syntactic forms go here. */ - case (127 & SCM_MAKISYM (0)): + case SCM_BIT8(SCM_MAKISYM (0)): proc = SCM_CAR (x); SCM_ASRTGO (SCM_ISYMP (proc), badfun); switch SCM_ISYMNUM (proc) @@ -1929,10 +2200,11 @@ dispatch: #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 + ENTER_APPLY; /* Copy argument list */ if (SCM_IMP (t.arg1)) argl = t.arg1; @@ -1953,16 +2225,16 @@ dispatch: x = SCM_CODE (proc); goto cdrxbegin; } - proc = scm_i_apply; + proc = scm_f_apply; goto evapply; case (SCM_ISYMNUM (SCM_IM_CONT)): scm_make_cont (&t.arg1); - if (safe_setjmp (SCM_JMPBUF (t.arg1))) + if (setjmp (SCM_JMPBUF (t.arg1))) { SCM val; val = SCM_THROW_VALUE (t.arg1); - RETURN (val); + RETURN (val) } proc = SCM_CDR (x); proc = evalcar (proc, env); @@ -1971,6 +2243,213 @@ 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_EQ_P (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_PACK (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))] + = SCM_UNPACK (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_lisp_nil)) + { + if (SCM_EQ_P (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_lisp_nil + : proc) + + case (SCM_ISYMNUM (SCM_IM_T_IFY)): + x = SCM_CDR (x); + RETURN (SCM_NFALSEP (EVALCAR (x, env)) ? scm_lisp_t : scm_lisp_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_EQ_P (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_PACK (SCM_UNPACK (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_PACK (SCM_UNPACK (SCM_CAR (t.arg1)) - 1L), + SCM_CAR (arg2)); + t.arg1 = SCM_CDR (t.arg1); + arg2 = SCM_CDR (arg2); + } + + RETURN (proc) + default: goto badfun; } @@ -1980,10 +2459,11 @@ dispatch: badfun: /* scm_everr (x, env,...) */ scm_misc_error (NULL, - "Wrong type to apply: %S", + "Wrong type to apply: ~S", 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: @@ -1992,22 +2472,27 @@ 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_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); #ifdef MEMOIZE_LOCALS - case (127 & SCM_ILOC00): + case SCM_BIT8(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 @@ -2017,9 +2502,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 @@ -2030,7 +2518,7 @@ dispatch: if (SCM_SYMBOLP (SCM_CAR (x))) { #ifdef USE_THREADS - t.lloc = scm_lookupcar1 (x, env); + t.lloc = scm_lookupcar1 (x, env, 1); if (t.lloc == NULL) { /* we have lost the race, start again. */ @@ -2038,7 +2526,7 @@ dispatch: } proc = *t.lloc; #else - proc = *scm_lookupcar (x, env); + proc = *scm_lookupcar (x, env, 1); #endif if (SCM_IMP (proc)) @@ -2051,10 +2539,18 @@ dispatch: unmemocar (x, env); handle_a_macro: +#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)); - switch ((int) (SCM_CAR (proc) >> 16)) +#ifdef DEVAL + SCM_CLEAR_MACROEXP (debug); +#endif + switch ((int) (SCM_UNPACK_CAR (proc) >> 16)) { case 2: if (scm_ilength (t.arg1) <= 0) @@ -2079,9 +2575,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)); @@ -2099,8 +2595,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)) @@ -2129,6 +2625,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: @@ -2151,32 +2648,39 @@ 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_I_OPERATORP (proc)) + if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) { - x = (SCM_I_ENTITYP (proc) - ? SCM_ENTITY_PROC_0 (proc) - : SCM_OPERATOR_PROC_0 (proc)); - if (SCM_NIMP (x)) - { - if (SCM_TYP7 (x) == scm_tc7_subr_1) - RETURN (SCM_SUBRF (x) (proc)) - else if (SCM_CLOSUREP (x)) - { - t.arg1 = proc; - proc = x; + 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.args = scm_cons (t.arg1, SCM_EOL); - debug.info->a.proc = proc; + debug.info->a.proc = proc; + debug.info->a.args = scm_cons (t.arg1, SCM_EOL); #endif - goto clos1; - } - } - /* Fall through. */ + if (SCM_NIMP (proc)) + goto evap1; + else + goto badfun; } case scm_tc7_contin: case scm_tc7_subr_1: @@ -2198,11 +2702,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 @@ -2219,7 +2738,6 @@ evapply: case scm_tc7_subr_1o: RETURN (SCM_SUBRF (proc) (t.arg1)); case scm_tc7_cxr: -#ifdef SCM_FLOATS if (SCM_SUBRF (proc)) { if (SCM_INUMP (t.arg1)) @@ -2239,15 +2757,15 @@ 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); { char *chrs = SCM_CHARS (proc) + SCM_LENGTH (proc) - 1; while ('c' != *--chrs) { - SCM_ASSERT (SCM_NIMP (t.arg1) && SCM_CONSP (t.arg1), + SCM_ASSERT (SCM_CONSP (t.arg1), t.arg1, SCM_ARG1, SCM_CHARS (proc)); t.arg1 = ('a' == *chrs) ? SCM_CAR (t.arg1) : SCM_CDR (t.arg1); } @@ -2274,8 +2792,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: + /* clos1: */ x = SCM_CODE (proc); #ifdef DEVAL env = EXTEND_ENV (SCM_CAR (x), debug.info->a.args, SCM_ENV (proc)); @@ -2283,33 +2807,37 @@ evapply: env = EXTEND_ENV (SCM_CAR (x), scm_cons (t.arg1, SCM_EOL), SCM_ENV (proc)); #endif goto cdrxbegin; + case scm_tc7_contin: + scm_call_continuation (proc, t.arg1); case scm_tcs_cons_gloc: - if (SCM_I_OPERATORP (proc)) + if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) { - x = (SCM_I_ENTITYP (proc) - ? SCM_ENTITY_PROC_1 (proc) - : SCM_OPERATOR_PROC_1 (proc)); - if (SCM_NIMP (x)) - { - if (SCM_TYP7 (x) == scm_tc7_subr_2) - RETURN (SCM_SUBRF (x) (proc, t.arg1)) - else if (SCM_CLOSUREP (x)) - { - arg2 = t.arg1; - t.arg1 = proc; - proc = x; + x = SCM_ENTITY_PROCEDURE (proc); #ifdef DEVAL - debug.info->a.args = scm_cons (t.arg1, - debug.info->a.args); - debug.info->a.proc = proc; + arg2 = debug.info->a.args; +#else + arg2 = scm_cons (t.arg1, SCM_EOL); #endif - goto clos2; - } - } - /* Fall through. */ + 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_contin: - scm_call_continuation (proc, t.arg1); case scm_tc7_subr_2: case scm_tc7_subr_0: case scm_tc7_subr_3: @@ -2319,12 +2847,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 @@ -2354,13 +2897,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)); @@ -2369,33 +2916,45 @@ 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_I_OPERATORP (proc)) + if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) { - x = (SCM_I_ENTITYP (proc) - ? SCM_ENTITY_PROC_2 (proc) - : SCM_OPERATOR_PROC_2 (proc)); - if (SCM_NIMP (x)) - { - if (SCM_TYP7 (x) == scm_tc7_subr_3) - RETURN (SCM_SUBRF (x) (proc, t.arg1, arg2)) - else if (SCM_CLOSUREP (x)) - { + x = SCM_ENTITY_PROCEDURE (proc); #ifdef DEVAL - SCM_SET_ARGSREADY (debug); - debug.info->a.args = scm_cons (proc, - debug.info->a.args); - debug.info->a.proc = x; -#endif - env = EXTEND_ENV (SCM_CAR (SCM_CODE (x)), - scm_cons2 (proc, t.arg1, - scm_cons (arg2, env)), - SCM_ENV (x)); - x = SCM_CODE (x); - goto cdrxbegin; - } - } - /* Fall through. */ + 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: @@ -2407,7 +2966,7 @@ evapply: default: goto badfun; case scm_tcs_closures: - clos2: + /* clos2: */ #ifdef DEVAL env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), debug.info->a.args, @@ -2420,11 +2979,17 @@ evapply: 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 @@ -2473,6 +3038,10 @@ evapply: 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)), @@ -2511,67 +3080,50 @@ evapply: RETURN (SCM_BOOL_T) #else /* BUILTIN_RPASUBR */ RETURN (SCM_APPLY (proc, t.arg1, - scm_acons (arg2, scm_eval_args (x, env), SCM_EOL))); + 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_I_OPERATORP (proc)) + if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) { - SCM p = (SCM_I_ENTITYP (proc) - ? SCM_ENTITY_PROC_3 (proc) - : SCM_OPERATOR_PROC_3 (proc)); - if (SCM_NIMP (p)) - { - if (SCM_TYP7 (p) == scm_tc7_lsubr_2) #ifdef DEVAL - RETURN (SCM_SUBRF (p) (proc, t.arg1, - scm_cons (arg2, SCM_CDDR (debug.info->a.args)))) + arg2 = debug.info->a.args; #else - RETURN (SCM_SUBRF (p) (proc, t.arg1, - scm_cons (arg2, - scm_eval_args (x, env)))) + arg2 = scm_cons2 (t.arg1, arg2, scm_eval_args (x, env, proc)); #endif - else if (SCM_CLOSUREP (p)) - { -#ifdef DEVAL - SCM_SET_ARGSREADY (debug); - debug.info->a.args = scm_cons (proc, debug.info->a.args); - debug.info->a.proc = p; - env = EXTEND_ENV (SCM_CAR (SCM_CODE (p)), - scm_cons2 (proc, t.arg1, - scm_cons (arg2, - SCM_CDDDR (debug.info->a.args))), - SCM_ENV (p)); -#else - env = EXTEND_ENV (SCM_CAR (SCM_CODE (p)), - scm_cons2 (proc, t.arg1, - scm_cons (arg2, - scm_eval_args (x, env))), - SCM_ENV (p)); -#endif - x = SCM_CODE (p); - goto cdrxbegin; - } - } - /* Fall through. */ + 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: @@ -2586,25 +3138,22 @@ 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_TRACE_P = 0; - SCM_RESET_DEBUG_MODE; SCM_CLEAR_TRACED_FRAME (debug); if (SCM_CHEAPTRAPS_P) t.arg1 = scm_make_debugobj (&debug); else { scm_make_cont (&t.arg1); - if (safe_setjmp (SCM_JMPBUF (t.arg1))) + if (setjmp (SCM_JMPBUF (t.arg1))) { proc = SCM_THROW_VALUE (t.arg1); goto ret; } } - scm_ithrow (scm_i_exit_frame, scm_cons2 (t.arg1, proc, SCM_EOL), 0); + scm_ithrow (scm_sym_exit_frame, scm_cons2 (t.arg1, proc, SCM_EOL), 0); } ret: scm_last_debug_frame = debug.prev; @@ -2618,37 +3167,6 @@ 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 arguments to apply: (apply PROC ARG1 ... ARGS) @@ -2668,21 +3186,21 @@ scm_procedure_documentation (proc) 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); - -SCM -scm_nconc2last (lst) - SCM lst; +SCM_DEFINE (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_NONEMPTYLIST (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 */ @@ -2694,21 +3212,15 @@ scm_nconc2last (lst) #if 0 SCM -scm_apply (proc, arg1, args) - SCM proc; - SCM arg1; - SCM args; +scm_apply (SCM proc, SCM arg1, SCM args) {} #endif #if 0 SCM -scm_dapply (proc, arg1, args) - SCM proc; - SCM arg1; - SCM args; -{} +scm_dapply (SCM proc, SCM arg1, SCM args) +{ /* empty */ } #endif @@ -2723,10 +3235,7 @@ scm_dapply (proc, arg1, 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 @@ -2778,27 +3287,25 @@ SCM_APPLY (proc, arg1, args) } else { - /* SCM_ASRTGO(SCM_NIMP(args) && SCM_CONSP(args), wrongnumargs); */ + /* SCM_ASRTGO(SCM_CONSP(args), wrongnumargs); */ args = scm_nconc2last (args); #ifdef DEVAL debug.vect[0].a.args = scm_cons (arg1, args); #endif } #ifdef DEVAL - 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 { scm_make_cont (&tmp); - if (safe_setjmp (SCM_JMPBUF (tmp))) + 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; @@ -2825,7 +3332,6 @@ tail: RETURN (SCM_SUBRF (proc) (arg1)) case scm_tc7_cxr: SCM_ASRTGO (SCM_NULLP (args), wrongnumargs); -#ifdef SCM_FLOATS if (SCM_SUBRF (proc)) { if (SCM_INUMP (arg1)) @@ -2838,20 +3344,19 @@ 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); { char *chrs = SCM_CHARS (proc) + SCM_LENGTH (proc) - 1; while ('c' != *--chrs) { - SCM_ASSERT (SCM_NIMP (arg1) && SCM_CONSP (arg1), + SCM_ASSERT (SCM_CONSP (arg1), arg1, SCM_ARG1, SCM_CHARS (proc)); arg1 = ('a' == *chrs) ? SCM_CAR (arg1) : SCM_CDR (arg1); } @@ -2866,7 +3371,7 @@ tail: RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args))) #endif case scm_tc7_lsubr_2: - SCM_ASRTGO (SCM_NIMP (args) && SCM_CONSP (args), wrongnumargs); + SCM_ASRTGO (SCM_CONSP (args), wrongnumargs); RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CDR (args))) case scm_tc7_asubr: if (SCM_NULLP (args)) @@ -2896,7 +3401,7 @@ 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 @@ -2907,8 +3412,7 @@ tail: else { SCM tl = args = scm_cons (SCM_CAR (arg1), SCM_UNSPECIFIED); - while (SCM_NIMP (arg1 = SCM_CDR (arg1)) - && SCM_CONSP (arg1)) + while (arg1 = SCM_CDR (arg1), SCM_CONSP (arg1)) { SCM_SETCDR (tl, scm_cons (SCM_CAR (arg1), SCM_UNSPECIFIED)); @@ -2918,10 +3422,24 @@ tail: } args = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), args, SCM_ENV (proc)); - proc = SCM_CODE (proc); - while (SCM_NNULLP (proc = SCM_CDR (proc))) - arg1 = EVALCAR (proc, args); - RETURN (arg1); + 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); @@ -2940,8 +3458,25 @@ 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_I_OPERATORP (proc)) + 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); @@ -2949,26 +3484,17 @@ tail: args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args)); #endif arg1 = proc; - proc = (SCM_NULLP (args) - ? (SCM_I_ENTITYP (proc) - ? SCM_ENTITY_PROC_0 (proc) - : SCM_OPERATOR_PROC_0 (proc)) - : SCM_NULLP (SCM_CDR (args)) - ? (SCM_I_ENTITYP (proc) - ? SCM_ENTITY_PROC_1 (proc) - : SCM_OPERATOR_PROC_1 (proc)) - : SCM_NULLP (SCM_CDDR (args)) - ? (SCM_I_ENTITYP (proc) - ? SCM_ENTITY_PROC_2 (proc) - : SCM_OPERATOR_PROC_2 (proc)) - : (SCM_I_ENTITYP (proc) - ? SCM_ENTITY_PROC_3 (proc) - : SCM_OPERATOR_PROC_3 (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 - goto tail; + if (SCM_NIMP (proc)) + goto tail; + else + goto badproc; } wrongnumargs: scm_wrong_num_args (proc); @@ -2979,24 +3505,22 @@ 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); else { scm_make_cont (&arg1); - if (safe_setjmp (SCM_JMPBUF (arg1))) + if (setjmp (SCM_JMPBUF (arg1))) { proc = SCM_THROW_VALUE (arg1); 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; @@ -3010,46 +3534,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]); } @@ -3059,34 +3625,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) { @@ -3105,9 +3670,7 @@ scm_for_each (proc, arg1, args) SCM -scm_closure (code, env) - SCM code; - SCM env; +scm_closure (SCM code, SCM env) { register SCM z; SCM_NEWCELL (z); @@ -3120,27 +3683,15 @@ scm_closure (code, env) long scm_tc16_promise; SCM -scm_makprom (code) - SCM code; +scm_makprom (SCM code) { - register SCM z; - SCM_NEWCELL (z); - SCM_DEFER_INTS; - SCM_SETCDR (z, code); - SCM_SETCAR (z, scm_tc16_promise); - SCM_ALLOW_INTS; - return z; + SCM_RETURN_NEWSMOB (scm_tc16_promise, SCM_UNPACK (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_puts ("#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; -{ - register SCM z; - SCM_NEWCELL (z); - SCM_SETCDR (z, code); - SCM_SETCAR (z, scm_tc16_macro | (2L << 16)); - return z; -} - - -SCM_PROC (s_macro_p, "macro?", 1, 0, 0, scm_macro_p); - -SCM -scm_macro_p (obj) - SCM obj; -{ - return (SCM_NIMP (obj) && SCM_TYP16 (obj) == scm_tc16_macro - ? SCM_BOOL_T - : SCM_BOOL_F); -} - - -SCM_SYMBOL (scm_sym_syntax, "syntax"); -SCM_SYMBOL (scm_sym_macro, "macro"); -SCM_SYMBOL (scm_sym_mmacro, "macro!"); - -SCM_PROC (s_macro_type, "macro-type", 1, 0, 0, scm_macro_type); - -SCM -scm_macro_type (m) - SCM m; -{ - if (!(SCM_NIMP (m) && SCM_TYP16 (m) == scm_tc16_macro)) - return SCM_BOOL_F; - switch ((int) (SCM_CAR (m) >> 16)) - { - case 0: return scm_sym_syntax; - case 1: return scm_sym_macro; - case 2: return scm_sym_mmacro; - default: scm_wrong_type_arg (s_macro_type, 1, m); - } -} - - -SCM_PROC (s_macro_name, "macro-name", 1, 0, 0, scm_macro_name); - -SCM -scm_macro_name (m) - SCM m; -{ - SCM_ASSERT (SCM_NIMP (m) && SCM_TYP16 (m) == scm_tc16_macro, - m, - SCM_ARG1, - s_macro_name); - return scm_procedure_name (SCM_CDR (m)); -} - - -SCM_PROC (s_macro_transformer, "macro-transformer", 1, 0, 0, scm_macro_transformer); - -SCM -scm_macro_transformer (m) - SCM m; -{ - SCM_ASSERT (SCM_NIMP (m) && SCM_TYP16 (m) == scm_tc16_macro, - m, - SCM_ARG1, - s_macro_transformer); - return SCM_CLOSUREP (SCM_CDR (m)) ? SCM_CDR (m) : SCM_BOOL_F; -} - - - -SCM_PROC(s_force, "force", 1, 0, 0, scm_force); - -SCM -scm_force (x) - SCM x; +SCM_DEFINE (scm_force, "force", 1, 0, 0, + (SCM x), + "") +#define FUNC_NAME s_scm_force { - SCM_ASSERT ((SCM_TYP16 (x) == scm_tc16_promise), x, SCM_ARG1, s_force); - if (!((1L << 16) & SCM_CAR (x))) + SCM_VALIDATE_SMOB (1,x,promise); + if (!((1L << 16) & SCM_UNPACK_CAR (x))) { SCM ans = scm_apply (SCM_CDR (x), SCM_EOL, SCM_EOL); - if (!((1L << 16) & SCM_CAR (x))) + if (!((1L << 16) & SCM_UNPACK_CAR (x))) { SCM_DEFER_INTS; SCM_SETCDR (x, ans); @@ -3277,40 +3722,62 @@ 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; +SCM_DEFINE (scm_promise_p, "promise?", 1, 0, 0, + (SCM x), + "Return true if @var{obj} is a promise, i.e. a delayed computation\n" + "(@pxref{Delayed evaluation,,,r4rs.info,The Revised^4 Report on Scheme}).") +#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); +SCM_DEFINE (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; +SCM_DEFINE (scm_copy_tree, "copy-tree", 1, 0, 0, + (SCM obj), + "Recursively copy the data tree that is bound to @var{obj}, and return a\n" + "pointer to the new data structure. @code{copy-tree} recurses down the\n" + "contents of both pairs and vectors (since both cons cells and vector\n" + "cells may point to arbitrary objects), and stops recursing when it hits\n" + "any other object.") +#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); - while (SCM_NIMP (obj = SCM_CDR (obj)) && SCM_CONSP (obj)) + ans = tl = scm_cons_source (obj, + scm_copy_tree (SCM_CAR (obj)), + SCM_UNSPECIFIED); + while (obj = SCM_CDR (obj), SCM_CONSP (obj)) { SCM_SETCDR (tl, scm_cons (scm_copy_tree (SCM_CAR (obj)), SCM_UNSPECIFIED)); @@ -3319,104 +3786,54 @@ 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); -} - - -SCM -scm_top_level_env (thunk) - SCM thunk; -{ - if (SCM_IMP(thunk)) - return SCM_EOL; - else - return scm_cons(thunk, (SCM)SCM_EOL); + return SCM_XEVAL (obj, env); } -SCM_PROC(s_eval2, "eval2", 2, 0, 0, scm_eval2); - -SCM -scm_eval2 (obj, env_thunk) - SCM obj; - SCM env_thunk; +SCM_DEFINE (scm_eval2, "eval2", 2, 0, 0, + (SCM obj, SCM env_thunk), + "Evaluate @var{exp}, a Scheme expression, in the environment designated\n" + "by @var{lookup}, a symbol-lookup function. @code{(eval exp)} is\n" + "equivalent to @code{(eval2 exp *top-level-lookup-closure*)}.") +#define FUNC_NAME s_scm_eval2 { - return scm_eval_3 (obj, 1, scm_top_level_env(env_thunk)); + return scm_eval_3 (obj, 1, scm_top_level_env (env_thunk)); } +#undef FUNC_NAME -SCM_PROC(s_eval, "eval", 1, 0, 0, scm_eval); - -SCM -scm_eval (obj) - SCM obj; +SCM_DEFINE (scm_eval, "eval", 1, 0, 0, + (SCM obj), + "Evaluate @var{exp}, a list representing a Scheme expression, in the\n" + "top-level environment.") +#define FUNC_NAME s_scm_eval { - return - scm_eval_3(obj, 1, scm_top_level_env(SCM_CDR(scm_top_level_lookup_closure_var))); + 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_x, "eval!", 1, 0, 0, scm_eval_x); */ +/* +SCM_REGISTER_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_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}; - -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))); } @@ -3440,49 +3857,37 @@ scm_init_eval () scm_eval_opts, SCM_N_EVAL_OPTIONS); - scm_tc16_promise = scm_newsmob (&promsmob); - scm_tc16_macro = scm_newsmob (¯osmob); - scm_i_apply = scm_make_subr ("apply", scm_tc7_lsubr_2, scm_apply); - scm_system_transformer = scm_sysintern ("scm:eval-transformer", SCM_UNDEFINED); - scm_i_dot = SCM_CAR (scm_sysintern (".", SCM_UNDEFINED)); - scm_i_arrow = SCM_CAR (scm_sysintern ("=>", SCM_UNDEFINED)); - scm_i_else = SCM_CAR (scm_sysintern ("else", SCM_UNDEFINED)); - scm_i_unquote = SCM_CAR (scm_sysintern ("unquote", SCM_UNDEFINED)); - scm_i_uq_splicing = SCM_CAR (scm_sysintern ("unquote-splicing", SCM_UNDEFINED)); + 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_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_lisp_nil = scm_sysintern ("nil", SCM_UNDEFINED); + SCM_SETCDR (scm_lisp_nil, SCM_CAR (scm_lisp_nil)); + scm_lisp_nil = SCM_CAR (scm_lisp_nil); + scm_lisp_t = scm_sysintern ("t", SCM_UNDEFINED); + SCM_SETCDR (scm_lisp_t, SCM_CAR (scm_lisp_t)); + scm_lisp_t = SCM_CAR (scm_lisp_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" @@ -3491,3 +3896,9 @@ scm_init_eval () } #endif /* !DEVAL */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/