mes_macro.c 6.6 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250
  1. /* -*-comment-start: "//";comment-end:""-*-
  2. * GNU Mes --- Maxwell Equations of Software
  3. * Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
  4. * Copyright © 2019 Jeremiah Orians
  5. *
  6. * This file is part of GNU Mes.
  7. *
  8. * GNU Mes is free software; you can redistribute it and/or modify it
  9. * under the terms of the GNU General Public License as published by
  10. * the Free Software Foundation; either version 3 of the License, or (at
  11. * your option) any later version.
  12. *
  13. * GNU Mes is distributed in the hope that it will be useful, but
  14. * WITHOUT ANY WARRANTY; without even the implied warranty of
  15. * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  16. * GNU General Public License for more details.
  17. *
  18. * You should have received a copy of the GNU General Public License
  19. * along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
  20. */
  21. #include "mes.h"
  22. /* Imported functions */
  23. struct cell* assoc(struct cell* key, struct cell* alist);
  24. struct cell* extend_env(struct cell* sym, struct cell* val, struct cell* env);
  25. struct cell* macro_progn(struct cell* exps, struct cell* env);
  26. struct cell* make_macro(struct cell* a, struct cell* b, struct cell* env);
  27. struct cell* make_proc(struct cell* a, struct cell* b, struct cell* env);
  28. struct cell* multiple_extend(struct cell* env, struct cell* syms, struct cell* vals);
  29. struct cell* pop_cell();
  30. struct cell* reverse_list(struct cell* head);
  31. void push_cell(struct cell* a);
  32. struct cell* define_macro(struct cell* exp, struct cell* env)
  33. {
  34. if(CONS == exp->cdr->car->type)
  35. {
  36. struct cell* fun = exp->cdr->cdr;
  37. struct cell* arguments = exp->cdr->car->cdr;
  38. struct cell* name = exp->cdr->car->car;
  39. exp->cdr = make_cons(name, make_cons(make_cons(s_macro, make_cons(arguments, fun)), nil));
  40. }
  41. return(extend_env(exp->cdr->car, exp->cdr->cdr->car, env));
  42. }
  43. struct cell* macro_apply(struct cell* exps, struct cell* vals);
  44. struct cell* macro_eval(struct cell* exps, struct cell* env);
  45. struct cell* expand_quasiquote(struct cell* exp, struct cell* env)
  46. {
  47. struct cell* i = exp;
  48. struct cell* f = NULL;
  49. struct cell* h;
  50. while(nil != i)
  51. {
  52. h = i->car;
  53. if(CONS == i->car->type)
  54. {
  55. if(unquote == i->car->car)
  56. {
  57. macro_eval(i->car->cdr->car, env);
  58. h = R0;
  59. }
  60. if(unquote_splicing == i->car->car)
  61. {
  62. macro_eval(i->car->cdr->car, env);
  63. while((NULL != R0) && (nil != R0))
  64. {
  65. /* Unsure if correct behavior is to revert to unquote behavior (what guile does) */
  66. /* Or restrict to just proper lists as the spec (r7rs) requires */
  67. /* eg. `(foo bar ,@(+ 4 5)) */
  68. require(CONS == R0->type, "unquote-splicing requires argument of type <proper list>\n");
  69. f = make_cons(R0->car, f);
  70. /* Simply convert require to if and the above */
  71. /* else f = make_cons(R0, f); */
  72. R0 = R0->cdr;
  73. }
  74. goto restart_expand_quasiquote;
  75. }
  76. }
  77. f = make_cons(h, f);
  78. restart_expand_quasiquote:
  79. i = i->cdr;
  80. }
  81. i = f;
  82. f = reverse_list(f);
  83. require(NULL != i, "Impossible quasiquote processed?\n");
  84. i->cdr = nil;
  85. return f;
  86. }
  87. struct cell* macro_list(struct cell* exps, struct cell* env)
  88. {
  89. if(exps == nil) return nil;
  90. struct cell* i = macro_eval(exps->car, env);
  91. struct cell* j = macro_list(exps->cdr, env);
  92. return make_cons(i, j);
  93. }
  94. struct cell* expand_if(struct cell* exp, struct cell* env)
  95. {
  96. R0 = macro_eval(exp->cdr->car, env);
  97. if(R0 != cell_f)
  98. {
  99. R0 = macro_eval(exp->cdr->cdr->car, env);
  100. return R0;
  101. }
  102. if(nil == exp->cdr->cdr->cdr) return cell_unspecified;
  103. R0 = macro_eval(exp->cdr->cdr->cdr->car, env);
  104. return R0;
  105. }
  106. struct cell* expand_cond(struct cell* exp, struct cell* env)
  107. {
  108. if(nil == exp) return cell_unspecified;
  109. macro_eval(exp->car->car, env);
  110. if(cell_t == R0)
  111. {
  112. macro_eval(exp->car->cdr->car, env);
  113. return R0;
  114. }
  115. return expand_cond(exp->cdr, env);
  116. }
  117. struct cell* expand_let(struct cell* exp, struct cell* env)
  118. {
  119. struct cell* lets;
  120. for(lets = exp->cdr->car; lets != nil; lets = lets->cdr)
  121. {
  122. macro_eval(lets->car->cdr->car, env);
  123. env = make_cons(make_cons(lets->car->car, R0), env);
  124. }
  125. return macro_progn(exp->cdr->cdr, env);
  126. }
  127. struct cell* expand_define(struct cell* exp, struct cell* env)
  128. {
  129. if(CONS == exp->cdr->car->type)
  130. {
  131. struct cell* fun = exp->cdr->cdr;
  132. struct cell* arguments = exp->cdr->car->cdr;
  133. struct cell* name = exp->cdr->car->car;
  134. exp->cdr = make_cons(name, make_cons(make_cons(s_lambda, make_cons(arguments, fun)), nil));
  135. }
  136. macro_eval(exp->cdr->cdr->car, env);
  137. return(extend_env(exp->cdr->car, R0, env));
  138. }
  139. struct cell* expand_cons(struct cell* exp, struct cell* env)
  140. {
  141. if(exp->car == s_if) return expand_if(exp, env);
  142. if(exp->car == s_cond) return expand_cond(exp->cdr, env);
  143. if(exp->car == s_lambda) return make_proc(exp->cdr->car, exp->cdr->cdr, env);
  144. if(exp->car == quote) return exp->cdr->car;
  145. if(exp->car == s_macro) return make_macro(exp->cdr->car, exp->cdr->cdr, env);
  146. if(exp->car == s_define) return expand_define(exp, env);
  147. if(exp->car == s_let) return expand_let(exp, env);
  148. if(exp->car == quasiquote) return expand_quasiquote(exp->cdr->car, env);
  149. R0 = macro_eval(exp->car, env);
  150. push_cell(R0);
  151. R1 = macro_list(exp->cdr, env);
  152. R0 = pop_cell();
  153. return macro_apply(R0, R1);
  154. }
  155. struct cell* macro_eval(struct cell* exps, struct cell* env)
  156. {
  157. if(CONS == exps->type) return expand_cons(exps, env);
  158. if(SYM == exps->type)
  159. {
  160. struct cell* tmp = assoc(exps, env);
  161. if(nil == tmp) return exps;
  162. return tmp->cdr;
  163. }
  164. return exps;
  165. }
  166. struct cell* macro_progn(struct cell* exps, struct cell* env)
  167. {
  168. if(exps == nil) return nil;
  169. struct cell* result;
  170. macro_progn_reset:
  171. result = macro_eval(exps->car, env);
  172. if(exps->cdr == nil) return result;
  173. exps = exps->cdr;
  174. goto macro_progn_reset;
  175. }
  176. struct cell* macro_apply(struct cell* proc, struct cell* vals)
  177. {
  178. struct cell* temp;
  179. if(proc->type == PRIMOP)
  180. {
  181. FUNCTION* fp = proc->function;
  182. temp = fp(vals);
  183. }
  184. else if(proc->type == LAMBDA)
  185. {
  186. temp = proc;
  187. }
  188. else if(proc->type == MACRO)
  189. {
  190. struct cell* env = make_cons(proc->env->car, proc->env->cdr);
  191. temp = macro_progn(proc->cdr, multiple_extend(env, proc->car, vals));
  192. }
  193. else
  194. {
  195. temp = macro_eval(proc, g_env);
  196. }
  197. return temp;
  198. }
  199. struct cell* expand_macros(struct cell* exp)
  200. {
  201. R0 = exp;
  202. struct cell* hold;
  203. expand_reset:
  204. if(NULL == R0) return exp;
  205. if(CONS != R0->type) return exp;
  206. else if(R0->car == s_define_macro)
  207. {
  208. define_macro(R0, g_env);
  209. return cell_unspecified;
  210. }
  211. hold = R0;
  212. hold->car = expand_macros(R0->car);
  213. R0 = hold;
  214. hold = assoc(R0->car, g_env);
  215. if(CONS == hold->type)
  216. {
  217. if(s_macro == hold->cdr->car)
  218. {
  219. return macro_apply(make_macro(hold->cdr->cdr->car, hold->cdr->cdr->cdr, g_env), R0->cdr);
  220. }
  221. }
  222. R0 = R0->cdr;
  223. goto expand_reset;
  224. }