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 length(Gc *gc, struct Expr obj)
  58 {
  59     if (!list_p(obj)) {
  60         return wrong_argument_type(gc, "listp", obj);
  61     }
  62
  63     return eval_success(NUMBER(gc, length_of_list(obj)));
  64 }
  65
  66 static struct EvalResult eval_atom(Gc *gc, struct Scope *scope, struct Atom *atom)
  67 {
  68     (void) scope;
  69     (void) gc;
  70
  71     switch (atom->type) {
  72     case ATOM_NUMBER:
  73     case ATOM_STRING:
  74     case ATOM_NATIVE:
  75         return eval_success(atom_as_expr(atom));
  76
  77     case ATOM_SYMBOL: {
  78         struct Expr value = get_scope_value(scope, atom_as_expr(atom));
  79
  80         if (nil_p(value)) {
  81             return eval_failure(CONS(gc,
  82                                      SYMBOL(gc, "void-variable"),
  83                                      atom_as_expr(atom)));
  84         }
  85
  86         return eval_success(value.cons->cdr);
  87     }
  88     }
  89
  90     return eval_failure(CONS(gc,
  91                              SYMBOL(gc, "unexpected-expression"),
  92                              atom_as_expr(atom)));
  93 }
  94
  95 static struct EvalResult eval_all_args(Gc *gc, struct Scope *scope, struct Expr args)
  96 {
  97     (void) scope;
  98     (void) args;
  99
 100     switch(args.type) {
 101     case EXPR_ATOM:
 102         return eval_atom(gc, scope, args.atom);
 103
 104     case EXPR_CONS: {
 105         struct EvalResult car = eval(gc, scope, args.cons->car);
 106         if (car.is_error) {
 107             return car;
 108         }
 109
 110         struct EvalResult cdr = eval_all_args(gc, scope, args.cons->cdr);
 111         if (cdr.is_error) {
 112             return cdr;
 113         }
 114
 115         return eval_success(cons_as_expr(create_cons(gc, car.expr, cdr.expr)));
 116     }
 117
 118     default: {}
 119     }
 120
 121     return eval_failure(CONS(gc,
 122                              SYMBOL(gc, "unexpected-expression"),
 123                              args));
 124 }
 125
 126 static struct EvalResult
 127 assoc_op(void *param, Gc *gc, struct Scope *scope, struct Expr args)
 128 {
 129     (void) param;
 130     assert(gc);
 131     assert(scope);
 132
 133     struct Expr key = NIL(gc);
 134     struct Expr alist = NIL(gc);
 135     struct EvalResult result = match_list(gc, "ee", args, &key, &alist);
 136     if (result.is_error) {
 137         return result;
 138     }
 139
 140     return eval_success(assoc(key, alist));
 141 }
 142
 143 static struct EvalResult
 144 plus_op(void *param, Gc *gc, struct Scope *scope, struct Expr args)
 145 {
 146     (void) param;
 147     assert(gc);
 148     assert(scope);
 149
 150     long int result = 0L;
 151
 152     while (!nil_p(args)) {
 153         if (!cons_p(args)) {
 154             return wrong_argument_type(gc, "consp", args);
 155         }
 156
 157         if (!number_p(CAR(args))) {
 158             return wrong_argument_type(gc, "numberp", CAR(args));
 159         }
 160
 161         result += CAR(args).atom->num;
 162         args = CDR(args);
 163     }
 164
 165     return eval_success(NUMBER(gc, result));
 166 }
 167
 168 static struct EvalResult call_lambda(Gc *gc,
 169                                      struct Scope *scope,
 170                                      struct Expr lambda,
 171                                      struct Expr args) {
 172     if (!lambda_p(lambda)) {
 173         return eval_failure(CONS(gc,
 174                                  SYMBOL(gc, "expected-callable"),
 175                                  lambda));
 176     }
 177
 178     if (!list_p(args)) {
 179         return eval_failure(CONS(gc,
 180                                  SYMBOL(gc, "expected-list"),
 181                                  args));
 182     }
 183
 184     struct Expr vars = lambda.cons->cdr.cons->car;
 185
 186     if (length_of_list(args) != length_of_list(vars)) {
 187         return eval_failure(CONS(gc,
 188                                  SYMBOL(gc, "wrong-number-of-arguments"),
 189                                  NUMBER(gc, length_of_list(args))));
 190     }
 191
 192     push_scope_frame(gc, scope, vars, args);
 193     struct Expr body = lambda.cons->cdr.cons->cdr;
 194
 195     struct EvalResult result = eval_success(NIL(gc));
 196
 197     while (!nil_p(body)) {
 198         result = eval(gc, scope, body.cons->car);
 199         if (result.is_error) {
 200             return result;
 201         }
 202         body = body.cons->cdr;
 203     }
 204
 205     pop_scope_frame(gc, scope);
 206
 207     return result;
 208 }
 209
 210 static struct EvalResult call_callable(Gc *gc,
 211                                        struct Scope *scope,
 212                                        struct Expr callable_expr,
 213                                        struct Expr args_expr) {
 214     struct EvalResult callable_result = eval(gc, scope, callable_expr);
 215     if (callable_result.is_error) {
 216         return callable_result;
 217     }
 218
 219     struct EvalResult args_result = symbol_p(callable_expr) && is_special(callable_expr.atom->sym)
 220         ? eval_success(args_expr)
 221         : eval_all_args(gc, scope, args_expr);
 222
 223     if (args_result.is_error) {
 224         return args_result;
 225     }
 226
 227     if (callable_result.expr.type == EXPR_ATOM &&
 228         callable_result.expr.atom->type == ATOM_NATIVE) {
 229         return ((NativeFunction)callable_result.expr.atom->native.fun)(
 230             callable_result.expr.atom->native.param, gc, scope, args_result.expr);
 231     }
 232
 233     return call_lambda(gc, scope, callable_result.expr, args_result.expr);
 234 }
 235
 236 static struct Expr
 237 lambda(Gc *gc, struct Expr args, struct Expr body)
 238 {
 239     return CONS(gc,
 240                 SYMBOL(gc, "lambda"),
 241                 CONS(gc, args, body));
 242 }
 243
 244 static struct EvalResult eval_block(Gc *gc, struct Scope *scope, struct Expr block)
 245 {
 246     assert(gc);
 247     assert(scope);
 248
 249     if (!list_p(block)) {
 250         return wrong_argument_type(gc, "listp", block);
 251     }
 252
 253     struct Expr head = block;
 254     struct EvalResult eval_result = eval_success(NIL(gc));
 255
 256     while (cons_p(head)) {
 257         eval_result = eval(gc, scope, CAR(head));
 258         if (eval_result.is_error) {
 259             return eval_result;
 260         }
 261
 262         head = CDR(head);
 263     }
 264
 265     return eval_result;
 266 }
 267
 268 static struct EvalResult eval_funcall(Gc *gc, struct Scope *scope, struct Cons *cons)
 269 {
 270     assert(cons);
 271     (void) scope;
 272
 273     if (symbol_p(cons->car)) {
 274         /* TODO(#580): eval_funcall contains some special forms that are not native function of stdlib */
 275         if (strcmp(cons->car.atom->sym, "set") == 0) {
 276             struct Expr args = cons->cdr;
 277             struct EvalResult n = length(gc, args);
 278
 279             if (n.is_error) {
 280                 return n;
 281             }
 282
 283             if (n.expr.atom->num != 2) {
 284                 return eval_failure(list(gc, 3,
 285                                          SYMBOL(gc, "wrong-number-of-arguments"),
 286                                          SYMBOL(gc, "set"),
 287                                          NUMBER(gc, n.expr.atom->num)));
 288             }
 289
 290             struct Expr name = args.cons->car;
 291             if (!symbol_p(name)) {
 292                 return eval_failure(list(gc, 3,
 293                                          SYMBOL(gc, "wrong-type-argument"),
 294                                          SYMBOL(gc, "symbolp"),
 295                                          name));
 296             }
 297
 298             struct EvalResult value = eval(gc, scope, args.cons->cdr.cons->car);
 299             if (value.is_error) {
 300                 return value;
 301             }
 302
 303             set_scope_value(gc, scope, name, value.expr);
 304
 305             return eval_success(value.expr);
 306         } else if (strcmp(cons->car.atom->sym, "quote") == 0) {
 307             /* TODO(#334): quote does not check the amout of it's arguments */
 308             return eval_success(cons->cdr.cons->car);
 309         } else if (strcmp(cons->car.atom->sym, "begin") == 0) {
 310             return eval_block(gc, scope, CDR(cons_as_expr(cons)));
 311         } else if (is_lambda(cons)) {
 312             /* TODO(#335): lambda special form doesn't check if it forms a callable object */
 313             return eval_success(cons_as_expr(cons));
 314         } else if (strcmp(cons->car.atom->sym, "defun") == 0) {
 315             struct Expr name = NIL(gc);
 316             struct Expr args = NIL(gc);
 317             struct Expr body = NIL(gc);
 318
 319             /* TODO(#554): defun doesn't support functions with empty body because of #545 */
 320             struct EvalResult result = match_list(gc, "ee*", cons->cdr, &name, &args, &body);
 321             if (result.is_error) {
 322                 return result;
 323             }
 324
 325             return eval(gc, scope,
 326                         list(gc, 3,
 327                              SYMBOL(gc, "set"),
 328                              name,
 329                              lambda(gc, args, body)));
 330         } else if (strcmp(cons->car.atom->sym, "when") == 0) {
 331             struct Expr condition = NIL(gc);
 332             struct Expr body = NIL(gc);
 333
 334             struct EvalResult result = match_list(
 335                 gc, "e*", cons->cdr, &condition, &body);
 336             if (result.is_error) {
 337                 return result;
 338             }
 339
 340             result = eval(gc, scope, condition);
 341             if (result.is_error) {
 342                 return result;
 343             }
 344
 345             if (!nil_p(result.expr)) {
 346                 return eval_block(gc, scope, body);
 347             }
 348
 349             return eval_success(NIL(gc));
 350         }
 351     }
 352
 353     return call_callable(gc, scope, cons->car, cons->cdr);
 354 }
 355
 356 struct EvalResult eval(Gc *gc, struct Scope *scope, struct Expr expr)
 357 {
 358     switch(expr.type) {
 359     case EXPR_ATOM:
 360         return eval_atom(gc, scope, expr.atom);
 361
 362     case EXPR_CONS:
 363         return eval_funcall(gc, scope, expr.cons);
 364
 365     default: {}
 366     }
 367
 368     return eval_failure(CONS(gc,
 369                              SYMBOL(gc, "unexpected-expression"),
 370                              expr));
 371 }
 372
 373 struct EvalResult
 374 car(void *param, Gc *gc, struct Scope *scope, struct Expr args)
 375 {
 376     (void) param;
 377     assert(gc);
 378     assert(scope);
 379
 380     struct Expr xs = NIL(gc);
 381
 382     struct EvalResult result = match_list(gc, "e", args, &xs);
 383     if (result.is_error) {
 384         return result;
 385     }
 386
 387     if (nil_p(xs)) {
 388         return eval_success(xs);
 389     }
 390
 391     if (!cons_p(xs)) {
 392         return wrong_argument_type(gc, "consp", xs);
 393     }
 394
 395     return eval_success(CAR(xs));
 396 }
 397
 398 static struct EvalResult
 399 list_op(void *param, Gc *gc, struct Scope *scope, struct Expr args)
 400 {
 401     assert(gc);
 402     assert(scope);
 403     (void) param;
 404
 405     return eval_success(args);
 406 }
 407
 408 /* TODO(#536): greaterThan does not support arbitrary amount of arguments */
 409 static struct EvalResult
 410 greaterThan(void *param, Gc *gc, struct Scope *scope, struct Expr args)
 411 {
 412     assert(gc);
 413     assert(scope);
 414     (void) param;
 415
 416     long int x = 0, y = 0;
 417
 418     struct EvalResult result = match_list(gc, "dd", args, &x, &y);
 419     if (result.is_error) {
 420         return result;
 421     }
 422
 423     if (x > y) {
 424         return eval_success(T(gc));
 425     } else {
 426         return eval_success(NIL(gc));
 427     }
 428 }
 429
 430 static struct EvalResult
 431 quasiquote(void *param, Gc *gc, struct Scope *scope, struct Expr expr)
 432 {
 433     (void) param;
 434     assert(gc);
 435     assert(scope);
 436     (void) expr;
 437
 438     /* TODO(#582): quasiquote special form is not implemented */
 439
 440     return not_implemented(gc);
 441 }
 442
 443 void load_std_library(Gc *gc, struct Scope *scope)
 444 {
 445     set_scope_value(
 446         gc,
 447         scope,
 448         SYMBOL(gc, "car"),
 449         NATIVE(gc, car, NULL));
 450     set_scope_value(
 451         gc,
 452         scope,
 453         SYMBOL(gc, ">"),
 454         NATIVE(gc, greaterThan, NULL));
 455     set_scope_value(
 456         gc,
 457         scope,
 458         SYMBOL(gc, "+"),
 459         NATIVE(gc, plus_op, NULL));
 460     set_scope_value(
 461         gc,
 462         scope,
 463         SYMBOL(gc, "list"),
 464         NATIVE(gc, list_op, NULL));
 465     set_scope_value(
 466         gc,
 467         scope,
 468         SYMBOL(gc, "t"),
 469         SYMBOL(gc, "t"));
 470     set_scope_value(
 471         gc,
 472         scope,
 473         SYMBOL(gc, "nil"),
 474         SYMBOL(gc, "nil"));
 475     set_scope_value(
 476         gc,
 477         scope,
 478         SYMBOL(gc, "assoc"),
 479         NATIVE(gc, assoc_op, NULL));
 480     set_scope_value(
 481         gc,
 482         scope,
 483         SYMBOL(gc, "quasiquote"),
 484         NATIVE(gc, quasiquote, NULL));
 485 }
 486
 487 struct EvalResult
 488 match_list(struct Gc *gc, const char *format, struct Expr xs, ...)
 489 {
 490     va_list args_list;
 491     va_start(args_list, xs);
 492
 493     long int i = 0;
 494     for (i = 0; *format != 0 && !nil_p(xs); ++i) {
 495         if (!cons_p(xs)) {
 496             va_end(args_list);
 497             return wrong_argument_type(gc, "consp", xs);
 498         }
 499
 500         struct Expr x = CAR(xs);
 501
 502         switch (*format) {
 503         case 'd': {
 504             if (!number_p(x)) {
 505                 va_end(args_list);
 506                 return wrong_argument_type(gc, "numberp", x);
 507             }
 508
 509             long int *p = va_arg(args_list, long int *);
 510             if (p != NULL) {
 511                 *p = x.atom->num;
 512             }
 513         } break;
 514
 515         case 's': {
 516             if (!string_p(x)) {
 517                 va_end(args_list);
 518                 return wrong_argument_type(gc, "stringp", x);
 519             }
 520
 521             const char **p = va_arg(args_list, const char**);
 522             if (p != NULL) {
 523                 *p = x.atom->str;
 524             }
 525         } break;
 526
 527         case 'q': {
 528             if (!symbol_p(x)) {
 529                 va_end(args_list);
 530                 return wrong_argument_type(gc, "symbolp", x);
 531             }
 532
 533             const char **p = va_arg(args_list, const char**);
 534             if (p != NULL) {
 535                 *p = x.atom->sym;
 536             }
 537         } break;
 538
 539         case 'e': {
 540             struct Expr *p = va_arg(args_list, struct Expr*);
 541             *p = x;
 542         } break;
 543
 544         case '*': {
 545             struct Expr *p = va_arg(args_list, struct Expr*);
 546             if (p != NULL) {
 547                 *p = xs;
 548             }
 549             xs = NIL(gc);
 550         } break;
 551         }
 552
 553         format++;
 554         if (!nil_p(xs)) {
 555             xs = CDR(xs);
 556         }
 557     }
 558
 559     if (*format == '*' && nil_p(xs)) {
 560         struct Expr *p = va_arg(args_list, struct Expr*);
 561         if (p != NULL) {
 562             *p = NIL(gc);
 563         }
 564         format++;
 565     }
 566
 567     if (*format != 0 || !nil_p(xs)) {
 568         va_end(args_list);
 569         return wrong_number_of_arguments(gc, i);
 570     }
 571
 572     va_end(args_list);
 573     return eval_success(NIL(gc));
 574 }
 575
 576 static struct Expr
 577 format_list_rec(Gc *gc, const char *format, va_list args)
 578 {
 579     assert(gc);
 580     assert(format);
 581
 582     if (*format == 0) {
 583         return NIL(gc);
 584     }
 585
 586     switch (*format) {
 587     case 'd': {
 588         long int p = va_arg(args, long int);
 589         return CONS(gc, NUMBER(gc, p),
 590                     format_list_rec(gc, format + 1, args));
 591     }
 592
 593     case 's': {
 594         const char* p = va_arg(args, const char*);
 595         return CONS(gc, STRING(gc, p),
 596                     format_list_rec(gc, format + 1, args));
 597     }
 598
 599     case 'q': {
 600         const char* p = va_arg(args, const char*);
 601         return CONS(gc, SYMBOL(gc, p),
 602                     format_list_rec(gc, format + 1, args));
 603     }
 604
 605     case 'e': {
 606         struct Expr p = va_arg(args, struct Expr);
 607         return CONS(gc, p, format_list_rec(gc, format + 1, args));
 608     }
 609
 610     default: {
 611         fprintf(stderr, "Wrong format parameter: %c\n", *format);
 612         assert(0);
 613     }
 614     }
 615 }
 616
 617 struct Expr
 618 format_list(Gc *gc, const char *format, ...)
 619 {
 620     va_list args;
 621     va_start(args, format);
 622     struct Expr result = format_list_rec(gc, format, args);
 623     va_end(args);
 624
 625     return result;
 626 }