5fefedd227a1976ab3c76186c576d8445727d193
[mes.git] / 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/hack-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/read-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