From d47f0f65c51e0eb32da867c8668694a57df983dd Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Mon, 17 Apr 2017 02:15:11 +0200 Subject: [PATCH] mescc: Support pointer arrays and some arithmetic. * 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 | 395 ++++++++++++++++++++++++------- module/mes/as-i386.mes | 27 ++- module/mes/as-i386.scm | 3 + scaffold/m.c | 1 + scaffold/t.c | 79 ++++++- 5 files changed, 417 insertions(+), 88 deletions(-) diff --git a/module/language/c99/compiler.mes b/module/language/c99/compiler.mes index 82c9756c..3231f21c 100644 --- a/module/language/c99/compiler.mes +++ b/module/language/c99/compiler.mes @@ -92,9 +92,11 @@ (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)))) @@ -108,7 +110,9 @@ (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 ') (define ') @@ -219,13 +223,33 @@ (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))) @@ -257,9 +281,15 @@ (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))) @@ -268,7 +298,6 @@ (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)) @@ -282,9 +311,15 @@ ,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))) @@ -297,19 +332,11 @@ (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)))) @@ -317,26 +344,81 @@ (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) @@ -348,8 +430,14 @@ (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) @@ -366,15 +454,28 @@ (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)))) @@ -384,10 +485,11 @@ (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))) @@ -405,16 +507,19 @@ (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))) @@ -432,7 +537,9 @@ ;; g_cells[] ((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)) @@ -475,11 +582,24 @@ ((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)))) @@ -529,8 +649,11 @@ ((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))) @@ -607,6 +730,7 @@ (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) @@ -660,14 +784,14 @@ (define (expr->accu* info) (lambda (o) - ;; (stderr "expr->accu* o=~s\n" o) - (pmatch o ;; g_cells[] ((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 @@ -718,11 +842,13 @@ ((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) @@ -913,8 +1039,6 @@ ("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)) @@ -925,10 +1049,6 @@ (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 @@ -944,10 +1064,6 @@ (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)) @@ -969,11 +1085,6 @@ (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)) @@ -1251,19 +1362,53 @@ (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) @@ -1271,7 +1416,42 @@ (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)))))) @@ -1286,7 +1466,6 @@ ;;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))) @@ -1299,14 +1478,12 @@ ;; 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)) @@ -1321,7 +1498,6 @@ ;; 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))) @@ -1350,7 +1526,6 @@ ;; 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))) @@ -1374,9 +1549,7 @@ ;; 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))) @@ -1406,19 +1579,80 @@ ;; 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: 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)) @@ -1526,7 +1760,6 @@ ((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))) @@ -1539,6 +1772,7 @@ (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) @@ -1558,12 +1792,18 @@ (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) @@ -1575,14 +1815,11 @@ (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 diff --git a/module/mes/as-i386.mes b/module/mes/as-i386.mes index 3e39cbbf..c325729b 100644 --- a/module/mes/as-i386.mes +++ b/module/mes/as-i386.mes @@ -58,11 +58,23 @@ `(#x8d #x45 ,(- 0 (* 4 n)) ; lea 0x(%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(%ebp),%eax #x0f #xb6 #x00 ; movzbl (%eax),%eax - ;;#x0f #xbe #xc0 ; movsbl %al,%eax ***FIXME BYTE**** + #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(%ebp),%eax + #x8b #x00 ; mov (%eax),%eax + #x0f #xb6 #x00 ; movzbl (%eax),%eax + #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(%ebp),%eax + #x8b #x00 ; mov (%eax),%eax #x50)) ; push %eax (define (i386:pop-accu) @@ -98,6 +110,10 @@ (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) @@ -188,7 +204,7 @@ (define (i386:byte-local->base n) (or n (error "invalid value: byte-local->base: " n)) - `(x0f #xb6 #x95 ,(- 0 (* 4 n)))) ; movzbl 0x(%ebp),%edx + `(#x0f #xb6 #x55 ,(- 0 (* 4 n)))) ; movzbl 0x(%ebp),%edx (define (i386:local->base n) (or n (error "invalid value: local->base: " n)) @@ -279,6 +295,9 @@ (or n (error "invalid value: i386:local-add: " n)) `(#x83 #x45 ,(- 0 (* 4 n)) ,v)) ; addl $,0x(%ebp) +(define (i386:accu-mem-add v) + `(#x83 #x00 ,v)) ; addl $,(%eax) + (define (i386:global-add n v) (or n (error "invalid value: i386:global-add: " n)) `(#x83 #x05 ,@(int->bv32 n) ,v)) ; addl $,0x diff --git a/module/mes/as-i386.scm b/module/mes/as-i386.scm index 5ab95cdc..330d9bb3 100644 --- a/module/mes/as-i386.scm +++ b/module/mes/as-i386.scm @@ -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 @@ -106,6 +107,8 @@ 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 diff --git a/scaffold/m.c b/scaffold/m.c index 4dd2472e..2d12be37 100644 --- a/scaffold/m.c +++ b/scaffold/m.c @@ -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 (); diff --git a/scaffold/t.c b/scaffold/t.c index 2f10d2f8..129605ab 100644 --- a/scaffold/t.c +++ b/scaffold/t.c @@ -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);