1 /* -*-comment-start: "//";comment-end:""-*-
2 * Mes --- Maxwell Equations of Software
3 * Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
5 * This file is part of Mes.
7 * Mes is free software; you can redistribute it and/or modify it
8 * under the terms of the GNU General Public License as published by
9 * the Free Software Foundation; either version 3 of the License, or (at
10 * your option) any later version.
12 * Mes is distributed in the hope that it will be useful, but
13 * WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 * GNU General Public License for more details.
17 * You should have received a copy of the GNU General Public License
18 * along with Mes. If not, see <http://www.gnu.org/licenses/>.
24 #define assert(x) ((x) ? (void)0 : assert_fail (#x))
31 int ARENA_SIZE = 100000;
32 int MAX_ARENA_SIZE = 20000000;
33 //int GC_SAFETY_DIV = 400;
34 //int GC_SAFETY = ARENA_SIZE / 400;
43 SCM g_continuations = 0;
55 enum type_t {TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TREF, TSPECIAL, TSTRING, TSYMBOL, TVALUES, TVECTOR, TBROKEN_HEART};
64 int (*function) (void);
69 typedef SCM (*function0_t) (void);
70 typedef SCM (*function1_t) (SCM);
71 typedef SCM (*function2_t) (SCM, SCM);
72 typedef SCM (*function3_t) (SCM, SCM, SCM);
73 typedef SCM (*functionn_t) (SCM);
76 function0_t function0;
77 function1_t function1;
78 function2_t function2;
79 function3_t function3;
80 functionn_t functionn;
110 struct scm *g_cells = foobar;
111 struct scm *g_news = foobar;
113 struct scm *g_cells = 0;
114 struct scm *g_news = 0;
117 struct scm scm_nil = {TSPECIAL, "()",0};
118 struct scm scm_f = {TSPECIAL, "#f",0};
119 struct scm scm_t = {TSPECIAL, "#t",0};
120 struct scm scm_dot = {TSPECIAL, ".",0};
121 struct scm scm_arrow = {TSPECIAL, "=>",0};
122 struct scm scm_undefined = {TSPECIAL, "*undefined*",0};
123 struct scm scm_unspecified = {TSPECIAL, "*unspecified*",0};
124 struct scm scm_closure = {TSPECIAL, "*closure*",0};
125 struct scm scm_circular = {TSPECIAL, "*circular*",0};
126 struct scm scm_begin = {TSPECIAL, "*begin*",0};
128 struct scm scm_symbol_dot = {TSYMBOL, "*dot*",0};
129 struct scm scm_symbol_lambda = {TSYMBOL, "lambda",0};
130 struct scm scm_symbol_begin = {TSYMBOL, "begin",0};
131 struct scm scm_symbol_if = {TSYMBOL, "if",0};
132 struct scm scm_symbol_quote = {TSYMBOL, "quote",0};
133 struct scm scm_symbol_set_x = {TSYMBOL, "set!",0};
135 struct scm scm_symbol_sc_expand = {TSYMBOL, "sc-expand",0};
136 struct scm scm_symbol_macro_expand = {TSYMBOL, "macro-expand",0};
137 struct scm scm_symbol_sc_expander_alist = {TSYMBOL, "*sc-expander-alist*",0};
139 struct scm scm_symbol_call_with_values = {TSYMBOL, "call-with-values",0};
140 struct scm scm_call_with_current_continuation = {TSPECIAL, "*call/cc*",0};
141 struct scm scm_symbol_call_with_current_continuation = {TSYMBOL, "call-with-current-continuation",0};
142 struct scm scm_symbol_current_module = {TSYMBOL, "current-module",0};
143 struct scm scm_symbol_primitive_load = {TSYMBOL, "primitive-load",0};
144 struct scm scm_symbol_read_input_file = {TSYMBOL, "read-input-file",0};
145 struct scm scm_symbol_write = {TSYMBOL, "write",0};
146 struct scm scm_symbol_display = {TSYMBOL, "display",0};
148 struct scm scm_symbol_throw = {TSYMBOL, "throw",0};
149 struct scm scm_symbol_not_a_pair = {TSYMBOL, "not-a-pair",0};
150 struct scm scm_symbol_system_error = {TSYMBOL, "system-error",0};
151 struct scm scm_symbol_wrong_number_of_args = {TSYMBOL, "wrong-number-of-args",0};
152 struct scm scm_symbol_wrong_type_arg = {TSYMBOL, "wrong-type-arg",0};
153 struct scm scm_symbol_unbound_variable = {TSYMBOL, "unbound-variable",0};
155 struct scm scm_symbol_argv = {TSYMBOL, "%argv",0};
156 struct scm scm_symbol_mes_prefix = {TSYMBOL, "%prefix",0};
157 struct scm scm_symbol_mes_version = {TSYMBOL, "%version",0};
159 struct scm scm_symbol_car = {TSYMBOL, "car",0};
160 struct scm scm_symbol_cdr = {TSYMBOL, "cdr",0};
161 struct scm scm_symbol_null_p = {TSYMBOL, "null?",0};
162 struct scm scm_symbol_eq_p = {TSYMBOL, "eq?",0};
163 struct scm scm_symbol_cons = {TSYMBOL, "cons",0};
165 struct scm scm_vm_evlis = {TSPECIAL, "*vm-evlis*",0};
166 struct scm scm_vm_evlis2 = {TSPECIAL, "*vm-evlis2*",0};
167 struct scm scm_vm_evlis3 = {TSPECIAL, "*vm-evlis3*",0};
168 struct scm scm_vm_apply = {TSPECIAL, "core:apply",0};
169 struct scm scm_vm_apply2 = {TSPECIAL, "*vm-apply2*",0};
170 struct scm scm_vm_eval = {TSPECIAL, "core:eval",0};
173 struct scm scm_vm_eval_car = {TSPECIAL, "*vm-eval-car*",0};
174 struct scm scm_vm_eval_cdr = {TSPECIAL, "*vm-eval-cdr*",0};
175 struct scm scm_vm_eval_cons = {TSPECIAL, "*vm-eval-cons*",0};
176 struct scm scm_vm_eval_null_p = {TSPECIAL, "*vm-eval-null-p*",0};
178 struct scm scm_vm_eval_set_x = {TSPECIAL, "*vm-eval-set!*",0};
179 struct scm scm_vm_eval_macro = {TSPECIAL, "*vm-eval-macro*",0};
180 struct scm scm_vm_eval_check_func = {TSPECIAL, "*vm-eval-check-func*",0};
181 struct scm scm_vm_eval2 = {TSPECIAL, "*vm-eval2*",0};
182 struct scm scm_vm_macro_expand = {TSPECIAL, "core:macro-expand",0};
183 struct scm scm_vm_begin = {TSPECIAL, "*vm-begin*",0};
184 struct scm scm_vm_begin_read_input_file = {TSPECIAL, "*vm-begin-read-input-file*",0};
185 struct scm scm_vm_begin2 = {TSPECIAL, "*vm-begin2*",0};
186 struct scm scm_vm_if = {TSPECIAL, "*vm-if*",0};
187 struct scm scm_vm_if_expr = {TSPECIAL, "*vm-if-expr*",0};
188 struct scm scm_vm_call_with_values2 = {TSPECIAL, "*vm-call-with-values2*",0};
189 struct scm scm_vm_call_with_current_continuation2 = {TSPECIAL, "*vm-call-with-current-continuation2*",0};
190 struct scm scm_vm_return = {TSPECIAL, "*vm-return*",0};
192 struct scm scm_symbol_gnuc = {TSYMBOL, "%gnuc",0};
193 struct scm scm_symbol_mesc = {TSYMBOL, "%mesc",0};
195 struct scm scm_test = {TSYMBOL, "test",0};
198 #include "mes.mes.symbols.h"
200 #include "mes.symbols.h"
207 struct function g_functions[200];
210 #if !__GNUC__ || !_POSIX_SOURCE
213 #include "math.mes.h"
215 #include "posix.mes.h"
217 #include "reader.mes.h"
219 #include "vector.mes.h"
230 #define TYPE(x) g_cells[x].type
231 #define CAR(x) g_cells[x].car
232 #define CDR(x) g_cells[x].cdr
234 #define NTYPE(x) g_news[x].type
235 #define NCAR(x) g_news[x].car
236 #define NCDR(x) g_news[x].cdr
239 #define LENGTH(x) g_cells[x].car
240 #define REF(x) g_cells[x].car
241 #define STRING(x) g_cells[x].car
243 #define CLOSURE(x) g_cells[x].cdr
244 #define CONTINUATION(x) g_cells[x].cdr
246 #define FUNCTION(x) g_functions[g_cells[x].cdr]
247 #define MACRO(x) g_cells[x].cdr
248 #define VALUE(x) g_cells[x].cdr
249 #define VECTOR(x) g_cells[x].cdr
251 #define NLENGTH(x) g_news[x].car
253 #define NVALUE(x) g_news[x].cdr
254 #define NVECTOR(x) g_news[x].cdr
257 #define CONTINUATION(x) g_cells[x].cdr
258 #define HITS(x) g_cells[x].hits
259 #define LENGTH(x) g_cells[x].length
260 #define NAME(x) g_cells[x].name
261 #define STRING(x) g_cells[x].string
262 #define CLOSURE(x) g_cells[x].closure
263 #define MACRO(x) g_cells[x].macro
264 #define REF(x) g_cells[x].ref
265 #define VALUE(x) g_cells[x].value
266 #define VECTOR(x) g_cells[x].vector
267 #define FUNCTION(x) g_functions[g_cells[x].function]
269 #define NLENGTH(x) g_news[x].length
271 #define NVALUE(x) g_news[x].value
272 #define NVECTOR(x) g_news[x].vector
275 #define MAKE_CHAR(n) make_cell_ (tmp_num_ (TCHAR), 0, tmp_num2_ (n))
276 #define MAKE_CONTINUATION(n) make_cell_ (tmp_num_ (TCONTINUATION), n, g_stack)
277 #define MAKE_NUMBER(n) make_cell_ (tmp_num_ (TNUMBER), 0, tmp_num2_ (n))
278 #define MAKE_REF(n) make_cell_ (tmp_num_ (TREF), n, 0)
279 #define MAKE_STRING(x) make_cell_ (tmp_num_ (TSTRING), x, 0)
281 #define CAAR(x) CAR (CAR (x))
282 #define CADR(x) CAR (CDR (x))
283 #define CDAR(x) CDR (CAR (x))
284 #define CDDR(x) CDR (CDR (x))
285 #define CADAR(x) CAR (CDR (CAR (x)))
286 #define CADDR(x) CAR (CDR (CDR (x)))
287 #define CDADAR(x) CAR (CDR (CAR (CDR (x))))
292 assert (g_free + n < ARENA_SIZE);
308 VALUE (tmp_num2) = x;
313 make_cell_ (SCM type, SCM car, SCM cdr)
316 assert (TYPE (type) == TNUMBER);
317 TYPE (x) = VALUE (type);
318 if (VALUE (type) == TCHAR || VALUE (type) == TNUMBER) {
319 if (car) CAR (x) = CAR (car);
320 if (cdr) CDR(x) = CDR(cdr);
322 else if (VALUE (type) == TFUNCTION) {
323 if (car) CAR (x) = car;
324 if (cdr) CDR(x) = CDR(cdr);
334 make_symbol_ (SCM s) ///((internal))
336 VALUE (tmp_num) = TSYMBOL;
337 SCM x = make_cell_ (tmp_num, s, 0);
338 g_symbols = cons (x, g_symbols);
343 list_of_char_equal_p (SCM a, SCM b) ///((internal))
345 while (a != cell_nil && b != cell_nil && VALUE (CAR (a)) == VALUE (CAR (b))) {
346 assert (TYPE (CAR (a)) == TCHAR);
347 assert (TYPE (CAR (b)) == TCHAR);
351 return (a == cell_nil && b == cell_nil) ? cell_t : cell_f;
355 lookup_symbol_ (SCM s)
359 if (list_of_char_equal_p (STRING (CAR (x)), s) == cell_t) break;
363 if (!x) x = make_symbol_ (s);
370 return MAKE_NUMBER (TYPE (x));
376 return (TYPE (x) != TCONTINUATION
377 && (TYPE (CAR (x)) == TPAIR // FIXME: this is weird
378 || TYPE (CAR (x)) == TREF
379 || TYPE (CAR (x)) == TSPECIAL
380 || TYPE (CAR (x)) == TSYMBOL
381 || TYPE (CAR (x)) == TSTRING)) ? CAR (x) : MAKE_NUMBER (CAR (x));
387 return (TYPE (CDR (x)) == TPAIR
388 || TYPE (CDR (x)) == TREF
389 || TYPE (CAR (x)) == TSPECIAL
390 || TYPE (CDR (x)) == TSYMBOL
391 || TYPE (CDR (x)) == TSTRING) ? CDR (x) : MAKE_NUMBER (CDR (x));
397 assert (TYPE (x) == TFUNCTION);
398 return MAKE_NUMBER (FUNCTION (x).arity);
404 VALUE (tmp_num) = TPAIR;
405 return make_cell_ (tmp_num, x, y);
412 if (TYPE (x) != TPAIR) error (cell_symbol_not_a_pair, cons (x, cell_symbol_car));
421 if (TYPE (x) != TPAIR) error (cell_symbol_not_a_pair, cons (x, cell_symbol_cdr));
427 list (SCM x) ///((arity . n))
435 return x == cell_nil ? cell_t : cell_f;
442 || ((TYPE (x) == TKEYWORD && TYPE (y) == TKEYWORD
443 && STRING (x) == STRING (y)))
444 || (TYPE (x) == TCHAR && TYPE (y) == TCHAR
445 && VALUE (x) == VALUE (y))
446 || (TYPE (x) == TNUMBER && TYPE (y) == TNUMBER
447 && VALUE (x) == VALUE (y)))
452 values (SCM x) ///((arity . n))
460 acons (SCM key, SCM value, SCM alist)
462 return cons (cons (key, value), alist);
469 while (x != cell_nil)
472 if (TYPE (x) != TPAIR) return MAKE_NUMBER (-1);
475 return MAKE_NUMBER (n);
478 SCM apply (SCM, SCM, SCM);
481 error (SCM key, SCM x)
485 if ((throw = assq_ref_env (cell_symbol_throw, r0)) != cell_undefined)
486 return apply (throw, cons (key, cons (x, cell_nil)), r0);
488 display_error_ (key);
496 cstring_to_list (char const* s)
501 p = cons (MAKE_CHAR (s[i]), p);
507 assert_defined (SCM x, SCM e) ///((internal))
509 if (e == cell_undefined) return error (cell_symbol_unbound_variable, x);
514 check_formals (SCM f, SCM formals, SCM args) ///((internal))
516 int flen = (TYPE (formals) == TNUMBER) ? VALUE (formals) : VALUE (length (formals));
517 int alen = VALUE (length (args));
518 if (alen != flen && alen != -1 && flen != -1)
520 char *s = "apply: wrong number of arguments; expected: ";
527 SCM e = MAKE_STRING (cstring_to_list (s));
528 return error (cell_symbol_wrong_number_of_args, cons (e, f));
530 return cell_unspecified;
534 check_apply (SCM f, SCM e) ///((internal))
537 if (f == cell_f || f == cell_t) type = "bool";
538 if (f == cell_nil) type = "nil";
539 if (f == cell_unspecified) type = "*unspecified*";
540 if (f == cell_undefined) type = "*undefined*";
541 if (TYPE (f) == TCHAR) type = "char";
542 if (TYPE (f) == TNUMBER) type = "number";
543 if (TYPE (f) == TSTRING) type = "string";
547 char *s = "cannot apply: ";
553 SCM e = MAKE_STRING (cstring_to_list (s));
554 return error (cell_symbol_wrong_type_arg, cons (e, f));
556 return cell_unspecified;
560 gc_push_frame () ///((internal))
562 SCM frame = cons (r1, cons (r2, cons (r3, cons (r0, cell_nil))));
563 g_stack = cons (frame, g_stack);
568 append2 (SCM x, SCM y)
570 if (x == cell_nil) return y;
571 assert (TYPE (x) == TPAIR);
572 return cons (car (x), append2 (cdr (x), y));
576 pairlis (SCM x, SCM y, SCM a)
580 if (TYPE (x) != TPAIR)
581 return cons (cons (x, y), a);
582 return cons (cons (car (x), car (y)),
583 pairlis (cdr (x), cdr (y), a));
589 if ((FUNCTION (fn).arity > 0 || FUNCTION (fn).arity == -1)
590 && x != cell_nil && TYPE (CAR (x)) == TVALUES)
591 x = cons (CADAR (x), CDR (x));
592 if ((FUNCTION (fn).arity > 1 || FUNCTION (fn).arity == -1)
593 && x != cell_nil && TYPE (CDR (x)) == TPAIR && TYPE (CADR (x)) == TVALUES)
594 x = cons (CAR (x), cons (CDADAR (x), CDR (x)));
595 switch (FUNCTION (fn).arity)
597 #if __MESC__ || !_POSIX_SOURCE
598 case 0: return (FUNCTION (fn).function) ();
599 case 1: return ((SCM(*)(SCM))(FUNCTION (fn).function)) (CAR (x));
600 case 2: return ((SCM(*)(SCM,SCM))(FUNCTION (fn).function)) (CAR (x), CADR (x));
601 case 3: return ((SCM(*)(SCM,SCM,SCM))(FUNCTION (fn).function)) (CAR (x), CADR (x), CAR (CDDR (x)));
602 case -1: return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);
603 default: return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);
605 case 0: return FUNCTION (fn).function0 ();
606 case 1: return FUNCTION (fn).function1 (CAR (x));
607 case 2: return FUNCTION (fn).function2 (CAR (x), CADR (x));
608 case 3: return FUNCTION (fn).function3 (CAR (x), CADR (x), CAR (CDDR (x)));
609 case -1: return FUNCTION (fn).functionn (x);
613 return cell_unspecified;
619 //FIXME: move into fast-non eq_p-ing assq core:assq?
620 //while (a != cell_nil && x != CAAR (a)) a = CDR (a);
621 while (a != cell_nil && eq_p (x, CAAR (a)) == cell_f) a = CDR (a);
622 return a != cell_nil ? CAR (a) : cell_f;
626 assq_ref_env (SCM x, SCM a)
629 if (x == cell_f) return cell_undefined;
634 set_car_x (SCM x, SCM e)
636 assert (TYPE (x) == TPAIR);
638 return cell_unspecified;
642 set_cdr_x (SCM x, SCM e)
644 if (TYPE (x) != TPAIR) error (cell_symbol_not_a_pair, cons (x, cell_set_cdr_x));
646 return cell_unspecified;
650 set_env_x (SCM x, SCM e, SCM a)
652 SCM p = assert_defined (x, assq (x, a));
653 if (TYPE (p) != TPAIR) error (cell_symbol_not_a_pair, cons (p, x));
654 return set_cdr_x (p, e);
658 call_lambda (SCM e, SCM x, SCM aa, SCM a) ///((internal))
660 SCM cl = cons (cons (cell_closure, x), x);
663 return cell_unspecified;
667 make_closure_ (SCM args, SCM body, SCM a) ///((internal))
669 return make_cell_ (tmp_num_ (TCLOSURE), cell_f, cons (cons (cell_circular, a), cons (args, body)));
673 lookup_macro_ (SCM x, SCM a) ///((internal))
675 if (TYPE (x) != TSYMBOL) return cell_f;
676 SCM m = assq_ref_env (x, a);
677 if (TYPE (m) == TMACRO) return MACRO (m);
682 push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal))
691 return cell_unspecified;
695 gc_peek_frame () ///((internal))
697 SCM frame = CAR (g_stack);
700 r3 = CAR (CDDR (frame));
701 r0 = CADR (CDDR (frame));
706 gc_pop_frame () ///((internal))
708 SCM frame = gc_peek_frame (g_stack);
709 g_stack = CDR (g_stack);
720 case cell_vm_evlis: goto evlis;
721 case cell_vm_evlis2: goto evlis2;
722 case cell_vm_evlis3: goto evlis3;
723 case cell_vm_apply: goto apply;
724 case cell_vm_apply2: goto apply2;
725 case cell_vm_eval: goto eval;
727 case cell_vm_eval_car: goto eval_car;
728 case cell_vm_eval_cdr: goto eval_cdr;
729 case cell_vm_eval_cons: goto eval_cons;
730 case cell_vm_eval_null_p: goto eval_null_p;
732 case cell_vm_eval_set_x: goto eval_set_x;
733 case cell_vm_eval_macro: goto eval_macro;
734 case cell_vm_eval_check_func: goto eval_check_func;
735 case cell_vm_eval2: goto eval2;
736 case cell_vm_macro_expand: goto macro_expand;
737 case cell_vm_begin: goto begin;
738 case cell_vm_begin_read_input_file: goto begin_read_input_file;
739 case cell_vm_begin2: goto begin2;
740 case cell_vm_if: goto vm_if;
741 case cell_vm_if_expr: goto if_expr;
742 case cell_vm_call_with_current_continuation2: goto call_with_current_continuation2;
743 case cell_vm_call_with_values2: goto call_with_values2;
744 case cell_vm_return: goto vm_return;
745 case cell_unspecified: return r1;
753 if (r1 == cell_nil) goto vm_return;
754 if (TYPE (r1) != TPAIR) goto eval;
755 push_cc (CAR (r1), r1, r0, cell_vm_evlis2);
758 push_cc (CDR (r2), r1, r0, cell_vm_evlis3);
766 switch (TYPE (CAR (r1)))
769 check_formals (CAR (r1), MAKE_NUMBER (FUNCTION (CAR (r1)).arity), CDR (r1));
770 r1 = call (CAR (r1), CDR (r1)); /// FIXME: move into eval_apply
775 SCM cl = CLOSURE (CAR (r1));
776 SCM formals = CADR (cl);
777 SCM body = CDDR (cl);
780 check_formals (CAR (r1), formals, CDR (r1));
781 SCM p = pairlis (formals, CDR (r1), aa);
782 call_lambda (body, p, aa, r0);
788 g_stack = CONTINUATION (CAR (r1));
799 push_cc (cons (CADR (r1), CADDR (r1)), r1, r0, cell_vm_return);
804 push_cc (CADR (r1), r1, CADDR (r1), cell_vm_return);
807 case cell_call_with_current_continuation:
810 goto call_with_current_continuation;
812 default: check_apply (cell_f, CAR (r1));
817 if (CAR (r1) == cell_symbol_call_with_values)
820 goto call_with_values;
822 if (CAR (r1) == cell_symbol_current_module)
833 case cell_symbol_lambda:
835 SCM formals = CADR (CAR (r1));
836 SCM body = CDDR (CAR (r1));
837 SCM p = pairlis (formals, CDR (r1), r0);
838 check_formals (r1, formals, CDR (r1));
839 call_lambda (body, p, p, r0);
845 push_cc (CAR (r1), r1, r0, cell_vm_apply2);
848 check_apply (r1, CAR (r2));
849 r1 = cons (r1, CDR (r2));
861 case cell_symbol_car:
863 push_cc (CADR (r1), r1, r0, cell_vm_eval_car); goto eval;
865 x = r1; gc_pop_frame (); r1 = CAR (x); goto eval_apply;
867 case cell_symbol_cdr:
869 push_cc (CADR (r1), r1, r0, cell_vm_eval_cdr); goto eval;
871 x = r1; gc_pop_frame (); r1 = CDR (x); goto eval_apply;
873 case cell_symbol_cons: {
874 push_cc (CDR (r1), r1, r0, cell_vm_eval_cons); goto evlis;
878 r1 = cons (CAR (x), CADR (x));
881 case cell_symbol_null_p:
883 push_cc (CADR (r1), r1, r0, cell_vm_eval_null_p);
886 x = r1; gc_pop_frame (); r1 = null_p (x); goto eval_apply;
888 #endif // FIXED_PRIMITIVES
889 case cell_symbol_quote:
891 x = r1; gc_pop_frame (); r1 = CADR (x); goto eval_apply;
893 case cell_symbol_begin: goto begin;
894 case cell_symbol_lambda:
896 r1 = make_closure_ (CADR (r1), CDDR (r1), assq (cell_closure, r0));
899 case cell_symbol_if: {r1=CDR (r1); goto vm_if;}
900 case cell_symbol_set_x:
902 push_cc (CAR (CDDR (r1)), r1, r0, cell_vm_eval_set_x);
906 r1 = set_env_x (CADR (x), r1, r0);
909 case cell_vm_macro_expand:
911 push_cc (CADR (r1), r1, r0, cell_vm_return);
915 push_cc (r1, r1, r0, cell_vm_eval_macro);
920 if (TYPE (r1) == TPAIR)
922 set_cdr_x (r2, CDR (r1));
923 set_car_x (r2, CAR (r1));
927 push_cc (CAR (r1), r1, r0, cell_vm_eval_check_func); goto eval;
929 push_cc (CDR (r2), r2, r0, cell_vm_eval2); goto evlis;
931 r1 = cons (CAR (r2), r1);
938 r1 = assert_defined (r1, assq_ref_env (r1, r0));
941 default: goto vm_return;
947 if (TYPE (r1) == TPAIR
948 && (macro = lookup_macro_ (CAR (r1), r0)) != cell_f)
950 r1 = cons (macro, CDR (r1));
953 else if (TYPE (r1) == TPAIR
954 && TYPE (CAR (r1)) == TSYMBOL
955 && ((expanders = assq_ref_env (cell_symbol_sc_expander_alist, r0)) != cell_undefined)
956 && ((macro = assq (CAR (r1), expanders)) != cell_f))
958 SCM sc_expand = assq_ref_env (cell_symbol_macro_expand, r0);
959 if (sc_expand != cell_undefined && sc_expand != cell_f)
961 r1 = cons (sc_expand, cons (r1, cell_nil));
968 x = cell_unspecified;
969 while (r1 != cell_nil) {
971 if (TYPE (r1) == TPAIR && TYPE (CAR (r1)) == TPAIR)
973 if (CAAR (r1) == cell_symbol_begin)
974 r1 = append2 (CDAR (r1), CDR (r1));
975 else if (CAAR (r1) == cell_symbol_primitive_load)
977 push_cc (cons (cell_symbol_read_input_file, cell_nil), r1, r0, cell_vm_begin_read_input_file);
979 begin_read_input_file:
980 r1 = append2 (r1, CDR (r2));
983 if (CDR (r1) == cell_nil)
988 push_cc (CAR (r1), r1, r0, cell_vm_begin2);
998 push_cc (CAR (r1), r1, r0, cell_vm_if_expr);
1008 if (CDDR (r1) != cell_nil)
1010 r1 = CAR (CDDR (r1));
1013 r1 = cell_unspecified;
1016 call_with_current_continuation:
1018 x = MAKE_CONTINUATION (g_continuations++);
1020 push_cc (cons (CAR (r1), cons (x, cell_nil)), x, r0, cell_vm_call_with_current_continuation2);
1022 call_with_current_continuation2:
1023 CONTINUATION (r2) = g_stack;
1027 push_cc (cons (CAR (r1), cell_nil), r1, r0, cell_vm_call_with_values2);
1030 if (TYPE (r1) == TVALUES)
1032 r1 = cons (CADR (r2), r1);
1043 apply (SCM f, SCM x, SCM a) ///((internal))
1045 push_cc (cons (f, x), cell_unspecified, r0, cell_unspecified);
1047 return eval_apply ();
1051 mes_g_stack (SCM a) ///((internal))
1057 g_stack = cons (cell_nil, cell_nil);
1061 //
\f Environment setup
1064 make_tmps (struct scm* cells)
1067 cells[tmp].type = TCHAR;
1069 cells[tmp_num].type = TNUMBER;
1070 tmp_num2 = g_free++;
1071 cells[tmp_num2].type = TNUMBER;
1083 gc_init_cells () ///((internal))
1085 g_cells = (struct scm *)malloc (2*ARENA_SIZE*sizeof (struct scm));
1091 g_cells += sizeof (struct scm);
1101 gc_init_news () ///((internal))
1105 p -= sizeof (struct scm);
1106 p += ARENA_SIZE * sizeof (struct scm);
1109 g_news = g_cells-1 + ARENA_SIZE;
1112 NTYPE (0) = TVECTOR;
1116 g_news += sizeof (struct scm);
1126 mes_symbols () ///((internal))
1132 #include "mes.mes.symbols.i"
1134 #include "mes.symbols.i"
1137 g_symbol_max = g_free;
1138 make_tmps (g_cells);
1141 for (int i=1; i<g_symbol_max; i++)
1142 g_symbols = cons (i, g_symbols);
1147 #include "mes.mes.symbol-names.i"
1149 #include "mes.symbol-names.i"
1152 a = acons (cell_symbol_mes_version, MAKE_STRING (cstring_to_list (VERSION)), a);
1153 a = acons (cell_symbol_mes_prefix, MAKE_STRING (cstring_to_list (PREFIX)), a);
1155 a = acons (cell_symbol_dot, cell_dot, a);
1156 a = acons (cell_symbol_begin, cell_begin, a);
1157 a = acons (cell_symbol_call_with_values, cell_symbol_call_with_values, a);
1158 a = acons (cell_symbol_current_module, cell_symbol_current_module, a);
1159 a = acons (cell_symbol_call_with_current_continuation, cell_call_with_current_continuation, a);
1160 a = acons (cell_symbol_sc_expand, cell_f, a);
1163 a = acons (cell_symbol_gnuc, cell_t, a);
1164 a = acons (cell_symbol_mesc, cell_f, a);
1166 a = acons (cell_symbol_gnuc, cell_f, a);
1167 a = acons (cell_symbol_mesc, cell_t, a);
1170 a = acons (cell_closure, a, a);
1176 mes_environment () ///((internal))
1178 SCM a = mes_symbols ();
1179 return mes_g_stack (a);
1183 mes_builtins (SCM a) ///((internal))
1185 #if !__GNUC__ || !_POSIX_SOURCE
1186 #include "mes.mes.i"
1188 // Do not sort: Order of these includes define builtins
1189 #include "posix.mes.i"
1190 #include "math.mes.i"
1191 #include "lib.mes.i"
1192 #include "vector.mes.i"
1195 #include "reader.mes.i"
1198 #include "gc.mes.environment.i"
1199 #include "lib.mes.environment.i"
1200 #include "math.mes.environment.i"
1201 #include "mes.mes.environment.i"
1202 #include "posix.mes.environment.i"
1204 #include "reader.mes.environment.i"
1206 #include "vector.mes.environment.i"
1210 // Do not sort: Order of these includes define builtins
1218 #include "gc.environment.i"
1219 #include "lib.environment.i"
1220 #include "math.environment.i"
1221 #include "mes.environment.i"
1222 #include "posix.environment.i"
1223 #include "reader.environment.i"
1224 #include "vector.environment.i"
1229 fputs ("functions: ", STDERR);
1230 fputs (itoa (g_function), STDERR);
1231 fputs ("\n", STDERR);
1232 for (int i = 0; i < g_function; i++)
1234 fputs ("[", STDERR);
1235 fputs (itoa (i), STDERR);
1236 fputs ("]: ", STDERR);
1237 fputs (g_functions[i].name, STDERR);
1238 fputs ("\n", STDERR);
1240 fputs ("\n", STDERR);
1247 load_env (SCM a) ///((internal))
1250 g_stdin = open ("module/mes/read-0.mes", O_RDONLY);
1251 g_stdin = g_stdin >= 0 ? g_stdin : open (MODULEDIR "/mes/read-0.mes", O_RDONLY);
1252 if (!g_function) r0 = mes_builtins (r0);
1253 r2 = read_input_file_env (r0);
1259 bload_env (SCM a) ///((internal))
1262 char *mo = "mes/read-0-32.mo";
1263 g_stdin = open ("module/mes/read-0-32.mo", O_RDONLY);
1264 g_stdin = g_stdin >= 0 ? g_stdin : open (MODULEDIR "/mes/read-0-32.mo", O_RDONLY);
1266 char *mo ="mes/read-0.mo";
1267 g_stdin = open ("module/mes/read-0.mo", O_RDONLY);
1268 g_stdin = g_stdin >= 0 ? g_stdin : open (MODULEDIR "/mes/read-0.mo", O_RDONLY);
1271 if (g_stdin < 0) {eputs ("no such file: ");eputs (mo);eputs ("\n");return 1;}
1272 assert (getchar () == 'M');
1273 assert (getchar () == 'E');
1274 assert (getchar () == 'S');
1276 if (g_debug) eputs ("*GOT MES*\n");
1277 g_stack = getchar () << 8;
1278 g_stack += getchar ();
1280 char *p = (char*)g_cells;
1287 g_free = (p-(char*)g_cells) / sizeof (struct scm);
1291 r0 = mes_builtins (r0);
1294 set_env_x (cell_symbol_gnuc, cell_t, r0);
1295 set_env_x (cell_symbol_mesc, cell_f, r0);
1297 set_env_x (cell_symbol_gnuc, cell_f, r0);
1298 set_env_x (cell_symbol_mesc, cell_t, r0);
1303 eputs ("symbols: ");
1305 while (s && s != cell_nil) {
1306 display_error_ (CAR (s));
1311 eputs ("functions: ");
1312 eputs (itoa (g_function));
1314 for (int i = 0; i < g_function; i++)
1319 eputs (g_functions[i].name);
1322 //display_error_ (r0);
1330 #if _POSIX_SOURCE || MES_FULL
1335 main (int argc, char *argv[])
1338 if (p = getenv ("MES_DEBUG")) g_debug = atoi (p);
1339 if (g_debug) {eputs (";;; MODULEDIR=");eputs (MODULEDIR);eputs ("\n");}
1340 if (p = getenv ("MES_MAX_ARENA")) MAX_ARENA_SIZE = atoi (p);
1341 if (p = getenv ("MES_ARENA")) ARENA_SIZE = atoi (p);
1342 if (argc > 1 && !strcmp (argv[1], "--help")) return puts ("Usage: mes [--dump|--load] < FILE\n");
1343 if (argc > 1 && !strcmp (argv[1], "--version")) {puts ("Mes ");puts (VERSION);puts ("\n");return 0;};
1345 r0 = mes_environment ();
1348 SCM program = bload_env (r0);
1350 SCM program = (argc > 1 && !strcmp (argv[1], "--load"))
1351 ? bload_env (r0) : load_env (r0);
1352 g_tiny = argc > 2 && !strcmp (argv[2], "--tiny");
1353 if (argc > 1 && !strcmp (argv[1], "--dump")) return dump ();
1357 for (int i=argc-1; i>=0; i--) lst = cons (MAKE_STRING (cstring_to_list (argv[i])), lst);
1358 r0 = acons (cell_symbol_argv, lst, r0);
1359 push_cc (r2, cell_unspecified, r0, cell_unspecified);
1362 eputs ("program: ");
1363 display_error_ (r1);
1368 display_error_ (r1);
1373 eputs ("\nstats: [");
1374 eputs (itoa (g_free));
1380 #if !_POSIX_SOURCE && !__MESC__