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))
27 #define FIXED_PRIMITIVES 0
36 #define NYACC_CAR nyacc_car
37 #define NYACC_CDR nyacc_cdr
40 int ARENA_SIZE = 1200000;
48 SCM g_continuations = 0;
60 enum type_t {TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TREF, TSPECIAL, TSTRING, TSYMBOL, TVALUES, TVECTOR, TBROKEN_HEART};
68 typedef int (*f_t) (void);
70 int (*function) (void);
75 struct scm *g_cells = arena;
78 //struct scm *g_news = 0;
80 struct scm scm_nil = {TSPECIAL, "()",0};
81 struct scm scm_f = {TSPECIAL, "#f",0};
82 struct scm scm_t = {TSPECIAL, "#t",0};
83 struct scm scm_dot = {TSPECIAL, ".",0};
84 struct scm scm_arrow = {TSPECIAL, "=>",0};
85 struct scm scm_undefined = {TSPECIAL, "*undefined*",0};
86 struct scm scm_unspecified = {TSPECIAL, "*unspecified*",0};
87 struct scm scm_closure = {TSPECIAL, "*closure*",0};
88 struct scm scm_circular = {TSPECIAL, "*circular*",0};
89 struct scm scm_begin = {TSPECIAL, "*begin*",0};
91 struct scm scm_symbol_dot = {TSYMBOL, "*dot*",0};
92 struct scm scm_symbol_lambda = {TSYMBOL, "lambda",0};
93 struct scm scm_symbol_begin = {TSYMBOL, "begin",0};
94 struct scm scm_symbol_if = {TSYMBOL, "if",0};
95 struct scm scm_symbol_quote = {TSYMBOL, "quote",0};
96 struct scm scm_symbol_set_x = {TSYMBOL, "set!",0};
98 struct scm scm_symbol_sc_expand = {TSYMBOL, "sc-expand",0};
99 struct scm scm_symbol_macro_expand = {TSYMBOL, "macro-expand",0};
100 struct scm scm_symbol_sc_expander_alist = {TSYMBOL, "*sc-expander-alist*",0};
102 struct scm scm_symbol_call_with_values = {TSYMBOL, "call-with-values",0};
103 struct scm scm_call_with_current_continuation = {TSPECIAL, "*call/cc*",0};
104 struct scm scm_symbol_call_with_current_continuation = {TSYMBOL, "call-with-current-continuation",0};
105 struct scm scm_symbol_current_module = {TSYMBOL, "current-module",0};
106 struct scm scm_symbol_primitive_load = {TSYMBOL, "primitive-load",0};
107 struct scm scm_symbol_read_input_file = {TSYMBOL, "read-input-file",0};
108 struct scm scm_symbol_write = {TSYMBOL, "write",0};
109 struct scm scm_symbol_display = {TSYMBOL, "display",0};
111 struct scm scm_symbol_throw = {TSYMBOL, "throw",0};
112 struct scm scm_symbol_not_a_pair = {TSYMBOL, "not-a-pair",0};
113 struct scm scm_symbol_system_error = {TSYMBOL, "system-error",0};
114 struct scm scm_symbol_wrong_number_of_args = {TSYMBOL, "wrong-number-of-args",0};
115 struct scm scm_symbol_wrong_type_arg = {TSYMBOL, "wrong-type-arg",0};
116 struct scm scm_symbol_unbound_variable = {TSYMBOL, "unbound-variable",0};
118 struct scm scm_symbol_argv = {TSYMBOL, "%argv",0};
119 struct scm scm_symbol_mes_prefix = {TSYMBOL, "%prefix",0};
120 struct scm scm_symbol_mes_version = {TSYMBOL, "%version",0};
122 struct scm scm_symbol_car = {TSYMBOL, "car",0};
123 struct scm scm_symbol_cdr = {TSYMBOL, "cdr",0};
124 struct scm scm_symbol_null_p = {TSYMBOL, "null?",0};
125 struct scm scm_symbol_eq_p = {TSYMBOL, "eq?",0};
126 struct scm scm_symbol_cons = {TSYMBOL, "cons",0};
128 struct scm scm_vm_evlis = {TSPECIAL, "*vm-evlis*",0};
129 struct scm scm_vm_evlis2 = {TSPECIAL, "*vm-evlis2*",0};
130 struct scm scm_vm_evlis3 = {TSPECIAL, "*vm-evlis3*",0};
131 struct scm scm_vm_apply = {TSPECIAL, "core:apply",0};
132 struct scm scm_vm_apply2 = {TSPECIAL, "*vm-apply2*",0};
133 struct scm scm_vm_eval = {TSPECIAL, "core:eval",0};
136 struct scm scm_vm_eval_car = {TSPECIAL, "*vm-eval-car*",0};
137 struct scm scm_vm_eval_cdr = {TSPECIAL, "*vm-eval-cdr*",0};
138 struct scm scm_vm_eval_cons = {TSPECIAL, "*vm-eval-cons*",0};
139 struct scm scm_vm_eval_null_p = {TSPECIAL, "*vm-eval-null-p*",0};
141 struct scm scm_vm_eval_set_x = {TSPECIAL, "*vm-eval-set!*",0};
142 struct scm scm_vm_eval_macro = {TSPECIAL, "*vm-eval-macro*",0};
143 struct scm scm_vm_eval2 = {TSPECIAL, "*vm-eval2*",0};
144 struct scm scm_vm_macro_expand = {TSPECIAL, "core:macro-expand",0};
145 struct scm scm_vm_begin = {TSPECIAL, "*vm-begin*",0};
146 struct scm scm_vm_begin_read_input_file = {TSPECIAL, "*vm-begin-read-input-file*",0};
147 struct scm scm_vm_begin2 = {TSPECIAL, "*vm-begin2*",0};
148 struct scm scm_vm_if = {TSPECIAL, "*vm-if*",0};
149 struct scm scm_vm_if_expr = {TSPECIAL, "*vm-if-expr*",0};
150 struct scm scm_vm_call_with_values2 = {TSPECIAL, "*vm-call-with-values2*",0};
151 struct scm scm_vm_call_with_current_continuation2 = {TSPECIAL, "*vm-call-with-current-continuation2*",0};
152 struct scm scm_vm_return = {TSPECIAL, "*vm-return*",0};
154 struct scm scm_test = {TSYMBOL, "test",0};
156 #include "mini-mes.symbols.h"
162 struct function g_functions[200];
167 #include "mini-mes.h"
168 // #include "posix.h"
169 // #include "reader.h"
172 #define TYPE(x) (g_cells[x].type)
174 #define CAR(x) g_cells[x].car
175 #define LENGTH(x) g_cells[x].car
176 #define STRING(x) g_cells[x].car
178 #define CDR(x) g_cells[x].cdr
179 #define CLOSURE(x) g_cells[x].cdr
180 #define CONTINUATION(x) g_cells[x].cdr
182 //#define FUNCTION(x) g_functions[g_cells[x].function]
185 #define FUNCTION(x) g_functions[g_cells[x].cdr]
186 #define MACRO(x) g_cells[x].car
187 #define VALUE(x) g_cells[x].cdr
188 #define VECTOR(x) g_cells[x].cdr
190 #define MAKE_CHAR(n) make_cell (tmp_num_ (TCHAR), 0, tmp_num2_ (n))
191 #define MAKE_CONTINUATION(n) make_cell (tmp_num_ (TCONTINUATION), n, g_stack)
192 #define MAKE_NUMBER(n) make_cell (tmp_num_ (TNUMBER), 0, tmp_num2_ (n))
193 //#define MAKE_REF(n) make_cell (tmp_num_ (REF), n, 0)
196 #define CAAR(x) CAR (CAR (x))
197 #define CDAR(x) CDR (CAR (x))
198 #define CADAR(x) CAR (CDR (CAR (x)))
199 #define CADDR(x) CAR (CDR (CDR (x)))
200 // #define CDDDR(x) CDR (CDR (CDR (x)))
201 #define CDADAR(x) CAR (CDR (CAR (CDR (x))))
202 #define CADR(x) CAR (CDR (x))
204 #define MAKE_STRING(x) make_cell (tmp_num_ (TSTRING), x, 0)
210 assert (g_free + n < ARENA_SIZE);
220 make_cell (SCM type, SCM car, SCM cdr)
224 assert (TYPE (type) == TNUMBER);
226 TYPE (x) = VALUE (type);
227 if (VALUE (type) == TCHAR || VALUE (type) == TNUMBER) {
228 if (car) CAR (x) = CAR (car);
229 if (cdr) CDR(x) = CDR(cdr);
231 else if (VALUE (type) == TFUNCTION) {
232 if (car) CAR (x) = car;
233 if (cdr) CDR(x) = CDR(cdr);
252 VALUE (tmp_num2) = x;
259 VALUE (tmp_num) = TPAIR;
260 return make_cell (tmp_num, x, y);
270 if (TYPE (x) != TPAIR) error (cell_symbol_not_a_pair, cons (x, cell_symbol_car));
282 if (TYPE (x) != TPAIR) error (cell_symbol_not_a_pair, cons (x, cell_symbol_cdr));
290 return x == cell_nil ? cell_t : cell_f;
297 || ((TYPE (x) == TKEYWORD && TYPE (y) == TKEYWORD
298 && STRING (x) == STRING (y)))
299 || (TYPE (x) == TCHAR && TYPE (y) == TCHAR
300 && VALUE (x) == VALUE (y))
301 || (TYPE (x) == TNUMBER && TYPE (y) == TNUMBER
302 && VALUE (x) == VALUE (y)))
309 return MAKE_NUMBER (TYPE (x));
315 return (TYPE (x) != TCONTINUATION
316 && (TYPE (CAR (x)) == TPAIR // FIXME: this is weird
317 || TYPE (CAR (x)) == TREF
318 || TYPE (CAR (x)) == TSPECIAL
319 || TYPE (CAR (x)) == TSYMBOL
320 || TYPE (CAR (x)) == TSTRING)) ? CAR (x) : MAKE_NUMBER (CAR (x));
326 return (TYPE (CDR (x)) == TPAIR
327 || TYPE (CDR (x)) == TREF
328 || TYPE (CAR (x)) == TSPECIAL
329 || TYPE (CDR (x)) == TSYMBOL
330 || TYPE (CDR (x)) == TSTRING) ? CDR (x) : MAKE_NUMBER (CDR (x));
334 assert_defined (SCM x, SCM e) ///((internal))
336 if (e != cell_undefined) return e;
337 // error (cell_symbol_unbound_variable, x);
338 puts ("unbound variable");
344 gc_push_frame () ///((internal))
346 SCM frame = cons (r1, cons (r2, cons (r3, cons (r0, cell_nil))));
347 g_stack = cons (frame, g_stack);
352 append2 (SCM x, SCM y)
354 if (x == cell_nil) return y;
356 assert (TYPE (x) == TPAIR);
358 return cons (car (x), append2 (cdr (x), y));
362 pairlis (SCM x, SCM y, SCM a)
366 if (TYPE (x) != TPAIR)
367 return cons (cons (x, y), a);
368 return cons (cons (car (x), car (y)),
369 pairlis (cdr (x), cdr (y), a));
377 if ((FUNCTION (fn).arity > 0 || FUNCTION (fn).arity == -1)
378 && x != cell_nil && TYPE (CAR (x)) == TVALUES)
379 x = cons (CADAR (x), CDR (x));
380 if ((FUNCTION (fn).arity > 1 || FUNCTION (fn).arity == -1)
381 && x != cell_nil && TYPE (CDR (x)) == TPAIR && TYPE (CADR (x)) == TVALUES)
382 x = cons (CAR (x), cons (CDADAR (x), CDR (x)));
383 switch (FUNCTION (fn).arity)
385 case 0: {return (FUNCTION (fn).function) ();}
386 case 1: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (car (x));}
387 case 2: {return ((SCM(*)(SCM,SCM))(FUNCTION (fn).function)) (car (x), cadr (x));}
388 case 3: {return ((SCM(*)(SCM,SCM,SCM))(FUNCTION (fn).function)) (car (x), cadr (x), car (cddr (x)));}
389 case -1: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);}
390 default: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);}
393 return cell_unspecified;
400 //while (a != cell_nil && eq_p (x, CAAR (a)) == cell_f) a = CDR (a);
401 while (a != cell_nil && x != CAAR (a)) a = CDR (a);
402 return a != cell_nil ? car (a) : cell_f;
406 assq_ref_env (SCM x, SCM a)
409 if (x == cell_f) return cell_undefined;
414 set_car_x (SCM x, SCM e)
417 assert (TYPE (x) == TPAIR);
420 return cell_unspecified;
424 set_cdr_x (SCM x, SCM e)
426 //if (TYPE (x) != TPAIR) error (cell_symbol_not_a_pair, cons (x, cell_set_cdr_x));
428 return cell_unspecified;
432 set_env_x (SCM x, SCM e, SCM a)
434 SCM p = assert_defined (x, assq (x, a));
435 //if (TYPE (p) != TPAIR) error (cell_symbol_not_a_pair, cons (p, x));
436 return set_cdr_x (p, e);
440 call_lambda (SCM e, SCM x, SCM aa, SCM a) ///((internal))
442 SCM cl = cons (cons (cell_closure, x), x);
443 cl = cons (cons (cell_closure, x), x);
446 return cell_unspecified;
450 make_closure (SCM args, SCM body, SCM a)
452 return make_cell (tmp_num_ (TCLOSURE), cell_f, cons (cons (cell_circular, a), cons (args, body)));
456 lookup_macro (SCM x, SCM a)
458 if (TYPE (x) != TSYMBOL) return cell_f;
459 SCM m = assq_ref_env (x, a);
460 if (TYPE (m) == TMACRO) return MACRO (m);
465 push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal))
474 return cell_unspecified;
477 SCM caar (SCM x) {return car (car (x));}
478 SCM cadr (SCM x) {return car (cdr (x));}
479 SCM cdar (SCM x) {return cdr (car (x));}
480 SCM cddr (SCM x) {return cdr (cdr (x));}
482 SCM gc_pop_frame (); //((internal))
488 // if (g_free + GC_SAFETY > ARENA_SIZE)
489 // gc_pop_frame (gc (gc_push_frame ()));
493 case cell_vm_evlis: goto evlis;
494 case cell_vm_evlis2: goto evlis2;
495 case cell_vm_evlis3: goto evlis3;
496 case cell_vm_apply: goto apply;
497 case cell_vm_apply2: goto apply2;
498 case cell_vm_eval: goto eval;
500 case cell_vm_eval_car: goto eval_car;
501 case cell_vm_eval_cdr: goto eval_cdr;
502 case cell_vm_eval_cons: goto eval_cons;
503 case cell_vm_eval_null_p: goto eval_null_p;
505 case cell_vm_eval_set_x: goto eval_set_x;
506 case cell_vm_eval_macro: goto eval_macro;
507 case cell_vm_eval2: goto eval2;
508 case cell_vm_macro_expand: goto macro_expand;
509 case cell_vm_begin: goto begin;
510 ///case cell_vm_begin_read_input_file: goto begin_read_input_file;
511 case cell_vm_begin2: goto begin2;
512 case cell_vm_if: goto vm_if;
513 case cell_vm_if_expr: goto if_expr;
514 case cell_vm_call_with_current_continuation2: goto call_with_current_continuation2;
515 case cell_vm_call_with_values2: goto call_with_values2;
516 case cell_vm_return: goto vm_return;
517 case cell_unspecified: return r1;
524 if (r1 == cell_nil) goto vm_return;
525 if (TYPE (r1) != TPAIR) goto eval;
526 push_cc (car (r1), r1, r0, cell_vm_evlis2);
529 push_cc (cdr (r2), r1, r0, cell_vm_evlis3);
536 switch (TYPE (car (r1)))
539 //check_formals (car (r1), MAKE_NUMBER (FUNCTION (car (r1)).arity), cdr (r1));
540 r1 = call (car (r1), cdr (r1)); /// FIXME: move into eval_apply
545 SCM cl = CLOSURE (car (r1));
546 SCM formals = cadr (cl);
547 SCM body = cddr (cl);
550 //check_formals (car (r1), formals, cdr (r1));
551 SCM p = pairlis (formals, cdr (r1), aa);
552 call_lambda (body, p, aa, r0);
558 g_stack = CONTINUATION (CAR (r1));
569 push_cc (cons (CADR (r1), CADDR (r1)), r1, r0, cell_vm_return);
574 push_cc (CADR (r1), r1, CADDR (r1), cell_vm_return);
577 case cell_call_with_current_continuation:
580 goto call_with_current_continuation;
582 //default: check_apply (cell_f, car (r1));
587 if (car (r1) == cell_symbol_call_with_values)
590 goto call_with_values;
592 if (car (r1) == cell_symbol_current_module)
603 case cell_symbol_lambda:
605 SCM formals = cadr (car (r1));
606 SCM body = cddr (car (r1));
607 SCM p = pairlis (formals, cdr (r1), r0);
608 //check_formals (r1, formals, cdr (r1));
609 call_lambda (body, p, p, r0);
615 push_cc (car (r1), r1, r0, cell_vm_apply2);
618 //check_apply (r1, car (r2));
619 r1 = cons (r1, cdr (r2));
630 case cell_symbol_car:
632 push_cc (CADR (r1), r1, r0, cell_vm_eval_car); goto eval;
634 x = r1; gc_pop_frame (); r1 = car (x); goto eval_apply;
636 case cell_symbol_cdr:
638 push_cc (CADR (r1), r1, r0, cell_vm_eval_cdr); goto eval;
640 x = r1; gc_pop_frame (); r1 = cdr (x); goto eval_apply;
642 case cell_symbol_cons: {
643 push_cc (CDR (r1), r1, r0, cell_vm_eval_cons); goto evlis;
647 r1 = cons (CAR (x), CADR (x));
650 case cell_symbol_null_p:
652 push_cc (CADR (r1), r1, r0, cell_vm_eval_null_p);
655 x = r1; gc_pop_frame (); r1 = null_p (x); goto eval_apply;
657 #endif // FIXED_PRIMITIVES
658 case cell_symbol_quote:
660 x = r1; gc_pop_frame (); r1 = cadr (x); goto eval_apply;
662 case cell_symbol_begin: goto begin;
663 case cell_symbol_lambda:
665 r1 = make_closure (cadr (r1), cddr (r1), assq (cell_closure, r0));
668 case cell_symbol_if: {r1=cdr (r1); goto vm_if;}
669 case cell_symbol_set_x:
671 push_cc (car (cddr (r1)), r1, r0, cell_vm_eval_set_x);
675 r1 = set_env_x (cadr (x), r1, r0);
678 case cell_vm_macro_expand:
680 push_cc (cadr (r1), r1, r0, cell_vm_return);
684 push_cc (r1, r1, r0, cell_vm_eval_macro);
690 if (TYPE (r1) == TPAIR)
692 set_cdr_x (r2, cdr (r1));
693 set_car_x (r2, car (r1));
697 push_cc (CDR (r1), r1, r0, cell_vm_eval2); goto evlis;
699 r1 = cons (car (r2), r1);
706 r1 = assert_defined (r1, assq_ref_env (r1, r0));
709 default: {goto vm_return;}
715 if (TYPE (r1) == TPAIR
716 && (macro = lookup_macro (car (r1), r0)) != cell_f)
718 r1 = cons (macro, CDR (r1));
721 else if (TYPE (r1) == TPAIR
722 && TYPE (CAR (r1)) == TSYMBOL
723 && ((expanders = assq_ref_env (cell_symbol_sc_expander_alist, r0)) != cell_undefined)
724 && ((macro = assq (CAR (r1), expanders)) != cell_f))
726 SCM sc_expand = assq_ref_env (cell_symbol_macro_expand, r0);
727 if (sc_expand != cell_undefined && sc_expand != cell_f)
729 r1 = cons (sc_expand, cons (r1, cell_nil));
735 x = cell_unspecified;
736 while (r1 != cell_nil) {
737 if (TYPE (r1) == TPAIR && TYPE (CAR (r1)) == TPAIR)
739 if (caar (r1) == cell_symbol_begin)
740 r1 = append2 (cdar (r1), cdr (r1));
741 else if (caar (r1) == cell_symbol_primitive_load)
743 push_cc (cons (cell_symbol_read_input_file, cell_nil), r1, r0, cell_vm_begin_read_input_file);
745 begin_read_input_file:
746 r1 = append2 (r1, cdr (r2));
749 if (CDR (r1) == cell_nil)
754 push_cc (CAR (r1), r1, r0, cell_vm_begin2);
764 push_cc (car (r1), r1, r0, cell_vm_if_expr);
774 if (cddr (r1) != cell_nil)
776 r1 = car (cddr (r1));
779 r1 = cell_unspecified;
782 call_with_current_continuation:
786 x = MAKE_CONTINUATION (g_continuations++);
788 x = MAKE_CONTINUATION (g_continuations);
792 push_cc (cons (car (r1), cons (x, cell_nil)), x, r0, cell_vm_call_with_current_continuation2);
794 call_with_current_continuation2:
795 CONTINUATION (r2) = g_stack;
799 push_cc (cons (car (r1), cell_nil), r1, r0, cell_vm_call_with_values2);
802 if (TYPE (r1) == TVALUES)
804 r1 = cons (cadr (r2), r1);
815 gc_peek_frame () ///((internal))
817 SCM frame = car (g_stack);
820 r3 = car (cddr (frame));
821 r0 = cadr (cddr (frame));
826 gc_pop_frame () ///((internal))
828 SCM frame = gc_peek_frame (g_stack);
829 g_stack = cdr (g_stack);
834 mes_g_stack (SCM a) ///((internal))
840 g_stack = cons (cell_nil, cell_nil);
844 //
\f Environment setup
846 make_tmps (struct scm* cells)
849 cells[tmp].type = TCHAR;
851 cells[tmp_num].type = TNUMBER;
853 cells[tmp_num2].type = TNUMBER;
860 VALUE (tmp_num) = TSYMBOL;
861 SCM x = make_cell (tmp_num, s, 0);
862 g_symbols = cons (x, g_symbols);
867 list_of_char_equal_p (SCM a, SCM b)
869 while (a != cell_nil && b != cell_nil && VALUE (car (a)) == VALUE (car (b))) {
871 assert (TYPE (car (a)) == TCHAR);
872 assert (TYPE (car (b)) == TCHAR);
877 return (a == cell_nil && b == cell_nil) ? cell_t : cell_f;
881 lookup_symbol_ (SCM s)
886 if (list_of_char_equal_p (STRING (car (x)), s) == cell_t) break;
898 return make_symbol_ (s);
900 SCM x = lookup_symbol_ (s);
901 return x ? x : make_symbol_ (s);
906 cstring_to_list (char const* s)
913 p = cons (MAKE_CHAR (s[i]), p);
920 acons (SCM key, SCM value, SCM alist)
922 return cons (cons (key, value), alist);
926 //
\f MINI_MES: temp-lib
929 write_byte (SCM x) ///((arity . n))
934 if (TYPE (p) == TPAIR && TYPE (car (p)) == TNUMBER) fd = VALUE (car (p));
935 //FILE *f = fd == 1 ? stdout : stderr;
937 assert (TYPE (c) == TNUMBER || TYPE (c) == TCHAR);
939 // fputc (VALUE (c), f);
941 write (1, (char*)&cc, fd);
948 // eputs ("<display>\n");
960 puts ("#<procedure ");
961 ///puts (FUNCTION (x).name ? FUNCTION (x).name : "?");
963 if (FUNCTION (x).name != 0)
964 p = FUNCTION (x).name;
967 puts (itoa (CDR (x)));
973 //puts ("<number>\n");
974 puts (itoa (VALUE (x)));
980 //if (cont != cell_f) puts "(");
982 if (x && x != cell_nil) display_ (CAR (x));
983 if (CDR (x) && CDR (x) != cell_nil)
985 if (TYPE (CDR (x)) != TPAIR)
989 //if (cont != cell_f) puts (")");
997 case 1: {puts ("()"); break;}
998 case 2: {puts ("#f"); break;}
999 case 3: {puts ("#t"); break;}
1012 while (t != cell_nil)
1014 putchar (VALUE (CAR (t)));
1021 //puts ("<default>\n");
1023 puts (itoa (TYPE (x)));
1038 gc_init_cells () ///((internal))
1041 // g_cells = (scm *)malloc (2*ARENA_SIZE*sizeof(scm));
1043 // #if __NYACC__ || FIXME_NYACC
1044 // TYPE (0) = TVECTOR;
1046 // // TYPE (0) = VECTOR;
1048 // LENGTH (0) = 1000;
1058 mes_symbols () ///((internal))
1063 #include "mini-mes.symbols.i"
1065 g_symbol_max = g_free;
1066 make_tmps (g_cells);
1069 for (int i=1; i<g_symbol_max; i++)
1070 g_symbols = cons (i, g_symbols);
1074 #include "mini-mes.symbol-names.i"
1076 // a = acons (cell_symbol_mes_version, MAKE_STRING (cstring_to_list (VERSION)), a);
1077 // a = acons (cell_symbol_mes_prefix, MAKE_STRING (cstring_to_list (PREFIX)), a);
1079 a = acons (cell_symbol_dot, cell_dot, a);
1080 a = acons (cell_symbol_begin, cell_begin, a);
1081 a = acons (cell_closure, a, a);
1083 // a = acons (cell_symbol_call_with_current_continuation, cell_call_with_current_continuation, a);
1084 // a = acons (cell_symbol_sc_expand, cell_f, a);
1090 mes_environment () ///((internal))
1094 a = mes_g_stack (a);
1099 mes_builtins (SCM a) ///((internal))
1101 #include "mini-mes.i"
1104 // #include "math.i"
1105 // #include "posix.i"
1106 // #include "reader.i"
1108 // #include "lib.environment.i"
1109 // #include "math.environment.i"
1110 #include "mini-mes.environment.i"
1111 // #include "posix.environment.i"
1112 // #include "reader.environment.i"
1118 bload_env (SCM a) ///((internal))
1120 char *mo = "module/mes/read-0-32.mo";
1121 g_stdin = open (mo, 0);
1122 if (g_stdin < 0) {eputs ("no such file: ");eputs (mo);eputs ("\n");return 1;}
1123 assert (getchar () == 'M');
1124 assert (getchar () == 'E');
1125 assert (getchar () == 'S');
1126 eputs ("*GOT MES*\n");
1127 g_stack = getchar () << 8;
1128 g_stack += getchar ();
1130 char *p = (char*)g_cells;
1137 g_free = (p-(char*)g_cells) / sizeof (struct scm);
1141 r0 = mes_builtins (r0);
1145 while (s && s != cell_nil) {
1151 puts ("functions: ");
1152 puts (itoa (g_function));
1154 for (int i = 0; i < g_function; i++)
1159 puts (g_functions[i].name);
1168 char string_to_cstring_buf[1024];
1170 string_to_cstring (SCM s)
1172 //static char buf[1024];
1174 char *p = string_to_cstring_buf;
1176 while (s != cell_nil)
1178 *p++ = VALUE (car (s));
1183 return string_to_cstring_buf;
1190 #if __NYACC__ || FIXME_NYACC
1191 if (TYPE (x) == TSTRING)
1193 // if (TYPE (x) == STRING)
1195 eputs (string_to_cstring (x));
1196 // else if ((write = assq_ref_env (cell_symbol_write, r0)) != cell_undefined)
1197 // apply (assq_ref_env (cell_symbol_display, r0), cons (x, cons (MAKE_NUMBER (2), cell_nil)), r0);
1198 #if __NYACC__ || FIXME_NYACC
1199 else if (TYPE (x) == TSPECIAL || TYPE (x) == TSTRING || TYPE (x) == TSYMBOL)
1201 // else if (TYPE (x) == SPECIAL || TYPE (x) == STRING || TYPE (x) == SYMBOL)
1203 eputs (string_to_cstring (x));
1204 else if (TYPE (x) == TNUMBER)
1205 eputs (itoa (VALUE (x)));
1207 eputs ("core:stderr: display undefined\n");
1208 return cell_unspecified;
1212 main (int argc, char *argv[])
1214 eputs ("Hello mini-mes!\n");
1216 //g_debug = getenv ("MES_DEBUG");
1218 //if (getenv ("MES_ARENA")) ARENA_SIZE = atoi (getenv ("MES_ARENA"));
1219 if (argc > 1 && !strcmp (argv[1], "--help")) return eputs ("Usage: mes [--dump|--load] < FILE");
1221 if (argc > 1 && !strcmp (argv[1], "--version")) {eputs ("Mes ");return eputs (VERSION);};
1223 if (argc > 1 && !strcmp (argv[1], "--version")) {eputs ("Mes ");return eputs ("0.4");};
1227 r0 = mes_environment ();
1230 SCM program = bload_env (r0);
1232 SCM program = (argc > 1 && !strcmp (argv[1], "--load"))
1233 ? bload_env (r0) : load_env (r0);
1234 if (argc > 1 && !strcmp (argv[1], "--dump")) return dump ();
1237 push_cc (r2, cell_unspecified, r0, cell_unspecified);
1238 eputs ("program: ");
1251 eputs ("\nstats: [");
1252 eputs (itoa (g_free));