mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-29 16:30:19 +02:00
Code Activity

* eval.c: Removed bogus comment about acros.

Browse source 
(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.
This commit is contained in:
Dirk Herrmann 2001-11-17 11:43:28 +00:00
parent 8f85c0c6c3
commit 302c12b4b7
4 changed files with 354 additions and 248 deletions
Download patch file Download diff file Expand all files Collapse all files

2
BUGS
View file

@ -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 bug 4 -- named-let transform evaluates initvalue in the wrong scope
reported-by: agj@alum.mit.edu / 2001-09-21 reported-by: agj@alum.mit.edu / 2001-09-21
fixed: not-yet fixed: 2001-11-17 (1.7.x)
currently: currently:
> (let name ((var init) ...) body ...) > (let name ((var init) ...) body ...)

1
THANKS
View file

@ -16,6 +16,7 @@ For fixes or providing information which led to a fix:
Michael Carmack Michael Carmack
Brian Crowder Brian Crowder
Christopher Cramer Christopher Cramer
Aubrey Jaffer
John Goerzen John Goerzen
Han-Wen Nienhuys Han-Wen Nienhuys
Ken Raeburn Ken Raeburn

59
libguile/ChangeLog
View file

@ -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> 2001-11-16 Neil Jerram <neil@ossau.uklinux.net>
* gc.h (scm_unhash_name): Old declaration removed. * gc.h (scm_unhash_name): Old declaration removed.

540
libguile/eval.c
View file

@ -405,34 +405,33 @@ SCM_SYMBOL (sym_three_question_marks, "???");
SCM SCM
scm_unmemocar (SCM form, SCM env) scm_unmemocar (SCM form, SCM env)
{ {
SCM c; if (!SCM_CONSP (form))
if (SCM_IMP (form))
return form; return form;
c = SCM_CAR (form); else
if (SCM_VARIABLEP (c))
{ {
SCM sym = scm_module_reverse_lookup (scm_env_module (env), c); SCM c = SCM_CAR (form);
if (SCM_EQ_P (sym, SCM_BOOL_F)) if (SCM_VARIABLEP (c))
sym = sym_three_question_marks; {
SCM_SETCAR (form, sym); 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 MEMOIZE_LOCALS
#ifdef DEBUG_EXTENSIONS else if (SCM_ILOCP (c))
else if (SCM_ILOCP (c)) {
{ unsigned long int ir;
long ir;
for (ir = SCM_IFRAME (c); ir != 0; --ir) for (ir = SCM_IFRAME (c); ir != 0; --ir)
env = SCM_CDR (env); env = SCM_CDR (env);
env = SCM_CAAR (env); env = SCM_CAAR (env);
for (ir = SCM_IDIST (c); ir != 0; --ir) for (ir = SCM_IDIST (c); ir != 0; --ir)
env = SCM_CDR (env); env = SCM_CDR (env);
SCM_SETCAR (form, SCM_ICDRP (c) ? env : SCM_CAR (env)); SCM_SETCAR (form, SCM_ICDRP (c) ? env : SCM_CAR (env));
}
#endif
return form;
} }
#endif
#endif
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_clauses[] = "bad or missing clauses";
const char scm_s_formals[] = "bad formals"; const char scm_s_formals[] = "bad formals";
const char scm_s_duplicate_formals[] = "duplicate 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_dot, ".");
SCM_GLOBAL_SYMBOL (scm_sym_arrow, "=>"); SCM_GLOBAL_SYMBOL (scm_sym_arrow, "=>");
@ -490,7 +490,7 @@ SCM_GLOBAL_SYMBOL (scm_sym_trace, "trace");
static SCM static SCM
scm_m_body (SCM op, SCM xorig, const char *what) 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. */ /* Don't add another ISYM if one is present already. */
if (SCM_ISYMP (SCM_CAR (xorig))) if (SCM_ISYMP (SCM_CAR (xorig)))
@ -515,10 +515,8 @@ SCM_GLOBAL_SYMBOL (scm_sym_quote, s_quote);
SCM SCM
scm_m_quote (SCM xorig, SCM env SCM_UNUSED) 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); 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 formals;
SCM x = SCM_CDR (xorig); 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); formals = SCM_CAR (x);
while (SCM_CONSP (formals)) while (SCM_CONSP (formals))
@ -698,7 +696,9 @@ scm_m_letstar (SCM xorig, SCM env SCM_UNUSED)
SCM x = SCM_CDR (xorig); SCM x = SCM_CDR (xorig);
SCM vars = SCM_EOL; SCM vars = SCM_EOL;
SCM *varloc = &vars; 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); bindings = SCM_CAR (x);
SCM_ASSYNT (scm_ilength (bindings) >= 0, scm_s_bindings, s_letstar); SCM_ASSYNT (scm_ilength (bindings) >= 0, scm_s_bindings, s_letstar);
while (!SCM_NULLP (bindings)) while (!SCM_NULLP (bindings))
@ -710,24 +710,30 @@ scm_m_letstar (SCM xorig, SCM env SCM_UNUSED)
varloc = SCM_CDRLOC (SCM_CDR (*varloc)); varloc = SCM_CDRLOC (SCM_CDR (*varloc));
bindings = SCM_CDR (bindings); bindings = SCM_CDR (bindings);
} }
return scm_cons2 (SCM_IM_LETSTAR, vars, return scm_cons2 (SCM_IM_LETSTAR, vars,
scm_m_body (SCM_IM_LETSTAR, SCM_CDR (x), s_letstar)); 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>) (do ((<var1> <init1> <step1>)
(<var2> <init2>) (<var2> <init2>)
... ) ... )
(<test> <return>) (<test> <return>)
<body>) <body>)
;; becomes ;; becomes
(do_mem (varn ... var2 var1)
(#@do (varn ... var2 var1)
(<init1> <init2> ... <initn>) (<init1> <init2> ... <initn>)
(<test> <return>) (<test> <return>)
(<body>) (<body>)
<step1> <step2> ... <stepn>) ;; missing steps replaced by var <step1> <step2> ... <stepn>) ;; missing steps replaced by var
*/ */
SCM_SYNTAX(s_do, "do", scm_makmmacro, scm_m_do); SCM_SYNTAX(s_do, "do", scm_makmmacro, scm_m_do);
SCM_GLOBAL_SYMBOL(scm_sym_do, s_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"); SCM_ASSYNT (scm_ilength (bindings) >= 0, scm_s_bindings, "do");
while (!SCM_NULLP (bindings)) while (!SCM_NULLP (bindings))
{ {
SCM arg1 = SCM_CAR (bindings); SCM binding = SCM_CAR (bindings);
long len = scm_ilength (arg1); long len = scm_ilength (binding);
SCM_ASSYNT (len == 2 || len == 3, scm_s_bindings, "do"); 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 */ SCM name = SCM_CAR (binding);
vars = scm_cons (SCM_CAR (arg1), vars); /* variable */ SCM init = SCM_CADR (binding);
arg1 = SCM_CDR (arg1); SCM step = (len == 2) ? name : SCM_CADDR (binding);
*initloc = scm_list_1 (SCM_CAR (arg1)); /* init */ SCM_ASSYNT (SCM_SYMBOLP (name), scm_s_variable, "do");
initloc = SCM_CDRLOC (*initloc); vars = scm_cons (name, vars);
arg1 = SCM_CDR (arg1); *initloc = scm_list_1 (init);
*steploc = scm_list_1 (len == 2 ? SCM_CAR (vars) : SCM_CAR (arg1)); initloc = SCM_CDRLOC (*initloc);
steploc = SCM_CDRLOC (*steploc); *steploc = scm_list_1 (step);
bindings = SCM_CDR (bindings); steploc = SCM_CDRLOC (*steploc);
bindings = SCM_CDR (bindings);
}
} }
x = SCM_CDR (x); x = SCM_CDR (x);
SCM_ASSYNT (scm_ilength (SCM_CAR (x)) >= 1, scm_s_test, "do"); SCM_ASSYNT (scm_ilength (SCM_CAR (x)) >= 1, scm_s_test, "do");
@ -768,16 +776,68 @@ scm_m_do (SCM xorig, SCM env SCM_UNUSED)
return scm_cons (SCM_IM_DO, x); 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
SCM_SYNTAX (s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote);
SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, s_quasiquote);
static SCM iqq (SCM form, SCM env, long depth); /* Internal function to handle a quasiquotation: 'form' is the parameter in
* the call (quasiquotation form), 'env' is the environment where unquoted
SCM_SYNTAX(s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote); * expressions will be evaluated, and 'depth' is the current quasiquotation
SCM_GLOBAL_SYMBOL(scm_sym_quasiquote, s_quasiquote); * 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 *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
scm_m_quasiquote (SCM xorig, SCM env) scm_m_quasiquote (SCM xorig, SCM env)
@ -788,56 +848,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_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_SYNTAX (s_delay, "delay", scm_makmmacro, scm_m_delay); SCM_SYNTAX (s_delay, "delay", scm_makmmacro, scm_m_delay);
SCM_GLOBAL_SYMBOL (scm_sym_delay, s_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_m_delay (SCM xorig, SCM env SCM_UNUSED)
{ {
SCM_ASSYNT (scm_ilength (xorig) == 2, scm_s_expression, s_delay); 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_SYNTAX(s_define, "define", scm_makmmacro, scm_m_define);
SCM_GLOBAL_SYMBOL(scm_sym_define, s_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_m_define (SCM x, SCM env)
{ {
SCM proc, arg1 = x; SCM name;
x = SCM_CDR (x); x = SCM_CDR (x);
SCM_ASSYNT (scm_ilength (x) >= 2, scm_s_expression, s_define); SCM_ASSYNT (scm_ilength (x) >= 2, scm_s_expression, s_define);
proc = SCM_CAR (x); name = SCM_CAR (x);
x = SCM_CDR (x); x = SCM_CDR (x);
while (SCM_CONSP (proc)) while (SCM_CONSP (name))
{ /* nested define syntax */ {
x = scm_list_1 (scm_cons2 (scm_sym_lambda, SCM_CDR (proc), x)); /* This while loop realizes function currying by variable nesting. */
proc = SCM_CAR (proc); 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 (SCM_SYMBOLP (name), scm_s_variable, s_define);
SCM_ASSYNT (1 == scm_ilength (x), scm_s_expression, s_define); SCM_ASSYNT (scm_ilength (x) == 1, scm_s_expression, s_define);
if (SCM_TOP_LEVEL (env)) if (SCM_TOP_LEVEL (env))
{ {
x = evalcar (x, env); SCM var;
#ifdef DEBUG_EXTENSIONS x = scm_eval_car (x, env);
if (SCM_REC_PROCNAMES_P && SCM_NIMP (x)) if (SCM_REC_PROCNAMES_P)
{ {
arg1 = x; SCM tmp = x;
proc: while (SCM_MACROP (tmp))
if (SCM_CLOSUREP (arg1) tmp = SCM_MACRO_CODE (tmp);
if (SCM_CLOSUREP (tmp)
/* Only the first definition determines the name. */ /* Only the first definition determines the name. */
&& SCM_FALSEP (scm_procedure_property (arg1, scm_sym_name))) && SCM_FALSEP (scm_procedure_property (tmp, scm_sym_name)))
scm_set_procedure_property_x (arg1, scm_sym_name, proc); scm_set_procedure_property_x (tmp, scm_sym_name, name);
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;
}
} }
#endif var = scm_sym2var (name, scm_env_top_level (env), SCM_BOOL_T);
arg1 = scm_sym2var (proc, scm_env_top_level (env), SCM_BOOL_T); SCM_VARIABLE_SET (var, x);
SCM_VARIABLE_SET (arg1, x);
#ifdef SICP
return scm_list_2 (scm_sym_quote, proc);
#else
return SCM_UNSPECIFIED; 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 /* The bindings ((v1 i1) (v2 i2) ... (vn in)) are transformed to the lists
scm_m_letrec1 (SCM op, SCM imm, SCM xorig, SCM env SCM_UNUSED) * (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 */ SCM rvars = SCM_EOL;
char *what = SCM_SYMBOL_CHARS (SCM_CAR (xorig)); *rvarloc = SCM_EOL;
SCM x = cdrx, proc, arg1; /* structure traversers */ *initloc = SCM_EOL;
SCM vars = SCM_EOL, inits = SCM_EOL, *initloc = &inits;
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 do
{ {
/* vars scm_list reversed here, inits reversed at evaluation */ SCM binding = SCM_CAR (bindings);
arg1 = SCM_CAR (proc); SCM_ASSYNT (scm_ilength (binding) == 2, scm_s_bindings, what);
SCM_ASSYNT (2 == scm_ilength (arg1), scm_s_bindings, what); SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding)), scm_s_variable, what);
SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)), scm_s_variable, what); if (scm_c_improper_memq (SCM_CAR (binding), rvars))
if (scm_c_improper_memq (SCM_CAR (arg1), vars))
scm_misc_error (what, scm_s_duplicate_bindings, SCM_EOL); scm_misc_error (what, scm_s_duplicate_bindings, SCM_EOL);
vars = scm_cons (SCM_CAR (arg1), vars); rvars = scm_cons (SCM_CAR (binding), rvars);
*initloc = scm_list_1 (SCM_CADR (arg1)); *initloc = scm_list_1 (SCM_CADR (binding));
initloc = SCM_CDRLOC (*initloc); initloc = SCM_CDRLOC (*initloc);
bindings = SCM_CDR (bindings);
} }
while (SCM_NIMP (proc = SCM_CDR (proc))); while (!SCM_NULLP (bindings));
return scm_cons2 (op, vars, *rvarloc = rvars;
scm_cons (inits, scm_m_body (imm, SCM_CDR (x), what)));
} }
SCM_SYNTAX(s_letrec, "letrec", scm_makmmacro, scm_m_letrec); SCM_SYNTAX(s_letrec, "letrec", scm_makmmacro, scm_m_letrec);
SCM_GLOBAL_SYMBOL(scm_sym_letrec, s_letrec); SCM_GLOBAL_SYMBOL(scm_sym_letrec, s_letrec);
@ -932,74 +962,89 @@ SCM
scm_m_letrec (SCM xorig, SCM env) scm_m_letrec (SCM xorig, SCM env)
{ {
SCM x = SCM_CDR (xorig); 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 */ if (SCM_NULLP (SCM_CAR (x)))
return scm_m_letstar (scm_cons2 (SCM_CAR (xorig), SCM_EOL, {
scm_m_body (SCM_IM_LETREC, /* null binding, let* faster */
SCM_CDR (x), SCM body = scm_m_body (SCM_IM_LETREC, SCM_CDR (x), s_letrec);
s_letrec)), return scm_m_letstar (scm_cons2 (SCM_CAR (xorig), SCM_EOL, body), env);
env); }
else 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_SYNTAX(s_let, "let", scm_makmmacro, scm_m_let);
SCM_GLOBAL_SYMBOL(scm_sym_let, s_let); SCM_GLOBAL_SYMBOL(scm_sym_let, s_let);
SCM SCM
scm_m_let (SCM xorig, SCM env) scm_m_let (SCM xorig, SCM env)
{ {
SCM cdrx = SCM_CDR (xorig); /* locally mutable version of form */ SCM x = SCM_CDR (xorig);
SCM x = cdrx, proc, arg1, name; /* structure traversers */ SCM temp;
SCM vars = SCM_EOL, inits = SCM_EOL, *varloc = &vars, *initloc = &inits;
SCM_ASSYNT (scm_ilength (x) >= 2, scm_s_body, s_let); SCM_ASSYNT (SCM_CONSP (x), scm_s_bindings, s_let);
proc = SCM_CAR (x); temp = SCM_CAR (x);
if (SCM_NULLP (proc) if (SCM_NULLP (temp)
|| (SCM_CONSP (proc) || (scm_ilength (temp) == 1 && SCM_CONSP (SCM_CAR (temp))))
&& SCM_CONSP (SCM_CAR (proc)) && SCM_NULLP (SCM_CDR (proc))))
{ {
/* null or single binding, let* is faster */ /* null or single binding, let* is faster */
return scm_m_letstar (scm_cons2 (SCM_CAR (xorig), proc, SCM body = scm_m_body (SCM_IM_LET, SCM_CDR (x), s_let);
scm_m_body (SCM_IM_LET, return scm_m_letstar (scm_cons2 (SCM_CAR (xorig), temp, body), env);
SCM_CDR (x),
s_let)),
env);
} }
else if (SCM_CONSP (temp))
SCM_ASSYNT (SCM_NIMP (proc), scm_s_bindings, s_let);
if (SCM_CONSP (proc))
{ {
/* plain let, proc is <bindings> */ /* plain let, temp is <bindings> */
return scm_m_letrec1 (SCM_IM_LET, SCM_IM_LET, xorig, env); 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 name = temp;
scm_misc_error (s_let, scm_s_bindings, SCM_EOL); /* bad let */ SCM vars = SCM_EOL;
name = proc; /* named let, build equiv letrec */ SCM *varloc = &vars;
x = SCM_CDR (x); SCM inits = SCM_EOL;
SCM_ASSYNT (scm_ilength (x) >= 2, scm_s_body, s_let); SCM *initloc = &inits;
proc = SCM_CAR (x); /* bindings list */ SCM bindings;
SCM_ASSYNT (scm_ilength (proc) >= 0, scm_s_bindings, s_let);
while (SCM_NIMP (proc)) SCM_ASSYNT (SCM_SYMBOLP (name), scm_s_bindings, s_let);
{ /* vars and inits both in order */ x = SCM_CDR (x);
arg1 = SCM_CAR (proc); SCM_ASSYNT (SCM_CONSP (x), scm_s_bindings, s_let);
SCM_ASSYNT (2 == scm_ilength (arg1), scm_s_bindings, s_let); bindings = SCM_CAR (x);
SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1)), scm_s_variable, s_let); SCM_ASSYNT (scm_ilength (bindings) >= 0, scm_s_bindings, s_let);
*varloc = scm_list_1 (SCM_CAR (arg1)); while (!SCM_NULLP (bindings))
varloc = SCM_CDRLOC (*varloc); { /* vars and inits both in order */
*initloc = scm_list_1 (SCM_CADR (arg1)); SCM binding = SCM_CAR (bindings);
initloc = SCM_CDRLOC (*initloc); SCM_ASSYNT (scm_ilength (binding) == 2, scm_s_bindings, s_let);
proc = SCM_CDR (proc); 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);
}
} }
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);
} }
@ -1205,19 +1250,21 @@ scm_m_expand_body (SCM xorig, SCM env)
} }
} }
SCM_ASSYNT (SCM_NIMP (x), scm_s_body, what); if (!SCM_NULLP (defs))
if (SCM_NIMP (defs))
{ {
x = scm_list_1 (scm_m_letrec1 (SCM_IM_LETREC, SCM rvars, inits, body, letrec;
SCM_IM_DEFINE, transform_bindings (defs, &rvars, &inits, what);
scm_cons2 (scm_sym_define, defs, x), body = scm_m_body (SCM_IM_DEFINE, x, what);
env)); 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; return xorig;
} }
@ -1947,14 +1994,13 @@ dispatch:
case SCM_BIT8(SCM_IM_AND): case SCM_BIT8(SCM_IM_AND):
x = SCM_CDR (x); x = SCM_CDR (x);
t.arg1 = x; while (!SCM_NULLP (SCM_CDR (x)))
while (!SCM_NULLP (t.arg1 = SCM_CDR (t.arg1))) {
if (SCM_FALSEP (EVALCAR (x, env))) if (SCM_FALSEP (EVALCAR (x, env)))
{
RETURN (SCM_BOOL_F); RETURN (SCM_BOOL_F);
} else
else x = SCM_CDR (x);
x = t.arg1; }
PREP_APPLY (SCM_UNDEFINED, SCM_EOL); PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
goto carloop; goto carloop;
@ -1974,13 +2020,12 @@ dispatch:
with the current module. */ with the current module. */
if (SCM_CONSP (env) && !SCM_CONSP (SCM_CAR (env))) if (SCM_CONSP (env) && !SCM_CONSP (SCM_CAR (env)))
{ {
t.arg1 = x;
UPDATE_TOPLEVEL_ENV (env); UPDATE_TOPLEVEL_ENV (env);
while (!SCM_NULLP (t.arg1 = SCM_CDR (t.arg1))) while (!SCM_NULLP (SCM_CDR (x)))
{ {
EVALCAR (x, env); EVALCAR (x, env);
x = t.arg1;
UPDATE_TOPLEVEL_ENV (env); UPDATE_TOPLEVEL_ENV (env);
x = SCM_CDR (x);
} }
goto carloop; goto carloop;
} }
@ -1992,8 +2037,7 @@ dispatch:
nontoplevel_cdrxbegin: nontoplevel_cdrxbegin:
x = SCM_CDR (x); x = SCM_CDR (x);
nontoplevel_begin: nontoplevel_begin:
t.arg1 = x; while (!SCM_NULLP (SCM_CDR (x)))
while (!SCM_NULLP (t.arg1 = SCM_CDR (t.arg1)))
{ {
if (SCM_IMP (SCM_CAR (x))) if (SCM_IMP (SCM_CAR (x)))
{ {
@ -2007,7 +2051,7 @@ dispatch:
} }
else else
SCM_CEVAL (SCM_CAR (x), env); SCM_CEVAL (SCM_CAR (x), env);
x = t.arg1; x = SCM_CDR (x);
} }
carloop: /* scm_eval car of last form in list */ carloop: /* scm_eval car of last form in list */
@ -2159,32 +2203,34 @@ dispatch:
case SCM_BIT8(SCM_IM_LETSTAR): case SCM_BIT8(SCM_IM_LETSTAR):
x = SCM_CDR (x); 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); env = EXTEND_ENV (SCM_EOL, SCM_EOL, env);
goto nontoplevel_cdrxnoap; else
} {
do do
{ {
t.arg1 = SCM_CAR (proc); SCM name = SCM_CAR (bindings);
proc = SCM_CDR (proc); SCM init = SCM_CDR (bindings);
env = EXTEND_ENV (t.arg1, EVALCAR (proc, env), env); env = EXTEND_ENV (name, EVALCAR (init, env), env);
} bindings = SCM_CDR (init);
while (SCM_NIMP (proc = SCM_CDR (proc))); }
while (!SCM_NULLP (bindings));
}
}
goto nontoplevel_cdrxnoap; goto nontoplevel_cdrxnoap;
case SCM_BIT8(SCM_IM_OR): case SCM_BIT8(SCM_IM_OR):
x = SCM_CDR (x); x = SCM_CDR (x);
t.arg1 = x; while (!SCM_NULLP (SCM_CDR (x)))
while (!SCM_NULLP (t.arg1 = SCM_CDR (t.arg1)))
{ {
x = EVALCAR (x, env); SCM val = EVALCAR (x, env);
if (!SCM_FALSEP (x)) if (!SCM_FALSEP (val))
{ RETURN (val);
RETURN (x); else
} x = SCM_CDR (x);
x = t.arg1;
} }
PREP_APPLY (SCM_UNDEFINED, SCM_EOL); PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
goto carloop; goto carloop;
@ -2289,7 +2335,7 @@ dispatch:
RETURN (val); RETURN (val);
} }
proc = SCM_CDR (x); proc = SCM_CDR (x);
proc = evalcar (proc, env); proc = scm_eval_car (proc, env);
SCM_ASRTGO (SCM_NIMP (proc), badfun); SCM_ASRTGO (SCM_NIMP (proc), badfun);
PREP_APPLY (proc, scm_list_1 (t.arg1)); PREP_APPLY (proc, scm_list_1 (t.arg1));
ENTER_APPLY; ENTER_APPLY;