(statics (.statics o))
(function (.function o))
(text (.text o))
+ (post (.post o))
(break (.break o))
(continue (.continue o)))
(let-keywords rest
(statics statics)
(function function)
(text text)
+ (post post)
(break break)
(continue continue))
- (make <info> #:types types #:constants constants #:functions functions #:globals globals #:locals locals #:statics statics #:function function #:text text #:break break #:continue continue))))))
+ (make <info> #: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))
(info (expr->base array info)))
(append-text info (wrap-as (i386:accu+base)))))
- (_ (error "expr->accu*: not supported: " o))))
-
-(define (expr-add info)
- (lambda (o n)
- (let* ((info (expr->accu* o info))
- (info (append-text info (wrap-as (i386:accu-mem-add n)))))
- info)))
-
-(define (expr->accu o info)
- (let ((locals (.locals info))
- (constants (.constants info))
- (text (.text info))
- (globals (.globals info)))
- (pmatch o
- ((expr) info)
-
- ((comma-expr) info)
-
- ((comma-expr ,a . ,rest)
- (let ((info (expr->accu a info)))
- (expr->accu `(comma-expr ,@rest) info)))
+ ;;((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")))))
- ((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)))))
+ ((cast ,type ,expr)
+ (expr->accu expr info))
- ((neg (p-expr (fixed ,value)))
- (let ((value (- (cstring->number value))))
- (append-text info (wrap-as (i386:value->accu value)))))
+ ;; ((post-dec (p-expr (ident "vtop"))))
- ((p-expr (char ,char))
- (let ((char (char->integer (car (string->list char)))))
- (append-text info (wrap-as (i386:value->accu char)))))
+ ;; ((cast ,type ,expr)
+ ;; (expr->accu `(ref-to ,expr) info))
- ((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)))
-
- ((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))))))
-
- ;; &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))
-
- ((ref-to ,expr)
- (expr->accu* 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)))))
-
- ((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 '())))))))
-
- ((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 '()))))))
-
- ((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))))))
-
- ((cond-expr . ,cond-expr)
- (ast->info `(expr-stmt ,o) 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))
- ((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))
+ ((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 (append (expr->accu expr info)))
+ (let* ((info (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))
+ (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)))
- (info ((expr-add info) expr (- size)))
- (info (append-text info (wrap-as (i386:pop-accu)))))
- info))
+ (post ((expr-add post) expr (- size)))
+ (post (append-text post (wrap-as (i386:pop-accu)))))
+ (clone info #:post (.text post))))
- ((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))
-
-
-
- ((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)))))))
-
- ((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)
+ ((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)
- ((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)))))))
-
- ((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<<base)))
- ((rshift ,a ,b) ((binop->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))))
-
- ((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))))
-
- ;; 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))))
+ (post ((expr-add post) expr size))
+ (post (append-text post (wrap-as (i386:pop-accu)))))
+ (clone info #:post (.text post))))
- ((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))
+ (_ (error "expr->accu*: not supported: " o))))
- ((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))
+(define (expr-add info)
+ (lambda (o n)
+ (let* ((info (expr->accu* o info))
+ (info (append-text info (wrap-as (i386:accu-mem-add n)))))
+ 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-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<<base)))
- (else (error (format #f "mescc: op ~a not supported: ~a\n" op o)))))))
- (cond ((not (and (= rank 1) (= rank-b 1))) info)
- ((equal? op "-=") (append-text info (wrap-as (append (i386:value->base size)
- (i386:accu/base)))))
- (else (error (format #f "invalid operands to binary ~s (have ~s* and ~s*)" op type (ast->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)))))
+(define (expr->accu o info)
+ (let ((locals (.locals info))
+ (text (.text info))
+ (globals (.globals info)))
+ (define (helper)
+ (pmatch o
+ ((expr) info)
+
+ ((comma-expr) 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 (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 (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)))
+
+ ((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))))))
+
+ ;; &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))
+
+ ((ref-to ,expr)
+ (expr->accu* 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)))))
+
+ ((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 '())))))))
+
+ ((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 '()))))))
+
+ ((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))))))
+
+ ((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-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-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 ,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 ,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<<base)))
+ ((rshift ,a ,b) ((binop->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))))
+
+ ((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))))
+
+ ;; 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))))
+
+ ((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))
+
+ ((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-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<<base)))
+ (else (error (format #f "mescc: op ~a not supported: ~a\n" op o)))))))
+ (cond ((not (and (= rank 1) (= rank-b 1))) info)
+ ((equal? op "-=") (append-text info (wrap-as (append (i386:value->base size)
+ (i386:accu/base)))))
+ (else (error (format #f "invalid operands to binary ~s (have ~s* and ~s*)" op type (ast->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))))
+
+ (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))))