1 /* -*-comment-start: "//";comment-end:""-*-
2 * GNU Mes --- Maxwell Equations of Software
3 * Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
5 * This file is part of GNU Mes.
7 * GNU 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 * GNU 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 GNU Mes. If not, see <http://www.gnu.org/licenses/>.
29 long ARENA_SIZE = 100000000; // 2.3GiB
31 long ARENA_SIZE = 300000; // 32b: 3MiB, 64b: 6 MiB
33 long MAX_ARENA_SIZE = 100000000;
34 long STACK_SIZE = 20000;
36 long JAM_SIZE = 20000;
37 long GC_SAFETY = 2000;
45 SCM g_continuations = 0;
48 SCM *g_stack_array = 0;
50 #define FRAME_PROCEDURE 4
68 CONSTANT TCONTINUATION 2
83 CONSTANT TBROKEN_HEART 17
84 #else // !__M2_PLANET__
85 enum type_t {TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TPORT, TREF, TSPECIAL, TSTRING, TSTRUCT, TSYMBOL, TVALUES, TVARIABLE, TVECTOR, TBROKEN_HEART};
86 #endif // !__M2_PLANET__
88 typedef SCM (*function0_t) (void);
89 typedef SCM (*function1_t) (SCM);
90 typedef SCM (*function2_t) (SCM, SCM);
91 typedef SCM (*function3_t) (SCM, SCM, SCM);
92 typedef SCM (*functionn_t) (SCM);
102 #else // !__M2_PLANET__
103 SCM (*function) (SCM);
104 #endif // !__M2_PLANET__
111 function0_t function0;
112 function1_t function1;
113 function2_t function2;
114 function3_t function3;
115 functionn_t functionn;
146 struct scm *g_cells = foobar;
147 struct scm *g_news = foobar;
149 struct scm *g_cells = 0;
150 struct scm *g_news = 0;
153 struct scm scm_nil = {TSPECIAL, "()",0};
154 struct scm scm_f = {TSPECIAL, "#f",0};
155 struct scm scm_t = {TSPECIAL, "#t",0};
156 struct scm scm_dot = {TSPECIAL, ".",0};
157 struct scm scm_arrow = {TSPECIAL, "=>",0};
158 struct scm scm_undefined = {TSPECIAL, "*undefined*",0};
159 struct scm scm_unspecified = {TSPECIAL, "*unspecified*",0};
160 struct scm scm_closure = {TSPECIAL, "*closure*",0};
161 struct scm scm_circular = {TSPECIAL, "*circular*",0};
162 struct scm scm_begin = {TSPECIAL, "*begin*",0};
164 struct scm scm_symbol_dot = {TSYMBOL, "*dot*",0};
165 struct scm scm_symbol_lambda = {TSYMBOL, "lambda",0};
166 struct scm scm_symbol_begin = {TSYMBOL, "begin",0};
167 struct scm scm_symbol_if = {TSYMBOL, "if",0};
168 struct scm scm_symbol_quote = {TSYMBOL, "quote",0};
169 struct scm scm_symbol_define = {TSYMBOL, "define",0};
170 struct scm scm_symbol_define_macro = {TSYMBOL, "define-macro",0};
172 struct scm scm_symbol_quasiquote = {TSYMBOL, "quasiquote", 0};
173 struct scm scm_symbol_unquote = {TSYMBOL, "unquote", 0};
174 struct scm scm_symbol_unquote_splicing = {TSYMBOL, "unquote-splicing", 0};
175 struct scm scm_symbol_syntax = {TSYMBOL, "syntax",0};
176 struct scm scm_symbol_quasisyntax = {TSYMBOL, "quasisyntax", 0};
177 struct scm scm_symbol_unsyntax = {TSYMBOL, "unsyntax", 0};
178 struct scm scm_symbol_unsyntax_splicing = {TSYMBOL, "unsyntax-splicing", 0};
180 struct scm scm_symbol_set_x = {TSYMBOL, "set!",0};
182 struct scm scm_symbol_sc_expand = {TSYMBOL, "sc-expand",0};
183 struct scm scm_symbol_macro_expand = {TSYMBOL, "macro-expand",0};
184 struct scm scm_symbol_portable_macro_expand = {TSYMBOL, "portable-macro-expand",0};
185 struct scm scm_symbol_sc_expander_alist = {TSYMBOL, "*sc-expander-alist*",0};
187 struct scm scm_symbol_call_with_values = {TSYMBOL, "call-with-values",0};
188 struct scm scm_call_with_current_continuation = {TSPECIAL, "*call/cc*",0};
189 struct scm scm_symbol_call_with_current_continuation = {TSYMBOL, "call-with-current-continuation",0};
190 struct scm scm_symbol_boot_module = {TSYMBOL, "boot-module",0};
191 struct scm scm_symbol_current_module = {TSYMBOL, "current-module",0};
192 struct scm scm_symbol_primitive_load = {TSYMBOL, "primitive-load",0};
193 struct scm scm_symbol_read_input_file = {TSYMBOL, "read-input-file",0};
194 struct scm scm_symbol_write = {TSYMBOL, "write",0};
195 struct scm scm_symbol_display = {TSYMBOL, "display",0};
197 struct scm scm_symbol_throw = {TSYMBOL, "throw",0};
198 struct scm scm_symbol_not_a_number = {TSYMBOL, "not-a-number",0};
199 struct scm scm_symbol_not_a_pair = {TSYMBOL, "not-a-pair",0};
200 struct scm scm_symbol_system_error = {TSYMBOL, "system-error",0};
201 struct scm scm_symbol_wrong_number_of_args = {TSYMBOL, "wrong-number-of-args",0};
202 struct scm scm_symbol_wrong_type_arg = {TSYMBOL, "wrong-type-arg",0};
203 struct scm scm_symbol_unbound_variable = {TSYMBOL, "unbound-variable",0};
205 struct scm scm_symbol_hashq_table = {TSYMBOL, "<hashq-table>",0};
206 struct scm scm_symbol_record_type = {TSYMBOL, "<record-type>",0};
207 struct scm scm_symbol_frame = {TSYMBOL, "<frame>",0};
208 struct scm scm_symbol_module = {TSYMBOL, "<module>",0};
209 struct scm scm_symbol_stack = {TSYMBOL, "<stack>",0};
210 struct scm scm_symbol_buckets = {TSYMBOL, "buckets",0};
211 struct scm scm_symbol_procedure = {TSYMBOL, "procedure",0};
212 struct scm scm_symbol_size = {TSYMBOL, "size",0};
214 struct scm scm_symbol_argv = {TSYMBOL, "%argv",0};
215 struct scm scm_symbol_mes_prefix = {TSYMBOL, "%prefix",0};
216 struct scm scm_symbol_mes_version = {TSYMBOL, "%version",0};
218 struct scm scm_symbol_car = {TSYMBOL, "car",0};
219 struct scm scm_symbol_cdr = {TSYMBOL, "cdr",0};
220 struct scm scm_symbol_pmatch_car = {TSYMBOL, "pmatch-car",0};
221 struct scm scm_symbol_pmatch_cdr = {TSYMBOL, "pmatch-cdr",0};
223 struct scm scm_vm_evlis = {TSPECIAL, "*vm-evlis*",0};
224 struct scm scm_vm_evlis2 = {TSPECIAL, "*vm-evlis2*",0};
225 struct scm scm_vm_evlis3 = {TSPECIAL, "*vm-evlis3*",0};
226 struct scm scm_vm_apply = {TSPECIAL, "core:apply",0};
227 struct scm scm_vm_apply2 = {TSPECIAL, "*vm-apply2*",0};
228 struct scm scm_vm_eval = {TSPECIAL, "core:eval-expanded",0};
230 struct scm scm_vm_eval_pmatch_car = {TSPECIAL, "*vm-eval-pmatch-car*",0};
231 struct scm scm_vm_eval_pmatch_cdr = {TSPECIAL, "*vm-eval-pmatch-cdr*",0};
232 struct scm scm_vm_eval_define = {TSPECIAL, "*vm-eval-define*",0};
234 struct scm scm_vm_eval_set_x = {TSPECIAL, "*vm-eval-set!*",0};
235 struct scm scm_vm_eval_macro_expand_eval = {TSPECIAL, "*vm:eval-macro-expand-eval*",0};
236 struct scm scm_vm_eval_macro_expand_expand = {TSPECIAL, "*vm:eval-macro-expand-expand*",0};
237 struct scm scm_vm_eval_check_func = {TSPECIAL, "*vm-eval-check-func*",0};
238 struct scm scm_vm_eval2 = {TSPECIAL, "*vm-eval2*",0};
239 struct scm scm_vm_macro_expand = {TSPECIAL, "core:macro-expand",0};
240 struct scm scm_vm_macro_expand_define = {TSPECIAL, "*vm:core:macro-expand-define*",0};
241 struct scm scm_vm_macro_expand_define_macro = {TSPECIAL, "*vm:core:macro-expand-define-macro*",0};
242 struct scm scm_vm_macro_expand_lambda = {TSPECIAL, "*vm:core:macro-expand-lambda*",0};
243 struct scm scm_vm_macro_expand_set_x = {TSPECIAL, "*vm:core:macro-expand-set!*",0};
244 struct scm scm_vm_begin_expand_primitive_load = {TSPECIAL, "*vm:core:begin-expand-primitive-load*",0};
245 struct scm scm_vm_begin_primitive_load = {TSPECIAL, "*vm:core:begin-primitive-load*",0};
246 struct scm scm_vm_macro_expand_car = {TSPECIAL, "*vm:core:macro-expand-car*",0};
247 struct scm scm_vm_macro_expand_cdr = {TSPECIAL, "*vm:macro-expand-cdr*",0};
248 struct scm scm_vm_begin_expand = {TSPECIAL, "core:eval",0};
249 struct scm scm_vm_begin_expand_eval = {TSPECIAL, "*vm:begin-expand-eval*",0};
250 struct scm scm_vm_begin_expand_macro = {TSPECIAL, "*vm:begin-expand-macro*",0};
251 struct scm scm_vm_begin = {TSPECIAL, "*vm-begin*",0};
252 struct scm scm_vm_begin_read_input_file = {TSPECIAL, "*vm-begin-read-input-file*",0};
253 struct scm scm_vm_begin_eval = {TSPECIAL, "*vm:begin-eval*",0};
254 struct scm scm_vm_if = {TSPECIAL, "*vm-if*",0};
255 struct scm scm_vm_if_expr = {TSPECIAL, "*vm-if-expr*",0};
256 struct scm scm_vm_call_with_values2 = {TSPECIAL, "*vm-call-with-values2*",0};
257 struct scm scm_vm_call_with_current_continuation2 = {TSPECIAL, "*vm-call-with-current-continuation2*",0};
258 struct scm scm_vm_return = {TSPECIAL, "*vm-return*",0};
260 struct scm scm_type_char = {TSYMBOL, "<cell:char>",0};
261 struct scm scm_type_closure = {TSYMBOL, "<cell:closure>",0};
262 struct scm scm_type_continuation = {TSYMBOL, "<cell:continuation>",0};
263 struct scm scm_type_function = {TSYMBOL, "<cell:function>",0};
264 struct scm scm_type_keyword = {TSYMBOL, "<cell:keyword>",0};
265 struct scm scm_type_macro = {TSYMBOL, "<cell:macro>",0};
266 struct scm scm_type_number = {TSYMBOL, "<cell:number>",0};
267 struct scm scm_type_pair = {TSYMBOL, "<cell:pair>",0};
268 struct scm scm_type_port = {TSYMBOL, "<cell:port>",0};
269 struct scm scm_type_ref = {TSYMBOL, "<cell:ref>",0};
270 struct scm scm_type_special = {TSYMBOL, "<cell:special>",0};
271 struct scm scm_type_string = {TSYMBOL, "<cell:string>",0};
272 struct scm scm_type_struct = {TSYMBOL, "<cell:struct>",0};
273 struct scm scm_type_symbol = {TSYMBOL, "<cell:symbol>",0};
274 struct scm scm_type_values = {TSYMBOL, "<cell:values>",0};
275 struct scm scm_type_variable = {TSYMBOL, "<cell:variable>",0};
276 struct scm scm_type_vector = {TSYMBOL, "<cell:vector>",0};
277 struct scm scm_type_broken_heart = {TSYMBOL, "<cell:broken-heart>",0};
279 struct scm scm_symbol_internal_time_units_per_second = {TSYMBOL, "internal-time-units-per-second",0};
280 struct scm scm_symbol_compiler = {TSYMBOL, "%compiler",0};
281 struct scm scm_symbol_arch = {TSYMBOL, "%arch",0};
283 struct scm scm_test = {TSYMBOL, "%%test",0};
286 #include "mes.mes.symbols.h"
288 #include "mes.symbols.h"
291 struct function g_functions[200];
294 #if !__GNUC__ || !_POSIX_SOURCE
296 #include "hash.mes.h"
298 #include "math.mes.h"
300 #include "module.mes.h"
301 #include "posix.mes.h"
302 #include "reader.mes.h"
303 #include "struct.mes.h"
304 #include "vector.mes.h"
318 #define TYPE(x) g_cells[x].type
319 #define CAR(x) g_cells[x].car
320 #define CDR(x) g_cells[x].cdr
322 #define NTYPE(x) g_news[x].type
323 #define NCAR(x) g_news[x].car
324 #define NCDR(x) g_news[x].cdr
327 #define LENGTH(x) g_cells[x].car
328 #define REF(x) g_cells[x].car
329 #define STRING(x) g_cells[x].car
330 #define VARIABLE(x) g_cells[x].car
332 #define CLOSURE(x) g_cells[x].cdr
333 #define CONTINUATION(x) g_cells[x].cdr
335 #define FUNCTION(x) g_functions[g_cells[x].cdr]
336 #define FUNCTION0(x) g_functions[g_cells[x].cdr].function
337 #define MACRO(x) g_cells[x].cdr
338 #define PORT(x) g_cells[x].cdr
339 #define STRUCT(x) g_cells[x].cdr
340 #define VALUE(x) g_cells[x].cdr
341 #define VECTOR(x) g_cells[x].cdr
343 #define NLENGTH(x) g_news[x].car
345 #define NVALUE(x) g_news[x].cdr
346 #define NVECTOR(x) g_news[x].cdr
349 #define CONTINUATION(x) g_cells[x].cdr
350 #define HITS(x) g_cells[x].hits
351 #define LENGTH(x) g_cells[x].length
352 #define NAME(x) g_cells[x].name
353 #define STRING(x) g_cells[x].string
354 #define VARIABLE(x) g_cells[x].variable
356 #define CLOSURE(x) g_cells[x].closure
357 #define MACRO(x) g_cells[x].macro
358 #define PORT(x) g_cells[x].port
359 #define REF(x) g_cells[x].ref
360 #define STRUCT(x) g_cells[x].vector
361 #define VALUE(x) g_cells[x].value
362 #define VECTOR(x) g_cells[x].vector
363 #define FUNCTION(x) g_functions[g_cells[x].function]
364 #define FUNCTION0(x) g_functions[g_cells[x].function].function0
366 #define NLENGTH(x) g_news[x].length
368 #define NVALUE(x) g_news[x].value
369 #define NVECTOR(x) g_news[x].vector
372 #define MAKE_CHAR(n) make_cell__ (TCHAR, 0, n)
373 #define MAKE_CONTINUATION(n) make_cell__ (TCONTINUATION, n, g_stack)
374 #define MAKE_NUMBER(n) make_cell__ (TNUMBER, 0, n)
375 #define MAKE_REF(n) make_cell__ (TREF, n, 0)
376 #define MAKE_STRING(x) make_cell__ (TSTRING, x, 0)
377 #define MAKE_KEYWORD(x) make_cell__ (TKEYWORD, x, 0)
378 #define MAKE_STRING_PORT(x) make_cell__ (TPORT, x, -length__ (g_ports) - 2)
379 #define MAKE_MACRO(name, x) make_cell__ (TMACRO, STRING (name), x)
381 #define CAAR(x) CAR (CAR (x))
382 #define CADR(x) CAR (CDR (x))
383 #define CDAR(x) CDR (CAR (x))
384 #define CDDR(x) CDR (CDR (x))
385 #define CADAR(x) CAR (CDR (CAR (x)))
386 #define CADDR(x) CAR (CDR (CDR (x)))
387 #define CDADAR(x) CAR (CDR (CAR (CDR (x))))
398 make_cell__ (long type, SCM car, SCM cdr)
408 make_cell_ (SCM type, SCM car, SCM cdr)
410 assert (TYPE (type) == TNUMBER);
411 long t = VALUE (type);
412 if (t == TCHAR || t == TNUMBER)
413 return make_cell__ (t, car ? CAR (car) : 0, cdr ? CDR (cdr) : 0);
414 return make_cell__ (t, car, cdr);
418 make_symbol_ (SCM string) ///((internal))
420 SCM x = make_cell__ (TSYMBOL, STRING (string), 0);
421 hash_set_x (g_symbols, string, x);
424 hash_table_printer (g_symbols);
430 list_of_char_equal_p (SCM a, SCM b) ///((internal))
432 assert (TYPE (CAR (a)) == TCHAR);
433 if (TYPE (CAR (b)) == TCHAR)
434 while (a != cell_nil && b != cell_nil && VALUE (CAR (a)) == VALUE (CAR (b)))
436 assert (TYPE (CAR (a)) == TCHAR);
437 assert (TYPE (CAR (b)) == TCHAR);
441 return (a == cell_nil && b == cell_nil) ? cell_t : cell_f;
445 assoc_string (SCM x, SCM a) ///((internal))
447 while (a != cell_nil && list_of_char_equal_p (STRING (x), STRING (CAAR (a))) == cell_f)
449 return a != cell_nil ? CAR (a) : cell_f;
453 list_to_symbol (SCM lst)
455 SCM key = MAKE_STRING (lst);
456 SCM x = hash_ref (g_symbols, key, cell_f);
458 x = make_symbol_ (key);
465 return MAKE_NUMBER (TYPE (x));
471 return (TYPE (x) != TCONTINUATION
472 && (TYPE (CAR (x)) == TPAIR // FIXME: this is weird
473 || TYPE (CAR (x)) == TREF
474 || TYPE (CAR (x)) == TSPECIAL
475 || TYPE (CAR (x)) == TSYMBOL
476 || TYPE (CAR (x)) == TSTRING)) ? CAR (x) : MAKE_NUMBER (CAR (x));
482 return (TYPE (x) != TCHAR
483 && TYPE (x) != TNUMBER
485 && (TYPE (CDR (x)) == TPAIR
486 || TYPE (CDR (x)) == TREF
487 || TYPE (CDR (x)) == TSPECIAL
488 || TYPE (CDR (x)) == TSYMBOL
489 || TYPE (CDR (x)) == TSTRING)) ? CDR (x) : MAKE_NUMBER (CDR (x));
495 assert (TYPE (x) == TFUNCTION);
496 return MAKE_NUMBER (FUNCTION (x).arity);
502 return make_cell__ (TPAIR, x, y);
509 if (TYPE (x) != TPAIR)
510 error (cell_symbol_not_a_pair, cons (x, cell_symbol_car));
519 if (TYPE (x) != TPAIR)
520 error (cell_symbol_not_a_pair, cons (x, cell_symbol_cdr));
526 list (SCM x) ///((arity . n))
534 return x == cell_nil ? cell_t : cell_f;
541 || ((TYPE (x) == TKEYWORD && TYPE (y) == TKEYWORD
542 && STRING (x) == STRING (y)))
543 || (TYPE (x) == TCHAR && TYPE (y) == TCHAR
544 && VALUE (x) == VALUE (y))
545 || (TYPE (x) == TNUMBER && TYPE (y) == TNUMBER
546 && VALUE (x) == VALUE (y)))
551 values (SCM x) ///((arity . n))
559 acons (SCM key, SCM value, SCM alist)
561 return cons (cons (key, value), alist);
565 length__ (SCM x) ///((internal))
568 while (x != cell_nil)
571 if (TYPE (x) != TPAIR)
581 return MAKE_NUMBER (length__ (x));
584 SCM apply (SCM, SCM, SCM);
587 error (SCM key, SCM x)
591 if ((throw = module_ref (r0, cell_symbol_throw)) != cell_undefined)
592 return apply (throw, cons (key, cons (x, cell_nil)), r0);
594 display_error_ (key);
603 string_to_list (char const* s, long i)
607 p = cons (MAKE_CHAR (s[i]), p);
612 cstring_to_list (char const* s)
614 return string_to_list (s, strlen (s));
618 cstring_to_symbol (char const *s)
620 return list_to_symbol (cstring_to_list (s));
625 assert_defined (SCM x, SCM e) ///((internal))
627 if (e == cell_undefined)
628 return error (cell_symbol_unbound_variable, x);
633 check_formals (SCM f, SCM formals, SCM args) ///((internal))
635 long flen = (TYPE (formals) == TNUMBER) ? VALUE (formals) : length__ (formals);
636 long alen = length__ (args);
637 if (alen != flen && alen != -1 && flen != -1)
639 char *s = "apply: wrong number of arguments; expected: ";
646 SCM e = MAKE_STRING (cstring_to_list (s));
647 return error (cell_symbol_wrong_number_of_args, cons (e, f));
649 return cell_unspecified;
653 check_apply (SCM f, SCM e) ///((internal))
656 if (f == cell_f || f == cell_t)
660 if (f == cell_unspecified)
661 type = "*unspecified*";
662 if (f == cell_undefined)
663 type = "*undefined*";
664 if (TYPE (f) == TCHAR)
666 if (TYPE (f) == TNUMBER)
668 if (TYPE (f) == TSTRING)
670 if (TYPE (f) == TSTRUCT)
672 if (TYPE (f) == TBROKEN_HEART)
677 char *s = "cannot apply: ";
683 SCM e = MAKE_STRING (cstring_to_list (s));
684 return error (cell_symbol_wrong_type_arg, cons (e, f));
686 return cell_unspecified;
690 gc_push_frame () ///((internal))
693 assert (!"STACK FULL");
694 g_stack_array[--g_stack] = cell_f;
695 g_stack_array[--g_stack] = r0;
696 g_stack_array[--g_stack] = r1;
697 g_stack_array[--g_stack] = r2;
698 g_stack_array[--g_stack] = r3;
703 gc_peek_frame () ///((internal))
705 r3 = g_stack_array[g_stack];
706 r2 = g_stack_array[g_stack+1];
707 r1 = g_stack_array[g_stack+2];
708 r0 = g_stack_array[g_stack+3];
709 return g_stack_array[g_stack+FRAME_PROCEDURE];
713 gc_pop_frame () ///((internal))
715 SCM x = gc_peek_frame ();
721 append2 (SCM x, SCM y)
725 if (TYPE (x) != TPAIR)
726 error (cell_symbol_not_a_pair, cons (x, cell_append2));
728 while (x != cell_nil)
730 r = cons (CAR (x), r);
733 return reverse_x_ (r, y);
737 append_reverse (SCM x, SCM y)
741 if (TYPE (x) != TPAIR)
742 error (cell_symbol_not_a_pair, cons (x, cell_append_reverse));
743 while (x != cell_nil)
745 y = cons (CAR (x), y);
752 reverse_x_ (SCM x, SCM t)
754 if (x != cell_nil && TYPE (x) != TPAIR)
755 error (cell_symbol_not_a_pair, cons (x, cell_reverse_x_));
757 while (x != cell_nil)
768 pairlis (SCM x, SCM y, SCM a)
772 if (TYPE (x) != TPAIR)
773 return cons (cons (x, y), a);
774 return cons (cons (car (x), car (y)),
775 pairlis (cdr (x), cdr (y), a));
782 struct function *f = FUNCTION (fn);
784 struct function *f = &FUNCTION (fn);
786 int arity = f->arity;
787 if ((arity > 0 || arity == -1)
788 && x != cell_nil && TYPE (CAR (x)) == TVALUES)
789 x = cons (CADAR (x), CDR (x));
790 if ((arity > 1 || arity == -1)
791 && x != cell_nil && TYPE (CDR (x)) == TPAIR && TYPE (CADR (x)) == TVALUES)
792 x = cons (CAR (x), cons (CDADAR (x), CDR (x)));
795 FUNCTION fp = f->function;
801 return fp (CAR (x), CADR (x));
803 return fp (CAR (x), CADR (x), CAR (CDDR (x)));
804 else if (arity == -1)
809 //function0_t fp = f->function;
810 SCM (*fp) (void) = f->function;
815 //function1_t fp = f->function;
816 SCM (*fp) (SCM) = f->function;
821 //function2_t fp = f->function;
822 SCM (*fp) (SCM, SCM) = f->function;
823 return fp (CAR (x), CADR (x));
827 //function3_t fp = f->function;
828 SCM (*fp) (SCM, SCM, SCM) = f->function;
829 return fp (CAR (x), CADR (x), CAR (CDDR (x)));
831 else if (arity == -1)
833 //functionn_t fp = f->function;
834 SCM (*fp) (SCM) = f->function;
839 return FUNCTION (fn).function0 ();
841 return FUNCTION (fn).function1 (CAR (x));
843 return FUNCTION (fn).function2 (CAR (x), CADR (x));
845 return FUNCTION (fn).function3 (CAR (x), CADR (x), CAR (CDDR (x)));
846 else if (arity == -1)
847 return FUNCTION (fn).functionn (x);
848 #endif //! (__M2_PLANET__ || !POSIX)
849 return cell_unspecified;
855 if (TYPE (a) != TPAIR)
860 while (a != cell_nil && x != CAAR (a))
866 while (a != cell_nil && v != VALUE (CAAR (a)))
869 else if (t == TKEYWORD)
872 while (a != cell_nil && v != STRING (CAAR (a)))
876 /* pointer equality, e.g. on strings. */
877 while (a != cell_nil && x != CAAR (a))
879 return a != cell_nil ? CAR (a) : cell_f;
885 if (TYPE (x) == TSTRING)
886 return assoc_string (x, a);
887 while (a != cell_nil && equal2_p (x, CAAR (a)) == cell_f)
889 return a != cell_nil ? CAR (a) : cell_f;
893 set_car_x (SCM x, SCM e)
895 if (TYPE (x) != TPAIR)
896 error (cell_symbol_not_a_pair, cons (x, cell_set_car_x));
898 return cell_unspecified;
902 set_cdr_x (SCM x, SCM e)
904 if (TYPE (x) != TPAIR)
905 error (cell_symbol_not_a_pair, cons (x, cell_set_cdr_x));
907 return cell_unspecified;
911 set_env_x (SCM x, SCM e, SCM a)
914 if (TYPE (x) == TVARIABLE)
917 p = assert_defined (x, module_variable (a, x));
918 if (TYPE (p) != TPAIR)
919 error (cell_symbol_not_a_pair, cons (p, x));
920 return set_cdr_x (p, e);
924 call_lambda (SCM e, SCM x, SCM aa, SCM a) ///((internal))
926 SCM cl = cons (cons (cell_closure, x), x);
929 return cell_unspecified;
933 make_closure_ (SCM args, SCM body, SCM a) ///((internal))
935 return make_cell__ (TCLOSURE, cell_f, cons (cons (cell_circular, a), cons (args, body)));
939 make_variable_ (SCM var) ///((internal))
941 return make_cell__ (TVARIABLE, var, 0);
945 macro_get_handle (SCM name)
947 if (TYPE (name) == TSYMBOL)
948 return hashq_get_handle (g_macros, name, cell_nil);
953 get_macro (SCM name) ///((internal))
955 SCM m = macro_get_handle (name);
957 return MACRO (CDR (m));
962 macro_set_x (SCM name, SCM value) ///((internal))
964 return hashq_set_x (g_macros, name, value);
968 push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal))
977 return cell_unspecified;
980 char const* string_to_cstring (SCM s);
983 add_formals (SCM formals, SCM x)
985 while (TYPE (x) == TPAIR)
987 formals = cons (CAR (x), formals);
990 if (TYPE (x) == TSYMBOL)
991 formals = cons (x, formals);
996 formal_p (SCM x, SCM formals) /// ((internal))
998 if (TYPE (formals) == TSYMBOL)
1004 while (TYPE (formals) == TPAIR && CAR (formals) != x)
1005 formals = CDR (formals);
1006 if (TYPE (formals) == TSYMBOL)
1007 return formals == x;
1008 return TYPE (formals) == TPAIR;
1012 expand_variable_ (SCM x, SCM formals, int top_p) ///((internal))
1014 while (TYPE (x) == TPAIR)
1016 if (TYPE (CAR (x)) == TPAIR)
1018 if (CAAR (x) == cell_symbol_lambda)
1020 SCM f = CAR (CDAR (x));
1021 formals = add_formals (formals, f);
1023 else if (CAAR (x) == cell_symbol_define
1024 || CAAR (x) == cell_symbol_define_macro)
1026 SCM f = CAR (CDAR (x));
1027 formals = add_formals (formals, f);
1029 if (CAAR (x) != cell_symbol_quote)
1030 expand_variable_ (CAR (x), formals, 0);
1034 if (CAR (x) == cell_symbol_lambda)
1037 formals = add_formals (formals, f);
1040 else if (CAR (x) == cell_symbol_define
1041 || CAR (x) == cell_symbol_define_macro)
1044 if (top_p && TYPE (f) == TPAIR)
1046 formals = add_formals (formals, f);
1049 else if (CAR (x) == cell_symbol_quote)
1050 return cell_unspecified;
1051 else if (TYPE (CAR (x)) == TSYMBOL
1052 && CAR (x) != cell_symbol_boot_module
1053 && CAR (x) != cell_symbol_current_module
1054 && CAR (x) != cell_symbol_primitive_load
1055 && !formal_p (CAR (x), formals))
1057 SCM v = module_variable (r0, CAR (x));
1059 CAR (x) = make_variable_ (v);
1065 return cell_unspecified;
1069 expand_variable (SCM x, SCM formals) ///((internal))
1071 return expand_variable_ (x, formals, 1);
1074 SCM struct_ref_ (SCM x, long i);
1075 SCM vector_ref_ (SCM x, long i);
1076 SCM make_vector__ (long k);
1077 SCM vector_set_x_ (SCM x, long i, SCM e);
1103 if (r3 == cell_vm_evlis) {eputs ("goto: evlis\n"); goto evlis;}
1104 else if (r3 == cell_vm_evlis2) {eputs ("goto: evlis2\n"); goto evlis2;}
1105 else if (r3 == cell_vm_evlis3) {eputs ("goto: evlis3\n"); goto evlis3;}
1106 else if (r3 == cell_vm_apply) {eputs ("goto: apply\n"); goto apply;}
1107 else if (r3 == cell_vm_apply2) {eputs ("goto: apply2\n"); goto apply2;}
1108 else if (r3 == cell_vm_eval) {eputs ("goto: eval\n"); goto eval;}
1109 else if (r3 == cell_vm_eval_pmatch_car) {eputs ("goto: eval_pmatch_car\n"); goto eval_pmatch_car;}
1110 else if (r3 == cell_vm_eval_pmatch_cdr) {eputs ("goto: eval_pmatch_cdr\n"); goto eval_pmatch_cdr;}
1111 else if (r3 == cell_vm_eval_define) {eputs ("goto: eval_define\n"); goto eval_define;}
1112 else if (r3 == cell_vm_eval_set_x) {eputs ("goto: eval_set_x\n"); goto eval_set_x;}
1113 else if (r3 == cell_vm_eval_macro_expand_eval) {eputs ("goto: eval_macro_expand_eval\n"); goto eval_macro_expand_eval;}
1114 else if (r3 == cell_vm_eval_macro_expand_expand) {eputs ("goto: eval_macro_expand_expand\n"); goto eval_macro_expand_expand;}
1115 else if (r3 == cell_vm_eval_check_func) {eputs ("goto: eval_check_func\n"); goto eval_check_func;}
1116 else if (r3 == cell_vm_eval2) {eputs ("goto: eval2\n"); goto eval2;}
1117 else if (r3 == cell_vm_macro_expand) {eputs ("goto: macro_expand\n"); goto macro_expand;}
1118 else if (r3 == cell_vm_macro_expand_define) {eputs ("goto: macro_expand_define\n"); goto macro_expand_define;}
1119 else if (r3 == cell_vm_macro_expand_define_macro) {eputs ("goto: macro_expand_define_macro\n"); goto macro_expand_define_macro;}
1120 else if (r3 == cell_vm_macro_expand_lambda) {eputs ("goto: macro_expand_lambda\n"); goto macro_expand_lambda;}
1121 else if (r3 == cell_vm_macro_expand_set_x) {eputs ("goto: macro_expand_set_x\n"); goto macro_expand_set_x;}
1122 else if (r3 == cell_vm_macro_expand_car) {eputs ("goto: macro_expand_car\n"); goto macro_expand_car;}
1123 else if (r3 == cell_vm_macro_expand_cdr) {eputs ("goto: macro_expand_cdr\n"); goto macro_expand_cdr;}
1124 else if (r3 == cell_vm_begin) {eputs ("goto: begin\n"); goto begin;}
1125 else if (r3 == cell_vm_begin_eval) {eputs ("goto: begin_eval\n"); goto begin_eval;}
1126 else if (r3 == cell_vm_begin_primitive_load) {eputs ("goto: begin_primitive_load\n"); goto begin_primitive_load;}
1127 else if (r3 == cell_vm_begin_expand) {eputs ("goto: begin_expand\n"); goto begin_expand;}
1128 else if (r3 == cell_vm_begin_expand_eval) {eputs ("goto: begin_expand_eval\n"); goto begin_expand_eval;}
1129 else if (r3 == cell_vm_begin_expand_macro) {eputs ("goto: begin_expand_macro\n"); goto begin_expand_macro;}
1130 else if (r3 == cell_vm_begin_expand_primitive_load) {eputs ("goto: begin_expand_primitive_load\n"); goto begin_expand_primitive_load;}
1131 else if (r3 == cell_vm_if) {eputs ("goto: vm_if\n"); goto vm_if;}
1132 else if (r3 == cell_vm_if_expr) {eputs ("goto: if_expr\n"); goto if_expr;}
1133 else if (r3 == cell_vm_call_with_current_continuation2) {eputs ("goto: call_with_current_continuation2\n"); goto call_with_current_continuation2;}
1134 else if (r3 == cell_vm_call_with_values2) {eputs ("goto: call_with_values2\n"); goto call_with_values2;}
1135 else if (r3 == cell_vm_return) {eputs ("goto: vm_return\n"); goto vm_return;}
1136 else if (r3 == cell_unspecified) return r1;
1138 error (cell_symbol_system_error,
1139 MAKE_STRING (cstring_to_list ("eval/apply unknown continuation")));
1144 if (TYPE (r1) != TPAIR)
1146 push_cc (CAR (r1), r1, r0, cell_vm_evlis2);
1149 push_cc (CDR (r2), r1, r0, cell_vm_evlis3);
1156 g_stack_array[g_stack+FRAME_PROCEDURE] = CAR (r1);
1157 t = TYPE (CAR (r1));
1160 check_formals (CAR (r1), MAKE_NUMBER (FUNCTION (CAR (r1)).arity), CDR (r1));
1161 r1 = call (CAR (r1), CDR (r1)); /// FIXME: move into eval_apply
1164 else if (t == TCLOSURE)
1166 cl = CLOSURE (CAR (r1));
1168 formals = CADR (cl);
1172 check_formals (CAR (r1), formals, CDR (r1));
1173 p = pairlis (formals, args, aa);
1174 call_lambda (body, p, aa, r0);
1177 else if (t == TCONTINUATION)
1179 v = CONTINUATION (CAR (r1));
1182 for (t=0; t < LENGTH (v); t++)
1183 g_stack_array[STACK_SIZE-LENGTH (v)+t] = vector_ref_ (v, t);
1184 g_stack = STACK_SIZE-LENGTH (v);
1191 else if (t == TSPECIAL)
1194 if (c == cell_vm_apply)
1196 push_cc (cons (CADR (r1), CADDR (r1)), r1, r0, cell_vm_return);
1199 else if (c == cell_vm_eval)
1201 push_cc (CADR (r1), r1, CADDR (r1), cell_vm_return);
1204 else if (c == cell_vm_begin_expand)
1206 push_cc (cons (CADR (r1), cell_nil), r1, CADDR (r1), cell_vm_return);
1209 else if (c == cell_call_with_current_continuation)
1212 goto call_with_current_continuation;
1215 check_apply (cell_f, CAR (r1));
1217 else if (t == TSYMBOL)
1219 if (CAR (r1) == cell_symbol_call_with_values)
1222 goto call_with_values;
1224 if (CAR (r1) == cell_symbol_current_module)
1229 if (CAR (r1) == cell_symbol_boot_module)
1235 else if (t == TPAIR)
1237 if (CAAR (r1) == cell_symbol_lambda)
1239 formals = CADR (CAR (r1));
1241 body = CDDR (CAR (r1));
1242 p = pairlis (formals, CDR (r1), r0);
1243 check_formals (r1, formals, args);
1244 call_lambda (body, p, p, r0);
1248 push_cc (CAR (r1), r1, r0, cell_vm_apply2);
1251 check_apply (r1, CAR (r2));
1252 r1 = cons (r1, CDR (r2));
1260 if (c == cell_symbol_pmatch_car)
1262 push_cc (CADR (r1), r1, r0, cell_vm_eval_pmatch_car);
1270 else if (c == cell_symbol_pmatch_cdr)
1272 push_cc (CADR (r1), r1, r0, cell_vm_eval_pmatch_cdr);
1280 else if (c == cell_symbol_quote)
1287 else if (c == cell_symbol_begin)
1289 else if (c == cell_symbol_lambda)
1291 r1 = make_closure_ (CADR (r1), CDDR (r1), r0);
1294 else if (c == cell_symbol_if)
1299 else if (c == cell_symbol_set_x)
1301 push_cc (CAR (CDDR (r1)), r1, r0, cell_vm_eval_set_x);
1304 r1 = set_env_x (CADR (r2), r1, r0);
1307 else if (c == cell_vm_macro_expand)
1309 push_cc (CADR (r1), r1, r0, cell_vm_eval_macro_expand_eval);
1311 eval_macro_expand_eval:
1312 push_cc (r1, r2, r0, cell_vm_eval_macro_expand_expand);
1314 eval_macro_expand_expand:
1319 if (TYPE (r1) == TPAIR
1320 && (CAR (r1) == cell_symbol_define
1321 || CAR (r1) == cell_symbol_define_macro))
1323 global_p = CAAR (r0) != cell_closure;
1324 macro_p = CAR (r1) == cell_symbol_define_macro;
1328 if (TYPE (CADR (r1)) == TPAIR)
1332 entry = assq (name, g_macros);
1333 if (entry == cell_f)
1334 macro_set_x (name, cell_f);
1338 entry = module_variable (r0, name);
1339 if (entry == cell_f)
1340 module_define_x (m0, name, cell_f);
1344 if (TYPE (CADR (r1)) != TPAIR)
1346 push_cc (CAR (CDDR (r1)), r2, cons (cons (CADR (r1), CADR (r1)), r0), cell_vm_eval_define);
1351 p = pairlis (CADR (r1), CADR (r1), r0);
1352 formals = CDR (CADR (r1));
1355 if (macro_p || global_p)
1356 expand_variable (body, formals);
1357 r1 = cons (cell_symbol_lambda, cons (formals, body));
1358 push_cc (r1, r2, p, cell_vm_eval_define);
1363 if (TYPE (CADR (r2)) == TPAIR)
1367 entry = macro_get_handle (name);
1368 r1 = MAKE_MACRO (name, r1);
1369 set_cdr_x (entry, r1);
1373 entry = module_variable (r0, name);
1374 set_cdr_x (entry, r1);
1378 entry = cons (name, r1);
1379 aa = cons (entry, cell_nil);
1380 set_cdr_x (aa, cdr (r0));
1382 cl = module_variable (r0, cell_closure);
1385 r1 = cell_unspecified;
1388 push_cc (CAR (r1), r1, r0, cell_vm_eval_check_func);
1392 push_cc (CDR (r2), r2, r0, cell_vm_eval2);
1395 r1 = cons (CAR (r2), r1);
1399 else if (t == TSYMBOL)
1401 if (r1 == cell_symbol_boot_module)
1403 if (r1 == cell_symbol_current_module)
1405 if (r1 == cell_symbol_begin) // FIXME
1410 r1 = assert_defined (r1, module_ref (r0, r1));
1413 else if (t == TVARIABLE)
1415 r1 = CDR (VARIABLE (r1));
1418 else if (t == TBROKEN_HEART)
1419 error (cell_symbol_system_error, r1);
1428 if (TYPE (r1) != TPAIR || CAR (r1) == cell_symbol_quote)
1431 if (CAR (r1) == cell_symbol_lambda)
1433 push_cc (CDDR (r1), r1, r0, cell_vm_macro_expand_lambda);
1435 macro_expand_lambda:
1441 if (TYPE (r1) == TPAIR
1442 && (macro = get_macro (CAR (r1))) != cell_f)
1444 r1 = cons (macro, CDR (r1));
1445 push_cc (r1, cell_nil, r0, cell_vm_macro_expand);
1449 if (CAR (r1) == cell_symbol_define
1450 || CAR (r1) == cell_symbol_define_macro)
1452 push_cc (CDDR (r1), r1, r0, cell_vm_macro_expand_define);
1454 macro_expand_define:
1457 if (CAR (r1) == cell_symbol_define_macro)
1459 push_cc (r1, r1, r0, cell_vm_macro_expand_define_macro);
1461 macro_expand_define_macro:
1467 if (CAR (r1) == cell_symbol_set_x)
1469 push_cc (CDDR (r1), r1, r0, cell_vm_macro_expand_set_x);
1477 if (TYPE (r1) == TPAIR
1478 && TYPE (CAR (r1)) == TSYMBOL
1479 && CAR (r1) != cell_symbol_begin
1480 && ((macro = macro_get_handle (cell_symbol_portable_macro_expand)) != cell_f)
1481 && ((expanders = module_ref (r0, cell_symbol_sc_expander_alist)) != cell_undefined)
1482 && ((macro = assq (CAR (r1), expanders)) != cell_f))
1484 sc_expand = module_ref (r0, cell_symbol_macro_expand);
1486 if (sc_expand != cell_undefined && sc_expand != cell_f)
1488 r1 = cons (sc_expand, cons (r1, cell_nil));
1493 push_cc (CAR (r1), r1, r0, cell_vm_macro_expand_car);
1499 if (CDR (r1) == cell_nil)
1502 push_cc (CDR (r1), r1, r0, cell_vm_macro_expand_cdr);
1513 x = cell_unspecified;
1514 while (r1 != cell_nil)
1517 if (TYPE (r1) == TPAIR)
1519 if (CAAR (r1) == cell_symbol_primitive_load)
1521 program = cons (CAR (r1), cell_nil);
1522 push_cc (program, r1, r0, cell_vm_begin_primitive_load);
1524 begin_primitive_load:
1530 if (TYPE (r1) == TPAIR && TYPE (CAR (r1)) == TPAIR)
1532 if (CAAR (r1) == cell_symbol_begin)
1533 r1 = append2 (CDAR (r1), CDR (r1));
1535 if (CDR (r1) == cell_nil)
1540 push_cc (CAR (r1), r1, r0, cell_vm_begin_eval);
1551 x = cell_unspecified;
1552 while (r1 != cell_nil)
1556 if (TYPE (r1) == TPAIR)
1558 if (TYPE (CAR (r1)) == TPAIR && CAAR (r1) == cell_symbol_begin)
1559 r1 = append2 (CDAR (r1), CDR (r1));
1560 if (CAAR (r1) == cell_symbol_primitive_load)
1562 push_cc (CADR (CAR (r1)), r1, r0, cell_vm_begin_expand_primitive_load);
1563 goto eval; // FIXME: expand too?!
1564 begin_expand_primitive_load:
1565 if (TYPE (r1) == TNUMBER && VALUE (r1) == 0)
1567 else if (TYPE (r1) == TSTRING)
1568 input = set_current_input_port (open_input_file (r1));
1569 else if (TYPE (r1) == TPORT)
1570 input = set_current_input_port (r1);
1574 push_cc (input, r2, r0, cell_vm_return);
1575 x = read_input_file_env (r0);
1577 module_printer (m0);
1581 set_current_input_port (input);
1582 r1 = cons (cell_symbol_begin, r1);
1589 push_cc (CAR (r1), r1, r0, cell_vm_begin_expand_macro);
1599 expand_variable (CAR (r1), cell_nil);
1600 push_cc (CAR (r1), r1, r0, cell_vm_begin_expand_eval);
1610 push_cc (CAR (r1), r1, r0, cell_vm_if_expr);
1620 if (CDDR (r1) != cell_nil)
1622 r1 = CAR (CDDR (r1));
1625 r1 = cell_unspecified;
1628 call_with_current_continuation:
1630 x = MAKE_CONTINUATION (g_continuations++);
1631 v = make_vector__ (STACK_SIZE-g_stack);
1632 for (t=g_stack; t < STACK_SIZE; t++)
1633 vector_set_x_ (v, t-g_stack, g_stack_array[t]);
1634 CONTINUATION (x) = v;
1636 push_cc (cons (CAR (r1), cons (x, cell_nil)), x, r0, cell_vm_call_with_current_continuation2);
1638 call_with_current_continuation2:
1639 v = make_vector__ (STACK_SIZE-g_stack);
1640 for (t=g_stack; t < STACK_SIZE; t++)
1641 vector_set_x_ (v, t-g_stack, g_stack_array[t]);
1642 CONTINUATION (r2) = v;
1646 push_cc (cons (CAR (r1), cell_nil), r1, r0, cell_vm_call_with_values2);
1649 if (TYPE (r1) == TVALUES)
1651 r1 = cons (CADR (r2), r1);
1662 apply (SCM f, SCM x, SCM a) ///((internal))
1664 push_cc (cons (f, x), cell_unspecified, r0, cell_unspecified);
1666 return eval_apply ();
1670 mes_g_stack (SCM a) ///((internal))
1672 //g_stack = g_free + ARENA_SIZE;
1673 g_stack = STACK_SIZE;
1681 //
\f Environment setup
1693 gc_init_cells () ///((internal))
1695 long arena_bytes = (ARENA_SIZE+JAM_SIZE)*sizeof (struct scm);
1696 void *p = malloc (arena_bytes+STACK_SIZE*sizeof (SCM));
1697 g_cells = (struct scm *)p;
1698 g_stack_array = (SCM*)(p + arena_bytes);
1710 mes_symbols () ///((internal))
1717 g_cells[cell_nil] = scm_nil;
1720 g_cells[cell_f] = scm_f;
1723 g_cells[cell_t] = scm_t;
1726 g_cells[cell_dot] = scm_dot;
1729 g_cells[cell_arrow] = scm_arrow;
1732 g_cells[cell_undefined] = scm_undefined;
1735 g_cells[cell_unspecified] = scm_unspecified;
1738 g_cells[cell_closure] = scm_closure;
1741 g_cells[cell_circular] = scm_circular;
1744 g_cells[cell_begin] = scm_begin;
1747 g_cells[cell_symbol_dot] = scm_symbol_dot;
1750 g_cells[cell_symbol_lambda] = scm_symbol_lambda;
1753 g_cells[cell_symbol_begin] = scm_symbol_begin;
1756 g_cells[cell_symbol_if] = scm_symbol_if;
1759 g_cells[cell_symbol_quote] = scm_symbol_quote;
1762 g_cells[cell_symbol_define] = scm_symbol_define;
1765 g_cells[cell_symbol_define_macro] = scm_symbol_define_macro;
1768 g_cells[cell_symbol_quasiquote] = scm_symbol_quasiquote;
1771 g_cells[cell_symbol_unquote] = scm_symbol_unquote;
1774 g_cells[cell_symbol_unquote_splicing] = scm_symbol_unquote_splicing;
1779 g_cells[cell_symbol_syntax] = scm_symbol_syntax;
1782 g_cells[cell_symbol_quasisyntax] = scm_symbol_quasisyntax;
1785 g_cells[cell_symbol_unsyntax] = scm_symbol_unsyntax;
1788 g_cells[cell_symbol_unsyntax_splicing] = scm_symbol_unsyntax_splicing;
1791 g_cells[cell_symbol_set_x] = scm_symbol_set_x;
1794 g_cells[cell_symbol_sc_expand] = scm_symbol_sc_expand;
1797 g_cells[cell_symbol_macro_expand] = scm_symbol_macro_expand;
1800 g_cells[cell_symbol_portable_macro_expand] = scm_symbol_portable_macro_expand;
1803 g_cells[cell_symbol_sc_expander_alist] = scm_symbol_sc_expander_alist;
1806 g_cells[cell_symbol_call_with_values] = scm_symbol_call_with_values;
1809 g_cells[cell_call_with_current_continuation] = scm_call_with_current_continuation;
1812 g_cells[cell_symbol_call_with_current_continuation] = scm_symbol_call_with_current_continuation;
1815 g_cells[cell_symbol_boot_module] = scm_symbol_boot_module;
1818 g_cells[cell_symbol_current_module] = scm_symbol_current_module;
1821 g_cells[cell_symbol_primitive_load] = scm_symbol_primitive_load;
1824 g_cells[cell_symbol_read_input_file] = scm_symbol_read_input_file;
1827 g_cells[cell_symbol_write] = scm_symbol_write;
1830 g_cells[cell_symbol_display] = scm_symbol_display;
1833 g_cells[cell_symbol_throw] = scm_symbol_throw;
1836 g_cells[cell_symbol_not_a_number] = scm_symbol_not_a_number;
1839 g_cells[cell_symbol_not_a_pair] = scm_symbol_not_a_pair;
1842 g_cells[cell_symbol_system_error] = scm_symbol_system_error;
1845 g_cells[cell_symbol_wrong_number_of_args] = scm_symbol_wrong_number_of_args;
1848 g_cells[cell_symbol_wrong_type_arg] = scm_symbol_wrong_type_arg;
1851 g_cells[cell_symbol_unbound_variable] = scm_symbol_unbound_variable;
1854 g_cells[cell_symbol_hashq_table] = scm_symbol_hashq_table;
1857 g_cells[cell_symbol_record_type] = scm_symbol_record_type;
1860 g_cells[cell_symbol_module] = scm_symbol_module;
1863 g_cells[cell_symbol_buckets] = scm_symbol_buckets;
1866 g_cells[cell_symbol_size] = scm_symbol_size;
1869 g_cells[cell_symbol_argv] = scm_symbol_argv;
1872 g_cells[cell_symbol_mes_prefix] = scm_symbol_mes_prefix;
1875 g_cells[cell_symbol_mes_version] = scm_symbol_mes_version;
1878 g_cells[cell_symbol_car] = scm_symbol_car;
1881 g_cells[cell_symbol_cdr] = scm_symbol_cdr;
1884 g_cells[cell_symbol_pmatch_car] = scm_symbol_pmatch_car;
1887 g_cells[cell_symbol_pmatch_cdr] = scm_symbol_pmatch_cdr;
1890 g_cells[cell_vm_evlis] = scm_vm_evlis;
1893 g_cells[cell_vm_evlis2] = scm_vm_evlis2;
1896 g_cells[cell_vm_evlis3] = scm_vm_evlis3;
1899 g_cells[cell_vm_apply] = scm_vm_apply;
1902 g_cells[cell_vm_apply2] = scm_vm_apply2;
1905 g_cells[cell_vm_eval] = scm_vm_eval;
1908 g_cells[cell_vm_eval_pmatch_car] = scm_vm_eval_pmatch_car;
1911 g_cells[cell_vm_eval_pmatch_cdr] = scm_vm_eval_pmatch_cdr;
1914 g_cells[cell_vm_eval_define] = scm_vm_eval_define;
1917 g_cells[cell_vm_eval_set_x] = scm_vm_eval_set_x;
1920 g_cells[cell_vm_eval_macro_expand_eval] = scm_vm_eval_macro_expand_eval;
1923 g_cells[cell_vm_eval_macro_expand_expand] = scm_vm_eval_macro_expand_expand;
1926 g_cells[cell_vm_eval_check_func] = scm_vm_eval_check_func;
1929 g_cells[cell_vm_eval2] = scm_vm_eval2;
1932 g_cells[cell_vm_macro_expand] = scm_vm_macro_expand;
1935 g_cells[cell_vm_macro_expand_define] = scm_vm_macro_expand_define;
1938 g_cells[cell_vm_macro_expand_define_macro] = scm_vm_macro_expand_define_macro;
1941 g_cells[cell_vm_macro_expand_lambda] = scm_vm_macro_expand_lambda;
1944 g_cells[cell_vm_macro_expand_set_x] = scm_vm_macro_expand_set_x;
1947 g_cells[cell_vm_begin_expand_primitive_load] = scm_vm_begin_expand_primitive_load;
1950 g_cells[cell_vm_begin_primitive_load] = scm_vm_begin_primitive_load;
1953 g_cells[cell_vm_macro_expand_car] = scm_vm_macro_expand_car;
1956 g_cells[cell_vm_macro_expand_cdr] = scm_vm_macro_expand_cdr;
1959 g_cells[cell_vm_begin_expand] = scm_vm_begin_expand;
1962 g_cells[cell_vm_begin_expand_eval] = scm_vm_begin_expand_eval;
1965 g_cells[cell_vm_begin_expand_macro] = scm_vm_begin_expand_macro;
1968 g_cells[cell_vm_begin] = scm_vm_begin;
1971 g_cells[cell_vm_begin_read_input_file] = scm_vm_begin_read_input_file;
1974 g_cells[cell_vm_begin_eval] = scm_vm_begin_eval;
1977 g_cells[cell_vm_if] = scm_vm_if;
1980 g_cells[cell_vm_if_expr] = scm_vm_if_expr;
1983 g_cells[cell_vm_call_with_values2] = scm_vm_call_with_values2;
1986 g_cells[cell_vm_call_with_current_continuation2] = scm_vm_call_with_current_continuation2;
1989 g_cells[cell_vm_return] = scm_vm_return;
1992 g_cells[cell_symbol_compiler] = scm_symbol_compiler;
1995 g_cells[cell_symbol_arch] = scm_symbol_arch;
1998 g_cells[cell_test] = scm_test;
2000 #elif !_POSIX_SOURCE
2001 #include "mes.mes.symbols.i"
2003 #include "mes.symbols.i"
2006 g_symbol_max = g_free++;
2010 g_cells[cell_nil].car = cstring_to_list (scm_nil.car);
2011 g_cells[cell_f].car = cstring_to_list (scm_f.car);
2012 g_cells[cell_t].car = cstring_to_list (scm_t.car);
2013 g_cells[cell_dot].car = cstring_to_list (scm_dot.car);
2014 g_cells[cell_arrow].car = cstring_to_list (scm_arrow.car);
2015 g_cells[cell_undefined].car = cstring_to_list (scm_undefined.car);
2016 g_cells[cell_unspecified].car = cstring_to_list (scm_unspecified.car);
2017 g_cells[cell_closure].car = cstring_to_list (scm_closure.car);
2018 g_cells[cell_circular].car = cstring_to_list (scm_circular.car);
2019 g_cells[cell_begin].car = cstring_to_list (scm_begin.car);
2020 g_cells[cell_symbol_dot].car = cstring_to_list (scm_symbol_dot.car);
2021 g_cells[cell_symbol_lambda].car = cstring_to_list (scm_symbol_lambda.car);
2022 g_cells[cell_symbol_begin].car = cstring_to_list (scm_symbol_begin.car);
2023 g_cells[cell_symbol_if].car = cstring_to_list (scm_symbol_if.car);
2024 g_cells[cell_symbol_quote].car = cstring_to_list (scm_symbol_quote.car);
2025 g_cells[cell_symbol_define].car = cstring_to_list (scm_symbol_define.car);
2026 g_cells[cell_symbol_define_macro].car = cstring_to_list (scm_symbol_define_macro.car);
2027 g_cells[cell_symbol_quasiquote].car = cstring_to_list (scm_symbol_quasiquote.car);
2028 g_cells[cell_symbol_unquote].car = cstring_to_list (scm_symbol_unquote.car);
2029 g_cells[cell_symbol_unquote_splicing].car = cstring_to_list (scm_symbol_unquote_splicing.car);
2035 g_cells[cell_symbol_syntax].car = cstring_to_list (scm_symbol_syntax.name);
2036 g_cells[cell_symbol_quasisyntax].car = cstring_to_list (scm_symbol_quasisyntax.name);
2037 g_cells[cell_symbol_unsyntax].car = cstring_to_list (scm_symbol_unsyntax.name);
2038 g_cells[cell_symbol_unsyntax_splicing].car = cstring_to_list (scm_symbol_unsyntax_splicing.name);
2039 g_cells[cell_symbol_set_x].car = cstring_to_list (scm_symbol_set_x.name);
2040 g_cells[cell_symbol_sc_expand].car = cstring_to_list (scm_symbol_sc_expand.name);
2041 g_cells[cell_symbol_macro_expand].car = cstring_to_list (scm_symbol_macro_expand.name);
2042 g_cells[cell_symbol_portable_macro_expand].car = cstring_to_list (scm_symbol_portable_macro_expand.name);
2043 g_cells[cell_symbol_sc_expander_alist].car = cstring_to_list (scm_symbol_sc_expander_alist.name);
2044 g_cells[cell_symbol_call_with_values].car = cstring_to_list (scm_symbol_call_with_values.name);
2045 g_cells[cell_call_with_current_continuation].car = cstring_to_list (scm_call_with_current_continuation.name);
2046 g_cells[cell_symbol_call_with_current_continuation].car = cstring_to_list (scm_symbol_call_with_current_continuation.name);
2047 g_cells[cell_symbol_boot_module].car = cstring_to_list (scm_symbol_boot_module.name);
2048 g_cells[cell_symbol_current_module].car = cstring_to_list (scm_symbol_current_module.name);
2049 g_cells[cell_symbol_primitive_load].car = cstring_to_list (scm_symbol_primitive_load.name);
2050 g_cells[cell_symbol_read_input_file].car = cstring_to_list (scm_symbol_read_input_file.name);
2051 g_cells[cell_symbol_write].car = cstring_to_list (scm_symbol_write.name);
2052 g_cells[cell_symbol_display].car = cstring_to_list (scm_symbol_display.name);
2053 g_cells[cell_symbol_throw].car = cstring_to_list (scm_symbol_throw.name);
2054 g_cells[cell_symbol_not_a_number].car = cstring_to_list (scm_symbol_not_a_number.name);
2055 g_cells[cell_symbol_not_a_pair].car = cstring_to_list (scm_symbol_not_a_pair.name);
2056 g_cells[cell_symbol_system_error].car = cstring_to_list (scm_symbol_system_error.name);
2057 g_cells[cell_symbol_wrong_number_of_args].car = cstring_to_list (scm_symbol_wrong_number_of_args.name);
2058 g_cells[cell_symbol_wrong_type_arg].car = cstring_to_list (scm_symbol_wrong_type_arg.name);
2059 g_cells[cell_symbol_unbound_variable].car = cstring_to_list (scm_symbol_unbound_variable.name);
2060 g_cells[cell_symbol_hashq_table].car = cstring_to_list (scm_symbol_hashq_table.name);
2061 g_cells[cell_symbol_record_type].car = cstring_to_list (scm_symbol_record_type.name);
2062 g_cells[cell_symbol_module].car = cstring_to_list (scm_symbol_module.name);
2063 g_cells[cell_symbol_buckets].car = cstring_to_list (scm_symbol_buckets.name);
2064 g_cells[cell_symbol_size].car = cstring_to_list (scm_symbol_size.name);
2065 g_cells[cell_symbol_argv].car = cstring_to_list (scm_symbol_argv.name);
2066 g_cells[cell_symbol_mes_prefix].car = cstring_to_list (scm_symbol_mes_prefix.name);
2067 g_cells[cell_symbol_mes_version].car = cstring_to_list (scm_symbol_mes_version.name);
2068 g_cells[cell_symbol_car].car = cstring_to_list (scm_symbol_car.name);
2069 g_cells[cell_symbol_cdr].car = cstring_to_list (scm_symbol_cdr.name);
2070 g_cells[cell_symbol_pmatch_car].car = cstring_to_list (scm_symbol_pmatch_car.name);
2071 g_cells[cell_symbol_pmatch_cdr].car = cstring_to_list (scm_symbol_pmatch_cdr.name);
2077 g_cells[cell_vm_evlis].car = cstring_to_list (scm_vm_evlis.car);
2078 g_cells[cell_vm_evlis2].car = cstring_to_list (scm_vm_evlis2.car);
2079 g_cells[cell_vm_evlis3].car = cstring_to_list (scm_vm_evlis3.car);
2080 g_cells[cell_vm_apply].car = cstring_to_list (scm_vm_apply.car);
2081 g_cells[cell_vm_apply2].car = cstring_to_list (scm_vm_apply2.car);
2082 g_cells[cell_vm_eval].car = cstring_to_list (scm_vm_eval.car);
2083 g_cells[cell_vm_eval_pmatch_car].car = cstring_to_list (scm_vm_eval_pmatch_car.car);
2084 g_cells[cell_vm_eval_pmatch_cdr].car = cstring_to_list (scm_vm_eval_pmatch_cdr.car);
2085 g_cells[cell_vm_eval_define].car = cstring_to_list (scm_vm_eval_define.car);
2086 g_cells[cell_vm_eval_set_x].car = cstring_to_list (scm_vm_eval_set_x.car);
2087 g_cells[cell_vm_eval_macro_expand_eval].car = cstring_to_list (scm_vm_eval_macro_expand_eval.car);
2088 g_cells[cell_vm_eval_macro_expand_expand].car = cstring_to_list (scm_vm_eval_macro_expand_expand.car);
2089 g_cells[cell_vm_eval_check_func].car = cstring_to_list (scm_vm_eval_check_func.car);
2090 g_cells[cell_vm_eval2].car = cstring_to_list (scm_vm_eval2.car);
2091 g_cells[cell_vm_macro_expand].car = cstring_to_list (scm_vm_macro_expand.car);
2092 g_cells[cell_vm_macro_expand_define].car = cstring_to_list (scm_vm_macro_expand_define.car);
2093 g_cells[cell_vm_macro_expand_define_macro].car = cstring_to_list (scm_vm_macro_expand_define_macro.car);
2094 g_cells[cell_vm_macro_expand_lambda].car = cstring_to_list (scm_vm_macro_expand_lambda.car);
2095 g_cells[cell_vm_macro_expand_set_x].car = cstring_to_list (scm_vm_macro_expand_set_x.car);
2096 g_cells[cell_vm_begin_expand_primitive_load].car = cstring_to_list (scm_vm_begin_expand_primitive_load.car);
2097 g_cells[cell_vm_begin_primitive_load].car = cstring_to_list (scm_vm_begin_primitive_load.car);
2098 g_cells[cell_vm_macro_expand_car].car = cstring_to_list (scm_vm_macro_expand_car.car);
2099 g_cells[cell_vm_macro_expand_cdr].car = cstring_to_list (scm_vm_macro_expand_cdr.car);
2100 g_cells[cell_vm_begin_expand].car = cstring_to_list (scm_vm_begin_expand.car);
2101 g_cells[cell_vm_begin_expand_eval].car = cstring_to_list (scm_vm_begin_expand_eval.car);
2102 g_cells[cell_vm_begin_expand_macro].car = cstring_to_list (scm_vm_begin_expand_macro.car);
2103 g_cells[cell_vm_begin].car = cstring_to_list (scm_vm_begin.car);
2104 g_cells[cell_vm_begin_read_input_file].car = cstring_to_list (scm_vm_begin_read_input_file.car);
2105 g_cells[cell_vm_begin_eval].car = cstring_to_list (scm_vm_begin_eval.car);
2106 g_cells[cell_vm_if].car = cstring_to_list (scm_vm_if.car);
2107 g_cells[cell_vm_if_expr].car = cstring_to_list (scm_vm_if_expr.car);
2108 g_cells[cell_vm_call_with_values2].car = cstring_to_list (scm_vm_call_with_values2.car);
2109 g_cells[cell_vm_call_with_current_continuation2].car = cstring_to_list (scm_vm_call_with_current_continuation2.car);
2110 g_cells[cell_vm_return].car = cstring_to_list (scm_vm_return.car);
2112 ////////////////// gc
2114 #elif !_POSIX_SOURCE
2115 #include "mes.mes.symbol-names.i"
2117 #include "mes.symbol-names.i"
2120 g_symbols = make_hash_table_ (500);
2121 for (int i=1; i<g_symbol_max; i++)
2122 hash_set_x (g_symbols, MAKE_STRING (STRING (i)), i);
2125 a = acons (cell_symbol_call_with_values, cell_symbol_call_with_values, a);
2126 a = acons (cell_symbol_boot_module, cell_symbol_boot_module, a);
2127 a = acons (cell_symbol_current_module, cell_symbol_current_module, a);
2128 a = acons (cell_symbol_call_with_current_continuation, cell_call_with_current_continuation, a);
2130 a = acons (cell_symbol_mes_version, MAKE_STRING (cstring_to_list (VERSION)), a);
2131 a = acons (cell_symbol_mes_prefix, MAKE_STRING (cstring_to_list (PREFIX)), a);
2133 a = acons (cell_type_char, MAKE_NUMBER (TCHAR), a);
2134 a = acons (cell_type_closure, MAKE_NUMBER (TCLOSURE), a);
2135 a = acons (cell_type_continuation, MAKE_NUMBER (TCONTINUATION), a);
2136 a = acons (cell_type_function, MAKE_NUMBER (TFUNCTION), a);
2137 a = acons (cell_type_keyword, MAKE_NUMBER (TKEYWORD), a);
2138 a = acons (cell_type_macro, MAKE_NUMBER (TMACRO), a);
2139 a = acons (cell_type_number, MAKE_NUMBER (TNUMBER), a);
2140 a = acons (cell_type_pair, MAKE_NUMBER (TPAIR), a);
2141 a = acons (cell_type_port, MAKE_NUMBER (TPORT), a);
2142 a = acons (cell_type_ref, MAKE_NUMBER (TREF), a);
2143 a = acons (cell_type_special, MAKE_NUMBER (TSPECIAL), a);
2144 a = acons (cell_type_string, MAKE_NUMBER (TSTRING), a);
2145 a = acons (cell_type_struct, MAKE_NUMBER (TSTRUCT), a);
2146 a = acons (cell_type_symbol, MAKE_NUMBER (TSYMBOL), a);
2147 a = acons (cell_type_values, MAKE_NUMBER (TVALUES), a);
2148 a = acons (cell_type_variable, MAKE_NUMBER (TVARIABLE), a);
2149 a = acons (cell_type_vector, MAKE_NUMBER (TVECTOR), a);
2150 a = acons (cell_type_broken_heart, MAKE_NUMBER (TBROKEN_HEART), a);
2152 a = acons (cell_closure, a, a);
2158 mes_environment (int argc, char *argv[])
2160 SCM a = mes_symbols ();
2162 char *compiler = "gnuc";
2168 a = acons (cell_symbol_compiler, MAKE_STRING (cstring_to_list (compiler)), a);
2174 a = acons (cell_symbol_arch, MAKE_STRING (cstring_to_list (arch)), a);
2178 for (int i=argc-1; i>=0; i--)
2179 lst = cons (MAKE_STRING (cstring_to_list (argv[i])), lst);
2180 a = acons (cell_symbol_argv, lst, a);
2183 return mes_g_stack (a);
2187 mes_builtins (SCM a) ///((internal))
2192 #define function cdr
2198 scm_cons.function = g_function;
2199 g_functions[g_function++] = fun_cons;
2200 cell_cons = g_free++;
2201 g_cells[cell_cons] = scm_cons;
2203 scm_car.function = g_function;
2204 g_functions[g_function++] = fun_car;
2205 cell_car = g_free++;
2206 g_cells[cell_car] = scm_car;
2208 scm_cdr.function = g_function;
2209 g_functions[g_function++] = fun_cdr;
2210 cell_cdr = g_free++;
2211 g_cells[cell_cdr] = scm_cdr;
2213 scm_list.function = g_function;
2214 g_functions[g_function++] = fun_list;
2215 cell_list = g_free++;
2216 g_cells[cell_list] = scm_list;
2218 scm_null_p.function = g_function;
2219 g_functions[g_function++] = fun_null_p;
2220 cell_null_p = g_free++;
2221 g_cells[cell_null_p] = scm_null_p;
2223 scm_eq_p.function = g_function;
2224 g_functions[g_function++] = fun_eq_p;
2225 cell_eq_p = g_free++;
2226 g_cells[cell_eq_p] = scm_eq_p;
2229 scm_minus.function = g_function;
2230 g_functions[g_function++] = fun_minus;
2231 cell_minus = g_free++;
2232 g_cells[cell_minus] = scm_minus;
2234 scm_plus.function = g_function;
2235 g_functions[g_function++] = fun_plus;
2236 cell_plus = g_free++;
2237 g_cells[cell_plus] = scm_plus;
2240 scm_display_.function = g_function;
2241 g_functions[g_function++] = fun_display_;
2242 cell_display_ = g_free++;
2243 g_cells[cell_display_] = scm_display_;
2245 scm_display_error_.function = g_function;
2246 g_functions[g_function++] = fun_display_error_;
2247 cell_display_error_ = g_free++;
2248 g_cells[cell_display_error_] = scm_display_error_;
2251 scm_getenv_.function = g_function;
2252 g_functions[g_function++] = fun_getenv_;
2253 cell_getenv_ = g_free++;
2254 g_cells[cell_getenv_] = scm_getenv_;
2261 scm_cons.string = cstring_to_list (fun_cons.name);
2262 g_cells[cell_cons].string = MAKE_STRING (scm_cons.string);
2263 a = acons (list_to_symbol (scm_cons.string), cell_cons, a);
2265 scm_car.string = cstring_to_list (fun_car.name);
2266 g_cells[cell_car].string = MAKE_STRING (scm_car.string);
2267 a = acons (list_to_symbol (scm_car.string), cell_car, a);
2269 scm_cdr.string = cstring_to_list (fun_cdr.name);
2270 g_cells[cell_cdr].string = MAKE_STRING (scm_cdr.string);
2271 a = acons (list_to_symbol (scm_cdr.string), cell_cdr, a);
2273 scm_list.string = cstring_to_list (fun_list.name);
2274 g_cells[cell_list].string = MAKE_STRING (scm_list.string);
2275 a = acons (list_to_symbol (scm_list.string), cell_list, a);
2277 scm_null_p.string = cstring_to_list (fun_null_p.name);
2278 g_cells[cell_null_p].string = MAKE_STRING (scm_null_p.string);
2279 a = acons (list_to_symbol (scm_null_p.string), cell_null_p, a);
2281 scm_eq_p.string = cstring_to_list (fun_eq_p.name);
2282 g_cells[cell_eq_p].string = MAKE_STRING (scm_eq_p.string);
2283 a = acons (list_to_symbol (scm_eq_p.string), cell_eq_p, a);
2286 scm_minus.string = cstring_to_list (fun_minus.name);
2287 g_cells[cell_minus].string = MAKE_STRING (scm_minus.string);
2288 a = acons (list_to_symbol (scm_minus.string), cell_minus, a);
2290 scm_plus.string = cstring_to_list (fun_plus.name);
2291 g_cells[cell_plus].string = MAKE_STRING (scm_plus.string);
2292 a = acons (list_to_symbol (scm_plus.string), cell_plus, a);
2295 scm_display_.string = cstring_to_list (fun_display_.name);
2296 g_cells[cell_display_].string = MAKE_STRING (scm_display_.string);
2297 a = acons (list_to_symbol (scm_display_.string), cell_display_, a);
2299 scm_display_error_.string = cstring_to_list (fun_display_error_.name);
2300 g_cells[cell_display_error_].string = MAKE_STRING (scm_display_error_.string);
2301 a = acons (list_to_symbol (scm_display_error_.string), cell_display_error_, a);
2304 scm_getenv_.string = cstring_to_list (fun_getenv_.name);
2305 g_cells[cell_getenv_].string = MAKE_STRING (scm_getenv_.string);
2306 a = acons (list_to_symbol (scm_getenv_.string), cell_getenv_, a);
2313 #elif !__GNUC__ || !_POSIX_SOURCE
2314 #include "mes.mes.i"
2316 // Do not sort: Order of these includes define builtins
2317 #include "hash.mes.i"
2318 #include "module.mes.i"
2319 #include "posix.mes.i"
2320 #include "math.mes.i"
2321 #include "lib.mes.i"
2322 #include "vector.mes.i"
2323 #include "struct.mes.i"
2325 #include "reader.mes.i"
2327 #include "gc.mes.environment.i"
2328 #include "hash.mes.environment.i"
2329 #include "lib.mes.environment.i"
2330 #include "math.mes.environment.i"
2331 #include "mes.mes.environment.i"
2332 #include "module.mes.environment.i"
2333 #include "posix.mes.environment.i"
2334 #include "reader.mes.environment.i"
2335 #include "struct.mes.environment.i"
2336 #include "vector.mes.environment.i"
2340 // Do not sort: Order of these includes define builtins
2351 #include "gc.environment.i"
2352 #include "hash.environment.i"
2353 #include "lib.environment.i"
2354 #include "math.environment.i"
2355 #include "mes.environment.i"
2356 #include "module.environment.i"
2357 #include "posix.environment.i"
2358 #include "reader.environment.i"
2359 #include "struct.environment.i"
2360 #include "vector.environment.i"
2365 fdputs ("functions: ", STDERR);
2366 fdputs (itoa (g_function), STDERR);
2367 fdputs ("\n", STDERR);
2368 for (int i = 0; i < g_function; i++)
2370 fdputs ("[", STDERR);
2371 fdputs (itoa (i), STDERR);
2372 fdputs ("]: ", STDERR);
2373 fdputs (g_functions[i].name, STDERR);
2374 fdputs ("\n", STDERR);
2376 fdputs ("\n", STDERR);
2382 SCM read_input_file_env (SCM);
2385 load_boot (char *prefix, char const *boot, char const *location)
2387 strcpy (prefix + strlen (prefix), boot);
2390 eputs ("mes: reading boot-0 [");
2396 int fd = open (prefix, O_RDONLY);
2397 if (g_debug && fd > 0)
2399 eputs ("mes: read boot-0: ");
2407 load_env () ///((internal))
2412 if (getenv ("MES_BOOT"))
2413 strcpy (boot, getenv ("MES_BOOT"));
2415 strcpy (boot, "boot-0.scm");
2416 if (getenv ("MES_PREFIX"))
2418 strcpy (prefix, getenv ("MES_PREFIX"));
2419 strcpy (prefix + strlen (prefix), "/module");
2420 strcpy (prefix + strlen (prefix), "/mes/");
2421 g_stdin = load_boot (prefix, boot, "MES_PREFIX");
2425 char const *p = MODULEDIR "/mes/";
2427 g_stdin = load_boot (prefix, boot, "MODULEDIR");
2431 strcpy (prefix, "mes/module/mes/");
2432 g_stdin = load_boot (prefix, boot, ".");
2437 g_stdin = load_boot (prefix, boot, "<boot>");
2441 eputs ("mes: boot failed: no such file: ");
2447 r2 = read_input_file_env (r0);
2453 bload_env () ///((internal))
2456 char *mo = "mes/boot-0.32-mo";
2457 g_stdin = open ("module/mes/boot-0.32-mo", O_RDONLY);
2458 char *read0 = MODULEDIR "/mes/boot-0.32-mo";
2459 g_stdin = g_stdin >= 0 ? g_stdin : open (read0, O_RDONLY);
2461 char *mo ="mes/boot-0.mo";
2462 g_stdin = open ("module/mes/boot-0.mo", O_RDONLY);
2463 g_stdin = g_stdin >= 0 ? g_stdin : open (MODULEDIR "/mes/boot-0.mo", O_RDONLY);
2468 eputs ("no such file: ");
2473 assert (getchar () == 'M');
2474 assert (getchar () == 'E');
2475 assert (getchar () == 'S');
2478 eputs ("*GOT MES*\n");
2479 g_stack = getchar () << 8;
2480 g_stack += getchar ();
2482 char *p = (char*)g_cells;
2489 g_free = (p-(char*)g_cells) / sizeof (struct scm);
2493 // SCM a = struct_ref (r0, 4);
2494 // a = mes_builtins (a);
2495 // struct_set_x (r0, 4, a);
2496 r0 = mes_builtins (r0);
2500 eputs ("symbols: ");
2501 write_error_ (g_symbols);
2503 eputs ("functions: ");
2504 eputs (itoa (g_function));
2506 for (int i = 0; i < g_function; i++)
2511 eputs (g_functions[i].name);
2524 main (int argc, char *argv[])
2527 if (p = getenv ("MES_DEBUG"))
2531 eputs (";;; MODULEDIR=");
2535 if (p = getenv ("MES_MAX_ARENA"))
2536 MAX_ARENA_SIZE = atoi (p);
2537 if (p = getenv ("MES_ARENA"))
2538 ARENA_SIZE = atoi (p);
2539 JAM_SIZE = ARENA_SIZE / 10;
2540 if (p = getenv ("MES_JAM"))
2541 JAM_SIZE = atoi (p);
2542 GC_SAFETY = ARENA_SIZE / 100;
2543 if (p = getenv ("MES_SAFETY"))
2544 GC_SAFETY = atoi (p);
2545 if (p = getenv ("MES_STACK"))
2546 STACK_SIZE = atoi (p);
2550 SCM a = mes_environment (argc, argv);
2551 a = mes_builtins (a);
2553 m0 = make_initial_module (a);
2554 g_macros = make_hash_table_ (0);
2557 module_printer (m0);
2559 SCM program = (argc > 1 && !strcmp (argv[1], "--load"))
2560 ? bload_env () : load_env ();
2561 g_tiny = argc > 2 && !strcmp (argv[2], "--tiny");
2562 if (argc > 1 && !strcmp (argv[1], "--dump"))
2565 push_cc (r2, cell_unspecified, r0, cell_unspecified);
2569 eputs ("\ngc stats: [");
2570 eputs (itoa (g_free));
2575 eputs ("program: ");
2581 eputs ("symbols: ");
2582 write_error_ (g_symbols);
2585 r3 = cell_vm_begin_expand;
2594 eputs ("\ngc stats: [");
2595 eputs (itoa (g_free));
2599 eputs (itoa (g_free));