mescc: Support switch.
authorJan Nieuwenhuizen <janneke@gnu.org>
Tue, 17 Jan 2017 18:03:08 +0000 (19:03 +0100)
committerJan Nieuwenhuizen <janneke@gnu.org>
Tue, 17 Jan 2017 18:03:08 +0000 (19:03 +0100)
* module/language/c99/compiler.mes (case->jump-info): New function.
  (ast->info): Use it.
* doc/examples/t.c (swits): Test it.

guile/mescc.scm
module/language/c99/compiler.mes
module/mes/elf-util.mes
module/mes/libc-i386.mes
module/mes/libc-i386.scm
scaffold/t.c

index 25fc9319ec54963696c60f71bf0c7f2e22075044..3a1b611ad53d43afb9da056ce2bf8d34e382cd22 100755 (executable)
@@ -1,6 +1,6 @@
 #! /bin/sh
 # -*-scheme-*-
-export GUILE_AUTO_COMPILE=0
+export GUILE_AUTO_COMPILE=${GUILE_AUTO_COMPILE-0}
 exec ${GUILE-guile} -L $(pwd)/guile -e '(mescc)' -s "$0" "$@"
 !#
 
index 13b0f8d1061cdcda64f37e18476c869845a8cffb..280c7d9f272a892542f52cac254ca64d9f400461 100644 (file)
@@ -54,7 +54,7 @@
                 ("__GNUC__" . "0")
                 ("__NYACC__" . "1")
                 ("VERSION" . "0.4")
-                ("PREFIX" . "")
+                ("PREFIX" . "\"\"")
                 )
    #:xdef? gnuc-xdef?
    #:mode 'code
     (lambda (f g t d)
       (i386:push-global (+ (data-offset o g) d)))))
 
+(define push-global-de-ref push-global)
+
 (define (push-ident globals locals)
   (lambda (o)
     (let ((local (assoc-ref locals o)))
       (if local (i386:push-local-ref local)
           ((push-global-ref globals) o)))))
 
+(define (push-ident-de-ref globals locals)
+  (lambda (o)
+    (let ((local (assoc-ref locals o)))
+      (if local (i386:push-local-de-ref local)
+          ((push-global-de-ref globals) o)))))
+
 (define (expr->arg info) ;; FIXME: get Mes curried-definitions
   (lambda (o)
     (pmatch o
       ((p-expr (fixed ,value)) (cstring->number value))
+      ((neg (p-expr (fixed ,value))) (- (cstring->number value)))
       ((p-expr (string ,string)) ((push-global-ref (.globals info)) string))
       ((p-expr (ident ,name))
        ((push-ident (.globals info) (.locals info)) name))
 
-      ((array-refo (p-expr (fixed ,value)) (p-expr (ident ,name)))
+      ((array-ref (p-expr (fixed ,value)) (p-expr (ident ,name)))
        (let ((value (cstring->number value))
              (size 4)) ;; FIXME: type: int
-         (lambda (f g t d)
-           (append
-            ((ident->base (.locals info)) name)
-            (i386:value->accu (* size value)) ;; FIXME: type: int
-            (i386:base-mem->accu) ;; FIXME: type: int
-            (i386:push-accu) ;; hmm
-            ))))
+         (append
+          ((ident->base (.locals info)) name)
+          (list
+           (lambda (f g t d)
+             (append
+              (i386:value->accu (* size value)) ;; FIXME: type: int
+              (i386:base-mem->accu)             ;; FIXME: type: int
+              (i386:push-accu)                  ;; hmm
+              ))))))
+
+      ((de-ref (p-expr (ident ,name)))
+       (lambda (f g t d)
+         ((push-ident-de-ref (.globals info) (.locals info)) name)))
+
       ((ref-to (p-expr (ident ,name)))
        (lambda (f g t d)
          ((push-ident-ref (.globals info) (.locals info)) name)))
+
+      ;; f (car (x))
+      ((fctn-call . ,call)
+       (let ((info ((ast->info info) o)))
+         (append (.text info)
+                 (list
+                  (lambda (f g t d)
+                    (i386:push-accu))))))
+
+      ;; f (CAR (x))
+      ((d-sel . ,d-sel)
+       (let* ((empty (clone info #:text '()))
+              (expr ((expr->accu empty) `(d-sel ,@d-sel))))
+         (append (.text expr)
+                 (list (lambda (f g t d)
+                         (i386:push-accu))))))
+
+      ;; f (0 + x)
+      ;;; aargh
+      ;;;((add (p-expr (fixed ,value)) (d-sel (ident cdr) (array-ref (p-expr (ident x)) (p-expr (ident g_cells))))))
+
       ((cast (type-name (decl-spec-list (type-spec (fixed-type _)))
                         (abs-declr (pointer)))
              ,cast)
        ((expr->arg info) cast))
       (_
-       (format (current-error-port) "SKIP expr->arg=~a\n" o)     
+       (format (current-error-port) "SKIP expr->arg=~s\n" o)     
        0))))
 
 (define (ident->accu info)
     (let ((local (assoc-ref (.locals info) o)))
       (if local
           (list (lambda (f g t d)
-                  (i386:local->accu local)))
+                  (if (equal? o "c1")
+                      (i386:byte-local->accu local) ;; FIXME
+                      (i386:local->accu local))))
           (list (lambda (f g t d)
                   (i386:global->accu (+ (data-offset o g) d))))))))
 
       ((not (fctn-call . _)) ((ast->info info) o))
       ((sub . _) ((ast->info info) o)) ;; FIXME: expr-stmt
       ((neg (p-expr (fixed ,value))) (- (cstring->number value)))
+
+      ;; g_cells[10].type
+      ((d-sel (ident ,field) (array-ref (p-expr (fixed ,index)) (p-expr (ident ,array))))
+       (let* ((struct-type "scm") ;; FIXME
+              (struct (assoc-ref (.types info) struct-type))
+              (size (length struct))
+              (field-size 4) ;; FIXME:4, not fixed
+              (offset (* field-size (1- (length (member field (reverse struct) (lambda (a b) (equal? a (cdr b))))))))
+              (index (cstring->number index))
+              (text (.text info)))
+         (clone info #:text
+                (append text
+                        (list (lambda (f g t d)
+                                (append
+                                 (i386:value->base index)
+                                 (i386:base->accu)
+                                 (if (> size 1) (i386:accu+accu) '())
+                                 (if (= size 3) (i386:accu+base) '())
+                                 (i386:accu-shl 2)
+                                 ;;;'(#x58 #x58)
+                                 )))
+                        ((ident->base info) array)
+                        (list (lambda (f g t d)
+                                (i386:accu+base)))))))
+
+      ;; g_cells[x].type
+      ((d-sel (ident ,field) (array-ref (p-expr (ident ,index)) (p-expr (ident ,array))))
+       (let* ((struct-type "scm") ;; FIXME
+              (struct (assoc-ref (.types info) struct-type))
+              (size (length struct))
+              (field-size 4) ;; FIXME:4, not fixed
+              (offset (* field-size (1- (length (member field (reverse struct) (lambda (a b) (equal? a (cdr b))))))))
+              (text (.text info)))
+         (clone info #:text
+                (append text
+                        ((ident->base info) index)
+                        (list (lambda (f g t d)
+                                (append
+                                 (i386:base->accu)
+                                 (if (> size 1) (i386:accu+accu) '())
+                                 (if (= size 3) (i386:accu+base) '())
+                                 (i386:accu-shl 2))))
+                        ((ident->base info) array)
+                        (list (lambda (f g t d)
+                                (i386:base-mem+n->accu offset)
+                                ;;(i386:accu+base)
+                                ))))))
+
+      (_
+       (format (current-error-port) "SKIP expr->accu=~s\n" o)
+       info)
+      )))
+
+(define (expr->Xaccu info)
+  (lambda (o)
+    (pmatch o
+      ;; g_cells[10].type
+      ((d-sel (ident ,field) (array-ref (p-expr (fixed ,index)) (p-expr (ident ,array))))
+       (let* ((struct-type "scm") ;; FIXME
+              (struct (assoc-ref (.types info) struct-type))
+              (size (length struct))
+              (field-size 4) ;; FIXME:4, not fixed
+              (offset (* field-size (1- (length (member field (reverse struct) (lambda (a b) (equal? a (cdr b))))))))
+              (index (cstring->number index))
+              (text (.text info)))
+         (clone info #:text
+                (append text
+                        (list (lambda (f g t d)
+                                (append
+                                 (i386:value->base index)
+                                 (i386:base->accu)
+                                 (if (> size 1) (i386:accu+accu) '())
+                                 (if (= size 3) (i386:accu+base) '())
+                                 (i386:accu-shl 2))))
+                        ((ident->base info) array)
+                        (list (lambda (f g t d)
+                                (i386:accu+base)))))))
+
+      ;; g_cells[x].type
+      ((d-sel (ident ,field) (array-ref (p-expr (ident ,index)) (p-expr (ident ,array))))
+       (let* ((struct-type "scm") ;; FIXME
+              (struct (assoc-ref (.types info) struct-type))
+              (size (length struct))
+              (field-size 4) ;; FIXME:4, not fixed
+              (offset (* field-size (1- (length (member field (reverse struct) (lambda (a b) (equal? a (cdr b))))))))
+              (text (.text info)))
+         (clone info #:text
+                (append text
+                        ((ident->base info) index)
+                        (list (lambda (f g t d)
+                                (append
+                                 (i386:base->accu)
+                                 (if (> size 1) (i386:accu+accu) '())
+                                 (if (= size 3) (i386:accu+base) '())
+                                 (i386:accu-shl 2))))
+                        ((ident->base info) array)
+                        (list (lambda (f g t d)
+                                (i386:accu+base)))))))
+
       (_
-       (format (current-error-port) "SKIP expr->accu=~a\n" o)
-       0)
+       (format (current-error-port) "SKIP expr->Xaccu=~s\n" o)
+       info)
       )))
 
 (define (string->global string)
 
 (define (asm->hex o)
   (let ((prefix ".byte "))
-    (if (not (string-prefix? prefix o)) (begin (stderr "SKIP:~a\n" o)'())
+    (if (not (string-prefix? prefix o)) (begin (stderr "SKIP:~s\n" o)'())
         (let ((s (string-drop o (string-length prefix))))
           (map byte->hex (string-split s #\space))))))
 
+(define (case->jump-info info)
+  (define (jump n)
+    (list (lambda (f g t d) (i386:Xjump n))))
+  (define (jump-nz n)
+    (list (lambda (f g t d) (i386:Xjump-nz n))))
+  (define (statement->info info body-length)
+    (lambda (o)
+      (pmatch o
+        ((break) (clone info #:text (append (.text info) (jump body-length)
+)))
+        (_
+         ((ast->info info) o)))))
+  (lambda (o)
+    (pmatch o
+      ((case (p-expr (ident ,constant)) (compd-stmt (block-item-list . ,elements)))
+       (lambda (body-length)
+         (let* ((value (assoc-ref (.constants info) constant))
+                (text-length (length (.text info)))
+                (clause-info (let loop ((elements elements) (info info))
+                               (if (null? elements) info
+                                   (loop (cdr elements) ((statement->info info body-length) (car elements))))))
+                (clause-text (list-tail (.text clause-info) text-length))
+                (clause-length (length (text->list clause-text))))
+           (stderr "clause text[~a]: ~a\n" clause-length (map dec->hex (text->list clause-text)))
+           (clone info #:text (append
+                               (.text info)
+                               (list (lambda (f g t d) (i386:accu-cmp-value value)))
+                               (jump-nz clause-length)
+                               clause-text)
+                  #:globals (.globals clause-info)))))
+
+      ((case (p-expr (fixed ,value)) (compd-stmt (block-item-list . ,elements)))
+       (lambda (body-length)
+         (let* ((value (cstring->number value))
+                (text-length (length (.text info)))
+                (clause-info (let loop ((elements elements) (info info))
+                               (if (null? elements) info
+                                   (loop (cdr elements) ((statement->info info body-length) (car elements))))))
+                (clause-text (list-tail (.text clause-info) text-length))
+                (clause-length (length (text->list clause-text))))
+           (stderr "clause text[~a]: ~a\n" clause-length (map dec->hex (text->list clause-text)))
+           (clone info #:text (append
+                               (.text info)
+                               (list (lambda (f g t d) (i386:accu-cmp-value value)))
+                               (jump-nz clause-length)
+                               clause-text)
+                  #:globals (.globals clause-info)))))
+
+      ((default (compd-stmt (block-item-list . ,elements)))
+       (lambda (body-length)
+         (let ((text-length (length (.text info))))
+          (let loop ((elements elements) (info info))
+            (if (null? elements) (let ((clause-text (list-tail (.text info) text-length)))
+                                   (stderr "default text[~a]: ~a\n" (length (text->list clause-text)) (map dec->hex (text->list clause-text)))
+                                   info)
+                (loop (cdr elements) ((statement->info info body-length) (car elements))))))))
+      (_ (stderr "no case match: ~a\n" o) barf)
+      )))
+
 (define (test->jump->info info)
   (define (jump type)
     (lambda (o)
       (_ ((jump i386:jump-z) o)))))
 
 (define (cstring->number s)
-  (if (string-prefix? "0" s) (string->number s 8)
-      (string->number s)))
+  (cond ((string-prefix? "0x" s) (string->number (string-drop s 2) 16))
+        ((string-prefix? "0" s) (string->number s 8))
+        (else (string->number s))))
+
+(define (struct-field o)
+  (pmatch o
+    ((comp-decl (decl-spec-list (type-spec (enum-ref (ident ,type))))
+                (comp-declr-list (comp-declr (ident ,name))))
+     (cons type name))
+    ((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ident ,name))))
+     (cons type name))
+    ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ident ,name))))
+     (cons type name))
+    (_ (stderr "struct-field: no match: ~a" o) barf)))
 
 (define (ast->info info)
   (lambda (o)
                           else-text)
                   #:globals (.globals else-info))))
 
+        ((switch ,expr (compd-stmt (block-item-list . ,cases)))
+         (let* ((accu ((expr->accu info) expr))
+                (expr (if (info? accu) accu ;; AAARGH
+                          (clone info #:text
+                                 (append text (list accu)))))
+                (empty (clone info #:text '()))
+                (case-infos (map (case->jump-info empty) cases))
+                (case-lengths (map (lambda (c-j) (length (text->list (.text (c-j 0))))) case-infos))
+                (cases-info (let loop ((cases cases) (info expr) (lengths case-lengths))
+                              (if (null? cases) info
+                                  (let ((c-j ((case->jump-info info) (car cases))))
+                                    (loop (cdr cases) (c-j (apply + (cdr lengths))) (cdr lengths)))))))
+           cases-info))
+
         ((for ,init ,test ,step ,body)
          (let* ((info (clone info #:text '()))
 
                                    (i386:value->accu b)
                                    (i386:sub-base)
                                    (i386:xor-zf))))))))
-        
+
+        ((ne (p-expr (ident ,a)) (p-expr (char ,b)))
+         (let ((b (char->integer (car (string->list b)))))
+           (clone info #:text
+                  (append text
+                          ((ident->base info) a)
+                          (list (lambda (f g t d)
+                                  (append 
+                                   (i386:value->accu b)
+                                   (i386:sub-base)
+                                   (i386:xor-zf))))))))        
+
         ((ne (p-expr (ident ,a)) (neg (p-expr (fixed ,b))))
          (let ((b (- (cstring->number b))))
            (clone info #:text
                                    (i386:sub-base)
                                    (i386:xor-zf))))))))
 
+        ((ne (p-expr (ident ,a)) (p-expr (ident ,constant)))
+         (let ((b (assoc-ref (.constants info) constant)))
+           (clone info #:text
+                  (append text
+                          ((ident->base info) a)
+                          (list (lambda (f g t d)
+                                  (append
+                                   (i386:value->accu b)
+                                   (i386:sub-base)
+                                   (i386:xor-zf))))))))
+        
         ((ne (fctn-call . ,call) (p-expr (fixed ,b)))
          (let ((b (cstring->number b))
                (info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
                                    (i386:byte-test-base)
                                    (i386:xor-zf)))))))
 
+        ((ne (de-ref (p-expr (ident ,a))) (p-expr (char ,b)))
+         (let ((b (char->integer (car (string->list b)))))
+           (clone info #:text
+                  (append text
+                          (list (lambda (f g t d)
+                                  (append
+                                   (i386:local->accu (assoc-ref locals a))
+                                   (i386:byte-mem->base)
+                                   ;;(i386:local->accu (assoc-ref locals b))
+                                   ;;(i386:byte-mem->accu)
+                                   (i386:value->accu b)
+                                   (i386:byte-test-base)
+                                   (i386:xor-zf))))))))
+
+        ;; CAR (x) != 1 // cell_nil
+        ((ne (d-sel . ,d-sel) (p-expr (fixed ,b)))
+         (let ((expr ((expr->accu info) `(d-sel ,@d-sel)))
+               (b (cstring->number b)))
+           (clone info #:text
+                  (append text
+                          (.text expr)
+                          (list (lambda (f g t d)
+                                  (append
+                                   (i386:value->base b)
+                                   (i386:sub-base)
+                                   (i386:xor-zf))))))))
+
+        ;; CAR (x) != PAIR
+        ((ne (d-sel . ,d-sel) (p-expr (ident ,constant)))
+         (let ((expr ((expr->accu info) `(d-sel ,@d-sel)))
+               (b (assoc-ref (.constants info) constant)))
+           (clone info #:text
+                  (append text
+                          (.text expr)
+                          (list (lambda (f g t d)
+                                  (append
+                                   (i386:value->base b)
+                                   (i386:sub-base)
+                                   (i386:xor-zf))))))))
+
         ((lt (p-expr (ident ,a)) (p-expr (fixed ,b)))
          (let ((b (cstring->number b)))
            (clone info #:text
              (clone info #:text
                     (append text ((value->ident info) name value))))))
 
+        ;; int i = 0;
+        ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
+         (let* ((locals (add-local name))
+                (info (clone info #:locals locals))
+                (value (cstring->number value)))
+           (clone info #:text
+                  (append text
+                          ((value->ident info) name value)))))
+
+        ;; int i = -1;
+        ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (neg (p-expr (fixed ,value)))))))
+         (let* ((locals (add-local name))
+                (info (clone info #:locals locals))
+                (value (- (cstring->number value))))
+           (clone info #:text
+                  (append text
+                          ((value->ident info) name value)))))
+
         ;; int i = argc;
         ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
          (let* ((locals (add-local name))
                                    (i386:global->accu (+ (data-offset value g) d)))))
                           ((accu->ident info) name)))))
         
+        ;; char arena[20000];
+        ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (array-of (ident ,name) (p-expr (fixed ,count))))))
+         (let* ((globals (.globals info))
+                (count (cstring->number count))
+                (size 1) ;; FIXME
+                (array (list (ident->global name 0)))  ;;FIXME: deref?
+                (dummy (list (cons (string->list "dummy")
+                                   (string->list (make-string (* count size) #\nul))))))
+           (clone info #:globals (append globals array dummy))))
+
+        ;;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)))))))
+         (let* ((locals (add-local name))
+                (info (clone info #:locals locals)))
+           (clone info #:text
+                  (append text
+                          ((ident->accu info) name)
+                          ((accu->ident info) value))))) ;; FIXME: deref?
+
         ;; SCM g_stack = 0;
         ((decl (decl-spec-list (type-spec (typename _))) (init-declr-list (init-declr (ident _) (initzer (p-expr (fixed _))))) (comment _))
          ((ast->info info) (list-head o (- (length o) 1))))
                     (append (.text info)
                             ((accu->ident info) name))))))
 
+        ;; 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)))))))
+         (let* ((locals (add-local name))
+                (info (clone info #:locals locals)))
+           (clone info #:text
+                  (append text
+                          ((ident->accu info) value)
+                          ((accu->ident info) name)))))
+
+        ;; char *p = g_cells;
+        ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (ident ,value))))))
+         (let* ((locals (add-local name))
+                (info (clone info #:locals locals)))
+           (clone info #:text
+                  (append text
+                          ((ident->accu info) value)
+                          ((accu->ident info) name)))))
+
         ;; enum 
         ((decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields)))))
          (let ((type (ident->type name "enum"))
            (clone info #:types (append (.types info) (list type))
                   #:constants (append constants (.constants info)))))
 
+        ;; struct
+        ((decl (decl-spec-list (type-spec (struct-def (ident ,name) (field-list . ,fields)))))
+         (let* ((type (ident->type name (map struct-field fields))))
+           (clone info #:types (append (.types info) (list type)))))
+        
         ;; i = 0;
         ((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (p-expr (fixed ,value))))
          ;;(stderr "RET LOCAL[~a]: ~a\n" name (assoc-ref locals name))
          (let* ((info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
            (clone info #:text (append (.text info) ((accu->ident info) name)))))
 
+        ;; p = g_cell;
+        ((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (p-expr (ident ,value))))
+         (clone info #:text
+                (append text
+                        ((ident->accu info) value)
+                        ((accu->ident info) name))))
+        
+        ;; *p++ = c;
+        ((expr-stmt (assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op _) (p-expr (ident ,value))))
+         (let* ((locals (add-local name))
+               (info (clone info #:locals locals)))
+           (clone info #:text
+                  (append text
+                          ((ident->accu info) value)
+                          ((accu->ident info) name)
+                          (list (lambda (f g t d)
+                                  (i386:local-add (assoc-ref locals name) 1)))))))
+
+        ((d-sel . ,d-sel)
+         (let ((expr ((expr->accu info) `(d-sel ,@d-sel))))
+           expr))        
+
+        ;; i = CAR (x)
+        ((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (d-sel . ,d-sel)))
+         (let ((expr ((expr->accu info) `(d-sel ,@d-sel))))
+           (clone info #:text (append (.text expr)
+                                      ((accu->ident info) name)))))
+
+
+        ;; TYPE (x) = PAIR;
+        ;; ((expr-stmt (assn-expr (d-sel . ,d-sel) (op _) (p-expr (ident ,constant))))
+        ;;  (let ((expr ((expr->accu info) `(d-sel ,@d-sel)))
+        ;;        (b (assoc-ref (.constants info) constant)))
+        ;;    (clone info #:text (append (.text expr)
+        ;;                               (list (lambda (f g t d)
+        ;;                                       (i386:accu+base)
+        ;;                                       (i386:value->accu-ref b)))))))
+
+        ((expr-stmt (assn-expr (d-sel (ident ,field) . ,d-sel) (op _) (p-expr (ident ,constant))))
+         (let* ((expr ((expr->Xaccu info) `(d-sel (ident ,field) ,@d-sel)))
+                (b (assoc-ref (.constants info) constant))
+
+                (struct-type "scm") ;; FIXME
+                (struct (assoc-ref (.types info) struct-type))
+                (size (length struct))
+                (field-size 4) ;; FIXME:4, not fixed
+                (offset (* field-size (1- (length (member field (reverse struct) (lambda (a b) (equal? a (cdr b)))))))))
+           (clone info #:text (append (.text expr)
+                                      (list (lambda (f g t d)
+                                              (i386:value->accu-ref+n offset b)))))))
+
+        ;; CAR (x) = 0
+        ;; ((expr-stmt (assn-expr (d-sel . ,d-sel) (op _) (p-expr (fixed ,value))))
+        ;;  (let ((expr ((expr->accu info) `(d-sel ,@d-sel)))
+        ;;        (b (cstring->number value)))
+        ;;    (clone info #:text (append (.text expr)
+        ;;                               (list (lambda (f g t d)
+        ;;                                       (i386:accu+base)
+        ;;                                       (i386:value->accu-ref b)))))))
+        ((expr-stmt (assn-expr (d-sel (ident ,field) . ,d-sel) (op _) (p-expr (fixed ,value))))
+         (let* ((expr ((expr->Xaccu info) `(d-sel (ident ,field) ,@d-sel)))
+                (b (cstring->number value))
+                
+                (struct-type "scm") ;; FIXME
+                (struct (assoc-ref (.types info) struct-type))
+                (size (length struct))
+                (field-size 4) ;; FIXME:4, not fixed
+                (offset (* field-size (1- (length (member field (reverse struct) (lambda (a b) (equal? a (cdr b))))))))               )
+           (clone info #:text (append (.text expr)
+                                      (list (lambda (f g t d)
+                                              (i386:value->accu-ref+n offset b)))))))
+
+        ;; g_cells[0] = 65;
+        ((expr-stmt (assn-expr (array-ref (p-expr (fixed ,index)) (p-expr (ident ,name))) (op _) (p-expr (fixed ,value))))
+         (let ((index (cstring->number index))
+               (value (cstring->number value)))
+          (clone info #:text
+                 (append text
+                         ((ident->base info) name)
+                         ((ident->accu info) index)
+                         (list (lambda (f g t d)
+                                 (i386:accu+base)
+                                 (i386:value->accu-ref value)))))))
+
+        ((expr-stmt (assn-expr (array-ref (p-expr (fixed ,index)) (p-expr (ident ,name))) (op _) (p-expr (char ,value))))
+         (let ((index (cstring->number index))
+               (value (char->integer (car (string->list value)))))
+          (clone info #:text
+                 (append text
+                         ((ident->base info) name)
+                         ((ident->accu info) index)
+                         (list (lambda (f g t d)
+                                 (i386:accu+base)
+                                 (i386:value->accu-ref value)))))))
+
         (_
          (format (current-error-port) "SKIP statement=~s\n" o)
          info)))))
@@ -1012,11 +1452,11 @@ strlen (char const* s)
 int
 getchar ()
 {
-  char c;
-  int r = read (g_stdin, &c, 1);
-  //int r = read (0, &c, 1);
+  char c1;
+  int r = read (g_stdin, &c1, 1);
+  //int r = read (0, &c1, 1);
   if (r < 1) return -1;
-  return c;
+  return c1;
 }
 "
 ;;paredit:"
@@ -1125,7 +1565,7 @@ strcmp (char const* a, char const* b)
 (define (compile)
   (let* ((ast (mescc))
          (info (make <info> #:functions i386:libc))
-         (info ((ast->info info) libc))
+         (ast (append libc ast))
          (info ((ast->info info) ast))
          (info ((ast->info info) _start)))
     (info->exe info)))
index 4875ecbf4dc14d3f6a26b71ec1ad6a14cea0c4b6..499d56ecc9dcf55d30f175cb5f9e898af7743d45 100644 (file)
 (define (function-prefix name functions)
   (member name (reverse functions) (lambda (a b) (equal? (car b) name))))
 
-(define (function-offset name functions)
-  (let ((prefix (function-prefix name functions)))
-    (if prefix (length (functions->text (cdr prefix) '() 0 0))
-        0)))
+(define function-offset
+  (let ((cache '()))
+    (lambda (name functions)
+      (or (assoc-ref cache name)
+          (let* ((prefix (function-prefix name functions))
+                 (offset (if prefix (length (functions->text (cdr prefix) '() 0 0))
+                             0)))
+            (if (or (equal? name "exit") (> offset 0)) (set! cache (assoc-set! cache name offset)))
+            offset)))))
 
 (define (label-offset function label functions)
   (let ((prefix (function-prefix function functions)))
index 7930b737cd2dd78e21aa9272f02b0a4468e3d374..27c806696d69c09df2ffc0923ca668145a027c57 100644 (file)
   '(#x83 #xec #x20))               ; sub    $0x10,%esp -- 8 local vars
 
 (define (i386:push-global-ref o)
+  (or o push-global-ref)
   `(#x68 ,@(int->bv32 o)))              ; push  $0x<o>
 
 (define (i386:push-global o)
+  (or o push-global)
   `(#xa1 ,@(int->bv32 o)                ; mov    0x804a000,%eax
          #x50))                         ; push  %eax
 
   `(#x8d #x45 ,(- 0 (* 4 n))            ; lea 0x<n>(%ebp),%eax
          #x50))                         ; push %eax
 
+(define (i386:push-local-de-ref n)
+  (or n push-local-de-ref)
+  `(#x8b #x45 ,(- 0 (* 4 n))            ; mov    -0x<n>(%ebp),%eax
+         #x0f #xb6 #x00                ; movzbl (%eax),%eax
+         ;;#x0f #xbe #xc0                 ; movsbl %al,%eax ***FIXME BYTE****
+         #x50))                         ; push   %eax
+
 (define (i386:push-accu)
   `(#x50))                              ; push %eax
 
 (define (i386:push-arg f g t d)
   (lambda (o)
+    (or o push-arg)
     (cond ((number? o)
            `(#x68 ,@(int->bv32 o)))     ; push $<o>
+          ((and (pair? o) (procedure? (car o)))
+           (append-map (lambda (p) (p f g t d)) o))
           ((pair? o) o)
           ((procedure? o) (o f g t d))
           (_ barf))))
 
 (define (i386:accu->global n)
   (or n accu->global)
-  `(#xa3 ,@(int->bv32 n)))                ; mov    %eax,0x0
+  `(#xa3 ,@(int->bv32 n)))              ; mov    %eax,0x0
 
 (define (i386:accu-zero?)
-  `(#x85 #xc0))                         ; cmpl   %eax,%eax
+  '(#x85 #xc0))                         ; cmpl   %eax,%eax
 
 (define (i386:accu-non-zero?)
   (append '(#x85 #xc0)                  ; cmpl   %eax,%eax
           (i386:xor-zf)))
 
+(define (i386:accu-shl n)
+  `(#xc1 #xe0 ,n))                      ; shl    $0x8,%eax
+
+(define (i386:accu+accu)
+  '(#x01 #xc0))                         ; add    %eax,%eax
+
+(define (i386:accu+base)
+  `(#x01 #xd0))                         ; add    %edx,%eax
+
+(define (i386:base->accu)
+  '(#x89 #xd0))                         ; mov    %edx,%eax
+
 (define (i386:local->accu n)
   (or n local->accu)
   `(#x8b #x45 ,(- 0 (* 4 n))))          ; mov    -<0xn>(%ebp),%eax
 
+(define (i386:byte-local->accu n)
+  (or n local->accu)
+  `(#x0f #xb6 #x45 ,(- 0 (* 4 n))))     ; movzbl 0x<n>(%ebp),%eax
+
 (define (i386:local->base n)
   (or n local->base)
   `(#x8b #x55 ,(- 0 (* 4 n))))          ; mov    -<0xn>(%ebp),%edx
 
+(define (i386:global-ref->base n)
+  (or n global->base)
+  `(#x8b #x15 ,@(int->bv32 n)))         ; mov    0x<n>,%edx
+
 (define (i386:global->base n)
   (or n global->base)
-  `(#x8b #x15 ,@(int->bv32 n)))         ; mov    0xn,%edx
+  `(#xba ,@(int->bv32 n)))              ; mov    $<n>,%edx
 
 (define (i386:byte-base-mem->accu)
   '(#x01 #xd0                           ; add    %edx,%eax
   '(#x01 #xd0                           ; add    %edx,%eax
          #x8b #x00))                    ; mov    (%eax),%eax
 
+(define (i386:base-mem+n->accu n)
+  `(#x01 #xd0                           ; add    %edx,%eax
+         #x8b #x40 ,n))                 ; mov    <n>(%eax),%eax
+
 (define (i386:global->accu o)
+  (or o global->accu)
   `(#xb8 ,@(int->bv32 o)))              ; mov    $<>,%eax
 
 (define (i386:value->accu v)
+  (or v value->accu)
   `(#xb8 ,@(int->bv32 v)))              ; mov    $<v>,%eax
 
+(define (i386:value->accu-ref v)
+  (or v value->accu-ref)
+  `(#xc7 #x00 ,@(int->bv32 v)))         ; movl   $0x<v>,(%eax)
+
+(define (i386:value->accu-ref+n n v)
+  `(#xc7 #x40 ,n ,@(int->bv32 v)))      ; movl   $<v>,0x<n>(%eax)
+
+(define (i386:base->accu-ref)
+  '(#x89 #x10))                         ; mov    %edx,(%eax)
+
 (define (i386:value->base v)
   `(#xba ,@(int->bv32 v)))              ; mov    $<v>,%edx
 
 
 (define (i386:local-address->accu n)
   (or n ladd)
-  `(#x8d #x45 ,(- 0 (* 4 n))))        ; lea 0x<n>(%ebp),%eax
+  `(#x8d #x45 ,(- 0 (* 4 n))))          ; lea 0x<n>(%ebp),%eax
 
 (define (i386:value->global n v)
   (or n value->global)
-  `(#xc7 #x05 ,@(int->bv32 n)            ; movl   $<v>,(<n>)
+  `(#xc7 #x05 ,@(int->bv32 n)           ; movl   $<v>,(<n>)
          ,@(int->bv32 v)))
 
 (define (i386:value->local n v)
      #xe8 ,@(int->bv32 (- address 5 s)) ; call relative
      #x83 #xc4 ,(* n 4)                 ; add    $00,%esp
      )))
-  
 (define (i386:accu-not)
   `(#x0f #x94 #xc0                      ; sete %al
          #x0f #xb6 #xc0))               ; movzbl %al,%eax
     #x80 #xf4 #x40                      ; xor    $0x40,%ah
     #x9e))                              ; sahf   
 
+(define (i386:accu-cmp-value v)
+  `(#x83 #xf8 ,v))                      ; cmp    $<v>,%eax
+
 (define (i386:accu-test)
   '(#x85 #xc0))                         ; test   %eax,%eax
 
-(define (i386:jump n)
+(define (i386:Xjump n)
+  `(#xe9 ,@(int->bv32 n)))              ; jmp . + <n>
+
+(define (i386:Xjump-nz n)
+  `(#x0f #x85 ,@(int->bv32 n)))         ; jnz . + <n>
+
+(define (i386:jump n)  ;;FIXME: NEED THIS WEIRDNESS for t.c
   `(#xeb ,(if (>= n 0) (- n 2) (- n 2))))   ; jmp <n>
 
+;; (define (i386:jump n)
+;;   `(#xeb ,(if (>= n 0) n (- n 2))))     ; jmp <n>
+
 (define (i386:jump-c n)
   `(#x72 ,(if (>= n 0) n (- n 2))))     ; jc <n>
 
index 610d1747b539904f13adeccdcf9df144ecccdcb0..9b057f69acf0ce411fef64aa2901524344c9bd87 100644 (file)
   #:use-module (mes elf)
   #:export (
             i386:accu-not
+            i386:accu-cmp-value
             i386:accu->global
             i386:accu->local
             i386:accu-non-zero?
             i386:accu-test
             i386:accu-zero?
+            i386:accu+accu
+            i386:accu+base
+            i386:accu-shl
             i386:base-sub
+            i386:base->accu
+            i386:base->accu-ref
             i386:base-mem->accu
             i386:byte-base-sub
             i386:byte-base-mem->accu
+            i386:byte-local->accu
             i386:byte-mem->accu
+            i386:base-mem+n->accu
             i386:byte-mem->base
             i386:byte-test-base
             i386:byte-sub-base
@@ -68,6 +76,7 @@
             i386:push-global
             i386:push-global-ref
             i386:push-local
+            i386:push-local-de-ref
             i386:push-local-ref
             i386:ret
             i386:ret-local
             i386:test-base
             i386:test-jump-z
             i386:value->accu
+            i386:value->accu-ref
+            i386:value->accu-ref+n
             i386:value->global
             i386:value->local
             i386:value->base
             i386:xor-accu
             i386:xor-zf
 
+            i386:Xjump
+            i386:Xjump-nz
+
             ;; libc
             i386:exit
             i386:open
index ae1949a4bc724aea8822824e39b649202005cf93..79590fba54aff1044e2bd917546f0f6c129f3feb 100644 (file)
@@ -72,6 +72,15 @@ puts (char const* s)
   return 0;
 }
 
+int
+putchar (int c)
+{
+  //write (STDOUT, s, strlen (s));
+  //int i = write (STDOUT, s, strlen (s));
+  write (1, (char*)&c, 1);
+  return 0;
+}
+
 int
 strcmp (char const* a, char const* b)
 {
@@ -81,6 +90,15 @@ strcmp (char const* a, char const* b)
 int test (char *p);
 #endif
 
+// struct scm {
+//   int type;
+//   int car;
+//   int cdr;
+// };
+
+char arena[20];
+char *g_cells = arena;
+
 int
 main (int argc, char *argv[])
 {
@@ -97,6 +115,32 @@ main (int argc, char *argv[])
   return 22;
 }
 
+int
+swits (int c)
+{
+  int x = -1;
+  switch (c)
+    {
+      case 0:
+        {
+          x = 0;
+          c = 34;
+          break;
+        }
+      case 1:
+        {
+          x = 1;
+          break;
+        }
+      default:
+        {
+          x = 2;
+          break;
+        }
+    }
+  return x;
+}
+
 int
 test (char *p)
 {
@@ -156,12 +200,26 @@ test (char *p)
   puts ("t: if (--i)\n");
   if (--i) return 1;
 
-  puts ("t: (one == 1) ?");
+  puts ("t: (one == 1) ?\n");
   (one == 1) ? 1 : exit (1);
 
-  puts ("t: (f) ?");
+  puts ("t: (f) ?\n");
   (f) ? exit (1) : 1;
 
+  puts ("t: *x != 'Q'\n");
+  g_cells[0] = 'Q';
+  char *x = g_cells;
+  if (*x != 'Q') return 1;
+
+  puts ("t: switch 0\n");
+  if (swits (0) != 0) return swits (0);
+
+  puts ("t: switch 1\n");
+  if (swits (1) != 1) return 1;
+
+  puts ("t: switch -1\n");
+  if (swits (-1) != 2) return 1;
+
   puts ("t: if (1)\n");
   if (1) goto ok0;
   return 1;