mescc: Support strings in struct initialization.

* module/mes/elf-util.mes (add-s:-prefix, drop-s:-prefix): New functions.
* module/mes/elf-util.scm: Export them.
* module/language/c99/compiler.mes (string->global): Add `s:' prefix
  to global strings.  Update users.
  (expr->arg): Update.
  (expr->accu): Handle string expressions.
  (initzer->global): New function.
  (struct-field): Handle string field.
* doc/examples/t.c: Test it.
* doc/examples/mini-mes.c: Use it.

dun!

diff --git a/module/language/c99/compiler.mes b/module/language/c99/compiler.mes
index e80efc50f979380b2fe2940dc06347663038dc39..7a55c03de77921c7f8f0a1bfd746b86f90b1919b 100644 (file)
--- a/module/language/c99/compiler.mes
+++ b/module/language/c99/compiler.mes
@@ -204,7 +204,7 @@
       (i386:push-local-de-ref (local:id o)))))
 
 (define (string->global string)
-  (make-global string "string" 0 (append (string->list string) (list #\nul))))
+  (make-global (add-s:-prefix string) "string" 0 (append (string->list string) (list #\nul))))
 
 (define (ident->global name type pointer value)
   (make-global name type pointer (int->bv32 value)))
@@ -256,7 +256,7 @@
                                           (i386:push-accu))))))))
 
         ((p-expr (string ,string))
-         (clone info #:text (append text (list ((push-global-address info) string)))))
+         (clone info #:text (append text (list ((push-global-address info) (add-s:-prefix string))))))
 
         ((p-expr (ident ,name))
          (clone info #:text (append text (list ((push-ident info) name)))))
@@ -344,7 +344,7 @@
       ;;     (stderr "globals: ~a\n" (map car (.globals info))))
       (if local
           (let ((ptr (local:pointer local)))
-            (stderr "ident->accu PTR[~a]: ~a\n" o ptr)
+            ;;(stderr "ident->accu PTR[~a]: ~a\n" o ptr)
             (cond ((equal? o "c1")
                    (list (lambda (f g ta t d)
                            (i386:byte-local->accu (local:id local))))) ;; FIXME type
@@ -359,7 +359,7 @@
                                    (i386:local->accu (local:id local)))))))))
           (if global
               (let ((ptr (ident->pointer info o)))
-                (stderr "ident->accu PTR[~a]: ~a\n" o ptr)
+                ;;(stderr "ident->accu PTR[~a]: ~a\n" o ptr)
                 (case ptr
                   ((-1) (list (lambda (f g ta t d)
                                 (i386:global->accu (+ (data-offset o g) d)))))
@@ -425,14 +425,14 @@
 (define (ident->base info)
   (lambda (o)
     (let ((local (assoc-ref (.locals info) o)))
-      (stderr "ident->base: local[~a]: ~a\n" o (and local (local:id local)))
+      ;;(stderr "ident->base: local[~a]: ~a\n" o (and local (local:id local)))
       (if local
           (list (lambda (f g ta t d)
                   (i386:local->base (local:id local))))
           (let ((global (assoc-ref (.globals info) o) ))
             (if global
                 (let ((ptr (ident->pointer info o)))
-                (stderr "ident->accu PTR[~a]: ~a\n" o ptr)
+                  ;;(stderr "ident->accu PTR[~a]: ~a\n" o ptr)
                 (case ptr
                   ((-1) (list (lambda (f g ta t d)
                                 (i386:global->base (+ (data-offset o g) d)))))
@@ -448,9 +448,15 @@
 (define (expr->accu info)
   (lambda (o)
     (let ((text (.text info))
-          (locals (.locals info)))
+          (locals (.locals info))
+          (globals (.globals info)))
       ;;(stderr "expr->accu o=~a\n" o)
       (pmatch o
+        ((p-expr (string ,string))
+         (clone info #:text (append text (list (lambda (f g ta t d)
+                                                 ;;(stderr "OFF[~a]: ~a\n" string (data-offset string globals))
+                                                 ;;(stderr "globals: ~s\n" (map car globals))
+                                                 (i386:global->accu (+ (data-offset (add-s:-prefix string) globals) d)))))))
         ((p-expr (fixed ,value))
          (clone info #:text (append text (value->accu (cstring->number value)))))
         ((p-expr (ident ,name))
@@ -566,7 +572,6 @@
                           '()))
                 (offset (* field-size (1- (length rest))))
                 (text (.text info)))
-           ;;(stderr "COUNT=~a\n" count)
            (clone info #:text
                   (append text
                           (.text index)
@@ -601,7 +606,6 @@
                         ((ident->accu info) name))))
 
         ((de-ref (p-expr (ident ,name)))
-         (stderr "de-ref: ~a\n" name)
          (clone info #:text
                 (append text
                         ((ident->accu info) name)
@@ -808,6 +812,11 @@
     ((p-expr (string ,string)) (string->global string))
     (_ #f)))
 
+(define (initzer->global o)
+  (pmatch o
+    ((initzer ,initzer) (expr->global initzer))
+    (_ #f)))
+
 (define (byte->hex o)
   (string->number (string-drop o 2) 16))
 
@@ -972,7 +981,9 @@
      (cons type name))
     ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ftn-declr (scope (ptr-declr (pointer) (ident ,name))) (param-list (param-decl (decl-spec-list (type-spec (void)))))))))
      (cons type name)) ;; FIXME function / int
-    (_ (stderr "struct-field: no match: ~a" o) barf)))
+    ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
+     (cons type name)) ;; FIXME: ptr/char
+    (_ (stderr "struct-field: no match: ~s\n" o) barf)))
 
 (define (ast->type o)
   (pmatch o
@@ -993,7 +1004,7 @@
   (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))
@@ -1536,16 +1547,16 @@
 
         ;; char *p = "t.c";
         ;;(decl (decl-spec-list (type-spec (fixed-type "char"))) (init-declr-list (init-declr (ptr-declr (pointer) (ident "p")) (initzer (p-expr (string "t.c\n"))))))
-        ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (string ,value))))))
+        ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (string ,string))))))
          (if (not (.function info)) decl-barf3)
          (let* ((locals (add-local locals name type 1))
-                (globals (append globals (list (string->global value))))
+                (globals (append globals (list (string->global string))))
                 (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)))))
+                                   (i386:global->accu (+ (data-offset (add-s:-prefix string) g) d)))))
                           ((accu->ident info) name)))))
         
         ;; char arena[20000];
@@ -1731,7 +1742,7 @@
         ;; struct
         ((decl (decl-spec-list (type-spec (struct-def (ident ,name) (field-list . ,fields)))))
          (let* ((type (struct->type (list "struct" name) (map struct-field fields))))
-           (stderr "type: ~a\n" type)
+           ;;(stderr "type: ~a\n" type)
            (clone info #:types (append (.types info) (list type)))))
 
         ;; *p++ = b;
@@ -1821,8 +1832,8 @@
                 (count (length fields))
                 (field-size 4) ;; FIXME:4, not fixed
                 (ptr (ident->pointer info array)))
-          (clone info #:text
-                 (append text
+           (clone info #:text
+                  (append text
                          (.text base)
                          (list (lambda (f g ta t d)
                                  (i386:push-base)))
@@ -1841,6 +1852,9 @@
                          (cond ((equal? array "g_functions") ;; FIXME
                                 (list (lambda (f g ta t d)
                                         (append
+                                         (i386:base-address->accu-address)
+                                         (i386:accu+n 4)
+                                         (i386:base+n 4)
                                          (i386:base-address->accu-address)
                                          (i386:accu+n 4)
                                          (i386:base+n 4)
@@ -1888,6 +1902,9 @@
                          (cond ((equal? array "g_functions") ;; FIXME
                                 (list (lambda (f g ta t d)
                                         (append
+                                         (i386:base-address->accu-address)
+                                         (i386:accu+n 4)
+                                         (i386:base+n 4)
                                          (i386:base-address->accu-address)
                                          (i386:accu+n 4)
                                          (i386:base+n 4)
@@ -1934,6 +1951,9 @@
                          (cond ((equal? array "g_functions") ;; FIXME
                                 (list (lambda (f g ta t d)
                                         (append
+                                         (i386:base-address->accu-address)
+                                         (i386:accu+n 4)
+                                         (i386:base+n 4)
                                          (i386:base-address->accu-address)
                                          (i386:accu+n 4)
                                          (i386:base+n 4)
@@ -1953,14 +1973,14 @@
                 (field-size 4))  ;; FIXME:4, not fixed
            ;;(stderr  "7TYPE: ~s\n" type)
            (if (.function info)
-               (let* ((locals (let loop ((fields (cdr fields)) (locals locals))
+               (let* ((globals (append globals (filter-map initzer->global initzers)))
+                      (locals (let loop ((fields (cdr fields)) (locals locals))
                                 (if (null? fields) locals
                                     (loop (cdr fields) (add-local locals "foobar" "int" 0)))))
                       (locals (add-local locals name type -1))
-                      (info (clone info #:locals locals))
+                      (info (clone info #:locals locals #:globals globals))
                       (empty (clone info #:text '())))
                  (let loop ((fields (iota (length fields))) (initzers initzers) (info info))
-                   ;; (stderr "LOEP local initzers=~s\n" initzers)
                    (if (null? fields) info
                        (let ((offset (* field-size (car fields)))
                              (initzer (car initzers)))
@@ -1975,13 +1995,13 @@
                                        (.text ((expr->accu empty) initzer))
                                        (list (lambda (f g ta t d)
                                                (i386:accu->base-address+n offset))))))))))
-               (let* ((global (make-global name type -1 (string->list (make-string size #\nul))))
+               (let* ((globals (append globals (filter-map initzer->global initzers)))
+                      (global (make-global name type -1 (string->list (make-string size #\nul))))
                       (globals (append globals (list global)))
                       (here (data-offset name globals))
                       (info (clone info #:globals globals))
                       (field-size 4))
                  (let loop ((fields (iota (length fields))) (initzers initzers) (info info))
-                   ;; (stderr "LOEP local initzers=~s\n" initzers)
                    (if (null? fields) info
                        (let ((offset (* field-size (car fields)))
                              (initzer (car initzers)))
@@ -2013,6 +2033,8 @@
     ((initzer (p-expr (ident ,name)))
      (let ((value (assoc-ref (.constants info) name)))
        (int->bv32 value)))
+    ((initzer (p-expr (string ,string)))
+     (int->bv32 (+ (data-offset (add-s:-prefix string) globals) d)))
     (_ (stderr "initzer->data:SKIP: ~s\n" o)
        barf
      (int->bv32 0))))
@@ -2064,10 +2086,10 @@
       (format (current-error-port) "compiling ~a\n" name)
       ;;(stderr "locals=~a\n" locals)
       (let loop ((statements (.statements o))
-                 (info (clone info #:locals locals #:function name #:text text)))
+                 (info (clone info #:locals locals #:function (.name o) #:text text)))
         (if (null? statements) (clone info
                                       #:function #f
-                                      #:functions (append (.functions info) (list (cons (.name o) (.text info)))))
+                                      #:functions (append (.functions info) (list (cons name (.text info)))))
             (let* ((statement (car statements)))
               (loop (cdr statements)
                     ((ast->info info) (car statements)))))))))

diff --git a/module/mes/elf-util.mes b/module/mes/elf-util.mes
index 5334de1d862edb81c8ea06e1cac4d9c142356fe1..002d4c84e821c7258b7dd9e5037af0dd2136ecb6 100644 (file)
--- a/module/mes/elf-util.mes
+++ b/module/mes/elf-util.mes
@@ -38,6 +38,9 @@
 (define global:pointer cadr)
 (define global:value caddr)
 
+(define (drop-s:-prefix o) (substring o 2))
+(define (add-s:-prefix o) (string-append "s:" o))
+
 (define (dec->hex o)
   (cond ((number? o) (number->string o 16))
         ((char? o) (number->string (char->integer o) 16))))

diff --git a/module/mes/elf-util.scm b/module/mes/elf-util.scm
index 15394e2a6aa75344735424f908e41b5cb57758ed..9ed6178bf925b4836669774b0e26ddf3fb7fe2e4 100644 (file)
--- a/module/mes/elf-util.scm
+++ b/module/mes/elf-util.scm
@@ -26,6 +26,8 @@
   #:use-module (srfi srfi-1)
   #:export (data-offset
             dec->hex
+            add-s:-prefix
+            drop-s:-prefix
             function-offset
             label-offset
             functions->lambdas

diff --git a/scaffold/mini-mes.c b/scaffold/mini-mes.c
index 794cd992d41bec0fb911f2ad96f275af838659ed..047cba4388012eb261b2545d2bc4845fa365cd2b 100644 (file)
--- a/scaffold/mini-mes.c
+++ b/scaffold/mini-mes.c
@@ -386,8 +386,8 @@ SCM make_cell (SCM type, SCM car, SCM cdr);
 #endif
 struct function fun_make_cell = {&make_cell, 3};
 
-#if __GNUC__
-struct scm scm_make_cell = {TFUNCTION, "make-cell", 0};
+#if 1
+struct scm scm_make_cell = {TFUNCTION,"make-cell",0};
 #else
 struct scm scm_make_cell = {TFUNCTION,0,0};
 #endif
@@ -399,9 +399,9 @@ SCM cons (SCM x, SCM y);
 #endif
 struct function fun_cons = {&cons, 2};
 #if __GNUC__
-struct scm scm_cons = {TFUNCTION,"cons", 0};
+struct scm scm_cons = {TFUNCTION,"cons",0};
 #else
-struct scm scm_make_cell = {TFUNCTION,0,0};
+struct scm scm_cons = {TFUNCTION,0,0};
 #endif
 SCM cell_cons;
 
@@ -411,9 +411,9 @@ SCM car (SCM x);
 #endif
 struct function fun_car = {&car, 1};
 #if __GNUC__
-struct scm scm_car = {TFUNCTION,"car", 0};
+struct scm scm_car = {TFUNCTION,"car",0};
 #else
-struct scm scm_make_cell = {TFUNCTION,0,0};
+struct scm scm_car = {TFUNCTION,0,0};
 #endif
 SCM cell_car;
 
@@ -423,9 +423,9 @@ SCM cdr (SCM x);
 #endif
 struct function fun_cdr = {&cdr, 1};
 #if __GNUC__
-struct scm scm_cdr = {TFUNCTION,"cdr", 0};
+struct scm scm_cdr = {TFUNCTION,"cdr",0};
 #else
-struct scm scm_make_cell = {TFUNCTION,0,0};
+struct scm scm_cdr = {TFUNCTION,0,0};
 #endif
 SCM cell_cdr;
 
@@ -1433,6 +1433,7 @@ g_functions[g_function++] = fun_cdr;
 cell_cdr = g_free++;
 g_cells[cell_cdr] = scm_cdr;
 
+ #if 1
 //scm_make_cell.string = cstring_to_list (scm_make_cell.name);
 //g_cells[cell_make_cell].string = MAKE_STRING (scm_make_cell.string);
 //a = acons (make_symbol (scm_make_cell.string), cell_make_cell, a);
@@ -1465,6 +1466,8 @@ scm_cdr.car = cstring_to_list (scm_cdr.car);
 g_cells[cell_cdr].car = MAKE_STRING (scm_cdr.car);
 a = acons (make_symbol (scm_cdr.car), cell_cdr, a);
 
+ #endif
+ 
 #endif
   return a;
 }

diff --git a/scaffold/t.c b/scaffold/t.c
index 61c36014d3d2eddc7ad50b39a4a3125ae9fcdd53..b1547cbf821d2ed8f052268d975ac86ba47b7675 100644 (file)
--- a/scaffold/t.c
+++ b/scaffold/t.c
@@ -105,10 +105,11 @@ int bar (int i) {puts ("t: bar\n"); return 0;};
 struct function {
   int (*function) (void);
   int arity;
+  char *name;
 };
-struct function g_fun = {&exit, 1};
-struct function g_foo = {&foo, 0};
-struct function g_bar = {&bar, 1};
+struct function g_fun = {&exit,1,"fun"};
+struct function g_foo = {&foo,0,"foo"};
+struct function g_bar = {&bar,1,"bar"};
 
 //void *functions[2];
 int functions[2];
@@ -299,21 +300,27 @@ struct_test ()
   if (CDR (3) != 0x22)
     return CDR (3);
 
-  puts ("t: struct fun = {&exit, 1};\n");
-  struct function fun = {&exit, 1};
-
   puts ("t: g_fun.arity != 1;\n");
   if (g_fun.arity != 1) return 1;
 
   puts ("t: g_fun.function != exit;\n");
   if (g_fun.function != &exit) return 1;
 
+  puts ("t: struct fun = {&exit,1,\"exit\"};\n");
+  struct function fun = {&exit,1,"exit"};
+
   puts ("t: fun.arity != 1;\n");
   if (fun.arity != 1) return 1;
 
   puts ("t: fun.function != exit;\n");
   if (fun.function != &exit) return 1;
 
+  puts ("t: puts (fun.name)\n");
+  if (strcmp (fun.name, "exit")) return 1;
+
+  puts ("t: puts (g_fun.name)\n");
+  if (strcmp (g_fun.name, "fun")) return 1;
+
   puts ("t: g_functions[g_function++] = g_foo;\n");
   g_functions[g_function++] = g_foo;
 
@@ -327,10 +334,13 @@ struct_test ()
 
   int (*functionx) (void) = 0;
   functionx = g_functions[0].function;
-  puts ("t: *functionx == foo\n");
+  puts ("t: functionx == foo\n");
   if (functionx != foo) return 11;
 
-  puts ("t: (*functionx) () == foo\n");
+  puts ("t: g_functions[0].name\n");
+  if (strcmp (g_functions[0].name, "foo")) return 1;
+
+  puts ("t: (functionx) () == foo\n");
   if ((functionx) () != 0) return 12;
 
   puts ("t: g_functions[<foo>].arity\n");
@@ -344,10 +354,13 @@ struct_test ()
   puts ("t: g_functions[g_cells[fn].cdr].function\n");
   functionx = g_functions[g_cells[fn].cdr].function;
 
+  puts ("t: g_functions[1].name\n");
+  if (strcmp (g_functions[1].name, "bar")) return 1;
+
   puts ("t: functionx == bar\n");
   if (functionx != bar) return 15;
 
-  puts ("t: (*functiony) (1) == bar\n");
+  puts ("t: (functiony) (1) == bar\n");
 #if __GNUC__
   //FIXME
   int (*functiony) (int) = 0;
@@ -642,9 +655,6 @@ test (char *p)
 int
 main (int argc, char *argv[])
 {
-  // int fn = 0;
-  // g_functions[fn] = g_bar;
-  // if (g_functions[fn].arity != 1) return 1;
   char *p = "t.c\n";
   puts ("t.c\n");