diff --git a/make.scm b/make.scm index c1b0699a..9d5323b2 100755 --- a/make.scm +++ b/make.scm @@ -244,7 +244,8 @@ exec ${GUILE-guile} --no-auto-compile -L . -L guile -C . -C guile -s "$0" ${1+"$ "7i-struct-struct" "7j-strtoull" "7k-for-each-elem" - "7l-struct-any-size-array")) + "7l-struct-any-size-array" + "7m-struct-char-array-assign")) (add-target (group "check-scaffold-tests/7" #:dependencies (filter (target-prefix? "check-scaffold/tests/7") %targets))) diff --git a/module/language/c99/compiler.mes b/module/language/c99/compiler.mes index c243a85d..64c9e6b6 100644 --- a/module/language/c99/compiler.mes +++ b/module/language/c99/compiler.mes @@ -48,6 +48,16 @@ (define (stderr string . rest) (apply logf (cons* (current-error-port) string rest))) +(define (pke . stuff) + (newline (current-error-port)) + (display ";;; " (current-error-port)) + (write stuff (current-error-port)) + (newline (current-error-port)) + (car (last-pair stuff))) + +(define (pke . stuff) + (car (last-pair stuff))) + (define %prefix (if (string-prefix? "@PREFIX" "@PREFIX@") (or (getenv "PREFIX") "") "@PREFIX@")) (define mes? (pair? (current-module))) @@ -149,1282 +159,6 @@ (continue continue)) (make #:types types #:constants constants #:functions functions #:globals globals #:locals locals #:function function #:text text #:break break #:continue continue)))))) -(define (append-text info text) - (clone info #:text (append (.text info) text))) - -(define (push-global info) - (lambda (o) - (let ((ptr (ident->pointer info o))) - (case ptr - ((-2) (list (i386:push-label `(#:address ,o)))) - ((-1) (list (i386:push-label `(#:address ,o)))) - (else (list (i386:push-label-mem `(#:address ,o)))))))) - -(define (push-local locals) - (lambda (o) - (wrap-as (i386:push-local (local:id o))))) - -(define (push-global-address info) - (lambda (o) - (list (i386:push-label o)))) - -(define (push-local-address locals) - (lambda (o) - (wrap-as (i386:push-local-address (local:id o))))) - -(define push-global-de-ref push-global) - -(define (push-local-de-ref info) - (lambda (o) - (let* ((local o) - (ptr (local:pointer local)) - (size (if (= ptr 1) (ast-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) (ast-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 (make-global-entry key type pointer value) - (cons key (make-global type pointer value))) - -(define (string->global-entry string) - (make-global-entry `(#:string ,string) "string" 0 (append (string->list string) (list #\nul)))) - -(define (int->global-entry value) - (make-global-entry (number->string value) "int" 0 (int->bv32 value))) - -(define (ident->global-entry name type pointer value) - (make-global-entry name type pointer (if (pair? value) value (int->bv32 value)))) - -(define (make-local-entry name type pointer id) - (cons name (make-local type pointer id))) - -(define (push-ident info) - (lambda (o) - (let ((local (assoc-ref (.locals info) o))) - (if local - (begin - (let* ((ptr (local:pointer local)) - (size (if (= ptr 1) (ast-type->size info (local:type local)) - 4))) - (if (= ptr -1) ((push-local-address (.locals info)) local) - ((push-local (.locals info)) local)))) - (let ((global (assoc-ref (.globals info) o))) - (if global - ((push-global info) o) ;; FIXME: char*/int - (let ((constant (assoc-ref (.constants info) o))) - (if constant - (wrap-as (append (i386:value->accu constant) - (i386:push-accu))) - ((push-global-address #f) `(#:address ,o)))))))))) - -(define (push-ident-address info) - (lambda (o) - (let ((local (assoc-ref (.locals info) o))) - (if local ((push-local-address (.locals info)) local) - (let ((global (assoc-ref (.globals info) o))) - (if global - ((push-global-address info) o) - ((push-global-address #f) `(#:address ,o)))))))) - -(define (push-ident-de-ref info) - (lambda (o) - (let ((local (assoc-ref (.locals info) o))) - (if local ((push-local-de-ref info) local) - ((push-global-de-ref 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))) - (append-text info (wrap-as (i386:push-accu)))))) - -(define (globals:add-string globals) - (lambda (o) - (let ((string `(#:string ,o))) - (if (assoc-ref globals string) globals - (append globals (list (string->global-entry o))))))) - -(define (expr->arg info) ;; FIXME: get Mes curried-definitions - (lambda (o) - (let ((text (.text info))) - (pmatch o - - ((p-expr (string ,string)) - (let* ((globals ((globals:add-string (.globals info)) string)) - (info (clone info #:globals globals))) - (append-text info ((push-global-address info) `(#:string ,string))))) - - ((p-expr (ident ,name)) - (append-text info ((push-ident info) name))) - - ((cast (type-name (decl-spec-list (type-spec (fixed-type _))) - (abs-declr (pointer))) - ,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))) - - (_ (append-text ((expr->accu info) o) - (wrap-as (i386:push-accu)))))))) - -;; FIXME: see ident->base -(define (ident->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 0) (ast-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)))) - (else - (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)) - (type (ident->type info o)) - (size (if (= ptr 1) (ast-type->size info type) - 4))) - (case ptr - ((-2) (list (i386:label->accu `(#:address ,o)))) - ((-1) (list (i386:label->accu `(#:address ,o)))) - (else (list (i386:label-mem->accu `(#:address ,o)))))) - (if constant (wrap-as (i386:value->accu constant)) - (list (i386:label->accu `(#:address ,o))))))))) - -(define (ident->base info) - (lambda (o) - (let ((local (assoc-ref (.locals info) o))) - (if local - (let* ((ptr (local:pointer local)) - (type (ident->type info o)) - (size (if (and type (= ptr 1)) (ast-type->size info type) - 4))) - (case ptr - ((-1) (wrap-as (i386:local-ptr->base (local:id local)))) - ((0) (wrap-as (if (= size 1) (i386:byte-local->base (local:id local)) - (i386:local->base (local:id local))))) - ;; WTF? - (else (wrap-as (i386:local->base (local:id local)))))) - (let ((global (assoc-ref (.globals info) o) )) - (if global - (let ((ptr (ident->pointer info o))) - (case ptr - ((-2) (list (i386:label->base `(#:address ,o)))) - ((-1) (list (i386:label->base `(#:address ,o)))) - (else (list (i386:label-mem->base `(#:address ,o)))))) - (let ((constant (assoc-ref (.constants info) o))) - (if constant (wrap-as (i386:value->base constant)) - (list (i386:label->base `(#:address ,o))))))))))) - -(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) (ast-type->size info type) - 4))) - (wrap-as (i386:local-ptr->accu (local:id local)))) - (if global (list (i386:label->accu `(#:address ,o))) - (list (i386:label->accu `(#:address ,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) (ast-type->size info type) - 4))) - (wrap-as (i386:local-ptr->base (local:id local)))) - (if global (list (i386:label->base `(#:address ,o))) - (list (i386:label->base `(#:address ,o)))))))) - -(define (value->accu v) - (wrap-as (i386:value->accu v))) - -(define (accu->ident info) - (lambda (o) - (let* ((local (assoc-ref (.locals info) o)) - (ptr (ident->pointer info o)) - (size (if (= ptr -1) (ident->size info o) - 4))) - (if local (if (<= size 4) (wrap-as (i386:accu->local (local:id local))) - (wrap-as (i386:accu*n->local (local:id local) size))) - (if (<= size 4) (wrap-as (i386:accu->label o)) - (wrap-as (i386:accu*n->label o size))))))) - -(define (base->ident-address info) - (lambda (o) - (let ((local (assoc-ref (.locals info) o))) - (if local - (let* ((ptr (local:pointer local)) - (type (ident->type info o)) - (size (if (= ptr 1) (ast-type->size info type) - 4))) - - (wrap-as (append (i386:local->accu (local:id local)) - (if (= size 1) (i386:byte-base->accu-mem) - (i386:base->accu-mem))))) - (let ((ptr (ident->pointer info o)) - (size 4)) ;; FIXME size - (case ptr - ((-2) (wrap-as (append (i386:label->accu `(#:address ,o)) - (if (= size 1) (i386:byte-base->accu-mem) - (i386:base->accu-mem))))) - ((-1) (wrap-as (append (i386:label->accu `(#:address ,o)) - (if (= size 1) (i386:byte-base->accu-mem) - (i386:base->accu-mem))))) - (else (wrap-as (append (i386:label-mem->accu `(#:address ,o)) - (if (= size 1) (i386:byte-base->accu-mem) - (i386:base->accu-mem))))))))))) - -(define (value->ident info) - (lambda (o value) - (let ((local (assoc-ref (.locals info) o))) - (if local (wrap-as (i386:value->local (local:id local) value)) - (list (i386:value->label `(#:address ,o) value)))))) - -(define (ident-add info) - (lambda (o n) - (let ((local (assoc-ref (.locals info) o))) - (if local (wrap-as (i386:local-add (local:id local) n)) - (list (i386:label-mem-add `(#:address ,o) n)))))) - -(define (expr-add info) - (lambda (o n) - (let* ((info ((expr->accu* info) o)) - (info (append-text info (wrap-as (i386:accu-mem-add n))))) - info))) - -(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 (wrap-as (append (i386:push-accu) - (i386:label->accu `(#:address ,o)) - (i386:accu-mem-add n) - (i386:pop-accu)))))))) - -(define (expr->accu info) - (lambda (o) - (let ((locals (.locals info)) - (constants (.constants info)) - (text (.text info)) - (globals (.globals info))) - (define (add-local locals name type pointer) - (let* ((id (if (or (null? locals) (not (local-var? (cdar locals)))) 1 - (1+ (local:id (cdar locals))))) - (locals (cons (make-local-entry name type pointer id) locals))) - locals)) - (pmatch o - ((expr) info) - - ((comma-expr) info) - - ((comma-expr ,a . ,rest) - (let ((info ((expr->accu info) a))) - ((expr->accu info) `(comma-expr ,@rest)))) - - ((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)))))) - - ;;; FIXME: FROM INFO ...only zero?! - ((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 info) initzer)) - - ;; offsetoff - ((ref-to (i-sel (ident ,field) (cast (type-name (decl-spec-list ,struct) (abs-declr (pointer))) (p-expr (fixed ,base))))) - (let* ((type (decl->ast-type struct)) - (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 info) expr)) - - ((ref-to ,expr) - ((expr->accu* info) expr)) - - ((sizeof-expr (p-expr (ident ,name))) - (let* ((type (ident->type info name)) - (size (ast-type->size info type))) - (append-text info (wrap-as (i386:value->accu size))))) - - ((sizeof-expr (p-expr (string ,string))) - (append-text info (wrap-as (i386:value->accu (1+ (string-length string)))))) - - ((sizeof-expr (i-sel (ident ,field) (p-expr (ident ,struct)))) - (let* ((type (ident->type info struct)) - (size (field-size info type field))) - (append-text info (wrap-as (i386:value->accu size))))) - - ((sizeof-expr (d-sel (ident ,field) (p-expr (ident ,struct)))) - (let* ((type (ident->type info struct)) - (size (field-size info type field))) - (append-text info (wrap-as (i386:value->accu size))))) - - ((sizeof-type (type-name (decl-spec-list (type-spec (fixed-type ,name))))) - (let* ((type name) - (size (ast-type->size info type))) - (append-text info (wrap-as (i386:value->accu size))))) - - ((sizeof-type (type-name (decl-spec-list (type-spec (struct-ref (ident (,type))))))) - (let* ((type `("tag" ,type)) - (size (ast-type->size info type))) - (append-text info (wrap-as (i386:value->accu size))))) - - ((sizeof-type (type-name (decl-spec-list (type-spec (struct-ref (ident ,type)))))) - (let* ((type `("tag" ,type)) - (size (ast-type->size info type))) - (append-text info (wrap-as (i386:value->accu size))))) - - ((sizeof-type (type-name (decl-spec-list (type-spec (typename ,type))))) - (let ((size (ast-type->size info type))) - (append-text info (wrap-as (i386:value->accu size))))) - - ((sizeof-type (type-name (decl-spec-list ,type) (abs-declr (pointer)))) - (let ((size 4)) - (append-text info (wrap-as (i386:value->accu size))))) - - ;; foo[bar] - ((array-ref ,index (p-expr (ident ,array))) - (let* ((info ((expr->accu* info) o)) - (type (ident->type info array)) - (ptr (ident->pointer info array)) - (size (if (or (= ptr 1) (= ptr -1)) (ast-type->size info type) - 4))) - (append-text info (wrap-as (case size - ((1) (i386:byte-mem->accu)) - ((2) (i386:word-mem->accu)) - ((4) (i386:mem->accu)) - (else '())))))) - - ;; foo.bar[baz]) - ((array-ref ,index (d-sel (ident ,field0) (p-expr (ident ,struct0)))) - (let* ((info ((expr->accu* info) o)) - (type0 (ident->type info struct0)) - (type1 (field-type info type0 field0)) - (ptr (field-pointer info type0 field0)) - (size (if (or (= ptr -1) (= ptr 1)) (ast-type->size info type1) - 4))) - (append-text info (wrap-as (case size - ((1) (i386:byte-mem->accu)) - ((2) (i386:word-mem->accu)) - (else (i386:mem->accu))))))) - - ;; foo->bar[baz]) - ((array-ref ,index (i-sel (ident ,field0) (p-expr (ident ,struct0)))) - (let* ((info ((expr->accu* info) o)) - (type0 (ident->type info struct0)) - (type1 (field-type info type0 field0)) - (ptr (field-pointer info type0 field0)) - (size (if (or (= ptr -1) (= ptr 1)) (ast-type->size info type1) - 4))) - (append-text info (wrap-as (case size - ((1) (i386:byte-mem->accu)) - ((2) (i386:word-mem->accu)) - (else (i386:mem->accu))))))) - - ;; [baz] - ((array-ref ,index ,array) - (let* ((info ((expr->accu* info) o)) - (ptr (expr->pointer info array)) - (size (if (= ptr 1) (expr->size info array) - 4))) - (append-text info (wrap-as (case size - ((1) (i386:byte-mem->accu)) - ((2) (i386:word-mem->accu)) - (else (i386:mem->accu))))))) - - ;; bar.f.i - ((d-sel (ident ,field1) (d-sel (ident ,field0) (p-expr (ident ,struct0)))) - (let ((info ((expr->accu* info) o))) - (append-text info (wrap-as (i386:mem->accu))))) - - ;; bar.poo->i - ((i-sel (ident ,field1) (d-sel (ident ,field0) (p-expr (ident ,struct0)))) - (let ((info ((expr->accu* info) o))) - (append-text info (wrap-as (i386:mem->accu))))) - - ;; bar->foo.i - ((d-sel (ident ,field1) (i-sel (ident ,field0) (p-expr (ident ,struct0)))) - (let ((info ((expr->accu* info) o))) - (append-text info (wrap-as (i386:mem->accu))))) - - ;;(i-sel (ident "i") (i-sel (ident "p") (p-expr (ident "p")))) - ((i-sel (ident ,field1) (i-sel (ident ,field0) (p-expr (ident ,struct0)))) - (let ((info ((expr->accu* info) o))) - (append-text info (wrap-as (i386:mem->accu))))) - - ;; (*pp)->bar.foo - ((d-sel (ident ,field1) (i-sel (ident ,field0) (de-ref (p-expr (ident ,struct0))))) - (let ((info ((expr->accu* info) o))) - (append-text info (wrap-as (i386:mem->accu))))) - - ;; foo.bar - ((d-sel (ident ,field) (p-expr (ident ,struct))) - (let* ((type (ident->type info struct)) - (offset (field-offset info type field)) - (ptr (field-pointer info type field)) - (size (if (= ptr 0) (field-size info type field) - 4))) - (if (= ptr -1) - (append-text info (append ((ident->accu info) struct) - (wrap-as (i386:accu+value offset)))) - (append-text info (append ((ident->accu info) struct) - (case size - ((1) (wrap-as (i386:byte-mem+n->accu offset))) - ((2) (wrap-as (i386:word-mem+n->accu offset))) - (else (wrap-as (i386:mem+n->accu offset))))))))) - - ((i-sel (ident ,field) (p-expr (ident ,struct))) - (let* ((type (ident->type info struct)) - (offset (field-offset info type field)) - (ptr (field-pointer info type field)) - (size (if (= ptr 0) (field-size info type field) - 4))) - (if (= ptr -1) - (append-text info (append ((ident-address->accu info) struct) - (wrap-as (i386:mem->accu)) - (wrap-as (i386:accu+value offset)))) - (append-text info (append ((ident-address->accu info) struct) - (wrap-as (i386:mem->accu)) - (case size - ((1) (wrap-as (i386:byte-mem+n->accu offset))) - ((2) (wrap-as (i386:word-mem+n->accu offset))) - (else (wrap-as (i386:mem+n->accu offset))))))))) - - ((d-sel (ident ,field) (array-ref ,index (p-expr (ident ,array)))) - (let* ((type (ident->type info array)) - (offset (field-offset info type field)) - (info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array)))))) - (append-text info (wrap-as (i386:mem+n->accu offset))))) - - ((i-sel (ident ,field) (de-ref (p-expr (ident ,array)))) - (let* ((type (ident->type info array)) - (offset (field-offset info type field))) - (append-text info (append ((ident-address->accu info) array) - (wrap-as (i386:mem->accu)) - (wrap-as (i386:mem->accu)) - (wrap-as (i386:mem+n->accu offset)))))) - - ;; foo[i].bar.baz - ((d-sel (ident ,field1) (d-sel (ident ,field0) (array-ref ,index (p-expr (ident ,array))))) - (let ((info ((expr->accu* info) o))) - (append-text info (wrap-as (i386:mem->accu))))) - - ;;foo[index]->bar - ((i-sel (ident ,field) (array-ref ,index ,array)) - (let* ((info ((expr->accu* info) o)) - (type (p-expr->type info array)) - (ptr (field-pointer info type field))) - (if (< ptr 0) info - (append-text info (wrap-as (i386:mem->accu)))))) - - ((de-ref (p-expr (ident ,name))) - (let* ((type (ident->type info name)) - (ptr (ident->pointer info name)) - (size (if (= ptr 1) (ast-type->size info type) - 4))) - (append-text info (append ((ident->accu info) name) - (wrap-as (case size - ((1) (i386:byte-mem->accu)) - ((2) (i386:word-mem->accu)) - (else (i386:mem->accu)))))))) - ((de-ref ,expr) - (let* ((info ((expr->accu info) expr)) - (ptr (expr->pointer info expr)) - (size (if (= ptr 1) (expr->size info expr) - 4))) - (append-text info (wrap-as (case size - ((1) (i386:byte-mem->accu)) - ((2) (i386:word-mem->accu)) - (else (i386:mem->accu))))))) - ((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 empty) `(p-expr (ident ,name))))) - (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 empty) function))) - (append-text args-info (append (.text accu) - (list (i386:call-accu n)))))) - - ((cond-expr . ,cond-expr) - ((ast->info info) `(expr-stmt ,o))) - - ((post-inc ,expr) - (let* ((info (append ((expr->accu info) expr))) - (info (append-text info (wrap-as (i386:push-accu)))) - (ptr (expr->pointer info expr)) - (size (cond ((= ptr 1) (expr->size info expr)) - ((> ptr 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 info) expr))) - (info (append-text info (wrap-as (i386:push-accu)))) - (ptr (expr->pointer info expr)) - (size (cond ((= ptr 1) (expr->size info expr)) - ((> ptr 1) 4) - (else 1))) - (info ((expr-add info) expr (- size))) - (info (append-text info (wrap-as (i386:pop-accu))))) - info)) - - ((pre-inc ,expr) - (let* ((ptr (expr->pointer info expr)) - (size (cond ((= ptr 1) (expr->size info expr)) - ((> ptr 1) 4) - (else 1))) - (info ((expr-add info) expr size)) - (info (append ((expr->accu info) expr)))) - info)) - - ((pre-dec ,expr) - (let* ((ptr (expr->pointer info expr)) - (size (cond ((= ptr 1) (expr->size info expr)) - ((> ptr 1) 4) - (else 1))) - (info ((expr-add info) expr (- size))) - (info (append ((expr->accu info) expr)))) - info)) - - ((add ,a (p-expr (fixed ,value))) - (let* ((ptr (expr->pointer info a)) - (type0 (p-expr->type info a)) - (struct? (memq (type:type (ast-type->type info type0)) '(struct union))) - (size (cond ((= ptr 1) (expr->size info a)) - ((> ptr 1) 4) - ((and struct? (= ptr -2)) 4) - ((and struct? (= ptr 2)) 4) - (else 1))) - (info ((expr->accu info) a)) - (value (cstring->number value)) - (value (* size value))) - (append-text info (wrap-as (i386:accu+value value))))) - - ((add ,a ,b) - (let* ((ptr (expr->pointer info a)) - (ptr-b (expr->pointer info b)) - (type0 (p-expr->type info a)) - (struct? (memq (type:type (ast-type->type info type0)) '(struct union))) - (size (cond ((= ptr 1) (expr->size info a)) - ((> ptr 1) 4) - ((and struct? (= ptr -2)) 4) - ((and struct? (= ptr 2)) 4) - (else 1)))) - (if (or (= size 1)) ((binop->accu info) a b (i386:accu+base)) - (let* ((info ((expr->accu info) b)) - (info (append-text info (wrap-as (append (i386:value->base size) - (i386:accu*base) - (i386:accu->base))))) - (info ((expr->accu info) a))) - (append-text info (wrap-as (i386:accu+base))))))) - - ((sub ,a (p-expr (fixed ,value))) - (let* ((ptr (expr->pointer info a)) - (type0 (p-expr->type info a)) - (struct? (memq (type:type (ast-type->type info type0)) '(struct union))) - (size (cond ((= ptr 1) (expr->size info a)) - ((> ptr 1) 4) - ((and struct? (= ptr -2)) 4) - ((and struct? (= ptr 2)) 4) - (else 1))) - (info ((expr->accu info) a)) - (value (cstring->number value)) - (value (* size value))) - (append-text info (wrap-as (i386:accu+value (- value)))))) - - ((sub ,a ,b) - (let* ((ptr (expr->pointer info a)) - (ptr-b (expr->pointer info b)) - (type0 (p-expr->type info a)) - (struct? (memq (type:type (ast-type->type info type0)) '(struct union))) - (size (cond ((= ptr 1) (expr->size info a)) - ((> ptr 1) 4) - ((and struct? (= ptr -2)) 4) - ((and struct? (= ptr 2)) 4) - (else 1)))) - (if (or (= size 1) (= ptr-b 1)) (let ((info ((binop->accu info) a b (i386:accu-base)))) - (if (not (= ptr-b 1)) info - (append-text info (wrap-as (append (i386:value->base size) - (i386:accu/base)))))) - (let* ((info ((expr->accu info) b)) - (info (append-text info (wrap-as (append (i386:value->base size) - (i386:accu*base) - (i386:accu->base))))) - (info ((expr->accu info) a))) - (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 info) expr))) - (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 info) expr))) - (clone info #:text - (append (.text test-info) - (wrap-as (i386:accu-negate))) - #:globals (.globals test-info)))) - - ((neg ,expr) - (let ((info ((expr->base info) expr))) - (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 info) a)) - (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 info) b)) - (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 info) a)) - (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 info) b)) - (info (append-text info (wrap-as (i386:accu-test)))) - (info (append-text info (wrap-as `((#:label ,skip-b-label)))))) - info)) - - ((cast ,cast ,o) - ((expr->accu info) o)) - - ((assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op ,op) ,b) - (let* ((info ((expr->accu info) `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b))) - (type (ident->type info name)) - (ptr (ident->pointer info name)) - (size (if (> ptr 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 info) `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b))) - (type (ident->type info name)) - (ptr (ident->pointer info name)) - (size (if (> ptr 1) 4 1))) - (append-text info ((ident-add info) name (- size))))) - - ;; type = *type; - ((assn-expr (p-expr (ident ,a)) (op ,op) (de-ref (p-expr (ident ,b)))) - (guard (and (equal? op "=") - (= 1 (expr->pointer info `(p-expr (ident ,b)))) - (let* ((type (ast-type->type info `(p-expr (ident ,a)))) - (struct? (memq (type:type type) '(struct union)))) - struct?))) - (let* ((info (append-text info (ast->comment o))) - (info ((expr->accu info) `(p-expr (ident ,b)))) - (info ((expr->base* info) `(p-expr (ident ,a)))) - (type (ast-type->type info `(p-expr (ident ,a)))) - (struct? (memq (type:type type) '(struct union))) - (ptr (expr->pointer info `(p-expr (ident ,a)))) - (size (if (and struct? (or (= ptr 0) (= ptr -1))) (type:size type) - 4))) - (accu-mem->base-mem*n info size))) - - ;; *type = *type; - ((assn-expr (de-ref (p-expr (ident ,a))) (op ,op) (de-ref (p-expr (ident ,b)))) - (guard (and (equal? op "=") - (= 1 (expr->pointer info `(p-expr (ident ,a)))) - (= 1 (expr->pointer info `(p-expr (ident ,b)))) - (let* ((type (ast-type->type info `(p-expr (ident ,a)))) - (struct? (memq (type:type type) '(struct union)))) - struct?))) - (let* ((info (append-text info (ast->comment o))) - (info ((expr->accu info) `(p-expr (ident ,b)))) - (info ((expr->base info) `(p-expr (ident ,a)))) - (type (ast-type->type info `(p-expr (ident ,a)))) - (struct? (memq (type:type type) '(struct union))) - (ptr (expr->pointer info `(p-expr (ident ,a)))) - (size (if (and struct? (or (= ptr 1) (= ptr -1))) (type:size type) - 4))) - (accu-mem->base-mem*n info size))) - - ;; s->tokc = tokc; - ((assn-expr (i-sel (ident ,field) (p-expr (ident ,a))) (op ,op) (p-expr (ident ,b))) - (guard (and (equal? op "=") - (or (= 0 (expr->pointer info `(p-expr (ident ,b)))) - (= -1 (expr->pointer info `(p-expr (ident ,b))))) - (let* ((type (ast-type->type info `(p-expr (ident ,b)))) - (struct? (memq (type:type type) '(struct union)))) - struct?))) - (let* ((info ((expr->accu* info) `(p-expr (ident ,b)))) - (info ((expr->base* info) `(i-sel (ident ,field) (p-expr (ident ,a))))) - (type (p-expr->type info `(p-expr (ident ,a)))) - (ptr (field-pointer info type field)) - (type (ast-type->type info `(p-expr (ident ,b)))) - (struct? (memq (type:type type) '(struct union))) - (type1 (p-expr->type info `(i-sel (ident ,field) (p-expr (ident ,a))))) - (size (if (and struct? (or (= ptr 0) (= ptr -1))) (ast-type->size info type1) - 4))) - (accu-mem->base-mem*n info size))) - - ;; vtop->type = *type; - ((assn-expr (i-sel (ident ,field) (p-expr (ident ,a))) (op ,op) (de-ref (p-expr (ident ,b)))) - (guard (and (equal? op "=") - (= 1 (expr->pointer info `(p-expr (ident ,b)))) - (let* ((type (ast-type->type info `(p-expr (ident ,b)))) - (struct? (memq (type:type type) '(struct union)))) - struct?))) - (let* ((info ((expr->accu info) `(p-expr (ident ,b)))) - (info ((expr->base* info) `(i-sel (ident ,field) (p-expr (ident ,a))))) - (type (p-expr->type info `(p-expr (ident ,a)))) - (ptr (field-pointer info type field)) - (type (ast-type->type info `(p-expr (ident ,b)))) - (struct? (memq (type:type type) '(struct union))) - (type1 (p-expr->type info `(i-sel (ident ,field) (p-expr (ident ,a))))) - (size (if (and struct? (= ptr 0)) (ast-type->size info type1) - 4))) - (accu-mem->base-mem*n info size))) - - ;; type[0] = type[1] - ((assn-expr (array-ref ,index-a (p-expr (ident ,a))) (op ,op) (array-ref ,index-b (p-expr (ident ,b)))) - (guard (and (equal? op "=") - (= 1 (abs (expr->pointer info `(p-expr (ident ,a))))) - (let* ((type (ast-type->type info `(p-expr (ident ,a)))) - (struct? (memq (type:type type) '(struct union)))) - struct?))) - (let* ((info (append-text info (ast->comment o))) - (info ((expr->accu* info) `(array-ref ,index-b (p-expr (ident ,b))))) - (info ((expr->base* info) `(array-ref ,index-a (p-expr (ident ,a))))) - (type (ast-type->type info `(p-expr (ident ,a)))) - (struct? (memq (type:type type) '(struct union))) - (ptr (expr->pointer info `(p-expr (ident ,a)))) - (size (if (and struct? (or (= ptr 1) (= ptr -1))) (type:size type) - 4))) - (accu-mem->base-mem*n info size))) - - ;; type[0] = type - ((assn-expr (array-ref ,index-a (p-expr (ident ,a))) (op ,op) (p-expr (ident ,b))) - (guard (and (equal? op "=") - (= 1 (abs (expr->pointer info `(p-expr (ident ,a))))) - (let* ((type (ast-type->type info `(p-expr (ident ,a)))) - (struct? (memq (type:type type) '(struct union)))) - struct?))) - (let* ((info (append-text info (ast->comment o))) - (info ((expr->accu* info) `(p-expr (ident ,b)))) - (info ((expr->base* info) `(array-ref ,index-a (p-expr (ident ,a))))) - (type (ast-type->type info `(p-expr (ident ,a)))) - (struct? (memq (type:type type) '(struct union))) - (ptr (expr->pointer info `(p-expr (ident ,a)))) - (size (if (and struct? (or (= ptr 1) (= ptr -1))) (type:size type) - 4))) - (accu-mem->base-mem*n info size))) - - ((assn-expr ,a (op ,op) ,b) - (let* ((info (append-text info (ast->comment o))) - (info ((expr->accu info) b)) - (info (if (equal? op "=") info - (let* ((ptr (expr->pointer info a)) - (ptr-b (expr->pointer info b)) - (type0 (p-expr->type info a)) - (struct? (memq (type:type (ast-type->type info type0)) '(struct union))) - (size (cond ((= ptr 1) (expr->size info a)) - ((> ptr 1) 4) - ((and struct? (= ptr -2)) 4) - ((and struct? (= ptr 2)) 4) - (else 1))) - (info (if (or (= size 1) (= ptr-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 info) a)) - (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<type info b))))))))) - (pmatch a - ((p-expr (ident ,name)) - (append-text info ((accu->ident info) name))) - ((d-sel (ident ,field) ,expr) - (let* ((info ((expr->base* info) a)) - (type (p-expr->type info expr)) - (ptr (field-pointer info type field)) - (type1 (field-type info type field)) - (size (if (= ptr 0) (ast-type->size info type1) - 4))) - (append-text info (case size - ((1) (wrap-as (i386:byte-accu->base-mem))) - ((2) (wrap-as (i386:word-accu->base-mem))) - (else (wrap-as (i386:accu->base-mem))))))) - ((i-sel (ident ,field) ,expr) - (let* ((info ((expr->base* info) a)) - (type (p-expr->type info expr)) - (ptr (field-pointer info type field)) - (type1 (field-type info type field)) - (size (if (= ptr 0) (ast-type->size info type1) - 4))) - (append-text info (case size - ((1) (wrap-as (i386:byte-accu->base-mem))) - ((2) (wrap-as (i386:word-accu->base-mem))) - (else (wrap-as (i386:accu->base-mem))))))) - ((Xde-ref ,expr) - (let* ((info ((expr->base info) expr)) - (ptr (expr->pointer info expr)) - (size (if (= ptr 1) (expr->size info expr) - 4))) - (append-text info (case size - ((1) (wrap-as (i386:byte-accu->base-mem))) - ((2) (wrap-as (i386:word-accu->base-mem))) - (else (wrap-as (i386:accu->base-mem))))))) - ((de-ref ,expr) - (let* ((info ((expr->base info) expr)) - (ptr (expr->pointer info expr)) - (size (if (= ptr 1) (expr->size info expr) - 4))) - (accu->base-mem*n info size))) - ((array-ref ,index (d-sel (ident ,field) (p-expr (ident ,struct)))) - (let* ((info ((expr->base* info) a)) - (type (ident->type info struct)) - (offset (field-offset info type field)) - (ptr (field-pointer info type field)) - (type1 (field-type info type field)) - (size (if (or (= ptr -1) (= ptr 1)) (ast-type->size info type1) - 4))) - (append-text info (case size - ((1) (wrap-as (i386:byte-accu->base-mem))) - ((2) (wrap-as (i386:word-accu->base-mem))) - (else (wrap-as (i386:accu->base-mem))))))) - ((array-ref ,index (i-sel (ident ,field) (p-expr (ident ,struct)))) - (let* ((info ((expr->base* info) a)) - (type (ident->type info struct)) - (offset (field-offset info type field)) - (ptr (field-pointer info type field)) - (type1 (field-type info type field)) - (size (if (or (= ptr -1) (= ptr 1)) (ast-type->size info type1) - 4))) - (append-text info (case size - ((1) (wrap-as (i386:byte-accu->base-mem))) - ((2) (wrap-as (i386:word-accu->base-mem))) - (else (wrap-as (i386:accu->base-mem))))))) - ((array-ref ,index (p-expr (ident ,array))) - (let* ((type (ident->type info array)) - (ptr (ident->pointer info array)) - (size (if (or (= ptr -1) (= ptr 1)) (ast-type->size info type) - 4)) - (info ((expr->base* info) a))) - ;;(accu->base-mem*n info size) - (append-text info - (append (case size - ((1) (wrap-as (i386:byte-accu->base-mem))) - ((2) (wrap-as (i386:word-accu->base-mem))) - (else (if (<= size 4) (wrap-as (i386:accu->base-mem)) - (append - (wrap-as (i386:accu-mem->base-mem)) - (wrap-as (append (i386:accu+value 4) - (i386:base+value 4) - (i386:accu-mem->base-mem))) - (if (<= size 8) '() - (wrap-as (append (i386:accu+value 4) - (i386:base+value 4) - (i386:accu-mem->base-mem)))))))))))) - (_ (error "expr->accu: unsupported assign: " a))))) - - (_ (error "expr->accu: unsupported: " o)))))) - -(define (expr->base info) - (lambda (o) - (let* ((info (append-text info (wrap-as (i386:push-accu)))) - (info ((expr->accu info) o)) - (info (append-text info (wrap-as (append (i386:accu->base) (i386:pop-accu)))))) - info))) - -(define (expr->base* info) - (lambda (o) - (let* ((info (append-text info (wrap-as (i386:push-accu)))) - (info ((expr->accu* info) o)) - (info (append-text info (wrap-as (i386:accu->base)))) - (info (append-text info (wrap-as (i386:pop-accu))))) - info))) - -(define (binop->accu info) - (lambda (a b c) - (let* ((info ((expr->accu info) a)) - (info ((expr->base info) b))) - (append-text info (wrap-as c))))) - -(define (wrap-as o . annotation) - `(,@annotation ,o)) - -(define (make-comment o) - (wrap-as `((#:comment ,o)))) - -(define (ast->comment o) - (let ((source (with-output-to-string (lambda () (pretty-print-c99 o))))) - (make-comment (string-join (string-split source #\newline) " ")))) - -(define (accu*n info n) - (append-text info (wrap-as (case n - ((1) (i386:accu->base)) - ((2) (i386:accu+accu)) - ((3) (append (i386:accu->base) - (i386:accu+accu) - (i386:accu+base))) - ((4) (i386:accu-shl 2)) - ((8) (append (i386:accu+accu) - (i386:accu-shl 2))) - ((12) (append (i386:accu->base) - (i386:accu+accu) - (i386:accu+base) - (i386:accu-shl 2))) - ((16) (i386:accu-shl 4)) - (else (append (i386:value->base n) - (i386:accu*base))))))) - -(define (accu->base-mem*n- info n) - (wrap-as - (case n - ((1) (i386:byte-accu->base-mem)) - ((2) (i386:word-accu->base-mem)) - ;; ((3) (append (i386:word-accu->base-mem) - ;; (i386:accu+value 2) - ;; (i386:base+value 2) - ;; (i386:byte-accu->base-mem))) - ((4) (i386:accu->base-mem)) - (else (append (let loop ((i 0)) - (if (>= i n) '() - (append (if (= i 0) '() - (append (i386:accu+value 4) - (i386:base+value 4))) - (case (- n i) - ((1) (append (i386:accu+value -3) - (i386:base+value -3) - (i386:accu-mem->base-mem))) - ((2) (append (i386:accu+value -2) - (i386:base+value -2) - (i386:accu-mem->base-mem))) - ((3) (append (i386:accu+value -1) - (i386:base+value -1) - (i386:accu-mem->base-mem))) - (else (i386:accu-mem->base-mem))) - (loop (+ i 4)))))))))) - -(define (accu->base-mem*n info n) - (append-text info (accu->base-mem*n- info n))) - -(define (accu-mem->base-mem*n info n) - (append-text info (append (cond ((= n 1) (wrap-as (i386:byte-mem->accu))) - ((= n 2) (wrap-as (i386:word-mem->accu))) - ((= n 3) (wrap-as (i386:mem->accu))) - ((= n 4) (wrap-as (i386:mem->accu))) - (else '())) - (accu->base-mem*n- info n)))) - -(define (expr->accu* info) - (lambda (o) - (pmatch o - - ((p-expr (ident ,name)) - (append-text info ((ident-address->accu info) name))) - - ((de-ref ,expr) - ((expr->accu info) expr)) - - ;; foo[bar] - ((array-ref ,index (p-expr (ident ,array))) - (let* ((type (ident->type info array)) - (ptr (ident->pointer info array)) - (size (if (or (= ptr 1) (= ptr -1)) (ast-type->size info type) - 4)) - (info ((expr->accu info) index)) - (info (accu*n info size))) - (append-text info (append ((ident->base info) array) - (wrap-as (i386:accu+base)))))) - - ;; bar.foo.i - ((d-sel (ident ,field1) (d-sel (ident ,field0) (p-expr (ident ,struct0)))) - (let* ((type0 (ident->type info struct0)) - (type1 (field-type info type0 field0)) - (offset (+ (field-offset info type0 field0) - (field-offset info type1 field1)))) - (append-text info (append ((ident->accu info) struct0) - (wrap-as (i386:accu+value offset)))))) - - ;; bar.poo->i - ((i-sel (ident ,field1) (d-sel (ident ,field0) (p-expr (ident ,struct0)))) - (let* ((type0 (ident->type info struct0)) - (type1 (field-type info type0 field0)) - (offset0 (field-offset info type0 field0)) - (offset1 (field-offset info type1 field1))) - (append-text info (append ((ident->accu info) struct0) - (wrap-as (i386:accu+value offset0)) - (wrap-as (i386:mem->accu)) - (wrap-as (i386:accu+value offset1)))))) - - ;; bar->foo.i - ((d-sel (ident ,field1) (i-sel (ident ,field0) (p-expr (ident ,struct0)))) - (let* ((type0 (ident->type info struct0)) - (type1 (field-type info type0 field0)) - (offset (+ (field-offset info type0 field0) - (field-offset info type1 field1))) - (ptr0 (ident->pointer info struct0))) - (append-text info (append ((ident->accu info) struct0) - (wrap-as (i386:accu+value offset)))))) - - ;; bar->foo.i - ((d-sel (ident ,field1) (d-sel (ident ,field0) (p-expr (ident ,struct0)))) - (let* ((type0 (ident->type info struct0)) - (type1 (field-type info type0 field0)) - (offset (+ (field-offset info type0 field0) - (field-offset info type1 field1)))) - (append-text info (append ((ident->accu info) struct0) - (wrap-as (i386:accu+value offset)))))) - - ;;(i-sel (ident "i") (i-sel (ident "p") (p-expr (ident "p")))) - ((i-sel (ident ,field1) (i-sel (ident ,field0) (p-expr (ident ,struct0)))) - (let* ((type0 (ident->type info struct0)) - (type1 (field-type info type0 field0)) - (offset0 (field-offset info type0 field0)) - (offset1 (field-offset info type1 field1))) - (append-text info (append ((ident->accu info) struct0) - (wrap-as (i386:accu+value offset0)) - (wrap-as (i386:mem->accu)) - (wrap-as (i386:accu+value offset1)))))) - - ;; (*pp)->bar.foo - ((d-sel (ident ,field1) (i-sel (ident ,field0) (de-ref (p-expr (ident ,struct0))))) - (let* ((type0 (ident->type info struct0)) - (type1 (field-type info type0 field0)) - (offset (+ (field-offset info type0 field0) - (field-offset info type1 field1)))) - (append-text info (append ((ident->accu info) struct0) - (wrap-as (i386:mem->accu)) - (wrap-as (i386:accu+value offset)))))) - - ;; g_cells[].type - ((d-sel (ident ,field) (array-ref ,index (p-expr (ident ,array)))) - (let* ((type (ident->type info array)) - (offset (field-offset info type field)) - (info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array)))))) - (append-text info (wrap-as (i386:accu+value offset))))) - - ;; foo.bar - ((d-sel (ident ,field) (p-expr (ident ,struct))) - (let* ((type (ident->type info struct)) - (offset (field-offset info type field)) - (text (.text info)) - (ptr (field-pointer info type field))) - (if (= ptr -1) - (append-text info (append ((ident-address->accu info) struct) - (wrap-as (i386:accu+value offset)))) - (append-text info (append ((ident->accu info) struct) - (wrap-as (i386:accu+value offset))))))) - - ;; foo.bar[baz] - ((array-ref ,index (d-sel (ident ,field0) (p-expr (ident ,struct0)))) - (let* ((type0 (ident->type info struct0)) - (type1 (field-type info type0 field0)) - (offset (field-offset info type0 field0)) - (info ((expr->accu info) index)) - (struct? (or #t (memq (type:type (ast-type->type info type0)) '(struct union)))) - (ptr (field-pointer info type0 field0)) - (size (if (or (= ptr -1) - (= ptr 1)) (ast-type->size info type1) - 4)) - (info (accu*n info size))) - (append-text info (append (wrap-as (i386:push-accu)) - ((ident->accu info) struct0) - (wrap-as (append (i386:accu+value offset) - (i386:pop-base) - (if (and struct? (or (= ptr -2) (= ptr 2) - (= ptr 1))) - (i386:mem->accu) '()) - (i386:accu+base))))))) - - ;; foo->bar[baz] - ((array-ref ,index (i-sel (ident ,field0) (p-expr (ident ,struct0)))) - (let* ((type0 (ident->type info struct0)) - (type1 (field-type info type0 field0)) - (offset (field-offset info type0 field0)) - (info ((expr->accu info) index)) - (struct? (or #t (memq (type:type (ast-type->type info type0)) '(struct union)))) - (ptr (field-pointer info type0 field0)) - (size (if (or (= ptr -1) - (= ptr 1)) (ast-type->size info type1) - 4)) - (info (accu*n info size))) - (append-text info (append (wrap-as (i386:push-accu)) - ((ident->accu info) struct0) - (wrap-as (append (i386:accu+value offset) - (i386:pop-base) - (if (and struct? (or (= ptr -2) (= ptr 2) - (= ptr 1))) - (i386:mem->accu) '()) - (i386:accu+base))))))) - - ((array-ref ,index ,array) - (let* ((info ((expr->accu info) index)) - (ptr (expr->pointer info array)) - (size (if (= ptr 1) (expr->size info array) - 4)) - (info (accu*n info size)) - (info ((expr->base info) array))) - (append-text info (wrap-as (i386:accu+base))))) - - ((i-sel (ident ,field) (p-expr (ident ,array))) - (let* ((type (ident->type info array)) - (offset (field-offset info type field))) - (append-text info (append ((ident-address->accu info) array) - (wrap-as (i386:mem->accu)) - (wrap-as (i386:accu+value offset)))))) - - ((i-sel (ident ,field) (de-ref (p-expr (ident ,array)))) - (let* ((type (ident->type info array)) - (offset (field-offset info type field))) - (append-text info (append ((ident-address->accu info) array) - (wrap-as (i386:mem->accu)) - (wrap-as (i386:mem->accu)) - (wrap-as (i386:accu+value offset)))))) - - ;; foo[i].bar.baz - ((d-sel (ident ,field1) (d-sel (ident ,field0) (array-ref ,index (p-expr (ident ,array))))) - (let* ((type0 (ident->type info array)) - (type1 (field-type info type0 field0)) - (offset (+ (field-offset info type0 field0) - (field-offset info type1 field1))) - (info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array)))))) - (append-text info (wrap-as (i386:accu+value offset))))) - - ;;foo[index]->bar - ((i-sel (ident ,field) (array-ref ,index (p-expr (ident ,array)))) - (let* ((type (ident->type info array)) - (offset (field-offset info type field)) - (info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array))))) - (ptr (field-pointer info type field))) - (append-text info (wrap-as (append (i386:mem->accu) - (i386:accu+value offset)))))) - - (_ (error "expr->accu*: unsupported: " o))))) - (define (ident->constant name value) (cons name value)) @@ -1489,26 +223,33 @@ (define (ast-type->type info o) (pmatch o - ((p-expr ,expr) (ast-type->type info (p-expr->type info o))) + ((p-expr ,expr) (ast-type->type info (expr->type info o))) ((pre-inc ,expr) (ast-type->type info expr)) ((post-inc ,expr) (ast-type->type info expr)) ((decl-spec-list ,type-spec) (ast-type->type info type-spec)) ((decl-spec-list (type-qual ,qual) (type-spec (fixed-type ,type))) (ast-type->type info type)) + ((array-ref ,index (p-expr (ident ,array))) + (ast-type->type info `(p-expr (ident ,array)))) ((struct-ref (ident (,type))) - (let ((struct (if (pair? type) type `("tag" ,type)))) - (ast-type->type info struct))) + (or (get-type (.types info) type) + (let ((struct (if (pair? type) type `("tag" ,type)))) + (ast-type->type info struct)))) ((struct-ref (ident ,type)) - (let ((struct (if (pair? type) type `("tag" ,type)))) - (ast-type->type info struct))) + (or (get-type (.types info) type) + (let ((struct (if (pair? type) type `("tag" ,type)))) + (ast-type->type info struct)))) ((union-ref (ident ,type)) - (let ((struct (if (pair? type) type `("tag" ,type)))) - (ast-type->type info struct))) + (or (get-type (.types info) type) + (let ((struct (if (pair? type) type `("tag" ,type)))) + (ast-type->type info struct)))) ((void) (ast-type->type info "void")) ((type-spec ,type) (ast-type->type info type)) ((fixed-type ,type) (ast-type->type info type)) ((typename ,type) (ast-type->type info type)) + ((de-ref ,expr) + (ast-type->type info expr)) ((d-sel (idend ,field) ,struct) (let ((type0 (ast-type->type info struct))) (field-type info type0 field))) @@ -1615,6 +356,938 @@ (let ((s (string-drop o (string-length prefix)))) (list (format #f "'~a'" (string-join (map byte->hex.m1 (cdr (string-split o #\space))) " "))))))) +(define (ident->decl info o) + (or (assoc-ref (.locals info) o) + (assoc-ref (.globals info) o) + (assoc-ref (.constants info) o) + (begin + (stderr "NO IDENT: ~a\n" o) + (assoc-ref (.functions info) o)))) + +(define (ident->type info o) + (let ((type (ident->decl info o))) + (cond ((global? type) (global:type type)) + ((local? type) (local:type type)) + ((assoc-ref (.constants info) o) "int") + (else (stderr "ident->type ~s => ~s\n" o type) + (car type))))) + +(define (ident->pointer info o) + (let ((local (assoc-ref (.locals info) o))) + (if local (local:pointer local) + (let ((global (assoc-ref (.globals info) o))) + (if global + (global:pointer (ident->decl info o)) + 0))))) + +(define (ident->type-size info o) + (let* ((type (ident->type info o)) + (xtype (ast-type->type info type))) + (type:size xtype))) + +(define (ptr-inc o) + (if (< o 0) (1- o) + (1+ o))) + +(define (ptr-dec o) + (if (< o 0) (1+ o) + (1- o))) + +(define (expr->pointer info o) + (pmatch o + ((pointer) 1) + ((p-expr (char ,value)) 0) + ((p-expr (fixed ,value)) 0) + ((p-expr (ident ,name)) (ident->pointer info name)) + ((de-ref ,expr) (ptr-dec (expr->pointer info expr))) + ((assn-expr ,lhs ,op ,rhs) (expr->pointer info lhs)) + ((add ,a ,b) (expr->pointer info a)) + ((div ,a ,b) (expr->pointer info a)) + ((mod ,a ,b) (expr->pointer info a)) + ((mul ,a ,b) (expr->pointer info a)) + ((sub ,a ,b) (expr->pointer info a)) + ((neg ,a) (expr->pointer info a)) + ((pre-inc ,a) (expr->pointer info a)) + ((pre-dec ,a) (expr->pointer info a)) + ((post-inc ,a) (expr->pointer info a)) + ((post-dec ,a) (expr->pointer info a)) + ((ref-to ,expr) (ptr-inc (expr->pointer info expr))) + ((array-ref ,index ,array) (ptr-dec (expr->pointer info array))) + + ((d-sel (ident ,field) ,struct) + (let ((type (expr->type info struct))) + (field-pointer info type field))) + + ((i-sel (ident ,field) ,struct) + (let ((type (expr->type info struct))) + (field-pointer info type field))) + + ((cast (type-name ,type) ,expr) ; FIXME: add expr? + (let* ((type (ast-type->type info type)) + (pointer (type:pointer type))) + pointer)) + ((cast (type-name ,type (abs-declr ,pointer)) ,expr) ; FIXME: add expr? + (let* ((type (ast-type->type info type)) + (pointer0 (type:pointer type)) + (pointer1 (ptr-declr->pointer pointer)) + (pointer2 (expr->pointer info expr))) + (+ pointer0 pointer1))) + (_ (stderr "expr->pointer: unsupported: ~s\n" o) 0))) + +(define %int-size 4) +(define %pointer-size %int-size) + +(define (expr->type-size info o) + (pmatch o + ((p-expr (char ,value)) 1) + ((p-expr (fixed ,name)) %int-size) + ((p-expr (ident ,name)) (ident->type-size info name)) + + ((array-ref ,index ,array) + (let ((type (expr->type info array))) + (ast-type->size info type))) + + ((d-sel (ident ,field) ,struct) + (let* ((type (expr->type info struct)) + (type (field-type info type field))) + (ast-type->size info type))) + + ((i-sel (ident ,field) ,struct) + (let* ((type (expr->type info struct)) + (type (field-type info type field))) + (ast-type->size info type))) + + ((de-ref ,expr) (expr->type-size info expr)) + ((ref-to ,expr) (expr->type-size info expr)) + ((add ,a ,b) (expr->type-size info a)) + ((div ,a ,b) (expr->type-size info a)) + ((mod ,a ,b) (expr->type-size info a)) + ((mul ,a ,b) (expr->type-size info a)) + ((sub ,a ,b) (expr->type-size info a)) + ((neg ,a) (expr->type-size info a)) + ((pre-inc ,a) (expr->type-size info a)) + ((pre-dec ,a) (expr->type-size info a)) + ((post-inc ,a) (expr->type-size info a)) + ((post-dec ,a) (expr->type-size info a)) + ((cast (type-name ,type) ,expr) ; FIXME: ignore expr? + (let ((type (ast-type->type info type))) + (type:size type))) + ((cast (type-name ,type (abs-declr ,pointer)) ,expr) ; FIXME: ignore expr? + (let ((type (ast-type->type info type))) + (type:size type))) + (_ (stderr "expr->type-size: unsupported: ~s\n" o) 4))) + +(define (expr->size info o) + (let ((ptr (expr->pointer info o))) + (if (or (= ptr -1) + (= ptr 0)) + (expr->type-size info o) + %pointer-size))) + +(define (expr->type info o) + (pmatch o + ((p-expr (char ,name)) "char") + ((p-expr (fixed ,value)) "int") + ((p-expr (ident ,name)) (ident->type info name)) + ((array-ref ,index ,array) + (expr->type info array)) + + ((i-sel (ident ,field) ,struct) + (let ((type (expr->type info struct))) + (field-type info type field))) + + ((d-sel (ident ,field) ,struct) + (let ((type (expr->type info struct))) + (field-type info type field))) + + ((de-ref ,expr) (expr->type info expr)) + ((ref-to ,expr) (expr->type info expr)) + ((add ,a ,b) (expr->type info a)) + ((div ,a ,b) (expr->type info a)) + ((mod ,a ,b) (expr->type info a)) + ((mul ,a ,b) (expr->type info a)) + ((sub ,a ,b) (expr->type info a)) + ((neg ,a) (expr->type info a)) + ((pre-inc ,a) (expr->type info a)) + ((pre-dec ,a) (expr->type info a)) + ((post-inc ,a) (expr->type info a)) + ((post-dec ,a) (expr->type info a)) + ((cast (type-name ,type) ,expr) ; FIXME: ignore expr? + type) + ((cast (type-name ,type (abs-declr ,pointer)) ,expr) ; FIXME: ignore expr? + type) + ((fctn-call (p-expr (ident ,name))) + (stderr "TODO: expr->type: unsupported: ~s\n" o) + "int") + (_ ;;(error (format #f "expr->type: unsupported: ~s") o) + (stderr "TODO: expr->type: unsupported: ~s\n" o) + "int"))) + +(define (append-text info text) + (clone info #:text (append (.text info) text))) + +(define (push-global info) + (lambda (o) + (let ((ptr (ident->pointer info o))) + (cond ((< ptr 0) (list (i386:push-label `(#:address ,o)))) + (else (list (i386:push-label-mem `(#:address ,o)))))))) + +(define (push-local locals) + (lambda (o) + (wrap-as (i386:push-local (local:id o))))) + +(define (push-global-address info) + (lambda (o) + (list (i386:push-label o)))) + +(define (push-local-address locals) + (lambda (o) + (wrap-as (i386:push-local-address (local:id o))))) + +(define push-global-de-ref push-global) + +(define (push-local-de-ref info) + (lambda (o) + (let* ((local o) + (ptr (local:pointer local)) + (size (if (= ptr 1) (ast-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) (ast-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 (make-global-entry key type pointer value) + (cons key (make-global type pointer value))) + +(define (string->global-entry string) + (make-global-entry `(#:string ,string) "string" 0 (append (string->list string) (list #\nul)))) + +(define (int->global-entry value) + (make-global-entry (number->string value) "int" 0 (int->bv32 value))) + +(define (ident->global-entry name type pointer value) + (make-global-entry name type pointer (if (pair? value) value (int->bv32 value)))) + +(define (make-local-entry name type pointer id) + (cons name (make-local type pointer id))) + +(define (push-ident info) + (lambda (o) + (let ((local (assoc-ref (.locals info) o))) + (if local + (begin + (let* ((ptr (local:pointer local))) + (if (or (< ptr 0)) ((push-local-address (.locals info)) local) + ((push-local (.locals info)) local)))) + (let ((global (assoc-ref (.globals info) o))) + (if global + ((push-global info) o) ;; FIXME: char*/int + (let ((constant (assoc-ref (.constants info) o))) + (if constant + (wrap-as (append (i386:value->accu constant) + (i386:push-accu))) + ((push-global-address #f) `(#:address ,o)))))))))) + +(define (push-ident-address info) + (lambda (o) + (let ((local (assoc-ref (.locals info) o))) + (if local ((push-local-address (.locals info)) local) + (let ((global (assoc-ref (.globals info) o))) + (if global + ((push-global-address info) o) + ((push-global-address #f) `(#:address ,o)))))))) + +(define (push-ident-de-ref info) + (lambda (o) + (let ((local (assoc-ref (.locals info) o))) + (if local ((push-local-de-ref info) local) + ((push-global-de-ref 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))) + (append-text info (wrap-as (i386:push-accu)))))) + +(define (globals:add-string globals) + (lambda (o) + (let ((string `(#:string ,o))) + (if (assoc-ref globals string) globals + (append globals (list (string->global-entry o))))))) + +(define (expr->arg info) ;; FIXME: get Mes curried-definitions + (lambda (o) + (let ((text (.text info))) + (pmatch o + + ((p-expr (string ,string)) + (let* ((globals ((globals:add-string (.globals info)) string)) + (info (clone info #:globals globals))) + (append-text info ((push-global-address info) `(#:string ,string))))) + + ((p-expr (ident ,name)) + (append-text info ((push-ident info) name))) + + ((cast (type-name (decl-spec-list (type-spec (fixed-type _))) + (abs-declr (pointer))) + ,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))) + + (_ (append-text ((expr->accu info) o) + (wrap-as (i386:push-accu)))))))) + +(define (ident->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 0) (ast-type->size info type) + 4))) + (cond ((< ptr 0) (wrap-as (i386:local-ptr->accu (local:id local)))) + (else (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))) + (cond ((< ptr 0) (list (i386:label->accu `(#:address ,o)))) + (else (list (i386:label-mem->accu `(#:address ,o)))))) + (if constant (wrap-as (i386:value->accu constant)) + (list (i386:label->accu `(#:address ,o))))))))) + +(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 (wrap-as (i386:local-ptr->accu (local:id local))) + (if global (list (i386:label->accu `(#:address ,o))) + (list (i386:label->accu `(#:address ,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 (wrap-as (i386:local-ptr->base (local:id local))) + (if global (list (i386:label->base `(#:address ,o))) + (list (i386:label->base `(#:address ,o)))))))) + +(define (value->accu v) + (wrap-as (i386:value->accu v))) + +(define (accu->ident info) + (lambda (o) + (let* ((local (assoc-ref (.locals info) o)) + (ptr (ident->pointer info o)) + (size (if (or (= ptr -1) (= ptr 0)) (ident->type-size info o) + 4))) + (if local (if (<= size 4) (wrap-as (i386:accu->local (local:id local))) + (wrap-as (i386:accu*n->local (local:id local) size))) + (if (<= size 4) (wrap-as (i386:accu->label o)) + (wrap-as (i386:accu*n->label o size))))))) + +(define (value->ident info) + (lambda (o value) + (let ((local (assoc-ref (.locals info) o))) + (if local (wrap-as (i386:value->local (local:id local) value)) + (list (i386:value->label `(#:address ,o) value)))))) + +(define (ident-add info) + (lambda (o n) + (let ((local (assoc-ref (.locals info) o))) + (if local (wrap-as (i386:local-add (local:id local) n)) + (list (i386:label-mem-add `(#:address ,o) n)))))) + +(define (expr-add info) + (lambda (o n) + (let* ((info ((expr->accu* info) o)) + (info (append-text info (wrap-as (i386:accu-mem-add n))))) + info))) + +(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 (wrap-as (append (i386:push-accu) + (i386:label->accu `(#:address ,o)) + (i386:accu-mem-add n) + (i386:pop-accu)))))))) + +(define (binop->accu info) + (lambda (a b c) + (let* ((info ((expr->accu info) a)) + (info ((expr->base info) b))) + (append-text info (wrap-as c))))) + +(define (wrap-as o . annotation) + `(,@annotation ,o)) + +(define (make-comment o) + (wrap-as `((#:comment ,o)))) + +(define (ast->comment o) + (let ((source (with-output-to-string (lambda () (pretty-print-c99 o))))) + (make-comment (string-join (string-split source #\newline) " ")))) + +(define (accu*n info n) + (append-text info (wrap-as (case n + ((1) (i386:accu->base)) + ((2) (i386:accu+accu)) + ((3) (append (i386:accu->base) + (i386:accu+accu) + (i386:accu+base))) + ((4) (i386:accu-shl 2)) + ((8) (append (i386:accu+accu) + (i386:accu-shl 2))) + ((12) (append (i386:accu->base) + (i386:accu+accu) + (i386:accu+base) + (i386:accu-shl 2))) + ((16) (i386:accu-shl 4)) + (else (append (i386:value->base n) + (i386:accu*base))))))) + +(define (accu->base-mem*n- info n) + (wrap-as + (case n + ((1) (i386:byte-accu->base-mem)) + ((2) (i386:word-accu->base-mem)) + ((4) (i386:accu->base-mem)) + (else (append (let loop ((i 0)) + (if (>= i n) '() + (append (if (= i 0) '() + (append (i386:accu+value 4) + (i386:base+value 4))) + (case (- n i) + ((1) (append (i386:accu+value -3) + (i386:base+value -3) + (i386:accu-mem->base-mem))) + ((2) (append (i386:accu+value -2) + (i386:base+value -2) + (i386:accu-mem->base-mem))) + ((3) (append (i386:accu+value -1) + (i386:base+value -1) + (i386:accu-mem->base-mem))) + (else (i386:accu-mem->base-mem))) + (loop (+ i 4)))))))))) + +(define (accu->base-mem*n info n) + (append-text info (accu->base-mem*n- info n))) + +(define (expr->accu* info) + (lambda (o) + (pmatch o + + ((p-expr (ident ,name)) + (append-text info ((ident-address->accu info) name))) + + ((de-ref ,expr) + ((expr->accu info) expr)) + + ((d-sel (ident ,field) ,struct) + (let* ((type (expr->type info struct)) + (offset (field-offset info type field)) + (info ((expr->accu* info) struct))) + (append-text info (wrap-as (i386:accu+value offset))))) + + ((i-sel (ident ,field) ,struct) + (let* ((type (expr->type info struct)) + (offset (field-offset info type field)) + (info ((expr->accu* info) struct))) + (append-text info (append (wrap-as (i386:mem->accu)) + (wrap-as (i386:accu+value offset)))))) + + ((array-ref ,index ,array) + (let* ((info ((expr->accu info) index)) + (ptr (expr->pointer info array)) + (size (if (or (= ptr 1) (= ptr -1) (= ptr -2)) (expr->type-size info array) + 4)) + (info (accu*n info size)) + (info ((expr->base info) array))) + (append-text info (wrap-as (i386:accu+base))))) + + (_ (error "expr->accu*: unsupported: " o))))) + +(define (expr->accu info) + (lambda (o) + (let ((locals (.locals info)) + (constants (.constants info)) + (text (.text info)) + (globals (.globals info))) + (define (add-local locals name type pointer) + (let* ((id (if (or (null? locals) (not (local-var? (cdar locals)))) 1 + (1+ (local:id (cdar locals))))) + (locals (cons (make-local-entry name type pointer id) locals))) + locals)) + (pmatch o + ((expr) info) + + ((comma-expr) info) + + ((comma-expr ,a . ,rest) + (let ((info ((expr->accu info) a))) + ((expr->accu info) `(comma-expr ,@rest)))) + + ((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)))))) + + ;;; FIXME: FROM INFO ...only zero?! + ((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 info) initzer)) + + ;; offsetoff + ((ref-to (i-sel (ident ,field) (cast (type-name (decl-spec-list ,struct) (abs-declr (pointer))) (p-expr (fixed ,base))))) + (let* ((type (decl->ast-type struct)) + (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 info) expr)) + + ((ref-to ,expr) + ((expr->accu* info) expr)) + + ((sizeof-expr (p-expr (ident ,name))) + (let* ((type (ident->type info name)) + (size (ast-type->size info type))) + (append-text info (wrap-as (i386:value->accu size))))) + + ((sizeof-expr (p-expr (string ,string))) + (append-text info (wrap-as (i386:value->accu (1+ (string-length string)))))) + + ((sizeof-expr (i-sel (ident ,field) (p-expr (ident ,struct)))) + (let* ((type (ident->type info struct)) + (size (field-size info type field))) + (append-text info (wrap-as (i386:value->accu size))))) + + ((sizeof-expr (d-sel (ident ,field) (p-expr (ident ,struct)))) + (let* ((type (ident->type info struct)) + (size (field-size info type field))) + (append-text info (wrap-as (i386:value->accu size))))) + + ((sizeof-type (type-name (decl-spec-list (type-spec (fixed-type ,name))))) + (let* ((type name) + (size (ast-type->size info type))) + (append-text info (wrap-as (i386:value->accu size))))) + + ((sizeof-type (type-name (decl-spec-list (type-spec (struct-ref (ident (,type))))))) + (let* ((type `("tag" ,type)) + (size (ast-type->size info type))) + (append-text info (wrap-as (i386:value->accu size))))) + + ((sizeof-type (type-name (decl-spec-list (type-spec (struct-ref (ident ,type)))))) + (let* ((type `("tag" ,type)) + (size (ast-type->size info type))) + (append-text info (wrap-as (i386:value->accu size))))) + + ((sizeof-type (type-name (decl-spec-list (type-spec (typename ,type))))) + (let ((size (ast-type->size info type))) + (append-text info (wrap-as (i386:value->accu size))))) + + ((sizeof-type (type-name (decl-spec-list ,type) (abs-declr (pointer)))) + (let ((size 4)) + (append-text info (wrap-as (i386:value->accu size))))) + + ;; [baz] + ((array-ref ,index ,array) + (let* ((info ((expr->accu* info) o)) + (ptr (expr->pointer info array)) + (size (if (or (= ptr 1) (= ptr -1) (= ptr -2)) (expr->type-size info array) + 4))) + (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* info) o)) + (ptr (expr->pointer info o)) + (size (if (= ptr 0) (expr->type-size info o) + 4))) + (if (= ptr -1) 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* info) o)) + (ptr (expr->pointer info o)) + (size (if (= ptr 0) (expr->type-size info o) + 4))) + (if (= ptr -1) 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 info) expr)) + (ptr (expr->pointer info expr)) + (size (expr->size info o))) + (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 empty) `(p-expr (ident ,name))))) + (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 empty) function))) + (append-text args-info (append (.text accu) + (list (i386:call-accu n)))))) + + ((cond-expr . ,cond-expr) + ((ast->info info) `(expr-stmt ,o))) + + ((post-inc ,expr) + (let* ((info (append ((expr->accu info) expr))) + (info (append-text info (wrap-as (i386:push-accu)))) + (ptr (expr->pointer info expr)) + (size (cond ((= ptr 1) (expr->type-size info expr)) + ((> ptr 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 info) expr))) + (info (append-text info (wrap-as (i386:push-accu)))) + (ptr (expr->pointer info expr)) + (size (cond ((= ptr 1) (expr->type-size info expr)) + ((> ptr 1) 4) + (else 1))) + (info ((expr-add info) expr (- size))) + (info (append-text info (wrap-as (i386:pop-accu))))) + info)) + + ((pre-inc ,expr) + (let* ((ptr (expr->pointer info expr)) + (size (cond ((= ptr 1) (expr->type-size info expr)) + ((> ptr 1) 4) + (else 1))) + (info ((expr-add info) expr size)) + (info (append ((expr->accu info) expr)))) + info)) + + ((pre-dec ,expr) + (let* ((ptr (expr->pointer info expr)) + (size (cond ((= ptr 1) (expr->type-size info expr)) + ((> ptr 1) 4) + (else 1))) + (info ((expr-add info) expr (- size))) + (info (append ((expr->accu info) expr)))) + info)) + + ((add ,a (p-expr (fixed ,value))) + (let* ((ptr (expr->pointer info a)) + (type0 (expr->type info a)) + (struct? (memq (type:type (ast-type->type info type0)) '(struct union))) + (size (cond ((= ptr 1) (expr->type-size info a)) + ((> ptr 1) 4) + ((and struct? (= ptr -2)) 4) + ((and struct? (= ptr 2)) 4) + (else 1))) + (info ((expr->accu info) a)) + (value (cstring->number value)) + (value (* size value))) + (append-text info (wrap-as (i386:accu+value value))))) + + ((add ,a ,b) + (let* ((ptr (expr->pointer info a)) + (ptr-b (expr->pointer info b)) + (type0 (expr->type info a)) + (struct? (memq (type:type (ast-type->type info type0)) '(struct union))) + (size (cond ((= ptr 1) (expr->type-size info a)) + ((> ptr 1) 4) + ((and struct? (= ptr -2)) 4) + ((and struct? (= ptr 2)) 4) + (else 1)))) + (if (or (= size 1)) ((binop->accu info) a b (i386:accu+base)) + (let* ((info ((expr->accu info) b)) + (info (append-text info (wrap-as (append (i386:value->base size) + (i386:accu*base) + (i386:accu->base))))) + (info ((expr->accu info) a))) + (append-text info (wrap-as (i386:accu+base))))))) + + ((sub ,a (p-expr (fixed ,value))) + (let* ((ptr (expr->pointer info a)) + (type0 (expr->type info a)) + (struct? (memq (type:type (ast-type->type info type0)) '(struct union))) + (size (cond ((= ptr 1) (expr->type-size info a)) + ((> ptr 1) 4) + ((and struct? (= ptr -2)) 4) + ((and struct? (= ptr 2)) 4) + (else 1))) + (info ((expr->accu info) a)) + (value (cstring->number value)) + (value (* size value))) + (append-text info (wrap-as (i386:accu+value (- value)))))) + + ((sub ,a ,b) + (let* ((ptr (expr->pointer info a)) + (ptr-b (expr->pointer info b)) + (type0 (expr->type info a)) + (struct? (memq (type:type (ast-type->type info type0)) '(struct union))) + (size (cond ((= ptr 1) (expr->type-size info a)) + ((> ptr 1) 4) + ((and struct? (= ptr -2)) 4) + ((and struct? (= ptr 2)) 4) + (else 1)))) + (if (or (= size 1) (= ptr-b 1)) (let ((info ((binop->accu info) a b (i386:accu-base)))) + (if (not (= ptr-b 1)) info + (append-text info (wrap-as (append (i386:value->base size) + (i386:accu/base)))))) + (let* ((info ((expr->accu info) b)) + (info (append-text info (wrap-as (append (i386:value->base size) + (i386:accu*base) + (i386:accu->base))))) + (info ((expr->accu info) a))) + (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 info) expr))) + (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 info) expr))) + (clone info #:text + (append (.text test-info) + (wrap-as (i386:accu-negate))) + #:globals (.globals test-info)))) + + ((neg ,expr) + (let ((info ((expr->base info) expr))) + (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 info) a)) + (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 info) b)) + (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 info) a)) + (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 info) b)) + (info (append-text info (wrap-as (i386:accu-test)))) + (info (append-text info (wrap-as `((#:label ,skip-b-label)))))) + info)) + + ((cast ,cast ,o) + ((expr->accu info) o)) + + ((assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op ,op) ,b) + (let* ((info ((expr->accu info) `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b))) + (type (ident->type info name)) + (ptr (ident->pointer info name)) + (size (if (> ptr 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 info) `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b))) + (type (ident->type info name)) + (ptr (ident->pointer info name)) + (size (if (> ptr 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))) + (ptr-a (expr->pointer info a)) + (ptr-b (expr->pointer info b)) + (size-a (expr->size info a)) + (size-b (expr->size info b)) + ;;(foo (stderr "assign ~s\n"(with-output-to-string (lambda () (pretty-print-c99 o))))) + ;;(foo (stderr " size-a: ~a, ptr=~a\n" size-a ptr-a)) + ;;(foo (stderr " size-b: ~a, ptr=~a\n" size-b ptr-b)) + (info ((expr->accu info) b)) + (info (if (equal? op "=") info + (let* ((ptr (expr->pointer info a)) + (ptr-b (expr->pointer info b)) + (type0 (expr->type info a)) + (struct? (memq (type:type (ast-type->type info type0)) '(struct union))) + (size (cond ((= ptr 1) (expr->type-size info a)) + ((> ptr 1) 4) + ((and struct? (= ptr -2)) 4) + ((and struct? (= ptr 2)) 4) + (else 1))) + (info (if (or (= size 1) (= ptr-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 info) a)) + (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<type info b))))))))) + (when (and (equal? op "=") + (not (= size-a size-b)) + (not (and (or (= size-a 1) (= size-a 2)) + (= size-b 4))) + (not (and (= size-a 2) + (= size-b 4))) + (not (and (= size-a 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" ptr-a size-a ptr-b size-b)) + (pmatch a + ((p-expr (ident ,name)) + (if (or (<= size-a 4) ;; FIXME: long long = int + (<= size-b 4)) (append-text info ((accu->ident info) name)) + (let ((info ((expr->base* info) a))) + (accu->base-mem*n info size-a)))) + (_ (let ((info ((expr->base* info) a))) + (accu->base-mem*n info (min size-a (max 4 size-b)))))))) ;; FIXME: long long = int + + (_ (error "expr->accu: unsupported: " o)))))) + +(define (expr->base info) + (lambda (o) + (let* ((info (append-text info (wrap-as (i386:push-accu)))) + (info ((expr->accu info) o)) + (info (append-text info (wrap-as (append (i386:accu->base) (i386:pop-accu)))))) + info))) + +(define (expr->base* info) + (lambda (o) + (let* ((info (append-text info (wrap-as (i386:push-accu)))) + (info ((expr->accu* info) o)) + (info (append-text info (wrap-as (i386:accu->base)))) + (info (append-text info (wrap-as (i386:pop-accu))))) + info))) + (define (clause->info info i label last?) (define clause-label (string-append label "clause" (number->string i))) @@ -1745,47 +1418,47 @@ ((string-prefix? "0" s) (string->number s 8)) (else (string->number s))))) -(define (p-expr->number info o) +(define (expr->number info o) (pmatch o ((p-expr (fixed ,a)) (cstring->number a)) ((neg ,a) - (- (p-expr->number info a))) + (- (expr->number info a))) ((add ,a ,b) - (+ (p-expr->number info a) (p-expr->number info b))) + (+ (expr->number info a) (expr->number info b))) ((bitwise-and ,a ,b) - (logand (p-expr->number info a) (p-expr->number info b))) + (logand (expr->number info a) (expr->number info b))) ((bitwise-not ,a) - (lognot (p-expr->number info a))) + (lognot (expr->number info a))) ((bitwise-or ,a ,b) - (logior (p-expr->number info a) (p-expr->number info b))) + (logior (expr->number info a) (expr->number info b))) ((div ,a ,b) - (quotient (p-expr->number info a) (p-expr->number info b))) + (quotient (expr->number info a) (expr->number info b))) ((mul ,a ,b) - (* (p-expr->number info a) (p-expr->number info b))) + (* (expr->number info a) (expr->number info b))) ((sub ,a ,b) - (- (p-expr->number info a) (p-expr->number info b))) + (- (expr->number info a) (expr->number info b))) ((sizeof-type (type-name (decl-spec-list (type-spec ,type)))) (ast-type->size info type)) ((sizeof-expr (i-sel (ident ,field) (p-expr (ident ,struct)))) (let ((type (ident->type info struct))) (field-size info type field))) ((lshift ,x ,y) - (ash (p-expr->number info x) (p-expr->number info y))) + (ash (expr->number info x) (expr->number info y))) ((rshift ,x ,y) - (ash (p-expr->number info x) (- (p-expr->number info y)))) + (ash (expr->number info x) (- (expr->number info y)))) ((p-expr (ident ,name)) (let ((value (assoc-ref (.constants info) name))) (or value - (error (format #f "p-expr->number: undeclared identifier: ~s\n" o))))) - ((cast ,type ,expr) (p-expr->number info expr)) + (error (format #f "expr->number: undeclared identifier: ~s\n" o))))) + ((cast ,type ,expr) (expr->number info expr)) ((cond-expr ,test ,then ,else) - (if (p-expr->bool info test) (p-expr->number info then) (p-expr->number info else))) - (_ (error (format #f "p-expr->number: not supported: ~s\n" o))))) + (if (p-expr->bool info test) (expr->number info then) (expr->number info else))) + (_ (error (format #f "expr->number: not supported: ~s\n" o))))) (define (p-expr->bool info o) (pmatch o - ((eq ,a ,b) (eq? (p-expr->number info a) (p-expr->number info b))))) + ((eq ,a ,b) (eq? (expr->number info a) (expr->number info b))))) (define (struct-field info) (lambda (o) @@ -1813,19 +1486,22 @@ (list name "void" 4 1)) ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name))))) (list name type 4 1)) + + ;; FIXME: array: -1,-2-3, name?? ((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (array-of (ident ,name) ,count))))) (let ((size 4) - (count (p-expr->number info count))) + (count (expr->number info count))) (list name type (* count size) -1))) ((comp-decl (decl-spec-list (type-spec ,type)) (comp-declr-list (comp-declr (array-of (ident ,name) ,count)))) (let ((size (ast-type->size info type)) - (count (p-expr->number info count))) + (count (expr->number info count))) (list name type (* count size) -1))) + ((comp-decl (decl-spec-list (type-spec (struct-ref (ident (,type))))) (comp-declr-list (comp-declr (ptr-declr (pointer (pointer)) (ident ,name))))) - (list name `("tag" ,type) 4 -2)) + (list name `("tag" ,type) 4 2)) ((comp-decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (comp-declr-list (comp-declr (ptr-declr (pointer (pointer)) (ident ,name))))) - (list name `("tag" ,type) 4 -2)) + (list name `("tag" ,type) 4 2)) ((comp-decl (decl-spec-list (type-spec (struct-ref (ident (,type))))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name))))) (list name `("tag" ,type) 4 1)) @@ -1852,228 +1528,6 @@ (_ (error "struct-field: unsupported: " o))))) -(define (ident->decl info o) - (or (assoc-ref (.locals info) o) - (assoc-ref (.globals info) o) - (assoc-ref (.constants info) o) - (begin - (stderr "NO IDENT: ~a\n" o) - (assoc-ref (.functions info) o)))) - -(define (ident->type info o) - (let ((type (ident->decl info o))) - (cond ((global? type) (global:type type)) - ((local? type) (local:type type)) - ((assoc-ref (.constants info) o) "int") - (else (stderr "ident->type ~s => ~s\n" o type) - (car type))))) - -(define (ident->pointer info o) - (let ((local (assoc-ref (.locals info) o))) - (if local (local:pointer local) - (let ((global (assoc-ref (.globals info) o))) - (if global - (global:pointer (ident->decl info o)) - 0))))) - -(define (ident->size info o) - (let* ((type (ident->type info o)) - (xtype (ast-type->type info type))) - (type:size xtype))) - -(define (expr->pointer info o) - (pmatch o - ((p-expr (fixed ,value)) 0) - ((p-expr (ident ,name)) (ident->pointer info name)) - ((de-ref ,expr) (1- (expr->pointer info expr))) - ((assn-expr ,lhs ,op ,rhs) (expr->pointer info lhs)) - ((add ,a ,b) (expr->pointer info a)) - ((neg ,a) (expr->pointer info a)) - ((sub ,a ,b) (expr->pointer info a)) - ((pre-inc ,a) (expr->pointer info a)) - ((pre-dec ,a) (expr->pointer info a)) - ((post-inc ,a) (expr->pointer info a)) - ((post-dec ,a) (expr->pointer info a)) - ((ref-to ,expr) (1+ (expr->pointer info expr))) - ((array-ref ,index ,array) - (1- (expr->pointer info array))) - - ((d-sel (ident ,field) (array-ref ,index ,array)) - (let ((type (p-expr->type info array))) - (field-pointer info type field))) - - ((i-sel (ident ,field) (array-ref ,index ,array)) - (let ((type (p-expr->type info array))) - (field-pointer info type field))) - - ((d-sel (ident ,field) (p-expr (ident ,struct))) - (let ((type (ident->type info struct))) - (field-pointer info type field))) - - ((i-sel (ident ,field) (p-expr (ident ,struct))) - (let ((type (ident->type info struct))) - (field-pointer info type field))) - - ((i-sel (ident ,field1) (i-sel (ident ,field0) ,struct0)) - (let* ((type0 (p-expr->type info struct0)) - (type0 (if (pair? type0) type0 `("tag" ,type0))) - (type1 (field-type info type0 field0))) - (field-pointer info type1 field1))) - - ((i-sel (ident ,field1) (d-sel (ident ,field0) ,struct0)) - (let* ((type0 (p-expr->type info struct0)) - (type0 (if (pair? type0) type0 `("tag" ,type0))) - (type1 (field-type info type0 field0))) - (field-pointer info type1 field1))) - - ((d-sel (ident ,field1) (i-sel (ident ,field0) ,struct0)) - (let* ((type0 (p-expr->type info struct0)) - ;;(type0 (if (pair? type0) type0 `("tag" ,type0))) - (type1 (field-type info type0 field0))) - (field-pointer info type1 field1))) - - ((d-sel (ident ,field1) (d-sel (ident ,field0) ,struct0)) - (let* ((type0 (p-expr->type info struct0)) - (type0 (if (pair? type0) type0 `("tag" ,type0))) - (type1 (field-type info type0 field0))) - (field-pointer info type1 field1))) - - ((cast (type-name ,type) ,expr) ; FIXME: add expr? - (let* ((type (ast-type->type info type)) - (pointer (type:pointer type))) - pointer)) - ((cast (type-name ,type (abs-declr ,pointer)) ,expr) ; FIXME: add expr? - (let* ((type (ast-type->type info type)) - (pointer0 (type:pointer type)) - (pointer1 (ptr-declr->pointer pointer)) - (pointer2 (expr->pointer info expr))) - (+ pointer0 pointer1))) - (_ (stderr "expr->pointer: unsupported: ~s\n" o) 0))) - -(define (expr->size info o) - (pmatch o - ((p-expr (ident ,name)) (ident->size info name)) - - ((array-ref ,index ,array) - (let ((type (p-expr->type info array))) - (ast-type->size info type))) - - ((d-sel (ident ,field) (array-ref ,index ,array)) - (let ((type (p-expr->type info array))) - (field-size info type field))) - - ((i-sel (ident ,field) (array-ref ,index ,array)) - (let ((type (p-expr->type info array))) - (field-size info type field))) - - ((d-sel (ident ,field) (p-expr (ident ,struct))) - (let* ((type (ident->type info struct)) - (type1 (field-type info type field))) - (ast-type->size info type1))) - - ((i-sel (ident ,field) (p-expr (ident ,struct))) - (let* ((type (ident->type info struct)) - (type1 (field-type info type field))) - (ast-type->size info type1))) - - ((i-sel (ident ,field1) (i-sel (ident ,field0) ,struct0)) - (let* ((type0 (p-expr->type info struct0)) - (type0 (if (pair? type0) type0 `("tag" ,type0))) - (type1 (field-type info type0 field0))) - (ast-type->size info type1))) - - ((i-sel (ident ,field1) (d-sel (ident ,field0) ,struct0)) - (let* ((type0 (p-expr->type info struct0)) - (type0 (if (pair? type0) type0 `("tag" ,type0))) - (type1 (field-type info type0 field0))) - (ast-type->size info type1))) - - ((d-sel (ident ,field1) (i-sel (ident ,field0) ,struct0)) - (let* ((type0 (p-expr->type info struct0)) - (type0 (if (pair? type0) type0 `("tag" ,type0))) - (type1 (field-type info type0 field0))) - (ast-type->size info type1))) - - ((d-sel (ident ,field1) (d-sel (ident ,field0) ,struct0)) - (let* ((type0 (p-expr->type info struct0)) - (type0 (if (pair? type0) type0 `("tag" ,type0))) - (type1 (field-type info type0 field0))) - (ast-type->size info type1))) - - ((de-ref ,expr) (expr->size info expr)) - ((add ,a ,b) (expr->size info a)) - ((sub ,a ,b) (expr->size info a)) - ((pre-inc ,a) (expr->size info a)) - ((pre-dec ,a) (expr->size info a)) - ((post-inc ,a) (expr->size info a)) - ((post-dec ,a) (expr->size info a)) - ((cast (type-name ,type) ,expr) ; FIXME: ignore expr? - (let ((type (ast-type->type info type))) - (type:size type))) - ((cast (type-name ,type (abs-declr ,pointer)) ,expr) ; FIXME: ignore expr? - (let ((type (ast-type->type info type))) - (type:size type))) - (_ (stderr "expr->size: unsupported: ~s\n" o) 4))) - -(define (p-expr->type info o) - (pmatch o - ((p-expr (ident ,name)) (ident->type info name)) - ((array-ref ,index ,array) - (p-expr->type info array)) - ((array-ref ,index (p-expr (ident ,array))) (ident->type info array)) - ((i-sel (ident ,field1) (i-sel (ident ,field0) ,struct0)) - (let* ((type0 (p-expr->type info struct0)) - (type0 (if (pair? type0) type0 `("tag" ,type0))) - (type1 (field-type info type0 field0))) - (field-type info type1 field1))) - - ((i-sel (ident ,field1) (d-sel (ident ,field0) ,struct0)) - (let* ((type0 (p-expr->type info struct0)) - (type0 (if (pair? type0) type0 `("tag" ,type0))) - (type1 (field-type info type0 field0))) - (field-type info type1 field1))) - - ((d-sel (ident ,field1) (i-sel (ident ,field0) ,struct0)) - (let* ((type0 (p-expr->type info struct0)) - (type0 (if (pair? type0) type0 `("tag" ,type0))) - (type1 (field-type info type0 field0))) - (field-type info type1 field1))) - - ((d-sel (ident ,field1) (d-sel (ident ,field0) ,struct0)) - (let* ((type0 (p-expr->type info struct0)) - (type0 (if (pair? type0) type0 `("tag" ,type0))) - (type1 (field-type info type0 field0))) - (field-type info type1 field1))) - - ((i-sel (ident ,field) (p-expr (ident ,struct))) - (let* ((type0 (ident->type info struct)) - (type0 (if (pair? type0) type0 `("tag" ,type0)))) - (field-type info type0 field))) - ((d-sel (ident ,field) (p-expr (ident ,struct))) - (let* ((type0 (ident->type info struct)) - (type0 (if (pair? type0) type0 `("tag" ,type0)))) - (field-type info type0 field))) - ((d-sel (ident ,field) (array-ref ,index (p-expr (ident ,array)))) - (let* ((type0 (ident->type info array)) - (type0 (if (pair? type0) type0 `("tag" ,type0)))) - (field-type info type0 field))) - ((de-ref ,expr) (p-expr->type info expr)) - ((ref-to ,expr) (p-expr->type info expr)) - ((add ,a ,b) (p-expr->type info a)) - ((sub ,a ,b) (p-expr->type info a)) - ((p-expr (fixed ,value)) "int") - ((neg ,a) (p-expr->type info a)) - ((cast (type-name ,type) ,expr) ; FIXME: ignore expr? - type) - ((cast (type-name ,type (abs-declr ,pointer)) ,expr) ; FIXME: ignore expr? - type) - ((fctn-call (p-expr (ident ,name))) - (stderr "TODO: p-expr->type: unsupported: ~s\n" o) - "int") - (_ ;;(error (format #f "p-expr->type: unsupported: ~s") o) - (stderr "TODO: p-expr->type: unsupported: ~s\n" o) - "int"))) - (define (local-var? o) ;; formals < 0, locals > 0 (positive? (local:id o))) @@ -2097,15 +1551,15 @@ (define (init-declr->count info o) (pmatch o - ((array-of (ident ,name) ,count) (p-expr->number info count)) + ((array-of (ident ,name) ,count) (expr->number info count)) (_ #f))) (define (init-declr->pointer o) (pmatch o ((ident ,name) 0) ((ptr-declr ,pointer (ident ,name)) (ptr-declr->pointer pointer)) - ((array-of (ident ,name) ,index) -1) - ((array-of (ident ,name)) -1) + ((array-of (ident ,name) ,index) -2) + ((array-of (ident ,name)) -2) ((ftn-declr (scope (ptr-declr ,pointer (ident ,name))) (param-list . ,params)) (ptr-declr->pointer pointer)) ((ptr-declr (pointer) (array-of (ident ,name))) -2) ((ptr-declr (pointer) (array-of (ident ,name) (p-expr ,size))) -2) @@ -2271,7 +1725,7 @@ ((decl (decl-spec-list (stor-spec (typedef)) (type-spec (typename ,type))) (init-declr-list (init-declr (array-of (ident ,name) ,value)))) (let* ((type (get-type types type)) - (value (p-expr->number info value)) + (value (expr->number info value)) (size (* value 4)) (pointer -1) (type (make-type 'array size pointer type))) @@ -2332,16 +1786,20 @@ (let ((type (ast->type type))) (if (.function info) (let* ((local (car (add-local locals name type -1))) - (count (p-expr->number info count)) + (count (expr->number info count)) (size (ast-type->size info type)) - (local (make-local-entry name type -1 (+ (local:id (cdr local)) -1 (quotient (+ (* count size) 3) 4)))) + (pointer (expr->pointer info `(type-spec ,type))) + (pointer (- -1 pointer)) + (local (pke "0local: " (make-local-entry name type pointer (+ (local:id (cdr local)) -1 (quotient (+ (* count size) 3) 4))))) (locals (cons local locals)) (info (clone info #:locals locals))) info) (let* ((globals (.globals info)) - (count (p-expr->number info count)) + (count (expr->number info count)) (size (ast-type->size info type)) - (array (make-global-entry name type -1 (string->list (make-string (* count size) #\nul)))) + (pointer (expr->pointer info `(type-spec ,type))) + (pointer (- -1 pointer)) + (array (pke "0global: " (make-global-entry name type pointer (string->list (make-string (* count size) #\nul))))) (globals (append globals (list array)))) (clone info #:globals globals))))) @@ -2350,16 +1808,20 @@ (let ((type (ast->type type))) (if (.function info) (let* ((local (car (add-local locals name type -1))) - (count (p-expr->number info count)) + (count (expr->number info count)) (size 4) - (local (make-local-entry name type -2 (+ (local:id (cdr local)) -1 (quotient (+ (* count size) 3) 4)))) + (pointer (expr->pointer info `(type-spec ,type))) + (pointer (- -3 pointer)) + (local (pke "1local:" (make-local-entry name type pointer (+ (local:id (cdr local)) -1 (quotient (+ (* count size) 3) 4))))) (locals (cons local locals)) (info (clone info #:locals locals))) info) (let* ((globals (.globals info)) - (count (p-expr->number info count)) + (count (expr->number info count)) (size 4) - (global (make-global-entry name type -2 (string->list (make-string (* count size) #\nul)))) + (pointer (expr->pointer info `(type-spec ,type))) + (pointer (- -3 pointer)) + (global (pke "1global: " (make-global-entry name type pointer (string->list (make-string (* count size) #\nul))))) (globals (append globals (list global)))) (clone info #:globals globals))))) @@ -2472,6 +1934,8 @@ ;; char *bla[] = {"a", "b"}; ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (array-of (ident ,name))) (initzer (initzer-list . ,initzers))))) (let* ((type (decl->ast-type type)) + (pointer (pke "2pointer: " (expr->pointer info `(type-spec ,type)))) + (pointer (pke "pointer: " (- -3 pointer))) (entries (filter identity (append-map (initzer->globals globals) initzers))) (global-names (map car globals)) (entries (filter (lambda (g) (and g (not (member (car g) global-names)))) entries)) @@ -2482,7 +1946,7 @@ (if (.function info) (let* ((count (length initzers)) (local (car (add-local locals name type -1))) - (local (make-local-entry name type -1 (+ (local:id (cdr local)) -1 (1+ count)))) + (local (pke "2local: " (make-local-entry name type pointer (+ (local:id (cdr local)) -1 (1+ count))))) (locals (cons local locals)) (info (clone info #:locals locals)) (info (clone info #:globals globals)) @@ -2499,7 +1963,7 @@ (wrap-as (append (i386:accu->base))) (.text ((expr->accu empty) initzer)) (wrap-as (i386:accu->base-mem+n offset))))))))) - (let* ((global (make-global-entry name type -2 (append-map (initzer->data info) initzers))) + (let* ((global (pke "2global: " (make-global-entry name type pointer (append-map (initzer->data info) initzers)))) (globals (append globals (list global)))) (clone info #:globals globals))))) @@ -2508,7 +1972,8 @@ (let* ((info (type->info info type)) (xtype type) (type (decl->ast-type type)) - (pointer -1) + (pointer (expr->pointer info `(type-spec ,type))) + (pointer (- -2 pointer)) (initzer-globals (filter identity (append-map (initzer->globals globals) initzers))) (global-names (map car globals)) (initzer-globals (filter (lambda (g) (and g (not (member (car g) global-names)))) initzer-globals)) @@ -2517,11 +1982,11 @@ (globals (append globals initzer-globals)) (info (clone info #:globals globals)) (size 4) - (count (p-expr->number info count)) + (count (expr->number info count)) (size (* count size))) (if (.function info) (let* ((local (car (add-local locals name type 1))) - (local (make-local-entry name type pointer (+ (local:id (cdr local)) -1 (quotient (+ size 3) 4)))) + (local (pke "3local: " (make-local-entry name type pointer (+ (local:id (cdr local)) -1 (quotient (+ size 3) 4))))) (locals (cons local locals)) (info (clone info #:locals locals)) (info (let loop ((info info) (initzers initzers) (id (local:id (cdr local)))) @@ -2530,7 +1995,7 @@ (info (append-text info (wrap-as (i386:accu->local id))))) (loop info (cdr initzers) (1- id))))))) info) - (let* ((global (make-global-entry name type pointer (append-map (initzer->data info) initzers))) + (let* ((global (pke "3global:" (make-global-entry name type pointer (append-map (initzer->data info) initzers)))) (globals (append globals (list global)))) (clone info #:globals globals))))) @@ -2539,7 +2004,7 @@ (xtype type) (type (decl->ast-type type)) (name (init-declr->name init)) - (pointer (init-declr->pointer init)) + (pointer (pke "pointer:" (init-declr->pointer init))) (initzer-globals (if (null? initzer) '() (filter identity (append-map (initzer->globals globals) initzer)))) (global-names (map car globals)) @@ -2559,15 +2024,15 @@ (if (.function info) (let* ((locals (if (or (> pointer 0) (<= size 4)) (add-local locals name type pointer) (let* ((local (car (add-local locals name type 1))) - (local (make-local-entry name type pointer (+ (local:id (cdr local)) -1 (quotient (+ size 3) 4))))) + (local (pke "4local:" (make-local-entry name type pointer (+ (local:id (cdr local)) -1 (quotient (+ size 3) 4)))))) (cons local locals)))) (info (clone info #:locals locals)) (info (if (null? initzer) info ((initzer->accu info) (car initzer)))) ;; FIXME array...struct? (info (if (null? initzer) info (append-text info ((accu->ident info) name))))) info) - (let* ((global (make-global-entry name type pointer (if (null? initzer) (string->list (make-string size #\nul)) - (append-map (initzer->data info) initzer)))) + (let* ((global (pke "4global:" (make-global-entry name type pointer (if (null? initzer) (string->list (make-string size #\nul)) + (append-map (initzer->data info) initzer))))) (globals (append globals (list global)))) (clone info #:globals globals))))) @@ -2808,7 +2273,7 @@ ((enum-defn (ident ,name) . _) name))) (i (pmatch field ((enum-defn ,name) i) - ((enum-defn ,name ,exp) (p-expr->number #f exp)) + ((enum-defn ,name ,exp) (expr->number #f exp)) (_ (error "not supported enum field=~s\n" field))))) (loop (cdr fields) (1+ i) @@ -2843,7 +2308,7 @@ (int->bv32 (+ base offset)))) (() (int->bv32 0)) ((initzer ,p-expr) - (int->bv32 (p-expr->number info p-expr))) + (int->bv32 (expr->number info p-expr))) (_ (error "initzer->data: unsupported: " o))))) (define (initzer->accu info) diff --git a/scaffold/tests/7c-dynarray.c b/scaffold/tests/7c-dynarray.c index 01a6b6be..ab76cb9c 100644 --- a/scaffold/tests/7c-dynarray.c +++ b/scaffold/tests/7c-dynarray.c @@ -46,9 +46,18 @@ add (void *ptab, int *nb_ptr, void *data) *nb_ptr = nb; } -typedef struct file { +typedef struct file4 { char name[4]; -} file_struct; +} file4_struct; + +typedef struct file12 { + int foo; + int bar; + char name[4]; +} file12_struct; + +//#define file file4 +#define file file12 struct state { int bla; @@ -81,9 +90,10 @@ test () eputs ("&PATHS="); eputs (itoa (&s->paths)); eputs ("\n"); eputs ("&FILES="); eputs (itoa (&s->files)); eputs ("\n"); - struct file *fs; - eputs ("foo\n"); - fs = s->files[0]; + // struct file *fs; + // eputs ("foo\n"); + // fs = s->files[0]; + struct file *fs = s->files[0]; eputs ("add s= "); eputs (itoa (s)); eputs ("\n"); eputs ("add fs= "); eputs (itoa (fs)); eputs ("\n"); eputs ("&fs->[0]="); eputs (itoa (fs->name)); eputs ("\n"); diff --git a/scaffold/tests/7k-for-each-elem.c b/scaffold/tests/7k-for-each-elem.c index bb93f3d5..2abf2637 100644 --- a/scaffold/tests/7k-for-each-elem.c +++ b/scaffold/tests/7k-for-each-elem.c @@ -31,7 +31,8 @@ struct sym { }; -struct sym tab[3] = {"foo", 0, "bar", 1, "baz", 2}; +struct sym tab3[3] = {"foo", 0, "bar", 1, "baz", 2}; +struct sym tab[] = {"foo", 0, "bar", 1, "baz", 2}; struct section section; @@ -45,10 +46,11 @@ struct section section; int test () { + struct sym* p; + p = tab3; section.data = tab; section.offset = 24; - struct sym* p; int size = sizeof (struct sym); eputs ("size="); eputs (itoa (size)); eputs ("\n"); if (size != 8) return 1; diff --git a/scaffold/tests/7m-struct-char-array-assign.c b/scaffold/tests/7m-struct-char-array-assign.c new file mode 100644 index 00000000..ea02363c --- /dev/null +++ b/scaffold/tests/7m-struct-char-array-assign.c @@ -0,0 +1,42 @@ +/* -*-comment-start: "//";comment-end:""-*- + * Mes --- Maxwell Equations of Software + * Copyright © 2017 Jan 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 . + */ + +#include "30-test.i" + +struct file { + char *ptr; + char buffer[20]; +}; + +int +test () +{ + struct file f; + f.ptr = f.buffer; + + eputs ("***\n"); + f.ptr[0] = 'X'; + eputs ("***\n"); + f.ptr[1] = 'X'; + + eputs (f.ptr); eputs ("\n"); + + return 0; +}