Skip to content

Commit

Permalink
apply.
Browse files Browse the repository at this point in the history
  • Loading branch information
@schani
schani committed Jul 6, 2012
1 parent deaf64c commit 27be8c8
Show file tree
Hide file tree
Showing 3 changed files with 116 additions and 2 deletions.
90 changes: 89 additions & 1 deletion src/c/preamble.c
View file
Expand Up @@ -224,11 +224,15 @@ env_fetch (environment_t *env, int num_ups, int index)

static value_t* VAR_NAME (cljc_DOT_core_SLASH_first);
static value_t* VAR_NAME (cljc_DOT_core_SLASH_next);
static value_t* VAR_NAME (cljc_DOT_core_SLASH_count);
static value_t* VAR_NAME (cljc_DOT_core_SLASH_flatten_tail);

#define ARG_NIL VAR_NAME (cljc_DOT_core_DOT_List_SLASH_EMPTY)
#define ARG_CONS(a,d) FUNCALL2 ((closure_t*)VAR_NAME (cljc_DOT_core_SLASH_Cons), (a), (d))
#define ARG_FIRST(c) FUNCALL1 ((closure_t*)VAR_NAME (cljc_DOT_core_SLASH_first), (c))
#define ARG_NEXT(c) FUNCALL1 ((closure_t*)VAR_NAME (cljc_DOT_core_SLASH_next), (c))
#define ARG_COUNT(c) integer_get (FUNCALL1 ((closure_t*)VAR_NAME (cljc_DOT_core_SLASH_count), (c)))
#define ARG_FLATTEN_TAIL(c) FUNCALL1 ((closure_t*)VAR_NAME (cljc_DOT_core_SLASH_flatten_tail), (c))

static value_t*
Closure_IFn_invoke (int nargs, environment_t *env, value_t *arg1, value_t *arg2, value_t *arg3, value_t *argrest)
Expand Down Expand Up @@ -380,6 +384,8 @@ cljc_core_print (int nargs, environment_t *env, value_t *arg1, value_t *arg2, va
return VALUE_NIL;
}

static value_t *VAR_NAME (cljc_DOT_core_SLASH_print) = VALUE_NIL;

static bool
truth (value_t *v)
{
Expand All @@ -390,14 +396,96 @@ truth (value_t *v)
return true;
}

static value_t *VAR_NAME (cljc_DOT_core_SLASH_print) = VALUE_NIL;
static value_t*
cljc_core_apply (int nargs, environment_t *env, value_t *f, value_t *arg1, value_t *arg2, value_t *argrest)
{
int ndirect = 0;
int nrest;

assert (nargs > 1);

switch (nargs) {
case 2:
ndirect = 0;
argrest = arg1;
break;
case 3:
ndirect = 1;
argrest = arg2;
break;
default:
ndirect = 2;
argrest = ARG_FLATTEN_TAIL (argrest);
break;
}

nrest = ARG_COUNT (argrest);

switch (ndirect) {
case 0:
switch (nrest) {
case 0:
arg1 = arg2 = argrest = VALUE_NONE;
break;
case 1:
arg1 = ARG_FIRST (argrest);
arg2 = argrest = VALUE_NONE;
break;
case 2:
arg1 = ARG_FIRST (argrest);
argrest = ARG_NEXT (argrest);
arg2 = ARG_FIRST (argrest);
argrest = VALUE_NONE;
break;
default:
arg1 = ARG_FIRST (argrest);
argrest = ARG_NEXT (argrest);
arg2 = ARG_FIRST (argrest);
argrest = ARG_NEXT (argrest);
break;
}
break;
case 1:
switch (nrest) {
case 0:
arg2 = argrest = VALUE_NONE;
break;
case 1:
arg2 = ARG_FIRST (argrest);
argrest = VALUE_NONE;
break;
default:
arg2 = ARG_FIRST (argrest);
argrest = ARG_NEXT (argrest);
break;
}
break;
case 2:
switch (nrest) {
case 0:
argrest = VALUE_NONE;
break;
default:
argrest = argrest;
break;
}
break;
default:
assert (false);
}

return invoken (f, ndirect + nrest, arg1, arg2, argrest);
}

static value_t *VAR_NAME (cljc_DOT_core_SLASH_apply) = VALUE_NIL;

static void
cljc_init (void)
{
GC_INIT ();

VAR_NAME (cljc_DOT_core_SLASH_print) = make_closure (cljc_core_print, NULL);
VAR_NAME (cljc_DOT_core_SLASH_apply) = make_closure (cljc_core_apply, NULL);
value_true = alloc_value (boolean_ptable (), sizeof (value_t));
value_false = alloc_value (boolean_ptable (), sizeof (value_t));
}
1 change: 1 addition & 0 deletions src/cljc/cljc/core.cljc
View file
Expand Up @@ -7,6 +7,7 @@
(ns cljc.core)

(declare print)
(declare apply)

(defn ^boolean not
"Returns true if x is logical false, false otherwise."
Expand Down
27 changes: 26 additions & 1 deletion test/clojurec/core_test.clj
View file
Expand Up @@ -104,6 +104,7 @@
(* x (fac (- x 1)))))
(print (fac 3))))
[6]))
(is (= (core-run '(apply (fn [& r] r) '())) []))
(is (= (core-run '(do
(defn printer [a b c d e]
(print a)
Expand All @@ -113,6 +114,11 @@
(print e))
(printer 1 2 3 4 5)))
[1 2 3 4 5]))
(is (= (core-run '(loop [l (apply (fn [& r] r) 1 2 '(3 4))]
(when (seq l)
(print (first l))
(recur (rest l)))))
[1 2 3 4]))
(is (= (core-run '(do
(defn print-list [l]
(loop [l l]
Expand Down Expand Up @@ -159,13 +165,32 @@
(defn p4 [p] (p 1 2 3 4) (print -1))
(defn p5 [p] (p 1 2 3 4 5) (print -1))
(defn p6 [p] (p 1 2 3 4 5 6) (print -1))
(defn ap0 [p] (apply p '()) (print -1))
(defn ap1 [p] (apply p '(1)) (print -1))
(defn ap2 [p] (apply p '(1 2)) (print -1))
(defn ap3 [p] (apply p '(1 2 3)) (print -1))
(defn ap4 [p] (apply p '(1 2 3 4)) (print -1))
(defn ap5 [p] (apply p '(1 2 3 4 5)) (print -1))
(defn ap6 [p] (apply p '(1 2 3 4 5 6)) (print -1))
(p0 printer0) (p1 printer0) (p2 printer0) (p3 printer0) (p4 printer0) (p5 printer0) (p6 printer0)
(p1 printer1) (p2 printer1) (p3 printer1) (p4 printer1) (p5 printer1) (p6 printer1)
(p2 printer2) (p3 printer2) (p4 printer2) (p5 printer2) (p6 printer2)
(p3 printer3) (p4 printer3) (p5 printer3) (p6 printer3)
(p4 printer4) (p5 printer4) (p6 printer4)
(p5 printer5) (p6 printer5)))
(p5 printer5) (p6 printer5)
(ap0 printer0) (ap1 printer0) (ap2 printer0) (ap3 printer0) (ap4 printer0) (ap5 printer0) (ap6 printer0)
(ap1 printer1) (ap2 printer1) (ap3 printer1) (ap4 printer1) (ap5 printer1) (ap6 printer1)
(ap2 printer2) (ap3 printer2) (ap4 printer2) (ap5 printer2) (ap6 printer2)
(ap3 printer3) (ap4 printer3) (ap5 printer3) (ap6 printer3)
(ap4 printer4) (ap5 printer4) (ap6 printer4)
(ap5 printer5) (ap6 printer5)))
[0 -1 0 1 -1 0 1 2 -1 0 1 2 3 -1 0 1 2 3 4 -1 0 1 2 3 4 5 -1 0 1 2 3 4 5 6 -1
1 0 -1 1 0 2 -1 1 0 2 3 -1 1 0 2 3 4 -1 1 0 2 3 4 5 -1 1 0 2 3 4 5 6 -1
1 2 0 -1 1 2 0 3 -1 1 2 0 3 4 -1 1 2 0 3 4 5 -1 1 2 0 3 4 5 6 -1
1 2 3 0 -1 1 2 3 0 4 -1 1 2 3 0 4 5 -1 1 2 3 0 4 5 6 -1
1 2 3 4 0 -1 1 2 3 4 0 5 -1 1 2 3 4 0 5 6 -1
1 2 3 4 5 0 -1 1 2 3 4 5 0 6 -1
0 -1 0 1 -1 0 1 2 -1 0 1 2 3 -1 0 1 2 3 4 -1 0 1 2 3 4 5 -1 0 1 2 3 4 5 6 -1
1 0 -1 1 0 2 -1 1 0 2 3 -1 1 0 2 3 4 -1 1 0 2 3 4 5 -1 1 0 2 3 4 5 6 -1
1 2 0 -1 1 2 0 3 -1 1 2 0 3 4 -1 1 2 0 3 4 5 -1 1 2 0 3 4 5 6 -1
1 2 3 0 -1 1 2 3 0 4 -1 1 2 3 0 4 5 -1 1 2 3 0 4 5 6 -1
Expand Down

0 comments on commit 27be8c8

Please sign in to comment.