bool display(Object *root); void display_pair(Object *root) { display(root->car); if (root->cdr->type == OBJ_TYPE_PAIR) { printf(" "); display_pair(root->cdr); } else if (root->cdr == obj_nil) { return; } else { printf(" . "); display(root->cdr); } } bool display(Object *root) { if (root == NULL) { return false; } switch (root->type) { case OBJ_TYPE_FIXNUM: { printf("%zd", root->fixnum); } break; case OBJ_TYPE_BOOL: { if (root->boolean) { printf("true"); } else { printf("false"); } } break; case OBJ_TYPE_NIL: { printf("()"); } break; case OBJ_TYPE_STRING: { printf("\"%.*s\"", (int)root->string_n, root->string); } break; case OBJ_TYPE_SYMBOL: { printf(":%.*s", (int)root->symbol_n, root->symbol); } break; case OBJ_TYPE_PAIR: { printf("("); display_pair(root); printf(")"); } break; case OBJ_TYPE_PROCEDURE: { printf("#{procedure}"); } break; } return true; } Object * eval(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 *value = find_environment_symbol(root); if (value == NULL) { printf("error: symbol not found: `"); display(root); printf("`\n"); return obj_nil; } return value; } break; case OBJ_TYPE_PAIR: { if (root->car->type == OBJ_TYPE_SYMBOL) { Object *value = find_environment_symbol(root->car); if (value == NULL) { printf("error: symbol not found: `"); display(root->car); printf("`\n"); return obj_nil; } if (value->type == OBJ_TYPE_PROCEDURE) { return value->proc(root->cdr); } } } break; default: { printf("error: can't eval type %d.\n", root->type); } break; } return obj_nil; } // // Arithmetic procedures. // Object * proc_add(Object *args) { // Extract first parameter. Object *car = eval(args->car); if (car == NULL) { fprintf(stderr, "error: not enough arguments\n"); return obj_nil; } if (car->type != OBJ_TYPE_FIXNUM) { fprintf(stderr, "addition not supported for type %d\n", car->type); return obj_nil; } args = args->cdr; ssize_t tot = car->fixnum; while (args->type == OBJ_TYPE_PAIR) { Object *car = eval(args->car); if (car == NULL) { car = obj_nil; } if (car->type != OBJ_TYPE_FIXNUM) { fprintf(stderr, "addition not supported for type %d\n", car->type); return obj_nil; } tot += car->fixnum; args = args->cdr; } return make_fixnum(tot); } Object * proc_sub(Object *args) { // Extract first parameter. Object *car = eval(args->car); if (car == NULL) { fprintf(stderr, "error: not enough arguments\n"); return obj_nil; } if (car->type != OBJ_TYPE_FIXNUM) { fprintf(stderr, "error: sub not supported for type %d\n", car->type); return obj_nil; } args = args->cdr; ssize_t tot = car->fixnum; while (args->type == OBJ_TYPE_PAIR) { car = eval(args->car); if (car == NULL) { car = obj_nil; } if (car->type != OBJ_TYPE_FIXNUM) { fprintf(stderr, "error: sub not supported for type %d\n", car->type); return obj_nil; } tot -= car->fixnum; args = args->cdr; } return make_fixnum(tot); } Object * proc_mul(Object *args) { // Extract first parameter. Object *car = eval(args->car); if (car == NULL) { fprintf(stderr, "error: not enough arguments\n"); return obj_nil; } if (car->type != OBJ_TYPE_FIXNUM) { fprintf(stderr, "error: mult not supported for type %d\n", car->type); return obj_nil; } args = args->cdr; ssize_t tot = car->fixnum; while (args->type == OBJ_TYPE_PAIR) { Object *car = eval(args->car); if (car == NULL) { car = obj_nil; } if (car->type != OBJ_TYPE_FIXNUM) { fprintf(stderr, "error: mult not supported for type %d\n", car->type); return obj_nil; } tot *= car->fixnum; args = args->cdr; } return make_fixnum(tot); } Object * proc_div(Object *args) { // Extract first parameter. Object *car = eval(args->car); if (car == NULL) { fprintf(stderr, "error: not enough arguments\n"); return obj_nil; } args = args->cdr; ssize_t tot = car->fixnum; while (args->type == OBJ_TYPE_PAIR) { Object *car = eval(args->car); if (car == NULL) { car = obj_nil; } if (car->type != OBJ_TYPE_FIXNUM) { fprintf(stderr, "error: div not supported for type %d\n", car->type); return obj_nil; } if (car->fixnum == 0) { fprintf(stderr, "error: division by zero\n"); return obj_nil; } tot /= car->fixnum; args = args->cdr; } return make_fixnum(tot); } Object * proc_mod(Object *args) { // Extract first parameter. Object *car = eval(args->car); if (car == NULL) { fprintf(stderr, "error: not enough arguments\n"); return obj_nil; } args = args->cdr; ssize_t tot = car->fixnum; while (args->type == OBJ_TYPE_PAIR) { Object *car = eval(args->car); if (car == NULL) { car = obj_nil; } if (car->type != OBJ_TYPE_FIXNUM) { fprintf(stderr, "error: div not supported for type %d\n", car->type); return obj_nil; } if (car->fixnum == 0) { fprintf(stderr, "error: division by zero\n"); return obj_nil; } tot %= car->fixnum; args = args->cdr; } return make_fixnum(tot); } // // Display/Evaluation procedues. // Object * proc_display(Object *args) { if (args == NULL) { return obj_nil; } if (args->type == OBJ_TYPE_PAIR) { display(eval(args->car)); } return obj_nil; } Object * proc_print(Object *args) { if (args == NULL) { return NULL; } if (args->type == OBJ_TYPE_PAIR) { Object *obj = args->car; if (obj->type == OBJ_TYPE_STRING) { StringView scanner = (StringView) { .start = obj->string, .n = obj->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); } } else { fprintf(stderr, "error: print requires a string argument\n"); } } return NULL; } // // Type info procedures. // Object * proc_is_boolean(Object *args) { Object *obj = NULL; if (args->type == OBJ_TYPE_PAIR) { obj = eval(args->car); } else { obj = eval(args); } return (obj == obj_true || obj == obj_false) ? obj_true : obj_false; } Object * proc_is_null(Object *args) { // TODO: stub return NULL; } Object * proc_is_symbol(Object *args) { // TODO: stub return NULL; } Object * proc_is_string(Object *args) { // TODO: stub return NULL; } Object * proc_is_fixnum(Object *args) { // TODO: stub return NULL; } Object * proc_is_pair(Object *args) { // TODO: stub return NULL; } Object * proc_is_procedure(Object *args) { // TODO: stub return NULL; } // // Boolean/conditional procedures. // Object * proc_not(Object *args) { if (args->type == OBJ_TYPE_PAIR) { return eval(args->car) == obj_false ? obj_true : obj_false; } return eval(args) == obj_false ? obj_true : obj_false; } Object * proc_and(Object *args) { while (args != NULL && args != obj_nil) { Object *obj = args->car; if (args->car->type == OBJ_TYPE_PAIR) { obj = eval(args->car); } if (proc_not(obj) == obj_true) { return obj_false; } args = args->cdr; } return obj_true; } Object * proc_or(Object *args) { if (args->type != OBJ_TYPE_PAIR) { return obj_false; } while (args != NULL && args != obj_nil) { Object *obj = args->car; if (args->car->type == OBJ_TYPE_PAIR) { obj = eval(args->car); } if (proc_not(obj) == obj_false) { return obj_true; } args = args->cdr; } return obj_false; } Object * proc_if(Object *args) { if (args->type != OBJ_TYPE_PAIR || args->cdr->type != OBJ_TYPE_PAIR) { fprintf(stderr, "error: wrong number of arguments.\n"); return NULL; } Object *condition = eval(args->car); if (condition == obj_true) { Object *ret = eval(args->cdr->car); return ret; } if (args->cdr->cdr != obj_nil) { Object *ret = eval(args->cdr->cdr->car); return ret; } return obj_nil; } Object * proc_cond(Object *args) { if (args->type != OBJ_TYPE_PAIR) { fprintf(stderr, "error: wrong number of arguments.\n"); return NULL; } if (args->car->type != OBJ_TYPE_PAIR) { fprintf(stderr, "error: wrong argument type.\n"); return NULL; } while (args != obj_nil) { Object *clause = args->car; if (eval(clause->car) == obj_true) { return eval(clause->cdr->car); } args = args->cdr; } return obj_nil; } Object * proc_num_less_than(Object *args) { if (args == obj_nil) { fprintf(stderr, "error: wrong number of arguments type.\n"); return NULL; } Object *obj = eval(args->car); if (obj->type != OBJ_TYPE_FIXNUM) { fprintf(stderr, "error: wrong argument type.\n"); return NULL; } ssize_t prev = obj->fixnum; args = args->cdr; if (args == obj_nil) { fprintf(stderr, "error: wrong number of arguments type.\n"); return NULL; } while (args != obj_nil) { Object *obj = eval(args->car); if (obj->type != OBJ_TYPE_FIXNUM) { fprintf(stderr, "error: wrong argument type.\n"); return NULL; } if (prev >= obj->fixnum) { return obj_false; } prev = obj->fixnum; args = args->cdr; } return obj_true; } Object * proc_num_greater_than(Object *args) { if (args == obj_nil) { fprintf(stderr, "error: wrong number of arguments type.\n"); return NULL; } Object *obj = eval(args->car); if (obj->type != OBJ_TYPE_FIXNUM) { fprintf(stderr, "error: wrong argument type.\n"); return NULL; } ssize_t prev = obj->fixnum; args = args->cdr; if (args == obj_nil) { fprintf(stderr, "error: wrong number of arguments type.\n"); return NULL; } while (args != obj_nil) { Object *obj = eval(args->car); if (obj->type != OBJ_TYPE_FIXNUM) { fprintf(stderr, "error: wrong argument type.\n"); return NULL; } if (prev <= obj->fixnum) { return obj_false; } prev = obj->fixnum; args = args->cdr; } return obj_true; } Object * proc_num_lesseq_than(Object *args) { if (args == obj_nil) { fprintf(stderr, "error: wrong number of arguments type.\n"); return NULL; } Object *obj = eval(args->car); if (obj->type != OBJ_TYPE_FIXNUM) { fprintf(stderr, "error: wrong argument type.\n"); return NULL; } ssize_t prev = obj->fixnum; args = args->cdr; if (args == obj_nil) { fprintf(stderr, "error: wrong number of arguments type.\n"); return NULL; } while (args != obj_nil) { Object *obj = eval(args->car); if (obj->type != OBJ_TYPE_FIXNUM) { fprintf(stderr, "error: wrong argument type.\n"); return NULL; } if (prev > obj->fixnum) { return obj_false; } prev = obj->fixnum; args = args->cdr; } return obj_true; } Object * proc_num_greatereq_than(Object *args) { if (args == obj_nil) { fprintf(stderr, "error: wrong number of arguments type.\n"); return NULL; } Object *obj = eval(args->car); if (obj->type != OBJ_TYPE_FIXNUM) { fprintf(stderr, "error: wrong argument type.\n"); return NULL; } ssize_t prev = obj->fixnum; args = args->cdr; if (args == obj_nil) { fprintf(stderr, "error: wrong number of arguments type.\n"); return NULL; } while (args != obj_nil) { Object *obj = eval(args->car); if (obj->type != OBJ_TYPE_FIXNUM) { fprintf(stderr, "error: wrong argument type.\n"); return NULL; } if (prev < obj->fixnum) { return obj_false; } prev = obj->fixnum; args = args->cdr; } return obj_true; } Object * proc_num_equal(Object *args) { if (args == obj_nil) { fprintf(stderr, "error: wrong number of arguments type.\n"); return NULL; } Object *obj = eval(args->car); if (obj->type != OBJ_TYPE_FIXNUM) { fprintf(stderr, "error: wrong argument type.\n"); return NULL; } ssize_t prev = obj->fixnum; args = args->cdr; if (args == obj_nil) { fprintf(stderr, "error: wrong number of arguments type.\n"); return NULL; } while (args != obj_nil) { Object *obj = eval(args->car); if (obj->type != OBJ_TYPE_FIXNUM) { fprintf(stderr, "error: wrong argument type.\n"); return NULL; } if (prev != obj->fixnum) { return obj_false; } prev = obj->fixnum; args = args->cdr; } return obj_true; } // // List operation procedures. // Object * proc_car(Object *args) { // TODO: stub return NULL; } Object * proc_cdr(Object *args) { // TODO: stub return NULL; } Object * proc_cons(Object *args) { // TODO: stub return NULL; } Object * proc_list(Object *args) { // TODO: stub return NULL; } // // Polymorphic procedures. // Object * proc_equal(Object *args) { // TODO: stub return NULL; } // TODO: fixnum left/right shift, mask, invert // TODO: implement and test missing procedures // TODO: properly implement nested environments // TODO: implement support for quotes and semi-quotes // TODO: LAMBDA // TODO: let // TODO: better error handling?