4c159a38c7e102e4af0ef185c686fb807ab8bff2
[mes.git] / scaffold / mini-mes.c
1 /* -*-comment-start: "//";comment-end:""-*-
2  * Mes --- Maxwell Equations of Software
3  * Copyright © 2016 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  __NYACC__ 0
25 #define NYACC
26 #define NYACC2
27 #else
28 #define  __NYACC__ 1
29 #define NYACC nyacc
30 #define NYACC2 nyacc2
31 #endif
32
33 typedef long size_t;
34 void *malloc (size_t i);
35
36 int
37 open (char const *s, int mode)
38 {
39   //return syscall (SYS_open, s, mode);
40   return 0;
41 }
42
43 int
44 read (int fd, int n)
45 {
46   //syscall (SYS_read, 1, 1);
47   return 0;
48 }
49
50 void
51 write (int fd, char const* s, int n)
52 {
53   int r;
54   //syscall (SYS_write, fd, s, n));
55   asm (
56        "mov %0, %%ebx\n\t"
57        "mov %1, %%ecx\n\t"
58        "mov %2, %%edx\n\t"
59
60        "mov $0x4, %%eax\n\t"
61        "int $0x80\n\t"
62        : // no outputs "=" (r)
63        : "" (fd), "" (s), "" (n)
64        : "eax", "ebx", "ecx", "edx"
65        );
66   
67 }
68
69 void *
70 malloc (size_t size)
71 {
72   int *n;
73   int len = size + sizeof (size);
74   //n = mmap (0, len, PROT_READ | PROT_WRITE, MAP_PRIVATE | MAP_ANONYMOUS, 0, 0 );
75   *n = len;
76   return (void*)(n+1);
77 }
78
79 void
80 free (void *p)
81 {
82   int *n = (int*)p-1;
83   //munmap ((void*)p, *n);
84 }
85
86 #define EOF -1
87 #define STDIN 0
88 #define STDOUT 1
89 #define STDERR 2
90
91 //#include <stdio.h>
92 //#include <string.h>
93 //#include <stdlib.h>
94
95 int g_stdin;
96
97 size_t
98 strlen (char const* s)
99 {
100   int i = 0;
101   while (s[i]) i++;
102   return i;
103 }
104
105 int
106 strcmp (char const* a, char const* b)
107 {
108   while (*a && *b && *a == *b) {*a++;b++;}
109   return *a == *b;
110 }
111
112 int
113 getc ()
114 {
115   return read (g_stdin, 1);
116 }
117
118 int
119 puts (char const* s)
120 {
121   write (STDOUT, s, strlen (s));
122   return 0;
123 }
124
125 int
126 eputs (char const* s)
127 {
128   write (STDERR, s, strlen (s));
129   return 0;
130 }
131
132 char const*
133 itoa (int x)
134 {
135   static char buf[10];
136   char *p = buf+9;
137   *p-- = 0;
138
139   int sign = x < 0;
140   if (sign)
141     x = -x;
142   
143   do
144     {
145       *p-- = '0' + (x % 10);
146       x = x / 10;
147     } while (x);
148
149   if (sign)
150     *p-- = '-';
151
152   return p+1;
153 }
154
155 void
156 assert_fail (char* s)
157 {
158   eputs ("assert fail:");
159   eputs (s);
160   eputs ("\n");
161   *((int*)0) = 0;
162 }
163
164 #define assert(x) ((x) ? (void)0 : assert_fail(#x))
165 #define false 0
166 #define true 1
167 typedef int bool;
168
169 int ARENA_SIZE = 100000;
170
171 typedef int SCM;
172 enum type_t {CHAR, CLOSURE, CONTINUATION, FUNCTION, KEYWORD, MACRO, NUMBER, PAIR, REF, SPECIAL, STRING, SYMBOL, VALUES, VECTOR, BROKEN_HEART};
173 typedef SCM (*function0_t) (void);
174 typedef SCM (*function1_t) (SCM);
175 typedef SCM (*function2_t) (SCM, SCM);
176 typedef SCM (*function3_t) (SCM, SCM, SCM);
177 typedef SCM (*functionn_t) (SCM);
178 typedef struct function_struct {
179   union {
180     function0_t function0;
181     function1_t function1;
182     function2_t function2;
183     function3_t function3;
184     functionn_t functionn;
185   } data;
186   int arity;
187 } function_t;
188 struct scm;
189
190 typedef struct scm_struct {
191   enum type_t type;
192   union {
193     char const *name;
194     SCM string;
195     SCM car;
196     SCM ref;
197     int length;
198   } NYACC;
199   union {
200     int value;
201     int function;
202     SCM cdr;
203     SCM closure;
204     SCM continuation;
205     SCM macro;
206     SCM vector;
207     int hits;
208   } NYACC2;
209 } scm;
210
211 scm scm_nil = {SPECIAL, "()"};
212 scm scm_f = {SPECIAL, "#f"};
213 scm scm_t = {SPECIAL, "#t"};
214 scm scm_dot = {SPECIAL, "."};
215 scm scm_arrow = {SPECIAL, "=>"};
216 scm scm_undefined = {SPECIAL, "*undefined*"};
217 scm scm_unspecified = {SPECIAL, "*unspecified*"};
218 scm scm_closure = {SPECIAL, "*closure*"};
219 scm scm_circular = {SPECIAL, "*circular*"};
220 scm scm_begin = {SPECIAL, "*begin*"};
221
222
223 //#include "mes.symbols.h"
224 #define cell_nil 1
225 #define cell_f 2
226 #define cell_t 3
227 #define cell_dot 4
228 #define cell_arrow 5
229 #define cell_undefined 6
230 #define cell_unspecified 7
231 #define cell_closure 8
232 #define cell_circular 9
233 #define cell_begin 10
234 #define cell_symbol_dot 11
235 #define cell_symbol_lambda 12
236 #define cell_symbol_begin 13
237 #define cell_symbol_if 14
238 #define cell_symbol_quote 15
239 #define cell_symbol_set_x 16
240
241 #if __GNUC__
242 bool g_debug = false;
243 #endif
244
245 int g_free = 0;
246 scm *g_cells;
247 //scm *g_news = 0;
248 SCM tmp;
249 SCM tmp_num;
250 SCM tmp_num2;
251
252 function_t functions[200];
253 int g_function = 0;
254
255 SCM g_symbols = 0;
256 SCM g_stack = 0;
257 SCM r0 = 0; // a/env
258 SCM r1 = 0; // param 1
259 SCM r2 = 0; // save 2+load/dump
260 SCM r3 = 0; // continuation
261
262 SCM make_cell (SCM type, SCM car, SCM cdr);
263 function_t fun_make_cell = {&make_cell, 3};
264 scm scm_make_cell = {FUNCTION, "make-cell", 0};
265 SCM cell_make_cell;
266
267 SCM cons (SCM x, SCM y);
268 function_t fun_cons = {&cons, 2};
269 scm scm_cons = {FUNCTION, "cons", 0};
270 SCM cell_cons;
271
272 SCM car (SCM x);
273 function_t fun_car = {&car, 1};
274 scm scm_car = {FUNCTION, "car", 0};
275 SCM cell_car;
276
277 SCM cdr (SCM x);
278 function_t fun_cdr = {&cdr, 1};
279 scm scm_cdr = {FUNCTION, "cdr", 0};
280 SCM cell_cdr;
281
282 // SCM eq_p (SCM x, SCM y);
283 // function_t fun_eq_p = {&eq_p, 2};
284 // scm scm_eq_p = {FUNCTION, "eq?", 0};
285 // SCM cell_eq_p;
286
287 #define TYPE(x) g_cells[x].type
288
289 #define CAR(x) g_cells[x].car
290 #define LENGTH(x) g_cells[x].length
291 #define STRING(x) g_cells[x].string
292
293 #define CDR(x) g_cells[x].cdr
294 #define VALUE(x) g_cells[x].value
295 #define VECTOR(x) g_cells[x].vector
296
297 #define MAKE_CHAR(n) make_cell (tmp_num_ (CHAR), 0, tmp_num2_ (n))
298 //#define MAKE_CONTINUATION(n) make_cell (tmp_num_ (CONTINUATION), n, g_stack)
299 //#define MAKE_NUMBER(n) make_cell (tmp_num_ (NUMBER), 0, tmp_num2_ (n))
300 //#define MAKE_REF(n) make_cell (tmp_num_ (REF), n, 0)
301 #define MAKE_STRING(x) make_cell (tmp_num_ (STRING), x, 0)
302
303 SCM
304 alloc (int n)
305 {
306   assert (g_free + n < ARENA_SIZE);
307   SCM x = g_free;
308   g_free += n;
309   return x;
310 }
311
312 SCM
313 make_cell (SCM type, SCM car, SCM cdr)
314 {
315   SCM x = alloc (1);
316   assert (TYPE (type) == NUMBER);
317   TYPE (x) = VALUE (type);
318   if (VALUE (type) == CHAR || VALUE (type) == NUMBER) {
319     if (car) CAR (x) = CAR (car);
320     if (cdr) CDR (x) = CDR (cdr);
321   } else if (VALUE (type) == FUNCTION) {
322     if (car) CAR (x) = car;
323     if (cdr) CDR (x) = CDR (cdr);
324   } else {
325     CAR (x) = car;
326     CDR (x) = cdr;
327   }
328   return x;
329 }
330
331 SCM
332 tmp_num_ (int x)
333 {
334   VALUE (tmp_num) = x;
335   return tmp_num;
336 }
337
338 SCM
339 tmp_num2_ (int x)
340 {
341   VALUE (tmp_num2) = x;
342   return tmp_num2;
343 }
344
345 SCM
346 cons (SCM x, SCM y)
347 {
348   VALUE (tmp_num) = PAIR;
349   return make_cell (tmp_num, x, y);
350 }
351
352 SCM
353 car (SCM x)
354 {
355 #if MES_MINI
356   assert("!car");
357 #else
358   if (TYPE (x) != PAIR) error (cell_symbol_not_a_pair, cons (x, cell_symbol_car));
359 #endif
360   return CAR (x);
361 }
362
363 SCM
364 cdr (SCM x)
365 {
366 #if MES_MINI
367   assert("!car");
368 #else
369   if (TYPE (x) != PAIR) error (cell_symbol_not_a_pair, cons (x, cell_symbol_cdr));
370 #endif
371   return CDR (x);
372 }
373
374 // SCM
375 // eq_p (SCM x, SCM y)
376 // {
377 //   return (x == y
378 //           || ((TYPE (x) == KEYWORD && TYPE (y) == KEYWORD
379 //                && STRING (x) == STRING (y)))
380 //           || (TYPE (x) == CHAR && TYPE (y) == CHAR
381 //               && VALUE (x) == VALUE (y))
382 //           || (TYPE (x) == NUMBER && TYPE (y) == NUMBER
383 //               && VALUE (x) == VALUE (y)))
384 //     ? cell_t : cell_f;
385 // }
386
387 SCM
388 gc_push_frame ()
389 {
390   SCM frame = cons (r1, cons (r2, cons (r3, cons (r0, cell_nil))));
391   return g_stack = cons (frame, g_stack);
392 }
393
394 SCM
395 push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal))
396 {
397   SCM x = r3;
398   r3 = c;
399   r2 = p2;
400   gc_push_frame ();
401   r1 = p1;
402   r0 = a;
403   r3 = x;
404   return cell_unspecified;
405 }
406
407 SCM caar (SCM x) {return car (car (x));}
408 SCM cadr (SCM x) {return car (cdr (x));}
409 SCM cdar (SCM x) {return cdr (car (x));}
410 SCM cddr (SCM x) {return cdr (cdr (x));}
411
412 SCM
413 gc_peek_frame ()
414 {
415   SCM frame = car (g_stack);
416   r1 = car (frame);
417   r2 = cadr (frame);
418   r3 = car (cddr (frame));
419   r0 = cadr (cddr (frame));
420   return frame;
421 }
422
423 SCM
424 mes_g_stack (SCM a) ///((internal))
425 {
426   r0 = a;
427   r1 = MAKE_CHAR (0);
428   r2 = MAKE_CHAR (0);
429   r3 = MAKE_CHAR (0);
430   g_stack = cons (cell_nil, cell_nil);
431   return r0;
432 }
433
434 //\f Environment setup
435 SCM
436 make_tmps (scm* cells)
437 {
438   tmp = g_free++;
439   cells[tmp].type = CHAR;
440   tmp_num = g_free++;
441   cells[tmp_num].type = NUMBER;
442   tmp_num2 = g_free++;
443   cells[tmp_num2].type = NUMBER;
444 }
445
446 SCM
447 make_symbol_ (SCM s)
448 {
449   VALUE (tmp_num) = SYMBOL;
450   SCM x = make_cell (tmp_num, s, 0);
451   g_symbols = cons (x, g_symbols);
452   return x;
453 }
454
455 SCM
456 make_symbol (SCM s)
457 {
458 #if MES_MINI
459   SCM x = 0;
460 #else
461   SCM x = lookup_symbol_ (s);
462 #endif
463   return x ? x : make_symbol_ (s);
464 }
465
466 SCM
467 cstring_to_list (char const* s)
468 {
469   SCM p = cell_nil;
470   int i = strlen (s);
471   while (i--)
472     p = cons (MAKE_CHAR (s[i]), p);
473   return p;
474 }
475
476 SCM
477 acons (SCM key, SCM value, SCM alist)
478 {
479   return cons (cons (key, value), alist);
480 }
481
482 //\f Jam Collector
483 SCM g_symbol_max;
484
485 SCM
486 gc_init_cells ()
487 {
488   g_cells = (scm *)malloc (2*ARENA_SIZE*sizeof(scm));
489   g_cells[0].type = VECTOR;
490   LENGTH (0) = 1000;
491   VECTOR (0) = 0;
492   g_cells++;
493   g_cells[0].type = CHAR;
494   VALUE (0) = 'c';
495 }
496
497 // INIT NEWS
498
499 SCM
500 mes_symbols () ///((internal))
501 {
502   gc_init_cells ();
503   //  gc_init_news ();
504
505 #if __GNUC__ && 0
506   //#include "mes.symbols.i"
507 #else
508 g_free++;
509 g_cells[cell_nil] = scm_nil;
510
511 g_free++;
512 g_cells[cell_f] = scm_f;
513
514 g_free++;
515 g_cells[cell_t] = scm_t;
516
517 g_free++;
518 g_cells[cell_dot] = scm_dot;
519
520 g_free++;
521 g_cells[cell_arrow] = scm_arrow;
522
523 g_free++;
524 g_cells[cell_undefined] = scm_undefined;
525
526 g_free++;
527 g_cells[cell_unspecified] = scm_unspecified;
528
529 g_free++;
530 g_cells[cell_closure] = scm_closure;
531
532 g_free++;
533 g_cells[cell_circular] = scm_circular;
534
535 g_free++;
536 g_cells[cell_begin] = scm_begin;
537
538 #endif
539
540   g_symbol_max = g_free;
541   make_tmps (g_cells);
542
543   g_symbols = 0;
544   for (int i=1; i<g_symbol_max; i++)
545     g_symbols = cons (i, g_symbols);
546
547   SCM a = cell_nil;
548
549 #if __GNUC__ && 0
550   //#include "mes.symbol-names.i"
551 #else
552 g_cells[cell_nil].car = cstring_to_list (scm_nil.name);
553 g_cells[cell_f].car = cstring_to_list (scm_f.name);
554 g_cells[cell_t].car = cstring_to_list (scm_t.name);
555 g_cells[cell_dot].car = cstring_to_list (scm_dot.name);
556 g_cells[cell_arrow].car = cstring_to_list (scm_arrow.name);
557 g_cells[cell_undefined].car = cstring_to_list (scm_undefined.name);
558 g_cells[cell_unspecified].car = cstring_to_list (scm_unspecified.name);
559 g_cells[cell_closure].car = cstring_to_list (scm_closure.name);
560 g_cells[cell_circular].car = cstring_to_list (scm_circular.name);
561 g_cells[cell_begin].car = cstring_to_list (scm_begin.name);
562 #endif
563
564   // a = acons (cell_symbol_mes_version, MAKE_STRING (cstring_to_list (VERSION)), a);
565   // a = acons (cell_symbol_mes_prefix, MAKE_STRING (cstring_to_list (PREFIX)), a);
566
567   a = acons (cell_symbol_dot, cell_dot, a); //
568   a = acons (cell_symbol_begin, cell_begin, a);
569   a = acons (cell_closure, a, a);
570
571   // a = acons (cell_symbol_call_with_current_continuation, cell_call_with_current_continuation, a);
572   // a = acons (cell_symbol_sc_expand, cell_f, a);
573
574   return a;
575 }
576
577 SCM
578 mes_environment () ///((internal))
579 {
580   SCM a = mes_symbols ();
581   return mes_g_stack (a);
582 }
583
584 SCM
585 mes_builtins (SCM a)
586 {
587 #if __GNUC__ && 0 // FIXME: Nyacc
588 // #include "mes.i"
589
590 // #include "lib.i"
591 // #include "math.i"
592 // #include "posix.i"
593 // #include "reader.i"
594
595 // #include "lib.environment.i"
596 // #include "math.environment.i"
597 // #include "mes.environment.i"
598 // #include "posix.environment.i"
599 // #include "reader.environment.i"
600 #else
601 scm_make_cell.function = g_function;
602 functions[g_function++] = fun_make_cell;
603 cell_make_cell = g_free++;
604 g_cells[cell_make_cell] = scm_make_cell;
605
606 scm_cons.function = g_function;
607 functions[g_function++] = fun_cons;
608 cell_cons = g_free++;
609 g_cells[cell_cons] = scm_cons;
610
611 scm_car.function = g_function;
612 functions[g_function++] = fun_car;
613 cell_car = g_free++;
614 g_cells[cell_car] = scm_car;
615
616 scm_cdr.function = g_function;
617 functions[g_function++] = fun_cdr;
618 cell_cdr = g_free++;
619 g_cells[cell_cdr] = scm_cdr;
620
621 // scm_eq_p.function = g_function;
622 // functions[g_function++] = fun_eq_p;
623 // cell_eq_p = g_free++;
624 // g_cells[cell_eq_p] = scm_eq_p;
625
626
627 scm_make_cell.string = cstring_to_list (scm_make_cell.name);
628 g_cells[cell_make_cell].string = MAKE_STRING (scm_make_cell.string);
629 a = acons (make_symbol (scm_make_cell.string), cell_make_cell, a);
630
631 scm_cons.string = cstring_to_list (scm_cons.name);
632 g_cells[cell_cons].string = MAKE_STRING (scm_cons.string);
633 a = acons (make_symbol (scm_cons.string), cell_cons, a);
634
635 scm_car.string = cstring_to_list (scm_car.name);
636 g_cells[cell_car].string = MAKE_STRING (scm_car.string);
637 a = acons (make_symbol (scm_car.string), cell_car, a);
638
639 scm_cdr.string = cstring_to_list (scm_cdr.name);
640 g_cells[cell_cdr].string = MAKE_STRING (scm_cdr.string);
641 a = acons (make_symbol (scm_cdr.string), cell_cdr, a);
642
643 // scm_eq_p.string = cstring_to_list (scm_eq_p.name);
644 // g_cells[cell_eq_p].string = MAKE_STRING (scm_eq_p.string);
645 // a = acons (make_symbol (scm_eq_p.string), cell_eq_p, a);
646
647 #endif
648   return a;
649 }
650
651 int
652 getchar ()
653 {
654   return getc (g_stdin);
655 }
656
657 SCM
658 bload_env (SCM a) ///((internal))
659 {
660   g_stdin = open ("module/mes/read-0.mo", 0);
661 #if __GNUC__
662   //g_stdin = g_stdin ? g_stdin : fopen (PREFIX "module/mes/read-0.mo", "r");
663 #endif
664   char *p = (char*)g_cells;
665   assert (getchar () == 'M');
666   assert (getchar () == 'E');
667   assert (getchar () == 'S');
668   g_stack = getchar () << 8;
669   g_stack += getchar ();
670   int c = getchar ();
671   while (c != EOF)
672     {
673       *p++ = c;
674       c = getchar ();
675     }
676   g_free = (p-(char*)g_cells) / sizeof (scm);
677   gc_peek_frame ();
678   g_symbols = r1;
679   g_stdin = STDIN;
680   r0 = mes_builtins (r0);
681   return r2;
682 }
683
684 char const*
685 string_to_cstring (SCM s)
686 {
687   static char buf[1024];
688   char *p = buf;
689   s = STRING (s);
690   while (s != cell_nil)
691     {
692       *p++ = VALUE (car (s));
693       s = cdr (s);
694     }
695   *p = 0;
696   return buf;
697 }
698
699 SCM
700 stderr_ (SCM x)
701 {
702   //SCM write;
703   if (TYPE (x) == STRING)
704     eputs (string_to_cstring (x));
705   // else if ((write = assq_ref_cache (cell_symbol_write, r0)) != cell_undefined)
706   //   apply (assq_ref_cache (cell_symbol_display, r0), cons (x, cons (MAKE_NUMBER (2), cell_nil)), r0);
707   else if (TYPE (x) == SPECIAL || TYPE (x) == STRING || TYPE (x) == SYMBOL)
708     eputs (string_to_cstring (x));
709   else if (TYPE (x) == NUMBER)
710     eputs (itoa (VALUE (x)));
711   else
712     eputs ("display: undefined\n");
713   return cell_unspecified;
714 }
715
716 int
717 main (int argc, char *argv[])
718 {
719   eputs (itoa (234));
720   eputs ("\n");
721   assert(!"boo");
722   return 33;
723   
724 #if __GNUC__
725   //g_debug = getenv ("MES_DEBUG");
726 #endif
727   //if (getenv ("MES_ARENA")) ARENA_SIZE = atoi (getenv ("MES_ARENA"));
728   if (argc > 1 && !strcmp (argv[1], "--help")) return eputs ("Usage: mes [--dump|--load] < FILE");
729   if (argc > 1 && !strcmp (argv[1], "--version")) {eputs ("Mes ");return eputs (VERSION);};
730   g_stdin = STDIN;
731   r0 = mes_environment ();
732
733 #if MES_MINI
734   SCM program = bload_env (r0);
735 #else  
736   SCM program = (argc > 1 && !strcmp (argv[1], "--load"))
737     ? bload_env (r0) : load_env (r0);
738   if (argc > 1 && !strcmp (argv[1], "--dump")) return dump ();
739 #endif
740
741   push_cc (r2, cell_unspecified, r0, cell_unspecified);
742   // r3 = cell_vm_begin;
743   // r1 = eval_apply ();
744   stderr_ (r1);
745
746   eputs ("\n");
747 #if !MES_MINI
748   gc (g_stack);
749 #endif
750 #if __GNUC__
751   if (g_debug)
752     {
753       eputs ("\nstats: [");
754       eputs (itoa (g_free));
755       eputs ("]\n");
756     }
757 #endif
758   puts ("Hello mini-mes!\n");
759   return 0;
760 }
761
762 void
763 _start ()
764 {
765   /* main body of program: call main(), etc */
766   
767   /* exit system call */
768   asm (
769        "movl $1,%eax;"
770        "xorl %ebx,%ebx;"
771        "int  $0x80"
772        );
773 }