参考

{% collapse title=”strings.c” %}

  1. #include "mpc.h"
  2. #ifdef _WIN32
  3. static char buffer[2048];
  4. char* readline(char* prompt) {
  5. fputs(prompt, stdout);
  6. fgets(buffer, 2048, stdin);
  7. char* cpy = malloc(strlen(buffer)+1);
  8. strcpy(cpy, buffer);
  9. cpy[strlen(cpy)-1] = '\0';
  10. return cpy;
  11. }
  12. void add_history(char* unused) {}
  13. #else
  14. #include <editline/readline.h>
  15. #include <editline/history.h>
  16. #endif
  17. /* Parser Declariations */
  18. mpc_parser_t* Number;
  19. mpc_parser_t* Symbol;
  20. mpc_parser_t* String;
  21. mpc_parser_t* Comment;
  22. mpc_parser_t* Sexpr;
  23. mpc_parser_t* Qexpr;
  24. mpc_parser_t* Expr;
  25. mpc_parser_t* Lispy;
  26. /* Forward Declarations */
  27. struct lval;
  28. struct lenv;
  29. typedef struct lval lval;
  30. typedef struct lenv lenv;
  31. /* Lisp Value */
  32. enum { LVAL_ERR, LVAL_NUM, LVAL_SYM, LVAL_STR,
  33. LVAL_FUN, LVAL_SEXPR, LVAL_QEXPR };
  34. typedef lval*(*lbuiltin)(lenv*, lval*);
  35. struct lval {
  36. int type;
  37. /* Basic */
  38. long num;
  39. char* err;
  40. char* sym;
  41. char* str;
  42. /* Function */
  43. lbuiltin builtin;
  44. lenv* env;
  45. lval* formals;
  46. lval* body;
  47. /* Expression */
  48. int count;
  49. lval** cell;
  50. };
  51. lval* lval_num(long x) {
  52. lval* v = malloc(sizeof(lval));
  53. v->type = LVAL_NUM;
  54. v->num = x;
  55. return v;
  56. }
  57. lval* lval_err(char* fmt, ...) {
  58. lval* v = malloc(sizeof(lval));
  59. v->type = LVAL_ERR;
  60. va_list va;
  61. va_start(va, fmt);
  62. v->err = malloc(512);
  63. vsnprintf(v->err, 511, fmt, va);
  64. v->err = realloc(v->err, strlen(v->err)+1);
  65. va_end(va);
  66. return v;
  67. }
  68. lval* lval_sym(char* s) {
  69. lval* v = malloc(sizeof(lval));
  70. v->type = LVAL_SYM;
  71. v->sym = malloc(strlen(s) + 1);
  72. strcpy(v->sym, s);
  73. return v;
  74. }
  75. lval* lval_str(char* s) {
  76. lval* v = malloc(sizeof(lval));
  77. v->type = LVAL_STR;
  78. v->str = malloc(strlen(s) + 1);
  79. strcpy(v->str, s);
  80. return v;
  81. }
  82. lval* lval_builtin(lbuiltin func) {
  83. lval* v = malloc(sizeof(lval));
  84. v->type = LVAL_FUN;
  85. v->builtin = func;
  86. return v;
  87. }
  88. lenv* lenv_new(void);
  89. lval* lval_lambda(lval* formals, lval* body) {
  90. lval* v = malloc(sizeof(lval));
  91. v->type = LVAL_FUN;
  92. v->builtin = NULL;
  93. v->env = lenv_new();
  94. v->formals = formals;
  95. v->body = body;
  96. return v;
  97. }
  98. lval* lval_sexpr(void) {
  99. lval* v = malloc(sizeof(lval));
  100. v->type = LVAL_SEXPR;
  101. v->count = 0;
  102. v->cell = NULL;
  103. return v;
  104. }
  105. lval* lval_qexpr(void) {
  106. lval* v = malloc(sizeof(lval));
  107. v->type = LVAL_QEXPR;
  108. v->count = 0;
  109. v->cell = NULL;
  110. return v;
  111. }
  112. void lenv_del(lenv* e);
  113. void lval_del(lval* v) {
  114. switch (v->type) {
  115. case LVAL_NUM: break;
  116. case LVAL_FUN:
  117. if (!v->builtin) {
  118. lenv_del(v->env);
  119. lval_del(v->formals);
  120. lval_del(v->body);
  121. }
  122. break;
  123. case LVAL_ERR: free(v->err); break;
  124. case LVAL_SYM: free(v->sym); break;
  125. case LVAL_STR: free(v->str); break;
  126. case LVAL_QEXPR:
  127. case LVAL_SEXPR:
  128. for (int i = 0; i < v->count; i++) {
  129. lval_del(v->cell[i]);
  130. }
  131. free(v->cell);
  132. break;
  133. }
  134. free(v);
  135. }
  136. lenv* lenv_copy(lenv* e);
  137. lval* lval_copy(lval* v) {
  138. lval* x = malloc(sizeof(lval));
  139. x->type = v->type;
  140. switch (v->type) {
  141. case LVAL_FUN:
  142. if (v->builtin) {
  143. x->builtin = v->builtin;
  144. } else {
  145. x->builtin = NULL;
  146. x->env = lenv_copy(v->env);
  147. x->formals = lval_copy(v->formals);
  148. x->body = lval_copy(v->body);
  149. }
  150. break;
  151. case LVAL_NUM: x->num = v->num; break;
  152. case LVAL_ERR: x->err = malloc(strlen(v->err) + 1);
  153. strcpy(x->err, v->err);
  154. break;
  155. case LVAL_SYM: x->sym = malloc(strlen(v->sym) + 1);
  156. strcpy(x->sym, v->sym);
  157. break;
  158. case LVAL_STR: x->str = malloc(strlen(v->str) + 1);
  159. strcpy(x->str, v->str);
  160. break;
  161. case LVAL_SEXPR:
  162. case LVAL_QEXPR:
  163. x->count = v->count;
  164. x->cell = malloc(sizeof(lval*) * x->count);
  165. for (int i = 0; i < x->count; i++) {
  166. x->cell[i] = lval_copy(v->cell[i]);
  167. }
  168. break;
  169. }
  170. return x;
  171. }
  172. lval* lval_add(lval* v, lval* x) {
  173. v->count++;
  174. v->cell = realloc(v->cell, sizeof(lval*) * v->count);
  175. v->cell[v->count-1] = x;
  176. return v;
  177. }
  178. lval* lval_join(lval* x, lval* y) {
  179. for (int i = 0; i < y->count; i++) {
  180. x = lval_add(x, y->cell[i]);
  181. }
  182. free(y->cell);
  183. free(y);
  184. return x;
  185. }
  186. lval* lval_pop(lval* v, int i) {
  187. lval* x = v->cell[i];
  188. memmove(&v->cell[i],
  189. &v->cell[i+1], sizeof(lval*) * (v->count-i-1));
  190. v->count--;
  191. v->cell = realloc(v->cell, sizeof(lval*) * v->count);
  192. return x;
  193. }
  194. lval* lval_take(lval* v, int i) {
  195. lval* x = lval_pop(v, i);
  196. lval_del(v);
  197. return x;
  198. }
  199. void lval_print(lval* v);
  200. void lval_print_expr(lval* v, char open, char close) {
  201. putchar(open);
  202. for (int i = 0; i < v->count; i++) {
  203. lval_print(v->cell[i]);
  204. if (i != (v->count-1)) {
  205. putchar(' ');
  206. }
  207. }
  208. putchar(close);
  209. }
  210. void lval_print_str(lval* v) {
  211. /* Make a Copy of the string */
  212. char* escaped = malloc(strlen(v->str)+1);
  213. strcpy(escaped, v->str);
  214. /* Pass it through the escape function */
  215. escaped = mpcf_escape(escaped);
  216. /* Print it between " characters */
  217. printf("\"%s\"", escaped);
  218. /* free the copied string */
  219. free(escaped);
  220. }
  221. void lval_print(lval* v) {
  222. switch (v->type) {
  223. case LVAL_FUN:
  224. if (v->builtin) {
  225. printf("<builtin>");
  226. } else {
  227. printf("(\\ ");
  228. lval_print(v->formals);
  229. putchar(' ');
  230. lval_print(v->body);
  231. putchar(')');
  232. }
  233. break;
  234. case LVAL_NUM: printf("%li", v->num); break;
  235. case LVAL_ERR: printf("Error: %s", v->err); break;
  236. case LVAL_SYM: printf("%s", v->sym); break;
  237. case LVAL_STR: lval_print_str(v); break;
  238. case LVAL_SEXPR: lval_print_expr(v, '(', ')'); break;
  239. case LVAL_QEXPR: lval_print_expr(v, '{', '}'); break;
  240. }
  241. }
  242. void lval_println(lval* v) { lval_print(v); putchar('\n'); }
  243. int lval_eq(lval* x, lval* y) {
  244. if (x->type != y->type) { return 0; }
  245. switch (x->type) {
  246. case LVAL_NUM: return (x->num == y->num);
  247. case LVAL_ERR: return (strcmp(x->err, y->err) == 0);
  248. case LVAL_SYM: return (strcmp(x->sym, y->sym) == 0);
  249. case LVAL_STR: return (strcmp(x->str, y->str) == 0);
  250. case LVAL_FUN:
  251. if (x->builtin || y->builtin) {
  252. return x->builtin == y->builtin;
  253. } else {
  254. return lval_eq(x->formals, y->formals) && lval_eq(x->body, y->body);
  255. }
  256. case LVAL_QEXPR:
  257. case LVAL_SEXPR:
  258. if (x->count != y->count) { return 0; }
  259. for (int i = 0; i < x->count; i++) {
  260. if (!lval_eq(x->cell[i], y->cell[i])) { return 0; }
  261. }
  262. return 1;
  263. break;
  264. }
  265. return 0;
  266. }
  267. char* ltype_name(int t) {
  268. switch(t) {
  269. case LVAL_FUN: return "Function";
  270. case LVAL_NUM: return "Number";
  271. case LVAL_ERR: return "Error";
  272. case LVAL_SYM: return "Symbol";
  273. case LVAL_STR: return "String";
  274. case LVAL_SEXPR: return "S-Expression";
  275. case LVAL_QEXPR: return "Q-Expression";
  276. default: return "Unknown";
  277. }
  278. }
  279. /* Lisp Environment */
  280. struct lenv {
  281. lenv* par;
  282. int count;
  283. char** syms;
  284. lval** vals;
  285. };
  286. lenv* lenv_new(void) {
  287. lenv* e = malloc(sizeof(lenv));
  288. e->par = NULL;
  289. e->count = 0;
  290. e->syms = NULL;
  291. e->vals = NULL;
  292. return e;
  293. }
  294. void lenv_del(lenv* e) {
  295. for (int i = 0; i < e->count; i++) {
  296. free(e->syms[i]);
  297. lval_del(e->vals[i]);
  298. }
  299. free(e->syms);
  300. free(e->vals);
  301. free(e);
  302. }
  303. lenv* lenv_copy(lenv* e) {
  304. lenv* n = malloc(sizeof(lenv));
  305. n->par = e->par;
  306. n->count = e->count;
  307. n->syms = malloc(sizeof(char*) * n->count);
  308. n->vals = malloc(sizeof(lval*) * n->count);
  309. for (int i = 0; i < e->count; i++) {
  310. n->syms[i] = malloc(strlen(e->syms[i]) + 1);
  311. strcpy(n->syms[i], e->syms[i]);
  312. n->vals[i] = lval_copy(e->vals[i]);
  313. }
  314. return n;
  315. }
  316. lval* lenv_get(lenv* e, lval* k) {
  317. for (int i = 0; i < e->count; i++) {
  318. if (strcmp(e->syms[i], k->sym) == 0) { return lval_copy(e->vals[i]); }
  319. }
  320. if (e->par) {
  321. return lenv_get(e->par, k);
  322. } else {
  323. return lval_err("Unbound Symbol '%s'", k->sym);
  324. }
  325. }
  326. void lenv_put(lenv* e, lval* k, lval* v) {
  327. for (int i = 0; i < e->count; i++) {
  328. if (strcmp(e->syms[i], k->sym) == 0) {
  329. lval_del(e->vals[i]);
  330. e->vals[i] = lval_copy(v);
  331. return;
  332. }
  333. }
  334. e->count++;
  335. e->vals = realloc(e->vals, sizeof(lval*) * e->count);
  336. e->syms = realloc(e->syms, sizeof(char*) * e->count);
  337. e->vals[e->count-1] = lval_copy(v);
  338. e->syms[e->count-1] = malloc(strlen(k->sym)+1);
  339. strcpy(e->syms[e->count-1], k->sym);
  340. }
  341. void lenv_def(lenv* e, lval* k, lval* v) {
  342. while (e->par) { e = e->par; }
  343. lenv_put(e, k, v);
  344. }
  345. /* Builtins */
  346. #define LASSERT(args, cond, fmt, ...) \
  347. if (!(cond)) { lval* err = lval_err(fmt, ##__VA_ARGS__); lval_del(args); return err; }
  348. #define LASSERT_TYPE(func, args, index, expect) \
  349. LASSERT(args, args->cell[index]->type == expect, \
  350. "Function '%s' passed incorrect type for argument %i. Got %s, Expected %s.", \
  351. func, index, ltype_name(args->cell[index]->type), ltype_name(expect))
  352. #define LASSERT_NUM(func, args, num) \
  353. LASSERT(args, args->count == num, \
  354. "Function '%s' passed incorrect number of arguments. Got %i, Expected %i.", \
  355. func, args->count, num)
  356. #define LASSERT_NOT_EMPTY(func, args, index) \
  357. LASSERT(args, args->cell[index]->count != 0, \
  358. "Function '%s' passed {} for argument %i.", func, index);
  359. lval* lval_eval(lenv* e, lval* v);
  360. lval* builtin_lambda(lenv* e, lval* a) {
  361. LASSERT_NUM("\\", a, 2);
  362. LASSERT_TYPE("\\", a, 0, LVAL_QEXPR);
  363. LASSERT_TYPE("\\", a, 1, LVAL_QEXPR);
  364. for (int i = 0; i < a->cell[0]->count; i++) {
  365. LASSERT(a, (a->cell[0]->cell[i]->type == LVAL_SYM),
  366. "Cannot define non-symbol. Got %s, Expected %s.",
  367. ltype_name(a->cell[0]->cell[i]->type), ltype_name(LVAL_SYM));
  368. }
  369. lval* formals = lval_pop(a, 0);
  370. lval* body = lval_pop(a, 0);
  371. lval_del(a);
  372. return lval_lambda(formals, body);
  373. }
  374. lval* builtin_list(lenv* e, lval* a) {
  375. a->type = LVAL_QEXPR;
  376. return a;
  377. }
  378. lval* builtin_head(lenv* e, lval* a) {
  379. LASSERT_NUM("head", a, 1);
  380. LASSERT_TYPE("head", a, 0, LVAL_QEXPR);
  381. LASSERT_NOT_EMPTY("head", a, 0);
  382. lval* v = lval_take(a, 0);
  383. while (v->count > 1) { lval_del(lval_pop(v, 1)); }
  384. return v;
  385. }
  386. lval* builtin_tail(lenv* e, lval* a) {
  387. LASSERT_NUM("tail", a, 1);
  388. LASSERT_TYPE("tail", a, 0, LVAL_QEXPR);
  389. LASSERT_NOT_EMPTY("tail", a, 0);
  390. lval* v = lval_take(a, 0);
  391. lval_del(lval_pop(v, 0));
  392. return v;
  393. }
  394. lval* builtin_eval(lenv* e, lval* a) {
  395. LASSERT_NUM("eval", a, 1);
  396. LASSERT_TYPE("eval", a, 0, LVAL_QEXPR);
  397. lval* x = lval_take(a, 0);
  398. x->type = LVAL_SEXPR;
  399. return lval_eval(e, x);
  400. }
  401. lval* builtin_join(lenv* e, lval* a) {
  402. for (int i = 0; i < a->count; i++) {
  403. LASSERT_TYPE("join", a, i, LVAL_QEXPR);
  404. }
  405. lval* x = lval_pop(a, 0);
  406. while (a->count) {
  407. lval* y = lval_pop(a, 0);
  408. x = lval_join(x, y);
  409. }
  410. lval_del(a);
  411. return x;
  412. }
  413. lval* builtin_op(lenv* e, lval* a, char* op) {
  414. for (int i = 0; i < a->count; i++) {
  415. LASSERT_TYPE(op, a, i, LVAL_NUM);
  416. }
  417. lval* x = lval_pop(a, 0);
  418. if ((strcmp(op, "-") == 0) && a->count == 0) { x->num = -x->num; }
  419. while (a->count > 0) {
  420. lval* y = lval_pop(a, 0);
  421. if (strcmp(op, "+") == 0) { x->num += y->num; }
  422. if (strcmp(op, "-") == 0) { x->num -= y->num; }
  423. if (strcmp(op, "*") == 0) { x->num *= y->num; }
  424. if (strcmp(op, "/") == 0) {
  425. if (y->num == 0) {
  426. lval_del(x); lval_del(y);
  427. x = lval_err("Division By Zero.");
  428. break;
  429. }
  430. x->num /= y->num;
  431. }
  432. lval_del(y);
  433. }
  434. lval_del(a);
  435. return x;
  436. }
  437. lval* builtin_add(lenv* e, lval* a) { return builtin_op(e, a, "+"); }
  438. lval* builtin_sub(lenv* e, lval* a) { return builtin_op(e, a, "-"); }
  439. lval* builtin_mul(lenv* e, lval* a) { return builtin_op(e, a, "*"); }
  440. lval* builtin_div(lenv* e, lval* a) { return builtin_op(e, a, "/"); }
  441. lval* builtin_var(lenv* e, lval* a, char* func) {
  442. LASSERT_TYPE(func, a, 0, LVAL_QEXPR);
  443. lval* syms = a->cell[0];
  444. for (int i = 0; i < syms->count; i++) {
  445. LASSERT(a, (syms->cell[i]->type == LVAL_SYM),
  446. "Function '%s' cannot define non-symbol. "
  447. "Got %s, Expected %s.",
  448. func, ltype_name(syms->cell[i]->type), ltype_name(LVAL_SYM));
  449. }
  450. LASSERT(a, (syms->count == a->count-1),
  451. "Function '%s' passed too many arguments for symbols. "
  452. "Got %i, Expected %i.",
  453. func, syms->count, a->count-1);
  454. for (int i = 0; i < syms->count; i++) {
  455. if (strcmp(func, "def") == 0) { lenv_def(e, syms->cell[i], a->cell[i+1]); }
  456. if (strcmp(func, "=") == 0) { lenv_put(e, syms->cell[i], a->cell[i+1]); }
  457. }
  458. lval_del(a);
  459. return lval_sexpr();
  460. }
  461. lval* builtin_def(lenv* e, lval* a) { return builtin_var(e, a, "def"); }
  462. lval* builtin_put(lenv* e, lval* a) { return builtin_var(e, a, "="); }
  463. lval* builtin_ord(lenv* e, lval* a, char* op) {
  464. LASSERT_NUM(op, a, 2);
  465. LASSERT_TYPE(op, a, 0, LVAL_NUM);
  466. LASSERT_TYPE(op, a, 1, LVAL_NUM);
  467. int r;
  468. if (strcmp(op, ">") == 0) { r = (a->cell[0]->num > a->cell[1]->num); }
  469. if (strcmp(op, "<") == 0) { r = (a->cell[0]->num < a->cell[1]->num); }
  470. if (strcmp(op, ">=") == 0) { r = (a->cell[0]->num >= a->cell[1]->num); }
  471. if (strcmp(op, "<=") == 0) { r = (a->cell[0]->num <= a->cell[1]->num); }
  472. lval_del(a);
  473. return lval_num(r);
  474. }
  475. lval* builtin_gt(lenv* e, lval* a) { return builtin_ord(e, a, ">"); }
  476. lval* builtin_lt(lenv* e, lval* a) { return builtin_ord(e, a, "<"); }
  477. lval* builtin_ge(lenv* e, lval* a) { return builtin_ord(e, a, ">="); }
  478. lval* builtin_le(lenv* e, lval* a) { return builtin_ord(e, a, "<="); }
  479. lval* builtin_cmp(lenv* e, lval* a, char* op) {
  480. LASSERT_NUM(op, a, 2);
  481. int r;
  482. if (strcmp(op, "==") == 0) { r = lval_eq(a->cell[0], a->cell[1]); }
  483. if (strcmp(op, "!=") == 0) { r = !lval_eq(a->cell[0], a->cell[1]); }
  484. lval_del(a);
  485. return lval_num(r);
  486. }
  487. lval* builtin_eq(lenv* e, lval* a) { return builtin_cmp(e, a, "=="); }
  488. lval* builtin_ne(lenv* e, lval* a) { return builtin_cmp(e, a, "!="); }
  489. lval* builtin_if(lenv* e, lval* a) {
  490. LASSERT_NUM("if", a, 3);
  491. LASSERT_TYPE("if", a, 0, LVAL_NUM);
  492. LASSERT_TYPE("if", a, 1, LVAL_QEXPR);
  493. LASSERT_TYPE("if", a, 2, LVAL_QEXPR);
  494. lval* x;
  495. a->cell[1]->type = LVAL_SEXPR;
  496. a->cell[2]->type = LVAL_SEXPR;
  497. if (a->cell[0]->num) {
  498. x = lval_eval(e, lval_pop(a, 1));
  499. } else {
  500. x = lval_eval(e, lval_pop(a, 2));
  501. }
  502. lval_del(a);
  503. return x;
  504. }
  505. lval* lval_read(mpc_ast_t* t);
  506. lval* builtin_load(lenv* e, lval* a) {
  507. LASSERT_NUM("load", a, 1);
  508. LASSERT_TYPE("load", a, 0, LVAL_STR);
  509. /* Parse File given by string name */
  510. mpc_result_t r;
  511. if (mpc_parse_contents(a->cell[0]->str, Lispy, &r)) {
  512. /* Read contents */
  513. lval* expr = lval_read(r.output);
  514. mpc_ast_delete(r.output);
  515. /* Evaluate each Expression */
  516. while (expr->count) {
  517. lval* x = lval_eval(e, lval_pop(expr, 0));
  518. /* If Evaluation leads to error print it */
  519. if (x->type == LVAL_ERR) { lval_println(x); }
  520. lval_del(x);
  521. }
  522. /* Delete expressions and arguments */
  523. lval_del(expr);
  524. lval_del(a);
  525. /* Return empty list */
  526. return lval_sexpr();
  527. } else {
  528. /* Get Parse Error as String */
  529. char* err_msg = mpc_err_string(r.error);
  530. mpc_err_delete(r.error);
  531. /* Create new error message using it */
  532. lval* err = lval_err("Could not load Library %s", err_msg);
  533. free(err_msg);
  534. lval_del(a);
  535. /* Cleanup and return error */
  536. return err;
  537. }
  538. }
  539. lval* builtin_print(lenv* e, lval* a) {
  540. /* Print each argument followed by a space */
  541. for (int i = 0; i < a->count; i++) {
  542. lval_print(a->cell[i]); putchar(' ');
  543. }
  544. /* Print a newline and delete arguments */
  545. putchar('\n');
  546. lval_del(a);
  547. return lval_sexpr();
  548. }
  549. lval* builtin_error(lenv* e, lval* a) {
  550. LASSERT_NUM("error", a, 1);
  551. LASSERT_TYPE("error", a, 0, LVAL_STR);
  552. /* Construct Error from first argument */
  553. lval* err = lval_err(a->cell[0]->str);
  554. /* Delete arguments and return */
  555. lval_del(a);
  556. return err;
  557. }
  558. void lenv_add_builtin(lenv* e, char* name, lbuiltin func) {
  559. lval* k = lval_sym(name);
  560. lval* v = lval_builtin(func);
  561. lenv_put(e, k, v);
  562. lval_del(k); lval_del(v);
  563. }
  564. void lenv_add_builtins(lenv* e) {
  565. /* Variable Functions */
  566. lenv_add_builtin(e, "\\", builtin_lambda);
  567. lenv_add_builtin(e, "def", builtin_def);
  568. lenv_add_builtin(e, "=", builtin_put);
  569. /* List Functions */
  570. lenv_add_builtin(e, "list", builtin_list);
  571. lenv_add_builtin(e, "head", builtin_head);
  572. lenv_add_builtin(e, "tail", builtin_tail);
  573. lenv_add_builtin(e, "eval", builtin_eval);
  574. lenv_add_builtin(e, "join", builtin_join);
  575. /* Mathematical Functions */
  576. lenv_add_builtin(e, "+", builtin_add);
  577. lenv_add_builtin(e, "-", builtin_sub);
  578. lenv_add_builtin(e, "*", builtin_mul);
  579. lenv_add_builtin(e, "/", builtin_div);
  580. /* Comparison Functions */
  581. lenv_add_builtin(e, "if", builtin_if);
  582. lenv_add_builtin(e, "==", builtin_eq);
  583. lenv_add_builtin(e, "!=", builtin_ne);
  584. lenv_add_builtin(e, ">", builtin_gt);
  585. lenv_add_builtin(e, "<", builtin_lt);
  586. lenv_add_builtin(e, ">=", builtin_ge);
  587. lenv_add_builtin(e, "<=", builtin_le);
  588. /* String Functions */
  589. lenv_add_builtin(e, "load", builtin_load);
  590. lenv_add_builtin(e, "error", builtin_error);
  591. lenv_add_builtin(e, "print", builtin_print);
  592. }
  593. /* Evaluation */
  594. lval* lval_call(lenv* e, lval* f, lval* a) {
  595. if (f->builtin) { return f->builtin(e, a); }
  596. int given = a->count;
  597. int total = f->formals->count;
  598. while (a->count) {
  599. if (f->formals->count == 0) {
  600. lval_del(a);
  601. return lval_err("Function passed too many arguments. "
  602. "Got %i, Expected %i.", given, total);
  603. }
  604. lval* sym = lval_pop(f->formals, 0);
  605. if (strcmp(sym->sym, "&") == 0) {
  606. if (f->formals->count != 1) {
  607. lval_del(a);
  608. return lval_err("Function format invalid. "
  609. "Symbol '&' not followed by single symbol.");
  610. }
  611. lval* nsym = lval_pop(f->formals, 0);
  612. lenv_put(f->env, nsym, builtin_list(e, a));
  613. lval_del(sym); lval_del(nsym);
  614. break;
  615. }
  616. lval* val = lval_pop(a, 0);
  617. lenv_put(f->env, sym, val);
  618. lval_del(sym); lval_del(val);
  619. }
  620. lval_del(a);
  621. if (f->formals->count > 0 &&
  622. strcmp(f->formals->cell[0]->sym, "&") == 0) {
  623. if (f->formals->count != 2) {
  624. return lval_err("Function format invalid. "
  625. "Symbol '&' not followed by single symbol.");
  626. }
  627. lval_del(lval_pop(f->formals, 0));
  628. lval* sym = lval_pop(f->formals, 0);
  629. lval* val = lval_qexpr();
  630. lenv_put(f->env, sym, val);
  631. lval_del(sym); lval_del(val);
  632. }
  633. if (f->formals->count == 0) {
  634. f->env->par = e;
  635. return builtin_eval(f->env, lval_add(lval_sexpr(), lval_copy(f->body)));
  636. } else {
  637. return lval_copy(f);
  638. }
  639. }
  640. lval* lval_eval_sexpr(lenv* e, lval* v) {
  641. for (int i = 0; i < v->count; i++) { v->cell[i] = lval_eval(e, v->cell[i]); }
  642. for (int i = 0; i < v->count; i++) { if (v->cell[i]->type == LVAL_ERR) { return lval_take(v, i); } }
  643. if (v->count == 0) { return v; }
  644. if (v->count == 1) { return lval_eval(e, lval_take(v, 0)); }
  645. lval* f = lval_pop(v, 0);
  646. if (f->type != LVAL_FUN) {
  647. lval* err = lval_err(
  648. "S-Expression starts with incorrect type. "
  649. "Got %s, Expected %s.",
  650. ltype_name(f->type), ltype_name(LVAL_FUN));
  651. lval_del(f); lval_del(v);
  652. return err;
  653. }
  654. lval* result = lval_call(e, f, v);
  655. lval_del(f);
  656. return result;
  657. }
  658. lval* lval_eval(lenv* e, lval* v) {
  659. if (v->type == LVAL_SYM) {
  660. lval* x = lenv_get(e, v);
  661. lval_del(v);
  662. return x;
  663. }
  664. if (v->type == LVAL_SEXPR) { return lval_eval_sexpr(e, v); }
  665. return v;
  666. }
  667. /* Reading */
  668. lval* lval_read_num(mpc_ast_t* t) {
  669. errno = 0;
  670. long x = strtol(t->contents, NULL, 10);
  671. return errno != ERANGE ? lval_num(x) : lval_err("Invalid Number.");
  672. }
  673. lval* lval_read_str(mpc_ast_t* t) {
  674. /* Cut off the final quote character */
  675. t->contents[strlen(t->contents)-1] = '\0';
  676. /* Copy the string missing out the first quote character */
  677. char* unescaped = malloc(strlen(t->contents+1)+1);
  678. strcpy(unescaped, t->contents+1);
  679. /* Pass through the unescape function */
  680. unescaped = mpcf_unescape(unescaped);
  681. /* Construct a new lval using the string */
  682. lval* str = lval_str(unescaped);
  683. /* Free the string and return */
  684. free(unescaped);
  685. return str;
  686. }
  687. lval* lval_read(mpc_ast_t* t) {
  688. if (strstr(t->tag, "number")) { return lval_read_num(t); }
  689. if (strstr(t->tag, "string")) { return lval_read_str(t); }
  690. if (strstr(t->tag, "symbol")) { return lval_sym(t->contents); }
  691. lval* x = NULL;
  692. if (strcmp(t->tag, ">") == 0) { x = lval_sexpr(); }
  693. if (strstr(t->tag, "sexpr")) { x = lval_sexpr(); }
  694. if (strstr(t->tag, "qexpr")) { x = lval_qexpr(); }
  695. for (int i = 0; i < t->children_num; i++) {
  696. if (strcmp(t->children[i]->contents, "(") == 0) { continue; }
  697. if (strcmp(t->children[i]->contents, ")") == 0) { continue; }
  698. if (strcmp(t->children[i]->contents, "}") == 0) { continue; }
  699. if (strcmp(t->children[i]->contents, "{") == 0) { continue; }
  700. if (strcmp(t->children[i]->tag, "regex") == 0) { continue; }
  701. if (strstr(t->children[i]->tag, "comment")) { continue; }
  702. x = lval_add(x, lval_read(t->children[i]));
  703. }
  704. return x;
  705. }
  706. /* Main */
  707. int main(int argc, char** argv) {
  708. Number = mpc_new("number");
  709. Symbol = mpc_new("symbol");
  710. String = mpc_new("string");
  711. Comment = mpc_new("comment");
  712. Sexpr = mpc_new("sexpr");
  713. Qexpr = mpc_new("qexpr");
  714. Expr = mpc_new("expr");
  715. Lispy = mpc_new("lispy");
  716. mpca_lang(MPCA_LANG_DEFAULT,
  717. " \
  718. number : /-?[0-9]+/ ; \
  719. symbol : /[a-zA-Z0-9_+\\-*\\/\\\\=<>!&]+/ ; \
  720. string : /\"(\\\\.|[^\"])*\"/ ; \
  721. comment : /;[^\\r\\n]*/ ; \
  722. sexpr : '(' <expr>* ')' ; \
  723. qexpr : '{' <expr>* '}' ; \
  724. expr : <number> | <symbol> | <string> \
  725. | <comment> | <sexpr> | <qexpr>; \
  726. lispy : /^/ <expr>* /$/ ; \
  727. ",
  728. Number, Symbol, String, Comment, Sexpr, Qexpr, Expr, Lispy);
  729. lenv* e = lenv_new();
  730. lenv_add_builtins(e);
  731. /* Interactive Prompt */
  732. if (argc == 1) {
  733. puts("Lispy Version 0.0.0.1.0");
  734. puts("Press Ctrl+c to Exit\n");
  735. while (1) {
  736. char* input = readline("lispy> ");
  737. add_history(input);
  738. mpc_result_t r;
  739. if (mpc_parse("<stdin>", input, Lispy, &r)) {
  740. lval* x = lval_eval(e, lval_read(r.output));
  741. lval_println(x);
  742. lval_del(x);
  743. mpc_ast_delete(r.output);
  744. } else {
  745. mpc_err_print(r.error);
  746. mpc_err_delete(r.error);
  747. }
  748. free(input);
  749. }
  750. }
  751. /* Supplied with list of files */
  752. if (argc >= 2) {
  753. /* loop over each supplied filename (starting from 1) */
  754. for (int i = 1; i < argc; i++) {
  755. /* Argument list with a single argument, the filename */
  756. lval* args = lval_add(lval_sexpr(), lval_str(argv[i]));
  757. /* Pass to builtin load and get the result */
  758. lval* x = builtin_load(e, args);
  759. /* If the result is an error be sure to print it */
  760. if (x->type == LVAL_ERR) { lval_println(x); }
  761. lval_del(x);
  762. }
  763. }
  764. lenv_del(e);
  765. mpc_cleanup(8,
  766. Number, Symbol, String, Comment,
  767. Sexpr, Qexpr, Expr, Lispy);
  768. return 0;
  769. }

{% endcollapse %}