gt, lt, /massive/ phi and psi bugs plugged

diff --git a/demos.kl b/demos.kl
index 45960f9ec71624c509e028949133a8777f6e5ce0..31c455ea21f7b07fced4c43fe17e83e04d3a7788 100644 (file)
--- a/demos.kl
+++ b/demos.kl
@@ -14,6 +14,18 @@
 (def U (L O))
 (def F (E T T E T))
 
+
+(def zd-identity I)
+(def zd-constant K)
+(def zd-compose B)
+(def zd-flip C)
+(def zd-duplicate W)
+(def zd-left t)
+(def zd-right nil)
+(def zd-recombine Phi)
+(def zd-under Psi)
+(def zd-conditional (B (B S) S))
+
 (def if I)
 
 (def church-and (B W (B C) I))
@@ -37,3 +49,15 @@
 (def map (B (B reverse) (B (B (Z (B (S (S (B (eq nil) (2 cdr)) (B car cdr))) (C B (S (B cons car) (Phi cons (Phi cons (S car (B (B car cdr) cdr)) (B car cdr)) (3 cdr))))))) (C (B B cons) (cons nil)))))
 
 (def fold (B (S (C (C (eq nil) nil) (Z (B (S (S (B (eq nil) (B cdr cdr)) (B car cdr))) (C B (S (B cons car) (Phi cons (S (S car (B car cdr)) (B car (2 cdr))) (3 cdr)))))))) cons))
+
+
+(def compose-all (rest (B (fold (B (C B unquote) B)) (cons I))))
+
+(def fibonacci-generator (Z (B (B (C (C C nil))) (B (Phi cons (Phi + car cdr)) (C B (Phi cons (Phi + car cdr) car))))))
+
+(def abstract-generator (Z (B (B (B (B (C (C C nil))))) (B (Phi B (B S (B cons))) (B (B W) (B (B B)))))))
+
+(def intermediary (Z (C (B B (B B (B C (B (B S) (B C (C (C Phi cdr) car)))))) (C (B (B B (Phi cons)) (C (C Phi car) cdr)) (C B cdr)))))
+(def withcons (B (B (B Z)) intermediary))
+
+(def tr-fac (B (S (Phi (eq 0) cdr car)) (C B (Phi cons (Phi * car cdr) (B (C - 1) cdr)))))
\ No newline at end of file

diff --git a/src/builtins.c b/src/builtins.c
index 840eac5a0e33a41b76cf27a548a096b07959cd6f..dfe2052e640accabafd95f43fa5b8c913a4bfacb 100644 (file)
--- a/src/builtins.c
+++ b/src/builtins.c
@@ -178,6 +178,10 @@ char* lookup_builtin(Sexpr* b) {
                        return ARITH_DIV_STR;
                case ARITH_MOD:
                        return ARITH_MOD_STR;
+               case ARITH_GT:
+                       return ARITH_GT_STR;
+               case ARITH_LT:
+                       return ARITH_LT_STR;
                default:
                        return "NOT FOUND (ARITH)";
                }

diff --git a/src/builtins/arithmetic.c b/src/builtins/arithmetic.c
index ea9ab886b85285be370d9f2d39a464ca124c8ebe..c13a0dc896fafaac1ccda0d8a6e00d6071527d14 100644 (file)
--- a/src/builtins/arithmetic.c
+++ b/src/builtins/arithmetic.c
@@ -131,6 +131,54 @@ Sexpr* a_mod(Sexpr* b, Sexpr* rest, Sexpr* env) {
        return cons(from_uint(n % m), rest);
 }
 
+ Sexpr* a_gt(Sexpr* b, Sexpr* rest, Sexpr* env) {
+       if(ARITH_GT_ARGS != u64_get_num_args(b)) {
+               return cons(b, rest);
+       }
+       Sexpr* args = b->value.b.args;
+       Sexpr* i = eval(clone(car(args)), env);
+       Sexpr* j = eval(clone(car(cdr(args))), env);
+#ifdef TYPECHECK
+       if((unquote(i)->type != UINT) || (unquote(j)->type != UINT)) {
+               ERR("%: ", "arguments not uints");
+               sexpr_free(b);
+               sexpr_free(i);
+               sexpr_free(j);
+               return cons(from_nil(), rest);
+       }
+#endif
+               K_UINT_TYPE m = unquote(i)->value.u;
+               K_UINT_TYPE n = unquote(j)->value.u;
+               sexpr_free(b);
+               sexpr_free(i);
+               sexpr_free(j);
+               return cons(m > n ? from_nil(): from_t(), rest);
+}
+
+Sexpr* a_lt(Sexpr* b, Sexpr* rest, Sexpr* env) {
+       if(ARITH_LT_ARGS != u64_get_num_args(b)) {
+               return cons(b, rest);
+       }
+       Sexpr* args = b->value.b.args;
+       Sexpr* i = eval(clone(car(args)), env);
+       Sexpr* j = eval(clone(car(cdr(args))), env);
+#ifdef TYPECHECK
+       if((unquote(i)->type != UINT) || (unquote(j)->type != UINT)) {
+               ERR("%: ", "arguments not uints");
+               sexpr_free(b);
+               sexpr_free(i);
+               sexpr_free(j);
+               return cons(from_nil(), rest);
+       }
+#endif
+               K_UINT_TYPE m = unquote(i)->value.u;
+               K_UINT_TYPE n = unquote(j)->value.u;
+               sexpr_free(b);
+               sexpr_free(i);
+               sexpr_free(j);
+               return cons(m < n ? from_nil() : from_t(), rest);
+}
+
 
 Sexpr* x_arith_dispatch(Sexpr* b, Sexpr* rest, Sexpr* env) {
        uint64_t code = b->value.b.opcode & 0xff;
@@ -146,6 +194,10 @@ Sexpr* x_arith_dispatch(Sexpr* b, Sexpr* rest, Sexpr* env) {
                return a_div(b, rest, env);
        case ARITH_MOD:
                return a_mod(b, rest, env);
+       case ARITH_GT:
+               return a_gt(b, rest, env);
+       case ARITH_LT:
+               return a_lt(b, rest, env);
        default:
                return from_nil();
        }
@@ -158,6 +210,8 @@ Sexpr* load_arith_env(Sexpr* env) {
        load_builtin(ARITH_MUL_STR, (ARITH_PREFIX << 8) | ARITH_MUL, env);
        load_builtin(ARITH_DIV_STR, (ARITH_PREFIX << 8) | ARITH_DIV, env);
        load_builtin(ARITH_MOD_STR, (ARITH_PREFIX << 8) | ARITH_MOD, env);
+       load_builtin(ARITH_GT_STR, (ARITH_PREFIX << 8) | ARITH_GT, env);
+       load_builtin(ARITH_LT_STR, (ARITH_PREFIX << 8) | ARITH_LT, env);
        
        return env;
 }

diff --git a/src/builtins/arithmetic.h b/src/builtins/arithmetic.h
index 00900ce123501fb4b0a3b47136fa9b646c83866d..efa64db5a9412fcab0e2cb9da276c1b43917a84e 100644 (file)
--- a/src/builtins/arithmetic.h
+++ b/src/builtins/arithmetic.h
@@ -21,6 +21,12 @@
 #define ARITH_MOD 0x04
 #define ARITH_MOD_ARGS 2
 #define ARITH_MOD_STR "%"
+#define ARITH_GT 0x05
+#define ARITH_GT_ARGS 2
+#define ARITH_GT_STR ">"
+#define ARITH_LT 0x06
+#define ARITH_LT_ARGS 2
+#define ARITH_LT_STR "<"
 
 Sexpr* x_arith_dispatch(Sexpr* s, Sexpr* rest, Sexpr* env);
 Sexpr* load_arith_env(Sexpr* env);

diff --git a/src/builtins/combinators.c b/src/builtins/combinators.c
index 0aa2fdbe3e09c75816fe6ee02d3de0cf4c69cbb1..7a0741d1058f28c4fc3f0bfd78d184b748b33497 100644 (file)
--- a/src/builtins/combinators.c
+++ b/src/builtins/combinators.c
@@ -100,7 +100,7 @@ Sexpr* c_phi(Sexpr* b, Sexpr* rest, Sexpr* env) {
        Sexpr* d2 = clone(d);
        Sexpr* bd = cons(bee, cons(d, from_nil()));
        Sexpr* cd = cons(c, cons(d2, from_nil()));
-       Sexpr* ret = cons(a, cons(bd, cons(cd, from_nil())));
+       Sexpr* ret = cons(a, cons(bd, cons(cd, rest)));
        sexpr_free(b);
        return ret;
 }
@@ -117,7 +117,7 @@ Sexpr* c_psi(Sexpr* b, Sexpr* rest, Sexpr* env) {
        Sexpr* bee2 = clone(bee);
        Sexpr* bd = cons(bee, cons(d, from_nil()));
        Sexpr* bc = cons(bee2, cons(c, from_nil()));
-       Sexpr* ret = cons(a, cons(bc, cons(bd, from_nil())));
+       Sexpr* ret = cons(a, cons(bc, cons(bd, rest)));
        sexpr_free(b);
        return ret;
 }

diff --git a/src/test.c b/src/test.c
index ecbf8fae949a00063ec4cbbe519fe797dcf020d5..a273ec219b222f8262cee4df62cc3f0b63478c68 100644 (file)
--- a/src/test.c
+++ b/src/test.c
@@ -9,6 +9,7 @@
 #include "dict.h"
 #include "eval.h"
 #include "builtins.h"
+#include "util.h"
 
 void assert_eq(Sexpr* env, char* a, char* b) {
        Sexpr* ap = parse(a);
@@ -23,6 +24,7 @@ void assert_eq(Sexpr* env, char* a, char* b) {
        }
        else {
                printf("\033[1m\033[31mFAILED\033[0m: %s != %s\n", a, b);
+               printf("got %s and %s\n", ao, bo);
        }
        sexpr_free(av);
        sexpr_free(bv);
@@ -383,10 +385,85 @@ void eval_tests() {
 void many_asserts() {
        Sexpr* env = init_dict();
        env = load_env(env);
+       env = load_file(env, "demos.kl");
 
+       // copy-paste this thing as needed
+       assert_eq(env, "", "");
+
+       printf("basics\n");
        assert_eq(env, "(+ 4 4)", "8");
-       assert_eq(env, "(* 3 4)", "8");
+       assert_eq(env, "(* 3 4)", "12");
+       assert_eq(env, "((+ 3) 7)", "10");
+       assert_eq(env, "atom 55", "t");
+       assert_eq(env, "atom (quote (1 2 3))", "nil");
+       assert_eq(env, "(cons 1 (cons 2 nil))", "(list 1 2)");
+       // the following two are problems... maybe
+       assert_eq(env, "(car (cons 1 2))","quote 1"); // PROBLEM
+       assert_eq(env, "(cdr (cons 1 2))", "quote 2"); // PROBLEM
+       assert_eq(env, "(eq 1 1)", "t");
+       assert_eq(env, "(eq 1 2)", "nil");
+       assert_eq(env, "(eq 1 (quote 1))", "t"); // PROBLEM
+       assert_eq(env, "eq (cons 1 2) (cons 1 2)", "t");
+       assert_eq(env, "eq (cons 1 2) (cons 1 3)", "nil");
+       assert_eq(env, "eq (quote (1 2)) (cons 1 (cons 2 nil))", "t"); // PROBLEM
+       assert_eq(env, "not 54", "nil");
+       assert_eq(env, "not nil", "t");
+       assert_eq(env, "def asdf 545", "545");
+       assert_eq(env, "asdf", "545");
+       //assert_eq(env, "notyetdefined", "nil"); // it's fine don't worry, just suppressing a message
+       assert_eq(env, "- 100 20", "* 10 8");
+       assert_eq(env, "/ 100 19", "% 13 8");
+
+       printf("combinators\n");
+       assert_eq(env, "I + 4 5", "9");
+       assert_eq(env, "S + (+ 4) 3", "10");
+       assert_eq(env, "K 5 6", "5");
+       assert_eq(env, "K I 5 6", "6");
+       assert_eq(env, "S K I 5", "5");
+       assert_eq(env, "K S (I (S K S I)) + (+ 4) 3", "10");
+       assert_eq(env, "B car cdr (quote (1 2 3))", "quote 2"); // PROBLEM
+       assert_eq(env, "C - 3 10", "7");
+       assert_eq(env, "W * 3", "9");
+       assert_eq(env, "R 5 * 3", "15");
+       assert_eq(env, "t 4 5", "4");
+       assert_eq(env, "nil 4 5", "5");
+       assert_eq(env, "5 (+ 3) 4", "19");
+
+       assert_eq(env, "t (cons 1 2) (cons 2 1)", "(cons 1 2)");
+       assert_eq(env, "(Z (B B S (C (eq 0) 1) (B B S * (C B (C - 1)))) 6)", "720");
+
+
+       printf("strings\n");
+       assert_eq(env, "strlen \"hi\"", "2");
+       assert_eq(env, "strcat \"hi \" \"there\"", "\"hi there\"");
+       assert_eq(env, "strat 5 \"hello world\"", "\"o\"");
+       assert_eq(env, "strexpand \"test\"", "list \"t\" \"e\" \"s\" \"t\"");
+       assert_eq(env, "substr \"oo\" \"looopy", "list 2 3");
+       assert_eq(env, "strtok \" /\" \"this is/a test\"", "list \"this\" \"is\" \"a\" \"test\"");
+
+       printf("meta\n");
+       assert_eq(env, "utob 512", "+");
+       assert_eq(env, "btou +", "512");
+       assert_eq(env, "parse \"cons 4 5\"", "quote (cons 4 5)"); // PROBLEM
+       assert_eq(env, "getargs +", "B car list nil"); // PROBLEM
+       assert_eq(env, "getargs (+ 5)", "list 5");
+
+       printf("with demos\n");
+       assert_eq(env, "fac 5", "120");
+       assert_eq(env, "range 5", "list 1 2 3 4 5");
+       assert_eq(env, "reverse (range 3)", "(list 3 2 1)");
+       assert_eq(env, "nth 5 (range 10)", "5");
+       assert_eq(env, "len (range 10)", "10");
+       assert_eq(env, "map (+ 4) (range 10)", "(list 5 6 7 8 9 10 11 12 13 14)");
+       assert_eq(env, "fold + (range 10)", "55");
+       assert_eq(env, "", "");
+       assert_eq(env, "", "");
+       assert_eq(env, "", "");
+       assert_eq(env, "", "");
+
+       
 
+       
        sexpr_free(env);
 }
 
@@ -457,7 +534,7 @@ void isolating_problem() {
 void run_tests(){
        //isolating_problem();
        //test_string_parsing();
-       eval_tests();
+       //eval_tests();
        many_asserts();
        //memtest_eval();
        //mem_testing();