artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

mescc: Factor-out append-text.

Browse source 
* module/language/c99/compiler.mes: Use append-text throughout.
This commit is contained in:
Jan Nieuwenhuizen 2017-04-07 09:53:56 +02:00
parent 7ccbc00047
commit 68d90aa645
1 changed files with 193 additions and 294 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

487
module/language/c99/compiler.mes
View file

@ -250,7 +250,7 @@
(define (expr->arg info) (define (expr->arg info)
(lambda (o) (lambda (o)
(let ((info ((expr->accu info) o))) (let ((info ((expr->accu info) o)))
(clone info #:text (append (.text info) (wrap-as (i386:push-accu))))))) (append-text info (wrap-as (i386:push-accu))))))
(define (expr->arg info) ;; FIXME: get Mes curried-definitions (define (expr->arg info) ;; FIXME: get Mes curried-definitions
(lambda (o) (lambda (o)
@ -259,10 +259,10 @@
(pmatch o (pmatch o
((p-expr (string ,string)) ((p-expr (string ,string))
(clone info #:text (append text ((push-global-address info) (add-s:-prefix string))))) (append-text info ((push-global-address info) (add-s:-prefix string))))
((p-expr (ident ,name)) ((p-expr (ident ,name))
(clone info #:text (append text ((push-ident info) name)))) (append-text info ((push-ident info) name)))
((cast (type-name (decl-spec-list (type-spec (fixed-type _))) ((cast (type-name (decl-spec-list (type-spec (fixed-type _)))
(abs-declr (pointer))) (abs-declr (pointer)))
@ -270,14 +270,13 @@
((expr->arg info) cast)) ((expr->arg info) cast))
((de-ref (p-expr (ident ,name))) ((de-ref (p-expr (ident ,name)))
(clone info #:text (append text ((push-ident-de-ref info) name)))) (append-text info ((push-ident-de-ref info) name)))
((ref-to (p-expr (ident ,name))) ((ref-to (p-expr (ident ,name)))
(clone info #:text (append text ((push-ident-address info) name)))) (append-text info ((push-ident-address info) name)))
(_ (let* ((info ((expr->accu info) o)) (_ (append-text ((expr->accu info) o)
(text (.text info))) (wrap-as (i386:push-accu))))))))
(clone info #:text (append text (wrap-as (i386:push-accu))))))))))
;; FIXME: see ident->base ;; FIXME: see ident->base
(define (ident->accu info) (define (ident->accu info)
@ -396,25 +395,22 @@
;; (stderr "expr->accu o=~a\n" o) ;; (stderr "expr->accu o=~a\n" o)
(pmatch o (pmatch o
((p-expr (string ,string)) ((p-expr (string ,string))
(clone info #:text (append text (list (lambda (f g ta t d) (append-text info (list (lambda (f g ta t d)
(i386:global->accu (+ (data-offset (add-s:-prefix string) globals) d))))))) (i386:global->accu (+ (data-offset (add-s:-prefix string) globals) d))))))
((p-expr (fixed ,value)) ((p-expr (fixed ,value))
(clone info #:text (append text (value->accu (cstring->number value))))) (append-text info (value->accu (cstring->number value))))
((p-expr (ident ,name)) ((p-expr (ident ,name))
(clone info #:text (append text ((ident->accu info) name)))) (append-text info ((ident->accu info) name)))
((initzer ,initzer) ((expr->accu info) initzer)) ((initzer ,initzer) ((expr->accu info) initzer))
((ref-to (p-expr (ident ,name))) ((ref-to (p-expr (ident ,name)))
(clone info #:text (append-text info ((ident->accu info) name)))
(append (.text info)
((ident->accu info) name))))
((sizeof-type (type-name (decl-spec-list (type-spec (struct-ref (ident ,name)))))) ((sizeof-type (type-name (decl-spec-list (type-spec (struct-ref (ident ,name))))))
(let* ((type (list "struct" name)) (let* ((type (list "struct" name))
(fields (or (type->description info type) '())) (fields (or (type->description info type) '()))
(size (type->size info type))) (size (type->size info type)))
(clone info #:text (append-text info (wrap-as (i386:value->accu size)))))
(append text (wrap-as (i386:value->accu size))))))
;; c+p expr->arg ;; c+p expr->arg
;; g_cells[<expr>] ;; g_cells[<expr>]
@ -422,8 +418,7 @@
(let* ((info ((expr->accu info) index)) (let* ((info ((expr->accu info) index))
(type (ident->type info array)) (type (ident->type info array))
(size (type->size info type))) (size (type->size info type)))
(clone info #:text (append-text info (append
(append (.text info)
;; immediate: (i386:value->accu (* size index)) ;; immediate: (i386:value->accu (* size index))
;; * size cells: * length * 4 = * 12 ;; * size cells: * length * 4 = * 12
(wrap-as (append (i386:accu->base) (wrap-as (append (i386:accu->base)
@ -445,10 +440,8 @@
(field-size 4) ;; FIXME:4, not fixed (field-size 4) ;; FIXME:4, not fixed
(offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b)))))))) (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
(text (.text info))) (text (.text info)))
(clone info #:text (append-text info (append ((ident->accu info) array)
(append text (wrap-as (i386:mem+n->accu offset))))))
((ident->accu info) array)
(wrap-as (i386:mem+n->accu offset))))))
;; g_cells[10].type ;; g_cells[10].type
((d-sel (ident ,field) (array-ref (p-expr (fixed ,index)) (p-expr (ident ,array)))) ((d-sel (ident ,field) (array-ref (p-expr (fixed ,index)) (p-expr (ident ,array))))
@ -460,15 +453,14 @@
(offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b)))))))) (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
(index (cstring->number index)) (index (cstring->number index))
(text (.text info))) (text (.text info)))
(clone info #:text (append-text info (append
(append text (wrap-as (append (i386:value->base index)
(wrap-as (append (i386:value->base index) (i386:base->accu)
(i386:base->accu) (if (<= count 1) '() (i386:accu+accu))
(if (> count 1) (i386:accu+accu) '()) (if (<= count 2) '() (i386:accu+base))
(if (= count 3) (i386:accu+base) '()) (i386:accu-shl 2)))
(i386:accu-shl 2))) ((ident->base info) array)
((ident->base info) array) (wrap-as (i386:base-mem+n->accu offset))))))
(wrap-as (i386:base-mem+n->accu offset))))))
;; g_cells[x].type ;; g_cells[x].type
((d-sel (ident ,field) (array-ref (p-expr (ident ,index)) (p-expr (ident ,array)))) ((d-sel (ident ,field) (array-ref (p-expr (ident ,index)) (p-expr (ident ,array))))
@ -479,15 +471,13 @@
(field-size 4) ;; FIXME:4, not fixed (field-size 4) ;; FIXME:4, not fixed
(offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b)))))))) (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
(text (.text info))) (text (.text info)))
(clone info #:text (append-text info (append ((ident->base info) index)
(append text (wrap-as (append (i386:base->accu)
((ident->base info) index) (if (<= count 1) '() (i386:accu+accu))
(wrap-as (append (i386:base->accu) (if (<= count 2) '() (i386:accu+base))
(if (> count 1) (i386:accu+accu) '()) (i386:accu-shl 2)))
(if (= count 3) (i386:accu+base) '()) ((ident->base info) array)
(i386:accu-shl 2))) (wrap-as (i386:base-mem+n->accu offset))))))
((ident->base info) array)
(wrap-as (i386:base-mem+n->accu offset))))))
;; g_functions[g_cells[fn].cdr].arity ;; g_functions[g_cells[fn].cdr].arity
;; INDEX0: g_cells[fn].cdr ;; INDEX0: g_cells[fn].cdr
@ -508,44 +498,36 @@
'()))) '())))
(offset (* field-size (1- (length rest)))) (offset (* field-size (1- (length rest))))
(text (.text info))) (text (.text info)))
(clone info #:text (append-text info (append (.text index)
(append text (wrap-as (append (i386:accu->base)
(.text index) (if (<= count 1) '() (i386:accu+accu))
(wrap-as (append (i386:accu->base) (if (<= count 2) '() (i386:accu+base))
(if (> count 1) (i386:accu+accu) '()) (i386:accu-shl 2)))
(if (= count 3) (i386:accu+base) '()) ((ident->base info) array)
(i386:accu-shl 2))) (wrap-as (i386:base-mem+n->accu offset))))))
((ident->base info) array)
(wrap-as (i386:base-mem+n->accu offset))))))
;;; FIXME: FROM INFO ...only zero?! ;;; FIXME: FROM INFO ...only zero?!
((p-expr (fixed ,value)) ((p-expr (fixed ,value))
(let ((value (cstring->number value))) (let ((value (cstring->number value)))
(clone info #:text (append-text info (wrap-as (i386:value->accu value)))))
(append text (wrap-as (i386:value->accu value))))))
((p-expr (char ,char)) ((p-expr (char ,char))
(let ((char (char->integer (car (string->list char))))) (let ((char (char->integer (car (string->list char)))))
(clone info #:text (append-text info (wrap-as (i386:value->accu char)))))
(append text (wrap-as (i386:value->accu char))))))
((p-expr (ident ,name)) ((p-expr (ident ,name))
(clone info #:text (append-text info ((ident->accu info) name)))
(append text
((ident->accu info) name))))
((de-ref (p-expr (ident ,name))) ((de-ref (p-expr (ident ,name)))
(let* ((type (ident->type info name)) (let* ((type (ident->type info name))
(size (and type (type->size info type)))) (size (and type (type->size info type))))
(clone info #:text (append-text info (append ((ident->accu info) name)
(append text (wrap-as (if (= size 1) (i386:byte-mem->accu)
((ident->accu info) name) (i386:mem->accu)))))))
(wrap-as (if (= size 1) (i386:byte-mem->accu)
(i386:mem->accu)))))))
((fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)) ((fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list))
(if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list)))) ;; FIXME (if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list)))) ;; FIXME
(clone info #:text (append text (wrap-as (asm->hex arg0))))) (append-text info (wrap-as (asm->hex arg0))))
(let* ((globals (append globals (filter-map expr->global expr-list))) (let* ((globals (append globals (filter-map expr->global expr-list)))
(info (clone info #:globals globals)) (info (clone info #:globals globals))
(text-length (length text)) (text-length (length text))
@ -592,120 +574,94 @@
((ast->info info) `(expr-stmt ,o))) ((ast->info info) `(expr-stmt ,o)))
((post-inc (p-expr (ident ,name))) ((post-inc (p-expr (ident ,name)))
(clone info #:text (append-text info (append ((ident->accu info) name)
(append text ((ident-add info) name 1))))
((ident->accu info) name)
((ident-add info) name 1))))
((post-dec (p-expr (ident ,name))) ((post-dec (p-expr (ident ,name)))
(or (assoc-ref locals name) (begin (stderr "i-- ~a\n" name) barf)) (or (assoc-ref locals name) (begin (stderr "i-- ~a\n" name) barf))
(clone info #:text (append-text info (append ((ident->accu info) name)
(append text ((ident-add info) name -1))))
((ident->accu info) name)
((ident-add info) name -1))))
((pre-inc (p-expr (ident ,name))) ((pre-inc (p-expr (ident ,name)))
(or (assoc-ref locals name) (begin (stderr "++i ~a\n" name) barf)) (or (assoc-ref locals name) (begin (stderr "++i ~a\n" name) barf))
(clone info #:text (append-text info (append ((ident-add info) name 1)
(append text ((ident->accu info) name))))
((ident-add info) name 1)
((ident->accu info) name))))
((pre-dec (p-expr (ident ,name))) ((pre-dec (p-expr (ident ,name)))
(or (assoc-ref locals name) (begin (stderr "--i ~a\n" name) barf)) (or (assoc-ref locals name) (begin (stderr "--i ~a\n" name) barf))
(clone info #:text (append-text info (append ((ident-add info) name -1)
(append text ((ident->accu info) name))))
((ident-add info) name -1)
((ident->accu info) name))))
((add (p-expr (ident ,name)) ,b) ((add (p-expr (ident ,name)) ,b)
(let* ((empty (clone info #:text '())) (let* ((empty (clone info #:text '()))
(base ((expr->base empty) b))) (base ((expr->base empty) b)))
(clone info #:text (append-text info (append (.text base)
(append text ((ident->accu info) name)
(.text base) (wrap-as (i386:accu+base))))))
((ident->accu info) name)
(wrap-as (i386:accu+base))))))
((add ,a ,b) ((add ,a ,b)
(let* ((empty (clone info #:text '())) (let* ((empty (clone info #:text '()))
(accu ((expr->accu empty) a)) (accu ((expr->accu empty) a))
(base ((expr->base empty) b))) (base ((expr->base empty) b)))
(clone info #:text (append-text info (append (.text accu)
(append text (.text base)
(.text accu) (wrap-as (i386:accu+base))))))
(.text base)
(wrap-as (i386:accu+base))))))
((sub ,a ,b) ((sub ,a ,b)
(let* ((empty (clone info #:text '())) (let* ((empty (clone info #:text '()))
(accu ((expr->accu empty) a)) (accu ((expr->accu empty) a))
(base ((expr->base empty) b))) (base ((expr->base empty) b)))
(clone info #:text (append-text info (append (.text accu)
(append text (.text base)
(.text accu) (wrap-as (i386:accu-base))))))
(.text base)
(wrap-as (i386:accu-base))))))
((bitwise-or ,a ,b) ((bitwise-or ,a ,b)
(let* ((empty (clone info #:text '())) (let* ((empty (clone info #:text '()))
(accu ((expr->accu empty) a)) (accu ((expr->accu empty) a))
(base ((expr->base empty) b))) (base ((expr->base empty) b)))
(clone info #:text (append-text info (append (.text accu)
(append text (.text base)
(.text accu) (wrap-as (i386:accu-or-base))))))
(.text base)
(wrap-as (i386:accu-or-base))))))
((lshift ,a ,b) ((lshift ,a ,b)
(let* ((empty (clone info #:text '())) (let* ((empty (clone info #:text '()))
(accu ((expr->accu empty) a)) (accu ((expr->accu empty) a))
(base ((expr->base empty) b))) (base ((expr->base empty) b)))
(clone info #:text (append-text info (append (.text accu)
(append text (.text base)
(.text accu) (wrap-as (i386:accu<<base))))))
(.text base)
(wrap-as (i386:accu<<base))))))
((rshift ,a ,b) ((rshift ,a ,b)
(let* ((empty (clone info #:text '())) (let* ((empty (clone info #:text '()))
(accu ((expr->accu empty) a)) (accu ((expr->accu empty) a))
(base ((expr->base empty) b))) (base ((expr->base empty) b)))
(clone info #:text (append-text info (append (.text accu)
(append text (.text base)
(.text accu) (wrap-as (i386:accu>>base))))))
(.text base)
(wrap-as (i386:accu>>base))))))
((div ,a ,b) ((div ,a ,b)
(let* ((empty (clone info #:text '())) (let* ((empty (clone info #:text '()))
(accu ((expr->accu empty) a)) (accu ((expr->accu empty) a))
(base ((expr->base empty) b))) (base ((expr->base empty) b)))
(clone info #:text (append-text info (append (.text accu)
(append text (.text base)
(.text accu) (wrap-as (i386:accu/base))))))
(.text base)
(wrap-as (i386:accu/base))))))
((mod ,a ,b) ((mod ,a ,b)
(let* ((empty (clone info #:text '())) (let* ((empty (clone info #:text '()))
(accu ((expr->accu empty) a)) (accu ((expr->accu empty) a))
(base ((expr->base empty) b))) (base ((expr->base empty) b)))
(clone info #:text (append-text info (append (.text accu)
(append text ;;FIXME:empty (.text base)
(.text accu) (wrap-as (i386:accu%base))))))
(.text base)
(wrap-as (i386:accu%base))))))
((mul ,a ,b) ((mul ,a ,b)
(let* ((empty (clone info #:text '())) (let* ((empty (clone info #:text '()))
(accu ((expr->accu empty) a)) (accu ((expr->accu empty) a))
(base ((expr->base empty) b))) (base ((expr->base empty) b)))
(clone info #:text (append-text info (append (.text accu)
(append text (.text base)
(.text accu) (wrap-as (i386:accu*base))))))
(.text base)
(wrap-as (i386:accu*base))))))
((not ,expr) ((not ,expr)
(let* ((test-info ((ast->info info) expr))) (let* ((test-info ((ast->info info) expr)))
@ -715,13 +671,12 @@
#:globals (.globals test-info)))) #:globals (.globals test-info))))
((neg (p-expr (fixed ,value))) ((neg (p-expr (fixed ,value)))
(clone info #:text (append text (value->accu (- (cstring->number value)))))) (append-text info (value->accu (- (cstring->number value)))))
((neg (p-expr (ident ,name))) ((neg (p-expr (ident ,name)))
(clone info #:text (append text (append-text info (append ((ident->base info) name)
((ident->base info) name) (wrap-as (i386:value->accu 0))
(wrap-as (i386:value->accu 0)) (wrap-as (i386:sub-base)))))
(wrap-as (i386:sub-base)))))
((eq ,a ,b) ((compare->accu info) a b (i386:sub-base))) ((eq ,a ,b) ((compare->accu info) a b (i386:sub-base)))
((ge ,a ,b) ((compare->accu info) b a (i386:sub-base))) ((ge ,a ,b) ((compare->accu info) b a (i386:sub-base)))
@ -742,13 +697,10 @@
barf) barf)
(let* ((empty (clone info #:text '())) (let* ((empty (clone info #:text '()))
(base ((expr->base empty) b))) (base ((expr->base empty) b)))
(clone info #:text (append-text info (append (.text base)
(append text ((base->ident-address info) name)
(.text base) ((ident->accu info) name)
((base->ident-address info) name) ((ident-add info) name 1)))))
((ident->accu info) name)
((ident-add info) name 1)))))
;; *p-- = b; ;; *p-- = b;
((assn-expr (de-ref (post-dec (p-expr (ident ,name)))) (op ,op) ,b) ((assn-expr (de-ref (post-dec (p-expr (ident ,name)))) (op ,op) ,b)
@ -757,13 +709,10 @@
barf) barf)
(let* ((empty (clone info #:text '())) (let* ((empty (clone info #:text '()))
(base ((expr->base empty) b))) (base ((expr->base empty) b)))
(clone info #:text (append-text info (append (.text base)
(append text ((base->ident-address info) name)
(.text base) ((ident->accu info) name)
((base->ident-address info) name) ((ident-add info) name -1)))))
((ident->accu info) name)
((ident-add info) name -1)))))
;; CAR (x) = 0 ;; CAR (x) = 0
;; TYPE (x) = PAIR; ;; TYPE (x) = PAIR;
@ -779,10 +728,9 @@
(size (type->size info type)) (size (type->size info type))
(field-size 4) ;; FIXME:4, not fixed (field-size 4) ;; FIXME:4, not fixed
(offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b)))))))) ) (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b)))))))) )
(clone info #:text (append text (append-text info (append (.text expr)
(.text expr) (.text base)
(.text base) (wrap-as (i386:base->accu-address)))))) ; FIXME: size
(wrap-as (i386:base->accu-address)))))) ; FIXME: size
;; i = 0; ;; i = 0;
@ -797,16 +745,15 @@
barf) barf)
(let* ((empty (clone info #:text '())) (let* ((empty (clone info #:text '()))
(base ((expr->base empty) b))) (base ((expr->base empty) b)))
(clone info #:text (append text (append-text info (append (.text base)
(.text base) (if (equal? op "=") '()
(if (equal? op "=") '() (append ((ident->accu info) name)
(append ((ident->accu info) name) (wrap-as (append (if (equal? op "+=") (i386:accu+base)
(wrap-as (append (if (equal? op "+=") (i386:accu+base) (i386:accu-base))
(i386:accu-base)) (i386:accu->base)))))
(i386:accu->base))))) ;;assign:
;;assign: ((base->ident info) name)
((base->ident info) name) (wrap-as (i386:base->accu))))))
(wrap-as (i386:base->accu))))))
;; *p = 0; ;; *p = 0;
((assn-expr (de-ref (p-expr (ident ,array))) (op ,op) ,b) ((assn-expr (de-ref (p-expr (ident ,array))) (op ,op) ,b)
@ -815,11 +762,10 @@
barf) barf)
(let* ((empty (clone info #:text '())) (let* ((empty (clone info #:text '()))
(base ((expr->base empty) b))) (base ((expr->base empty) b)))
(clone info #:text (append text (append-text info (append (.text base)
(.text base) ;;assign:
;;assign: ((base->ident-address info) array)
((base->ident-address info) array) (wrap-as (i386:base->accu))))))
(wrap-as (i386:base->accu))))))
;; g_cells[<expr>] = <expr>; ;; g_cells[<expr>] = <expr>;
((assn-expr (array-ref ,index (p-expr (ident ,array))) (op ,op) ,b) ((assn-expr (array-ref ,index (p-expr (ident ,array))) (op ,op) ,b)
@ -831,20 +777,18 @@
(type (ident->type info array)) (type (ident->type info array))
(size (type->size info type)) (size (type->size info type))
(ptr (ident->pointer info array))) (ptr (ident->pointer info array)))
(clone info #:text (append-text info (append
(append (.text info) (if (eq? size 1) (wrap-as (i386:byte-base->accu-address))
(append
(if (eq? size 1) (wrap-as (i386:byte-base->accu-address)) (wrap-as (i386:base-address->accu-address))
(append (if (<= size 4) '()
(wrap-as (i386:base-address->accu-address)) (wrap-as (append (i386:accu+n 4)
(if (<= size 4) '() (i386:base+n 4)
(wrap-as (append (i386:accu+n 4) (i386:base-address->accu-address))))
(i386:base+n 4) (if (<= size 8) '()
(i386:base-address->accu-address)))) (wrap-as (append (i386:accu+n 4)
(if (<= size 8) '() (i386:base+n 4)
(wrap-as (append (i386:accu+n 4) (i386:base-address->accu-address))))))))))
(i386:base+n 4)
(i386:base-address->accu-address))))))))))
(_ (_
(format (current-error-port) "SKIP: expr->accu=~s\n" o) (format (current-error-port) "SKIP: expr->accu=~s\n" o)
@ -889,18 +833,16 @@
(let* ((info ((expr->accu info) index)) (let* ((info ((expr->accu info) index))
(type (ident->type info array)) (type (ident->type info array))
(size (type->size info type))) (size (type->size info type)))
(clone info #:text (append-text info (append (wrap-as (append (i386:accu->base)
(append (.text info) (if (eq? size 1) '()
(wrap-as (append (i386:accu->base) (append
(if (eq? size 1) '() (if (<= size 4) '()
(append (i386:accu+accu))
(if (<= size 4) '() (if (<= size 8) '()
(i386:accu+accu)) (i386:accu+base))
(if (<= size 8) '() (i386:accu-shl 2)))))
(i386:accu+base)) ((ident->base info) array)
(i386:accu-shl 2))))) (wrap-as (i386:accu+base))))))
((ident->base info) array)
(wrap-as (i386:accu+base))))))
;; g_cells[10].type ;; g_cells[10].type
((d-sel (ident ,field) (array-ref (p-expr (fixed ,index)) (p-expr (ident ,array)))) ((d-sel (ident ,field) (array-ref (p-expr (fixed ,index)) (p-expr (ident ,array))))
@ -912,20 +854,18 @@
(offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b)))))))) (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
(index (cstring->number index)) (index (cstring->number index))
(text (.text info))) (text (.text info)))
(clone info #:text (append-text info (append (wrap-as (append (i386:value->base index)
(append text (i386:base->accu)
(wrap-as (append (i386:value->base index) (if (<= count 1) '()
(i386:base->accu) (i386:accu+accu))
(if (<= count 1) '() (if (<= count 2) '()
(i386:accu+accu)) (i386:accu+base))
(if (<= count 2) '() (i386:accu-shl 2)))
(i386:accu+base)) ;; de-ref: g_cells, non: arena
(i386:accu-shl 2))) ;;((ident->base info) array)
;; de-ref: g_cells, non: arena ((ident->base info) array)
;;((ident->base info) array) (wrap-as (append (i386:accu+base)
((ident->base info) array) (i386:accu+value offset)))))))
(wrap-as (append (i386:accu+base)
(i386:accu+value offset)))))))
;; g_cells[x].type ;; g_cells[x].type
((d-sel (ident ,field) (array-ref (p-expr (ident ,index)) (p-expr (ident ,array)))) ((d-sel (ident ,field) (array-ref (p-expr (ident ,index)) (p-expr (ident ,array))))
@ -936,20 +876,18 @@
(field-size 4) ;; FIXME:4, not fixed (field-size 4) ;; FIXME:4, not fixed
(offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b)))))))) (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
(text (.text info))) (text (.text info)))
(clone info #:text (append-text info (append ((ident->base info) index)
(append text (wrap-as (append (i386:base->accu)
((ident->base info) index) (if (<= count 1) '()
(wrap-as (append (i386:base->accu) (i386:accu+accu))
(if (<= count 1) '() (if (<= count 2) '()
(i386:accu+accu)) (i386:accu+base))
(if (<= count 2) '() (i386:accu-shl 2)))
(i386:accu+base)) ;; de-ref: g_cells, non: arena
(i386:accu-shl 2))) ;;((ident->base info) array)
;; de-ref: g_cells, non: arena ((ident->base info) array)
;;((ident->base info) array) (wrap-as (append (i386:accu+base)
((ident->base info) array) (i386:accu+value offset)))))))
(wrap-as (append (i386:accu+base)
(i386:accu+value offset)))))))
;;((d-sel (ident "cdr") (p-expr (ident "scm_make_cell")))) ;;((d-sel (ident "cdr") (p-expr (ident "scm_make_cell"))))
((d-sel (ident ,field) (p-expr (ident ,name))) ((d-sel (ident ,field) (p-expr (ident ,name)))
@ -958,10 +896,8 @@
(field-size 4) ;; FIXME (field-size 4) ;; FIXME
(offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b)))))))) (offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
(text (.text info))) (text (.text info)))
(clone info #:text (append-text info (append ((ident->accu info) name)
(append text (wrap-as (i386:accu+value offset))))))
((ident->accu info) name)
(wrap-as (i386:accu+value offset))))))
(_ (_
(format (current-error-port) "SKIP: expr->accu*=~s\n" o) (format (current-error-port) "SKIP: expr->accu*=~s\n" o)
@ -1020,8 +956,7 @@
(define (statement->info info body-length) (define (statement->info info body-length)
(lambda (o) (lambda (o)
(pmatch o (pmatch o
((break) (clone info #:text (append (.text info) (jump body-length) ((break) (append-text info (jump body-length)))
)))
(_ (_
((ast->info info) o))))) ((ast->info info) o)))))
(lambda (o) (lambda (o)
@ -1033,8 +968,7 @@
(append (wrap-as (i386:accu-cmp-value value)) (append (wrap-as (i386:accu-cmp-value value))
(jump-nz clause-length))) (jump-nz clause-length)))
(let* ((value (assoc-ref (.constants info) constant)) (let* ((value (assoc-ref (.constants info) constant))
(test-info (test-info (append-text info (test->text value 0)))
(clone info #:text (append (.text info) (test->text value 0))))
(text-length (length (.text test-info))) (text-length (length (.text test-info)))
(clause-info (let loop ((elements elements) (info test-info)) (clause-info (let loop ((elements elements) (info test-info))
(if (null? elements) info (if (null? elements) info
@ -1054,8 +988,7 @@
(append (wrap-as (i386:accu-cmp-value value)) (append (wrap-as (i386:accu-cmp-value value))
(jump-nz clause-length))) (jump-nz clause-length)))
(let* ((value (cstring->number value)) (let* ((value (cstring->number value))
(test-info (test-info (append-text info (test->text value 0)))
(clone info #:text (append (.text info) (test->text value 0))))
(text-length (length (.text test-info))) (text-length (length (.text test-info)))
(clause-info (let loop ((elements elements) (info test-info)) (clause-info (let loop ((elements elements) (info test-info))
(if (null? elements) info (if (null? elements) info
@ -1488,21 +1421,19 @@
#:globals (.globals body-info)))) #:globals (.globals body-info))))
((labeled-stmt (ident ,label) ,statement) ((labeled-stmt (ident ,label) ,statement)
(let ((info (clone info #:text (append text (list label))))) (let ((info (append-text info (list label))))
((ast->info info) statement))) ((ast->info info) statement)))
((goto (ident ,label)) ((goto (ident ,label))
(let* ((jump (lambda (n) (i386:XXjump n))) (let* ((jump (lambda (n) (i386:XXjump n)))
(offset (+ (length (jump 0)) (length (text->list text))))) (offset (+ (length (jump 0)) (length (text->list text)))))
(clone info #:text (append-text info (append
(append text (list (lambda (f g ta t d)
(list (lambda (f g ta t d) (jump (- (label-offset (.function info) label f) offset))))))))
(jump (- (label-offset (.function info) label f) offset))))))))
((return ,expr) ((return ,expr)
(let ((accu ((expr->accu info) expr))) (let ((info ((expr->accu info) expr)))
(clone accu #:text (append-text info (append (wrap-as (i386:ret))))))
(append (.text accu) (wrap-as (i386:ret))))))
;; DECL ;; DECL
@ -1518,9 +1449,7 @@
(if (.function info) (if (.function info)
(let* ((locals (add-local locals name type 0)) (let* ((locals (add-local locals name type 0))
(info (clone info #:locals locals))) (info (clone info #:locals locals)))
(clone info #:text (append-text info ((value->ident info) name value)))
(append text
((value->ident info) name value))))
(clone info #:globals (append globals (list (ident->global name type 0 value))))))) (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
;; char c = 'A'; ;; char c = 'A';
@ -1529,9 +1458,7 @@
(let* ((locals (add-local locals name type 0)) (let* ((locals (add-local locals name type 0))
(info (clone info #:locals locals)) (info (clone info #:locals locals))
(value (char->integer (car (string->list value))))) (value (char->integer (car (string->list value)))))
(clone info #:text (append-text info ((value->ident info) name value))))
(append text
((value->ident info) name value)))))
;; int i = -1; ;; int i = -1;
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (neg (p-expr (fixed ,value))))))) ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (neg (p-expr (fixed ,value)))))))
@ -1539,9 +1466,7 @@
(if (.function info) (if (.function info)
(let* ((locals (add-local locals name type 0)) (let* ((locals (add-local locals name type 0))
(info (clone info #:locals locals))) (info (clone info #:locals locals)))
(clone info #:text (append-text info ((value->ident info) name value)))
(append text
((value->ident info) name value))))
(clone info #:globals (append globals (list (ident->global name type 0 value))))))) (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
;; int i = argc; ;; int i = argc;
@ -1549,13 +1474,10 @@
(if (not (.function info)) decl-barf2) (if (not (.function info)) decl-barf2)
(let* ((locals (add-local locals name type 0)) (let* ((locals (add-local locals name type 0))
(info (clone info #:locals locals))) (info (clone info #:locals locals)))
(clone info #:text (append-text info (append ((ident->accu info) local)
(append text ((accu->ident info) name)))))
((ident->accu info) local)
((accu->ident info) name)))))
;; char *p = "t.c"; ;; char *p = "t.c";
;;(decl (decl-spec-list (type-spec (fixed-type "char"))) (init-declr-list (init-declr (ptr-declr (pointer) (ident "p")) (initzer (p-expr (string "t.c\n"))))))
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (string ,string)))))) ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (string ,string))))))
(when (not (.function info)) (when (not (.function info))
(stderr "o=~s\n" o) (stderr "o=~s\n" o)
@ -1563,12 +1485,11 @@
(let* ((locals (add-local locals name type 1)) (let* ((locals (add-local locals name type 1))
(globals (append globals (list (string->global string)))) (globals (append globals (list (string->global string))))
(info (clone info #:locals locals #:globals globals))) (info (clone info #:locals locals #:globals globals)))
(clone info #:text (append-text info (append
(append text (list (lambda (f g ta t d)
(list (lambda (f g ta t d) (append
(append (i386:global->accu (+ (data-offset (add-s:-prefix string) g) d)))))
(i386:global->accu (+ (data-offset (add-s:-prefix string) g) d))))) ((accu->ident info) name)))))
((accu->ident info) name)))))
;; char *p = 0; ;; char *p = 0;
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (fixed ,value)))))) ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (fixed ,value))))))
@ -1576,10 +1497,8 @@
(if (.function info) (if (.function info)
(let* ((locals (add-local locals name type 1)) (let* ((locals (add-local locals name type 1))
(info (clone info #:locals locals))) (info (clone info #:locals locals)))
(clone info #:text (append-text info (append (wrap-as (i386:value->accu value))
(append text ((accu->ident info) name))))
(wrap-as (i386:value->accu value))
((accu->ident info) name))))
(clone info #:globals (append globals (list (ident->global name type 0 value))))))) (clone info #:globals (append globals (list (ident->global name type 0 value)))))))
;; char arena[20000]; ;; char arena[20000];
@ -1590,11 +1509,9 @@
(let* ((globals (.globals info)) (let* ((globals (.globals info))
(count (cstring->number count)) (count (cstring->number count))
(size (type->size info type)) (size (type->size info type))
;;;;(array (make-global name type -1 (string->list (make-string (* count size) #\nul))))
(array (make-global name type -1 (string->list (make-string (* count size) #\nul)))) (array (make-global name type -1 (string->list (make-string (* count size) #\nul))))
(globals (append globals (list array)))) (globals (append globals (list array))))
(clone info (clone info #:globals globals)))))
#:globals globals)))))
;;struct scm *g_cells = (struct scm*)arena; ;;struct scm *g_cells = (struct scm*)arena;
((decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (cast (type-name (decl-spec-list (type-spec (struct-ref (ident ,=type)))) (abs-declr (pointer))) (p-expr (ident ,value))))))) ((decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (cast (type-name (decl-spec-list (type-spec (struct-ref (ident ,=type)))) (abs-declr (pointer))) (p-expr (ident ,value)))))))
@ -1602,16 +1519,12 @@
(if (.function info) (if (.function info)
(let* ((locals (add-local locals name type 1)) (let* ((locals (add-local locals name type 1))
(info (clone info #:locals locals))) (info (clone info #:locals locals)))
(clone info #:text (append-text info (append ((ident->accu info) name)
(append text ((accu->ident info) value)))) ;; FIXME: deref?
((ident->accu info) name)
((accu->ident info) value)))) ;; FIXME: deref?
(let* ((globals (append globals (list (ident->global name type 1 0)))) (let* ((globals (append globals (list (ident->global name type 1 0))))
(info (clone info #:globals globals))) (info (clone info #:globals globals)))
(clone info #:text (append-text info (append ((ident->accu info) name)
(append text ((accu->ident info) value)))))) ;; FIXME: deref?
((ident->accu info) name)
((accu->ident info) value)))))) ;; FIXME: deref?
;; SCM tmp; ;; SCM tmp;
((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name)))) ((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name))))
@ -1627,9 +1540,7 @@
(if (.function info) (if (.function info)
(let* ((locals (add-local locals name type 0)) (let* ((locals (add-local locals name type 0))
(info (clone info #:locals locals))) (info (clone info #:locals locals)))
(clone info #:text (append-text info ((value->ident info) name value)))
(append text
((value->ident info) name value))))
(let ((globals (append globals (list (ident->global name type 0 value))))) (let ((globals (append globals (list (ident->global name type 0 value)))))
(clone info #:globals globals))))) (clone info #:globals globals)))))
@ -1643,16 +1554,12 @@
(if (.function info) (if (.function info)
(let* ((locals (add-local locals name type 0)) (let* ((locals (add-local locals name type 0))
(info (clone info #:locals locals))) (info (clone info #:locals locals)))
(clone info #:text (append-text info (append ((ident->accu info) local)
(append text ((accu->ident info) name))))
((ident->accu info) local)
((accu->ident info) name))))
(let* ((globals (append globals (list (ident->global name type 0 0)))) (let* ((globals (append globals (list (ident->global name type 0 0))))
(info (clone info #:globals globals))) (info (clone info #:globals globals)))
(clone info #:text (append-text info (append ((ident->accu info) local)
(append text ((accu->ident info) name))))))
((ident->accu info) local)
((accu->ident info) name))))))
;; int (*function) (void) = g_functions[g_cells[fn].cdr].function; ;; int (*function) (void) = g_functions[g_cells[fn].cdr].function;
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ftn-declr (scope (ptr-declr (pointer) (ident ,name))) (param-list . ,param-list)) (initzer ,initzer)))) ((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ftn-declr (scope (ptr-declr (pointer) (ident ,name))) (param-list . ,param-list)) (initzer ,initzer))))
@ -1676,10 +1583,8 @@
(if (.function info) (if (.function info)
(let* ((locals (add-local locals name type 1)) (let* ((locals (add-local locals name type 1))
(info (clone info #:locals locals))) (info (clone info #:locals locals)))
(clone info #:text (append-text info (append ((ident->accu info) value)
(append text ((accu->ident info) name))))
((ident->accu info) value)
((accu->ident info) name))))
(let* ((globals (append globals (list (ident->global name type 1 0)))) (let* ((globals (append globals (list (ident->global name type 1 0))))
(here (data-offset name globals)) (here (data-offset name globals))
(there (data-offset value globals))) (there (data-offset value globals)))
@ -1704,10 +1609,8 @@
(if (.function info) (if (.function info)
(let* ((locals (add-local locals name type 1)) (let* ((locals (add-local locals name type 1))
(info (clone info #:locals locals))) (info (clone info #:locals locals)))
(clone info #:text (append-text info (append ((ident->accu info) value)
(append text ((accu->ident info) name))))
((ident->accu info) value)
((accu->ident info) name))))
(let* ((globals (append globals (list (ident->global name type 1 0)))) (let* ((globals (append globals (list (ident->global name type 1 0))))
(here (data-offset name globals))) (here (data-offset name globals)))
(clone info (clone info
@ -1843,16 +1746,12 @@
;; EXPR ;; EXPR
((expr-stmt ,expression) ((expr-stmt ,expression)
(let ((info ((expr->accu info) expression))) (let ((info ((expr->accu info) expression)))
(clone info #:text (append-text info (wrap-as (i386:accu-zero?)))))
(append (.text info)
(wrap-as (i386:accu-zero?))))))
;; FIXME: why do we get (post-inc ...) here ;; FIXME: why do we get (post-inc ...) here
;; (array-ref ;; (array-ref
(_ (let ((info ((expr->accu info) o))) (_ (let ((info ((expr->accu info) o)))
(clone info #:text (append-text info (wrap-as (i386:accu-zero?)))))))))
(append (.text info)
(wrap-as (i386:accu-zero?))))))))))
(define (initzer->data info functions globals ta t d o) (define (initzer->data info functions globals ta t d o)
(pmatch o (pmatch o