mescc: Support pointer arrays and some arithmetic.
authorJan Nieuwenhuizen <janneke@gnu.org>
Mon, 17 Apr 2017 00:15:11 +0000 (02:15 +0200)
committerJan Nieuwenhuizen <janneke@gnu.org>
Mon, 17 Apr 2017 00:15:11 +0000 (02:15 +0200)
* module/language/c99/compiler.mes (.name): Support **; handle type size.
  (.statements): Likewise.
  (push-local-de-ref): Likewise.
  (push-ident-de-ref): Likewise.
  (expr->arg): Likewise.
  (ident->accu):  Likewise.
  (base->ident-address):  Likewise.
  (ident-add): Likewise.
  (expr->accu):  Likewise.
  (decl->type):  Likewise.
  (formal->text):  Likewise.
  (int->global, ident-address->accu, ident-address->base): New functions.
  (ast->info): Support *, *[] ** declarations.
  (push-local-de-de-ref,  push-ident-de-de-ref): New functions.
* module/mes/as-i386.mes (i386:push-byte-local-de-ref): Rename from
  i386:push-local-de-ref.  Update callers.
  (i386:push-local-de-ref, i386:push-byte-local-de-de-ref,
  i386:accu-mem-add): New functions.
* module/mes/as-i386.scm (mes): Export them.
* scaffold/t.c (array_test): Test it.

module/language/c99/compiler.mes
module/mes/as-i386.mes
module/mes/as-i386.scm
scaffold/m.c
scaffold/t.c

index 82c9756c1ea6f37d640630fa9251fceddb9f7325..3231f21cc99bd3ca98500cafb6ac5e2456f72fc7 100644 (file)
   (pmatch o
     ((fctn-defn _ (ftn-declr (ident ,name) _) _) name)
     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr (ident ,name) _)) _) name)
+    ((fctn-defn _ (ptr-declr (pointer (pointer)) (ftn-declr (ident ,name) _)) _) name)
     ((param-decl _ (param-declr (ident ,name))) name)
     ((param-decl _ (param-declr (ptr-declr (pointer) (ident ,name)))) name)
     ((param-decl _ (param-declr (ptr-declr (pointer) (array-of (ident ,name))))) name)
+    ((param-decl _ (param-declr (ptr-declr (pointer (pointer)) (ident ,name)))) name)
     (_
      (format (current-error-port) "SKIP: .name =~a\n" o))))
 
 (define (.statements o)
   (pmatch o
     ((fctn-defn _ (ftn-declr (ident ,name) _) (compd-stmt (block-item-list . ,statements))) statements)
-    ((fctn-defn _ (ptr-declr (pointer) (ftn-declr (ident ,name) _)) (compd-stmt (block-item-list . ,statements))) statements)))
+    ((fctn-defn _ (ptr-declr (pointer) (ftn-declr (ident ,name) _)) (compd-stmt (block-item-list . ,statements))) statements)
+    ((fctn-defn _ (ptr-declr (pointer (pointer)) (ftn-declr (ident ,name) _)) (compd-stmt (block-item-list . ,statements))) statements)
+    (_ (error ".statements: unsupported: " o))))
 
 (define <info> '<info>)
 (define <types> '<types>)
 
 (define push-global-de-ref push-global)
 
-(define (push-local-de-ref locals)
+(define (push-local-de-ref info)
   (lambda (o)
-    (wrap-as (i386:push-local-de-ref (local:id o)))))
+    (let* ((local o)
+           (ptr (local:pointer local))
+           (size (if (= ptr 1) (type->size info (local:type o))
+                     4)))
+      (if (= size 1)
+          (wrap-as (i386:push-byte-local-de-ref (local:id o)))
+          (wrap-as (i386:push-local-de-ref (local:id o)))))))
+
+
+(define (push-local-de-de-ref info)
+  (lambda (o)
+    (let* ((local o)
+           (ptr (local:pointer local))
+           (size (if (= ptr 2) (type->size info (local:type o));; URG
+                     4)))
+      (if (= size 1)
+          (wrap-as (i386:push-byte-local-de-de-ref (local:id o)))
+          (error "TODO int-de-de-ref")))))
 
 (define (string->global string)
   (make-global (add-s:-prefix string) "string" 0 (append (string->list string) (list #\nul))))
 
+(define (int->global value)
+  (make-global (add-s:-prefix (number->string value)) "int" 0 (int->bv32 value)))
+
 (define (ident->global name type pointer value)
   (make-global name type pointer (int->bv32 value)))
 
 (define (push-ident-de-ref info)
   (lambda (o)
     (let ((local (assoc-ref (.locals info) o)))
-      (if local ((push-local-de-ref (.locals info)) local)
+      (if local ((push-local-de-ref info) local)
           ((push-global-de-ref (.globals info)) o)))))
 
+(define (push-ident-de-de-ref info)
+  (lambda (o)
+    (let ((local (assoc-ref (.locals info) o)))
+      (if local ((push-local-de-de-ref info) local)
+          (error "TODO: global push-local-de-de-ref")))))
+
 (define (expr->arg info)
   (lambda (o)
     (let ((info ((expr->accu info) o)))
 (define (expr->arg info) ;; FIXME: get Mes curried-definitions
   (lambda (o)
     (let ((text (.text info)))
-      ;;(stderr  "expr->arg o=~s\n" o)
       (pmatch o
 
         ((p-expr (string ,string))
                ,cast)
          ((expr->arg info) cast))
 
+        ((cast (type-name (decl-spec-list (type-spec (fixed-type ,type)))) ,cast)
+         ((expr->arg info) cast))
+
         ((de-ref (p-expr (ident ,name)))
          (append-text info ((push-ident-de-ref info) name)))
 
+        ((de-ref (de-ref (p-expr (ident ,name))))
+         (append-text info ((push-ident-de-de-ref info) name)))
+
         ((ref-to (p-expr (ident ,name)))
          (append-text info ((push-ident-address info) name)))
 
     (let ((local (assoc-ref (.locals info) o))
           (global (assoc-ref (.globals info) o))
           (constant (assoc-ref (.constants info) o)))
-      ;; (stderr "ident->accu: local[~a]: ~a\n" o (and local (local:id local)))
-      ;; (stderr "ident->accu: global[~a]: ~a\n" o global)
-      ;; (stderr "globals: ~a\n" (.globals info))
-      ;; (if (and (not global) (not (local:id local)))
-      ;;     (stderr "globals: ~a\n" (map car (.globals info))))
       (if local
           (let* ((ptr (local:pointer local))
                  (type (ident->type info o))
-                 (size (and type (type->size info type))))
-            ;;(stderr "ident->accu PTR[~a]: ~a\n" o ptr)
-            ;;(stderr "type: ~s\n" type)
-            ;;(stderr "ident->accu PTR[~a]: ~a\n" o ptr)
-            ;;(stderr "locals: ~s\n" locals)
+                 (size (if (= ptr 0) (type->size info type)
+                           4)))
             (case ptr
               ((-1) (wrap-as (i386:local-ptr->accu (local:id local))))
               ((1) (wrap-as (i386:local->accu (local:id local))))
                (wrap-as (if (= size 1) (i386:byte-local->accu (local:id local))
                             (i386:local->accu (local:id local)))))))
           (if global
-              (let ((ptr (ident->pointer info o)))
-                ;;(stderr "ident->accu PTR[~a]: ~a\n" o ptr)
+              (let* ((ptr (ident->pointer info o))
+                     (type (ident->type info o))
+                     (size (if (= ptr 1) (type->size info type)
+                               4)))
                 (case ptr
                   ((-1) (list (lambda (f g ta t d)
                                 (i386:global->accu (+ (data-offset o g) d)))))
+                  ((1) (list (lambda (f g ta t d)
+                               (i386:global-address->accu (+ (data-offset o g) d)))))
+
+                  ((2) (list (lambda (f g ta t d)
+                               (append (i386:value->accu (+ (data-offset o g) d))))))
                   (else (list (lambda (f g ta t d)
                                 (i386:global-address->accu (+ (data-offset o g) d)))))))
               (if constant (wrap-as (i386:value->accu constant))
                   (list (lambda (f g ta t d)
                           (i386:global->accu (+ ta (function-offset o f)))))))))))
 
+(define (ident-address->accu info)
+  (lambda (o)
+    (let ((local (assoc-ref (.locals info) o))
+          (global (assoc-ref (.globals info) o))
+          (constant (assoc-ref (.constants info) o)))
+      (if local
+          (let* ((ptr (local:pointer local))
+                 (type (ident->type info o))
+                 (size (if (= ptr 1) (type->size info type)
+                           4)))
+            ;;(stderr "ident->accu ~a => ~a\n" o ptr)
+            (wrap-as (i386:local-ptr->accu (local:id local))))
+          (if global
+              (let ((ptr (ident->pointer info o)))
+                (case ptr
+                  ((10)
+                   (list (lambda (f g ta t d)
+                           (i386:global->accu (+ (data-offset o g) d)))))
+                  (else (list (lambda (f g ta t d)
+                                (append (i386:value->accu (+ (data-offset o g) d))))))))
+              (error "TODO ident-address->accu" o))))))
+
+
+(define (ident-address->base info)
+  (lambda (o)
+    (let ((local (assoc-ref (.locals info) o))
+          (global (assoc-ref (.globals info) o))
+          (constant (assoc-ref (.constants info) o)))
+      (if local
+          (let* ((ptr (local:pointer local))
+                 (type (ident->type info o))
+                 (size (if (= ptr 1) (type->size info type)
+                           4)))
+            (wrap-as (i386:local-ptr->base (local:id local))))
+          (if global
+              (let ((ptr (ident->pointer info o)))
+                (case ptr
+                  ((1)
+                   (list (lambda (f g ta t d)
+                           (i386:global->base (+ (data-offset o g) d)))))
+                  (else (list (lambda (f g ta t d)
+                                (append (i386:value->base (+ (data-offset o g) d))))))))
+              (error "TODO ident-address->base" o))))))
+
 (define (value->accu v)
   (wrap-as (i386:value->accu v)))
 
 (define (accu->ident info)
   (lambda (o)
     (let ((local (assoc-ref (.locals info) o)))
-      (if local (wrap-as (i386:accu->local (local:id local)))
-          (list (lambda (f g ta t d)
-                  (i386:accu->global (+ (data-offset o g) d))))))))
+      (if local
+          (let ((ptr (local:pointer local)))
+            (case ptr
+              (else (wrap-as (i386:accu->local (local:id local))))))
+          (let ((ptr (ident->pointer info o)))
+            (list (lambda (f g ta t d)
+                    (i386:accu->global (+ (data-offset o g) d)))))))))
 
 (define (base->ident info)
   (lambda (o)
 (define (base->ident-address info)
   (lambda (o)
     (let ((local (assoc-ref (.locals info) o)))
-      (if local (wrap-as (append (i386:local->accu (local:id local))
-                                 (i386:byte-base->accu-address)))
+      (if local
+          (let* ((ptr (local:pointer local))
+                 (type (ident->type info o))
+                 (size (if (= ptr 1) (type->size info type)
+                           4)))
+            (wrap-as (append (i386:local->accu (local:id local))
+                             (if (= size 1) (i386:byte-base->accu-address)
+                                 (i386:byte-base->accu-address)))))
           (error "TODO:base->ident-address-global" o)))))
 
 (define (value->ident info)
           (list (lambda (f g ta t d)
                   (i386:global-add (+ (data-offset o g) d) n)))))))
 
+(define (ident-address-add info)
+  (lambda (o n)
+    (let ((local (assoc-ref (.locals info) o)))
+      (if local (wrap-as (append (i386:push-accu)
+                                 (i386:local->accu (local:id local))
+                                 (i386:accu-mem-add n)
+                                 (i386:pop-accu)))
+          (list (lambda (f g ta t d)
+                  (append (i386:push-accu)
+                          (i386:global->accu (+ (data-offset o g) d))
+                          (i386:accu-mem-add n)
+                          (i386:pop-accu))))))))
+
 ;; FIXME: see ident->accu
 (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)))
       (if local
           (let* ((ptr (local:pointer local))
                  (type (ident->type info o))
-                 (size (and type (type->size info type))))
+                 (size (if (and type (= ptr 1)) (type->size info type)
+                           4)))
             (case ptr
               ((-1) (wrap-as (i386:local-ptr->base (local:id local))))
               ((1) (wrap-as (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)
                   (case ptr
                     ((-1) (list (lambda (f g ta t d)
                                   (i386:global->base (+ (data-offset o g) d)))))
+                    ((2) (list (lambda (f g ta t d)
+                                 (i386:global->base (+ (data-offset o g) d)))))
                     (else (list (lambda (f g ta t d)
                                   (i386:global-address->base (+ (data-offset o g) d)))))))
                 (let ((constant (assoc-ref (.constants info) o)))
         (let* ((id (1+ (length (filter local? (map cdr locals)))))
                (locals (cons (make-local name type pointer id) locals)))
           locals))
-      ;; (stderr "expr->accu o=~a\n" o)
       (pmatch o
         ((p-expr (string ,string))
-         (append-text info (list (lambda (f g ta t d)
-                                   (i386:global->accu (+ (data-offset (add-s:-prefix string) globals) d))))))
+         (let* ((globals (append globals (list (string->global string))))
+                (info (clone info #:globals globals)))
+           (append-text info (list (lambda (f g ta t d)
+                                     (i386:global->accu (+ (data-offset (add-s:-prefix string) globals) d)))))))
+
         ((p-expr (string . ,strings))
          (append-text info (list (lambda (f g ta t d)
                                    (i386:global->accu (+ (data-offset (add-s:-prefix (apply string-append strings)) globals) d))))))
         ((p-expr (fixed ,value))
          (append-text info (value->accu (cstring->number value))))
+
         ((p-expr (ident ,name))
          (append-text info ((ident->accu info) name)))
 
         ;; g_cells[<expr>]
         ((array-ref ,index (p-expr (ident ,array)))
          (let* ((type (ident->type info array))
-                (size (type->size info type))
+                (ptr (ident->pointer info array))
+                (size (if (< ptr 2) (type->size info type)
+                          4))
                 (info ((expr->accu* info) o)))
            (append-text info (wrap-as (append (case size
                                                 ((1) (i386:byte-mem->accu))
 
         ((de-ref (p-expr (ident ,name)))
          (let* ((type (ident->type info name))
-                (size (and type (type->size info type))))
+                (ptr (ident->pointer info name))
+                (size (if (= ptr 1) (type->size info type)
+                          4)))
            (append-text info (append ((ident->accu info) name)
                                      (wrap-as (if (= size 1) (i386:byte-mem->accu)
                                                   (i386:mem->accu)))))))
 
+        ((de-ref (post-inc (p-expr (ident ,name))))
+         (let* ((info ((expr->accu info) `(de-ref (p-expr (ident ,name)))))
+                (type (ident->type info name))
+                (ptr (ident->pointer info name))
+                (size (if (> ptr 1) 4 1)))
+           (append-text info ((ident-add info) name size))))
+
+        ((de-ref ,expr)
+         (let ((info ((expr->accu info) expr)))
+           (append-text info (wrap-as (i386:byte-mem->accu))))) ;; FIXME: byte
+
         ((fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list))
          (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list)))) ;; FIXME
                                    (append-text info (wrap-as (asm->hex arg0))))
          ((ast->info info) `(expr-stmt ,o)))
 
         ((post-inc (p-expr (ident ,name)))
-         (append-text info (append ((ident->accu info) name)
-                                   ((ident-add info) name 1))))
+         (let* ((type (ident->type info name))
+                (ptr (ident->pointer info name))
+                (size (if (> ptr 1) 4 1)))
+           (append-text info (append ((ident->accu info) name)
+                                     ((ident-add info) name size)))))
 
         ((post-dec (p-expr (ident ,name)))
          (or (assoc-ref locals name) (begin (stderr "i-- ~a\n" name) (error "undefined identifier: " name)))
                      (info ((expr->accu* info) a))
                      (info (append-text info (wrap-as (i386:pop-base)))))
                 (append-text info (wrap-as (i386:base->accu-address))))) ; FIXME: size
+             ;; FIXME: c&p above
              ((de-ref (p-expr (ident ,array)))
               (append-text info (append (wrap-as (i386:accu->base))
                                         ((base->ident-address info) array)
 
 (define (expr->accu* info)
   (lambda (o)
-    ;; (stderr "expr->accu* o=~s\n" o)
-
     (pmatch o
       ;; g_cells[<expr>]
       ((array-ref ,index (p-expr (ident ,array)))
        (let* ((info ((expr->accu info) index))
               (type (ident->type info array))
-              (size (type->size info type)))
+              (ptr (ident->pointer info array))
+              (size (if (< ptr 2) (type->size info type)
+                        4)))
          (append-text info (append (wrap-as (append (i386:accu->base)
                                                     (if (eq? size 1) '()
                                                         (append
     ((decl (decl-spec-list (type-spec (struct-ref (ident ,name)))));; "scm"
      (list "struct" name)) ;; FIXME
     ((typename ,name) name)
+    (,name name)
     (_ (error "decl->type: unsupported: " o))))
 
 (define (expr->global o)
   (pmatch o
     ((p-expr (string ,string)) (string->global string))
+    ((p-expr (fixed ,value)) (int->global (cstring->number value)))
     (_ #f)))
 
 (define (initzer->global o)
     ("int" . (builtin 4 #f))))
 
 (define (type->size info o)
-  ;;(stderr  "types=~s\n" (.types info))
-  ;;(stderr  "type->size o=~s => ~s\n" o   (cadr (assoc-ref (.types info) o)))
   (pmatch o
     ((decl-spec-list (type-spec (fixed-type ,type)))
      (type->size info type))
              (error "type->size: unsupported: " o))))))
 
 (define (ident->decl info 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))
   (or (assoc-ref (.locals info) o)
       (assoc-ref (.globals info) o)
       (begin
         (or (and=> (ident->decl info o) global:pointer) 0))))
 
 (define (type->description info o)
-  ;; (stderr  "type->description =~s\n" o)  
-  ;; (stderr  "types=~s\n" (.types info))
-  ;; (stderr  "type->description o=~s ==> ~s\n" o  (caddr (assoc-ref (.types info) o)))
-  ;; (stderr  "  assoc ~a\n" (assoc-ref (.types info) o))
   (pmatch o
     ((decl-spec-list (type-spec (fixed-type ,type)))
      (type->description info type))
                (locals (cons (make-local name type pointer id) locals)))
           locals))
 
-      ;; (stderr "\n ast->info=~s\n" o)
-      ;; (stderr "  globals[~a=>~a]: ~a\n" (length globals) (length (append-map cdr globals)) (map (lambda (s) (if (string? s) (string-delete #\newline s))) (map car globals)))
-      ;; (stderr "  text=~a\n" text)
-      ;; (stderr "   info=~a\n" info)
-      ;; (stderr "   globals=~a\n" globals)
       (pmatch o
         (((trans-unit . _) . _)
          ((ast-list->info info)  o))
            (append-text info (append ((ident->accu info) local)
                                      ((accu->ident info) name)))))
 
-        ;; char *p = "t.c";
+        ;; char *p = "foo";
         ((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)) (error "ast->info: unsupported: " o))
-         (let* ((locals (add-local locals name type 1))
-                (globals (append globals (list (string->global string))))
-                (info (clone info #:locals locals #:globals globals)))
-           (append-text info (append
-                              (list (lambda (f g ta t d)
-                                      (append
-                                       (i386:global->accu (+ (data-offset (add-s:-prefix string) g) d)))))
-                              ((accu->ident info) name)))))
+         (if (.function info)
+             (let* ((locals (add-local locals name type 1))
+                    (globals (append globals (list (string->global string))))
+                    (info (clone info #:locals locals #:globals globals)))
+               (append-text info (append
+                                  (list (lambda (f g ta t d)
+                                          (append
+                                           (i386:global->accu (+ (data-offset (add-s:-prefix string) g) d)))))
+                                  ((accu->ident info) name))))
+             (let* ((global (string->global string))
+                    (globals (append globals (list global)))
+                    (size 4)
+                    (global (make-global name type 1 (string->list (make-string size #\nul))))
+                    (globals (append globals (list global)))
+                    (info (clone info #:globals globals))
+                    (here (data-offset name globals)))
+               (clone info #:init
+                      (append
+                       (.init info)
+                       (list (lambda (functions globals ta t d data)
+                               (append
+                                (list-head data here)
+                                (initzer->data info functions globals ta t d `(initzer (p-expr (string ,string))))
+                                (list-tail data (+ here size))))))))))
         
-        ;; char *p = 0;
+        ;; char const *p;
+        ((decl (decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qualifier)) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
+         (if (.function info)
+             (let* ((locals (add-local locals name type 1))
+                    (info (clone info #:locals locals)))
+               (append-text info (append (wrap-as (i386:value->accu 0))
+                                         ((accu->ident info) name))))
+             (let ((globals (append globals (list (ident->global name type 1 0)))))
+               (clone info #:globals globals))))
+
+        ;; char *p;
+        ((decl (decl-spec-list (type-spec (fixed-type ,type)) . _) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
+         (if (.function info)
+             (let* ((locals (add-local locals name type 1))
+                    (info (clone info #:locals locals)))
+               (append-text info (append (wrap-as (i386:value->accu 0))
+                                         ((accu->ident info) name))))
+             (let ((globals (append globals (list (ident->global name type 1 0)))))
+               (clone info #:globals globals))))
+
         ((decl (decl-spec-list (type-spec (fixed-type ,type)) . _) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (fixed ,value))))))
          (let ((value (cstring->number value)))
            (if (.function info)
                       (info (clone info #:locals locals)))
                  (append-text info (append (wrap-as (i386:value->accu value))
                                            ((accu->ident info) name))))
-               (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
+               (clone info #:globals (append globals (list (ident->global name type 1 value)))))))
+
+        ;; char **p;
+        ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
+         (if (.function info)
+             (let* ((locals (add-local locals name type 2))
+                    (info (clone info #:locals locals)))
+               (append-text info (append (wrap-as (i386:value->accu 0))
+                                         ((accu->ident info) name))))
+             (let ((globals (append globals (list (ident->global name type 2 0)))))
+               (clone info #:globals globals))))
+
+        ;; char **p = 0;
+        ;;((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer (pointer)) (ident ,name)) (initzer (p-expr (fixed ,value)))))))
+
+        ;; char **p = g_environment;
+        ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer (pointer)) (ident ,name)) (initzer (p-expr (ident ,b)))))) ;; FIXME: initzer
+         (if (.function info)
+             (let* ((locals (add-local locals name type 2))
+                    (info (clone info #:locals locals)))
+               (append-text info (append
+                                  ((ident->accu info) b)
+                                  ((accu->ident info) name))))
+             (let* ((globals (append globals (list (ident->global name type 2 0))))
+                    (here (data-offset name globals)))
+               (clone info
+                      #:globals globals
+                      #:init (append (.init info)
+                                     (list (lambda (functions globals ta t d data)
+                                             (append
+                                              (list-head data here)
+                                              ;;(initzer->data info functions globals ta t d initzer)
+                                              (initzer->data info functions globals ta t d `(p-expr (ident ,b)))
+                                              (list-tail data (+ here 4))))))))
+             ;;;(clone info #:globals (append globals (list (ident->global name type 1 0))))
+             ))
 
         ;; char arena[20000];
         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (array-of (ident ,name) (p-expr (fixed ,count))))))
 
         ;;struct scm *g_cells = (struct scm*)arena;
         ((decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (cast (type-name (decl-spec-list (type-spec (struct-ref (ident ,=type)))) (abs-declr (pointer))) (p-expr (ident ,value)))))))
-         ;;(stderr "0TYPE: ~s\n" type)
          (if (.function info)
              (let* ((locals (add-local locals name type 1))
                     (info (clone info #:locals locals)))
 
         ;; SCM tmp;
         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name))))
-         ;;(stderr  "1TYPE: ~s\n" type)
          (if (.function info)
              (clone info #:locals (add-local locals name type 0))
              (clone info #:globals (append globals (list (ident->global name type 0 0))))))
 
         ;; 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)
          (let ((value (cstring->number value)))
            (if (.function info)
                (let* ((locals (add-local locals name type 0))
 
         ;; SCM i = argc;
         ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
-         ;;(stderr  "3TYPE: ~s\n" type)
          (if (.function info)
              (let* ((locals (add-local locals name type 0))
                     (info (clone info #:locals locals)))
 
         ;; char *p = (char*)g_cells;
         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (cast (type-name (decl-spec-list (type-spec (fixed-type ,=type))) (abs-declr (pointer))) (p-expr (ident ,value)))))))
-         ;;(stderr  "6TYPE: ~s\n" type)
          (if (.function info)
              (let* ((locals (add-local locals name type 1))
                     (info (clone info #:locals locals)))
 
         ;; char *p = g_cells;
         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (ident ,value))))))
-         ;;(stderr  "7TYPE: ~s\n" type)
          (let ((type (decl->type type)))
-           ;;(stderr "0DECL: ~s\n" type)
            (if (.function info)
                (let* ((locals (add-local locals name type  1))
                       (info (clone info #:locals locals)))
         ;; 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)
            (clone info #:types (append (.types info) (list type)))))
 
+        ;; char *p = &bla;
+        ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (ref-to (p-expr (ident ,value)))))))
+         (let ((type (decl->type type)))
+           (if (.function info)
+               (let* ((locals (add-local locals name type 1))
+                      (info (clone info #:locals locals)))
+                 (append-text info (append ((ident-address->accu info) value)
+                                           ((accu->ident info) name))))
+               (error "TODO" o))))
+
+        ;; char **p = &bla;
+        ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer (pointer)) (ident ,name)) (initzer (ref-to (p-expr (ident ,value)))))))
+         (let ((type (decl->type type)))
+           (if (.function info)
+               (let* ((locals (add-local locals name type 2))
+                      (info (clone info #:locals locals)))
+                 (append-text info (append ((ident-address->accu info) value)
+                                           ((accu->ident info) name))))
+               (error "TODO" o))))
+
+        ;; char *p = bla[0];
+        ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (array-ref ,index (p-expr (ident ,array)))))))
+         (if (.function info)
+             (let* ((locals (add-local locals name type 1))
+                    (info (clone info #:locals locals))
+                    (info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array))))))
+               (append-text info ((accu->ident info) name)))
+             (error "TODO" o)))
+
+        ;; char *p = *bla;
+        ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (de-ref (p-expr (ident ,value)))))))
+         (if (.function info)
+             (let* ((locals (add-local locals name type 2))
+                    (info (clone info #:locals locals))
+                    (local (assoc-ref (.locals info) name)))
+               (append-text info (append ((ident->accu info) value)
+                                         (wrap-as (i386:mem->accu))
+                                         ((accu->ident info) name))))
+             (error "TODO" o)))
+
         ;; DECL
+        ;; char *bla[] = {"a", "b"};
+        ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (array-of (ident ,name))) (initzer (initzer-list . ,initzers)))))
+         (let* ((type (decl->type type))
+                (entries (map initzer->global initzers))
+                (entry-size 4)
+                (size (* (length entries) entry-size)))
+           (if (.function info)
+               (error "TODO: <type> x[] = {};" o)
+               (let* ((global (make-global name type 2 (string->list (make-string size #\nul))))
+                      (globals (append globals entries (list global)))
+                      (info (clone info #:globals globals))
+                      (here (data-offset name globals)))
+                 (clone info #:init
+                        (append
+                         (.init info)
+                         (list (lambda (functions globals ta t d data)
+                                 (append
+                                  (list-head data here)
+                                  (append-map
+                                   (lambda (i)
+                                     (initzer->data info functions globals ta t d i))
+                                   initzers)
+                                  (list-tail data (+ here size)))))))))))
+
         ;;
         ;; struct f = {...};
         ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer (initzer-list . ,initzers)))))
          (let* ((type (decl->type type))
-                ;;(foo (stderr "1DECL: ~s\n" type))
                 (fields (type->description info type))
                 (size (type->size info type))
                 (field-size 4))  ;; FIXME:4, not fixed
-           ;;(stderr  "7TYPE: ~s\n" type)
            (if (.function info)
                (let* ((globals (append globals (filter-map initzer->global initzers)))
                       (locals (let loop ((fields (cdr fields)) (locals locals))
     ((initzer (p-expr (fixed ,value))) (int->bv32 (cstring->number value)))
     ((initzer (neg (p-expr (fixed ,value)))) (int->bv32 (- (cstring->number value))))
     ((initzer (ref-to (p-expr (ident ,name))))
-     ;;(stderr "INITZER[~a] => 0x~a\n" o (dec->hex (+ ta (function-offset name functions))))
      (int->bv32 (+ ta (function-offset name functions))))
     ((initzer (p-expr (ident ,name)))
      (let ((value (assoc-ref (.constants info) name)))
   (pmatch o
     ((fctn-defn _ (ftn-declr _ ,formals) _) formals)
     ((fctn-defn _ (ptr-declr (pointer) (ftn-declr _ ,formals)) _) formals)
+    ((fctn-defn _ (ptr-declr (pointer (pointer)) (ftn-declr _ ,formals)) _) formals)
     (_ (error ".formals: " o))))
 
 (define (formal->text n)
 
 (define (formal:ptr o)
   (pmatch o
-    ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) . _)))
-     1)
     ((param-decl (decl-spec-list . ,decl) (param-declr (ident ,name)))
      0)
+    ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) (array-of (ident ,name)))))
+     2)
+    ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) (ident ,name))))
+     1)
+    ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) . _)))
+     1)
+    ((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer (pointer)) (ident ,name))))
+     2)
     (_
-     (stderr "formal:ptr[~a] => 0\n" o)
+     (stderr "formal:ptr[~a] => ~a\n" o 0)
      0)))
 
 (define (formals->locals o)
 
 (define (function->info info)
   (lambda (o)
-    ;;(stderr "function->info o=~s\n" o)
-    ;;(stderr "formals=~s\n" (.formals o))
     (let* ((name (.name o))
            (formals (.formals o))
            (text (formals->text formals))
            (locals (formals->locals formals)))
       (format (current-error-port) "compiling ~s\n" name)
-      ;;(stderr "locals=~s\n" locals)
       (let loop ((statements (.statements o))
                  (info (clone info #:locals locals #:function (.name o) #:text text)))
         (if (null? statements) (clone info
index 3e39cbbf277ec2816788cf2d3e98ec0a31e6716b..c325729b5ef527cf1fb0b3fa34afe640bbd57b2f 100644 (file)
   `(#x8d #x45 ,(- 0 (* 4 n))            ; lea 0x<n>(%ebp),%eax
          #x50))                         ; push %eax
 
-(define (i386:push-local-de-ref n)
-  (or n (error "invalid value: push-local-de-ref: " n))
+(define (i386:push-byte-local-de-ref n)
+  (or n (error "invalid value: push-byte-local-de-ref: " n))
+  `(#x8b #x45 ,(- 0 (* 4 n))            ; mov    -0x<n>(%ebp),%eax
+         #x0f #xb6 #x00                ; movzbl (%eax),%eax
+         #x50))                         ; push   %eax
+
+(define (i386:push-byte-local-de-de-ref n)
+  (or n (error "invalid value: push-byte-local-de-de-ref: " n))
   `(#x8b #x45 ,(- 0 (* 4 n))            ; mov    -0x<n>(%ebp),%eax
+         #x8b #x00                      ; mov    (%eax),%eax
          #x0f #xb6 #x00                ; movzbl (%eax),%eax
-         ;;#x0f #xbe #xc0                 ; movsbl %al,%eax ***FIXME BYTE****
+         #x50))
+
+(define (i386:push-local-de-ref n)
+  (or n (error "invalid value: push-byte-local-de-ref: " n))
+  `(#x8b #x45 ,(- 0 (* 4 n))            ; mov    -0x<n>(%ebp),%eax
+         #x8b #x00                      ; mov (%eax),%eax
          #x50))                         ; push   %eax
 
 (define (i386:pop-accu)
   (or n (error "invalid value: accu->local: " n))
   `(#x89 #x45 ,(- 0 (* 4 n))))          ; mov    %eax,-<0xn>(%ebp)
 
+;; (define (i386:accu->local-address n)
+;;   (or n (error "invalid value: accu->local: " n))
+;;   `(#x89 #x45 ,(- 0 (* 4 n))))          ; mov    %eax,-<0xn>(%ebp)
+
 (define (i386:base->local n)
   (or n (error "invalid value: base->local: " n))
   `(#x89 #x55 ,(- 0 (* 4 n))))          ; mov    %edx,-<0xn>(%ebp)
 
 (define (i386:byte-local->base n)
   (or n (error "invalid value: byte-local->base: " n))
-  `(x0f #xb6 #x95 ,(- 0 (* 4 n))))     ; movzbl 0x<n>(%ebp),%edx
+  `(#x0f #xb6 #x55 ,(- 0 (* 4 n))))     ; movzbl 0x<n>(%ebp),%edx
 
 (define (i386:local->base n)
   (or n (error "invalid value: local->base: " n))
   (or n (error "invalid value: i386:local-add: " n))
   `(#x83 #x45 ,(- 0 (* 4 n)) ,v))       ; addl   $<v>,0x<n>(%ebp)
 
+(define (i386:accu-mem-add v)
+  `(#x83 #x00 ,v))                      ; addl   $<v>,(%eax)
+
 (define (i386:global-add n v)
   (or n (error "invalid value: i386:global-add: " n))
   `(#x83 #x05 ,@(int->bv32 n) ,v))      ; addl   $<v>,0x<n>
index 5ab95cdc2bf7388b887118046bb61ea1e9e7005b..330d9bb3da60bf2b34b6ffbab8f4696b6b5dfed4 100644 (file)
@@ -97,6 +97,7 @@
             i386:local-ptr->base
             i386:local-address->base
             i386:local-test
+            i386:accu-mem-add
             i386:mem->accu
             i386:mem+n->accu
             i386:pop-accu
             i386:push-global
             i386:push-global-address
             i386:push-local
+            i386:push-byte-local-de-ref
+            i386:push-byte-local-de-de-ref
             i386:push-local-de-ref
             i386:push-local-address
             i386:ret
index 4dd2472ef9c23b89844625d8344951e0fcb66f94..2d12be375bc399ee3601d935893a53742d7158aa 100644 (file)
@@ -27,6 +27,7 @@ main (int argc, char *argv[])
 {
   g_stdin = open ("scaffold/mesmes", 0);
   int c = getchar ();
+  if (c != 'm') return c;
   while (c != EOF) {
     putchar (c);
     c = getchar ();
index 2f10d2f8f43aac738f50258f34d6e755a81f2f9a..129605ab19e42ab402d0984412a01854452c0134 100644 (file)
@@ -77,6 +77,8 @@ int ARENA_SIZE = 200;
 struct scm scm_fun = {TFUNCTION,0,0};
 SCM cell_fun;
 
+char *env[] = {"foo", "bar", "baz", 0};
+
 #if 1
 int
 add (int a, int b)
@@ -180,9 +182,72 @@ read_test ()
   //if (getchar () != '\0') return 1;
   if (getchar () != 0) return 1;
 
+  puts ("t: i == 'm'\n");
+  char m = 0x1122336d;
+  i = m;
+  if (i != 'm') return 1;
+
   return 0;
 }
 
+int
+array_test (char **e)
+{
+  int i = 0;
+
+  puts ("env [");
+  puts (itoa (env));
+  puts ("]\n");
+
+  puts ("e [");
+  puts (itoa (e));
+  puts ("]\n");
+
+  puts ("env [0] == \"foo\"\n");
+  if (strcmp (env[0], "foo")) return 1;
+
+  puts ("env [1] == \"bar\"\n");
+  if (strcmp (env[1], "bar")) return 1;
+
+  puts ("t: **p in *env[]\n");
+
+  char **pp = env;
+  while (*pp)
+    {
+      puts ("pp [");
+      puts (itoa (pp));
+      puts ("]: ");
+      if (*pp) puts (*pp);
+      puts ("\n");
+      pp++;
+      i++;
+    }
+  if (i != 3) return i;
+
+  pp = env;
+  puts ("t: *pp++ == \"foo\"\n");
+  if (strcmp (*pp++, "foo")) return 1;
+
+  puts ("t: *pp++ == \"bar\"\n");
+  if (strcmp (*pp++, "bar")) return 1;
+
+  char *buf = "hello";
+  puts ("t: buf[0]\n");
+  if (buf[0] != 'h') return 1;
+
+  puts ("t: buf + 1\n");
+  if (*(buf+1) != 'e') return 1;
+
+  char **p = &buf;
+  puts ("t: **p\n");
+  if (**p != 'h') return 1;
+
+  puts ("t: *(p + 1)\n");
+  if (*(*p + 1) != 'e') return 1;
+
+  return read_test ();
+}
+
 int
 math_test ()
 {
@@ -266,7 +331,7 @@ math_test ()
   puts ("t: -1 + 2\n");
   if (-1 + 2 != 1) return 1;
 
-  return read_test ();
+  return array_test (env);
 }
 
 SCM
@@ -842,11 +907,15 @@ main (int argc, char *argv[])
   char *p = "t.c\n";
   puts ("t.c\n");
 
-  if (argc > 1 && !strcmp (argv[1], "--help")) return 1;
-  puts ("t: if (argc > 1 && !strcmp (argv[1], \"--help\")\n");
+  puts ("t: argv[0] == \"out/t....\"\n");
+  if (strncmp (argv[0], "out/t", 5)) return 1;
 
-  // FIXME mescc?!
-  if (argc > 1) if (!strcmp (argv[1], "--help")) return 1;
+  puts ("t: *argv\"\n");
+  puts (*argv);
+  puts ("\n");
+
+  puts ("t: if (argc > 1 && !strcmp (argv[1], \"--help\")\n");
+  if (argc > 1 && !strcmp (argv[1], "--help")) return 1;
 
   return test (p);