目录
前言
通过开发一门类 Lisp 的编程语言来理解编程语言的设计思想，本实践来自著名的《Build Your Own Lisp》。
- 代码实现：https://github.com/JmilkFan/Lispy
前文列表
《用 C 语言开发一门编程语言 — 交互式解析器》
《用 C 语言开发一门编程语言 — 语法解析器运行原理》
《用 C 语言开发一门编程语言 — 波兰表达式解析器》
《用 C 语言开发一门编程语言 — 表达式存储器》
《用 C 语言开发一门编程语言 — 符号表达式解析器》
《用 C 语言开发一门编程语言 — 引用表达式解析器》
《用 C 语言开发一门编程语言 — 变量的设计与实现》
《用 C 语言开发一门编程语言 — 基于 Lambda 表达式的函数设计与实现》
条件分支
为了支持条件判断的语法功能，我们会为此实现几个 builtin 函数，包括：
- 大于小于函数
- 等于函数
- if 函数
- 递归函数
实现效果：
Lispy Version 0.1
Press Ctrl+c to Exit
lispy> > 10 5
1
lispy> <= 88 5
0
lispy> == 5 6
0
lispy> == 5 {}
0
lispy> == 1 1
1
lispy> != {} 56
1
lispy> == {1 2 3 {5 6}} {1 2 3 {5 6}}
1
lispy> def {x y} 100 200
()
lispy> if (== x y) {+ x y} {- x y}
-100
- 首先，进行断言检查。
- 然后，比较参数中的数字获得结果。
- 最后，将结果返回。
大小比较函数
大小比较函数用于比较两个 Number 类型数据，并返回 0（False）或 1（True）结果。我们使用 C 语言的比较运算符就可以做到这一点。
lval* builtin_gt(lenv* e, lval* a) {
return builtin_ord(e, a, ">");
}
lval* builtin_lt(lenv* e, lval* a) {
return builtin_ord(e, a, "<");
}
lval* builtin_ge(lenv* e, lval* a) {
return builtin_ord(e, a, ">=");
}
lval* builtin_le(lenv* e, lval* a) {
return builtin_ord(e, a, "<=");
}
lval* builtin_ord(lenv* e, lval* a, char* op) {
LASSERT_NUM(op, a, 2);
LASSERT_TYPE(op, a, 0, LVAL_NUM);
LASSERT_TYPE(op, a, 1, LVAL_NUM);
int r;
if (strcmp(op, ">") == 0) {
r = (a->cell[0]->num > a->cell[1]->num);
}
if (strcmp(op, "<") == 0) {
r = (a->cell[0]->num < a->cell[1]->num);
}
if (strcmp(op, ">=") == 0) {
r = (a->cell[0]->num >= a->cell[1]->num);
}
if (strcmp(op, "<=") == 0) {
r = (a->cell[0]->num <= a->cell[1]->num);
}
lval_del(a);
return lval_num(r);
}
- 22
- 23
- 24
- 25
- 26
- 27
- 28
- 29
- 30
- 31
- 32
- 33
- 34
- 35
- 36
- 37
等于比较函数
区别于大小比较函数，等于比较函数处理能够处理 Number 类型数据之外，还可以用于判断输入是否为空列表，活着判断两个函数是否相同。
基于我们将 Lispy Values 作为用户输入数据的存储器，所以等于函数的本质是比较两个 lval 数据的所有字段是否都相等。最后我们将比较结果存储到一个新的 lval 中并返回它。
int lval_eq(lval* x, lval* y) {
/* Different Types are always unequal */
if (x->type != y->type) { return 0; }
/* Compare Based upon type */
switch (x->type) {
/* Compare Number Value */
case LVAL_NUM: return (x->num == y->num);
/* Compare String Values */
case LVAL_ERR: return (strcmp(x->err, y->err) == 0);
case LVAL_SYM: return (strcmp(x->sym, y->sym) == 0);
/* If builtin compare, otherwise compare formals and body */
case LVAL_FUN:
if (x->builtin || y->builtin) {
return x->builtin == y->builtin;
} else {
return lval_eq(x->formals, y->formals)
&& lval_eq(x->body, y->body);
}
/* If list compare every individual element */
case LVAL_QEXPR:
case LVAL_SEXPR:
if (x->count != y->count) { return 0; }
for (int i = 0; i < x->count; i++) {
/* If any element not equal then whole list not equal */
if (!lval_eq(x->cell[i], y->cell[i])) { return 0; }
}
/* Otherwise lists must be equal */
return 1;
break;
}
return 0;
}
lval* builtin_cmp(lenv* e, lval* a, char* op) {
LASSERT_NUM(op, a, 2);
int r;
if (strcmp(op, "==") == 0) {
r = lval_eq(a->cell[0], a->cell[1]);
}
if (strcmp(op, "!=") == 0) {
r = !lval_eq(a->cell[0], a->cell[1]);
}
lval_del(a);
return lval_num(r);
}
lval* builtin_eq(lenv* e, lval* a) {
return builtin_cmp(e, a, "==");
}
lval* builtin_ne(lenv* e, lval* a) {
return builtin_cmp(e, a, "!=");
}
- 22
- 23
- 24
- 25
- 26
- 27
- 28
- 29
- 30
- 31
- 32
- 33
- 34
- 35
- 36
- 37
- 38
- 39
- 40
- 41
- 42
- 43
- 44
- 45
- 46
- 47
- 48
- 49
- 50
- 51
- 52
- 53
- 54
- 55
- 56
- 57
- 58
if 关键字函数
还需要为条件分支引入一个新的 if 关键字函数，语法规则类型与 C 语言中的三目运算符。
条件分支的代码体，我们依旧使用 2 个 Q-Expression 来表示，分别表示在条件结果为 True 或 False 时进行求值的代码。
lval* builtin_if(lenv* e, lval* a) {
LASSERT_NUM("if", a, 3);
LASSERT_TYPE("if", a, 0, LVAL_NUM);
LASSERT_TYPE("if", a, 1, LVAL_QEXPR);
LASSERT_TYPE("if", a, 2, LVAL_QEXPR);
/* Mark Both Expressions as evaluable */
lval* x;
a->cell[1]->type = LVAL_SEXPR;
a->cell[2]->type = LVAL_SEXPR;
if (a->cell[0]->num) {
/* If condition is true evaluate first expression */
x = lval_eval(e, lval_pop(a, 1));
} else {
/* Otherwise evaluate second expression */
x = lval_eval(e, lval_pop(a, 2));
}
/* Delete argument list and return */
lval_del(a);
return x;
}
- 22
- 23
函数注册
最后，我们将上述实现的所有 builtin 函数注册到函数路由器中。
/* Comparison Functions */
lenv_add_builtin(e, "if", builtin_if);
lenv_add_builtin(e, "==", builtin_eq);
lenv_add_builtin(e, "!=", builtin_ne);
lenv_add_builtin(e, ">", builtin_gt);
lenv_add_builtin(e, "<", builtin_lt);
lenv_add_builtin(e, ">=", builtin_ge);
lenv_add_builtin(e, "<=", builtin_le);
- 1
- 2
- 3
- 4
- 5
- 6
- 7
- 8
源代码
#include <stdio.h>
#include <stdlib.h>
#include "mpc.h"
#define LASSERT(args, cond, fmt, ...) \
if (!(cond)) { lval* err = lval_err(fmt, ##__VA_ARGS__); lval_del(args); return err; }
#define LASSERT_TYPE(func, args, index, expect) \
LASSERT(args, args->cell[index]->type == expect, \
"Function '%s' passed incorrect type for argument %i. Got %s, Expected %s.", \
func, index, ltype_name(args->cell[index]->type), ltype_name(expect))
#define LASSERT_NUM(func, args, num) \
LASSERT(args, args->count == num, \
"Function '%s' passed incorrect number of arguments. Got %i, Expected %i.", \
func, args->count, num)
#define LASSERT_NOT_EMPTY(func, args, index) \
LASSERT(args, args->cell[index]->count != 0, \
"Function '%s' passed {} for argument %i.", func, index);
#ifdef _WIN32
#include <string.h>
static char buffer[2048];
char *readline(char *prompt) {
fputs(prompt, stdout);
fgets(buffer, 2048, stdin);
char *cpy = malloc(strlen(buffer) + 1);
strcpy(cpy, buffer);
cpy[strlen(cpy) - 1] = '\0';
return cpy;
}
void add_history(char *unused) {}
#else
#ifdef __linux__
#include <readline/readline.h>
#include <readline/history.h>
#endif
#ifdef __MACH__
#include <readline/readline.h>
#endif
#endif
/* Forward Declarations */
struct lval;
struct lenv;
typedef struct lval lval;
typedef struct lenv lenv;
/* Lisp Value Type Enumeration */
enum {
LVAL_NUM,
LVAL_ERR,
LVAL_SYM,
LVAL_FUN,
LVAL_SEXPR,
LVAL_QEXPR
};
typedef lval *(*lbuiltin)(lenv*, lval*);
/* Declare lisp lval Struct */
struct lval {
int type;
/* Basic */
long num;
char *err;
char *sym;
/* Function */
lbuiltin builtin;
lenv *env;
lval *formals;
lval *body;
/* Expression */
int count;
struct lval **cell;
};
/* Construct a pointer to a new Number lval */
lval *lval_num(long x) {
lval *v = malloc(sizeof(lval));
v->type = LVAL_NUM;
v->num = x;
return v;
}
char *ltype_name(int t) {
switch(t) {
case LVAL_FUN: return "Function";
case LVAL_NUM: return "Number";
case LVAL_ERR: return "Error";
case LVAL_SYM: return "Symbol";
case LVAL_SEXPR: return "S-Expression";
case LVAL_QEXPR: return "Q-Expression";
default: return "Unknown";
}
}
/* Construct a pointer to a new Error lval */
lval *lval_err(char *fmt, ...) {
lval *v = malloc(sizeof(lval));
v->type = LVAL_ERR;
/* Create a va list and initialize it */
va_list va;
va_start(va, fmt);
/* Allocate 512 bytes of space */
v->err = malloc(512);
/* printf the error string with a maximum of 511 characters */
vsnprintf(v->err, 511, fmt, va);
/* Reallocate to number of bytes actually used */
v->err = realloc(v->err, strlen(v->err)+1);
/* Cleanup our va list */
va_end(va);
return v;
}
/* Construct a pointer to a new Symbol lval */
lval *lval_sym(char *sym) {
lval *v = malloc(sizeof(lval));
v->type = LVAL_SYM;
v->sym = malloc(strlen(sym) + 1);
strcpy(v->sym, sym);
return v;
}
/* A pointer to a new empty Sexpr lval */
lval *lval_sexpr(void) {
lval *v = malloc(sizeof(lval));
v->type = LVAL_SEXPR;
v->count = 0;
v->cell = NULL;
return v;
}
/* A pointer to a new empty Qexpr lval */
lval *lval_qexpr(void) {
lval *v = malloc(sizeof(lval));
v->type = LVAL_QEXPR;
v->count = 0;
v->cell = NULL;
return v;
}
lval* lval_builtin(lbuiltin func) {
lval *v = malloc(sizeof(lval));
v->type = LVAL_FUN;
v->builtin = func;
return v;
}
struct lenv {
lenv *par;
int count;
char **syms;
lval **vals;
};
lenv *lenv_new(void) {
lenv *e = malloc(sizeof(lenv));
e->par = NULL;
e->count = 0;
e->syms = NULL;
e->vals = NULL;
return e;
}
lval *lval_lambda(lval *formals, lval *body) {
lval *v = malloc(sizeof(lval));
v->type = LVAL_FUN;
/* Set Builtin to Null */
v->builtin = NULL;
/* Build new environment */
v->env = lenv_new();
/* Set Formals and Body */
v->formals = formals;
v->body = body;
return v;
}
void lenv_del(lenv *e);
void lval_del(lval *v) {
switch (v->type) {
/* Do nothing special for number type */
case LVAL_NUM:
break;
/* For Err or Sym free the string data */
case LVAL_ERR:
free(v->err);
break;
case LVAL_SYM:
free(v->sym);
break;
case LVAL_FUN:
if (!v->builtin) {
lenv_del(v->env);
lval_del(v->formals);
lval_del(v->body);
}
break;
/* If Qexpr or Sexpr then delete all elements inside */
case LVAL_QEXPR:
case LVAL_SEXPR:
for (int 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);
}
void lenv_del(lenv *e) {
for (int i = 0; i < e->count; i++) {
free(e->syms[i]);
lval_del(e->vals[i]);
}
free(e->syms);
free(e->vals);
free(e);
}
lval *lval_copy(lval *v);
lenv *lenv_copy(lenv *e) {
lenv *n = malloc(sizeof(lenv));
n->par = e->par;
n->count = e->count;
n->syms = malloc(sizeof(char*) * n->count);
n->vals = malloc(sizeof(lval*) * n->count);
for (int i = 0; i < e->count; i++) {
n->syms[i] = malloc(strlen(e->syms[i]) + 1);
strcpy(n->syms[i], e->syms[i]);
n->vals[i] = lval_copy(e->vals[i]);
}
return n;
}
lval *lval_copy(lval *v) {
lval *x = malloc(sizeof(lval));
x->type = v->type;
switch (v->type) {
/* Copy Functions and Numbers Directly */
case LVAL_FUN:
if (v->builtin) {
x->builtin = v->builtin;
} else {
x->builtin = NULL;
x->env = lenv_copy(v->env);
x->formals = lval_copy(v->formals);
x->body = lval_copy(v->body);
}
break;
case LVAL_NUM: x->num = v->num; break;
/* Copy Strings using malloc and strcpy */
case LVAL_ERR:
x->err = malloc(strlen(v->err) + 1);
strcpy(x->err, v->err);
break;
case LVAL_SYM:
x->sym = malloc(strlen(v->sym) + 1);
strcpy(x->sym, v->sym);
break;
/* Copy Lists by copying each sub-expression */
case LVAL_SEXPR:
case LVAL_QEXPR:
x->count = v->count;
x->cell = malloc(sizeof(lval*) * x->count);
for (int i = 0; i < x->count; i++) {
x->cell[i] = lval_copy(v->cell[i]);
}
break;
}
return x;
}
lval *lenv_get(lenv *e, lval *k) {
/* Iterate over all items in environment */
for (int i = 0; i < e->count; i++) {
/* Check if the stored string matches the symbol string */
/* If it does, return a copy of the value */
if (strcmp(e->syms[i], k->sym) == 0) {
return lval_copy(e->vals[i]);
}
}
/* If no symbol check in parent otherwise error */
if (e->par) {
return lenv_get(e->par, k);
} else {
return lval_err("Unbound Symbol '%s'", k->sym);
}
}
void lenv_put(lenv *e, lval *k, lval *v) {
/* Iterate over all items in environment */
/* This is to see if variable already exists */
for (int i = 0; i < e->count; i++) {
/* If variable is found delete item at that position */
/* And replace with variable supplied by user */
if (strcmp(e->syms[i], k->sym) == 0) {
lval_del(e->vals[i]);
e->vals[i] = lval_copy(v);
return;
}
}
/* If no existing entry found allocate space for new entry */
e->count++;
e->vals = realloc(e->vals, sizeof(lval*) * e->count);
e->syms = realloc(e->syms, sizeof(char*) * e->count);
/* Copy contents of lval and symbol string into new location */
e->vals[e->count-1] = lval_copy(v);
e->syms[e->count-1] = malloc(strlen(k->sym)+1);
strcpy(e->syms[e->count-1], k->sym);
}
void lenv_def(lenv *e, lval *k, lval *v) {
/* Iterate till e has no parent */
while (e->par) {
e = e->par;
}
/* Put value in e */
lenv_put(e, k, v);
}
lval *lval_add(lval *v, lval *x) {
v->count++;
v->cell = realloc(v->cell, sizeof(lval*) * v->count);
v->cell[v->count-1] = x;
return v;
}
lval *lval_read_num(mpc_ast_t *t) {
errno = 0;
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) {
x = lval_sexpr();
}
if (strstr(t->tag, "sexpr")) {
x = lval_sexpr();
}
if (strstr(t->tag, "qexpr")) {
x = lval_qexpr();
}
/* Fill this list with any valid expression contained within */
for (int i = 0; i < 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;
}
void lval_print(lval *v);
void lval_expr_print(lval *v, char open, char close) {
putchar(open);
for (int 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(' ');
}
}
putchar(close);
}
/* Print an "lval*" */
void lval_print(lval *v) {
switch (v->type) {
case LVAL_NUM: printf("%li", v->num); break;
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;
case LVAL_FUN:
if (v->builtin) {
printf("<builtin>");
} else {
printf("(\\ "); lval_print(v->formals);
putchar(' ');
lval_print(v->body);
putchar(')');
}
break;
}
}
/* Print an "lval" followed by a newline */
void lval_println(lval *v) {
lval_print(v);
putchar('\n');
}
lval *lval_pop(lval *v, int i) {
/* Find 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);
return x;
}
lval *lval_take(lval *v, int i) {
lval *x = lval_pop(v, i);
lval_del(v);
return x;
}
lval *builtin_eval(lenv* e, lval *a);
lval *builtin_list(lenv *e, lval *a);
lval *lval_call(lenv *e, lval *f, lval *a) {
/* If Builtin then simply apply that */
if (f->builtin) {
return f->builtin(e, a);
}
/* Record Argument Counts */
int given = a->count;
int total = f->formals->count;
/* While arguments still remain to be processed */
while (a->count) {
/* If we've ran out of formal arguments to bind */
if (f->formals->count == 0) {
lval_del(a);
return lval_err("Function passed too many arguments. "
"Got %i, Expected %i.", given, total);
}
/* Pop the first symbol from the formals */
lval *sym = lval_pop(f->formals, 0);
/* Special Case to deal with '&' */
if (strcmp(sym->sym, "&") == 0) {
/* Ensure '&' is followed by another symbol */
if (f->formals->count != 1) {
lval_del(a);
return lval_err("Function format invalid. "
"Symbol '&' not followed by single symbol.");
}
/* Next formal should be bound to remaining arguments */
lval *nsym = lval_pop(f->formals, 0);
lenv_put(f->env, nsym, builtin_list(e, a));
lval_del(sym); lval_del(nsym);
break;
}
/* Pop the next argument from the list */
lval* val = lval_pop(a, 0);
/* Bind a copy into the function's environment */
lenv_put(f->env, sym, val);
/* Delete symbol and value */
lval_del(sym); lval_del(val);
}
/* Argument list is now bound so can be cleaned up */
lval_del(a);
/* If '&' remains in formal list bind to empty list */
if (f->formals->count > 0 && strcmp(f->formals->cell[0]->sym, "&") == 0) {
/* Check to ensure that & is not passed invalidly. */
if (f->formals->count != 2) {
return lval_err("Function format invalid. "
"Symbol '&' not followed by single symbol.");
}
/* Pop and delete '&' symbol */
lval_del(lval_pop(f->formals, 0));
/* Pop next symbol and create empty list */
lval* sym = lval_pop(f->formals, 0);
lval* val = lval_qexpr();
/* Bind to environment and delete */
lenv_put(f->env, sym, val);
lval_del(sym); lval_del(val);
}
/* If all formals have been bound evaluate */
if (f->formals->count == 0) {
/* Set environment parent to evaluation environment */
f->env->par = e;
/* Evaluate and return */
return builtin_eval(f->env, lval_add(lval_sexpr(),
lval_copy(f->body)));
} else {
/* Otherwise return partially evaluated function */
return lval_copy(f);
}
}
lval *lval_eval(lenv *e, lval *v);
lval *builtin(lval* a, char* func);
lval *lval_eval_sexpr(lenv *e, lval *v) {
/* Evaluate Children */
for (int i = 0; i < v->count; i++) {
v->cell[i] = lval_eval(e, v->cell[i]);
}
/* Error Checking */
for (int 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 a function after evaluation */
lval *f = lval_pop(v, 0);
if (f->type != LVAL_FUN) {
lval *err = lval_err("S-Expression starts with incorrect type. "
"Got %s, Expected %s.",
ltype_name(f->type), ltype_name(LVAL_FUN));
lval_del(f);
lval_del(v);
return err;
}
lval *result = lval_call(e, f, v);
lval_del(f);
return result;
}
lval *lval_eval(lenv *e, lval *v) {
if (v->type == LVAL_SYM) {
lval *x = lenv_get(e, v);
lval_del(v);
return x;
}
/* Evaluate Sexpressions */
if (v->type == LVAL_SEXPR) {
return lval_eval_sexpr(e, v);
}
/* All other lval types remain the same */
return v;
}
lval *builtin_op(lenv* e, lval *a, char *op) {
/* Ensure all arguments are numbers */
for (int i = 0; i < a->count; i++) {
LASSERT_TYPE(op, a, i, LVAL_NUM);
}
/* Pop the first element */
lval *x = lval_pop(a, 0);
/* If no arguments and sub then perform unary negation */
if ((strcmp(op, "-") == 0) && a->count == 0) {
x->num = -x->num;
}
/* While there are still elements remaining */
while (a->count > 0) {
/* Pop the next element */
lval *y = lval_pop(a, 0);
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 (y->num == 0) {
lval_del(x);
lval_del(y);
x = lval_err("Division By Zero!");
break;
}
x->num /= y->num;
}
lval_del(y);
}
lval_del(a);
return x;
}
lval *builtin_head(lenv* e, lval *a) {
LASSERT_NUM("head", a, 1);
LASSERT_TYPE("head", a, 0, LVAL_QEXPR);
LASSERT_NOT_EMPTY("head", a, 0);
/* 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(lenv *e, lval *a) {
LASSERT_NUM("tail", a, 1);
LASSERT_TYPE("tail", a, 0, LVAL_QEXPR);
LASSERT_NOT_EMPTY("tail", a, 0);
/* 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(lenv *e, lval *a) {
a->type = LVAL_QEXPR;
return a;
}
lval *builtin_eval(lenv* e, lval *a) {
LASSERT_NUM("eval", a, 1);
LASSERT_TYPE("eval", a, 0, LVAL_QEXPR);
lval *x = lval_take(a, 0);
x->type = LVAL_SEXPR;
return lval_eval(e, 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;
}
lval *builtin_join(lenv *e, lval *a) {
for (int i = 0; i < a->count; i++) {
LASSERT_TYPE("join", a, i, LVAL_QEXPR);
}
lval *x = lval_pop(a, 0);
while (a->count) {
x = lval_join(x, lval_pop(a, 0));
}
lval_del(a);
return x;
}
lval *builtin_add(lenv *e, lval *a) {
return builtin_op(e, a, "+");
}
lval *builtin_sub(lenv *e, lval *a) {
return builtin_op(e, a, "-");
}
lval *builtin_mul(lenv *e, lval *a) {
return builtin_op(e, a, "*");
}
lval *builtin_div(lenv *e, lval *a) {
return builtin_op(e, a, "/");
}
void lenv_add_builtin(lenv *e, char *name, lbuiltin func) {
lval *k = lval_sym(name);
lval* v = lval_builtin(func);
lenv_put(e, k, v);
lval_del(k); lval_del(v);
}
lval *builtin_var(lenv *e, lval *a, char *func) {
LASSERT_TYPE(func, a, 0, LVAL_QEXPR);
lval* syms = a->cell[0];
for (int i = 0; i < syms->count; i++) {
LASSERT(a, (syms->cell[i]->type == LVAL_SYM),
"Function '%s' cannot define non-symbol. "
"Got %s, Expected %s.", func,
ltype_name(syms->cell[i]->type),
ltype_name(LVAL_SYM));
}
LASSERT(a, (syms->count == a->count-1),
"Function '%s' passed too many arguments for symbols. "
"Got %i, Expected %i.", func, syms->count, a->count-1);
for (int i = 0; i < syms->count; i++) {
/* If 'def' define in globally. If 'put' define in locally */
if (strcmp(func, "def") == 0) {
lenv_def(e, syms->cell[i], a->cell[i+1]);
}
if (strcmp(func, "=") == 0) {
lenv_put(e, syms->cell[i], a->cell[i+1]);
}
}
lval_del(a);
return lval_sexpr();
}
lval *builtin_def(lenv *e, lval *a) {
return builtin_var(e, a, "def");
}
lval *builtin_put(lenv *e, lval *a) {
return builtin_var(e, a, "=");
}
lval *builtin_lambda(lenv *e, lval *a) {
/* Check Two arguments, each of which are Q-Expressions */
LASSERT_NUM("\\", a, 2);
LASSERT_TYPE("\\", a, 0, LVAL_QEXPR);
LASSERT_TYPE("\\", a, 1, LVAL_QEXPR);
/* Check first Q-Expression contains only Symbols */
for (int i = 0; i < a->cell[0]->count; i++) {
LASSERT(a, (a->cell[0]->cell[i]->type == LVAL_SYM),
"Cannot define non-symbol. Got %s, Expected %s.",
ltype_name(a->cell[0]->cell[i]->type),ltype_name(LVAL_SYM));
}
/* Pop first two arguments and pass them to lval_lambda */
lval *formals = lval_pop(a, 0);
lval *body = lval_pop(a, 0);
lval_del(a);
return lval_lambda(formals, body);
}
lval *builtin_ord(lenv *e, lval *a, char *op);
lval *builtin_gt(lenv *e, lval *a) {
return builtin_ord(e, a, ">");
}
lval *builtin_lt(lenv *e, lval *a) {
return builtin_ord(e, a, "<");
}
lval *builtin_ge(lenv *e, lval *a) {
return builtin_ord(e, a, ">=");
}
lval *builtin_le(lenv *e, lval *a) {
return builtin_ord(e, a, "<=");
}
lval *builtin_ord(lenv *e, lval *a, char *op) {
LASSERT_NUM(op, a, 2);
LASSERT_TYPE(op, a, 0, LVAL_NUM);
LASSERT_TYPE(op, a, 1, LVAL_NUM);
int r;
if (strcmp(op, ">") == 0) {
r = (a->cell[0]->num > a->cell[1]->num);
}
if (strcmp(op, "<") == 0) {
r = (a->cell[0]->num < a->cell[1]->num);
}
if (strcmp(op, ">=") == 0) {
r = (a->cell[0]->num >= a->cell[1]->num);
}
if (strcmp(op, "<=") == 0) {
r = (a->cell[0]->num <= a->cell[1]->num);
}
lval_del(a);
return lval_num(r);
}
int lval_eq(lval *x, lval *y) {
/* Different Types are always unequal */
if (x->type != y->type) { return 0; }
/* Compare Based upon type */
switch (x->type) {
/* Compare Number Value */
case LVAL_NUM: return (x->num == y->num);
/* Compare String Values */
case LVAL_ERR: return (strcmp(x->err, y->err) == 0);
case LVAL_SYM: return (strcmp(x->sym, y->sym) == 0);
/* If builtin compare, otherwise compare formals and body */
case LVAL_FUN:
if (x->builtin || y->builtin) {
return x->builtin == y->builtin;
} else {
return lval_eq(x->formals, y->formals) && lval_eq(x->body, y->body);
}
/* If list compare every individual element */
case LVAL_QEXPR:
case LVAL_SEXPR:
if (x->count != y->count) { return 0; }
for (int i = 0; i < x->count; i++) {
/* If any element not equal then whole list not equal */
if (!lval_eq(x->cell[i], y->cell[i])) { return 0; }
}
/* Otherwise lists must be equal */
return 1;
break;
}
return 0;
}
lval *builtin_cmp(lenv *e, lval *a, char *op) {
LASSERT_NUM(op, a, 2);
int r;
if (strcmp(op, "==") == 0) {
r = lval_eq(a->cell[0], a->cell[1]);
}
if (strcmp(op, "!=") == 0) {
r = !lval_eq(a->cell[0], a->cell[1]);
}
lval_del(a);
return lval_num(r);
}
lval *builtin_eq(lenv *e, lval *a) {
return builtin_cmp(e, a, "==");
}
lval *builtin_ne(lenv *e, lval *a) {
return builtin_cmp(e, a, "!=");
}
lval *builtin_if(lenv *e, lval *a) {
LASSERT_NUM("if", a, 3);
LASSERT_TYPE("if", a, 0, LVAL_NUM);
LASSERT_TYPE("if", a, 1, LVAL_QEXPR);
LASSERT_TYPE("if", a, 2, LVAL_QEXPR);
/* Mark Both Expressions as evaluable */
lval *x;
a->cell[1]->type = LVAL_SEXPR;
a->cell[2]->type = LVAL_SEXPR;
if (a->cell[0]->num) {
/* If condition is true evaluate first expression */
x = lval_eval(e, lval_pop(a, 1));
} else {
/* Otherwise evaluate second expression */
x = lval_eval(e, lval_pop(a, 2));
}
/* Delete argument list and return */
lval_del(a);
return x;
}
void lenv_add_builtins(lenv *e) {
/* Variable Functions */
lenv_add_builtin(e, "def", builtin_def);
lenv_add_builtin(e, "\\", builtin_lambda);
lenv_add_builtin(e, "=", builtin_put);
/* List Functions */
lenv_add_builtin(e, "list", builtin_list);
lenv_add_builtin(e, "head", builtin_head);
lenv_add_builtin(e, "tail", builtin_tail);
lenv_add_builtin(e, "eval", builtin_eval);
lenv_add_builtin(e, "join", builtin_join);
/* Mathematical Functions */
lenv_add_builtin(e, "+", builtin_add);
lenv_add_builtin(e, "-", builtin_sub);
lenv_add_builtin(e, "*", builtin_mul);
lenv_add_builtin(e, "/", builtin_div);
/* Comparison Functions */
lenv_add_builtin(e, "if", builtin_if);
lenv_add_builtin(e, "==", builtin_eq);
lenv_add_builtin(e, "!=", builtin_ne);
lenv_add_builtin(e, ">", builtin_gt);
lenv_add_builtin(e, "<", builtin_lt);
lenv_add_builtin(e, ">=", builtin_ge);
lenv_add_builtin(e, "<=", builtin_le);
}
int main(int argc, char *argv[]) {
/* 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,
" \
number : /-?[0-9]+/ ; \
symbol : /[a-zA-Z0-9_+\\-*\\/\\\\=<>!&]+/ ; \
sexpr : '(' <expr>* ')' ; \
qexpr : '{' <expr>* '}' ; \
expr : <number> | <symbol> | <sexpr> | <qexpr> ; \
lispy : /^/ <expr>* /$/ ; \
",
Number, Symbol, Sexpr, Qexpr, Expr, Lispy);
puts("Lispy Version 0.1");
puts("Press Ctrl+c to Exit\n");
lenv *e = lenv_new();
lenv_add_builtins(e);
while(1) {
char *input = readline("lispy> ");
add_history(input);
/* Attempt to parse the user input */
mpc_result_t r;
if (mpc_parse("<stdin>", input, Lispy, &r)) {
/* On success print and delete the AST */
lval *x = lval_eval(e, lval_read(r.output));
lval_println(x);
lval_del(x);
mpc_ast_delete(r.output);
} else {
/* Otherwise print and delete the Error */
mpc_err_print(r.error);
mpc_err_delete(r.error);
}
free(input);
}
lenv_del(e);
/* Undefine and delete our parsers */
mpc_cleanup(6, Number, Symbol, Sexpr, Qexpr, Expr, Lispy);
return 0;
}
- 22
- 23
- 24
- 25
- 26
- 27
- 28
- 29
- 30
- 31
- 32
- 33
- 34
- 35
- 36
- 37
- 38
- 39
- 40
- 41
- 42
- 43
- 44
- 45
- 46
- 47
- 48
- 49
- 50
- 51
- 52
- 53
- 54
- 55
- 56
- 57
- 58
- 59
- 60
- 61
- 62
- 63
- 64
- 65
- 66
- 67
- 68
- 69
- 70
- 71
- 72
- 73
- 74
- 75
- 76
- 77
- 78
- 79
- 80
- 81
- 82
- 83
- 84
- 85
- 86
- 87
- 88
- 89
- 90
- 91
- 92
- 93
- 94
- 95
- 96
- 97
- 98
- 99
- 100
- 101
- 102
- 103
- 104
- 105
- 106
- 107
- 108
- 109
- 110
- 111
- 112
- 113
- 114
- 115
- 116
- 117
- 118
- 119
- 120
- 121
- 122
- 123
- 124
- 125
- 126
- 127
- 128
- 129
- 130
- 131
- 132
- 133
- 134
- 135
- 136
- 137
- 138
- 139
- 140
- 141
- 142
- 143
- 144
- 145
- 146
- 147
- 148
- 149
- 150
- 151
- 152
- 153
- 154
- 155
- 156
- 157
- 158
- 159
- 160
- 161
- 162
- 163
- 164
- 165
- 166
- 167
- 168
- 169
- 170
- 171
- 172
- 173
- 174
- 175
- 176
- 177
- 178
- 179
- 180
- 181
- 182
- 183
- 184
- 185
- 186
- 187
- 188
- 189
- 190
- 191
- 192
- 193
- 194
- 195
- 196
- 197
- 198
- 199
- 200
- 201
- 202
- 203
- 204
- 205
- 206
- 207
- 208
- 209
- 210
- 211
- 212
- 213
- 214
- 215
- 216
- 217
- 218
- 219
- 220
- 221
- 222
- 223
- 224
- 225
- 226
- 227
- 228
- 229
- 230
- 231
- 232
- 233
- 234
- 235
- 236
- 237
- 238
- 239
- 240
- 241
- 242
- 243
- 244
- 245
- 246
- 247
- 248
- 249
- 250
- 251
- 252
- 253
- 254
- 255
- 256
- 257
- 258
- 259
- 260
- 261
- 262
- 263
- 264
- 265
- 266
- 267
- 268
- 269
- 270
- 271
- 272
- 273
- 274
- 275
- 276
- 277
- 278
- 279
- 280
- 281
- 282
- 283
- 284
- 285
- 286
- 287
- 288
- 289
- 290
- 291
- 292
- 293
- 294
- 295
- 296
- 297
- 298
- 299
- 300
- 301
- 302
- 303
- 304
- 305
- 306
- 307
- 308
- 309
- 310
- 311
- 312
- 313
- 314
- 315
- 316
- 317
- 318
- 319
- 320
- 321
- 322
- 323
- 324
- 325
- 326
- 327
- 328
- 329
- 330
- 331
- 332
- 333
- 334
- 335
- 336
- 337
- 338
- 339
- 340
- 341
- 342
- 343
- 344
- 345
- 346
- 347
- 348
- 349
- 350
- 351
- 352
- 353
- 354
- 355
- 356
- 357
- 358
- 359
- 360
- 361
- 362
- 363
- 364
- 365
- 366
- 367
- 368
- 369
- 370
- 371
- 372
- 373
- 374
- 375
- 376
- 377
- 378
- 379
- 380
- 381
- 382
- 383
- 384
- 385
- 386
- 387
- 388
- 389
- 390
- 391
- 392
- 393
- 394
- 395
- 396
- 397
- 398
- 399
- 400
- 401
- 402
- 403
- 404
- 405
- 406
- 407
- 408
- 409
- 410
- 411
- 412
- 413
- 414
- 415
- 416
- 417
- 418
- 419
- 420
- 421
- 422
- 423
- 424
- 425
- 426
- 427
- 428
- 429
- 430
- 431
- 432
- 433
- 434
- 435
- 436
- 437
- 438
- 439
- 440
- 441
- 442
- 443
- 444
- 445
- 446
- 447
- 448
- 449
- 450
- 451
- 452
- 453
- 454
- 455
- 456
- 457
- 458
- 459
- 460
- 461
- 462
- 463
- 464
- 465
- 466
- 467
- 468
- 469
- 470
- 471
- 472
- 473
- 474
- 475
- 476
- 477
- 478
- 479
- 480
- 481
- 482
- 483
- 484
- 485
- 486
- 487
- 488
- 489
- 490
- 491
- 492
- 493
- 494
- 495
- 496
- 497
- 498
- 499
- 500
- 501
- 502
- 503
- 504
- 505
- 506
- 507
- 508
- 509
- 510
- 511
- 512
- 513
- 514
- 515
- 516
- 517
- 518
- 519
- 520
- 521
- 522
- 523
- 524
- 525
- 526
- 527
- 528
- 529
- 530
- 531
- 532
- 533
- 534
- 535
- 536
- 537
- 538
- 539
- 540
- 541
- 542
- 543
- 544
- 545
- 546
- 547
- 548
- 549
- 550
- 551
- 552
- 553
- 554
- 555
- 556
- 557
- 558
- 559
- 560
- 561
- 562
- 563
- 564
- 565
- 566
- 567
- 568
- 569
- 570
- 571
- 572
- 573
- 574
- 575
- 576
- 577
- 578
- 579
- 580
- 581
- 582
- 583
- 584
- 585
- 586
- 587
- 588
- 589
- 590
- 591
- 592
- 593
- 594
- 595
- 596
- 597
- 598
- 599
- 600
- 601
- 602
- 603
- 604
- 605
- 606
- 607
- 608
- 609
- 610
- 611
- 612
- 613
- 614
- 615
- 616
- 617
- 618
- 619
- 620
- 621
- 622
- 623
- 624
- 625
- 626
- 627
- 628
- 629
- 630
- 631
- 632
- 633
- 634
- 635
- 636
- 637
- 638
- 639
- 640
- 641
- 642
- 643
- 644
- 645
- 646
- 647
- 648
- 649
- 650
- 651
- 652
- 653
- 654
- 655
- 656
- 657
- 658
- 659
- 660
- 661
- 662
- 663
- 664
- 665
- 666
- 667
- 668
- 669
- 670
- 671
- 672
- 673
- 674
- 675
- 676
- 677
- 678
- 679
- 680
- 681
- 682
- 683
- 684
- 685
- 686
- 687
- 688
- 689
- 690
- 691
- 692
- 693
- 694
- 695
- 696
- 697
- 698
- 699
- 700
- 701
- 702
- 703
- 704
- 705
- 706
- 707
- 708
- 709
- 710
- 711
- 712
- 713
- 714
- 715
- 716
- 717
- 718
- 719
- 720
- 721
- 722
- 723
- 724
- 725
- 726
- 727
- 728
- 729
- 730
- 731
- 732
- 733
- 734
- 735
- 736
- 737
- 738
- 739
- 740
- 741
- 742
- 743
- 744
- 745
- 746
- 747
- 748
- 749
- 750
- 751
- 752
- 753
- 754
- 755
- 756
- 757
- 758
- 759
- 760
- 761
- 762
- 763
- 764
- 765
- 766
- 767
- 768
- 769
- 770
- 771
- 772
- 773
- 774
- 775
- 776
- 777
- 778
- 779
- 780
- 781
- 782
- 783
- 784
- 785
- 786
- 787
- 788
- 789
- 790
- 791
- 792
- 793
- 794
- 795
- 796
- 797
- 798
- 799
- 800
- 801
- 802
- 803
- 804
- 805
- 806
- 807
- 808
- 809
- 810
- 811
- 812
- 813
- 814
- 815
- 816
- 817
- 818
- 819
- 820
- 821
- 822
- 823
- 824
- 825
- 826
- 827
- 828
- 829
- 830
- 831
- 832
- 833
- 834
- 835
- 836
- 837
- 838
- 839
- 840
- 841
- 842
- 843
- 844
- 845
- 846
- 847
- 848
- 849
- 850
- 851
- 852
- 853
- 854
- 855
- 856
- 857
- 858
- 859
- 860
- 861
- 862
- 863
- 864
- 865
- 866
- 867
- 868
- 869
- 870
- 871
- 872
- 873
- 874
- 875
- 876
- 877
- 878
- 879
- 880
- 881
- 882
- 883
- 884
- 885
- 886
- 887
- 888
- 889
- 890
- 891
- 892
- 893
- 894
- 895
- 896
- 897
- 898
- 899
- 900
- 901
- 902
- 903
- 904
- 905
- 906
- 907
- 908
- 909
- 910
- 911
- 912
- 913
- 914
- 915
- 916
- 917
- 918
- 919
- 920
- 921
- 922
- 923
- 924
- 925
- 926
- 927
- 928
- 929
- 930
- 931
- 932
- 933
- 934
- 935
- 936
- 937
- 938
- 939
- 940
- 941
- 942
- 943
- 944
- 945
- 946
- 947
- 948
- 949
- 950
- 951
- 952
- 953
- 954
- 955
- 956
- 957
- 958
- 959
- 960
- 961
- 962
- 963
- 964
- 965
- 966
- 967
- 968
- 969
- 970
- 971
- 972
- 973
- 974
- 975
- 976
- 977
- 978
- 979
- 980
- 981
- 982
- 983
- 984
- 985
- 986
- 987
- 988
- 989
- 990
- 991
- 992
- 993
- 994
- 995
- 996
- 997
- 998
- 999
- 1000
- 1001
- 1002
- 1003
- 1004
- 1005
- 1006
- 1007
- 1008
- 1009
- 1010
- 1011
- 1012
- 1013
- 1014
- 1015
- 1016
- 1017
- 1018
- 1019
- 1020
- 1021
- 1022
- 1023
- 1024
- 1025
- 1026
- 1027
- 1028
- 1029
- 1030
