32bfd7ee7dbad68ade86b36b53b64f97b180ad3b
[mes.git] / src / mes.c
1 /* -*-comment-start: "//";comment-end:""-*-
2  * GNU Mes --- Maxwell Equations of Software
3  * Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
4  *
5  * This file is part of GNU Mes.
6  *
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.
11  *
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.
16  *
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/>.
19  */
20
21 #include <stdio.h>
22 #include <assert.h>
23 #include <stdint.h>
24 #include <stdlib.h>
25 #include <string.h>
26 #include <libmes.h>
27
28 //#define MES_MINI 1
29 #if POSIX
30 long ARENA_SIZE = 100000000; // 2.3GiB
31 #else
32 long ARENA_SIZE = 300000; // 32b: 3MiB, 64b: 6 MiB
33 #endif
34 long MAX_ARENA_SIZE = 100000000;
35 long STACK_SIZE = 20000;
36
37 long JAM_SIZE = 20000;
38 long GC_SAFETY = 2000;
39
40 char *g_arena = 0;
41 typedef long SCM;
42
43 int g_debug = 0;
44 long g_free = 0;
45
46 SCM g_continuations = 0;
47 SCM g_symbols = 0;
48 SCM g_stack = 0;
49 SCM *g_stack_array = 0;
50 #define FRAME_SIZE 5
51 #define FRAME_PROCEDURE 4
52 // a/env
53 SCM r0 = 0;
54 // param 1
55 SCM r1 = 0;
56 // save 2+load/dump
57 SCM r2 = 0;
58 // continuation
59 SCM r3 = 0;
60 // current-module
61 SCM m0 = 0;
62 // macro
63 SCM g_macros = 0;
64 SCM g_ports = 1;
65
66 #if __x86_64__
67 #define HALFLONG_MAX UINT_MAX
68 typedef int halflong;
69 #else
70 #define HALFLONG_MAX UINT16_MAX
71 typedef short halflong;
72 #endif
73
74 #if __M2_PLANET__
75 CONSTANT TBYTES         0
76 CONSTANT TCHAR          1
77 CONSTANT TCLOSURE       2
78 CONSTANT TCONTINUATION  3
79 CONSTANT TFUNCTION      4
80 CONSTANT TKEYWORD       5
81 CONSTANT TMACRO         6
82 CONSTANT TNUMBER        7
83 CONSTANT TPAIR          8
84 CONSTANT TPORT          9
85 CONSTANT TREF          10
86 CONSTANT TSPECIAL      11
87 CONSTANT TSTRING       12
88 CONSTANT TSTRUCT       13
89 CONSTANT TSYMBOL       14
90 CONSTANT TVALUES       15
91 CONSTANT TVARIABLE     16
92 CONSTANT TVECTOR       17
93 CONSTANT TBROKEN_HEART 18
94 #else // !__M2_PLANET__
95 enum type_t {TBYTES, TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TPORT, TREF, TSPECIAL, TSTRING, TSTRUCT, TSYMBOL, TVALUES, TVARIABLE, TVECTOR, TBROKEN_HEART};
96 #endif // !__M2_PLANET__
97
98 typedef SCM (*function0_t) (void);
99 typedef SCM (*function1_t) (SCM);
100 typedef SCM (*function2_t) (SCM, SCM);
101 typedef SCM (*function3_t) (SCM, SCM, SCM);
102 typedef SCM (*functionn_t) (SCM);
103 #if !POSIX
104 struct scm {
105   enum type_t type;
106   SCM car;
107   SCM cdr;
108 };
109 struct function {
110 #if __M2_PLANET__
111   FUNCTION function;
112 #else // !__M2_PLANET__
113   SCM (*function) (SCM);
114 #endif // !__M2_PLANET__
115   long arity;
116   char *name;
117 };
118 #else
119 struct function {
120   union {
121     function0_t function0;
122     function1_t function1;
123     function2_t function2;
124     function3_t function3;
125     functionn_t functionn;
126   };
127   long arity;
128   char const *name;
129 };
130 struct scm {
131   enum type_t type;
132   union
133   {
134 #if 0
135     struct
136     {
137       unsigned halflong start;
138       unsigned halflong end;
139     };
140 #endif
141     unsigned long function;
142     unsigned long length;
143     long port;
144     SCM car;
145     SCM macro;
146     SCM ref;
147     SCM variable;
148   };
149   union
150   {
151     long value;
152     char const* name;
153     char const* bytes;
154     SCM cdr;
155     SCM closure;
156     SCM continuation;
157     SCM string;
158     SCM vector;
159   };
160 };
161 #endif
162
163 #if __MESC__
164 //FIXME
165 char *foobar = 0;
166 struct scm *g_cells = foobar;
167 struct scm *g_news = foobar;
168 #else
169 struct scm *g_cells = 0;
170 struct scm *g_news = 0;
171 #endif
172
173 struct scm scm_nil = {TSPECIAL, 0, "()"};
174 struct scm scm_f = {TSPECIAL, 0, "#f"};
175 struct scm scm_t = {TSPECIAL, 0, "#t"};
176 struct scm scm_dot = {TSPECIAL, 0, "."};
177 struct scm scm_arrow = {TSPECIAL, 0, "=>"};
178 struct scm scm_undefined = {TSPECIAL, 0, "*undefined*"};
179 struct scm scm_unspecified = {TSPECIAL, 0, "*unspecified*"};
180 struct scm scm_closure = {TSPECIAL, 0, "*closure*"};
181 struct scm scm_circular = {TSPECIAL, 0, "*circular*"};
182 struct scm scm_begin = {TSPECIAL, 0, "*begin*"};
183
184 struct scm scm_symbol_dot = {TSYMBOL, 0, "*dot*"};
185 struct scm scm_symbol_lambda = {TSYMBOL, 0, "lambda"};
186 struct scm scm_symbol_begin = {TSYMBOL, 0, "begin"};
187 struct scm scm_symbol_if = {TSYMBOL, 0, "if"};
188 struct scm scm_symbol_quote = {TSYMBOL, 0, "quote"};
189 struct scm scm_symbol_define = {TSYMBOL, 0, "define"};
190 struct scm scm_symbol_define_macro = {TSYMBOL, 0, "define-macro"};
191
192 struct scm scm_symbol_quasiquote = {TSYMBOL, 0, "quasiquote"};
193 struct scm scm_symbol_unquote = {TSYMBOL, 0, "unquote"};
194 struct scm scm_symbol_unquote_splicing = {TSYMBOL, 0, "unquote-splicing"};
195 struct scm scm_symbol_syntax = {TSYMBOL, 0, "syntax"};
196 struct scm scm_symbol_quasisyntax = {TSYMBOL, 0, "quasisyntax"};
197 struct scm scm_symbol_unsyntax = {TSYMBOL, 0, "unsyntax"};
198 struct scm scm_symbol_unsyntax_splicing = {TSYMBOL, 0, "unsyntax-splicing"};
199
200 struct scm scm_symbol_set_x = {TSYMBOL, 0, "set!"};
201
202 struct scm scm_symbol_sc_expand = {TSYMBOL, 0, "sc-expand"};
203 struct scm scm_symbol_macro_expand = {TSYMBOL, 0, "macro-expand"};
204 struct scm scm_symbol_portable_macro_expand = {TSYMBOL, 0, "portable-macro-expand"};
205 struct scm scm_symbol_sc_expander_alist = {TSYMBOL, 0, "*sc-expander-alist*"};
206
207 struct scm scm_symbol_call_with_values = {TSYMBOL, 0, "call-with-values"};
208 struct scm scm_call_with_current_continuation = {TSPECIAL, 0, "*call/cc*"};
209 struct scm scm_symbol_call_with_current_continuation = {TSYMBOL, 0, "call-with-current-continuation"};
210 struct scm scm_symbol_boot_module = {TSYMBOL, 0, "boot-module"};
211 struct scm scm_symbol_current_module = {TSYMBOL, 0, "current-module"};
212 struct scm scm_symbol_primitive_load = {TSYMBOL, 0, "primitive-load"};
213 struct scm scm_symbol_read_input_file = {TSYMBOL, 0, "read-input-file"};
214 struct scm scm_symbol_write = {TSYMBOL, 0, "write"};
215 struct scm scm_symbol_display = {TSYMBOL, 0, "display"};
216
217 struct scm scm_symbol_throw = {TSYMBOL, 0, "throw"};
218 struct scm scm_symbol_not_a_number = {TSYMBOL, 0, "not-a-number"};
219 struct scm scm_symbol_not_a_pair = {TSYMBOL, 0, "not-a-pair"};
220 struct scm scm_symbol_system_error = {TSYMBOL, 0, "system-error"};
221 struct scm scm_symbol_wrong_number_of_args = {TSYMBOL, 0, "wrong-number-of-args"};
222 struct scm scm_symbol_wrong_type_arg = {TSYMBOL, 0, "wrong-type-arg"};
223 struct scm scm_symbol_unbound_variable = {TSYMBOL, 0, "unbound-variable"};
224
225 struct scm scm_symbol_hashq_table = {TSYMBOL, 0, "<hashq-table>"};
226 struct scm scm_symbol_record_type = {TSYMBOL, 0, "<record-type>"};
227 struct scm scm_symbol_frame = {TSYMBOL, 0, "<frame>"};
228 struct scm scm_symbol_module = {TSYMBOL, 0, "<module>"};
229 struct scm scm_symbol_stack = {TSYMBOL, 0, "<stack>"};
230 struct scm scm_symbol_buckets = {TSYMBOL, 0, "buckets"};
231 struct scm scm_symbol_procedure = {TSYMBOL, 0, "procedure"};
232 struct scm scm_symbol_size = {TSYMBOL, 0, "size"};
233
234 struct scm scm_symbol_argv = {TSYMBOL, 0, "%argv"};
235 struct scm scm_symbol_mes_prefix = {TSYMBOL, 0, "%prefix"};
236 struct scm scm_symbol_mes_version = {TSYMBOL, 0, "%version"};
237
238 struct scm scm_symbol_car = {TSYMBOL, 0, "car"};
239 struct scm scm_symbol_cdr = {TSYMBOL, 0, "cdr"};
240 struct scm scm_symbol_pmatch_car = {TSYMBOL, 0, "pmatch-car"};
241 struct scm scm_symbol_pmatch_cdr = {TSYMBOL, 0, "pmatch-cdr"};
242
243 struct scm scm_vm_evlis = {TSPECIAL, 0, "*vm-evlis*"};
244 struct scm scm_vm_evlis2 = {TSPECIAL, 0, "*vm-evlis2*"};
245 struct scm scm_vm_evlis3 = {TSPECIAL, 0, "*vm-evlis3*"};
246 struct scm scm_vm_apply = {TSPECIAL, 0, "core:apply"};
247 struct scm scm_vm_apply2 = {TSPECIAL, 0, "*vm-apply2*"};
248 struct scm scm_vm_eval = {TSPECIAL, 0, "core:eval-expanded"};
249
250 struct scm scm_vm_eval_pmatch_car = {TSPECIAL, 0, "*vm-eval-pmatch-car*"};
251 struct scm scm_vm_eval_pmatch_cdr = {TSPECIAL, 0, "*vm-eval-pmatch-cdr*"};
252 struct scm scm_vm_eval_define = {TSPECIAL, 0, "*vm-eval-define*"};
253
254 struct scm scm_vm_eval_set_x = {TSPECIAL, 0, "*vm-eval-set!*"};
255 struct scm scm_vm_eval_macro_expand_eval = {TSPECIAL, 0, "*vm:eval-macro-expand-eval*"};
256 struct scm scm_vm_eval_macro_expand_expand = {TSPECIAL, 0, "*vm:eval-macro-expand-expand*"};
257 struct scm scm_vm_eval_check_func = {TSPECIAL, 0, "*vm-eval-check-func*"};
258 struct scm scm_vm_eval2 = {TSPECIAL, 0, "*vm-eval2*"};
259 struct scm scm_vm_macro_expand = {TSPECIAL, 0, "core:macro-expand"};
260 struct scm scm_vm_macro_expand_define = {TSPECIAL, 0, "*vm:core:macro-expand-define*"};
261 struct scm scm_vm_macro_expand_define_macro = {TSPECIAL, 0, "*vm:core:macro-expand-define-macro*"};
262 struct scm scm_vm_macro_expand_lambda = {TSPECIAL, 0, "*vm:core:macro-expand-lambda*"};
263 struct scm scm_vm_macro_expand_set_x = {TSPECIAL, 0, "*vm:core:macro-expand-set!*"};
264 struct scm scm_vm_begin_expand_primitive_load = {TSPECIAL, 0, "*vm:core:begin-expand-primitive-load*"};
265 struct scm scm_vm_begin_primitive_load = {TSPECIAL, 0, "*vm:core:begin-primitive-load*"};
266 struct scm scm_vm_macro_expand_car = {TSPECIAL, 0, "*vm:core:macro-expand-car*"};
267 struct scm scm_vm_macro_expand_cdr = {TSPECIAL, 0, "*vm:macro-expand-cdr*"};
268 struct scm scm_vm_begin_expand = {TSPECIAL, 0, "core:eval"};
269 struct scm scm_vm_begin_expand_eval = {TSPECIAL, 0, "*vm:begin-expand-eval*"};
270 struct scm scm_vm_begin_expand_macro = {TSPECIAL, 0, "*vm:begin-expand-macro*"};
271 struct scm scm_vm_begin = {TSPECIAL, 0, "*vm-begin*"};
272 struct scm scm_vm_begin_read_input_file = {TSPECIAL, 0, "*vm-begin-read-input-file*"};
273 struct scm scm_vm_begin_eval = {TSPECIAL, 0, "*vm:begin-eval*"};
274 struct scm scm_vm_if = {TSPECIAL, 0, "*vm-if*"};
275 struct scm scm_vm_if_expr = {TSPECIAL, 0, "*vm-if-expr*"};
276 struct scm scm_vm_call_with_values2 = {TSPECIAL, 0, "*vm-call-with-values2*"};
277 struct scm scm_vm_call_with_current_continuation2 = {TSPECIAL, 0, "*vm-call-with-current-continuation2*"};
278 struct scm scm_vm_return = {TSPECIAL, 0, "*vm-return*"};
279
280 struct scm scm_type_bytes = {TSYMBOL, 0, "<cell:bytes>"};
281 struct scm scm_type_char = {TSYMBOL, 0, "<cell:char>"};
282 struct scm scm_type_closure = {TSYMBOL, 0, "<cell:closure>"};
283 struct scm scm_type_continuation = {TSYMBOL, 0, "<cell:continuation>"};
284 struct scm scm_type_function = {TSYMBOL, 0, "<cell:function>"};
285 struct scm scm_type_keyword = {TSYMBOL, 0, "<cell:keyword>"};
286 struct scm scm_type_macro = {TSYMBOL, 0, "<cell:macro>"};
287 struct scm scm_type_number = {TSYMBOL, 0, "<cell:number>"};
288 struct scm scm_type_pair = {TSYMBOL, 0, "<cell:pair>"};
289 struct scm scm_type_port = {TSYMBOL, 0, "<cell:port>"};
290 struct scm scm_type_ref = {TSYMBOL, 0, "<cell:ref>"};
291 struct scm scm_type_special = {TSYMBOL, 0, "<cell:special>"};
292 struct scm scm_type_string = {TSYMBOL, 0, "<cell:string>"};
293 struct scm scm_type_struct = {TSYMBOL, 0, "<cell:struct>"};
294 struct scm scm_type_symbol = {TSYMBOL, 0, "<cell:symbol>"};
295 struct scm scm_type_values = {TSYMBOL, 0, "<cell:values>"};
296 struct scm scm_type_variable = {TSYMBOL, 0, "<cell:variable>"};
297 struct scm scm_type_vector = {TSYMBOL, 0, "<cell:vector>"};
298 struct scm scm_type_broken_heart = {TSYMBOL, 0, "<cell:broken-heart>"};
299
300 struct scm scm_symbol_internal_time_units_per_second = {TSYMBOL, 0, "internal-time-units-per-second"};
301 struct scm scm_symbol_compiler = {TSYMBOL, 0, "%compiler"};
302 struct scm scm_symbol_arch = {TSYMBOL, 0, "%arch"};
303
304 struct scm scm_test = {TSYMBOL, 0, "%%test"};
305
306 #if !POSIX
307 #include "src/mes.mes.symbols.h"
308 #else
309 #include "src/mes.symbols.h"
310 #endif
311
312 struct function g_functions[200];
313 int g_function = 0;
314
315 #if !__GNUC__ || !POSIX
316 #include "src/gc.mes.h"
317 #include "src/hash.mes.h"
318 #include "src/lib.mes.h"
319 #include "src/math.mes.h"
320 #include "src/mes.mes.h"
321 #include "src/module.mes.h"
322 #include "src/posix.mes.h"
323 #include "src/reader.mes.h"
324 #include "src/strings.mes.h"
325 #include "src/struct.mes.h"
326 #include "src/vector.mes.h"
327 #else
328 #include "src/gc.h"
329 #include "src/hash.h"
330 #include "src/lib.h"
331 #include "src/math.h"
332 #include "src/mes.h"
333 #include "src/module.h"
334 #include "src/posix.h"
335 #include "src/reader.h"
336 #include "src/strings.h"
337 #include "src/struct.h"
338 #include "src/vector.h"
339 #endif
340
341 #define TYPE(x) g_cells[x].type
342 #define CAR(x) g_cells[x].car
343 #define CDR(x) g_cells[x].cdr
344
345 #define NTYPE(x) g_news[x].type
346 #define NCAR(x) g_news[x].car
347 #define NCDR(x) g_news[x].cdr
348
349 #if !POSIX
350 #define BYTES(x) g_cells[x].car
351 #define LENGTH(x) g_cells[x].car
352 #define REF(x) g_cells[x].car
353 #define START(x) (g_cells[x].car >> 16)
354 #define LEN(x) (g_cells[x].car & 0xffff)
355 #define VARIABLE(x) g_cells[x].car
356
357 #define CLOSURE(x) g_cells[x].cdr
358 #define CONTINUATION(x) g_cells[x].cdr
359
360 #define CBYTES(x) &g_cells[x].cdr
361 #define CSTRING_STRUCT(x) &g_cells[x.cdr].cdr
362
363 #define FUNCTION(x) g_functions[g_cells[x].car]
364 #define FUNCTION0(x) g_functions[g_cells[x].car].function
365 #define MACRO(x) g_cells[x].car
366 #define NAME(x) g_cells[x].cdr
367 #define PORT(x) g_cells[x].car
368 #define STRING(x) g_cells[x].cdr
369 #define STRUCT(x) g_cells[x].cdr
370 #define VALUE(x) g_cells[x].cdr
371 #define VECTOR(x) g_cells[x].cdr
372
373 #define NLENGTH(x) g_news[x].car
374 #define NCBYTES(x) &g_news[x].cdr
375 #define NVALUE(x) g_news[x].cdr
376 #define NSTRING(x) g_news[x].cdr
377 #define NVECTOR(x) g_news[x].cdr
378
379 #else
380 #define BYTES(x) g_cells[x].bytes
381 #define FUNCTION(x) g_functions[g_cells[x].function]
382 #define FUNCTION0(x) g_functions[g_cells[x].function].function0
383 #define LENGTH(x) g_cells[x].length
384 #define REF(x) g_cells[x].ref
385 #define START(x) g_cells[x].start
386 #define LEN(x) g_cells[x].end
387 #define VARIABLE(x) g_cells[x].variable
388
389 #define CLOSURE(x) g_cells[x].closure
390 #define CBYTES(x) &g_cells[x].bytes
391 #define CSTRING_STRUCT(x) &g_cells[x.string].string
392 #define CONTINUATION(x) g_cells[x].continuation
393 #define MACRO(x) g_cells[x].macro
394 #define NAME(x) g_cells[x].name
395 #define PORT(x) g_cells[x].port
396 #define STRING(x) g_cells[x].string
397 #define STRUCT(x) g_cells[x].vector
398 #define VALUE(x) g_cells[x].value
399 #define VECTOR(x) g_cells[x].vector
400
401 #define NLENGTH(x) g_news[x].length
402
403 #define NCBYTES(x) &g_news[x].bytes
404 #define NVALUE(x) g_news[x].value
405 #define NVECTOR(x) g_news[x].vector
406 #endif
407
408 #define CSTRING(x) CBYTES (STRING (x))
409
410 #define MAKE_BYTES0(x) make_bytes (x, strlen (x))
411 #define NAME_SYMBOL(symbol,name) {size_t s = strlen (name); CAR (symbol) = s; CDR (symbol) = make_bytes (name, s);}
412
413 #define MAKE_CHAR(n) make_cell__ (TCHAR, 0, n)
414 #define MAKE_CONTINUATION(n) make_cell__ (TCONTINUATION, n, g_stack)
415 #define MAKE_NUMBER(n) make_cell__ (TNUMBER, 0, n)
416 #define MAKE_REF(n) make_cell__ (TREF, n, 0)
417 #define MAKE_STRING0(x) make_string (x, strlen (x))
418 #define MAKE_STRING_PORT(x) make_cell__ (TPORT, -length__ (g_ports) - 2, x)
419 #define MAKE_MACRO(name, x) make_cell__ (TMACRO, x, STRING (name))
420
421 #define CAAR(x) CAR (CAR (x))
422 #define CADR(x) CAR (CDR (x))
423 #define CDAR(x) CDR (CAR (x))
424 #define CDDR(x) CDR (CDR (x))
425 #define CADAR(x) CAR (CDR (CAR (x)))
426 #define CADDR(x) CAR (CDR (CDR (x)))
427 #define CDADAR(x) CAR (CDR (CAR (CDR (x))))
428
429 SCM make_bytes (char const* s, size_t length);
430 SCM cstring_to_list (char const* s);
431 SCM string_equal_p (SCM a, SCM b);
432
433 SCM
434 alloc (long n)
435 {
436   SCM x = g_free;
437   g_free += n;
438   if (g_free > ARENA_SIZE)
439     assert (!"alloc: out of memory");
440   return x;
441 }
442
443 SCM
444 make_cell__ (long type, SCM car, SCM cdr)
445 {
446   SCM x = alloc (1);
447   TYPE (x) = type;
448   CAR (x) = car;
449   CDR (x) = cdr;
450   return x;
451 }
452
453 SCM
454 make_cell_ (SCM type, SCM car, SCM cdr)
455 {
456   assert (TYPE (type) == TNUMBER);
457   long t = VALUE (type);
458   if (t == TCHAR || t == TNUMBER)
459     return make_cell__ (t, car ? CAR (car) : 0, cdr ? CDR (cdr) : 0);
460   return make_cell__ (t, car, cdr);
461 }
462
463 SCM
464 assoc_string (SCM x, SCM a) ///((internal))
465 {
466   while (a != cell_nil && (TYPE (CAAR (a)) != TSTRING
467                            || string_equal_p (x, CAAR (a)) == cell_f))
468     a = CDR (a);
469   return a != cell_nil ? CAR (a) : cell_f;
470 }
471
472 SCM
473 type_ (SCM x)
474 {
475   return MAKE_NUMBER (TYPE (x));
476 }
477
478 // SCM
479 // car_to_cell_ (SCM x)
480 // {
481 //   return CAR (x);
482 // }
483
484 // SCM
485 // cdr_to_cell_ (SCM x)
486 // {
487 //   return CDR (x);
488 // }
489
490 // SCM
491 // car_to_number_ (SCM x)
492 // {
493 //   return MAKE_NUMBER (CAR (x));
494 // }
495
496 // SCM
497 // cdr_to_number_ (SCM x)
498 // {
499 //   return MAKE_NUMBER (CDR (x));
500 // }
501
502 SCM
503 car_ (SCM x)
504 {
505   return (TYPE (x) != TCONTINUATION
506           && (TYPE (CAR (x)) == TPAIR // FIXME: this is weird
507               || TYPE (CAR (x)) == TREF
508               || TYPE (CAR (x)) == TSPECIAL
509               || TYPE (CAR (x)) == TSYMBOL
510               || TYPE (CAR (x)) == TSTRING)) ? CAR (x) : MAKE_NUMBER (CAR (x));
511 }
512
513 SCM
514 cdr_ (SCM x)
515 {
516   return (TYPE (x) != TCHAR
517           && TYPE (x) != TNUMBER
518           && TYPE (x) != TPORT
519           && (TYPE (CDR (x)) == TPAIR
520               || TYPE (CDR (x)) == TREF
521               || TYPE (CDR (x)) == TSPECIAL
522               || TYPE (CDR (x)) == TSYMBOL
523               || TYPE (CDR (x)) == TSTRING)) ? CDR (x) : MAKE_NUMBER (CDR (x));
524 }
525
526 SCM
527 arity_ (SCM x)
528 {
529   assert (TYPE (x) == TFUNCTION);
530   return MAKE_NUMBER (FUNCTION (x).arity);
531 }
532
533 SCM
534 cons (SCM x, SCM y)
535 {
536   return make_cell__ (TPAIR, x, y);
537 }
538
539 SCM
540 car (SCM x)
541 {
542 #if !__MESC_MES__
543   if (TYPE (x) != TPAIR)
544     error (cell_symbol_not_a_pair, cons (x, cell_symbol_car));
545 #endif
546   return CAR (x);
547 }
548
549 SCM
550 cdr (SCM x)
551 {
552 #if !__MESC_MES__
553   if (TYPE (x) != TPAIR)
554     error (cell_symbol_not_a_pair, cons (x, cell_symbol_cdr));
555 #endif
556   return CDR (x);
557 }
558
559 SCM
560 list (SCM x) ///((arity . n))
561 {
562   return x;
563 }
564
565 SCM
566 null_p (SCM x)
567 {
568   return x == cell_nil ? cell_t : cell_f;
569 }
570
571 SCM
572 eq_p (SCM x, SCM y)
573 {
574   return (x == y
575           || ((TYPE (x) == TKEYWORD && TYPE (y) == TKEYWORD
576                && string_equal_p (x, y) == cell_t))
577           || (TYPE (x) == TCHAR && TYPE (y) == TCHAR
578               && VALUE (x) == VALUE (y))
579           || (TYPE (x) == TNUMBER && TYPE (y) == TNUMBER
580               && VALUE (x) == VALUE (y)))
581     ? cell_t : cell_f;
582 }
583
584 SCM
585 values (SCM x) ///((arity . n))
586 {
587   SCM v = cons (0, x);
588   TYPE (v) = TVALUES;
589   return v;
590 }
591
592 SCM
593 acons (SCM key, SCM value, SCM alist)
594 {
595   return cons (cons (key, value), alist);
596 }
597
598 long
599 length__ (SCM x) ///((internal))
600 {
601   long n = 0;
602   while (x != cell_nil)
603     {
604       n++;
605       if (TYPE (x) != TPAIR)
606         return -1;
607       x = CDR (x);
608     }
609   return n;
610 }
611
612 SCM
613 length (SCM x)
614 {
615   return MAKE_NUMBER (length__ (x));
616 }
617
618 SCM apply (SCM, SCM, SCM);
619
620 SCM
621 error (SCM key, SCM x)
622 {
623 #if !__MESC_MES__
624   SCM throw;
625   if ((throw = module_ref (r0, cell_symbol_throw)) != cell_undefined)
626     return apply (throw, cons (key, cons (x, cell_nil)), r0);
627 #endif
628   display_error_ (key);
629   eputs (": ");
630   write_error_ (x);
631   eputs ("\n");
632   assert (0);
633   exit (1);
634 }
635
636 // \f extra lib
637 SCM
638 assert_defined (SCM x, SCM e) ///((internal))
639 {
640   if (e == cell_undefined)
641     return error (cell_symbol_unbound_variable, x);
642   return e;
643 }
644
645 SCM make_string (char const* s, size_t length);
646
647 SCM
648 check_formals (SCM f, SCM formals, SCM args) ///((internal))
649 {
650   long flen = (TYPE (formals) == TNUMBER) ? VALUE (formals) : length__ (formals);
651   long alen = length__ (args);
652   if (alen != flen && alen != -1 && flen != -1)
653     {
654       char *s = "apply: wrong number of arguments; expected: ";
655       eputs (s);
656       eputs (itoa (flen));
657       eputs (", got: ");
658       eputs (itoa (alen));
659       eputs ("\n");
660       write_error_ (f);
661       SCM e = MAKE_STRING0 (s);
662       return error (cell_symbol_wrong_number_of_args, cons (e, f));
663     }
664   return cell_unspecified;
665 }
666
667 SCM
668 check_apply (SCM f, SCM e) ///((internal))
669 {
670   char* type = 0;
671   if (f == cell_f || f == cell_t)
672     type = "bool";
673   if (f == cell_nil)
674     type = "nil";
675   if (f == cell_unspecified)
676     type = "*unspecified*";
677   if (f == cell_undefined)
678     type = "*undefined*";
679   if (TYPE (f) == TCHAR)
680     type = "char";
681   if (TYPE (f) == TNUMBER)
682     type = "number";
683   if (TYPE (f) == TSTRING)
684     type = "string";
685   if (TYPE (f) == TSTRUCT)
686     type = "#<...>";
687   if (TYPE (f) == TBROKEN_HEART)
688     type = "<3";
689
690   if (type)
691     {
692       char *s = "cannot apply: ";
693       eputs (s);
694       eputs (type);
695       eputs ("[");
696       write_error_ (e);
697       eputs ("]\n");
698       SCM e = MAKE_STRING0 (s);
699       return error (cell_symbol_wrong_type_arg, cons (e, f));
700     }
701   return cell_unspecified;
702 }
703
704 SCM
705 gc_push_frame () ///((internal))
706 {
707   if (g_stack < 5)
708     assert (!"STACK FULL");
709   g_stack_array[--g_stack] = cell_f;
710   g_stack_array[--g_stack] = r0;
711   g_stack_array[--g_stack] = r1;
712   g_stack_array[--g_stack] = r2;
713   g_stack_array[--g_stack] = r3;
714   return g_stack;
715 }
716
717 SCM
718 gc_peek_frame () ///((internal))
719 {
720   r3 = g_stack_array[g_stack];
721   r2 = g_stack_array[g_stack+1];
722   r1 = g_stack_array[g_stack+2];
723   r0 = g_stack_array[g_stack+3];
724   return g_stack_array[g_stack+FRAME_PROCEDURE];
725 }
726
727 SCM
728 gc_pop_frame () ///((internal))
729 {
730   SCM x = gc_peek_frame ();
731   g_stack += 5;
732   return x;
733 }
734
735 SCM
736 append2 (SCM x, SCM y)
737 {
738   if (x == cell_nil)
739     return y;
740   if (TYPE (x) != TPAIR)
741     error (cell_symbol_not_a_pair, cons (x, cell_append2));
742   SCM r = cell_nil;
743   while (x != cell_nil)
744     {
745       r = cons (CAR (x), r);
746       x = CDR (x);
747     }
748   return reverse_x_ (r, y);
749 }
750
751 SCM
752 append_reverse (SCM x, SCM y)
753 {
754   if (x == cell_nil)
755     return y;
756   if (TYPE (x) != TPAIR)
757     error (cell_symbol_not_a_pair, cons (x, cell_append_reverse));
758   while (x != cell_nil)
759     {
760       y = cons (CAR (x), y);
761       x = CDR (x);
762     }
763   return y;
764 }
765
766 SCM
767 reverse_x_ (SCM x, SCM t)
768 {
769   if (x != cell_nil && TYPE (x) != TPAIR)
770     error (cell_symbol_not_a_pair, cons (x, cell_reverse_x_));
771   SCM r = t;
772   while (x != cell_nil)
773     {
774       t = CDR (x);
775       CDR (x) = r;
776       r = x;
777       x = t;
778     }
779   return r;
780 }
781
782 SCM
783 pairlis (SCM x, SCM y, SCM a)
784 {
785   if (x == cell_nil)
786     return a;
787   if (TYPE (x) != TPAIR)
788     return cons (cons (x, y), a);
789   return cons (cons (car (x), car (y)),
790                pairlis (cdr (x), cdr (y), a));
791 }
792
793 SCM
794 call (SCM fn, SCM x)
795 {
796 #if __M2_PLANET__
797   struct function *f = FUNCTION (fn);
798 #else
799   struct function *f = &FUNCTION (fn);
800 #endif
801   int arity = f->arity;
802   if ((arity > 0 || arity == -1)
803       && x != cell_nil && TYPE (CAR (x)) == TVALUES)
804     x = cons (CADAR (x), CDR (x));
805   if ((arity > 1 || arity == -1)
806       && x != cell_nil && TYPE (CDR (x)) == TPAIR && TYPE (CADR (x)) == TVALUES)
807     x = cons (CAR (x), cons (CDADAR (x), CDR (x)));
808
809 #if __M2_PLANET__
810   FUNCTION fp = f->function;
811   if (arity == 0)
812     return fp ();
813   else if (arity == 1)
814     return fp (CAR (x));
815   else if (arity == 2)
816     return fp (CAR (x), CADR (x));
817   else if (arity == 3)
818     return fp (CAR (x), CADR (x), CAR (CDDR (x)));
819   else if (arity == -1)
820     return fp (x);
821 #elif !POSIX
822   if (arity == 0)
823     {
824       //function0_t fp = f->function;
825       SCM (*fp) (void) = f->function;
826       return fp ();
827     }
828   else if (arity == 1)
829     {
830       //function1_t fp = f->function;
831       SCM (*fp) (SCM) = f->function;
832       return fp (CAR (x));
833     }
834   else if (arity == 2)
835     {
836       //function2_t fp = f->function;
837       SCM (*fp) (SCM, SCM) = f->function;
838       return fp (CAR (x), CADR (x));
839     }
840   else if (arity == 3)
841     {
842       //function3_t fp = f->function;
843       SCM (*fp) (SCM, SCM, SCM) = f->function;
844       return fp (CAR (x), CADR (x), CAR (CDDR (x)));
845     }
846   else if (arity == -1)
847     {
848       //functionn_t fp = f->function;
849       SCM (*fp) (SCM) = f->function;
850       return fp (x);
851     }
852 #else
853   if (arity == 0)
854     return FUNCTION (fn).function0 ();
855   else if (arity == 1)
856     return FUNCTION (fn).function1 (CAR (x));
857   else if (arity == 2)
858     return FUNCTION (fn).function2 (CAR (x), CADR (x));
859   else if (arity == 3)
860     return FUNCTION (fn).function3 (CAR (x), CADR (x), CAR (CDDR (x)));
861   else if (arity == -1)
862     return FUNCTION (fn).functionn (x);
863 #endif //! (__M2_PLANET__ || !POSIX)
864   return cell_unspecified;
865 }
866
867 SCM
868 assq (SCM x, SCM a)
869 {
870   if (TYPE (a) != TPAIR)
871     return cell_f;
872   int t = TYPE (x);
873   if (t == TSYMBOL
874       || t == TSPECIAL)
875     while (a != cell_nil && x != CAAR (a))
876       a = CDR (a);
877   else if (t == TCHAR
878            || t == TNUMBER)
879       {
880         SCM v = VALUE (x);
881         while (a != cell_nil && v != VALUE (CAAR (a)))
882           a = CDR (a);
883       }
884   else if (t == TKEYWORD)
885     {
886       while (a != cell_nil && string_equal_p (x, CAAR (a)) == cell_f)
887         a = CDR (a);
888     }
889   else
890     /* pointer equality, e.g. on strings. */
891     while (a != cell_nil && x != CAAR (a))
892       a = CDR (a);
893   return a != cell_nil ? CAR (a) : cell_f;
894 }
895
896 SCM
897 assoc (SCM x, SCM a)
898 {
899   if (TYPE (x) == TSTRING)
900     return assoc_string (x, a);
901   while (a != cell_nil && equal2_p (x, CAAR (a)) == cell_f)
902     a = CDR (a);
903   return a != cell_nil ? CAR (a) : cell_f;
904 }
905
906 SCM
907 set_car_x (SCM x, SCM e)
908 {
909   if (TYPE (x) != TPAIR)
910     error (cell_symbol_not_a_pair, cons (x, cell_set_car_x));
911   CAR (x) = e;
912   return cell_unspecified;
913 }
914
915 SCM
916 set_cdr_x (SCM x, SCM e)
917 {
918   if (TYPE (x) != TPAIR)
919     error (cell_symbol_not_a_pair, cons (x, cell_set_cdr_x));
920   CDR (x) = e;
921   return cell_unspecified;
922 }
923
924 SCM
925 set_env_x (SCM x, SCM e, SCM a)
926 {
927   SCM p;
928   if (TYPE (x) == TVARIABLE)
929     p = VARIABLE (x);
930   else
931     p = assert_defined (x, module_variable (a, x));
932   if (TYPE (p) != TPAIR)
933     error (cell_symbol_not_a_pair, cons (p, x));
934   return set_cdr_x (p, e);
935 }
936
937 SCM
938 call_lambda (SCM e, SCM x, SCM aa, SCM a) ///((internal))
939 {
940   SCM cl = cons (cons (cell_closure, x), x);
941   r1 = e;
942   r0 = cl;
943   return cell_unspecified;
944 }
945
946 SCM
947 make_closure_ (SCM args, SCM body, SCM a) ///((internal))
948 {
949   return make_cell__ (TCLOSURE, cell_f, cons (cons (cell_circular, a), cons (args, body)));
950 }
951
952 SCM
953 make_variable_ (SCM var) ///((internal))
954 {
955   return make_cell__ (TVARIABLE, var, 0);
956 }
957
958 SCM
959 macro_get_handle (SCM name)
960 {
961   if (TYPE (name) == TSYMBOL)
962     return hashq_get_handle (g_macros, name, cell_nil);
963   return cell_f;
964 }
965
966 SCM
967 get_macro (SCM name) ///((internal))
968 {
969   SCM m = macro_get_handle (name);
970   if (m != cell_f)
971     return MACRO (CDR (m));
972   return cell_f;
973 }
974
975 SCM
976 macro_set_x (SCM name, SCM value) ///((internal))
977 {
978   return hashq_set_x (g_macros, name, value);
979 }
980
981 SCM
982 push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal))
983 {
984   SCM x = r3;
985   r3 = c;
986   r2 = p2;
987   gc_push_frame ();
988   r1 = p1;
989   r0 = a;
990   r3 = x;
991   return cell_unspecified;
992 }
993
994 SCM
995 add_formals (SCM formals, SCM x)
996 {
997   while (TYPE (x) == TPAIR)
998     {
999       formals = cons (CAR (x), formals);
1000       x = CDR (x);
1001     }
1002   if (TYPE (x) == TSYMBOL)
1003     formals = cons (x, formals);
1004   return formals;
1005 }
1006
1007 int
1008 formal_p (SCM x, SCM formals) /// ((internal))
1009 {
1010   if (TYPE (formals) == TSYMBOL)
1011     {
1012       if (x == formals)
1013         return x;
1014       else return cell_f;
1015     }
1016   while (TYPE (formals) == TPAIR && CAR (formals) != x)
1017     formals = CDR (formals);
1018   if (TYPE (formals) == TSYMBOL)
1019     return formals == x;
1020   return TYPE (formals) == TPAIR;
1021 }
1022
1023 SCM
1024 expand_variable_ (SCM x, SCM formals, int top_p) ///((internal))
1025 {
1026   while (TYPE (x) == TPAIR)
1027     {
1028       if (TYPE (CAR (x)) == TPAIR)
1029         {
1030           if (CAAR (x) == cell_symbol_lambda)
1031             {
1032               SCM f = CAR (CDAR (x));
1033               formals = add_formals (formals, f);
1034             }
1035           else if (CAAR (x) == cell_symbol_define
1036                    || CAAR (x) == cell_symbol_define_macro)
1037             {
1038               SCM f = CAR (CDAR (x));
1039               formals = add_formals (formals, f);
1040             }
1041           if (CAAR (x) != cell_symbol_quote)
1042             expand_variable_ (CAR (x), formals, 0);
1043         }
1044       else
1045         {
1046           if (CAR (x) == cell_symbol_lambda)
1047             {
1048               SCM f = CADR (x);
1049               formals = add_formals (formals, f);
1050               x = CDR (x);
1051             }
1052           else if (CAR (x) == cell_symbol_define
1053                    || CAR (x) == cell_symbol_define_macro)
1054             {
1055               SCM f = CADR (x);
1056               if (top_p && TYPE (f) == TPAIR)
1057                 f = CDR (f);
1058               formals = add_formals (formals, f);
1059               x = CDR (x);
1060             }
1061           else if (CAR (x) == cell_symbol_quote)
1062             return cell_unspecified;
1063           else if (TYPE (CAR (x)) == TSYMBOL
1064                    && CAR (x) != cell_symbol_boot_module
1065                    && CAR (x) != cell_symbol_current_module
1066                    && CAR (x) != cell_symbol_primitive_load
1067                    && !formal_p (CAR (x), formals))
1068             {
1069               SCM v = module_variable (r0, CAR (x));
1070               if (v != cell_f)
1071                 CAR (x) = make_variable_ (v);
1072             }
1073         }
1074       x = CDR (x);
1075       top_p = 0;
1076     }
1077   return cell_unspecified;
1078 }
1079
1080 SCM
1081 expand_variable (SCM x, SCM formals) ///((internal))
1082 {
1083   return expand_variable_ (x, formals, 1);
1084 }
1085
1086 SCM struct_ref_ (SCM x, long i);
1087 SCM vector_ref_ (SCM x, long i);
1088 SCM make_vector__ (long k);
1089 SCM vector_set_x_ (SCM x, long i, SCM e);
1090
1091 SCM
1092 eval_apply ()
1093 {
1094   SCM aa;
1095   SCM args;
1096   SCM body;
1097   SCM cl;
1098   SCM entry;
1099   SCM expanders;
1100   SCM formals;
1101   SCM input;
1102   SCM name;
1103   SCM macro;
1104   SCM p;
1105   SCM program;
1106   SCM sc_expand;
1107   SCM v;
1108   SCM x;
1109   int global_p;
1110   int macro_p;
1111   int t;
1112   long c;
1113
1114  eval_apply:
1115   if (r3 == cell_vm_evlis2) goto evlis2;
1116   else if (r3 == cell_vm_evlis3) goto evlis3;
1117   else if (r3 == cell_vm_eval_check_func) goto eval_check_func;
1118   else if (r3 == cell_vm_eval2) goto eval2;
1119   else if (r3 == cell_vm_apply2) goto apply2;
1120   else if (r3 == cell_vm_if_expr) goto if_expr;
1121   else if (r3 == cell_vm_begin_eval) goto begin_eval;
1122   else if (r3 == cell_vm_eval_set_x) goto eval_set_x;
1123   else if (r3 == cell_vm_macro_expand_car) goto macro_expand_car;
1124   else if (r3 == cell_vm_return) goto vm_return;
1125   else if (r3 == cell_vm_macro_expand_cdr) goto macro_expand_cdr;
1126   else if (r3 == cell_vm_eval_define) goto eval_define;
1127   else if (r3 == cell_vm_macro_expand) goto macro_expand;
1128   else if (r3 == cell_vm_macro_expand_lambda) goto macro_expand_lambda;
1129   else if (r3 == cell_vm_eval_pmatch_car) goto eval_pmatch_car;
1130   else if (r3 == cell_vm_begin_expand_macro) goto begin_expand_macro;
1131   else if (r3 == cell_vm_macro_expand_define) goto macro_expand_define;
1132   else if (r3 == cell_vm_begin_expand_eval) goto begin_expand_eval;
1133   else if (r3 == cell_vm_call_with_current_continuation2) goto call_with_current_continuation2;
1134   else if (r3 == cell_vm_macro_expand_set_x) goto macro_expand_set_x;
1135   else if (r3 == cell_vm_eval_pmatch_cdr) goto eval_pmatch_cdr;
1136   else if (r3 == cell_vm_macro_expand_define_macro) goto macro_expand_define_macro;
1137   else if (r3 == cell_vm_begin_primitive_load) goto begin_primitive_load;
1138
1139   else if (r3 == cell_vm_evlis) goto evlis;
1140   else if (r3 == cell_vm_apply) goto apply;
1141   else if (r3 == cell_vm_eval) goto eval;
1142   else if (r3 == cell_vm_eval_macro_expand_eval) goto eval_macro_expand_eval;
1143   else if (r3 == cell_vm_eval_macro_expand_expand) goto eval_macro_expand_expand;
1144   else if (r3 == cell_vm_begin) goto begin;
1145   else if (r3 == cell_vm_begin_expand) goto begin_expand;
1146   else if (r3 == cell_vm_begin_expand_primitive_load) goto begin_expand_primitive_load;
1147   else if (r3 == cell_vm_if) goto vm_if;
1148   else if (r3 == cell_vm_call_with_values2) goto call_with_values2;
1149   else if (r3 == cell_unspecified) return r1;
1150   else
1151     error (cell_symbol_system_error,
1152            MAKE_STRING0 ("eval/apply unknown continuation"));
1153
1154  evlis:
1155   if (r1 == cell_nil)
1156     goto vm_return;
1157   if (TYPE (r1) != TPAIR)
1158     goto eval;
1159   push_cc (CAR (r1), r1, r0, cell_vm_evlis2);
1160   goto eval;
1161  evlis2:
1162   push_cc (CDR (r2), r1, r0, cell_vm_evlis3);
1163   goto evlis;
1164  evlis3:
1165   r1 = cons (r2, r1);
1166   goto vm_return;
1167
1168  apply:
1169   g_stack_array[g_stack+FRAME_PROCEDURE] = CAR (r1);
1170   t = TYPE (CAR (r1));
1171   if (t == TFUNCTION)
1172     {
1173       check_formals (CAR (r1), MAKE_NUMBER (FUNCTION (CAR (r1)).arity), CDR (r1));
1174       r1 = call (CAR (r1), CDR (r1)); /// FIXME: move into eval_apply
1175       goto vm_return;
1176     }
1177   else if (t == TCLOSURE)
1178     {
1179       cl = CLOSURE (CAR (r1));
1180       body = CDDR (cl);
1181       formals = CADR (cl);
1182       args = CDR (r1);
1183       aa = CDAR (cl);
1184       aa = CDR (aa);
1185       check_formals (CAR (r1), formals, CDR (r1));
1186       p = pairlis (formals, args, aa);
1187       call_lambda (body, p, aa, r0);
1188       goto begin;
1189     }
1190   else if (t == TCONTINUATION)
1191     {
1192       v = CONTINUATION (CAR (r1));
1193       if (LENGTH (v))
1194         {
1195           for (t=0; t < LENGTH (v); t++)
1196             g_stack_array[STACK_SIZE-LENGTH (v)+t] = vector_ref_ (v, t);
1197           g_stack = STACK_SIZE-LENGTH (v);
1198         }
1199       x = r1;
1200       gc_pop_frame ();
1201       r1 = CADR (x);
1202       goto eval_apply;
1203     }
1204   else if (t == TSPECIAL)
1205     {
1206       c = CAR (r1);
1207       if (c == cell_vm_apply)
1208         {
1209           push_cc (cons (CADR (r1), CADDR (r1)), r1, r0, cell_vm_return);
1210           goto apply;
1211         }
1212       else if (c ==  cell_vm_eval)
1213         {
1214           push_cc (CADR (r1), r1, CADDR (r1), cell_vm_return);
1215           goto eval;
1216         }
1217       else if (c ==  cell_vm_begin_expand)
1218         {
1219           push_cc (cons (CADR (r1), cell_nil), r1, CADDR (r1), cell_vm_return);
1220           goto begin_expand;
1221         }
1222       else if (c ==  cell_call_with_current_continuation)
1223         {
1224           r1 = CDR (r1);
1225           goto call_with_current_continuation;
1226         }
1227       else
1228         check_apply (cell_f, CAR (r1));
1229     }
1230   else if (t == TSYMBOL)
1231     {
1232       if (CAR (r1) == cell_symbol_call_with_values)
1233         {
1234           r1 = CDR (r1);
1235           goto call_with_values;
1236         }
1237       if (CAR (r1) == cell_symbol_current_module)
1238         {
1239           r1 = r0;
1240           goto vm_return;
1241         }
1242       if (CAR (r1) == cell_symbol_boot_module)
1243         {
1244           r1 = m0;
1245           goto vm_return;
1246         }
1247     }
1248   else if (t == TPAIR)
1249     {
1250       if (CAAR (r1) == cell_symbol_lambda)
1251         {
1252           formals = CADR (CAR (r1));
1253           args = CDR (r1);
1254           body = CDDR (CAR (r1));
1255           p = pairlis (formals, CDR (r1), r0);
1256           check_formals (r1, formals, args);
1257           call_lambda (body, p, p, r0);
1258           goto begin;
1259         }
1260     }
1261   // write_error_ (CAR (r1));
1262   // eputs ("\n");
1263   push_cc (CAR (r1), r1, r0, cell_vm_apply2);
1264   goto eval;
1265  apply2:
1266   check_apply (r1, CAR (r2));
1267   r1 = cons (r1, CDR (r2));
1268   goto apply;
1269
1270  eval:
1271   t = TYPE (r1);
1272   if (t == TPAIR)
1273     {
1274       c = CAR (r1);
1275       if (c ==  cell_symbol_pmatch_car)
1276         {
1277           push_cc (CADR (r1), r1, r0, cell_vm_eval_pmatch_car);
1278           goto eval;
1279         eval_pmatch_car:
1280           x = r1;
1281           gc_pop_frame ();
1282           r1 = CAR (x);
1283           goto eval_apply;
1284         }
1285       else if (c ==  cell_symbol_pmatch_cdr)
1286         {
1287           push_cc (CADR (r1), r1, r0, cell_vm_eval_pmatch_cdr);
1288           goto eval;
1289         eval_pmatch_cdr:
1290           x = r1;
1291           gc_pop_frame ();
1292           r1 = CDR (x);
1293           goto eval_apply;
1294         }
1295       else if (c ==  cell_symbol_quote)
1296         {
1297           x = r1;
1298           gc_pop_frame ();
1299           r1 = CADR (x);
1300           goto eval_apply;
1301         }
1302       else if (c ==  cell_symbol_begin)
1303         goto begin;
1304       else if (c ==  cell_symbol_lambda)
1305         {
1306           r1 = make_closure_ (CADR (r1), CDDR (r1), r0);
1307           goto vm_return;
1308         }
1309       else if (c ==  cell_symbol_if)
1310         {
1311           r1=CDR (r1);
1312           goto vm_if;
1313         }
1314       else if (c ==  cell_symbol_set_x)
1315         {
1316           push_cc (CAR (CDDR (r1)), r1, r0, cell_vm_eval_set_x);
1317           goto eval;
1318         eval_set_x:
1319           r1 = set_env_x (CADR (r2), r1, r0);
1320           goto vm_return;
1321         }
1322       else if (c == cell_vm_macro_expand)
1323         {
1324           push_cc (CADR (r1), r1, r0, cell_vm_eval_macro_expand_eval);
1325           goto eval;
1326         eval_macro_expand_eval:
1327           push_cc (r1, r2, r0, cell_vm_eval_macro_expand_expand);
1328           goto macro_expand;
1329         eval_macro_expand_expand:
1330           goto vm_return;
1331         }
1332       else
1333         {
1334           if (TYPE (r1) == TPAIR
1335               && (CAR (r1) == cell_symbol_define
1336                   || CAR (r1) == cell_symbol_define_macro))
1337             {
1338               global_p = CAAR (r0) != cell_closure;
1339               macro_p = CAR (r1) == cell_symbol_define_macro;
1340               if (global_p)
1341                 {
1342                   name = CADR (r1);
1343                   if (TYPE (CADR (r1)) == TPAIR)
1344                     name = CAR (name);
1345                   if (macro_p)
1346                     {
1347                       entry = assq (name, g_macros);
1348                       if (entry == cell_f)
1349                         macro_set_x (name, cell_f);
1350                     }
1351                   else
1352                     {
1353                       entry = module_variable (r0, name);
1354                       if (entry == cell_f)
1355                         module_define_x (m0, name, cell_f);
1356                     }
1357                 }
1358               r2 = r1;
1359               if (TYPE (CADR (r1)) != TPAIR)
1360                 {
1361                   push_cc (CAR (CDDR (r1)), r2, cons (cons (CADR (r1), CADR (r1)), r0), cell_vm_eval_define);
1362                   goto eval;
1363                 }
1364               else
1365                 {
1366                   p = pairlis (CADR (r1), CADR (r1), r0);
1367                   formals = CDR (CADR (r1));
1368                   body = CDDR (r1);
1369
1370                   if (macro_p || global_p)
1371                     expand_variable (body, formals);
1372                   r1 = cons (cell_symbol_lambda, cons (formals, body));
1373                   push_cc (r1, r2, p, cell_vm_eval_define);
1374                   goto eval;
1375                 }
1376             eval_define:;
1377               name = CADR (r2);
1378               if (TYPE (CADR (r2)) == TPAIR)
1379                 name = CAR (name);
1380               if (macro_p)
1381                 {
1382                   entry = macro_get_handle (name);
1383                   r1 = MAKE_MACRO (name, r1);
1384                   set_cdr_x (entry, r1);
1385                 }
1386               else if (global_p)
1387                 {
1388                   entry = module_variable (r0, name);
1389                   set_cdr_x (entry, r1);
1390                 }
1391               else
1392                 {
1393                   entry = cons (name, r1);
1394                   aa = cons (entry, cell_nil);
1395                   set_cdr_x (aa, cdr (r0));
1396                   set_cdr_x (r0, aa);
1397                   cl = module_variable (r0, cell_closure);
1398                   set_cdr_x (cl, aa);
1399                 }
1400               r1 = cell_unspecified;
1401               goto vm_return;
1402             }
1403           push_cc (CAR (r1), r1, r0, cell_vm_eval_check_func);
1404           gc_check ();
1405           goto eval;
1406         eval_check_func:
1407           push_cc (CDR (r2), r2, r0, cell_vm_eval2);
1408           goto evlis;
1409         eval2:
1410           r1 = cons (CAR (r2), r1);
1411           goto apply;
1412         }
1413     }
1414   else if (t == TSYMBOL)
1415     {
1416       if (r1 == cell_symbol_boot_module)
1417         goto vm_return;
1418       if (r1 == cell_symbol_current_module)
1419         goto vm_return;
1420       if (r1 == cell_symbol_begin) // FIXME
1421         {
1422           r1 = cell_begin;
1423           goto vm_return;
1424         }
1425       r1 = assert_defined (r1, module_ref (r0, r1));
1426       goto vm_return;
1427     }
1428   else if (t == TVARIABLE)
1429     {
1430       r1 = CDR (VARIABLE (r1));
1431       goto vm_return;
1432     }
1433   else if (t == TBROKEN_HEART)
1434     error (cell_symbol_system_error,  r1);
1435   else
1436     goto vm_return;
1437
1438  macro_expand:
1439   {
1440     macro;
1441     expanders;
1442
1443     if (TYPE (r1) != TPAIR || CAR (r1) == cell_symbol_quote)
1444       goto vm_return;
1445
1446     if (CAR (r1) == cell_symbol_lambda)
1447       {
1448         push_cc (CDDR (r1), r1, r0, cell_vm_macro_expand_lambda);
1449         goto macro_expand;
1450       macro_expand_lambda:
1451         CDDR (r2) = r1;
1452         r1 = r2;
1453         goto vm_return;
1454       }
1455
1456     if (TYPE (r1) == TPAIR
1457         && (macro = get_macro (CAR (r1))) != cell_f)
1458       {
1459         r1 = cons (macro, CDR (r1));
1460         push_cc (r1, cell_nil, r0, cell_vm_macro_expand);
1461         goto apply;
1462       }
1463
1464     if (CAR (r1) == cell_symbol_define
1465         || CAR (r1) == cell_symbol_define_macro)
1466       {
1467         push_cc (CDDR (r1), r1, r0, cell_vm_macro_expand_define);
1468         goto macro_expand;
1469       macro_expand_define:
1470         CDDR (r2) = r1;
1471         r1 = r2;
1472         if (CAR (r1) == cell_symbol_define_macro)
1473           {
1474             push_cc (r1, r1, r0, cell_vm_macro_expand_define_macro);
1475             goto eval;
1476           macro_expand_define_macro:
1477             r1 = r2;
1478           }
1479         goto vm_return;
1480       }
1481
1482     if (CAR (r1) == cell_symbol_set_x)
1483       {
1484         push_cc (CDDR (r1), r1, r0, cell_vm_macro_expand_set_x);
1485         goto macro_expand;
1486       macro_expand_set_x:
1487         CDDR (r2) = r1;
1488         r1 = r2;
1489         goto vm_return;
1490       }
1491
1492     if (TYPE (r1) == TPAIR
1493         && TYPE (CAR (r1)) == TSYMBOL
1494         && CAR (r1) != cell_symbol_begin
1495         && ((macro = macro_get_handle (cell_symbol_portable_macro_expand)) != cell_f)
1496         && ((expanders = module_ref (r0, cell_symbol_sc_expander_alist)) != cell_undefined)
1497         && ((macro = assq (CAR (r1), expanders)) != cell_f))
1498       {
1499         sc_expand = module_ref (r0, cell_symbol_macro_expand);
1500         r2 = r1;
1501         if (sc_expand != cell_undefined && sc_expand != cell_f)
1502           {
1503             r1 = cons (sc_expand, cons (r1, cell_nil));
1504             goto apply;
1505           }
1506       }
1507
1508     push_cc (CAR (r1), r1, r0, cell_vm_macro_expand_car);
1509     goto macro_expand;
1510
1511   macro_expand_car:
1512     CAR (r2) = r1;
1513     r1 = r2;
1514     if (CDR (r1) == cell_nil)
1515       goto vm_return;
1516
1517     push_cc (CDR (r1), r1, r0, cell_vm_macro_expand_cdr);
1518     goto macro_expand;
1519
1520   macro_expand_cdr:
1521     CDR (r2) = r1;
1522     r1 = r2;
1523
1524     goto vm_return;
1525   }
1526
1527  begin:
1528   x = cell_unspecified;
1529   while (r1 != cell_nil)
1530     {
1531       gc_check ();
1532       if (TYPE (r1) == TPAIR)
1533         {
1534           if (CAAR (r1) == cell_symbol_primitive_load)
1535             {
1536               program = cons (CAR (r1), cell_nil);
1537               push_cc (program, r1, r0, cell_vm_begin_primitive_load);
1538               goto begin_expand;
1539             begin_primitive_load:
1540               CAR (r2) = r1;
1541               r1 = r2;
1542             }
1543         }
1544
1545       if (TYPE (r1) == TPAIR && TYPE (CAR (r1)) == TPAIR)
1546         {
1547           if (CAAR (r1) == cell_symbol_begin)
1548             r1 = append2 (CDAR (r1), CDR (r1));
1549         }
1550       if (CDR (r1) == cell_nil)
1551         {
1552           r1 = CAR (r1);
1553           goto eval;
1554         }
1555       push_cc (CAR (r1), r1, r0, cell_vm_begin_eval);
1556       goto eval;
1557     begin_eval:
1558       x = r1;
1559       r1 = CDR (r2);
1560     }
1561   r1 = x;
1562   goto vm_return;
1563
1564
1565  begin_expand:
1566   x = cell_unspecified;
1567   while (r1 != cell_nil)
1568     {
1569       gc_check ();
1570
1571       if (TYPE (r1) == TPAIR)
1572         {
1573           if (TYPE (CAR (r1)) == TPAIR && CAAR (r1) == cell_symbol_begin)
1574             r1 = append2 (CDAR (r1), CDR (r1));
1575           if (CAAR (r1) == cell_symbol_primitive_load)
1576             {
1577               push_cc (CADR (CAR (r1)), r1, r0, cell_vm_begin_expand_primitive_load);
1578               goto eval; // FIXME: expand too?!
1579             begin_expand_primitive_load:
1580               if (TYPE (r1) == TNUMBER && VALUE (r1) == 0)
1581                 ;
1582               else if (TYPE (r1) == TSTRING)
1583                 input = set_current_input_port (open_input_file (r1));
1584               else if (TYPE (r1) == TPORT)
1585                 input = set_current_input_port (r1);
1586               else
1587                 assert (0);
1588
1589               push_cc (input, r2, r0, cell_vm_return);
1590               x = read_input_file_env (r0);
1591               if (g_debug > 3)
1592                 module_printer (m0);
1593               gc_pop_frame ();
1594               input = r1;
1595               r1 = x;
1596               set_current_input_port (input);
1597               r1 = cons (cell_symbol_begin, r1);
1598               CAR (r2) = r1;
1599               r1 = r2;
1600               continue;
1601             }
1602         }
1603
1604       push_cc (CAR (r1), r1, r0, cell_vm_begin_expand_macro);
1605       goto macro_expand;
1606     begin_expand_macro:
1607       if (r1 != CAR (r2))
1608         {
1609           CAR (r2) = r1;
1610           r1 = r2;
1611           continue;
1612         }
1613       r1 = r2;
1614       expand_variable (CAR (r1), cell_nil);
1615       push_cc (CAR (r1), r1, r0, cell_vm_begin_expand_eval);
1616       goto eval;
1617     begin_expand_eval:
1618       x = r1;
1619       r1 = CDR (r2);
1620     }
1621   r1 = x;
1622   goto vm_return;
1623
1624  vm_if:
1625   push_cc (CAR (r1), r1, r0, cell_vm_if_expr);
1626   goto eval;
1627  if_expr:
1628   x = r1;
1629   r1 = r2;
1630   if (x != cell_f)
1631     {
1632       r1 = CADR (r1);
1633       goto eval;
1634     }
1635   if (CDDR (r1) != cell_nil)
1636     {
1637       r1 = CAR (CDDR (r1));
1638       goto eval;
1639     }
1640   r1 = cell_unspecified;
1641   goto vm_return;
1642
1643  call_with_current_continuation:
1644   gc_push_frame ();
1645   x = MAKE_CONTINUATION (g_continuations++);
1646   v = make_vector__ (STACK_SIZE-g_stack);
1647   for (t=g_stack; t < STACK_SIZE; t++)
1648     vector_set_x_ (v, t-g_stack, g_stack_array[t]);
1649   CONTINUATION (x) = v;
1650   gc_pop_frame ();
1651   push_cc (cons (CAR (r1), cons (x, cell_nil)), x, r0, cell_vm_call_with_current_continuation2);
1652   goto apply;
1653  call_with_current_continuation2:
1654   v = make_vector__ (STACK_SIZE-g_stack);
1655   for (t=g_stack; t < STACK_SIZE; t++)
1656     vector_set_x_ (v, t-g_stack, g_stack_array[t]);
1657   CONTINUATION (r2) = v;
1658   goto vm_return;
1659
1660  call_with_values:
1661   push_cc (cons (CAR (r1), cell_nil), r1, r0, cell_vm_call_with_values2);
1662   goto apply;
1663  call_with_values2:
1664   if (TYPE (r1) == TVALUES)
1665     r1 = CDR (r1);
1666   r1 = cons (CADR (r2), r1);
1667   goto apply;
1668
1669  vm_return:
1670   x = r1;
1671   gc_pop_frame ();
1672   r1 = x;
1673   goto eval_apply;
1674 }
1675
1676 SCM
1677 apply (SCM f, SCM x, SCM a) ///((internal))
1678 {
1679   push_cc (cons (f, x), cell_unspecified, r0, cell_unspecified);
1680   r3 = cell_vm_apply;
1681   return eval_apply ();
1682 }
1683
1684 SCM
1685 mes_g_stack (SCM a) ///((internal))
1686 {
1687   //g_stack = g_free + ARENA_SIZE;
1688   g_stack = STACK_SIZE;
1689   r0 = a;
1690   r1 = MAKE_CHAR (0);
1691   r2 = MAKE_CHAR (0);
1692   r3 = MAKE_CHAR (0);
1693   return r0;
1694 }
1695
1696 //\f Environment setup
1697
1698 #include "src/hash.c"
1699 #include "src/module.c"
1700 #include "src/posix.c"
1701 #include "src/math.c"
1702 #include "src/lib.c"
1703
1704 //\f Jam Collector
1705 SCM g_symbol_max;
1706
1707 SCM
1708 gc_init_cells () ///((internal))
1709 {
1710   long arena_bytes = (ARENA_SIZE+JAM_SIZE)*sizeof (struct scm);
1711   void *p = malloc (arena_bytes+STACK_SIZE*sizeof (SCM));
1712   g_cells = (struct scm *)p;
1713   g_stack_array = (SCM*)(p + arena_bytes);
1714
1715   TYPE (0) = TVECTOR;
1716   LENGTH (0) = 1000;
1717   VECTOR (0) = 0;
1718   g_cells++;
1719   TYPE (0) = TCHAR;
1720   VALUE (0) = 'c';
1721   return 0;
1722 }
1723
1724 SCM
1725 mes_symbols () ///((internal))
1726 {
1727   gc_init_cells ();
1728
1729 #if MES_MINI
1730
1731 g_free++;
1732 g_cells[cell_nil] = scm_nil;
1733
1734 g_free++;
1735 g_cells[cell_f] = scm_f;
1736
1737 g_free++;
1738 g_cells[cell_t] = scm_t;
1739
1740 g_free++;
1741 g_cells[cell_dot] = scm_dot;
1742
1743 g_free++;
1744 g_cells[cell_arrow] = scm_arrow;
1745
1746 g_free++;
1747 g_cells[cell_undefined] = scm_undefined;
1748
1749 g_free++;
1750 g_cells[cell_unspecified] = scm_unspecified;
1751
1752 g_free++;
1753 g_cells[cell_closure] = scm_closure;
1754
1755 g_free++;
1756 g_cells[cell_circular] = scm_circular;
1757
1758 g_free++;
1759 g_cells[cell_begin] = scm_begin;
1760
1761 g_free++;
1762 g_cells[cell_symbol_dot] = scm_symbol_dot;
1763
1764 g_free++;
1765 g_cells[cell_symbol_lambda] = scm_symbol_lambda;
1766
1767 g_free++;
1768 g_cells[cell_symbol_begin] = scm_symbol_begin;
1769
1770 g_free++;
1771 g_cells[cell_symbol_if] = scm_symbol_if;
1772
1773 g_free++;
1774 g_cells[cell_symbol_quote] = scm_symbol_quote;
1775
1776 g_free++;
1777 g_cells[cell_symbol_define] = scm_symbol_define;
1778
1779 g_free++;
1780 g_cells[cell_symbol_define_macro] = scm_symbol_define_macro;
1781
1782 g_free++;
1783 g_cells[cell_symbol_quasiquote] = scm_symbol_quasiquote;
1784
1785 g_free++;
1786 g_cells[cell_symbol_unquote] = scm_symbol_unquote;
1787
1788 g_free++;
1789 g_cells[cell_symbol_unquote_splicing] = scm_symbol_unquote_splicing;
1790
1791 g_free++;
1792 g_cells[cell_symbol_syntax] = scm_symbol_syntax;
1793
1794 g_free++;
1795 g_cells[cell_symbol_quasisyntax] = scm_symbol_quasisyntax;
1796
1797 g_free++;
1798 g_cells[cell_symbol_unsyntax] = scm_symbol_unsyntax;
1799
1800 g_free++;
1801 g_cells[cell_symbol_unsyntax_splicing] = scm_symbol_unsyntax_splicing;
1802
1803 g_free++;
1804 g_cells[cell_symbol_set_x] = scm_symbol_set_x;
1805
1806 g_free++;
1807 g_cells[cell_symbol_sc_expand] = scm_symbol_sc_expand;
1808
1809 g_free++;
1810 g_cells[cell_symbol_macro_expand] = scm_symbol_macro_expand;
1811
1812 g_free++;
1813 g_cells[cell_symbol_portable_macro_expand] = scm_symbol_portable_macro_expand;
1814
1815 g_free++;
1816 g_cells[cell_symbol_sc_expander_alist] = scm_symbol_sc_expander_alist;
1817
1818 g_free++;
1819 g_cells[cell_symbol_call_with_values] = scm_symbol_call_with_values;
1820
1821 g_free++;
1822 g_cells[cell_call_with_current_continuation] = scm_call_with_current_continuation;
1823
1824 g_free++;
1825 g_cells[cell_symbol_call_with_current_continuation] = scm_symbol_call_with_current_continuation;
1826
1827 g_free++;
1828 g_cells[cell_symbol_boot_module] = scm_symbol_boot_module;
1829
1830 g_free++;
1831 g_cells[cell_symbol_current_module] = scm_symbol_current_module;
1832
1833 g_free++;
1834 g_cells[cell_symbol_primitive_load] = scm_symbol_primitive_load;
1835
1836 g_free++;
1837 g_cells[cell_symbol_read_input_file] = scm_symbol_read_input_file;
1838
1839 g_free++;
1840 g_cells[cell_symbol_write] = scm_symbol_write;
1841
1842 g_free++;
1843 g_cells[cell_symbol_display] = scm_symbol_display;
1844
1845 g_free++;
1846 g_cells[cell_symbol_throw] = scm_symbol_throw;
1847
1848 g_free++;
1849 g_cells[cell_symbol_not_a_number] = scm_symbol_not_a_number;
1850
1851 g_free++;
1852 g_cells[cell_symbol_not_a_pair] = scm_symbol_not_a_pair;
1853
1854 g_free++;
1855 g_cells[cell_symbol_system_error] = scm_symbol_system_error;
1856
1857 g_free++;
1858 g_cells[cell_symbol_wrong_number_of_args] = scm_symbol_wrong_number_of_args;
1859
1860 g_free++;
1861 g_cells[cell_symbol_wrong_type_arg] = scm_symbol_wrong_type_arg;
1862
1863 g_free++;
1864 g_cells[cell_symbol_unbound_variable] = scm_symbol_unbound_variable;
1865
1866 g_free++;
1867 g_cells[cell_symbol_hashq_table] = scm_symbol_hashq_table;
1868
1869 g_free++;
1870 g_cells[cell_symbol_record_type] = scm_symbol_record_type;
1871
1872 g_free++;
1873 g_cells[cell_symbol_frame] = scm_symbol_frame;
1874
1875 g_free++;
1876 g_cells[cell_symbol_module] = scm_symbol_module;
1877
1878 g_free++;
1879 g_cells[cell_symbol_stack] = scm_symbol_stack;
1880
1881 g_free++;
1882 g_cells[cell_symbol_buckets] = scm_symbol_buckets;
1883
1884 g_free++;
1885 g_cells[cell_symbol_procedure] = scm_symbol_procedure;
1886
1887 g_free++;
1888 g_cells[cell_symbol_size] = scm_symbol_size;
1889
1890 g_free++;
1891 g_cells[cell_symbol_argv] = scm_symbol_argv;
1892
1893 g_free++;
1894 g_cells[cell_symbol_mes_prefix] = scm_symbol_mes_prefix;
1895
1896 g_free++;
1897 g_cells[cell_symbol_mes_version] = scm_symbol_mes_version;
1898
1899 g_free++;
1900 g_cells[cell_symbol_car] = scm_symbol_car;
1901
1902 g_free++;
1903 g_cells[cell_symbol_cdr] = scm_symbol_cdr;
1904
1905 g_free++;
1906 g_cells[cell_symbol_pmatch_car] = scm_symbol_pmatch_car;
1907
1908 g_free++;
1909 g_cells[cell_symbol_pmatch_cdr] = scm_symbol_pmatch_cdr;
1910
1911 g_free++;
1912 g_cells[cell_vm_evlis] = scm_vm_evlis;
1913
1914 g_free++;
1915 g_cells[cell_vm_evlis2] = scm_vm_evlis2;
1916
1917 g_free++;
1918 g_cells[cell_vm_evlis3] = scm_vm_evlis3;
1919
1920 g_free++;
1921 g_cells[cell_vm_apply] = scm_vm_apply;
1922
1923 g_free++;
1924 g_cells[cell_vm_apply2] = scm_vm_apply2;
1925
1926 g_free++;
1927 g_cells[cell_vm_eval] = scm_vm_eval;
1928
1929 g_free++;
1930 g_cells[cell_vm_eval_pmatch_car] = scm_vm_eval_pmatch_car;
1931
1932 g_free++;
1933 g_cells[cell_vm_eval_pmatch_cdr] = scm_vm_eval_pmatch_cdr;
1934
1935 g_free++;
1936 g_cells[cell_vm_eval_define] = scm_vm_eval_define;
1937
1938 g_free++;
1939 g_cells[cell_vm_eval_set_x] = scm_vm_eval_set_x;
1940
1941 g_free++;
1942 g_cells[cell_vm_eval_macro_expand_eval] = scm_vm_eval_macro_expand_eval;
1943
1944 g_free++;
1945 g_cells[cell_vm_eval_macro_expand_expand] = scm_vm_eval_macro_expand_expand;
1946
1947 g_free++;
1948 g_cells[cell_vm_eval_check_func] = scm_vm_eval_check_func;
1949
1950 g_free++;
1951 g_cells[cell_vm_eval2] = scm_vm_eval2;
1952
1953 g_free++;
1954 g_cells[cell_vm_macro_expand] = scm_vm_macro_expand;
1955
1956 g_free++;
1957 g_cells[cell_vm_macro_expand_define] = scm_vm_macro_expand_define;
1958
1959 g_free++;
1960 g_cells[cell_vm_macro_expand_define_macro] = scm_vm_macro_expand_define_macro;
1961
1962 g_free++;
1963 g_cells[cell_vm_macro_expand_lambda] = scm_vm_macro_expand_lambda;
1964
1965 g_free++;
1966 g_cells[cell_vm_macro_expand_set_x] = scm_vm_macro_expand_set_x;
1967
1968 g_free++;
1969 g_cells[cell_vm_begin_expand_primitive_load] = scm_vm_begin_expand_primitive_load;
1970
1971 g_free++;
1972 g_cells[cell_vm_begin_primitive_load] = scm_vm_begin_primitive_load;
1973
1974 g_free++;
1975 g_cells[cell_vm_macro_expand_car] = scm_vm_macro_expand_car;
1976
1977 g_free++;
1978 g_cells[cell_vm_macro_expand_cdr] = scm_vm_macro_expand_cdr;
1979
1980 g_free++;
1981 g_cells[cell_vm_begin_expand] = scm_vm_begin_expand;
1982
1983 g_free++;
1984 g_cells[cell_vm_begin_expand_eval] = scm_vm_begin_expand_eval;
1985
1986 g_free++;
1987 g_cells[cell_vm_begin_expand_macro] = scm_vm_begin_expand_macro;
1988
1989 g_free++;
1990 g_cells[cell_vm_begin] = scm_vm_begin;
1991
1992 g_free++;
1993 g_cells[cell_vm_begin_read_input_file] = scm_vm_begin_read_input_file;
1994
1995 g_free++;
1996 g_cells[cell_vm_begin_eval] = scm_vm_begin_eval;
1997
1998 g_free++;
1999 g_cells[cell_vm_if] = scm_vm_if;
2000
2001 g_free++;
2002 g_cells[cell_vm_if_expr] = scm_vm_if_expr;
2003
2004 g_free++;
2005 g_cells[cell_vm_call_with_values2] = scm_vm_call_with_values2;
2006
2007 g_free++;
2008 g_cells[cell_vm_call_with_current_continuation2] = scm_vm_call_with_current_continuation2;
2009
2010 g_free++;
2011 g_cells[cell_vm_return] = scm_vm_return;
2012
2013 g_free++;
2014 g_cells[cell_type_bytes] = scm_type_bytes;
2015
2016 g_free++;
2017 g_cells[cell_type_char] = scm_type_char;
2018
2019 g_free++;
2020 g_cells[cell_type_closure] = scm_type_closure;
2021
2022 g_free++;
2023 g_cells[cell_type_continuation] = scm_type_continuation;
2024
2025 g_free++;
2026 g_cells[cell_type_function] = scm_type_function;
2027
2028 g_free++;
2029 g_cells[cell_type_keyword] = scm_type_keyword;
2030
2031 g_free++;
2032 g_cells[cell_type_macro] = scm_type_macro;
2033
2034 g_free++;
2035 g_cells[cell_type_number] = scm_type_number;
2036
2037 g_free++;
2038 g_cells[cell_type_pair] = scm_type_pair;
2039
2040 g_free++;
2041 g_cells[cell_type_port] = scm_type_port;
2042
2043 g_free++;
2044 g_cells[cell_type_ref] = scm_type_ref;
2045
2046 g_free++;
2047 g_cells[cell_type_special] = scm_type_special;
2048
2049 g_free++;
2050 g_cells[cell_type_string] = scm_type_string;
2051
2052 g_free++;
2053 g_cells[cell_type_struct] = scm_type_struct;
2054
2055 g_free++;
2056 g_cells[cell_type_symbol] = scm_type_symbol;
2057
2058 g_free++;
2059 g_cells[cell_type_values] = scm_type_values;
2060
2061 g_free++;
2062 g_cells[cell_type_variable] = scm_type_variable;
2063
2064 g_free++;
2065 g_cells[cell_type_vector] = scm_type_vector;
2066
2067 g_free++;
2068 g_cells[cell_type_broken_heart] = scm_type_broken_heart;
2069
2070 g_free++;
2071 g_cells[cell_symbol_internal_time_units_per_second] = scm_symbol_internal_time_units_per_second;
2072
2073 g_free++;
2074 g_cells[cell_symbol_compiler] = scm_symbol_compiler;
2075
2076 g_free++;
2077 g_cells[cell_symbol_arch] = scm_symbol_arch;
2078
2079 g_free++;
2080 g_cells[cell_test] = scm_test;
2081
2082 #elif !POSIX
2083 #include "src/mes.mes.symbols.i"
2084 #else
2085 #include "src/mes.symbols.i"
2086 #endif
2087
2088 g_symbol_max = g_free++;
2089
2090 #if MES_MINI
2091
2092 #if !POSIX
2093  #define name cdr
2094 #endif
2095
2096 NAME_SYMBOL (cell_nil, scm_nil.name);
2097 NAME_SYMBOL (cell_f, scm_f.name);
2098 NAME_SYMBOL (cell_t, scm_t.name);
2099 NAME_SYMBOL (cell_dot, scm_dot.name);
2100 NAME_SYMBOL (cell_arrow, scm_arrow.name);
2101 NAME_SYMBOL (cell_undefined, scm_undefined.name);
2102 NAME_SYMBOL (cell_unspecified, scm_unspecified.name);
2103 NAME_SYMBOL (cell_closure, scm_closure.name);
2104 NAME_SYMBOL (cell_circular, scm_circular.name);
2105 NAME_SYMBOL (cell_begin, scm_begin.name);
2106 NAME_SYMBOL (cell_symbol_dot, scm_symbol_dot.name);
2107 NAME_SYMBOL (cell_symbol_lambda, scm_symbol_lambda.name);
2108 NAME_SYMBOL (cell_symbol_begin, scm_symbol_begin.name);
2109 NAME_SYMBOL (cell_symbol_if, scm_symbol_if.name);
2110 NAME_SYMBOL (cell_symbol_quote, scm_symbol_quote.name);
2111 NAME_SYMBOL (cell_symbol_define, scm_symbol_define.name);
2112 NAME_SYMBOL (cell_symbol_define_macro, scm_symbol_define_macro.name);
2113 NAME_SYMBOL (cell_symbol_quasiquote, scm_symbol_quasiquote.name);
2114 NAME_SYMBOL (cell_symbol_unquote, scm_symbol_unquote.name);
2115 NAME_SYMBOL (cell_symbol_unquote_splicing, scm_symbol_unquote_splicing.name);
2116 NAME_SYMBOL (cell_symbol_syntax, scm_symbol_syntax.name);
2117 NAME_SYMBOL (cell_symbol_quasisyntax, scm_symbol_quasisyntax.name);
2118 NAME_SYMBOL (cell_symbol_unsyntax, scm_symbol_unsyntax.name);
2119 NAME_SYMBOL (cell_symbol_unsyntax_splicing, scm_symbol_unsyntax_splicing.name);
2120 NAME_SYMBOL (cell_symbol_set_x, scm_symbol_set_x.name);
2121 NAME_SYMBOL (cell_symbol_sc_expand, scm_symbol_sc_expand.name);
2122 NAME_SYMBOL (cell_symbol_macro_expand, scm_symbol_macro_expand.name);
2123 NAME_SYMBOL (cell_symbol_portable_macro_expand, scm_symbol_portable_macro_expand.name);
2124 NAME_SYMBOL (cell_symbol_sc_expander_alist, scm_symbol_sc_expander_alist.name);
2125 NAME_SYMBOL (cell_symbol_call_with_values, scm_symbol_call_with_values.name);
2126 NAME_SYMBOL (cell_call_with_current_continuation, scm_call_with_current_continuation.name);
2127 NAME_SYMBOL (cell_symbol_call_with_current_continuation, scm_symbol_call_with_current_continuation.name);
2128 NAME_SYMBOL (cell_symbol_boot_module, scm_symbol_boot_module.name);
2129 NAME_SYMBOL (cell_symbol_current_module, scm_symbol_current_module.name);
2130 NAME_SYMBOL (cell_symbol_primitive_load, scm_symbol_primitive_load.name);
2131 NAME_SYMBOL (cell_symbol_read_input_file, scm_symbol_read_input_file.name);
2132 NAME_SYMBOL (cell_symbol_write, scm_symbol_write.name);
2133 NAME_SYMBOL (cell_symbol_display, scm_symbol_display.name);
2134 NAME_SYMBOL (cell_symbol_throw, scm_symbol_throw.name);
2135 NAME_SYMBOL (cell_symbol_not_a_number, scm_symbol_not_a_number.name);
2136 NAME_SYMBOL (cell_symbol_not_a_pair, scm_symbol_not_a_pair.name);
2137 NAME_SYMBOL (cell_symbol_system_error, scm_symbol_system_error.name);
2138 NAME_SYMBOL (cell_symbol_wrong_number_of_args, scm_symbol_wrong_number_of_args.name);
2139 NAME_SYMBOL (cell_symbol_wrong_type_arg, scm_symbol_wrong_type_arg.name);
2140 NAME_SYMBOL (cell_symbol_unbound_variable, scm_symbol_unbound_variable.name);
2141 NAME_SYMBOL (cell_symbol_hashq_table, scm_symbol_hashq_table.name);
2142 NAME_SYMBOL (cell_symbol_record_type, scm_symbol_record_type.name);
2143 NAME_SYMBOL (cell_symbol_frame, scm_symbol_frame.name);
2144 NAME_SYMBOL (cell_symbol_module, scm_symbol_module.name);
2145 NAME_SYMBOL (cell_symbol_stack, scm_symbol_stack.name);
2146 NAME_SYMBOL (cell_symbol_buckets, scm_symbol_buckets.name);
2147 NAME_SYMBOL (cell_symbol_procedure, scm_symbol_procedure.name);
2148 NAME_SYMBOL (cell_symbol_size, scm_symbol_size.name);
2149 NAME_SYMBOL (cell_symbol_argv, scm_symbol_argv.name);
2150 NAME_SYMBOL (cell_symbol_mes_prefix, scm_symbol_mes_prefix.name);
2151 NAME_SYMBOL (cell_symbol_mes_version, scm_symbol_mes_version.name);
2152 NAME_SYMBOL (cell_symbol_car, scm_symbol_car.name);
2153 NAME_SYMBOL (cell_symbol_cdr, scm_symbol_cdr.name);
2154 NAME_SYMBOL (cell_symbol_pmatch_car, scm_symbol_pmatch_car.name);
2155 NAME_SYMBOL (cell_symbol_pmatch_cdr, scm_symbol_pmatch_cdr.name);
2156 NAME_SYMBOL (cell_vm_evlis, scm_vm_evlis.name);
2157 NAME_SYMBOL (cell_vm_evlis2, scm_vm_evlis2.name);
2158 NAME_SYMBOL (cell_vm_evlis3, scm_vm_evlis3.name);
2159 NAME_SYMBOL (cell_vm_apply, scm_vm_apply.name);
2160 NAME_SYMBOL (cell_vm_apply2, scm_vm_apply2.name);
2161 NAME_SYMBOL (cell_vm_eval, scm_vm_eval.name);
2162 NAME_SYMBOL (cell_vm_eval_pmatch_car, scm_vm_eval_pmatch_car.name);
2163 NAME_SYMBOL (cell_vm_eval_pmatch_cdr, scm_vm_eval_pmatch_cdr.name);
2164 NAME_SYMBOL (cell_vm_eval_define, scm_vm_eval_define.name);
2165 NAME_SYMBOL (cell_vm_eval_set_x, scm_vm_eval_set_x.name);
2166 NAME_SYMBOL (cell_vm_eval_macro_expand_eval, scm_vm_eval_macro_expand_eval.name);
2167 NAME_SYMBOL (cell_vm_eval_macro_expand_expand, scm_vm_eval_macro_expand_expand.name);
2168 NAME_SYMBOL (cell_vm_eval_check_func, scm_vm_eval_check_func.name);
2169 NAME_SYMBOL (cell_vm_eval2, scm_vm_eval2.name);
2170 NAME_SYMBOL (cell_vm_macro_expand, scm_vm_macro_expand.name);
2171 NAME_SYMBOL (cell_vm_macro_expand_define, scm_vm_macro_expand_define.name);
2172 NAME_SYMBOL (cell_vm_macro_expand_define_macro, scm_vm_macro_expand_define_macro.name);
2173 NAME_SYMBOL (cell_vm_macro_expand_lambda, scm_vm_macro_expand_lambda.name);
2174 NAME_SYMBOL (cell_vm_macro_expand_set_x, scm_vm_macro_expand_set_x.name);
2175 NAME_SYMBOL (cell_vm_begin_expand_primitive_load, scm_vm_begin_expand_primitive_load.name);
2176 NAME_SYMBOL (cell_vm_begin_primitive_load, scm_vm_begin_primitive_load.name);
2177 NAME_SYMBOL (cell_vm_macro_expand_car, scm_vm_macro_expand_car.name);
2178 NAME_SYMBOL (cell_vm_macro_expand_cdr, scm_vm_macro_expand_cdr.name);
2179 NAME_SYMBOL (cell_vm_begin_expand, scm_vm_begin_expand.name);
2180 NAME_SYMBOL (cell_vm_begin_expand_eval, scm_vm_begin_expand_eval.name);
2181 NAME_SYMBOL (cell_vm_begin_expand_macro, scm_vm_begin_expand_macro.name);
2182 NAME_SYMBOL (cell_vm_begin, scm_vm_begin.name);
2183 NAME_SYMBOL (cell_vm_begin_read_input_file, scm_vm_begin_read_input_file.name);
2184 NAME_SYMBOL (cell_vm_begin_eval, scm_vm_begin_eval.name);
2185 NAME_SYMBOL (cell_vm_if, scm_vm_if.name);
2186 NAME_SYMBOL (cell_vm_if_expr, scm_vm_if_expr.name);
2187 NAME_SYMBOL (cell_vm_call_with_values2, scm_vm_call_with_values2.name);
2188 NAME_SYMBOL (cell_vm_call_with_current_continuation2, scm_vm_call_with_current_continuation2.name);
2189 NAME_SYMBOL (cell_vm_return, scm_vm_return.name);
2190 NAME_SYMBOL (cell_type_bytes, scm_type_bytes.name);
2191 NAME_SYMBOL (cell_type_char, scm_type_char.name);
2192 NAME_SYMBOL (cell_type_closure, scm_type_closure.name);
2193 NAME_SYMBOL (cell_type_continuation, scm_type_continuation.name);
2194 NAME_SYMBOL (cell_type_function, scm_type_function.name);
2195 NAME_SYMBOL (cell_type_keyword, scm_type_keyword.name);
2196 NAME_SYMBOL (cell_type_macro, scm_type_macro.name);
2197 NAME_SYMBOL (cell_type_number, scm_type_number.name);
2198 NAME_SYMBOL (cell_type_pair, scm_type_pair.name);
2199 NAME_SYMBOL (cell_type_port, scm_type_port.name);
2200 NAME_SYMBOL (cell_type_ref, scm_type_ref.name);
2201 NAME_SYMBOL (cell_type_special, scm_type_special.name);
2202 NAME_SYMBOL (cell_type_string, scm_type_string.name);
2203 NAME_SYMBOL (cell_type_struct, scm_type_struct.name);
2204 NAME_SYMBOL (cell_type_symbol, scm_type_symbol.name);
2205 NAME_SYMBOL (cell_type_values, scm_type_values.name);
2206 NAME_SYMBOL (cell_type_variable, scm_type_variable.name);
2207 NAME_SYMBOL (cell_type_vector, scm_type_vector.name);
2208 NAME_SYMBOL (cell_type_broken_heart, scm_type_broken_heart.name);
2209 NAME_SYMBOL (cell_symbol_internal_time_units_per_second, scm_symbol_internal_time_units_per_second.name);
2210 NAME_SYMBOL (cell_symbol_compiler, scm_symbol_compiler.name);
2211 NAME_SYMBOL (cell_symbol_arch, scm_symbol_arch.name);
2212 NAME_SYMBOL (cell_test, scm_test.name);
2213
2214 #if !POSIX
2215  #undef name
2216 #endif
2217
2218 #elif !POSIX
2219 #include "src/mes.mes.symbol-names.i"
2220 #else
2221 #include "src/mes.symbol-names.i"
2222 #endif
2223
2224   g_symbols = make_hash_table_ (500);
2225   for (int i=1; i<g_symbol_max; i++)
2226     hash_set_x (g_symbols, symbol_to_string (i), i);
2227
2228   SCM a = cell_nil;
2229   a = acons (cell_symbol_call_with_values, cell_symbol_call_with_values, a);
2230   a = acons (cell_symbol_boot_module, cell_symbol_boot_module, a);
2231   a = acons (cell_symbol_current_module, cell_symbol_current_module, a);
2232   a = acons (cell_symbol_call_with_current_continuation, cell_call_with_current_continuation, a);
2233
2234   a = acons (cell_symbol_mes_version, MAKE_STRING0 (VERSION), a);
2235   a = acons (cell_symbol_mes_prefix, MAKE_STRING0 (PREFIX), a);
2236
2237   a = acons (cell_type_bytes, MAKE_NUMBER (TBYTES), a);
2238   a = acons (cell_type_char, MAKE_NUMBER (TCHAR), a);
2239   a = acons (cell_type_closure, MAKE_NUMBER (TCLOSURE), a);
2240   a = acons (cell_type_continuation, MAKE_NUMBER (TCONTINUATION), a);
2241   a = acons (cell_type_function, MAKE_NUMBER (TFUNCTION), a);
2242   a = acons (cell_type_keyword, MAKE_NUMBER (TKEYWORD), a);
2243   a = acons (cell_type_macro, MAKE_NUMBER (TMACRO), a);
2244   a = acons (cell_type_number, MAKE_NUMBER (TNUMBER), a);
2245   a = acons (cell_type_pair, MAKE_NUMBER (TPAIR), a);
2246   a = acons (cell_type_port, MAKE_NUMBER (TPORT), a);
2247   a = acons (cell_type_ref, MAKE_NUMBER (TREF), a);
2248   a = acons (cell_type_special, MAKE_NUMBER (TSPECIAL), a);
2249   a = acons (cell_type_string, MAKE_NUMBER (TSTRING), a);
2250   a = acons (cell_type_struct, MAKE_NUMBER (TSTRUCT), a);
2251   a = acons (cell_type_symbol, MAKE_NUMBER (TSYMBOL), a);
2252   a = acons (cell_type_values, MAKE_NUMBER (TVALUES), a);
2253   a = acons (cell_type_variable, MAKE_NUMBER (TVARIABLE), a);
2254   a = acons (cell_type_vector, MAKE_NUMBER (TVECTOR), a);
2255   a = acons (cell_type_broken_heart, MAKE_NUMBER (TBROKEN_HEART), a);
2256
2257   a = acons (cell_closure, a, a);
2258
2259   return a;
2260 }
2261
2262 SCM
2263 mes_environment (int argc, char *argv[])
2264 {
2265   SCM a = mes_symbols ();
2266
2267   char *compiler = "gnuc";
2268 #if __MESC__
2269   compiler = "mesc";
2270 #elif __TINYC__
2271   compiler = "tcc";
2272 #endif
2273   a = acons (cell_symbol_compiler, MAKE_STRING0 (compiler), a);
2274
2275   char *arch = "x86";
2276 #if __x86_64__
2277   arch = "x86_64";
2278 #endif
2279   a = acons (cell_symbol_arch, MAKE_STRING0 (arch), a);
2280
2281 #if !MES_MINI
2282   SCM lst = cell_nil;
2283   for (int i=argc-1; i>=0; i--)
2284     lst = cons (MAKE_STRING0 (argv[i]), lst);
2285   a = acons (cell_symbol_argv, lst, a);
2286 #endif
2287
2288   return mes_g_stack (a);
2289 }
2290
2291 SCM
2292 mes_builtins (SCM a) ///((internal))
2293 {
2294 #if MES_MINI
2295
2296 #if !POSIX
2297  #define function car
2298 #endif
2299
2300 //mes
2301 scm_cons.function = g_function;
2302 g_functions[g_function++] = fun_cons;
2303 cell_cons = g_free++;
2304 g_cells[cell_cons] = scm_cons;
2305
2306 scm_car.function = g_function;
2307 g_functions[g_function++] = fun_car;
2308 cell_car = g_free++;
2309 g_cells[cell_car] = scm_car;
2310
2311 scm_cdr.function = g_function;
2312 g_functions[g_function++] = fun_cdr;
2313 cell_cdr = g_free++;
2314 g_cells[cell_cdr] = scm_cdr;
2315
2316 scm_list.function = g_function;
2317 g_functions[g_function++] = fun_list;
2318 cell_list = g_free++;
2319 g_cells[cell_list] = scm_list;
2320
2321 scm_null_p.function = g_function;
2322 g_functions[g_function++] = fun_null_p;
2323 cell_null_p = g_free++;
2324 g_cells[cell_null_p] = scm_null_p;
2325
2326 scm_eq_p.function = g_function;
2327 g_functions[g_function++] = fun_eq_p;
2328 cell_eq_p = g_free++;
2329 g_cells[cell_eq_p] = scm_eq_p;
2330
2331 //math
2332 scm_minus.function = g_function;
2333 g_functions[g_function++] = fun_minus;
2334 cell_minus = g_free++;
2335 g_cells[cell_minus] = scm_minus;
2336
2337 scm_plus.function = g_function;
2338 g_functions[g_function++] = fun_plus;
2339 cell_plus = g_free++;
2340 g_cells[cell_plus] = scm_plus;
2341
2342 //lib
2343 scm_display_.function = g_function;
2344 g_functions[g_function++] = fun_display_;
2345 cell_display_ = g_free++;
2346 g_cells[cell_display_] = scm_display_;
2347
2348 scm_display_error_.function = g_function;
2349 g_functions[g_function++] = fun_display_error_;
2350 cell_display_error_ = g_free++;
2351 g_cells[cell_display_error_] = scm_display_error_;
2352
2353 //posix
2354 scm_getenv_.function = g_function;
2355 g_functions[g_function++] = fun_getenv_;
2356 cell_getenv_ = g_free++;
2357 g_cells[cell_getenv_] = scm_getenv_;
2358
2359 #if !POSIX
2360  #undef name
2361  #define string cdr
2362 #endif
2363
2364 //mes.environment
2365 scm_cons.string = MAKE_BYTES0 (fun_cons.name);
2366 a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_cons)), cell_cons, a);
2367
2368 scm_car.string = MAKE_BYTES0 (fun_car.name);
2369 a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_car)), cell_car, a);
2370
2371 scm_cdr.string = MAKE_BYTES0 (fun_cdr.name);
2372 a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_cdr)), cell_cdr, a);
2373
2374 scm_list.string = MAKE_BYTES0 (fun_list.name);
2375 a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_list)), cell_list, a);
2376
2377 scm_null_p.string = MAKE_BYTES0 (fun_null_p.name);
2378 a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_null_p)), cell_null_p, a);
2379
2380 scm_eq_p.string = MAKE_BYTES0 (fun_eq_p.name);
2381  a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_eq_p)), cell_eq_p, a);
2382
2383 //math.environment
2384 scm_minus.string = MAKE_BYTES0 (fun_minus.name);
2385 a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_minus)), cell_minus, a);
2386
2387 scm_plus.string = MAKE_BYTES0 (fun_plus.name);
2388 a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_plus)), cell_plus, a);
2389
2390 //lib.environment
2391 scm_display_.string = MAKE_BYTES0 (fun_display_.name);
2392 a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_display_)), cell_display_, a);
2393
2394 scm_display_error_.string = MAKE_BYTES0 (fun_display_error_.name);
2395 a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_display_error_)), cell_display_error_, a);
2396
2397 //posix.environment
2398 scm_getenv_.string = MAKE_BYTES0 (fun_getenv_.name);
2399 a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_getenv_)), cell_getenv_, a);
2400
2401 #if !POSIX
2402  #undef function
2403  #undef string
2404 #endif
2405
2406 #elif !__GNUC__ || !POSIX
2407 #include "src/mes.mes.i"
2408
2409   // Do not sort: Order of these includes define builtins
2410 #include "src/hash.mes.i"
2411 #include "src/module.mes.i"
2412 #include "src/posix.mes.i"
2413 #include "src/math.mes.i"
2414 #include "src/lib.mes.i"
2415 #include "src/vector.mes.i"
2416 #include "src/strings.mes.i"
2417 #include "src/struct.mes.i"
2418 #include "src/gc.mes.i"
2419 #include "src/reader.mes.i"
2420
2421 #include "src/gc.mes.environment.i"
2422 #include "src/hash.mes.environment.i"
2423 #include "src/lib.mes.environment.i"
2424 #include "src/math.mes.environment.i"
2425 #include "src/mes.mes.environment.i"
2426 #include "src/module.mes.environment.i"
2427 #include "src/posix.mes.environment.i"
2428 #include "src/reader.mes.environment.i"
2429 #include "src/strings.mes.environment.i"
2430 #include "src/struct.mes.environment.i"
2431 #include "src/vector.mes.environment.i"
2432 #else
2433 #include "src/mes.i"
2434
2435   // Do not sort: Order of these includes define builtins
2436 #include "src/hash.i"
2437 #include "src/module.i"
2438 #include "src/posix.i"
2439 #include "src/math.i"
2440 #include "src/lib.i"
2441 #include "src/vector.i"
2442 #include "src/strings.i"
2443 #include "src/struct.i"
2444 #include "src/gc.i"
2445 #include "src/reader.i"
2446
2447 #include "src/gc.environment.i"
2448 #include "src/hash.environment.i"
2449 #include "src/lib.environment.i"
2450 #include "src/math.environment.i"
2451 #include "src/mes.environment.i"
2452 #include "src/module.environment.i"
2453 #include "src/posix.environment.i"
2454 #include "src/reader.environment.i"
2455 #include "src/strings.environment.i"
2456 #include "src/struct.environment.i"
2457 #include "src/vector.environment.i"
2458 #endif
2459
2460   if (g_debug > 3)
2461     {
2462       fdputs ("functions: ", g_stderr);
2463       fdputs (itoa (g_function), g_stderr);
2464       fdputs ("\n", g_stderr);
2465       for (int i = 0; i < g_function; i++)
2466         {
2467           fdputs ("[", g_stderr);
2468           fdputs (itoa (i), g_stderr);
2469           fdputs ("]: ", g_stderr);
2470           fdputs (g_functions[i].name, g_stderr);
2471           fdputs ("\n", g_stderr);
2472         }
2473       fdputs ("\n", g_stderr);
2474     }
2475
2476   return a;
2477 }
2478
2479 SCM read_input_file_env (SCM);
2480
2481 int
2482 load_boot (char *prefix, char const *boot, char const *location)
2483 {
2484   strcpy (prefix + strlen (prefix), boot);
2485   if (g_debug > 1)
2486     {
2487       eputs ("mes: reading boot-0 [");
2488       eputs (location);
2489       eputs ("]: ");
2490       eputs (prefix);
2491       eputs ("\n");
2492     }
2493   int fd = open (prefix, O_RDONLY);
2494   if (g_debug && fd > 0)
2495     {
2496       eputs ("mes: read boot-0: ");
2497       eputs (prefix);
2498       eputs ("\n");
2499     }
2500   return fd;
2501 }
2502
2503 SCM
2504 load_env () ///((internal))
2505 {
2506   g_stdin = -1;
2507   char prefix[1024];
2508   char boot[1024];
2509   if (getenv ("MES_BOOT"))
2510     strcpy (boot, getenv ("MES_BOOT"));
2511   else
2512     strcpy (boot, "boot-0.scm");
2513   if (getenv ("MES_PREFIX"))
2514     {
2515       strcpy (prefix, getenv ("MES_PREFIX"));
2516       strcpy (prefix + strlen (prefix), "/module");
2517       strcpy (prefix + strlen (prefix), "/mes/");
2518       g_stdin = load_boot (prefix, boot, "MES_PREFIX");
2519     }
2520   if (g_stdin < 0)
2521     {
2522       char const *p = MODULEDIR "/mes/";
2523       strcpy (prefix, p);
2524       g_stdin = load_boot (prefix, boot, "MODULEDIR");
2525     }
2526   if (g_stdin < 0)
2527     {
2528       strcpy (prefix, "mes/module/mes/");
2529       g_stdin = load_boot (prefix, boot, ".");
2530     }
2531   if (g_stdin < 0)
2532     {
2533       prefix[0] = 0;
2534       g_stdin = load_boot (prefix, boot, "<boot>");
2535     }
2536   if (g_stdin < 0)
2537     {
2538       eputs ("mes: boot failed: no such file: ");
2539       eputs (boot);
2540       eputs ("\n");
2541       exit (1);
2542     }
2543
2544   r2 = read_input_file_env (r0);
2545   g_stdin = STDIN;
2546   return r2;
2547 }
2548
2549 SCM
2550 bload_env () ///((internal))
2551 {
2552 #if !POSIX
2553   char *mo = "mes/boot-0.32-mo";
2554   g_stdin = open ("module/mes/boot-0.32-mo", O_RDONLY);
2555   char *read0 = MODULEDIR "/mes/boot-0.32-mo";
2556   g_stdin = g_stdin >= 0 ? g_stdin : open (read0, O_RDONLY);
2557 #else
2558   char *mo ="mes/boot-0.mo";
2559   g_stdin = open ("module/mes/boot-0.mo", O_RDONLY);
2560   g_stdin = g_stdin >= 0 ? g_stdin : open (MODULEDIR "/mes/boot-0.mo", O_RDONLY);
2561 #endif
2562
2563   if (g_stdin < 0)
2564     {
2565       eputs ("no such file: ");
2566       eputs (mo);
2567       eputs ("\n");
2568       return 1;
2569     }
2570   assert (getchar () == 'M');
2571   assert (getchar () == 'E');
2572   assert (getchar () == 'S');
2573
2574   if (g_debug)
2575     eputs ("*GOT MES*\n");
2576   g_stack = getchar () << 8;
2577   g_stack += getchar ();
2578
2579   char *p = (char*)g_cells;
2580   int c = getchar ();
2581   while (c != EOF)
2582     {
2583       *p++ = c;
2584       c = getchar ();
2585     }
2586   g_free = (p-(char*)g_cells) / sizeof (struct scm);
2587   gc_peek_frame ();
2588   g_symbols = r1;
2589   g_stdin = STDIN;
2590   // SCM a = struct_ref (r0, 4);
2591   // a = mes_builtins (a);
2592   // struct_set_x (r0, 4, a);
2593   r0 = mes_builtins (r0);
2594
2595   if (g_debug > 3)
2596     {
2597       eputs ("symbols: ");
2598       write_error_ (g_symbols);
2599       eputs ("\n");
2600       eputs ("functions: ");
2601       eputs (itoa (g_function));
2602       eputs ("\n");
2603       for (int i = 0; i < g_function; i++)
2604         {
2605           eputs ("[");
2606           eputs (itoa (i));
2607           eputs ("]: ");
2608           eputs (g_functions[i].name);
2609           eputs ("\n");
2610         }
2611     }
2612   return r2;
2613 }
2614
2615 #include "src/vector.c"
2616 #include "src/strings.c"
2617 #include "src/struct.c"
2618 #include "src/gc.c"
2619 #include "src/reader.c"
2620
2621 int
2622 main (int argc, char *argv[])
2623 {
2624   char *p;
2625   if (p = getenv ("MES_DEBUG"))
2626     g_debug = atoi (p);
2627   if (g_debug > 1)
2628     {
2629       eputs (";;; MODULEDIR=");
2630       eputs (MODULEDIR);
2631       eputs ("\n");
2632     }
2633   if (p = getenv ("MES_MAX_ARENA"))
2634     MAX_ARENA_SIZE = atoi (p);
2635   if (p = getenv ("MES_ARENA"))
2636     ARENA_SIZE = atoi (p);
2637   JAM_SIZE = ARENA_SIZE / 10;
2638   if (p = getenv ("MES_JAM"))
2639     JAM_SIZE = atoi (p);
2640   GC_SAFETY = ARENA_SIZE / 100;
2641   if (p = getenv ("MES_SAFETY"))
2642     GC_SAFETY = atoi (p);
2643   if (p = getenv ("MES_STACK"))
2644     STACK_SIZE = atoi (p);
2645   g_stdin = STDIN;
2646   g_stdout = STDOUT;
2647   g_stderr = STDERR;
2648
2649   SCM a = mes_environment (argc, argv);
2650   a = mes_builtins (a);
2651   a = init_time (a);
2652   m0 = make_initial_module (a);
2653   g_macros = make_hash_table_ (0);
2654
2655   if (g_debug > 3)
2656     module_printer (m0);
2657
2658   SCM program = (argc > 1 && !strcmp (argv[1], "--load"))
2659     ? bload_env () : load_env ();
2660   g_tiny = argc > 2 && !strcmp (argv[2], "--tiny");
2661   if (argc > 1 && !strcmp (argv[1], "--dump"))
2662     return dump ();
2663
2664   push_cc (r2, cell_unspecified, r0, cell_unspecified);
2665
2666   if (g_debug > 2)
2667     {
2668       eputs ("\ngc stats: [");
2669       eputs (itoa (g_free));
2670       eputs ("]\n");
2671     }
2672   if (g_debug > 3)
2673     {
2674       eputs ("program: ");
2675       write_error_ (r1);
2676       eputs ("\n");
2677     }
2678   // if (g_debug > 3)
2679   //   {
2680   //     eputs ("symbols: ");
2681   //     write_error_ (g_symbols);
2682   //     eputs ("\n");
2683   //   }
2684   r3 = cell_vm_begin_expand;
2685   r1 = eval_apply ();
2686   if (g_debug)
2687     {
2688       write_error_ (r1);
2689       eputs ("\n");
2690     }
2691   if (g_debug)
2692     {
2693       if (g_debug > 3)
2694         module_printer (m0);
2695
2696       eputs ("\ngc stats: [");
2697       eputs (itoa (g_free));
2698       MAX_ARENA_SIZE = 0;
2699
2700       gc (g_stack);
2701       eputs (" => ");
2702       eputs (itoa (g_free));
2703       eputs ("]\n");
2704       if (g_debug > 3)
2705         module_printer (m0);
2706       eputs ("\n");
2707
2708       gc (g_stack);
2709       eputs (" => ");
2710       eputs (itoa (g_free));
2711       eputs ("]\n");
2712       if (g_debug > 3)
2713         module_printer (m0);
2714       eputs ("\n");
2715
2716       gc (g_stack);
2717       eputs (" => ");
2718       eputs (itoa (g_free));
2719       eputs ("]\n");
2720       if (g_debug > 3)
2721         module_printer (m0);
2722       if (g_debug > 3)
2723         {
2724           eputs ("ports:"); write_error_ (g_ports); eputs ("\n");
2725         }
2726       eputs ("\n");
2727
2728
2729     }
2730   return 0;
2731 }