From 057607ca0a8d4cbc748c4f9d9ee37d918b07fb70 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 13 May 2018 13:50:32 +0200 Subject: [PATCH] mescc: Tinycc support: Implement (foo--)->bar and permutations. * module/language/c99/info.scm (clone): Add post field. (make): Handle post parameter. * module/language/c99/compiler.mes (clone): Handle post parameter. (expr->accu*): Set it to support foo--/foo--. (expr->accu): Read it to support foo--/foo--. * scaffold/tests/7o-struct-pre-post.c: Test it. * build-aux/check-mescc.sh: Run it. --- build-aux/check-mescc.sh | 1 + module/language/c99/compiler.mes | 746 +++++++++++++++------------- module/language/c99/info.scm | 8 +- scaffold/tests/7o-struct-pre-post.c | 39 ++ 4 files changed, 451 insertions(+), 343 deletions(-) create mode 100644 scaffold/tests/7o-struct-pre-post.c diff --git a/build-aux/check-mescc.sh b/build-aux/check-mescc.sh index 404c8bbe..59d2328d 100755 --- a/build-aux/check-mescc.sh +++ b/build-aux/check-mescc.sh @@ -111,6 +111,7 @@ t 7l-struct-any-size-array 7m-struct-char-array-assign 7n-struct-struct-array +7o-struct-pre-post 80-setjmp 81-qsort 82-define diff --git a/module/language/c99/compiler.mes b/module/language/c99/compiler.mes index ea41b362..947ab1df 100644 --- a/module/language/c99/compiler.mes +++ b/module/language/c99/compiler.mes @@ -115,6 +115,7 @@ (statics (.statics o)) (function (.function o)) (text (.text o)) + (post (.post o)) (break (.break o)) (continue (.continue o))) (let-keywords rest @@ -127,9 +128,10 @@ (statics statics) (function function) (text text) + (post post) (break break) (continue continue)) - (make #:types types #:constants constants #:functions functions #:globals globals #:locals locals #:statics statics #:function function #:text text #:break break #:continue continue)))))) + (make #:types types #:constants constants #:functions functions #:globals globals #:locals locals #:statics statics #:function function #:text text #:post post #:break break #:continue continue)))))) (define (ident->constant name value) (cons name value)) @@ -810,6 +812,66 @@ (info (expr->base array info))) (append-text info (wrap-as (i386:accu+base))))) + ;;((cast (type-name (decl-spec-list (type-spec (typename "Elf32_Rel"))) (abs-declr (pointer))) (add (i-sel (ident "data") (p-expr (ident "sr"))) (p-expr (ident "a"))))) + + ((cast ,type ,expr) + (expr->accu expr info)) + + ;; ((post-dec (p-expr (ident "vtop")))) + + ;; ((cast ,type ,expr) + ;; (expr->accu `(ref-to ,expr) info)) + + ((pre-dec ,expr) + (let* ((rank (expr->rank info expr)) + (size (cond ((= rank 1) (ast-type->size info expr)) + ((> rank 1) 4) + (else 1))) + (info ((expr-add info) expr (- size))) + (info (append (expr->accu* expr info)))) + info)) + + ((pre-inc ,expr) + (let* ((rank (expr->rank info expr)) + (size (cond ((= rank 1) (ast-type->size info expr)) + ((> rank 1) 4) + (else 1))) + (info ((expr-add info) expr size)) + (info (append (expr->accu* expr info)))) + info)) + + ((post-dec ,expr) + (let* ((info (expr->accu* expr info)) + (info (append-text info (wrap-as (i386:push-accu)))) + (post (clone info #:text '())) + (post (append-text post (ast->comment o))) + (post (append-text post (wrap-as (i386:pop-base)))) + (post (append-text post (wrap-as (i386:push-accu)))) + (post (append-text post (wrap-as (i386:base->accu)))) + (rank (expr->rank post expr)) + (size (cond ((= rank 1) (ast-type->size post expr)) + ((> rank 1) 4) + (else 1))) + (post ((expr-add post) expr (- size))) + (post (append-text post (wrap-as (i386:pop-accu))))) + (clone info #:post (.text post)))) + + ((post-inc ,expr) + (let* ((info (expr->accu* expr info)) + (info (append-text info (wrap-as (i386:push-accu)))) + (post (clone info #:text '())) + (post (append-text post (ast->comment o))) + (post (append-text post (wrap-as (i386:pop-base)))) + (post (append-text post (wrap-as (i386:push-accu)))) + (post (append-text post (wrap-as (i386:base->accu)))) + (rank (expr->rank post expr)) + (size (cond ((= rank 1) (ast-type->size post expr)) + ((> rank 1) 4) + (else 1))) + (post ((expr-add post) expr size)) + (post (append-text post (wrap-as (i386:pop-accu))))) + (clone info #:post (.text post)))) + (_ (error "expr->accu*: not supported: " o)))) (define (expr-add info) @@ -820,392 +882,396 @@ (define (expr->accu o info) (let ((locals (.locals info)) - (constants (.constants info)) (text (.text info)) (globals (.globals info))) - (pmatch o - ((expr) info) + (define (helper) + (pmatch o + ((expr) info) - ((comma-expr) info) + ((comma-expr) info) - ((comma-expr ,a . ,rest) - (let ((info (expr->accu a info))) - (expr->accu `(comma-expr ,@rest) info))) + ((comma-expr ,a . ,rest) + (let ((info (expr->accu a info))) + (expr->accu `(comma-expr ,@rest) info))) - ((p-expr (string ,string)) - (let* ((globals ((globals:add-string globals) string)) - (info (clone info #:globals globals))) - (append-text info (list (i386:label->accu `(#:string ,string)))))) + ((p-expr (string ,string)) + (let* ((globals ((globals:add-string globals) string)) + (info (clone info #:globals globals))) + (append-text info (list (i386:label->accu `(#:string ,string)))))) - ((p-expr (fixed ,value)) - (let ((value (cstring->number value))) - (append-text info (wrap-as (i386:value->accu value))))) + ((p-expr (fixed ,value)) + (let ((value (cstring->number value))) + (append-text info (wrap-as (i386:value->accu value))))) - ((neg (p-expr (fixed ,value))) - (let ((value (- (cstring->number value)))) - (append-text info (wrap-as (i386:value->accu value))))) + ((neg (p-expr (fixed ,value))) + (let ((value (- (cstring->number value)))) + (append-text info (wrap-as (i386:value->accu value))))) - ((p-expr (char ,char)) - (let ((char (char->integer (car (string->list char))))) - (append-text info (wrap-as (i386:value->accu char))))) + ((p-expr (char ,char)) + (let ((char (char->integer (car (string->list char))))) + (append-text info (wrap-as (i386:value->accu char))))) - ((p-expr (string . ,strings)) - (append-text info (list (i386:label->accu `(#:string ,(apply string-append strings)))))) + ((p-expr (string . ,strings)) + (append-text info (list (i386:label->accu `(#:string ,(apply string-append strings)))))) - ((p-expr (ident ,name)) - (append-text info ((ident->accu info) name))) + ((p-expr (ident ,name)) + (append-text info ((ident->accu info) name))) - ((initzer ,initzer) - (expr->accu initzer info)) + ((initzer ,initzer) + (expr->accu initzer info)) - ;; offsetoff - ((ref-to (i-sel (ident ,field) (cast (type-name (decl-spec-list ,struct) (abs-declr (pointer))) (p-expr (fixed ,base))))) - (let* ((type (ast->basic-type struct info)) - (offset (field-offset info type field)) - (base (cstring->number base))) - (append-text info (wrap-as (i386:value->accu (+ base offset)))))) + ;; offsetoff + ((ref-to (i-sel (ident ,field) (cast (type-name (decl-spec-list ,struct) (abs-declr (pointer))) (p-expr (fixed ,base))))) + (let* ((type (ast->basic-type struct info)) + (offset (field-offset info type field)) + (base (cstring->number base))) + (append-text info (wrap-as (i386:value->accu (+ base offset)))))) - ;; &foo - ((ref-to (p-expr (ident ,name))) - (append-text info ((ident-address->accu info) name))) + ;; &foo + ((ref-to (p-expr (ident ,name))) + (append-text info ((ident-address->accu info) name))) - ;; &*foo - ((ref-to (de-ref ,expr)) - (expr->accu expr info)) + ;; &*foo + ((ref-to (de-ref ,expr)) + (expr->accu expr info)) - ((ref-to ,expr) - (expr->accu* expr info)) + ((ref-to ,expr) + (expr->accu* expr info)) - ((sizeof-expr ,expr) - (append-text info (wrap-as (i386:value->accu (ast->size expr info))))) + ((sizeof-expr ,expr) + (append-text info (wrap-as (i386:value->accu (ast->size expr info))))) - ((sizeof-type ,type) - (append-text info (wrap-as (i386:value->accu (ast->size type info))))) + ((sizeof-type ,type) + (append-text info (wrap-as (i386:value->accu (ast->size type info))))) - ((array-ref ,index ,array) - (let* ((info (expr->accu* o info)) - (size (ast->size o info))) - (append-text info (wrap-as (case size - ((1) (i386:byte-mem->accu)) - ((2) (i386:word-mem->accu)) - ((4) (i386:mem->accu)) - (else '())))))) + ((array-ref ,index ,array) + (let* ((info (expr->accu* o info)) + (size (ast->size o info))) + (append-text info (wrap-as (case size + ((1) (i386:byte-mem->accu)) + ((2) (i386:word-mem->accu)) + ((4) (i386:mem->accu)) + (else '())))))) - ((d-sel ,field ,struct) - (let* ((info (expr->accu* o info)) - (info (append-text info (ast->comment o))) - (type (ast->type o info)) - (size (->size type)) - (array? (c-array? type))) - (if array? info - (append-text info (wrap-as (case size - ((1) (i386:byte-mem->accu)) - ((2) (i386:word-mem->accu)) - ((4) (i386:mem->accu)) - (else '()))))))) + ((d-sel ,field ,struct) + (let* ((info (expr->accu* o info)) + (info (append-text info (ast->comment o))) + (type (ast->type o info)) + (size (->size type)) + (array? (c-array? type))) + (if array? info + (append-text info (wrap-as (case size + ((1) (i386:byte-mem->accu)) + ((2) (i386:word-mem->accu)) + ((4) (i386:mem->accu)) + (else '()))))))) - ((i-sel ,field ,struct) - (let* ((info (expr->accu* o info)) - (info (append-text info (ast->comment o))) - (type (ast->type o info)) - (size (->size type)) - (array? (c-array? type))) - (if array? info - (append-text info (wrap-as (case size - ((1) (i386:byte-mem->accu)) - ((2) (i386:word-mem->accu)) - ((4) (i386:mem->accu)) - (else '()))))))) + ((i-sel ,field ,struct) + (let* ((info (expr->accu* o info)) + (info (append-text info (ast->comment o))) + (type (ast->type o info)) + (size (->size type)) + (array? (c-array? type))) + (if array? info + (append-text info (wrap-as (case size + ((1) (i386:byte-mem->accu)) + ((2) (i386:word-mem->accu)) + ((4) (i386:mem->accu)) + (else '()))))))) - ((de-ref ,expr) - (let* ((info (expr->accu expr info)) - (size (ast->size o info))) - (append-text info (wrap-as (case size - ((1) (i386:byte-mem->accu)) - ((2) (i386:word-mem->accu)) - ((4) (i386:mem->accu)) - (else '())))))) + ((de-ref ,expr) + (let* ((info (expr->accu expr info)) + (size (ast->size o info))) + (append-text info (wrap-as (case size + ((1) (i386:byte-mem->accu)) + ((2) (i386:word-mem->accu)) + ((4) (i386:mem->accu)) + (else '())))))) - ((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->m1 arg0)))) - (let* ((text-length (length text)) - (args-info (let loop ((expressions (reverse expr-list)) (info info)) - (if (null? expressions) info - (loop (cdr expressions) ((expr->arg info) (car expressions)))))) - (n (length expr-list))) - (if (not (assoc-ref locals name)) - (begin - (if (and (not (assoc name (.functions info))) - (not (assoc name globals)) - (not (equal? name (.function info)))) - (stderr "warning: undeclared function: ~a\n" name)) - (append-text args-info (list (i386:call-label name n)))) - (let* ((empty (clone info #:text '())) - (accu (expr->accu `(p-expr (ident ,name)) empty))) - (append-text args-info (append (.text accu) - (list (i386:call-accu n))))))))) + ((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->m1 arg0)))) + (let* ((text-length (length text)) + (args-info (let loop ((expressions (reverse expr-list)) (info info)) + (if (null? expressions) info + (loop (cdr expressions) ((expr->arg info) (car expressions)))))) + (n (length expr-list))) + (if (not (assoc-ref locals name)) + (begin + (if (and (not (assoc name (.functions info))) + (not (assoc name globals)) + (not (equal? name (.function info)))) + (stderr "warning: undeclared function: ~a\n" name)) + (append-text args-info (list (i386:call-label name n)))) + (let* ((empty (clone info #:text '())) + (accu (expr->accu `(p-expr (ident ,name)) empty))) + (append-text args-info (append (.text accu) + (list (i386:call-accu n))))))))) - ((fctn-call ,function (expr-list . ,expr-list)) - (let* ((text-length (length text)) - (args-info (let loop ((expressions (reverse expr-list)) (info info)) - (if (null? expressions) info - (loop (cdr expressions) ((expr->arg info) (car expressions)))))) - (n (length expr-list)) - (empty (clone info #:text '())) - (accu (expr->accu function empty))) - (append-text args-info (append (.text accu) - (list (i386:call-accu n)))))) + ((fctn-call ,function (expr-list . ,expr-list)) + (let* ((text-length (length text)) + (args-info (let loop ((expressions (reverse expr-list)) (info info)) + (if (null? expressions) info + (loop (cdr expressions) ((expr->arg info) (car expressions)))))) + (n (length expr-list)) + (empty (clone info #:text '())) + (accu (expr->accu function empty))) + (append-text args-info (append (.text accu) + (list (i386:call-accu n)))))) - ((cond-expr . ,cond-expr) - (ast->info `(expr-stmt ,o) info)) + ((cond-expr . ,cond-expr) + (ast->info `(expr-stmt ,o) info)) - ((post-inc ,expr) - (let* ((info (append (expr->accu expr info))) - (info (append-text info (wrap-as (i386:push-accu)))) - (rank (expr->rank info expr)) - (size (cond ((= rank 1) (ast-type->size info expr)) - ((> rank 1) 4) - (else 1))) - (info ((expr-add info) expr size)) - (info (append-text info (wrap-as (i386:pop-accu))))) - info)) + ((post-inc ,expr) + (let* ((info (append (expr->accu expr info))) + (info (append-text info (wrap-as (i386:push-accu)))) + (rank (expr->rank info expr)) + (size (cond ((= rank 1) (ast-type->size info expr)) + ((> rank 1) 4) + (else 1))) + (info ((expr-add info) expr size)) + (info (append-text info (wrap-as (i386:pop-accu))))) + info)) - ((post-dec ,expr) - (let* ((info (append (expr->accu expr info))) - (info (append-text info (wrap-as (i386:push-accu)))) - (rank (expr->rank info expr)) - (size (cond ((= rank 1) (ast-type->size info expr)) - ((> rank 1) 4) - (else 1))) - (info ((expr-add info) expr (- size))) - (info (append-text info (wrap-as (i386:pop-accu))))) - info)) + ((post-dec ,expr) + (let* ((info (append (expr->accu expr info))) + (info (append-text info (wrap-as (i386:push-accu)))) + (rank (expr->rank info expr)) + (size (cond ((= rank 1) (ast-type->size info expr)) + ((> rank 1) 4) + (else 1))) + (info ((expr-add info) expr (- size))) + (info (append-text info (wrap-as (i386:pop-accu))))) + info)) - ((pre-inc ,expr) - (let* ((rank (expr->rank info expr)) - (size (cond ((= rank 1) (ast-type->size info expr)) - ((> rank 1) 4) - (else 1))) - (info ((expr-add info) expr size)) - (info (append (expr->accu expr info)))) - info)) + ((pre-inc ,expr) + (let* ((rank (expr->rank info expr)) + (size (cond ((= rank 1) (ast-type->size info expr)) + ((> rank 1) 4) + (else 1))) + (info ((expr-add info) expr size)) + (info (append (expr->accu expr info)))) + info)) - ((pre-dec ,expr) - (let* ((rank (expr->rank info expr)) - (size (cond ((= rank 1) (ast-type->size info expr)) - ((> rank 1) 4) - (else 1))) - (info ((expr-add info) expr (- size))) - (info (append (expr->accu expr info)))) - info)) + ((pre-dec ,expr) + (let* ((rank (expr->rank info expr)) + (size (cond ((= rank 1) (ast-type->size info expr)) + ((> rank 1) 4) + (else 1))) + (info ((expr-add info) expr (- size))) + (info (append (expr->accu expr info)))) + info)) - ((add ,a (p-expr (fixed ,value))) - (let* ((rank (expr->rank info a)) - (type (ast->basic-type a info)) - (struct? (structured-type? type)) - (size (cond ((= rank 1) (ast-type->size info a)) - ((> rank 1) 4) - ((and struct? (= rank 2)) 4) - (else 1))) - (info (expr->accu a info)) - (value (cstring->number value)) - (value (* size value))) - (append-text info (wrap-as (i386:accu+value value))))) + ((add ,a (p-expr (fixed ,value))) + (let* ((rank (expr->rank info a)) + (type (ast->basic-type a info)) + (struct? (structured-type? type)) + (size (cond ((= rank 1) (ast-type->size info a)) + ((> rank 1) 4) + ((and struct? (= rank 2)) 4) + (else 1))) + (info (expr->accu a info)) + (value (cstring->number value)) + (value (* size value))) + (append-text info (wrap-as (i386:accu+value value))))) - ((add ,a ,b) - (let* ((rank (expr->rank info a)) - (rank-b (expr->rank info b)) - (type (ast->basic-type a info)) - (struct? (structured-type? type)) - (size (cond ((= rank 1) (ast-type->size info a)) - ((> rank 1) 4) - ((and struct? (= rank 2)) 4) - (else 1)))) - (if (or (= size 1)) ((binop->accu info) a b (i386:accu+base)) - (let* ((info (expr->accu b info)) - (info (append-text info (wrap-as (append (i386:value->base size) - (i386:accu*base) - (i386:accu->base))))) - (info (expr->accu a info))) - (append-text info (wrap-as (i386:accu+base))))))) + ((add ,a ,b) + (let* ((rank (expr->rank info a)) + (rank-b (expr->rank info b)) + (type (ast->basic-type a info)) + (struct? (structured-type? type)) + (size (cond ((= rank 1) (ast-type->size info a)) + ((> rank 1) 4) + ((and struct? (= rank 2)) 4) + (else 1)))) + (if (or (= size 1)) ((binop->accu info) a b (i386:accu+base)) + (let* ((info (expr->accu b info)) + (info (append-text info (wrap-as (append (i386:value->base size) + (i386:accu*base) + (i386:accu->base))))) + (info (expr->accu a info))) + (append-text info (wrap-as (i386:accu+base))))))) - ((sub ,a (p-expr (fixed ,value))) - (let* ((rank (expr->rank info a)) - (type (ast->basic-type a info)) - (struct? (structured-type? type)) - (size (->size type)) - (size (cond ((= rank 1) size) - ((> rank 1) 4) - ((and struct? (= rank 2)) 4) - (else 1))) - (info (expr->accu a info)) - (value (cstring->number value)) - (value (* size value))) - (append-text info (wrap-as (i386:accu+value (- value)))))) + ((sub ,a (p-expr (fixed ,value))) + (let* ((rank (expr->rank info a)) + (type (ast->basic-type a info)) + (struct? (structured-type? type)) + (size (->size type)) + (size (cond ((= rank 1) size) + ((> rank 1) 4) + ((and struct? (= rank 2)) 4) + (else 1))) + (info (expr->accu a info)) + (value (cstring->number value)) + (value (* size value))) + (append-text info (wrap-as (i386:accu+value (- value)))))) - ((sub ,a ,b) - (let* ((rank (expr->rank info a)) - (rank-b (expr->rank info b)) - (type (ast->basic-type a info)) - (struct? (structured-type? type)) - (size (->size type)) - (size (cond ((= rank 1) size) - ((> rank 1) 4) - ((and struct? (= rank 2)) 4) - (else 1)))) - (if (or (= size 1) (or (= rank-b 2) (= rank-b 1))) - (let ((info ((binop->accu info) a b (i386:accu-base)))) - (if (and (not (= rank-b 2)) (not (= rank-b 1))) info - (append-text info (wrap-as (append (i386:value->base size) - (i386:accu/base)))))) - (let* ((info (expr->accu b info)) - (info (append-text info (wrap-as (append (i386:value->base size) - (i386:accu*base) - (i386:accu->base))))) - (info (expr->accu a info))) - (append-text info (wrap-as (i386:accu-base))))))) + ((sub ,a ,b) + (let* ((rank (expr->rank info a)) + (rank-b (expr->rank info b)) + (type (ast->basic-type a info)) + (struct? (structured-type? type)) + (size (->size type)) + (size (cond ((= rank 1) size) + ((> rank 1) 4) + ((and struct? (= rank 2)) 4) + (else 1)))) + (if (or (= size 1) (or (= rank-b 2) (= rank-b 1))) + (let ((info ((binop->accu info) a b (i386:accu-base)))) + (if (and (not (= rank-b 2)) (not (= rank-b 1))) info + (append-text info (wrap-as (append (i386:value->base size) + (i386:accu/base)))))) + (let* ((info (expr->accu b info)) + (info (append-text info (wrap-as (append (i386:value->base size) + (i386:accu*base) + (i386:accu->base))))) + (info (expr->accu a info))) + (append-text info (wrap-as (i386:accu-base))))))) - ((bitwise-and ,a ,b) ((binop->accu info) a b (i386:accu-and-base))) - ((bitwise-not ,expr) - (let ((info (ast->info expr info))) - (append-text info (wrap-as (i386:accu-not))))) - ((bitwise-or ,a ,b) ((binop->accu info) a b (i386:accu-or-base))) - ((bitwise-xor ,a ,b) ((binop->accu info) a b (i386:accu-xor-base))) - ((lshift ,a ,b) ((binop->accu info) a b (i386:accu<accu info) a b (i386:accu>>base))) - ((div ,a ,b) ((binop->accu info) a b (i386:accu/base))) - ((mod ,a ,b) ((binop->accu info) a b (i386:accu%base))) - ((mul ,a ,b) ((binop->accu info) a b (i386:accu*base))) + ((bitwise-and ,a ,b) ((binop->accu info) a b (i386:accu-and-base))) + ((bitwise-not ,expr) + (let ((info (ast->info expr info))) + (append-text info (wrap-as (i386:accu-not))))) + ((bitwise-or ,a ,b) ((binop->accu info) a b (i386:accu-or-base))) + ((bitwise-xor ,a ,b) ((binop->accu info) a b (i386:accu-xor-base))) + ((lshift ,a ,b) ((binop->accu info) a b (i386:accu<accu info) a b (i386:accu>>base))) + ((div ,a ,b) ((binop->accu info) a b (i386:accu/base))) + ((mod ,a ,b) ((binop->accu info) a b (i386:accu%base))) + ((mul ,a ,b) ((binop->accu info) a b (i386:accu*base))) - ((not ,expr) - (let* ((test-info (ast->info expr info))) - (clone info #:text - (append (.text test-info) - (wrap-as (i386:accu-negate))) - #:globals (.globals test-info)))) + ((not ,expr) + (let* ((test-info (ast->info expr info))) + (clone info #:text + (append (.text test-info) + (wrap-as (i386:accu-negate))) + #:globals (.globals test-info)))) - ((neg ,expr) - (let ((info (expr->base expr info))) - (append-text info (append (wrap-as (i386:value->accu 0)) - (wrap-as (i386:sub-base)))))) + ((neg ,expr) + (let ((info (expr->base expr info))) + (append-text info (append (wrap-as (i386:value->accu 0)) + (wrap-as (i386:sub-base)))))) - ((eq ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:z->accu)))) - ((ge ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:ge?->accu)))) - ((gt ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:g?->accu) (i386:accu-test)))) + ((eq ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:z->accu)))) + ((ge ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:ge?->accu)))) + ((gt ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:g?->accu) (i386:accu-test)))) - ;; FIXME: set accu *and* flags - ((ne ,a ,b) ((binop->accu info) a b (append (i386:push-accu) - (i386:sub-base) - (i386:nz->accu) - (i386:accu<->stack) - (i386:sub-base) - (i386:xor-zf) - (i386:pop-accu)))) + ;; FIXME: set accu *and* flags + ((ne ,a ,b) ((binop->accu info) a b (append (i386:push-accu) + (i386:sub-base) + (i386:nz->accu) + (i386:accu<->stack) + (i386:sub-base) + (i386:xor-zf) + (i386:pop-accu)))) - ((ne ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:xor-zf)))) - ((le ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:le?->accu)))) - ((lt ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:l?->accu)))) + ((ne ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:xor-zf)))) + ((le ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:le?->accu)))) + ((lt ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:l?->accu)))) - ((or ,a ,b) - (let* ((info (expr->accu a info)) - (here (number->string (length (.text info)))) - (skip-b-label (string-append "_" (.function info) "_" here "_or_skip_b")) - (info (append-text info (wrap-as (i386:accu-test)))) - (info (append-text info (wrap-as (i386:jump-nz skip-b-label)))) - (info (append-text info (wrap-as (i386:accu-test)))) - (info (expr->accu b info)) - (info (append-text info (wrap-as (i386:accu-test)))) - (info (append-text info (wrap-as `((#:label ,skip-b-label)))))) - info)) + ((or ,a ,b) + (let* ((info (expr->accu a info)) + (here (number->string (length (.text info)))) + (skip-b-label (string-append "_" (.function info) "_" here "_or_skip_b")) + (info (append-text info (wrap-as (i386:accu-test)))) + (info (append-text info (wrap-as (i386:jump-nz skip-b-label)))) + (info (append-text info (wrap-as (i386:accu-test)))) + (info (expr->accu b info)) + (info (append-text info (wrap-as (i386:accu-test)))) + (info (append-text info (wrap-as `((#:label ,skip-b-label)))))) + info)) - ((and ,a ,b) - (let* ((info (expr->accu a info)) - (here (number->string (length (.text info)))) - (skip-b-label (string-append "_" (.function info) "_" here "_and_skip_b")) - (info (append-text info (wrap-as (i386:accu-test)))) - (info (append-text info (wrap-as (i386:jump-z skip-b-label)))) - (info (append-text info (wrap-as (i386:accu-test)))) - (info (expr->accu b info)) - (info (append-text info (wrap-as (i386:accu-test)))) - (info (append-text info (wrap-as `((#:label ,skip-b-label)))))) - info)) + ((and ,a ,b) + (let* ((info (expr->accu a info)) + (here (number->string (length (.text info)))) + (skip-b-label (string-append "_" (.function info) "_" here "_and_skip_b")) + (info (append-text info (wrap-as (i386:accu-test)))) + (info (append-text info (wrap-as (i386:jump-z skip-b-label)))) + (info (append-text info (wrap-as (i386:accu-test)))) + (info (expr->accu b info)) + (info (append-text info (wrap-as (i386:accu-test)))) + (info (append-text info (wrap-as `((#:label ,skip-b-label)))))) + info)) - ((cast ,type ,expr) - (expr->accu expr info)) + ((cast ,type ,expr) + (expr->accu expr info)) - ((assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op ,op) ,b) - (let* ((info (expr->accu `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b) info)) - (type (ident->type info name)) - (rank (ident->rank info name)) - (size (if (> rank 1) 4 1))) - (append-text info ((ident-add info) name size)))) + ((assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op ,op) ,b) + (let* ((info (expr->accu `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b) info)) + (type (ident->type info name)) + (rank (ident->rank info name)) + (size (if (> rank 1) 4 1))) + (append-text info ((ident-add info) name size)))) - ((assn-expr (de-ref (post-dec (p-expr (ident ,name)))) (op ,op) ,b) - (let* ((info (expr->accu `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b) info)) - (type (ident->type info name)) - (rank (ident->rank info name)) - (size (if (> rank 1) 4 1))) - (append-text info ((ident-add info) name (- size))))) + ((assn-expr (de-ref (post-dec (p-expr (ident ,name)))) (op ,op) ,b) + (let* ((info (expr->accu `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b) info)) + (type (ident->type info name)) + (rank (ident->rank info name)) + (size (if (> rank 1) 4 1))) + (append-text info ((ident-add info) name (- size))))) - ((assn-expr ,a (op ,op) ,b) - (let* ((info (append-text info (ast->comment o))) - (type (ast->type a info)) - (rank (->rank type)) - (type-b (ast->type b info)) - (rank-b (->rank type-b)) - (size (->size type)) - (size-b (->size type-b)) - (info (expr->accu b info)) - (info (if (equal? op "=") info - (let* ((struct? (structured-type? type)) - (size (cond ((= rank 1) (ast-type->size info a)) - ((> rank 1) 4) - ((and struct? (= rank 2)) 4) - (else 1))) - (info (if (or (= size 1) (= rank-b 1)) info - (let ((info (append-text info (wrap-as (i386:value->base size))))) - (append-text info (wrap-as (i386:accu*base)))))) - (info (append-text info (wrap-as (i386:push-accu)))) - (info (expr->accu a info)) - (info (append-text info (wrap-as (i386:pop-base)))) - (info (append-text info (cond ((equal? op "+=") (wrap-as (i386:accu+base))) - ((equal? op "-=") (wrap-as (i386:accu-base))) - ((equal? op "*=") (wrap-as (i386:accu*base))) - ((equal? op "/=") (wrap-as (i386:accu/base))) - ((equal? op "%=") (wrap-as (i386:accu%base))) - ((equal? op "&=") (wrap-as (i386:accu-and-base))) - ((equal? op "|=") (wrap-as (i386:accu-or-base))) - ((equal? op "^=") (wrap-as (i386:accu-xor-base))) - ((equal? op ">>=") (wrap-as (i386:accu>>base))) - ((equal? op "<<=") (wrap-as (i386:accu<basic-type b info))))))))) - (when (and (equal? op "=") - (not (= size size-b)) - (not (and (or (= size 1) (= size 2)) - (= size-b 4))) - (not (and (= size 2) - (= size-b 4))) - (not (and (= size 4) - (or (= size-b 1) (= size-b 2))))) - (stderr "ERROR assign: ~a" (with-output-to-string (lambda () (pretty-print-c99 o)))) - (stderr " size[~a]:~a != size[~a]:~a\n" rank size rank-b size-b)) - (pmatch a - ((p-expr (ident ,name)) - (if (or (<= size 4) ;; FIXME: long long = int - (<= size-b 4)) (append-text info ((accu->ident info) name)) - (let ((info (expr->base* a info))) - (accu->base-mem*n info size)))) - (_ (let ((info (expr->base* a info))) - (accu->base-mem*n info (min size (max 4 size-b)))))))) ;; FIXME: long long = int + ((assn-expr ,a (op ,op) ,b) + (let* ((info (append-text info (ast->comment o))) + (type (ast->type a info)) + (rank (->rank type)) + (type-b (ast->type b info)) + (rank-b (->rank type-b)) + (size (->size type)) + (size-b (->size type-b)) + (info (expr->accu b info)) + (info (if (equal? op "=") info + (let* ((struct? (structured-type? type)) + (size (cond ((= rank 1) (ast-type->size info a)) + ((> rank 1) 4) + ((and struct? (= rank 2)) 4) + (else 1))) + (info (if (or (= size 1) (= rank-b 1)) info + (let ((info (append-text info (wrap-as (i386:value->base size))))) + (append-text info (wrap-as (i386:accu*base)))))) + (info (append-text info (wrap-as (i386:push-accu)))) + (info (expr->accu a info)) + (info (append-text info (wrap-as (i386:pop-base)))) + (info (append-text info (cond ((equal? op "+=") (wrap-as (i386:accu+base))) + ((equal? op "-=") (wrap-as (i386:accu-base))) + ((equal? op "*=") (wrap-as (i386:accu*base))) + ((equal? op "/=") (wrap-as (i386:accu/base))) + ((equal? op "%=") (wrap-as (i386:accu%base))) + ((equal? op "&=") (wrap-as (i386:accu-and-base))) + ((equal? op "|=") (wrap-as (i386:accu-or-base))) + ((equal? op "^=") (wrap-as (i386:accu-xor-base))) + ((equal? op ">>=") (wrap-as (i386:accu>>base))) + ((equal? op "<<=") (wrap-as (i386:accu<basic-type b info))))))))) + (when (and (equal? op "=") + (not (= size size-b)) + (not (and (or (= size 1) (= size 2)) + (= size-b 4))) + (not (and (= size 2) + (= size-b 4))) + (not (and (= size 4) + (or (= size-b 1) (= size-b 2))))) + (stderr "ERROR assign: ~a" (with-output-to-string (lambda () (pretty-print-c99 o)))) + (stderr " size[~a]:~a != size[~a]:~a\n" rank size rank-b size-b)) + (pmatch a + ((p-expr (ident ,name)) + (if (or (<= size 4) ;; FIXME: long long = int + (<= size-b 4)) (append-text info ((accu->ident info) name)) + (let ((info (expr->base* a info))) + (accu->base-mem*n info size)))) + (_ (let ((info (expr->base* a info))) + (accu->base-mem*n info (min size (max 4 size-b)))))))) ;; FIXME: long long = int - (_ (error "expr->accu: not supported: " o))))) + (_ (error "expr->accu: not supported: " o)))) + + (let ((info (helper))) + (if (null? (.post info)) info + (append-text (clone info #:post '()) (.post info)))))) (define (expr->base o info) (let* ((info (append-text info (wrap-as (i386:push-accu)))) diff --git a/module/language/c99/info.scm b/module/language/c99/info.scm index a0427610..000b364e 100644 --- a/module/language/c99/info.scm +++ b/module/language/c99/info.scm @@ -40,6 +40,7 @@ .function .statics .text + .post .break .continue @@ -114,7 +115,7 @@ (mes-use-module (mes optargs)))) (define-immutable-record-type - (make- types constants functions globals locals statics function text break continue) + (make- types constants functions globals locals statics function text post break continue) info? (types .types) (constants .constants) @@ -124,11 +125,12 @@ (statics .statics) (function .function) (text .text) + (post .post) (break .break) (continue .continue)) -(define* (make o #:key (types '()) (constants '()) (functions '()) (globals '()) (locals '()) (statics '()) (function #f) (text '()) (break '()) (continue '())) - (make- types constants functions globals locals statics function text break continue)) +(define* (make o #:key (types '()) (constants '()) (functions '()) (globals '()) (locals '()) (statics '()) (function #f) (text '()) (post '()) (break '()) (continue '())) + (make- types constants functions globals locals statics function text post break continue)) ;; ("int" . ,(make-type 'builtin 4 #f 0 #f)) ;; (make-type 'enum 4 0 fields) diff --git a/scaffold/tests/7o-struct-pre-post.c b/scaffold/tests/7o-struct-pre-post.c new file mode 100644 index 00000000..46f22e7d --- /dev/null +++ b/scaffold/tests/7o-struct-pre-post.c @@ -0,0 +1,39 @@ +/* -*-comment-start: "//";comment-end:""-*- + * Mes --- Maxwell Equations of Software + * Copyright © 2018 Jan (janneke) Nieuwenhuizen + * + * This file is part of Mes. + * + * Mes is free software; you can redistribute it and/or modify it + * under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 3 of the License, or (at + * your option) any later version. + * + * Mes is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with Mes. If not, see . + */ + +// struct foo {int length; char* string; struct foo *next;}; +// struct foo stack[] = {{20, "foo", 0}, {4, "baaz", 0}, {0, 0, 0}}; + +struct info {int flag;}; +struct foo {int length; char* string; struct info info;}; +struct foo stack[] = {{3, "foo", {11}},{4, "baar", {12}}}; + +int +main () +{ + puts (stack[0].string); puts ("\n"); + puts (stack[1].string); puts ("\n"); + struct foo* top = &stack[1]; + int i; + i = (top--)->info.flag; + top++; + int j = (--top)->info.flag; + return i - j - 1; +}