8a8e4fac021533c8437f98bdbf6a3bb35068eea7
[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 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