(Somewhat adapted) code and solutions from the book "Build Your Own Lisp"
http://www.buildyourownlisp.com
You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
610 lines
14 KiB
610 lines
14 KiB
#include <stdio.h>
|
|
#include <stdlib.h>
|
|
#include <assert.h>
|
|
#include "../mpc/mpc.h"
|
|
|
|
|
|
/* If we are on Windows compile these functions */
|
|
#ifdef _WIN32
|
|
#include <string.h>
|
|
|
|
static char buffer[2048];
|
|
|
|
/* Fake readline function */
|
|
char* readline(char* prompt) {
|
|
fputs(prompt, stdout);
|
|
fgets(buffer, 2048, stdin);
|
|
char* cpy = malloc(strlen(buffer)+1);
|
|
assert(cpy != NULL)
|
|
strcpy(cpy, buffer);
|
|
cpy[strlen(cpy)-1] = '\0';
|
|
return cpy;
|
|
}
|
|
|
|
/* Fake add_history function */
|
|
void add_history(char* unused) {}
|
|
|
|
/* Otherwise include the editline headers
|
|
could use __APPLE__ for detection of OSX */
|
|
#else
|
|
#include <editline/readline.h>
|
|
#endif
|
|
|
|
/* Include type and function declarations */
|
|
#include "lispy.h"
|
|
|
|
|
|
/* Construct a pointer to a new number lval */
|
|
lval* lval_num(long x) {
|
|
lval* v = malloc(sizeof(lval));
|
|
assert(v != NULL);
|
|
v->type = LVAL_NUM;
|
|
v->num = x;
|
|
return v;
|
|
}
|
|
|
|
|
|
/* Construct a pointer to a new decimal lval */
|
|
lval* lval_dec(double x) {
|
|
lval* v = malloc(sizeof(lval));
|
|
assert(v != NULL);
|
|
v->type = LVAL_DEC;
|
|
v->dec = x;
|
|
return v;
|
|
}
|
|
|
|
|
|
/* Construct a pointer to a new error lval */
|
|
lval* lval_err(char* m) {
|
|
lval* v = malloc(sizeof(lval));
|
|
assert(v != NULL);
|
|
v->type = LVAL_ERR;
|
|
v->err = malloc(strlen(m)+1);
|
|
assert(v->err != NULL);
|
|
strcpy(v->err, m);
|
|
return v;
|
|
}
|
|
|
|
|
|
/* Construct a pointer to a new symbol lval */
|
|
lval* lval_sym(char* s) {
|
|
lval* v = malloc(sizeof(lval));
|
|
assert(v != NULL);
|
|
v->type = LVAL_SYM;
|
|
v->sym = malloc(strlen(s)+1);
|
|
assert(v->sym != NULL);
|
|
strcpy(v->sym, s);
|
|
return v;
|
|
}
|
|
|
|
|
|
/* Construct a pointer to a new empty sexpr lval */
|
|
lval* lval_sexpr(void) {
|
|
lval* v = malloc(sizeof(lval));
|
|
assert(v != NULL);
|
|
v->type = LVAL_SEXPR;
|
|
v->count = 0;
|
|
v->cell = NULL;
|
|
return v;
|
|
}
|
|
|
|
|
|
/* Construct a pointer to a new empty qexpr lval */
|
|
lval* lval_qexpr(void) {
|
|
lval* v = malloc(sizeof(lval));
|
|
assert(v != NULL);
|
|
v->type = LVAL_QEXPR;
|
|
v->count = 0;
|
|
v->cell = NULL;
|
|
return v;
|
|
}
|
|
|
|
|
|
/* Free memory of an lval and all its members */
|
|
void lval_del(lval* v) {
|
|
|
|
switch (v->type) {
|
|
/* Do nothing special for number / decimal type */
|
|
case LVAL_NUM:
|
|
case LVAL_DEC:
|
|
break;
|
|
|
|
/* For err or sym free the string data */
|
|
case LVAL_ERR:
|
|
free(v->err);
|
|
break;
|
|
case LVAL_SYM:
|
|
free(v->sym);
|
|
break;
|
|
|
|
/* If sexpr then delete all elements inside */
|
|
case LVAL_SEXPR:
|
|
case LVAL_QEXPR:
|
|
for (size_t i = 0; i < v->count; i++) {
|
|
lval_del(v->cell[i]);
|
|
}
|
|
/* Also free the memory allocated to contain
|
|
the pointers */
|
|
free(v->cell);
|
|
break;
|
|
}
|
|
/* Free the memory allocated for the lval struct itself */
|
|
free(v);
|
|
}
|
|
|
|
|
|
lval* lval_read_num(mpc_ast_t* t) {
|
|
errno = 0;
|
|
if (strstr(t->contents, ".")) {
|
|
double x = strtod(t->contents, NULL);
|
|
return errno != ERANGE ? lval_dec(x)
|
|
: lval_err("Invalid number");
|
|
} else {
|
|
long x = strtol(t->contents, NULL, 10);
|
|
return errno != ERANGE ? lval_num(x)
|
|
: lval_err("Invalid number");
|
|
}
|
|
}
|
|
|
|
|
|
lval* lval_read(mpc_ast_t* t) {
|
|
|
|
/* If symbol or number return conversion to that type */
|
|
if (strstr(t->tag, "number")) {
|
|
return lval_read_num(t);
|
|
}
|
|
if (strstr(t->tag, "symbol")) {
|
|
return lval_sym(t->contents);
|
|
}
|
|
|
|
/* If root (>) or sexpr then create empty list */
|
|
lval* x = NULL;
|
|
if (strcmp(t->tag, ">") == 0 || strstr(t->tag, "sexpr")) {
|
|
x = lval_sexpr();
|
|
}
|
|
|
|
/* If qexpr create then empty list */
|
|
if (strstr(t->tag, "qexpr")) {
|
|
x = lval_qexpr();
|
|
}
|
|
|
|
/* Fill this list with any valid expression
|
|
contained within */
|
|
for (size_t i = 0; i < (size_t) t->children_num; i++) {
|
|
if (strcmp(t->children[i]->contents, "(") == 0) {
|
|
continue;
|
|
}
|
|
if (strcmp(t->children[i]->contents, ")") == 0) {
|
|
continue;
|
|
}
|
|
if (strcmp(t->children[i]->contents, "{") == 0) {
|
|
continue;
|
|
}
|
|
if (strcmp(t->children[i]->contents, "}") == 0) {
|
|
continue;
|
|
}
|
|
if (strcmp(t->children[i]->tag, "regex") == 0) {
|
|
continue;
|
|
}
|
|
x = lval_add(x, lval_read(t->children[i]));
|
|
}
|
|
|
|
return x;
|
|
}
|
|
|
|
|
|
lval* lval_add(lval* v, lval* x) {
|
|
v->count++;
|
|
v->cell = realloc(v->cell, sizeof(lval*) * v->count);
|
|
assert(v->cell != NULL);
|
|
v->cell[v->count-1] = x;
|
|
return v;
|
|
}
|
|
|
|
|
|
void lval_expr_print(lval* v, char open, char close) {
|
|
/* Opening char */
|
|
putchar(open);
|
|
|
|
for (size_t i = 0; i < v->count; i++) {
|
|
/* Print value contained within */
|
|
lval_print(v->cell[i]);
|
|
/* Don't print trailing space if last element */
|
|
if (i != (v->count-1)) {
|
|
putchar(' ');
|
|
}
|
|
}
|
|
/* Opening char */
|
|
putchar(close);
|
|
}
|
|
|
|
|
|
/* Print an lval */
|
|
void lval_print(lval* v) {
|
|
|
|
switch (v->type) {
|
|
/* In the case the type is a number print it
|
|
Then break out of the switch */
|
|
case LVAL_NUM:
|
|
printf("%li", v->num);
|
|
break;
|
|
case LVAL_DEC:
|
|
printf("%.2f", v->dec);
|
|
break;
|
|
/* In the case the type is an error */
|
|
case LVAL_ERR:
|
|
printf("Error: %s", v->err);
|
|
break;
|
|
case LVAL_SYM:
|
|
printf("%s", v->sym);
|
|
break;
|
|
case LVAL_SEXPR:
|
|
lval_expr_print(v, '(', ')');
|
|
break;
|
|
case LVAL_QEXPR:
|
|
lval_expr_print(v, '{', '}');
|
|
break;
|
|
}
|
|
|
|
}
|
|
|
|
|
|
/* Print an lval followed by a newline */
|
|
void lval_println(lval* v) {
|
|
lval_print(v);
|
|
putchar('\n');
|
|
}
|
|
|
|
|
|
lval* lval_eval_sexpr(lval* v) {
|
|
|
|
/* Evaluate children */
|
|
for (size_t i = 0; i < v->count; i++) {
|
|
v->cell[i] = lval_eval(v->cell[i]);
|
|
}
|
|
|
|
/* Error checking */
|
|
for (size_t i = 0; i < v->count; i++) {
|
|
if (v->cell[i]->type == LVAL_ERR) {
|
|
return lval_take(v, i);
|
|
}
|
|
}
|
|
|
|
/* Empty expression */
|
|
if (v->count == 0) {
|
|
return v;
|
|
}
|
|
|
|
/* Single expression */
|
|
if (v->count == 1) {
|
|
return lval_take(v, 0);
|
|
}
|
|
|
|
/* Ensure first element is symbol */
|
|
lval* f = lval_pop(v, 0);
|
|
if (f->type != LVAL_SYM) {
|
|
lval_del(f);
|
|
lval_del(v);
|
|
return lval_err("S-expression does not start with symbol!");
|
|
}
|
|
|
|
/* Call builtin with operator */
|
|
lval* result = builtin(v, f->sym);
|
|
lval_del(f);
|
|
return result;
|
|
|
|
}
|
|
|
|
|
|
lval* lval_eval(lval* v) {
|
|
|
|
/* Evaluate sexpressions */
|
|
if (v->type == LVAL_SEXPR) {
|
|
return lval_eval_sexpr(v);
|
|
}
|
|
|
|
/* All other lval types remain the same */
|
|
return v;
|
|
|
|
}
|
|
|
|
|
|
lval* lval_pop(lval* v, size_t i) {
|
|
|
|
/* Fine the item at i */
|
|
lval* x = v->cell[i];
|
|
|
|
/* Shift memory after the item at i over the top */
|
|
memmove(&v->cell[i], &v->cell[i+1],
|
|
sizeof(lval*) * (v->count-i-1));
|
|
|
|
/* Decrease the count of items in the list */
|
|
v->count--;
|
|
|
|
/* Reallocate the memory used */
|
|
v->cell = realloc(v->cell, sizeof(lval*) * v->count);
|
|
assert(v->cell != NULL);
|
|
|
|
return x;
|
|
|
|
}
|
|
|
|
lval* lval_take(lval* v, size_t i) {
|
|
|
|
lval* x = lval_pop(v, i);
|
|
lval_del(v);
|
|
return x;
|
|
|
|
}
|
|
|
|
|
|
lval* builtin(lval* a, char* func) {
|
|
|
|
/* Check for builtin functions */
|
|
if (strcmp("list", func) == 0) {return builtin_list(a);}
|
|
if (strcmp("head", func) == 0) {return builtin_head(a);}
|
|
if (strcmp("tail", func) == 0) {return builtin_tail(a);}
|
|
if (strcmp("join", func) == 0) {return builtin_join(a);}
|
|
if (strcmp("eval", func) == 0) {return builtin_eval(a);}
|
|
|
|
/* Check for operators */
|
|
if (strstr("+-*/%^", func) ||
|
|
strcmp("min", func) == 0 || strcmp("max", func) == 0) {
|
|
return builtin_op(a, func);
|
|
}
|
|
|
|
lval_del(a);
|
|
return lval_err("Unknown function!");
|
|
|
|
}
|
|
|
|
|
|
lval* builtin_op(lval* a, char* op) {
|
|
|
|
/* Ensure all arguments are numbers */
|
|
for (size_t i = 0; i < a->count; i++) {
|
|
if (a->cell[i]->type != LVAL_NUM && a->cell[i]->type != LVAL_DEC) {
|
|
lval_del(a);
|
|
return lval_err("Cannot operate on non-number/non-decimal!");
|
|
}
|
|
}
|
|
|
|
/* Pop the 1st element */
|
|
lval* x = lval_pop(a, 0);
|
|
|
|
/* If no arguments and sub then perform unary negation */
|
|
if (strcmp(op, "-") == 0 && a->count == 0) {
|
|
if (x->type == LVAL_NUM) {
|
|
x->num = -x->num;
|
|
} else {
|
|
x->dec = -x->dec;
|
|
}
|
|
}
|
|
|
|
/* While there are still elements remaining */
|
|
while (a->count > 0) {
|
|
/* Pop the next element */
|
|
lval* y = lval_pop(a, 0);
|
|
if (x->type == LVAL_NUM && y->type == LVAL_NUM) {
|
|
if (strcmp(op, "+") == 0) {x->num += y->num;}
|
|
if (strcmp(op, "-") == 0) {x->num -= y->num;}
|
|
if (strcmp(op, "*") == 0) {x->num *= y->num;}
|
|
if (strcmp(op, "/") == 0) {
|
|
/* If second operand is zero return error */
|
|
if (y->num == 0) {
|
|
lval_del(x);
|
|
lval_del(y);
|
|
x = lval_err("Division by zero!");
|
|
break;
|
|
}
|
|
x->num /= y->num;
|
|
}
|
|
if (strcmp(op, "%") == 0) {x->num %= y->num;}
|
|
if (strcmp(op, "^") == 0) {x->num = (pow(x->num, y->num));}
|
|
if (strcmp(op, "min") == 0) {x->num = min(x->num, y->num);}
|
|
if (strcmp(op, "max") == 0) {x->num = max(x->num, y->num);}
|
|
} else {
|
|
/* Cast integer number into double if necessary */
|
|
double b = x->type == LVAL_NUM ? (double) x->num : x->dec;
|
|
double c = y->type == LVAL_NUM ? (double) y->num : y->dec;
|
|
/* Perform all operations on double */
|
|
if (strcmp(op, "+") == 0) {b += c;}
|
|
if (strcmp(op, "-") == 0) {b -= c;}
|
|
if (strcmp(op, "*") == 0) {b *= c;}
|
|
if (strcmp(op, "/") == 0) {
|
|
/* If second operand is zero return error */
|
|
if (c == 0) {
|
|
lval_del(x);
|
|
lval_del(y);
|
|
x = lval_err("Division by zero!");
|
|
break;
|
|
}
|
|
b /= c;
|
|
}
|
|
if (strcmp(op, "%") == 0) {b = fmod(b, c);}
|
|
if (strcmp(op, "^") == 0) {b = (pow(b, c));}
|
|
if (strcmp(op, "min") == 0) {b = fmin(b, c);}
|
|
if (strcmp(op, "max") == 0) {b = fmax(b, c);}
|
|
x->type = LVAL_DEC;
|
|
x->dec = b;
|
|
}
|
|
}
|
|
|
|
lval_del(a);
|
|
return x;
|
|
|
|
}
|
|
|
|
|
|
lval* builtin_head(lval* a) {
|
|
|
|
/* Check error conditions */
|
|
LASSERT(a, a->count == 1,
|
|
"Function 'head' passed too many arguments!");
|
|
|
|
LASSERT(a, a->cell[0]->type == LVAL_QEXPR,
|
|
"Function 'head' passed incorrect type!");
|
|
|
|
LASSERT(a, a->cell[0]->count != 0,
|
|
"Function 'head' passed {}!");
|
|
|
|
/* Otherwise take first argument */
|
|
lval* v = lval_take(a, 0);
|
|
|
|
/* Delete all elements that are not head and return */
|
|
while (v-> count > 1) {
|
|
lval_del(lval_pop(v, 1));
|
|
}
|
|
|
|
return v;
|
|
|
|
}
|
|
|
|
|
|
lval* builtin_tail(lval* a) {
|
|
|
|
/* Check error conditions */
|
|
LASSERT(a, a->count == 1,
|
|
"Function 'tail' passed too many arguments!");
|
|
|
|
LASSERT(a, a->cell[0]->type == LVAL_QEXPR,
|
|
"Function 'tail' passed incorrect type!");
|
|
|
|
LASSERT(a, a->cell[0]->count != 0,
|
|
"Function 'tail' passed {}!");
|
|
|
|
/* Otherwise take first argument */
|
|
lval* v = lval_take(a, 0);
|
|
|
|
/* Delete first element and return */
|
|
lval_del(lval_pop(v, 0));
|
|
|
|
return v;
|
|
|
|
}
|
|
|
|
|
|
lval* builtin_list(lval* a) {
|
|
|
|
a->type = LVAL_QEXPR;
|
|
return a;
|
|
|
|
}
|
|
|
|
|
|
lval* builtin_eval(lval* a) {
|
|
|
|
/* Check error conditions */
|
|
LASSERT(a, a->count == 1,
|
|
"Function 'eval' passed too many arguments!");
|
|
|
|
LASSERT(a, a->cell[0]->type == LVAL_QEXPR,
|
|
"Function 'eval' passed incorrect type!");
|
|
|
|
lval* x = lval_take(a, 0);
|
|
x->type = LVAL_SEXPR;
|
|
return lval_eval(x);
|
|
|
|
}
|
|
|
|
|
|
lval* builtin_join(lval* a) {
|
|
|
|
/* Check error conditions */
|
|
for (size_t i = 0; i < a->count; i++) {
|
|
LASSERT(a, a->cell[i]->type == LVAL_QEXPR,
|
|
"Function 'join' passed incorrect type!");
|
|
}
|
|
|
|
lval* x = lval_pop(a, 0);
|
|
|
|
while (a->count) {
|
|
x = lval_join(x, lval_pop(a, 0));
|
|
}
|
|
|
|
lval_del(a);
|
|
return x;
|
|
|
|
}
|
|
|
|
|
|
lval* lval_join(lval* x, lval* y) {
|
|
|
|
/* For each cell in y add it to x */
|
|
while (y->count) {
|
|
x = lval_add(x, lval_pop(y, 0));
|
|
}
|
|
|
|
/* Delete the empty y and return x */
|
|
lval_del(y);
|
|
return x;
|
|
|
|
}
|
|
|
|
|
|
long min(long x, long y) {
|
|
if (x <= y) {
|
|
return x;
|
|
} else {
|
|
return y;
|
|
}
|
|
}
|
|
|
|
|
|
long max(long x, long y) {
|
|
if (x >= y) {
|
|
return x;
|
|
} else {
|
|
return y;
|
|
}
|
|
}
|
|
|
|
|
|
int main() {
|
|
|
|
/* Create some parsers */
|
|
mpc_parser_t* Number = mpc_new("number");
|
|
mpc_parser_t* Symbol = mpc_new("symbol");
|
|
mpc_parser_t* Sexpr = mpc_new("sexpr");
|
|
mpc_parser_t* Qexpr = mpc_new("qexpr");
|
|
mpc_parser_t* Expr = mpc_new("expr");
|
|
mpc_parser_t* Lispy = mpc_new("lispy");
|
|
|
|
/* Define them with the following language */
|
|
mpca_lang(MPCA_LANG_DEFAULT, parser,
|
|
Number, Symbol, Sexpr, Qexpr, Expr, Lispy);
|
|
|
|
/* Print version and exit information */
|
|
puts(lispy_version);
|
|
puts("Press Ctrl+c to exit\n");
|
|
|
|
/* In a never ending loop */
|
|
while (1) {
|
|
/* Output our prompt and get input */
|
|
char* input = readline("lispy> ");
|
|
|
|
/* Add input to history */
|
|
add_history(input);
|
|
|
|
/* Attempt to parse the user input */
|
|
mpc_result_t r;
|
|
if (mpc_parse("<stdin>", input, Lispy, &r)) {
|
|
/* On success evaluate the user input */
|
|
lval* x = lval_eval(lval_read(r.output));
|
|
lval_println(x);
|
|
lval_del(x);
|
|
} else {
|
|
/* Otherwise print the error */
|
|
mpc_err_print(r.error);
|
|
mpc_err_delete(r.error);
|
|
}
|
|
|
|
/* Free retrieved input */
|
|
free(input);
|
|
}
|
|
|
|
/* Undefine and delete our parsers */
|
|
mpc_cleanup(6, Number, Symbol, Sexpr, Qexpr, Expr, Lispy);
|
|
|
|
return 0;
|
|
}
|