1571 |
int |
int |
1572 |
scm_badargsp (SCM formals, SCM args) |
scm_badargsp (SCM formals, SCM args) |
1573 |
{ |
{ |
1574 |
while (SCM_NIMP (formals)) |
while (!SCM_NULLP (formals)) |
1575 |
{ |
{ |
1576 |
if (!SCM_CONSP (formals)) |
if (!SCM_CONSP (formals)) |
1577 |
return 0; |
return 0; |
1578 |
if (SCM_IMP(args)) |
if (SCM_NULLP (args)) |
1579 |
return 1; |
return 1; |
1580 |
formals = SCM_CDR (formals); |
formals = SCM_CDR (formals); |
1581 |
args = SCM_CDR (args); |
args = SCM_CDR (args); |
1845 |
env = scm_top_level_env (p); \ |
env = scm_top_level_env (p); \ |
1846 |
} while (0) |
} while (0) |
1847 |
|
|
|
#ifndef DEVAL |
|
|
#define CHECK_EQVISH(A,B) (SCM_EQ_P ((A), (B)) || (!SCM_FALSEP (scm_eqv_p ((A), (B))))) |
|
|
#endif /* DEVAL */ |
|
1848 |
|
|
1849 |
/* This is the evaluator. Like any real monster, it has three heads: |
/* This is the evaluator. Like any real monster, it has three heads: |
1850 |
* |
* |
1923 |
scm_report_stack_overflow (); |
scm_report_stack_overflow (); |
1924 |
} |
} |
1925 |
#endif |
#endif |
1926 |
|
|
1927 |
#ifdef DEVAL |
#ifdef DEVAL |
1928 |
goto start; |
goto start; |
1929 |
#endif |
#endif |
1930 |
|
|
1931 |
loopnoap: |
loopnoap: |
1932 |
PREP_APPLY (SCM_UNDEFINED, SCM_EOL); |
PREP_APPLY (SCM_UNDEFINED, SCM_EOL); |
1933 |
loop: |
loop: |
1950 |
SCM_SET_OVERFLOW (debug); |
SCM_SET_OVERFLOW (debug); |
1951 |
debug.info -= 2; |
debug.info -= 2; |
1952 |
} |
} |
1953 |
|
|
1954 |
start: |
start: |
1955 |
debug.info->e.exp = x; |
debug.info->e.exp = x; |
1956 |
debug.info->e.env = env; |
debug.info->e.env = env; |
1999 |
x = scm_cons (x, SCM_UNDEFINED); |
x = scm_cons (x, SCM_UNDEFINED); |
2000 |
RETURN (*scm_lookupcar (x, env, 1)); |
RETURN (*scm_lookupcar (x, env, 1)); |
2001 |
|
|
2002 |
case SCM_BIT8(SCM_IM_AND): |
case SCM_BIT8 (SCM_IM_AND): |
2003 |
x = SCM_CDR (x); |
x = SCM_CDR (x); |
2004 |
while (!SCM_NULLP (SCM_CDR (x))) |
while (!SCM_NULLP (SCM_CDR (x))) |
2005 |
{ |
{ |
2006 |
if (SCM_FALSEP (t.arg1 = EVALCAR (x, env)) || SCM_NILP (t.arg1)) |
SCM condition = EVALCAR (x, env); |
2007 |
|
if (SCM_FALSEP (condition) || SCM_NILP (condition)) |
2008 |
RETURN (SCM_BOOL_F); |
RETURN (SCM_BOOL_F); |
2009 |
else |
else |
2010 |
x = SCM_CDR (x); |
x = SCM_CDR (x); |
2012 |
PREP_APPLY (SCM_UNDEFINED, SCM_EOL); |
PREP_APPLY (SCM_UNDEFINED, SCM_EOL); |
2013 |
goto carloop; |
goto carloop; |
2014 |
|
|
2015 |
case SCM_BIT8(SCM_IM_BEGIN): |
case SCM_BIT8 (SCM_IM_BEGIN): |
2016 |
if (SCM_NULLP (SCM_CDR (x))) |
if (SCM_NULLP (SCM_CDR (x))) |
2017 |
RETURN (SCM_UNSPECIFIED); |
RETURN (SCM_UNSPECIFIED); |
2018 |
|
|
2047 |
nontoplevel_begin: |
nontoplevel_begin: |
2048 |
while (!SCM_NULLP (SCM_CDR (x))) |
while (!SCM_NULLP (SCM_CDR (x))) |
2049 |
{ |
{ |
2050 |
if (SCM_IMP (SCM_CAR (x))) |
SCM form = SCM_CAR (x); |
2051 |
|
if (SCM_IMP (form)) |
2052 |
{ |
{ |
2053 |
if (SCM_ISYMP (SCM_CAR (x))) |
if (SCM_ISYMP (form)) |
2054 |
{ |
{ |
2055 |
x = scm_m_expand_body (x, env); |
x = scm_m_expand_body (x, env); |
2056 |
goto nontoplevel_begin; |
goto nontoplevel_begin; |
2057 |
} |
} |
2058 |
else |
else |
2059 |
SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (x)); |
SCM_VALIDATE_NON_EMPTY_COMBINATION (form); |
2060 |
} |
} |
2061 |
else |
else |
2062 |
SCM_CEVAL (SCM_CAR (x), env); |
SCM_CEVAL (form, env); |
2063 |
x = SCM_CDR (x); |
x = SCM_CDR (x); |
2064 |
} |
} |
2065 |
|
|
2066 |
carloop: /* scm_eval car of last form in list */ |
carloop: |
2067 |
if (SCM_IMP (SCM_CAR (x))) |
{ |
2068 |
{ |
/* scm_eval last form in list */ |
2069 |
x = SCM_CAR (x); |
SCM last_form = SCM_CAR (x); |
|
RETURN (SCM_EVALIM (x, env)); |
|
|
} |
|
|
|
|
|
if (SCM_SYMBOLP (SCM_CAR (x))) |
|
|
RETURN (*scm_lookupcar (x, env, 1)); |
|
2070 |
|
|
2071 |
x = SCM_CAR (x); |
if (SCM_CONSP (last_form)) |
2072 |
goto loop; /* tail recurse */ |
{ |
2073 |
|
/* This is by far the most frequent case. */ |
2074 |
|
x = last_form; |
2075 |
|
goto loop; /* tail recurse */ |
2076 |
|
} |
2077 |
|
else if (SCM_IMP (last_form)) |
2078 |
|
RETURN (SCM_EVALIM (last_form, env)); |
2079 |
|
else if (SCM_VARIABLEP (last_form)) |
2080 |
|
RETURN (SCM_VARIABLE_REF (last_form)); |
2081 |
|
else if (SCM_SYMBOLP (last_form)) |
2082 |
|
RETURN (*scm_lookupcar (x, env, 1)); |
2083 |
|
else |
2084 |
|
RETURN (last_form); |
2085 |
|
} |
2086 |
|
|
2087 |
|
|
2088 |
case SCM_BIT8(SCM_IM_CASE): |
case SCM_BIT8(SCM_IM_CASE): |
2089 |
x = SCM_CDR (x); |
x = SCM_CDR (x); |
2090 |
t.arg1 = EVALCAR (x, env); |
{ |
2091 |
while (SCM_NIMP (x = SCM_CDR (x))) |
SCM key = EVALCAR (x, env); |
2092 |
{ |
x = SCM_CDR (x); |
2093 |
proc = SCM_CAR (x); |
while (!SCM_NULLP (x)) |
2094 |
if (SCM_EQ_P (scm_sym_else, SCM_CAR (proc))) |
{ |
2095 |
{ |
SCM clause = SCM_CAR (x); |
2096 |
x = SCM_CDR (proc); |
SCM labels = SCM_CAR (clause); |
2097 |
PREP_APPLY (SCM_UNDEFINED, SCM_EOL); |
if (SCM_EQ_P (labels, scm_sym_else)) |
2098 |
goto begin; |
{ |
2099 |
} |
x = SCM_CDR (clause); |
2100 |
proc = SCM_CAR (proc); |
PREP_APPLY (SCM_UNDEFINED, SCM_EOL); |
2101 |
while (SCM_NIMP (proc)) |
goto begin; |
2102 |
{ |
} |
2103 |
if (CHECK_EQVISH (SCM_CAR (proc), t.arg1)) |
while (!SCM_NULLP (labels)) |
2104 |
{ |
{ |
2105 |
x = SCM_CDAR (x); |
SCM label = SCM_CAR (labels); |
2106 |
PREP_APPLY (SCM_UNDEFINED, SCM_EOL); |
if (SCM_EQ_P (label, key) || !SCM_FALSEP (scm_eqv_p (label, key))) |
2107 |
goto begin; |
{ |
2108 |
} |
x = SCM_CDR (clause); |
2109 |
proc = SCM_CDR (proc); |
PREP_APPLY (SCM_UNDEFINED, SCM_EOL); |
2110 |
} |
goto begin; |
2111 |
} |
} |
2112 |
|
labels = SCM_CDR (labels); |
2113 |
|
} |
2114 |
|
x = SCM_CDR (x); |
2115 |
|
} |
2116 |
|
} |
2117 |
RETURN (SCM_UNSPECIFIED); |
RETURN (SCM_UNSPECIFIED); |
2118 |
|
|
2119 |
|
|
2134 |
x = SCM_CDR (proc); |
x = SCM_CDR (proc); |
2135 |
if (SCM_NULLP (x)) |
if (SCM_NULLP (x)) |
2136 |
RETURN (t.arg1); |
RETURN (t.arg1); |
2137 |
if (!SCM_EQ_P (scm_sym_arrow, SCM_CAR (x))) |
else if (!SCM_EQ_P (SCM_CAR (x), scm_sym_arrow)) |
2138 |
{ |
{ |
2139 |
PREP_APPLY (SCM_UNDEFINED, SCM_EOL); |
PREP_APPLY (SCM_UNDEFINED, SCM_EOL); |
2140 |
goto begin; |
goto begin; |
2141 |
} |
} |
2142 |
proc = SCM_CDR (x); |
proc = SCM_CDR (x); |
2143 |
proc = EVALCAR (proc, env); |
proc = EVALCAR (proc, env); |
2144 |
SCM_ASRTGO (SCM_NIMP (proc), badfun); |
SCM_ASRTGO (!SCM_IMP (proc), badfun); |
2145 |
PREP_APPLY (proc, scm_list_1 (t.arg1)); |
PREP_APPLY (proc, scm_list_1 (t.arg1)); |
2146 |
ENTER_APPLY; |
ENTER_APPLY; |
2147 |
if (SCM_CLOSUREP(proc) && scm_badformalsp (proc, 1)) |
if (SCM_CLOSUREP(proc) && scm_badformalsp (proc, 1)) |
2157 |
x = SCM_CDR (x); |
x = SCM_CDR (x); |
2158 |
proc = SCM_CADR (x); /* inits */ |
proc = SCM_CADR (x); /* inits */ |
2159 |
t.arg1 = SCM_EOL; /* values */ |
t.arg1 = SCM_EOL; /* values */ |
2160 |
while (SCM_NIMP (proc)) |
while (!SCM_NULLP (proc)) |
2161 |
{ |
{ |
2162 |
t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1); |
t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1); |
2163 |
proc = SCM_CDR (proc); |
proc = SCM_CDR (proc); |