(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))))
((,name . ,type) (->size type))
(_ (error (format #f "field:size: ~s\n" o)))))
-(define (ast->type info o)
- (let ((type (-><type> (ast-><type> 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)))
((typedef ,next) (or (get-type next info) o))
(_ t))))
-(define (ast-><type> 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> type info))
- ((float-type ,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))
-
- ((type-spec (typename ,type)) (ast-><type> type 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)))
-
-
-
- ((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> struct 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) ; FIXME: ignore expr?
- (ast-><type> type info))
- ((cast (type-name ,type (abs-declr ,pointer)) ,expr) ; FIXME: ignore expr?
- (ast-><type> type info))
-
- ((decl-spec-list (type-spec ,type))
- (ast-><type> type info))
- ((assn-expr ,a ,op ,b)
- (ast-><type> 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 -><type> (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)))
(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
(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))
(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 ;; <pointer> ((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 ;; <pointer> ((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))
-
-(define (ptr-inc o)
- (if (< o 0) (1- o)
- (1+ o)))
-
-(define (ptr-dec o)
- (if (< o 0) (1+ o)
- (1- o)))
+ ((compose type:size (cut ident->type info <>)) 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))))
-
- ((d-sel (ident ,field) ,struct)
- (let ((type (ast->type info struct)))
- (field-pointer info type field)))
+ (->rank (ast->type o info)))
- ((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)
(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)
(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)
((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)))))))
((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)))))))
(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)))
=>
(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)
(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))))
(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))
((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))
;; 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))))))
(expr->accu* expr info))
((sizeof-expr ,expr)
- (append-text info (wrap-as (i386:value->accu (expr->size info expr)))))
-
- ((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)))))
+ (append-text info (wrap-as (i386:value->accu (ast->size expr info)))))
- ((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))
((d-sel ,field ,struct)
(let* ((info (expr->accu* o info))
(info (append-text info (ast->comment o)))
- (type (ast-><type> o info))
+ (type (ast->type o info))
(size (->size type))
(array? (c-array? type)))
(if array? info
((i-sel ,field ,struct)
(let* ((info (expr->accu* o info))
(info (append-text info (ast->comment o)))
- (type (ast-><type> o info))
+ (type (ast->type o info))
(size (->size type))
(array? (c-array? type)))
(if array? info
((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))
((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)))))
((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))))
((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))
(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))
(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))
(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))
((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))))
((equal? op ">>=") (wrap-as (i386:accu>>base)))
((equal? op "<<=") (wrap-as (i386:accu<<base)))
(else (error (format #f "mescc: op ~a not supported: ~a\n" op o)))))))
- (cond ((not (and (= ptr 1) (= ptr-b 1))) info)
+ (cond ((not (and (= rank 1) (= rank-b 1))) info)
((equal? op "-=") (append-text info (wrap-as (append (i386:value->base size)
(i386:accu/base)))))
- (else (error (format #f "invalid operands to binary ~s (have ~s* and ~s*)" op type (ast->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)))))
(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))
(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)
(lambda (o)
(pmatch o
((comp-decl (decl-spec-list (type-spec ,type)) (comp-declr-list (comp-declr (ident ,name))))
- (list (cons name (ast-><type> 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> 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> 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> 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)))))
(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)
(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
((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)
((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)))))))))
(_ (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)
(() (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)
(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))))
((,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)
(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)
(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)
(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)
(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)
(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)))