scaffold/tiny-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 #if __GNUC__
  22 #include "mlibc.c"
  23 #endif
  24 #define assert(x) ((x) ? (void)0 : assert_fail (#x))
  25
  26 #define MES_MINI 1
  27
  28 #if __GNUC__
  29 #define FIXME_NYACC 1
  30 #define  __NYACC__ 0
  31 #define NYACC_CAR
  32 #define NYACC_CDR
  33 #else
  34 #define  __NYACC__ 1
  35 #define NYACC_CAR nyacc_car
  36 #define NYACC_CDR nyacc_cdr
  37 #endif
  38
  39 char arena[200];
  40
  41 typedef int SCM;
  42
  43 #if __GNUC__
  44 int g_debug = 0;
  45 #endif
  46
  47 int g_free = 0;
  48
  49 SCM g_symbols = 0;
  50 SCM g_stack = 0;
  51 SCM r0 = 0; // a/env
  52 SCM r1 = 0; // param 1
  53 SCM r2 = 0; // save 2+load/dump
  54 SCM r3 = 0; // continuation
  55
  56 #if __NYACC__ || FIXME_NYACC
  57 enum type_t {CHAR, CLOSURE, CONTINUATION, TFUNCTION, KEYWORD, MACRO, NUMBER, PAIR, REF, SPECIAL, TSTRING, SYMBOL, VALUES, TVECTOR, BROKEN_HEART};
  58 #else
  59 enum type_t {CHAR, CLOSURE, CONTINUATION, FUNCTION, KEYWORD, MACRO, NUMBER, PAIR, REF, SPECIAL, STRING, SYMBOL, VALUES, VECTOR, BROKEN_HEART};
  60 #endif
  61
  62 struct scm {
  63   enum type_t type;
  64   SCM car;
  65   SCM cdr;
  66 };
  67
  68 //char arena[200];
  69 //struct scm *g_cells = arena;
  70 //struct scm *g_cells = (struct scm*)arena;
  71 struct scm *g_cells = arena;
  72
  73 #define cell_nil 1
  74 #define cell_f 2
  75 #define cell_t 3
  76
  77 #define TYPE(x) (g_cells[x].type)
  78
  79 #define CAR(x) g_cells[x].car
  80
  81 #define CDR(x) g_cells[x].cdr
  82 //#define VALUE(x) g_cells[x].value
  83 #define VALUE(x) g_cells[x].cdr
  84
  85 SCM
  86 car (SCM x)
  87 {
  88 #if MES_MINI
  89   //Nyacc
  90   //assert ("!car");
  91 #else
  92   if (TYPE (x) != PAIR) error (cell_symbol_not_a_pair, cons (x, cell_symbol_car));
  93 #endif
  94   return CAR (x);
  95 }
  96
  97 SCM
  98 cdr (SCM x)
  99 {
 100 #if MES_MINI
 101   //Nyacc
 102   //assert ("!cdr");
 103 #else
 104   if (TYPE (x) != PAIR) error (cell_symbol_not_a_pair, cons (x, cell_symbol_cdr));
 105 #endif
 106   return CDR(x);
 107 }
 108 SCM caar (SCM x) {return car (car (x));}
 109 SCM cadr (SCM x) {return car (cdr (x));}
 110 SCM cdar (SCM x) {return cdr (car (x));}
 111 SCM cddr (SCM x) {return cdr (cdr (x));}
 112
 113 SCM
 114 gc_peek_frame ()
 115 {
 116   SCM frame = car (g_stack);
 117   r1 = car (frame);
 118   r2 = cadr (frame);
 119   r3 = car (cddr (frame));
 120   r0 = cadr (cddr (frame));
 121   return frame;
 122 }
 123
 124 //\f Environment setup
 125
 126 SCM
 127 mes_environment ()
 128 {
 129   return 0;
 130 }
 131
 132 SCM
 133 mes_builtins (SCM a)
 134 {
 135   return a;
 136 }
 137
 138 SCM
 139 fill ()
 140 {
 141   TYPE (0) = 0x6c6c6168;
 142   CAR (0) = 0x6a746f6f;
 143   CDR (0) = 0x00002165;
 144
 145   TYPE (1) = SYMBOL;
 146   CAR (1) = 0x2d2d2d2d;
 147   CDR (1) = 0x3e3e3e3e;
 148
 149   TYPE (9) = 0x2d2d2d2d;
 150   CAR (9) = 0x2d2d2d2d;
 151   CDR (9) = 0x3e3e3e3e;
 152
 153   // (A(B))
 154   TYPE (10) = PAIR;
 155   CAR (10) = 11;
 156   CDR (10) = 12;
 157
 158   TYPE (11) = CHAR;
 159   CAR (11) = 0x58585858;
 160   CDR (11) = 89;
 161
 162   TYPE (12) = PAIR;
 163   CAR (12) = 13;
 164   CDR (12) = 1;
 165
 166   TYPE (13) = CHAR;
 167   CAR (11) = 0x58585858;
 168   CDR (13) = 90;
 169
 170   TYPE (14) = 0x58585858;
 171   CAR (14) = 0x58585858;
 172   CDR (14) = 0x58585858;
 173
 174   TYPE (14) = 0x58585858;
 175   CAR (14) = 0x58585858;
 176   CDR (14) = 0x58585858;
 177
 178   TYPE (16) = 0x3c3c3c3c;
 179   CAR (16) = 0x2d2d2d2d;
 180   CDR (16) = 0x2d2d2d2d;
 181   return 0;
 182 }
 183
 184 SCM
 185 display_ (SCM x)
 186 {
 187   //puts ("<display>\n");
 188   switch (TYPE (x))
 189     {
 190     case CHAR:
 191       {
 192         //puts ("<char>\n");
 193         puts ("#\\");
 194         putchar (VALUE (x));
 195         break;
 196       }
 197     case TFUNCTION:
 198       {
 199         //puts ("<function>\n");
 200         if (VALUE (x) == 0)
 201           puts ("make-cell");
 202         if (VALUE (x) == 1)
 203           puts ("cons");
 204         if (VALUE (x) == 2)
 205           puts ("car");
 206         if (VALUE (x) == 3)
 207           puts ("cdr");
 208         break;
 209       }
 210     case NUMBER:
 211       {
 212         //puts ("<number>\n");
 213 #if __GNUC__
 214         puts (itoa (VALUE (x)));
 215 #else
 216         int i;
 217         i = VALUE (x);
 218         i = i + 48;
 219         putchar (i);
 220 #endif
 221         break;
 222       }
 223     case PAIR:
 224       {
 225         //puts ("<pair>\n");
 226         //if (cont != cell_f) puts "(");
 227         puts ("(");
 228         if (x && x != cell_nil) display_ (CAR (x));
 229         if (CDR (x) && CDR (x) != cell_nil)
 230           {
 231 #if __GNUC__
 232             if (TYPE (CDR (x)) != PAIR)
 233               puts (" . ");
 234 #else
 235             int c;
 236             c = CDR (x);
 237             c = TYPE (c);
 238             if (c != PAIR)
 239               puts (" . ");
 240 #endif
 241             display_ (CDR (x));
 242           }
 243         //if (cont != cell_f) puts (")");
 244         puts (")");
 245         break;
 246       }
 247     case SPECIAL:
 248       {
 249         switch (x)
 250           {
 251           case 1: {puts ("()"); break;}
 252           case 2: {puts ("#f"); break;}
 253           case 3: {puts ("#t"); break;}
 254           default:
 255             {
 256 #if __GNUC__
 257         puts ("<x:");
 258         puts (itoa (x));
 259         puts (">");
 260 #else
 261         puts ("<x>");
 262 #endif
 263             }
 264           }
 265         break;
 266       }
 267     case SYMBOL:
 268       {
 269         switch (x)
 270           {
 271           case 11: {puts (" . "); break;}
 272           case 12: {puts ("lambda"); break;}
 273           case 13: {puts ("begin"); break;}
 274           case 14: {puts ("if"); break;}
 275           case 15: {puts ("quote"); break;}
 276           case 37: {puts ("car"); break;}
 277           case 38: {puts ("cdr"); break;}
 278           case 39: {puts ("null?"); break;}
 279           case 40: {puts ("eq?"); break;}
 280           case 41: {puts ("cons"); break;}
 281           default:
 282             {
 283 #if __GNUC__
 284         puts ("<s:");
 285         puts (itoa (x));
 286         puts (">");
 287 #else
 288         puts ("<s>");
 289 #endif
 290             }
 291           }
 292         break;
 293       }
 294     default:
 295       {
 296         //puts ("<default>\n");
 297 #if __GNUC__
 298         puts ("<");
 299         puts (itoa (TYPE (x)));
 300         puts (":");
 301         puts (itoa (x));
 302         puts (">");
 303 #else
 304         puts ("_");
 305 #endif
 306         break;
 307       }
 308     }
 309   return 0;
 310 }
 311
 312 SCM
 313 bload_env (SCM a) ///((internal))
 314 {
 315   puts ("reading: ");
 316   char *mo = "module/mes/tiny-0-32.mo";
 317   puts (mo);
 318   puts ("\n");
 319   g_stdin = open (mo, 0);
 320   if (g_stdin < 0) {eputs ("no such file: module/mes/tiny-0-32.mo\n");return 1;}
 321
 322   // BOOM
 323   //char *p = arena;
 324   char *p = (char*)g_cells;
 325   int c;
 326
 327   c = getchar ();
 328   putchar (c);
 329   if (c != 'M') exit (10);
 330   c = getchar ();
 331   putchar (c);
 332   if (c != 'E') exit (11);
 333   c = getchar ();
 334   putchar (c);
 335   if (c != 'S') exit (12);
 336   puts (" *GOT MES*\n");
 337
 338   // skip stack
 339   getchar ();
 340   getchar ();
 341
 342   c = getchar ();
 343   while (c != -1)
 344     {
 345       *p++ = c;
 346       c = getchar ();
 347     }
 348
 349   puts ("read done\n");
 350   display_ (10);
 351
 352   puts ("\n");
 353   return r2;
 354 }
 355
 356 int
 357 main (int argc, char *argv[])
 358 {
 359   fill ();
 360   char *p = arena;
 361   puts (p);
 362   puts ("\n");
 363   display_ (10);
 364   puts ("\n");
 365   SCM program = bload_env (r0);
 366
 367   return 0;
 368 }
 369
 370 #if __GNUC__
 371 #include "mstart.c"
 372 #endif