100 |
|
|
101 |
#include "libguile/validate.h" |
#include "libguile/validate.h" |
102 |
#include "libguile/eval.h" |
#include "libguile/eval.h" |
103 |
|
#include "libguile/lang.h" |
104 |
|
|
105 |
|
|
106 |
|
|
538 |
scm_m_if (SCM xorig, SCM env SCM_UNUSED) |
scm_m_if (SCM xorig, SCM env SCM_UNUSED) |
539 |
{ |
{ |
540 |
long len = scm_ilength (SCM_CDR (xorig)); |
long len = scm_ilength (SCM_CDR (xorig)); |
541 |
SCM_ASSYNT (len >= 2 && len <= 3, scm_s_expression, "if"); |
SCM_ASSYNT (len >= 2 && len <= 3, scm_s_expression, s_if); |
542 |
return scm_cons (SCM_IM_IF, SCM_CDR (xorig)); |
return scm_cons (SCM_IM_IF, SCM_CDR (xorig)); |
543 |
} |
} |
544 |
|
|
1074 |
return scm_cons (SCM_IM_CONT, SCM_CDR (xorig)); |
return scm_cons (SCM_IM_CONT, SCM_CDR (xorig)); |
1075 |
} |
} |
1076 |
|
|
1077 |
/* Multi-language support */ |
#ifdef SCM_ENABLE_ELISP |
|
|
|
|
SCM_GLOBAL_SYMBOL (scm_lisp_nil, "nil"); |
|
|
SCM_GLOBAL_SYMBOL (scm_lisp_t, "t"); |
|
1078 |
|
|
1079 |
SCM_SYNTAX (s_nil_cond, "nil-cond", scm_makmmacro, scm_m_nil_cond); |
SCM_SYNTAX (s_nil_cond, "nil-cond", scm_makmmacro, scm_m_nil_cond); |
1080 |
|
|
1086 |
return scm_cons (SCM_IM_NIL_COND, SCM_CDR (xorig)); |
return scm_cons (SCM_IM_NIL_COND, SCM_CDR (xorig)); |
1087 |
} |
} |
1088 |
|
|
|
SCM_SYNTAX (s_nil_ify, "nil-ify", scm_makmmacro, scm_m_nil_ify); |
|
|
|
|
|
SCM |
|
|
scm_m_nil_ify (SCM xorig, SCM env SCM_UNUSED) |
|
|
{ |
|
|
SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_s_expression, "nil-ify"); |
|
|
return scm_cons (SCM_IM_NIL_IFY, SCM_CDR (xorig)); |
|
|
} |
|
|
|
|
|
SCM_SYNTAX (s_t_ify, "t-ify", scm_makmmacro, scm_m_t_ify); |
|
|
|
|
|
SCM |
|
|
scm_m_t_ify (SCM xorig, SCM env SCM_UNUSED) |
|
|
{ |
|
|
SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_s_expression, "t-ify"); |
|
|
return scm_cons (SCM_IM_T_IFY, SCM_CDR (xorig)); |
|
|
} |
|
|
|
|
|
SCM_SYNTAX (s_0_cond, "0-cond", scm_makmmacro, scm_m_0_cond); |
|
|
|
|
|
SCM |
|
|
scm_m_0_cond (SCM xorig, SCM env SCM_UNUSED) |
|
|
{ |
|
|
long len = scm_ilength (SCM_CDR (xorig)); |
|
|
SCM_ASSYNT (len >= 1 && (len & 1) == 1, scm_s_expression, "0-cond"); |
|
|
return scm_cons (SCM_IM_0_COND, SCM_CDR (xorig)); |
|
|
} |
|
|
|
|
|
SCM_SYNTAX (s_0_ify, "0-ify", scm_makmmacro, scm_m_0_ify); |
|
|
|
|
|
SCM |
|
|
scm_m_0_ify (SCM xorig, SCM env SCM_UNUSED) |
|
|
{ |
|
|
SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_s_expression, "0-ify"); |
|
|
return scm_cons (SCM_IM_0_IFY, SCM_CDR (xorig)); |
|
|
} |
|
|
|
|
|
SCM_SYNTAX (s_1_ify, "1-ify", scm_makmmacro, scm_m_1_ify); |
|
|
|
|
|
SCM |
|
|
scm_m_1_ify (SCM xorig, SCM env SCM_UNUSED) |
|
|
{ |
|
|
SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_s_expression, "1-ify"); |
|
|
return scm_cons (SCM_IM_1_IFY, SCM_CDR (xorig)); |
|
|
} |
|
|
|
|
1089 |
SCM_SYNTAX (s_atfop, "@fop", scm_makmmacro, scm_m_atfop); |
SCM_SYNTAX (s_atfop, "@fop", scm_makmmacro, scm_m_atfop); |
1090 |
|
|
1091 |
SCM |
SCM |
1094 |
SCM x = SCM_CDR (xorig), var; |
SCM x = SCM_CDR (xorig), var; |
1095 |
SCM_ASSYNT (scm_ilength (x) >= 1, scm_s_expression, "@fop"); |
SCM_ASSYNT (scm_ilength (x) >= 1, scm_s_expression, "@fop"); |
1096 |
var = scm_symbol_fref (SCM_CAR (x)); |
var = scm_symbol_fref (SCM_CAR (x)); |
1097 |
|
/* Passing the symbol name as the `subr' arg here isn't really |
1098 |
|
right, but without it it can be very difficult to work out from |
1099 |
|
the error message which function definition was missing. In any |
1100 |
|
case, we shouldn't really use SCM_ASSYNT here at all, but instead |
1101 |
|
something equivalent to (signal void-function (list SYM)) in |
1102 |
|
Elisp. */ |
1103 |
SCM_ASSYNT (SCM_VARIABLEP (var), |
SCM_ASSYNT (SCM_VARIABLEP (var), |
1104 |
"Symbol's function definition is void", NULL); |
"Symbol's function definition is void", |
1105 |
|
SCM_SYMBOL_CHARS (SCM_CAR (x))); |
1106 |
|
/* Support `defalias'. */ |
1107 |
|
while (SCM_SYMBOLP (SCM_VARIABLE_REF (var))) |
1108 |
|
{ |
1109 |
|
var = scm_symbol_fref (SCM_VARIABLE_REF (var)); |
1110 |
|
SCM_ASSYNT (SCM_VARIABLEP (var), |
1111 |
|
"Symbol's function definition is void", |
1112 |
|
SCM_SYMBOL_CHARS (SCM_CAR (x))); |
1113 |
|
} |
1114 |
|
/* Use `var' here rather than `SCM_VARIABLE_REF (var)' because the |
1115 |
|
former allows for automatically picking up redefinitions of the |
1116 |
|
corresponding symbol. */ |
1117 |
SCM_SETCAR (x, var); |
SCM_SETCAR (x, var); |
1118 |
|
/* If the variable contains a procedure, leave the |
1119 |
|
`transformer-macro' in place so that the procedure's arguments |
1120 |
|
get properly transformed, and change the initial @fop to |
1121 |
|
SCM_IM_APPLY. */ |
1122 |
|
if (!SCM_MACROP (SCM_VARIABLE_REF (var))) |
1123 |
|
{ |
1124 |
|
SCM_SETCAR (xorig, SCM_IM_APPLY); |
1125 |
|
return xorig; |
1126 |
|
} |
1127 |
|
/* Otherwise (the variable contains a macro), the arguments should |
1128 |
|
not be transformed, so cut the `transformer-macro' out and return |
1129 |
|
the resulting expression starting with the variable. */ |
1130 |
|
SCM_SETCDR (x, SCM_CDADR (x)); |
1131 |
return x; |
return x; |
1132 |
} |
} |
1133 |
|
|
1134 |
|
#endif /* SCM_ENABLE_ELISP */ |
1135 |
|
|
1136 |
/* (@bind ((var exp) ...) body ...) |
/* (@bind ((var exp) ...) body ...) |
1137 |
|
|
1138 |
This will assign the values of the `exp's to the global variables |
This will assign the values of the `exp's to the global variables |
1143 |
error when a symbol appears more than once among the `var's. |
error when a symbol appears more than once among the `var's. |
1144 |
All `exp's are evaluated before any `var' is set. |
All `exp's are evaluated before any `var' is set. |
1145 |
|
|
1146 |
This of this as `let' for dynamic scope. |
Think of this as `let' for dynamic scope. |
1147 |
|
|
1148 |
It is memoized into (#@bind ((var ...) . (reversed-val ...)) body ...). |
It is memoized into (#@bind ((var ...) . (reversed-val ...)) body ...). |
1149 |
|
|
1310 |
* generating the source for a stackframe in a backtrace, and in |
* generating the source for a stackframe in a backtrace, and in |
1311 |
* display_expression. |
* display_expression. |
1312 |
* |
* |
1313 |
* Unmemoizing is not a realiable process. You can not in general |
* Unmemoizing is not a reliable process. You cannot in general |
1314 |
* expect to get the original source back. |
* expect to get the original source back. |
1315 |
* |
* |
1316 |
* However, GOOPS currently relies on this for method compilation. |
* However, GOOPS currently relies on this for method compilation. |
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 (EVALCAR (x, env))) |
if (SCM_FALSEP (t.arg1 = EVALCAR (x, env)) || SCM_NILP (t.arg1)) |
2007 |
RETURN (SCM_BOOL_F); |
RETURN (SCM_BOOL_F); |
2008 |
else |
else |
2009 |
x = SCM_CDR (x); |
x = SCM_CDR (x); |
2114 |
goto begin; |
goto begin; |
2115 |
} |
} |
2116 |
t.arg1 = EVALCAR (proc, env); |
t.arg1 = EVALCAR (proc, env); |
2117 |
if (!SCM_FALSEP (t.arg1)) |
if (!SCM_FALSEP (t.arg1) && !SCM_NILP (t.arg1)) |
2118 |
{ |
{ |
2119 |
x = SCM_CDR (proc); |
x = SCM_CDR (proc); |
2120 |
if (SCM_NULLP (x)) |
if (SCM_NULLP (x)) |
2149 |
} |
} |
2150 |
env = EXTEND_ENV (SCM_CAR (x), t.arg1, env); |
env = EXTEND_ENV (SCM_CAR (x), t.arg1, env); |
2151 |
x = SCM_CDDR (x); |
x = SCM_CDDR (x); |
2152 |
while (proc = SCM_CAR (x), SCM_FALSEP (EVALCAR (proc, env))) |
while (proc = SCM_CAR (x), |
2153 |
|
SCM_FALSEP (t.arg1 = EVALCAR (proc, env)) || SCM_NILP (t.arg1)) |
2154 |
{ |
{ |
2155 |
for (proc = SCM_CADR (x); SCM_NIMP (proc); proc = SCM_CDR (proc)) |
for (proc = SCM_CADR (x); SCM_NIMP (proc); proc = SCM_CDR (proc)) |
2156 |
{ |
{ |
2172 |
|
|
2173 |
case SCM_BIT8(SCM_IM_IF): |
case SCM_BIT8(SCM_IM_IF): |
2174 |
x = SCM_CDR (x); |
x = SCM_CDR (x); |
2175 |
if (!SCM_FALSEP (EVALCAR (x, env))) |
if (!SCM_FALSEP (t.arg1 = EVALCAR (x, env)) && !SCM_NILP (t.arg1)) |
2176 |
x = SCM_CDR (x); |
x = SCM_CDR (x); |
2177 |
else if (SCM_IMP (x = SCM_CDDR (x))) |
else if (SCM_IMP (x = SCM_CDDR (x))) |
2178 |
RETURN (SCM_UNSPECIFIED); |
RETURN (SCM_UNSPECIFIED); |
2235 |
while (!SCM_NULLP (SCM_CDR (x))) |
while (!SCM_NULLP (SCM_CDR (x))) |
2236 |
{ |
{ |
2237 |
SCM val = EVALCAR (x, env); |
SCM val = EVALCAR (x, env); |
2238 |
if (!SCM_FALSEP (val)) |
if (!SCM_FALSEP (val) && !SCM_NILP (val)) |
2239 |
RETURN (val); |
RETURN (val); |
2240 |
else |
else |
2241 |
x = SCM_CDR (x); |
x = SCM_CDR (x); |
2463 |
SCM_STRUCT_DATA (t.arg1) [SCM_INUM (SCM_CAR (x))] |
SCM_STRUCT_DATA (t.arg1) [SCM_INUM (SCM_CAR (x))] |
2464 |
= SCM_UNPACK (EVALCAR (proc, env)); |
= SCM_UNPACK (EVALCAR (proc, env)); |
2465 |
RETURN (SCM_UNSPECIFIED); |
RETURN (SCM_UNSPECIFIED); |
2466 |
|
|
2467 |
|
#ifdef SCM_ENABLE_ELISP |
2468 |
|
|
2469 |
case (SCM_ISYMNUM (SCM_IM_NIL_COND)): |
case (SCM_ISYMNUM (SCM_IM_NIL_COND)): |
2470 |
proc = SCM_CDR (x); |
proc = SCM_CDR (x); |
2471 |
while (SCM_NIMP (x = SCM_CDR (proc))) |
while (SCM_NIMP (x = SCM_CDR (proc))) |
2472 |
{ |
{ |
2473 |
if (!(SCM_FALSEP (t.arg1 = EVALCAR (proc, env)) |
if (!(SCM_FALSEP (t.arg1 = EVALCAR (proc, env)) |
2474 |
|| SCM_EQ_P (t.arg1, scm_lisp_nil))) |
|| SCM_NILP (t.arg1) |
2475 |
{ |
|| SCM_NULLP (t.arg1))) |
|
if (SCM_EQ_P (SCM_CAR (x), SCM_UNSPECIFIED)) |
|
|
RETURN (t.arg1); |
|
|
PREP_APPLY (SCM_UNDEFINED, SCM_EOL); |
|
|
goto carloop; |
|
|
} |
|
|
proc = SCM_CDR (x); |
|
|
} |
|
|
x = proc; |
|
|
PREP_APPLY (SCM_UNDEFINED, SCM_EOL); |
|
|
goto carloop; |
|
|
|
|
|
case (SCM_ISYMNUM (SCM_IM_NIL_IFY)): |
|
|
x = SCM_CDR (x); |
|
|
RETURN ((SCM_FALSEP (proc = EVALCAR (x, env)) || SCM_NULLP (proc)) |
|
|
? scm_lisp_nil |
|
|
: proc); |
|
|
|
|
|
case (SCM_ISYMNUM (SCM_IM_T_IFY)): |
|
|
x = SCM_CDR (x); |
|
|
RETURN (!SCM_FALSEP (EVALCAR (x, env)) ? scm_lisp_t : scm_lisp_nil); |
|
|
|
|
|
case (SCM_ISYMNUM (SCM_IM_0_COND)): |
|
|
proc = SCM_CDR (x); |
|
|
while (SCM_NIMP (x = SCM_CDR (proc))) |
|
|
{ |
|
|
if (!(SCM_FALSEP (t.arg1 = EVALCAR (proc, env)) |
|
|
|| SCM_EQ_P (t.arg1, SCM_INUM0))) |
|
2476 |
{ |
{ |
2477 |
if (SCM_EQ_P (SCM_CAR (x), SCM_UNSPECIFIED)) |
if (SCM_EQ_P (SCM_CAR (x), SCM_UNSPECIFIED)) |
2478 |
RETURN (t.arg1); |
RETURN (t.arg1); |
2485 |
PREP_APPLY (SCM_UNDEFINED, SCM_EOL); |
PREP_APPLY (SCM_UNDEFINED, SCM_EOL); |
2486 |
goto carloop; |
goto carloop; |
2487 |
|
|
2488 |
case (SCM_ISYMNUM (SCM_IM_0_IFY)): |
#endif /* SCM_ENABLE_ELISP */ |
|
x = SCM_CDR (x); |
|
|
RETURN (SCM_FALSEP (proc = EVALCAR (x, env)) |
|
|
? SCM_INUM0 |
|
|
: proc); |
|
|
|
|
|
case (SCM_ISYMNUM (SCM_IM_1_IFY)): |
|
|
x = SCM_CDR (x); |
|
|
RETURN (!SCM_FALSEP (EVALCAR (x, env)) |
|
|
? SCM_MAKINUM (1) |
|
|
: SCM_INUM0); |
|
2489 |
|
|
2490 |
case (SCM_ISYMNUM (SCM_IM_BIND)): |
case (SCM_ISYMNUM (SCM_IM_BIND)): |
2491 |
{ |
{ |
2519 |
|
|
2520 |
RETURN (proc); |
RETURN (proc); |
2521 |
} |
} |
2522 |
|
|
2523 |
case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES)): |
case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES)): |
2524 |
{ |
{ |
2525 |
proc = SCM_CDR (x); |
proc = SCM_CDR (x); |
3339 |
SCM *lloc; |
SCM *lloc; |
3340 |
SCM_VALIDATE_NONEMPTYLIST (1,lst); |
SCM_VALIDATE_NONEMPTYLIST (1,lst); |
3341 |
lloc = &lst; |
lloc = &lst; |
3342 |
while (!SCM_NULLP (SCM_CDR (*lloc))) |
while (!SCM_NULLP (SCM_CDR (*lloc))) /* Perhaps should be |
3343 |
|
SCM_NULL_OR_NIL_P, but not |
3344 |
|
needed in 99.99% of cases, |
3345 |
|
and it could seriously hurt |
3346 |
|
performance. - Neil */ |
3347 |
lloc = SCM_CDRLOC (*lloc); |
lloc = SCM_CDRLOC (*lloc); |
3348 |
SCM_ASSERT (scm_ilength (SCM_CAR (*lloc)) >= 0, lst, SCM_ARG1, FUNC_NAME); |
SCM_ASSERT (scm_ilength (SCM_CAR (*lloc)) >= 0, lst, SCM_ARG1, FUNC_NAME); |
3349 |
*lloc = SCM_CAR (*lloc); |
*lloc = SCM_CAR (*lloc); |
3801 |
SCM_GASSERTn (len >= 0, g_for_each, scm_cons2 (proc, arg1, args), |
SCM_GASSERTn (len >= 0, g_for_each, scm_cons2 (proc, arg1, args), |
3802 |
SCM_ARG2, s_for_each); |
SCM_ARG2, s_for_each); |
3803 |
SCM_VALIDATE_REST_ARGUMENT (args); |
SCM_VALIDATE_REST_ARGUMENT (args); |
3804 |
if SCM_NULLP (args) |
if (SCM_NULLP (args)) |
3805 |
{ |
{ |
3806 |
while SCM_NIMP (arg1) |
while (SCM_NIMP (arg1)) |
3807 |
{ |
{ |
3808 |
scm_apply (proc, SCM_CAR (arg1), scm_listofnull); |
scm_apply (proc, SCM_CAR (arg1), scm_listofnull); |
3809 |
arg1 = SCM_CDR (arg1); |
arg1 = SCM_CDR (arg1); |
3820 |
arg1 = SCM_EOL; |
arg1 = SCM_EOL; |
3821 |
for (i = SCM_VECTOR_LENGTH (args) - 1; i >= 0; i--) |
for (i = SCM_VECTOR_LENGTH (args) - 1; i >= 0; i--) |
3822 |
{ |
{ |
3823 |
if SCM_IMP |
if (SCM_IMP (ve[i])) |
3824 |
(ve[i]) return SCM_UNSPECIFIED; |
return SCM_UNSPECIFIED; |
3825 |
arg1 = scm_cons (SCM_CAR (ve[i]), arg1); |
arg1 = scm_cons (SCM_CAR (ve[i]), arg1); |
3826 |
ve[i] = SCM_CDR (ve[i]); |
ve[i] = SCM_CDR (ve[i]); |
3827 |
} |
} |
4137 |
#ifndef SCM_MAGIC_SNARFER |
#ifndef SCM_MAGIC_SNARFER |
4138 |
#include "libguile/eval.x" |
#include "libguile/eval.x" |
4139 |
#endif |
#endif |
|
|
|
|
scm_c_define ("nil", scm_lisp_nil); |
|
|
scm_c_define ("t", scm_lisp_t); |
|
4140 |
|
|
4141 |
scm_add_feature ("delay"); |
scm_add_feature ("delay"); |
4142 |
} |
} |