1487 |
SCM_GLOBAL_SYMBOL (scm_sym_set_x, s_set_x); |
SCM_GLOBAL_SYMBOL (scm_sym_set_x, s_set_x); |
1488 |
|
|
1489 |
SCM |
SCM |
1490 |
scm_m_set_x (SCM xorig, SCM env SCM_UNUSED) |
scm_m_set_x (SCM expr, SCM env SCM_UNUSED) |
1491 |
{ |
{ |
1492 |
SCM x = SCM_CDR (xorig); |
SCM variable; |
1493 |
SCM_ASSYNT (scm_ilength (x) == 2, s_expression, s_set_x); |
|
1494 |
SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x)), s_variable, s_set_x); |
const SCM cdr_expr = SCM_CDR (expr); |
1495 |
return scm_cons (SCM_IM_SET_X, x); |
ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); |
1496 |
|
ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr); |
1497 |
|
variable = SCM_CAR (cdr_expr); |
1498 |
|
ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable), s_bad_variable, variable, expr); |
1499 |
|
|
1500 |
|
SCM_SETCAR (expr, SCM_IM_SET_X); |
1501 |
|
return expr; |
1502 |
} |
} |
1503 |
|
|
1504 |
|
|
1510 |
SCM_GLOBAL_SYMBOL (scm_sym_apply, s_atapply + 1); |
SCM_GLOBAL_SYMBOL (scm_sym_apply, s_atapply + 1); |
1511 |
|
|
1512 |
SCM |
SCM |
1513 |
scm_m_apply (SCM xorig, SCM env SCM_UNUSED) |
scm_m_apply (SCM expr, SCM env SCM_UNUSED) |
1514 |
{ |
{ |
1515 |
SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2, s_expression, s_atapply); |
const SCM cdr_expr = SCM_CDR (expr); |
1516 |
return scm_cons (SCM_IM_APPLY, SCM_CDR (xorig)); |
ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); |
1517 |
} |
ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_missing_expression, expr); |
|
|
|
|
|
|
|
/* (@bind ((var exp) ...) body ...) |
|
1518 |
|
|
1519 |
This will assign the values of the `exp's to the global variables |
SCM_SETCAR (expr, SCM_IM_APPLY); |
1520 |
named by `var's (symbols, not evaluated), creating them if they |
return expr; |
1521 |
don't exist, executes body, and then restores the previous values of |
} |
|
the `var's. Additionally, whenever control leaves body, the values |
|
|
of the `var's are saved and restored when control returns. It is an |
|
|
error when a symbol appears more than once among the `var's. |
|
|
All `exp's are evaluated before any `var' is set. |
|
|
|
|
|
Think of this as `let' for dynamic scope. |
|
|
|
|
|
It is memoized into (#@bind ((var ...) . (reversed-val ...)) body ...). |
|
1522 |
|
|
|
XXX - also implement `@bind*'. |
|
|
*/ |
|
1523 |
|
|
1524 |
SCM_SYNTAX (s_atbind, "@bind", scm_i_makbimacro, scm_m_atbind); |
SCM_SYNTAX (s_atbind, "@bind", scm_i_makbimacro, scm_m_atbind); |
1525 |
|
|
1526 |
|
/* FIXME: The following explanation should go into the documentation: */ |
1527 |
|
/* (@bind ((var init) ...) body ...) will assign the values of the `init's to |
1528 |
|
* the global variables named by `var's (symbols, not evaluated), creating |
1529 |
|
* them if they don't exist, executes body, and then restores the previous |
1530 |
|
* values of the `var's. Additionally, whenever control leaves body, the |
1531 |
|
* values of the `var's are saved and restored when control returns. It is an |
1532 |
|
* error when a symbol appears more than once among the `var's. All `init's |
1533 |
|
* are evaluated before any `var' is set. |
1534 |
|
* |
1535 |
|
* Think of this as `let' for dynamic scope. |
1536 |
|
*/ |
1537 |
|
|
1538 |
|
/* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into |
1539 |
|
* (#@bind ((varn ... var1) . (exp1 ... expn)) body ...). |
1540 |
|
* |
1541 |
|
* FIXME - also implement `@bind*'. |
1542 |
|
*/ |
1543 |
SCM |
SCM |
1544 |
scm_m_atbind (SCM xorig, SCM env) |
scm_m_atbind (SCM expr, SCM env) |
1545 |
{ |
{ |
1546 |
SCM x = SCM_CDR (xorig); |
SCM bindings; |
1547 |
SCM top_level = scm_env_top_level (env); |
SCM rvariables; |
1548 |
SCM vars = SCM_EOL, var; |
SCM inits; |
1549 |
SCM exps = SCM_EOL; |
SCM variable_idx; |
1550 |
|
|
1551 |
SCM_ASSYNT (scm_ilength (x) > 1, s_expression, s_atbind); |
const SCM top_level = scm_env_top_level (env); |
1552 |
|
|
1553 |
x = SCM_CAR (x); |
const SCM cdr_expr = SCM_CDR (expr); |
1554 |
while (SCM_NIMP (x)) |
ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); |
1555 |
|
ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr); |
1556 |
|
bindings = SCM_CAR (cdr_expr); |
1557 |
|
check_bindings (bindings, expr); |
1558 |
|
transform_bindings (bindings, expr, &rvariables, &inits); |
1559 |
|
|
1560 |
|
for (variable_idx = rvariables; |
1561 |
|
!SCM_NULLP (variable_idx); |
1562 |
|
variable_idx = SCM_CDR (variable_idx)) |
1563 |
{ |
{ |
1564 |
SCM rest; |
/* The first call to scm_sym2var will look beyond the current module, |
1565 |
SCM sym_exp = SCM_CAR (x); |
* while the second call wont. */ |
1566 |
SCM_ASSYNT (scm_ilength (sym_exp) == 2, s_bindings, s_atbind); |
const SCM variable = SCM_CAR (variable_idx); |
1567 |
SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (sym_exp)), s_bindings, s_atbind); |
SCM new_variable = scm_sym2var (variable, top_level, SCM_BOOL_F); |
1568 |
x = SCM_CDR (x); |
if (SCM_FALSEP (new_variable)) |
1569 |
for (rest = x; SCM_NIMP (rest); rest = SCM_CDR (rest)) |
new_variable = scm_sym2var (variable, top_level, SCM_BOOL_T); |
1570 |
if (SCM_EQ_P (SCM_CAR (sym_exp), SCM_CAAR (rest))) |
SCM_SETCAR (variable_idx, new_variable); |
|
scm_misc_error (s_atbind, s_duplicate_bindings, SCM_EOL); |
|
|
/* The first call to scm_sym2var will look beyond the current |
|
|
module, while the second call wont. */ |
|
|
var = scm_sym2var (SCM_CAR (sym_exp), top_level, SCM_BOOL_F); |
|
|
if (SCM_FALSEP (var)) |
|
|
var = scm_sym2var (SCM_CAR (sym_exp), top_level, SCM_BOOL_T); |
|
|
vars = scm_cons (var, vars); |
|
|
exps = scm_cons (SCM_CADR (sym_exp), exps); |
|
1571 |
} |
} |
1572 |
return scm_cons (SCM_IM_BIND, |
|
1573 |
scm_cons (scm_cons (scm_reverse_x (vars, SCM_EOL), exps), |
SCM_SETCAR (expr, SCM_IM_BIND); |
1574 |
SCM_CDDR (xorig))); |
SCM_SETCAR (cdr_expr, scm_cons (rvariables, inits)); |
1575 |
|
return expr; |
1576 |
} |
} |
1577 |
|
|
1578 |
|
|
3180 |
x = SCM_CDR (x); |
x = SCM_CDR (x); |
3181 |
vars = SCM_CAAR (x); |
vars = SCM_CAAR (x); |
3182 |
exps = SCM_CDAR (x); |
exps = SCM_CDAR (x); |
|
|
|
3183 |
vals = SCM_EOL; |
vals = SCM_EOL; |
3184 |
|
while (!SCM_NULLP (exps)) |
|
while (SCM_NIMP (exps)) |
|
3185 |
{ |
{ |
3186 |
vals = scm_cons (EVALCAR (exps, env), vals); |
vals = scm_cons (EVALCAR (exps, env), vals); |
3187 |
exps = SCM_CDR (exps); |
exps = SCM_CDR (exps); |
3215 |
proc = EVALCAR (x, env); /* proc is the consumer. */ |
proc = EVALCAR (x, env); /* proc is the consumer. */ |
3216 |
arg1 = SCM_APPLY (producer, SCM_EOL, SCM_EOL); |
arg1 = SCM_APPLY (producer, SCM_EOL, SCM_EOL); |
3217 |
if (SCM_VALUESP (arg1)) |
if (SCM_VALUESP (arg1)) |
3218 |
arg1 = scm_struct_ref (arg1, SCM_INUM0); |
{ |
3219 |
|
/* The list of arguments is not copied. Rather, it is assumed |
3220 |
|
* that this has been done by the 'values' procedure. */ |
3221 |
|
arg1 = scm_struct_ref (arg1, SCM_INUM0); |
3222 |
|
} |
3223 |
else |
else |
3224 |
arg1 = scm_list_1 (arg1); |
{ |
3225 |
|
arg1 = scm_list_1 (arg1); |
3226 |
|
} |
3227 |
PREP_APPLY (proc, arg1); |
PREP_APPLY (proc, arg1); |
3228 |
goto apply_proc; |
goto apply_proc; |
3229 |
} |
} |
3236 |
default: |
default: |
3237 |
proc = x; |
proc = x; |
3238 |
goto evapply; |
goto evapply; |
3239 |
|
|
3240 |
case scm_tc7_vector: |
case scm_tc7_vector: |
3241 |
case scm_tc7_wvect: |
case scm_tc7_wvect: |
3242 |
#if SCM_HAVE_ARRAYS |
#if SCM_HAVE_ARRAYS |