src/ebisp/interpreter.c

   1 #include <assert.h>
   2 #include <math.h>
   3 #include <string.h>
   4 #include <stdarg.h>
   5 #include <stdbool.h>
   6
   7 #include "./builtins.h"
   8 #include "./expr.h"
   9 #include "./interpreter.h"
  10 #include "./scope.h"
  11
  12 struct EvalResult eval_success(struct Expr expr)
  13 {
  14     struct EvalResult result = {
  15         .is_error = false,
  16         .expr = expr,
  17     };
  18
  19     return result;
  20 }
  21
  22 struct EvalResult eval_failure(struct Expr error)
  23 {
  24     struct EvalResult result = {
  25         .is_error = true,
  26         .expr = error,
  27     };
  28
  29     return result;
  30 }
  31
  32 struct EvalResult
  33 wrong_argument_type(Gc *gc, const char *type, struct Expr obj)
  34 {
  35     return eval_failure(
  36         list(gc, 3,
  37              SYMBOL(gc, "wrong-argument-type"),
  38              SYMBOL(gc, type),
  39              obj));
  40 }
  41
  42 struct EvalResult
  43 wrong_number_of_arguments(Gc *gc, long int count)
  44 {
  45     return eval_failure(
  46         CONS(gc,
  47              SYMBOL(gc, "wrong-number-of-arguments"),
  48              NUMBER(gc, count)));
  49 }
  50
  51 struct EvalResult
  52 not_implemented(Gc *gc)
  53 {
  54     return eval_failure(SYMBOL(gc, "not-implemented"));
  55 }
  56
  57 static struct EvalResult eval_atom(Gc *gc, struct Scope *scope, struct Atom *atom)
  58 {
  59     (void) scope;
  60     (void) gc;
  61
  62     switch (atom->type) {
  63     case ATOM_NUMBER:
  64     case ATOM_STRING:
  65     case ATOM_NATIVE:
  66         return eval_success(atom_as_expr(atom));
  67
  68     case ATOM_SYMBOL: {
  69         struct Expr value = get_scope_value(scope, atom_as_expr(atom));
  70
  71         if (nil_p(value)) {
  72             return eval_failure(CONS(gc,
  73                                      SYMBOL(gc, "void-variable"),
  74                                      atom_as_expr(atom)));
  75         }
  76
  77         return eval_success(value.cons->cdr);
  78     }
  79     }
  80
  81     return eval_failure(CONS(gc,
  82                              SYMBOL(gc, "unexpected-expression"),
  83                              atom_as_expr(atom)));
  84 }
  85
  86 static struct EvalResult eval_all_args(Gc *gc, struct Scope *scope, struct Expr args)
  87 {
  88     (void) scope;
  89     (void) args;
  90
  91     switch(args.type) {
  92     case EXPR_ATOM:
  93         return eval_atom(gc, scope, args.atom);
  94
  95     case EXPR_CONS: {
  96         struct EvalResult car = eval(gc, scope, args.cons->car);
  97         if (car.is_error) {
  98             return car;
  99         }
 100
 101         struct EvalResult cdr = eval_all_args(gc, scope, args.cons->cdr);
 102         if (cdr.is_error) {
 103             return cdr;
 104         }
 105
 106         return eval_success(cons_as_expr(create_cons(gc, car.expr, cdr.expr)));
 107     }
 108
 109     default: {}
 110     }
 111
 112     return eval_failure(CONS(gc,
 113                              SYMBOL(gc, "unexpected-expression"),
 114                              args));
 115 }
 116
 117 static struct EvalResult call_lambda(Gc *gc,
 118                                      struct Scope *scope,
 119                                      struct Expr lambda,
 120                                      struct Expr args) {
 121     if (!lambda_p(lambda)) {
 122         return eval_failure(CONS(gc,
 123                                  SYMBOL(gc, "expected-callable"),
 124                                  lambda));
 125     }
 126
 127     if (!list_p(args)) {
 128         return eval_failure(CONS(gc,
 129                                  SYMBOL(gc, "expected-list"),
 130                                  args));
 131     }
 132
 133     struct Expr vars = lambda.cons->cdr.cons->car;
 134
 135     if (length_of_list(args) != length_of_list(vars)) {
 136         return eval_failure(CONS(gc,
 137                                  SYMBOL(gc, "wrong-number-of-arguments"),
 138                                  NUMBER(gc, length_of_list(args))));
 139     }
 140
 141     push_scope_frame(gc, scope, vars, args);
 142     struct Expr body = lambda.cons->cdr.cons->cdr;
 143
 144     struct EvalResult result = eval_success(NIL(gc));
 145
 146     while (!nil_p(body)) {
 147         result = eval(gc, scope, body.cons->car);
 148         if (result.is_error) {
 149             return result;
 150         }
 151         body = body.cons->cdr;
 152     }
 153
 154     pop_scope_frame(gc, scope);
 155
 156     return result;
 157 }
 158
 159 static struct EvalResult call_callable(Gc *gc,
 160                                        struct Scope *scope,
 161                                        struct Expr callable_expr,
 162                                        struct Expr args_expr) {
 163     struct EvalResult callable_result = eval(gc, scope, callable_expr);
 164     if (callable_result.is_error) {
 165         return callable_result;
 166     }
 167
 168     struct EvalResult args_result = symbol_p(callable_expr) && is_special(callable_expr.atom->sym)
 169         ? eval_success(args_expr)
 170         : eval_all_args(gc, scope, args_expr);
 171
 172     if (args_result.is_error) {
 173         return args_result;
 174     }
 175
 176     if (callable_result.expr.type == EXPR_ATOM &&
 177         callable_result.expr.atom->type == ATOM_NATIVE) {
 178         return ((NativeFunction)callable_result.expr.atom->native.fun)(
 179             callable_result.expr.atom->native.param, gc, scope, args_result.expr);
 180     }
 181
 182     return call_lambda(gc, scope, callable_result.expr, args_result.expr);
 183 }
 184
 185
 186 struct EvalResult eval_block(Gc *gc, struct Scope *scope, struct Expr block)
 187 {
 188     assert(gc);
 189     assert(scope);
 190
 191     if (!list_p(block)) {
 192         return wrong_argument_type(gc, "listp", block);
 193     }
 194
 195     struct Expr head = block;
 196     struct EvalResult eval_result = eval_success(NIL(gc));
 197
 198     while (cons_p(head)) {
 199         eval_result = eval(gc, scope, CAR(head));
 200         if (eval_result.is_error) {
 201             return eval_result;
 202         }
 203
 204         head = CDR(head);
 205     }
 206
 207     return eval_result;
 208 }
 209
 210 static struct EvalResult eval_funcall(Gc *gc, struct Scope *scope, struct Cons *cons)
 211 {
 212     assert(cons);
 213     (void) scope;
 214
 215     return call_callable(gc, scope, cons->car, cons->cdr);
 216 }
 217
 218 struct EvalResult eval(Gc *gc, struct Scope *scope, struct Expr expr)
 219 {
 220     switch(expr.type) {
 221     case EXPR_ATOM:
 222         return eval_atom(gc, scope, expr.atom);
 223
 224     case EXPR_CONS:
 225         return eval_funcall(gc, scope, expr.cons);
 226
 227     default: {}
 228     }
 229
 230     return eval_failure(CONS(gc,
 231                              SYMBOL(gc, "unexpected-expression"),
 232                              expr));
 233 }
 234
 235 struct EvalResult
 236 car(void *param, Gc *gc, struct Scope *scope, struct Expr args)
 237 {
 238     (void) param;
 239     assert(gc);
 240     assert(scope);
 241
 242     struct Expr xs = NIL(gc);
 243
 244     struct EvalResult result = match_list(gc, "e", args, &xs);
 245     if (result.is_error) {
 246         return result;
 247     }
 248
 249     if (nil_p(xs)) {
 250         return eval_success(xs);
 251     }
 252
 253     if (!cons_p(xs)) {
 254         return wrong_argument_type(gc, "consp", xs);
 255     }
 256
 257     return eval_success(CAR(xs));
 258 }
 259
 260 struct EvalResult
 261 match_list(struct Gc *gc, const char *format, struct Expr xs, ...)
 262 {
 263     va_list args_list;
 264     va_start(args_list, xs);
 265
 266     long int i = 0;
 267     for (i = 0; *format != 0 && !nil_p(xs); ++i) {
 268         if (!cons_p(xs)) {
 269             va_end(args_list);
 270             return wrong_argument_type(gc, "consp", xs);
 271         }
 272
 273         struct Expr x = CAR(xs);
 274
 275         switch (*format) {
 276         case 'd': {
 277             if (!number_p(x)) {
 278                 va_end(args_list);
 279                 return wrong_argument_type(gc, "numberp", x);
 280             }
 281
 282             long int *p = va_arg(args_list, long int *);
 283             if (p != NULL) {
 284                 *p = x.atom->num;
 285             }
 286         } break;
 287
 288         case 's': {
 289             if (!string_p(x)) {
 290                 va_end(args_list);
 291                 return wrong_argument_type(gc, "stringp", x);
 292             }
 293
 294             const char **p = va_arg(args_list, const char**);
 295             if (p != NULL) {
 296                 *p = x.atom->str;
 297             }
 298         } break;
 299
 300         case 'q': {
 301             if (!symbol_p(x)) {
 302                 va_end(args_list);
 303                 return wrong_argument_type(gc, "symbolp", x);
 304             }
 305
 306             const char **p = va_arg(args_list, const char**);
 307             if (p != NULL) {
 308                 *p = x.atom->sym;
 309             }
 310         } break;
 311
 312         case 'e': {
 313             struct Expr *p = va_arg(args_list, struct Expr*);
 314             *p = x;
 315         } break;
 316
 317         case '*': {
 318             struct Expr *p = va_arg(args_list, struct Expr*);
 319             if (p != NULL) {
 320                 *p = xs;
 321             }
 322             xs = NIL(gc);
 323         } break;
 324         }
 325
 326         format++;
 327         if (!nil_p(xs)) {
 328             xs = CDR(xs);
 329         }
 330     }
 331
 332     if (*format == '*' && nil_p(xs)) {
 333         struct Expr *p = va_arg(args_list, struct Expr*);
 334         if (p != NULL) {
 335             *p = NIL(gc);
 336         }
 337         format++;
 338     }
 339
 340     if (*format != 0 || !nil_p(xs)) {
 341         va_end(args_list);
 342         return wrong_number_of_arguments(gc, i);
 343     }
 344
 345     va_end(args_list);
 346     return eval_success(NIL(gc));
 347 }
 348
 349 static struct Expr
 350 format_list_rec(Gc *gc, const char *format, va_list args)
 351 {
 352     assert(gc);
 353     assert(format);
 354
 355     if (*format == 0) {
 356         return NIL(gc);
 357     }
 358
 359     switch (*format) {
 360     case 'd': {
 361         long int p = va_arg(args, long int);
 362         return CONS(gc, NUMBER(gc, p),
 363                     format_list_rec(gc, format + 1, args));
 364     }
 365
 366     case 's': {
 367         const char* p = va_arg(args, const char*);
 368         return CONS(gc, STRING(gc, p),
 369                     format_list_rec(gc, format + 1, args));
 370     }
 371
 372     case 'q': {
 373         const char* p = va_arg(args, const char*);
 374         return CONS(gc, SYMBOL(gc, p),
 375                     format_list_rec(gc, format + 1, args));
 376     }
 377
 378     case 'e': {
 379         struct Expr p = va_arg(args, struct Expr);
 380         return CONS(gc, p, format_list_rec(gc, format + 1, args));
 381     }
 382
 383     default: {
 384         fprintf(stderr, "Wrong format parameter: %c\n", *format);
 385         assert(0);
 386     }
 387     }
 388 }
 389
 390 struct Expr
 391 format_list(Gc *gc, const char *format, ...)
 392 {
 393     va_list args;
 394     va_start(args, format);
 395     struct Expr result = format_list_rec(gc, format, args);
 396     va_end(args);
 397
 398     return result;
 399 }