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/>.
22 #define FIXED_PRIMITIVES 0
31 #define NYACC_CAR nyacc_car
32 #define NYACC_CDR nyacc_cdr
42 void *malloc (size_t i);
43 int open (char const *s, int mode);
44 int read (int fd, void* buf, size_t n);
45 void write (int fd, char const* s, int n);
54 : // no outputs "=" (r)
62 getenv (char const* p)
68 read (int fd, void* buf, size_t n)
71 //syscall (SYS_write, fd, s, n));
80 : "" (fd), "" (buf), "" (n)
81 : "eax", "ebx", "ecx", "edx"
87 open (char const *s, int mode)
90 //syscall (SYS_open, mode));
108 int r = read (g_stdin, &c, 1);
109 if (r < 1) return -1;
114 write (int fd, char const* s, int n)
117 //syscall (SYS_write, fd, s, n));
123 "mov $0x4, %%eax\n\t"
125 : // no outputs "=" (r)
126 : "" (fd), "" (s), "" (n)
127 : "eax", "ebx", "ecx", "edx"
134 //write (STDOUT, s, strlen (s));
135 //int i = write (STDOUT, s, strlen (s));
136 write (1, (char*)&c, 1);
144 int len = size + sizeof (size);
145 //n = mmap (0, len, PROT_READ | PROT_WRITE, MAP_PRIVATE | MAP_ANONYMOUS, 0, 0 );
154 //munmap ((void*)p, *n);
163 strlen (char const* s)
171 strcmp (char const* a, char const* b)
173 while (*a && *b && *a == *b) {a++;b++;}
180 //write (STDOUT, s, strlen (s));
181 //int i = write (STDOUT, s, strlen (s));
188 eputs (char const* s)
190 //write (STDERR, s, strlen (s));
191 //int i = write (STDERR, s, strlen (s));
210 *p-- = '0' + (x % 10);
222 assert_fail (char* s)
224 eputs ("assert fail:");
235 #define assert(x) ((x) ? (void)0 : assert_fail ("boo:" #x))
237 //#define assert(x) ((x) ? (void)0 : assert_fail ("boo:" #x))
238 #define assert(x) ((x) ? (void)0 : assert_fail (0))
260 #if __NYACC__ || FIXME_NYACC
261 enum type_t {CHAR, CLOSURE, CONTINUATION, TFUNCTION, KEYWORD, MACRO, NUMBER, PAIR, REF, SPECIAL, TSTRING, SYMBOL, VALUES, TVECTOR, BROKEN_HEART};
263 enum type_t {CHAR, CLOSURE, CONTINUATION, FUNCTION, KEYWORD, MACRO, NUMBER, PAIR, REF, SPECIAL, STRING, SYMBOL, VALUES, VECTOR, BROKEN_HEART};
272 typedef int (*f_t) (void);
274 int (*function) (void);
278 struct scm *g_cells = arena;
282 // struct scm scm_nil = {SPECIAL, "()"};
283 // struct scm scm_f = {SPECIAL, "#f"};
284 // struct scm scm_t = {SPECIAL, "#t"};
285 // struct scm_dot = {SPECIAL, "."};
286 // struct scm_arrow = {SPECIAL, "=>"};
287 // struct scm_undefined = {SPECIAL, "*undefined*"};
288 // struct scm_unspecified = {SPECIAL, "*unspecified*"};
289 // struct scm_closure = {SPECIAL, "*closure*"};
290 // struct scm_circular = {SPECIAL, "*circular*"};
291 // struct scm_begin = {SPECIAL, "*begin*"};
293 // struct scm_vm_apply = {SPECIAL, "core:apply"};
294 // struct scm_vm_apply2 = {SPECIAL, "*vm-apply2*"};
296 // struct scm_vm_eval = {SPECIAL, "core:eval"};
298 // struct scm_vm_begin = {SPECIAL, "*vm-begin*"};
299 // //scm scm_vm_begin_read_input_file = {SPECIAL, "*vm-begin-read-input-file*"};
300 // struct scm_vm_begin2 = {SPECIAL, "*vm-begin2*"};
302 // struct scm_vm_return = {SPECIAL, "*vm-return*"};
304 // //#include "mes.symbols.h"
310 // #define cell_arrow 5
311 #define cell_undefined 6
312 #define cell_unspecified 7
313 #define cell_closure 8
314 #define cell_circular 9
315 #define cell_begin 10
316 #define cell_symbol_dot 11
317 #define cell_symbol_lambda 12
318 #define cell_symbol_begin 13
319 #define cell_symbol_if 14
320 #define cell_symbol_quote 15
321 #define cell_symbol_set_x 16
323 #define cell_vm_apply 45
324 #define cell_vm_apply2 46
326 #define cell_vm_eval 47
328 #define cell_vm_begin 56
329 //#define cell_vm_begin_read_input_file 57
330 #define cell_vm_begin2 58
332 #define cell_vm_return 63
338 int ARENA_SIZE = 200;
339 struct function functions[2];
343 SCM make_cell (SCM type, SCM car, SCM cdr);
344 struct function fun_make_cell = {&make_cell, 3};
345 struct scm scm_make_cell = {TFUNCTION,0,0};
349 SCM cons (SCM x, SCM y);
350 struct function fun_cons = {&cons, 2};
351 struct scm scm_cons = {TFUNCTION,0,0};
356 struct function fun_car = {&car, 1};
357 struct scm scm_car = {TFUNCTION,0,0};
362 struct function fun_cdr = {&cdr, 1};
363 struct scm scm_cdr = {TFUNCTION,0,0};
367 // SCM eq_p (SCM x, SCM y);
368 // struct function fun_eq_p = {&eq_p, 2};
369 // scm scm_eq_p = {TFUNCTION,0,0};// "eq?", 0};
372 #define TYPE(x) (g_cells[x].type)
374 #define CAR(x) g_cells[x].car
375 #define LENGTH(x) g_cells[x].car
376 #define STRING(x) g_cells[x].car
378 #define CDR(x) g_cells[x].cdr
380 //#define CLOSURE(x) g_cells[x].closure
382 #define CONTINUATION(x) g_cells[x].cdr
384 //#define FUNCTION(x) functions[g_cells[x].function]
387 #define FUNCTION(x) functions[g_cells[x].cdr]
388 #define VALUE(x) g_cells[x].cdr
389 #define VECTOR(x) g_cells[x].cdr
391 #define MAKE_CHAR(n) make_cell (tmp_num_ (CHAR), 0, tmp_num2_ (n))
392 //#define MAKE_CONTINUATION(n) make_cell (tmp_num_ (CONTINUATION), n, g_stack)
393 #define MAKE_NUMBER(n) make_cell (tmp_num_ (NUMBER), 0, tmp_num2_ (n))
394 //#define MAKE_REF(n) make_cell (tmp_num_ (REF), n, 0)
397 #define CAAR(x) CAR (CAR (x))
398 // #define CDAR(x) CDR (CAR (x))
399 #define CADAR(x) CAR (CDR (CAR (x)))
400 // #define CADDR(x) CAR (CDR (CDR (x)))
401 // #define CDDDR(x) CDR (CDR (CDR (x)))
402 #define CDADAR(x) CAR (CDR (CAR (CDR (x))))
403 #define CADR(x) CAR (CDR (x))
406 #if __NYACC__ || FIXME_NYACC
407 #define MAKE_STRING(x) make_cell (tmp_num_ (TSTRING), x, 0)
409 // #define MAKE_STRING(x) make_cell (tmp_num_ (STRING), x, 0)
415 assert (g_free + n < ARENA_SIZE);
422 make_cell (SCM type, SCM car, SCM cdr)
425 assert (TYPE (type) == NUMBER);
426 TYPE (x) = VALUE (type);
427 if (VALUE (type) == CHAR || VALUE (type) == NUMBER) {
428 if (car) CAR (x) = CAR (car);
429 if (cdr) CDR(x) = CDR(cdr);
430 } else if (VALUE (type) == TFUNCTION) {
431 if (car) CAR (x) = car;
432 if (cdr) CDR(x) = CDR(cdr);
450 VALUE (tmp_num2) = x;
458 VALUE (tmp_num) = PAIR;
459 return make_cell (tmp_num, x, y);
473 if (TYPE (x) != PAIR) error (cell_symbol_not_a_pair, cons (x, cell_symbol_car));
485 if (TYPE (x) != PAIR) error (cell_symbol_not_a_pair, cons (x, cell_symbol_cdr));
491 // eq_p (SCM x, SCM y)
494 // || ((TYPE (x) == KEYWORD && TYPE (y) == KEYWORD
495 // && STRING (x) == STRING (y)))
496 // || (TYPE (x) == CHAR && TYPE (y) == CHAR
497 // && VALUE (x) == VALUE (y))
498 // || (TYPE (x) == NUMBER && TYPE (y) == NUMBER
499 // && VALUE (x) == VALUE (y)))
500 // ? cell_t : cell_f;
506 SCM frame = cons (r1, cons (r2, cons (r3, cons (r0, cell_nil))));
507 g_stack = cons (frame, g_stack);
514 // SCM frame = cons (r1, cons (r2, cons (r3, cons (r0, cell_nil))));
515 // g_stack = cons (frame, g_stack);
520 append2 (SCM x, SCM y)
522 if (x == cell_nil) return y;
523 assert (TYPE (x) == PAIR);
524 return cons (car (x), append2 (cdr (x), y));
528 pairlis (SCM x, SCM y, SCM a)
532 if (TYPE (x) != PAIR)
533 return cons (cons (x, y), a);
534 return cons (cons (car (x), car (y)),
535 pairlis (cdr (x), cdr (y), a));
541 //while (a != cell_nil && eq_p (x, CAAR (a)) == cell_f) a = CDR (a);
542 while (a != cell_nil && x == CAAR (a)) a = CDR (a);
543 return a != cell_nil ? car (a) : cell_f;
547 assq_ref_env (SCM x, SCM a)
550 if (x == cell_f) return cell_undefined;
555 assert_defined (SCM x, SCM e)
557 if (e != cell_undefined) return e;
558 // error (cell_symbol_unbound_variable, x);
559 puts ("unbound variable");
565 push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal))
575 return cell_unspecified;
579 xpush_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal))
589 return cell_unspecified;
592 SCM caar (SCM x) {return car (car (x));}
593 SCM cadr (SCM x) {return car (cdr (x));}
594 SCM cdar (SCM x) {return cdr (car (x));}
595 SCM cddr (SCM x) {return cdr (cdr (x));}
604 // if (g_free + GC_SAFETY > ARENA_SIZE)
605 // gc_pop_frame (gc (gc_push_frame ()));
610 case cell_vm_evlis: goto evlis;
611 case cell_vm_evlis2: goto evlis2;
612 case cell_vm_evlis3: goto evlis3;
614 case cell_vm_apply: {goto apply;}
615 case cell_vm_apply2: {goto apply2;}
616 case cell_vm_eval: {goto eval;}
619 case cell_vm_eval_car: goto eval_car;
620 case cell_vm_eval_cdr: goto eval_cdr;
621 case cell_vm_eval_cons: goto eval_cons;
622 case cell_vm_eval_null_p: goto eval_null_p;
624 case cell_vm_eval_set_x: goto eval_set_x;
625 case cell_vm_eval_macro: goto eval_macro;
626 case cell_vm_eval2: goto eval2;
627 case cell_vm_macro_expand: goto macro_expand;
629 case cell_vm_begin: {goto begin;}
630 ///case cell_vm_begin_read_input_file: goto begin_read_input_file;
631 case cell_vm_begin2: {goto begin2;}
633 case cell_vm_if: goto vm_if;
634 case cell_vm_if_expr: goto if_expr;
635 case cell_vm_call_with_current_continuation2: goto call_with_current_continuation2;
636 case cell_vm_call_with_values2: goto call_with_values2;
637 case cell_vm_return: goto vm_return;
639 case cell_unspecified: {return r1;}
640 default: {assert (0);}
647 // if (r1 == cell_nil) goto vm_return;
648 // if (TYPE (r1) != PAIR) goto eval;
649 // push_cc (car (r1), r1, r0, cell_vm_evlis2);
652 // push_cc (cdr (r2), r1, r0, cell_vm_evlis3);
655 // r1 = cons (r2, r1);
660 switch (TYPE (car (r1)))
663 //check_formals (car (r1), MAKE_NUMBER (FUNCTION (car (r1)).arity), cdr (r1));
664 r1 = call (car (r1), cdr (r1)); /// FIXME: move into eval_apply
669 // SCM cl = CLOSURE (car (r1));
670 // SCM formals = cadr (cl);
671 // SCM body = cddr (cl);
672 // SCM aa = cdar (cl);
674 // //check_formals (car (r1), formals, cdr (r1));
675 // SCM p = pairlis (formals, cdr (r1), aa);
676 // call_lambda (body, p, aa, r0);
679 // case CONTINUATION:
682 // g_stack = CONTINUATION (CAR (r1));
692 // case cell_vm_apply:
694 // push_cc (cons (CADR (r1), CADDR (r1)), r1, r0, cell_vm_return);
697 // case cell_vm_eval:
699 // push_cc (CADR (r1), r1, CADDR (r1), cell_vm_return);
702 // case cell_call_with_current_continuation:
705 // goto call_with_current_continuation;
707 // default: check_apply (cell_f, car (r1));
712 // if (car (r1) == cell_symbol_call_with_values)
715 // goto call_with_values;
717 // if (car (r1) == cell_symbol_current_module)
727 // switch (caar (r1))
729 // case cell_symbol_lambda:
731 // SCM formals = cadr (car (r1));
732 // SCM body = cddr (car (r1));
733 // SCM p = pairlis (formals, cdr (r1), r0);
734 // check_formals (r1, formals, cdr (r1));
735 // call_lambda (body, p, p, r0);
741 push_cc (car (r1), r1, r0, cell_vm_apply2);
744 //check_apply (r1, car (r2));
745 r1 = cons (r1, cdr (r2));
755 // #if FIXED_PRIMITIVES
756 // case cell_symbol_car:
758 // push_cc (CADR (r1), r1, r0, cell_vm_eval_car); goto eval;
760 // x = r1; gc_pop_frame (); r1 = car (x); goto eval_apply;
762 // case cell_symbol_cdr:
764 // push_cc (CADR (r1), r1, r0, cell_vm_eval_cdr); goto eval;
766 // x = r1; gc_pop_frame (); r1 = cdr (x); goto eval_apply;
768 // case cell_symbol_cons: {
769 // push_cc (CDR (r1), r1, r0, cell_vm_eval_cons); goto evlis;
773 // r1 = cons (CAR (x), CADR (x));
776 // case cell_symbol_null_p:
778 // push_cc (CADR (r1), r1, r0, cell_vm_eval_null_p);
781 // x = r1; gc_pop_frame (); r1 = null_p (x); goto eval_apply;
783 // #endif // FIXED_PRIMITIVES
784 // case cell_symbol_quote:
786 // x = r1; gc_pop_frame (); r1 = cadr (x); goto eval_apply;
788 // case cell_symbol_begin: goto begin;
789 // case cell_symbol_lambda:
791 // r1 = make_closure (cadr (r1), cddr (r1), assq (cell_closure, r0));
795 // case cell_symbol_if: {r1=cdr (r1); goto vm_if;}
796 // case cell_symbol_set_x:
798 // push_cc (car (cddr (r1)), r1, r0, cell_vm_eval_set_x);
802 // r1 = set_env_x (cadr (x), r1, r0);
805 // case cell_vm_macro_expand:
807 // push_cc (cadr (r1), r1, r0, cell_vm_return);
808 // goto macro_expand;
813 push_cc (r1, r1, r0, cell_vm_eval_macro);
819 if (TYPE (r1) == PAIR)
821 set_cdr_x (r2, cdr (r1));
822 set_car_x (r2, car (r1));
826 push_cc (CDR (r1), r1, r0, cell_vm_eval2); goto evlis;
829 r1 = cons (car (r2), r1);
836 r1 = assert_defined (r1, assq_ref_env (r1, r0));
839 default: {goto vm_return;}
846 // if (TYPE (r1) == PAIR
847 // && (macro = lookup_macro (car (r1), r0)) != cell_f)
849 // r1 = cons (macro, CDR (r1));
852 // else if (TYPE (r1) == PAIR
853 // && TYPE (CAR (r1)) == SYMBOL
854 // && ((expanders = assq_ref_env (cell_symbol_sc_expander_alist, r0)) != cell_undefined)
855 // && ((macro = assq (CAR (r1), expanders)) != cell_f))
857 // SCM sc_expand = assq_ref_env (cell_symbol_macro_expand, r0);
858 // if (sc_expand != cell_undefined && sc_expand != cell_f)
860 // r1 = cons (sc_expand, cons (r1, cell_nil));
867 x = cell_unspecified;
868 while (r1 != cell_nil) {
869 if (TYPE (r1) == PAIR && TYPE (CAR (r1)) == PAIR)
871 if (caar (r1) == cell_symbol_begin)
872 r1 = append2 (cdar (r1), cdr (r1));
874 else if (caar (r1) == cell_symbol_primitive_load)
876 push_cc (cons (cell_symbol_read_input_file, cell_nil), r1, r0, cell_vm_begin_read_input_file);
878 begin_read_input_file:
879 r1 = append2 (r1, cdr (r2));
883 if (CDR (r1) == cell_nil)
888 push_cc (CAR (r1), r1, r0, cell_vm_begin2);
899 // push_cc (car (r1), r1, r0, cell_vm_if_expr);
909 // if (cddr (r1) != cell_nil)
911 // r1 = car (cddr (r1));
914 // r1 = cell_unspecified;
917 // call_with_current_continuation:
919 // x = MAKE_CONTINUATION (g_continuations++);
921 // push_cc (cons (car (r1), cons (x, cell_nil)), x, r0, cell_vm_call_with_current_continuation2);
923 // call_with_current_continuation2:
924 // CONTINUATION (r2) = g_stack;
928 // push_cc (cons (car (r1), cell_nil), r1, r0, cell_vm_call_with_values2);
930 // call_with_values2:
931 // if (TYPE (r1) == VALUES)
933 // r1 = cons (cadr (r2), r1);
947 if ((FUNCTION (fn).arity > 0 || FUNCTION (fn).arity == -1)
948 && x != cell_nil && TYPE (CAR (x)) == VALUES)
949 x = cons (CADAR (x), CDR (x));
950 if ((FUNCTION (fn).arity > 1 || FUNCTION (fn).arity == -1)
951 && x != cell_nil && TYPE (CDR (x)) == PAIR && TYPE (CADR (x)) == VALUES)
952 x = cons (CAR (x), cons (CDADAR (x), CDR (x)));
953 struct function* f = &FUNCTION (fn);
954 switch (FUNCTION (fn).arity)
956 // case 0: return FUNCTION (fn).function0 ();
957 // case 1: return FUNCTION (fn).function1 (car (x));
958 // case 2: return FUNCTION (fn).function2 (car (x), cadr (x));
959 // case 3: return FUNCTION (fn).function3 (car (x), cadr (x), car (cddr (x)));
960 // case -1: return FUNCTION (fn).functionn (x);
961 case 0: {return (FUNCTION (fn).function) ();}
962 case 1: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (car (x));}
963 case 2: {return ((SCM(*)(SCM,SCM))(FUNCTION (fn).function)) (car (x), cadr (x));}
964 case 3: {return ((SCM(*)(SCM,SCM,SCM))(FUNCTION (fn).function)) (car (x), cadr (x), car (cddr (x)));}
965 //case -1: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);}
966 default: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);}
969 return cell_unspecified;
975 SCM frame = car (g_stack);
978 r3 = car (cddr (frame));
979 r0 = cadr (cddr (frame));
986 SCM frame = gc_peek_frame (g_stack);
987 g_stack = cdr (g_stack);
992 mes_g_stack (SCM a) ///((internal))
998 g_stack = cons (cell_nil, cell_nil);
1002 //
\f Environment setup
1004 make_tmps (struct scm* cells)
1007 cells[tmp].type = CHAR;
1009 cells[tmp_num].type = NUMBER;
1010 tmp_num2 = g_free++;
1011 cells[tmp_num2].type = NUMBER;
1016 make_symbol_ (SCM s)
1018 VALUE (tmp_num) = SYMBOL;
1019 SCM x = make_cell (tmp_num, s, 0);
1020 g_symbols = cons (x, g_symbols);
1030 SCM x = lookup_symbol_ (s);
1032 return x ? x : make_symbol_ (s);
1036 cstring_to_list (char const* s)
1041 p = cons (MAKE_CHAR (s[i]), p);
1046 acons (SCM key, SCM value, SCM alist)
1048 return cons (cons (key, value), alist);
1058 // g_cells = (scm *)malloc (2*ARENA_SIZE*sizeof(scm));
1060 // #if __NYACC__ || FIXME_NYACC
1061 // TYPE (0) = TVECTOR;
1063 // // TYPE (0) = VECTOR;
1065 // LENGTH (0) = 1000;
1075 mes_symbols () ///((internal))
1081 //#include "mes.symbols.i"
1084 // g_cells[cell_nil] = scm_nil;
1087 // g_cells[cell_f] = scm_f;
1090 // g_cells[cell_t] = scm_t;
1093 // g_cells[cell_dot] = scm_dot;
1096 // g_cells[cell_arrow] = scm_arrow;
1099 // g_cells[cell_undefined] = scm_undefined;
1102 // g_cells[cell_unspecified] = scm_unspecified;
1105 // g_cells[cell_closure] = scm_closure;
1108 // g_cells[cell_circular] = scm_circular;
1111 // g_cells[cell_begin] = scm_begin;
1116 // g_cells[cell_vm_apply] = scm_vm_apply;
1119 // g_cells[cell_vm_apply2] = scm_vm_apply2;
1122 // g_cells[cell_vm_eval] = scm_vm_eval;
1127 // g_cells[cell_vm_begin] = scm_vm_begin;
1130 // g_cells[cell_vm_begin_read_input_file] = scm_vm_begin_read_input_file;
1133 // g_cells[cell_vm_begin2] = scm_vm_begin2;
1138 // g_cells[cell_vm_return] = scm_vm_return;
1142 g_symbol_max = g_free;
1143 make_tmps (g_cells);
1147 for (int i=1; i<g_symbol_max; i++)
1148 g_symbols = cons (i, g_symbols);
1153 //#include "mes.symbol-names.i"
1155 // g_cells[cell_nil].car = cstring_to_list (scm_nil.name);
1156 // g_cells[cell_f].car = cstring_to_list (scm_f.name);
1157 // g_cells[cell_t].car = cstring_to_list (scm_t.name);
1158 // g_cells[cell_dot].car = cstring_to_list (scm_dot.name);
1159 // g_cells[cell_arrow].car = cstring_to_list (scm_arrow.name);
1160 // g_cells[cell_undefined].car = cstring_to_list (scm_undefined.name);
1161 // g_cells[cell_unspecified].car = cstring_to_list (scm_unspecified.name);
1162 // g_cells[cell_closure].car = cstring_to_list (scm_closure.name);
1163 // g_cells[cell_circular].car = cstring_to_list (scm_circular.name);
1164 // g_cells[cell_begin].car = cstring_to_list (scm_begin.name);
1167 // a = acons (cell_symbol_mes_version, MAKE_STRING (cstring_to_list (VERSION)), a);
1168 // a = acons (cell_symbol_mes_prefix, MAKE_STRING (cstring_to_list (PREFIX)), a);
1171 a = acons (cell_symbol_dot, cell_dot, a); //
1172 a = acons (cell_symbol_begin, cell_begin, a);
1173 a = acons (cell_closure, a, a);
1175 // a = acons (cell_symbol_call_with_current_continuation, cell_call_with_current_continuation, a);
1176 // a = acons (cell_symbol_sc_expand, cell_f, a);
1182 make_closure (SCM args, SCM body, SCM a)
1184 return make_cell (tmp_num_ (CLOSURE), cell_f, cons (cons (cell_circular, a), cons (args, body)));
1188 mes_environment () ///((internal))
1192 a = mes_g_stack (a);
1197 mes_builtins (SCM a)
1204 // #include "math.i"
1205 // #include "posix.i"
1206 // #include "reader.i"
1208 // #include "lib.environment.i"
1209 // #include "math.environment.i"
1210 // #include "mes.environment.i"
1211 // #include "posix.environment.i"
1212 // #include "reader.environment.i"
1215 scm_make_cell.cdr = g_function;
1216 functions[g_function++] = fun_make_cell;
1217 cell_make_cell = g_free++;
1220 puts (itoa (g_free));
1223 g_cells[16] = scm_make_cell;
1226 scm_cons.cdr = g_function;
1227 functions[g_function++] = fun_cons;
1228 cell_cons = g_free++;
1231 g_cells[cell_cons] = scm_cons;
1233 g_cells[17] = scm_cons;
1236 scm_car.cdr = g_function;
1237 functions[g_function++] = fun_car;
1238 cell_car = g_free++;
1241 g_cells[cell_car] = scm_car;
1246 scm_cdr.cdr = g_function;
1247 functions[g_function++] = fun_cdr;
1248 cell_cdr = g_free++;
1249 g_cells[cell_cdr] = scm_cdr;
1251 // scm_make_cell.string = cstring_to_list (scm_make_cell.name);
1252 // g_cells[cell_make_cell].string = MAKE_STRING (scm_make_cell.string);
1253 // a = acons (make_symbol (scm_make_cell.string), cell_make_cell, a);
1255 // scm_cons.string = cstring_to_list (scm_cons.name);
1256 // g_cells[cell_cons].string = MAKE_STRING (scm_cons.string);
1257 // a = acons (make_symbol (scm_cons.string), cell_cons, a);
1259 // scm_car.string = cstring_to_list (scm_car.name);
1260 // g_cells[cell_car].string = MAKE_STRING (scm_car.string);
1261 // a = acons (make_symbol (scm_car.string), cell_car, a);
1263 // scm_cdr.string = cstring_to_list (scm_cdr.name);
1264 // g_cells[cell_cdr].string = MAKE_STRING (scm_cdr.string);
1265 // a = acons (make_symbol (scm_cdr.string), cell_cdr, a);
1272 bload_env (SCM a) ///((internal))
1274 g_stdin = open ("module/mes/read-0.mo", 0);
1276 //g_stdin = g_stdin ? g_stdin : fopen (PREFIX "module/mes/read-0.mo", "r");
1278 char *p = (char*)g_cells;
1279 assert (getchar () == 'M');
1280 assert (getchar () == 'E');
1281 assert (getchar () == 'S');
1282 g_stack = getchar () << 8;
1283 g_stack += getchar ();
1290 g_free = (p-(char*)g_cells) / sizeof (struct scm);
1294 r0 = mes_builtins (r0);
1301 TYPE (0) = 0x6c6c6168;
1302 CAR (0) = 0x6a746f6f;
1303 CDR (0) = 0x00002165;
1306 CAR (1) = 0x2d2d2d2d;
1307 CDR (1) = 0x3e3e3e3e;
1309 TYPE (9) = 0x2d2d2d2d;
1310 CAR (9) = 0x2d2d2d2d;
1311 CDR (9) = 0x3e3e3e3e;
1319 CAR (11) = 0x58585858;
1327 CAR (13) = 0x58585858;
1330 TYPE (14) = 0x58585858;
1331 CAR (14) = 0x58585858;
1332 CDR (14) = 0x58585858;
1334 TYPE (14) = 0x58585858;
1335 CAR (14) = 0x58585858;
1336 CDR (14) = 0x58585858;
1343 TYPE (11) = TFUNCTION;
1344 CAR (11) = 0x58585858;
1356 CAR (13) = 0x58585858;
1364 CAR (15) = 0x58585858;
1375 //puts ("<display>\n");
1380 //puts ("<char>\n");
1382 putchar (VALUE (x));
1387 //puts ("<function>\n");
1400 //puts ("<number>\n");
1402 putchar (48 + VALUE (x));
1413 //puts ("<pair>\n");
1414 //if (cont != cell_f) puts "(");
1416 if (x && x != cell_nil) display_ (CAR (x));
1417 if (CDR (x) && CDR (x) != cell_nil)
1420 if (TYPE (CDR (x)) != PAIR)
1431 //if (cont != cell_f) puts (")");
1437 //puts ("<default>\n");
1446 simple_bload_env (SCM a) ///((internal))
1449 char *mo = "module/mes/hack-32.mo";
1452 g_stdin = open (mo, 0);
1453 if (g_stdin < 0) {eputs ("no such file: module/mes/read-0-32.mo\n");return 1;}
1455 char *p = (char*)g_cells;
1461 puts (itoa (g_stdin));
1467 assert (getchar () == 'M');
1468 assert (getchar () == 'E');
1469 assert (getchar () == 'S');
1470 puts (" *GOT MES*\n");
1471 g_stack = getchar () << 8;
1472 g_stack += getchar ();
1474 puts (itoa (g_stack));
1479 if (c != 'M') exit (10);
1482 if (c != 'E') exit (11);
1485 if (c != 'S') exit (12);
1486 puts (" *GOT MES*\n");
1501 puts ("read done\n");
1503 g_free = (p-(char*)g_cells) / sizeof (struct scm);
1504 // gc_peek_frame ();
1508 r0 = mes_builtins (r0);
1511 puts ("cells read: ");
1512 puts (itoa (g_free));
1516 puts (itoa (g_symbols));
1518 // display_ (g_symbols);
1528 if (TYPE (12) != PAIR)
1547 string_to_cstring (SCM s)
1549 static char buf[1024];
1552 while (s != cell_nil)
1554 *p++ = VALUE (car (s));
1565 #if __NYACC__ || FIXME_NYACC
1566 if (TYPE (x) == TSTRING)
1568 // if (TYPE (x) == STRING)
1570 eputs (string_to_cstring (x));
1571 // else if ((write = assq_ref_env (cell_symbol_write, r0)) != cell_undefined)
1572 // apply (assq_ref_env (cell_symbol_display, r0), cons (x, cons (MAKE_NUMBER (2), cell_nil)), r0);
1573 #if __NYACC__ || FIXME_NYACC
1574 else if (TYPE (x) == SPECIAL || TYPE (x) == TSTRING || TYPE (x) == SYMBOL)
1576 // else if (TYPE (x) == SPECIAL || TYPE (x) == STRING || TYPE (x) == SYMBOL)
1578 eputs (string_to_cstring (x));
1579 else if (TYPE (x) == NUMBER)
1580 eputs (itoa (VALUE (x)));
1582 eputs ("display: undefined\n");
1583 return cell_unspecified;
1587 main (int argc, char *argv[])
1589 puts ("Hello mini-mes!\n");
1591 //g_debug = getenv ("MES_DEBUG");
1593 //if (getenv ("MES_ARENA")) ARENA_SIZE = atoi (getenv ("MES_ARENA"));
1594 if (argc > 1 && !strcmp (argv[1], "--help")) return eputs ("Usage: mes [--dump|--load] < FILE");
1596 if (argc > 1 && !strcmp (argv[1], "--version")) {eputs ("Mes ");return eputs (VERSION);};
1598 if (argc > 1 && !strcmp (argv[1], "--version")) {eputs ("Mes ");return eputs ("0.4");};
1603 r0 = mes_environment ();
1605 puts ("FIXME: mes_environment ()\n");
1609 SCM program = simple_bload_env (r0);
1611 SCM program = (argc > 1 && !strcmp (argv[1], "--load"))
1612 ? bload_env (r0) : load_env (r0);
1613 if (argc > 1 && !strcmp (argv[1], "--dump")) return dump ();
1616 push_cc (r2, cell_unspecified, r0, cell_unspecified);
1617 //r3 = cell_vm_begin;
1630 eputs ("\nstats: [");
1631 eputs (itoa (g_free));
1644 "mov %%ebp,%%eax\n\t"
1648 "mov %%ebp,%%eax\n\t"
1650 "movzbl (%%eax),%%eax\n\t"
1656 : //no inputs "" (&main)