src/ebisp/std.c

   1 #include "system/stacktrace.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 #include "ebisp/parser.h"
   9
  10 #include "std.h"
  11
  12 static struct Expr
  13 lambda(Gc *gc, struct Expr args, struct Expr body)
  14 {
  15     return atom_as_expr(create_lambda_atom(gc, args, body));
  16 }
  17
  18 static struct EvalResult
  19 quasiquote(void *param, Gc *gc, struct Scope *scope, struct Expr args)
  20 {
  21     (void) param;
  22     trace_assert(gc);
  23     trace_assert(scope);
  24
  25     struct Expr expr = void_expr();
  26     struct EvalResult result = match_list(gc, "e", args, &expr);
  27     if (result.is_error) {
  28         return result;
  29     }
  30
  31     const char *unquote = NULL;
  32     struct Expr unquote_expr = void_expr();
  33     result = match_list(gc, "qe", expr, &unquote, &unquote_expr);
  34
  35     if (!result.is_error && strcmp(unquote, "unquote") == 0) {
  36         return eval(gc, scope, unquote_expr);
  37     } else if (cons_p(expr)) {
  38         struct EvalResult left = quasiquote(param, gc, scope, CONS(gc, CAR(expr), NIL(gc)));
  39         if (left.is_error) {
  40             return left;
  41         }
  42         struct EvalResult right = quasiquote(param, gc, scope, CONS(gc, CDR(expr), NIL(gc)));
  43         if (right.is_error) {
  44             return right;
  45         }
  46         return eval_success(CONS(gc, left.expr, right.expr));
  47     } else {
  48         return eval_success(expr);
  49     }
  50 }
  51
  52 static struct EvalResult
  53 unquote(void *param, Gc *gc, struct Scope *scope, struct Expr args)
  54 {
  55     (void) param;
  56     trace_assert(gc);
  57     trace_assert(scope);
  58     (void) args;
  59
  60     return eval_failure(STRING(gc, "Using unquote outside of quasiquote."));
  61 }
  62
  63 static struct EvalResult
  64 greaterThan(void *param, Gc *gc, struct Scope *scope, struct Expr args)
  65 {
  66     trace_assert(gc);
  67     trace_assert(scope);
  68     (void) param;
  69
  70     long int x1 = 0;
  71     struct Expr xs = void_expr();
  72
  73     struct EvalResult result = match_list(gc, "d*", args, &x1, &xs);
  74     if (result.is_error) {
  75         return result;
  76     }
  77
  78     bool sorted = true;
  79
  80     while (!nil_p(xs) && sorted) {
  81         long int x2 = 0;
  82         result = match_list(gc, "d*", xs, &x2, NULL);
  83         if (result.is_error) {
  84             return result;
  85         }
  86
  87         sorted = sorted && (x1 > x2);
  88         args = xs;
  89
  90         result = match_list(gc, "d*", args, &x1, &xs);
  91         if (result.is_error) {
  92             return result;
  93         }
  94     }
  95
  96     return eval_success(bool_as_expr(gc, sorted));
  97 }
  98
  99 static struct EvalResult
 100 list_op(void *param, Gc *gc, struct Scope *scope, struct Expr args)
 101 {
 102     trace_assert(gc);
 103     trace_assert(scope);
 104     (void) param;
 105
 106     return eval_success(args);
 107 }
 108
 109 static struct EvalResult
 110 plus_op(void *param, Gc *gc, struct Scope *scope, struct Expr args)
 111 {
 112     (void) param;
 113     trace_assert(gc);
 114     trace_assert(scope);
 115
 116     long int result = 0L;
 117
 118     while (!nil_p(args)) {
 119         if (!cons_p(args)) {
 120             return wrong_argument_type(gc, "consp", args);
 121         }
 122
 123         if (!number_p(CAR(args))) {
 124             return wrong_argument_type(gc, "numberp", CAR(args));
 125         }
 126
 127         result += CAR(args).atom->num;
 128         args = CDR(args);
 129     }
 130
 131     return eval_success(NUMBER(gc, result));
 132 }
 133
 134 static struct EvalResult
 135 mul_op(void *param, Gc *gc, struct Scope *scope, struct Expr args)
 136 {
 137     (void) param;
 138     trace_assert(gc);
 139     trace_assert(scope);
 140
 141     long int result = 1L;
 142
 143     while (!nil_p(args)) {
 144         if (!cons_p(args)) {
 145             return wrong_argument_type(gc, "consp", args);
 146         }
 147
 148         if (!number_p(CAR(args))) {
 149             return wrong_argument_type(gc, "numberp", CAR(args));
 150         }
 151
 152         result *= CAR(args).atom->num;
 153         args = CDR(args);
 154     }
 155
 156     return eval_success(NUMBER(gc, result));
 157 }
 158
 159 static struct EvalResult
 160 assoc_op(void *param, Gc *gc, struct Scope *scope, struct Expr args)
 161 {
 162     (void) param;
 163     trace_assert(gc);
 164     trace_assert(scope);
 165
 166     struct Expr key = NIL(gc);
 167     struct Expr alist = NIL(gc);
 168     struct EvalResult result = match_list(gc, "ee", args, &key, &alist);
 169     if (result.is_error) {
 170         return result;
 171     }
 172
 173     return eval_success(assoc(key, alist));
 174 }
 175
 176 static struct EvalResult
 177 set(void *param, Gc *gc, struct Scope *scope, struct Expr args)
 178 {
 179     (void) param;
 180     trace_assert(gc);
 181     trace_assert(scope);
 182
 183     const char *name = NULL;
 184     struct Expr value = void_expr();
 185     struct EvalResult result = match_list(gc, "qe", args, &name, &value);
 186     if (result.is_error) {
 187         return result;
 188     }
 189
 190     result = eval(gc, scope, value);
 191     if (result.is_error) {
 192         return result;
 193     }
 194
 195     set_scope_value(gc, scope, SYMBOL(gc, name), result.expr);
 196
 197     return eval_success(result.expr);
 198 }
 199
 200 static struct EvalResult
 201 quote(void *param, Gc *gc, struct Scope *scope, struct Expr args)
 202 {
 203     (void) param;
 204     trace_assert(gc);
 205     trace_assert(scope);
 206
 207     struct Expr expr = void_expr();
 208     struct EvalResult result = match_list(gc, "e", args, &expr);
 209     if (result.is_error) {
 210         return result;
 211     }
 212
 213     return eval_success(expr);
 214 }
 215
 216 static struct EvalResult
 217 begin(void *param, Gc *gc, struct Scope *scope, struct Expr args)
 218 {
 219     (void) param;
 220     trace_assert(gc);
 221     trace_assert(scope);
 222
 223     struct Expr block = void_expr();
 224     struct EvalResult result = match_list(gc, "*", args, &block);
 225     if (result.is_error) {
 226         return result;
 227     }
 228
 229     return eval_block(gc, scope, block);
 230 }
 231
 232 static struct EvalResult
 233 defun(void *param, Gc *gc, struct Scope *scope, struct Expr args)
 234 {
 235     (void) param;
 236     trace_assert(gc);
 237     trace_assert(scope);
 238
 239     struct Expr name = void_expr();
 240     struct Expr args_list = void_expr();
 241     struct Expr body = void_expr();
 242
 243     struct EvalResult result = match_list(gc, "ee*", args, &name, &args_list, &body);
 244     if (result.is_error) {
 245         return result;
 246     }
 247
 248     if (!list_of_symbols_p(args_list)) {
 249         return wrong_argument_type(gc, "list-of-symbolsp", args_list);
 250     }
 251
 252     return eval(gc, scope,
 253                 list(gc, "qee", "set", name,
 254                             lambda(gc, args_list, body)));
 255 }
 256
 257 static struct EvalResult
 258 when(void *param, Gc *gc, struct Scope *scope, struct Expr args)
 259 {
 260     (void) param;
 261     trace_assert(gc);
 262     trace_assert(scope);
 263
 264     struct Expr condition = void_expr();
 265     struct Expr body = void_expr();
 266
 267     struct EvalResult result = match_list(
 268         gc, "e*", args, &condition, &body);
 269     if (result.is_error) {
 270         return result;
 271     }
 272
 273     result = eval(gc, scope, condition);
 274     if (result.is_error) {
 275         return result;
 276     }
 277
 278     if (!nil_p(result.expr)) {
 279         return eval_block(gc, scope, body);
 280     }
 281
 282     return eval_success(NIL(gc));
 283 }
 284
 285 static struct EvalResult
 286 lambda_op(void *param, Gc *gc, struct Scope *scope, struct Expr args)
 287 {
 288     (void) param;
 289     trace_assert(gc);
 290     trace_assert(scope);
 291
 292     struct Expr args_list = void_expr();
 293     struct Expr body = void_expr();
 294
 295     struct EvalResult result = match_list(gc, "e*", args, &args_list, &body);
 296     if (result.is_error) {
 297         return result;
 298     }
 299
 300     if (!list_of_symbols_p(args_list)) {
 301         return wrong_argument_type(gc, "list-of-symbolsp", args_list);
 302     }
 303
 304     return eval_success(lambda(gc, args_list, body));
 305 }
 306
 307 static struct EvalResult
 308 load(void *param, Gc *gc, struct Scope *scope, struct Expr args)
 309 {
 310     (void) param;
 311     trace_assert(gc);
 312     trace_assert(scope);
 313
 314     const char *filename = NULL;
 315     struct EvalResult result = match_list(gc, "s", args, &filename);
 316     if (result.is_error) {
 317         return result;
 318     }
 319
 320     struct ParseResult parse_result = read_all_exprs_from_file(gc, filename);
 321     if (parse_result.is_error) {
 322         /* TODO(#599): (load) does not provide position of the parse error  */
 323         return read_error(gc, parse_result.error_message, 0);
 324     }
 325
 326     return eval_block(gc, scope, parse_result.expr);
 327 }
 328
 329 void load_std_library(Gc *gc, struct Scope *scope)
 330 {
 331     set_scope_value(gc, scope, SYMBOL(gc, "car"), NATIVE(gc, car, NULL));
 332     set_scope_value(gc, scope, SYMBOL(gc, ">"), NATIVE(gc, greaterThan, NULL));
 333     set_scope_value(gc, scope, SYMBOL(gc, "+"), NATIVE(gc, plus_op, NULL));
 334     set_scope_value(gc, scope, SYMBOL(gc, "*"), NATIVE(gc, mul_op, NULL));
 335     set_scope_value(gc, scope, SYMBOL(gc, "list"), NATIVE(gc, list_op, NULL));
 336     set_scope_value(gc, scope, SYMBOL(gc, "t"), SYMBOL(gc, "t"));
 337     set_scope_value(gc, scope, SYMBOL(gc, "nil"), SYMBOL(gc, "nil"));
 338     set_scope_value(gc, scope, SYMBOL(gc, "assoc"), NATIVE(gc, assoc_op, NULL));
 339     set_scope_value(gc, scope, SYMBOL(gc, "quasiquote"), NATIVE(gc, quasiquote, NULL));
 340     set_scope_value(gc, scope, SYMBOL(gc, "set"), NATIVE(gc, set, NULL));
 341     set_scope_value(gc, scope, SYMBOL(gc, "quote"), NATIVE(gc, quote, NULL));
 342     set_scope_value(gc, scope, SYMBOL(gc, "begin"), NATIVE(gc, begin, NULL));
 343     set_scope_value(gc, scope, SYMBOL(gc, "defun"), NATIVE(gc, defun, NULL));
 344     set_scope_value(gc, scope, SYMBOL(gc, "when"), NATIVE(gc, when, NULL));
 345     set_scope_value(gc, scope, SYMBOL(gc, "lambda"), NATIVE(gc, lambda_op, NULL));
 346     set_scope_value(gc, scope, SYMBOL(gc, "λ"), NATIVE(gc, lambda_op, NULL));
 347     set_scope_value(gc, scope, SYMBOL(gc, "unquote"), NATIVE(gc, unquote, NULL));
 348     set_scope_value(gc, scope, SYMBOL(gc, "load"), NATIVE(gc, load, NULL));
 349 }