diff options
author | Dirk Herrmann <dirk@dirk-herrmanns-seiten.de> | 2001-11-17 11:43:28 +0000 |
---|---|---|
committer | Dirk Herrmann <dirk@dirk-herrmanns-seiten.de> | 2001-11-17 11:43:28 +0000 |
commit | 302c12b4b780e15934873ef267b636d1a3c1707e (patch) | |
tree | 8103a877a2afad16fc56b12b8c81b3c4c19298e9 | |
parent | 8f85c0c6c3eb8de857babc08ca6e832e8a497c44 (diff) | |
download | guile-302c12b4b780e15934873ef267b636d1a3c1707e.tar.gz |
* eval.c: Removed bogus comment about acros.
(scm_unmemocar): Use !SCM_CONSP instead of SCM_IMP.
Minimize scope of local variable. Eliminate dependency on
macro DEBUG_EXTENSIONS.
(s_splicing): New error message string.
(scm_m_body): Issue 'bad body' message rather than 'missing
expression' message.
(scm_m_quote): Eliminate unnecessary copying.
(scm_m_lambda, scm_m_letstar, scm_m_letrec, scm_m_let): Leave the
checking of the body to scm_m_body.
(scm_m_do): Move comment to function header. Rename arg1 to
binding. Made the code a bit easier to read.
(evalcar): Removed.
(iqq): Added a comment. Changed the depth parameter to
unsigned. Use size_t for vector lengths. Make sure vector object
is gc protected as long as its contents are read. Add some syntax
checks. Get rid of unnecessary SCM_IMP test. Clean up the
control structure a bit.
(scm_m_delay): Added comment about the implementation of
scm_m_delay.
(scm_m_define): Add comment about guile's currying define
syntax. Renamed 'proc' to 'name'. Eliminate dependency on macro
DEBUG_EXTENSIONS. Simplified code a bit. Eliminate SICP code.
(scm_m_letrec1): Removed. Part of the functionality is taken
over by the new function 'transform_bindings'.
(transform_bindings): New function. Takes over some of the
functionality of removed function 'scm_m_letrec1', namely to split
a list of bindings into a reversed list of variables and a list of
initializers.
(scm_m_letrec): Call 'transform_bindings'.
(scm_m_let): Minimized scope of local variables. Renamed 'proc'
to 'temp' and 'arg1' to 'binding'. Eliminated redundant SCM_NIMP
test. Use 'transform_bindings'. Fixed scoping error with named
let (Thanks to Aubrey Jaffer for reporting the bug and to Neil
Jerram for suggesting the fix). Cleaned up the control structure
a bit.
(scm_m_expand_body): Use 'transform_bindings'. Eliminated
unnecessary consing. Eliminated unnecessary
SCM_DEFER/ALLOW_INTS.
(SCM_CEVAL): Un-obfuscated some loops.
-rw-r--r-- | BUGS | 2 | ||||
-rw-r--r-- | THANKS | 1 | ||||
-rw-r--r-- | libguile/ChangeLog | 59 | ||||
-rw-r--r-- | libguile/eval.c | 544 |
4 files changed, 356 insertions, 250 deletions
@@ -63,7 +63,7 @@ to change people is difficult, but that's why we have guile... bug 4 -- named-let transform evaluates initvalue in the wrong scope reported-by: agj@alum.mit.edu / 2001-09-21 -fixed: not-yet +fixed: 2001-11-17 (1.7.x) currently: > (let name ((var init) ...) body ...) @@ -16,6 +16,7 @@ For fixes or providing information which led to a fix: Michael Carmack Brian Crowder Christopher Cramer + Aubrey Jaffer John Goerzen Han-Wen Nienhuys Ken Raeburn diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 002cd3521..53b6a1b19 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,62 @@ +2001-11-17 Dirk Herrmann <D.Herrmann@tu-bs.de> + + * eval.c: Removed bogus comment about acros. + + (scm_unmemocar): Use !SCM_CONSP instead of SCM_IMP. + Minimize scope of local variable. Eliminate dependency on + macro DEBUG_EXTENSIONS. + + (s_splicing): New error message string. + + (scm_m_body): Issue 'bad body' message rather than 'missing + expression' message. + + (scm_m_quote): Eliminate unnecessary copying. + + (scm_m_lambda, scm_m_letstar, scm_m_letrec, scm_m_let): Leave the + checking of the body to scm_m_body. + + (scm_m_do): Move comment to function header. Rename arg1 to + binding. Made the code a bit easier to read. + + (evalcar): Removed. + + (iqq): Added a comment. Changed the depth parameter to + unsigned. Use size_t for vector lengths. Make sure vector object + is gc protected as long as its contents are read. Add some syntax + checks. Get rid of unnecessary SCM_IMP test. Clean up the + control structure a bit. + + (scm_m_delay): Added comment about the implementation of + scm_m_delay. + + (scm_m_define): Add comment about guile's currying define + syntax. Renamed 'proc' to 'name'. Eliminate dependency on macro + DEBUG_EXTENSIONS. Simplified code a bit. Eliminate SICP code. + + (scm_m_letrec1): Removed. Part of the functionality is taken + over by the new function 'transform_bindings'. + + (transform_bindings): New function. Takes over some of the + functionality of removed function 'scm_m_letrec1', namely to split + a list of bindings into a reversed list of variables and a list of + initializers. + + (scm_m_letrec): Call 'transform_bindings'. + + (scm_m_let): Minimized scope of local variables. Renamed 'proc' + to 'temp' and 'arg1' to 'binding'. Eliminated redundant SCM_NIMP + test. Use 'transform_bindings'. Fixed scoping error with named + let (Thanks to Aubrey Jaffer for reporting the bug and to Neil + Jerram for suggesting the fix). Cleaned up the control structure + a bit. + + (scm_m_expand_body): Use 'transform_bindings'. Eliminated + unnecessary consing. Eliminated unnecessary + SCM_DEFER/ALLOW_INTS. + + (SCM_CEVAL): Un-obfuscated some loops. + 2001-11-16 Neil Jerram <neil@ossau.uklinux.net> * gc.h (scm_unhash_name): Old declaration removed. diff --git a/libguile/eval.c b/libguile/eval.c index 2977da696..11383acf3 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -405,34 +405,33 @@ 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)) + else { - 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); - } + 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); + } #ifdef MEMOIZE_LOCALS -#ifdef DEBUG_EXTENSIONS - else if (SCM_ILOCP (c)) - { - long 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)); - } -#endif + 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)); + } #endif - return form; + return form; + } } @@ -457,6 +456,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, "=>"); @@ -490,7 +490,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))) @@ -515,10 +515,8 @@ 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)); } @@ -666,8 +664,8 @@ scm_m_lambda (SCM xorig, SCM env SCM_UNUSED) { SCM formals; SCM x = SCM_CDR (xorig); - if (scm_ilength (x) < 2) - scm_misc_error (s_lambda, scm_s_formals, SCM_EOL); + + SCM_ASSYNT (SCM_CONSP (x), scm_s_formals, s_lambda); formals = SCM_CAR (x); while (SCM_CONSP (formals)) @@ -698,7 +696,9 @@ scm_m_letstar (SCM xorig, SCM env SCM_UNUSED) SCM x = SCM_CDR (xorig); SCM vars = SCM_EOL; SCM *varloc = &vars; - SCM_ASSYNT (scm_ilength (x) >= 2, scm_s_body, s_letstar); + + 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)) @@ -710,24 +710,30 @@ scm_m_letstar (SCM xorig, SCM env SCM_UNUSED) varloc = SCM_CDRLOC (SCM_CDR (*varloc)); bindings = SCM_CDR (bindings); } + 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 ((<var1> <init1> <step1>) (<var2> <init2>) ... ) (<test> <return>) <body>) + ;; becomes - (do_mem (varn ... var2 var1) + + (#@do (varn ... var2 var1) (<init1> <init2> ... <initn>) (<test> <return>) (<body>) <step1> <step2> ... <stepn>) ;; missing steps replaced by var - */ + */ SCM_SYNTAX(s_do, "do", scm_makmmacro, scm_m_do); SCM_GLOBAL_SYMBOL(scm_sym_do, s_do); @@ -747,19 +753,21 @@ scm_m_do (SCM xorig, SCM env SCM_UNUSED) SCM_ASSYNT (scm_ilength (bindings) >= 0, scm_s_bindings, "do"); while (!SCM_NULLP (bindings)) { - SCM arg1 = SCM_CAR (bindings); - long len = scm_ilength (arg1); + SCM binding = SCM_CAR (bindings); + long len = scm_ilength (binding); SCM_ASSYNT (len == 2 || len == 3, 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_list_1 (SCM_CAR (arg1)); /* init */ - initloc = SCM_CDRLOC (*initloc); - arg1 = SCM_CDR (arg1); - *steploc = scm_list_1 (len == 2 ? SCM_CAR (vars) : SCM_CAR (arg1)); - steploc = SCM_CDRLOC (*steploc); - bindings = SCM_CDR (bindings); + { + 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"); @@ -768,76 +776,86 @@ 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 -scm_m_quasiquote (SCM xorig, SCM env) -{ - SCM x = SCM_CDR (xorig); - SCM_ASSYNT (scm_ilength (x) == 1, scm_s_expression, s_quasiquote); - return iqq (SCM_CAR (x), env, 1); -} +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, long depth) +iqq (SCM form, SCM env, unsigned long int depth) { - SCM tmp; - long edepth = depth; - if (SCM_IMP (form)) - return form; - if (SCM_VECTORP (form)) + 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)) { - long i = SCM_VECTOR_LENGTH (form); + size_t i = SCM_VECTOR_LENGTH (form); SCM *data = SCM_VELTS (form); - tmp = SCM_EOL; - for (; --i >= 0;) - tmp = scm_cons (data[i], tmp); + 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)); } - if (!SCM_CONSP (form)) + else 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_list_2 (tmp, iqq (SCM_CAR (form), env, depth)); - } - 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_list_2 (evalcar (tmp, env), iqq (SCM_CDR (form), env, depth))); - } - 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 +scm_m_quasiquote (SCM xorig, SCM env) +{ + SCM x = SCM_CDR (xorig); + SCM_ASSYNT (scm_ilength (x) == 1, scm_s_expression, s_quasiquote); + return iqq (SCM_CAR (x), env, 1); +} + SCM_SYNTAX (s_delay, "delay", scm_makmmacro, scm_m_delay); SCM_GLOBAL_SYMBOL (scm_sym_delay, s_delay); -SCM +/* Promises are implemented as closures with an empty parameter list. Thus, + * (delay <expression>) is transformed into (#@delay '() <expression>), 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); @@ -848,83 +866,95 @@ scm_m_delay (SCM xorig, SCM env SCM_UNUSED) 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 <nested-variable> <body>), where <nested-variable> has of one of + * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>), + * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals> + * 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 <body> 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) <body>) is equivalent to + * (define a (lambda (b . c) (lambda d <body>))) + * Example 2: + * (define (((a) b) c . d) <body>) is equivalent to + * (define a (lambda () (lambda (b) (lambda (c . d) <body>)))) + */ +/* 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_list_1 (scm_cons2 (scm_sym_lambda, SCM_CDR (proc), x)); - 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_list_2 (scm_sym_quote, proc); -#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_list_1 (SCM_CADR (arg1)); + 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); @@ -932,74 +962,89 @@ 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 body = scm_m_body (SCM_IM_LET, SCM_CDR (x), s_let); + return scm_m_letstar (scm_cons2 (SCM_CAR (xorig), temp, 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 <bindings> */ - return scm_m_letrec1 (SCM_IM_LET, SCM_IM_LET, xorig, env); + /* plain let, temp is <bindings> */ + SCM rvars, inits, body; + transform_bindings (temp, &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_list_1 (SCM_CAR (arg1)); - varloc = SCM_CDRLOC (*varloc); - *initloc = scm_list_1 (SCM_CADR (arg1)); - 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; - proc = scm_cons2 (scm_sym_lambda, vars, - scm_m_body (SCM_IM_LET, SCM_CDR (x), "let")); - proc = scm_list_3 (scm_sym_let, - scm_list_1 (scm_list_2 (name, proc)), - scm_cons (name, inits)); - return scm_m_letrec1 (SCM_IM_LETREC, SCM_IM_LET, proc, env); + 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); + } + + { + 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); + } + } } @@ -1205,19 +1250,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_list_1 (scm_m_letrec1 (SCM_IM_LETREC, - SCM_IM_DEFINE, - scm_cons2 (scm_sym_define, defs, x), - env)); + 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; } @@ -1947,14 +1994,13 @@ dispatch: 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))) + { + if (SCM_FALSEP (EVALCAR (x, env))) RETURN (SCM_BOOL_F); - } - else - x = t.arg1; + else + x = SCM_CDR (x); + } PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto carloop; @@ -1974,13 +2020,12 @@ dispatch: 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; } @@ -1992,8 +2037,7 @@ dispatch: 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))) { @@ -2007,7 +2051,7 @@ dispatch: } else SCM_CEVAL (SCM_CAR (x), env); - x = t.arg1; + x = SCM_CDR (x); } carloop: /* scm_eval car of last form in list */ @@ -2159,32 +2203,34 @@ dispatch: 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))); + 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)); + } + } goto nontoplevel_cdrxnoap; + 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)) + RETURN (val); + else + x = SCM_CDR (x); } PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto carloop; @@ -2289,7 +2335,7 @@ dispatch: RETURN (val); } proc = SCM_CDR (x); - proc = evalcar (proc, env); + proc = scm_eval_car (proc, env); SCM_ASRTGO (SCM_NIMP (proc), badfun); PREP_APPLY (proc, scm_list_1 (t.arg1)); ENTER_APPLY; |