From ed1f406102738812fafa5e49ee131fe06c177687 Mon Sep 17 00:00:00 2001 From: Bad Diode Date: Wed, 13 Oct 2021 16:44:17 +0200 Subject: Add a lot of primitive types --- examples/booleans.bdl | 4 +- examples/lists.bdl | 2 +- examples/types.bdl | 21 +- src/bootstrap/errors.c | 2 + src/bootstrap/main.c | 57 ++- src/bootstrap/objects.c | 103 ----- src/bootstrap/primitives.c | 900 ++++++++++++++++++++++++++++++++++++++++++++ tests/booleans_expected.txt | 4 +- tests/lists_expected.txt | 2 +- tests/types_expected.txt | 18 +- 10 files changed, 974 insertions(+), 139 deletions(-) create mode 100644 src/bootstrap/primitives.c diff --git a/examples/booleans.bdl b/examples/booleans.bdl index e38fb1f..0598450 100644 --- a/examples/booleans.bdl +++ b/examples/booleans.bdl @@ -44,7 +44,7 @@ (print "(if (or false false) (+ 1 2 3) (+ 7 8 9)) -> ") (if (or false false) (+ 1 2 3) (+ 7 8 9)) (print "(if (or (+ 1 2 3) false) (+ 1 2 3) (+ 7 8 9)) -> ") (if (or (+ 1 2 3) false) (+ 1 2 3) (+ 7 8 9)) (print "(if true 7) -> ") (if true 7) -(print "(if false 7) -> ") (if false 7) +(print "(if false 7) -> ") (if false 7) (newline) ;; Cond. (print "(cond ((and true true true) 1) ((or true true false) 2) (else 3)) -> ") @@ -61,7 +61,7 @@ (else 3)) (print "(cond ((and true true true) 1) ((or true true false) 2)) -> ") (cond ((and true true false) 1) - ((or false false false) 2)) + ((or false false false) 2)) (newline) (print "(cond ((and true true true) (+ 1 2 3)) ((or true true false) 2) (else 3)) -> ") (cond ((and true true true) (+ 1 2 3)) ((or true true false) 2) diff --git a/examples/lists.bdl b/examples/lists.bdl index 4a27005..36063d6 100644 --- a/examples/lists.bdl +++ b/examples/lists.bdl @@ -3,7 +3,7 @@ ;; ;; List function. -(print "(list) -> ") (list) +(print "(list) -> ") (list) (newline) (print "(list 1) -> ") (list 1) (print "(list 1 2) -> ") (list 1 2) (print "(list 1 2 3) -> ") (list 1 2 3) diff --git a/examples/types.bdl b/examples/types.bdl index 43b7be9..36dab7a 100644 --- a/examples/types.bdl +++ b/examples/types.bdl @@ -12,14 +12,14 @@ (print "(boolean? (not 1)) -> ") (boolean? (not 1)) ;; Empty list/null. -(print "(null? true) -> ") (null? true) -(print "(null? false) -> ") (null? false) -(print "(null? 1) -> ") (null? 1) -(print "(null? 5) -> ") (null? 5) -(print "(null? \"string\") -> ") (null? "string") -(print "(null? (+ 1 2 3)) -> ") (null? (+ 1 2 3)) -(print "(null? (not 1)) -> ") (null? (not 1)) -(print "(null? ()) -> ") (null? ()) +(print "(nil? true) -> ") (nil? true) +(print "(nil? false) -> ") (nil? false) +(print "(nil? 1) -> ") (nil? 1) +(print "(nil? 5) -> ") (nil? 5) +(print "(nil? \"string\") -> ") (nil? "string") +(print "(nil? (+ 1 2 3)) -> ") (nil? (+ 1 2 3)) +(print "(nil? (not 1)) -> ") (nil? (not 1)) +(print "(nil? ()) -> ") (nil? ()) ;; String. (print "(string? true) -> ") (string? true) @@ -40,7 +40,6 @@ (print "(fixnum? (not 1)) -> ") (fixnum? (not 1)) ;; Symbol -;; TODO: We need quotation to test for symbols. (print "(symbol? true) -> ") (symbol? true) (print "(symbol? false) -> ") (symbol? false) (print "(symbol? 1) -> ") (symbol? 1) @@ -48,8 +47,8 @@ (print "(symbol? \"string\") -> ") (symbol? "string") (print "(symbol? (+ 1 2 3)) -> ") (symbol? (+ 1 2 3)) (print "(symbol? (not 1)) -> ") (symbol? (not 1)) -; (print "(symbol? 'a) -> ") (symbol? 'a) -; (print "(symbol? 'c) -> ") (symbol? 'c) +(print "(symbol? 'a) -> ") (symbol? 'a) +(print "(symbol? 'c) -> ") (symbol? 'c) ;; Pair. (print "(pair? false) -> ") (pair? false) diff --git a/src/bootstrap/errors.c b/src/bootstrap/errors.c index c9d9c97..13a2f3c 100644 --- a/src/bootstrap/errors.c +++ b/src/bootstrap/errors.c @@ -17,6 +17,7 @@ typedef enum ErrorValue { ERR_OBJ_NOT_CALLABLE, ERR_NOT_ENOUGH_ARGS, ERR_WRONG_ARG_TYPE, + ERR_DIVISION_BY_ZERO, } ErrorValue; typedef struct Error { @@ -39,6 +40,7 @@ static const char* error_msgs[] = { [ERR_OBJ_NOT_CALLABLE] = "error: object is not callable", [ERR_NOT_ENOUGH_ARGS] = "error: not enough arguments", [ERR_WRONG_ARG_TYPE] = "error: wrong argument type", + [ERR_DIVISION_BY_ZERO] = "error: division by zero", }; #define ERR_MAX_NUMBER 16 diff --git a/src/bootstrap/main.c b/src/bootstrap/main.c index 2aa3038..8092bbd 100755 --- a/src/bootstrap/main.c +++ b/src/bootstrap/main.c @@ -11,8 +11,14 @@ #include "lexer.c" #include "objects.c" #include "parser.c" +#include "environment.c" +#include "primitives.c" #define MAKE_SYM(STR) make_symbol((StringView){(STR), sizeof(STR) - 1}) +#define MAKE_ENV_VAR(ENV,STR,VAR) \ + (env_add_symbol((ENV), MAKE_SYM(STR), (VAR))) +#define MAKE_ENV_PROC(ENV,STR,FUN) \ + (env_add_symbol((ENV), MAKE_SYM(STR), make_procedure(FUN))) void init(void) { @@ -24,8 +30,42 @@ init(void) { // Global environment. global_env = env_create(NULL); - env_add_symbol(global_env, MAKE_SYM("quote"), make_procedure(proc_quote)); - env_add_symbol(global_env, MAKE_SYM("+"), make_procedure(proc_sum)); + + // Primitive symbols. + MAKE_ENV_VAR(global_env, "else", obj_true); + MAKE_ENV_VAR(global_env, "nil", obj_nil); + + // Primitive procedures. + MAKE_ENV_PROC(global_env, "quote", proc_quote); + MAKE_ENV_PROC(global_env, "car", proc_car); + MAKE_ENV_PROC(global_env, "cdr", proc_cdr); + MAKE_ENV_PROC(global_env, "cons", proc_cons); + MAKE_ENV_PROC(global_env, "list", proc_list); + MAKE_ENV_PROC(global_env, "+", proc_sum); + MAKE_ENV_PROC(global_env, "-", proc_sub); + MAKE_ENV_PROC(global_env, "*", proc_mul); + MAKE_ENV_PROC(global_env, "/", proc_div); + MAKE_ENV_PROC(global_env, "%", proc_mod); + MAKE_ENV_PROC(global_env, "print", proc_print); + MAKE_ENV_PROC(global_env, "display", proc_display); + MAKE_ENV_PROC(global_env, "newline", proc_newline); + MAKE_ENV_PROC(global_env, "boolean?", proc_is_boolean); + MAKE_ENV_PROC(global_env, "nil?", proc_is_nil); + MAKE_ENV_PROC(global_env, "symbol?", proc_is_symbol); + MAKE_ENV_PROC(global_env, "string?", proc_is_string); + MAKE_ENV_PROC(global_env, "fixnum?", proc_is_fixnum); + MAKE_ENV_PROC(global_env, "pair?", proc_is_pair); + MAKE_ENV_PROC(global_env, "procedure?", proc_is_procedure); + MAKE_ENV_PROC(global_env, "not", proc_not); + MAKE_ENV_PROC(global_env, "and", proc_and); + MAKE_ENV_PROC(global_env, "or", proc_or); + MAKE_ENV_PROC(global_env, "if", proc_if); + MAKE_ENV_PROC(global_env, "cond", proc_cond); + MAKE_ENV_PROC(global_env, "<", proc_num_less_than); + MAKE_ENV_PROC(global_env, "<=", proc_num_lesseq_than); + MAKE_ENV_PROC(global_env, ">", proc_num_greater_than); + MAKE_ENV_PROC(global_env, ">=", proc_num_greatereq_than); + MAKE_ENV_PROC(global_env, "=", proc_num_equal); } void @@ -51,12 +91,10 @@ process_source(const StringView *source) { // FIXME: Not freeing result or intermediate objects, can leak memory. Object *result = eval(global_env, root); - printf("AST: "); - display(root); - printf("\n"); - printf("EVAL: "); - display(result); - printf("\n"); + if (result != obj_nil) { + display(result); + printf("\n"); + } free_objects(root); } @@ -94,9 +132,6 @@ run_repl(void) { errors_n = 0; continue; } - if (sv.n != 0) { - printf("\n"); - } } } diff --git a/src/bootstrap/objects.c b/src/bootstrap/objects.c index 30827f1..0361ae8 100644 --- a/src/bootstrap/objects.c +++ b/src/bootstrap/objects.c @@ -197,106 +197,3 @@ display(Object *root) { } return; } - -#include "environment.c" - -Object * -eval(Environment* env, Object *root) { - switch (root->type) { - case OBJ_TYPE_FIXNUM: - case OBJ_TYPE_BOOL: - case OBJ_TYPE_NIL: - case OBJ_TYPE_STRING: { - return root; - } break; - case OBJ_TYPE_SYMBOL: { - Object *val = env_lookup(env, root); - if (val == obj_err) { - error_push((Error){ - .type = ERR_TYPE_RUNTIME, - .value = ERR_SYMBOL_NOT_FOUND, - }); - return obj_err; - } - return val; - } break; - case OBJ_TYPE_PAIR: { - if (root->car->type == OBJ_TYPE_SYMBOL) { - Object *val = env_lookup(env, root->car); - if (val == obj_err) { - error_push((Error){ - .type = ERR_TYPE_RUNTIME, - .value = ERR_SYMBOL_NOT_FOUND, - }); - return obj_err; - } - if (val->type == OBJ_TYPE_PROCEDURE) { - return val->proc(env, root->cdr); - } - error_push((Error){ - .type = ERR_TYPE_RUNTIME, - .value = ERR_OBJ_NOT_CALLABLE, - }); - return obj_err; - } - } break; - default: { - break; - } break; - } - - error_push((Error){ - .type = ERR_TYPE_RUNTIME, - .value = ERR_UNKNOWN_OBJ_TYPE, - }); - return obj_err; -} - -Object * -proc_quote(Environment *env, Object *obj) { - (void)env; - return obj->car; -} - -Object * -proc_sum(Environment *env, Object *obj) { - // First argument. - if (obj == obj_nil) { - error_push((Error){ - .type = ERR_TYPE_RUNTIME, - .value = ERR_NOT_ENOUGH_ARGS, - }); - return obj_err; - } - Object *car = eval(env, obj->car); - if (car == obj_err) { - return obj_err; - } - if (car->type != OBJ_TYPE_FIXNUM) { - error_push((Error){ - .type = ERR_TYPE_RUNTIME, - .value = ERR_WRONG_ARG_TYPE, - }); - return obj_err; - } - - // Traverse the list. - obj = obj->cdr; - ssize_t tot = car->fixnum; - while (obj->type == OBJ_TYPE_PAIR) { - Object *car = eval(env, obj->car); - if (car == obj_err) { - return obj_err; - } - if (car->type != OBJ_TYPE_FIXNUM) { - error_push((Error){ - .type = ERR_TYPE_RUNTIME, - .value = ERR_WRONG_ARG_TYPE, - }); - return obj_err; - } - tot += car->fixnum; - obj = obj->cdr; - } - return make_fixnum(tot); -} diff --git a/src/bootstrap/primitives.c b/src/bootstrap/primitives.c new file mode 100644 index 0000000..8369fa8 --- /dev/null +++ b/src/bootstrap/primitives.c @@ -0,0 +1,900 @@ +Object * +eval(Environment* env, Object *root) { + switch (root->type) { + case OBJ_TYPE_FIXNUM: + case OBJ_TYPE_BOOL: + case OBJ_TYPE_NIL: + case OBJ_TYPE_STRING: { + return root; + } break; + case OBJ_TYPE_SYMBOL: { + Object *val = env_lookup(env, root); + if (val == obj_err) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_SYMBOL_NOT_FOUND, + }); + return obj_err; + } + return val; + } break; + case OBJ_TYPE_PAIR: { + if (root->car->type == OBJ_TYPE_SYMBOL) { + Object *val = env_lookup(env, root->car); + if (val == obj_err) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_SYMBOL_NOT_FOUND, + }); + return obj_err; + } + if (val->type == OBJ_TYPE_PROCEDURE) { + return val->proc(env, root->cdr); + } + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_OBJ_NOT_CALLABLE, + }); + return obj_err; + } + } break; + default: { + break; + } break; + } + + printf("DING\n"); + display(root); + printf("\nTYPE: %d\n", root->type); + + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_UNKNOWN_OBJ_TYPE, + }); + return obj_err; +} + +Object * +proc_quote(Environment *env, Object *obj) { + (void)env; + return obj->car; +} + +// +// Arithmetic procedures. +// + +Object * +proc_sum(Environment *env, Object *obj) { + // First argument. + if (obj == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + Object *car = eval(env, obj->car); + if (car == obj_err) { + return obj_err; + } + if (car->type != OBJ_TYPE_FIXNUM) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_WRONG_ARG_TYPE, + }); + return obj_err; + } + + // Traverse the list. + obj = obj->cdr; + ssize_t tot = car->fixnum; + while (obj != obj_nil) { + car = eval(env, obj->car); + if (car == obj_err) { + return obj_err; + } + if (car->type != OBJ_TYPE_FIXNUM) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_WRONG_ARG_TYPE, + }); + return obj_err; + } + tot += car->fixnum; + obj = obj->cdr; + } + return make_fixnum(tot); +} + +Object * +proc_sub(Environment *env, Object *obj) { + // First argument. + if (obj == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + Object *car = eval(env, obj->car); + if (car == obj_err) { + return obj_err; + } + if (car->type != OBJ_TYPE_FIXNUM) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_WRONG_ARG_TYPE, + }); + return obj_err; + } + + // Traverse the list. + obj = obj->cdr; + ssize_t tot = car->fixnum; + while (obj != obj_nil) { + car = eval(env, obj->car); + if (car == obj_err) { + return obj_err; + } + if (car->type != OBJ_TYPE_FIXNUM) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_WRONG_ARG_TYPE, + }); + return obj_err; + } + tot -= car->fixnum; + obj = obj->cdr; + } + return make_fixnum(tot); +} + +Object * +proc_mul(Environment *env, Object *obj) { + // First argument. + if (obj == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + Object *car = eval(env, obj->car); + if (car == obj_err) { + return obj_err; + } + if (car->type != OBJ_TYPE_FIXNUM) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_WRONG_ARG_TYPE, + }); + return obj_err; + } + + // Traverse the list. + obj = obj->cdr; + ssize_t tot = car->fixnum; + while (obj != obj_nil) { + Object *car = eval(env, obj->car); + if (car == obj_err) { + return obj_err; + } + if (car->type != OBJ_TYPE_FIXNUM) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_WRONG_ARG_TYPE, + }); + return obj_err; + } + tot *= car->fixnum; + obj = obj->cdr; + } + return make_fixnum(tot); +} + +Object * +proc_div(Environment *env, Object *obj) { + // First argument. + if (obj == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + Object *car = eval(env, obj->car); + if (car == obj_err) { + return obj_err; + } + if (car->type != OBJ_TYPE_FIXNUM) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_WRONG_ARG_TYPE, + }); + return obj_err; + } + + // Traverse the list. + obj = obj->cdr; + ssize_t tot = car->fixnum; + while (obj != obj_nil) { + Object *car = eval(env, obj->car); + if (car == obj_err) { + return obj_err; + } + if (car->type != OBJ_TYPE_FIXNUM) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_WRONG_ARG_TYPE, + }); + return obj_err; + } + if (car->fixnum == 0) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_DIVISION_BY_ZERO, + }); + return obj_err; + } + tot /= car->fixnum; + obj = obj->cdr; + } + return make_fixnum(tot); +} + +Object * +proc_mod(Environment *env, Object *obj) { + // First argument. + if (obj == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + Object *car = eval(env, obj->car); + if (car == obj_err) { + return obj_err; + } + if (car->type != OBJ_TYPE_FIXNUM) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_WRONG_ARG_TYPE, + }); + return obj_err; + } + + // Traverse the list. + obj = obj->cdr; + ssize_t tot = car->fixnum; + while (obj != obj_nil) { + Object *car = eval(env, obj->car); + if (car == obj_err) { + return obj_err; + } + if (car->type != OBJ_TYPE_FIXNUM) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_WRONG_ARG_TYPE, + }); + return obj_err; + } + if (car->fixnum == 0) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_DIVISION_BY_ZERO, + }); + return obj_err; + } + tot %= car->fixnum; + obj = obj->cdr; + } + return make_fixnum(tot); +} + +// +// Display/Evaluation procedues. +// + +Object * +proc_display(Environment *env, Object *obj) { + display(eval(env, obj->car)); + return obj_nil; +} + +Object * +proc_print(Environment *env, Object *obj) { + if (obj == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + Object *car = eval(env, obj->car); + if (car == obj_err) { + return obj_err; + } + if (car->type != OBJ_TYPE_STRING) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_WRONG_ARG_TYPE, + }); + return obj_err; + } + + StringView scanner = (StringView) { + .start = car->string, + .n = car->string_n, + }; + while (scanner.n != 0) { + char c = sv_next(&scanner); + if (c == '\\' && sv_peek(&scanner) == 'n') { + putchar('\n'); + sv_next(&scanner); + continue; + } + if (c == '\\' && sv_peek(&scanner) == '"') { + putchar('"'); + sv_next(&scanner); + continue; + } + putchar(c); + } + return obj_nil; +} + +Object * +proc_newline(Environment *env, Object *obj) { + printf("\n"); + (void)env; + (void)obj; + return obj_nil; +} + +// +// Type info procedures. +// + +Object * +proc_is_boolean(Environment *env, Object *obj) { + if (obj == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + obj = eval(env, obj->car); + if (obj == obj_err) { + return obj_err; + } + return (obj == obj_true || obj == obj_false) ? obj_true : obj_false; +} + +Object * +proc_is_nil(Environment *env, Object *obj) { + if (obj == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + obj = eval(env, obj->car); + if (obj == obj_err) { + return obj_err; + } + return obj == obj_nil ? obj_true : obj_false; +} + +Object * +proc_is_symbol(Environment *env, Object *obj) { + if (obj == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + obj = eval(env, obj->car); + if (obj == obj_err) { + return obj_err; + } + return obj->type == OBJ_TYPE_SYMBOL ? obj_true : obj_false; +} + +Object * +proc_is_string(Environment *env, Object *obj) { + if (obj == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + obj = eval(env, obj->car); + if (obj == obj_err) { + return obj_err; + } + return obj->type == OBJ_TYPE_STRING ? obj_true : obj_false; +} + +Object * +proc_is_fixnum(Environment *env, Object *obj) { + if (obj == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + obj = eval(env, obj->car); + if (obj == obj_err) { + return obj_err; + } + return obj->type == OBJ_TYPE_FIXNUM ? obj_true : obj_false; +} + +Object * +proc_is_pair(Environment *env, Object *obj) { + if (obj == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + obj = eval(env, obj->car); + if (obj == obj_err) { + return obj_err; + } + return obj->type == OBJ_TYPE_PAIR ? obj_true : obj_false; +} + +Object * +proc_is_procedure(Environment *env, Object *obj) { + if (obj == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + obj = eval(env, obj->car); + if (obj == obj_err) { + return obj_err; + } + return obj->type == OBJ_TYPE_PROCEDURE ? obj_true : obj_false; +} + +// +// Boolean/conditional procedures. +// + +Object * +proc_not(Environment *env, Object *obj) { + if (obj == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + obj = eval(env, obj->car); + if (obj == obj_err) { + return obj_err; + } + return obj == obj_false ? obj_true : obj_false; +} + +Object * +proc_and(Environment *env, Object *obj) { + while (obj != obj_nil) { + if (proc_not(env, obj) == obj_true) { + return obj_false; + } + obj = obj->cdr; + } + return obj_true; +} + +Object * +proc_or(Environment *env, Object *obj) { + while (obj != obj_nil) { + if (proc_not(env, obj) == obj_false) { + return obj_true; + } + obj = obj->cdr; + } + return obj_false; +} + +Object * +proc_if(Environment *env, Object *obj) { + if (obj == obj_nil || obj->cdr == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + Object *car = obj->car; + Object *cdr = obj->cdr; + Object *clause = eval(env, car); + if (obj == obj_err) { + return obj_err; + } + if (clause == obj_true) { + return eval(env, cdr->car); + } + if (obj->cdr->cdr != obj_nil) { + return eval(env, cdr->cdr->car); + } + + return obj_nil; +} + +Object * +proc_cond(Environment *env, Object *obj) { + if (obj == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + + if (obj->car->type != OBJ_TYPE_PAIR) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_WRONG_ARG_TYPE, + }); + return obj_err; + } + + // TODO: review this, the cdr->car could cause issues? + while (obj != obj_nil) { + Object *clause = obj->car; + Object *result = eval(env, clause->car); + if (result == obj_err) { + return obj_err; + } + if (result == obj_true) { + return eval(env, clause->cdr->car); + } + obj = obj->cdr; + } + return obj_nil; +} + +Object * +proc_num_less_than(Environment *env, Object *obj) { + // First argument. + if (obj == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + Object *car = eval(env, obj->car); + if (car == obj_err) { + return obj_err; + } + if (car->type != OBJ_TYPE_FIXNUM) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_WRONG_ARG_TYPE, + }); + return obj_err; + } + + // Traverse the list. + obj = obj->cdr; + ssize_t prev = car->fixnum; + while (obj != obj_nil) { + car = eval(env, obj->car); + if (car == obj_err) { + return obj_err; + } + if (car->type != OBJ_TYPE_FIXNUM) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_WRONG_ARG_TYPE, + }); + return obj_err; + } + if (prev >= car->fixnum) { + return obj_false; + } + prev = car->fixnum; + obj = obj->cdr; + } + return obj_true; +} + +Object * +proc_num_greater_than(Environment *env, Object *obj) { + // First argument. + if (obj == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + Object *car = eval(env, obj->car); + if (car == obj_err) { + return obj_err; + } + if (car->type != OBJ_TYPE_FIXNUM) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_WRONG_ARG_TYPE, + }); + return obj_err; + } + + // Traverse the list. + obj = obj->cdr; + ssize_t prev = car->fixnum; + while (obj != obj_nil) { + car = eval(env, obj->car); + if (car == obj_err) { + return obj_err; + } + if (car->type != OBJ_TYPE_FIXNUM) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_WRONG_ARG_TYPE, + }); + return obj_err; + } + if (prev <= car->fixnum) { + return obj_false; + } + prev = car->fixnum; + obj = obj->cdr; + } + return obj_true; +} + +Object * +proc_num_lesseq_than(Environment *env, Object *obj) { + // First argument. + if (obj == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + Object *car = eval(env, obj->car); + if (car == obj_err) { + return obj_err; + } + if (car->type != OBJ_TYPE_FIXNUM) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_WRONG_ARG_TYPE, + }); + return obj_err; + } + + // Traverse the list. + obj = obj->cdr; + ssize_t prev = car->fixnum; + while (obj != obj_nil) { + car = eval(env, obj->car); + if (car == obj_err) { + return obj_err; + } + if (car->type != OBJ_TYPE_FIXNUM) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_WRONG_ARG_TYPE, + }); + return obj_err; + } + if (prev > car->fixnum) { + return obj_false; + } + prev = car->fixnum; + obj = obj->cdr; + } + return obj_true; +} + +Object * +proc_num_greatereq_than(Environment *env, Object *obj) { + // First argument. + if (obj == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + Object *car = eval(env, obj->car); + if (car == obj_err) { + return obj_err; + } + if (car->type != OBJ_TYPE_FIXNUM) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_WRONG_ARG_TYPE, + }); + return obj_err; + } + + // Traverse the list. + obj = obj->cdr; + ssize_t prev = car->fixnum; + while (obj != obj_nil) { + car = eval(env, obj->car); + if (car == obj_err) { + return obj_err; + } + if (car->type != OBJ_TYPE_FIXNUM) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_WRONG_ARG_TYPE, + }); + return obj_err; + } + if (prev < car->fixnum) { + return obj_false; + } + prev = car->fixnum; + obj = obj->cdr; + } + return obj_true; +} + +Object * +proc_num_equal(Environment *env, Object *obj) { + // First argument. + if (obj == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + Object *car = eval(env, obj->car); + if (car == obj_err) { + return obj_err; + } + if (car->type != OBJ_TYPE_FIXNUM) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_WRONG_ARG_TYPE, + }); + return obj_err; + } + + // Traverse the list. + obj = obj->cdr; + ssize_t prev = car->fixnum; + while (obj != obj_nil) { + car = eval(env, obj->car); + if (car == obj_err) { + return obj_err; + } + if (car->type != OBJ_TYPE_FIXNUM) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_WRONG_ARG_TYPE, + }); + return obj_err; + } + if (prev != car->fixnum) { + return obj_false; + } + prev = car->fixnum; + obj = obj->cdr; + } + return obj_true; +} + +// +// List operation procedures. +// + +Object * +proc_car(Environment *env, Object *obj) { + if (obj == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + obj = eval(env, obj->car); + if (obj == obj_err) { + return obj_err; + } + if (obj->type != OBJ_TYPE_PAIR) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_WRONG_ARG_TYPE, + }); + return obj_err; + } + return obj->car; +} + +Object * +proc_cdr(Environment *env, Object *obj) { + if (obj == obj_nil) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_NOT_ENOUGH_ARGS, + }); + return obj_err; + } + obj = eval(env, obj->car); + if (obj == obj_err) { + return obj_err; + } + if (obj->type != OBJ_TYPE_PAIR) { + error_push((Error){ + .type = ERR_TYPE_RUNTIME, + .value = ERR_WRONG_ARG_TYPE, + }); + return obj_err; + } + return obj->cdr; +} + +Object * +proc_cons(Environment *env, Object *obj) { + if (obj == obj_nil || obj->cdr == obj_nil) { + fprintf(stderr, "error: not enough arguments\n"); + return obj_nil; + } + Object *a = eval(env, obj->car); + Object *b = eval(env, obj->cdr->car); + return make_pair(a, b); +} + +Object * +proc_list(Environment *env, Object *obj) { + if (obj == obj_nil) { + return obj_nil; + } + Object *head = make_pair(eval(env, obj->car), obj_nil); + Object *curr = head; + obj = obj->cdr; + while (obj != obj_nil) { + curr->cdr = make_pair(eval(env, obj->car), obj_nil); + curr = curr->cdr; + obj = obj->cdr; + } + return head; +} + +// +// Polymorphic procedures. +// + +//Object * +//proc_equal(Object *args) { +// // TODO: stub +// (void) args; +// return NULL; +//} + +//// TODO: fixnum left/right shift, mask, invert +//// TODO: implement and test missing procedures +//// TODO: add primitives for type transforms: string->symbol, symbol->string, etc +//// TODO: properly implement nested environments +//// TODO: implement support for quotes and semi-quotes +//// TODO: LAMBDA +//// TODO: let +//// TODO: better error handling? +//// TODO: Revise all instances where we are returning an object, since currently +//// we may be returning a pointer to an object instead of a new one. Check also +//// on eval function and everytime we do make_xxx(obj). diff --git a/tests/booleans_expected.txt b/tests/booleans_expected.txt index f47d32f..43f67e5 100644 --- a/tests/booleans_expected.txt +++ b/tests/booleans_expected.txt @@ -33,11 +33,11 @@ (if (or false false) (+ 1 2 3) (+ 7 8 9)) -> 24 (if (or (+ 1 2 3) false) (+ 1 2 3) (+ 7 8 9)) -> 6 (if true 7) -> 7 -(if false 7) -> () +(if false 7) -> (cond ((and true true true) 1) ((or true true false) 2) (else 3)) -> 1 (cond ((and true true false) 1) ((or true true false) 2) (else 3)) -> 2 (cond ((and true true false) 1) ((or false false false) 2) (else 3)) -> 3 -(cond ((and true true true) 1) ((or true true false) 2)) -> () +(cond ((and true true true) 1) ((or true true false) 2)) -> (cond ((and true true true) (+ 1 2 3)) ((or true true false) 2) (else 3)) -> 6 (< 1 2 3) -> true (< 3 2 1) -> false diff --git a/tests/lists_expected.txt b/tests/lists_expected.txt index 9030886..6ddb71b 100644 --- a/tests/lists_expected.txt +++ b/tests/lists_expected.txt @@ -1,4 +1,4 @@ -(list) -> () +(list) -> (list 1) -> (1) (list 1 2) -> (1 2) (list 1 2 3) -> (1 2 3) diff --git a/tests/types_expected.txt b/tests/types_expected.txt index 3a5a2de..58eaa7f 100644 --- a/tests/types_expected.txt +++ b/tests/types_expected.txt @@ -5,14 +5,14 @@ (boolean? "string") -> false (boolean? (+ 1 2 3)) -> false (boolean? (not 1)) -> true -(null? true) -> false -(null? false) -> false -(null? 1) -> false -(null? 5) -> false -(null? "string") -> false -(null? (+ 1 2 3)) -> false -(null? (not 1)) -> false -(null? ()) -> true +(nil? true) -> false +(nil? false) -> false +(nil? 1) -> false +(nil? 5) -> false +(nil? "string") -> false +(nil? (+ 1 2 3)) -> false +(nil? (not 1)) -> false +(nil? ()) -> true (string? true) -> false (string? false) -> false (string? 1) -> false @@ -34,6 +34,8 @@ (symbol? "string") -> false (symbol? (+ 1 2 3)) -> false (symbol? (not 1)) -> false +(symbol? 'a) -> true +(symbol? 'c) -> true (pair? false) -> false (pair? 1) -> false (pair? 5) -> false -- cgit v1.2.1