X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/311f67823da38891c829ccd84f982c8b844b51c1..277ee0fa4c63602f66fd1dd976ade36b116db297:/libguile/eval.c diff --git a/libguile/eval.c b/libguile/eval.c index 4e272cb51..554c14e0b 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002, 2003 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 @@ -39,7 +39,6 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ - /* This file is read twice in order to produce debugging versions of @@ -53,10 +52,13 @@ /* SECTION: This code is compiled once. */ -#ifndef DEVAL +#if HAVE_CONFIG_H +# include +#endif + +#include "libguile/__scm.h" -/* We need this to get the definitions for HAVE_ALLOCA_H, etc. */ -#include "libguile/scmconfig.h" +#ifndef DEVAL /* AIX requires this to be the first thing in the file. The #pragma directive is indented so pre-ANSI compilers will ignore it, rather @@ -81,6 +83,7 @@ char *alloca (); #include "libguile/alist.h" #include "libguile/eq.h" #include "libguile/continuations.h" +#include "libguile/futures.h" #include "libguile/throw.h" #include "libguile/smob.h" #include "libguile/macros.h" @@ -97,10 +100,12 @@ char *alloca (); #include "libguile/root.h" #include "libguile/vectors.h" #include "libguile/fluids.h" +#include "libguile/goops.h" #include "libguile/values.h" #include "libguile/validate.h" #include "libguile/eval.h" +#include "libguile/lang.h" @@ -122,18 +127,11 @@ char *alloca (); * Originally, it is defined to scm_ceval, but is redefined to * scm_deval during the second pass. * - * SIDEVAL corresponds to SCM_CEVAL, but is used in situations where - * only side effects of expressions matter. All immediates are - * ignored. - * * 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. * - * EVALCELLCAR is like EVALCAR, but is used when it is known that the - * car is a lisp cell. - * * The following macros should be used in code which is read once * (where the choice of evaluator is dynamic): * @@ -149,19 +147,16 @@ char *alloca (); */ #define SCM_CEVAL scm_ceval -#define SIDEVAL(x, env) if (SCM_NIMP (x)) SCM_CEVAL((x), (env)) - -#define EVALCELLCAR(x, env) (SCM_SYMBOLP (SCM_CAR (x)) \ - ? *scm_lookupcar (x, env, 1) \ - : SCM_CEVAL (SCM_CAR (x), env)) #define EVALCAR(x, env) (SCM_IMP (SCM_CAR (x)) \ ? SCM_EVALIM (SCM_CAR (x), env) \ - : EVALCELLCAR (x, env)) + : (SCM_SYMBOLP (SCM_CAR (x)) \ + ? *scm_lookupcar (x, env, 1) \ + : SCM_CEVAL (SCM_CAR (x), env))) #define EXTEND_ENV SCM_EXTEND_ENV -#ifdef MEMOIZE_LOCALS +SCM_REC_MUTEX (source_mutex); SCM * scm_ilookup (SCM iloc, SCM env) @@ -177,9 +172,6 @@ scm_ilookup (SCM iloc, SCM env) return SCM_CDRLOC (er); return SCM_CARLOC (SCM_CDR (er)); } -#endif - -#ifdef USE_THREADS /* The Lookup Car Race - by Eva Luator @@ -248,29 +240,20 @@ scm_ilookup (SCM iloc, SCM env) reconsider the complete special form. SCM_LOOKUPCAR is still there, of course. It just calls - SCM_LOOKUPCAR1 and aborts on recieving NULL. So SCM_LOOKUPCAR + SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR should only be called when it is known that VLOC is not the first pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check for NULL. I think I've found the only places where this applies. */ -#endif /* USE_THREADS */ - SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable"); -#ifdef USE_THREADS static SCM * scm_lookupcar1 (SCM vloc, SCM genv, int check) -#else -SCM * -scm_lookupcar (SCM vloc, SCM genv, int check) -#endif { SCM env = genv; register SCM *al, fl, var = SCM_CAR (vloc); -#ifdef MEMOIZE_LOCALS register SCM iloc = SCM_ILOC00; -#endif for (; SCM_NIMP (env); env = SCM_CDR (env)) { if (!SCM_CONSP (SCM_CAR (env))) @@ -282,13 +265,9 @@ scm_lookupcar (SCM vloc, SCM genv, int check) { if (SCM_EQ_P (fl, var)) { -#ifdef MEMOIZE_LOCALS -#ifdef USE_THREADS if (! SCM_EQ_P (SCM_CAR (vloc), var)) goto race; -#endif SCM_SET_CELL_WORD_0 (vloc, SCM_UNPACK (iloc) + SCM_ICDR); -#endif return SCM_CDRLOC (*al); } else @@ -297,29 +276,19 @@ scm_lookupcar (SCM vloc, SCM genv, int check) al = SCM_CDRLOC (*al); if (SCM_EQ_P (SCM_CAR (fl), var)) { -#ifdef MEMOIZE_LOCALS -#ifndef SCM_RECKLESS /* letrec inits to SCM_UNDEFINED */ if (SCM_UNBNDP (SCM_CAR (*al))) { env = SCM_EOL; goto errout; } -#endif -#ifdef USE_THREADS if (!SCM_EQ_P (SCM_CAR (vloc), var)) goto race; -#endif SCM_SETCAR (vloc, iloc); -#endif return SCM_CARLOC (*al); } -#ifdef MEMOIZE_LOCALS iloc = SCM_PACK (SCM_UNPACK (iloc) + SCM_IDINC); -#endif } -#ifdef MEMOIZE_LOCALS iloc = SCM_PACK ((~SCM_IDSTMSK) & (SCM_UNPACK(iloc) + SCM_IFRINC)); -#endif } { SCM top_thunk, real_var; @@ -335,20 +304,18 @@ scm_lookupcar (SCM vloc, SCM genv, int check) if (SCM_FALSEP (real_var)) goto errout; -#ifndef SCM_RECKLESS if (!SCM_NULLP (env) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var))) { errout: - /* scm_everr (vloc, genv,...) */ if (check) { if (SCM_NULLP (env)) scm_error (scm_unbound_variable_key, NULL, "Unbound variable: ~S", - scm_cons (var, SCM_EOL), SCM_BOOL_F); + scm_list_1 (var), SCM_BOOL_F); else scm_misc_error (NULL, "Damaged environment: ~S", - scm_cons (var, SCM_EOL)); + scm_list_1 (var)); } else { @@ -358,9 +325,7 @@ scm_lookupcar (SCM vloc, SCM genv, int check) return &undef_object; } } -#endif -#ifdef USE_THREADS if (!SCM_EQ_P (SCM_CAR (vloc), var)) { /* Some other thread has changed the very cell we are working @@ -370,10 +335,8 @@ scm_lookupcar (SCM vloc, SCM genv, int check) var = SCM_CAR (vloc); if (SCM_VARIABLEP (var)) return SCM_VARIABLE_LOC (var); -#ifdef MEMOIZE_LOCALS if (SCM_ITAG7 (var) == SCM_ITAG7 (SCM_ILOC00)) return scm_ilookup (var, genv); -#endif /* We can't cope with anything else than variables and ilocs. When a special form has been memoized (i.e. `let' into `#@let') we return NULL and expect the calling function to do the right @@ -381,14 +344,12 @@ scm_lookupcar (SCM vloc, SCM genv, int check) the dispatch on the car of the form. */ return NULL; } -#endif /* USE_THREADS */ SCM_SETCAR (vloc, real_var); return SCM_VARIABLE_LOC (real_var); } } -#ifdef USE_THREADS SCM * scm_lookupcar (SCM vloc, SCM genv, int check) { @@ -397,7 +358,6 @@ scm_lookupcar (SCM vloc, SCM genv, int check) abort (); return loc; } -#endif #define unmemocar scm_unmemocar @@ -406,34 +366,31 @@ SCM_SYMBOL (sym_three_question_marks, "???"); SCM scm_unmemocar (SCM form, SCM env) { - SCM c; - - if (SCM_IMP (form)) + if (!SCM_CONSP (form)) return form; - c = SCM_CAR (form); - if (SCM_VARIABLEP (c)) - { - SCM sym = scm_module_reverse_lookup (scm_env_module (env), c); - if (SCM_EQ_P (sym, SCM_BOOL_F)) - sym = sym_three_question_marks; - SCM_SETCAR (form, sym); - } -#ifdef MEMOIZE_LOCALS -#ifdef DEBUG_EXTENSIONS - else if (SCM_ILOCP (c)) + else { - long ir; - - for (ir = SCM_IFRAME (c); ir != 0; --ir) - env = SCM_CDR (env); - env = SCM_CAR (SCM_CAR (env)); - for (ir = SCM_IDIST (c); ir != 0; --ir) - env = SCM_CDR (env); - SCM_SETCAR (form, SCM_ICDRP (c) ? env : SCM_CAR (env)); + SCM c = SCM_CAR (form); + if (SCM_VARIABLEP (c)) + { + SCM sym = scm_module_reverse_lookup (scm_env_module (env), c); + if (SCM_FALSEP (sym)) + sym = sym_three_question_marks; + SCM_SETCAR (form, sym); + } + else if (SCM_ILOCP (c)) + { + unsigned long int ir; + + for (ir = SCM_IFRAME (c); ir != 0; --ir) + env = SCM_CDR (env); + env = SCM_CAAR (env); + for (ir = SCM_IDIST (c); ir != 0; --ir) + env = SCM_CDR (env); + SCM_SETCAR (form, SCM_ICDRP (c) ? env : SCM_CAR (env)); + } + return form; } -#endif -#endif - return form; } @@ -458,6 +415,7 @@ const char scm_s_variable[] = "bad variable"; const char scm_s_clauses[] = "bad or missing clauses"; const char scm_s_formals[] = "bad formals"; const char scm_s_duplicate_formals[] = "duplicate formals"; +static const char s_splicing[] = "bad (non-list) result for unquote-splicing"; SCM_GLOBAL_SYMBOL (scm_sym_dot, "."); SCM_GLOBAL_SYMBOL (scm_sym_arrow, "=>"); @@ -491,7 +449,7 @@ SCM_GLOBAL_SYMBOL (scm_sym_trace, "trace"); static SCM scm_m_body (SCM op, SCM xorig, const char *what) { - SCM_ASSYNT (scm_ilength (xorig) >= 1, scm_s_expression, what); + SCM_ASSYNT (scm_ilength (xorig) >= 1, scm_s_body, what); /* Don't add another ISYM if one is present already. */ if (SCM_ISYMP (SCM_CAR (xorig))) @@ -500,70 +458,69 @@ scm_m_body (SCM op, SCM xorig, const char *what) /* Retain possible doc string. */ if (!SCM_CONSP (SCM_CAR (xorig))) { - if (!SCM_NULLP (SCM_CDR(xorig))) + if (!SCM_NULLP (SCM_CDR (xorig))) return scm_cons (SCM_CAR (xorig), - scm_m_body (op, SCM_CDR(xorig), what)); + scm_m_body (op, SCM_CDR (xorig), what)); return xorig; } return scm_cons (op, xorig); } -SCM_SYNTAX(s_quote,"quote", scm_makmmacro, scm_m_quote); -SCM_GLOBAL_SYMBOL(scm_sym_quote, s_quote); -SCM +SCM_SYNTAX (s_quote, "quote", scm_makmmacro, scm_m_quote); +SCM_GLOBAL_SYMBOL (scm_sym_quote, s_quote); + +SCM scm_m_quote (SCM xorig, SCM env SCM_UNUSED) { - SCM x = scm_copy_tree (SCM_CDR (xorig)); - SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_s_expression, s_quote); - return scm_cons (SCM_IM_QUOTE, x); + return scm_cons (SCM_IM_QUOTE, SCM_CDR (xorig)); } +SCM_SYNTAX (s_begin, "begin", scm_makmmacro, scm_m_begin); +SCM_GLOBAL_SYMBOL (scm_sym_begin, s_begin); -SCM_SYNTAX(s_begin, "begin", scm_makmmacro, scm_m_begin); -SCM_GLOBAL_SYMBOL(scm_sym_begin, s_begin); - -SCM +SCM scm_m_begin (SCM xorig, SCM env SCM_UNUSED) { - SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) >= 1, scm_s_expression, s_begin); + SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) >= 0, 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_SYNTAX (s_if, "if", scm_makmmacro, scm_m_if); +SCM_GLOBAL_SYMBOL (scm_sym_if, s_if); + +SCM scm_m_if (SCM xorig, SCM env SCM_UNUSED) { long len = scm_ilength (SCM_CDR (xorig)); - SCM_ASSYNT (len >= 2 && len <= 3, scm_s_expression, "if"); + SCM_ASSYNT (len >= 2 && len <= 3, scm_s_expression, s_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); */ +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_GLOBAL_SYMBOL (scm_sym_set_x, scm_s_set_x); -SCM +SCM scm_m_set_x (SCM xorig, SCM env SCM_UNUSED) { SCM x = SCM_CDR (xorig); - SCM_ASSYNT (2 == scm_ilength (x), scm_s_expression, scm_s_set_x); + SCM_ASSYNT (scm_ilength (x) == 2, scm_s_expression, scm_s_set_x); SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x)), scm_s_variable, scm_s_set_x); return scm_cons (SCM_IM_SET_X, x); } -SCM_SYNTAX(s_and, "and", scm_makmmacro, scm_m_and); -SCM_GLOBAL_SYMBOL(scm_sym_and, s_and); +SCM_SYNTAX (s_and, "and", scm_makmmacro, scm_m_and); +SCM_GLOBAL_SYMBOL (scm_sym_and, s_and); -SCM +SCM scm_m_and (SCM xorig, SCM env SCM_UNUSED) { long len = scm_ilength (SCM_CDR (xorig)); @@ -574,10 +531,11 @@ scm_m_and (SCM xorig, SCM env SCM_UNUSED) return SCM_BOOL_T; } -SCM_SYNTAX(s_or,"or", scm_makmmacro, scm_m_or); -SCM_GLOBAL_SYMBOL(scm_sym_or,s_or); -SCM +SCM_SYNTAX (s_or, "or", scm_makmmacro, scm_m_or); +SCM_GLOBAL_SYMBOL (scm_sym_or, s_or); + +SCM scm_m_or (SCM xorig, SCM env SCM_UNUSED) { long len = scm_ilength (SCM_CDR (xorig)); @@ -589,63 +547,66 @@ scm_m_or (SCM xorig, SCM env SCM_UNUSED) } -SCM_SYNTAX(s_case, "case", scm_makmmacro, scm_m_case); -SCM_GLOBAL_SYMBOL(scm_sym_case, s_case); +SCM_SYNTAX (s_case, "case", scm_makmmacro, scm_m_case); +SCM_GLOBAL_SYMBOL (scm_sym_case, s_case); -SCM +SCM scm_m_case (SCM xorig, SCM env SCM_UNUSED) { - SCM proc, cdrx = scm_list_copy (SCM_CDR (xorig)), x = cdrx; - SCM_ASSYNT (scm_ilength (x) >= 2, scm_s_clauses, s_case); - while (SCM_NIMP (x = SCM_CDR (x))) + SCM clauses; + SCM cdrx = SCM_CDR (xorig); + SCM_ASSYNT (scm_ilength (cdrx) >= 2, scm_s_clauses, s_case); + clauses = SCM_CDR (cdrx); + while (!SCM_NULLP (clauses)) { - proc = SCM_CAR (x); - SCM_ASSYNT (scm_ilength (proc) >= 2, scm_s_clauses, s_case); - SCM_ASSYNT (scm_ilength (SCM_CAR (proc)) >= 0 - || (SCM_EQ_P (scm_sym_else, SCM_CAR (proc)) - && SCM_NULLP (SCM_CDR (x))), + SCM clause = SCM_CAR (clauses); + SCM_ASSYNT (scm_ilength (clause) >= 2, scm_s_clauses, s_case); + SCM_ASSYNT (scm_ilength (SCM_CAR (clause)) >= 0 + || (SCM_EQ_P (scm_sym_else, SCM_CAR (clause)) + && SCM_NULLP (SCM_CDR (clauses))), scm_s_clauses, s_case); + clauses = SCM_CDR (clauses); } 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_SYNTAX (s_cond, "cond", scm_makmmacro, scm_m_cond); +SCM_GLOBAL_SYMBOL (scm_sym_cond, s_cond); - -SCM +SCM scm_m_cond (SCM xorig, SCM env SCM_UNUSED) { - SCM arg1, cdrx = scm_list_copy (SCM_CDR (xorig)), x = cdrx; - long len = scm_ilength (x); - SCM_ASSYNT (len >= 1, scm_s_clauses, s_cond); - while (SCM_NIMP (x)) + SCM cdrx = SCM_CDR (xorig); + SCM clauses = cdrx; + SCM_ASSYNT (scm_ilength (clauses) >= 1, scm_s_clauses, s_cond); + while (!SCM_NULLP (clauses)) { - arg1 = SCM_CAR (x); - len = scm_ilength (arg1); + SCM clause = SCM_CAR (clauses); + long len = scm_ilength (clause); SCM_ASSYNT (len >= 1, scm_s_clauses, s_cond); - if (SCM_EQ_P (scm_sym_else, SCM_CAR (arg1))) + if (SCM_EQ_P (scm_sym_else, SCM_CAR (clause))) { - SCM_ASSYNT (SCM_NULLP (SCM_CDR (x)) && len >= 2, - "bad ELSE clause", s_cond); - SCM_SETCAR (arg1, SCM_BOOL_T); + int last_clause_p = SCM_NULLP (SCM_CDR (clauses)); + SCM_ASSYNT (len >= 2 && last_clause_p, "bad ELSE clause", s_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)))), - "bad recipient", s_cond); - x = SCM_CDR (x); + else if (len >= 2 && SCM_EQ_P (scm_sym_arrow, SCM_CADR (clause))) + { + SCM_ASSYNT (len > 2, "missing recipient", s_cond); + SCM_ASSYNT (len == 3, "bad recipient", s_cond); + } + clauses = SCM_CDR (clauses); } 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); -/* Return true if OBJ is `eq?' to one of the elements of LIST or to the - cdr of the last cons. (Thus, LIST is not required to be a proper - list and when OBJ also found in the improper ending.) */ +SCM_SYNTAX (s_lambda, "lambda", scm_makmmacro, scm_m_lambda); +SCM_GLOBAL_SYMBOL (scm_sym_lambda, s_lambda); +/* Return true if OBJ is `eq?' to one of the elements of LIST or to the + * cdr of the last cons. (Thus, LIST is not required to be a proper + * list and OBJ can also be found in the improper ending.) */ static int scm_c_improper_memq (SCM obj, SCM list) { @@ -657,89 +618,81 @@ scm_c_improper_memq (SCM obj, SCM list) return SCM_EQ_P (list, obj); } -SCM +SCM scm_m_lambda (SCM xorig, SCM env SCM_UNUSED) { - SCM proc, x = SCM_CDR (xorig); - if (scm_ilength (x) < 2) - goto badforms; - proc = SCM_CAR (x); - if (SCM_NULLP (proc)) - goto memlambda; - if (SCM_EQ_P (SCM_IM_LET, proc)) /* named let */ - goto memlambda; - if (SCM_IMP (proc)) - goto badforms; - if (SCM_SYMBOLP (proc)) - goto memlambda; - if (!SCM_CONSP (proc)) - goto badforms; - while (SCM_NIMP (proc)) + SCM formals; + SCM x = SCM_CDR (xorig); + + SCM_ASSYNT (SCM_CONSP (x), scm_s_formals, s_lambda); + + formals = SCM_CAR (x); + while (SCM_CONSP (formals)) { - if (!SCM_CONSP (proc)) - { - if (!SCM_SYMBOLP (proc)) - goto badforms; - else - goto memlambda; - } - if (!SCM_SYMBOLP (SCM_CAR (proc))) - goto badforms; - else if (scm_c_improper_memq (SCM_CAR(proc), SCM_CDR(proc))) + SCM formal = SCM_CAR (formals); + SCM_ASSYNT (SCM_SYMBOLP (formal), scm_s_formals, s_lambda); + if (scm_c_improper_memq (formal, SCM_CDR (formals))) scm_misc_error (s_lambda, scm_s_duplicate_formals, SCM_EOL); - proc = SCM_CDR (proc); - } - if (!SCM_NULLP (proc)) - { - badforms: - scm_misc_error (s_lambda, scm_s_formals, SCM_EOL); + formals = SCM_CDR (formals); } + if (!SCM_NULLP (formals) && !SCM_SYMBOLP (formals)) + scm_misc_error (s_lambda, scm_s_formals, SCM_EOL); - 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_SYNTAX (s_letstar, "let*", scm_makmmacro, scm_m_letstar); +SCM_GLOBAL_SYMBOL (scm_sym_letstar, s_letstar); -SCM +/* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vk and initializers + * i1 .. ik is transformed into the form (#@let* (v1 i1 v2 i2 ...) body*). */ +SCM scm_m_letstar (SCM xorig, SCM env SCM_UNUSED) { - SCM x = SCM_CDR (xorig), arg1, proc, vars = SCM_EOL, *varloc = &vars; - long len = scm_ilength (x); - SCM_ASSYNT (len >= 2, scm_s_body, s_letstar); - proc = SCM_CAR (x); - SCM_ASSYNT (scm_ilength (proc) >= 0, scm_s_bindings, s_letstar); - while (SCM_NIMP (proc)) + SCM bindings; + SCM x = SCM_CDR (xorig); + SCM vars = SCM_EOL; + SCM *varloc = &vars; + + SCM_ASSYNT (SCM_CONSP (x), scm_s_bindings, s_letstar); + + bindings = SCM_CAR (x); + SCM_ASSYNT (scm_ilength (bindings) >= 0, scm_s_bindings, s_letstar); + while (!SCM_NULLP (bindings)) { - arg1 = SCM_CAR (proc); - SCM_ASSYNT (2 == scm_ilength (arg1), scm_s_bindings, s_letstar); - SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)), scm_s_variable, s_letstar); - *varloc = scm_cons2 (SCM_CAR (arg1), SCM_CAR (SCM_CDR (arg1)), SCM_EOL); + SCM binding = SCM_CAR (bindings); + SCM_ASSYNT (scm_ilength (binding) == 2, scm_s_bindings, s_letstar); + SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding)), scm_s_variable, s_letstar); + *varloc = scm_list_2 (SCM_CAR (binding), SCM_CADR (binding)); varloc = SCM_CDRLOC (SCM_CDR (*varloc)); - proc = SCM_CDR (proc); + bindings = SCM_CDR (bindings); } - x = scm_cons (vars, SCM_CDR (x)); - return scm_cons2 (SCM_IM_LETSTAR, SCM_CAR (x), + return scm_cons2 (SCM_IM_LETSTAR, vars, scm_m_body (SCM_IM_LETSTAR, SCM_CDR (x), s_letstar)); } -/* DO gets the most radically altered syntax + +/* DO gets the most radically altered syntax. The order of the vars is + * reversed here. In contrast, the order of the inits and steps is reversed + * during the evaluation: + (do (( ) ( ) ... ) ( ) ) + ;; becomes - (do_mem (varn ... var2 var1) + + (#@do (varn ... var2 var1) ( ... ) ( ) () ... ) ;; missing steps replaced by var - */ + */ SCM_SYNTAX(s_do, "do", scm_makmmacro, scm_m_do); SCM_GLOBAL_SYMBOL(scm_sym_do, s_do); @@ -747,28 +700,33 @@ SCM_GLOBAL_SYMBOL(scm_sym_do, s_do); SCM scm_m_do (SCM xorig, SCM env SCM_UNUSED) { - SCM x = SCM_CDR (xorig), arg1, proc; - SCM vars = SCM_EOL, inits = SCM_EOL, steps = SCM_EOL; - SCM *initloc = &inits, *steploc = &steps; - long len = scm_ilength (x); - SCM_ASSYNT (len >= 2, scm_s_test, "do"); - proc = SCM_CAR (x); - SCM_ASSYNT (scm_ilength (proc) >= 0, scm_s_bindings, "do"); - while (SCM_NIMP(proc)) + SCM bindings; + SCM x = SCM_CDR (xorig); + SCM vars = SCM_EOL; + SCM inits = SCM_EOL; + SCM *initloc = &inits; + SCM steps = SCM_EOL; + SCM *steploc = &steps; + SCM_ASSYNT (scm_ilength (x) >= 2, scm_s_test, "do"); + bindings = SCM_CAR (x); + SCM_ASSYNT (scm_ilength (bindings) >= 0, scm_s_bindings, "do"); + while (!SCM_NULLP (bindings)) { - arg1 = SCM_CAR (proc); - len = scm_ilength (arg1); - SCM_ASSYNT (2 == len || 3 == len, scm_s_bindings, "do"); - SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)), 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); - *initloc = scm_cons (SCM_CAR (arg1), SCM_EOL); /* init */ - initloc = SCM_CDRLOC (*initloc); - arg1 = SCM_CDR (arg1); - *steploc = scm_cons (SCM_IMP (arg1) ? SCM_CAR (vars) : SCM_CAR (arg1), SCM_EOL); /* step */ - steploc = SCM_CDRLOC (*steploc); - proc = SCM_CDR (proc); + SCM binding = SCM_CAR (bindings); + long len = scm_ilength (binding); + SCM_ASSYNT (len == 2 || len == 3, scm_s_bindings, "do"); + { + SCM name = SCM_CAR (binding); + SCM init = SCM_CADR (binding); + SCM step = (len == 2) ? name : SCM_CADDR (binding); + SCM_ASSYNT (SCM_SYMBOLP (name), scm_s_variable, "do"); + vars = scm_cons (name, vars); + *initloc = scm_list_1 (init); + initloc = SCM_CDRLOC (*initloc); + *steploc = scm_list_1 (step); + steploc = SCM_CDRLOC (*steploc); + bindings = SCM_CDR (bindings); + } } x = SCM_CDR (x); SCM_ASSYNT (scm_ilength (SCM_CAR (x)) >= 1, scm_s_test, "do"); @@ -777,16 +735,68 @@ scm_m_do (SCM xorig, SCM env SCM_UNUSED) return scm_cons (SCM_IM_DO, x); } -/* evalcar is small version of inline EVALCAR when we don't care about - * speed - */ -#define evalcar scm_eval_car - -static SCM iqq (SCM form, SCM env, long depth); +SCM_SYNTAX (s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote); +SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, s_quasiquote); -SCM_SYNTAX(s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote); -SCM_GLOBAL_SYMBOL(scm_sym_quasiquote, s_quasiquote); +/* Internal function to handle a quasiquotation: 'form' is the parameter in + * the call (quasiquotation form), 'env' is the environment where unquoted + * expressions will be evaluated, and 'depth' is the current quasiquotation + * nesting level and is known to be greater than zero. */ +static SCM +iqq (SCM form, SCM env, unsigned long int depth) +{ + if (SCM_CONSP (form)) + { + SCM tmp = SCM_CAR (form); + if (SCM_EQ_P (tmp, scm_sym_quasiquote)) + { + SCM args = SCM_CDR (form); + SCM_ASSYNT (scm_ilength (args) == 1, scm_s_expression, s_quasiquote); + return scm_list_2 (tmp, iqq (SCM_CAR (args), env, depth + 1)); + } + else if (SCM_EQ_P (tmp, scm_sym_unquote)) + { + SCM args = SCM_CDR (form); + SCM_ASSYNT (scm_ilength (args) == 1, scm_s_expression, s_quasiquote); + if (depth - 1 == 0) + return scm_eval_car (args, env); + else + return scm_list_2 (tmp, iqq (SCM_CAR (args), env, depth - 1)); + } + else if (SCM_CONSP (tmp) + && SCM_EQ_P (SCM_CAR (tmp), scm_sym_uq_splicing)) + { + SCM args = SCM_CDR (tmp); + SCM_ASSYNT (scm_ilength (args) == 1, scm_s_expression, s_quasiquote); + if (depth - 1 == 0) + { + SCM list = scm_eval_car (args, env); + SCM rest = SCM_CDR (form); + SCM_ASSYNT (scm_ilength (list) >= 0, s_splicing, s_quasiquote); + return scm_append (scm_list_2 (list, iqq (rest, env, depth))); + } + else + return scm_cons (iqq (SCM_CAR (form), env, depth - 1), + iqq (SCM_CDR (form), env, depth)); + } + else + return scm_cons (iqq (SCM_CAR (form), env, depth), + iqq (SCM_CDR (form), env, depth)); + } + else if (SCM_VECTORP (form)) + { + size_t i = SCM_VECTOR_LENGTH (form); + SCM const *data = SCM_VELTS (form); + SCM tmp = SCM_EOL; + while (i != 0) + tmp = scm_cons (data[--i], tmp); + scm_remember_upto_here_1 (form); + return scm_vector (iqq (tmp, env, depth)); + } + else + return form; +} SCM scm_m_quasiquote (SCM xorig, SCM env) @@ -797,56 +807,14 @@ scm_m_quasiquote (SCM xorig, SCM env) } -static SCM -iqq (SCM form, SCM env, long depth) -{ - SCM tmp; - long edepth = depth; - if (SCM_IMP (form)) - return form; - if (SCM_VECTORP (form)) - { - long i = SCM_VECTOR_LENGTH (form); - SCM *data = SCM_VELTS (form); - tmp = SCM_EOL; - for (; --i >= 0;) - tmp = scm_cons (data[i], tmp); - return scm_vector (iqq (tmp, env, depth)); - } - if (!SCM_CONSP (form)) - return form; - tmp = SCM_CAR (form); - if (SCM_EQ_P (scm_sym_quasiquote, tmp)) - { - depth++; - goto label; - } - if (SCM_EQ_P (scm_sym_unquote, tmp)) - { - --depth; - label: - form = SCM_CDR (form); - SCM_ASSERT (SCM_CONSP (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_CONSP (tmp) && (SCM_EQ_P (scm_sym_uq_splicing, SCM_CAR (tmp)))) - { - tmp = SCM_CDR (tmp); - if (0 == --edepth) - return scm_append (scm_cons2 (evalcar (tmp, env), iqq (SCM_CDR (form), env, depth), SCM_EOL)); - } - return scm_cons (iqq (SCM_CAR (form), env, edepth), iqq (SCM_CDR (form), env, depth)); -} - -/* Here are acros which return values rather than code. */ - SCM_SYNTAX (s_delay, "delay", scm_makmmacro, scm_m_delay); SCM_GLOBAL_SYMBOL (scm_sym_delay, s_delay); -SCM +/* Promises are implemented as closures with an empty parameter list. Thus, + * (delay ) is transformed into (#@delay '() ), where + * the empty list represents the empty parameter list. This representation + * allows for easy creation of the closure during evaluation. */ +SCM scm_m_delay (SCM xorig, SCM env SCM_UNUSED) { SCM_ASSYNT (scm_ilength (xorig) == 2, scm_s_expression, s_delay); @@ -854,86 +822,114 @@ scm_m_delay (SCM xorig, SCM env SCM_UNUSED) } +SCM_SYNTAX (s_future, "future", scm_makmmacro, scm_m_future); +SCM_GLOBAL_SYMBOL (scm_sym_future, s_future); + +/* Like promises, futures are implemented as closures with an empty + * parameter list. Thus, (future ) is transformed into + * (#@future '() ), where the empty list represents the + * empty parameter list. This representation allows for easy creation + * of the closure during evaluation. */ +SCM +scm_m_future (SCM xorig, SCM env SCM_UNUSED) +{ + SCM_ASSYNT (scm_ilength (xorig) == 2, scm_s_expression, s_future); + return scm_cons2 (SCM_IM_FUTURE, SCM_EOL, SCM_CDR (xorig)); +} + + SCM_SYNTAX(s_define, "define", scm_makmmacro, scm_m_define); SCM_GLOBAL_SYMBOL(scm_sym_define, s_define); -SCM +/* Guile provides an extension to R5RS' define syntax to represent function + * currying in a compact way. With this extension, it is allowed to write + * (define ), where has of one of + * the forms ( ), ( . ), + * ( ) or ( . ). As in R5RS, + * should be either a sequence of zero or more variables, or a sequence of one + * or more variables followed by a space-delimited period and another + * variable. Each level of argument nesting wraps the within another + * lambda expression. For example, the following forms are allowed, each one + * followed by an equivalent, more explicit implementation. + * Example 1: + * (define ((a b . c) . d) ) is equivalent to + * (define a (lambda (b . c) (lambda d ))) + * Example 2: + * (define (((a) b) c . d) ) is equivalent to + * (define a (lambda () (lambda (b) (lambda (c . d) )))) + */ +/* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS + * module that does not implement this extension. */ +SCM scm_m_define (SCM x, SCM env) { - SCM proc, arg1 = x; + SCM name; x = SCM_CDR (x); SCM_ASSYNT (scm_ilength (x) >= 2, scm_s_expression, s_define); - proc = SCM_CAR (x); + name = SCM_CAR (x); x = SCM_CDR (x); - while (SCM_CONSP (proc)) - { /* nested define syntax */ - x = scm_cons (scm_cons2 (scm_sym_lambda, SCM_CDR (proc), x), SCM_EOL); - proc = SCM_CAR (proc); + while (SCM_CONSP (name)) + { + /* This while loop realizes function currying by variable nesting. */ + SCM formals = SCM_CDR (name); + x = scm_list_1 (scm_cons2 (scm_sym_lambda, formals, x)); + name = SCM_CAR (name); } - SCM_ASSYNT (SCM_SYMBOLP (proc), scm_s_variable, s_define); - SCM_ASSYNT (1 == scm_ilength (x), scm_s_expression, s_define); + SCM_ASSYNT (SCM_SYMBOLP (name), scm_s_variable, s_define); + SCM_ASSYNT (scm_ilength (x) == 1, scm_s_expression, s_define); if (SCM_TOP_LEVEL (env)) { - x = evalcar (x, env); -#ifdef DEBUG_EXTENSIONS - if (SCM_REC_PROCNAMES_P && SCM_NIMP (x)) + SCM var; + x = scm_eval_car (x, env); + if (SCM_REC_PROCNAMES_P) { - arg1 = x; - proc: - if (SCM_CLOSUREP (arg1) + SCM tmp = x; + while (SCM_MACROP (tmp)) + tmp = SCM_MACRO_CODE (tmp); + if (SCM_CLOSUREP (tmp) /* Only the first definition determines the name. */ - && SCM_FALSEP (scm_procedure_property (arg1, scm_sym_name))) - scm_set_procedure_property_x (arg1, scm_sym_name, proc); - else if (SCM_MACROP (arg1) - /* Dirk::FIXME: Does the following test make sense? */ - && !SCM_EQ_P (SCM_MACRO_CODE (arg1), arg1)) - { - arg1 = SCM_MACRO_CODE (arg1); - goto proc; - } + && SCM_FALSEP (scm_procedure_property (tmp, scm_sym_name))) + scm_set_procedure_property_x (tmp, scm_sym_name, name); } -#endif - arg1 = scm_sym2var (proc, scm_env_top_level (env), SCM_BOOL_T); - SCM_VARIABLE_SET (arg1, x); -#ifdef SICP - return scm_cons2 (scm_sym_quote, proc, SCM_EOL); -#else + var = scm_sym2var (name, scm_env_top_level (env), SCM_BOOL_T); + SCM_VARIABLE_SET (var, x); return SCM_UNSPECIFIED; -#endif } - return scm_cons2 (SCM_IM_DEFINE, proc, x); + else + return scm_cons2 (SCM_IM_DEFINE, name, x); } -/* end of acros */ -static SCM -scm_m_letrec1 (SCM op, SCM imm, SCM xorig, SCM env SCM_UNUSED) +/* The bindings ((v1 i1) (v2 i2) ... (vn in)) are transformed to the lists + * (vn ... v2 v1) and (i1 i2 ... in). That is, the list of variables is + * reversed here, the list of inits gets reversed during evaluation. */ +static void +transform_bindings (SCM bindings, SCM *rvarloc, SCM *initloc, const char *what) { - SCM cdrx = SCM_CDR (xorig); /* locally mutable version of form */ - char *what = SCM_SYMBOL_CHARS (SCM_CAR (xorig)); - SCM x = cdrx, proc, arg1; /* structure traversers */ - SCM vars = SCM_EOL, inits = SCM_EOL, *initloc = &inits; + SCM rvars = SCM_EOL; + *rvarloc = SCM_EOL; + *initloc = SCM_EOL; + + SCM_ASSYNT (scm_ilength (bindings) >= 1, scm_s_bindings, what); - proc = SCM_CAR (x); - SCM_ASSYNT (scm_ilength (proc) >= 1, scm_s_bindings, what); do { - /* vars scm_list reversed here, inits reversed at evaluation */ - arg1 = SCM_CAR (proc); - SCM_ASSYNT (2 == scm_ilength (arg1), scm_s_bindings, what); - SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)), scm_s_variable, what); - if (scm_c_improper_memq (SCM_CAR (arg1), vars)) + SCM binding = SCM_CAR (bindings); + SCM_ASSYNT (scm_ilength (binding) == 2, scm_s_bindings, what); + SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding)), scm_s_variable, what); + if (scm_c_improper_memq (SCM_CAR (binding), rvars)) scm_misc_error (what, scm_s_duplicate_bindings, SCM_EOL); - vars = scm_cons (SCM_CAR (arg1), vars); - *initloc = scm_cons (SCM_CAR (SCM_CDR (arg1)), SCM_EOL); + rvars = scm_cons (SCM_CAR (binding), rvars); + *initloc = scm_list_1 (SCM_CADR (binding)); initloc = SCM_CDRLOC (*initloc); + bindings = SCM_CDR (bindings); } - while (SCM_NIMP (proc = SCM_CDR (proc))); + while (!SCM_NULLP (bindings)); - return scm_cons2 (op, vars, - scm_cons (inits, scm_m_body (imm, SCM_CDR (x), what))); + *rvarloc = rvars; } + SCM_SYNTAX(s_letrec, "letrec", scm_makmmacro, scm_m_letrec); SCM_GLOBAL_SYMBOL(scm_sym_letrec, s_letrec); @@ -941,78 +937,95 @@ SCM scm_m_letrec (SCM xorig, SCM env) { SCM x = SCM_CDR (xorig); - SCM_ASSYNT (scm_ilength (x) >= 2, scm_s_body, s_letrec); + SCM_ASSYNT (SCM_CONSP (x), scm_s_bindings, 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); + if (SCM_NULLP (SCM_CAR (x))) + { + /* null binding, let* faster */ + SCM body = scm_m_body (SCM_IM_LETREC, SCM_CDR (x), s_letrec); + return scm_m_letstar (scm_cons2 (SCM_CAR (xorig), SCM_EOL, body), env); + } else - return scm_m_letrec1 (SCM_IM_LETREC, SCM_IM_LETREC, xorig, env); + { + SCM rvars, inits, body; + transform_bindings (SCM_CAR (x), &rvars, &inits, "letrec"); + body = scm_m_body (SCM_IM_LETREC, SCM_CDR (x), "letrec"); + return scm_cons2 (SCM_IM_LETREC, rvars, scm_cons (inits, body)); + } } + SCM_SYNTAX(s_let, "let", scm_makmmacro, scm_m_let); SCM_GLOBAL_SYMBOL(scm_sym_let, s_let); -SCM +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; - - SCM_ASSYNT (scm_ilength (x) >= 2, scm_s_body, s_let); - proc = SCM_CAR (x); - if (SCM_NULLP (proc) - || (SCM_CONSP (proc) - && SCM_CONSP (SCM_CAR (proc)) && SCM_NULLP (SCM_CDR (proc)))) + SCM x = SCM_CDR (xorig); + SCM temp; + + SCM_ASSYNT (SCM_CONSP (x), scm_s_bindings, s_let); + temp = SCM_CAR (x); + if (SCM_NULLP (temp) + || (scm_ilength (temp) == 1 && SCM_CONSP (SCM_CAR (temp)))) { /* 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 bindings = temp; + SCM body = scm_m_body (SCM_IM_LET, SCM_CDR (x), s_let); + return scm_m_letstar (scm_cons2 (SCM_CAR (xorig), bindings, body), env); } - - SCM_ASSYNT (SCM_NIMP (proc), scm_s_bindings, s_let); - if (SCM_CONSP (proc)) + else if (SCM_CONSP (temp)) { - /* plain let, proc is */ - return scm_m_letrec1 (SCM_IM_LET, SCM_IM_LET, xorig, env); + /* plain let */ + SCM bindings = temp; + SCM rvars, inits, body; + transform_bindings (bindings, &rvars, &inits, "let"); + body = scm_m_body (SCM_IM_LET, SCM_CDR (x), "let"); + return scm_cons2 (SCM_IM_LET, rvars, scm_cons (inits, body)); } + else + { + /* named let: Transform (let name ((var init) ...) body ...) into + * ((letrec ((name (lambda (var ...) body ...))) name) init ...) */ - if (!SCM_SYMBOLP (proc)) - scm_misc_error (s_let, scm_s_bindings, SCM_EOL); /* bad let */ - name = proc; /* named let, build equiv letrec */ - x = SCM_CDR (x); - SCM_ASSYNT (scm_ilength (x) >= 2, scm_s_body, s_let); - proc = SCM_CAR (x); /* bindings list */ - SCM_ASSYNT (scm_ilength (proc) >= 0, scm_s_bindings, s_let); - while (SCM_NIMP (proc)) - { /* vars and inits both in order */ - arg1 = SCM_CAR (proc); - SCM_ASSYNT (2 == scm_ilength (arg1), scm_s_bindings, s_let); - SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)), 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); - } + SCM name = temp; + SCM vars = SCM_EOL; + SCM *varloc = &vars; + SCM inits = SCM_EOL; + SCM *initloc = &inits; + SCM bindings; + + SCM_ASSYNT (SCM_SYMBOLP (name), scm_s_bindings, s_let); + x = SCM_CDR (x); + SCM_ASSYNT (SCM_CONSP (x), scm_s_bindings, s_let); + bindings = SCM_CAR (x); + SCM_ASSYNT (scm_ilength (bindings) >= 0, scm_s_bindings, s_let); + while (!SCM_NULLP (bindings)) + { /* vars and inits both in order */ + SCM binding = SCM_CAR (bindings); + SCM_ASSYNT (scm_ilength (binding) == 2, scm_s_bindings, s_let); + SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding)), scm_s_variable, s_let); + *varloc = scm_list_1 (SCM_CAR (binding)); + varloc = SCM_CDRLOC (*varloc); + *initloc = scm_list_1 (SCM_CADR (binding)); + initloc = SCM_CDRLOC (*initloc); + bindings = SCM_CDR (bindings); + } - 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 lambda_body = scm_m_body (SCM_IM_LET, SCM_CDR (x), "let"); + SCM lambda_form = scm_cons2 (scm_sym_lambda, vars, lambda_body); + SCM rvar = scm_list_1 (name); + SCM init = scm_list_1 (lambda_form); + SCM body = scm_m_body (SCM_IM_LET, scm_list_1 (name), "let"); + SCM letrec = scm_cons2 (SCM_IM_LETREC, rvar, scm_cons (init, body)); + return scm_cons (letrec, inits); + } + } } -SCM_SYNTAX (s_atapply,"@apply", scm_makmmacro, scm_m_apply); +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); @@ -1024,8 +1037,8 @@ scm_m_apply (SCM xorig, SCM env SCM_UNUSED) } -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_SYNTAX(s_atcall_cc, "@call-with-current-continuation", scm_makmmacro, scm_m_cont); +SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc, s_atcall_cc); SCM @@ -1036,10 +1049,7 @@ scm_m_cont (SCM xorig, SCM env SCM_UNUSED) return scm_cons (SCM_IM_CONT, SCM_CDR (xorig)); } -/* Multi-language support */ - -SCM_GLOBAL_SYMBOL (scm_lisp_nil, "nil"); -SCM_GLOBAL_SYMBOL (scm_lisp_t, "t"); +#ifdef SCM_ENABLE_ELISP SCM_SYNTAX (s_nil_cond, "nil-cond", scm_makmmacro, scm_m_nil_cond); @@ -1051,52 +1061,6 @@ scm_m_nil_cond (SCM xorig, SCM env SCM_UNUSED) 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_UNUSED) -{ - SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, 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_UNUSED) -{ - SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, 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 SCM_UNUSED) -{ - long len = scm_ilength (SCM_CDR (xorig)); - SCM_ASSYNT (len >= 1 && (len & 1) == 1, 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_UNUSED) -{ - SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, 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_UNUSED) -{ - SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, 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 @@ -1105,12 +1069,45 @@ scm_m_atfop (SCM xorig, SCM env SCM_UNUSED) SCM x = SCM_CDR (xorig), var; SCM_ASSYNT (scm_ilength (x) >= 1, scm_s_expression, "@fop"); var = scm_symbol_fref (SCM_CAR (x)); + /* Passing the symbol name as the `subr' arg here isn't really + right, but without it it can be very difficult to work out from + the error message which function definition was missing. In any + case, we shouldn't really use SCM_ASSYNT here at all, but instead + something equivalent to (signal void-function (list SYM)) in + Elisp. */ SCM_ASSYNT (SCM_VARIABLEP (var), - "Symbol's function definition is void", NULL); + "Symbol's function definition is void", + SCM_SYMBOL_CHARS (SCM_CAR (x))); + /* Support `defalias'. */ + while (SCM_SYMBOLP (SCM_VARIABLE_REF (var))) + { + var = scm_symbol_fref (SCM_VARIABLE_REF (var)); + SCM_ASSYNT (SCM_VARIABLEP (var), + "Symbol's function definition is void", + SCM_SYMBOL_CHARS (SCM_CAR (x))); + } + /* Use `var' here rather than `SCM_VARIABLE_REF (var)' because the + former allows for automatically picking up redefinitions of the + corresponding symbol. */ SCM_SETCAR (x, var); + /* If the variable contains a procedure, leave the + `transformer-macro' in place so that the procedure's arguments + get properly transformed, and change the initial @fop to + SCM_IM_APPLY. */ + if (!SCM_MACROP (SCM_VARIABLE_REF (var))) + { + SCM_SETCAR (xorig, SCM_IM_APPLY); + return xorig; + } + /* Otherwise (the variable contains a macro), the arguments should + not be transformed, so cut the `transformer-macro' out and return + the resulting expression starting with the variable. */ + SCM_SETCDR (x, SCM_CDADR (x)); return x; } +#endif /* SCM_ENABLE_ELISP */ + /* (@bind ((var exp) ...) body ...) This will assign the values of the `exp's to the global variables @@ -1121,7 +1118,7 @@ scm_m_atfop (SCM xorig, SCM env SCM_UNUSED) error when a symbol appears more than once among the `var's. All `exp's are evaluated before any `var' is set. - This of this as `let' for dynamic scope. + Think of this as `let' for dynamic scope. It is memoized into (#@bind ((var ...) . (reversed-val ...)) body ...). @@ -1149,7 +1146,7 @@ scm_m_atbind (SCM xorig, SCM env) SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (sym_exp)), scm_s_bindings, s_atbind); x = SCM_CDR (x); for (rest = x; SCM_NIMP (rest); rest = SCM_CDR (rest)) - if (SCM_EQ_P (SCM_CAR (sym_exp), SCM_CAR (SCM_CAR (rest)))) + if (SCM_EQ_P (SCM_CAR (sym_exp), SCM_CAAR (rest))) scm_misc_error (s_atbind, scm_s_duplicate_bindings, SCM_EOL); /* The first call to scm_sym2var will look beyond the current module, while the second call wont. */ @@ -1205,7 +1202,7 @@ scm_m_expand_body (SCM xorig, SCM env) } else if (SCM_EQ_P (SCM_IM_BEGIN, SCM_CAR (form))) { - x = scm_append (scm_cons2 (SCM_CDR (form), SCM_CDR (x), SCM_EOL)); + x = scm_append (scm_list_2 (SCM_CDR (form), SCM_CDR (x))); } else { @@ -1214,20 +1211,21 @@ scm_m_expand_body (SCM xorig, SCM env) } } - SCM_ASSYNT (SCM_NIMP (x), scm_s_body, what); - if (SCM_NIMP (defs)) + if (!SCM_NULLP (defs)) { - x = scm_cons (scm_m_letrec1 (SCM_IM_LETREC, - SCM_IM_DEFINE, - scm_cons2 (scm_sym_define, defs, x), - env), - SCM_EOL); + SCM rvars, inits, body, letrec; + transform_bindings (defs, &rvars, &inits, what); + body = scm_m_body (SCM_IM_DEFINE, x, what); + letrec = scm_cons2 (SCM_IM_LETREC, rvars, scm_cons (inits, body)); + SCM_SETCAR (xorig, letrec); + SCM_SETCDR (xorig, SCM_EOL); + } + else + { + SCM_ASSYNT (SCM_CONSP (x), scm_s_body, what); + SCM_SETCAR (xorig, SCM_CAR (x)); + SCM_SETCDR (xorig, SCM_CDR (x)); } - - SCM_DEFER_INTS; - SCM_SETCAR (xorig, SCM_CAR (x)); - SCM_SETCDR (xorig, SCM_CDR (x)); - SCM_ALLOW_INTS; return xorig; } @@ -1245,7 +1243,6 @@ scm_macroexp (SCM x, SCM env) if (!SCM_SYMBOLP (orig_sym)) return x; -#ifdef USE_THREADS { SCM *proc_ptr = scm_lookupcar1 (x, env, 0); if (proc_ptr == NULL) @@ -1255,9 +1252,6 @@ scm_macroexp (SCM x, SCM env) } 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. */ @@ -1269,7 +1263,7 @@ scm_macroexp (SCM x, SCM env) res = scm_call_2 (SCM_MACRO_CODE (proc), x, env); if (scm_ilength (res) <= 0) - res = scm_cons2 (SCM_IM_BEGIN, res, SCM_EOL); + res = scm_list_2 (SCM_IM_BEGIN, res); SCM_DEFER_INTS; SCM_SETCAR (x, SCM_CAR (res)); @@ -1287,7 +1281,7 @@ scm_macroexp (SCM x, SCM env) * generating the source for a stackframe in a backtrace, and in * display_expression. * - * Unmemoizing is not a realiable process. You can not in general + * Unmemoizing is not a reliable process. You cannot in general * expect to get the original source back. * * However, GOOPS currently relies on this for method compilation. @@ -1296,6 +1290,20 @@ scm_macroexp (SCM x, SCM env) #define SCM_BIT8(x) (127 & SCM_UNPACK (x)) +static SCM +build_binding_list (SCM names, SCM inits) +{ + SCM bindings = SCM_EOL; + while (!SCM_NULLP (names)) + { + SCM binding = scm_list_2 (SCM_CAR (names), SCM_CAR (inits)); + bindings = scm_cons (binding, bindings); + names = SCM_CDR (names); + inits = SCM_CDR (inits); + } + return bindings; +} + static SCM unmemocopy (SCM x, SCM env) { @@ -1308,7 +1316,7 @@ unmemocopy (SCM x, SCM env) #ifdef DEBUG_EXTENSIONS p = scm_whash_lookup (scm_source_whash, x); #endif - switch (SCM_TYP7 (x)) + switch (SCM_ITAG7 (SCM_CAR (x))) { case SCM_BIT8(SCM_IM_AND): ls = z = scm_cons (scm_sym_and, SCM_UNSPECIFIED); @@ -1322,79 +1330,104 @@ unmemocopy (SCM x, SCM env) case SCM_BIT8(SCM_IM_COND): ls = z = scm_cons (scm_sym_cond, SCM_UNSPECIFIED); break; - case SCM_BIT8(SCM_IM_DO): - ls = scm_cons (scm_sym_do, SCM_UNSPECIFIED); - goto transform; - case SCM_BIT8(SCM_IM_IF): - ls = z = scm_cons (scm_sym_if, SCM_UNSPECIFIED); - break; - case SCM_BIT8(SCM_IM_LET): - ls = scm_cons (scm_sym_let, SCM_UNSPECIFIED); - goto transform; - case SCM_BIT8(SCM_IM_LETREC): + case SCM_BIT8 (SCM_IM_DO): { - SCM f, v, e, s; - ls = scm_cons (scm_sym_letrec, SCM_UNSPECIFIED); - transform: + /* format: (#@do (nk nk-1 ...) (i1 ... ik) (test) (body) s1 ... sk), + * where nx is the name of a local variable, ix is an initializer for + * the local variable, test is the test clause of the do loop, body is + * the body of the do loop and sx are the step clauses for the local + * variables. */ + SCM names, inits, test, memoized_body, steps, bindings; + + x = SCM_CDR (x); + names = SCM_CAR (x); + x = SCM_CDR (x); + inits = scm_reverse (unmemocopy (SCM_CAR (x), env)); + env = EXTEND_ENV (names, SCM_EOL, env); + x = SCM_CDR (x); + test = unmemocopy (SCM_CAR (x), env); x = SCM_CDR (x); - /* binding names */ - f = v = SCM_CAR (x); + memoized_body = SCM_CAR (x); x = SCM_CDR (x); - z = EXTEND_ENV (f, SCM_EOL, env); - /* inits */ - e = scm_reverse (unmemocopy (SCM_CAR (x), - SCM_EQ_P (SCM_CAR (ls), scm_sym_letrec) ? z : env)); - env = z; - /* increments */ - s = SCM_EQ_P (SCM_CAR (ls), scm_sym_do) - ? scm_reverse (unmemocopy (SCM_CDR (SCM_CDR (SCM_CDR (x))), env)) - : f; + steps = scm_reverse (unmemocopy (x, env)); + /* build transformed binding list */ - z = SCM_EOL; - while (SCM_NIMP (v)) - { - z = scm_acons (SCM_CAR (v), - scm_cons (SCM_CAR (e), - SCM_EQ_P (SCM_CAR (s), SCM_CAR (v)) - ? SCM_EOL - : scm_cons (SCM_CAR (s), SCM_EOL)), - z); - v = SCM_CDR (v); - e = SCM_CDR (e); - s = SCM_CDR (s); - } - z = scm_cons (z, SCM_UNSPECIFIED); - SCM_SETCDR (ls, z); - if (SCM_EQ_P (SCM_CAR (ls), scm_sym_do)) + bindings = SCM_EOL; + while (!SCM_NULLP (names)) { - 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! :) */ + SCM name = SCM_CAR (names); + SCM init = SCM_CAR (inits); + SCM step = SCM_CAR (steps); + step = SCM_EQ_P (step, name) ? SCM_EOL : scm_list_1 (step); + + bindings = scm_cons (scm_cons2 (name, init, step), bindings); + + names = SCM_CDR (names); + inits = SCM_CDR (inits); + steps = SCM_CDR (steps); } + z = scm_cons (test, SCM_UNSPECIFIED); + ls = scm_cons2 (scm_sym_do, bindings, z); + + x = scm_cons (SCM_BOOL_F, memoized_body); break; } - case SCM_BIT8(SCM_IM_LETSTAR): + case SCM_BIT8(SCM_IM_IF): + ls = z = scm_cons (scm_sym_if, SCM_UNSPECIFIED); + break; + case SCM_BIT8 (SCM_IM_LET): { - SCM b, y; + /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...), + * where nx is the name of a local variable, ix is an initializer for + * the local variable and by are the body clauses. */ + SCM names, inits, bindings; + x = SCM_CDR (x); - b = SCM_CAR (x); - y = SCM_EOL; - if SCM_IMP (b) - { - env = EXTEND_ENV (SCM_EOL, SCM_EOL, env); - goto letstar; + names = SCM_CAR (x); + x = SCM_CDR (x); + inits = scm_reverse (unmemocopy (SCM_CAR (x), env)); + env = EXTEND_ENV (names, SCM_EOL, env); + + bindings = build_binding_list (names, inits); + z = scm_cons (bindings, SCM_UNSPECIFIED); + ls = scm_cons (scm_sym_let, z); + break; + } + case SCM_BIT8 (SCM_IM_LETREC): + { + /* format: (#@letrec (nk nk-1 ...) (i1 ... ik) b1 ...), + * where nx is the name of a local variable, ix is an initializer for + * the local variable and by are the body clauses. */ + SCM names, inits, bindings; + + x = SCM_CDR (x); + names = SCM_CAR (x); + env = EXTEND_ENV (names, SCM_EOL, env); + x = SCM_CDR (x); + inits = scm_reverse (unmemocopy (SCM_CAR (x), env)); + + bindings = build_binding_list (names, inits); + z = scm_cons (bindings, SCM_UNSPECIFIED); + ls = scm_cons (scm_sym_letrec, z); + break; + } + case SCM_BIT8(SCM_IM_LETSTAR): + { + SCM b, y; + x = SCM_CDR (x); + b = SCM_CAR (x); + y = SCM_EOL; + if SCM_IMP (b) + { + env = EXTEND_ENV (SCM_EOL, SCM_EOL, env); + goto letstar; } y = z = scm_acons (SCM_CAR (b), unmemocar ( - scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b)), env), SCM_EOL), env), + scm_cons (unmemocopy (SCM_CADR (b), env), SCM_EOL), env), SCM_UNSPECIFIED); env = EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env); - b = SCM_CDR (SCM_CDR (b)); + b = SCM_CDDR (b); if (SCM_IMP (b)) { SCM_SETCDR (y, SCM_EOL); @@ -1405,11 +1438,11 @@ unmemocopy (SCM x, SCM env) { SCM_SETCDR (z, scm_acons (SCM_CAR (b), unmemocar ( - scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b)), env), SCM_EOL), env), + scm_list_1 (unmemocopy (SCM_CADR (b), env)), env), SCM_UNSPECIFIED)); z = SCM_CDR (z); env = EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env); - b = SCM_CDR (SCM_CDR (b)); + b = SCM_CDDR (b); } while (SCM_NIMP (b)); SCM_SETCDR (z, SCM_EOL); @@ -1422,8 +1455,8 @@ unmemocopy (SCM x, SCM env) break; case SCM_BIT8(SCM_IM_LAMBDA): x = SCM_CDR (x); - ls = scm_cons (scm_sym_lambda, - z = scm_cons (SCM_CAR (x), SCM_UNSPECIFIED)); + z = scm_cons (SCM_CAR (x), SCM_UNSPECIFIED); + ls = scm_cons (scm_sym_lambda, z); env = EXTEND_ENV (SCM_CAR (x), SCM_EOL, env); break; case SCM_BIT8(SCM_IM_QUOTE): @@ -1436,10 +1469,13 @@ unmemocopy (SCM x, SCM env) { SCM n; x = SCM_CDR (x); - ls = scm_cons (scm_sym_define, - z = scm_cons (n = SCM_CAR (x), SCM_UNSPECIFIED)); + n = SCM_CAR (x); + z = scm_cons (n, SCM_UNSPECIFIED); + ls = scm_cons (scm_sym_define, z); if (!SCM_NULLP (env)) - SCM_SETCAR (SCM_CAR (env), scm_cons (n, SCM_CAR (SCM_CAR (env)))); + env = scm_cons (scm_cons (scm_cons (n, SCM_CAAR (env)), + SCM_CDAR (env)), + SCM_CDR (env)); break; } case SCM_BIT8(SCM_MAKISYM (0)): @@ -1458,6 +1494,10 @@ unmemocopy (SCM x, SCM env) ls = z = scm_cons (scm_sym_delay, SCM_UNSPECIFIED); x = SCM_CDR (x); goto loop; + case (SCM_ISYMNUM (SCM_IM_FUTURE)): + ls = z = scm_cons (scm_sym_future, SCM_UNSPECIFIED); + x = SCM_CDR (x); + goto loop; case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES)): ls = z = scm_cons (scm_sym_at_call_with_values, SCM_UNSPECIFIED); goto loop; @@ -1503,23 +1543,22 @@ scm_unmemocopy (SCM x, SCM env) return unmemocopy (x, env); } -#ifndef SCM_RECKLESS int scm_badargsp (SCM formals, SCM args) { - while (SCM_NIMP (formals)) + while (!SCM_NULLP (formals)) { if (!SCM_CONSP (formals)) return 0; - if (SCM_IMP(args)) + if (SCM_NULLP (args)) return 1; formals = SCM_CDR (formals); args = SCM_CDR (args); } return !SCM_NULLP (args) ? 1 : 0; } -#endif + static int scm_badformalsp (SCM closure, int n) @@ -1546,14 +1585,12 @@ scm_eval_args (SCM l, SCM env, SCM proc) { res = EVALCAR (l, env); - *lloc = scm_cons (res, SCM_EOL); + *lloc = scm_list_1 (res); lloc = SCM_CDRLOC (*lloc); l = SCM_CDR (l); } -#ifdef SCM_CAUTIOUS if (!SCM_NULLP (l)) scm_wrong_num_args (proc); -#endif return results; } @@ -1569,7 +1606,11 @@ scm_eval_body (SCM code, SCM env) { if (SCM_ISYMP (SCM_CAR (code))) { - code = scm_m_expand_body (code, env); + scm_rec_mutex_lock (&source_mutex); + /* check for race condition */ + if (SCM_ISYMP (SCM_CAR (code))) + code = scm_m_expand_body (code, env); + scm_rec_mutex_unlock (&source_mutex); goto again; } } @@ -1595,7 +1636,7 @@ scm_eval_body (SCM code, SCM env) #define SCM_APPLY scm_apply #define PREP_APPLY(proc, args) #define ENTER_APPLY -#define RETURN(x) return x; +#define RETURN(x) do { return x; } while (0) #ifdef STACK_CHECKING #ifndef NO_CEVAL_STACK_CHECKING #define EVAL_STACK_CHECKING @@ -1615,7 +1656,7 @@ scm_eval_body (SCM code, SCM env) #define ENTER_APPLY \ do { \ SCM_SET_ARGSREADY (debug);\ - if (CHECK_APPLY && SCM_TRAPS_P)\ + if (scm_check_apply_p && SCM_TRAPS_P)\ if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\ {\ SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \ @@ -1637,7 +1678,7 @@ do { \ }\ } while (0) #undef RETURN -#define RETURN(e) {proc = (e); goto exit;} +#define RETURN(e) do { proc = (e); goto exit; } while (0) #ifdef STACK_CHECKING #ifndef EVAL_STACK_CHECKING #define EVAL_STACK_CHECKING @@ -1660,10 +1701,6 @@ SCM (*scm_ceval_ptr) (SCM x, SCM env); * any stack swaps. */ -#ifndef USE_THREADS -scm_t_debug_frame *scm_last_debug_frame; -#endif - /* scm_debug_eframe_size is the number of slots available for pseudo * stack frames at each real stack frame. */ @@ -1714,7 +1751,7 @@ SCM_DEFINE (scm_eval_options_interface, "eval-options-interface", 0, 1, 0, (SCM setting), "Option interface for the evaluation options. Instead of using\n" "this procedure directly, use the procedures @code{eval-enable},\n" - "@code{eval-disable}, @code{eval-set!} and @var{eval-options}.") + "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.") #define FUNC_NAME s_scm_eval_options_interface { SCM ans; @@ -1746,34 +1783,32 @@ SCM_DEFINE (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0, } #undef FUNC_NAME -SCM -scm_deval_args (SCM l, SCM env, SCM proc, SCM *lloc) +static SCM +deval_args (SCM l, SCM env, SCM proc, SCM *lloc) { SCM *results = lloc, res; while (SCM_CONSP (l)) { res = EVALCAR (l, env); - *lloc = scm_cons (res, SCM_EOL); + *lloc = scm_list_1 (res); lloc = SCM_CDRLOC (*lloc); l = SCM_CDR (l); } -#ifdef SCM_CAUTIOUS if (!SCM_NULLP (l)) scm_wrong_num_args (proc); -#endif return *results; } #endif /* !DEVAL */ -/* SECTION: Some local definitions for the evaluator. +/* SECTION: This code is compiled twice. */ + /* Update the toplevel environment frame ENV so that it refers to the - current module. -*/ + * current module. */ #define UPDATE_TOPLEVEL_ENV(env) \ do { \ SCM p = scm_current_module_lookup_closure (); \ @@ -1781,24 +1816,42 @@ scm_deval_args (SCM l, SCM env, SCM proc, SCM *lloc) env = scm_top_level_env (p); \ } while (0) -#ifndef DEVAL -#define CHECK_EQVISH(A,B) (SCM_EQ_P ((A), (B)) || (!SCM_FALSEP (scm_eqv_p ((A), (B))))) -#endif /* DEVAL */ - -#define BUILTIN_RPASUBR /* Handle rpsubrs and asubrs without calling apply */ -/* SECTION: This is the evaluator. Like any real monster, it has - * three heads. This code is compiled twice. - */ +/* This is the evaluator. Like any real monster, it has three heads: + * + * scm_ceval is the non-debugging evaluator, scm_deval is the debugging + * version. Both are implemented using a common code base, using the + * following mechanism: SCM_CEVAL is a macro, which is either defined to + * scm_ceval or scm_deval. Thus, there is no function SCM_CEVAL, but the code + * for SCM_CEVAL actually compiles to either scm_ceval or scm_deval. When + * SCM_CEVAL is defined to scm_ceval, it is known that the macro DEVAL is not + * defined. When SCM_CEVAL is defined to scm_deval, then the macro DEVAL is + * known to be defined. Thus, in SCM_CEVAL parts for the debugging evaluator + * are enclosed within #ifdef DEVAL ... #endif. + * + * All three (scm_ceval, scm_deval and their common implementation SCM_CEVAL) + * take two input parameters, x and env: x is a single expression to be + * evalutated. env is the environment in which bindings are searched. + * + * x is known to be a cell (i. e. a pair or any other non-immediate). Since x + * is a single expression, it is necessarily in a tail position. If x is just + * a call to another function like in the expression (foo exp1 exp2 ...), the + * realization of that call therefore _must_not_ increase stack usage (the + * evaluation of exp1, exp2 etc., however, may do so). This is realized by + * making extensive use of 'goto' statements within the evaluator: The gotos + * replace recursive calls to SCM_CEVAL, thus re-using the same stack frame + * that SCM_CEVAL was already using. If, however, x represents some form that + * requires to evaluate a sequence of expressions like (begin exp1 exp2 ...), + * then recursive calls to SCM_CEVAL are performed for all but the last + * expression of that sequence. */ #if 0 - SCM scm_ceval (SCM x, SCM env) {} #endif -#if 0 +#if 0 SCM scm_deval (SCM x, SCM env) {} @@ -1807,17 +1860,12 @@ scm_deval (SCM x, SCM env) SCM SCM_CEVAL (SCM x, SCM env) { - union - { - SCM *lloc; - SCM arg1; - } t; - SCM proc, arg2, orig_sym; + SCM proc, arg1; #ifdef DEVAL scm_t_debug_frame debug; scm_t_debug_info *debug_info_end; debug.prev = scm_last_debug_frame; - debug.status = scm_debug_eframe_size; + debug.status = 0; /* * The debug.vect contains twice as much scm_t_debug_info frames as the * user has specified with (debug-set! frames ). @@ -1825,7 +1873,7 @@ SCM_CEVAL (SCM x, SCM env) * Even frames are eval frames, odd frames are apply frames. */ debug.vect = (scm_t_debug_info *) alloca (scm_debug_eframe_size - * sizeof (debug.vect[0])); + * sizeof (scm_t_debug_info)); debug.info = debug.vect; debug_info_end = debug.vect + scm_debug_eframe_size; scm_last_debug_frame = &debug; @@ -1841,11 +1889,11 @@ SCM_CEVAL (SCM x, SCM env) scm_report_stack_overflow (); } #endif + #ifdef DEVAL goto start; #endif -loopnoap: - PREP_APPLY (SCM_UNDEFINED, SCM_EOL); + loop: #ifdef DEVAL SCM_CLEAR_ARGSREADY (debug); @@ -1858,583 +1906,704 @@ loop: * * 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'. + * label call PREP_APPLY. */ else if (++debug.info >= debug_info_end) { SCM_SET_OVERFLOW (debug); debug.info -= 2; } + start: debug.info->e.exp = x; debug.info->e.env = env; - if (CHECK_ENTRY && SCM_TRAPS_P) - if (SCM_ENTER_FRAME_P || (SCM_BREAKPOINTS_P && SRCBRKP (x))) - { - SCM tail = SCM_BOOL(SCM_TAILRECP (debug)); - SCM_SET_TAILREC (debug); - if (SCM_CHEAPTRAPS_P) - t.arg1 = scm_make_debugobj (&debug); - else - { - int first; - SCM val = scm_make_continuation (&first); - - if (first) - t.arg1 = val; - else - { - x = val; - if (SCM_IMP (x)) - { + if (scm_check_entry_p && SCM_TRAPS_P) + { + if (SCM_ENTER_FRAME_P + || (SCM_BREAKPOINTS_P && scm_c_source_property_breakpoint_p (x))) + { + SCM stackrep; + SCM tail = SCM_BOOL (SCM_TAILRECP (debug)); + SCM_SET_TAILREC (debug); + if (SCM_CHEAPTRAPS_P) + stackrep = scm_make_debugobj (&debug); + else + { + int first; + SCM val = scm_make_continuation (&first); + + if (first) + stackrep = val; + else + { + x = val; + if (SCM_IMP (x)) RETURN (x); - } - else - /* This gives the possibility for the debugger to - modify the source expression before evaluation. */ - goto dispatch; - } - } - SCM_TRAPS_P = 0; - scm_call_4 (SCM_ENTER_FRAME_HDLR, - scm_sym_enter_frame, - t.arg1, - tail, - scm_unmemocopy (x, env)); - SCM_TRAPS_P = 1; - } + else + /* This gives the possibility for the debugger to + modify the source expression before evaluation. */ + goto dispatch; + } + } + SCM_TRAPS_P = 0; + scm_call_4 (SCM_ENTER_FRAME_HDLR, + scm_sym_enter_frame, + stackrep, + tail, + scm_unmemocopy (x, env)); + SCM_TRAPS_P = 1; + } + } #endif -#if defined (USE_THREADS) || defined (DEVAL) dispatch: -#endif SCM_TICK; switch (SCM_TYP7 (x)) { case scm_tc7_symbol: - /* Only happens when called at top level. - */ + /* Only happens when called at top level. */ x = scm_cons (x, SCM_UNDEFINED); - goto retval; + RETURN (*scm_lookupcar (x, env, 1)); - case SCM_BIT8(SCM_IM_AND): + case SCM_BIT8 (SCM_IM_AND): x = SCM_CDR (x); - t.arg1 = x; - while (!SCM_NULLP (t.arg1 = SCM_CDR (t.arg1))) - if (SCM_FALSEP (EVALCAR (x, env))) - { + while (!SCM_NULLP (SCM_CDR (x))) + { + SCM test_result = EVALCAR (x, env); + if (SCM_FALSEP (test_result) || SCM_NILP (test_result)) RETURN (SCM_BOOL_F); - } - else - x = t.arg1; + else + x = SCM_CDR (x); + } PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto carloop; - case SCM_BIT8(SCM_IM_BEGIN): - /* (currently unused) - cdrxnoap: */ - PREP_APPLY (SCM_UNDEFINED, SCM_EOL); - /* (currently unused) - cdrxbegin: */ + case SCM_BIT8 (SCM_IM_BEGIN): x = SCM_CDR (x); + if (SCM_NULLP (x)) + RETURN (SCM_UNSPECIFIED); + + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); begin: /* If we are on toplevel with a lookup closure, we need to sync with the current module. */ if (SCM_CONSP (env) && !SCM_CONSP (SCM_CAR (env))) { - t.arg1 = x; UPDATE_TOPLEVEL_ENV (env); - while (!SCM_NULLP (t.arg1 = SCM_CDR (t.arg1))) + while (!SCM_NULLP (SCM_CDR (x))) { EVALCAR (x, env); - x = t.arg1; UPDATE_TOPLEVEL_ENV (env); + x = SCM_CDR (x); } goto carloop; } else goto nontoplevel_begin; - nontoplevel_cdrxnoap: - PREP_APPLY (SCM_UNDEFINED, SCM_EOL); - nontoplevel_cdrxbegin: - x = SCM_CDR (x); nontoplevel_begin: - t.arg1 = x; - while (!SCM_NULLP (t.arg1 = SCM_CDR (t.arg1))) + while (!SCM_NULLP (SCM_CDR (x))) { - if (SCM_IMP (SCM_CAR (x))) + SCM form = SCM_CAR (x); + if (SCM_IMP (form)) { - if (SCM_ISYMP (SCM_CAR (x))) + if (SCM_ISYMP (form)) { - x = scm_m_expand_body (x, env); + scm_rec_mutex_lock (&source_mutex); + /* check for race condition */ + if (SCM_ISYMP (SCM_CAR (x))) + x = scm_m_expand_body (x, env); + scm_rec_mutex_unlock (&source_mutex); goto nontoplevel_begin; } else - SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (x)); + SCM_VALIDATE_NON_EMPTY_COMBINATION (form); } else - SCM_CEVAL (SCM_CAR (x), env); - x = t.arg1; + SCM_CEVAL (form, env); + x = SCM_CDR (x); } - carloop: /* scm_eval car of last form in list */ - if (SCM_IMP (SCM_CAR (x))) - { - x = SCM_CAR (x); - RETURN (SCM_EVALIM (x, env)) - } + carloop: + { + /* scm_eval last form in list */ + SCM last_form = SCM_CAR (x); + + if (SCM_CONSP (last_form)) + { + /* This is by far the most frequent case. */ + x = last_form; + goto loop; /* tail recurse */ + } + else if (SCM_IMP (last_form)) + RETURN (SCM_EVALIM (last_form, env)); + else if (SCM_VARIABLEP (last_form)) + RETURN (SCM_VARIABLE_REF (last_form)); + else if (SCM_SYMBOLP (last_form)) + RETURN (*scm_lookupcar (x, env, 1)); + else + RETURN (last_form); + } - if (SCM_SYMBOLP (SCM_CAR (x))) - { - retval: - RETURN (*scm_lookupcar (x, env, 1)) - } - x = SCM_CAR (x); - goto loop; /* tail recurse */ + case SCM_BIT8 (SCM_IM_CASE): + x = SCM_CDR (x); + { + SCM key = EVALCAR (x, env); + x = SCM_CDR (x); + while (!SCM_NULLP (x)) + { + SCM clause = SCM_CAR (x); + SCM labels = SCM_CAR (clause); + if (SCM_EQ_P (labels, scm_sym_else)) + { + x = SCM_CDR (clause); + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); + goto begin; + } + while (!SCM_NULLP (labels)) + { + SCM label = SCM_CAR (labels); + if (SCM_EQ_P (label, key) || !SCM_FALSEP (scm_eqv_p (label, key))) + { + x = SCM_CDR (clause); + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); + goto begin; + } + labels = SCM_CDR (labels); + } + x = SCM_CDR (x); + } + } + RETURN (SCM_UNSPECIFIED); - case SCM_BIT8(SCM_IM_CASE): + case SCM_BIT8 (SCM_IM_COND): x = SCM_CDR (x); - t.arg1 = EVALCAR (x, env); - while (SCM_NIMP (x = SCM_CDR (x))) + while (!SCM_NULLP (x)) { - proc = SCM_CAR (x); - if (SCM_EQ_P (scm_sym_else, SCM_CAR (proc))) + SCM clause = SCM_CAR (x); + if (SCM_EQ_P (SCM_CAR (clause), scm_sym_else)) { - x = SCM_CDR (proc); + x = SCM_CDR (clause); PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto begin; } - proc = SCM_CAR (proc); - while (SCM_NIMP (proc)) + else { - if (CHECK_EQVISH (SCM_CAR (proc), t.arg1)) + arg1 = EVALCAR (clause, env); + if (!SCM_FALSEP (arg1) && !SCM_NILP (arg1)) { - x = SCM_CDR (SCM_CAR (x)); - PREP_APPLY (SCM_UNDEFINED, SCM_EOL); - goto begin; + x = SCM_CDR (clause); + if (SCM_NULLP (x)) + RETURN (arg1); + else if (!SCM_EQ_P (SCM_CAR (x), scm_sym_arrow)) + { + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); + goto begin; + } + else + { + proc = SCM_CDR (x); + proc = EVALCAR (proc, env); + SCM_ASRTGO (!SCM_IMP (proc), badfun); + PREP_APPLY (proc, scm_list_1 (arg1)); + ENTER_APPLY; + if (SCM_CLOSUREP(proc) && scm_badformalsp (proc, 1)) + goto umwrongnumargs; + else + goto evap1; + } } - proc = SCM_CDR (proc); + x = SCM_CDR (x); } } - RETURN (SCM_UNSPECIFIED) + RETURN (SCM_UNSPECIFIED); - case SCM_BIT8(SCM_IM_COND): - while (!SCM_IMP (x = SCM_CDR (x))) - { - proc = SCM_CAR (x); - t.arg1 = EVALCAR (proc, env); - if (!SCM_FALSEP (t.arg1)) + case SCM_BIT8 (SCM_IM_DO): + x = SCM_CDR (x); + { + /* Compute the initialization values and the initial environment. */ + SCM init_forms = SCM_CADR (x); + SCM init_values = SCM_EOL; + while (!SCM_NULLP (init_forms)) + { + init_values = scm_cons (EVALCAR (init_forms, env), init_values); + init_forms = SCM_CDR (init_forms); + } + env = EXTEND_ENV (SCM_CAR (x), init_values, env); + } + x = SCM_CDDR (x); + { + SCM test_form = SCM_CAR (x); + SCM body_forms = SCM_CADR (x); + SCM step_forms = SCM_CDDR (x); + + SCM test_result = EVALCAR (test_form, env); + + while (SCM_FALSEP (test_result) || SCM_NILP (test_result)) + { { - x = SCM_CDR (proc); - if (SCM_NULLP (x)) - { - RETURN (t.arg1) - } - if (!SCM_EQ_P (scm_sym_arrow, SCM_CAR (x))) + /* Evaluate body forms. */ + SCM temp_forms; + for (temp_forms = body_forms; + !SCM_NULLP (temp_forms); + temp_forms = SCM_CDR (temp_forms)) { - PREP_APPLY (SCM_UNDEFINED, SCM_EOL); - goto begin; + SCM form = SCM_CAR (temp_forms); + /* Dirk:FIXME: We only need to eval forms, that may have a + * side effect here. This is only true for forms that start + * with a pair. All others are just constants. However, + * since in the common case there is no constant expression + * in a body of a do form, we just check for immediates here + * and have SCM_CEVAL take care of other cases. In the long + * run it would make sense to get rid of this test and have + * the macro transformer of 'do' eliminate all forms that + * have no sideeffect. */ + if (!SCM_IMP (form)) + SCM_CEVAL (form, env); } - proc = SCM_CDR (x); - proc = EVALCAR (proc, env); - SCM_ASRTGO (SCM_NIMP (proc), badfun); - PREP_APPLY (proc, scm_cons (t.arg1, SCM_EOL)); - ENTER_APPLY; - if (SCM_CLOSUREP(proc) && scm_badformalsp (proc, 1)) - goto umwrongnumargs; - goto evap1; } - } - RETURN (SCM_UNSPECIFIED) - - case SCM_BIT8(SCM_IM_DO): - x = SCM_CDR (x); - proc = SCM_CAR (SCM_CDR (x)); /* inits */ - t.arg1 = SCM_EOL; /* values */ - while (SCM_NIMP (proc)) - { - t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1); - proc = SCM_CDR (proc); - } - env = EXTEND_ENV (SCM_CAR (x), t.arg1, env); - x = SCM_CDR (SCM_CDR (x)); - while (proc = SCM_CAR (x), SCM_FALSEP (EVALCAR (proc, env))) - { - for (proc = SCM_CADR (x); SCM_NIMP (proc); proc = SCM_CDR (proc)) { - t.arg1 = SCM_CAR (proc); /* body */ - SIDEVAL (t.arg1, env); + /* Evaluate the step expressions. */ + SCM temp_forms; + SCM step_values = SCM_EOL; + for (temp_forms = step_forms; + !SCM_NULLP (temp_forms); + temp_forms = SCM_CDR (temp_forms)) + { + SCM value = EVALCAR (temp_forms, env); + step_values = scm_cons (value, step_values); + } + env = EXTEND_ENV (SCM_CAAR (env), step_values, SCM_CDR (env)); } - 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)); - } - x = SCM_CDR (proc); + + test_result = EVALCAR (test_form, env); + } + } + x = SCM_CDAR (x); if (SCM_NULLP (x)) RETURN (SCM_UNSPECIFIED); PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto nontoplevel_begin; - case SCM_BIT8(SCM_IM_IF): + case SCM_BIT8 (SCM_IM_IF): x = SCM_CDR (x); - if (!SCM_FALSEP (EVALCAR (x, env))) - x = SCM_CDR (x); - else if (SCM_IMP (x = SCM_CDR (SCM_CDR (x)))) - { - RETURN (SCM_UNSPECIFIED); - } + { + SCM test_result = EVALCAR (x, env); + if (!SCM_FALSEP (test_result) && !SCM_NILP (test_result)) + x = SCM_CDR (x); + else + { + x = SCM_CDDR (x); + if (SCM_NULLP (x)) + RETURN (SCM_UNSPECIFIED); + } + } PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto carloop; - case SCM_BIT8(SCM_IM_LET): - x = SCM_CDR (x); - proc = SCM_CAR (SCM_CDR (x)); - t.arg1 = SCM_EOL; - do - { - t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1); - } - while (SCM_NIMP (proc = SCM_CDR (proc))); - env = EXTEND_ENV (SCM_CAR (x), t.arg1, env); + case SCM_BIT8 (SCM_IM_LET): x = SCM_CDR (x); - goto nontoplevel_cdrxnoap; + { + SCM init_forms = SCM_CADR (x); + SCM init_values = SCM_EOL; + do + { + init_values = scm_cons (EVALCAR (init_forms, env), init_values); + init_forms = SCM_CDR (init_forms); + } + while (!SCM_NULLP (init_forms)); + env = EXTEND_ENV (SCM_CAR (x), init_values, env); + } + x = SCM_CDDR (x); + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); + goto nontoplevel_begin; - case SCM_BIT8(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); - proc = SCM_CAR (x); - t.arg1 = SCM_EOL; - do - { - t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1); - } - while (SCM_NIMP (proc = SCM_CDR (proc))); - SCM_SETCDR (SCM_CAR (env), t.arg1); - goto nontoplevel_cdrxnoap; + { + SCM init_forms = SCM_CAR (x); + SCM init_values = SCM_EOL; + do + { + init_values = scm_cons (EVALCAR (init_forms, env), init_values); + init_forms = SCM_CDR (init_forms); + } + while (!SCM_NULLP (init_forms)); + SCM_SETCDR (SCM_CAR (env), init_values); + } + x = SCM_CDR (x); + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); + goto nontoplevel_begin; - case SCM_BIT8(SCM_IM_LETSTAR): + case SCM_BIT8 (SCM_IM_LETSTAR): x = SCM_CDR (x); - proc = SCM_CAR (x); - if (SCM_IMP (proc)) - { + { + SCM bindings = SCM_CAR (x); + if (SCM_NULLP (bindings)) env = EXTEND_ENV (SCM_EOL, SCM_EOL, env); - goto nontoplevel_cdrxnoap; - } - do - { - t.arg1 = SCM_CAR (proc); - proc = SCM_CDR (proc); - env = EXTEND_ENV (t.arg1, EVALCAR (proc, env), env); - } - while (SCM_NIMP (proc = SCM_CDR (proc))); - goto nontoplevel_cdrxnoap; + else + { + do + { + SCM name = SCM_CAR (bindings); + SCM init = SCM_CDR (bindings); + env = EXTEND_ENV (name, EVALCAR (init, env), env); + bindings = SCM_CDR (init); + } + while (!SCM_NULLP (bindings)); + } + } + x = SCM_CDR (x); + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); + goto nontoplevel_begin; - case SCM_BIT8(SCM_IM_OR): + + case SCM_BIT8 (SCM_IM_OR): x = SCM_CDR (x); - t.arg1 = x; - while (!SCM_NULLP (t.arg1 = SCM_CDR (t.arg1))) + while (!SCM_NULLP (SCM_CDR (x))) { - x = EVALCAR (x, env); - if (!SCM_FALSEP (x)) - { - RETURN (x); - } - x = t.arg1; + SCM val = EVALCAR (x, env); + if (!SCM_FALSEP (val) && !SCM_NILP (val)) + RETURN (val); + else + x = SCM_CDR (x); } PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto carloop; - case SCM_BIT8(SCM_IM_LAMBDA): + case SCM_BIT8 (SCM_IM_LAMBDA): RETURN (scm_closure (SCM_CDR (x), env)); - case SCM_BIT8(SCM_IM_QUOTE): - RETURN (SCM_CAR (SCM_CDR (x))); + case SCM_BIT8 (SCM_IM_QUOTE): + RETURN (SCM_CADR (x)); - case SCM_BIT8(SCM_IM_SET_X): - x = SCM_CDR (x); - proc = SCM_CAR (x); - switch (SCM_ITAG3 (proc)) - { - case scm_tc3_cons: - if (SCM_VARIABLEP (proc)) - t.lloc = SCM_VARIABLE_LOC (proc); - else - t.lloc = scm_lookupcar (x, env, 1); - break; -#ifdef MEMOIZE_LOCALS - case scm_tc3_imm24: - t.lloc = scm_ilookup (proc, env); - break; -#endif - } + case SCM_BIT8 (SCM_IM_SET_X): x = SCM_CDR (x); - *t.lloc = EVALCAR (x, env); -#ifdef SICP - RETURN (*t.lloc); -#else + { + SCM *location; + SCM variable = SCM_CAR (x); + if (SCM_ILOCP (variable)) + location = scm_ilookup (variable, env); + else if (SCM_VARIABLEP (variable)) + location = SCM_VARIABLE_LOC (variable); + else /* (SCM_SYMBOLP (variable)) is known to be true */ + location = scm_lookupcar (x, env, 1); + x = SCM_CDR (x); + *location = EVALCAR (x, env); + } RETURN (SCM_UNSPECIFIED); -#endif 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 SCM_BIT8(SCM_MAKISYM (0)): + case SCM_BIT8 (SCM_MAKISYM (0)): proc = SCM_CAR (x); SCM_ASRTGO (SCM_ISYMP (proc), badfun); - switch SCM_ISYMNUM (proc) + switch (SCM_ISYMNUM (proc)) { + + case (SCM_ISYMNUM (SCM_IM_APPLY)): proc = SCM_CDR (x); proc = EVALCAR (proc, env); - SCM_ASRTGO (SCM_NIMP (proc), badfun); + SCM_ASRTGO (!SCM_IMP (proc), badfun); if (SCM_CLOSUREP (proc)) { - SCM argl, tl; PREP_APPLY (proc, SCM_EOL); - t.arg1 = SCM_CDR (SCM_CDR (x)); - t.arg1 = EVALCAR (t.arg1, env); + arg1 = SCM_CDDR (x); + arg1 = EVALCAR (arg1, env); apply_closure: /* Go here to tail-call a closure. PROC is the closure - and T.ARG1 is the list of arguments. Do not forget to - call PREP_APPLY. */ + and ARG1 is the list of arguments. Do not forget to + call PREP_APPLY. */ + { + SCM formals = SCM_CLOSURE_FORMALS (proc); #ifdef DEVAL - debug.info->a.args = t.arg1; -#endif -#ifndef SCM_RECKLESS - if (scm_badargsp (SCM_CLOSURE_FORMALS (proc), t.arg1)) - goto wrongnumargs; + debug.info->a.args = arg1; #endif - ENTER_APPLY; - /* Copy argument list */ - if (SCM_IMP (t.arg1)) - argl = t.arg1; - else - { - argl = tl = scm_cons (SCM_CAR (t.arg1), SCM_UNSPECIFIED); - while (SCM_NIMP (t.arg1 = SCM_CDR (t.arg1)) - && SCM_CONSP (t.arg1)) - { - SCM_SETCDR (tl, scm_cons (SCM_CAR (t.arg1), - SCM_UNSPECIFIED)); - tl = SCM_CDR (tl); - } - SCM_SETCDR (tl, t.arg1); - } + if (scm_badargsp (formals, arg1)) + scm_wrong_num_args (proc); + ENTER_APPLY; + /* Copy argument list */ + if (SCM_NULL_OR_NIL_P (arg1)) + env = EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc)); + else + { + SCM args = scm_list_1 (SCM_CAR (arg1)); + SCM tail = args; + arg1 = SCM_CDR (arg1); + while (!SCM_NULL_OR_NIL_P (arg1)) + { + SCM new_tail = scm_list_1 (SCM_CAR (arg1)); + SCM_SETCDR (tail, new_tail); + tail = new_tail; + arg1 = SCM_CDR (arg1); + } + env = EXTEND_ENV (formals, args, SCM_ENV (proc)); + } - env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), argl, SCM_ENV (proc)); - x = SCM_CODE (proc); - goto nontoplevel_cdrxbegin; + x = SCM_CLOSURE_BODY (proc); + goto nontoplevel_begin; + } + } + else + { + proc = scm_f_apply; + goto evapply; } - proc = scm_f_apply; - goto evapply; + case (SCM_ISYMNUM (SCM_IM_CONT)): { int first; SCM val = scm_make_continuation (&first); - if (first) - t.arg1 = val; - else + if (!first) RETURN (val); + else + { + arg1 = val; + proc = SCM_CDR (x); + proc = scm_eval_car (proc, env); + SCM_ASRTGO (SCM_NIMP (proc), badfun); + PREP_APPLY (proc, scm_list_1 (arg1)); + ENTER_APPLY; + if (SCM_CLOSUREP(proc) && scm_badformalsp (proc, 1)) + goto umwrongnumargs; + goto evap1; + } } - proc = SCM_CDR (x); - proc = evalcar (proc, env); - SCM_ASRTGO (SCM_NIMP (proc), badfun); - PREP_APPLY (proc, scm_cons (t.arg1, SCM_EOL)); - ENTER_APPLY; - if (SCM_CLOSUREP(proc) && scm_badformalsp (proc, 1)) - goto umwrongnumargs; - goto evap1; + case (SCM_ISYMNUM (SCM_IM_DELAY)): - RETURN (scm_makprom (scm_closure (SCM_CDR (x), env))) + RETURN (scm_makprom (scm_closure (SCM_CDR (x), env))); + + + case (SCM_ISYMNUM (SCM_IM_FUTURE)): + RETURN (scm_i_make_future (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_CONSP (proc)) - { - if (SCM_VARIABLEP (proc)) - arg2 = SCM_VARIABLE_REF (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%. - */ { - long 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_VECTOR_LENGTH (proc); - } + /* If not done yet, evaluate the operand forms. The result is a + * list of arguments stored in arg1, which is used to perform the + * function dispatch. */ + SCM operand_forms = SCM_CADR (x); + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); + if (SCM_ILOCP (operand_forms)) + arg1 = *scm_ilookup (operand_forms, env); + else if (SCM_VARIABLEP (operand_forms)) + arg1 = SCM_VARIABLE_REF (operand_forms); + else if (!SCM_CONSP (operand_forms)) + arg1 = *scm_lookupcar (SCM_CDR (x), env, 1); else { - /* Compute a hash value */ - long hashset = SCM_INUM (proc); - long j = n; - z = SCM_CDDR (z); - mask = SCM_INUM (SCM_CAR (z)); - proc = SCM_CADR (z); - i = 0; - t.arg1 = arg2; - if (SCM_NIMP (t.arg1)) - do + SCM tail = arg1 = scm_list_1 (EVALCAR (operand_forms, env)); + operand_forms = SCM_CDR (operand_forms); + while (!SCM_NULLP (operand_forms)) + { + SCM new_tail = scm_list_1 (EVALCAR (operand_forms, env)); + SCM_SETCDR (tail, new_tail); + tail = new_tail; + operand_forms = SCM_CDR (operand_forms); + } + } + } + + /* The type dispatch code is duplicated below + * (c.f. objects.c:scm_mcache_compute_cmethod) since that + * cuts down execution time for type dispatch to 50%. */ + type_dispatch: /* inputs: x, arg1 */ + /* Type dispatch means to determine from the types of the function + * arguments (i. e. the 'signature' of the call), which method from + * a generic function is to be called. This process of selecting + * the right method takes some time. To speed it up, guile uses + * caching: Together with the macro call to dispatch the signatures + * of some previous calls to that generic function from the same + * place are stored (in the code!) in a cache that we call the + * 'method cache'. This is done since it is likely, that + * consecutive calls to dispatch from that position in the code will + * have the same signature. Thus, the type dispatch works as + * follows: First, determine a hash value from the signature of the + * actual arguments. Second, use this hash value as an index to + * find that same signature in the method cache stored at this + * position in the code. If found, you have also found the + * corresponding method that belongs to that signature. If the + * signature is not found in the method cache, you have to perform a + * full search over all signatures stored with the generic + * function. */ + { + unsigned long int specializers; + unsigned long int hash_value; + unsigned long int cache_end_pos; + unsigned long int mask; + SCM method_cache; + + { + SCM z = SCM_CDDR (x); + SCM tmp = SCM_CADR (z); + specializers = SCM_INUM (SCM_CAR (z)); + + /* Compute a hash value for searching the method cache. There + * are two variants for computing the hash value, a (rather) + * complicated one, and a simple one. For the complicated one + * explained below, tmp holds a number that is used in the + * computation. */ + if (SCM_INUMP (tmp)) + { + /* Use the signature of the actual arguments to determine + * the hash value. This is done as follows: Each class has + * an array of random numbers, that are determined when the + * class is created. The integer 'hashset' is an index into + * that array of random numbers. Now, from all classes that + * are part of the signature of the actual arguments, the + * random numbers at index 'hashset' are taken and summed + * up, giving the hash value. The value of 'hashset' is + * stored at the call to dispatch. This allows to have + * different 'formulas' for calculating the hash value at + * different places where dispatch is called. This allows + * to optimize the hash formula at every individual place + * where dispatch is called, such that hopefully the hash + * value that is computed will directly point to the right + * method in the method cache. */ + unsigned long int hashset = SCM_INUM (tmp); + unsigned long int counter = specializers + 1; + SCM tmp_arg = arg1; + hash_value = 0; + while (!SCM_NULLP (tmp_arg) && counter != 0) { - i += SCM_STRUCT_DATA (scm_class_of (SCM_CAR (t.arg1))) - [scm_si_hashsets + hashset]; - t.arg1 = SCM_CDR (t.arg1); + SCM class = scm_class_of (SCM_CAR (tmp_arg)); + hash_value += SCM_INSTANCE_HASH (class, hashset); + tmp_arg = SCM_CDR (tmp_arg); + counter--; } - while (j-- && SCM_NIMP (t.arg1)); - i &= mask; - end = i; - } + z = SCM_CDDR (z); + method_cache = SCM_CADR (z); + mask = SCM_INUM (SCM_CAR (z)); + hash_value &= mask; + cache_end_pos = hash_value; + } + else + { + /* This method of determining the hash value is much + * simpler: Set the hash value to zero and just perform a + * linear search through the method cache. */ + method_cache = tmp; + mask = (unsigned long int) ((long) -1); + hash_value = 0; + cache_end_pos = SCM_VECTOR_LENGTH (method_cache); + } + } - /* Search for match */ - do - { - long j = n; - z = SCM_VELTS (proc)[i]; - t.arg1 = arg2; /* list of arguments */ - if (SCM_NIMP (t.arg1)) - do + { + /* Search the method cache for a method with a matching + * signature. Start the search at position 'hash_value'. The + * hashing implementation uses linear probing for conflict + * resolution, that is, if the signature in question is not + * found at the starting index in the hash table, the next table + * entry is tried, and so on, until in the worst case the whole + * cache has been searched, but still the signature has not been + * found. */ + SCM z; + do + { + SCM args = arg1; /* list of arguments */ + z = SCM_VELTS (method_cache)[hash_value]; + while (!SCM_NULLP (args)) { /* More arguments than specifiers => CLASS != ENV */ - if (! SCM_EQ_P (scm_class_of (SCM_CAR (t.arg1)), SCM_CAR (z))) + SCM class_of_arg = scm_class_of (SCM_CAR (args)); + if (!SCM_EQ_P (class_of_arg, SCM_CAR (z))) goto next_method; - t.arg1 = SCM_CDR (t.arg1); + args = SCM_CDR (args); 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 nontoplevel_cdrxbegin; - next_method: - i = (i + 1) & mask; - } while (i != end); - - z = scm_memoize_method (x, arg2); - goto apply_cmethod; + /* Fewer arguments than specifiers => CAR != ENV */ + if (SCM_NULLP (SCM_CAR (z)) || SCM_CONSP (SCM_CAR (z))) + goto apply_cmethod; + next_method: + hash_value = (hash_value + 1) & mask; + } while (hash_value != cache_end_pos); + + /* No appropriate method was found in the cache. */ + z = scm_memoize_method (x, arg1); + + apply_cmethod: /* inputs: z, arg1 */ + { + SCM formals = SCM_CMETHOD_FORMALS (z); + env = EXTEND_ENV (formals, arg1, SCM_CMETHOD_ENV (z)); + x = SCM_CMETHOD_BODY (z); + goto nontoplevel_begin; + } + } } + 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))])) - + { + SCM instance = EVALCAR (x, env); + unsigned long int slot = SCM_INUM (SCM_CADR (x)); + RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot])); + } + + 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) + { + SCM instance = EVALCAR (x, env); + unsigned long int slot = SCM_INUM (SCM_CADR (x)); + SCM value = EVALCAR (SCM_CDDR (x), env); + SCM_STRUCT_DATA (instance) [slot] = SCM_UNPACK (value); + RETURN (SCM_UNSPECIFIED); + } + + +#ifdef SCM_ENABLE_ELISP 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)) - || SCM_EQ_P (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_FALSEP (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)) - || SCM_EQ_P (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; + { + SCM test_form = SCM_CDR (x); + x = SCM_CDR (test_form); + while (!SCM_NULL_OR_NIL_P (x)) + { + SCM test_result = EVALCAR (test_form, env); + if (!(SCM_FALSEP (test_result) + || SCM_NULL_OR_NIL_P (test_result))) + { + if (SCM_EQ_P (SCM_CAR (x), SCM_UNSPECIFIED)) + RETURN (test_result); + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); + goto carloop; + } + else + { + test_form = SCM_CDR (x); + x = SCM_CDR (test_form); + } + } + x = test_form; + 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_FALSEP (EVALCAR (x, env)) - ? SCM_MAKINUM (1) - : SCM_INUM0) +#endif /* SCM_ENABLE_ELISP */ case (SCM_ISYMNUM (SCM_IM_BIND)): { @@ -2454,40 +2623,42 @@ dispatch: scm_swap_bindings (vars, vals); scm_dynwinds = scm_acons (vars, vals, scm_dynwinds); - - arg2 = x = SCM_CDR (x); - while (!SCM_NULLP (arg2 = SCM_CDR (arg2))) + + /* Ignore all but the last evaluation result. */ + for (x = SCM_CDR (x); !SCM_NULLP (SCM_CDR (x)); x = SCM_CDR (x)) { - SIDEVAL (SCM_CAR (x), env); - x = arg2; + if (SCM_CONSP (SCM_CAR (x))) + SCM_CEVAL (SCM_CAR (x), env); } proc = EVALCAR (x, env); scm_dynwinds = SCM_CDR (scm_dynwinds); scm_swap_bindings (vars, vals); - RETURN (proc) + RETURN (proc); } - + + case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES)): { proc = SCM_CDR (x); x = EVALCAR (proc, env); proc = SCM_CDR (proc); proc = EVALCAR (proc, env); - t.arg1 = SCM_APPLY (x, SCM_EOL, SCM_EOL); - if (SCM_VALUESP (t.arg1)) - t.arg1 = scm_struct_ref (t.arg1, SCM_INUM0); + arg1 = SCM_APPLY (x, SCM_EOL, SCM_EOL); + if (SCM_VALUESP (arg1)) + arg1 = scm_struct_ref (arg1, SCM_INUM0); else - t.arg1 = scm_cons (t.arg1, SCM_EOL); + arg1 = scm_list_1 (arg1); if (SCM_CLOSUREP (proc)) { - PREP_APPLY (proc, t.arg1); + PREP_APPLY (proc, arg1); goto apply_closure; } - return SCM_APPLY (proc, t.arg1, SCM_EOL); + return SCM_APPLY (proc, arg1, SCM_EOL); } + default: goto badfun; } @@ -2495,11 +2666,10 @@ dispatch: default: proc = x; badfun: - /* scm_everr (x, env,...) */ scm_misc_error (NULL, "Wrong type to apply: ~S", scm_list_1 (proc)); case scm_tc7_vector: case scm_tc7_wvect: -#ifdef HAVE_ARRAYS +#ifdef SCM_HAVE_ARRAYS case scm_tc7_bvect: case scm_tc7_byvect: case scm_tc7_svect: @@ -2508,7 +2678,7 @@ dispatch: case scm_tc7_fvect: case scm_tc7_dvect: case scm_tc7_cvect: -#ifdef HAVE_LONG_LONGS +#if SCM_SIZEOF_LONG_LONG != 0 case scm_tc7_llvect: #endif #endif @@ -2524,33 +2694,24 @@ dispatch: case scm_tc7_variable: RETURN (SCM_VARIABLE_REF(x)); -#ifdef MEMOIZE_LOCALS case SCM_BIT8(SCM_ILOC00): proc = *scm_ilookup (SCM_CAR (x), env); SCM_ASRTGO (SCM_NIMP (proc), badfun); -#ifndef SCM_RECKLESS -#ifdef SCM_CAUTIOUS goto checkargs; -#endif -#endif - break; -#endif /* ifdef MEMOIZE_LOCALS */ - + case scm_tcs_cons_nimcar: - orig_sym = SCM_CAR (x); - if (SCM_SYMBOLP (orig_sym)) + if (SCM_SYMBOLP (SCM_CAR (x))) { -#ifdef USE_THREADS - t.lloc = scm_lookupcar1 (x, env, 1); - if (t.lloc == NULL) - { - /* we have lost the race, start again. */ - goto dispatch; - } - proc = *t.lloc; -#else - proc = *scm_lookupcar (x, env, 1); -#endif + SCM orig_sym = SCM_CAR (x); + { + SCM *location = scm_lookupcar1 (x, env, 1); + if (location == NULL) + { + /* we have lost the race, start again. */ + goto dispatch; + } + proc = *location; + } if (SCM_IMP (proc)) { @@ -2562,13 +2723,13 @@ dispatch: { SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of lookupcar */ - handle_a_macro: + handle_a_macro: /* inputs: x, env, proc */ #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_MACRO_CODE (proc), x, + arg1 = SCM_APPLY (SCM_MACRO_CODE (proc), x, scm_cons (env, scm_listofnull)); #ifdef DEVAL @@ -2577,14 +2738,14 @@ dispatch: switch (SCM_MACRO_TYPE (proc)) { case 2: - if (scm_ilength (t.arg1) <= 0) - t.arg1 = scm_cons2 (SCM_IM_BEGIN, t.arg1, SCM_EOL); + if (scm_ilength (arg1) <= 0) + arg1 = scm_list_2 (SCM_IM_BEGIN, arg1); #ifdef DEVAL if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc))) { SCM_DEFER_INTS; - SCM_SETCAR (x, SCM_CAR (t.arg1)); - SCM_SETCDR (x, SCM_CDR (t.arg1)); + SCM_SETCAR (x, SCM_CAR (arg1)); + SCM_SETCDR (x, SCM_CDR (arg1)); SCM_ALLOW_INTS; goto dispatch; } @@ -2594,48 +2755,54 @@ dispatch: SCM_CDR (x)); #endif SCM_DEFER_INTS; - SCM_SETCAR (x, SCM_CAR (t.arg1)); - SCM_SETCDR (x, SCM_CDR (t.arg1)); + SCM_SETCAR (x, SCM_CAR (arg1)); + SCM_SETCDR (x, SCM_CDR (arg1)); SCM_ALLOW_INTS; - goto loopnoap; + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); + goto loop; +#if SCM_ENABLE_DEPRECATED == 1 case 1: - if (SCM_NIMP (x = t.arg1)) - goto loopnoap; + x = arg1; + if (SCM_NIMP (x)) + { + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); + goto loop; + } + else + RETURN (arg1); +#endif case 0: - RETURN (t.arg1); + RETURN (arg1); } } } else proc = SCM_CEVAL (SCM_CAR (x), env); SCM_ASRTGO (!SCM_IMP (proc), badfun); -#ifndef SCM_RECKLESS -#ifdef SCM_CAUTIOUS + checkargs: -#endif if (SCM_CLOSUREP (proc)) { - arg2 = SCM_CLOSURE_FORMALS (proc); - t.arg1 = SCM_CDR (x); - while (!SCM_NULLP (arg2)) + SCM formals = SCM_CLOSURE_FORMALS (proc); + SCM args = SCM_CDR (x); + while (!SCM_NULLP (formals)) { - if (!SCM_CONSP (arg2)) + if (!SCM_CONSP (formals)) goto evapply; - if (SCM_IMP (t.arg1)) + if (SCM_IMP (args)) goto umwrongnumargs; - arg2 = SCM_CDR (arg2); - t.arg1 = SCM_CDR (t.arg1); + formals = SCM_CDR (formals); + args = SCM_CDR (args); } - if (!SCM_NULLP (t.arg1)) + if (!SCM_NULLP (args)) goto umwrongnumargs; } else if (SCM_MACROP (proc)) goto handle_a_macro; -#endif } -evapply: +evapply: /* inputs: x, proc */ PREP_APPLY (proc, SCM_EOL); if (SCM_NULLP (SCM_CDR (x))) { ENTER_APPLY; @@ -2657,11 +2824,11 @@ evapply: goto badfun; RETURN (SCM_SMOB_APPLY_0 (proc)); case scm_tc7_cclo: - t.arg1 = proc; + arg1 = proc; proc = SCM_CCLO_SUBR (proc); #ifdef DEVAL debug.info->a.proc = proc; - debug.info->a.args = scm_cons (t.arg1, SCM_EOL); + debug.info->a.args = scm_list_1 (arg1); #endif goto evap1; case scm_tc7_pws: @@ -2674,27 +2841,27 @@ evapply: if (scm_badformalsp (proc, 0)) goto umwrongnumargs; case scm_tcs_closures: - x = SCM_CODE (proc); + x = SCM_CLOSURE_BODY (proc); env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), SCM_EOL, SCM_ENV (proc)); - goto nontoplevel_cdrxbegin; + goto nontoplevel_begin; case scm_tcs_struct: if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) { x = SCM_ENTITY_PROCEDURE (proc); - arg2 = SCM_EOL; + arg1 = SCM_EOL; goto type_dispatch; } else if (!SCM_I_OPERATORP (proc)) goto badfun; else { - t.arg1 = proc; + arg1 = proc; proc = (SCM_I_ENTITYP (proc) ? SCM_ENTITY_PROCEDURE (proc) : SCM_OPERATOR_PROCEDURE (proc)); #ifdef DEVAL debug.info->a.proc = proc; - debug.info->a.args = scm_cons (t.arg1, SCM_EOL); + debug.info->a.args = scm_list_1 (arg1); #endif if (SCM_NIMP (proc)) goto evap1; @@ -2709,8 +2876,6 @@ evapply: case scm_tc7_lsubr_2: umwrongnumargs: unmemocar (x, env); - wrongnumargs: - /* scm_everr (x, env,...) */ scm_wrong_num_args (proc); default: /* handle macros here */ @@ -2720,459 +2885,425 @@ evapply: /* must handle macros by here */ x = SCM_CDR (x); -#ifdef SCM_CAUTIOUS - if (SCM_IMP (x)) - goto wrongnumargs; - 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); - } + if (SCM_CONSP (x)) + arg1 = EVALCAR (x, env); else - goto wrongnumargs; -#else - t.arg1 = EVALCAR (x, env); -#endif + scm_wrong_num_args (proc); #ifdef DEVAL - debug.info->a.args = scm_cons (t.arg1, SCM_EOL); + debug.info->a.args = scm_list_1 (arg1); #endif x = SCM_CDR (x); - if (SCM_NULLP (x)) - { - ENTER_APPLY; - evap1: - switch (SCM_TYP7 (proc)) - { /* have one argument in t.arg1 */ - case scm_tc7_subr_2o: - RETURN (SCM_SUBRF (proc) (t.arg1, SCM_UNDEFINED)); - case scm_tc7_subr_1: - case scm_tc7_subr_1o: - RETURN (SCM_SUBRF (proc) (t.arg1)); - case scm_tc7_cxr: - if (SCM_SUBRF (proc)) - { - if (SCM_INUMP (t.arg1)) - { - RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (t.arg1)))); - } - else if (SCM_REALP (t.arg1)) - { - RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (t.arg1)))); - } + { + SCM arg2; + if (SCM_NULLP (x)) + { + ENTER_APPLY; + evap1: /* inputs: proc, arg1 */ + switch (SCM_TYP7 (proc)) + { /* have one argument in arg1 */ + case scm_tc7_subr_2o: + RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED)); + case scm_tc7_subr_1: + case scm_tc7_subr_1o: + RETURN (SCM_SUBRF (proc) (arg1)); + case scm_tc7_cxr: + if (SCM_SUBRF (proc)) + { + if (SCM_INUMP (arg1)) + { + RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1)))); + } + else if (SCM_REALP (arg1)) + { + RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1)))); + } #ifdef SCM_BIGDIG - else if (SCM_BIGP (t.arg1)) + else if (SCM_BIGP (arg1)) + { + RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1)))); + } +#endif + SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1, + SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc))); + } + proc = SCM_SNAME (proc); + { + char *chrs = SCM_SYMBOL_CHARS (proc) + SCM_SYMBOL_LENGTH (proc) - 1; + while ('c' != *--chrs) { - RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (t.arg1)))); + SCM_ASSERT (SCM_CONSP (arg1), + arg1, SCM_ARG1, SCM_SYMBOL_CHARS (proc)); + arg1 = ('a' == *chrs) ? SCM_CAR (arg1) : SCM_CDR (arg1); } -#endif - SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), t.arg1, - SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc))); + RETURN (arg1); } - proc = SCM_SNAME (proc); - { - char *chrs = SCM_SYMBOL_CHARS (proc) + SCM_SYMBOL_LENGTH (proc) - 1; - while ('c' != *--chrs) - { - SCM_ASSERT (SCM_CONSP (t.arg1), - t.arg1, SCM_ARG1, SCM_SYMBOL_CHARS (proc)); - t.arg1 = ('a' == *chrs) ? SCM_CAR (t.arg1) : SCM_CDR (t.arg1); - } - RETURN (t.arg1); - } - case scm_tc7_rpsubr: - RETURN (SCM_BOOL_T); - case scm_tc7_asubr: - RETURN (SCM_SUBRF (proc) (t.arg1, SCM_UNDEFINED)); - case scm_tc7_lsubr: + case scm_tc7_rpsubr: + RETURN (SCM_BOOL_T); + case scm_tc7_asubr: + RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED)); + case scm_tc7_lsubr: #ifdef DEVAL - RETURN (SCM_SUBRF (proc) (debug.info->a.args)) + RETURN (SCM_SUBRF (proc) (debug.info->a.args)); #else - RETURN (SCM_SUBRF (proc) (scm_cons (t.arg1, SCM_EOL))); + RETURN (SCM_SUBRF (proc) (scm_list_1 (arg1))); #endif - case scm_tc7_smob: - if (!SCM_SMOB_APPLICABLE_P (proc)) - goto badfun; - RETURN (SCM_SMOB_APPLY_1 (proc, t.arg1)); - case scm_tc7_cclo: - arg2 = t.arg1; - t.arg1 = proc; - proc = SCM_CCLO_SUBR (proc); + case scm_tc7_smob: + if (!SCM_SMOB_APPLICABLE_P (proc)) + goto badfun; + RETURN (SCM_SMOB_APPLY_1 (proc, arg1)); + case scm_tc7_cclo: + arg2 = arg1; + arg1 = proc; + proc = SCM_CCLO_SUBR (proc); #ifdef DEVAL - debug.info->a.args = scm_cons (t.arg1, debug.info->a.args); - debug.info->a.proc = proc; + debug.info->a.args = scm_cons (arg1, debug.info->a.args); + debug.info->a.proc = proc; #endif - goto evap2; - case scm_tc7_pws: - proc = SCM_PROCEDURE (proc); + goto evap2; + case scm_tc7_pws: + proc = SCM_PROCEDURE (proc); #ifdef DEVAL - debug.info->a.proc = proc; + debug.info->a.proc = proc; #endif - if (!SCM_CLOSUREP (proc)) - goto evap1; - if (scm_badformalsp (proc, 1)) - goto umwrongnumargs; - case scm_tcs_closures: - /* clos1: */ - x = SCM_CODE (proc); + if (!SCM_CLOSUREP (proc)) + goto evap1; + if (scm_badformalsp (proc, 1)) + goto umwrongnumargs; + case scm_tcs_closures: + /* clos1: */ + x = SCM_CLOSURE_BODY (proc); #ifdef DEVAL - env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), debug.info->a.args, SCM_ENV (proc)); + env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), debug.info->a.args, SCM_ENV (proc)); #else - env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), scm_cons (t.arg1, SCM_EOL), SCM_ENV (proc)); + env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), scm_list_1 (arg1), SCM_ENV (proc)); #endif - goto nontoplevel_cdrxbegin; - case scm_tcs_struct: - if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) - { - x = SCM_ENTITY_PROCEDURE (proc); + goto nontoplevel_begin; + case scm_tcs_struct: + if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) + { + x = SCM_ENTITY_PROCEDURE (proc); #ifdef DEVAL - arg2 = debug.info->a.args; + arg1 = debug.info->a.args; #else - arg2 = scm_cons (t.arg1, SCM_EOL); + arg1 = scm_list_1 (arg1); #endif - goto type_dispatch; - } - else if (!SCM_I_OPERATORP (proc)) - goto badfun; - else - { - arg2 = t.arg1; - t.arg1 = proc; - proc = (SCM_I_ENTITYP (proc) - ? SCM_ENTITY_PROCEDURE (proc) - : SCM_OPERATOR_PROCEDURE (proc)); + goto type_dispatch; + } + else if (!SCM_I_OPERATORP (proc)) + goto badfun; + else + { + arg2 = arg1; + 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 (arg1, debug.info->a.args); + debug.info->a.proc = proc; #endif - if (SCM_NIMP (proc)) - goto evap2; - else - goto badfun; - } - case scm_tc7_subr_2: - case scm_tc7_subr_0: - case scm_tc7_subr_3: - case scm_tc7_lsubr_2: - goto wrongnumargs; - default: - goto badfun; - } - } -#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 - goto wrongnumargs; -#else - arg2 = EVALCAR (x, env); + if (SCM_NIMP (proc)) + goto evap2; + else + goto badfun; + } + case scm_tc7_subr_2: + case scm_tc7_subr_0: + case scm_tc7_subr_3: + case scm_tc7_lsubr_2: + scm_wrong_num_args (proc); + default: + goto badfun; + } + } + if (SCM_CONSP (x)) + arg2 = EVALCAR (x, env); + else + scm_wrong_num_args (proc); + + { /* have two or more arguments */ +#ifdef DEVAL + debug.info->a.args = scm_list_2 (arg1, arg2); #endif - { /* have two or more arguments */ + x = SCM_CDR (x); + if (SCM_NULLP (x)) { + ENTER_APPLY; + evap2: + switch (SCM_TYP7 (proc)) + { /* have two arguments */ + case scm_tc7_subr_2: + case scm_tc7_subr_2o: + RETURN (SCM_SUBRF (proc) (arg1, arg2)); + case scm_tc7_lsubr: #ifdef DEVAL - debug.info->a.args = scm_cons2 (t.arg1, arg2, SCM_EOL); + RETURN (SCM_SUBRF (proc) (debug.info->a.args)); +#else + RETURN (SCM_SUBRF (proc) (scm_list_2 (arg1, arg2))); #endif - x = SCM_CDR (x); - if (SCM_NULLP (x)) { - ENTER_APPLY; - evap2: - switch (SCM_TYP7 (proc)) - { /* have two arguments */ - case scm_tc7_subr_2: - case scm_tc7_subr_2o: - RETURN (SCM_SUBRF (proc) (t.arg1, arg2)); - case scm_tc7_lsubr: + case scm_tc7_lsubr_2: + RETURN (SCM_SUBRF (proc) (arg1, arg2, SCM_EOL)); + case scm_tc7_rpsubr: + case scm_tc7_asubr: + RETURN (SCM_SUBRF (proc) (arg1, arg2)); + case scm_tc7_smob: + if (!SCM_SMOB_APPLICABLE_P (proc)) + goto badfun; + RETURN (SCM_SMOB_APPLY_2 (proc, arg1, arg2)); + cclon: + case scm_tc7_cclo: #ifdef DEVAL - RETURN (SCM_SUBRF (proc) (debug.info->a.args)) + RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), + scm_cons (proc, debug.info->a.args), + SCM_EOL)); #else - RETURN (SCM_SUBRF (proc) (scm_cons2 (t.arg1, arg2, SCM_EOL))); + RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), + scm_cons2 (proc, arg1, + scm_cons (arg2, + scm_eval_args (x, + env, + proc))), + SCM_EOL)); #endif - case scm_tc7_lsubr_2: - RETURN (SCM_SUBRF (proc) (t.arg1, arg2, SCM_EOL)); - case scm_tc7_rpsubr: - case scm_tc7_asubr: - RETURN (SCM_SUBRF (proc) (t.arg1, arg2)); - case scm_tc7_smob: - if (!SCM_SMOB_APPLICABLE_P (proc)) - goto badfun; - RETURN (SCM_SMOB_APPLY_2 (proc, t.arg1, arg2)); - cclon: - case scm_tc7_cclo: + case scm_tcs_struct: + if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) + { + x = SCM_ENTITY_PROCEDURE (proc); #ifdef DEVAL - RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), - scm_cons (proc, debug.info->a.args), - SCM_EOL)); + arg1 = debug.info->a.args; #else - RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), - scm_cons2 (proc, t.arg1, - scm_cons (arg2, - scm_eval_args (x, - env, - proc))), - SCM_EOL)); + arg1 = scm_list_2 (arg1, arg2); #endif - case scm_tcs_struct: - if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) - { - x = SCM_ENTITY_PROCEDURE (proc); + goto type_dispatch; + } + else if (!SCM_I_OPERATORP (proc)) + goto badfun; + else + { + operatorn: #ifdef DEVAL - arg2 = debug.info->a.args; + 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 - arg2 = scm_cons2 (t.arg1, arg2, SCM_EOL); + RETURN (SCM_APPLY (SCM_I_ENTITYP (proc) + ? SCM_ENTITY_PROCEDURE (proc) + : SCM_OPERATOR_PROCEDURE (proc), + scm_cons2 (proc, arg1, + scm_cons (arg2, + scm_eval_args (x, + env, + proc))), + SCM_EOL)); #endif - goto type_dispatch; - } - else if (!SCM_I_OPERATORP (proc)) + } + case scm_tc7_subr_0: + case scm_tc7_cxr: + case scm_tc7_subr_1o: + case scm_tc7_subr_1: + case scm_tc7_subr_3: + scm_wrong_num_args (proc); + default: goto badfun; - else - { - operatorn: + case scm_tc7_pws: + proc = SCM_PROCEDURE (proc); #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)); + debug.info->a.proc = proc; +#endif + if (!SCM_CLOSUREP (proc)) + goto evap2; + if (scm_badformalsp (proc, 2)) + goto umwrongnumargs; + case scm_tcs_closures: + /* clos2: */ +#ifdef DEVAL + env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), + debug.info->a.args, + SCM_ENV (proc)); #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)); + env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), + scm_list_2 (arg1, arg2), SCM_ENV (proc)); #endif - } - case scm_tc7_subr_0: - case scm_tc7_cxr: - case scm_tc7_subr_1o: - case scm_tc7_subr_1: + x = SCM_CLOSURE_BODY (proc); + goto nontoplevel_begin; + } + } + if (!SCM_CONSP (x)) + scm_wrong_num_args (proc); +#ifdef DEVAL + debug.info->a.args = scm_cons2 (arg1, arg2, + deval_args (x, env, proc, + SCM_CDRLOC (SCM_CDR (debug.info->a.args)))); +#endif + ENTER_APPLY; + evap3: + switch (SCM_TYP7 (proc)) + { /* have 3 or more arguments */ +#ifdef DEVAL case scm_tc7_subr_3: - goto wrongnumargs; - default: - goto badfun; + if (!SCM_NULLP (SCM_CDR (x))) + scm_wrong_num_args (proc); + else + RETURN (SCM_SUBRF (proc) (arg1, arg2, + SCM_CADDR (debug.info->a.args))); + case scm_tc7_asubr: + arg1 = SCM_SUBRF(proc)(arg1, arg2); + arg2 = SCM_CDDR (debug.info->a.args); + do + { + arg1 = SCM_SUBRF(proc)(arg1, SCM_CAR (arg2)); + arg2 = SCM_CDR (arg2); + } + while (SCM_NIMP (arg2)); + RETURN (arg1); + case scm_tc7_rpsubr: + if (SCM_FALSEP (SCM_SUBRF (proc) (arg1, arg2))) + RETURN (SCM_BOOL_F); + arg1 = SCM_CDDR (debug.info->a.args); + do + { + if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, SCM_CAR (arg1)))) + RETURN (SCM_BOOL_F); + arg2 = SCM_CAR (arg1); + arg1 = SCM_CDR (arg1); + } + while (SCM_NIMP (arg1)); + RETURN (SCM_BOOL_T); + case scm_tc7_lsubr_2: + RETURN (SCM_SUBRF (proc) (arg1, arg2, + SCM_CDDR (debug.info->a.args))); + case scm_tc7_lsubr: + RETURN (SCM_SUBRF (proc) (debug.info->a.args)); + case scm_tc7_smob: + if (!SCM_SMOB_APPLICABLE_P (proc)) + goto badfun; + RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2, + SCM_CDDR (debug.info->a.args))); + case scm_tc7_cclo: + goto cclon; case scm_tc7_pws: proc = SCM_PROCEDURE (proc); -#ifdef DEVAL debug.info->a.proc = proc; -#endif if (!SCM_CLOSUREP (proc)) - goto evap2; - if (scm_badformalsp (proc, 2)) + goto evap3; + if (scm_badargsp (SCM_CLOSURE_FORMALS (proc), debug.info->a.args)) goto umwrongnumargs; case scm_tcs_closures: - /* clos2: */ -#ifdef DEVAL + SCM_SET_ARGSREADY (debug); env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), debug.info->a.args, SCM_ENV (proc)); -#else - env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), - scm_cons2 (t.arg1, arg2, SCM_EOL), SCM_ENV (proc)); -#endif - x = SCM_CODE (proc); - goto nontoplevel_cdrxbegin; - } - } -#ifdef SCM_CAUTIOUS - if (SCM_IMP (x) || !SCM_CONSP (x)) - goto wrongnumargs; -#endif -#ifdef DEVAL - debug.info->a.args = scm_cons2 (t.arg1, arg2, - scm_deval_args (x, env, proc, - SCM_CDRLOC (SCM_CDR (debug.info->a.args)))); -#endif - ENTER_APPLY; - evap3: - switch (SCM_TYP7 (proc)) - { /* have 3 or more arguments */ -#ifdef DEVAL - case scm_tc7_subr_3: - SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs); - RETURN (SCM_SUBRF (proc) (t.arg1, arg2, - SCM_CADDR (debug.info->a.args))); - case scm_tc7_asubr: -#ifdef BUILTIN_RPASUBR - t.arg1 = SCM_SUBRF(proc)(t.arg1, arg2); - arg2 = SCM_CDR (SCM_CDR (debug.info->a.args)); - do - { - t.arg1 = SCM_SUBRF(proc)(t.arg1, SCM_CAR (arg2)); - arg2 = SCM_CDR (arg2); - } - while (SCM_NIMP (arg2)); - RETURN (t.arg1) -#endif /* BUILTIN_RPASUBR */ - case scm_tc7_rpsubr: -#ifdef BUILTIN_RPASUBR - if (SCM_FALSEP (SCM_SUBRF (proc) (t.arg1, arg2))) - RETURN (SCM_BOOL_F) - t.arg1 = SCM_CDR (SCM_CDR (debug.info->a.args)); - do - { - if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, SCM_CAR (t.arg1)))) - RETURN (SCM_BOOL_F) - arg2 = SCM_CAR (t.arg1); - t.arg1 = SCM_CDR (t.arg1); - } - while (SCM_NIMP (t.arg1)); - RETURN (SCM_BOOL_T) -#else /* BUILTIN_RPASUBR */ - RETURN (SCM_APPLY (proc, t.arg1, - scm_acons (arg2, - SCM_CDR (SCM_CDR (debug.info->a.args)), - SCM_EOL))) -#endif /* BUILTIN_RPASUBR */ - case scm_tc7_lsubr_2: - RETURN (SCM_SUBRF (proc) (t.arg1, arg2, - SCM_CDR (SCM_CDR (debug.info->a.args)))) - case scm_tc7_lsubr: - RETURN (SCM_SUBRF (proc) (debug.info->a.args)) - case scm_tc7_smob: - if (!SCM_SMOB_APPLICABLE_P (proc)) - goto badfun; - RETURN (SCM_SMOB_APPLY_3 (proc, t.arg1, arg2, - SCM_CDDR (debug.info->a.args))); - case scm_tc7_cclo: - goto cclon; - case scm_tc7_pws: - proc = SCM_PROCEDURE (proc); - debug.info->a.proc = proc; - if (!SCM_CLOSUREP (proc)) - goto evap3; - if (scm_badargsp (SCM_CLOSURE_FORMALS (proc), debug.info->a.args)) - goto umwrongnumargs; - case scm_tcs_closures: - SCM_SET_ARGSREADY (debug); - env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), - debug.info->a.args, - SCM_ENV (proc)); - x = SCM_CODE (proc); - goto nontoplevel_cdrxbegin; + x = SCM_CLOSURE_BODY (proc); + goto nontoplevel_begin; #else /* DEVAL */ - case scm_tc7_subr_3: - SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs); - RETURN (SCM_SUBRF (proc) (t.arg1, arg2, EVALCAR (x, env))); - case scm_tc7_asubr: -#ifdef BUILTIN_RPASUBR - t.arg1 = SCM_SUBRF (proc) (t.arg1, arg2); - do - { - t.arg1 = SCM_SUBRF(proc)(t.arg1, EVALCAR(x, env)); - x = SCM_CDR(x); - } - while (SCM_NIMP (x)); - RETURN (t.arg1) -#endif /* BUILTIN_RPASUBR */ - case scm_tc7_rpsubr: -#ifdef BUILTIN_RPASUBR - if (SCM_FALSEP (SCM_SUBRF (proc) (t.arg1, arg2))) - RETURN (SCM_BOOL_F) - do + case scm_tc7_subr_3: + if (!SCM_NULLP (SCM_CDR (x))) + scm_wrong_num_args (proc); + else + RETURN (SCM_SUBRF (proc) (arg1, arg2, EVALCAR (x, env))); + case scm_tc7_asubr: + arg1 = SCM_SUBRF (proc) (arg1, arg2); + do + { + arg1 = SCM_SUBRF(proc)(arg1, EVALCAR(x, env)); + x = SCM_CDR(x); + } + while (SCM_NIMP (x)); + RETURN (arg1); + case scm_tc7_rpsubr: + if (SCM_FALSEP (SCM_SUBRF (proc) (arg1, arg2))) + RETURN (SCM_BOOL_F); + do + { + arg1 = EVALCAR (x, env); + if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, arg1))) + RETURN (SCM_BOOL_F); + arg2 = arg1; + x = SCM_CDR (x); + } + while (SCM_NIMP (x)); + RETURN (SCM_BOOL_T); + case scm_tc7_lsubr_2: + RETURN (SCM_SUBRF (proc) (arg1, arg2, scm_eval_args (x, env, proc))); + case scm_tc7_lsubr: + RETURN (SCM_SUBRF (proc) (scm_cons2 (arg1, + arg2, + scm_eval_args (x, env, proc)))); + case scm_tc7_smob: + if (!SCM_SMOB_APPLICABLE_P (proc)) + goto badfun; + RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2, + scm_eval_args (x, env, proc))); + case scm_tc7_cclo: + goto cclon; + case scm_tc7_pws: + proc = SCM_PROCEDURE (proc); + if (!SCM_CLOSUREP (proc)) + goto evap3; { - t.arg1 = EVALCAR (x, env); - if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, t.arg1))) - RETURN (SCM_BOOL_F) - arg2 = t.arg1; - x = SCM_CDR (x); + SCM formals = SCM_CLOSURE_FORMALS (proc); + if (SCM_NULLP (formals) + || (SCM_CONSP (formals) + && (SCM_NULLP (SCM_CDR (formals)) + || (SCM_CONSP (SCM_CDR (formals)) + && scm_badargsp (SCM_CDDR (formals), x))))) + goto umwrongnumargs; } - while (SCM_NIMP (x)); - RETURN (SCM_BOOL_T) -#else /* BUILTIN_RPASUBR */ - RETURN (SCM_APPLY (proc, t.arg1, - scm_acons (arg2, - scm_eval_args (x, env, proc), - SCM_EOL))); -#endif /* BUILTIN_RPASUBR */ - case scm_tc7_lsubr_2: - RETURN (SCM_SUBRF (proc) (t.arg1, arg2, scm_eval_args (x, env, proc))); - case scm_tc7_lsubr: - RETURN (SCM_SUBRF (proc) (scm_cons2 (t.arg1, - arg2, - scm_eval_args (x, env, proc)))); - case scm_tc7_smob: - if (!SCM_SMOB_APPLICABLE_P (proc)) - goto badfun; - RETURN (SCM_SMOB_APPLY_3 (proc, t.arg1, arg2, - scm_eval_args (x, env, proc))); - case scm_tc7_cclo: - goto cclon; - case scm_tc7_pws: - proc = SCM_PROCEDURE (proc); - if (!SCM_CLOSUREP (proc)) - goto evap3; - { - SCM formals = SCM_CLOSURE_FORMALS (proc); - if (SCM_NULLP (formals) - || (SCM_CONSP (formals) - && (SCM_NULLP (SCM_CDR (formals)) - || (SCM_CONSP (SCM_CDR (formals)) - && scm_badargsp (SCM_CDDR (formals), x))))) - goto umwrongnumargs; - } - case scm_tcs_closures: + case scm_tcs_closures: #ifdef DEVAL - SCM_SET_ARGSREADY (debug); + SCM_SET_ARGSREADY (debug); #endif - env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), - scm_cons2 (t.arg1, - arg2, - scm_eval_args (x, env, proc)), - SCM_ENV (proc)); - x = SCM_CODE (proc); - goto nontoplevel_cdrxbegin; + env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), + scm_cons2 (arg1, + arg2, + scm_eval_args (x, env, proc)), + SCM_ENV (proc)); + x = SCM_CLOSURE_BODY (proc); + goto nontoplevel_begin; #endif /* DEVAL */ - case scm_tcs_struct: - if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) - { + case scm_tcs_struct: + if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) + { #ifdef DEVAL - arg2 = debug.info->a.args; + arg1 = debug.info->a.args; #else - arg2 = scm_cons2 (t.arg1, arg2, scm_eval_args (x, env, proc)); + arg1 = scm_cons2 (arg1, arg2, scm_eval_args (x, env, proc)); #endif - x = SCM_ENTITY_PROCEDURE (proc); - goto type_dispatch; - } - else if (!SCM_I_OPERATORP (proc)) + 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: + case scm_tc7_subr_0: + case scm_tc7_cxr: + case scm_tc7_subr_1: + scm_wrong_num_args (proc); + default: goto badfun; - else - goto operatorn; - case scm_tc7_subr_2: - case scm_tc7_subr_1o: - case scm_tc7_subr_2o: - case scm_tc7_subr_0: - case scm_tc7_cxr: - case scm_tc7_subr_1: - goto wrongnumargs; - default: - goto badfun; - } + } + } } #ifdef DEVAL exit: - if (CHECK_EXIT && SCM_TRAPS_P) + if (scm_check_exit_p && SCM_TRAPS_P) if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug))) { SCM_CLEAR_TRACED_FRAME (debug); if (SCM_CHEAPTRAPS_P) - t.arg1 = scm_make_debugobj (&debug); + arg1 = scm_make_debugobj (&debug); else { int first; SCM val = scm_make_continuation (&first); - + if (first) - t.arg1 = val; + arg1 = val; else { proc = val; @@ -3180,7 +3311,7 @@ exit: } } SCM_TRAPS_P = 0; - scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, t.arg1, proc); + scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, arg1, proc); SCM_TRAPS_P = 1; } ret: @@ -3289,9 +3420,13 @@ SCM_DEFINE (scm_nconc2last, "apply:nconc2last", 1, 0, 0, #define FUNC_NAME s_scm_nconc2last { SCM *lloc; - SCM_VALIDATE_NONEMPTYLIST (1,lst); + SCM_VALIDATE_NONEMPTYLIST (1, lst); lloc = &lst; - while (!SCM_NULLP (SCM_CDR (*lloc))) + while (!SCM_NULLP (SCM_CDR (*lloc))) /* Perhaps should be + SCM_NULL_OR_NIL_P, but not + needed in 99.99% of cases, + and it could seriously hurt + performance. - Neil */ lloc = SCM_CDRLOC (*lloc); SCM_ASSERT (scm_ilength (SCM_CAR (*lloc)) >= 0, lst, SCM_ARG1, FUNC_NAME); *lloc = SCM_CAR (*lloc); @@ -3307,14 +3442,12 @@ SCM_DEFINE (scm_nconc2last, "apply:nconc2last", 1, 0, 0, */ #if 0 - SCM scm_apply (SCM proc, SCM arg1, SCM args) {} #endif #if 0 - SCM scm_dapply (SCM proc, SCM arg1, SCM args) { /* empty */ } @@ -3415,22 +3548,28 @@ tail: { case scm_tc7_subr_2o: args = SCM_NULLP (args) ? SCM_UNDEFINED : SCM_CAR (args); - RETURN (SCM_SUBRF (proc) (arg1, args)) + RETURN (SCM_SUBRF (proc) (arg1, args)); case scm_tc7_subr_2: - SCM_ASRTGO (!SCM_NULLP (args) && SCM_NULLP (SCM_CDR (args)), - wrongnumargs); + if (SCM_NULLP (args) || !SCM_NULLP (SCM_CDR (args))) + scm_wrong_num_args (proc); args = SCM_CAR (args); - RETURN (SCM_SUBRF (proc) (arg1, args)) + RETURN (SCM_SUBRF (proc) (arg1, args)); case scm_tc7_subr_0: - SCM_ASRTGO (SCM_UNBNDP (arg1), wrongnumargs); - RETURN (SCM_SUBRF (proc) ()) + if (!SCM_UNBNDP (arg1)) + scm_wrong_num_args (proc); + else + RETURN (SCM_SUBRF (proc) ()); case scm_tc7_subr_1: - SCM_ASRTGO (!SCM_UNBNDP (arg1), wrongnumargs); + if (SCM_UNBNDP (arg1)) + scm_wrong_num_args (proc); case scm_tc7_subr_1o: - SCM_ASRTGO (SCM_NULLP (args), wrongnumargs); - RETURN (SCM_SUBRF (proc) (arg1)) + if (!SCM_NULLP (args)) + scm_wrong_num_args (proc); + else + RETURN (SCM_SUBRF (proc) (arg1)); case scm_tc7_cxr: - SCM_ASRTGO (!SCM_UNBNDP (arg1) && SCM_NULLP (args), wrongnumargs); + if (SCM_UNBNDP (arg1) || !SCM_NULLP (args)) + scm_wrong_num_args (proc); if (SCM_SUBRF (proc)) { if (SCM_INUMP (arg1)) @@ -3443,7 +3582,7 @@ tail: } #ifdef SCM_BIGDIG else if (SCM_BIGP (arg1)) - RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1)))) + RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1)))); #endif SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1, SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc))); @@ -3457,26 +3596,29 @@ tail: arg1, SCM_ARG1, SCM_SYMBOL_CHARS (proc)); arg1 = ('a' == *chrs) ? SCM_CAR (arg1) : SCM_CDR (arg1); } - RETURN (arg1) + RETURN (arg1); } case scm_tc7_subr_3: - SCM_ASRTGO (!SCM_NULLP (args) - && !SCM_NULLP (SCM_CDR (args)) - && SCM_NULLP (SCM_CDDR (args)), - wrongnumargs); - RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CAR (SCM_CDR (args)))) + if (SCM_NULLP (args) + || SCM_NULLP (SCM_CDR (args)) + || !SCM_NULLP (SCM_CDDR (args))) + scm_wrong_num_args (proc); + else + RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CADR (args))); case scm_tc7_lsubr: #ifdef DEVAL - RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args)) + RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args)); #else - RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args))) + RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args))); #endif case scm_tc7_lsubr_2: - SCM_ASRTGO (SCM_CONSP (args), wrongnumargs); - RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CDR (args))) + if (!SCM_CONSP (args)) + scm_wrong_num_args (proc); + else + RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CDR (args))); case scm_tc7_asubr: if (SCM_NULLP (args)) - RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED)) + RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED)); while (SCM_NIMP (args)) { SCM_ASSERT (SCM_CONSP (args), args, SCM_ARG2, "apply"); @@ -3502,10 +3644,8 @@ tail: #else arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args)); #endif -#ifndef SCM_RECKLESS if (scm_badargsp (SCM_CLOSURE_FORMALS (proc), arg1)) - goto wrongnumargs; -#endif + scm_wrong_num_args (proc); /* Copy argument list */ if (SCM_IMP (arg1)) @@ -3523,7 +3663,7 @@ tail: } args = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), args, SCM_ENV (proc)); - proc = SCM_CDR (SCM_CODE (proc)); + proc = SCM_CLOSURE_BODY (proc); again: arg1 = proc; while (!SCM_NULLP (arg1 = SCM_CDR (arg1))) @@ -3532,7 +3672,11 @@ tail: { if (SCM_ISYMP (SCM_CAR (proc))) { - proc = scm_m_expand_body (proc, args); + scm_rec_mutex_lock (&source_mutex); + /* check for race condition */ + if (SCM_ISYMP (SCM_CAR (proc))) + proc = scm_m_expand_body (proc, args); + scm_rec_mutex_unlock (&source_mutex); goto again; } else @@ -3547,11 +3691,11 @@ tail: if (!SCM_SMOB_APPLICABLE_P (proc)) goto badproc; if (SCM_UNBNDP (arg1)) - RETURN (SCM_SMOB_APPLY_0 (proc)) + RETURN (SCM_SMOB_APPLY_0 (proc)); else if (SCM_NULLP (args)) - RETURN (SCM_SMOB_APPLY_1 (proc, arg1)) + RETURN (SCM_SMOB_APPLY_1 (proc, arg1)); else if (SCM_NULLP (SCM_CDR (args))) - RETURN (SCM_SMOB_APPLY_2 (proc, arg1, SCM_CAR (args))) + RETURN (SCM_SMOB_APPLY_2 (proc, arg1, SCM_CAR (args))); else RETURN (SCM_SMOB_APPLY_3 (proc, arg1, SCM_CAR (args), SCM_CDR (args))); case scm_tc7_cclo: @@ -3587,6 +3731,7 @@ tail: goto badproc; else { + /* operator */ #ifdef DEVAL args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args); #else @@ -3605,16 +3750,13 @@ tail: else goto badproc; } - wrongnumargs: - scm_wrong_num_args (proc); default: badproc: scm_wrong_type_arg ("apply", SCM_ARG1, proc); - RETURN (arg1); } #ifdef DEVAL exit: - if (CHECK_EXIT && SCM_TRAPS_P) + if (scm_check_exit_p && SCM_TRAPS_P) if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug))) { SCM_CLEAR_TRACED_FRAME (debug); @@ -3649,6 +3791,284 @@ ret: #ifndef DEVAL +/* Trampolines + * + * Trampolines make it possible to move procedure application dispatch + * outside inner loops. The motivation was clean implementation of + * efficient replacements of R5RS primitives in SRFI-1. + * + * The semantics is clear: scm_trampoline_N returns an optimized + * version of scm_call_N (or NULL if the procedure isn't applicable + * on N args). + * + * Applying the optimization to map and for-each increased efficiency + * noticeably. For example, (map abs ls) is now 8 times faster than + * before. + */ + +static SCM +call_subr0_0 (SCM proc) +{ + return SCM_SUBRF (proc) (); +} + +static SCM +call_subr1o_0 (SCM proc) +{ + return SCM_SUBRF (proc) (SCM_UNDEFINED); +} + +static SCM +call_lsubr_0 (SCM proc) +{ + return SCM_SUBRF (proc) (SCM_EOL); +} + +SCM +scm_i_call_closure_0 (SCM proc) +{ + return scm_eval_body (SCM_CLOSURE_BODY (proc), + SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), + SCM_EOL, + SCM_ENV (proc))); +} + +scm_t_trampoline_0 +scm_trampoline_0 (SCM proc) +{ + if (SCM_IMP (proc)) + return 0; + if (SCM_DEBUGGINGP) + return scm_call_0; + switch (SCM_TYP7 (proc)) + { + case scm_tc7_subr_0: + return call_subr0_0; + case scm_tc7_subr_1o: + return call_subr1o_0; + case scm_tc7_lsubr: + return call_lsubr_0; + case scm_tcs_closures: + { + SCM formals = SCM_CLOSURE_FORMALS (proc); + if (SCM_NULLP (formals) || !SCM_CONSP (formals)) + return scm_i_call_closure_0; + else + return 0; + } + case scm_tcs_struct: + if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) + return scm_call_generic_0; + else if (!SCM_I_OPERATORP (proc)) + return 0; + return scm_call_0; + case scm_tc7_smob: + if (SCM_SMOB_APPLICABLE_P (proc)) + return SCM_SMOB_DESCRIPTOR (proc).apply_0; + else + return 0; + /* fall through */ + case scm_tc7_asubr: + case scm_tc7_rpsubr: + case scm_tc7_cclo: + case scm_tc7_pws: + return scm_call_0; + default: + return 0; /* not applicable on one arg */ + } +} + +static SCM +call_subr1_1 (SCM proc, SCM arg1) +{ + return SCM_SUBRF (proc) (arg1); +} + +static SCM +call_subr2o_1 (SCM proc, SCM arg1) +{ + return SCM_SUBRF (proc) (arg1, SCM_UNDEFINED); +} + +static SCM +call_lsubr_1 (SCM proc, SCM arg1) +{ + return SCM_SUBRF (proc) (scm_list_1 (arg1)); +} + +static SCM +call_dsubr_1 (SCM proc, SCM arg1) +{ + if (SCM_INUMP (arg1)) + { + RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1)))); + } + else if (SCM_REALP (arg1)) + { + RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1)))); + } +#ifdef SCM_BIGDIG + else if (SCM_BIGP (arg1)) + RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1)))); +#endif + SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1, + SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc))); +} + +static SCM +call_cxr_1 (SCM proc, SCM arg1) +{ + proc = SCM_SNAME (proc); + { + char *chrs = SCM_SYMBOL_CHARS (proc) + SCM_SYMBOL_LENGTH (proc) - 1; + while ('c' != *--chrs) + { + SCM_ASSERT (SCM_CONSP (arg1), + arg1, SCM_ARG1, SCM_SYMBOL_CHARS (proc)); + arg1 = ('a' == *chrs) ? SCM_CAR (arg1) : SCM_CDR (arg1); + } + return (arg1); + } +} + +static SCM +call_closure_1 (SCM proc, SCM arg1) +{ + return scm_eval_body (SCM_CLOSURE_BODY (proc), + SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), + scm_list_1 (arg1), + SCM_ENV (proc))); +} + +scm_t_trampoline_1 +scm_trampoline_1 (SCM proc) +{ + if (SCM_IMP (proc)) + return 0; + if (SCM_DEBUGGINGP) + return scm_call_1; + switch (SCM_TYP7 (proc)) + { + case scm_tc7_subr_1: + case scm_tc7_subr_1o: + return call_subr1_1; + case scm_tc7_subr_2o: + return call_subr2o_1; + case scm_tc7_lsubr: + return call_lsubr_1; + case scm_tc7_cxr: + if (SCM_SUBRF (proc)) + return call_dsubr_1; + else + return call_cxr_1; + case scm_tcs_closures: + { + SCM formals = SCM_CLOSURE_FORMALS (proc); + if (!SCM_NULLP (formals) + && (!SCM_CONSP (formals) || !SCM_CONSP (SCM_CDR (formals)))) + return call_closure_1; + else + return 0; + } + case scm_tcs_struct: + if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) + return scm_call_generic_1; + else if (!SCM_I_OPERATORP (proc)) + return 0; + return scm_call_1; + case scm_tc7_smob: + if (SCM_SMOB_APPLICABLE_P (proc)) + return SCM_SMOB_DESCRIPTOR (proc).apply_1; + else + return 0; + /* fall through */ + case scm_tc7_asubr: + case scm_tc7_rpsubr: + case scm_tc7_cclo: + case scm_tc7_pws: + return scm_call_1; + default: + return 0; /* not applicable on one arg */ + } +} + +static SCM +call_subr2_2 (SCM proc, SCM arg1, SCM arg2) +{ + return SCM_SUBRF (proc) (arg1, arg2); +} + +static SCM +call_lsubr2_2 (SCM proc, SCM arg1, SCM arg2) +{ + return SCM_SUBRF (proc) (arg1, arg2, SCM_EOL); +} + +static SCM +call_lsubr_2 (SCM proc, SCM arg1, SCM arg2) +{ + return SCM_SUBRF (proc) (scm_list_2 (arg1, arg2)); +} + +static SCM +call_closure_2 (SCM proc, SCM arg1, SCM arg2) +{ + return scm_eval_body (SCM_CLOSURE_BODY (proc), + SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), + scm_list_2 (arg1, arg2), + SCM_ENV (proc))); +} + +scm_t_trampoline_2 +scm_trampoline_2 (SCM proc) +{ + if (SCM_IMP (proc)) + return 0; + if (SCM_DEBUGGINGP) + return scm_call_2; + switch (SCM_TYP7 (proc)) + { + case scm_tc7_subr_2: + case scm_tc7_subr_2o: + case scm_tc7_rpsubr: + case scm_tc7_asubr: + return call_subr2_2; + case scm_tc7_lsubr_2: + return call_lsubr2_2; + case scm_tc7_lsubr: + return call_lsubr_2; + case scm_tcs_closures: + { + SCM formals = SCM_CLOSURE_FORMALS (proc); + if (!SCM_NULLP (formals) + && (!SCM_CONSP (formals) + || (!SCM_NULLP (SCM_CDR (formals)) + && (!SCM_CONSP (SCM_CDR (formals)) + || !SCM_CONSP (SCM_CDDR (formals)))))) + return call_closure_2; + else + return 0; + } + case scm_tcs_struct: + if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) + return scm_call_generic_2; + else if (!SCM_I_OPERATORP (proc)) + return 0; + return scm_call_2; + case scm_tc7_smob: + if (SCM_SMOB_APPLICABLE_P (proc)) + return SCM_SMOB_DESCRIPTOR (proc).apply_2; + else + return 0; + /* fall through */ + case scm_tc7_cclo: + case scm_tc7_pws: + return scm_call_2; + default: + return 0; /* not applicable on two args */ + } +} + /* Typechecking for multi-argument MAP and FOR-EACH. Verify that each element of the vector ARGV, except for the first, @@ -3662,7 +4082,7 @@ check_map_args (SCM argv, SCM args, const char *who) { - SCM *ve = SCM_VELTS (argv); + SCM const *ve = SCM_VELTS (argv); long i; for (i = SCM_VECTOR_LENGTH (argv) - 1; i >= 1; i--) @@ -3678,7 +4098,7 @@ check_map_args (SCM argv, } if (elt_len != len) - scm_out_of_range (who, ve[i]); + scm_out_of_range_pos (who, ve[i], SCM_MAKINUM (i + 2)); } scm_remember_upto_here_1 (argv); @@ -3701,7 +4121,7 @@ scm_map (SCM proc, SCM arg1, SCM args) long i, len; SCM res = SCM_EOL; SCM *pres = &res; - SCM *ve = &args; /* Keep args from being optimized away. */ + SCM const *ve = &args; /* Keep args from being optimized away. */ len = scm_ilength (arg1); SCM_GASSERTn (len >= 0, @@ -3709,20 +4129,39 @@ scm_map (SCM proc, SCM arg1, SCM args) SCM_VALIDATE_REST_ARGUMENT (args); if (SCM_NULLP (args)) { + scm_t_trampoline_1 call = scm_trampoline_1 (proc); + SCM_GASSERT2 (call, g_map, proc, arg1, SCM_ARG1, s_map); + while (SCM_NIMP (arg1)) + { + *pres = scm_list_1 (call (proc, SCM_CAR (arg1))); + pres = SCM_CDRLOC (*pres); + arg1 = SCM_CDR (arg1); + } + return res; + } + if (SCM_NULLP (SCM_CDR (args))) + { + SCM arg2 = SCM_CAR (args); + int len2 = scm_ilength (arg2); + scm_t_trampoline_2 call = scm_trampoline_2 (proc); + SCM_GASSERTn (call, + g_map, scm_cons2 (proc, arg1, args), SCM_ARG1, s_map); + SCM_GASSERTn (len2 >= 0, + g_map, scm_cons2 (proc, arg1, args), SCM_ARG3, s_map); + if (len2 != len) + SCM_OUT_OF_RANGE (3, arg2); while (SCM_NIMP (arg1)) { - *pres = scm_cons (scm_apply (proc, SCM_CAR (arg1), scm_listofnull), - SCM_EOL); + *pres = scm_list_1 (call (proc, SCM_CAR (arg1), SCM_CAR (arg2))); pres = SCM_CDRLOC (*pres); arg1 = SCM_CDR (arg1); + arg2 = SCM_CDR (arg2); } return res; } args = scm_vector (arg1 = scm_cons (arg1, args)); ve = SCM_VELTS (args); -#ifndef SCM_RECKLESS check_map_args (args, len, g_map, proc, arg1, s_map); -#endif while (1) { arg1 = SCM_EOL; @@ -3731,9 +4170,9 @@ scm_map (SCM proc, SCM arg1, SCM args) if (SCM_IMP (ve[i])) return res; arg1 = scm_cons (SCM_CAR (ve[i]), arg1); - ve[i] = SCM_CDR (ve[i]); + SCM_VECTOR_SET (args, i, SCM_CDR (ve[i])); } - *pres = scm_cons (scm_apply (proc, arg1, SCM_EOL), SCM_EOL); + *pres = scm_list_1 (scm_apply (proc, arg1, SCM_EOL)); pres = SCM_CDRLOC (*pres); } } @@ -3746,35 +4185,54 @@ SCM scm_for_each (SCM proc, SCM arg1, SCM args) #define FUNC_NAME s_for_each { - SCM *ve = &args; /* Keep args from being optimized away. */ + SCM const *ve = &args; /* Keep args from being optimized away. */ long i, len; len = scm_ilength (arg1); SCM_GASSERTn (len >= 0, g_for_each, scm_cons2 (proc, arg1, args), SCM_ARG2, s_for_each); SCM_VALIDATE_REST_ARGUMENT (args); - if SCM_NULLP (args) + if (SCM_NULLP (args)) { - while SCM_NIMP (arg1) + scm_t_trampoline_1 call = scm_trampoline_1 (proc); + SCM_GASSERT2 (call, g_for_each, proc, arg1, SCM_ARG1, s_for_each); + while (SCM_NIMP (arg1)) + { + call (proc, SCM_CAR (arg1)); + arg1 = SCM_CDR (arg1); + } + return SCM_UNSPECIFIED; + } + if (SCM_NULLP (SCM_CDR (args))) + { + SCM arg2 = SCM_CAR (args); + int len2 = scm_ilength (arg2); + scm_t_trampoline_2 call = scm_trampoline_2 (proc); + SCM_GASSERTn (call, g_for_each, + scm_cons2 (proc, arg1, args), SCM_ARG1, s_for_each); + SCM_GASSERTn (len2 >= 0, g_for_each, + scm_cons2 (proc, arg1, args), SCM_ARG3, s_for_each); + if (len2 != len) + SCM_OUT_OF_RANGE (3, arg2); + while (SCM_NIMP (arg1)) { - scm_apply (proc, SCM_CAR (arg1), scm_listofnull); + call (proc, SCM_CAR (arg1), SCM_CAR (arg2)); arg1 = SCM_CDR (arg1); + arg2 = SCM_CDR (arg2); } return SCM_UNSPECIFIED; } args = scm_vector (arg1 = scm_cons (arg1, args)); ve = SCM_VELTS (args); -#ifndef SCM_RECKLESS check_map_args (args, len, g_for_each, proc, arg1, s_for_each); -#endif while (1) { arg1 = SCM_EOL; for (i = SCM_VECTOR_LENGTH (args) - 1; i >= 0; i--) { - if SCM_IMP - (ve[i]) return SCM_UNSPECIFIED; + if (SCM_IMP (ve[i])) + return SCM_UNSPECIFIED; arg1 = scm_cons (SCM_CAR (ve[i]), arg1); - ve[i] = SCM_CDR (ve[i]); + SCM_VECTOR_SET (args, i, SCM_CDR (ve[i])); } scm_apply (proc, arg1, SCM_EOL); } @@ -3785,11 +4243,10 @@ scm_for_each (SCM proc, SCM arg1, SCM args) SCM scm_closure (SCM code, SCM env) { - register SCM z; - - SCM_NEWCELL (z); - SCM_SETCODE (z, code); - SCM_SETENV (z, env); + SCM z; + SCM closcar = scm_cons (code, SCM_EOL); + z = scm_cell (SCM_UNPACK (closcar) + scm_tc3_closure, (scm_t_bits) env); + scm_remember_upto_here (closcar); return z; } @@ -3799,10 +4256,17 @@ scm_t_bits scm_tc16_promise; SCM scm_makprom (SCM code) { - SCM_RETURN_NEWSMOB (scm_tc16_promise, SCM_UNPACK (code)); + SCM_RETURN_NEWSMOB2 (scm_tc16_promise, + SCM_UNPACK (code), + scm_make_rec_mutex ()); } - +static size_t +promise_free (SCM promise) +{ + scm_rec_mutex_free (SCM_PROMISE_MUTEX (promise)); + return 0; +} static int promise_print (SCM exp, SCM port, scm_print_state *pstate) @@ -3810,33 +4274,32 @@ promise_print (SCM exp, SCM port, scm_print_state *pstate) int writingp = SCM_WRITINGP (pstate); scm_puts ("#', port); return !0; } - SCM_DEFINE (scm_force, "force", 1, 0, 0, - (SCM x), + (SCM promise), "If the promise @var{x} has not been computed yet, compute and\n" "return @var{x}, otherwise just return the previously computed\n" "value.") #define FUNC_NAME s_scm_force { - SCM_VALIDATE_SMOB (1, x, promise); - if (!((1L << 16) & SCM_CELL_WORD_0 (x))) + SCM_VALIDATE_SMOB (1, promise, promise); + scm_rec_mutex_lock (SCM_PROMISE_MUTEX (promise)); + if (!SCM_PROMISE_COMPUTED_P (promise)) { - SCM ans = scm_call_0 (SCM_CELL_OBJECT_1 (x)); - if (!((1L << 16) & SCM_CELL_WORD_0 (x))) + SCM ans = scm_call_0 (SCM_PROMISE_DATA (promise)); + if (!SCM_PROMISE_COMPUTED_P (promise)) { - SCM_DEFER_INTS; - SCM_SET_CELL_OBJECT_1 (x, ans); - SCM_SET_CELL_WORD_0 (x, SCM_CELL_WORD_0 (x) | (1L << 16)); - SCM_ALLOW_INTS; + SCM_SET_PROMISE_DATA (promise, ans); + SCM_SET_PROMISE_COMPUTED (promise); } } - return SCM_CELL_OBJECT_1 (x); + scm_rec_mutex_unlock (SCM_PROMISE_MUTEX (promise)); + return SCM_PROMISE_DATA (promise); } #undef FUNC_NAME @@ -3860,9 +4323,7 @@ SCM_DEFINE (scm_cons_source, "cons-source", 3, 0, 0, #define FUNC_NAME s_scm_cons_source { SCM p, z; - SCM_NEWCELL (z); - SCM_SET_CELL_OBJECT_0 (z, x); - SCM_SET_CELL_OBJECT_1 (z, y); + z = scm_cons (x, y); /* Copy source properties possibly associated with xorig. */ p = scm_whash_lookup (scm_source_whash, xorig); if (!SCM_IMP (p)) @@ -3889,7 +4350,7 @@ SCM_DEFINE (scm_copy_tree, "copy-tree", 1, 0, 0, unsigned long i = SCM_VECTOR_LENGTH (obj); ans = scm_c_make_vector (i, SCM_UNSPECIFIED); while (i--) - SCM_VELTS (ans)[i] = scm_copy_tree (SCM_VELTS (obj)[i]); + SCM_VECTOR_SET (ans, i, scm_copy_tree (SCM_VELTS (obj)[i])); return ans; } if (!SCM_CONSP (obj)) @@ -4038,7 +4499,7 @@ SCM_DEFINE (scm_eval, "eval", 2, 0, 0, (SCM exp, SCM module), "Evaluate @var{exp}, a list representing a Scheme expression,\n" "in the top-level environment specified by @var{module}.\n" - "While @var{exp} is evaluated (using @var{primitive-eval}),\n" + "While @var{exp} is evaluated (using @code{primitive-eval}),\n" "@var{module} is made the current module. The current module\n" "is reset to its previous value when @var{eval} returns.") #define FUNC_NAME s_scm_eval @@ -4075,24 +4536,20 @@ scm_init_eval () scm_tc16_promise = scm_make_smob_type ("promise", 0); scm_set_smob_mark (scm_tc16_promise, scm_markcdr); + scm_set_smob_free (scm_tc16_promise, promise_free); scm_set_smob_print (scm_tc16_promise, promise_print); /* Dirk:Fixme:: make scm_undefineds local to eval.c: it's only used here. */ - scm_undefineds = scm_cons (SCM_UNDEFINED, SCM_EOL); + scm_undefineds = scm_list_1 (SCM_UNDEFINED); SCM_SETCDR (scm_undefineds, scm_undefineds); - scm_listofnull = scm_cons (SCM_EOL, SCM_EOL); + scm_listofnull = scm_list_1 (SCM_EOL); scm_f_apply = scm_c_define_subr ("apply", scm_tc7_lsubr_2, scm_apply); /* acros */ /* end of acros */ -#ifndef SCM_MAGIC_SNARFER #include "libguile/eval.x" -#endif - - scm_c_define ("nil", scm_lisp_nil); - scm_c_define ("t", scm_lisp_t); scm_add_feature ("delay"); }