X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/3eeba8d4f523f0c823a11484a36ac0100eed9be7..d8c40b9f49836a0d8c28b49ff5346033c50e113d:/libguile/eval.c diff --git a/libguile/eval.c b/libguile/eval.c index a83bab5b3..c17e4787d 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998 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,7 +86,6 @@ char *alloca (); #include "continuations.h" #include "throw.h" #include "smob.h" -#include "markers.h" #include "macros.h" #include "procprop.h" #include "hashtab.h" @@ -90,9 +93,18 @@ char *alloca (); #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. @@ -132,26 +144,24 @@ char *alloca (); */ #define SCM_CEVAL scm_ceval -#define SIDEVAL(x, env) if SCM_NIMP(x) SCM_CEVAL((x), (env)) +#define SIDEVAL(x, env) if (SCM_NIMP (x)) SCM_CEVAL((x), (env)) -#define EVALCELLCAR(x, env) (SCM_SYMBOLP (SCM_CAR(x)) \ - ? *scm_lookupcar(x, env) \ - : SCM_CEVAL(SCM_CAR(x), env)) +#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 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; @@ -238,16 +248,24 @@ 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) +scm_lookupcar1 (SCM vloc, SCM genv, int check) #else SCM * -scm_lookupcar (SCM vloc, SCM genv) +scm_lookupcar (SCM vloc, SCM genv, int check) #endif { SCM env = genv; @@ -260,18 +278,18 @@ scm_lookupcar (SCM vloc, SCM 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); @@ -282,7 +300,7 @@ scm_lookupcar (SCM vloc, SCM genv) break; } al = SCM_CDRLOC (*al); - if (SCM_CAR (fl) == var) + if (SCM_EQ_P (SCM_CAR (fl), var)) { #ifdef MEMOIZE_LOCALS #ifndef SCM_RECKLESS /* letrec inits to SCM_UNDEFINED */ @@ -305,7 +323,7 @@ scm_lookupcar (SCM vloc, SCM genv) #endif } #ifdef MEMOIZE_LOCALS - iloc = (~SCM_IDSTMSK) & (iloc + SCM_IFRINC); + iloc = SCM_PACK ((~SCM_IDSTMSK) & SCM_UNPACK(iloc + SCM_IFRINC)); #endif } { @@ -318,7 +336,7 @@ scm_lookupcar (SCM vloc, SCM 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; @@ -329,11 +347,17 @@ scm_lookupcar (SCM vloc, SCM genv) 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 @@ -344,10 +368,10 @@ scm_lookupcar (SCM vloc, SCM 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 @@ -367,11 +391,9 @@ scm_lookupcar (SCM vloc, SCM 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; @@ -381,9 +403,7 @@ scm_lookupcar (vloc, genv) #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; @@ -393,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)) @@ -413,9 +433,7 @@ scm_unmemocar (form, env) SCM -scm_eval_car (pair, env) - SCM pair; - SCM env; +scm_eval_car (SCM pair, SCM env) { return SCM_XEVALCAR (pair, env); } @@ -434,50 +452,82 @@ 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_i_dot, scm_i_arrow, scm_i_else, scm_i_unquote, scm_i_uq_splicing, scm_i_apply; +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, 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_i_quote,s_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) { + 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, SCM_CDR (xorig)); + return scm_cons (SCM_IM_QUOTE, x); } SCM_SYNTAX(s_begin, "begin", scm_makmmacro, scm_m_begin); -SCM_SYMBOL(scm_i_begin, s_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) { SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) >= 1, xorig, scm_s_expression, s_begin); @@ -485,12 +535,10 @@ scm_m_begin (xorig, env) } SCM_SYNTAX(s_if, "if", scm_makmmacro, scm_m_if); -SCM_SYMBOL(scm_i_if, s_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)); SCM_ASSYNT (len >= 2 && len <= 3, xorig, scm_s_expression, "if"); @@ -498,28 +546,26 @@ scm_m_if (xorig, env) } -SCM_SYNTAX(s_set,"set!", scm_makmmacro, scm_m_set); -SCM_SYMBOL(scm_i_set,s_set); +/* 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); - SCM_ASSYNT (2 == scm_ilength (x), xorig, scm_s_expression, s_set); - SCM_ASSYNT (SCM_NIMP (SCM_CAR (x)) && SCM_SYMBOLP (SCM_CAR (x)), - xorig, scm_s_variable, s_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); SCM_ASSYNT (1 == scm_ilength (x), xorig, scm_s_expression, s_vref); @@ -527,21 +573,18 @@ scm_m_vref (xorig, env) { /* 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)); } SCM_ASSYNT (SCM_NIMP(x) && DEFSCM_VARIABLEP (SCM_CAR (x)), xorig, scm_s_variable, s_vref); - return 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); SCM_ASSYNT (3 == scm_ilength (x), xorig, scm_s_expression, s_vset); @@ -554,12 +597,10 @@ scm_m_vset (xorig, env) SCM_SYNTAX(s_and, "and", scm_makmmacro, scm_m_and); -SCM_GLOBAL_SYMBOL(scm_i_and, s_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)); SCM_ASSYNT (len >= 0, xorig, scm_s_test, s_and); @@ -570,12 +611,10 @@ scm_m_and (xorig, env) } SCM_SYNTAX(s_or,"or", scm_makmmacro, scm_m_or); -SCM_SYMBOL(scm_i_or,s_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)); SCM_ASSYNT (len >= 0, xorig, scm_s_test, s_or); @@ -587,37 +626,33 @@ scm_m_or (xorig, env) SCM_SYNTAX(s_case, "case", scm_makmmacro, scm_m_case); -SCM_SYMBOL(scm_i_case, s_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); + 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); SCM_ASSYNT (scm_ilength (proc) >= 2, xorig, scm_s_clauses, s_case); SCM_ASSYNT (scm_ilength (SCM_CAR (proc)) >= 0 - || scm_i_else == SCM_CAR (proc), + || 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_SYMBOL(scm_i_cond, s_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); SCM_ASSYNT (len >= 1, xorig, scm_s_clauses, s_cond); while (SCM_NIMP (x)) @@ -625,27 +660,25 @@ scm_m_cond (xorig, env) arg1 = SCM_CAR (x); len = scm_ilength (arg1); SCM_ASSYNT (len >= 1, xorig, scm_s_clauses, s_cond); - if (scm_i_else == SCM_CAR (arg1)) + if (SCM_EQ_P (scm_sym_else, SCM_CAR (arg1))) { 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))) + 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_i_lambda, s_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) @@ -653,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)) @@ -668,45 +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, scm_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_SYMBOL(scm_i_letstar,s_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); SCM_ASSYNT (len >= 2, xorig, scm_s_body, s_letstar); proc = SCM_CAR (x); SCM_ASSYNT (scm_ilength (proc) >= 0, xorig, scm_s_bindings, s_letstar); - while SCM_NIMP (proc) + while (SCM_NIMP (proc)) { arg1 = SCM_CAR (proc); SCM_ASSYNT (2 == scm_ilength (arg1), xorig, scm_s_bindings, s_letstar); - SCM_ASSYNT (SCM_NIMP (SCM_CAR (arg1)) && SCM_SYMBOLP (SCM_CAR (arg1)), - xorig, scm_s_variable, s_letstar); + 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), s_letstar); - 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 @@ -724,12 +760,10 @@ scm_m_letstar (xorig, env) */ SCM_SYNTAX(s_do, "do", scm_makmmacro, scm_m_do); -SCM_SYMBOL(scm_i_do, s_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; @@ -738,14 +772,12 @@ scm_m_do (xorig, env) SCM_ASSYNT (len >= 2, xorig, scm_s_test, "do"); proc = SCM_CAR (x); SCM_ASSYNT (scm_ilength (proc) >= 0, xorig, scm_s_bindings, "do"); - while SCM_NIMP - (proc) + while (SCM_NIMP(proc)) { arg1 = SCM_CAR (proc); len = scm_ilength (arg1); SCM_ASSYNT (2 == len || 3 == len, xorig, scm_s_bindings, "do"); - SCM_ASSYNT (SCM_NIMP (SCM_CAR (arg1)) && SCM_SYMBOLP (SCM_CAR (arg1)), - xorig, scm_s_variable, "do"); + 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); @@ -770,15 +802,13 @@ 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_i_quasiquote, s_quasiquote); +SCM_GLOBAL_SYMBOL(scm_sym_quasiquote, s_quasiquote); SCM -scm_m_quasiquote (xorig, env) - SCM xorig; - SCM env; +scm_m_quasiquote (SCM xorig, SCM env) { SCM x = SCM_CDR (xorig); SCM_ASSYNT (scm_ilength (x) == 1, xorig, scm_s_expression, s_quasiquote); @@ -787,15 +817,12 @@ scm_m_quasiquote (xorig, env) 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); @@ -805,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) @@ -835,40 +862,22 @@ iqq (form, env, depth) /* Here are acros which return values rather than code. */ -SCM_SYNTAX(s_delay, "delay", scm_makacro, scm_m_delay); +SCM_SYNTAX (s_delay, "delay", scm_makmmacro, scm_m_delay); +SCM_GLOBAL_SYMBOL (scm_sym_delay, s_delay); SCM -scm_m_delay (xorig, env) - SCM xorig; - SCM env; +scm_m_delay (SCM xorig, SCM env) { SCM_ASSYNT (scm_ilength (xorig) == 2, xorig, scm_s_expression, s_delay); - xorig = SCM_CDR (xorig); - return scm_makprom (scm_closure (scm_cons2 (SCM_EOL, SCM_CAR (xorig), SCM_CDR (xorig)), - env)); + return scm_cons2 (SCM_IM_DELAY, SCM_EOL, SCM_CDR (xorig)); } -SCM -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_SYMBOL(scm_i_define, s_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); @@ -876,12 +885,12 @@ scm_m_define (x, env) 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); } - SCM_ASSYNT (SCM_NIMP (proc) && SCM_SYMBOLP (proc), + 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)) @@ -894,10 +903,10 @@ 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; @@ -917,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 @@ -927,49 +936,57 @@ scm_m_define (x, env) /* end of acros */ -SCM_SYNTAX(s_letrec, "letrec", scm_makmmacro, scm_m_letrec); -SCM_SYMBOL(scm_i_letrec, s_letrec); - -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, scm_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, scm_s_bindings); do { /* vars scm_list reversed here, inits reversed at evaluation */ arg1 = SCM_CAR (proc); ASRTSYNTAX (2 == scm_ilength (arg1), scm_s_bindings); - ASRTSYNTAX (SCM_NIMP (SCM_CAR (arg1)) && SCM_SYMBOLP (SCM_CAR (arg1)), scm_s_variable); + 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_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_SYMBOL(scm_i_let, s_let); +SCM_GLOBAL_SYMBOL(scm_sym_let, s_let); SCM -scm_m_let (xorig, env) - SCM xorig; - SCM env; +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 */ @@ -978,25 +995,36 @@ scm_m_let (xorig, env) 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 */ + || (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_cons (SCM_IM_LET, SCM_CDR (scm_m_letrec (xorig, env))); + 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, scm_s_bindings, s_let); /* bad let */ name = proc; /* named let, build equiv letrec */ x = SCM_CDR (x); SCM_ASSYNT (scm_ilength (x) >= 2, xorig, scm_s_body, s_let); - proc = SCM_CAR (x); /* bindings scm_list */ + proc = SCM_CAR (x); /* bindings list */ SCM_ASSYNT (scm_ilength (proc) >= 0, xorig, scm_s_bindings, s_let); - while SCM_NIMP - (proc) + while (SCM_NIMP (proc)) { /* vars and inits both in order */ arg1 = SCM_CAR (proc); SCM_ASSYNT (2 == scm_ilength (arg1), xorig, scm_s_bindings, s_let); - SCM_ASSYNT (SCM_NIMP (SCM_CAR (arg1)) && SCM_SYMBOLP (SCM_CAR (arg1)), + 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); @@ -1004,21 +1032,22 @@ scm_m_let (xorig, env) 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_SYMBOL(scm_i_atapply, s_atapply); +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) { SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2, xorig, scm_s_expression, s_atapply); @@ -1027,19 +1056,233 @@ scm_m_apply (xorig, env) SCM_SYNTAX(s_atcall_cc,"@call-with-current-continuation", scm_makmmacro, scm_m_cont); -SCM_SYMBOL(scm_i_atcall_cc,s_atcall_cc); +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) { 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 @@ -1049,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 @@ -1067,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); @@ -1116,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); @@ -1149,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 @@ -1162,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: */ ; @@ -1217,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)); @@ -1232,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 @@ -1247,17 +1507,14 @@ scm_unmemocopy (x, env) #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); } @@ -1268,10 +1525,7 @@ scm_badargsp (formals, args) SCM -scm_eval_args (l, env, proc) - SCM l; - SCM env; - SCM proc; +scm_eval_args (SCM l, SCM env, SCM proc) { SCM results = SCM_EOL, *lloc = &results, res; while (SCM_NIMP (l)) @@ -1310,6 +1564,29 @@ scm_eval_args (l, env, proc) return results; } +SCM +scm_eval_body (SCM code, SCM env) +{ + SCM next; + again: + next = code; + while (SCM_NNULLP (next = SCM_CDR (next))) + { + if (SCM_IMP (SCM_CAR (code))) + { + if (SCM_ISYMP (SCM_CAR (code))) + { + code = scm_m_expand_body (code, env); + goto again; + } + } + else + SCM_XEVAL (SCM_CAR (code), env); + code = next; + } + return SCM_XEVALCAR (code, env); +} + #endif /* !DEVAL */ @@ -1342,26 +1619,26 @@ scm_eval_args (l, env, proc) { ++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 && 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); \ if (SCM_CHEAPTRAPS_P)\ {\ tmp = scm_make_debugobj (&debug);\ - scm_ithrow (scm_i_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\ + scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\ }\ else\ {\ scm_make_cont (&tmp);\ if (!setjmp (SCM_JMPBUF (tmp)))\ - scm_ithrow (scm_i_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\ + scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\ }\ }\ -} +} while (0) #undef RETURN #define RETURN(e) {proc = (e); goto exit;} #ifdef STACK_CHECKING @@ -1377,7 +1654,7 @@ scm_eval_args (l, env, proc) */ -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 @@ -1413,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." }, @@ -1431,42 +1709,42 @@ scm_option scm_evaluator_trap_table[] = { { 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 (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, proc, lloc) - SCM l, env, proc, *lloc; +scm_deval_args (SCM l, SCM env, SCM proc, SCM *lloc) { SCM *results = lloc, res; while (SCM_NIMP (l)) @@ -1512,11 +1790,7 @@ scm_deval_args (l, env, proc, 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 */ @@ -1528,24 +1802,18 @@ scm_deval_args (l, env, proc, 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 { @@ -1558,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; @@ -1565,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; @@ -1585,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); @@ -1596,7 +1880,7 @@ start: 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); if (SCM_CHEAPTRAPS_P) t.arg1 = scm_make_debugobj (&debug); @@ -1616,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); @@ -1634,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))) @@ -1647,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: @@ -1657,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; } @@ -1671,20 +1964,20 @@ dispatch: 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); @@ -1705,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); @@ -1717,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; @@ -1733,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 */ @@ -1746,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)); } @@ -1762,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); @@ -1774,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; @@ -1788,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); @@ -1803,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)) @@ -1820,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))) @@ -1836,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); @@ -1870,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) @@ -1958,7 +2225,7 @@ dispatch: x = SCM_CODE (proc); goto cdrxbegin; } - proc = scm_i_apply; + proc = scm_f_apply; goto evapply; case (SCM_ISYMNUM (SCM_IM_CONT)): @@ -1967,7 +2234,7 @@ dispatch: { SCM val; val = SCM_THROW_VALUE (t.arg1); - RETURN (val); + RETURN (val) } proc = SCM_CDR (x); proc = evalcar (proc, env); @@ -1976,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; } @@ -1985,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: @@ -1997,8 +2472,9 @@ 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: @@ -2007,11 +2483,12 @@ dispatch: #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 SCM_RECKLESS @@ -2041,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. */ @@ -2049,7 +2526,7 @@ dispatch: } proc = *t.lloc; #else - proc = *scm_lookupcar (x, env); + proc = *scm_lookupcar (x, env, 1); #endif if (SCM_IMP (proc)) @@ -2073,7 +2550,7 @@ dispatch: #ifdef DEVAL SCM_CLEAR_MACROEXP (debug); #endif - switch ((int) (SCM_CAR (proc) >> 16)) + switch ((int) (SCM_UNPACK_CAR (proc) >> 16)) { case 2: if (scm_ilength (t.arg1) <= 0) @@ -2098,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)); @@ -2148,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: @@ -2170,34 +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_ENTITY_PROCEDURE (proc); + arg2 = SCM_EOL; + goto type_dispatch; + } + else if (!SCM_I_OPERATORP (proc)) goto badfun; else { - 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; + 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: @@ -2255,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)) @@ -2275,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); } @@ -2310,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)); @@ -2322,31 +2810,33 @@ evapply: 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_ENTITY_PROCEDURE (proc); +#ifdef DEVAL + arg2 = debug.info->a.args; +#else + arg2 = scm_cons (t.arg1, SCM_EOL); +#endif + goto type_dispatch; + } + else if (!SCM_I_OPERATORP (proc)) goto badfun; else { - 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; + 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; + debug.info->a.args = scm_cons (t.arg1, debug.info->a.args); + debug.info->a.proc = proc; #endif - goto clos2; - } - } - /* Fall through. */ + if (SCM_NIMP (proc)) + goto evap2; + else + goto badfun; } case scm_tc7_subr_2: case scm_tc7_subr_0: @@ -2407,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, proc), - 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)); @@ -2422,35 +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_ENTITY_PROCEDURE (proc); +#ifdef DEVAL + arg2 = debug.info->a.args; +#else + arg2 = scm_cons2 (t.arg1, arg2, SCM_EOL); +#endif + goto type_dispatch; + } + else if (!SCM_I_OPERATORP (proc)) goto badfun; else { - 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)) - { + operatorn: #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, SCM_EOL)), - SCM_ENV (x)); - x = SCM_CODE (x); - goto cdrxbegin; - } - } - /* Fall through. */ + 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: @@ -2462,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, @@ -2485,6 +2989,7 @@ evapply: SCM_CDRLOC (SCM_CDR (debug.info->a.args)))); #endif ENTER_APPLY; + evap3: switch (SCM_TYP7 (proc)) { /* have 3 or more arguments */ #ifdef DEVAL @@ -2533,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)), @@ -2585,6 +3094,9 @@ evapply: 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); @@ -2598,48 +3110,20 @@ evapply: goto cdrxbegin; #endif /* DEVAL */ case scm_tcs_cons_gloc: - if (!SCM_I_OPERATORP (proc)) - goto badfun; - else + 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, proc)))) + 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, proc))), - 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: @@ -2669,7 +3153,7 @@ exit: goto ret; } } - scm_ithrow (scm_i_exit_frame, scm_cons2 (t.arg1, proc, SCM_EOL), 0); + scm_ithrow (scm_sym_exit_frame, scm_cons2 (t.arg1, proc, SCM_EOL), 0); } ret: scm_last_debug_frame = debug.prev; @@ -2702,21 +3186,21 @@ ret: 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 */ @@ -2728,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 @@ -2757,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 @@ -2812,7 +3287,7 @@ 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); @@ -2830,7 +3305,7 @@ SCM_APPLY (proc, arg1, args) if (setjmp (SCM_JMPBUF (tmp))) goto entap; } - scm_ithrow (scm_i_enter_frame, scm_cons (tmp, SCM_EOL), 0); + scm_ithrow (scm_sym_enter_frame, scm_cons (tmp, SCM_EOL), 0); } entap: ENTER_APPLY; @@ -2857,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)) @@ -2870,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); } @@ -2898,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)) @@ -2939,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)); @@ -2950,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); @@ -2972,8 +3458,23 @@ 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 { @@ -2983,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); @@ -3028,7 +3520,7 @@ exit: goto ret; } } - scm_ithrow (scm_i_exit_frame, scm_cons2 (arg1, proc, SCM_EOL), 0); + scm_ithrow (scm_sym_exit_frame, scm_cons2 (arg1, proc, SCM_EOL), 0); } ret: scm_last_debug_frame = debug.prev; @@ -3042,7 +3534,43 @@ 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 @@ -3052,43 +3580,42 @@ SCM_PROC (s_map, "map", 2, 0, 1, scm_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 SCM_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); + 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]); } @@ -3098,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 SCM_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); + check_map_args (args, len, g_for_each, proc, arg1, s_for_each); #endif while (1) { @@ -3144,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); @@ -3159,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_ENTER_A_SECTION; - SCM_SETCDR (z, code); - SCM_SETCAR (z, scm_tc16_promise); - SCM_EXIT_A_SECTION; - 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 ("#", SCM_UNDEFINED)); - scm_i_else = SCM_CAR (scm_sysintern ("else", SCM_UNDEFINED)); - scm_i_unquote = SCM_CAR (scm_sysintern ("unquote", SCM_UNDEFINED)); - scm_i_uq_splicing = SCM_CAR (scm_sysintern ("unquote-splicing", SCM_UNDEFINED)); - + scm_sym_dot = SCM_CAR (scm_sysintern (".", SCM_UNDEFINED)); + scm_sym_arrow = SCM_CAR (scm_sysintern ("=>", SCM_UNDEFINED)); + scm_sym_else = SCM_CAR (scm_sysintern ("else", SCM_UNDEFINED)); + scm_sym_unquote = SCM_CAR (scm_sysintern ("unquote", SCM_UNDEFINED)); + scm_sym_uq_splicing = SCM_CAR (scm_sysintern ("unquote-splicing", SCM_UNDEFINED)); + + scm_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 */ /* end of acros */ @@ -3359,10 +3884,10 @@ scm_init_eval () scm_can_use_top_level_lookup_closure_var = 1; #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" @@ -3371,3 +3896,9 @@ scm_init_eval () } #endif /* !DEVAL */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/