Reference

variables.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. /* Forward Declarations */
  25. struct lval;
  26. struct lenv;
  27. typedef struct lval lval;
  28. typedef struct lenv lenv;
  30. /* Lisp Value */
  32. enum { LVAL_ERR, LVAL_NUM,   LVAL_SYM, 
  33.        LVAL_FUN, LVAL_SEXPR, LVAL_QEXPR };
  35. typedef lval*(*lbuiltin)(lenv*, lval*);
  37. struct lval {
  38.   int type;
  39.   long num;
  40.   char* err;
  41.   char* sym;
  42.   lbuiltin fun;
  43.   int count;
  44.   lval** cell;
  45. };
  47. lval* lval_num(long x) {
  48.   lval* v = malloc(sizeof(lval));
  49.   v->type = LVAL_NUM;
  50.   v->num = x;
  51.   return v;
  52. }
  54. lval* lval_err(char* fmt, ...) {
  55.   lval* v = malloc(sizeof(lval));
  56.   v->type = LVAL_ERR;
  58.   /* Create a va list and initialize it */
  59.   va_list va;
  60.   va_start(va, fmt);
  62.   /* Allocate 512 bytes of space */
  63.   v->err = malloc(512);
  65.   /* printf the error string with a maximum of 511 characters */
  66.   vsnprintf(v->err, 511, fmt, va);
  68.   /* Reallocate to number of bytes actually used */
  69.   v->err = realloc(v->err, strlen(v->err)+1);
  71.   /* Cleanup our va list */
  72.   va_end(va);
  74.   return v;
  75. }
  77. lval* lval_sym(char* s) {
  78.   lval* v = malloc(sizeof(lval));
  79.   v->type = LVAL_SYM;
  80.   v->sym = malloc(strlen(s) + 1);
  81.   strcpy(v->sym, s);
  82.   return v;
  83. }
  85. lval* lval_fun(lbuiltin func) {
  86.   lval* v = malloc(sizeof(lval));
  87.   v->type = LVAL_FUN;
  88.   v->fun = func;
  89.   return v;
  90. }
  92. lval* lval_sexpr(void) {
  93.   lval* v = malloc(sizeof(lval));
  94.   v->type = LVAL_SEXPR;
  95.   v->count = 0;
  96.   v->cell = NULL;
  97.   return v;
  98. }
  100. lval* lval_qexpr(void) {
  101.   lval* v = malloc(sizeof(lval));
  102.   v->type = LVAL_QEXPR;
  103.   v->count = 0;
  104.   v->cell = NULL;
  105.   return v;
  106. }
  108. void lval_del(lval* v) {
  110.   switch (v->type) {
  111.     case LVAL_NUM: break;
  112.     case LVAL_FUN: break;
  113.     case LVAL_ERR: free(v->err); break;
  114.     case LVAL_SYM: free(v->sym); break;
  115.     case LVAL_QEXPR:
  116.     case LVAL_SEXPR:
  117.       for (int i = 0; i < v->count; i++) {
  118.         lval_del(v->cell[i]);
  119.       }
  120.       free(v->cell);
  121.     break;
  122.   }
  124.   free(v);
  125. }
  127. lval* lval_copy(lval* v) {
  129.   lval* x = malloc(sizeof(lval));
  130.   x->type = v->type;
  132.   switch (v->type) {
  134.     /* Copy Functions and Numbers Directly */
  135.     case LVAL_FUN: x->fun = v->fun; break;
  136.     case LVAL_NUM: x->num = v->num; break;
  138.     /* Copy Strings using malloc and strcpy */
  139.     case LVAL_ERR:
  140.       x->err = malloc(strlen(v->err) + 1);
  141.       strcpy(x->err, v->err); break;
  143.     case LVAL_SYM:
  144.       x->sym = malloc(strlen(v->sym) + 1);
  145.       strcpy(x->sym, v->sym); break;
  147.     /* Copy Lists by copying each sub-expression */
  148.     case LVAL_SEXPR:
  149.     case LVAL_QEXPR:
  150.       x->count = v->count;
  151.       x->cell = malloc(sizeof(lval*) * x->count);
  152.       for (int i = 0; i < x->count; i++) {
  153.         x->cell[i] = lval_copy(v->cell[i]);
  154.       }
  155.     break;
  156.   }
  158.   return x;
  159. }
  161. lval* lval_add(lval* v, lval* x) {
  162.   v->count++;
  163.   v->cell = realloc(v->cell, sizeof(lval*) * v->count);
  164.   v->cell[v->count-1] = x;
  165.   return v;
  166. }
  168. lval* lval_join(lval* x, lval* y) {  
  169.   for (int i = 0; i < y->count; i++) {
  170.     x = lval_add(x, y->cell[i]);
  171.   }
  172.   free(y->cell);
  173.   free(y);  
  174.   return x;
  175. }
  177. lval* lval_pop(lval* v, int i) {
  178.   lval* x = v->cell[i];  
  179.   memmove(&v->cell[i], &v->cell[i+1],
  180.     sizeof(lval*) * (v->count-i-1));  
  181.   v->count--;  
  182.   v->cell = realloc(v->cell, sizeof(lval*) * v->count);
  183.   return x;
  184. }
  186. lval* lval_take(lval* v, int i) {
  187.   lval* x = lval_pop(v, i);
  188.   lval_del(v);
  189.   return x;
  190. }
  192. void lval_print(lval* v);
  194. void lval_print_expr(lval* v, char open, char close) {
  195.   putchar(open);
  196.   for (int i = 0; i < v->count; i++) {
  197.     lval_print(v->cell[i]);    
  198.     if (i != (v->count-1)) {
  199.       putchar(' ');
  200.     }
  201.   }
  202.   putchar(close);
  203. }
  205. void lval_print(lval* v) {
  206.   switch (v->type) {
  207.     case LVAL_FUN:   printf("<function>"); break;
  208.     case LVAL_NUM:   printf("%li", v->num); break;
  209.     case LVAL_ERR:   printf("Error: %s", v->err); break;
  210.     case LVAL_SYM:   printf("%s", v->sym); break;
  211.     case LVAL_SEXPR: lval_print_expr(v, '(', ')'); break;
  212.     case LVAL_QEXPR: lval_print_expr(v, '{', '}'); break;
  213.   }
  214. }
  216. void lval_println(lval* v) { lval_print(v); putchar('\n'); }
  218. char* ltype_name(int t) {
  219.   switch(t) {
  220.     case LVAL_FUN: return "Function";
  221.     case LVAL_NUM: return "Number";
  222.     case LVAL_ERR: return "Error";
  223.     case LVAL_SYM: return "Symbol";
  224.     case LVAL_SEXPR: return "S-Expression";
  225.     case LVAL_QEXPR: return "Q-Expression";
  226.     default: return "Unknown";
  227.   }
  228. }
  230. /* Lisp Environment */
  232. struct lenv {
  233.   int count;
  234.   char** syms;
  235.   lval** vals;
  236. };
  238. lenv* lenv_new(void) {
  240.   /* Initialize struct */
  241.   lenv* e = malloc(sizeof(lenv));
  242.   e->count = 0;
  243.   e->syms = NULL;
  244.   e->vals = NULL;
  245.   return e;
  247. }
  249. void lenv_del(lenv* e) {
  251.   /* Iterate over all items in environment deleting them */
  252.   for (int i = 0; i < e->count; i++) {
  253.     free(e->syms[i]);
  254.     lval_del(e->vals[i]);
  255.   }
  257.   /* Free allocated memory for lists */
  258.   free(e->syms);
  259.   free(e->vals);
  260.   free(e);
  261. }
  263. lval* lenv_get(lenv* e, lval* k) {
  265.   /* Iterate over all items in environment */
  266.   for (int i = 0; i < e->count; i++) {
  267.     /* Check if the stored string matches the symbol string */
  268.     /* If it does, return a copy of the value */
  269.     if (strcmp(e->syms[i], k->sym) == 0) {
  270.       return lval_copy(e->vals[i]);
  271.     }
  272.   }
  273.   /* If no symbol found return error */
  274.   return lval_err("Unbound Symbol '%s'", k->sym);
  275. }
  277. void lenv_put(lenv* e, lval* k, lval* v) {
  279.   /* Iterate over all items in environment */
  280.   /* This is to see if variable already exists */
  281.   for (int i = 0; i < e->count; i++) {
  283.     /* If variable is found delete item at that position */
  284.     /* And replace with variable supplied by user */
  285.     if (strcmp(e->syms[i], k->sym) == 0) {
  286.       lval_del(e->vals[i]);
  287.       e->vals[i] = lval_copy(v);
  288.       return;
  289.     }
  290.   }
  292.   /* If no existing entry found allocate space for new entry */
  293.   e->count++;
  294.   e->vals = realloc(e->vals, sizeof(lval*) * e->count);
  295.   e->syms = realloc(e->syms, sizeof(char*) * e->count);
  297.   /* Copy contents of lval and symbol string into new location */
  298.   e->vals[e->count-1] = lval_copy(v);
  299.   e->syms[e->count-1] = malloc(strlen(k->sym)+1);
  300.   strcpy(e->syms[e->count-1], k->sym);
  301. }
  303. /* Builtins */
  305. #define LASSERT(args, cond, fmt, ...) \
  306.   if (!(cond)) { lval* err = lval_err(fmt, ##__VA_ARGS__); lval_del(args); return err; }
  308. #define LASSERT_TYPE(func, args, index, expect) \
  309.   LASSERT(args, args->cell[index]->type == expect, \
  310.     "Function '%s' passed incorrect type for argument %i. Got %s, Expected %s.", \
  311.     func, index, ltype_name(args->cell[index]->type), ltype_name(expect))
  313. #define LASSERT_NUM(func, args, num) \
  314.   LASSERT(args, args->count == num, \
  315.     "Function '%s' passed incorrect number of arguments. Got %i, Expected %i.", \
  316.     func, args->count, num)
  318. #define LASSERT_NOT_EMPTY(func, args, index) \
  319.   LASSERT(args, args->cell[index]->count != 0, \
  320.     "Function '%s' passed {} for argument %i.", func, index);
  323. lval* lval_eval(lenv* e, lval* v);
  325. lval* builtin_list(lenv* e, lval* a) {
  326.   a->type = LVAL_QEXPR;
  327.   return a;
  328. }
  330. lval* builtin_head(lenv* e, lval* a) {
  331.   LASSERT_NUM("head", a, 1);
  332.   LASSERT_TYPE("head", a, 0, LVAL_QEXPR);
  333.   LASSERT_NOT_EMPTY("head", a, 0);
  335.   lval* v = lval_take(a, 0);  
  336.   while (v->count > 1) { lval_del(lval_pop(v, 1)); }
  337.   return v;
  338. }
  340. lval* builtin_tail(lenv* e, lval* a) {
  341.   LASSERT_NUM("tail", a, 1);
  342.   LASSERT_TYPE("tail", a, 0, LVAL_QEXPR);
  343.   LASSERT_NOT_EMPTY("tail", a, 0);
  345.   lval* v = lval_take(a, 0);  
  346.   lval_del(lval_pop(v, 0));
  347.   return v;
  348. }
  350. lval* builtin_eval(lenv* e, lval* a) {
  351.   LASSERT_NUM("eval", a, 1);
  352.   LASSERT_TYPE("eval", a, 0, LVAL_QEXPR);
  354.   lval* x = lval_take(a, 0);
  355.   x->type = LVAL_SEXPR;
  356.   return lval_eval(e, x);
  357. }
  359. lval* builtin_join(lenv* e, lval* a) {
  361.   for (int i = 0; i < a->count; i++) {
  362.     LASSERT_TYPE("join", a, i, LVAL_QEXPR);
  363.   }
  365.   lval* x = lval_pop(a, 0);
  367.   while (a->count) {
  368.     lval* y = lval_pop(a, 0);
  369.     x = lval_join(x, y);
  370.   }
  372.   lval_del(a);
  373.   return x;
  374. }
  376. lval* builtin_op(lenv* e, lval* a, char* op) {
  378.   for (int i = 0; i < a->count; i++) {
  379.     LASSERT_TYPE(op, a, i, LVAL_NUM);
  380.   }
  382.   lval* x = lval_pop(a, 0);
  384.   if ((strcmp(op, "-") == 0) && a->count == 0) {
  385.     x->num = -x->num;
  386.   }
  388.   while (a->count > 0) {  
  389.     lval* y = lval_pop(a, 0);
  391.     if (strcmp(op, "+") == 0) { x->num += y->num; }
  392.     if (strcmp(op, "-") == 0) { x->num -= y->num; }
  393.     if (strcmp(op, "*") == 0) { x->num *= y->num; }
  394.     if (strcmp(op, "/") == 0) {
  395.       if (y->num == 0) {
  396.         lval_del(x); lval_del(y);
  397.         x = lval_err("Division By Zero.");
  398.         break;
  399.       }
  400.       x->num /= y->num;
  401.     }
  403.     lval_del(y);
  404.   }
  406.   lval_del(a);
  407.   return x;
  408. }
  410. lval* builtin_add(lenv* e, lval* a) {
  411.   return builtin_op(e, a, "+");
  412. }
  414. lval* builtin_sub(lenv* e, lval* a) {
  415.   return builtin_op(e, a, "-");
  416. }
  418. lval* builtin_mul(lenv* e, lval* a) {
  419.   return builtin_op(e, a, "*");
  420. }
  422. lval* builtin_div(lenv* e, lval* a) {
  423.   return builtin_op(e, a, "/");
  424. }
  426. lval* builtin_def(lenv* e, lval* a) {
  428.   LASSERT_TYPE("def", a, 0, LVAL_QEXPR);
  430.   /* First argument is symbol list */
  431.   lval* syms = a->cell[0];
  433.   /* Ensure all elements of first list are symbols */
  434.   for (int i = 0; i < syms->count; i++) {
  435.     LASSERT(a, (syms->cell[i]->type == LVAL_SYM),
  436.       "Function 'def' cannot define non-symbol. "
  437.       "Got %s, Expected %s.",
  438.       ltype_name(syms->cell[i]->type), ltype_name(LVAL_SYM));
  439.   }
  441.   /* Check correct number of symbols and values */
  442.   LASSERT(a, (syms->count == a->count-1),
  443.     "Function 'def' passed too many arguments for symbols. "
  444.     "Got %i, Expected %i.",
  445.     syms->count, a->count-1);
  447.   /* Assign copies of values to symbols */
  448.   for (int i = 0; i < syms->count; i++) {
  449.     lenv_put(e, syms->cell[i], a->cell[i+1]);
  450.   }
  452.   lval_del(a);
  453.   return lval_sexpr();
  454. }
  456. void lenv_add_builtin(lenv* e, char* name, lbuiltin func) {
  457.   lval* k = lval_sym(name);
  458.   lval* v = lval_fun(func);
  459.   lenv_put(e, k, v);
  460.   lval_del(k); lval_del(v);
  461. }
  463. void lenv_add_builtins(lenv* e) {
  464.   /* Variable Functions */
  465.   lenv_add_builtin(e, "def", builtin_def);
  467.   /* List Functions */
  468.   lenv_add_builtin(e, "list", builtin_list);
  469.   lenv_add_builtin(e, "head", builtin_head);
  470.   lenv_add_builtin(e, "tail", builtin_tail);
  471.   lenv_add_builtin(e, "eval", builtin_eval);
  472.   lenv_add_builtin(e, "join", builtin_join);
  474.   /* Mathematical Functions */
  475.   lenv_add_builtin(e, "+", builtin_add);
  476.   lenv_add_builtin(e, "-", builtin_sub);
  477.   lenv_add_builtin(e, "*", builtin_mul);
  478.   lenv_add_builtin(e, "/", builtin_div);
  479. }
  481. /* Evaluation */
  483. lval* lval_eval_sexpr(lenv* e, lval* v) {
  485.   for (int i = 0; i < v->count; i++) {
  486.     v->cell[i] = lval_eval(e, v->cell[i]);
  487.   }
  489.   for (int i = 0; i < v->count; i++) {
  490.     if (v->cell[i]->type == LVAL_ERR) { return lval_take(v, i); }
  491.   }
  493.   if (v->count == 0) { return v; }  
  494.   if (v->count == 1) { return lval_take(v, 0); }
  496.   /* Ensure first element is a function after evaluation */
  497.   lval* f = lval_pop(v, 0);
  498.   if (f->type != LVAL_FUN) {
  499.     lval* err = lval_err(
  500.       "S-Expression starts with incorrect type. "
  501.       "Got %s, Expected %s.",
  502.       ltype_name(f->type), ltype_name(LVAL_FUN));
  503.     lval_del(f); lval_del(v);
  504.     return err;
  505.   }
  507.   /* If so call function to get result */
  508.   lval* result = f->fun(e, v);
  509.   lval_del(f);
  510.   return result;
  511. }
  513. lval* lval_eval(lenv* e, lval* v) {
  514.   if (v->type == LVAL_SYM) {
  515.     lval* x = lenv_get(e, v);
  516.     lval_del(v);
  517.     return x;
  518.   }
  519.   if (v->type == LVAL_SEXPR) { return lval_eval_sexpr(e, v); }
  520.   return v;
  521. }
  523. /* Reading */
  525. lval* lval_read_num(mpc_ast_t* t) {
  526.   errno = 0;
  527.   long x = strtol(t->contents, NULL, 10);
  528.   return errno != ERANGE ? lval_num(x) : lval_err("Invalid Number.");
  529. }
  531. lval* lval_read(mpc_ast_t* t) {
  533.   if (strstr(t->tag, "number")) { return lval_read_num(t); }
  534.   if (strstr(t->tag, "symbol")) { return lval_sym(t->contents); }
  536.   lval* x = NULL;
  537.   if (strcmp(t->tag, ">") == 0) { x = lval_sexpr(); } 
  538.   if (strstr(t->tag, "sexpr"))  { x = lval_sexpr(); }
  539.   if (strstr(t->tag, "qexpr"))  { x = lval_qexpr(); }
  541.   for (int i = 0; i < t->children_num; i++) {
  542.     if (strcmp(t->children[i]->contents, "(") == 0) { continue; }
  543.     if (strcmp(t->children[i]->contents, ")") == 0) { continue; }
  544.     if (strcmp(t->children[i]->contents, "}") == 0) { continue; }
  545.     if (strcmp(t->children[i]->contents, "{") == 0) { continue; }
  546.     if (strcmp(t->children[i]->tag,  "regex") == 0) { continue; }
  547.     x = lval_add(x, lval_read(t->children[i]));
  548.   }
  550.   return x;
  551. }
  553. /* Main */
  555. int main(int argc, char** argv) {
  557.   mpc_parser_t* Number = mpc_new("number");
  558.   mpc_parser_t* Symbol = mpc_new("symbol");
  559.   mpc_parser_t* Sexpr  = mpc_new("sexpr");
  560.   mpc_parser_t* Qexpr  = mpc_new("qexpr");
  561.   mpc_parser_t* Expr   = mpc_new("expr");
  562.   mpc_parser_t* Lispy  = mpc_new("lispy");
  564.   mpca_lang(MPCA_LANG_DEFAULT,
  565.     "                                                     \
  566.       number : /-?[0-9]+/ ;                               \
  567.       symbol : /[a-zA-Z0-9_+\\-*\\/\\\\=<>!&]+/ ;         \
  568.       sexpr  : '(' <expr>* ')' ;                          \
  569.       qexpr  : '{' <expr>* '}' ;                          \
  570.       expr   : <number> | <symbol> | <sexpr> | <qexpr> ;  \
  571.       lispy  : /^/ <expr>* /$/ ;                          \
  572.     ",
  573.     Number, Symbol, Sexpr, Qexpr, Expr, Lispy);
  575.   puts("Lispy Version 0.0.0.0.7");
  576.   puts("Press Ctrl+c to Exit\n");
  578.   lenv* e = lenv_new();
  579.   lenv_add_builtins(e);
  581.   while (1) {
  583.     char* input = readline("lispy> ");
  584.     add_history(input);
  586.     mpc_result_t r;
  587.     if (mpc_parse("<stdin>", input, Lispy, &r)) {
  588.       lval* x = lval_eval(e, lval_read(r.output));
  589.       lval_println(x);
  590.       lval_del(x);
  591.       mpc_ast_delete(r.output);
  592.     } else {    
  593.       mpc_err_print(r.error);
  594.       mpc_err_delete(r.error);
  595.     }
  597.     free(input);
  599.   }
  601.   lenv_del(e);
  603.   mpc_cleanup(6, Number, Symbol, Sexpr, Qexpr, Expr, Lispy);
  605.   return 0;
  606. }