mescc: Support mini-mes running scheme program with builtins.
authorJan Nieuwenhuizen <janneke@gnu.org>
Sun, 12 Mar 2017 11:02:12 +0000 (12:02 +0100)
committerJan Nieuwenhuizen <janneke@gnu.org>
Sun, 12 Mar 2017 11:02:12 +0000 (12:02 +0100)
Mini-mes, compiled with either gcc or mescc, now runs a memory dump of
this mini-0.mes program

(begin
  (write-byte (make-cell 0 0 65))
  (write-byte (make-cell 0 0 66))
          (write-byte (make-cell 0 0 67))
    (write-byte (make-cell 0 0 10))
  #f)

when read and dumped by (gcc-compiled) mes-32.

* build-aux/mes-snarf.scm: FIXES ..collapse?
* module/language/c99/compiler.mes (ast->info): Bail out on unhandled
  declarations.  Was: verbosely skip.

GNUmakefile
build-aux/mes-snarf.scm
module/language/c99/compiler.mes
module/mes/elf.mes
module/mes/libc-i386.mes
scaffold/cons-mes.c
scaffold/mini-mes.c
scaffold/t.c

index a0499aa5cea11e79d1aeeea5bb583cf7ad0595e0..800d6d6f70f036736dff7fa45237be6067b33304 100644 (file)
@@ -151,7 +151,7 @@ main: doc/examples/main.c GNUmakefile
 
 t: scaffold/t.c GNUmakefile
        rm -f $@
-       gcc -nostdlib --std=gnu99 -m32 -o $@ '-DVERSION="0.4"' $<
+       gcc -nostdlib --std=gnu99 -m32 -g -o $@ '-DVERSION="0.4"' $<
        chmod +x $@
 
 MAIN_C:=doc/examples/main.c
index 71054379eb90111657cdc9c668264077ce1293a2..d88ac014147ab4376ac4477099eb53d7756722f8 100755 (executable)
@@ -80,7 +80,13 @@ exec ${GUILE-guile} --no-auto-compile -L $HOME/src/mes/build-aux -L build-aux -e
 (define (symbol->source s i)
   (string-append
    (format #f "g_free++;\n")
-   (format #f "g_cells[cell_~a] = scm_~a;\n\n" s s)))
+   ;; FIXME: g_functions
+   (if GCC?
+       (format #f "g_cells[cell_~a] = scm_~a;\n\n" s s)
+       (string-append
+         (format #f "g_cells[cell_~a].type = scm_~a.type;\n" s s)
+         (format #f "g_cells[cell_~a].car = scm_~a.car;\n" s s)
+         (format #f "g_cells[cell_~a].cdr = scm_~a.cdr;\n\n" s s)))))
 
 (define (symbol->names s i)
   (string-append
@@ -110,7 +116,14 @@ exec ${GUILE-guile} --no-auto-compile -L $HOME/src/mes/build-aux -L build-aux -e
        (format #f "~a.cdr = g_function;\n" (function-builtin-name f)))
    (format #f "g_functions[g_function++] = fun_~a;\n" (.name f))
    (format #f "cell_~a = g_free++;\n" (.name f))
-   (format #f "g_cells[cell_~a] = ~a;\n\n" (.name f) (function-builtin-name f))))
+   ;; FIXME: g_functions
+   (if GCC?
+       (format #f "g_cells[cell_~a] = ~a;\n\n" (.name f) (function-builtin-name f))
+       (string-append
+         (format #f "g_cells[cell_~a].type = ~a.type;\n" (.name f) (function-builtin-name f))
+         (format #f "g_cells[cell_~a].car = ~a.car;\n" (.name f) (function-builtin-name f))
+         ;;(format #f "g_cells[cell_~a].car = MAKE_STRING (~a.car);\n" (.name f) (function-builtin-name f))
+         (format #f "g_cells[cell_~a].cdr = ~a.cdr;\n\n" (.name f) (function-builtin-name f))))))
 
 (define (function->environment f i)
   (string-append
index 339bbdae89eae605c919cb6bce187fc4843a5988..35abc763b5eb997c195866a0c22d897d07780ab8 100644 (file)
   (cadr (assoc-ref (.types info) o)))
 
 (define (ident->decl info o)
-  (stderr "ident->decl o=~s\n" o)
+  ;; (stderr "ident->decl o=~s\n" o)
   ;; (stderr "  types=~s\n" (.types info))
   ;; (stderr "  local=~s\n" (assoc-ref (.locals info) o))
   ;; (stderr "  global=~s\n" (assoc-ref (.globals info) o))
         ;; SCM g_stack = 0;
         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
          ;;(stderr  "2TYPE: ~s\n" type)
-         (if (.function info)
-             (let* ((locals (add-local locals name type 0))
-                    (globals (append globals (list (string->global value))))
-                    (info (clone info #:locals locals #:globals globals)))
-               (clone info #:text
-                      (append text
-                              (list (lambda (f g ta t d)
-                                      (append
-                                       (i386:global->accu (+ (data-offset value g) d)))))
-                              ((accu->ident info) name))))
-             (let* ((value (length (globals->data globals)))
-                    (globals (append globals (list (ident->global name type 0 value)))))
-               (clone info #:globals globals))))
+         (let ((value (cstring->number value)))
+          (if (.function info)
+              (let* ((locals (add-local locals name type 0))
+                     (info (clone info #:locals locals)))
+                (clone info #:text
+                       (append text
+                               ((value->ident info) name value))))
+              (let ((globals (append globals (list (ident->global name type 0 value)))))
+                (clone info #:globals globals)))))
 
         ;; SCM g_stack = 0; // comment
         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident _) (initzer (p-expr (fixed _))))) (comment _))
                                                 (initzer->data info functions globals ta t d (car initzers))
                                                 (list-tail data (+ here offset field-size)))))))))))))))
 
+        ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
+         info)
+
+        ((decl (decl-spec-list (stor-spec (typedef)) ,type) ,name)
+         (format (current-error-port) "SKIP: typedef=~s\n" o)
+         info)
+
+        ((decl (@ ,at))
+         (format (current-error-port) "SKIP: at=~s\n" o)
+         info)
+
         ((decl . _)
          (format (current-error-port) "SKIP: decl statement=~s\n" o)
+         barf
          info)
 
         (_
index dcb52f6bfce8ef3f7def3169c78e14073354da5c..5b914ca09081e3f705243f3092794193659db3fa 100644 (file)
     (define section-headers-offset
       (+ str-offset str-length))
 
-    (format (current-error-port) "ELF text=~a\n" (map dec->hex text))
+    (if (< (length text) 2000)
+        (format (current-error-port) "ELF text=~a\n" (map dec->hex text)))
     (if (< (length raw-data) 200)
         (format (current-error-port) "ELF raw-data=~a\n" (map dec->hex raw-data)))
     (if (< (length data) 200)
index 70bc493524c2e8440de5d3baf6927d91386455ef..6bfe7b439f90acf6abd99d69a7e0301af6ce0d2a 100644 (file)
   '(#x55                                ; push   %ebp
     #x89 #xe5))                         ; mov    %esp,%ebp
 
+;; (define (i386:function-locals)
+;;   '(#x83 #xec #x20))               ; sub    $0x10,%esp -- 8 local vars
+
 (define (i386:function-locals)
-  '(#x83 #xec #x20))               ; sub    $0x10,%esp -- 8 local vars
+  '(#x83 #xec #x40))              ; sub    $0x10,%esp -- 16 local vars
 
 (define (i386:push-global-address o)
   (or o push-global-address)
index d500914be81a34418b8cd3e9ea25087f2601b10b..9d0a389d0220e627e3e0602bcbb1923de30e723d 100644 (file)
@@ -1170,11 +1170,13 @@ simple_bload_env (SCM a) ///((internal))
   return r2;
 }
 
+char string_to_cstring_buf[1024];
 char const*
 string_to_cstring (SCM s)
 {
-  static char buf[1024];
-  char *p = buf;
+  //static char buf[1024];
+  //char *p = buf;
+  char *p = string_to_cstring_buf;
   s = STRING(s);
   while (s != cell_nil)
     {
@@ -1182,7 +1184,8 @@ string_to_cstring (SCM s)
       s = cdr (s);
     }
   *p = 0;
-  return buf;
+  //return buf;
+  return string_to_cstring_buf;
 }
 
 SCM
index 62245d08d6e341e6b70a4dd2bada8abf4c505bb9..9de5677d83d6030cb0513f062712eee4bd0dec3f 100644 (file)
@@ -286,7 +286,8 @@ struct function {
 
 struct scm *g_cells = arena;
 
-struct scm *g_news = 0;
+//FIXME
+//struct scm *g_news = 0;
 
 struct scm scm_nil = {TSPECIAL, "()",0};
 struct scm scm_f = {TSPECIAL, "#f",0};
@@ -591,11 +592,6 @@ call (SCM fn, SCM x)
   if ((FUNCTION (fn).arity > 1 || FUNCTION (fn).arity == -1)
       && x != cell_nil && TYPE (CDR (x)) == TPAIR && TYPE (CADR (x)) == TVALUES)
     x = cons (CAR (x), cons (CDADAR (x), CDR (x)));
-
-  eputs ("call: ");
-  if (FUNCTION (fn).name) eputs (FUNCTION (fn).name);
-  else eputs (itoa (CDR (fn)));
-  eputs ("\n");
   switch (FUNCTION (fn).arity)
     {
     // case 0: return FUNCTION (fn).function0 ();
@@ -621,12 +617,46 @@ SCM
 assq (SCM x, SCM a)
 {
   //while (a != cell_nil && eq_p (x, CAAR (a)) == cell_f) a = CDR (a);
-  while (a != cell_nil && x != CAAR (a)) a = CDR (a);
-#if __GNUC__
+  //while (a != cell_nil && x != CAAR (a)) a = CDR (a);
+
+#if BDEBUG
   puts  ("assq: ");
   display_ (x);
+  puts  (" [");
+  puts (itoa (x));
+  puts  ("]\n");
+#endif
+  int i;
+  while (a != cell_nil) // && x != CAR (CAR (a)))
+    {
+      a = CDR (a);
+      // FIXME
+      i = CAR (CAR (a));
+#if  1
+      //!__GNUC__
+      // puts ("  ");
+      // puts (itoa (i));
+      // if (x == i) puts ("***FOUND*** ");
+      if (x == i) goto found;
+      // puts ("  ");
+      // display_ (CAAR (a));
+      // puts  ("[");
+      // puts (itoa (CAAR (a)));
+      // puts  ("]\n");
+#endif
+    }
+ found:
+#if BDEBUG
+  //!__GNUC__
+  //puts  ("assq: ");
+  puts  ("  ");
+  puts  (" [");
+  puts (itoa (x));
+  puts  ("]");
+  display_ (x);
   puts  (" => ");
-  display_ (a != cell_nil ? car (a) : cell_f);
+  if (a == cell_nil) display_ (cell_f);
+  else display_ (CAR (a));
   puts  ("[");
   puts (itoa (CDR (CDR (CAR (a)))));
   puts  ("]\n");
@@ -669,7 +699,10 @@ set_env_x (SCM x, SCM e, SCM a)
 SCM
 call_lambda (SCM e, SCM x, SCM aa, SCM a) ///((internal))
 {
-  SCM cl = cons (cons (cell_closure, x), x);
+  //FIXME
+  //SCM cl = cons (cons (cell_closure, x), x);
+  SCM cl;
+  cl = cons (cons (cell_closure, x), x);
   r1 = e;
   r0 = cl;
   return cell_unspecified;
@@ -774,7 +807,10 @@ eval_apply ()
     }
     case TCLOSURE:
       {
-        SCM cl = CLOSURE (car (r1));
+        //FIXME
+        //SCM cl = CLOSURE (car (r1));
+        SCM cl;
+        cl = CLOSURE (car (r1));
         SCM formals = cadr (cl);
         SCM body = cddr (cl);
         SCM aa = cdar (cl);
@@ -964,8 +1000,8 @@ eval_apply ()
           goto apply;
         }
     }
-  goto vm_return;
 #endif
+  goto vm_return;
  begin:
   x = cell_unspecified;
   while (r1 != cell_nil) {
@@ -1093,8 +1129,25 @@ SCM
 make_symbol_ (SCM s)
 {
   VALUE (tmp_num) = TSYMBOL;
-  SCM x = make_cell (tmp_num, s, 0);
+  ///FIXMESCM x = make_cell (tmp_num, s, 0);
+  SCM x;
+  x = make_cell (tmp_num, s, 0);
   puts ("MAKE SYMBOL: ");
+  // puts ("[s=");
+  // puts (itoa (s));
+  // puts (",s.car=");
+  // puts (itoa (CAR (s)));
+  // puts (",s.car.cdr=");
+  // //  puts (itoa (CDR (CAR (s))));
+  // putchar (CDR (CAR (s)));
+  // puts (",x=");
+  // puts (itoa (x));
+  // puts (",x.car=");
+  // puts (itoa (CAR (x)));
+  // puts ("]");
+
+
+  ////TYPE (x) = TSYMBOL;
   display_ (x);
   puts ("\n");
   g_symbols = cons (x, g_symbols);
@@ -1117,24 +1170,36 @@ SCM
 lookup_symbol_ (SCM s)
 {
   SCM x = g_symbols;
+#if !MES_MINI
   while (x) {
     if (list_of_char_equal_p (STRING (car (x)), s) == cell_t) break;
     x = cdr (x);
   }
   if (x) x = car (x);
+#endif;
   return x;
 }
 
 SCM
 make_symbol (SCM s)
 {
-#if 0
-  // MINI_MES
-  SCM x = 0;
+#if MES_MINI
+  return make_symbol_ (s);
 #else
   SCM x = lookup_symbol_ (s);
-#endif
+  // FIXME: does not work with mescc?!
+  // return x != 0 ? x : make_symbol_ (s);
   return x ? x : make_symbol_ (s);
+#endif
+// FIXME
+// #if MES_MINI
+//   SCM x = 0;
+// #else
+//   SCM x = lookup_symbol_ (s);
+// #endif
+//   //FIXME
+//   //return x ? x : make_symbol_ (s);
+//   return x != 0 ? x : make_symbol_ (s);
 }
 
 SCM
@@ -1143,16 +1208,38 @@ cstring_to_list (char const* s)
   char *x = s;
   SCM p = cell_nil;
   int i = strlen (s);
+  puts ("cstring_to_list[");
+  puts (s);
+  puts ("]: ");
   while (i--)
     {
 #if 0
       //FIXME
       p = cons (MAKE_CHAR (s[i]), p);
 #else
-      p = cons (MAKE_CHAR (*x), p);
+      char c;
+      c = *x;
+      puts ("[c:");
+      putchar (c);
+#if __GNUC__
+      p = cons (MAKE_CHAR (c), p);
+#else
+      SCM xx;
+      xx = MAKE_CHAR (c);
+      //FIXME
+      TYPE (xx) = 0;
+      VALUE (xx) = c;
+      puts (",t=");
+      puts (itoa (TYPE (xx)));
+      puts (",v=");
+      putchar (VALUE (xx));
+      puts ("]");
+      p = cons (xx, p);
+#endif
       x++;
 #endif
     }
+  puts ("\n");
   return p;
 }
 
@@ -1168,7 +1255,6 @@ acons (SCM key, SCM value, SCM alist)
 SCM
 write_byte (SCM x) ///((arity . n))
 {
-  puts ("write-byte 00\n");
   SCM c = car (x);
   SCM p = cdr (x);
   int fd = 1;
@@ -1176,7 +1262,10 @@ write_byte (SCM x) ///((arity . n))
   //FILE *f = fd == 1 ? stdout : stderr;
   assert (TYPE (c) == TNUMBER || TYPE (c) == TCHAR);
   //  fputc (VALUE (c), f);
-  char cc = VALUE (c);
+  // FIXME
+  //char cc = VALUE (c);
+  char cc;
+  cc = VALUE (c);
   write (1, (char*)&cc, fd);
   return c;
 }
@@ -1196,24 +1285,28 @@ display_ (SCM x)
       }
     case TFUNCTION:
       {
-#if __GNUC__
+#if 1
         puts ("#<procedure ");
-        puts (FUNCTION (x).name ? FUNCTION (x).name : "?");
+        ///puts (FUNCTION (x).name ? FUNCTION (x).name : "?");
+        char *p = "?";
+        if (FUNCTION (x).name != 0)
+          p = FUNCTION (x).name;
+        puts (p);
         puts ("[");
         puts (itoa (CDR (x)));
         puts ("]>");
         break;
 #endif
-        //puts ("<function>\n");
-        if (VALUE (x) == 0)
-          puts ("make-cell");
-        if (VALUE (x) == 1)
-          puts ("cons");
-        if (VALUE (x) == 2)
-          puts ("car");
-        if (VALUE (x) == 3)
-          puts ("cdr");
-        break;
+        // //puts ("<function>\n");
+        // if (VALUE (x) == 0)
+        //   puts ("make-cell");
+        // if (VALUE (x) == 1)
+        //   puts ("cons");
+        // if (VALUE (x) == 2)
+        //   puts ("car");
+        // if (VALUE (x) == 3)
+        //   puts ("cdr");
+        // break;
       }
     case TNUMBER:
       {
@@ -1275,43 +1368,35 @@ display_ (SCM x)
     case TSYMBOL:
       {
 #if 0
-        switch (x)
-          {
-          case 11: {puts (" . "); break;}
-          case 12: {puts ("lambda"); break;}
-          case 13: {puts ("begin"); break;}
-          case 14: {puts ("if"); break;}
-          case 15: {puts ("quote"); break;}
-          case 37: {puts ("car"); break;}
-          case 38: {puts ("cdr"); break;}
-          case 39: {puts ("null?"); break;}
-          case 40: {puts ("eq?"); break;}
-          case 41: {puts ("cons"); break;}
-          default:
-            {
-#if __GNUC__
         puts ("<s:");
         puts (itoa (x));
         puts (">");
-#else
-        puts ("<s>");
 #endif
-            }
-          }
-        break;
-#else
-        SCM t = CAR (x);
+        // FIXME
+        ///SCM t = CAR (x);
+        SCM t;
+        t = CAR (x);
         while (t != cell_nil)
           {
+            //FIXME
+            //SCM xx = CAR (t);
+            // SCM xx;
+            // xx = CAR (t);
+            // puts ("[c:");
+            // puts (itoa (xx));
+            // puts (",");
+            // puts (itoa (VALUE (xx)));
+            // puts ("]");
+            // putchar (VALUE (xx));
             putchar (VALUE (CAR (t)));
             t = CDR (t);
           }
-#endif
+        break;
       }
     default:
       {
         //puts ("<default>\n");
-#if __GNUC__
+#if 1
         puts ("<");
         puts (itoa (TYPE (x)));
         puts (":");
@@ -1407,9 +1492,6 @@ mes_builtins (SCM a) ///((internal))
 // #include "posix.environment.i"
 // #include "reader.environment.i"
 
-  puts ("cell_write_byte: ");
-  puts (itoa (CDR (cell_write_byte)));
-  puts ("\n");
   return a;
 }
 
@@ -1439,7 +1521,8 @@ bload_env (SCM a) ///((internal))
   g_symbols = r1;
   g_stdin = STDIN;
   r0 = mes_builtins (r0);
-#if __GNUC__
+#if 1
+  //__GNUC__
   puts ("symbols: ");
   SCM s = g_symbols;
   while (s && s != cell_nil) {
@@ -1465,11 +1548,13 @@ bload_env (SCM a) ///((internal))
   return r2;
 }
 
+char string_to_cstring_buf[1024];
 char const*
 string_to_cstring (SCM s)
 {
-  static char buf[1024];
-  char *p = buf;
+  //static char buf[1024];
+  //char *p = buf;
+  char *p = string_to_cstring_buf;
   s = STRING(s);
   while (s != cell_nil)
     {
@@ -1477,7 +1562,8 @@ string_to_cstring (SCM s)
       s = cdr (s);
     }
   *p = 0;
-  return buf;
+  //return buf;
+  return string_to_cstring_buf;
 }
 
 SCM
@@ -1509,6 +1595,16 @@ int
 main (int argc, char *argv[])
 {
   eputs ("Hello mini-mes!\n");
+
+  // make_tmps (g_cells);
+  // SCM x = cstring_to_list ("bla");
+  // while (x != 1)
+  //   {
+  //     putchar (CDR (CAR (x)));
+  //     x = CDR (x);
+  //   }
+  // return 0;
+
 #if __GNUC__
   //g_debug = getenv ("MES_DEBUG");
 #endif
index 5121c9695bafc12442182ca697e2d4b0336fada2..23def0f28d584ac0267e56c25164324acc5521bc 100644 (file)
@@ -117,7 +117,7 @@ int functions[2];
 struct function g_functions[2];
 int g_function = 0;
 
-enum type_t {CHAR, CLOSURE, CONTINUATION, TFUNCTION, KEYWORD, MACRO, NUMBER, PAIR, REF, SPECIAL, TSTRING, SYMBOL, VALUES, TVECTOR, BROKEN_HEART};
+enum type_t {TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TREF, TSPECIAL, TSTRING, TSYMBOL, TVALUES, TVECTOR, TBROKEN_HEART};
 
 typedef int SCM;
 int g_free = 3;
@@ -193,7 +193,7 @@ swits (int c)
 
   switch (c)
     {
-    case CHAR: {goto next;}
+    case TCHAR: {goto next;}
     case 1: {goto next;}
     case 2: {goto next;}
     default: {goto next;}
@@ -277,7 +277,7 @@ make_cell (SCM type, SCM car, SCM cdr)
 {
   SCM x = alloc (1);
   TYPE (x) = VALUE (type);
-  if (VALUE (type) == CHAR || VALUE (type) == NUMBER) {
+  if (VALUE (type) == TCHAR || VALUE (type) == TNUMBER) {
     if (car) CAR (x) = CAR (car);
     if (cdr) CDR(x) = CDR(cdr);
   }
@@ -295,7 +295,7 @@ make_cell (SCM type, SCM car, SCM cdr)
 SCM
 make_cell_test ()
 {
-  VALUE (tmp_num) = PAIR;
+  VALUE (tmp_num) = TPAIR;
   make_cell (tmp_num, 0, 1);
   return math_test ();
 }
@@ -306,9 +306,9 @@ make_tmps_test (struct scm* cells)
   puts ("t: tmp = g_free++\n");
   tmp = g_free++;
   puts ("t: cells[tmp].type = CHAR\n");
-  cells[tmp].type = CHAR;
+  cells[tmp].type = TCHAR;
   tmp_num = g_free++;
-  cells[tmp_num].type = NUMBER;
+  cells[tmp_num].type = TNUMBER;
 
   return make_cell_test();
 }