From a1862f749f58b7f4db4af7a5ac860a16b2683e89 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Thu, 10 May 2018 12:40:07 +0200 Subject: [PATCH] mescc: Refactor type system: WIP * module/language/c99/compiler.mes (): WIP * module/language/c99/info.scm (): WIP --- build-aux/check-mescc.sh | 3 - module/language/c99/compiler.mes | 994 +++++++++++++--------------- module/language/c99/info.scm | 24 +- scaffold/tests/23-pointer.c | 29 +- scaffold/tests/46-function-static.c | 5 +- scaffold/tests/64-make-cell.c | 4 - scaffold/tests/t.c | 8 + 7 files changed, 480 insertions(+), 587 deletions(-) diff --git a/build-aux/check-mescc.sh b/build-aux/check-mescc.sh index dd2d5b62..2f52620d 100755 --- a/build-aux/check-mescc.sh +++ b/build-aux/check-mescc.sh @@ -232,9 +232,6 @@ broken="$broken 42_function_pointer 46_grep 49_bracket_evaluation - -52_unnamed_enum -55_lshift_type " #22_floating_point ; float diff --git a/module/language/c99/compiler.mes b/module/language/c99/compiler.mes index 7947a019..c810ee9f 100644 --- a/module/language/c99/compiler.mes +++ b/module/language/c99/compiler.mes @@ -138,7 +138,6 @@ (cons `(tag ,name) (make-type 'enum 4 fields))) (define (struct->type-entry name fields) - (stderr "struct->type-entry name=~s fields=~s\n" name fields) (let ((size (apply + (map (compose ->size cdr) fields)))) (cons `(tag ,name) (make-type 'struct size fields)))) @@ -196,11 +195,137 @@ ((,name . ,type) (->size type)) (_ (error (format #f "field:size: ~s\n" o))))) -(define (ast->type info o) - (let ((type (-> (ast-> o info)))) +(define (ast->type o info) + (define (type-helper o info) + (pmatch o + (,t (guard (type? t)) t) + (,p (guard (pointer? p)) p) + (,a (guard (c-array? a)) a) + + ((char ,value) (get-type "char" info)) + ((enum-ref . _) (get-type "int" info)) + ((fixed ,value) (get-type "int" info)) + ((sizeof-expr . _) (get-type "int" info)) + ((sizeof-type . _) (get-type "int" info)) + ((string _) (make-c-array (get-type "char" info) #f)) + ((void) (get-type "void" info)) + + ((type-name ,type) (ast->type type info)) + ((type-name ,type (abs-declr ,pointer)) + (let ((rank (pointer->rank pointer))) + (rank+= (ast->type type info) rank))) + + ((ident ,name) (ident->type info name)) + ((tag ,name) (or (get-type o info) + o)) + + (,name (guard (string? name)) + (let ((type (get-type name info))) + (ast->type type info))) + + ((fctn-call (p-expr (ident ,name)) . _) (or (ident->type info name) + (get-type "int" info))) + + ((fixed-type ,type) (ast->type type info)) + ((float-type ,type) (ast->type type info)) + ((type-spec ,type) (ast->type type info)) + ((typename ,type) (ast->type type info)) + + ((array-ref ,index ,array) (rank-- (ast->type array info))) + + ((de-ref ,expr) (rank-- (ast->type expr info))) + ((ref-to ,expr) (rank++ (ast->type expr info))) + + ((p-expr ,expr) (ast->type expr info)) + ((pre-inc ,expr) (ast->type expr info)) + ((post-inc ,expr) (ast->type expr info)) + + ((struct-ref (ident ,type)) + (or (get-type type info) + (let ((struct (if (pair? type) type `(tag ,type)))) + (ast->type struct info)))) + ((union-ref (ident ,type)) + (or (get-type type info) + (let ((struct (if (pair? type) type `(tag ,type)))) + (ast->type struct info)))) + + ((struct-def (ident ,name) . _) + (ast->type `(tag ,name) info)) + ((union-def (ident ,name) . _) + (ast->type `(tag ,name) info)) + ((struct-def (field-list . ,fields)) + (let ((fields (append-map (struct-field info) fields))) + (make-type 'struct (apply + (map field:size fields)) fields))) + ((union-def (field-list . ,fields)) + (let ((fields (append-map (struct-field info) fields))) + (make-type 'union (apply + (map field:size fields)) fields))) + ((enum-def (enum-def-list . ,fields)) + (get-type "int" info)) + + ((d-sel (ident ,field) ,struct) + (let ((type0 (ast->type struct info))) + (ast->type (field-type info type0 field) info))) + + ((i-sel (ident ,field) ,struct) + (let ((type0 (ast->type (rank-- (ast->type struct info)) info))) + (ast->type (field-type info type0 field) info))) + + ;; arithmetic + ((pre-inc ,a) (ast->type a info)) + ((pre-dec ,a) (ast->type a info)) + ((post-inc ,a) (ast->type a info)) + ((post-dec ,a) (ast->type a info)) + ((add ,a ,b) (ast->type a info)) + ((sub ,a ,b) (ast->type a info)) + ((bitwise-and ,a ,b) (ast->type a info)) + ((bitwise-not ,a) (ast->type a info)) + ((bitwise-or ,a ,b) (ast->type a info)) + ((bitwise-xor ,a ,b) (ast->type a info)) + ((lshift ,a ,b) (ast->type a info)) + ((rshift ,a ,b) (ast->type a info)) + ((div ,a ,b) (ast->type a info)) + ((mod ,a ,b) (ast->type a info)) + ((mul ,a ,b) (ast->type a info)) + ((not ,a) (ast->type a info)) + ((neg ,a) (ast->type a info)) + ((eq ,a ,b) (ast->type a info)) + ((ge ,a ,b) (ast->type a info)) + ((gt ,a ,b) (ast->type a info)) + ((ne ,a ,b) (ast->type a info)) + ((le ,a ,b) (ast->type a info)) + ((lt ,a ,b) (ast->type a info)) + + ;; logical + ((or ,a ,b) (ast->type a info)) + ((and ,a ,b) (ast->type a info)) + + ((cast (type-name ,type) ,expr) (ast->type type info)) + + ((cast (type-name ,type (abs-declr ,pointer)) ,expr) + (let ((rank (pointer->rank pointer))) + (rank+= (ast->type type info) rank))) + + ((decl-spec-list (type-spec ,type)) + (ast->type type info)) + ((assn-expr ,a ,op ,b) + (ast->type a info)) + + (_ (get-type o info)))) + + (let ((type (type-helper o info))) + (cond ((or (type? type) + (pointer? type) type + (c-array? type)) type) + ((and (equal? type o) (pair? type) (eq? (car type) 'tag)) o) + ((equal? type o) + (error "ast->type: not supported: " o)) + (else (ast->type type info))))) + +(define (ast->basic-type o info) + (let ((type (->type (ast->type o info)))) (cond ((type? type) type) ((equal? type o) o) - (else (ast->type info type))))) + (else (ast->type type info))))) (define (get-type o info) (let ((t (assoc-ref (.types info) o))) @@ -208,132 +333,15 @@ ((typedef ,next) (or (get-type next info) o)) (_ t)))) -(define (ast-> o info) - (pmatch o - (,t (guard (type? t)) t) - (,p (guard (pointer? p)) p) - (,a (guard (c-array? a)) a) - - ((char ,value) (get-type "char" info)) - ((enum-ref . _) (get-type "int" info)) - ((fixed ,value) (get-type "int" info)) - ((sizeof-expr . _) (get-type "int" info)) - ((sizeof-type . _) (get-type "int" info)) - ((string _) (make-c-array (get-type "char" info) #f)) - ((void) (get-type "void" info)) - - ((ident ,name) (ident->type info name)) - ((fctn-call (p-expr (ident ,name)) . _) (ident->type info name)) - - - ((fixed-type ,type) (ast-> type info)) - ((float-type ,type) (ast-> type info)) - ((typename ,type) (ast-> type info)) - - ((array-ref ,index ,array) (rank-- (ast-> array info))) - - ((de-ref ,expr) (rank-- (ast-> expr info))) - ((ref-to ,expr) (rank++ (ast-> expr info))) - - ((p-expr ,expr) (ast-> expr info)) - ((pre-inc ,expr) (ast-> expr info)) - ((post-inc ,expr) (ast-> expr info)) - - ((type-spec (typename ,type)) (ast-> type info)) - - ((struct-ref (ident ,type)) - (or (get-type type info) - (let ((struct (if (pair? type) type `(tag ,type)))) - (ast-> struct info)))) - ((union-ref (ident ,type)) - (or (get-type type info) - (let ((struct (if (pair? type) type `(tag ,type)))) - (ast-> struct info)))) - - ;;; - ((struct-def (ident ,name) . _) - (ast-> `(tag ,name) info)) - ((union-def (ident ,name) . _) - (ast-> `(tag ,name) info)) - ((struct-def (field-list . ,fields)) - (let ((fields (append-map (struct-field info) fields))) - (make-type 'struct (apply + (map field:size fields)) fields))) - ((union-def (field-list . ,fields)) - (let ((fields (append-map (struct-field info) fields))) - (make-type 'union (apply + (map field:size fields)) fields))) - - - - ((d-sel (ident ,field) ,struct) - (let ((type0 (ast-> struct info))) - (ast-> (field-type info type0 field) info))) - ((i-sel (ident ,field) ,struct) - (let ((type0 (ast-> struct info))) - (ast-> (field-type info type0 field) info))) - - ;; arithmetic - ((pre-inc ,a) (ast-> a info)) - ((pre-dec ,a) (ast-> a info)) - ((post-inc ,a) (ast-> a info)) - ((post-dec ,a) (ast-> a info)) - ((add ,a ,b) (ast-> a info)) - ((sub ,a ,b) (ast-> a info)) - ((bitwise-and ,a ,b) (ast-> a info)) - ((bitwise-not ,a) (ast-> a info)) - ((bitwise-or ,a ,b) (ast-> a info)) - ((bitwise-xor ,a ,b) (ast-> a info)) - ((lshift ,a ,b) (ast-> a info)) - ((rshift ,a ,b) (ast-> a info)) - ((div ,a ,b) (ast-> a info)) - ((mod ,a ,b) (ast-> a info)) - ((mul ,a ,b) (ast-> a info)) - ((not ,a) (ast-> a info)) - ((neg ,a) (ast-> a info)) - ((eq ,a ,b) (ast-> a info)) - ((ge ,a ,b) (ast-> a info)) - ((gt ,a ,b) (ast-> a info)) - ((ne ,a ,b) (ast-> a info)) - ((le ,a ,b) (ast-> a info)) - ((lt ,a ,b) (ast-> a info)) - - ;; logical - ((or ,a ,b) (ast-> a info)) - ((and ,a ,b) (ast-> a info)) - - - ((cast (type-name ,type) ,expr) ; FIXME: ignore expr? - (ast-> type info)) - ((cast (type-name ,type (abs-declr ,pointer)) ,expr) ; FIXME: ignore expr? - (ast-> type info)) - - ((decl-spec-list (type-spec ,type)) - (ast-> type info)) - ((assn-expr ,a ,op ,b) - (ast-> a info)) - - - (_ (let ((type (get-type o info))) - (cond ((type? type) type) - ((and (pair? type) (eq? (car type) 'tag)) - (stderr "NO STRUCT YET:~s\n" (.types info)) - type) - ((and (pair? o) (eq? (car o) 'tag)) - (stderr "NO STRUCT YET:~s\n" (.types info)) - o) - (else - (stderr "types: ~s\n" (.types info)) - (error "ast->type: not supported: " o))))))) - -(define (ast-type->description info o) - ((compose type:description (cut ast->type info <>) o))) (define (ast-type->size info o) - ((compose type:size -> (cut ast->type info <>)) o)) + (let ((type (->type (ast->type o info)))) + (cond ((type? type) (type:size type)) + (else (stderr "ast-type->size barf: ~s => ~s\n" o type) + 4)))) (define (field-field info struct field) - (let* ((xtype (if (type? struct) struct - (ast->type info struct))) - (fields (type:description xtype))) + (let* ((fields (type:description struct))) (let loop ((fields fields)) (if (null? fields) (error (format #f "no such field: ~a in ~s" field struct)) (let ((f (car fields))) @@ -343,42 +351,38 @@ (else (loop (cdr fields))))))))) (define (field-offset info struct field) - (let ((xtype (if (type? struct) struct - (ast->type info struct)))) - (if (eq? (type:type xtype) 'union) 0 - (let ((fields (type:description xtype))) - (let loop ((fields fields) (offset 0)) - (if (null? fields) (error (format #f "no such field: ~a in ~s" field struct)) - (let ((f (car fields))) - (cond ((equal? (car f) field) offset) - ((and (eq? (car f) 'struct) (type? (cdr f))) - (let ((fields (type:description (cdr f)))) - (find (lambda (x) (equal? (car x) field)) fields) - (apply + (cons offset - (map field:size - (member field (reverse fields) - (lambda (a b) - (equal? a (car b) field)))))))) - ((and (eq? (car f) 'union) (type? (cdr f))) - (let ((fields (type:description (cdr f)))) - (find (lambda (x) (equal? (car x) field)) fields) - offset)) - (else (loop (cdr fields) (+ offset (field:size f)))))))))))) + (if (eq? (type:type struct) 'union) 0 + (let ((fields (type:description struct))) + (let loop ((fields fields) (offset 0)) + (if (null? fields) (error (format #f "no such field: ~a in ~s" field struct)) + (let ((f (car fields))) + (cond ((equal? (car f) field) offset) + ((and (eq? (car f) 'struct) (type? (cdr f))) + (let ((fields (type:description (cdr f)))) + (find (lambda (x) (equal? (car x) field)) fields) + (apply + (cons offset + (map field:size + (member field (reverse fields) + (lambda (a b) + (equal? a (car b) field)))))))) + ((and (eq? (car f) 'union) (type? (cdr f))) + (let ((fields (type:description (cdr f)))) + (find (lambda (x) (equal? (car x) field)) fields) + offset)) + (else (loop (cdr fields) (+ offset (field:size f))))))))))) (define (field-pointer info struct field) (let ((field (field-field info struct field))) (field:pointer field))) (define (field-size info struct field) - (let ((xtype (if (type? struct) struct - (ast->type info struct)))) - (if (eq? (type:type xtype) 'union) 0 - (let ((field (field-field info struct field))) - (field:size field))))) + (if (eq? (type:type struct) 'union) 0 + (let ((field (field-field info struct field))) + (field:size field)))) (define (field-type info struct field) (let ((field (field-field info struct field))) - (cdr field))) + (ast->type (cdr field) info))) (define (struct->fields o) (pmatch o @@ -401,14 +405,21 @@ (define (ident->variable info o) (or (assoc-ref (.locals info) o) - (assoc-ref (.globals info) o) (assoc-ref (.statics info) o) + (assoc-ref (filter (negate static-global?) (.globals info)) o) (assoc-ref (.constants info) o) (assoc-ref (.functions info) o) (begin (stderr "info=~s\n" info) (error "ident->variable: undefined variabled:" o)))) +(define (static-global? o) + ((compose global:function cdr) o)) + +(define (string-global? o) + (and (pair? (car o)) + (eq? (caar o) #:string))) + (define (ident->type info o) (let ((var (ident->variable info o))) (cond ((global? var) (global:type var)) @@ -419,128 +430,33 @@ (else (stderr "ident->type ~s => ~s\n" o var) #f)))) +(define (local:pointer o) + (->rank o)) + (define (ident->rank info o) - (let ((local (assoc-ref (.locals info) o))) - (if local (let* ((t 0 ;; ((compose type:pointer local:type) local) - ) - (v (local:pointer local)) - (p (+ (abs t) (abs v)))) - (if (or (< t 0) (< v 0)) (- p) p)) - (let ((global (assoc-ref (.globals info) o))) - (if global - (let* ((t 0 ;; ((compose type:pointer global:type) global) - ) - (v (global:pointer global)) - (p (+ (abs t) (abs v)))) - (if (or (< t 0) (< v 0)) (- p) p)) - 0))))) + (->rank (ident->variable info o))) (define (ident->size info o) - ((compose type:size (cut ident->type info <>)) o)) + ((compose type:size (cut ident->type info <>)) o)) -(define (ptr-inc o) - (if (< o 0) (1- o) - (1+ o))) - -(define (ptr-dec o) - (if (< o 0) (1+ o) - (1- o))) - -(define (pointer->ptr o) +(define (pointer->rank o) (pmatch o ((pointer) 1) - ((pointer ,pointer) (1+ (pointer->ptr pointer))))) + ((pointer ,pointer) (1+ (pointer->rank pointer))))) (define (expr->rank info o) - (pmatch o - ((pointer . _) (pointer->ptr o)) - ((p-expr (char ,value)) 0) - ((p-expr (fixed ,value)) 0) - ((ident ,name) (ident->rank info name)) - ((p-expr ,expr) (expr->rank info expr)) - ((de-ref ,expr) (ptr-dec (expr->rank info expr))) - ((assn-expr ,lhs ,op ,rhs) (expr->rank info lhs)) - ((add ,a ,b) (expr->rank info a)) - ((div ,a ,b) (expr->rank info a)) - ((mod ,a ,b) (expr->rank info a)) - ((mul ,a ,b) (expr->rank info a)) - ((sub ,a ,b) (expr->rank info a)) - ((neg ,a) (expr->rank info a)) - ((pre-inc ,a) (expr->rank info a)) - ((pre-dec ,a) (expr->rank info a)) - ((post-inc ,a) (expr->rank info a)) - ((post-dec ,a) (expr->rank info a)) - ((ref-to ,expr) (ptr-inc (expr->rank info expr))) - ((array-ref ,index ,array) - (ptr-dec (abs (expr->rank info array)))) + (->rank (ast->type o info))) - ((d-sel (ident ,field) ,struct) - (let ((type (ast->type info struct))) - (field-pointer info type field))) - - ((i-sel (ident ,field) ,struct) - (let ((type (ast->type info struct))) - (field-pointer info type field))) - - ((cast (type-name ,type) ,expr) ; FIXME: add expr? - (let* ((type (ast->type info type))) - (->rank type))) - ((cast (type-name ,type (abs-declr ,pointer)) ,expr) ; FIXME: add expr? - (let* ((type (ast->type info type)) - (pointer0 (->rank type)) - (pointer1 (ptr-declr->rank pointer)) - (pointer2 (expr->rank info expr))) - (+ pointer0 pointer1))) - ((type-spec ,type) - (or (and=> (ast->type info o) ->rank) - (begin - (stderr "expr->rank: not supported: ~a\n" o) - 0))) - ((fctn-call (p-expr (ident ,function)) . ,rest) - (or (and=> (and=> (assoc-ref (.functions info) function) function:type) - (lambda (t) - (and (type? t) 0 (->rank t)))) - (begin - (stderr "expr->rank: no such function: ~a\n" function) - 0))) - - ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr ,pointer ,init) . ,initzer))) - (let* ((t (expr->rank info `(type-spec ,type))) - (i (expr->rank info init)) - (p (expr->rank info pointer)) - (e (+ (abs t) (abs i) (abs p)))) - (if (or (< t 0) (< i 0)) (- e) e))) - ((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr ,init . ,initzer))) - (let* ((t (expr->rank info `(type-spec ,type))) - (i (expr->rank info init)) - (p (+ (abs t) (abs i)))) - (if (or (< t 0) (< i 0)) (- p) p))) - ((ptr-declr ,pointer (array-of ,array . ,rest)) - (let* ((p (expr->rank info pointer)) - (a (expr->rank info array)) - (t (+ (abs p) (abs a) 2))) - (- t))) - ((ptr-declr ,pointer . ,rest) - (expr->rank info pointer)) - ((array-of ,array . ,rest) - (let ((a (abs (expr->rank info array)))) - (- (+ a 1)))) - (_ (stderr "expr->rank: not supported: ~s\n" o) 0))) - -(define (expr->size info o) - (let ((ptr (expr->rank info o))) - (if (or (= ptr -1) - (= ptr 0)) - (ast-type->size info o) - %pointer-size))) +(define (ast->size o info) + (->size (ast->type o info))) (define (append-text info text) (clone info #:text (append (.text info) text))) (define (push-global info) (lambda (o) - (let ((ptr (ident->rank info o))) - (cond ((< ptr 0) (list (i386:push-label `(#:address ,o)))) + (let ((rank (ident->rank info o))) + (cond ((< rank 0) (list (i386:push-label `(#:address ,o)))) ;; FIXME (else (list (i386:push-label-mem `(#:address ,o)))))))) (define (push-local locals) @@ -555,80 +471,84 @@ (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))) + (let ((size (->size o))) (case size ((1) (wrap-as (i386:push-byte-local-de-ref (local:id o)))) ((2) (wrap-as (i386:push-word-local-de-ref (local:id o)))) ((4) (wrap-as (i386:push-local-de-ref (local:id o)))) (else (error (format #f "TODO: push size >4: ~a\n" size))))))) + ;; (if (= ptr 2) (ast-type->size info (local:type o)) ;; URG + ;; 4) (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))) + (let ((size (->size (rank-- (rank-- o))))) (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 name type pointer array value) - (cons name (make-global name type pointer array value #f))) +(define (make-global-entry name type value) + (cons name (make-global name type value #f))) (define (string->global-entry string) (let ((value (append (string->list string) (list #\nul)))) - (make-global-entry `(#:string ,string) "char" 0 (length value) value))) + (make-global-entry `(#:string ,string) "char" value))) ;; FIXME char-array -(define (make-local-entry name type pointer array id) - (cons name (make-local name type pointer array id))) +(define (make-local-entry name type id) + (cons name (make-local name type id))) (define* (mescc:trace name #:optional (type "")) (format (current-error-port) " :~a~a\n" name type)) (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)))))))))) + (cond ((assoc-ref (.locals info) o) + => + (push-local (.locals info))) + ((assoc-ref (.statics info) o) + => + (push-global info)) + ((assoc-ref (filter (negate static-global?) (.globals info)) o) + => + (push-global info)) + ((assoc-ref (.constants info) o) + => + (lambda (constant) + (wrap-as (append (i386:value->accu constant) + (i386:push-accu))))) + (else + ((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)))))))) + (cond ((assoc-ref (.locals info) o) + => + (push-local-address (.locals info))) + ((assoc-ref (.statics info) o) + => + (push-global-address info)) + ((assoc-ref (filter (negate static-global?) (.globals info)) o) + => + (push-global-address info)) + (else + ((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))))) + (cond ((assoc-ref (.locals info) o) + => + (push-local-de-ref info)) + (else ((push-global 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"))))) + (cond ((assoc-ref (.locals info) o) + => + (push-local-de-de-ref info)) + (else + (error "not supported: global push-ident-de-de-ref:" o))))) (define (expr->arg info) (lambda (o) @@ -646,37 +566,33 @@ (if (assoc-ref globals string) globals (append globals (list (string->global-entry o))))))) -(define (local->accu o) - (let* ((ptr (local:pointer o)) - (type (local:type o)) - (size (if (= ptr 0) (type:size type) - 4))) - (cond ((< ptr 0) (wrap-as (i386:local-ptr->accu (local:id o)))) - (else (wrap-as (case size - ((1) (i386:byte-local->accu (local:id o))) - ((2) (i386:word-local->accu (local:id o))) - (else (i386:local->accu (local:id o))))))))) - (define (ident->accu info) (lambda (o) (cond ((assoc-ref (.locals info) o) => local->accu) - ((assoc-ref (.statics info) o) - => - (lambda (global) - (let* ((ptr (ident->rank info o))) - (cond ((< ptr 0) (list (i386:label->accu `(#:address ,global)))) - (else (list (i386:label-mem->accu `(#:address ,global)))))))) - ((assoc-ref (.globals info) o) - => - (lambda (global) - (let* ((ptr (ident->rank info o))) - (cond ((< ptr 0) (list (i386:label->accu `(#:address ,o)))) - (else (list (i386:label-mem->accu `(#:address ,o)))))))) - ((assoc-ref (.constants info) o) - => - (lambda (constant) (wrap-as (i386:value->accu constant)))) + ((assoc-ref (.statics info) o) => global->accu) + ((assoc-ref (filter (negate static-global?) (.globals info)) o) => global->accu) + ((assoc-ref (.constants info) o) => number->accu) (else (list (i386:label->accu `(#:address ,o))))))) +(define (local->accu o) + (let* ((type (local:type o))) + (cond ((or (c-array? type) + (structured-type? type)) (wrap-as (i386:local-ptr->accu (local:id o)))) + (else (let ((size (->size o))) + (wrap-as (case size + ((1) (i386:byte-local->accu (local:id o))) + ((2) (i386:word-local->accu (local:id o))) + (else (i386:local->accu (local:id o)))))))))) + +(define (global->accu o) + (let ((type (global:type o))) + (cond ((or (c-array? type) + (structured-type? type)) (wrap-as (i386:label->accu `(#:address ,o)))) + (else (wrap-as (i386:label-mem->accu `(#:address ,o))))))) + +(define (number->accu o) + (wrap-as (i386:value->accu o))) + (define (ident-address->accu info) (lambda (o) (cond ((assoc-ref (.locals info) o) @@ -685,7 +601,7 @@ ((assoc-ref (.statics info) o) => (lambda (global) (list (i386:label->accu `(#:address ,global))))) - ((assoc-ref (.globals info) o) + ((assoc-ref (filter (negate static-global?) (.globals info)) o) => (lambda (global) (list (i386:label->accu `(#:address ,global))))) (else (list (i386:label->accu `(#:address ,o))))))) @@ -699,7 +615,7 @@ ((assoc-ref (.statics info) o) => (lambda (global) (list (i386:label->base `(#:address ,global))))) - ((assoc-ref (.globals info) o) + ((assoc-ref (filter (negate static-global?) (.globals info)) o) => (lambda (global) (list (i386:label->base `(#:address ,global))))) (else (list (i386:label->base `(#:address ,o))))))) @@ -709,7 +625,7 @@ (define (accu->local+n-text local n) (let* ((type (local:type local)) - (ptr (local:pointer local)) + (ptr (->rank local)) (size (if (= ptr -1) ((compose type:size local:type) local) 4)) (id (local:id local))) @@ -760,12 +676,6 @@ => (lambda (global) (list (i386:label-mem-add `(#:address ,global) n))))))) -(define (expr-add info) - (lambda (o n) - (let* ((info (expr->accu* o info)) - (info (append-text info (wrap-as (i386:accu-mem-add n))))) - info))) - (define (ident-address-add info) (lambda (o n) (cond ((assoc-ref (.locals info) o) @@ -787,15 +697,6 @@ (i386:accu-mem-add n) (i386:pop-accu))))))))) -(define (binop->accu info) - (lambda (a b c) - (let* ((info (expr->accu a info)) - (info (expr->base b info))) - (append-text info (wrap-as c))))) - -(define (wrap-as o . annotation) - `(,@annotation ,o)) - (define (make-comment o) (wrap-as `((#:comment ,o)))) @@ -864,19 +765,19 @@ (expr->accu expr info)) ((d-sel (ident ,field) ,struct) - (let* ((type (ast->type info struct)) + (let* ((type (ast->basic-type struct info)) (offset (field-offset info type field)) (info (expr->accu* struct info))) (append-text info (wrap-as (i386:accu+value offset))))) ((i-sel (ident ,field) (fctn-call (p-expr (ident ,function)) . ,rest)) - (let* ((type (ast->type info `(fctn-call (p-expr (ident ,function)) ,@rest))) + (let* ((type (ast->basic-type `(fctn-call (p-expr (ident ,function)) ,@rest) info)) (offset (field-offset info type field)) (info (expr->accu `(fctn-call (p-expr (ident ,function)) ,@rest) info))) (append-text info (wrap-as (i386:accu+value offset))))) ((i-sel (ident ,field) ,struct) - (let* ((type (ast->type info struct)) + (let* ((type (ast->basic-type struct info)) (offset (field-offset info type field)) (info (expr->accu* struct info))) (append-text info (append (wrap-as (i386:mem->accu)) @@ -884,14 +785,19 @@ ((array-ref ,index ,array) (let* ((info (expr->accu index info)) - (ptr (expr->rank info array)) - (size (expr->size info o)) + (size (ast->size o info)) (info (accu*n info size)) (info (expr->base array info))) (append-text info (wrap-as (i386:accu+base))))) (_ (error "expr->accu*: not supported: " o)))) +(define (expr-add info) + (lambda (o n) + (let* ((info (expr->accu* o info)) + (info (append-text info (wrap-as (i386:accu-mem-add n))))) + info))) + (define (expr->accu o info) (let ((locals (.locals info)) (constants (.constants info)) @@ -934,7 +840,7 @@ ;; offsetoff ((ref-to (i-sel (ident ,field) (cast (type-name (decl-spec-list ,struct) (abs-declr (pointer))) (p-expr (fixed ,base))))) - (let* ((type (ast->type info struct)) + (let* ((type (ast->basic-type struct info)) (offset (field-offset info type field)) (base (cstring->number base))) (append-text info (wrap-as (i386:value->accu (+ base offset)))))) @@ -951,29 +857,14 @@ (expr->accu* expr info)) ((sizeof-expr ,expr) - (append-text info (wrap-as (i386:value->accu (expr->size info expr))))) + (append-text info (wrap-as (i386:value->accu (ast->size expr info))))) - ((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 (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))))) + ((sizeof-type ,type) + (append-text info (wrap-as (i386:value->accu (ast->size type info))))) ((array-ref ,index ,array) (let* ((info (expr->accu* o info)) - (size (expr->size info o))) + (size (ast->size o info))) (append-text info (wrap-as (case size ((1) (i386:byte-mem->accu)) ((2) (i386:word-mem->accu)) @@ -983,7 +874,7 @@ ((d-sel ,field ,struct) (let* ((info (expr->accu* o info)) (info (append-text info (ast->comment o))) - (type (ast-> o info)) + (type (ast->type o info)) (size (->size type)) (array? (c-array? type))) (if array? info @@ -996,7 +887,7 @@ ((i-sel ,field ,struct) (let* ((info (expr->accu* o info)) (info (append-text info (ast->comment o))) - (type (ast-> o info)) + (type (ast->type o info)) (size (->size type)) (array? (c-array? type))) (if array? info @@ -1008,7 +899,7 @@ ((de-ref ,expr) (let* ((info (expr->accu expr info)) - (size (expr->size info o))) + (size (ast->size o info))) (append-text info (wrap-as (case size ((1) (i386:byte-mem->accu)) ((2) (i386:word-mem->accu)) @@ -1052,9 +943,9 @@ ((post-inc ,expr) (let* ((info (append (expr->accu expr info))) (info (append-text info (wrap-as (i386:push-accu)))) - (ptr (expr->rank info expr)) - (size (cond ((= ptr 1) (ast-type->size info expr)) - ((> ptr 1) 4) + (rank (expr->rank info expr)) + (size (cond ((= rank 1) (ast-type->size info expr)) + ((> rank 1) 4) (else 1))) (info ((expr-add info) expr size)) (info (append-text info (wrap-as (i386:pop-accu))))) @@ -1063,27 +954,27 @@ ((post-dec ,expr) (let* ((info (append (expr->accu expr info))) (info (append-text info (wrap-as (i386:push-accu)))) - (ptr (expr->rank info expr)) - (size (cond ((= ptr 1) (ast-type->size info expr)) - ((> ptr 1) 4) + (rank (expr->rank info expr)) + (size (cond ((= rank 1) (ast-type->size info expr)) + ((> rank 1) 4) (else 1))) (info ((expr-add info) expr (- size))) (info (append-text info (wrap-as (i386:pop-accu))))) info)) ((pre-inc ,expr) - (let* ((ptr (expr->rank info expr)) - (size (cond ((= ptr 1) (ast-type->size info expr)) - ((> ptr 1) 4) + (let* ((rank (expr->rank info expr)) + (size (cond ((= rank 1) (ast-type->size info expr)) + ((> rank 1) 4) (else 1))) (info ((expr-add info) expr size)) (info (append (expr->accu expr info)))) info)) ((pre-dec ,expr) - (let* ((ptr (expr->rank info expr)) - (size (cond ((= ptr 1) (ast-type->size info expr)) - ((> ptr 1) 4) + (let* ((rank (expr->rank info expr)) + (size (cond ((= rank 1) (ast-type->size info expr)) + ((> rank 1) 4) (else 1))) (info ((expr-add info) expr (- size))) (info (append (expr->accu expr info)))) @@ -1092,13 +983,12 @@ ((add ,a (p-expr (fixed ,value))) - (let* ((ptr (expr->rank info a)) - (type (ast->type info a)) + (let* ((rank (expr->rank info a)) + (type (ast->basic-type a info)) (struct? (structured-type? type)) - (size (cond ((= ptr 1) (ast-type->size info a)) - ((> ptr 1) 4) - ((and struct? (= ptr -2)) 4) - ((and struct? (= ptr 2)) 4) + (size (cond ((= rank 1) (ast-type->size info a)) + ((> rank 1) 4) + ((and struct? (= rank 2)) 4) (else 1))) (info (expr->accu a info)) (value (cstring->number value)) @@ -1106,14 +996,13 @@ (append-text info (wrap-as (i386:accu+value value))))) ((add ,a ,b) - (let* ((ptr (expr->rank info a)) - (ptr-b (expr->rank info b)) - (type (ast->type info a)) + (let* ((rank (expr->rank info a)) + (rank-b (expr->rank info b)) + (type (ast->basic-type a info)) (struct? (structured-type? type)) - (size (cond ((= ptr 1) (ast-type->size info a)) - ((> ptr 1) 4) - ((and struct? (= ptr -2)) 4) - ((and struct? (= ptr 2)) 4) + (size (cond ((= rank 1) (ast-type->size info a)) + ((> rank 1) 4) + ((and struct? (= rank 2)) 4) (else 1)))) (if (or (= size 1)) ((binop->accu info) a b (i386:accu+base)) (let* ((info (expr->accu b info)) @@ -1124,13 +1013,13 @@ (append-text info (wrap-as (i386:accu+base))))))) ((sub ,a (p-expr (fixed ,value))) - (let* ((ptr (expr->rank info a)) - (type (ast->type info a)) + (let* ((rank (expr->rank info a)) + (type (ast->basic-type a info)) (struct? (structured-type? type)) - (size (cond ((= ptr 1) (ast-type->size info a)) - ((> ptr 1) 4) - ((and struct? (= ptr -2)) 4) - ((and struct? (= ptr 2)) 4) + (size (->size type)) + (size (cond ((= rank 1) size) + ((> rank 1) 4) + ((and struct? (= rank 2)) 4) (else 1))) (info (expr->accu a info)) (value (cstring->number value)) @@ -1138,18 +1027,18 @@ (append-text info (wrap-as (i386:accu+value (- value)))))) ((sub ,a ,b) - (let* ((ptr (expr->rank info a)) - (ptr-b (expr->rank info b)) - (type (ast->type info a)) + (let* ((rank (expr->rank info a)) + (rank-b (expr->rank info b)) + (type (ast->basic-type a info)) (struct? (structured-type? type)) - (size (cond ((= ptr 1) (ast-type->size info a)) - ((> ptr 1) 4) - ((and struct? (= ptr -2)) 4) - ((and struct? (= ptr 2)) 4) + (size (->size type)) + (size (cond ((= rank 1) size) + ((> rank 1) 4) + ((and struct? (= rank 2)) 4) (else 1)))) - (if (or (= size 1) (or (= ptr-b -2) (= ptr-b 1))) + (if (or (= size 1) (or (= rank-b 2) (= rank-b 1))) (let ((info ((binop->accu info) a b (i386:accu-base)))) - (if (and (not (= ptr-b -2)) (not (= ptr-b 1))) info + (if (and (not (= rank-b 2)) (not (= rank-b 1))) info (append-text info (wrap-as (append (i386:value->base size) (i386:accu/base)))))) (let* ((info (expr->accu b info)) @@ -1230,35 +1119,33 @@ ((assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op ,op) ,b) (let* ((info (expr->accu `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b) info)) (type (ident->type info name)) - (ptr (ident->rank info name)) - (size (if (> ptr 1) 4 1))) + (rank (ident->rank info name)) + (size (if (> rank 1) 4 1))) (append-text info ((ident-add info) name size)))) ((assn-expr (de-ref (post-dec (p-expr (ident ,name)))) (op ,op) ,b) (let* ((info (expr->accu `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b) info)) (type (ident->type info name)) - (ptr (ident->rank info name)) - (size (if (> ptr 1) 4 1))) + (rank (ident->rank info name)) + (size (if (> rank 1) 4 1))) (append-text info ((ident-add info) name (- size))))) ((assn-expr ,a (op ,op) ,b) (let* ((info (append-text info (ast->comment o))) - (ptr-a (expr->rank info a)) - (ptr-b (expr->rank info b)) - (size-a (expr->size info a)) - (size-b (expr->size info b)) + (type (ast->type a info)) + (rank (->rank type)) + (type-b (ast->type b info)) + (rank-b (->rank type-b)) + (size (->size type)) + (size-b (->size type-b)) (info (expr->accu b info)) (info (if (equal? op "=") info - (let* ((ptr (expr->rank info a)) - (ptr-b (expr->rank info b)) - (type (ast->type info a)) - (struct? (structured-type? type)) - (size (cond ((= ptr 1) (ast-type->size info a)) - ((> ptr 1) 4) - ((and struct? (= ptr -2)) 4) - ((and struct? (= ptr 2)) 4) + (let* ((struct? (structured-type? type)) + (size (cond ((= rank 1) (ast-type->size info a)) + ((> rank 1) 4) + ((and struct? (= rank 2)) 4) (else 1))) - (info (if (or (= size 1) (= ptr-b 1)) info + (info (if (or (= size 1) (= rank-b 1)) info (let ((info (append-text info (wrap-as (i386:value->base size))))) (append-text info (wrap-as (i386:accu*base)))))) (info (append-text info (wrap-as (i386:push-accu)))) @@ -1275,28 +1162,28 @@ ((equal? op ">>=") (wrap-as (i386:accu>>base))) ((equal? op "<<=") (wrap-as (i386:accu<type info b))))))))) + (else (error (format #f "invalid operands to binary ~s (have ~s* and ~s*)" op type (ast->basic-type b info))))))))) (when (and (equal? op "=") - (not (= size-a size-b)) - (not (and (or (= size-a 1) (= size-a 2)) + (not (= size size-b)) + (not (and (or (= size 1) (= size 2)) (= size-b 4))) - (not (and (= size-a 2) + (not (and (= size 2) (= size-b 4))) - (not (and (= size-a 4) + (not (and (= size 4) (or (= size-b 1) (= size-b 2))))) (stderr "ERROR assign: ~a" (with-output-to-string (lambda () (pretty-print-c99 o)))) - (stderr " size[~a]:~a != size[~a]:~a\n" ptr-a size-a ptr-b size-b)) + (stderr " size[~a]:~a != size[~a]:~a\n" rank size rank-b size-b)) (pmatch a ((p-expr (ident ,name)) - (if (or (<= size-a 4) ;; FIXME: long long = int + (if (or (<= size 4) ;; FIXME: long long = int (<= size-b 4)) (append-text info ((accu->ident info) name)) (let ((info (expr->base* a info))) - (accu->base-mem*n info size-a)))) + (accu->base-mem*n info size)))) (_ (let ((info (expr->base* a info))) - (accu->base-mem*n info (min size-a (max 4 size-b)))))))) ;; FIXME: long long = int + (accu->base-mem*n info (min size (max 4 size-b)))))))) ;; FIXME: long long = int (_ (error "expr->accu: not supported: " o))))) @@ -1306,6 +1193,15 @@ (info (append-text info (wrap-as (append (i386:accu->base) (i386:pop-accu)))))) info)) +(define (binop->accu info) + (lambda (a b c) + (let* ((info (expr->accu a info)) + (info (expr->base b info))) + (append-text info (wrap-as c))))) + +(define (wrap-as o . annotation) + `(,@annotation ,o)) + (define (expr->base* o info) (let* ((info (append-text info (wrap-as (i386:push-accu)))) (info (expr->accu* o info)) @@ -1416,15 +1312,15 @@ (info (append-text info (wrap-as `((#:label ,skip-b-label)))))) info)) - ((array-ref ,index ,expr) (let* ((ptr (expr->rank info expr)) - (size (if (= ptr 1) (ast-type->size info expr) + ((array-ref ,index ,expr) (let* ((rank (expr->rank info expr)) + (size (if (= rank 1) (ast-type->size info expr) 4))) ((jump (if (= size 1) i386:jump-byte-z i386:jump-z) (wrap-as (i386:accu-zero?))) o))) - ((de-ref ,expr) (let* ((ptr (expr->rank info expr)) - (size (if (= ptr 1) (ast-type->size info expr) + ((de-ref ,expr) (let* ((rank (expr->rank info expr)) + (size (if (= rank 1) (ast-type->size info expr) 4))) ((jump (if (= size 1) i386:jump-byte-z i386:jump-z) @@ -1498,20 +1394,20 @@ (lambda (o) (pmatch o ((comp-decl (decl-spec-list (type-spec ,type)) (comp-declr-list (comp-declr (ident ,name)))) - (list (cons name (ast-> type info)))) + (list (cons name (ast->type type info)))) ((comp-decl (decl-spec-list (type-spec ,type)) (comp-declr-list (comp-declr (ptr-declr ,pointer (ident ,name))))) - (let ((rank (pointer->ptr pointer))) - (list (cons name (rank+= (ast-> type info) rank))))) + (let ((rank (pointer->rank pointer))) + (list (cons name (rank+= (ast->type type info) rank))))) ((comp-decl (decl-spec-list (type-spec ,type)) (comp-declr-list (comp-declr (ftn-declr (scope (ptr-declr ,pointer (ident ,name))) _)))) - (let ((rank (pointer->ptr pointer))) - (list (cons name (rank+= (ast-> type info) rank))))) + (let ((rank (pointer->rank pointer))) + (list (cons name (rank+= (ast->type type info) rank))))) ((comp-decl (decl-spec-list (type-spec ,type)) (comp-declr-list (comp-declr (ptr-declr ,pointer (array-of (ident ,name) ,count))))) - (let ((rank (pointer->ptr pointer)) + (let ((rank (pointer->rank pointer)) (count (expr->number info count))) (list (cons name (make-c-array (rank+= type rank) count))))) ((comp-decl (decl-spec-list (type-spec ,type)) (comp-declr-list (comp-declr (array-of (ident ,name) ,count)))) (let ((count (expr->number info count))) - (list (cons name (make-c-array (ast-> type info) count))))) + (list (cons name (make-c-array (ast->type type info) count))))) ((comp-decl (decl-spec-list (type-spec (struct-def (field-list . ,fields))))) (let ((fields (append-map (struct-field info) fields))) (list (cons 'struct (make-type 'struct (apply + (map field:size fields)) fields))))) @@ -1803,42 +1699,28 @@ (lambda (o) (cons (car o) (set-field (cdr o) (global:function) function)))) -(define (decl-local->info info) - (lambda (o) - (pmatch o - (((decl-spec-list (stor-spec (static)) (type-spec ,type)) (init-declr-list ,init)) - (let* ((function (.function info)) - (i (clone info #:function #f #:globals '())) - (i ((decl->info i `(decl (decl-spec-list (type-spec ,type)) (init-declr-list ,init))))) - (statics (map (global->static function) (.globals i)))) - (clone info #:statics (append statics (.statics info))))) - (_ #f)))) - -(define (decl-global->info info) - (lambda (o) - #f)) - (define (decl->info info o) (pmatch o (((decl-spec-list (type-spec ,type)) (init-declr-list . ,inits)) (let* ((info (type->info type #f info)) - (type (ast->type info type)) - (pointer 0)) ; FIXME - (fold (cut init-declr->info type pointer <> <>) info (map cdr inits)))) + (type (ast->type type info))) + (fold (cut init-declr->info type <> <>) info (map cdr inits)))) (((decl-spec-list (type-spec ,type))) (type->info type #f info)) (((decl-spec-list (stor-spec (typedef)) (type-spec ,type)) (init-declr-list (init-declr (ident ,name)))) (let* ((info (type->info type name info)) - (type (ast->type info type))) + (type (ast->type type info))) (clone info #:types (acons name type (.types info))))) (((decl-spec-list (stor-spec (,store)) (type-spec ,type)) (init-declr-list . ,inits)) - (let* ((type (ast->type info type)) - (pointer 0) ; FIXME - (function (.function info)) - (tmp (clone info #:function #f #:globals '())) - (tmp (fold (cut init-declr->info type pointer <> <>) tmp (map cdr inits))) - (statics (map (global->static function) (.globals tmp)))) - (clone info #:statics (append statics (.statics info))))) + (let* ((type (ast->type type info)) + (function (.function info))) + (if (not function) (fold (cut init-declr->info type <> <>) info (map cdr inits)) + (let* ((tmp (clone info #:function #f #:globals '())) + (tmp (fold (cut init-declr->info type <> <>) tmp (map cdr inits))) + (statics (map (global->static function) (.globals tmp))) + (strings (filter string-global? (.globals tmp)))) + (clone info #:globals (append (.globals info) strings) + #:statics (append statics (.statics info))))))) (((@ . _)) (stderr "decl->info: skip: ~s\n" o) info) @@ -1870,7 +1752,6 @@ (define (init-struct-field local field init info) (let* ((offset (field-offset info (local:type local) (car field))) - (pointer (field:pointer field)) (size (field:size field)) (empty (clone info #:text '()))) (clone info #:text @@ -1904,6 +1785,7 @@ ((2) (i386:word-accu->base-mem+n offset)) (else (i386:accu->base-mem+n offset)))))))) + (define (init-local local o n info) (pmatch o (#f info) @@ -1912,7 +1794,7 @@ ((initzer-list ,init) (init-local local init n info)) ((initzer-list . ,inits) - (let ((struct? (pke 'struct? local '=> (structured-type? local)))) + (let ((struct? (structured-type? local))) (cond (struct? (let ((fields ((compose struct->fields local:type) local))) (fold (cut init-struct-field local <> <> <>) info fields (append inits (map (const '(p-expr (fixed "22"))) (iota (max 0 (- (length fields) (length inits))))))))) @@ -1923,35 +1805,55 @@ (_ (let ((info (init->accu o info))) (append-text info (accu->local+n-text local n)))))) -(define (local->info type pointer array name o init info) +(define (local->info type name o init info) (let* ((locals (.locals info)) (id (if (or (null? locals) (not (local-var? (cdar locals)))) 1 (1+ (local:id (cdar locals))))) - (local (make-local-entry name type pointer array id)) - (struct? (and (or (zero? pointer) - (= -1 pointer)) - (structured-type? type))) - (size (or (and (zero? pointer) (type? type) (type:size type)) - (and struct? (and=> (ast->type info type) ->size)) - 4)) + (local (make-local-entry name type id)) + (pointer (->rank (cdr local))) + (array (or (and (c-array? type) type) + (and (pointer? type) (c-array? (pointer:type type)) + (pointer:type type)) + (and (pointer? type) + (pointer? (pointer:type type)) + (c-array? (pointer:type (pointer:type type))) + (pointer:type (pointer:type type))))) + (struct? (structured-type? type)) + (size (->size type)) + (count (and (c-array? array) (c-array:count array))) (local (if (not array) local - (make-local-entry name type pointer array (+ (local:id (cdr local)) -1 (quotient (+ (* array size) 3) 4))))) - (local (if struct? (make-local-entry name type -1 array (+ (local:id (cdr local)) (quotient (+ size 3) 4))) + (make-local-entry name type (+ (local:id (cdr local)) -1 (quotient (+ (* count size) 3) 4))))) + (local (if struct? (make-local-entry name type (+ (local:id (cdr local)) (quotient (+ size 3) 4))) local)) (locals (cons local locals)) (info (clone info #:locals locals)) (local (cdr local))) (init-local local init 0 info))) -(define (global->info type pointer array name o init info) - (let* ((size (cond ((type? type) (type:size type)) - ((not (zero? pointer)) 4) - (else (error "global->info: no such type:" type)))) +(define (global->info type name o init info) + (let* ((rank (->rank type)) + (size (cond ;;((not (zero? rank)) 4) + ((pointer? type) 4) + ((c-array? type) (cond ((pointer? (c-array:type type)) 4) + ((type? (c-array:type type)) ((compose type:size c-array:type) type)) + (else (error "urg:" type)))) + ((type? type) (type:size type)) + (else (error "global->info: no such type:" type)))) (data (cond ((not init) (string->list (make-string size #\nul))) - (array (array-init->data (and array (* array (type:size type))) init info)) + ((let ((array (or (and (c-array? type) type) + (and (pointer? type) + (c-array? (pointer:type type)) + (pointer:type type)) + (and (pointer? type) + (pointer? (pointer:type type)) + (c-array? (pointer:type (pointer:type type))) + (pointer:type (pointer:type type)))))) + array) + => + (lambda (array) (array-init->data (* (c-array:count array) size) init info))) (else (let ((data (init->data init info))) (append data (string->list (make-string (max 0 (- size (length data))) #\nul))))))) - (global (make-global-entry name type pointer array data))) + (global (make-global-entry name type data))) (clone info #:globals (append (.globals info) (list global))))) (define (array-init-element->data size o info) @@ -1985,60 +1887,57 @@ (() (string->list (make-string size #\nul))) (_ (error "array-init->data: not supported: " o)))) -(define (init-declr->info type pointer o info) +(define (init-declr->info type o info) (pmatch o (((ident ,name)) - (if (.function info) (local->info type pointer #f name o #f info) - (global->info type pointer #f name o #f info))) + (if (.function info) (local->info type name o #f info) + (global->info type name o #f info))) (((ident ,name) (initzer ,init)) (let* ((strings (init->strings init info)) (info (if (null? strings) info - (clone info #:globals (append (.globals info) strings)))) - (struct? (and (zero? pointer) - (structured-type? type))) - (pointer (if struct? (- (1+ (abs pointer))) pointer))) - (if (.function info) (local->info type pointer #f name o init info) - (global->info type pointer #f name o init info)))) + (clone info #:globals (append (.globals info) strings))))) + (if (.function info) (local->info type name o init info) + (global->info type name o init info)))) (((ftn-declr (ident ,name) . ,_)) (let ((functions (.functions info))) (if (member name functions) info (let* ((type (ftn-declr:get-type info `(ftn-declr (ident ,name) ,@_))) (function (make-function name type #f))) (clone info #:functions (cons (cons name function) functions)))))) - (((ftn-declr (scope (ptr-declr ,p (ident ,name))) ,param-list) ,init) - - (let ((pointer (+ pointer (pointer->ptr p)))) - (if (.function info) (local->info type pointer #f name o init info) - (global->info type pointer #f name o init info)))) - (((ptr-declr ,p . ,_) . ,init) - (let ((pointer (+ pointer (pointer->ptr p)))) - (init-declr->info type pointer (append _ init) info))) - (((array-of (ident ,name) ,array) . ,init) + (((ftn-declr (scope (ptr-declr ,pointer (ident ,name))) ,param-list) ,init) + (let* ((rank (pointer->rank pointer)) + (type (rank+= type rank))) + (if (.function info) (local->info type name o init info) + (global->info type name o init info)))) + (((ptr-declr ,pointer . ,_) . ,init) + (let* ((rank (pointer->rank pointer)) + (type (rank+= type rank))) + (init-declr->info type (append _ init) info))) + (((array-of (ident ,name) ,count) . ,init) (let* ((strings (init->strings init info)) (info (if (null? strings) info (clone info #:globals (append (.globals info) strings)))) - (array (expr->number info array)) - (pointer (- (1+ pointer)))) - (if (.function info) (local->info type pointer array name o init info) - (global->info type pointer array name o init info)))) + (count (expr->number info count)) + (type (make-c-array type count))) + (if (.function info) (local->info type name o init info) + (global->info type name o init info)))) (((array-of (ident ,name)) . ,init) (let* ((strings (init->strings init info)) (info (if (null? strings) info (clone info #:globals (append (.globals info) strings)))) - (pointer (- (1+ pointer)))) - (if (.function info) (local->info type pointer (length (cadar init)) name o init info) - (global->info type pointer #f name o init info)))) - + (count (length (cadar init))) + (type (make-c-array type count))) + (if (.function info) (local->info type name o init info) + (global->info type name o init info)))) ;; FIXME: recursion - (((array-of (array-of (ident ,name) ,array) ,array1) . ,init) + (((array-of (array-of (ident ,name) ,count) ,count1) . ,init) (let* ((strings (init->strings init info)) (info (if (null? strings) info (clone info #:globals (append (.globals info) strings)))) - (array (expr->number info array)) - (pointer (- (+ 2 pointer)))) - (if (.function info) (local->info type pointer array name o init info) - (global->info type pointer array name o init info)))) - + (count (expr->number info count)) + (type (make-c-array (rank++ type) count))) + (if (.function info) (local->info type name o init info) + (global->info type name o init info)))) (_ (error "init-declr->info: not supported: " o)))) (define (enum-def-list->constants constants fields) @@ -2074,7 +1973,7 @@ (let ((var (ident->variable info name))) `((#:address ,var)))) ((ref-to (i-sel (ident ,field) (cast (type-name (decl-spec-list ,struct) (abs-declr (pointer))) (p-expr (fixed ,base))))) - (let* ((type (ast->type info struct)) + (let* ((type (ast->type struct info)) (offset (field-offset info type field)) (base (cstring->number base))) (int->bv32 (+ base offset)))) @@ -2082,6 +1981,7 @@ ((,number . _) (guard (number? number)) (append (map int->bv32 o))) ((initzer ,init) (init->data init info)) + ((cast _ ,expr) (init->data expr info)) (_ (error "init->data: not supported: " o)))) (define (init->strings o info) @@ -2143,6 +2043,7 @@ (let ((type-entry (union->type-entry name (append-map (struct-field info) fields)))) (clone info #:types (cons type-entry (.types info))))) + ((enum-ref . _) info) ((struct-ref . _) info) ((typename ,name) info) ((union-ref . _) info) @@ -2171,9 +2072,14 @@ (define (param-decl:get-type o info) (pmatch o ((ellipsis) #f) - ((param-decl (decl-spec-list (type-spec (void)))) #f) - ((param-decl (decl-spec-list (type-spec ,type)) _) (ast->type info type)) - ((param-decl ,type _) (ast->type info type)) + ((param-decl (decl-spec-list ,type)) (ast->type type info)) + ((param-decl (decl-spec-list (type-spec ,type)) (param-declr (ptr-declr ,pointer (ident ,name)))) + (let ((rank (pointer->rank pointer))) + (rank+= (ast->type type info) rank))) + ((param-decl (decl-spec-list ,type) (param-declr (ptr-declr ,pointer (array-of _)))) + (let ((rank (pointer->rank pointer))) + (rank+= (ast->type type info) (1+ rank)))) + ((param-decl ,type _) (ast->type type info)) (_ (error "param-decl:get-type not supported:" o)))) (define (fctn-defn:get-formals o) @@ -2197,20 +2103,6 @@ (i386:function-locals))))) (_ (error "param-list->text: not supported: " o)))) -(define (param-decl:get-ptr o) - (pmatch o - ((param-decl (decl-spec-list . ,decl) (param-declr (ident ,name) (array-of _))) - 1) - ((param-decl (decl-spec-list . ,decl) (param-declr (ident ,name))) - 0) - ((param-decl _ (param-declr (ptr-declr ,pointer (array-of _)))) - (1+ (pointer->ptr pointer))) - ((param-decl _ (param-declr (ptr-declr ,pointer . _))) - (pointer->ptr pointer)) - ((param-decl (decl-spec-list (type-spec (void)))) - 0) - (_ (error "param-decl:get-ptr: not supported: " o)))) - (define (param-list->locals o info) (pmatch o ((param-list . ,formals) @@ -2218,22 +2110,20 @@ (map make-local-entry (map param-decl:get-name formals) (map (cut param-decl:get-type <> info) formals) - (map param-decl:get-ptr formals) - (map (const #f) (iota n)) (iota n -2 -1)))) (_ (error "param-list->locals: not supported:" o)))) (define (fctn-defn:get-type info o) (pmatch o (((decl-spec-list (type-spec ,type)) (ptr-declr ,pointer . _) ,statement) - (let* ((type (ast->type info type)) + (let* ((type (ast->type type info)) (rank (ptr-declr->rank pointer))) (if (zero? rank) type (make-pointer type rank)))) (((decl-spec-list (type-spec ,type)) . ,rest) - (ast->type info type)) + (ast->type type info)) (((decl-spec-list (stor-spec ,store) (type-spec ,type)) (ftn-declr (ident _) _) _) - (ast->type info type)) + (ast->type type info)) (_ (error "fctn-defn:get-type: not supported:" o)))) (define (ftn-declr:get-type info o) @@ -2259,7 +2149,7 @@ (text (param-list->text formals)) (locals (param-list->locals formals info)) (statement (fctn-defn:get-statement o)) - (info (clone info #:locals locals #:function name #:text text)) + (info (clone info #:locals locals #:function name #:text text #:statics '())) (info (ast->info statement info)) (locals (.locals info)) (local (and (pair? locals) (car locals))) diff --git a/module/language/c99/info.scm b/module/language/c99/info.scm index b613fda8..1d387ced 100644 --- a/module/language/c99/info.scm +++ b/module/language/c99/info.scm @@ -97,7 +97,7 @@ function:type function:text - -> + ->type ->rank rank-- rank++ @@ -162,36 +162,32 @@ (value var:value)) (define-immutable-record-type - (make-global- name type var pointer c-array value function) + (make-global- name type var value function) global? (name global:name) (type global:type) (var global:var) ; - (pointer global:pointer) - (c-array global:c-array) (value global:value) (function global:function)) -(define (make-global name type pointer c-array value function) - (make-global- name type (make-var name type function #f value) pointer c-array value function)) +(define (make-global name type value function) + (make-global- name type (make-var name type function #f value) value function)) (define (global->string o) (or (and=> (global:function o) (cut string-append <> "-" (global:name o))) (global:name o))) (define-immutable-record-type - (make-local- type var id pointer c-array) + (make-local- type var id) local? (type local:type) (var local:var) ; - (id local:id) - (pointer local:pointer) - (c-array local:c-array)) + (id local:id)) -(define (make-local name type pointer c-array id) - (make-local- type (make-var name type #f id #f) id pointer c-array)) +(define (make-local name type id) + (make-local- type (make-var name type #f id #f) id)) (define-immutable-record-type (make-function name type text) @@ -207,7 +203,7 @@ ((and (pair? o) (eq? (car o) 'tag))) ;; FIXME: enum? (else #f))) -(define (-> o) +(define (->type o) (cond ((type? o) o) ((pointer? o) (pointer:type o)) ((c-array? o) (c-array:type o)) @@ -216,7 +212,7 @@ (#t (format (current-error-port) "->type--: not a : ~s\n" o) (make-type 'builtin 4 #f)) - (else (error "->: not a :" o)))) + (else (error "->type: not a :" o)))) (define (->rank o) (cond ((type? o) 0) diff --git a/scaffold/tests/23-pointer.c b/scaffold/tests/23-pointer.c index 0ae2d78c..4c446a28 100644 --- a/scaffold/tests/23-pointer.c +++ b/scaffold/tests/23-pointer.c @@ -20,6 +20,7 @@ #include "00-test.i" +char *g_hello = "hello"; char g_arena[4] = "XXX"; char *g_chars = g_arena; @@ -32,32 +33,36 @@ struct foo *file; int test () { - if (*g_chars != 'X') return 1; + if (*g_hello != 'h') return 1; + if (g_hello[0] != 'h') return 2; + if (g_chars[0] != 'X') return 3; + if (*g_chars != 'X') return 4; + g_arena[0] = 'A'; - if (*g_chars != 'A') return 2; + if (*g_chars != 'A') return 5; char *x = g_arena; - if (*x++ != 'A') return 3; + if (*x++ != 'A') return 5; *x++ = 'C'; - if (g_chars[1] != 'C') return 4; - if (g_chars[2] != 'X') return 5; + if (g_chars[1] != 'C') return 7; + if (g_chars[2] != 'X') return 8; *--x = 'X'; - if (g_chars[1] != 'X') return 7; + if (g_chars[1] != 'X') return 9; char **pp = &x; - if (**pp != 'X') return 7; + if (**pp != 'X') return 10; char *p = *pp; - if (*p != 'X') return 8; + if (*p != 'X') return 11; char ***ppp = &pp; - if (***ppp != 'X') return 9; + if (***ppp != 'X') return 12; char **pp2 = *ppp; - if (**pp2 != 'X') return 10; + if (**pp2 != 'X') return 13; struct foo *f = 0; - if (f) return 11; - if (file) return 12; + if (f) return 14; + if (file) return 15; return 0; } diff --git a/scaffold/tests/46-function-static.c b/scaffold/tests/46-function-static.c index 658b167f..2fcada90 100644 --- a/scaffold/tests/46-function-static.c +++ b/scaffold/tests/46-function-static.c @@ -18,6 +18,8 @@ * along with Mes. If not, see . */ +static int i = 2; + int test () { @@ -27,10 +29,9 @@ test () return foo - i--; } -static int i = 2; int main () { test (); - return test (); + return i - 2 - test (); } diff --git a/scaffold/tests/64-make-cell.c b/scaffold/tests/64-make-cell.c index c9f460ca..b37c6a26 100644 --- a/scaffold/tests/64-make-cell.c +++ b/scaffold/tests/64-make-cell.c @@ -32,11 +32,7 @@ struct scm { int bla = 1234; char g_arena[84]; -#if __MESC__ -struct scm *g_cells = g_arena; -#else struct scm *g_cells = (struct scm*)g_arena; -#endif char *g_chars = g_arena; int foo () {puts ("t: foo\n"); return 0;}; diff --git a/scaffold/tests/t.c b/scaffold/tests/t.c index 1324e375..0e993752 100644 --- a/scaffold/tests/t.c +++ b/scaffold/tests/t.c @@ -41,6 +41,14 @@ struct anon {struct {int bar; int baz;};}; struct here {int and;} there; +int +test (struct foo* p) +{ + struct foo *g = &f; + g[0].length = 0; + p[0].length = 0; +} + int main (int argc, char* argv[]) {