commit 12857fa47148b10fa3a77f843716904b59935fe8
parent 51adc01edbf2827483c3f3df0c837a6ab9e8e865
Author: Andres Navarro <canavarro82@gmail.com>
Date: Sun, 13 Mar 2011 04:24:29 -0300
Bugfix: $lambda was a disaster. Now it correctly takes at least one parameter and does what is should.
Diffstat:
3 files changed, 86 insertions(+), 31 deletions(-)
diff --git a/src/kgcombiners.c b/src/kgcombiners.c
@@ -113,15 +113,16 @@ void unwrap(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
void Slambda(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
{
(void) xparams;
- bind_al2p(K, "$lambda", ptree, vptree, vpenv, vbody);
+ bind_al1p(K, "$lambda", ptree, vptree, vbody);
/* The ptree & body are copied to avoid mutation */
- vptree = check_copy_ptree(K, "$lambda", vptree, vpenv);
+ vptree = check_copy_ptree(K, "$lambda", vptree, KIGNORE);
/* the body should be a list */
(void)check_list(K, "$lambda", vbody);
vbody = copy_es_immutable_h(K, "$lambda", vbody);
- TValue new_app = make_applicative(K, do_vau, 4, vptree, vpenv, vbody, denv);
+ TValue new_app = make_applicative(K, do_vau, 4, vptree, KIGNORE, vbody,
+ denv);
kapply_cc(K, new_app);
}
@@ -131,26 +132,14 @@ void apply(klisp_State *K, TValue *xparams, TValue ptree,
{
(void) denv;
(void) xparams;
- bind_al2p(K, "apply", ptree, app, obj, maybe_env);
+ bind_al2tp(K, "apply", ptree,
+ "applicative", ttisapplicative, app,
+ "any", anytype, obj,
+ maybe_env);
+
+ TValue env = (get_opt_tpar(K, "apply", K_TENVIRONMENT, &maybe_env))?
+ maybe_env : kmake_empty_environment(K);
- if(!ttisapplicative(app)) {
- klispE_throw(K, "apply: Bad type on first argument "
- "(expected applicative)");
- return;
- }
- TValue env;
- /* TODO move to an inlinable function */
- if (ttisnil(maybe_env)) {
- env = kmake_empty_environment(K);
- } else if (ttispair(maybe_env) && ttisnil(kcdr(maybe_env))) {
- env = kcar(maybe_env);
- if (!ttisenvironment(env)) {
- klispE_throw(K, "apply: Bad type on optional argument "
- "(expected environment)");
- }
- } else {
- klispE_throw(K, "apply: Bad ptree structure (in optional argument)");
- }
TValue expr = kcons(K, kunwrap(K, app), obj);
ktail_eval(K, expr, env);
}
diff --git a/src/kgenv_mut.h b/src/kgenv_mut.h
@@ -220,7 +220,7 @@ inline TValue check_copy_ptree(klisp_State *K, char *name, TValue ptree,
/* TODO add symbol name */
ptree_clear_all(K, sym_ls);
klispE_throw_extra(K, name, ": same symbol in both ptree and "
- "environment parmameter");
+ "environment parameter");
}
} else if (!ttisignore(penv)) {
/* TODO add symbol name */
diff --git a/src/kghelpers.h b/src/kghelpers.h
@@ -29,16 +29,19 @@
** they expand to more than one statement and may evaluate some of
** their arguments more than once
*/
+
+/* XXX: add parens around macro vars!! */
#define bind_1p(K_, n_, ptree_, v_) \
- bind_1tp(K_, n_, ptree_, "any", anytype, v_)
+ bind_1tp((K_), (n_), (ptree_), "any", anytype, (v_))
#define bind_1tp(K_, n_, ptree_, tstr_, t_, v_) \
TValue v_; \
if (!ttispair(ptree_) || !ttisnil(kcdr(ptree_))) { \
- klispE_throw_extra(K_, n_ , ": Bad ptree (expected one argument)"); \
+ klispE_throw_extra((K_), (n_) , \
+ ": Bad ptree (expected one argument)"); \
return; \
} \
- v_ = kcar(ptree_); \
+ v_ = kcar(ptree_); \
if (!t_(v_)) { \
klispE_throw_extra(K_, n_ , ": Bad type on first argument " \
"(expected " tstr_ ")"); \
@@ -47,7 +50,8 @@
#define bind_2p(K_, n_, ptree_, v1_, v2_) \
- bind_2tp(K_, n_, ptree_, "any", anytype, v1_, "any", anytype, v2_)
+ bind_2tp((K_), (n_), (ptree_), "any", anytype, (v1_), \
+ "any", anytype, (v2_))
#define bind_2tp(K_, n_, ptree_, tstr1_, t1_, v1_, \
tstr2_, t2_, v2_) \
@@ -98,18 +102,80 @@
return; \
}
+/* bind at least 1 parameter, like (v1_ . v2_) */
+#define bind_al1p(K_, n_, ptree_, v1_, v2_) \
+ bind_al1tp((K_), (n_), (ptree_), "any", anytype, (v1_), (v2_))
+
+/* bind at least 1 parameters (with type), like (v1_ . v2_) */
+#define bind_al1tp(K_, n_, ptree_, tstr1_, t1_, v1_, v2_) \
+ TValue v1_, v2_; \
+ if (!ttispair(ptree_)) { \
+ klispE_throw_extra(K_, n_ , ": Bad ptree (expected at least " \
+ "one argument)"); \
+ return; \
+ } \
+ v1_ = kcar(ptree_); \
+ v2_ = kcdr(ptree_); \
+ if (!t1_(v1_)) { \
+ klispE_throw_extra(K_, n_, ": Bad type on first argument (expected " \
+ tstr1_ ")"); \
+ return; \
+ }
/* bind at least 2 parameters, like (v1_ v2_ . v3_) */
#define bind_al2p(K_, n_, ptree_, v1_, v2_, v3_) \
+ bind_al2tp((K_), (n_), (ptree_), "any", anytype, (v1_), \
+ "any", anytype, (v2_), (v3_))
+
+/* bind at least 2 parameters (with type), like (v1_ v2_ . v3_) */
+#define bind_al2tp(K_, n_, ptree_, tstr1_, t1_, v1_, \
+ tstr2_, t2_, v2_, v3_) \
TValue v1_, v2_, v3_; \
- if (!ttispair(ptree_) || !ttispair(kcdr(ptree_))) { \
- klispE_throw_extra(K_, n_, ": Bad ptree (expected at least 2 " \
- "arguments)"); \
+ if (!ttispair(ptree_) || !ttispair(kcdr(ptree_))) { \
+ klispE_throw_extra(K_, n_ , ": Bad ptree (expected at least " \
+ "two arguments)"); \
return; \
} \
v1_ = kcar(ptree_); \
v2_ = kcadr(ptree_); \
- v3_ = kcddr(ptree_)
+ v3_ = kcddr(ptree_); \
+ if (!t1_(v1_)) { \
+ klispE_throw_extra(K_, n_, ": Bad type on first argument (expected " \
+ tstr1_ ")"); \
+ return; \
+ } else if (!t2_(v2_)) { \
+ klispE_throw_extra(K_, n_, ": Bad type on second argument (expected " \
+ tstr2_ ")"); \
+ return; \
+ }
+
+
+/* returns true if the obj pointed by par is a list of one element of
+ type type, and puts that element in par
+ returns false if *par is nil
+ In any other case it throws an error */
+inline bool get_opt_tpar(klisp_State *K, char *name, int32_t type, TValue *par)
+{
+ if (ttisnil(*par)) {
+ return false;
+ } else if (ttispair(*par) && ttisnil(kcdr(*par))) {
+ *par = kcar(*par);
+ if (ttype(*par) != type) {
+ /* TODO show expected type */
+ klispE_throw_extra(K, name, ": Bad type on optional argument "
+ "(expected ?)");
+ /* avoid warning */
+ return false;
+ } else {
+ return true;
+ }
+ } else {
+ klispE_throw(K, "apply: Bad ptree structure (in optional argument)");
+ /* avoid warning */
+ return false;
+ }
+}
+
/* TODO: add name and source info */
#define make_operative(K_, fn_, ...) \
