src/ebisp/std.c

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