e1752c9470fae3dd07d6d5014f047c44b0b9790f
[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   push_cc (CAR (r1), r1, r0, cell_vm_apply2);
1262   goto eval;
1263  apply2:
1264   check_apply (r1, CAR (r2));
1265   r1 = cons (r1, CDR (r2));
1266   goto apply;
1267
1268  eval:
1269   t = TYPE (r1);
1270   if (t == TPAIR)
1271     {
1272       c = CAR (r1);
1273       if (c ==  cell_symbol_pmatch_car)
1274         {
1275           push_cc (CADR (r1), r1, r0, cell_vm_eval_pmatch_car);
1276           goto eval;
1277         eval_pmatch_car:
1278           x = r1;
1279           gc_pop_frame ();
1280           r1 = CAR (x);
1281           goto eval_apply;
1282         }
1283       else if (c ==  cell_symbol_pmatch_cdr)
1284         {
1285           push_cc (CADR (r1), r1, r0, cell_vm_eval_pmatch_cdr);
1286           goto eval;
1287         eval_pmatch_cdr:
1288           x = r1;
1289           gc_pop_frame ();
1290           r1 = CDR (x);
1291           goto eval_apply;
1292         }
1293       else if (c ==  cell_symbol_quote)
1294         {
1295           x = r1;
1296           gc_pop_frame ();
1297           r1 = CADR (x);
1298           goto eval_apply;
1299         }
1300       else if (c ==  cell_symbol_begin)
1301         goto begin;
1302       else if (c ==  cell_symbol_lambda)
1303         {
1304           r1 = make_closure_ (CADR (r1), CDDR (r1), r0);
1305           goto vm_return;
1306         }
1307       else if (c ==  cell_symbol_if)
1308         {
1309           r1=CDR (r1);
1310           goto vm_if;
1311         }
1312       else if (c ==  cell_symbol_set_x)
1313         {
1314           push_cc (CAR (CDDR (r1)), r1, r0, cell_vm_eval_set_x);
1315           goto eval;
1316         eval_set_x:
1317           r1 = set_env_x (CADR (r2), r1, r0);
1318           goto vm_return;
1319         }
1320       else if (c == cell_vm_macro_expand)
1321         {
1322           push_cc (CADR (r1), r1, r0, cell_vm_eval_macro_expand_eval);
1323           goto eval;
1324         eval_macro_expand_eval:
1325           push_cc (r1, r2, r0, cell_vm_eval_macro_expand_expand);
1326           goto macro_expand;
1327         eval_macro_expand_expand:
1328           goto vm_return;
1329         }
1330       else
1331         {
1332           if (TYPE (r1) == TPAIR
1333               && (CAR (r1) == cell_symbol_define
1334                   || CAR (r1) == cell_symbol_define_macro))
1335             {
1336               global_p = CAAR (r0) != cell_closure;
1337               macro_p = CAR (r1) == cell_symbol_define_macro;
1338               if (global_p)
1339                 {
1340                   name = CADR (r1);
1341                   if (TYPE (CADR (r1)) == TPAIR)
1342                     name = CAR (name);
1343                   if (macro_p)
1344                     {
1345                       entry = assq (name, g_macros);
1346                       if (entry == cell_f)
1347                         macro_set_x (name, cell_f);
1348                     }
1349                   else
1350                     {
1351                       entry = module_variable (r0, name);
1352                       if (entry == cell_f)
1353                         module_define_x (m0, name, cell_f);
1354                     }
1355                 }
1356               r2 = r1;
1357               if (TYPE (CADR (r1)) != TPAIR)
1358                 {
1359                   push_cc (CAR (CDDR (r1)), r2, cons (cons (CADR (r1), CADR (r1)), r0), cell_vm_eval_define);
1360                   goto eval;
1361                 }
1362               else
1363                 {
1364                   p = pairlis (CADR (r1), CADR (r1), r0);
1365                   formals = CDR (CADR (r1));
1366                   body = CDDR (r1);
1367
1368                   if (macro_p || global_p)
1369                     expand_variable (body, formals);
1370                   r1 = cons (cell_symbol_lambda, cons (formals, body));
1371                   push_cc (r1, r2, p, cell_vm_eval_define);
1372                   goto eval;
1373                 }
1374             eval_define:;
1375               name = CADR (r2);
1376               if (TYPE (CADR (r2)) == TPAIR)
1377                 name = CAR (name);
1378               if (macro_p)
1379                 {
1380                   entry = macro_get_handle (name);
1381                   r1 = MAKE_MACRO (name, r1);
1382                   set_cdr_x (entry, r1);
1383                 }
1384               else if (global_p)
1385                 {
1386                   entry = module_variable (r0, name);
1387                   set_cdr_x (entry, r1);
1388                 }
1389               else
1390                 {
1391                   entry = cons (name, r1);
1392                   aa = cons (entry, cell_nil);
1393                   set_cdr_x (aa, cdr (r0));
1394                   set_cdr_x (r0, aa);
1395                   cl = module_variable (r0, cell_closure);
1396                   set_cdr_x (cl, aa);
1397                 }
1398               r1 = cell_unspecified;
1399               goto vm_return;
1400             }
1401           push_cc (CAR (r1), r1, r0, cell_vm_eval_check_func);
1402           gc_check ();
1403           goto eval;
1404         eval_check_func:
1405           push_cc (CDR (r2), r2, r0, cell_vm_eval2);
1406           goto evlis;
1407         eval2:
1408           r1 = cons (CAR (r2), r1);
1409           goto apply;
1410         }
1411     }
1412   else if (t == TSYMBOL)
1413     {
1414       if (r1 == cell_symbol_boot_module)
1415         goto vm_return;
1416       if (r1 == cell_symbol_current_module)
1417         goto vm_return;
1418       if (r1 == cell_symbol_begin) // FIXME
1419         {
1420           r1 = cell_begin;
1421           goto vm_return;
1422         }
1423       r1 = assert_defined (r1, module_ref (r0, r1));
1424       goto vm_return;
1425     }
1426   else if (t == TVARIABLE)
1427     {
1428       r1 = CDR (VARIABLE (r1));
1429       goto vm_return;
1430     }
1431   else if (t == TBROKEN_HEART)
1432     error (cell_symbol_system_error,  r1);
1433   else
1434     goto vm_return;
1435
1436  macro_expand:
1437   {
1438     macro;
1439     expanders;
1440
1441     if (TYPE (r1) != TPAIR || CAR (r1) == cell_symbol_quote)
1442       goto vm_return;
1443
1444     if (CAR (r1) == cell_symbol_lambda)
1445       {
1446         push_cc (CDDR (r1), r1, r0, cell_vm_macro_expand_lambda);
1447         goto macro_expand;
1448       macro_expand_lambda:
1449         CDDR (r2) = r1;
1450         r1 = r2;
1451         goto vm_return;
1452       }
1453
1454     if (TYPE (r1) == TPAIR
1455         && (macro = get_macro (CAR (r1))) != cell_f)
1456       {
1457         r1 = cons (macro, CDR (r1));
1458         push_cc (r1, cell_nil, r0, cell_vm_macro_expand);
1459         goto apply;
1460       }
1461
1462     if (CAR (r1) == cell_symbol_define
1463         || CAR (r1) == cell_symbol_define_macro)
1464       {
1465         push_cc (CDDR (r1), r1, r0, cell_vm_macro_expand_define);
1466         goto macro_expand;
1467       macro_expand_define:
1468         CDDR (r2) = r1;
1469         r1 = r2;
1470         if (CAR (r1) == cell_symbol_define_macro)
1471           {
1472             push_cc (r1, r1, r0, cell_vm_macro_expand_define_macro);
1473             goto eval;
1474           macro_expand_define_macro:
1475             r1 = r2;
1476           }
1477         goto vm_return;
1478       }
1479
1480     if (CAR (r1) == cell_symbol_set_x)
1481       {
1482         push_cc (CDDR (r1), r1, r0, cell_vm_macro_expand_set_x);
1483         goto macro_expand;
1484       macro_expand_set_x:
1485         CDDR (r2) = r1;
1486         r1 = r2;
1487         goto vm_return;
1488       }
1489
1490     if (TYPE (r1) == TPAIR
1491         && TYPE (CAR (r1)) == TSYMBOL
1492         && CAR (r1) != cell_symbol_begin
1493         && ((macro = macro_get_handle (cell_symbol_portable_macro_expand)) != cell_f)
1494         && ((expanders = module_ref (r0, cell_symbol_sc_expander_alist)) != cell_undefined)
1495         && ((macro = assq (CAR (r1), expanders)) != cell_f))
1496       {
1497         sc_expand = module_ref (r0, cell_symbol_macro_expand);
1498         r2 = r1;
1499         if (sc_expand != cell_undefined && sc_expand != cell_f)
1500           {
1501             r1 = cons (sc_expand, cons (r1, cell_nil));
1502             goto apply;
1503           }
1504       }
1505
1506     push_cc (CAR (r1), r1, r0, cell_vm_macro_expand_car);
1507     goto macro_expand;
1508
1509   macro_expand_car:
1510     CAR (r2) = r1;
1511     r1 = r2;
1512     if (CDR (r1) == cell_nil)
1513       goto vm_return;
1514
1515     push_cc (CDR (r1), r1, r0, cell_vm_macro_expand_cdr);
1516     goto macro_expand;
1517
1518   macro_expand_cdr:
1519     CDR (r2) = r1;
1520     r1 = r2;
1521
1522     goto vm_return;
1523   }
1524
1525  begin:
1526   x = cell_unspecified;
1527   while (r1 != cell_nil)
1528     {
1529       gc_check ();
1530       if (TYPE (r1) == TPAIR)
1531         {
1532           if (CAAR (r1) == cell_symbol_primitive_load)
1533             {
1534               program = cons (CAR (r1), cell_nil);
1535               push_cc (program, r1, r0, cell_vm_begin_primitive_load);
1536               goto begin_expand;
1537             begin_primitive_load:
1538               CAR (r2) = r1;
1539               r1 = r2;
1540             }
1541         }
1542
1543       if (TYPE (r1) == TPAIR && TYPE (CAR (r1)) == TPAIR)
1544         {
1545           if (CAAR (r1) == cell_symbol_begin)
1546             r1 = append2 (CDAR (r1), CDR (r1));
1547         }
1548       if (CDR (r1) == cell_nil)
1549         {
1550           r1 = CAR (r1);
1551           goto eval;
1552         }
1553       push_cc (CAR (r1), r1, r0, cell_vm_begin_eval);
1554       goto eval;
1555     begin_eval:
1556       x = r1;
1557       r1 = CDR (r2);
1558     }
1559   r1 = x;
1560   goto vm_return;
1561
1562
1563  begin_expand:
1564   x = cell_unspecified;
1565   while (r1 != cell_nil)
1566     {
1567       gc_check ();
1568
1569       if (TYPE (r1) == TPAIR)
1570         {
1571           if (TYPE (CAR (r1)) == TPAIR && CAAR (r1) == cell_symbol_begin)
1572             r1 = append2 (CDAR (r1), CDR (r1));
1573           if (CAAR (r1) == cell_symbol_primitive_load)
1574             {
1575               push_cc (CADR (CAR (r1)), r1, r0, cell_vm_begin_expand_primitive_load);
1576               goto eval; // FIXME: expand too?!
1577             begin_expand_primitive_load:
1578               if (TYPE (r1) == TNUMBER && VALUE (r1) == 0)
1579                 ;
1580               else if (TYPE (r1) == TSTRING)
1581                 input = set_current_input_port (open_input_file (r1));
1582               else if (TYPE (r1) == TPORT)
1583                 input = set_current_input_port (r1);
1584               else
1585                 assert (0);
1586
1587               push_cc (input, r2, r0, cell_vm_return);
1588               x = read_input_file_env (r0);
1589               if (g_debug > 3)
1590                 module_printer (m0);
1591               gc_pop_frame ();
1592               input = r1;
1593               r1 = x;
1594               set_current_input_port (input);
1595               r1 = cons (cell_symbol_begin, r1);
1596               CAR (r2) = r1;
1597               r1 = r2;
1598               continue;
1599             }
1600         }
1601
1602       push_cc (CAR (r1), r1, r0, cell_vm_begin_expand_macro);
1603       goto macro_expand;
1604     begin_expand_macro:
1605       if (r1 != CAR (r2))
1606         {
1607           CAR (r2) = r1;
1608           r1 = r2;
1609           continue;
1610         }
1611       r1 = r2;
1612       expand_variable (CAR (r1), cell_nil);
1613       push_cc (CAR (r1), r1, r0, cell_vm_begin_expand_eval);
1614       goto eval;
1615     begin_expand_eval:
1616       x = r1;
1617       r1 = CDR (r2);
1618     }
1619   r1 = x;
1620   goto vm_return;
1621
1622  vm_if:
1623   push_cc (CAR (r1), r1, r0, cell_vm_if_expr);
1624   goto eval;
1625  if_expr:
1626   x = r1;
1627   r1 = r2;
1628   if (x != cell_f)
1629     {
1630       r1 = CADR (r1);
1631       goto eval;
1632     }
1633   if (CDDR (r1) != cell_nil)
1634     {
1635       r1 = CAR (CDDR (r1));
1636       goto eval;
1637     }
1638   r1 = cell_unspecified;
1639   goto vm_return;
1640
1641  call_with_current_continuation:
1642   gc_push_frame ();
1643   x = MAKE_CONTINUATION (g_continuations++);
1644   v = make_vector__ (STACK_SIZE-g_stack);
1645   for (t=g_stack; t < STACK_SIZE; t++)
1646     vector_set_x_ (v, t-g_stack, g_stack_array[t]);
1647   CONTINUATION (x) = v;
1648   gc_pop_frame ();
1649   push_cc (cons (CAR (r1), cons (x, cell_nil)), x, r0, cell_vm_call_with_current_continuation2);
1650   goto apply;
1651  call_with_current_continuation2:
1652   v = make_vector__ (STACK_SIZE-g_stack);
1653   for (t=g_stack; t < STACK_SIZE; t++)
1654     vector_set_x_ (v, t-g_stack, g_stack_array[t]);
1655   CONTINUATION (r2) = v;
1656   goto vm_return;
1657
1658  call_with_values:
1659   push_cc (cons (CAR (r1), cell_nil), r1, r0, cell_vm_call_with_values2);
1660   goto apply;
1661  call_with_values2:
1662   if (TYPE (r1) == TVALUES)
1663     r1 = CDR (r1);
1664   r1 = cons (CADR (r2), r1);
1665   goto apply;
1666
1667  vm_return:
1668   x = r1;
1669   gc_pop_frame ();
1670   r1 = x;
1671   goto eval_apply;
1672 }
1673
1674 SCM
1675 apply (SCM f, SCM x, SCM a) ///((internal))
1676 {
1677   push_cc (cons (f, x), cell_unspecified, r0, cell_unspecified);
1678   r3 = cell_vm_apply;
1679   return eval_apply ();
1680 }
1681
1682 SCM
1683 mes_g_stack (SCM a) ///((internal))
1684 {
1685   //g_stack = g_free + ARENA_SIZE;
1686   g_stack = STACK_SIZE;
1687   r0 = a;
1688   r1 = MAKE_CHAR (0);
1689   r2 = MAKE_CHAR (0);
1690   r3 = MAKE_CHAR (0);
1691   return r0;
1692 }
1693
1694 //\f Environment setup
1695
1696 #include "src/hash.c"
1697 #include "src/module.c"
1698 #include "src/posix.c"
1699 #include "src/math.c"
1700 #include "src/lib.c"
1701
1702 //\f Jam Collector
1703 SCM g_symbol_max;
1704
1705 SCM
1706 gc_init_cells () ///((internal))
1707 {
1708   long arena_bytes = (ARENA_SIZE+JAM_SIZE)*sizeof (struct scm);
1709   void *p = malloc (arena_bytes+STACK_SIZE*sizeof (SCM));
1710   g_cells = (struct scm *)p;
1711   g_stack_array = (SCM*)(p + arena_bytes);
1712
1713   TYPE (0) = TVECTOR;
1714   LENGTH (0) = 1000;
1715   VECTOR (0) = 0;
1716   g_cells++;
1717   TYPE (0) = TCHAR;
1718   VALUE (0) = 'c';
1719   return 0;
1720 }
1721
1722 SCM
1723 mes_symbols () ///((internal))
1724 {
1725   gc_init_cells ();
1726
1727 #if MES_MINI
1728
1729 g_free++;
1730 g_cells[cell_nil] = scm_nil;
1731
1732 g_free++;
1733 g_cells[cell_f] = scm_f;
1734
1735 g_free++;
1736 g_cells[cell_t] = scm_t;
1737
1738 g_free++;
1739 g_cells[cell_dot] = scm_dot;
1740
1741 g_free++;
1742 g_cells[cell_arrow] = scm_arrow;
1743
1744 g_free++;
1745 g_cells[cell_undefined] = scm_undefined;
1746
1747 g_free++;
1748 g_cells[cell_unspecified] = scm_unspecified;
1749
1750 g_free++;
1751 g_cells[cell_closure] = scm_closure;
1752
1753 g_free++;
1754 g_cells[cell_circular] = scm_circular;
1755
1756 g_free++;
1757 g_cells[cell_begin] = scm_begin;
1758
1759 g_free++;
1760 g_cells[cell_symbol_dot] = scm_symbol_dot;
1761
1762 g_free++;
1763 g_cells[cell_symbol_lambda] = scm_symbol_lambda;
1764
1765 g_free++;
1766 g_cells[cell_symbol_begin] = scm_symbol_begin;
1767
1768 g_free++;
1769 g_cells[cell_symbol_if] = scm_symbol_if;
1770
1771 g_free++;
1772 g_cells[cell_symbol_quote] = scm_symbol_quote;
1773
1774 g_free++;
1775 g_cells[cell_symbol_define] = scm_symbol_define;
1776
1777 g_free++;
1778 g_cells[cell_symbol_define_macro] = scm_symbol_define_macro;
1779
1780 g_free++;
1781 g_cells[cell_symbol_quasiquote] = scm_symbol_quasiquote;
1782
1783 g_free++;
1784 g_cells[cell_symbol_unquote] = scm_symbol_unquote;
1785
1786 g_free++;
1787 g_cells[cell_symbol_unquote_splicing] = scm_symbol_unquote_splicing;
1788
1789 g_free++;
1790 g_cells[cell_symbol_syntax] = scm_symbol_syntax;
1791
1792 g_free++;
1793 g_cells[cell_symbol_quasisyntax] = scm_symbol_quasisyntax;
1794
1795 g_free++;
1796 g_cells[cell_symbol_unsyntax] = scm_symbol_unsyntax;
1797
1798 g_free++;
1799 g_cells[cell_symbol_unsyntax_splicing] = scm_symbol_unsyntax_splicing;
1800
1801 g_free++;
1802 g_cells[cell_symbol_set_x] = scm_symbol_set_x;
1803
1804 g_free++;
1805 g_cells[cell_symbol_sc_expand] = scm_symbol_sc_expand;
1806
1807 g_free++;
1808 g_cells[cell_symbol_macro_expand] = scm_symbol_macro_expand;
1809
1810 g_free++;
1811 g_cells[cell_symbol_portable_macro_expand] = scm_symbol_portable_macro_expand;
1812
1813 g_free++;
1814 g_cells[cell_symbol_sc_expander_alist] = scm_symbol_sc_expander_alist;
1815
1816 g_free++;
1817 g_cells[cell_symbol_call_with_values] = scm_symbol_call_with_values;
1818
1819 g_free++;
1820 g_cells[cell_call_with_current_continuation] = scm_call_with_current_continuation;
1821
1822 g_free++;
1823 g_cells[cell_symbol_call_with_current_continuation] = scm_symbol_call_with_current_continuation;
1824
1825 g_free++;
1826 g_cells[cell_symbol_boot_module] = scm_symbol_boot_module;
1827
1828 g_free++;
1829 g_cells[cell_symbol_current_module] = scm_symbol_current_module;
1830
1831 g_free++;
1832 g_cells[cell_symbol_primitive_load] = scm_symbol_primitive_load;
1833
1834 g_free++;
1835 g_cells[cell_symbol_read_input_file] = scm_symbol_read_input_file;
1836
1837 g_free++;
1838 g_cells[cell_symbol_write] = scm_symbol_write;
1839
1840 g_free++;
1841 g_cells[cell_symbol_display] = scm_symbol_display;
1842
1843 g_free++;
1844 g_cells[cell_symbol_throw] = scm_symbol_throw;
1845
1846 g_free++;
1847 g_cells[cell_symbol_not_a_number] = scm_symbol_not_a_number;
1848
1849 g_free++;
1850 g_cells[cell_symbol_not_a_pair] = scm_symbol_not_a_pair;
1851
1852 g_free++;
1853 g_cells[cell_symbol_system_error] = scm_symbol_system_error;
1854
1855 g_free++;
1856 g_cells[cell_symbol_wrong_number_of_args] = scm_symbol_wrong_number_of_args;
1857
1858 g_free++;
1859 g_cells[cell_symbol_wrong_type_arg] = scm_symbol_wrong_type_arg;
1860
1861 g_free++;
1862 g_cells[cell_symbol_unbound_variable] = scm_symbol_unbound_variable;
1863
1864 g_free++;
1865 g_cells[cell_symbol_hashq_table] = scm_symbol_hashq_table;
1866
1867 g_free++;
1868 g_cells[cell_symbol_record_type] = scm_symbol_record_type;
1869
1870 g_free++;
1871 g_cells[cell_symbol_frame] = scm_symbol_frame;
1872
1873 g_free++;
1874 g_cells[cell_symbol_module] = scm_symbol_module;
1875
1876 g_free++;
1877 g_cells[cell_symbol_stack] = scm_symbol_stack;
1878
1879 g_free++;
1880 g_cells[cell_symbol_buckets] = scm_symbol_buckets;
1881
1882 g_free++;
1883 g_cells[cell_symbol_procedure] = scm_symbol_procedure;
1884
1885 g_free++;
1886 g_cells[cell_symbol_size] = scm_symbol_size;
1887
1888 g_free++;
1889 g_cells[cell_symbol_argv] = scm_symbol_argv;
1890
1891 g_free++;
1892 g_cells[cell_symbol_mes_prefix] = scm_symbol_mes_prefix;
1893
1894 g_free++;
1895 g_cells[cell_symbol_mes_version] = scm_symbol_mes_version;
1896
1897 g_free++;
1898 g_cells[cell_symbol_car] = scm_symbol_car;
1899
1900 g_free++;
1901 g_cells[cell_symbol_cdr] = scm_symbol_cdr;
1902
1903 g_free++;
1904 g_cells[cell_symbol_pmatch_car] = scm_symbol_pmatch_car;
1905
1906 g_free++;
1907 g_cells[cell_symbol_pmatch_cdr] = scm_symbol_pmatch_cdr;
1908
1909 g_free++;
1910 g_cells[cell_vm_evlis] = scm_vm_evlis;
1911
1912 g_free++;
1913 g_cells[cell_vm_evlis2] = scm_vm_evlis2;
1914
1915 g_free++;
1916 g_cells[cell_vm_evlis3] = scm_vm_evlis3;
1917
1918 g_free++;
1919 g_cells[cell_vm_apply] = scm_vm_apply;
1920
1921 g_free++;
1922 g_cells[cell_vm_apply2] = scm_vm_apply2;
1923
1924 g_free++;
1925 g_cells[cell_vm_eval] = scm_vm_eval;
1926
1927 g_free++;
1928 g_cells[cell_vm_eval_pmatch_car] = scm_vm_eval_pmatch_car;
1929
1930 g_free++;
1931 g_cells[cell_vm_eval_pmatch_cdr] = scm_vm_eval_pmatch_cdr;
1932
1933 g_free++;
1934 g_cells[cell_vm_eval_define] = scm_vm_eval_define;
1935
1936 g_free++;
1937 g_cells[cell_vm_eval_set_x] = scm_vm_eval_set_x;
1938
1939 g_free++;
1940 g_cells[cell_vm_eval_macro_expand_eval] = scm_vm_eval_macro_expand_eval;
1941
1942 g_free++;
1943 g_cells[cell_vm_eval_macro_expand_expand] = scm_vm_eval_macro_expand_expand;
1944
1945 g_free++;
1946 g_cells[cell_vm_eval_check_func] = scm_vm_eval_check_func;
1947
1948 g_free++;
1949 g_cells[cell_vm_eval2] = scm_vm_eval2;
1950
1951 g_free++;
1952 g_cells[cell_vm_macro_expand] = scm_vm_macro_expand;
1953
1954 g_free++;
1955 g_cells[cell_vm_macro_expand_define] = scm_vm_macro_expand_define;
1956
1957 g_free++;
1958 g_cells[cell_vm_macro_expand_define_macro] = scm_vm_macro_expand_define_macro;
1959
1960 g_free++;
1961 g_cells[cell_vm_macro_expand_lambda] = scm_vm_macro_expand_lambda;
1962
1963 g_free++;
1964 g_cells[cell_vm_macro_expand_set_x] = scm_vm_macro_expand_set_x;
1965
1966 g_free++;
1967 g_cells[cell_vm_begin_expand_primitive_load] = scm_vm_begin_expand_primitive_load;
1968
1969 g_free++;
1970 g_cells[cell_vm_begin_primitive_load] = scm_vm_begin_primitive_load;
1971
1972 g_free++;
1973 g_cells[cell_vm_macro_expand_car] = scm_vm_macro_expand_car;
1974
1975 g_free++;
1976 g_cells[cell_vm_macro_expand_cdr] = scm_vm_macro_expand_cdr;
1977
1978 g_free++;
1979 g_cells[cell_vm_begin_expand] = scm_vm_begin_expand;
1980
1981 g_free++;
1982 g_cells[cell_vm_begin_expand_eval] = scm_vm_begin_expand_eval;
1983
1984 g_free++;
1985 g_cells[cell_vm_begin_expand_macro] = scm_vm_begin_expand_macro;
1986
1987 g_free++;
1988 g_cells[cell_vm_begin] = scm_vm_begin;
1989
1990 g_free++;
1991 g_cells[cell_vm_begin_read_input_file] = scm_vm_begin_read_input_file;
1992
1993 g_free++;
1994 g_cells[cell_vm_begin_eval] = scm_vm_begin_eval;
1995
1996 g_free++;
1997 g_cells[cell_vm_if] = scm_vm_if;
1998
1999 g_free++;
2000 g_cells[cell_vm_if_expr] = scm_vm_if_expr;
2001
2002 g_free++;
2003 g_cells[cell_vm_call_with_values2] = scm_vm_call_with_values2;
2004
2005 g_free++;
2006 g_cells[cell_vm_call_with_current_continuation2] = scm_vm_call_with_current_continuation2;
2007
2008 g_free++;
2009 g_cells[cell_vm_return] = scm_vm_return;
2010
2011 g_free++;
2012 g_cells[cell_type_bytes] = scm_type_bytes;
2013
2014 g_free++;
2015 g_cells[cell_type_char] = scm_type_char;
2016
2017 g_free++;
2018 g_cells[cell_type_closure] = scm_type_closure;
2019
2020 g_free++;
2021 g_cells[cell_type_continuation] = scm_type_continuation;
2022
2023 g_free++;
2024 g_cells[cell_type_function] = scm_type_function;
2025
2026 g_free++;
2027 g_cells[cell_type_keyword] = scm_type_keyword;
2028
2029 g_free++;
2030 g_cells[cell_type_macro] = scm_type_macro;
2031
2032 g_free++;
2033 g_cells[cell_type_number] = scm_type_number;
2034
2035 g_free++;
2036 g_cells[cell_type_pair] = scm_type_pair;
2037
2038 g_free++;
2039 g_cells[cell_type_port] = scm_type_port;
2040
2041 g_free++;
2042 g_cells[cell_type_ref] = scm_type_ref;
2043
2044 g_free++;
2045 g_cells[cell_type_special] = scm_type_special;
2046
2047 g_free++;
2048 g_cells[cell_type_string] = scm_type_string;
2049
2050 g_free++;
2051 g_cells[cell_type_struct] = scm_type_struct;
2052
2053 g_free++;
2054 g_cells[cell_type_symbol] = scm_type_symbol;
2055
2056 g_free++;
2057 g_cells[cell_type_values] = scm_type_values;
2058
2059 g_free++;
2060 g_cells[cell_type_variable] = scm_type_variable;
2061
2062 g_free++;
2063 g_cells[cell_type_vector] = scm_type_vector;
2064
2065 g_free++;
2066 g_cells[cell_type_broken_heart] = scm_type_broken_heart;
2067
2068 g_free++;
2069 g_cells[cell_symbol_internal_time_units_per_second] = scm_symbol_internal_time_units_per_second;
2070
2071 g_free++;
2072 g_cells[cell_symbol_compiler] = scm_symbol_compiler;
2073
2074 g_free++;
2075 g_cells[cell_symbol_arch] = scm_symbol_arch;
2076
2077 g_free++;
2078 g_cells[cell_test] = scm_test;
2079
2080 #elif !POSIX
2081 #include "src/mes.mes.symbols.i"
2082 #else
2083 #include "src/mes.symbols.i"
2084 #endif
2085
2086 g_symbol_max = g_free++;
2087
2088 #if MES_MINI
2089
2090 #if !POSIX
2091  #define name cdr
2092 #endif
2093
2094 NAME_SYMBOL (cell_nil, scm_nil.name);
2095 NAME_SYMBOL (cell_f, scm_f.name);
2096 NAME_SYMBOL (cell_t, scm_t.name);
2097 NAME_SYMBOL (cell_dot, scm_dot.name);
2098 NAME_SYMBOL (cell_arrow, scm_arrow.name);
2099 NAME_SYMBOL (cell_undefined, scm_undefined.name);
2100 NAME_SYMBOL (cell_unspecified, scm_unspecified.name);
2101 NAME_SYMBOL (cell_closure, scm_closure.name);
2102 NAME_SYMBOL (cell_circular, scm_circular.name);
2103 NAME_SYMBOL (cell_begin, scm_begin.name);
2104 NAME_SYMBOL (cell_symbol_dot, scm_symbol_dot.name);
2105 NAME_SYMBOL (cell_symbol_lambda, scm_symbol_lambda.name);
2106 NAME_SYMBOL (cell_symbol_begin, scm_symbol_begin.name);
2107 NAME_SYMBOL (cell_symbol_if, scm_symbol_if.name);
2108 NAME_SYMBOL (cell_symbol_quote, scm_symbol_quote.name);
2109 NAME_SYMBOL (cell_symbol_define, scm_symbol_define.name);
2110 NAME_SYMBOL (cell_symbol_define_macro, scm_symbol_define_macro.name);
2111 NAME_SYMBOL (cell_symbol_quasiquote, scm_symbol_quasiquote.name);
2112 NAME_SYMBOL (cell_symbol_unquote, scm_symbol_unquote.name);
2113 NAME_SYMBOL (cell_symbol_unquote_splicing, scm_symbol_unquote_splicing.name);
2114 NAME_SYMBOL (cell_symbol_syntax, scm_symbol_syntax.name);
2115 NAME_SYMBOL (cell_symbol_quasisyntax, scm_symbol_quasisyntax.name);
2116 NAME_SYMBOL (cell_symbol_unsyntax, scm_symbol_unsyntax.name);
2117 NAME_SYMBOL (cell_symbol_unsyntax_splicing, scm_symbol_unsyntax_splicing.name);
2118 NAME_SYMBOL (cell_symbol_set_x, scm_symbol_set_x.name);
2119 NAME_SYMBOL (cell_symbol_sc_expand, scm_symbol_sc_expand.name);
2120 NAME_SYMBOL (cell_symbol_macro_expand, scm_symbol_macro_expand.name);
2121 NAME_SYMBOL (cell_symbol_portable_macro_expand, scm_symbol_portable_macro_expand.name);
2122 NAME_SYMBOL (cell_symbol_sc_expander_alist, scm_symbol_sc_expander_alist.name);
2123 NAME_SYMBOL (cell_symbol_call_with_values, scm_symbol_call_with_values.name);
2124 NAME_SYMBOL (cell_call_with_current_continuation, scm_call_with_current_continuation.name);
2125 NAME_SYMBOL (cell_symbol_call_with_current_continuation, scm_symbol_call_with_current_continuation.name);
2126 NAME_SYMBOL (cell_symbol_boot_module, scm_symbol_boot_module.name);
2127 NAME_SYMBOL (cell_symbol_current_module, scm_symbol_current_module.name);
2128 NAME_SYMBOL (cell_symbol_primitive_load, scm_symbol_primitive_load.name);
2129 NAME_SYMBOL (cell_symbol_read_input_file, scm_symbol_read_input_file.name);
2130 NAME_SYMBOL (cell_symbol_write, scm_symbol_write.name);
2131 NAME_SYMBOL (cell_symbol_display, scm_symbol_display.name);
2132 NAME_SYMBOL (cell_symbol_throw, scm_symbol_throw.name);
2133 NAME_SYMBOL (cell_symbol_not_a_number, scm_symbol_not_a_number.name);
2134 NAME_SYMBOL (cell_symbol_not_a_pair, scm_symbol_not_a_pair.name);
2135 NAME_SYMBOL (cell_symbol_system_error, scm_symbol_system_error.name);
2136 NAME_SYMBOL (cell_symbol_wrong_number_of_args, scm_symbol_wrong_number_of_args.name);
2137 NAME_SYMBOL (cell_symbol_wrong_type_arg, scm_symbol_wrong_type_arg.name);
2138 NAME_SYMBOL (cell_symbol_unbound_variable, scm_symbol_unbound_variable.name);
2139 NAME_SYMBOL (cell_symbol_hashq_table, scm_symbol_hashq_table.name);
2140 NAME_SYMBOL (cell_symbol_record_type, scm_symbol_record_type.name);
2141 NAME_SYMBOL (cell_symbol_frame, scm_symbol_frame.name);
2142 NAME_SYMBOL (cell_symbol_module, scm_symbol_module.name);
2143 NAME_SYMBOL (cell_symbol_stack, scm_symbol_stack.name);
2144 NAME_SYMBOL (cell_symbol_buckets, scm_symbol_buckets.name);
2145 NAME_SYMBOL (cell_symbol_procedure, scm_symbol_procedure.name);
2146 NAME_SYMBOL (cell_symbol_size, scm_symbol_size.name);
2147 NAME_SYMBOL (cell_symbol_argv, scm_symbol_argv.name);
2148 NAME_SYMBOL (cell_symbol_mes_prefix, scm_symbol_mes_prefix.name);
2149 NAME_SYMBOL (cell_symbol_mes_version, scm_symbol_mes_version.name);
2150 NAME_SYMBOL (cell_symbol_car, scm_symbol_car.name);
2151 NAME_SYMBOL (cell_symbol_cdr, scm_symbol_cdr.name);
2152 NAME_SYMBOL (cell_symbol_pmatch_car, scm_symbol_pmatch_car.name);
2153 NAME_SYMBOL (cell_symbol_pmatch_cdr, scm_symbol_pmatch_cdr.name);
2154 NAME_SYMBOL (cell_vm_evlis, scm_vm_evlis.name);
2155 NAME_SYMBOL (cell_vm_evlis2, scm_vm_evlis2.name);
2156 NAME_SYMBOL (cell_vm_evlis3, scm_vm_evlis3.name);
2157 NAME_SYMBOL (cell_vm_apply, scm_vm_apply.name);
2158 NAME_SYMBOL (cell_vm_apply2, scm_vm_apply2.name);
2159 NAME_SYMBOL (cell_vm_eval, scm_vm_eval.name);
2160 NAME_SYMBOL (cell_vm_eval_pmatch_car, scm_vm_eval_pmatch_car.name);
2161 NAME_SYMBOL (cell_vm_eval_pmatch_cdr, scm_vm_eval_pmatch_cdr.name);
2162 NAME_SYMBOL (cell_vm_eval_define, scm_vm_eval_define.name);
2163 NAME_SYMBOL (cell_vm_eval_set_x, scm_vm_eval_set_x.name);
2164 NAME_SYMBOL (cell_vm_eval_macro_expand_eval, scm_vm_eval_macro_expand_eval.name);
2165 NAME_SYMBOL (cell_vm_eval_macro_expand_expand, scm_vm_eval_macro_expand_expand.name);
2166 NAME_SYMBOL (cell_vm_eval_check_func, scm_vm_eval_check_func.name);
2167 NAME_SYMBOL (cell_vm_eval2, scm_vm_eval2.name);
2168 NAME_SYMBOL (cell_vm_macro_expand, scm_vm_macro_expand.name);
2169 NAME_SYMBOL (cell_vm_macro_expand_define, scm_vm_macro_expand_define.name);
2170 NAME_SYMBOL (cell_vm_macro_expand_define_macro, scm_vm_macro_expand_define_macro.name);
2171 NAME_SYMBOL (cell_vm_macro_expand_lambda, scm_vm_macro_expand_lambda.name);
2172 NAME_SYMBOL (cell_vm_macro_expand_set_x, scm_vm_macro_expand_set_x.name);
2173 NAME_SYMBOL (cell_vm_begin_expand_primitive_load, scm_vm_begin_expand_primitive_load.name);
2174 NAME_SYMBOL (cell_vm_begin_primitive_load, scm_vm_begin_primitive_load.name);
2175 NAME_SYMBOL (cell_vm_macro_expand_car, scm_vm_macro_expand_car.name);
2176 NAME_SYMBOL (cell_vm_macro_expand_cdr, scm_vm_macro_expand_cdr.name);
2177 NAME_SYMBOL (cell_vm_begin_expand, scm_vm_begin_expand.name);
2178 NAME_SYMBOL (cell_vm_begin_expand_eval, scm_vm_begin_expand_eval.name);
2179 NAME_SYMBOL (cell_vm_begin_expand_macro, scm_vm_begin_expand_macro.name);
2180 NAME_SYMBOL (cell_vm_begin, scm_vm_begin.name);
2181 NAME_SYMBOL (cell_vm_begin_read_input_file, scm_vm_begin_read_input_file.name);
2182 NAME_SYMBOL (cell_vm_begin_eval, scm_vm_begin_eval.name);
2183 NAME_SYMBOL (cell_vm_if, scm_vm_if.name);
2184 NAME_SYMBOL (cell_vm_if_expr, scm_vm_if_expr.name);
2185 NAME_SYMBOL (cell_vm_call_with_values2, scm_vm_call_with_values2.name);
2186 NAME_SYMBOL (cell_vm_call_with_current_continuation2, scm_vm_call_with_current_continuation2.name);
2187 NAME_SYMBOL (cell_vm_return, scm_vm_return.name);
2188 NAME_SYMBOL (cell_type_bytes, scm_type_bytes.name);
2189 NAME_SYMBOL (cell_type_char, scm_type_char.name);
2190 NAME_SYMBOL (cell_type_closure, scm_type_closure.name);
2191 NAME_SYMBOL (cell_type_continuation, scm_type_continuation.name);
2192 NAME_SYMBOL (cell_type_function, scm_type_function.name);
2193 NAME_SYMBOL (cell_type_keyword, scm_type_keyword.name);
2194 NAME_SYMBOL (cell_type_macro, scm_type_macro.name);
2195 NAME_SYMBOL (cell_type_number, scm_type_number.name);
2196 NAME_SYMBOL (cell_type_pair, scm_type_pair.name);
2197 NAME_SYMBOL (cell_type_port, scm_type_port.name);
2198 NAME_SYMBOL (cell_type_ref, scm_type_ref.name);
2199 NAME_SYMBOL (cell_type_special, scm_type_special.name);
2200 NAME_SYMBOL (cell_type_string, scm_type_string.name);
2201 NAME_SYMBOL (cell_type_struct, scm_type_struct.name);
2202 NAME_SYMBOL (cell_type_symbol, scm_type_symbol.name);
2203 NAME_SYMBOL (cell_type_values, scm_type_values.name);
2204 NAME_SYMBOL (cell_type_variable, scm_type_variable.name);
2205 NAME_SYMBOL (cell_type_vector, scm_type_vector.name);
2206 NAME_SYMBOL (cell_type_broken_heart, scm_type_broken_heart.name);
2207 NAME_SYMBOL (cell_symbol_internal_time_units_per_second, scm_symbol_internal_time_units_per_second.name);
2208 NAME_SYMBOL (cell_symbol_compiler, scm_symbol_compiler.name);
2209 NAME_SYMBOL (cell_symbol_arch, scm_symbol_arch.name);
2210 NAME_SYMBOL (cell_test, scm_test.name);
2211
2212 #if !POSIX
2213  #undef name
2214 #endif
2215
2216 #elif !POSIX
2217 #include "src/mes.mes.symbol-names.i"
2218 #else
2219 #include "src/mes.symbol-names.i"
2220 #endif
2221
2222   g_symbols = make_hash_table_ (500);
2223   for (int i=1; i<g_symbol_max; i++)
2224     hash_set_x (g_symbols, symbol_to_string (i), i);
2225
2226   SCM a = cell_nil;
2227   a = acons (cell_symbol_call_with_values, cell_symbol_call_with_values, a);
2228   a = acons (cell_symbol_boot_module, cell_symbol_boot_module, a);
2229   a = acons (cell_symbol_current_module, cell_symbol_current_module, a);
2230   a = acons (cell_symbol_call_with_current_continuation, cell_call_with_current_continuation, a);
2231
2232   a = acons (cell_symbol_mes_version, MAKE_STRING0 (VERSION), a);
2233   a = acons (cell_symbol_mes_prefix, MAKE_STRING0 (PREFIX), a);
2234
2235   a = acons (cell_type_bytes, MAKE_NUMBER (TBYTES), a);
2236   a = acons (cell_type_char, MAKE_NUMBER (TCHAR), a);
2237   a = acons (cell_type_closure, MAKE_NUMBER (TCLOSURE), a);
2238   a = acons (cell_type_continuation, MAKE_NUMBER (TCONTINUATION), a);
2239   a = acons (cell_type_function, MAKE_NUMBER (TFUNCTION), a);
2240   a = acons (cell_type_keyword, MAKE_NUMBER (TKEYWORD), a);
2241   a = acons (cell_type_macro, MAKE_NUMBER (TMACRO), a);
2242   a = acons (cell_type_number, MAKE_NUMBER (TNUMBER), a);
2243   a = acons (cell_type_pair, MAKE_NUMBER (TPAIR), a);
2244   a = acons (cell_type_port, MAKE_NUMBER (TPORT), a);
2245   a = acons (cell_type_ref, MAKE_NUMBER (TREF), a);
2246   a = acons (cell_type_special, MAKE_NUMBER (TSPECIAL), a);
2247   a = acons (cell_type_string, MAKE_NUMBER (TSTRING), a);
2248   a = acons (cell_type_struct, MAKE_NUMBER (TSTRUCT), a);
2249   a = acons (cell_type_symbol, MAKE_NUMBER (TSYMBOL), a);
2250   a = acons (cell_type_values, MAKE_NUMBER (TVALUES), a);
2251   a = acons (cell_type_variable, MAKE_NUMBER (TVARIABLE), a);
2252   a = acons (cell_type_vector, MAKE_NUMBER (TVECTOR), a);
2253   a = acons (cell_type_broken_heart, MAKE_NUMBER (TBROKEN_HEART), a);
2254
2255   a = acons (cell_closure, a, a);
2256
2257   return a;
2258 }
2259
2260 SCM
2261 mes_environment (int argc, char *argv[])
2262 {
2263   SCM a = mes_symbols ();
2264
2265   char *compiler = "gnuc";
2266 #if __MESC__
2267   compiler = "mesc";
2268 #elif __TINYC__
2269   compiler = "tcc";
2270 #endif
2271   a = acons (cell_symbol_compiler, MAKE_STRING0 (compiler), a);
2272
2273   char *arch = "x86";
2274 #if __x86_64__
2275   arch = "x86_64";
2276 #endif
2277   a = acons (cell_symbol_arch, MAKE_STRING0 (arch), a);
2278
2279 #if !MES_MINI
2280   SCM lst = cell_nil;
2281   for (int i=argc-1; i>=0; i--)
2282     lst = cons (MAKE_STRING0 (argv[i]), lst);
2283   a = acons (cell_symbol_argv, lst, a);
2284 #endif
2285
2286   return mes_g_stack (a);
2287 }
2288
2289 SCM
2290 mes_builtins (SCM a) ///((internal))
2291 {
2292 #if MES_MINI
2293
2294 #if !POSIX
2295  #define function car
2296 #endif
2297
2298 //mes
2299 scm_cons.function = g_function;
2300 g_functions[g_function++] = fun_cons;
2301 cell_cons = g_free++;
2302 g_cells[cell_cons] = scm_cons;
2303
2304 scm_car.function = g_function;
2305 g_functions[g_function++] = fun_car;
2306 cell_car = g_free++;
2307 g_cells[cell_car] = scm_car;
2308
2309 scm_cdr.function = g_function;
2310 g_functions[g_function++] = fun_cdr;
2311 cell_cdr = g_free++;
2312 g_cells[cell_cdr] = scm_cdr;
2313
2314 scm_list.function = g_function;
2315 g_functions[g_function++] = fun_list;
2316 cell_list = g_free++;
2317 g_cells[cell_list] = scm_list;
2318
2319 scm_null_p.function = g_function;
2320 g_functions[g_function++] = fun_null_p;
2321 cell_null_p = g_free++;
2322 g_cells[cell_null_p] = scm_null_p;
2323
2324 scm_eq_p.function = g_function;
2325 g_functions[g_function++] = fun_eq_p;
2326 cell_eq_p = g_free++;
2327 g_cells[cell_eq_p] = scm_eq_p;
2328
2329 //math
2330 scm_minus.function = g_function;
2331 g_functions[g_function++] = fun_minus;
2332 cell_minus = g_free++;
2333 g_cells[cell_minus] = scm_minus;
2334
2335 scm_plus.function = g_function;
2336 g_functions[g_function++] = fun_plus;
2337 cell_plus = g_free++;
2338 g_cells[cell_plus] = scm_plus;
2339
2340 //lib
2341 scm_display_.function = g_function;
2342 g_functions[g_function++] = fun_display_;
2343 cell_display_ = g_free++;
2344 g_cells[cell_display_] = scm_display_;
2345
2346 scm_display_error_.function = g_function;
2347 g_functions[g_function++] = fun_display_error_;
2348 cell_display_error_ = g_free++;
2349 g_cells[cell_display_error_] = scm_display_error_;
2350
2351 //posix
2352 scm_getenv_.function = g_function;
2353 g_functions[g_function++] = fun_getenv_;
2354 cell_getenv_ = g_free++;
2355 g_cells[cell_getenv_] = scm_getenv_;
2356
2357 #if !POSIX
2358  #undef name
2359  #define string cdr
2360 #endif
2361
2362 //mes.environment
2363 scm_cons.string = MAKE_BYTES0 (fun_cons.name);
2364 a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_cons)), cell_cons, a);
2365
2366 scm_car.string = MAKE_BYTES0 (fun_car.name);
2367 a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_car)), cell_car, a);
2368
2369 scm_cdr.string = MAKE_BYTES0 (fun_cdr.name);
2370 a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_cdr)), cell_cdr, a);
2371
2372 scm_list.string = MAKE_BYTES0 (fun_list.name);
2373 a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_list)), cell_list, a);
2374
2375 scm_null_p.string = MAKE_BYTES0 (fun_null_p.name);
2376 a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_null_p)), cell_null_p, a);
2377
2378 scm_eq_p.string = MAKE_BYTES0 (fun_eq_p.name);
2379  a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_eq_p)), cell_eq_p, a);
2380
2381 //math.environment
2382 scm_minus.string = MAKE_BYTES0 (fun_minus.name);
2383 a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_minus)), cell_minus, a);
2384
2385 scm_plus.string = MAKE_BYTES0 (fun_plus.name);
2386 a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_plus)), cell_plus, a);
2387
2388 //lib.environment
2389 scm_display_.string = MAKE_BYTES0 (fun_display_.name);
2390 a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_display_)), cell_display_, a);
2391
2392 scm_display_error_.string = MAKE_BYTES0 (fun_display_error_.name);
2393 a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_display_error_)), cell_display_error_, a);
2394
2395 //posix.environment
2396 scm_getenv_.string = MAKE_BYTES0 (fun_getenv_.name);
2397 a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_getenv_)), cell_getenv_, a);
2398
2399 #if !POSIX
2400  #undef function
2401  #undef string
2402 #endif
2403
2404 #elif !__GNUC__ || !POSIX
2405 #include "src/mes.mes.i"
2406
2407   // Do not sort: Order of these includes define builtins
2408 #include "src/hash.mes.i"
2409 #include "src/module.mes.i"
2410 #include "src/posix.mes.i"
2411 #include "src/math.mes.i"
2412 #include "src/lib.mes.i"
2413 #include "src/vector.mes.i"
2414 #include "src/strings.mes.i"
2415 #include "src/struct.mes.i"
2416 #include "src/gc.mes.i"
2417 #include "src/reader.mes.i"
2418
2419 #include "src/gc.mes.environment.i"
2420 #include "src/hash.mes.environment.i"
2421 #include "src/lib.mes.environment.i"
2422 #include "src/math.mes.environment.i"
2423 #include "src/mes.mes.environment.i"
2424 #include "src/module.mes.environment.i"
2425 #include "src/posix.mes.environment.i"
2426 #include "src/reader.mes.environment.i"
2427 #include "src/strings.mes.environment.i"
2428 #include "src/struct.mes.environment.i"
2429 #include "src/vector.mes.environment.i"
2430 #else
2431 #include "src/mes.i"
2432
2433   // Do not sort: Order of these includes define builtins
2434 #include "src/hash.i"
2435 #include "src/module.i"
2436 #include "src/posix.i"
2437 #include "src/math.i"
2438 #include "src/lib.i"
2439 #include "src/vector.i"
2440 #include "src/strings.i"
2441 #include "src/struct.i"
2442 #include "src/gc.i"
2443 #include "src/reader.i"
2444
2445 #include "src/gc.environment.i"
2446 #include "src/hash.environment.i"
2447 #include "src/lib.environment.i"
2448 #include "src/math.environment.i"
2449 #include "src/mes.environment.i"
2450 #include "src/module.environment.i"
2451 #include "src/posix.environment.i"
2452 #include "src/reader.environment.i"
2453 #include "src/strings.environment.i"
2454 #include "src/struct.environment.i"
2455 #include "src/vector.environment.i"
2456 #endif
2457
2458   if (g_debug > 3)
2459     {
2460       fdputs ("functions: ", g_stderr);
2461       fdputs (itoa (g_function), g_stderr);
2462       fdputs ("\n", g_stderr);
2463       for (int i = 0; i < g_function; i++)
2464         {
2465           fdputs ("[", g_stderr);
2466           fdputs (itoa (i), g_stderr);
2467           fdputs ("]: ", g_stderr);
2468           fdputs (g_functions[i].name, g_stderr);
2469           fdputs ("\n", g_stderr);
2470         }
2471       fdputs ("\n", g_stderr);
2472     }
2473
2474   return a;
2475 }
2476
2477 SCM read_input_file_env (SCM);
2478
2479 int
2480 load_boot (char *prefix, char const *boot, char const *location)
2481 {
2482   strcpy (prefix + strlen (prefix), boot);
2483   if (g_debug > 1)
2484     {
2485       eputs ("mes: reading boot-0 [");
2486       eputs (location);
2487       eputs ("]: ");
2488       eputs (prefix);
2489       eputs ("\n");
2490     }
2491   int fd = open (prefix, O_RDONLY);
2492   if (g_debug && fd > 0)
2493     {
2494       eputs ("mes: read boot-0: ");
2495       eputs (prefix);
2496       eputs ("\n");
2497     }
2498   return fd;
2499 }
2500
2501 SCM
2502 load_env () ///((internal))
2503 {
2504   g_stdin = -1;
2505   char prefix[1024];
2506   char boot[1024];
2507   if (getenv ("MES_BOOT"))
2508     strcpy (boot, getenv ("MES_BOOT"));
2509   else
2510     strcpy (boot, "boot-0.scm");
2511   if (getenv ("MES_PREFIX"))
2512     {
2513       strcpy (prefix, getenv ("MES_PREFIX"));
2514       strcpy (prefix + strlen (prefix), "/module");
2515       strcpy (prefix + strlen (prefix), "/mes/");
2516       g_stdin = load_boot (prefix, boot, "MES_PREFIX");
2517     }
2518   if (g_stdin < 0)
2519     {
2520       char const *p = MODULEDIR "/mes/";
2521       strcpy (prefix, p);
2522       g_stdin = load_boot (prefix, boot, "MODULEDIR");
2523     }
2524   if (g_stdin < 0)
2525     {
2526       strcpy (prefix, "mes/module/mes/");
2527       g_stdin = load_boot (prefix, boot, ".");
2528     }
2529   if (g_stdin < 0)
2530     {
2531       prefix[0] = 0;
2532       g_stdin = load_boot (prefix, boot, "<boot>");
2533     }
2534   if (g_stdin < 0)
2535     {
2536       eputs ("mes: boot failed: no such file: ");
2537       eputs (boot);
2538       eputs ("\n");
2539       exit (1);
2540     }
2541
2542   r2 = read_input_file_env (r0);
2543   g_stdin = STDIN;
2544   return r2;
2545 }
2546
2547 SCM
2548 bload_env () ///((internal))
2549 {
2550 #if !POSIX
2551   char *mo = "mes/boot-0.32-mo";
2552   g_stdin = open ("module/mes/boot-0.32-mo", O_RDONLY);
2553   char *read0 = MODULEDIR "/mes/boot-0.32-mo";
2554   g_stdin = g_stdin >= 0 ? g_stdin : open (read0, O_RDONLY);
2555 #else
2556   char *mo ="mes/boot-0.mo";
2557   g_stdin = open ("module/mes/boot-0.mo", O_RDONLY);
2558   g_stdin = g_stdin >= 0 ? g_stdin : open (MODULEDIR "/mes/boot-0.mo", O_RDONLY);
2559 #endif
2560
2561   if (g_stdin < 0)
2562     {
2563       eputs ("no such file: ");
2564       eputs (mo);
2565       eputs ("\n");
2566       return 1;
2567     }
2568   assert (getchar () == 'M');
2569   assert (getchar () == 'E');
2570   assert (getchar () == 'S');
2571
2572   if (g_debug)
2573     eputs ("*GOT MES*\n");
2574   g_stack = getchar () << 8;
2575   g_stack += getchar ();
2576
2577   char *p = (char*)g_cells;
2578   int c = getchar ();
2579   while (c != EOF)
2580     {
2581       *p++ = c;
2582       c = getchar ();
2583     }
2584   g_free = (p-(char*)g_cells) / sizeof (struct scm);
2585   gc_peek_frame ();
2586   g_symbols = r1;
2587   g_stdin = STDIN;
2588   // SCM a = struct_ref (r0, 4);
2589   // a = mes_builtins (a);
2590   // struct_set_x (r0, 4, a);
2591   r0 = mes_builtins (r0);
2592
2593   if (g_debug > 3)
2594     {
2595       eputs ("symbols: ");
2596       write_error_ (g_symbols);
2597       eputs ("\n");
2598       eputs ("functions: ");
2599       eputs (itoa (g_function));
2600       eputs ("\n");
2601       for (int i = 0; i < g_function; i++)
2602         {
2603           eputs ("[");
2604           eputs (itoa (i));
2605           eputs ("]: ");
2606           eputs (g_functions[i].name);
2607           eputs ("\n");
2608         }
2609     }
2610   return r2;
2611 }
2612
2613 #include "src/vector.c"
2614 #include "src/strings.c"
2615 #include "src/struct.c"
2616 #include "src/gc.c"
2617 #include "src/reader.c"
2618
2619 int
2620 main (int argc, char *argv[])
2621 {
2622   char *p;
2623   if (p = getenv ("MES_DEBUG"))
2624     g_debug = atoi (p);
2625   if (g_debug > 1)
2626     {
2627       eputs (";;; MODULEDIR=");
2628       eputs (MODULEDIR);
2629       eputs ("\n");
2630     }
2631   if (p = getenv ("MES_MAX_ARENA"))
2632     MAX_ARENA_SIZE = atoi (p);
2633   if (p = getenv ("MES_ARENA"))
2634     ARENA_SIZE = atoi (p);
2635   JAM_SIZE = ARENA_SIZE / 10;
2636   if (p = getenv ("MES_JAM"))
2637     JAM_SIZE = atoi (p);
2638   GC_SAFETY = ARENA_SIZE / 100;
2639   if (p = getenv ("MES_SAFETY"))
2640     GC_SAFETY = atoi (p);
2641   if (p = getenv ("MES_STACK"))
2642     STACK_SIZE = atoi (p);
2643   g_stdin = STDIN;
2644   g_stdout = STDOUT;
2645   g_stderr = STDERR;
2646
2647   SCM a = mes_environment (argc, argv);
2648   a = mes_builtins (a);
2649   a = init_time (a);
2650   m0 = make_initial_module (a);
2651   g_macros = make_hash_table_ (0);
2652
2653   if (g_debug > 3)
2654     module_printer (m0);
2655
2656   SCM program = (argc > 1 && !strcmp (argv[1], "--load"))
2657     ? bload_env () : load_env ();
2658   g_tiny = argc > 2 && !strcmp (argv[2], "--tiny");
2659   if (argc > 1 && !strcmp (argv[1], "--dump"))
2660     return dump ();
2661
2662   push_cc (r2, cell_unspecified, r0, cell_unspecified);
2663
2664   if (g_debug > 2)
2665     {
2666       eputs ("\ngc stats: [");
2667       eputs (itoa (g_free));
2668       eputs ("]\n");
2669     }
2670   if (g_debug > 3)
2671     {
2672       eputs ("program: ");
2673       write_error_ (r1);
2674       eputs ("\n");
2675     }
2676   // if (g_debug > 3)
2677   //   {
2678   //     eputs ("symbols: ");
2679   //     write_error_ (g_symbols);
2680   //     eputs ("\n");
2681   //   }
2682   r3 = cell_vm_begin_expand;
2683   r1 = eval_apply ();
2684   if (g_debug)
2685     {
2686       write_error_ (r1);
2687       eputs ("\n");
2688     }
2689   if (g_debug)
2690     {
2691       if (g_debug > 3)
2692         module_printer (m0);
2693
2694       eputs ("\ngc stats: [");
2695       eputs (itoa (g_free));
2696       MAX_ARENA_SIZE = 0;
2697
2698       gc (g_stack);
2699       eputs (" => ");
2700       eputs (itoa (g_free));
2701       eputs ("]\n");
2702       if (g_debug > 3)
2703         module_printer (m0);
2704       eputs ("\n");
2705
2706       gc (g_stack);
2707       eputs (" => ");
2708       eputs (itoa (g_free));
2709       eputs ("]\n");
2710       if (g_debug > 3)
2711         module_printer (m0);
2712       eputs ("\n");
2713
2714       gc (g_stack);
2715       eputs (" => ");
2716       eputs (itoa (g_free));
2717       eputs ("]\n");
2718       if (g_debug > 3)
2719         module_printer (m0);
2720       if (g_debug > 3)
2721         {
2722           eputs ("ports:"); write_error_ (g_ports); eputs ("\n");
2723         }
2724       eputs ("\n");
2725
2726
2727     }
2728   return 0;
2729 }