mes.c

   1 /* -*-comment-start: "//";comment-end:""-*-
   2  * Mes --- Maxwell Equations of Software
   3  * Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
   4  *
   5  * This file is part of Mes.
   6  *
   7  * Mes is free software; you can redistribute it and/or modify it
   8  * under the terms of the GNU General Public License as published by
   9  * the Free Software Foundation; either version 3 of the License, or (at
  10  * your option) any later version.
  11  *
  12  * Mes is distributed in the hope that it will be useful, but
  13  * WITHOUT ANY WARRANTY; without even the implied warranty of
  14  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15  * GNU General Public License for more details.
  16  *
  17  * You should have received a copy of the GNU General Public License
  18  * along with Mes.  If not, see <http://www.gnu.org/licenses/>.
  19  */
  20
  21 #define _GNU_SOURCE
  22 #if __GNUC__
  23 #define  __NYACC__ 0
  24 #define NYACC
  25 #define NYACC2
  26 #include <assert.h>
  27 #include <ctype.h>
  28 #include <errno.h>
  29 #include <limits.h>
  30 #include <stdio.h>
  31 #include <string.h>
  32 #include <stdlib.h>
  33 #include <stdbool.h>
  34 #else
  35 typedef int bool;
  36 #define  __NYACC__ 1
  37 #define NYACC nyacc
  38 #define NYACC2 nyacc2
  39 #endif
  40
  41 #define DEBUG 0
  42 #define FIXED_PRIMITIVES 1
  43
  44 int ARENA_SIZE = 100000;
  45 int MAX_ARENA_SIZE = 20000000;
  46 int GC_SAFETY = 100;
  47
  48 typedef int SCM;
  49 enum type_t {CHAR, CLOSURE, CONTINUATION, FUNCTION, KEYWORD, MACRO, NUMBER, PAIR, REF, SPECIAL, STRING, SYMBOL, VALUES, VECTOR, BROKEN_HEART};
  50 typedef SCM (*function0_t) (void);
  51 typedef SCM (*function1_t) (SCM);
  52 typedef SCM (*function2_t) (SCM, SCM);
  53 typedef SCM (*function3_t) (SCM, SCM, SCM);
  54 typedef SCM (*functionn_t) (SCM);
  55 typedef struct function_struct {
  56   union {
  57     function0_t function0;
  58     function1_t function1;
  59     function2_t function2;
  60     function3_t function3;
  61     functionn_t functionn;
  62   } NYACC;
  63   int arity;
  64   char const *name;
  65 } function_t;
  66 struct scm;
  67 typedef struct scm_struct {
  68   enum type_t type;
  69   union {
  70     char const* name;
  71     SCM string;
  72     SCM car;
  73     SCM ref;
  74     int length;
  75   } NYACC;
  76   union {
  77     int value;
  78     int function;
  79     SCM cdr;
  80     SCM closure;
  81     SCM continuation;
  82     SCM macro;
  83     SCM vector;
  84     int hits;
  85   } NYACC2;
  86 } scm;
  87
  88 scm scm_nil = {SPECIAL, "()"};
  89 scm scm_f = {SPECIAL, "#f"};
  90 scm scm_t = {SPECIAL, "#t"};
  91 scm scm_dot = {SPECIAL, "."};
  92 scm scm_arrow = {SPECIAL, "=>"};
  93 scm scm_undefined = {SPECIAL, "*undefined*"};
  94 scm scm_unspecified = {SPECIAL, "*unspecified*"};
  95 scm scm_closure = {SPECIAL, "*closure*"};
  96 scm scm_circular = {SPECIAL, "*circular*"};
  97 scm scm_begin = {SPECIAL, "*begin*"};
  98
  99 scm scm_symbol_dot = {SYMBOL, "*dot*"};
 100 scm scm_symbol_lambda = {SYMBOL, "lambda"};
 101 scm scm_symbol_begin = {SYMBOL, "begin"};
 102 scm scm_symbol_if = {SYMBOL, "if"};
 103 scm scm_symbol_quote = {SYMBOL, "quote"};
 104 scm scm_symbol_set_x = {SYMBOL, "set!"};
 105
 106 scm scm_symbol_sc_expand = {SYMBOL, "sc-expand"};
 107 scm scm_symbol_macro_expand = {SYMBOL, "macro-expand"};
 108 scm scm_symbol_sc_expander_alist = {SYMBOL, "*sc-expander-alist*"};
 109
 110 scm scm_symbol_call_with_values = {SYMBOL, "call-with-values"};
 111 scm scm_call_with_current_continuation = {SPECIAL, "*call/cc*"};
 112 scm scm_symbol_call_with_current_continuation = {SYMBOL, "call-with-current-continuation"};
 113 scm scm_symbol_current_module = {SYMBOL, "current-module"};
 114 scm scm_symbol_primitive_load = {SYMBOL, "primitive-load"};
 115 scm scm_symbol_read_input_file = {SYMBOL, "read-input-file"};
 116 scm scm_symbol_write = {SYMBOL, "write"};
 117 scm scm_symbol_display = {SYMBOL, "display"};
 118
 119 scm scm_symbol_throw = {SYMBOL, "throw"};
 120 scm scm_symbol_not_a_pair = {SYMBOL, "not-a-pair"};
 121 scm scm_symbol_system_error = {SYMBOL, "system-error"};
 122 scm scm_symbol_wrong_number_of_args = {SYMBOL, "wrong-number-of-args"};
 123 scm scm_symbol_wrong_type_arg = {SYMBOL, "wrong-type-arg"};
 124 scm scm_symbol_unbound_variable = {SYMBOL, "unbound-variable"};
 125
 126 scm scm_symbol_argv = {SYMBOL, "%argv"};
 127 scm scm_symbol_mes_prefix = {SYMBOL, "%prefix"};
 128 scm scm_symbol_mes_version = {SYMBOL, "%version"};
 129
 130 scm scm_symbol_car = {SYMBOL, "car"};
 131 scm scm_symbol_cdr = {SYMBOL, "cdr"};
 132 scm scm_symbol_null_p = {SYMBOL, "null?"};
 133 scm scm_symbol_eq_p = {SYMBOL, "eq?"};
 134 scm scm_symbol_cons = {SYMBOL, "cons"};
 135
 136 scm scm_vm_evlis = {SPECIAL, "*vm-evlis*"};
 137 scm scm_vm_evlis2 = {SPECIAL, "*vm-evlis2*"};
 138 scm scm_vm_evlis3 = {SPECIAL, "*vm-evlis3*"};
 139 scm scm_vm_apply = {SPECIAL, "core:apply"};
 140 scm scm_vm_apply2 = {SPECIAL, "*vm-apply2*"};
 141 scm scm_vm_eval = {SPECIAL, "core:eval"};
 142
 143 #if 1 //FIXED_PRIMITIVES
 144 scm scm_vm_eval_car = {SPECIAL, "*vm-eval-car*"};
 145 scm scm_vm_eval_cdr = {SPECIAL, "*vm-eval-cdr*"};
 146 scm scm_vm_eval_cons = {SPECIAL, "*vm-eval-cons*"};
 147 scm scm_vm_eval_null_p = {SPECIAL, "*vm-eval-null-p*"};
 148 #endif
 149
 150 scm scm_vm_eval_set_x = {SPECIAL, "*vm-eval-set!*"};
 151 scm scm_vm_eval_macro = {SPECIAL, "*vm-eval-macro*"};
 152 scm scm_vm_eval2 = {SPECIAL, "*vm-eval2*"};
 153 scm scm_vm_macro_expand = {SPECIAL, "core:macro-expand"};
 154 scm scm_vm_begin = {SPECIAL, "*vm-begin*"};
 155 scm scm_vm_begin_read_input_file = {SPECIAL, "*vm-begin-read-input-file*"};
 156 scm scm_vm_begin2 = {SPECIAL, "*vm-begin2*"};
 157 scm scm_vm_if = {SPECIAL, "*vm-if*"};
 158 scm scm_vm_if_expr = {SPECIAL, "*vm-if-expr*"};
 159 scm scm_vm_call_with_values2 = {SPECIAL, "*vm-call-with-values2*"};
 160 scm scm_vm_call_with_current_continuation2 = {SPECIAL, "*vm-call-with-current-continuation2*"};
 161 scm scm_vm_return = {SPECIAL, "*vm-return*"};
 162
 163 scm scm_test = {SYMBOL, "test"};
 164
 165 int g_free = 0;
 166 scm *g_cells;
 167 scm *g_news = 0;
 168
 169 #include "mes.symbols.h"
 170
 171 SCM tmp;
 172 SCM tmp_num;
 173 SCM tmp_num2;
 174
 175 function_t g_functions[200];
 176 int g_function = 0;
 177
 178 SCM g_continuations = 0;
 179 SCM g_symbols = 0;
 180 SCM g_stack = 0;
 181 SCM r0 = 0; // a/env
 182 SCM r1 = 0; // param 1
 183 SCM r2 = 0; // save 2+load/dump
 184 SCM r3 = 0; // continuation
 185
 186 #include "lib.h"
 187 #include "math.h"
 188 #include "mes.h"
 189 #include "posix.h"
 190 #include "reader.h"
 191
 192 #define CAR(x) g_cells[x].car
 193 #define CDR(x) g_cells[x].cdr
 194 #define CONTINUATION(x) g_cells[x].cdr
 195 #define HITS(x) g_cells[x].hits
 196 #define LENGTH(x) g_cells[x].length
 197 #define NAME(x) g_cells[x].name
 198 #define STRING(x) g_cells[x].string
 199 #define TYPE(x) g_cells[x].type
 200 #define CLOSURE(x) g_cells[x].closure
 201 #define MACRO(x) g_cells[x].macro
 202 #define REF(x) g_cells[x].ref
 203 #define VALUE(x) g_cells[x].value
 204 #define VECTOR(x) g_cells[x].vector
 205 #define FUNCTION(x) g_functions[g_cells[x].function]
 206 #define NCAR(x) g_news[x].car
 207 #define NTYPE(x) g_news[x].type
 208
 209 #define CAAR(x) CAR (CAR (x))
 210 #define CDAR(x) CDR (CAR (x))
 211 #define CAAR(x) CAR (CAR (x))
 212 #define CADAR(x) CAR (CDR (CAR (x)))
 213 #define CADDR(x) CAR (CDR (CDR (x)))
 214 #define CDDDR(x) CDR (CDR (CDR (x)))
 215 #define CDADAR(x) CAR (CDR (CAR (CDR (x))))
 216 #define CADR(x) CAR (CDR (x))
 217
 218 #define MAKE_CHAR(n) make_cell (tmp_num_ (CHAR), 0, tmp_num2_ (n))
 219 #define MAKE_CONTINUATION(n) make_cell (tmp_num_ (CONTINUATION), n, g_stack)
 220 #define MAKE_NUMBER(n) make_cell (tmp_num_ (NUMBER), 0, tmp_num2_ (n))
 221 #define MAKE_REF(n) make_cell (tmp_num_ (REF), n, 0)
 222 #define MAKE_STRING(x) make_cell (tmp_num_ (STRING), x, 0)
 223
 224 SCM vm_call (function0_t f, SCM p1, SCM a);
 225
 226 SCM
 227 tmp_num_ (int x)
 228 {
 229   g_cells[tmp_num].value = x;
 230   return tmp_num;
 231 }
 232
 233 SCM
 234 tmp_num2_ (int x)
 235 {
 236   g_cells[tmp_num2].value = x;
 237   return tmp_num2;
 238 }
 239
 240 SCM
 241 alloc (int n)
 242 {
 243   assert (g_free + n < ARENA_SIZE);
 244   SCM x = g_free;
 245   g_free += n;
 246   return x;
 247 }
 248
 249 SCM
 250 make_cell (SCM type, SCM car, SCM cdr)
 251 {
 252   SCM x = alloc (1);
 253   assert (TYPE (type) == NUMBER);
 254   TYPE (x) = VALUE (type);
 255   if (VALUE (type) == CHAR || VALUE (type) == NUMBER) {
 256     if (car) CAR (x) = CAR (car);
 257     if (cdr) CDR (x) = CDR (cdr);
 258   } else if (VALUE (type) == FUNCTION) {
 259     if (car) CAR (x) = car;
 260     if (cdr) CDR (x) = CDR (cdr);
 261   } else {
 262     CAR (x) = car;
 263     CDR (x) = cdr;
 264   }
 265   return x;
 266 }
 267
 268 SCM
 269 cons (SCM x, SCM y)
 270 {
 271   g_cells[tmp_num].value = PAIR;
 272   return make_cell (tmp_num, x, y);
 273 }
 274
 275 SCM
 276 car (SCM x)
 277 {
 278   if (TYPE (x) != PAIR) error (cell_symbol_not_a_pair, cons (x, cell_symbol_car));
 279   return CAR (x);
 280 }
 281
 282 SCM
 283 cdr (SCM x)
 284 {
 285   if (TYPE (x) != PAIR) error (cell_symbol_not_a_pair, cons (x, cell_symbol_cdr));
 286   return CDR (x);
 287 }
 288
 289 SCM
 290 eq_p (SCM x, SCM y)
 291 {
 292   return (x == y
 293           || ((TYPE (x) == KEYWORD && TYPE (y) == KEYWORD
 294                && STRING (x) == STRING (y)))
 295           || (TYPE (x) == CHAR && TYPE (y) == CHAR
 296               && VALUE (x) == VALUE (y))
 297           || (TYPE (x) == NUMBER && TYPE (y) == NUMBER
 298               && VALUE (x) == VALUE (y)))
 299     ? cell_t : cell_f;
 300 }
 301
 302 SCM
 303 type_ (SCM x)
 304 {
 305   return MAKE_NUMBER (TYPE (x));
 306 }
 307
 308 SCM
 309 car_ (SCM x)
 310 {
 311   return (TYPE (x) != CONTINUATION
 312           && (TYPE (CAR (x)) == PAIR // FIXME: this is weird
 313               || TYPE (CAR (x)) == REF
 314               || TYPE (CAR (x)) == SPECIAL
 315               || TYPE (CAR (x)) == SYMBOL
 316               || TYPE (CAR (x)) == STRING)) ? CAR (x) : MAKE_NUMBER (CAR (x));
 317 }
 318
 319 SCM
 320 cdr_ (SCM x)
 321 {
 322   return (TYPE (CDR (x)) == PAIR
 323           || TYPE (CDR (x)) == REF
 324           || TYPE (CAR (x)) == SPECIAL
 325           || TYPE (CDR (x)) == SYMBOL
 326           || TYPE (CDR (x)) == STRING) ? CDR (x) : MAKE_NUMBER (CDR (x));
 327 }
 328
 329 SCM
 330 set_car_x (SCM x, SCM e)
 331 {
 332   assert (TYPE (x) == PAIR);
 333   CAR (x) = e;
 334   return cell_unspecified;
 335 }
 336
 337 SCM
 338 set_cdr_x (SCM x, SCM e)
 339 {
 340   if (TYPE (x) != PAIR) error (cell_symbol_not_a_pair, cons (x, cell_set_cdr_x));
 341   CDR (x) = e;
 342   return cell_unspecified;
 343 }
 344
 345 SCM
 346 set_env_x (SCM x, SCM e, SCM a)
 347 {
 348   SCM p = assert_defined (x, assq (x, a));
 349   if (TYPE (p) != PAIR)  error (cell_symbol_not_a_pair, cons (p, x));
 350   return set_cdr_x (p, e);
 351 }
 352
 353 SCM
 354 pairlis (SCM x, SCM y, SCM a)
 355 {
 356   if (x == cell_nil)
 357     return a;
 358   if (TYPE (x) != PAIR)
 359     return cons (cons (x, y), a);
 360   return cons (cons (car (x), car (y)),
 361                pairlis (cdr (x), cdr (y), a));
 362 }
 363
 364 SCM
 365 assq (SCM x, SCM a)
 366 {
 367   while (a != cell_nil && eq_p (x, CAAR (a)) == cell_f) a = CDR (a);
 368   return a != cell_nil ? car (a) : cell_f;
 369 }
 370
 371 SCM
 372 assq_ref_cache (SCM x, SCM a)
 373 {
 374   x = assq (x, a);
 375   if (x == cell_f) return cell_undefined;
 376   return cdr (x);
 377 }
 378
 379 SCM
 380 call_lambda (SCM e, SCM x, SCM aa, SCM a) ///((internal))
 381 {
 382   SCM cl = cons (cons (cell_closure, x), x);
 383   r1 = e;
 384   r0 = cl;
 385   return cell_unspecified;
 386 }
 387
 388 SCM
 389 push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal))
 390 {
 391   SCM x = r3;
 392   r3 = c;
 393   r2 = p2;
 394   gc_push_frame ();
 395   r1 = p1;
 396   r0 = a;
 397   r3 = x;
 398   return cell_unspecified;
 399 }
 400
 401 SCM
 402 eval_apply ()
 403 {
 404  eval_apply:
 405   if (g_free + GC_SAFETY > ARENA_SIZE)
 406     gc_pop_frame (gc (gc_push_frame ()));
 407
 408   switch (r3)
 409     {
 410     case cell_vm_evlis: goto evlis;
 411     case cell_vm_evlis2: goto evlis2;
 412     case cell_vm_evlis3: goto evlis3;
 413     case cell_vm_apply: goto apply;
 414     case cell_vm_apply2: goto apply2;
 415     case cell_vm_eval: goto eval;
 416 #if FIXED_PRIMITIVES
 417     case cell_vm_eval_car: goto eval_car;
 418     case cell_vm_eval_cdr: goto eval_cdr;
 419     case cell_vm_eval_cons: goto eval_cons;
 420     case cell_vm_eval_null_p: goto eval_null_p;
 421 #endif
 422     case cell_vm_eval_set_x: goto eval_set_x;
 423     case cell_vm_eval_macro: goto eval_macro;
 424     case cell_vm_eval2: goto eval2;
 425     case cell_vm_macro_expand: goto macro_expand;
 426     case cell_vm_begin: goto begin;
 427     case cell_vm_begin_read_input_file: goto begin_read_input_file;
 428     case cell_vm_begin2: goto begin2;
 429     case cell_vm_if: goto vm_if;
 430     case cell_vm_if_expr: goto if_expr;
 431     case cell_vm_call_with_current_continuation2: goto call_with_current_continuation2;
 432     case cell_vm_call_with_values2: goto call_with_values2;
 433     case cell_vm_return: goto vm_return;
 434     case cell_unspecified: return r1;
 435     default:
 436       assert (0);
 437     }
 438
 439   SCM x = cell_nil;
 440   SCM y = cell_nil;
 441  evlis:
 442   if (r1 == cell_nil) goto vm_return;
 443   if (TYPE (r1) != PAIR) goto eval;
 444   push_cc (car (r1), r1, r0, cell_vm_evlis2);
 445   goto eval;
 446  evlis2:
 447   push_cc (cdr (r2), r1, r0, cell_vm_evlis3);
 448   goto evlis;
 449  evlis3:
 450   r1 = cons (r2, r1);
 451   goto vm_return;
 452
 453  apply:
 454   switch (TYPE (car (r1)))
 455     {
 456     case FUNCTION: {
 457       check_formals (car (r1), MAKE_NUMBER (FUNCTION (car (r1)).arity), cdr (r1));
 458       r1 = call (car (r1), cdr (r1)); /// FIXME: move into eval_apply
 459       goto vm_return;
 460     }
 461     case CLOSURE:
 462       {
 463         SCM cl = CLOSURE (car (r1));
 464         SCM formals = cadr (cl);
 465         SCM body = cddr (cl);
 466         SCM aa = cdar (cl);
 467         aa = cdr (aa);
 468         check_formals (car (r1), formals, cdr (r1));
 469         SCM p = pairlis (formals, cdr (r1), aa);
 470         call_lambda (body, p, aa, r0);
 471         goto begin;
 472       }
 473       case CONTINUATION:
 474         {
 475           x = r1;
 476           g_stack = CONTINUATION (CAR (r1));
 477           gc_pop_frame ();
 478           r1 = cadr (x);
 479           goto eval_apply;
 480         }
 481     case SPECIAL:
 482       {
 483         switch (car (r1))
 484           {
 485           case cell_vm_apply:
 486             {
 487               push_cc (cons (CADR (r1), CADDR (r1)), r1, r0, cell_vm_return);
 488               goto apply;
 489             }
 490           case cell_vm_eval:
 491             {
 492               push_cc (CADR (r1), r1, CADDR (r1), cell_vm_return);
 493               goto eval;
 494             }
 495           case cell_call_with_current_continuation:
 496             {
 497               r1 = cdr (r1);
 498               goto call_with_current_continuation;
 499             }
 500           default: check_apply (cell_f, car (r1));
 501           }
 502       }
 503     case SYMBOL:
 504       {
 505         if (car (r1) == cell_symbol_call_with_values)
 506           {
 507             r1 = cdr (r1);
 508             goto call_with_values;
 509           }
 510         if (car (r1) == cell_symbol_current_module)
 511           {
 512             r1 = r0;
 513             goto vm_return;
 514           }
 515         break;
 516       }
 517     case PAIR:
 518       {
 519         switch (caar (r1))
 520           {
 521           case cell_symbol_lambda:
 522             {
 523               SCM formals = cadr (car (r1));
 524               SCM body = cddr (car (r1));
 525               SCM p = pairlis (formals, cdr (r1), r0);
 526               check_formals (r1, formals, cdr (r1));
 527               call_lambda (body, p, p, r0);
 528               goto begin;
 529             }
 530           }
 531       }
 532     }
 533   push_cc (car (r1), r1, r0, cell_vm_apply2);
 534   goto eval;
 535  apply2:
 536   check_apply (r1, car (r2));
 537   r1 = cons (r1, cdr (r2));
 538   goto apply;
 539
 540  eval:
 541   switch (TYPE (r1))
 542     {
 543     case PAIR:
 544       {
 545         switch (car (r1))
 546           {
 547 #if FIXED_PRIMITIVES
 548           case cell_symbol_car:
 549             {
 550               push_cc (CADR (r1), r1, r0, cell_vm_eval_car); goto eval;
 551             eval_car:
 552               x = r1; gc_pop_frame (); r1 = car (x); goto eval_apply;
 553             }
 554           case cell_symbol_cdr:
 555             {
 556               push_cc (CADR (r1), r1, r0, cell_vm_eval_cdr); goto eval;
 557             eval_cdr:
 558               x = r1; gc_pop_frame (); r1 = cdr (x); goto eval_apply;
 559             }
 560           case cell_symbol_cons: {
 561             push_cc (CDR (r1), r1, r0, cell_vm_eval_cons); goto evlis;
 562             eval_cons:
 563             x = r1;
 564             gc_pop_frame ();
 565             r1 = cons (CAR (x), CADR (x));
 566             goto eval_apply;
 567           }
 568           case cell_symbol_null_p:
 569             {
 570               push_cc (CADR (r1), r1, r0, cell_vm_eval_null_p);
 571               goto eval;
 572             eval_null_p:
 573               x = r1; gc_pop_frame (); r1 = null_p (x); goto eval_apply;
 574             }
 575 #endif // FIXED_PRIMITIVES
 576           case cell_symbol_quote:
 577             {
 578               x = r1; gc_pop_frame (); r1 = cadr (x); goto eval_apply;
 579             }
 580           case cell_symbol_begin: goto begin;
 581           case cell_symbol_lambda:
 582             {
 583               r1 = make_closure (cadr (r1), cddr (r1), assq (cell_closure, r0));
 584               goto vm_return;
 585             }
 586           case cell_symbol_if: {r1=cdr (r1); goto vm_if;}
 587           case cell_symbol_set_x:
 588             {
 589               push_cc (car (cddr (r1)), r1, r0, cell_vm_eval_set_x);
 590               goto eval;
 591             eval_set_x:
 592               x = r2;
 593               r1 = set_env_x (cadr (x), r1, r0);
 594               goto vm_return;
 595             }
 596           case cell_vm_macro_expand:
 597             {
 598               push_cc (cadr (r1), r1, r0, cell_vm_return);
 599               goto macro_expand;
 600             }
 601           default: {
 602             push_cc (r1, r1, r0, cell_vm_eval_macro);
 603             goto macro_expand;
 604             eval_macro:
 605             x = r2;
 606             if (r1 != r2)
 607               {
 608                 if (TYPE (r1) == PAIR)
 609                   {
 610                     set_cdr_x (r2, cdr (r1));
 611                     set_car_x (r2, car (r1));
 612                   }
 613                 goto eval;
 614               }
 615             push_cc (CDR (r1), r1, r0, cell_vm_eval2); goto evlis;
 616             eval2:
 617             r1 = cons (car (r2), r1);
 618             goto apply;
 619           }
 620           }
 621       }
 622     case SYMBOL:
 623       {
 624         r1 = assert_defined (r1, assq_ref_cache (r1, r0));
 625         goto vm_return;
 626       }
 627     default: goto vm_return;
 628     }
 629
 630   SCM macro;
 631   SCM expanders;
 632  macro_expand:
 633   if (TYPE (r1) == PAIR
 634       && (macro = lookup_macro (car (r1), r0)) != cell_f)
 635     {
 636       r1 = cons (macro, CDR (r1));
 637       goto apply;
 638     }
 639   else if (TYPE (r1) == PAIR
 640            && TYPE (CAR (r1)) == SYMBOL
 641            && ((expanders = assq_ref_cache (cell_symbol_sc_expander_alist, r0)) != cell_undefined)
 642            && ((macro = assq (CAR (r1), expanders)) != cell_f))
 643     {
 644       SCM sc_expand = assq_ref_cache (cell_symbol_macro_expand, r0);
 645       if (sc_expand != cell_undefined && sc_expand != cell_f)
 646         {
 647           r1 = cons (sc_expand, cons (r1, cell_nil));
 648           goto apply;
 649         }
 650     }
 651   goto vm_return;
 652
 653  begin:
 654   x = cell_unspecified;
 655   while (r1 != cell_nil) {
 656     if (TYPE (r1) == PAIR && TYPE (CAR (r1)) == PAIR)
 657       {
 658         if (caar (r1) == cell_symbol_begin)
 659           r1 = append2 (cdar (r1), cdr (r1));
 660         else if (caar (r1) == cell_symbol_primitive_load)
 661           {
 662             push_cc (cons (cell_symbol_read_input_file, cell_nil), r1, r0, cell_vm_begin_read_input_file);
 663             goto apply;
 664           begin_read_input_file:
 665             r1 = append2 (r1, cdr (r2));
 666           }
 667       }
 668     if (CDR (r1) == cell_nil)
 669       {
 670         r1 = car (r1);
 671         goto eval;
 672       }
 673     push_cc (CAR (r1), r1, r0, cell_vm_begin2);
 674     goto eval;
 675   begin2:
 676     x = r1;
 677     r1 = CDR (r2);
 678   }
 679   r1 = x;
 680   goto vm_return;
 681
 682  vm_if:
 683   push_cc (car (r1), r1, r0, cell_vm_if_expr);
 684   goto eval;
 685  if_expr:
 686   x = r1;
 687   r1 = r2;
 688   if (x != cell_f)
 689     {
 690       r1 = cadr (r1);
 691       goto eval;
 692     }
 693   if (cddr (r1) != cell_nil)
 694     {
 695       r1 = car (cddr (r1));
 696       goto eval;
 697     }
 698   r1 = cell_unspecified;
 699   goto vm_return;
 700
 701  call_with_current_continuation:
 702   gc_push_frame ();
 703   x = MAKE_CONTINUATION (g_continuations++);
 704   gc_pop_frame ();
 705   push_cc (cons (car (r1), cons (x, cell_nil)), x, r0, cell_vm_call_with_current_continuation2);
 706   goto apply;
 707  call_with_current_continuation2:
 708   CONTINUATION (r2) = g_stack;
 709   goto vm_return;
 710
 711  call_with_values:
 712   push_cc (cons (car (r1), cell_nil), r1, r0, cell_vm_call_with_values2);
 713   goto apply;
 714  call_with_values2:
 715   if (TYPE (r1) == VALUES)
 716     r1 = CDR (r1);
 717   r1 = cons (cadr (r2), r1);
 718   goto apply;
 719
 720  vm_return:
 721   x = r1;
 722   gc_pop_frame ();
 723   r1 = x;
 724   goto eval_apply;
 725 }
 726
 727 SCM
 728 call (SCM fn, SCM x)
 729 {
 730   if ((FUNCTION (fn).arity > 0 || FUNCTION (fn).arity == -1)
 731       && x != cell_nil && TYPE (CAR (x)) == VALUES)
 732     x = cons (CADAR (x), CDR (x));
 733   if ((FUNCTION (fn).arity > 1 || FUNCTION (fn).arity == -1)
 734       && x != cell_nil && TYPE (CDR (x)) == PAIR && TYPE (CADR (x)) == VALUES)
 735     x = cons (CAR (x), cons (CDADAR (x), CDR (x)));
 736   switch (FUNCTION (fn).arity)
 737     {
 738     case 0: return FUNCTION (fn).function0 ();
 739     case 1: return FUNCTION (fn).function1 (car (x));
 740     case 2: return FUNCTION (fn).function2 (car (x), cadr (x));
 741     case 3: return FUNCTION (fn).function3 (car (x), cadr (x), car (cddr (x)));
 742     case -1: return FUNCTION (fn).functionn (x);
 743     }
 744
 745   return cell_unspecified;
 746 }
 747
 748 SCM
 749 gc_peek_frame ()
 750 {
 751   SCM frame = car (g_stack);
 752   r1 = car (frame);
 753   r2 = cadr (frame);
 754   r3 = car (cddr (frame));
 755   r0 = cadr (cddr (frame));
 756   return frame;
 757 }
 758
 759 SCM
 760 gc_pop_frame ()
 761 {
 762   SCM frame = gc_peek_frame (g_stack);
 763   g_stack = cdr (g_stack);
 764   return frame;
 765 }
 766
 767 SCM
 768 gc_push_frame ()
 769 {
 770   SCM frame = cons (r1, cons (r2, cons (r3, cons (r0, cell_nil))));
 771   return g_stack = cons (frame, g_stack);
 772 }
 773
 774 SCM
 775 apply (SCM f, SCM x, SCM a) ///((internal))
 776 {
 777   push_cc (cons (f, x), cell_unspecified, r0, cell_unspecified);
 778   r3 = cell_vm_apply;
 779   return eval_apply ();
 780 }
 781
 782 SCM
 783 append2 (SCM x, SCM y)
 784 {
 785   if (x == cell_nil) return y;
 786   assert (TYPE (x) == PAIR);
 787   return cons (car (x), append2 (cdr (x), y));
 788 }
 789
 790 SCM
 791 append (SCM x) ///((arity . n))
 792  {
 793   if (x == cell_nil) return cell_nil;
 794   if (cdr (x) == cell_nil) return car (x);
 795   return append2 (car (x), append (cdr (x)));
 796  }
 797
 798 SCM
 799 cstring_to_list (char const* s)
 800 {
 801   SCM p = cell_nil;
 802   int i = strlen (s);
 803   while (i--)
 804     p = cons (MAKE_CHAR (s[i]), p);
 805   return p;
 806 }
 807
 808 SCM
 809 null_p (SCM x)
 810 {
 811   return x == cell_nil ? cell_t : cell_f;
 812 }
 813
 814 SCM
 815 make_symbol_ (SCM s)
 816 {
 817   g_cells[tmp_num].value = SYMBOL;
 818   SCM x = make_cell (tmp_num, s, 0);
 819   g_symbols = cons (x, g_symbols);
 820   return x;
 821 }
 822
 823 SCM
 824 make_symbol (SCM s)
 825 {
 826   SCM x = lookup_symbol_ (s);
 827   return x ? x : make_symbol_ (s);
 828 }
 829
 830 SCM
 831 make_vector (SCM n)
 832 {
 833   int k = VALUE (n);
 834   g_cells[tmp_num].value = VECTOR;
 835   SCM v = alloc (k);
 836   SCM x = make_cell (tmp_num, k, v);
 837   for (int i=0; i<k; i++) g_cells[v+i] = g_cells[vector_entry (cell_unspecified)];
 838   return x;
 839 }
 840
 841 SCM
 842 arity_ (SCM x)
 843 {
 844   assert (TYPE (x) == FUNCTION);
 845   return MAKE_NUMBER (FUNCTION (x).arity);
 846 }
 847
 848 SCM
 849 values (SCM x) ///((arity . n))
 850 {
 851   SCM v = cons (0, x);
 852   TYPE (v) = VALUES;
 853   return v;
 854 }
 855
 856 SCM
 857 vector_length (SCM x)
 858 {
 859   assert (TYPE (x) == VECTOR);
 860   return MAKE_NUMBER (LENGTH (x));
 861 }
 862
 863 SCM
 864 vector_ref (SCM x, SCM i)
 865 {
 866   assert (TYPE (x) == VECTOR);
 867   assert (VALUE (i) < LENGTH (x));
 868   SCM e = VECTOR (x) + VALUE (i);
 869   if (TYPE (e) == REF) e = g_cells[e].ref;
 870   if (TYPE (e) == CHAR) e = MAKE_CHAR (VALUE (e));
 871   if (TYPE (e) == NUMBER) e = MAKE_NUMBER (VALUE (e));
 872   return e;
 873 }
 874
 875 SCM
 876 vector_entry (SCM x) {
 877   if (TYPE (x) == PAIR || TYPE (x) == SPECIAL || TYPE (x) == STRING || TYPE (x) == SYMBOL || TYPE (x) == VECTOR) x = MAKE_REF (x);
 878   return x;
 879 }
 880
 881 SCM
 882 vector_set_x (SCM x, SCM i, SCM e)
 883 {
 884   assert (TYPE (x) == VECTOR);
 885   assert (VALUE (i) < LENGTH (x));
 886   g_cells[VECTOR (x)+g_cells[i].value] = g_cells[vector_entry (e)];
 887   return cell_unspecified;
 888 }
 889
 890 SCM
 891 list_to_vector (SCM x)
 892 {
 893   VALUE (tmp_num) = VALUE (length (x));
 894   SCM v = make_vector (tmp_num);
 895   SCM p = VECTOR (v);
 896   while (x != cell_nil)
 897     {
 898       g_cells[p++] = g_cells[vector_entry (car (x))];
 899       x = cdr (x);
 900     }
 901   return v;
 902 }
 903
 904 SCM
 905 vector_to_list (SCM v)
 906 {
 907   SCM x = cell_nil;
 908   for (int i = 0; i < LENGTH (v); i++) {
 909     SCM e = VECTOR (v)+i;
 910     if (TYPE (e) == REF) e = g_cells[e].ref;
 911     x = append2 (x, cons (e, cell_nil));
 912   }
 913   return x;
 914 }
 915
 916 void
 917 make_tmps (scm* cells)
 918 {
 919   tmp = g_free++;
 920   cells[tmp].type = CHAR;
 921   tmp_num = g_free++;
 922   cells[tmp_num].type = NUMBER;
 923   tmp_num2 = g_free++;
 924   cells[tmp_num2].type = NUMBER;
 925 }
 926
 927 //\f Jam Collector
 928 SCM g_symbol_max;
 929 bool g_debug = false;
 930
 931 SCM
 932 gc_up_arena ()
 933 {
 934   ARENA_SIZE *= 2;
 935   void *p = realloc (g_cells-1, 2*ARENA_SIZE*sizeof(scm));
 936   if (!p) error (cell_symbol_system_error, cons (MAKE_STRING (cstring_to_list (strerror (errno))), MAKE_NUMBER (g_free)));
 937   g_cells = (scm*)p;
 938   g_cells++;
 939   gc_init_news ();
 940 }
 941
 942 SCM
 943 gc ()
 944 {
 945   if (g_debug) fprintf (stderr, "***gc[%d]...", g_free);
 946   g_free = 1;
 947   if (g_cells < g_news && ARENA_SIZE < MAX_ARENA_SIZE) gc_up_arena ();
 948   for (int i=g_free; i<g_symbol_max; i++)
 949     gc_copy (i);
 950   make_tmps (g_news);
 951   g_symbols = gc_copy (g_symbols);
 952   SCM new = gc_copy (g_stack);
 953   if (g_debug) fprintf (stderr, "new=%d\n", new, g_stack);
 954   g_stack = new;
 955   return gc_loop (1);
 956 }
 957
 958 SCM
 959 gc_loop (SCM scan)
 960 {
 961   while (scan < g_free)
 962     {
 963       if (NTYPE (scan) == CLOSURE
 964           || NTYPE (scan) == CONTINUATION
 965           || NTYPE (scan) == FUNCTION
 966           || NTYPE (scan) == KEYWORD
 967           || NTYPE (scan) == MACRO
 968           || NTYPE (scan) == PAIR
 969           || NTYPE (scan) == REF
 970           || scan == 1 // null
 971           || NTYPE (scan) == SPECIAL
 972           || NTYPE (scan) == STRING
 973           || NTYPE (scan) == SYMBOL)
 974         {
 975           SCM car = gc_copy (g_news[scan].car);
 976           gc_relocate_car (scan, car);
 977         }
 978       if ((NTYPE (scan) == CLOSURE
 979            || NTYPE (scan) == CONTINUATION
 980            || NTYPE (scan) == MACRO
 981            || NTYPE (scan) == PAIR
 982            || NTYPE (scan) == VALUES)
 983           && g_news[scan].cdr) // allow for 0 terminated list of symbols
 984         {
 985           SCM cdr = gc_copy (g_news[scan].cdr);
 986           gc_relocate_cdr (scan, cdr);
 987         }
 988       scan++;
 989     }
 990   return gc_flip ();
 991 }
 992
 993 SCM
 994 gc_copy (SCM old)
 995 {
 996   if (TYPE (old) == BROKEN_HEART) return g_cells[old].car;
 997   SCM new = g_free++;
 998   g_news[new] = g_cells[old];
 999   if (NTYPE (new) == VECTOR)
1000     {
1001       g_news[new].vector = g_free;
1002       for (int i=0; i<LENGTH (old); i++)
1003         g_news[g_free++] = g_cells[VECTOR (old)+i];
1004     }
1005   g_cells[old].type = BROKEN_HEART;
1006   g_cells[old].car = new;
1007   return new;
1008 }
1009
1010 SCM
1011 gc_relocate_car (SCM new, SCM car)
1012 {
1013   g_news[new].car = car;
1014   return cell_unspecified;
1015 }
1016
1017 SCM
1018 gc_relocate_cdr (SCM new, SCM cdr)
1019 {
1020   g_news[new].cdr = cdr;
1021   return cell_unspecified;
1022 }
1023
1024 SCM
1025 gc_flip ()
1026 {
1027   scm *cells = g_cells;
1028   g_cells = g_news;
1029   g_news = cells;
1030   if (g_debug) fprintf (stderr, " => jam[%d]\n", g_free);
1031   return g_stack;
1032 }
1033
1034 //\f Environment setup
1035 SCM
1036 acons (SCM key, SCM value, SCM alist)
1037 {
1038   return cons (cons (key, value), alist);
1039 }
1040
1041 SCM
1042 gc_init_cells ()
1043 {
1044   g_cells = (scm *)malloc (2*ARENA_SIZE*sizeof(scm));
1045   g_cells[0].type = VECTOR;
1046   g_cells[0].length = 1000;
1047   g_cells[0].vector = 0;
1048   g_cells++;
1049   g_cells[0].type = CHAR;
1050   g_cells[0].value = 'c';
1051 }
1052
1053 SCM
1054 gc_init_news ()
1055 {
1056   g_news = g_cells-1 + ARENA_SIZE;
1057   g_news[0].type = VECTOR;
1058   g_news[0].length = 1000;
1059   g_news[0].vector = 0;
1060   g_news++;
1061   g_news[0].type = CHAR;
1062   g_news[0].value = 'n';
1063 }
1064
1065 SCM
1066 mes_symbols () ///((internal))
1067 {
1068   gc_init_cells ();
1069   gc_init_news ();
1070
1071 #include "mes.symbols.i"
1072
1073   g_symbol_max = g_free;
1074   make_tmps (g_cells);
1075
1076   g_symbols = 0;
1077   for (int i=1; i<g_symbol_max; i++)
1078     g_symbols = cons (i, g_symbols);
1079
1080   SCM a = cell_nil;
1081
1082 #include "mes.symbol-names.i"
1083
1084   a = acons (cell_symbol_mes_version, MAKE_STRING (cstring_to_list (VERSION)), a);
1085   a = acons (cell_symbol_mes_prefix, MAKE_STRING (cstring_to_list (PREFIX)), a);
1086
1087 #if BOOT
1088   a = acons (cell_symbol_label, cell_t, a);
1089 #endif
1090   a = acons (cell_symbol_dot, cell_dot, a);
1091   a = acons (cell_symbol_begin, cell_begin, a);
1092   a = acons (cell_symbol_call_with_current_continuation, cell_call_with_current_continuation, a);
1093   a = acons (cell_symbol_sc_expand, cell_f, a);
1094   a = acons (cell_closure, a, a);
1095
1096   return a;
1097 }
1098
1099 SCM
1100 mes_builtins (SCM a)
1101 {
1102 #include "mes.i"
1103
1104 #include "lib.i"
1105 #include "math.i"
1106 #include "posix.i"
1107 #include "reader.i"
1108
1109 #include "lib.environment.i"
1110 #include "math.environment.i"
1111 #include "mes.environment.i"
1112 #include "posix.environment.i"
1113 #include "reader.environment.i"
1114
1115   return a;
1116 }
1117
1118 SCM
1119 mes_g_stack (SCM a) ///((internal))
1120 {
1121   r0 = a;
1122   r1 = MAKE_CHAR (0);
1123   r2 = MAKE_CHAR (0);
1124   r3 = MAKE_CHAR (0);
1125   g_stack = cons (cell_nil, cell_nil);
1126   return r0;
1127 }
1128
1129 SCM
1130 mes_environment () ///((internal))
1131 {
1132   SCM a = mes_symbols ();
1133   return mes_g_stack (a);
1134 }
1135
1136 SCM
1137 make_closure (SCM args, SCM body, SCM a)
1138 {
1139   return make_cell (tmp_num_ (CLOSURE), cell_f, cons (cons (cell_circular, a), cons (args, body)));
1140 }
1141
1142 SCM
1143 lookup_macro (SCM x, SCM a)
1144 {
1145   if (TYPE (x) != SYMBOL) return cell_f;
1146   SCM m = assq_ref_cache (x, a);
1147   if (TYPE (m) == MACRO) return MACRO (m);
1148   return cell_f;
1149 }
1150
1151 FILE *g_stdin;
1152 #include "lib.c"
1153 #include "math.c"
1154 #include "posix.c"
1155 #include "reader.c"
1156
1157 int
1158 main (int argc, char *argv[])
1159 {
1160 #if __GNUC__
1161   g_debug = getenv ("MES_DEBUG");
1162 #else
1163 #endif
1164   if (getenv ("MES_ARENA")) ARENA_SIZE = atoi (getenv ("MES_ARENA"));
1165   if (argc > 1 && !strcmp (argv[1], "--help")) return puts ("Usage: mes [--dump|--load] < FILE");
1166   if (argc > 1 && !strcmp (argv[1], "--version")) {puts ("Mes ");puts (VERSION);return 0;};
1167   g_stdin = stdin;
1168   r0 = mes_environment ();
1169
1170   SCM program = (argc > 1 && !strcmp (argv[1], "--load"))
1171     ? bload_env (r0) : load_env (r0);
1172   if (argc > 1 && !strcmp (argv[1], "--dump")) return dump ();
1173
1174   SCM lst = cell_nil;
1175   for (int i=argc; i; i--) lst = cons (MAKE_STRING (cstring_to_list (argv[i-1])), lst);
1176   r0 = acons (cell_symbol_argv, lst, r0);
1177
1178   push_cc (r2, cell_unspecified, r0, cell_unspecified);
1179   r3 = cell_vm_begin;
1180   r1 = eval_apply ();
1181   stderr_ (r1);
1182   fputs ("", stderr);
1183   gc (g_stack);
1184 #if __GNUC__
1185   if (g_debug) fprintf (stderr, "\nstats: [%d]\n", g_free);
1186 #else
1187 #endif
1188   return 0;
1189 }