1 /* -*-comment-start: "//";comment-end:""-*-
2 * Mes --- Maxwell Equations of Software
3 * Copyright © 2016 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/>.
35 #define FIXED_PRIMITIVES 1
37 int ARENA_SIZE = 100000;
38 int MAX_ARENA_SIZE = 20000000;
42 enum type_t {CHAR, FUNCTION, MACRO, NUMBER, PAIR, SPECIAL, STRING, SYMBOL, REF, VALUES, VECTOR, BROKEN_HEART};
43 typedef SCM (*function0_t) (void);
44 typedef SCM (*function1_t) (SCM);
45 typedef SCM (*function2_t) (SCM, SCM);
46 typedef SCM (*function3_t) (SCM, SCM, SCM);
47 typedef SCM (*functionn_t) (SCM);
48 typedef struct function_t {
50 function0_t function0;
51 function1_t function1;
52 function2_t function2;
53 function3_t function3;
54 functionn_t functionn;
59 typedef struct scm_t {
78 function functions[200];
81 #include "mes.symbols.h"
88 #include "quasiquote.h"
96 SCM r1 = 0; // param 1
97 SCM r2 = 0; // param 2
98 SCM r3 = 0; // param 3
106 scm scm_nil = {SPECIAL, "()"};
107 scm scm_f = {SPECIAL, "#f"};
108 scm scm_t = {SPECIAL, "#t"};
109 scm scm_dot = {SPECIAL, "."};
110 scm scm_undefined = {SPECIAL, "*undefined*"};
111 scm scm_unspecified = {SPECIAL, "*unspecified*"};
112 scm scm_closure = {SPECIAL, "*closure*"};
113 scm scm_circular = {SPECIAL, "*circular*"};
118 scm scm_begin = {SPECIAL, "*begin*"};
120 scm scm_symbol_lambda = {SYMBOL, "lambda"};
121 scm scm_symbol_begin = {SYMBOL, "begin"};
122 scm scm_symbol_if = {SYMBOL, "if"};
123 scm scm_symbol_define = {SYMBOL, "define"};
124 scm scm_symbol_define_macro = {SYMBOL, "define-macro"};
125 scm scm_symbol_set_x = {SYMBOL, "set!"};
127 scm scm_symbol_quote = {SYMBOL, "quote"};
128 scm scm_symbol_quasiquote = {SYMBOL, "quasiquote"};
129 scm scm_symbol_unquote = {SYMBOL, "unquote"};
130 scm scm_symbol_unquote_splicing = {SYMBOL, "unquote-splicing"};
132 scm scm_symbol_sc_expand = {SYMBOL, "sc-expand"};
133 scm scm_symbol_expand_macro = {SYMBOL, "expand-macro"};
134 scm scm_symbol_sc_expander_alist = {SYMBOL, "*sc-expander-alist*"};
135 scm scm_symbol_noexpand = {SYMBOL, "noexpand"};
136 scm scm_symbol_syntax = {SYMBOL, "syntax"};
137 scm scm_symbol_quasisyntax = {SYMBOL, "quasisyntax"};
138 scm scm_symbol_unsyntax = {SYMBOL, "unsyntax"};
139 scm scm_symbol_unsyntax_splicing = {SYMBOL, "unsyntax-splicing"};
141 scm scm_symbol_call_with_values = {SYMBOL, "call-with-values"};
142 scm scm_symbol_current_module = {SYMBOL, "current-module"};
143 scm scm_symbol_primitive_load = {SYMBOL, "primitive-load"};
145 scm scm_symbol_the_unquoters = {SYMBOL, "*the-unquoters*"};
147 scm scm_symbol_car = {SYMBOL, "car"};
148 scm scm_symbol_cdr = {SYMBOL, "cdr"};
149 scm scm_symbol_null_p = {SYMBOL, "null?"};
150 scm scm_symbol_eq_p = {SYMBOL, "eq?"};
151 scm scm_symbol_cons = {SYMBOL, "cons"};
153 scm char_eof = {CHAR, .name="*eof*", .value=-1};
154 scm char_nul = {CHAR, .name="nul", .value=0};
155 scm char_backspace = {CHAR, .name="backspace", .value=8};
156 scm char_tab = {CHAR, .name="tab", .value=9};
157 scm char_newline = {CHAR, .name="newline", .value=10};
158 scm char_vt = {CHAR, .name="vt", .value=11};
159 scm char_page = {CHAR, .name="page", .value=12};
160 scm char_return = {CHAR, .name="return", .value=13};
161 scm char_space = {CHAR, .name="space", .value=32};
163 scm g_free = {NUMBER, .value=0};
167 #define CAR(x) g_cells[x].car
168 #define CDR(x) g_cells[x].cdr
169 #define HITS(x) g_cells[x].hits
170 #define LENGTH(x) g_cells[x].length
171 #define NAME(x) g_cells[x].name
172 #define STRING(x) g_cells[x].string
173 #define TYPE(x) g_cells[x].type
174 #define MACRO(x) g_cells[x].macro
175 #define REF(x) g_cells[x].ref
176 #define VALUE(x) g_cells[x].value
177 #define VECTOR(x) g_cells[x].vector
178 #define FUNCTION(x) functions[g_cells[x].function]
179 #define NCAR(x) g_news[x].car
180 #define NTYPE(x) g_news[x].type
182 #define CAAR(x) CAR (CAR (x))
183 #define CDAR(x) CDR (CAR (x))
184 #define CAAR(x) CAR (CAR (x))
185 #define CADAR(x) CAR (CDR (CAR (x)))
186 #define CADDR(x) CAR (CDR (CDR (x)))
187 #define CDADAR(x) CAR (CDR (CAR (CDR (x))))
188 #define CADR(x) CAR (CDR (x))
190 SCM display_ (FILE* f, SCM x);
191 SCM vm_call (function0_t f, SCM p1, SCM p2, SCM a);
196 assert (g_free.value + n < ARENA_SIZE);
197 SCM x = g_free.value;
203 make_cell (SCM type, SCM car, SCM cdr)
206 assert (TYPE (type) == NUMBER);
207 TYPE (x) = VALUE (type);
208 if (VALUE (type) == CHAR || VALUE (type) == NUMBER) {
209 if (car) CAR (x) = CAR (car);
210 if (cdr) CDR (x) = CDR (cdr);
211 } else if (VALUE (type) == FUNCTION) {
212 if (car) CAR (x) = car;
213 if (cdr) CDR (x) = CDR (cdr);
224 g_cells[tmp_num].value = PAIR;
225 return make_cell (tmp_num, x, y);
231 assert (TYPE (x) == PAIR);
238 assert (TYPE (x) == PAIR);
246 || (TYPE (x) == CHAR && TYPE (y) == CHAR
247 && VALUE (x) == VALUE (y))
248 || (TYPE (x) == NUMBER && TYPE (y) == NUMBER
249 && VALUE (x) == VALUE (y)))
254 set_car_x (SCM x, SCM e)
256 assert (TYPE (x) == PAIR);
258 return cell_unspecified;
262 set_cdr_x (SCM x, SCM e)
264 assert (TYPE (x) == PAIR);
266 return cell_unspecified;
270 set_env_x (SCM x, SCM e, SCM a)
272 SCM p = assert_defined (x, assq (x, a));
273 return set_cdr_x (p, e);
279 return cons (cell_symbol_quote, x);
285 return cons (cell_symbol_quasiquote, x);
291 return cons (cell_symbol_quasisyntax, x);
295 pairlis (SCM x, SCM y, SCM a)
299 if (pair_p (x) == cell_f)
300 return cons (cons (x, y), a);
301 return cons (cons (car (x), car (y)),
302 pairlis (cdr (x), cdr (y), a));
308 while (a != cell_nil && eq_p (x, CAAR (a)) == cell_f)
310 if (TYPE (a) == BROKEN_HEART || TYPE (CAR (a)) == BROKEN_HEART)
311 fprintf (stderr, "oops, broken heart\n");
314 return a != cell_nil ? car (a) : cell_f;
318 assq_ref_cache (SCM x, SCM a)
321 if (x == cell_f) return cell_undefined;
326 assert_defined (SCM x, SCM e)
328 if (e == cell_undefined)
330 fprintf (stderr, "eval: unbound variable:");
331 display_ (stderr, x);
332 fprintf (stderr, "\n");
333 assert (!"unbound variable");
341 if (r1 == cell_nil) return cell_nil;
342 if (TYPE (r1) != PAIR) return eval_env (r1, r0);
343 r2 = eval_env (car (r1), r0);
344 r1 = evlis_env (cdr (r1), r0);
345 return cons (r2, r1);
351 return vm_call (vm_begin_env, r1, cell_undefined, r0);
355 call_lambda (SCM e, SCM x, SCM aa, SCM a) ///((internal))
357 SCM cl = cons (cons (cell_closure, x), x);
362 return vm_call_lambda ();
368 if (TYPE (r1) != PAIR)
370 if (TYPE (r1) == FUNCTION) return call (r1, r2);
371 if (r1 == cell_symbol_call_with_values)
372 return call_with_values_env (car (r2), cadr (r2), r0);
373 if (r1 == cell_symbol_current_module) return r0;
375 else if (car (r1) == cell_symbol_lambda) {
376 SCM args = cadr (r1);
377 SCM body = cddr (r1);
378 SCM p = pairlis (args, r2, r0);
379 return call_lambda (body, p, p, r0);
381 else if (car (r1) == cell_closure) {
382 SCM args = caddr (r1);
383 SCM body = cdddr (r1);
386 SCM p = pairlis (args, r2, aa);
387 return call_lambda (body, p, aa, r0);
390 else if (car (r1) == cell_symbol_label)
391 return apply_env (caddr (r1), r2, cons (cons (cadr (r1), caddr (r1)), r0));
393 SCM e = eval_env (r1, r0);
394 char const* type = 0;
395 if (e == cell_f || e == cell_t) type = "bool";
396 if (TYPE (e) == CHAR) type = "char";
397 if (TYPE (e) == NUMBER) type = "number";
398 if (TYPE (e) == STRING) type = "string";
399 if (e == cell_unspecified) type = "*unspecified*";
400 if (e == cell_undefined) type = "*undefined*";
403 fprintf (stderr, "cannot apply: %s: ", type);
404 display_ (stderr, e);
405 fprintf (stderr, " [");
406 display_ (stderr, r1);
407 fprintf (stderr, "]\n");
408 assert (!"cannot apply");
410 return apply_env (e, r2, r0);
421 if (car (r1) == cell_symbol_car)
422 return car (eval_env (CADR (r1), r0));
423 if (car (r1) == cell_symbol_cdr)
424 return cdr (eval_env (CADR (r1), r0));
425 if (car (r1) == cell_symbol_cons) {
426 SCM m = evlis_env (CDR (r1), r0);
427 return cons (CAR (m), CADR (m));
429 if (car (r1) == cell_symbol_null_p)
430 return null_p (eval_env (CADR (r1), r0));
431 #endif // FIXED_PRIMITIVES
432 if (car (r1) == cell_symbol_quote)
435 if (car (r1) == cell_symbol_syntax)
438 if (car (r1) == cell_symbol_begin)
439 return begin_env (r1, r0);
440 if (car (r1) == cell_symbol_lambda)
441 return make_closure (cadr (r1), cddr (r1), assq (cell_closure, r0));
442 if (car (r1) == cell_closure)
444 if (car (r1) == cell_symbol_if)
445 return if_env (cdr (r1), r0);
447 if (car (r1) == cell_symbol_define)
448 return define_env (r1, r0);
449 if (car (r1) == cell_symbol_define_macro)
450 return define_env (r1, r0);
451 if (car (r1) == cell_symbol_primitive_load)
452 return begin_env (read_input_file_env (r0), r0);
454 if (car (r1) == cell_symbol_define) {
455 fprintf (stderr, "C DEFINE: ");
457 TYPE (cadr (r1)) == SYMBOL
459 : STRING (caadr (r1)));
460 fprintf (stderr, "\n");
462 assert (car (r1) != cell_symbol_define);
463 assert (car (r1) != cell_symbol_define_macro);
466 if (car (r1) == cell_symbol_set_x)
468 SCM x = eval_env (caddr (r1), r0);
469 return set_env_x (cadr (r1), x, r0);
472 assert (car (r1) != cell_symbol_set_x);
475 if (car (r1) == cell_symbol_unquote)
476 return eval_env (cadr (r1), r0);
477 if (car (r1) == cell_symbol_quasiquote)
478 return eval_quasiquote (cadr (r1), add_unquoters (r0));
481 if (car (r1) == cell_symbol_unsyntax)
482 return eval_env (cadr (r1), r0);
483 if (car (r1) == cell_symbol_quasisyntax)
484 return eval_quasisyntax (cadr (r1), add_unsyntaxers (r0));
486 SCM x = expand_macro_env (r1, r0);
488 return eval_env (x, r0);
489 SCM m = evlis_env (CDR (r1), r0);
490 return apply_env (car (r1), m, r0);
492 case SYMBOL: return assert_defined (r1, assq_ref_cache (r1, r0));
498 vm_expand_macro_env ()
500 if (TYPE (CAR (r1)) == STRING && string_to_symbol (CAR (r1)) == cell_symbol_noexpand)
505 if (TYPE (r1) == PAIR
506 && (macro = lookup_macro (car (r1), r0)) != cell_f)
507 return apply_env (macro, CDR (r1), r0);
508 else if (TYPE (r1) == PAIR
509 && TYPE (CAR (r1)) == SYMBOL
510 && ((expanders = assq_ref_cache (cell_symbol_sc_expander_alist, r0)) != cell_undefined)
511 && ((macro = assq (CAR (r1), expanders)) != cell_f))
513 SCM sc_expand = assq_ref_cache (cell_symbol_expand_macro, r0);
514 if (sc_expand != cell_undefined && sc_expand != cell_f)
515 r1 = apply_env (sc_expand, cons (r1, cell_nil), r0);
523 SCM r = cell_unspecified;
524 while (r1 != cell_nil) {
525 if (TYPE (r1) == PAIR && TYPE (CAR (r1)) == PAIR)
527 if (caar (r1) == cell_symbol_begin)
528 r1 = append2 (cdar (r1), cdr (r1));
529 else if (caar (r1) == cell_symbol_primitive_load)
530 r1 = append2 (read_input_file_env (r0), cdr (r1));
532 r = eval_env (car (r1), r0);
541 SCM x = eval_env (car (r1), r0);
543 return eval_env (cadr (r1), r0);
544 if (cddr (r1) != cell_nil)
545 return eval_env (caddr (r1), r0);
546 return cell_unspecified;
550 vm_call_with_values_env ()
552 SCM v = apply_env (r1, cell_nil, r0);
553 if (TYPE (v) == VALUES)
555 return apply_env (r2, v, r0);
561 if ((FUNCTION (fn).arity > 0 || FUNCTION (fn).arity == -1)
562 && x != cell_nil && TYPE (CAR (x)) == VALUES)
563 x = cons (CADAR (x), CDR (x));
564 if ((FUNCTION (fn).arity > 1 || FUNCTION (fn).arity == -1)
565 && x != cell_nil && TYPE (CDR (x)) == PAIR && TYPE (CADR (x)) == VALUES)
566 x = cons (CAR (x), cons (CDADAR (x), CDR (x)));
567 switch (FUNCTION (fn).arity)
569 case 0: return FUNCTION (fn).function0 ();
570 case 1: return FUNCTION (fn).function1 (car (x));
571 case 2: return FUNCTION (fn).function2 (car (x), cadr (x));
572 case 3: return FUNCTION (fn).function3 (car (x), cadr (x), caddr (x));
573 case -1: return FUNCTION (fn).functionn (x);
575 return cell_unspecified;
581 SCM frame = car (stack);
592 SCM frame = cons (r1, cons (r2, cons (r3, cons (r0, cell_nil))));
593 stack = cons (frame, stack);
601 vm_call (function0_t f, SCM p1, SCM p2, SCM a)
603 SCM frame = cons (r1, cons (r2, cons (r3, cons (r0, cell_nil))));
604 stack = cons (frame, stack);
608 if (g_free.value + GC_SAFETY > ARENA_SIZE)
612 frame = gc_frame (stack);
618 evlis_env (SCM m, SCM a)
620 return vm_call (vm_evlis_env, m, cell_undefined, a);
624 apply_env (SCM fn, SCM x, SCM a)
626 return vm_call (vm_apply_env, fn, x, a);
630 eval_env (SCM e, SCM a)
632 return vm_call (vm_eval_env, e, cell_undefined, a);
636 expand_macro_env (SCM e, SCM a)
638 return vm_call (vm_expand_macro_env, e, cell_undefined, a);
642 begin_env (SCM e, SCM a)
644 return vm_call (vm_begin_env, e, cell_undefined, a);
648 if_env (SCM e, SCM a)
650 return vm_call (vm_if_env, e, cell_undefined, a);
654 call_with_values_env (SCM producer, SCM consumer, SCM a)
656 return vm_call (vm_call_with_values_env, producer, consumer, a);
660 append2 (SCM x, SCM y)
662 if (x == cell_nil) return y;
663 assert (TYPE (x) == PAIR);
664 return cons (car (x), append2 (cdr (x), y));
668 append (SCM x) ///((arity . n))
670 if (x == cell_nil) return cell_nil;
671 return append2 (car (x), append (cdr (x)));
677 g_cells[tmp_num].value = CHAR;
678 g_cells[tmp_num2].value = x;
679 return make_cell (tmp_num, tmp_num2, tmp_num2);
683 make_function (SCM name, SCM id, SCM arity)
685 g_cells[tmp_num3].value = FUNCTION;
686 function *f = (function*)malloc (sizeof (function));
687 f->arity = VALUE (arity);
688 g_cells[tmp_num4].value = (long)f;
689 return make_cell (tmp_num3, name, tmp_num4);
693 make_macro (SCM name, SCM x)
695 g_cells[tmp_num].value = MACRO;
696 return make_cell (tmp_num, STRING (name), x);
702 g_cells[tmp_num].value = NUMBER;
703 g_cells[tmp_num2].value = x;
704 return make_cell (tmp_num, tmp_num2, tmp_num2);
710 g_cells[tmp_num].value = REF;
711 return make_cell (tmp_num, x, x);
717 g_cells[tmp_num].value = STRING;
718 return make_cell (tmp_num, x, 0);
722 cstring_to_list (char const* s)
727 p = cons (make_char (s[i]), p);
734 return x == cell_nil ? cell_t : cell_f;
738 internal_make_symbol (SCM s)
740 g_cells[tmp_num].value = SYMBOL;
741 SCM x = make_cell (tmp_num, s, 0);
742 g_symbols = cons (x, g_symbols);
749 SCM x = internal_lookup_symbol (s);
750 return x ? x : internal_make_symbol (s);
757 g_cells[tmp_num].value = VECTOR;
759 SCM x = make_cell (tmp_num, k, v);
760 for (int i=0; i<k; i++) g_cells[v+i] = g_cells[vector_entry (cell_unspecified)];
765 values (SCM x) ///((arity . n))
773 vector_length (SCM x)
775 assert (TYPE (x) == VECTOR);
776 return make_number (LENGTH (x));
780 vector_ref (SCM x, SCM i)
782 assert (TYPE (x) == VECTOR);
783 assert (VALUE (i) < LENGTH (x));
784 SCM e = VECTOR (x) + VALUE (i);
785 if (TYPE (e) == REF) e = g_cells[e].ref;
786 if (TYPE (e) == CHAR) e = make_char (VALUE (e));
787 if (TYPE (e) == NUMBER) e = make_number (VALUE (e));
792 vector_entry (SCM x) {
793 if (TYPE (x) == PAIR || TYPE (x) == SPECIAL || TYPE (x) == STRING || TYPE (x) == SYMBOL || TYPE (x) == VECTOR) x = make_ref (x);
798 vector_set_x (SCM x, SCM i, SCM e)
800 assert (TYPE (x) == VECTOR);
801 assert (VALUE (i) < LENGTH (x));
802 g_cells[VECTOR (x)+g_cells[i].value] = g_cells[vector_entry (e)];
803 return cell_unspecified;
807 list_to_vector (SCM x)
809 VALUE (tmp_num) = VALUE (length (x));
810 SCM v = make_vector (tmp_num);
812 while (x != cell_nil)
814 g_cells[p++] = g_cells[vector_entry (car (x))];
824 return getc (g_stdin);
830 return ungetc (c, g_stdin);
844 return make_number (peekchar ());
850 return make_number (getchar ());
856 return ungetchar (VALUE (i));
860 write_char (SCM x) ///((arity . n))
865 if (TYPE (p) == PAIR && TYPE (car (p)) == NUMBER) fd = VALUE (car (p));
866 FILE *f = fd == 1 ? stdout : stderr;
867 assert (TYPE (c) == NUMBER || TYPE (c) == CHAR);
868 fputc (VALUE (c), f);
873 symbol_to_list (SCM x)
875 assert (TYPE (x) == SYMBOL);
880 char_to_integer (SCM x)
882 assert (TYPE (x) == CHAR);
883 return make_number (VALUE (x));
887 integer_to_char (SCM x)
889 assert (TYPE (x) == NUMBER);
890 return make_char (VALUE (x));
894 make_tmps (scm* cells)
896 tmp = g_free.value++;
897 cells[tmp].type = CHAR;
898 tmp_num = g_free.value++;
899 cells[tmp_num].type = NUMBER;
900 tmp_num2 = g_free.value++;
901 cells[tmp_num2].type = NUMBER;
902 tmp_num3 = g_free.value++;
903 cells[tmp_num3].type = NUMBER;
904 tmp_num4 = g_free.value++;
905 cells[tmp_num4].type = NUMBER;
910 bool g_debug = false;
916 void *p = realloc (g_cells-1, 2*ARENA_SIZE*sizeof(scm));
919 if (g_debug) fprintf (stderr, "cannot up arena: %s: arena=%d\n", strerror (errno), 2*ARENA_SIZE);
920 return cell_unspecified;
930 if (g_debug) fprintf (stderr, "***gc[%d]...", g_free.value);
932 if (g_cells < g_news && ARENA_SIZE < MAX_ARENA_SIZE) gc_up_arena ();
933 for (int i=g_free.value; i<g_symbol_max; i++)
936 g_symbols = gc_copy (g_symbols);
937 SCM new = gc_copy (stack);
938 if (g_debug) fprintf (stderr, "new=%d\n", new, stack);
946 while (scan < g_free.value)
948 if (NTYPE (scan) == MACRO
949 || NTYPE (scan) == PAIR
950 || NTYPE (scan) == REF
952 || NTYPE (scan) == SPECIAL
953 || NTYPE (scan) == STRING
954 || NTYPE (scan) == SYMBOL)
956 SCM car = gc_copy (g_news[scan].car);
957 gc_relocate_car (scan, car);
959 if ((NTYPE (scan) == MACRO
960 || NTYPE (scan) == PAIR
961 || NTYPE (scan) == VALUES)
962 && g_news[scan].cdr) // allow for 0 terminated list of symbols
964 SCM cdr = gc_copy (g_news[scan].cdr);
965 gc_relocate_cdr (scan, cdr);
975 if (TYPE (old) == BROKEN_HEART) return g_cells[old].car;
976 SCM new = g_free.value++;
977 g_news[new] = g_cells[old];
978 if (NTYPE (new) == VECTOR)
980 g_news[new].vector = g_free.value;
981 for (int i=0; i<LENGTH (old); i++)
982 g_news[g_free.value++] = g_cells[VECTOR (old)+i];
984 g_cells[old].type = BROKEN_HEART;
985 g_cells[old].car = new;
990 gc_relocate_car (SCM new, SCM car)
992 g_news[new].car = car;
993 return cell_unspecified;
997 gc_relocate_cdr (SCM new, SCM cdr)
999 g_news[new].cdr = cdr;
1000 return cell_unspecified;
1006 scm *cells = g_cells;
1009 if (g_debug) fprintf (stderr, " => jam[%d]\n", g_free.value);
1016 fprintf (stderr, "cells: ");
1018 display_ (stderr, -1);
1019 fprintf (stderr, "\n");
1022 fprintf (stderr, "news: ");
1024 display_ (stderr, -1);
1025 fprintf (stderr, "\n");
1028 return cell_unspecified;
1031 //
\f Environment setup
1033 acons (SCM key, SCM value, SCM alist)
1035 return cons (cons (key, value), alist);
1039 add_environment (SCM a, char const *name, SCM x)
1041 return acons (make_symbol (cstring_to_list (name)), x, a);
1047 g_cells = (scm *)malloc (2*ARENA_SIZE*sizeof(scm));
1048 g_cells[0].type = VECTOR;
1049 g_cells[0].length = 1000;
1050 g_cells[0].vector = 0;
1052 g_cells[0].type = CHAR;
1053 g_cells[0].value = 'c';
1054 g_free.value = 1; // 0 is tricky
1060 g_news = g_cells-1 + ARENA_SIZE;
1061 g_news[0].type = VECTOR;
1062 g_news[0].length = 1000;
1063 g_news[0].vector = 0;
1065 g_news[0].type = CHAR;
1066 g_news[0].value = 'n';
1070 mes_symbols () ///((internal))
1075 #include "mes.symbols.i"
1077 g_symbol_max = g_free.value;
1078 make_tmps (g_cells);
1081 for (int i=1; i<g_symbol_max; i++)
1082 g_symbols = cons (i, g_symbols);
1087 a = acons (cell_symbol_label, cell_t, a);
1089 a = acons (cell_symbol_begin, cell_begin, a);
1090 a = add_environment (a, "sc-expand", cell_f);
1091 a = acons (cell_closure, a, a);
1093 internal_lookup_symbol (cell_nil);
1099 mes_builtins (SCM a)
1104 #include "display.i"
1108 #include "quasiquote.i"
1113 #include "define.environment.i"
1114 #include "display.environment.i"
1115 #include "lib.environment.i"
1116 #include "math.environment.i"
1117 #include "mes.environment.i"
1118 #include "posix.environment.i"
1119 //#include "quasiquote.environment.i"
1120 #include "reader.environment.i"
1121 #include "string.environment.i"
1122 #include "type.environment.i"
1124 SCM cell_unquote = assq_ref_cache (cell_symbol_unquote, a);
1125 SCM cell_unquote_splicing = assq_ref_cache (cell_symbol_unquote_splicing, a);
1126 SCM the_unquoters = cons (cons (cell_symbol_unquote, cell_unquote),
1127 cons (cons (cell_symbol_unquote_splicing, cell_unquote_splicing),
1129 a = acons (cell_symbol_the_unquoters, the_unquoters, a);
1131 a = add_environment (a, "*foo-bar-baz*", cell_nil); // FIXME: some off-by one?
1137 mes_stack (SCM a) ///((internal))
1143 stack = cons (cell_nil, cell_nil);
1148 mes_environment () ///((internal))
1150 SCM a = mes_symbols ();
1151 return mes_stack (a);
1155 make_lambda (SCM args, SCM body)
1157 return cons (cell_symbol_lambda, cons (args, body));
1161 make_closure (SCM args, SCM body, SCM a)
1163 return cons (cell_closure, cons (cons (cell_circular, a), cons (args, body)));
1167 lookup_macro (SCM x, SCM a)
1169 if (TYPE (x) != SYMBOL) return cell_f;
1170 SCM m = assq_ref_cache (x, a);
1171 if (macro_p (m) == cell_t) return MACRO (m);
1176 read_input_file_env_ (SCM e, SCM a)
1178 if (e == cell_nil) return e;
1179 return cons (e, read_input_file_env_ (read_env (a), a));
1183 read_input_file_env (SCM a)
1185 return read_input_file_env_ (read_env (r0), r0);
1188 bool g_dump_p = false;
1193 r3 = read_input_file_env (r0);
1194 if (g_dump_p && !g_function)
1197 SCM frame = cons (r1, cons (r2, cons (r3, cons (r0, cell_nil))));
1198 stack = cons (frame, stack);
1201 char *p = (char*)g_cells;
1202 fputc ('M', stdout);
1203 fputc ('E', stdout);
1204 fputc ('S', stdout);
1205 fputc (stack >> 8, stdout);
1206 fputc (stack % 256, stdout);
1207 for (int i=0; i<g_free.value * sizeof(scm); i++)
1208 fputc (*p++, stdout);
1212 r0 = mes_builtins (r0);
1213 return begin_env (r3, r0);
1219 g_stdin = fopen ("module/mes/read-0.mo", "r");
1220 g_stdin = g_stdin ? g_stdin : fopen (PREFIX "module/mes/read-0.mo", "r");
1221 char *p = (char*)g_cells;
1222 assert (getchar () == 'M');
1223 assert (getchar () == 'E');
1224 assert (getchar () == 'S');
1225 stack = getchar () << 8;
1226 stack += getchar ();
1233 g_free.value = (p-(char*)g_cells) / sizeof (scm);
1238 r0 = mes_builtins (r0);
1240 return begin_env (r3, r0);
1245 #include "display.c"
1249 #include "quasiquote.c"
1254 main (int argc, char *argv[])
1256 g_debug = getenv ("MES_DEBUG");
1257 if (getenv ("MES_ARENA"))
1258 ARENA_SIZE = atoi (getenv ("MES_ARENA"));
1259 if (argc > 1 && !strcmp (argv[1], "--dump")) g_dump_p = true;
1260 if (argc > 1 && !strcmp (argv[1], "--help")) return puts ("Usage: mes < FILE\n");
1261 if (argc > 1 && !strcmp (argv[1], "--version")) return puts ("Mes 0.2\n");
1263 SCM a = mes_environment ();
1264 if (argc > 1 && !strcmp (argv[1], "--load"))
1265 display_ (stderr, bload_env (a));
1267 display_ (stderr, load_env (a));
1270 if (g_debug) fprintf (stderr, "\nstats: [%d]\n", g_free.value);