diff options
Diffstat (limited to 'modules')
| -rw-r--r-- | modules/std_lib.c | 193 |
1 files changed, 193 insertions, 0 deletions
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 <stddef.h> +#include <stdio.h> +#include <string.h> +#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; +} |