前文列表

《用 C 语言开发一门编程语言 — 交互式解析器》
《用 C 语言开发一门编程语言 — 跨平台的可移植性》
《用 C 语言开发一门编程语言 — 语法解析器》
《用 C 语言开发一门编程语言 — 抽象语法树》
《用 C 语言开发一门编程语言 — 异常处理》
《用 C 语言开发一门编程语言 — S-表达式》
《用 C 语言开发一门编程语言 — Q-表达式》
《用 C 语言开发一门编程语言 — 变量元素设计》

函数

函数是所有程序设计的关键，其本质源自于一个数学概念，有了函数之后，程序员就可以只考虑它的意义，而不用考虑它的内部结构。在计算机科学的早期，程序员会将复杂的任务分解成一个个小的函数。那时就有人提出了一个设想：只要有足够的时间，程序员们就可以建立一个完整的函数库，以此满足所有计算的要求。当然，现今为止这个设想仍未预见有实现的苗头，主要是因为随着科技的发展计算问题也越发复杂。但很显然的，现在所有受到欢迎的编程语言都有这个趋向，提供更多的库，更好的代码重用率，更好的抽象，让我们的工作更简单。Python 就是一个非常好的例子。

Lambda 表达式

Lambda 表达式（Lambda Expression）是一种简单而强大的定义函数的方法，虽然语法有点笨拙，有很多括号和符号。Lambda 表达式的命名来自数学中的 λ 运算，对应了其中的 Lambda 抽象（Lambda Abstraction）。

Lambda 表达式让程序员在一个列表中提供函数的名称和形式参数，它将第一个参数的作为函数名，其余的是形式参数，将它们分离出来之后，并在函数定义中使用它们。

通过 Lambda 表达式，我们可以尝试使用一些更简单的语法编写一个定义函数本身的函数。

函数设计

在以往的文章中，我们实现了 S-Expression、Q-Expression 以及变量结构，有了这些条件，我们就可以继续实现函数的定义机制了。

我们不妨首先设计一个函数定义的语法规则，函数定义的语法使用 / 进行标识，这是为了向 Lambda 表达式致敬：

\ {x y} {+ x y}

将个函数定义放入 S-Expression 中，以接受参数并进行运算：

(\ {x y} {+ x y}) 10 20

为了更友好的阅读体验，程序员还可以通过以往我们内建的 def 函数来进行创建 “别名”，就像其他的输入一样，这个 “别名” 和自定义函数的内容都会被保存在变量环境中：

def {add-together} (\ {x y} {+ x y})

最终，程序员可以如此的调用它：

add-together 10 20

下面我们来实现这个自定义函数的设计。

函数的存储

为了像存储变量那般存储一个函数，我们需要考虑它是由什么组成的：

形参
Q-Expression
实参

继续丰富 Lisp Value 结构体，加入存储函数所需要的 formals、body。

struct lval {int type;/* Basic */long num;char* err;char* sym;/* Function */lbuiltin builtin;lenv* env;lval* formals;lval* body;/* Expression */int count;lval** cell;
};

并且，我们可以使用 LAVL_FUN 类型来同时表示内建函数和自定义的函数，通过 lbuiltin 函数指针是否为 NULL 来进行区别。

同样的，继续完成构造函数、析构函数、复制部分、打印部分的填充：


// 构造函数
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;
}// 析构函数
case LVAL_FUN:if (!v->builtin) {lenv_del(v->env);lval_del(v->formals);lval_del(v->body);}
break;// 复制的部分
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_FUN:if (v->builtin) {printf("<builtin>");} else {printf("(\\ "); lval_print(v->formals);putchar(' '); lval_print(v->body); putchar(')');}
break;

实现 Lambda 函数

现在可以开始编写 Lambda 函数了，类似 def，需要检查类型是否正确，接着做其他的操作：

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);
}

函数的运行环境

一个理想的状态，编程语言可以提供一个与函数相关的环境，在这个环境中，完成形参代入和运算。但实际上，当前整个程序就是一个全局变量的作用域。为了解决这个问题，我们可以修改 lenv 的定义，引用一个表示父类环境的字段。我们可以通过设置父类环境的全局变量来达到我们的目的：

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* lenv_get(lenv* e, lval* k) {for (int i = 0; i < e->count; i++) {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);}
}

同时，当我们使用 lval 结构体时，还需要一个新的函数来完成 “环境” 的复制：

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;
}

拥有父环境也改变了我们定义变量的概念。有两种方法可以定义一个变量：

我们可以在本地，最内层环境中定义它，
或者我们可以在全局最外层环境中定义它。

所以，我们将 lenv_put 方法保持不变，用于在本地环境中定义。但是我们将在全局环境中添加一个新的函数 lenv_def 用于定义：

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);
}

目前这种区分似乎没有用处，但稍后我们将使用它来将部分计算结果写入到函数内的局部变量中。

我们应该为本地赋值添加另一个内置函数。我们将这个 put 放在 C 中，但在 Lisp 中给它赋予 = 符号。我们可以调整 builtin_def 函数来重用代码，我们需要注册这些函数作为内置函数：

lenv_add_builtin(e, "def", builtin_def);
lenv_add_builtin(e, "=",   builtin_put);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_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();
}

函数调用

当这个函数类型是一个内置函数时，我们可以像以前一样通过函数指针的方式来调用它。但当这个函数是一个自定义函数时，我们需要将传入的每个参数绑定到 formals 字段，完成后，我们需要计算 body 字段，此时会使用到 env 字段来作为函数调用的运算环境。

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);/* 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 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_eval_sexpr 函数来调用 lval_call：

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);

可变长的函数参数

我们希望内建的函数可以接受可变数量的参数，例如：+ 和 join 这样的函数可以取任意数量的参数，并在逻辑上对它们进行操作。

因此，我们将使用 & 符号，让用户可以定义看起来像 {x&xs} 这样的形式的参数列表，类似于 C 语言中可变长形参符号 ...。这意味着一个函数将接受一个参数 x，后跟零个或多个其他参数，连接在一起成为一个名为 xs 的列表。

当程序分配形式参数时，会搜索 & 符号，如果它存在，取出下一个形参，并为它分配剩余的参数。重要的是我们将这个参数列表转换为 Q-Expression。此外，还需要检查 & 符号后时候紧跟了一个真正的符号，如果不是，我们应该抛出一个错误。

在第一个符号从 lval_call 的 while 循环中的 formals 中弹出后，在 lval_call 我们可以添加这个特殊情况。

/* 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;
}

假设调用函数时，用户不提供任何变量参数，而只提供第一个命名的参数。在这种情况下，我们需要在空列表后面设置符号。在删除参数列表之后，检查所有的 formal 求值之前，把这个特例添加进去。

/* 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);
}

源代码

#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);
}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);
}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;
}

编译：

gcc -g -std=c99 -Wall parsing.c mpc.c -lreadline -lm -o parsing

运行：

$ ./parsing
Lispy Version 0.1
Press Ctrl+c to Exitlispy> def {add-mul} (\ {x y} {+ x (* x y)})
()
lispy> add-mul 10 20
210
lispy> add-mul 10
(\ {y} {+ x (* x y)})
lispy> def {add-mul-ten} (add-mul 10)
()
lispy> add-mul-ten 50
510
lispy>

用 C 语言开发一门编程语言 — 基于 Lambda 表达式的函数设计相关推荐

用 C 语言开发一门编程语言 — 字符串与文件加载
目录文章目录目录前文列表字符串读取字符串注释文件加载函数命令行参数打印函数报错函数源代码前文列表 <用 C 语言开发一门编程语言 - 交互式解析器> <用 C ...
用 C 语言开发一门编程语言 — 条件分支
目录文章目录目录前文列表条件分支排序函数等于函数 if 函数递归函数源代码前文列表 <用 C 语言开发一门编程语言 - 交互式解析器> <用 C 语言开发一门编程语 ...
用 C 语言开发一门编程语言 — 字符串的设计与实现
目录文章目录目录前言前文列表字符串与文件库字符串 print 关键字函数 error 关键字函数注释文件加载函数注册命令行参数前言通过开发一门类 Lisp 的编程语言来理解编程 ...
用 C 语言开发一门编程语言 — 变量元素设计
目录文章目录目录前文列表变量变量语法规则变量的读取和存储将变量加入 Lisp Value 体系变量的计算变量的定义与赋值异常处理优化源代码前文列表 <用 C 语言开发一门 ...
用 C 语言开发一门编程语言 — Q-表达式
目录文章目录目录前文列表 Q-表达式读取并存储输入实现 Q-Expression 语法解析器读取 Q-Expression 实现 Q-Expression 的函数 Head & T ...
用 C 语言开发一门编程语言 — S-表达式
目录文章目录目录前文列表使用 S-表达式进行重构读取并存储输入实现 S-Expression 语法解析器实现 S-Expression 存储器实现 lval 变量的构造函数实现 lv ...
用 C 语言开发一门编程语言 — 异常处理
目录文章目录目录前文列表异常捕获定义 Lisp Value 函数前文列表 <用 C 语言开发一门编程语言 - 交互式解析器l> <用 C 语言开发一门编程语言 - 跨平台 ...
用 C 语言开发一门编程语言 — 抽象语法树
目录文章目录目录前文列表抽象语法树的结构使用递归来遍历树结构实现求值计算抽象语法树与行为树前文列表 <用 C 语言开发一门编程语言 - 交互式解析器l> <用 C 语 ...
用 C 语言开发一门编程语言 — 语法解析器
目录文章目录目录前文列表编程语言的本质词法分析语法分析使用 MPC 解析器组合库安装快速入门实现波兰表达式的语法解析波兰表达式正则表达式代码实现前文列表 <用 C 语 ...

用 C 语言开发一门编程语言 — 基于 Lambda 表达式的函数设计

目录

文章目录