1 |
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002, 2003 Free Software Foundation, Inc. |
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003 Free Software Foundation, Inc. |
2 |
* |
* |
3 |
* This library is free software; you can redistribute it and/or |
* This library is free software; you can redistribute it and/or |
4 |
* modify it under the terms of the GNU Lesser General Public |
* modify it under the terms of the GNU Lesser General Public |
757 |
else if (SCM_VECTORP (form)) |
else if (SCM_VECTORP (form)) |
758 |
{ |
{ |
759 |
size_t i = SCM_VECTOR_LENGTH (form); |
size_t i = SCM_VECTOR_LENGTH (form); |
760 |
SCM const *data = SCM_VELTS (form); |
SCM const *const data = SCM_VELTS (form); |
761 |
SCM tmp = SCM_EOL; |
SCM tmp = SCM_EOL; |
762 |
while (i != 0) |
while (i != 0) |
763 |
tmp = scm_cons (data[--i], tmp); |
tmp = scm_cons (data[--i], tmp); |
1583 |
return results; |
return results; |
1584 |
} |
} |
1585 |
|
|
1586 |
|
|
1587 |
SCM |
SCM |
1588 |
scm_eval_body (SCM code, SCM env) |
scm_eval_body (SCM code, SCM env) |
1589 |
{ |
{ |
1612 |
return SCM_XEVALCAR (code, env); |
return SCM_XEVALCAR (code, env); |
1613 |
} |
} |
1614 |
|
|
|
|
|
1615 |
#endif /* !DEVAL */ |
#endif /* !DEVAL */ |
1616 |
|
|
1617 |
|
|
1755 |
} |
} |
1756 |
#undef FUNC_NAME |
#undef FUNC_NAME |
1757 |
|
|
1758 |
|
|
1759 |
SCM_DEFINE (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0, |
SCM_DEFINE (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0, |
1760 |
(SCM setting), |
(SCM setting), |
1761 |
"Option interface for the evaluator trap options.") |
"Option interface for the evaluator trap options.") |
1773 |
} |
} |
1774 |
#undef FUNC_NAME |
#undef FUNC_NAME |
1775 |
|
|
1776 |
|
|
1777 |
static SCM |
static SCM |
1778 |
deval_args (SCM l, SCM env, SCM proc, SCM *lloc) |
deval_args (SCM l, SCM env, SCM proc, SCM *lloc) |
1779 |
{ |
{ |
1803 |
#define UPDATE_TOPLEVEL_ENV(env) \ |
#define UPDATE_TOPLEVEL_ENV(env) \ |
1804 |
do { \ |
do { \ |
1805 |
SCM p = scm_current_module_lookup_closure (); \ |
SCM p = scm_current_module_lookup_closure (); \ |
1806 |
if (p != SCM_CAR(env)) \ |
if (p != SCM_CAR (env)) \ |
1807 |
env = scm_top_level_env (p); \ |
env = scm_top_level_env (p); \ |
1808 |
} while (0) |
} while (0) |
1809 |
|
|
3325 |
#ifndef DEVAL |
#ifndef DEVAL |
3326 |
|
|
3327 |
|
|
3328 |
|
|
3329 |
/* Simple procedure calls |
/* Simple procedure calls |
3330 |
*/ |
*/ |
3331 |
|
|
3449 |
#if 0 |
#if 0 |
3450 |
SCM |
SCM |
3451 |
scm_dapply (SCM proc, SCM arg1, SCM args) |
scm_dapply (SCM proc, SCM arg1, SCM args) |
3452 |
{ /* empty */ } |
{} |
3453 |
#endif |
#endif |
3454 |
|
|
3455 |
|
|
3824 |
SCM |
SCM |
3825 |
scm_i_call_closure_0 (SCM proc) |
scm_i_call_closure_0 (SCM proc) |
3826 |
{ |
{ |
3827 |
return scm_eval_body (SCM_CLOSURE_BODY (proc), |
const SCM env = SCM_ENV (proc); |
3828 |
SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), |
const SCM formals = SCM_CLOSURE_FORMALS (proc); |
3829 |
SCM_EOL, |
const SCM new_env = SCM_EXTEND_ENV (formals, SCM_EOL, env); |
3830 |
SCM_ENV (proc))); |
const SCM body = SCM_CLOSURE_BODY (proc); |
3831 |
|
const SCM result = scm_eval_body (body, new_env); |
3832 |
|
return result; |
3833 |
} |
} |
3834 |
|
|
3835 |
scm_t_trampoline_0 |
scm_t_trampoline_0 |
3836 |
scm_trampoline_0 (SCM proc) |
scm_trampoline_0 (SCM proc) |
3837 |
{ |
{ |
3838 |
if (SCM_IMP (proc)) |
if (SCM_IMP (proc)) |
3839 |
return 0; |
return NULL; |
3840 |
if (SCM_DEBUGGINGP) |
if (SCM_DEBUGGINGP) |
3841 |
return scm_call_0; |
return scm_call_0; |
3842 |
switch (SCM_TYP7 (proc)) |
switch (SCM_TYP7 (proc)) |
3853 |
if (SCM_NULLP (formals) || !SCM_CONSP (formals)) |
if (SCM_NULLP (formals) || !SCM_CONSP (formals)) |
3854 |
return scm_i_call_closure_0; |
return scm_i_call_closure_0; |
3855 |
else |
else |
3856 |
return 0; |
return NULL; |
3857 |
} |
} |
3858 |
case scm_tcs_struct: |
case scm_tcs_struct: |
3859 |
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) |
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) |
3860 |
return scm_call_generic_0; |
return scm_call_generic_0; |
3861 |
else if (!SCM_I_OPERATORP (proc)) |
else if (!SCM_I_OPERATORP (proc)) |
3862 |
return 0; |
return NULL; |
3863 |
return scm_call_0; |
return scm_call_0; |
3864 |
case scm_tc7_smob: |
case scm_tc7_smob: |
3865 |
if (SCM_SMOB_APPLICABLE_P (proc)) |
if (SCM_SMOB_APPLICABLE_P (proc)) |
3866 |
return SCM_SMOB_DESCRIPTOR (proc).apply_0; |
return SCM_SMOB_DESCRIPTOR (proc).apply_0; |
3867 |
else |
else |
3868 |
return 0; |
return NULL; |
|
/* fall through */ |
|
3869 |
case scm_tc7_asubr: |
case scm_tc7_asubr: |
3870 |
case scm_tc7_rpsubr: |
case scm_tc7_rpsubr: |
3871 |
case scm_tc7_cclo: |
case scm_tc7_cclo: |
3872 |
case scm_tc7_pws: |
case scm_tc7_pws: |
3873 |
return scm_call_0; |
return scm_call_0; |
3874 |
default: |
default: |
3875 |
return 0; /* not applicable on one arg */ |
return NULL; /* not applicable on one arg */ |
3876 |
} |
} |
3877 |
} |
} |
3878 |
|
|
3930 |
static SCM |
static SCM |
3931 |
call_closure_1 (SCM proc, SCM arg1) |
call_closure_1 (SCM proc, SCM arg1) |
3932 |
{ |
{ |
3933 |
return scm_eval_body (SCM_CLOSURE_BODY (proc), |
const SCM env = SCM_ENV (proc); |
3934 |
SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), |
const SCM formals = SCM_CLOSURE_FORMALS (proc); |
3935 |
scm_list_1 (arg1), |
const SCM args = scm_list_1 (arg1); |
3936 |
SCM_ENV (proc))); |
const SCM new_env = SCM_EXTEND_ENV (formals, args, env); |
3937 |
|
const SCM body = SCM_CLOSURE_BODY (proc); |
3938 |
|
const SCM result = scm_eval_body (body, new_env); |
3939 |
|
return result; |
3940 |
} |
} |
3941 |
|
|
3942 |
scm_t_trampoline_1 |
scm_t_trampoline_1 |
3943 |
scm_trampoline_1 (SCM proc) |
scm_trampoline_1 (SCM proc) |
3944 |
{ |
{ |
3945 |
if (SCM_IMP (proc)) |
if (SCM_IMP (proc)) |
3946 |
return 0; |
return NULL; |
3947 |
if (SCM_DEBUGGINGP) |
if (SCM_DEBUGGINGP) |
3948 |
return scm_call_1; |
return scm_call_1; |
3949 |
switch (SCM_TYP7 (proc)) |
switch (SCM_TYP7 (proc)) |
3967 |
&& (!SCM_CONSP (formals) || !SCM_CONSP (SCM_CDR (formals)))) |
&& (!SCM_CONSP (formals) || !SCM_CONSP (SCM_CDR (formals)))) |
3968 |
return call_closure_1; |
return call_closure_1; |
3969 |
else |
else |
3970 |
return 0; |
return NULL; |
3971 |
} |
} |
3972 |
case scm_tcs_struct: |
case scm_tcs_struct: |
3973 |
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) |
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) |
3974 |
return scm_call_generic_1; |
return scm_call_generic_1; |
3975 |
else if (!SCM_I_OPERATORP (proc)) |
else if (!SCM_I_OPERATORP (proc)) |
3976 |
return 0; |
return NULL; |
3977 |
return scm_call_1; |
return scm_call_1; |
3978 |
case scm_tc7_smob: |
case scm_tc7_smob: |
3979 |
if (SCM_SMOB_APPLICABLE_P (proc)) |
if (SCM_SMOB_APPLICABLE_P (proc)) |
3980 |
return SCM_SMOB_DESCRIPTOR (proc).apply_1; |
return SCM_SMOB_DESCRIPTOR (proc).apply_1; |
3981 |
else |
else |
3982 |
return 0; |
return NULL; |
|
/* fall through */ |
|
3983 |
case scm_tc7_asubr: |
case scm_tc7_asubr: |
3984 |
case scm_tc7_rpsubr: |
case scm_tc7_rpsubr: |
3985 |
case scm_tc7_cclo: |
case scm_tc7_cclo: |
3986 |
case scm_tc7_pws: |
case scm_tc7_pws: |
3987 |
return scm_call_1; |
return scm_call_1; |
3988 |
default: |
default: |
3989 |
return 0; /* not applicable on one arg */ |
return NULL; /* not applicable on one arg */ |
3990 |
} |
} |
3991 |
} |
} |
3992 |
|
|
4011 |
static SCM |
static SCM |
4012 |
call_closure_2 (SCM proc, SCM arg1, SCM arg2) |
call_closure_2 (SCM proc, SCM arg1, SCM arg2) |
4013 |
{ |
{ |
4014 |
return scm_eval_body (SCM_CLOSURE_BODY (proc), |
const SCM env = SCM_ENV (proc); |
4015 |
SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), |
const SCM formals = SCM_CLOSURE_FORMALS (proc); |
4016 |
scm_list_2 (arg1, arg2), |
const SCM args = scm_list_2 (arg1, arg2); |
4017 |
SCM_ENV (proc))); |
const SCM new_env = SCM_EXTEND_ENV (formals, args, env); |
4018 |
|
const SCM body = SCM_CLOSURE_BODY (proc); |
4019 |
|
const SCM result = scm_eval_body (body, new_env); |
4020 |
|
return result; |
4021 |
} |
} |
4022 |
|
|
4023 |
scm_t_trampoline_2 |
scm_t_trampoline_2 |
4024 |
scm_trampoline_2 (SCM proc) |
scm_trampoline_2 (SCM proc) |
4025 |
{ |
{ |
4026 |
if (SCM_IMP (proc)) |
if (SCM_IMP (proc)) |
4027 |
return 0; |
return NULL; |
4028 |
if (SCM_DEBUGGINGP) |
if (SCM_DEBUGGINGP) |
4029 |
return scm_call_2; |
return scm_call_2; |
4030 |
switch (SCM_TYP7 (proc)) |
switch (SCM_TYP7 (proc)) |
4048 |
|| !SCM_CONSP (SCM_CDDR (formals)))))) |
|| !SCM_CONSP (SCM_CDDR (formals)))))) |
4049 |
return call_closure_2; |
return call_closure_2; |
4050 |
else |
else |
4051 |
return 0; |
return NULL; |
4052 |
} |
} |
4053 |
case scm_tcs_struct: |
case scm_tcs_struct: |
4054 |
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) |
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) |
4055 |
return scm_call_generic_2; |
return scm_call_generic_2; |
4056 |
else if (!SCM_I_OPERATORP (proc)) |
else if (!SCM_I_OPERATORP (proc)) |
4057 |
return 0; |
return NULL; |
4058 |
return scm_call_2; |
return scm_call_2; |
4059 |
case scm_tc7_smob: |
case scm_tc7_smob: |
4060 |
if (SCM_SMOB_APPLICABLE_P (proc)) |
if (SCM_SMOB_APPLICABLE_P (proc)) |
4061 |
return SCM_SMOB_DESCRIPTOR (proc).apply_2; |
return SCM_SMOB_DESCRIPTOR (proc).apply_2; |
4062 |
else |
else |
4063 |
return 0; |
return NULL; |
|
/* fall through */ |
|
4064 |
case scm_tc7_cclo: |
case scm_tc7_cclo: |
4065 |
case scm_tc7_pws: |
case scm_tc7_pws: |
4066 |
return scm_call_2; |
return scm_call_2; |
4067 |
default: |
default: |
4068 |
return 0; /* not applicable on two args */ |
return NULL; /* not applicable on two args */ |
4069 |
} |
} |
4070 |
} |
} |
4071 |
|
|