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