From 31e9a82704455dd92cfeef878456493c47cac63b Mon Sep 17 00:00:00 2001 From: Felix Perktold Date: Sun, 18 Jan 2026 18:39:19 +0100 Subject: factor out basic standard procedures (+, -, cons, car...) into separate module --- Makefile | 5 +- lisp.c | 155 ------------------------------------------- lisp.h | 13 ---- lisp_api.h | 2 + main.c | 13 +--- modules/std_lib.c | 193 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ test.c | 73 ++++++++++++++------- 7 files changed, 250 insertions(+), 204 deletions(-) create mode 100644 modules/std_lib.c diff --git a/Makefile b/Makefile index ad69623..3b7dee5 100644 --- a/Makefile +++ b/Makefile @@ -8,9 +8,10 @@ OBJS = lisp.o lisp.tab.o lex.yy.o MODULE_LIBS = -lpq MODULE_SRC = $(wildcard modules/*.c) MODULE_SO = $(MODULE_SRC:.c=.so) +STD_MODULES = modules/std_lib.so .SUFFIXES: -main: main.c $(OBJS) +main: main.c $(OBJS) $(STD_MODULES) $(CC) $(CFLAGS) -o $@ main.c $(OBJS) $(LIBS) lisp.o: lisp.c lisp_api.h lisp.h lex.yy.o @@ -31,7 +32,7 @@ lex.yy.o: lex.yy.c clean: rm -f *.o main test lisp.tab.c lisp.tab.h lex.yy.c lex.yy.h modules/*.so -test: test.o $(OBJS) +test: test.o $(OBJS) $(STD_MODULES) $(CC) $(CFLAGS) -o $@ test.o $(OBJS) $(LIBS) ./test diff --git a/lisp.c b/lisp.c index 88ff472..e1f09dd 100644 --- a/lisp.c +++ b/lisp.c @@ -334,161 +334,6 @@ value *apply(value *lval, value *args) { return make_lambda(sub_env, params, lval->as.lambda.body); } -value *procedure_cons(env *e, value *args) { - value *v = eval(e, car(args)); - return cons(v, eval(e, car(cdr(args)))); -} - -value *procedure_car(env *e, value *args) { - return car(eval(e, car(args))); -} - -value *procedure_cdr(env *e, value *args) { - return cdr(eval(e, car(args))); -} - -value *procedure_reverse(env *e, value *args) { - return reverse(eval(e, car(args))); -} - -value *procedure_isnull(env *e, value *args) { - value *v = eval(e, car(args)); - if(v->type == VT_NIL) { - return make_int(1); - } - return make_nil(); -} - -int value_eq(value *a, value *b) { - if(a->type != b->type){ - return 0; - } - if(a == b){ - return 1; - } - switch (a->type) { - case VT_INT: return a->as.i == b->as.i; - case VT_DOUBLE: return a->as.d == b->as.d; - case VT_SYMBOL: return !strcmp(a->as.sym, b->as.sym); - case VT_STRING: return !strcmp(a->as.sym, b->as.sym); - case VT_NIL: return 1; - case VT_PAIR: - return value_eq(car(a), car(b)) && - value_eq(cdr(a), cdr(b)); - case VT_LAMBDA: - case VT_PROCEDURE: - default: - return 0; - } - return 1; -} - -value *procedure_equal(env *e, value *args) { - value *v_prev = eval(e, car(args)); - - args = cdr(args); - while (args->type == VT_PAIR) { - value *v_cur = eval(e, car(args)); - if (!value_eq(v_prev, v_cur)) { - return make_nil(); - } - v_prev = v_cur; - args = cdr(args); - } - - return make_int(1); -} - -value *apply_to_nums(env *e, value *args, double (*fn)(double, double)) { - double result; - value *v = eval(e, car(args)); - if (v->type == VT_INT) { - result = v->as.i; - } else if (v->type == VT_DOUBLE) { - result = v->as.d; - } else { - printf("not a number: "); - println_value(v); - return make_nil(); - } - - args = cdr(args); - while (args->type == VT_PAIR) { - v = eval(e, car(args)); - if (v->type == VT_INT) { - result = fn(result, v->as.i); - } else if (v->type == VT_DOUBLE) { - result = fn(result, v->as.d); - } else { - printf("not a number: "); - println_value(v); - return make_nil(); - } - args = cdr(args); - } - - if(is_integer(result)){ - return make_int((int) result); - } - return make_double(result); -} - -double add_fn(double x, double y) { return x+y; } -value *procedure_add(env *e, value *args) { - return apply_to_nums(e, args, add_fn); -} - -double sub_fn(double x, double y) { return x-y; } -value *procedure_sub(env *e, value *args) { - return apply_to_nums(e, args, sub_fn); -} - -double mul_fn(double x, double y) { return x*y; } -value *procedure_mul(env *e, value *args) { - return apply_to_nums(e, args, mul_fn); -} - -double div_fn(double x, double y) { return x/y; } -value *procedure_div(env *e, value *args) { - return apply_to_nums(e, args, div_fn); -} - -value *procedure_lt(env *e, value *args) { - double prev_num; - value *v = eval(e, car(args)); - - if (v->type == VT_INT) { - prev_num = v->as.i; - } else if (v->type == VT_DOUBLE) { - prev_num = v->as.d; - } else { - printf("not a number: "); - println_value(v); - return make_nil(); - } - - args = cdr(args); - while (args->type == VT_PAIR) { - v = eval(e, car(args)); - double cur_num; - if (v->type == VT_INT) { - cur_num = v->as.i; - } else if (v->type == VT_DOUBLE) { - cur_num = v->as.d; - } else { - printf("not a number: "); - println_value(v); - return make_nil(); - } - if(prev_num >= cur_num) { - return make_nil(); - } - prev_num = cur_num; - args = cdr(args); - } - return make_int(1); -} - value *procedure_load_module(env *e, value *args) { value *fst_arg = eval(e, car(args)); diff --git a/lisp.h b/lisp.h index ef4505a..a747b8d 100644 --- a/lisp.h +++ b/lisp.h @@ -23,19 +23,6 @@ value *eval_pair(env *e, value *val); value *apply(value *lambda, value *args); -value *procedure_cons(env *e, value *args); -value *procedure_car(env *e, value *args); -value *procedure_cdr(env *e, value *args); -value *procedure_reverse(env *e, value *args); -value *procedure_isnull(env *e, value *args); -value *procedure_equal(env *e, value *args); -value *procedure_add(env *e, value *args); -value *procedure_sub(env *e, value *args); -value *procedure_mul(env *e, value *args); -value *procedure_div(env *e, value *args); -value *procedure_lt(env *e, value *args); value *procedure_load_module(env *e, value *args); -int is_integer(double x); - #endif diff --git a/lisp_api.h b/lisp_api.h index 66ad231..6cc6588 100644 --- a/lisp_api.h +++ b/lisp_api.h @@ -61,4 +61,6 @@ typedef struct { module_export *module_init(); +int is_integer(double x); + #endif diff --git a/main.c b/main.c index 86aa69d..84d585c 100644 --- a/main.c +++ b/main.c @@ -94,19 +94,8 @@ void init_readline() { int main(int argc, char **argv) { // init global env global_env = env_create(NULL); - env_define(global_env, "cons", make_procedure(procedure_cons)); - env_define(global_env, "car", make_procedure(procedure_car)); - env_define(global_env, "cdr", make_procedure(procedure_cdr)); - env_define(global_env, "reverse", make_procedure(procedure_reverse)); - env_define(global_env, "null?", make_procedure(procedure_isnull)); - env_define(global_env, "equal?", make_procedure(procedure_equal)); - env_define(global_env, "+", make_procedure(procedure_add)); - env_define(global_env, "-", make_procedure(procedure_sub)); - env_define(global_env, "*", make_procedure(procedure_mul)); - env_define(global_env, "/", make_procedure(procedure_div)); - env_define(global_env, "<", make_procedure(procedure_lt)); - env_define(global_env, "load_module", make_procedure(procedure_load_module)); + procedure_load_module(global_env, cons(make_string("modules/std_lib.so"), make_nil())); // evaluate files for(int i = 1; i < argc; i++) { diff --git a/modules/std_lib.c b/modules/std_lib.c new file mode 100644 index 0000000..7964422 --- /dev/null +++ b/modules/std_lib.c @@ -0,0 +1,193 @@ +#include +#include +#include +#include "../lisp_api.h" + +value *procedure_cons(env *e, value *args) { + value *v = eval(e, car(args)); + return cons(v, eval(e, car(cdr(args)))); +} + +value *procedure_car(env *e, value *args) { + return car(eval(e, car(args))); +} + +value *procedure_cdr(env *e, value *args) { + return cdr(eval(e, car(args))); +} + +value *procedure_reverse(env *e, value *args) { + return reverse(eval(e, car(args))); +} + +value *procedure_isnull(env *e, value *args) { + value *v = eval(e, car(args)); + if(v->type == VT_NIL) { + return make_int(1); + } + return make_nil(); +} + +int value_eq(value *a, value *b) { + if(a->type != b->type){ + return 0; + } + if(a == b){ + return 1; + } + switch (a->type) { + case VT_INT: return a->as.i == b->as.i; + case VT_DOUBLE: return a->as.d == b->as.d; + case VT_SYMBOL: return !strcmp(a->as.sym, b->as.sym); + case VT_STRING: return !strcmp(a->as.sym, b->as.sym); + case VT_NIL: return 1; + case VT_PAIR: + return value_eq(car(a), car(b)) && + value_eq(cdr(a), cdr(b)); + case VT_LAMBDA: + case VT_PROCEDURE: + default: + return 0; + } + return 1; +} + +value *procedure_equal(env *e, value *args) { + value *v_prev = eval(e, car(args)); + + args = cdr(args); + while (args->type == VT_PAIR) { + value *v_cur = eval(e, car(args)); + if (!value_eq(v_prev, v_cur)) { + return make_nil(); + } + v_prev = v_cur; + args = cdr(args); + } + + return make_int(1); +} + +value *apply_to_nums(env *e, value *args, double (*fn)(double, double)) { + double result; + value *v = eval(e, car(args)); + if (v->type == VT_INT) { + result = v->as.i; + } else if (v->type == VT_DOUBLE) { + result = v->as.d; + } else { + printf("not a number: "); + println_value(v); + return make_nil(); + } + + args = cdr(args); + while (args->type == VT_PAIR) { + v = eval(e, car(args)); + if (v->type == VT_INT) { + result = fn(result, v->as.i); + } else if (v->type == VT_DOUBLE) { + result = fn(result, v->as.d); + } else { + printf("not a number: "); + println_value(v); + return make_nil(); + } + args = cdr(args); + } + + if(is_integer(result)){ + return make_int((int) result); + } + return make_double(result); +} + +double add_fn(double x, double y) { return x+y; } +value *procedure_add(env *e, value *args) { + return apply_to_nums(e, args, add_fn); +} + +double sub_fn(double x, double y) { return x-y; } +value *procedure_sub(env *e, value *args) { + return apply_to_nums(e, args, sub_fn); +} + +double mul_fn(double x, double y) { return x*y; } +value *procedure_mul(env *e, value *args) { + return apply_to_nums(e, args, mul_fn); +} + +double div_fn(double x, double y) { return x/y; } +value *procedure_div(env *e, value *args) { + return apply_to_nums(e, args, div_fn); +} + +value *procedure_lt(env *e, value *args) { + double prev_num; + value *v = eval(e, car(args)); + + if (v->type == VT_INT) { + prev_num = v->as.i; + } else if (v->type == VT_DOUBLE) { + prev_num = v->as.d; + } else { + printf("not a number: "); + println_value(v); + return make_nil(); + } + + args = cdr(args); + while (args->type == VT_PAIR) { + v = eval(e, car(args)); + double cur_num; + if (v->type == VT_INT) { + cur_num = v->as.i; + } else if (v->type == VT_DOUBLE) { + cur_num = v->as.d; + } else { + printf("not a number: "); + println_value(v); + return make_nil(); + } + if(prev_num >= cur_num) { + return make_nil(); + } + prev_num = cur_num; + args = cdr(args); + } + return make_int(1); +} + +module_export *module_init() { + //exports[i].name = "xxx" + //exports[i].v = make_procedure(xxx); + static module_export exports[12]; + + exports[0].name = "cons"; + exports[0].v = make_procedure(procedure_cons); + exports[1].name = "car"; + exports[1].v = make_procedure(procedure_car); + exports[2].name = "cdr"; + exports[2].v = make_procedure(procedure_cdr); + exports[3].name = "reverse"; + exports[3].v = make_procedure(procedure_reverse); + exports[4].name = "null?"; + exports[4].v = make_procedure(procedure_isnull); + exports[5].name = "equal?"; + exports[5].v = make_procedure(procedure_equal); + exports[6].name = "+"; + exports[6].v = make_procedure(procedure_add); + exports[7].name = "-"; + exports[7].v = make_procedure(procedure_sub); + exports[8].name = "*"; + exports[8].v = make_procedure(procedure_mul); + exports[9].name = "/"; + exports[9].v = make_procedure(procedure_div); + exports[10].name = "<"; + exports[10].v = make_procedure(procedure_lt); + + exports[11].name = NULL; + exports[11].v = NULL; + + return exports; +} diff --git a/test.c b/test.c index 4360bef..95f8666 100644 --- a/test.c +++ b/test.c @@ -120,7 +120,8 @@ void test_lambda_add() { env *e = env_create(NULL); // install + - env_define(e, "+", make_procedure(procedure_add)); + procedure_load_module(e, cons(make_string("modules/std_lib.so"), make_nil())); + value *expr = cons( @@ -148,7 +149,7 @@ void test_lambda_add() { void test_lambda_multiple_args() { env *e = env_create(NULL); - env_define(e, "+", make_procedure(procedure_add)); + procedure_load_module(e, cons(make_string("modules/std_lib.so"), make_nil())); value *expr = cons( @@ -184,7 +185,8 @@ void test_lambda_closure() { //((lambda (y) (+ x y)) 5) env *e = env_create(NULL); - env_define(e, "+", make_procedure(procedure_add)); + procedure_load_module(e, cons(make_string("modules/std_lib.so"), make_nil())); + env_define(e, "x", make_int(10)); value *expr = @@ -213,7 +215,7 @@ void test_lambda_closure() { void test_nested_lambdas() { // (((lambda (x) (lambda (y) (+ x y))) 3) 4) env *e = env_create(NULL); - env_define(e, "+", make_procedure(procedure_add)); + procedure_load_module(e, cons(make_string("modules/std_lib.so"), make_nil())); value *expr = cons( @@ -274,10 +276,7 @@ void test_lambda_does_not_modify_outer_env() { void test_recursive_factorial() { env *e = env_create(NULL); - env_define(e, "+", make_procedure(procedure_add)); - env_define(e, "-", make_procedure(procedure_sub)); - env_define(e, "*", make_procedure(procedure_mul)); - env_define(e, "<", make_procedure(procedure_lt)); + procedure_load_module(e, cons(make_string("modules/std_lib.so"), make_nil())); /* (define fact @@ -349,10 +348,11 @@ void test_recursive_factorial() { void test_eq_ints() { env *e = env_create(NULL); - env_define(e, "eq", make_procedure(procedure_equal)); + procedure_load_module(e, cons(make_string("modules/std_lib.so"), make_nil())); + value *expr = - cons(make_symbol("eq"), + cons(make_symbol("equal?"), cons(make_int(3), cons(make_int(3), make_nil()) ) @@ -366,10 +366,11 @@ void test_eq_ints() { void test_eq_ints_false() { env *e = env_create(NULL); - env_define(e, "eq", make_procedure(procedure_equal)); + procedure_load_module(e, cons(make_string("modules/std_lib.so"), make_nil())); + value *expr = - cons(make_symbol("eq"), + cons(make_symbol("equal?"), cons(make_int(3), cons(make_int(4), make_nil()) ) @@ -381,10 +382,11 @@ void test_eq_ints_false() { void test_eq_symbols() { env *e = env_create(NULL); - env_define(e, "eq", make_procedure(procedure_equal)); + procedure_load_module(e, cons(make_string("modules/std_lib.so"), make_nil())); + value *expr = - cons(make_symbol("eq"), + cons(make_symbol("equal?"), cons(make_symbol("foo"), cons(make_symbol("foo"), make_nil()) ) @@ -396,7 +398,8 @@ void test_eq_symbols() { void test_eq_lists() { env *e = env_create(NULL); - env_define(e, "eq", make_procedure(procedure_equal)); + procedure_load_module(e, cons(make_string("modules/std_lib.so"), make_nil())); + value *list1 = cons(make_int(1), @@ -409,7 +412,7 @@ void test_eq_lists() { ); value *expr = - cons(make_symbol("eq"), + cons(make_symbol("equal?"), cons(list1, cons(list2, make_nil()) ) @@ -421,7 +424,8 @@ void test_eq_lists() { void test_null_true() { env *e = env_create(NULL); - env_define(e, "null?", make_procedure(procedure_isnull)); + procedure_load_module(e, cons(make_string("modules/std_lib.so"), make_nil())); + value *expr = cons(make_symbol("null?"), @@ -434,7 +438,8 @@ void test_null_true() { void test_null_false() { env *e = env_create(NULL); - env_define(e, "null?", make_procedure(procedure_isnull)); + procedure_load_module(e, cons(make_string("modules/std_lib.so"), make_nil())); + value *expr = cons(make_symbol("null?"), @@ -450,7 +455,7 @@ void test_null_false() { void test_if_true() { env *e = env_create(NULL); - env_define(e, "<", make_procedure(procedure_lt)); + procedure_load_module(e, cons(make_string("modules/std_lib.so"), make_nil())); value *expr = cons(make_symbol("if"), @@ -503,7 +508,7 @@ void test_if_short_circuit() { void test_add_multiple_args() { env *e = env_create(NULL); - env_define(e, "+", make_procedure(procedure_add)); + procedure_load_module(e, cons(make_string("modules/std_lib.so"), make_nil())); value *expr = cons(make_symbol("+"), @@ -520,7 +525,7 @@ void test_add_multiple_args() { void test_lt_chain() { env *e = env_create(NULL); - env_define(e, "<", make_procedure(procedure_lt)); + procedure_load_module(e, cons(make_string("modules/std_lib.so"), make_nil())); value *expr = cons(make_symbol("<"), @@ -536,33 +541,57 @@ void test_lt_chain() { } int main(void) { + printf("lol 1\n"); test_make_int(); + printf("lol 2\n"); test_cons_car_cdr(); + printf("lol 3\n"); test_env_define_lookup(); + printf("lol 4\n"); test_env_parent_lookup(); + printf("lol 5\n"); test_eval_literal(); + printf("lol 6\n"); test_eval_symbol(); + printf("lol 7\n"); test_define(); + printf("lol 8\n"); test_lambda_identity(); + printf("lol 9\n"); test_lambda_add(); + printf("lol 10\n"); test_lambda_multiple_args(); + printf("lol 11\n"); test_lambda_closure(); + printf("lol 12\n"); test_nested_lambdas(); + printf("lol 13\n"); test_lambda_does_not_modify_outer_env(); + printf("lol 14\n"); test_recursive_factorial(); + printf("lol 15\n"); test_eq_ints(); + printf("lol 16\n"); test_eq_ints_false(); + printf("lol 17\n"); test_eq_symbols(); + printf("lol 18\n"); test_eq_lists(); + printf("lol 19\n"); test_null_true(); + printf("lol 20\n"); test_null_false(); + printf("lol 21\n"); test_if_true(); + printf("lol 22\n"); test_if_false(); + printf("lol 23\n"); test_if_short_circuit(); + printf("lol 24\n"); test_add_multiple_args(); + printf("lol 25\n"); test_lt_chain(); - printf("\nTests run: %d\n", tests_run); printf("Tests failed: %d\n", tests_failed); -- cgit v1.2.3