参考

{% collapse title=”strings.c” %}

  1. #include "mpc.h"
  3. #ifdef _WIN32
  5. static char buffer[2048];
  7. char* readline(char* prompt) {
  8.   fputs(prompt, stdout);
  9.   fgets(buffer, 2048, stdin);
  10.   char* cpy = malloc(strlen(buffer)+1);
  11.   strcpy(cpy, buffer);
  12.   cpy[strlen(cpy)-1] = '\0';
  13.   return cpy;
  14. }
  16. void add_history(char* unused) {}
  18. #else
  19. #include <editline/readline.h>
  20. #include <editline/history.h>
  21. #endif
  23. /* Parser Declariations */
  25. mpc_parser_t* Number; 
  26. mpc_parser_t* Symbol; 
  27. mpc_parser_t* String; 
  28. mpc_parser_t* Comment;
  29. mpc_parser_t* Sexpr;  
  30. mpc_parser_t* Qexpr;  
  31. mpc_parser_t* Expr; 
  32. mpc_parser_t* Lispy;
  34. /* Forward Declarations */
  36. struct lval;
  37. struct lenv;
  38. typedef struct lval lval;
  39. typedef struct lenv lenv;
  41. /* Lisp Value */
  43. enum { LVAL_ERR, LVAL_NUM,   LVAL_SYM, LVAL_STR, 
  44.        LVAL_FUN, LVAL_SEXPR, LVAL_QEXPR };
  46. typedef lval*(*lbuiltin)(lenv*, lval*);
  48. struct lval {
  49.   int type;
  51.   /* Basic */
  52.   long num;
  53.   char* err;
  54.   char* sym;
  55.   char* str;
  57.   /* Function */
  58.   lbuiltin builtin;
  59.   lenv* env;
  60.   lval* formals;
  61.   lval* body;
  63.   /* Expression */
  64.   int count;
  65.   lval** cell;
  66. };
  68. lval* lval_num(long x) {
  69.   lval* v = malloc(sizeof(lval));
  70.   v->type = LVAL_NUM;
  71.   v->num = x;
  72.   return v;
  73. }
  75. lval* lval_err(char* fmt, ...) {
  76.   lval* v = malloc(sizeof(lval));
  77.   v->type = LVAL_ERR;  
  78.   va_list va;
  79.   va_start(va, fmt);  
  80.   v->err = malloc(512);  
  81.   vsnprintf(v->err, 511, fmt, va);  
  82.   v->err = realloc(v->err, strlen(v->err)+1);
  83.   va_end(va);  
  84.   return v;
  85. }
  87. lval* lval_sym(char* s) {
  88.   lval* v = malloc(sizeof(lval));
  89.   v->type = LVAL_SYM;
  90.   v->sym = malloc(strlen(s) + 1);
  91.   strcpy(v->sym, s);
  92.   return v;
  93. }
  95. lval* lval_str(char* s) {
  96.   lval* v = malloc(sizeof(lval));
  97.   v->type = LVAL_STR;
  98.   v->str = malloc(strlen(s) + 1);
  99.   strcpy(v->str, s);
  100.   return v;
  101. }
  103. lval* lval_builtin(lbuiltin func) {
  104.   lval* v = malloc(sizeof(lval));
  105.   v->type = LVAL_FUN;
  106.   v->builtin = func;
  107.   return v;
  108. }
  110. lenv* lenv_new(void);
  112. lval* lval_lambda(lval* formals, lval* body) {
  113.   lval* v = malloc(sizeof(lval));
  114.   v->type = LVAL_FUN;  
  115.   v->builtin = NULL;  
  116.   v->env = lenv_new();  
  117.   v->formals = formals;
  118.   v->body = body;
  119.   return v;  
  120. }
  122. lval* lval_sexpr(void) {
  123.   lval* v = malloc(sizeof(lval));
  124.   v->type = LVAL_SEXPR;
  125.   v->count = 0;
  126.   v->cell = NULL;
  127.   return v;
  128. }
  130. lval* lval_qexpr(void) {
  131.   lval* v = malloc(sizeof(lval));
  132.   v->type = LVAL_QEXPR;
  133.   v->count = 0;
  134.   v->cell = NULL;
  135.   return v;
  136. }
  138. void lenv_del(lenv* e);
  140. void lval_del(lval* v) {
  142.   switch (v->type) {
  143.     case LVAL_NUM: break;
  144.     case LVAL_FUN: 
  145.       if (!v->builtin) {
  146.         lenv_del(v->env);
  147.         lval_del(v->formals);
  148.         lval_del(v->body);
  149.       }
  150.     break;
  151.     case LVAL_ERR: free(v->err); break;
  152.     case LVAL_SYM: free(v->sym); break;
  153.     case LVAL_STR: free(v->str); break;
  154.     case LVAL_QEXPR:
  155.     case LVAL_SEXPR:
  156.       for (int i = 0; i < v->count; i++) {
  157.         lval_del(v->cell[i]);
  158.       }
  159.       free(v->cell);
  160.     break;
  161.   }
  163.   free(v);
  164. }
  166. lenv* lenv_copy(lenv* e);
  168. lval* lval_copy(lval* v) {
  169.   lval* x = malloc(sizeof(lval));
  170.   x->type = v->type;
  171.   switch (v->type) {
  172.     case LVAL_FUN:
  173.       if (v->builtin) {
  174.         x->builtin = v->builtin;
  175.       } else {
  176.         x->builtin = NULL;
  177.         x->env = lenv_copy(v->env);
  178.         x->formals = lval_copy(v->formals);
  179.         x->body = lval_copy(v->body);
  180.       }
  181.     break;
  182.     case LVAL_NUM: x->num = v->num; break;
  183.     case LVAL_ERR: x->err = malloc(strlen(v->err) + 1);
  184.       strcpy(x->err, v->err);
  185.     break;
  186.     case LVAL_SYM: x->sym = malloc(strlen(v->sym) + 1);
  187.       strcpy(x->sym, v->sym);
  188.     break;
  189.     case LVAL_STR: x->str = malloc(strlen(v->str) + 1);
  190.       strcpy(x->str, v->str);
  191.     break;
  192.     case LVAL_SEXPR:
  193.     case LVAL_QEXPR:
  194.       x->count = v->count;
  195.       x->cell = malloc(sizeof(lval*) * x->count);
  196.       for (int i = 0; i < x->count; i++) {
  197.         x->cell[i] = lval_copy(v->cell[i]);
  198.       }
  199.     break;
  200.   }
  201.   return x;
  202. }
  204. lval* lval_add(lval* v, lval* x) {
  205.   v->count++;
  206.   v->cell = realloc(v->cell, sizeof(lval*) * v->count);
  207.   v->cell[v->count-1] = x;
  208.   return v;
  209. }
  211. lval* lval_join(lval* x, lval* y) {  
  212.   for (int i = 0; i < y->count; i++) {
  213.     x = lval_add(x, y->cell[i]);
  214.   }
  215.   free(y->cell);
  216.   free(y);  
  217.   return x;
  218. }
  220. lval* lval_pop(lval* v, int i) {
  221.   lval* x = v->cell[i];  
  222.   memmove(&v->cell[i],
  223.     &v->cell[i+1], sizeof(lval*) * (v->count-i-1));  
  224.   v->count--;  
  225.   v->cell = realloc(v->cell, sizeof(lval*) * v->count);
  226.   return x;
  227. }
  229. lval* lval_take(lval* v, int i) {
  230.   lval* x = lval_pop(v, i);
  231.   lval_del(v);
  232.   return x;
  233. }
  235. void lval_print(lval* v);
  237. void lval_print_expr(lval* v, char open, char close) {
  238.   putchar(open);
  239.   for (int i = 0; i < v->count; i++) {
  240.     lval_print(v->cell[i]);    
  241.     if (i != (v->count-1)) {
  242.       putchar(' ');
  243.     }
  244.   }
  245.   putchar(close);
  246. }
  248. void lval_print_str(lval* v) {
  249.   /* Make a Copy of the string */
  250.   char* escaped = malloc(strlen(v->str)+1);
  251.   strcpy(escaped, v->str);
  252.   /* Pass it through the escape function */
  253.   escaped = mpcf_escape(escaped);
  254.   /* Print it between " characters */
  255.   printf("\"%s\"", escaped);
  256.   /* free the copied string */
  257.   free(escaped);
  258. }
  260. void lval_print(lval* v) {
  261.   switch (v->type) {
  262.     case LVAL_FUN:
  263.       if (v->builtin) {
  264.         printf("<builtin>");
  265.       } else {
  266.         printf("(\\ ");
  267.         lval_print(v->formals);
  268.         putchar(' ');
  269.         lval_print(v->body);
  270.         putchar(')');
  271.       }
  272.     break;
  273.     case LVAL_NUM:   printf("%li", v->num); break;
  274.     case LVAL_ERR:   printf("Error: %s", v->err); break;
  275.     case LVAL_SYM:   printf("%s", v->sym); break;
  276.     case LVAL_STR:   lval_print_str(v); break;
  277.     case LVAL_SEXPR: lval_print_expr(v, '(', ')'); break;
  278.     case LVAL_QEXPR: lval_print_expr(v, '{', '}'); break;
  279.   }
  280. }
  282. void lval_println(lval* v) { lval_print(v); putchar('\n'); }
  284. int lval_eq(lval* x, lval* y) {
  286.   if (x->type != y->type) { return 0; }
  288.   switch (x->type) {
  289.     case LVAL_NUM: return (x->num == y->num);    
  290.     case LVAL_ERR: return (strcmp(x->err, y->err) == 0);
  291.     case LVAL_SYM: return (strcmp(x->sym, y->sym) == 0);    
  292.     case LVAL_STR: return (strcmp(x->str, y->str) == 0);    
  293.     case LVAL_FUN: 
  294.       if (x->builtin || y->builtin) {
  295.         return x->builtin == y->builtin;
  296.       } else {
  297.         return lval_eq(x->formals, y->formals) && lval_eq(x->body, y->body);
  298.       }    
  299.     case LVAL_QEXPR:
  300.     case LVAL_SEXPR:
  301.       if (x->count != y->count) { return 0; }
  302.       for (int i = 0; i < x->count; i++) {
  303.         if (!lval_eq(x->cell[i], y->cell[i])) { return 0; }
  304.       }
  305.       return 1;
  306.     break;
  307.   }
  308.   return 0;
  309. }
  311. char* ltype_name(int t) {
  312.   switch(t) {
  313.     case LVAL_FUN: return "Function";
  314.     case LVAL_NUM: return "Number";
  315.     case LVAL_ERR: return "Error";
  316.     case LVAL_SYM: return "Symbol";
  317.     case LVAL_STR: return "String";
  318.     case LVAL_SEXPR: return "S-Expression";
  319.     case LVAL_QEXPR: return "Q-Expression";
  320.     default: return "Unknown";
  321.   }
  322. }
  324. /* Lisp Environment */
  326. struct lenv {
  327.   lenv* par;
  328.   int count;
  329.   char** syms;
  330.   lval** vals;
  331. };
  333. lenv* lenv_new(void) {
  334.   lenv* e = malloc(sizeof(lenv));
  335.   e->par = NULL;
  336.   e->count = 0;
  337.   e->syms = NULL;
  338.   e->vals = NULL;
  339.   return e;
  340. }
  342. void lenv_del(lenv* e) {
  343.   for (int i = 0; i < e->count; i++) {
  344.     free(e->syms[i]);
  345.     lval_del(e->vals[i]);
  346.   }  
  347.   free(e->syms);
  348.   free(e->vals);
  349.   free(e);
  350. }
  352. lenv* lenv_copy(lenv* e) {
  353.   lenv* n = malloc(sizeof(lenv));
  354.   n->par = e->par;
  355.   n->count = e->count;
  356.   n->syms = malloc(sizeof(char*) * n->count);
  357.   n->vals = malloc(sizeof(lval*) * n->count);
  358.   for (int i = 0; i < e->count; i++) {
  359.     n->syms[i] = malloc(strlen(e->syms[i]) + 1);
  360.     strcpy(n->syms[i], e->syms[i]);
  361.     n->vals[i] = lval_copy(e->vals[i]);
  362.   }
  363.   return n;
  364. }
  366. lval* lenv_get(lenv* e, lval* k) {
  368.   for (int i = 0; i < e->count; i++) {
  369.     if (strcmp(e->syms[i], k->sym) == 0) { return lval_copy(e->vals[i]); }
  370.   }
  372.   if (e->par) {
  373.     return lenv_get(e->par, k);
  374.   } else {
  375.     return lval_err("Unbound Symbol '%s'", k->sym);
  376.   }
  377. }
  379. void lenv_put(lenv* e, lval* k, lval* v) {
  381.   for (int i = 0; i < e->count; i++) {
  382.     if (strcmp(e->syms[i], k->sym) == 0) {
  383.       lval_del(e->vals[i]);
  384.       e->vals[i] = lval_copy(v);
  385.       return;
  386.     }
  387.   }
  389.   e->count++;
  390.   e->vals = realloc(e->vals, sizeof(lval*) * e->count);
  391.   e->syms = realloc(e->syms, sizeof(char*) * e->count);  
  392.   e->vals[e->count-1] = lval_copy(v);
  393.   e->syms[e->count-1] = malloc(strlen(k->sym)+1);
  394.   strcpy(e->syms[e->count-1], k->sym);
  395. }
  397. void lenv_def(lenv* e, lval* k, lval* v) {
  398.   while (e->par) { e = e->par; }
  399.   lenv_put(e, k, v);
  400. }
  402. /* Builtins */
  404. #define LASSERT(args, cond, fmt, ...) \
  405.   if (!(cond)) { lval* err = lval_err(fmt, ##__VA_ARGS__); lval_del(args); return err; }
  407. #define LASSERT_TYPE(func, args, index, expect) \
  408.   LASSERT(args, args->cell[index]->type == expect, \
  409.     "Function '%s' passed incorrect type for argument %i. Got %s, Expected %s.", \
  410.     func, index, ltype_name(args->cell[index]->type), ltype_name(expect))
  412. #define LASSERT_NUM(func, args, num) \
  413.   LASSERT(args, args->count == num, \
  414.     "Function '%s' passed incorrect number of arguments. Got %i, Expected %i.", \
  415.     func, args->count, num)
  417. #define LASSERT_NOT_EMPTY(func, args, index) \
  418.   LASSERT(args, args->cell[index]->count != 0, \
  419.     "Function '%s' passed {} for argument %i.", func, index);
  421. lval* lval_eval(lenv* e, lval* v);
  423. lval* builtin_lambda(lenv* e, lval* a) {
  424.   LASSERT_NUM("\\", a, 2);
  425.   LASSERT_TYPE("\\", a, 0, LVAL_QEXPR);
  426.   LASSERT_TYPE("\\", a, 1, LVAL_QEXPR);
  428.   for (int i = 0; i < a->cell[0]->count; i++) {
  429.     LASSERT(a, (a->cell[0]->cell[i]->type == LVAL_SYM),
  430.       "Cannot define non-symbol. Got %s, Expected %s.",
  431.       ltype_name(a->cell[0]->cell[i]->type), ltype_name(LVAL_SYM));
  432.   }
  434.   lval* formals = lval_pop(a, 0);
  435.   lval* body = lval_pop(a, 0);
  436.   lval_del(a);
  438.   return lval_lambda(formals, body);
  439. }
  441. lval* builtin_list(lenv* e, lval* a) {
  442.   a->type = LVAL_QEXPR;
  443.   return a;
  444. }
  446. lval* builtin_head(lenv* e, lval* a) {
  447.   LASSERT_NUM("head", a, 1);
  448.   LASSERT_TYPE("head", a, 0, LVAL_QEXPR);
  449.   LASSERT_NOT_EMPTY("head", a, 0);
  451.   lval* v = lval_take(a, 0);  
  452.   while (v->count > 1) { lval_del(lval_pop(v, 1)); }
  453.   return v;
  454. }
  456. lval* builtin_tail(lenv* e, lval* a) {
  457.   LASSERT_NUM("tail", a, 1);
  458.   LASSERT_TYPE("tail", a, 0, LVAL_QEXPR);
  459.   LASSERT_NOT_EMPTY("tail", a, 0);
  461.   lval* v = lval_take(a, 0);  
  462.   lval_del(lval_pop(v, 0));
  463.   return v;
  464. }
  466. lval* builtin_eval(lenv* e, lval* a) {
  467.   LASSERT_NUM("eval", a, 1);
  468.   LASSERT_TYPE("eval", a, 0, LVAL_QEXPR);
  470.   lval* x = lval_take(a, 0);
  471.   x->type = LVAL_SEXPR;
  472.   return lval_eval(e, x);
  473. }
  475. lval* builtin_join(lenv* e, lval* a) {
  477.   for (int i = 0; i < a->count; i++) {
  478.     LASSERT_TYPE("join", a, i, LVAL_QEXPR);
  479.   }
  481.   lval* x = lval_pop(a, 0);
  483.   while (a->count) {
  484.     lval* y = lval_pop(a, 0);
  485.     x = lval_join(x, y);
  486.   }
  488.   lval_del(a);
  489.   return x;
  490. }
  492. lval* builtin_op(lenv* e, lval* a, char* op) {
  494.   for (int i = 0; i < a->count; i++) {
  495.     LASSERT_TYPE(op, a, i, LVAL_NUM);
  496.   }
  498.   lval* x = lval_pop(a, 0);
  500.   if ((strcmp(op, "-") == 0) && a->count == 0) { x->num = -x->num; }
  502.   while (a->count > 0) {  
  503.     lval* y = lval_pop(a, 0);
  505.     if (strcmp(op, "+") == 0) { x->num += y->num; }
  506.     if (strcmp(op, "-") == 0) { x->num -= y->num; }
  507.     if (strcmp(op, "*") == 0) { x->num *= y->num; }
  508.     if (strcmp(op, "/") == 0) {
  509.       if (y->num == 0) {
  510.         lval_del(x); lval_del(y);
  511.         x = lval_err("Division By Zero.");
  512.         break;
  513.       }
  514.       x->num /= y->num;
  515.     }
  517.     lval_del(y);
  518.   }
  520.   lval_del(a);
  521.   return x;
  522. }
  524. lval* builtin_add(lenv* e, lval* a) { return builtin_op(e, a, "+"); }
  525. lval* builtin_sub(lenv* e, lval* a) { return builtin_op(e, a, "-"); }
  526. lval* builtin_mul(lenv* e, lval* a) { return builtin_op(e, a, "*"); }
  527. lval* builtin_div(lenv* e, lval* a) { return builtin_op(e, a, "/"); }
  529. lval* builtin_var(lenv* e, lval* a, char* func) {
  530.   LASSERT_TYPE(func, a, 0, LVAL_QEXPR);
  532.   lval* syms = a->cell[0];
  533.   for (int i = 0; i < syms->count; i++) {
  534.     LASSERT(a, (syms->cell[i]->type == LVAL_SYM),
  535.       "Function '%s' cannot define non-symbol. "
  536.       "Got %s, Expected %s.",
  537.       func, ltype_name(syms->cell[i]->type), ltype_name(LVAL_SYM));
  538.   }
  540.   LASSERT(a, (syms->count == a->count-1),
  541.     "Function '%s' passed too many arguments for symbols. "
  542.     "Got %i, Expected %i.",
  543.     func, syms->count, a->count-1);
  545.   for (int i = 0; i < syms->count; i++) {
  546.     if (strcmp(func, "def") == 0) { lenv_def(e, syms->cell[i], a->cell[i+1]); }
  547.     if (strcmp(func, "=")   == 0) { lenv_put(e, syms->cell[i], a->cell[i+1]); } 
  548.   }
  550.   lval_del(a);
  551.   return lval_sexpr();
  552. }
  554. lval* builtin_def(lenv* e, lval* a) { return builtin_var(e, a, "def"); }
  555. lval* builtin_put(lenv* e, lval* a) { return builtin_var(e, a, "="); }
  557. lval* builtin_ord(lenv* e, lval* a, char* op) {
  558.   LASSERT_NUM(op, a, 2);
  559.   LASSERT_TYPE(op, a, 0, LVAL_NUM);
  560.   LASSERT_TYPE(op, a, 1, LVAL_NUM);
  562.   int r;
  563.   if (strcmp(op, ">")  == 0) { r = (a->cell[0]->num >  a->cell[1]->num); }
  564.   if (strcmp(op, "<")  == 0) { r = (a->cell[0]->num <  a->cell[1]->num); }
  565.   if (strcmp(op, ">=") == 0) { r = (a->cell[0]->num >= a->cell[1]->num); }
  566.   if (strcmp(op, "<=") == 0) { r = (a->cell[0]->num <= a->cell[1]->num); }
  567.   lval_del(a);
  568.   return lval_num(r);
  569. }
  571. lval* builtin_gt(lenv* e, lval* a) { return builtin_ord(e, a, ">");  }
  572. lval* builtin_lt(lenv* e, lval* a) { return builtin_ord(e, a, "<");  }
  573. lval* builtin_ge(lenv* e, lval* a) { return builtin_ord(e, a, ">="); }
  574. lval* builtin_le(lenv* e, lval* a) { return builtin_ord(e, a, "<="); }
  576. lval* builtin_cmp(lenv* e, lval* a, char* op) {
  577.   LASSERT_NUM(op, a, 2);
  578.   int r;
  579.   if (strcmp(op, "==") == 0) { r =  lval_eq(a->cell[0], a->cell[1]); }
  580.   if (strcmp(op, "!=") == 0) { r = !lval_eq(a->cell[0], a->cell[1]); }
  581.   lval_del(a);
  582.   return lval_num(r);
  583. }
  585. lval* builtin_eq(lenv* e, lval* a) { return builtin_cmp(e, a, "=="); }
  586. lval* builtin_ne(lenv* e, lval* a) { return builtin_cmp(e, a, "!="); }
  588. lval* builtin_if(lenv* e, lval* a) {
  589.   LASSERT_NUM("if", a, 3);
  590.   LASSERT_TYPE("if", a, 0, LVAL_NUM);
  591.   LASSERT_TYPE("if", a, 1, LVAL_QEXPR);
  592.   LASSERT_TYPE("if", a, 2, LVAL_QEXPR);
  594.   lval* x;
  595.   a->cell[1]->type = LVAL_SEXPR;
  596.   a->cell[2]->type = LVAL_SEXPR;
  598.   if (a->cell[0]->num) {
  599.     x = lval_eval(e, lval_pop(a, 1));
  600.   } else {
  601.     x = lval_eval(e, lval_pop(a, 2));
  602.   }
  604.   lval_del(a);
  605.   return x;
  606. }
  608. lval* lval_read(mpc_ast_t* t);
  610. lval* builtin_load(lenv* e, lval* a) {
  611.   LASSERT_NUM("load", a, 1);
  612.   LASSERT_TYPE("load", a, 0, LVAL_STR);
  614.   /* Parse File given by string name */
  615.   mpc_result_t r;
  616.   if (mpc_parse_contents(a->cell[0]->str, Lispy, &r)) {
  618.     /* Read contents */
  619.     lval* expr = lval_read(r.output);
  620.     mpc_ast_delete(r.output);
  622.     /* Evaluate each Expression */
  623.     while (expr->count) {
  624.       lval* x = lval_eval(e, lval_pop(expr, 0));
  625.       /* If Evaluation leads to error print it */
  626.       if (x->type == LVAL_ERR) { lval_println(x); }
  627.       lval_del(x);
  628.     }
  630.     /* Delete expressions and arguments */
  631.     lval_del(expr);    
  632.     lval_del(a);
  634.     /* Return empty list */
  635.     return lval_sexpr();
  637.   } else {
  638.     /* Get Parse Error as String */
  639.     char* err_msg = mpc_err_string(r.error);
  640.     mpc_err_delete(r.error);
  642.     /* Create new error message using it */
  643.     lval* err = lval_err("Could not load Library %s", err_msg);
  644.     free(err_msg);
  645.     lval_del(a);
  647.     /* Cleanup and return error */
  648.     return err;
  649.   }
  650. }
  652. lval* builtin_print(lenv* e, lval* a) {
  654.   /* Print each argument followed by a space */
  655.   for (int i = 0; i < a->count; i++) {
  656.     lval_print(a->cell[i]); putchar(' ');
  657.   }
  659.   /* Print a newline and delete arguments */
  660.   putchar('\n');
  661.   lval_del(a);
  663.   return lval_sexpr();
  664. }
  666. lval* builtin_error(lenv* e, lval* a) {
  667.   LASSERT_NUM("error", a, 1);
  668.   LASSERT_TYPE("error", a, 0, LVAL_STR);
  670.   /* Construct Error from first argument */
  671.   lval* err = lval_err(a->cell[0]->str);
  673.   /* Delete arguments and return */
  674.   lval_del(a);
  675.   return err;
  676. }
  678. void lenv_add_builtin(lenv* e, char* name, lbuiltin func) {
  679.   lval* k = lval_sym(name);
  680.   lval* v = lval_builtin(func);
  681.   lenv_put(e, k, v);
  682.   lval_del(k); lval_del(v);
  683. }
  685. void lenv_add_builtins(lenv* e) {
  686.   /* Variable Functions */
  687.   lenv_add_builtin(e, "\\",  builtin_lambda); 
  688.   lenv_add_builtin(e, "def", builtin_def);
  689.   lenv_add_builtin(e, "=",   builtin_put);
  691.   /* List Functions */
  692.   lenv_add_builtin(e, "list", builtin_list);
  693.   lenv_add_builtin(e, "head", builtin_head);
  694.   lenv_add_builtin(e, "tail", builtin_tail);
  695.   lenv_add_builtin(e, "eval", builtin_eval);
  696.   lenv_add_builtin(e, "join", builtin_join);
  698.   /* Mathematical Functions */
  699.   lenv_add_builtin(e, "+", builtin_add);
  700.   lenv_add_builtin(e, "-", builtin_sub);
  701.   lenv_add_builtin(e, "*", builtin_mul);
  702.   lenv_add_builtin(e, "/", builtin_div);
  704.   /* Comparison Functions */
  705.   lenv_add_builtin(e, "if", builtin_if);
  706.   lenv_add_builtin(e, "==", builtin_eq);
  707.   lenv_add_builtin(e, "!=", builtin_ne);
  708.   lenv_add_builtin(e, ">",  builtin_gt);
  709.   lenv_add_builtin(e, "<",  builtin_lt);
  710.   lenv_add_builtin(e, ">=", builtin_ge);
  711.   lenv_add_builtin(e, "<=", builtin_le);
  713.   /* String Functions */
  714.   lenv_add_builtin(e, "load",  builtin_load); 
  715.   lenv_add_builtin(e, "error", builtin_error);
  716.   lenv_add_builtin(e, "print", builtin_print);
  717. }
  719. /* Evaluation */
  721. lval* lval_call(lenv* e, lval* f, lval* a) {
  723.   if (f->builtin) { return f->builtin(e, a); }
  725.   int given = a->count;
  726.   int total = f->formals->count;
  728.   while (a->count) {
  730.     if (f->formals->count == 0) {
  731.       lval_del(a);
  732.       return lval_err("Function passed too many arguments. "
  733.         "Got %i, Expected %i.", given, total); 
  734.     }
  736.     lval* sym = lval_pop(f->formals, 0);
  738.     if (strcmp(sym->sym, "&") == 0) {
  740.       if (f->formals->count != 1) {
  741.         lval_del(a);
  742.         return lval_err("Function format invalid. "
  743.           "Symbol '&' not followed by single symbol.");
  744.       }
  746.       lval* nsym = lval_pop(f->formals, 0);
  747.       lenv_put(f->env, nsym, builtin_list(e, a));
  748.       lval_del(sym); lval_del(nsym);
  749.       break;
  750.     }
  752.     lval* val = lval_pop(a, 0);    
  753.     lenv_put(f->env, sym, val);    
  754.     lval_del(sym); lval_del(val);
  755.   }
  757.   lval_del(a);
  759.   if (f->formals->count > 0 &&
  760.     strcmp(f->formals->cell[0]->sym, "&") == 0) {
  762.     if (f->formals->count != 2) {
  763.       return lval_err("Function format invalid. "
  764.         "Symbol '&' not followed by single symbol.");
  765.     }
  767.     lval_del(lval_pop(f->formals, 0));
  769.     lval* sym = lval_pop(f->formals, 0);
  770.     lval* val = lval_qexpr();    
  771.     lenv_put(f->env, sym, val);
  772.     lval_del(sym); lval_del(val);
  773.   }
  775.   if (f->formals->count == 0) {  
  776.     f->env->par = e;    
  777.     return builtin_eval(f->env, lval_add(lval_sexpr(), lval_copy(f->body)));
  778.   } else {
  779.     return lval_copy(f);
  780.   }
  782. }
  784. lval* lval_eval_sexpr(lenv* e, lval* v) {
  786.   for (int i = 0; i < v->count; i++) { v->cell[i] = lval_eval(e, v->cell[i]); }
  787.   for (int i = 0; i < v->count; i++) { if (v->cell[i]->type == LVAL_ERR) { return lval_take(v, i); } }
  789.   if (v->count == 0) { return v; }  
  790.   if (v->count == 1) { return lval_eval(e, lval_take(v, 0)); }
  792.   lval* f = lval_pop(v, 0);
  793.   if (f->type != LVAL_FUN) {
  794.     lval* err = lval_err(
  795.       "S-Expression starts with incorrect type. "
  796.       "Got %s, Expected %s.",
  797.       ltype_name(f->type), ltype_name(LVAL_FUN));
  798.     lval_del(f); lval_del(v);
  799.     return err;
  800.   }
  802.   lval* result = lval_call(e, f, v);
  803.   lval_del(f);
  804.   return result;
  805. }
  807. lval* lval_eval(lenv* e, lval* v) {
  808.   if (v->type == LVAL_SYM) {
  809.     lval* x = lenv_get(e, v);
  810.     lval_del(v);
  811.     return x;
  812.   }
  813.   if (v->type == LVAL_SEXPR) { return lval_eval_sexpr(e, v); }
  814.   return v;
  815. }
  817. /* Reading */
  819. lval* lval_read_num(mpc_ast_t* t) {
  820.   errno = 0;
  821.   long x = strtol(t->contents, NULL, 10);
  822.   return errno != ERANGE ? lval_num(x) : lval_err("Invalid Number.");
  823. }
  825. lval* lval_read_str(mpc_ast_t* t) {
  826.   /* Cut off the final quote character */
  827.   t->contents[strlen(t->contents)-1] = '\0';
  828.   /* Copy the string missing out the first quote character */
  829.   char* unescaped = malloc(strlen(t->contents+1)+1);
  830.   strcpy(unescaped, t->contents+1);
  831.   /* Pass through the unescape function */
  832.   unescaped = mpcf_unescape(unescaped);
  833.   /* Construct a new lval using the string */
  834.   lval* str = lval_str(unescaped);
  835.   /* Free the string and return */
  836.   free(unescaped);
  837.   return str;
  838. }
  840. lval* lval_read(mpc_ast_t* t) {
  842.   if (strstr(t->tag, "number")) { return lval_read_num(t); }
  843.   if (strstr(t->tag, "string")) { return lval_read_str(t); }
  844.   if (strstr(t->tag, "symbol")) { return lval_sym(t->contents); }
  846.   lval* x = NULL;
  847.   if (strcmp(t->tag, ">") == 0) { x = lval_sexpr(); } 
  848.   if (strstr(t->tag, "sexpr"))  { x = lval_sexpr(); }
  849.   if (strstr(t->tag, "qexpr"))  { x = lval_qexpr(); }
  851.   for (int i = 0; i < t->children_num; i++) {
  852.     if (strcmp(t->children[i]->contents, "(") == 0) { continue; }
  853.     if (strcmp(t->children[i]->contents, ")") == 0) { continue; }
  854.     if (strcmp(t->children[i]->contents, "}") == 0) { continue; }
  855.     if (strcmp(t->children[i]->contents, "{") == 0) { continue; }
  856.     if (strcmp(t->children[i]->tag,  "regex") == 0) { continue; }
  857.     if (strstr(t->children[i]->tag, "comment")) { continue; }
  858.     x = lval_add(x, lval_read(t->children[i]));
  859.   }
  861.   return x;
  862. }
  864. /* Main */
  866. int main(int argc, char** argv) {
  868.   Number  = mpc_new("number");
  869.   Symbol  = mpc_new("symbol");
  870.   String  = mpc_new("string");
  871.   Comment = mpc_new("comment");
  872.   Sexpr   = mpc_new("sexpr");
  873.   Qexpr   = mpc_new("qexpr");
  874.   Expr    = mpc_new("expr");
  875.   Lispy   = mpc_new("lispy");
  877.   mpca_lang(MPCA_LANG_DEFAULT,
  878.     "                                              \
  879.       number  : /-?[0-9]+/ ;                       \
  880.       symbol  : /[a-zA-Z0-9_+\\-*\\/\\\\=<>!&]+/ ; \
  881.       string  : /\"(\\\\.|[^\"])*\"/ ;             \
  882.       comment : /;[^\\r\\n]*/ ;                    \
  883.       sexpr   : '(' <expr>* ')' ;                  \
  884.       qexpr   : '{' <expr>* '}' ;                  \
  885.       expr    : <number>  | <symbol> | <string>    \
  886.               | <comment> | <sexpr>  | <qexpr>;    \
  887.       lispy   : /^/ <expr>* /$/ ;                  \
  888.     ",
  889.     Number, Symbol, String, Comment, Sexpr, Qexpr, Expr, Lispy);
  891.   lenv* e = lenv_new();
  892.   lenv_add_builtins(e);
  894.   /* Interactive Prompt */
  895.   if (argc == 1) {
  897.     puts("Lispy Version 0.0.0.1.0");
  898.     puts("Press Ctrl+c to Exit\n");
  900.     while (1) {
  902.       char* input = readline("lispy> ");
  903.       add_history(input);
  905.       mpc_result_t r;
  906.       if (mpc_parse("<stdin>", input, Lispy, &r)) {
  908.         lval* x = lval_eval(e, lval_read(r.output));
  909.         lval_println(x);
  910.         lval_del(x);
  912.         mpc_ast_delete(r.output);
  913.       } else {    
  914.         mpc_err_print(r.error);
  915.         mpc_err_delete(r.error);
  916.       }
  918.       free(input);
  920.     }
  921.   }
  923.   /* Supplied with list of files */
  924.   if (argc >= 2) {
  926.     /* loop over each supplied filename (starting from 1) */
  927.     for (int i = 1; i < argc; i++) {
  929.       /* Argument list with a single argument, the filename */
  930.       lval* args = lval_add(lval_sexpr(), lval_str(argv[i]));
  932.       /* Pass to builtin load and get the result */
  933.       lval* x = builtin_load(e, args);
  935.       /* If the result is an error be sure to print it */
  936.       if (x->type == LVAL_ERR) { lval_println(x); }
  937.       lval_del(x);
  938.     }
  939.   }
  941.   lenv_del(e);
  943.   mpc_cleanup(8, 
  944.     Number, Symbol, String, Comment, 
  945.     Sexpr,  Qexpr,  Expr,   Lispy);
  947.   return 0;
  948. }

{% endcollapse %}