Reference

hand_rolled_parser.c

  1. #include <string.h>
  2. #include <stdio.h>
  3. #include <stdlib.h>
  4. #include <stdarg.h>
  5. #include <errno.h>
  7. #ifdef _WIN32
  9. static char buffer[2048];
  11. char* readline(char* prompt) {
  12.   fputs(prompt, stdout);
  13.   fgets(buffer, 2048, stdin);
  14.   char* cpy = malloc(strlen(buffer)+1);
  15.   strcpy(cpy, buffer);
  16.   cpy[strlen(cpy)-1] = '\0';
  17.   return cpy;
  18. }
  20. void add_history(char* unused) {}
  22. #else
  23. #include <editline/readline.h>
  24. #include <editline/history.h>
  25. #endif
  27. /* Forward Declarations */
  29. struct lval;
  30. struct lenv;
  31. typedef struct lval lval;
  32. typedef struct lenv lenv;
  34. /* Lisp Value */
  36. enum { LVAL_ERR, LVAL_NUM,   LVAL_SYM, LVAL_STR, 
  37.        LVAL_FUN, LVAL_SEXPR, LVAL_QEXPR };
  39. typedef lval*(*lbuiltin)(lenv*, lval*);
  41. struct lval {
  42.   int type;
  44.   /* Basic */
  45.   long num;
  46.   char* err;
  47.   char* sym;
  48.   char* str;
  50.   /* Function */
  51.   lbuiltin builtin;
  52.   lenv* env;
  53.   lval* formals;
  54.   lval* body;
  56.   /* Expression */
  57.   int count;
  58.   lval** cell;
  59. };
  61. lval* lval_num(long x) {
  62.   lval* v = malloc(sizeof(lval));
  63.   v->type = LVAL_NUM;
  64.   v->num = x;
  65.   return v;
  66. }
  68. lval* lval_err(char* fmt, ...) {
  69.   lval* v = malloc(sizeof(lval));
  70.   v->type = LVAL_ERR;  
  71.   va_list va;
  72.   va_start(va, fmt);  
  73.   v->err = malloc(512);  
  74.   vsnprintf(v->err, 511, fmt, va);  
  75.   v->err = realloc(v->err, strlen(v->err)+1);
  76.   va_end(va);  
  77.   return v;
  78. }
  80. lval* lval_sym(char* s) {
  81.   lval* v = malloc(sizeof(lval));
  82.   v->type = LVAL_SYM;
  83.   v->sym = malloc(strlen(s) + 1);
  84.   strcpy(v->sym, s);
  85.   return v;
  86. }
  88. lval* lval_str(char* s) {
  89.   lval* v = malloc(sizeof(lval));
  90.   v->type = LVAL_STR;
  91.   v->str = malloc(strlen(s) + 1);
  92.   strcpy(v->str, s);
  93.   return v;
  94. }
  96. lval* lval_builtin(lbuiltin func) {
  97.   lval* v = malloc(sizeof(lval));
  98.   v->type = LVAL_FUN;
  99.   v->builtin = func;
  100.   return v;
  101. }
  103. lenv* lenv_new(void);
  105. lval* lval_lambda(lval* formals, lval* body) {
  106.   lval* v = malloc(sizeof(lval));
  107.   v->type = LVAL_FUN;  
  108.   v->builtin = NULL;  
  109.   v->env = lenv_new();  
  110.   v->formals = formals;
  111.   v->body = body;
  112.   return v;  
  113. }
  115. lval* lval_sexpr(void) {
  116.   lval* v = malloc(sizeof(lval));
  117.   v->type = LVAL_SEXPR;
  118.   v->count = 0;
  119.   v->cell = NULL;
  120.   return v;
  121. }
  123. lval* lval_qexpr(void) {
  124.   lval* v = malloc(sizeof(lval));
  125.   v->type = LVAL_QEXPR;
  126.   v->count = 0;
  127.   v->cell = NULL;
  128.   return v;
  129. }
  131. void lenv_del(lenv* e);
  133. void lval_del(lval* v) {
  135.   switch (v->type) {
  136.     case LVAL_NUM: break;
  137.     case LVAL_FUN: 
  138.       if (!v->builtin) {
  139.         lenv_del(v->env);
  140.         lval_del(v->formals);
  141.         lval_del(v->body);
  142.       }
  143.     break;
  144.     case LVAL_ERR: free(v->err); break;
  145.     case LVAL_SYM: free(v->sym); break;
  146.     case LVAL_STR: free(v->str); break;
  147.     case LVAL_QEXPR:
  148.     case LVAL_SEXPR:
  149.       for (int i = 0; i < v->count; i++) {
  150.         lval_del(v->cell[i]);
  151.       }
  152.       free(v->cell);
  153.     break;
  154.   }
  156.   free(v);
  157. }
  159. lenv* lenv_copy(lenv* e);
  161. lval* lval_copy(lval* v) {
  162.   lval* x = malloc(sizeof(lval));
  163.   x->type = v->type;
  164.   switch (v->type) {
  165.     case LVAL_FUN:
  166.       if (v->builtin) {
  167.         x->builtin = v->builtin;
  168.       } else {
  169.         x->builtin = NULL;
  170.         x->env = lenv_copy(v->env);
  171.         x->formals = lval_copy(v->formals);
  172.         x->body = lval_copy(v->body);
  173.       }
  174.     break;
  175.     case LVAL_NUM: x->num = v->num; break;
  176.     case LVAL_ERR: x->err = malloc(strlen(v->err) + 1);
  177.       strcpy(x->err, v->err);
  178.     break;
  179.     case LVAL_SYM: x->sym = malloc(strlen(v->sym) + 1);
  180.       strcpy(x->sym, v->sym);
  181.     break;
  182.     case LVAL_STR: x->str = malloc(strlen(v->str) + 1);
  183.       strcpy(x->str, v->str);
  184.     break;
  185.     case LVAL_SEXPR:
  186.     case LVAL_QEXPR:
  187.       x->count = v->count;
  188.       x->cell = malloc(sizeof(lval*) * x->count);
  189.       for (int i = 0; i < x->count; i++) {
  190.         x->cell[i] = lval_copy(v->cell[i]);
  191.       }
  192.     break;
  193.   }
  194.   return x;
  195. }
  197. lval* lval_add(lval* v, lval* x) {
  198.   v->count++;
  199.   v->cell = realloc(v->cell, sizeof(lval*) * v->count);
  200.   v->cell[v->count-1] = x;
  201.   return v;
  202. }
  204. lval* lval_join(lval* x, lval* y) {  
  205.   for (int i = 0; i < y->count; i++) {
  206.     x = lval_add(x, y->cell[i]);
  207.   }
  208.   free(y->cell);
  209.   free(y);  
  210.   return x;
  211. }
  213. lval* lval_pop(lval* v, int i) {
  214.   lval* x = v->cell[i];  
  215.   memmove(&v->cell[i],
  216.     &v->cell[i+1], sizeof(lval*) * (v->count-i-1));  
  217.   v->count--;  
  218.   v->cell = realloc(v->cell, sizeof(lval*) * v->count);
  219.   return x;
  220. }
  222. lval* lval_take(lval* v, int i) {
  223.   lval* x = lval_pop(v, i);
  224.   lval_del(v);
  225.   return x;
  226. }
  228. void lval_print(lval* v);
  230. void lval_print_expr(lval* v, char open, char close) {
  231.   putchar(open);
  232.   for (int i = 0; i < v->count; i++) {
  233.     lval_print(v->cell[i]);    
  234.     if (i != (v->count-1)) {
  235.       putchar(' ');
  236.     }
  237.   }
  238.   putchar(close);
  239. }
  241. /* Possible unescapable characters */
  242. char* lval_str_unescapable = "abfnrtv\\\'\"";
  244. /* Function to unescape characters */
  245. char lval_str_unescape(char x) {
  246.   switch (x) {
  247.     case 'a':  return '\a';
  248.     case 'b':  return '\b';
  249.     case 'f':  return '\f';
  250.     case 'n':  return '\n';
  251.     case 'r':  return '\r';
  252.     case 't':  return '\t';
  253.     case 'v':  return '\v';
  254.     case '\\': return '\\';
  255.     case '\'': return '\'';
  256.     case '\"': return '\"';
  257.   }
  258.   return '\0';
  259. }
  261. /* List of possible escapable characters */
  262. char* lval_str_escapable = "\a\b\f\n\r\t\v\\\'\"";
  264. /* Function to escape characters */
  265. char* lval_str_escape(char x) {
  266.   switch (x) {
  267.     case '\a': return "\\a";
  268.     case '\b': return "\\b";
  269.     case '\f': return "\\f";
  270.     case '\n': return "\\n";
  271.     case '\r': return "\\r";
  272.     case '\t': return "\\t";
  273.     case '\v': return "\\v";
  274.     case '\\': return "\\\\";
  275.     case '\'': return "\\\'";
  276.     case '\"': return "\\\"";
  277.   }
  278.   return "";
  279. }
  281. void lval_print_str(lval* v) {
  282.   putchar('"');
  283.   /* Loop over the characters in the string */
  284.   for (int i = 0; i < strlen(v->str); i++) {
  285.     if (strchr(lval_str_escapable, v->str[i])) {
  286.       /* If the character is escapable then escape it */
  287.       printf("%s", lval_str_escape(v->str[i]));
  288.     } else {
  289.       /* Otherwise print character as it is */
  290.       putchar(v->str[i]);
  291.     }
  292.   }
  293.   putchar('"');
  294. }
  296. void lval_print(lval* v) {
  297.   switch (v->type) {
  298.     case LVAL_FUN:
  299.       if (v->builtin) {
  300.         printf("<builtin>");
  301.       } else {
  302.         printf("(\\ ");
  303.         lval_print(v->formals);
  304.         putchar(' ');
  305.         lval_print(v->body);
  306.         putchar(')');
  307.       }
  308.     break;
  309.     case LVAL_NUM:   printf("%li", v->num); break;
  310.     case LVAL_ERR:   printf("Error: %s", v->err); break;
  311.     case LVAL_SYM:   printf("%s", v->sym); break;
  312.     case LVAL_STR:   lval_print_str(v); break;
  313.     case LVAL_SEXPR: lval_print_expr(v, '(', ')'); break;
  314.     case LVAL_QEXPR: lval_print_expr(v, '{', '}'); break;
  315.   }
  316. }
  318. void lval_println(lval* v) { lval_print(v); putchar('\n'); }
  320. int lval_eq(lval* x, lval* y) {
  322.   if (x->type != y->type) { return 0; }
  324.   switch (x->type) {
  325.     case LVAL_NUM: return (x->num == y->num);    
  326.     case LVAL_ERR: return (strcmp(x->err, y->err) == 0);
  327.     case LVAL_SYM: return (strcmp(x->sym, y->sym) == 0);    
  328.     case LVAL_STR: return (strcmp(x->str, y->str) == 0);    
  329.     case LVAL_FUN: 
  330.       if (x->builtin || y->builtin) {
  331.         return x->builtin == y->builtin;
  332.       } else {
  333.         return lval_eq(x->formals, y->formals) && lval_eq(x->body, y->body);
  334.       }    
  335.     case LVAL_QEXPR:
  336.     case LVAL_SEXPR:
  337.       if (x->count != y->count) { return 0; }
  338.       for (int i = 0; i < x->count; i++) {
  339.         if (!lval_eq(x->cell[i], y->cell[i])) { return 0; }
  340.       }
  341.       return 1;
  342.     break;
  343.   }
  344.   return 0;
  345. }
  347. char* ltype_name(int t) {
  348.   switch(t) {
  349.     case LVAL_FUN: return "Function";
  350.     case LVAL_NUM: return "Number";
  351.     case LVAL_ERR: return "Error";
  352.     case LVAL_SYM: return "Symbol";
  353.     case LVAL_STR: return "String";
  354.     case LVAL_SEXPR: return "S-Expression";
  355.     case LVAL_QEXPR: return "Q-Expression";
  356.     default: return "Unknown";
  357.   }
  358. }
  360. /* Lisp Environment */
  362. struct lenv {
  363.   lenv* par;
  364.   int count;
  365.   char** syms;
  366.   lval** vals;
  367. };
  369. lenv* lenv_new(void) {
  370.   lenv* e = malloc(sizeof(lenv));
  371.   e->par = NULL;
  372.   e->count = 0;
  373.   e->syms = NULL;
  374.   e->vals = NULL;
  375.   return e;
  376. }
  378. void lenv_del(lenv* e) {
  379.   for (int i = 0; i < e->count; i++) {
  380.     free(e->syms[i]);
  381.     lval_del(e->vals[i]);
  382.   }  
  383.   free(e->syms);
  384.   free(e->vals);
  385.   free(e);
  386. }
  388. lenv* lenv_copy(lenv* e) {
  389.   lenv* n = malloc(sizeof(lenv));
  390.   n->par = e->par;
  391.   n->count = e->count;
  392.   n->syms = malloc(sizeof(char*) * n->count);
  393.   n->vals = malloc(sizeof(lval*) * n->count);
  394.   for (int i = 0; i < e->count; i++) {
  395.     n->syms[i] = malloc(strlen(e->syms[i]) + 1);
  396.     strcpy(n->syms[i], e->syms[i]);
  397.     n->vals[i] = lval_copy(e->vals[i]);
  398.   }
  399.   return n;
  400. }
  402. lval* lenv_get(lenv* e, lval* k) {
  404.   for (int i = 0; i < e->count; i++) {
  405.     if (strcmp(e->syms[i], k->sym) == 0) { return lval_copy(e->vals[i]); }
  406.   }
  408.   if (e->par) {
  409.     return lenv_get(e->par, k);
  410.   } else {
  411.     return lval_err("Unbound Symbol '%s'", k->sym);
  412.   }
  413. }
  415. void lenv_put(lenv* e, lval* k, lval* v) {
  417.   for (int i = 0; i < e->count; i++) {
  418.     if (strcmp(e->syms[i], k->sym) == 0) {
  419.       lval_del(e->vals[i]);
  420.       e->vals[i] = lval_copy(v);
  421.       return;
  422.     }
  423.   }
  425.   e->count++;
  426.   e->vals = realloc(e->vals, sizeof(lval*) * e->count);
  427.   e->syms = realloc(e->syms, sizeof(char*) * e->count);  
  428.   e->vals[e->count-1] = lval_copy(v);
  429.   e->syms[e->count-1] = malloc(strlen(k->sym)+1);
  430.   strcpy(e->syms[e->count-1], k->sym);
  431. }
  433. void lenv_def(lenv* e, lval* k, lval* v) {
  434.   while (e->par) { e = e->par; }
  435.   lenv_put(e, k, v);
  436. }
  438. /* Builtins */
  440. #define LASSERT(args, cond, fmt, ...) \
  441.   if (!(cond)) { lval* err = lval_err(fmt, ##__VA_ARGS__); lval_del(args); return err; }
  443. #define LASSERT_TYPE(func, args, index, expect) \
  444.   LASSERT(args, args->cell[index]->type == expect, \
  445.     "Function '%s' passed incorrect type for argument %i. Got %s, Expected %s.", \
  446.     func, index, ltype_name(args->cell[index]->type), ltype_name(expect))
  448. #define LASSERT_NUM(func, args, num) \
  449.   LASSERT(args, args->count == num, \
  450.     "Function '%s' passed incorrect number of arguments. Got %i, Expected %i.", \
  451.     func, args->count, num)
  453. #define LASSERT_NOT_EMPTY(func, args, index) \
  454.   LASSERT(args, args->cell[index]->count != 0, \
  455.     "Function '%s' passed {} for argument %i.", func, index);
  457. lval* lval_eval(lenv* e, lval* v);
  459. lval* builtin_lambda(lenv* e, lval* a) {
  460.   LASSERT_NUM("\\", a, 2);
  461.   LASSERT_TYPE("\\", a, 0, LVAL_QEXPR);
  462.   LASSERT_TYPE("\\", a, 1, LVAL_QEXPR);
  464.   for (int i = 0; i < a->cell[0]->count; i++) {
  465.     LASSERT(a, (a->cell[0]->cell[i]->type == LVAL_SYM),
  466.       "Cannot define non-symbol. Got %s, Expected %s.",
  467.       ltype_name(a->cell[0]->cell[i]->type), ltype_name(LVAL_SYM));
  468.   }
  470.   lval* formals = lval_pop(a, 0);
  471.   lval* body = lval_pop(a, 0);
  472.   lval_del(a);
  474.   return lval_lambda(formals, body);
  475. }
  477. lval* builtin_list(lenv* e, lval* a) {
  478.   a->type = LVAL_QEXPR;
  479.   return a;
  480. }
  482. lval* builtin_head(lenv* e, lval* a) {
  483.   LASSERT_NUM("head", a, 1);
  484.   LASSERT_TYPE("head", a, 0, LVAL_QEXPR);
  485.   LASSERT_NOT_EMPTY("head", a, 0);
  487.   lval* v = lval_take(a, 0);  
  488.   while (v->count > 1) { lval_del(lval_pop(v, 1)); }
  489.   return v;
  490. }
  492. lval* builtin_tail(lenv* e, lval* a) {
  493.   LASSERT_NUM("tail", a, 1);
  494.   LASSERT_TYPE("tail", a, 0, LVAL_QEXPR);
  495.   LASSERT_NOT_EMPTY("tail", a, 0);
  497.   lval* v = lval_take(a, 0);  
  498.   lval_del(lval_pop(v, 0));
  499.   return v;
  500. }
  502. lval* builtin_eval(lenv* e, lval* a) {
  503.   LASSERT_NUM("eval", a, 1);
  504.   LASSERT_TYPE("eval", a, 0, LVAL_QEXPR);
  506.   lval* x = lval_take(a, 0);
  507.   x->type = LVAL_SEXPR;
  508.   return lval_eval(e, x);
  509. }
  511. lval* builtin_join(lenv* e, lval* a) {
  513.   for (int i = 0; i < a->count; i++) {
  514.     LASSERT_TYPE("join", a, i, LVAL_QEXPR);
  515.   }
  517.   lval* x = lval_pop(a, 0);
  519.   while (a->count) {
  520.     lval* y = lval_pop(a, 0);
  521.     x = lval_join(x, y);
  522.   }
  524.   lval_del(a);
  525.   return x;
  526. }
  528. lval* builtin_op(lenv* e, lval* a, char* op) {
  530.   for (int i = 0; i < a->count; i++) {
  531.     LASSERT_TYPE(op, a, i, LVAL_NUM);
  532.   }
  534.   lval* x = lval_pop(a, 0);
  536.   if ((strcmp(op, "-") == 0) && a->count == 0) { x->num = -x->num; }
  538.   while (a->count > 0) {  
  539.     lval* y = lval_pop(a, 0);
  541.     if (strcmp(op, "+") == 0) { x->num += y->num; }
  542.     if (strcmp(op, "-") == 0) { x->num -= y->num; }
  543.     if (strcmp(op, "*") == 0) { x->num *= y->num; }
  544.     if (strcmp(op, "/") == 0) {
  545.       if (y->num == 0) {
  546.         lval_del(x); lval_del(y);
  547.         x = lval_err("Division By Zero.");
  548.         break;
  549.       }
  550.       x->num /= y->num;
  551.     }
  553.     lval_del(y);
  554.   }
  556.   lval_del(a);
  557.   return x;
  558. }
  560. lval* builtin_add(lenv* e, lval* a) { return builtin_op(e, a, "+"); }
  561. lval* builtin_sub(lenv* e, lval* a) { return builtin_op(e, a, "-"); }
  562. lval* builtin_mul(lenv* e, lval* a) { return builtin_op(e, a, "*"); }
  563. lval* builtin_div(lenv* e, lval* a) { return builtin_op(e, a, "/"); }
  565. lval* builtin_var(lenv* e, lval* a, char* func) {
  566.   LASSERT_TYPE(func, a, 0, LVAL_QEXPR);
  568.   lval* syms = a->cell[0];
  569.   for (int i = 0; i < syms->count; i++) {
  570.     LASSERT(a, (syms->cell[i]->type == LVAL_SYM),
  571.       "Function '%s' cannot define non-symbol. "
  572.       "Got %s, Expected %s.",
  573.       func, ltype_name(syms->cell[i]->type), ltype_name(LVAL_SYM));
  574.   }
  576.   LASSERT(a, (syms->count == a->count-1),
  577.     "Function '%s' passed too many arguments for symbols. "
  578.     "Got %i, Expected %i.",
  579.     func, syms->count, a->count-1);
  581.   for (int i = 0; i < syms->count; i++) {
  582.     if (strcmp(func, "def") == 0) { lenv_def(e, syms->cell[i], a->cell[i+1]); }
  583.     if (strcmp(func, "=")   == 0) { lenv_put(e, syms->cell[i], a->cell[i+1]); } 
  584.   }
  586.   lval_del(a);
  587.   return lval_sexpr();
  588. }
  590. lval* builtin_def(lenv* e, lval* a) { return builtin_var(e, a, "def"); }
  591. lval* builtin_put(lenv* e, lval* a) { return builtin_var(e, a, "="); }
  593. lval* builtin_ord(lenv* e, lval* a, char* op) {
  594.   LASSERT_NUM(op, a, 2);
  595.   LASSERT_TYPE(op, a, 0, LVAL_NUM);
  596.   LASSERT_TYPE(op, a, 1, LVAL_NUM);
  598.   int r;
  599.   if (strcmp(op, ">")  == 0) { r = (a->cell[0]->num >  a->cell[1]->num); }
  600.   if (strcmp(op, "<")  == 0) { r = (a->cell[0]->num <  a->cell[1]->num); }
  601.   if (strcmp(op, ">=") == 0) { r = (a->cell[0]->num >= a->cell[1]->num); }
  602.   if (strcmp(op, "<=") == 0) { r = (a->cell[0]->num <= a->cell[1]->num); }
  603.   lval_del(a);
  604.   return lval_num(r);
  605. }
  607. lval* builtin_gt(lenv* e, lval* a) { return builtin_ord(e, a, ">");  }
  608. lval* builtin_lt(lenv* e, lval* a) { return builtin_ord(e, a, "<");  }
  609. lval* builtin_ge(lenv* e, lval* a) { return builtin_ord(e, a, ">="); }
  610. lval* builtin_le(lenv* e, lval* a) { return builtin_ord(e, a, "<="); }
  612. lval* builtin_cmp(lenv* e, lval* a, char* op) {
  613.   LASSERT_NUM(op, a, 2);
  614.   int r;
  615.   if (strcmp(op, "==") == 0) { r =  lval_eq(a->cell[0], a->cell[1]); }
  616.   if (strcmp(op, "!=") == 0) { r = !lval_eq(a->cell[0], a->cell[1]); }
  617.   lval_del(a);
  618.   return lval_num(r);
  619. }
  621. lval* builtin_eq(lenv* e, lval* a) { return builtin_cmp(e, a, "=="); }
  622. lval* builtin_ne(lenv* e, lval* a) { return builtin_cmp(e, a, "!="); }
  624. lval* builtin_if(lenv* e, lval* a) {
  625.   LASSERT_NUM("if", a, 3);
  626.   LASSERT_TYPE("if", a, 0, LVAL_NUM);
  627.   LASSERT_TYPE("if", a, 1, LVAL_QEXPR);
  628.   LASSERT_TYPE("if", a, 2, LVAL_QEXPR);
  630.   lval* x;
  631.   a->cell[1]->type = LVAL_SEXPR;
  632.   a->cell[2]->type = LVAL_SEXPR;
  634.   if (a->cell[0]->num) {
  635.     x = lval_eval(e, lval_pop(a, 1));
  636.   } else {
  637.     x = lval_eval(e, lval_pop(a, 2));
  638.   }
  640.   lval_del(a);
  641.   return x;
  642. }
  644. /* Change forward declaration */
  645. lval* lval_read_expr(char* s, int* i, char end);
  647. lval* builtin_load(lenv* e, lval* a) {
  648.   LASSERT_NUM("load", a, 1);
  649.   LASSERT_TYPE("load", a, 0, LVAL_STR);
  651.   /* Open file and check it exists */
  652.   FILE* f = fopen(a->cell[0]->str, "rb");
  653.   if (f == NULL) {
  654.     lval* err = lval_err("Could not load Library %s", a->cell[0]->str);
  655.     lval_del(a);
  656.     return err;
  657.   }
  659.   /* Read File Contents */
  660.   fseek(f, 0, SEEK_END);
  661.   long length = ftell(f);
  662.   fseek(f, 0, SEEK_SET);
  663.   char* input = calloc(length+1, 1);
  664.   fread(input, 1, length, f);
  665.   fclose(f);
  667.   /* Read from input to create an S-Expr */
  668.   int pos = 0;
  669.   lval* expr = lval_read_expr(input, &pos, '\0');
  670.   free(input);
  672.   /* Evaluate all expressions contained in S-Expr */
  673.   if (expr->type != LVAL_ERR) {
  674.     while (expr->count) {
  675.       lval* x = lval_eval(e, lval_pop(expr, 0));
  676.       if (x->type == LVAL_ERR) { lval_println(x); }
  677.       lval_del(x);
  678.     }
  679.   } else {
  680.     lval_println(expr);
  681.   }
  683.   lval_del(expr);    
  684.   lval_del(a);
  686.   return lval_sexpr();
  687. }
  689. lval* builtin_print(lenv* e, lval* a) {  
  690.   for (int i = 0; i < a->count; i++) {
  691.     lval_print(a->cell[i]); putchar(' ');
  692.   }
  693.   putchar('\n');
  694.   lval_del(a);
  695.   return lval_sexpr();
  696. }
  698. lval* builtin_error(lenv* e, lval* a) {
  699.   LASSERT_NUM("error", a, 1);
  700.   LASSERT_TYPE("error", a, 0, LVAL_STR);
  701.   lval* err = lval_err(a->cell[0]->str);  
  702.   lval_del(a);
  703.   return err;
  704. }
  706. void lenv_add_builtin(lenv* e, char* name, lbuiltin func) {
  707.   lval* k = lval_sym(name);
  708.   lval* v = lval_builtin(func);
  709.   lenv_put(e, k, v);
  710.   lval_del(k); lval_del(v);
  711. }
  713. void lenv_add_builtins(lenv* e) {
  714.   /* Variable Functions */
  715.   lenv_add_builtin(e, "\\",  builtin_lambda); 
  716.   lenv_add_builtin(e, "def", builtin_def);
  717.   lenv_add_builtin(e, "=",   builtin_put);
  719.   /* List Functions */
  720.   lenv_add_builtin(e, "list", builtin_list);
  721.   lenv_add_builtin(e, "head", builtin_head);
  722.   lenv_add_builtin(e, "tail", builtin_tail);
  723.   lenv_add_builtin(e, "eval", builtin_eval);
  724.   lenv_add_builtin(e, "join", builtin_join);
  726.   /* Mathematical Functions */
  727.   lenv_add_builtin(e, "+", builtin_add);
  728.   lenv_add_builtin(e, "-", builtin_sub);
  729.   lenv_add_builtin(e, "*", builtin_mul);
  730.   lenv_add_builtin(e, "/", builtin_div);
  732.   /* Comparison Functions */
  733.   lenv_add_builtin(e, "if", builtin_if);
  734.   lenv_add_builtin(e, "==", builtin_eq);
  735.   lenv_add_builtin(e, "!=", builtin_ne);
  736.   lenv_add_builtin(e, ">",  builtin_gt);
  737.   lenv_add_builtin(e, "<",  builtin_lt);
  738.   lenv_add_builtin(e, ">=", builtin_ge);
  739.   lenv_add_builtin(e, "<=", builtin_le);
  741.   /* String Functions */
  742.   lenv_add_builtin(e, "load",  builtin_load); 
  743.   lenv_add_builtin(e, "error", builtin_error);
  744.   lenv_add_builtin(e, "print", builtin_print);
  745. }
  747. /* Evaluation */
  749. lval* lval_call(lenv* e, lval* f, lval* a) {
  751.   if (f->builtin) { return f->builtin(e, a); }
  753.   int given = a->count;
  754.   int total = f->formals->count;
  756.   while (a->count) {
  758.     if (f->formals->count == 0) {
  759.       lval_del(a);
  760.       return lval_err("Function passed too many arguments. "
  761.         "Got %i, Expected %i.", given, total); 
  762.     }
  764.     lval* sym = lval_pop(f->formals, 0);
  766.     if (strcmp(sym->sym, "&") == 0) {
  768.       if (f->formals->count != 1) {
  769.         lval_del(a);
  770.         return lval_err("Function format invalid. "
  771.           "Symbol '&' not followed by single symbol.");
  772.       }
  774.       lval* nsym = lval_pop(f->formals, 0);
  775.       lenv_put(f->env, nsym, builtin_list(e, a));
  776.       lval_del(sym); lval_del(nsym);
  777.       break;
  778.     }
  780.     lval* val = lval_pop(a, 0);    
  781.     lenv_put(f->env, sym, val);    
  782.     lval_del(sym); lval_del(val);
  783.   }
  785.   lval_del(a);
  787.   if (f->formals->count > 0 &&
  788.     strcmp(f->formals->cell[0]->sym, "&") == 0) {
  790.     if (f->formals->count != 2) {
  791.       return lval_err("Function format invalid. "
  792.         "Symbol '&' not followed by single symbol.");
  793.     }
  795.     lval_del(lval_pop(f->formals, 0));
  797.     lval* sym = lval_pop(f->formals, 0);
  798.     lval* val = lval_qexpr();    
  799.     lenv_put(f->env, sym, val);
  800.     lval_del(sym); lval_del(val);
  801.   }
  803.   if (f->formals->count == 0) {  
  804.     f->env->par = e;    
  805.     return builtin_eval(f->env, lval_add(lval_sexpr(), lval_copy(f->body)));
  806.   } else {
  807.     return lval_copy(f);
  808.   }
  810. }
  812. lval* lval_eval_sexpr(lenv* e, lval* v) {
  814.   for (int i = 0; i < v->count; i++) { v->cell[i] = lval_eval(e, v->cell[i]); }
  815.   for (int i = 0; i < v->count; i++) { if (v->cell[i]->type == LVAL_ERR) { return lval_take(v, i); } }
  817.   if (v->count == 0) { return v; }  
  818.   if (v->count == 1) { return lval_eval(e, lval_take(v, 0)); }
  820.   lval* f = lval_pop(v, 0);
  821.   if (f->type != LVAL_FUN) {
  822.     lval* err = lval_err(
  823.       "S-Expression starts with incorrect type. "
  824.       "Got %s, Expected %s.",
  825.       ltype_name(f->type), ltype_name(LVAL_FUN));
  826.     lval_del(f); lval_del(v);
  827.     return err;
  828.   }
  830.   lval* result = lval_call(e, f, v);
  831.   lval_del(f);
  832.   return result;
  833. }
  835. lval* lval_eval(lenv* e, lval* v) {
  836.   if (v->type == LVAL_SYM) {
  837.     lval* x = lenv_get(e, v);
  838.     lval_del(v);
  839.     return x;
  840.   }
  841.   if (v->type == LVAL_SEXPR) { return lval_eval_sexpr(e, v); }
  842.   return v;
  843. }
  845. /* Reading */
  847. lval* lval_read_sym(char* s, int* i) {
  849.   /* Allocate Empty String */
  850.   char* part = calloc(1,1);
  852.   /* While valid identifier characters */
  853.   while (strchr(
  854.       "abcdefghijklmnopqrstuvwxyz"
  855.       "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
  856.       "0123456789_+-*\\/=<>!&", s[*i]) && s[*i] != '\0') {
  858.     /* Append character to end of string */
  859.     part = realloc(part, strlen(part)+2);
  860.     part[strlen(part)+1] = '\0';
  861.     part[strlen(part)+0] = s[*i];
  862.     (*i)++;
  863.   }
  865.   /* Check if Identifier looks like number */
  866.   int is_num = strchr("-0123456789", part[0]) != NULL;
  867.   for (int j = 1; j < strlen(part); j++) {
  868.     if (strchr("0123456789", part[j]) == NULL) { is_num = 0; break; }
  869.   }
  870.   if (strlen(part) == 1 && part[0] == '-') { is_num = 0; }
  872.   /* Add Symbol or Number as lval */
  873.   lval* x = NULL;
  874.   if (is_num) {
  875.     errno = 0;
  876.     long v = strtol(part, NULL, 10);
  877.     x = (errno != ERANGE) ? lval_num(v) : lval_err("Invalid Number %s", part);
  878.   } else {
  879.     x = lval_sym(part);
  880.   }
  882.   /* Free temp string */
  883.   free(part);
  885.   /* Return lval */
  886.   return x;
  887. }
  889. lval* lval_read_str(char* s, int* i) {
  891.   /* Allocate empty string */
  892.   char* part = calloc(1,1);
  894.   /* More forward one step past initial " character */
  895.   (*i)++;
  896.   while (s[*i] != '"') {
  898.     char c = s[*i];
  900.     /* If end of input then there is an unterminated string literal */
  901.     if (c == '\0') {
  902.       free(part);
  903.       return lval_err("Unexpected end of input");
  904.     }
  906.     /* If backslash then unescape character after it */
  907.     if (c == '\\') {
  908.       (*i)++;
  909.       /* Check next character is escapable */
  910.       if (strchr(lval_str_unescapable, s[*i])) {        
  911.         c = lval_str_unescape(s[*i]);
  912.       } else {
  913.         free(part);
  914.         return lval_err("Invalid escape sequence \\%c", s[*i]);
  915.       }
  916.     }
  918.     /* Append character to string */
  919.     part = realloc(part, strlen(part)+2);
  920.     part[strlen(part)+1] = '\0';
  921.     part[strlen(part)+0] = c;
  922.     (*i)++;    
  923.   }
  924.   /* Move forward past final " character */
  925.   (*i)++;
  927.   lval* x = lval_str(part);
  929.   /* free temp string */
  930.   free(part);
  932.   return x;
  933. }
  935. lval* lval_read(char* s, int* i);
  937. lval* lval_read_expr(char* s, int* i, char end) {
  939.   /* Either create new qexpr or sexpr */
  940.   lval* x = (end == '}') ? lval_qexpr() : lval_sexpr();
  942.   /* While not at end character keep reading lvals */
  943.   while (s[*i] != end) {
  944.     lval* y = lval_read(s, i);
  945.     /* If an error then return this and stop */
  946.     if (y->type == LVAL_ERR) {
  947.       lval_del(x);
  948.       return y;
  949.     } else {
  950.       lval_add(x, y);
  951.     }
  952.   }
  954.   /* Move past end character */
  955.   (*i)++;
  957.   return x;
  959. }
  961. lval* lval_read(char* s, int* i) {
  963.   /* Skip all trailing whitespace and comments */
  964.   while (strchr(" \t\v\r\n;", s[*i]) && s[*i] != '\0') {
  965.     if (s[*i] == ';') {
  966.       while (s[*i] != '\n' && s[*i] != '\0') { (*i)++; }
  967.     }
  968.     (*i)++;
  969.   }
  971.   lval* x = NULL;
  973.   /* If we reach end of input then we're missing something */
  974.   if (s[*i] == '\0') {
  975.     return lval_err("Unexpected end of input");
  976.   }
  978.   /* If next character is ( then read S-Expr */
  979.   else if (s[*i] == '(') {
  980.     (*i)++;
  981.     x = lval_read_expr(s, i, ')');
  982.   }
  984.   /* If next character is { then read Q-Expr */
  985.   else if (s[*i] == '{') {
  986.     (*i)++;
  987.     x = lval_read_expr(s, i, '}');
  988.   }
  990.   /* If next character is part of a symbol then read symbol */
  991.   else if (strchr(
  992.     "abcdefghijklmnopqrstuvwxyz"
  993.     "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
  994.     "0123456789_+-*\\/=<>!&", s[*i])) {
  995.     x = lval_read_sym(s, i);
  996.   }
  998.   /* If next character is " then read string */
  999.   else if (strchr("\"", s[*i])) {
  1000.     x = lval_read_str(s, i);
  1001.   }
  1003.   /* Encountered some unexpected character */
  1004.   else {
  1005.     x = lval_err("Unexpected character %c", s[*i]);
  1006.   }
  1008.   /* Skip all trailing whitespace and comments */
  1009.   while (strchr(" \t\v\r\n;", s[*i]) && s[*i] != '\0') {
  1010.     if (s[*i] == ';') {
  1011.       while (s[*i] != '\n' && s[*i] != '\0') { (*i)++; }
  1012.     }
  1013.     (*i)++;
  1014.   }
  1016.   return x;
  1018. }
  1020. /* Main */    
  1022. int main(int argc, char** argv) {
  1024.   lenv* e = lenv_new();
  1025.   lenv_add_builtins(e);
  1027.   /* Interactive Prompt */
  1028.   if (argc == 1) {
  1030.     puts("Lispy Version 0.0.0.1.1");
  1031.     puts("Press Ctrl+c to Exit\n");
  1033.     while (1) {
  1035.       char* input = readline("lispy> ");
  1036.       add_history(input);
  1038.       /* Read from input to create an S-Expr */
  1039.       int pos = 0;
  1040.       lval* expr = lval_read_expr(input, &pos, '\0');
  1042.       /* Evaluate and print input */
  1043.       lval* x = lval_eval(e, expr);
  1044.       lval_println(x);
  1045.       lval_del(x);
  1047.       free(input);
  1048.     }
  1049.   }
  1051.   /* Supplied with list of files */
  1052.   if (argc >= 2) {  
  1053.     for (int i = 1; i < argc; i++) {
  1054.       lval* args = lval_add(lval_sexpr(), lval_str(argv[i]));
  1055.       lval* x = builtin_load(e, args);      
  1056.       if (x->type == LVAL_ERR) { lval_println(x); }
  1057.       lval_del(x);
  1058.     }
  1059.   }
  1061.   lenv_del(e);
  1063.   return 0;
  1064. }