mescc: Display sexps better.
[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 #define MES_MINI 1
22
23 #if __GNUC__
24 #define FIXME_NYACC 1
25 #define  __NYACC__ 0
26 #define NYACC_CAR
27 #define NYACC_CDR
28 #else
29 #define  __NYACC__ 1
30 #define NYACC_CAR nyacc_car
31 #define NYACC_CDR nyacc_cdr
32 #endif
33
34 char arena[200];
35
36 int g_stdin = 0;
37
38 #if __GNUC__
39 typedef long size_t;
40 void *malloc (size_t i);
41 int open (char const *s, int mode);
42 int read (int fd, void* buf, size_t n);
43 void write (int fd, char const* s, int n);
44
45 void
46 exit (int code)
47 {
48   asm (
49        "movl %0,%%ebx\n\t"
50        "movl $1,%%eax\n\t"
51        "int  $0x80"
52        : // no outputs "=" (r)
53        : "" (code)
54        );
55   // not reached
56   exit (0);
57 }
58
59 char const*
60 getenv (char const* p)
61 {
62   return 0;
63 }
64
65 int
66 read (int fd, void* buf, size_t n)
67 {
68   int r;
69   //syscall (SYS_write, fd, s, n));
70   asm (
71        "movl %1,%%ebx\n\t"
72        "movl %2,%%ecx\n\t"
73        "movl %3,%%edx\n\t"
74        "movl $0x3,%%eax\n\t"
75        "int  $0x80\n\t"
76        "mov %%eax,%0\n\t"
77        : "=r" (r)
78        : "" (fd), "" (buf), "" (n)
79        : "eax", "ebx", "ecx", "edx"
80        );
81   return r;
82 }
83
84 int
85 open (char const *s, int mode)
86 {
87   int r;
88   //syscall (SYS_open, mode));
89   asm (
90        "mov %1,%%ebx\n\t"
91        "mov %2,%%ecx\n\t"
92        "mov $0x5,%%eax\n\t"
93        "int $0x80\n\t"
94        "mov %%eax,%0\n\t"
95        : "=r" (r)
96        : "" (s), "" (mode)
97        : "eax", "ebx", "ecx"
98        );
99   return r;
100 }
101
102 int
103 getchar ()
104 {
105   char c;
106   int r = read (g_stdin, &c, 1);
107   if (r < 1) return -1;
108   return c;
109 }
110
111 void
112 write (int fd, char const* s, int n)
113 {
114   int r;
115   //syscall (SYS_write, fd, s, n));
116   asm (
117        "mov %0,%%ebx\n\t"
118        "mov %1,%%ecx\n\t"
119        "mov %2,%%edx\n\t"
120
121        "mov $0x4, %%eax\n\t"
122        "int $0x80\n\t"
123        : // no outputs "=" (r)
124        : "" (fd), "" (s), "" (n)
125        : "eax", "ebx", "ecx", "edx"
126        );
127 }
128
129 int
130 putchar (int c)
131 {
132   //write (STDOUT, s, strlen (s));
133   //int i = write (STDOUT, s, strlen (s));
134   write (1, (char*)&c, 1);
135   return 0;
136 }
137
138 void *
139 malloc (size_t size)
140 {
141   int *n;
142   int len = size + sizeof (size);
143   //n = mmap (0, len, PROT_READ | PROT_WRITE, MAP_PRIVATE | MAP_ANONYMOUS, 0, 0 );
144   *n = len;
145   return (void*)(n+1);
146 }
147
148 void
149 free (void *p)
150 {
151   int *n = (int*)p-1;
152   //munmap ((void*)p, *n);
153 }
154
155 #define EOF -1
156 #define STDIN 0
157 #define STDOUT 1
158 #define STDERR 2
159
160 size_t
161 strlen (char const* s)
162 {
163   int i = 0;
164   while (s[i]) i++;
165   return i;
166 }
167
168 int
169 strcmp (char const* a, char const* b)
170 {
171   while (*a && *b && *a == *b) {a++;b++;}
172   return *a - *b;
173 }
174
175 int
176 puts (char const* s)
177 {
178   //write (STDOUT, s, strlen (s));
179   //int i = write (STDOUT, s, strlen (s));
180   int i = strlen (s);
181   write (1, s, i);
182   return 0;
183 }
184
185 int
186 eputs (char const* s)
187 {
188   //write (STDERR, s, strlen (s));
189   //int i = write (STDERR, s, strlen (s));
190   int i = strlen (s);
191   write (2, s, i);
192   return 0;
193 }
194
195 char const*
196 itoa (int x)
197 {
198   static char buf[10];
199   char *p = buf+9;
200   *p-- = 0;
201
202   int sign = x < 0;
203   if (sign)
204     x = -x;
205   
206   do
207     {
208       *p-- = '0' + (x % 10);
209       x = x / 10;
210     } while (x);
211
212   if (sign)
213     *p-- = '-';
214
215   return p+1;
216 }
217
218 #endif
219
220 void
221 assert_fail (char* s)
222 {
223   eputs ("assert fail:");
224 #if __GNUC__
225   eputs (s);
226 #endif
227   eputs ("\n");
228 #if __GNUC__
229   *((int*)0) = 0;
230 #endif
231 }
232
233 #if __GNUC__
234 #define assert(x) ((x) ? (void)0 : assert_fail ("boo:" #x))
235 #else
236 //#define assert(x) ((x) ? (void)0 : assert_fail ("boo:" #x))
237 #define assert(x) ((x) ? (void)0 : assert_fail (0))
238 #endif
239
240 typedef int SCM;
241
242 #if __GNUC__
243 int g_debug = 0;
244 #endif
245
246 int g_free = 0;
247
248 SCM g_symbols = 0;
249 SCM g_stack = 0;
250 SCM r0 = 0; // a/env
251 SCM r1 = 0; // param 1
252 SCM r2 = 0; // save 2+load/dump
253 SCM r3 = 0; // continuation
254
255 #if __NYACC__ || FIXME_NYACC
256 enum type_t {CHAR, CLOSURE, CONTINUATION, TFUNCTION, KEYWORD, MACRO, NUMBER, PAIR, REF, SPECIAL, TSTRING, SYMBOL, VALUES, TVECTOR, BROKEN_HEART};
257 #else
258 enum type_t {CHAR, CLOSURE, CONTINUATION, FUNCTION, KEYWORD, MACRO, NUMBER, PAIR, REF, SPECIAL, STRING, SYMBOL, VALUES, VECTOR, BROKEN_HEART};
259 #endif
260
261 struct scm {
262   enum type_t type;
263   SCM car;
264   SCM cdr;
265 };
266
267 //char arena[200];
268 //struct scm *g_cells = arena;
269 //struct scm *g_cells = (struct scm*)arena;
270 struct scm *g_cells = arena;
271
272 #define cell_nil 1
273 #define cell_f 2
274 #define cell_t 3
275
276 #define TYPE(x) (g_cells[x].type)
277
278 #define CAR(x) g_cells[x].car
279
280 #define CDR(x) g_cells[x].cdr
281 //#define VALUE(x) g_cells[x].value
282 #define VALUE(x) g_cells[x].cdr
283
284 SCM
285 car (SCM x)
286 {
287 #if MES_MINI
288   //Nyacc
289   //assert ("!car");
290 #else
291   if (TYPE (x) != PAIR) error (cell_symbol_not_a_pair, cons (x, cell_symbol_car));
292 #endif
293   return CAR (x);
294 }
295
296 SCM
297 cdr (SCM x)
298 {
299 #if MES_MINI
300   //Nyacc
301   //assert ("!cdr");
302 #else
303   if (TYPE (x) != PAIR) error (cell_symbol_not_a_pair, cons (x, cell_symbol_cdr));
304 #endif
305   return CDR(x);
306 }
307 SCM caar (SCM x) {return car (car (x));}
308 SCM cadr (SCM x) {return car (cdr (x));}
309 SCM cdar (SCM x) {return cdr (car (x));}
310 SCM cddr (SCM x) {return cdr (cdr (x));}
311
312 SCM
313 gc_peek_frame ()
314 {
315   SCM frame = car (g_stack);
316   r1 = car (frame);
317   r2 = cadr (frame);
318   r3 = car (cddr (frame));
319   r0 = cadr (cddr (frame));
320   return frame;
321 }
322
323 //\f Environment setup
324
325 SCM
326 mes_environment ()
327 {
328   return 0;
329 }
330
331 SCM
332 mes_builtins (SCM a)
333 {
334   return a;
335 }
336
337 SCM
338 fill ()
339 {
340   TYPE (0) = 0x6c6c6168;
341   CAR (0) = 0x6a746f6f;
342   CDR (0) = 0x00002165;
343
344   TYPE (1) = SYMBOL;
345   CAR (1) = 0x2d2d2d2d;
346   CDR (1) = 0x3e3e3e3e;
347
348   TYPE (9) = 0x2d2d2d2d;
349   CAR (9) = 0x2d2d2d2d;
350   CDR (9) = 0x3e3e3e3e;
351
352   // (A(B))
353   TYPE (10) = PAIR;
354   CAR (10) = 11;
355   CDR (10) = 12;
356
357   TYPE (11) = CHAR;
358   CAR (11) = 0x58585858;
359   CDR (11) = 89;
360
361   TYPE (12) = PAIR;
362   CAR (12) = 13;
363   CDR (12) = 1;
364
365   TYPE (13) = CHAR;
366   CAR (11) = 0x58585858;
367   CDR (13) = 90;
368
369   TYPE (14) = 0x58585858;
370   CAR (14) = 0x58585858;
371   CDR (14) = 0x58585858;
372
373   TYPE (14) = 0x58585858;
374   CAR (14) = 0x58585858;
375   CDR (14) = 0x58585858;
376
377   TYPE (16) = 0x3c3c3c3c;
378   CAR (16) = 0x2d2d2d2d;
379   CDR (16) = 0x2d2d2d2d;
380   return 0;
381 }
382
383 SCM
384 display_ (SCM x)
385 {
386   //puts ("<display>\n");
387   switch (TYPE (x))
388     {
389     case CHAR:
390       {
391         //puts ("<char>\n");
392         puts ("#\\");
393         putchar (VALUE (x));
394         break;
395       }
396     case TFUNCTION:
397       {
398         //puts ("<function>\n");
399         if (VALUE (x) == 0)
400           puts ("make-cell");
401         if (VALUE (x) == 1)
402           puts ("cons");
403         if (VALUE (x) == 2)
404           puts ("car");
405         if (VALUE (x) == 3)
406           puts ("cdr");
407         break;
408       }
409     case NUMBER:
410       {
411         //puts ("<number>\n");
412 #if __GNUC__
413         puts (itoa (VALUE (x)));
414 #else
415         int i;
416         i = VALUE (x);
417         i = i + 48;
418         putchar (i);
419 #endif
420         break;
421       }
422     case PAIR:
423       {
424         //puts ("<pair>\n");
425         //if (cont != cell_f) puts "(");
426         puts ("(");
427         if (x && x != cell_nil) display_ (CAR (x));
428         if (CDR (x) && CDR (x) != cell_nil)
429           {
430 #if __GNUC__
431             if (TYPE (CDR (x)) != PAIR)
432               puts (" . ");
433 #else
434             int c;
435             c = CDR (x);
436             c = TYPE (c);
437             if (c != PAIR)
438               puts (" . ");
439 #endif
440             display_ (CDR (x));
441           }
442         //if (cont != cell_f) puts (")");
443         puts (")");
444         break;
445       }
446     case SPECIAL:
447       {
448         switch (x)
449           {
450           case 1: {puts ("()"); break;}
451           case 2: {puts ("#f"); break;}
452           case 3: {puts ("#t"); break;}
453           default:
454             {
455 #if __GNUC__
456         puts ("<x:");
457         puts (itoa (x));
458         puts (">");
459 #else
460         puts ("<x>");
461 #endif
462             }
463           }
464         break;
465       }
466     case SYMBOL:
467       {
468         switch (x)
469           {
470           case 11: {puts (" . "); break;}
471           case 12: {puts ("lambda"); break;}
472           case 13: {puts ("begin"); break;}
473           case 14: {puts ("if"); break;}
474           case 15: {puts ("quote"); break;}
475           case 37: {puts ("car"); break;}
476           case 38: {puts ("cdr"); break;}
477           case 39: {puts ("null?"); break;}
478           case 40: {puts ("eq?"); break;}
479           case 41: {puts ("cons"); break;}
480           default:
481             {
482 #if __GNUC__
483         puts ("<s:");
484         puts (itoa (x));
485         puts (">");
486 #else
487         puts ("<s>");
488 #endif
489             }
490           }
491         break;
492       }
493     default:
494       {
495         //puts ("<default>\n");
496 #if __GNUC__
497         puts ("<");
498         puts (itoa (TYPE (x)));
499         puts (":");
500         puts (itoa (x));
501         puts (">");
502 #else
503         puts ("_");
504 #endif
505         break;
506       }
507     }
508   return 0;
509 }
510
511 SCM
512 bload_env (SCM a) ///((internal))
513 {
514   puts ("reading: ");
515   char *mo = "module/mes/hack-32.mo";
516   puts (mo);
517   puts ("\n");
518   g_stdin = open (mo, 0);
519   if (g_stdin < 0) {eputs ("no such file: module/mes/read-0-32.mo\n");return 1;} 
520
521   // BOOM
522   //char *p = arena;
523   char *p = (char*)g_cells;
524   int c;
525
526   c = getchar ();
527   putchar (c);
528   if (c != 'M') exit (10);
529   c = getchar ();
530   putchar (c);
531   if (c != 'E') exit (11);
532   c = getchar ();
533   putchar (c);
534   if (c != 'S') exit (12);
535   puts (" *GOT MES*\n");
536
537   // skip stack
538   getchar ();
539   getchar ();
540
541   c = getchar ();
542   while (c != -1)
543     {
544       *p++ = c;
545       c = getchar ();
546     }
547
548   puts ("read done\n");
549   display_ (10);
550
551   puts ("\n");
552   return r2;
553 }
554
555 int
556 main (int argc, char *argv[])
557 {
558   fill ();
559   char *p = arena;
560   puts (p);
561   puts ("\n");
562   display_ (10);
563   puts ("\n");
564   SCM program = bload_env (r0);
565
566   return 0;
567 }
568
569 #if __GNUC__
570 void
571 _start ()
572 {
573   int r;
574   asm (
575        "mov %%ebp,%%eax\n\t"
576        "addl $8,%%eax\n\t"
577        "push %%eax\n\t"
578
579        "mov %%ebp,%%eax\n\t"
580        "addl $4,%%eax\n\t"
581        "movzbl (%%eax),%%eax\n\t"
582        "push %%eax\n\t"
583
584        "call main\n\t"
585        "movl %%eax,%0\n\t"
586        : "=r" (r)
587        : //no inputs "" (&main)
588        );
589   exit (r);
590 }
591 #endif
592