src/ebisp/std.c

   1 #include <assert.h>
   2
   3 #include "ebisp/gc.h"
   4 #include "ebisp/interpreter.h"
   5 #include "ebisp/builtins.h"
   6 #include "ebisp/scope.h"
   7
   8 #include "std.h"
   9
  10 static struct Expr
  11 lambda(Gc *gc, struct Expr args, struct Expr body)
  12 {
  13     return CONS(gc,
  14                 SYMBOL(gc, "lambda"),
  15                 CONS(gc, args, body));
  16 }
  17
  18 static struct EvalResult
  19 quasiquote(void *param, Gc *gc, struct Scope *scope, struct Expr expr)
  20 {
  21     (void) param;
  22     assert(gc);
  23     assert(scope);
  24     (void) expr;
  25
  26     /* TODO(#582): quasiquote special form is not implemented */
  27
  28     return not_implemented(gc);
  29 }
  30
  31 /* TODO(#536): greaterThan does not support arbitrary amount of arguments */
  32 static struct EvalResult
  33 greaterThan(void *param, Gc *gc, struct Scope *scope, struct Expr args)
  34 {
  35     assert(gc);
  36     assert(scope);
  37     (void) param;
  38
  39     long int x = 0, y = 0;
  40
  41     struct EvalResult result = match_list(gc, "dd", args, &x, &y);
  42     if (result.is_error) {
  43         return result;
  44     }
  45
  46     if (x > y) {
  47         return eval_success(T(gc));
  48     } else {
  49         return eval_success(NIL(gc));
  50     }
  51 }
  52
  53 static struct EvalResult
  54 list_op(void *param, Gc *gc, struct Scope *scope, struct Expr args)
  55 {
  56     assert(gc);
  57     assert(scope);
  58     (void) param;
  59
  60     return eval_success(args);
  61 }
  62
  63 static struct EvalResult
  64 plus_op(void *param, Gc *gc, struct Scope *scope, struct Expr args)
  65 {
  66     (void) param;
  67     assert(gc);
  68     assert(scope);
  69
  70     long int result = 0L;
  71
  72     while (!nil_p(args)) {
  73         if (!cons_p(args)) {
  74             return wrong_argument_type(gc, "consp", args);
  75         }
  76
  77         if (!number_p(CAR(args))) {
  78             return wrong_argument_type(gc, "numberp", CAR(args));
  79         }
  80
  81         result += CAR(args).atom->num;
  82         args = CDR(args);
  83     }
  84
  85     return eval_success(NUMBER(gc, result));
  86 }
  87
  88 static struct EvalResult
  89 assoc_op(void *param, Gc *gc, struct Scope *scope, struct Expr args)
  90 {
  91     (void) param;
  92     assert(gc);
  93     assert(scope);
  94
  95     struct Expr key = NIL(gc);
  96     struct Expr alist = NIL(gc);
  97     struct EvalResult result = match_list(gc, "ee", args, &key, &alist);
  98     if (result.is_error) {
  99         return result;
 100     }
 101
 102     return eval_success(assoc(key, alist));
 103 }
 104
 105 static struct EvalResult
 106 set(void *param, Gc *gc, struct Scope *scope, struct Expr args)
 107 {
 108     (void) param;
 109     assert(gc);
 110     assert(scope);
 111
 112     const char *name = NULL;
 113     struct Expr value = void_expr();
 114     struct EvalResult result = match_list(gc, "qe", args, &name, &value);
 115     if (result.is_error) {
 116         return result;
 117     }
 118
 119     result = eval(gc, scope, value);
 120     if (result.is_error) {
 121         return result;
 122     }
 123
 124     set_scope_value(gc, scope, SYMBOL(gc, name), result.expr);
 125
 126     return eval_success(result.expr);
 127 }
 128
 129 static struct EvalResult
 130 quote(void *param, Gc *gc, struct Scope *scope, struct Expr args)
 131 {
 132     (void) param;
 133     assert(gc);
 134     assert(scope);
 135
 136     struct Expr expr = void_expr();
 137     struct EvalResult result = match_list(gc, "e", args, &expr);
 138     if (result.is_error) {
 139         return result;
 140     }
 141
 142     return eval_success(expr);
 143 }
 144
 145 static struct EvalResult
 146 begin(void *param, Gc *gc, struct Scope *scope, struct Expr args)
 147 {
 148     (void) param;
 149     assert(gc);
 150     assert(scope);
 151
 152     struct Expr block = void_expr();
 153     struct EvalResult result = match_list(gc, "*", args, &block);
 154     if (result.is_error) {
 155         return result;
 156     }
 157
 158     return eval_block(gc, scope, block);
 159 }
 160
 161 static struct EvalResult
 162 defun(void *param, Gc *gc, struct Scope *scope, struct Expr args)
 163 {
 164     (void) param;
 165     assert(gc);
 166     assert(scope);
 167
 168     struct Expr name = void_expr();
 169     struct Expr args_list = void_expr();
 170     struct Expr body = void_expr();
 171
 172     struct EvalResult result = match_list(gc, "ee*", args, &name, &args_list, &body);
 173     if (result.is_error) {
 174         return result;
 175     }
 176
 177     return eval(gc, scope,
 178                 list(gc, 3,
 179                      SYMBOL(gc, "set"),
 180                      name,
 181                      lambda(gc, args_list, body)));
 182 }
 183
 184 static struct EvalResult
 185 when(void *param, Gc *gc, struct Scope *scope, struct Expr args)
 186 {
 187     (void) param;
 188     assert(gc);
 189     assert(scope);
 190
 191     struct Expr condition = void_expr();
 192     struct Expr body = void_expr();
 193
 194     struct EvalResult result = match_list(
 195         gc, "e*", args, &condition, &body);
 196     if (result.is_error) {
 197         return result;
 198     }
 199
 200     result = eval(gc, scope, condition);
 201     if (result.is_error) {
 202         return result;
 203     }
 204
 205     if (!nil_p(result.expr)) {
 206         return eval_block(gc, scope, body);
 207     }
 208
 209     return eval_success(NIL(gc));
 210 }
 211
 212 static struct EvalResult
 213 lambda_op(void *param, Gc *gc, struct Scope *scope, struct Expr args)
 214 {
 215     (void) param;
 216     assert(gc);
 217     assert(scope);
 218
 219     struct Expr args_list = void_expr();
 220     struct Expr body = void_expr();
 221
 222     struct EvalResult result = match_list(gc, "e*", args, &args_list, &body);
 223     if (result.is_error) {
 224         return result;
 225     }
 226
 227     if (!list_of_symbols_p(args_list)) {
 228         return wrong_argument_type(gc, "list-of-symbolsp", args_list);
 229     }
 230
 231     return eval_success(lambda(gc, args_list, body));
 232 }
 233
 234 void load_std_library(Gc *gc, struct Scope *scope)
 235 {
 236     set_scope_value(gc, scope, SYMBOL(gc, "car"), NATIVE(gc, car, NULL));
 237     set_scope_value(gc, scope, SYMBOL(gc, ">"), NATIVE(gc, greaterThan, NULL));
 238     set_scope_value(gc, scope, SYMBOL(gc, "+"), NATIVE(gc, plus_op, NULL));
 239     set_scope_value(gc, scope, SYMBOL(gc, "list"), NATIVE(gc, list_op, NULL));
 240     set_scope_value(gc, scope, SYMBOL(gc, "t"), SYMBOL(gc, "t"));
 241     set_scope_value(gc, scope, SYMBOL(gc, "nil"), SYMBOL(gc, "nil"));
 242     set_scope_value(gc, scope, SYMBOL(gc, "assoc"), NATIVE(gc, assoc_op, NULL));
 243     set_scope_value(gc, scope, SYMBOL(gc, "quasiquote"), NATIVE(gc, quasiquote, NULL));
 244     set_scope_value(gc, scope, SYMBOL(gc, "set"), NATIVE(gc, set, NULL));
 245     set_scope_value(gc, scope, SYMBOL(gc, "quote"), NATIVE(gc, quote, NULL));
 246     set_scope_value(gc, scope, SYMBOL(gc, "begin"), NATIVE(gc, begin, NULL));
 247     set_scope_value(gc, scope, SYMBOL(gc, "defun"), NATIVE(gc, defun, NULL));
 248     set_scope_value(gc, scope, SYMBOL(gc, "when"), NATIVE(gc, when, NULL));
 249     set_scope_value(gc, scope, SYMBOL(gc, "lambda"), NATIVE(gc, lambda_op, NULL));
 250     set_scope_value(gc, scope, SYMBOL(gc, "λ"), NATIVE(gc, lambda_op, NULL));
 251 }