artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity
mes/module/language/c99/compiler.mes
Jan Nieuwenhuizen 6a816687e8 core: Prepare gc.c for mescc, non-POSIX_SOURCE. 
* mes.c (NLENGTH, NVALUE, NVECTOR): New macros.
  (mes_builtins): Add comment on .i include order.
* module/language/c99/compiler.mes (mescc): Add define _POSIX_SOURCE=0.
* gc.c (gc_up_arena, gc_flip, gc_loop, gc)[!_POSIX_SOURCE]: Use eputs
  rather than fprintf.
  (gc_loop): Use CAR, TYPE, NVECTOR rather than .car, .type, .vector.
* gc.c (gc_up_arena)[!_POSIX_SOURCE]: Add non-POSIX mlib.c
  implementation.
2017-03-26 15:55:12 +02:00

2485 lines
107 KiB
Scheme
Raw Blame History

;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Mes.
;;;
;;; Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; compiler.mes produces an i386 binary from the C produced by
;;; Nyacc c99.
;;; Code:
(cond-expand
(guile-2
(set-port-encoding! (current-output-port) "ISO-8859-1"))
(guile)
(mes
(mes-use-module (nyacc lang c99 parser))
(mes-use-module (mes elf-util))
(mes-use-module (mes pmatch))
(mes-use-module (mes elf))
(mes-use-module (mes as-i386))
(mes-use-module (mes libc))
(mes-use-module (mes optargs))))
(define (logf port string . rest)
(apply format (cons* port string rest))
(force-output port)
#t)
(define (stderr string . rest)
(apply logf (cons* (current-error-port) string rest)))
(define (gnuc-xdef? name mode) (if (equal? name "__GNUC__") #f (eq? mode 'code)))
(define (mescc)
(parse-c99
#:inc-dirs (string-split (getenv "C_INCLUDE_PATH") #\:)
#:cpp-defs '(
"_POSIX_SOURCE=0"
"__GNUC__=0"
"__MESC__=1"
"__NYACC__=1" ;; REMOVEME
"STDIN=0"
"STDOUT=1"
"STDERR=2"
"O_RDONLY=0"
"INT_MIN=-2147483648"
"INT_MAX=2147483647"
"VERSION=\"0.4\""
"PREFIX=\"\""
)
#:xdef? gnuc-xdef?
#:mode 'code
))
(define (write-any x)
(write-char (cond ((char? x) x)
((and (number? x) (< (+ x 256) 0)) (format (current-error-port) "***BROKEN*** x=~a ==> ~a\n" x (dec->hex x)) (integer->char #xaa))
((number? x) (integer->char (if (>= x 0) x (+ x 256))))
((procedure? x)
(stderr "write-any: proc: ~a\n" x)
(stderr " ==> ~a\n" (map dec->hex (x '() '() 0 0)))
barf)
(else (stderr "write-any: ~a\n" x) barf))))
(define (ast:function? o)
(and (pair? o) (eq? (car o) 'fctn-defn)))
(define (.name o)
(pmatch o
((fctn-defn _ (ftn-declr (ident ,name) _) _) name)
((fctn-defn _ (ptr-declr (pointer) (ftn-declr (ident ,name) _)) _) name)
((param-decl _ (param-declr (ident ,name))) name)
((param-decl _ (param-declr (ptr-declr (pointer) (ident ,name)))) name)
((param-decl _ (param-declr (ptr-declr (pointer) (array-of (ident ,name))))) name)
(_
(format (current-error-port) "SKIP: .name =~a\n" o))))
(define (.type o)
(pmatch o
((param-decl (decl-spec-list (type-spec ,type)) _) (decl->type type))
((param-decl ,type _) type)
(_
(format (current-error-port) "SKIP: .type =~a\n" o))))
(define (.statements o)
(pmatch o
((fctn-defn _ (ftn-declr (ident ,name) _) (compd-stmt (block-item-list . ,statements))) statements)
((fctn-defn _ (ptr-declr (pointer) (ftn-declr (ident ,name) _)) (compd-stmt (block-item-list . ,statements))) statements)))
(define <info> '<info>)
(define <types> '<types>)
(define <constants> '<constants>)
(define <functions> '<functions>)
(define <globals> '<globals>)
(define <init> '<init>)
(define <locals> '<locals>)
(define <function> '<function>)
(define <text> '<text>)
(define* (make o #:key (types '()) (constants '()) (functions '()) (globals '()) (init '()) (locals '()) (function #f) (text '()))
(pmatch o
(<info> (list <info>
(cons <types> types)
(cons <constants> constants)
(cons <functions> functions)
(cons <globals> globals)
(cons <init> init)
(cons <locals> locals)
(cons <function> function)
(cons <text> text)))))
(define (.types o)
(pmatch o
((<info> . ,alist) (assq-ref alist <types>))))
(define (.constants o)
(pmatch o
((<info> . ,alist) (assq-ref alist <constants>))))
(define (.functions o)
(pmatch o
((<info> . ,alist) (assq-ref alist <functions>))))
(define (.globals o)
(pmatch o
((<info> . ,alist) (assq-ref alist <globals>))))
(define (.init o)
(pmatch o
((<info> . ,alist) (assq-ref alist <init>))))
(define (.locals o)
(pmatch o
((<info> . ,alist) (assq-ref alist <locals>))))
(define (.function o)
(pmatch o
((<info> . ,alist) (assq-ref alist <function>))))
(define (.text o)
(pmatch o
((<info> . ,alist) (assq-ref alist <text>))))
(define (info? o)
(and (pair? o) (eq? (car o) <info>)))
(define (clone o . rest)
(cond ((info? o)
(let ((types (.types o))
(constants (.constants o))
(functions (.functions o))
(globals (.globals o))
(init (.init o))
(locals (.locals o))
(function (.function o))
(text (.text o)))
(let-keywords rest
#f
((types types)
(constants constants)
(functions functions)
(globals globals)
(init init)
(locals locals)
(function function)
(text text))
(make <info> #:types types #:constants constants #:functions functions #:globals globals #:init init #:locals locals #:function function #:text text))))))
(define (push-global globals)
(lambda (o)
(list
(lambda (f g ta t d)
(i386:push-global (+ (data-offset o g) d))))))
(define (push-local locals)
(lambda (o)
(list
(lambda (f g ta t d)
(i386:push-local (local:id o))))))
(define (push-global-address globals)
(lambda (o)
(list
(lambda (f g ta t d)
(i386:push-global-address (+ (data-offset o g) d))))))
(define (push-local-address locals)
(lambda (o)
(list
(lambda (f g ta t d)
(i386:push-local-address (local:id o))))))
(define push-global-de-ref push-global)
(define (push-local-de-ref locals)
(lambda (o)
(list
(lambda (f g ta t d)
(i386:push-local-de-ref (local:id o))))))
(define (string->global string)
(make-global (add-s:-prefix string) "string" 0 (append (string->list string) (list #\nul))))
(define (ident->global name type pointer value)
(make-global name type pointer (int->bv32 value)))
(define (make-local name type pointer id)
(cons name (list type pointer id)))
(define local:type car)
(define local:pointer cadr)
(define local:id caddr)
(define (push-ident info)
(lambda (o)
(let ((local (assoc-ref (.locals info) o)))
(if local ((push-local (.locals info)) local)
(let ((global (assoc-ref (.globals info) o)))
(if global
((push-global (.globals info)) o) ;; FIXME: char*/int
(let ((constant (assoc-ref (.constants info) o)))
(if constant
(list (lambda (f g ta t d)
(append
(i386:value->accu constant)
(i386:push-accu))))
TODO:push-function))))))))
(define (push-ident-address info)
(lambda (o)
(let ((local (assoc-ref (.locals info) o)))
(if local ((push-local-address (.locals info)) local)
((push-global-address (.globals info)) o)))))
(define (push-ident-de-ref info)
(lambda (o)
(let ((local (assoc-ref (.locals info) o)))
(if local ((push-local-de-ref (.locals info)) local)
((push-global-de-ref (.globals info)) o)))))
(define (expr->arg info) ;; FIXME: get Mes curried-definitions
(lambda (o)
(let ((text (.text info)))
;;(stderr "expr->arg o=~s\n" o)
(pmatch o
((p-expr (fixed ,value))
(let ((value (cstring->number value)))
(clone info #:text (append text
(list
(lambda (f g ta t d)
(append
(i386:value->accu value)
(i386:push-accu))))))))
((neg (p-expr (fixed ,value)))
(let ((value (- (cstring->number value))))
(clone info #:text (append text
(list
(lambda (f g ta t d)
(append
(i386:value->accu value)
(i386:push-accu))))))))
((p-expr (string ,string))
(clone info #:text (append text ((push-global-address info) (add-s:-prefix string)))))
((p-expr (ident ,name))
(clone info #:text (append text ((push-ident info) name))))
;; g_cells[0]
((array-ref (p-expr (fixed ,index)) (p-expr (ident ,array)))
(let* ((index (cstring->number index))
(type (ident->type info array))
(size (type->size info type)))
(clone info
#:text (append text
((ident->base info) array)
(list
(lambda (f g ta t d)
(append
(i386:value->accu (* size index))
(if (eq? size 1)
(i386:byte-base-mem->accu)
(i386:base-mem->accu))
(i386:push-accu))))))))
;; g_cells[i]
((array-ref (p-expr (ident ,index)) (p-expr (ident ,array)))
(let* ((type (ident->type info array))
(size (type->size info type)))
(clone info #:text (append text
((ident->base info) index)
(list (lambda (f g ta t d)
(append
(i386:base->accu)
(if (< size 4) '()
(append ;; FIXME
(i386:accu+accu)
(if (= size 12) (i386:accu+base)
'()))))))
((ident->base info) array)
(list (lambda (f g ta t d)
(if (eq? size 1)
(i386:byte-base-mem->accu)
(i386:base-mem->accu))))
(list
(lambda (f g ta t d)
(i386:push-accu)))))))
((de-ref (p-expr (ident ,name)))
(clone info #:text (append text ((push-ident-de-ref info) name))))
((ref-to (p-expr (ident ,name)))
(clone info #:text (append text ((push-ident-address info) name))))
;; f (car (x))
((fctn-call . ,call)
(let* (;;(empty (clone info #:text '()))
;;(info ((ast->info empty) o))
(info ((ast->info info) o))
(text (.text info)))
(clone info
#:text (append text
(list
(lambda (f g ta t d)
(i386:push-accu)))))))
;; f (CAR (x))
((d-sel . ,d-sel)
(let* (;;(empty (clone info #:text '()))
;;(expr ((expr->accu empty) `(d-sel ,@d-sel)))
(expr ((expr->accu info) `(d-sel ,@d-sel)))
(text (.text expr)))
(clone info
#:text (append text
(list (lambda (f g ta t d)
(i386:push-accu)))))))
((p-expr (char ,char))
(let ((char (char->integer (car (string->list char)))))
(clone info
#:text (append text
(list (lambda (f g ta t d)
(append
(i386:value->accu char)
(i386:push-accu)))))))
)
;; f (0 + x)
;;; aargh
;;;((add (p-expr (fixed ,value)) (d-sel (ident cdr) (array-ref (p-expr (ident x)) (p-expr (ident g_cells))))))
((cast (type-name (decl-spec-list (type-spec (fixed-type _)))
(abs-declr (pointer)))
,cast)
((expr->arg info) cast))
(_
;; (stderr "catch: expr->arg=~s\n" o)
(let* ((info ((expr->accu info) o))
(text (.text info)))
(clone info
#:text (append text
(list (lambda (f g ta t d)
(append
(i386:accu-zero?)
(i386:push-accu))))))))
(_
(stderr "SKIP: expr->arg=~s\n" o)
barf
0)))))
;; FIXME: see ident->base
(define (ident->accu info)
(lambda (o)
(let ((local (assoc-ref (.locals info) o))
(global (assoc-ref (.globals info) o))
(constant (assoc-ref (.constants info) o)))
;; (stderr "ident->accu: local[~a]: ~a\n" o (and local (local:id local)))
;; (stderr "ident->accu: global[~a]: ~a\n" o global)
;; (stderr "globals: ~a\n" (.globals info))
;; (if (and (not global) (not (local:id local)))
;; (stderr "globals: ~a\n" (map car (.globals info))))
(if local
(let* ((ptr (local:pointer local))
(type (ident->type info o))
(size (and type (type->size info type))))
;;(stderr "ident->accu PTR[~a]: ~a\n" o ptr)
;;(stderr "type: ~s\n" type)
;;(stderr "ident->accu PTR[~a]: ~a\n" o ptr)
;;(stderr "locals: ~s\n" locals)
(case ptr
((-1) (list (lambda (f g ta t d)
(i386:local-ptr->accu (local:id local)))))
((1) (list (lambda (f g ta t d)
(i386:local->accu (local:id local)))))
(else
(list (lambda (f g ta t d)
(if (= size 1)
(i386:byte-local->accu (local:id local))
(i386:local->accu (local:id local))))))))
(if global
(let ((ptr (ident->pointer info o)))
;;(stderr "ident->accu PTR[~a]: ~a\n" o ptr)
(case ptr
((-1) (list (lambda (f g ta t d)
(i386:global->accu (+ (data-offset o g) d)))))
(else (list (lambda (f g ta t d)
(i386:global-address->accu (+ (data-offset o g) d)))))))
(if constant
(list (lambda (f g ta t d)
(i386:value->accu constant)))
(list (lambda (f g ta t d)
(i386:global->accu (+ ta (function-offset o f)))))))))))
(define (value->accu v)
(list (lambda (f g ta t d)
(i386:value->accu v))))
(define (accu->ident info)
(lambda (o)
(let ((local (assoc-ref (.locals info) o)))
(if local
(list (lambda (f g ta t d)
(i386:accu->local (local:id local))))
(list (lambda (f g ta t d)
(i386:accu->global (+ (data-offset o g) d))))))))
(define (base->ident info)
(lambda (o)
(let ((local (assoc-ref (.locals info) o)))
(if local
(list (lambda (f g ta t d)
(i386:base->local (local:id local))))
(list (lambda (f g ta t d)
(i386:base->global (+ (data-offset o g) d))))))))
(define (base->ident-address info)
(lambda (o)
(let ((local (assoc-ref (.locals info) o)))
(if local
(list (lambda (f g ta t d)
(append
(i386:local->accu (local:id local))
(i386:byte-base->accu-address))))
TODO:base->ident-address-global))))
(define (value->ident info)
(lambda (o value)
(let ((local (assoc-ref (.locals info) o)))
(if local
(list (lambda (f g ta t d)
(i386:value->local (local:id local) value)))
(list (lambda (f g ta t d)
(i386:value->global (+ (data-offset o g) d) value)))))))
(define (ident-add info)
(lambda (o n)
(let ((local (assoc-ref (.locals info) o)))
(if local
(list (lambda (f g ta t d)
(i386:local-add (local:id local) n)))
(list (lambda (f g ta t d)
(i386:global-add (+ (data-offset o g) d) n)))))))
;; FIXME: see ident->accu
(define (ident->base info)
(lambda (o)
(let ((local (assoc-ref (.locals info) o)))
;;(stderr "ident->base: local[~a]: ~a\n" o (and local (local:id local)))
(if local
(let* ((ptr (local:pointer local))
(type (ident->type info o))
(size (and type (type->size info type))))
(case ptr
((-1) (list (lambda (f g ta t d)
(i386:local-ptr->base (local:id local)))))
((1) (list (lambda (f g ta t d)
(i386:local->base (local:id local)))))
(else
(list (lambda (f g ta t d)
(if (= size 1)
(i386:byte-local->base (local:id local))
(i386:local->base (local:id local))))))))
(let ((global (assoc-ref (.globals info) o) ))
(if global
(let ((ptr (ident->pointer info o)))
;;(stderr "ident->accu PTR[~a]: ~a\n" o ptr)
(case ptr
((-1) (list (lambda (f g ta t d)
(i386:global->base (+ (data-offset o g) d)))))
(else (list (lambda (f g ta t d)
(i386:global-address->base (+ (data-offset o g) d)))))))
(let ((constant (assoc-ref (.constants info) o)))
(if constant
(list (lambda (f g ta t d)
(i386:value->base constant)))
(list (lambda (f g ta t d)
(i386:global->base (+ ta (function-offset o f)))))))))))))
(define (expr->accu info)
(lambda (o)
(let ((text (.text info))
(locals (.locals info))
(globals (.globals info)))
;;(stderr "expr->accu o=~a\n" o)
(pmatch o
((p-expr (string ,string))
(clone info #:text (append text (list (lambda (f g ta t d)
;;(stderr "OFF[~a]: ~a\n" string (data-offset string globals))
;;(stderr "globals: ~s\n" (map car globals))
(i386:global->accu (+ (data-offset (add-s:-prefix string) globals) d)))))))
((p-expr (fixed ,value))
(clone info #:text (append text (value->accu (cstring->number value)))))
((p-expr (ident ,name))
(clone info #:text (append text ((ident->accu info) name))))
((fctn-call . _) ((ast->info info) `(expr-stmt ,o)))
((not (fctn-call . _)) ((ast->info info) o))
((neg (p-expr (fixed ,value)))
(clone info #:text (append text (value->accu (- (cstring->number value))))))
((initzer ,initzer) ((expr->accu info) initzer))
((ref-to (p-expr (ident ,name)))
(clone info #:text
(append (.text info)
((ident->accu info) name))))
((sizeof-type (type-name (decl-spec-list (type-spec (struct-ref (ident ,name))))))
(let* ((type (list "struct" name))
(fields (or (type->description info type) '()))
(size (type->size info type)))
(clone info #:text
(append text
(list (lambda (f g ta t d)
(append
(i386:value->accu size))))))))
;; c+p expr->arg
((array-ref (p-expr (fixed ,index)) (p-expr (ident ,array)))
(let* ((index (cstring->number index))
(type (ident->type info array))
(size (type->size info type)))
(clone info #:text
(append text
((ident->base info) array)
(list (lambda (f g ta t d)
(append
(i386:value->accu (* size index))
(if (eq? size 1)
(i386:byte-base-mem->accu)
(i386:base-mem->accu)))))))))
;; c+p expr->arg
((array-ref (p-expr (ident ,index)) (p-expr (ident ,array)))
(let* ((type (ident->type info array))
(size (type->size info type)))
(clone info #:text (append text
((ident->base info) index)
(list (lambda (f g ta t d)
(append
(i386:base->accu)
(if (< size 4) '()
(append ;; FIXME
(i386:accu+accu)
(if (= size 12) (i386:accu+base)
'()))))))
((ident->base info) array)
(list (lambda (f g ta t d)
(if (eq? size 1)
(i386:byte-base-mem->accu)
(i386:base-mem->accu))))))))
;; f.field
((d-sel (ident ,field) (p-expr (ident ,array)))
(let* ((type (ident->type info array))
(fields (type->description info type))
(field-size 4) ;; FIXME:4, not fixed
(offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
(text (.text info)))
(clone info #:text
(append text
((ident->accu info) array)
(list (lambda (f g ta t d)
(i386:mem+n->accu offset)))))))
;; g_cells[10].type
((d-sel (ident ,field) (array-ref (p-expr (fixed ,index)) (p-expr (ident ,array))))
(let* ((type (ident->type info array))
(fields (or (type->description info type) '()))
(size (type->size info type))
(count (length fields))
(field-size 4) ;; FIXME:4, not fixed
(offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
(index (cstring->number index))
(text (.text info)))
(clone info #:text
(append text
(list (lambda (f g ta t d)
(append
(i386:value->base index)
(i386:base->accu)
(if (> count 1) (i386:accu+accu) '())
(if (= count 3) (i386:accu+base) '())
(i386:accu-shl 2))))
((ident->base info) array)
(list (lambda (f g ta t d)
(i386:base-mem+n->accu offset)))))))
;; g_cells[x].type
((d-sel (ident ,field) (array-ref (p-expr (ident ,index)) (p-expr (ident ,array))))
(let* ((type (ident->type info array))
(fields (or (type->description info type) '()))
(size (type->size info type))
(count (length fields))
(field-size 4) ;; FIXME:4, not fixed
(offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
(text (.text info)))
(clone info #:text
(append text
((ident->base info) index)
(list (lambda (f g ta t d)
(append
(i386:base->accu)
(if (> count 1) (i386:accu+accu) '())
(if (= count 3) (i386:accu+base) '())
(i386:accu-shl 2))))
((ident->base info) array)
(list (lambda (f g ta t d)
(i386:base-mem+n->accu offset)))))))
;; g_functions[g_cells[fn].cdr].arity
;; INDEX0: g_cells[fn].cdr
;;; index: (d-sel (ident ,cdr) (array-ref (p-expr (ident ,fn)) (p-expr (ident ,g_cells))))
;;((d-sel (ident ,arity) (array-ref (d-sel (ident ,cdr) (array-ref (p-expr (ident ,fn)) (p-expr (ident ,g_cells)))) (p-expr (ident ,g_functions)))))
((d-sel (ident ,field) (array-ref ,index (p-expr (ident ,array))))
(let* ((empty (clone info #:text '()))
(index ((expr->accu empty) index))
(type (ident->type info array))
(fields (or (type->description info type) '()))
(size (type->size info type))
(count (length fields))
(field-size 4) ;; FIXME:4, not fixed
(rest (or (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))
barf
'()))
(offset (* field-size (1- (length rest))))
(text (.text info)))
(clone info #:text
(append text
(.text index)
(list (lambda (f g ta t d)
(append
(i386:accu->base)
(if (> count 1) (i386:accu+accu) '())
(if (= count 3) (i386:accu+base) '())
(i386:accu-shl 2))))
((ident->base info) array)
(list (lambda (f g ta t d)
(i386:base-mem+n->accu offset)))))))
;;; FIXME: FROM INFO ...only zero?!
((p-expr (fixed ,value))
(let ((value (cstring->number value)))
(clone info #:text
(append text
(list (lambda (f g ta t d)
(i386:value->accu value)))))))
((p-expr (char ,char))
(let ((char (char->integer (car (string->list char)))))
(clone info #:text
(append text
(list (lambda (f g ta t d)
(i386:value->accu char)))))))
((p-expr (ident ,name))
(clone info #:text
(append text
((ident->accu info) name))))
((de-ref (p-expr (ident ,name)))
(let* ((type (ident->type info name))
(size (and type (type->size info type))))
(clone info #:text
(append text
((ident->accu info) name)
(list (lambda (f g ta t d)
(if (= size 1)
(i386:byte-mem->accu)
(i386:mem->accu))))))))
;; GRR --> info again??!?
((fctn-call . ,call)
((ast->info info) `(expr-stmt ,o)))
((cond-expr . ,cond-expr)
((ast->info info) `(expr-stmt ,o)))
;; FIXME
;;((post-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
((post-inc (p-expr (ident ,name)))
(clone info #:text
(append text
((ident->accu info) name)
((ident-add info) name 1))))
;; GRR --> info again??!?
((post-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
((post-dec ,expr) ((ast->info info) `(expr-stmt ,o)))
((pre-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
((pre-dec ,expr) ((ast->info info) `(expr-stmt ,o)))
((add (p-expr (ident ,name)) ,b)
(let* ((empty (clone info #:text '()))
(base ((expr->base empty) b)))
(clone info #:text
(append text
(.text base)
((ident->accu info) name)
(list (lambda (f g ta t d)
(i386:accu+base)))))))
((add ,a ,b)
(let* ((empty (clone info #:text '()))
(accu ((expr->accu empty) a))
(base ((expr->base empty) b)))
(clone info #:text
(append text
(.text accu)
(.text base)
(list (lambda (f g ta t d)
(i386:accu+base)))))))
((sub ,a ,b)
(let* ((empty (clone info #:text '()))
(accu ((expr->accu empty) a))
(base ((expr->base empty) b)))
(clone info #:text
(append text
(.text accu)
(.text base)
(list (lambda (f g ta t d)
(i386:accu-base)))))))
((bitwise-or ,a ,b)
(let* ((empty (clone info #:text '()))
(accu ((expr->accu empty) a))
(base ((expr->base empty) b)))
(clone info #:text
(append text
(.text accu)
(.text base)
(list (lambda (f g ta t d)
(i386:accu-or-base)))))))
((lshift ,a ,b)
(let* ((empty (clone info #:text '()))
(accu ((expr->accu empty) a))
(base ((expr->base empty) b)))
(clone info #:text
(append text
(.text accu)
(.text base)
(list (lambda (f g ta t d)
(i386:accu<<base)))))))
((rshift ,a ,b)
(let* ((empty (clone info #:text '()))
(accu ((expr->accu empty) a))
(base ((expr->base empty) b)))
(clone info #:text
(append text
(.text accu)
(.text base)
(list (lambda (f g ta t d)
(i386:accu>>base)))))))
((div ,a ,b)
(let* ((empty (clone info #:text '()))
(accu ((expr->accu empty) a))
(base ((expr->base empty) b)))
(clone info #:text
(append text
(.text accu)
(.text base)
(list (lambda (f g ta t d)
(i386:accu/base)))))))
((mod ,a ,b)
(let* ((empty (clone info #:text '()))
(accu ((expr->accu empty) a))
(base ((expr->base empty) b)))
(clone info #:text
(append text ;;FIXME:empty
(.text accu)
(.text base)
(list (lambda (f g ta t d)
(i386:accu%base)))))))
((mul ,a ,b)
(let* ((empty (clone info #:text '()))
(accu ((expr->accu empty) a))
(base ((expr->base empty) b)))
(clone info #:text
(append text
(.text accu)
(.text base)
(list (lambda (f g ta t d)
(i386:accu*base)))))))
;; FIXME: c/p ast->info
((eq ,a ,b)
(let* ((base ((expr->base info) a))
(empty (clone base #:text '()))
(accu ((expr->accu empty) b)))
(clone info #:text
(append (.text base)
(list (lambda (f g ta t d)
(i386:push-base)))
(.text accu)
(list (lambda (f g ta t d)
(i386:pop-base)))
(list (lambda (f g ta t d)
(i386:sub-base)))))))
;; FIXME: c/p ast->info
((lt ,a ,b)
(let* ((base ((expr->base info) a))
(empty (clone base #:text '()))
(accu ((expr->accu empty) b)))
(clone info #:text
(append (.text base)
(.text accu)
(list (lambda (f g ta t d)
(i386:base-sub)))))))
;; FIXME: ...c/p ast->info
((neg (p-expr (ident ,name)))
(clone info #:text (append text
((ident->base info) name)
(list (lambda (f g ta t d)
(i386:value->accu 0)))
(list (lambda (f g ta t d)
(i386:sub-base))))))
;;((cast (type-name (decl-spec-list (type-spec (typename "SCM"))) (abs-declr (declr-fctn (declr-scope (abs-declr (pointer))) (param-list (param-decl (decl-spec-list (type-spec (typename "SCM")))))))) (d-sel (ident "function") (array-ref (d-sel (ident "cdr") (array-ref (p-expr (ident "fn")) (p-expr (ident "g_cells")))) (p-expr (ident "functions"))))))
((cast ,cast ,o)
((expr->accu info) o))
((assn-expr (p-expr (ident ,name)) ,op ,expr)
(let ((info ((ast->info info) o)))
(clone info #:text (append (.text info)
((ident->accu info) name)))))
(_
(format (current-error-port) "SKIP: expr->accu=~s\n" o)
barf
info)))))
(define (expr->base info)
(lambda (o)
(let ((info ((expr->accu info) o)))
(clone info
#:text (append
(list (lambda (f g ta t d)
(i386:push-accu)))
(.text info)
(list (lambda (f g ta t d)
(append
(i386:accu->base)
(i386:pop-accu)))))))))
(define (expr->accu* info)
(lambda (o)
(pmatch o
;;(stderr "expr->accu* o=~s\n" o)
;; g_cells[10].type
((d-sel (ident ,field) (array-ref (p-expr (fixed ,index)) (p-expr (ident ,array))))
(let* ((type (ident->type info array))
(fields (or (type->description info type) '()))
(size (type->size info type))
(count (length fields))
(field-size 4) ;; FIXME:4, not fixed
(offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
(index (cstring->number index))
(text (.text info)))
(clone info #:text
(append text
(list (lambda (f g ta t d)
(append
(i386:value->base index)
(i386:base->accu)
(if (> count 1) (i386:accu+accu) '())
(if (= count 3) (i386:accu+base) '())
(i386:accu-shl 2))))
;; de-ref: g_cells, non: arena
;;((ident->base info) array)
((ident->base info) array)
(list (lambda (f g ta t d)
(append
(i386:accu+base)
(i386:accu+value offset))))))))
;; g_cells[x].type
((d-sel (ident ,field) (array-ref (p-expr (ident ,index)) (p-expr (ident ,array))))
(let* ((type (ident->type info array))
(fields (or (type->description info type) '()))
(size (type->size info type))
(count (length fields))
(field-size 4) ;; FIXME:4, not fixed
(offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
(text (.text info)))
(clone info #:text
(append text
((ident->base info) index)
(list (lambda (f g ta t d)
(append
(i386:base->accu)
(if (> count 1) (i386:accu+accu) '())
(if (= count 3) (i386:accu+base) '())
(i386:accu-shl 2))))
;; de-ref: g_cells, non: arena
;;((ident->base info) array)
((ident->base info) array)
(list (lambda (f g ta t d)
(append
(i386:accu+base)
(i386:accu+value offset))))))))
;;((d-sel (ident "cdr") (p-expr (ident "scm_make_cell"))))
((d-sel (ident ,field) (p-expr (ident ,name)))
(let* ((type (ident->type info name))
(fields (or (type->description info type) '()))
(field-size 4) ;; FIXME
(offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))))))
(text (.text info)))
(clone info #:text
(append text
((ident->accu info) name)
(list (lambda (f g ta t d)
(i386:accu+value offset)))))))
(_
(format (current-error-port) "SKIP: expr->accu*=~s\n" o)
barf
info)
)))
(define (ident->constant name value)
(cons name value))
(define (make-type name type size description)
(cons name (list type size description)))
(define (enum->type name fields)
(make-type name 'enum 4 fields))
(define (struct->type name fields)
(make-type name 'struct (* 4 (length fields)) fields)) ;; FIXME
(define (decl->type o)
(pmatch o
((fixed-type ,type) type)
((struct-ref (ident ,name)) (list "struct" name))
((decl (decl-spec-list (type-spec (struct-ref (ident ,name)))));; "scm"
(list "struct" name)) ;; FIXME
((typename ,name) name)
(_
(stderr "SKIP: decl type=~s\n" o)
barf
o)))
(define (expr->global o)
(pmatch o
((p-expr (string ,string)) (string->global string))
(_ #f)))
(define (initzer->global o)
(pmatch o
((initzer ,initzer) (expr->global initzer))
(_ #f)))
(define (byte->hex o)
(string->number (string-drop o 2) 16))
(define (asm->hex o)
(let ((prefix ".byte "))
(if (not (string-prefix? prefix o)) (begin (stderr "SKIP:~s\n" o)'())
(let ((s (string-drop o (string-length prefix))))
(map byte->hex (string-split s #\space))))))
(define (case->jump-info info)
(define (jump n)
(list (lambda (f g ta t d) (i386:Xjump n))))
(define (jump-nz n)
(list (lambda (f g ta t d) (i386:Xjump-nz n))))
(define (statement->info info body-length)
(lambda (o)
(pmatch o
((break) (clone info #:text (append (.text info) (jump body-length)
)))
(_
((ast->info info) o)))))
(lambda (o)
(pmatch o
((case (p-expr (ident ,constant)) (compd-stmt (block-item-list . ,elements)))
(lambda (body-length)
(define (test->text value clause-length)
(append (list (lambda (f g ta t d) (i386:accu-cmp-value value)))
(jump-nz clause-length)))
(let* ((value (assoc-ref (.constants info) constant))
(test-info
(clone info #:text (append (.text info) (test->text value 0))))
(text-length (length (.text test-info)))
(clause-info (let loop ((elements elements) (info test-info))
(if (null? elements) info
(loop (cdr elements) ((statement->info info body-length) (car elements))))))
(clause-text (list-tail (.text clause-info) text-length))
(clause-length (length (text->list clause-text))))
(clone info #:text (append
(.text info)
(test->text value clause-length)
clause-text)
#:globals (.globals clause-info)))))
((case (p-expr (fixed ,value)) (compd-stmt (block-item-list . ,elements)))
(lambda (body-length)
(define (test->text value clause-length)
(append (list (lambda (f g ta t d) (i386:accu-cmp-value value)))
(jump-nz clause-length)))
(let* ((value (cstring->number value))
(test-info
(clone info #:text (append (.text info) (test->text value 0))))
(text-length (length (.text test-info)))
(clause-info (let loop ((elements elements) (info test-info))
(if (null? elements) info
(loop (cdr elements) ((statement->info info body-length) (car elements))))))
(clause-text (list-tail (.text clause-info) text-length))
(clause-length (length (text->list clause-text))))
(clone info #:text (append
(.text info)
(test->text value clause-length)
clause-text)
#:globals (.globals clause-info)))))
((case (neg (p-expr (fixed ,value))) ,statement)
((case->jump-info info) `(case (p-expr (fixed ,(string-append "-" value))) ,statement)))
((default (compd-stmt (block-item-list . ,elements)))
(lambda (body-length)
(let ((text-length (length (.text info))))
(let loop ((elements elements) (info info))
(if (null? elements) info
(loop (cdr elements) ((statement->info info body-length) (car elements))))))))
((case (p-expr (ident ,constant)) ,statement)
((case->jump-info info) `(case (p-expr (ident ,constant)) (compd-stmt (block-item-list ,statement)))))
((case (p-expr (fixed ,value)) ,statement)
((case->jump-info info) `(case (p-expr (fixed ,value)) (compd-stmt (block-item-list ,statement)))))
((default ,statement)
((case->jump-info info) `(default (compd-stmt (block-item-list ,statement)))))
(_ (stderr "no case match: ~a\n" o) barf)
)))
(define (test->jump->info info)
(define (jump type . test)
(lambda (o)
(let* ((text (.text info))
(info (clone info #:text '()))
(info ((ast->info info) o))
(jump-text (lambda (body-length)
(list (lambda (f g ta t d) (type body-length))))))
(lambda (body-length)
(clone info #:text
(append text
(.text info)
(if (null? test) '() (car test))
(jump-text body-length)))))))
(lambda (o)
(pmatch o
;; unsigned
;; ((le ,a ,b) ((jump i386:Xjump-ncz) o)) ; ja
;; ((lt ,a ,b) ((jump i386:Xjump-nc) o)) ; jae
;; ((ge ,a ,b) ((jump i386:Xjump-ncz) o))
;; ((gt ,a ,b) ((jump i386:Xjump-nc) o))
((le ,a ,b) ((jump i386:Xjump-g) o))
((lt ,a ,b) ((jump i386:Xjump-ge) o))
((ge ,a ,b) ((jump i386:Xjump-g) o))
((gt ,a ,b) ((jump i386:Xjump-ge) o))
((ne ,a ,b) ((jump i386:Xjump-nz) o))
((eq ,a ,b) ((jump i386:Xjump-nz) o))
((not _) ((jump i386:Xjump-z) o))
((and ,a ,b)
(let* ((text (.text info))
(info (clone info #:text '()))
(a-jump ((test->jump->info info) a))
(a-text (.text (a-jump 0)))
(a-length (length (text->list a-text)))
(b-jump ((test->jump->info info) b))
(b-text (.text (b-jump 0)))
(b-length (length (text->list b-text))))
(lambda (body-length)
(clone info #:text
(append text
(.text (a-jump (+ b-length body-length)))
(.text (b-jump body-length)))))))
((or ,a ,b)
(let* ((text (.text info))
(info (clone info #:text '()))
(a-jump ((test->jump->info info) a))
(a-text (.text (a-jump 0)))
(a-length (length (text->list a-text)))
(jump-text (list (lambda (f g ta t d) (i386:Xjump 0))))
(jump-length (length (text->list jump-text)))
(b-jump ((test->jump->info info) b))
(b-text (.text (b-jump 0)))
(b-length (length (text->list b-text)))
(jump-text (list (lambda (f g ta t d) (i386:Xjump b-length)))))
(lambda (body-length)
(clone info #:text
(append text
(.text (a-jump jump-length))
jump-text
(.text (b-jump body-length)))))))
((array-ref . _) ((jump i386:jump-byte-z
(list (lambda (f g ta t d) (i386:accu-zero?)))) o))
((de-ref _) ((jump i386:jump-byte-z
(list (lambda (f g ta t d) (i386:accu-zero?)))) o))
((assn-expr (p-expr (ident ,name)) ,op ,expr)
((jump i386:Xjump-z
(append
((ident->accu info) name)
(list (lambda (f g ta t d) (i386:accu-zero?))))) o))
(_ ((jump i386:Xjump-z (list (lambda (f g ta t d) (i386:accu-zero?)))) o)))))
(define (cstring->number s)
(cond ((string-prefix? "0x" s) (string->number (string-drop s 2) 16))
((string-prefix? "0" s) (string->number s 8))
(else (string->number s))))
(define (struct-field o)
(pmatch o
((comp-decl (decl-spec-list (type-spec (enum-ref (ident ,type))))
(comp-declr-list (comp-declr (ident ,name))))
(cons type name))
((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ident ,name))))
(cons type name))
((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ident ,name))))
(cons type name))
((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ftn-declr (scope (ptr-declr (pointer) (ident ,name))) (param-list (param-decl (decl-spec-list (type-spec (void)))))))))
(cons type name)) ;; FIXME function / int
((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
(cons type name)) ;; FIXME: ptr/char
(_ (stderr "struct-field: no match: ~s\n" o) barf)))
(define (ast->type o)
(pmatch o
((fixed-type ,type)
type)
((struct-ref (ident ,type))
(list "struct" type))
(_ (stderr "SKIP: type=~s\n" o)
"int")))
(define i386:type-alist
'(("char" . (builtin 1 #f))
("int" . (builtin 4 #f))))
(define (type->size info o)
;;(stderr "types=~s\n" (.types info))
;;(stderr "type->size o=~s => ~s\n" o (cadr (assoc-ref (.types info) o)))
(pmatch o
((decl-spec-list (type-spec (fixed-type ,type)))
(type->size info type))
((decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qual))
(type->size info type))
(_ (let ((type (assoc-ref (.types info) o)))
(if type (cadr type)
(begin
(stderr "***TYPE NOT FOUND**: o=~s\n" o)
barf
4))))))
(define (ident->decl info o)
;; (stderr "ident->decl o=~s\n" o)
;; (stderr " types=~s\n" (.types info))
;; (stderr " local=~s\n" (assoc-ref (.locals info) o))
;; (stderr " global=~s\n" (assoc-ref (.globals info) o))
(or (assoc-ref (.locals info) o)
(assoc-ref (.globals info) o)
(begin
(stderr "NO IDENT: ~a\n" (assoc-ref (.functions info) o))
(assoc-ref (.functions info) o))))
(define (ident->type info o)
(and=> (ident->decl info o) car))
(define (ident->pointer info o)
(let ((local (assoc-ref (.locals info) o)))
(if local (local:pointer local)
(or (and=> (ident->decl info o) global:pointer) 0))))
(define (type->description info o)
;; (stderr "type->description =~s\n" o)
;; (stderr "types=~s\n" (.types info))
;; (stderr "type->description o=~s ==> ~s\n" o (caddr (assoc-ref (.types info) o)))
;; (stderr " assoc ~a\n" (assoc-ref (.types info) o))
(pmatch o
((decl-spec-list (type-spec (fixed-type ,type)))
(type->description info type))
((decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qual))
(type->description info type))
(_ (caddr (assoc-ref (.types info) o)))))
(define (local? o) ;; formals < 0, locals > 0
(positive? (local:id o)))
(define (ast->info info)
(lambda (o)
(let ((globals (.globals info))
(locals (.locals info))
(constants (.constants info))
(text (.text info)))
(define (add-local locals name type pointer)
(let* ((id (1+ (length (filter local? (map cdr locals)))))
(locals (cons (make-local name type pointer id) locals)))
locals))
;; (stderr "\n ast->info=~s\n" o)
;; (stderr " globals[~a=>~a]: ~a\n" (length globals) (length (append-map cdr globals)) (map (lambda (s) (if (string? s) (string-delete #\newline s))) (map car globals)))
;; (stderr " text=~a\n" text)
;; (stderr " info=~a\n" info)
;; (stderr " globals=~a\n" globals)
(pmatch o
(((trans-unit . _) . _)
((ast-list->info info) o))
((trans-unit . ,elements)
((ast-list->info info) elements))
((fctn-defn . _) ((function->info info) o))
((comment . _) info)
((cpp-stmt (define (name ,name) (repl ,value)))
info)
((cast (type-name (decl-spec-list (type-spec (void)))) _)
info)
;; FIXME: expr-stmt wrapper?
(trans-unit info)
((expr-stmt) info)
((assn-expr . ,assn-expr)
((ast->info info) `(expr-stmt ,o)))
((d-sel . ,d-sel)
(let ((expr ((expr->accu info) `(d-sel ,@d-sel))))
expr))
((compd-stmt (block-item-list . ,statements)) ((ast-list->info info) statements))
((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))
(if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list)))) ;; FIXME
(clone info #:text (append text (list (lambda (f g ta t d) (asm->hex arg0))))))
(let* ((globals (append globals (filter-map expr->global expr-list)))
(info (clone info #:globals globals))
(text-length (length text))
(args-info (let loop ((expressions (reverse expr-list)) (info info))
(if (null? expressions) info
(loop (cdr expressions) ((expr->arg info) (car expressions))))))
(text (.text args-info))
(n (length expr-list)))
(if (and (not (assoc-ref locals name))
(assoc-ref (.functions info) name))
(clone args-info #:text
(append text
(list (lambda (f g ta t d)
(i386:call f g ta t d (+ t (function-offset name f)) n))))
#:globals globals)
(let* ((empty (clone info #:text '()))
(accu ((expr->accu empty) `(p-expr (ident ,name)))))
(clone args-info #:text
(append text
(.text accu)
(list (lambda (f g ta t d)
(i386:call-accu f g ta t d n))))
#:globals globals))))))
;;((expr-stmt (fctn-call (d-sel (ident "function") (array-ref (d-sel (ident "cdr") (array-ref (p-expr (ident "fn")) (p-expr (ident "g_cells")))) (p-expr (ident "g_functions")))) (expr-list))))
((expr-stmt (fctn-call ,function (expr-list . ,expr-list)))
(let* ((globals (append globals (filter-map expr->global expr-list)))
(info (clone info #:globals globals))
(text-length (length text))
(args-info (let loop ((expressions (reverse expr-list)) (info info))
(if (null? expressions) info
(loop (cdr expressions) ((expr->arg info) (car expressions))))))
(text (.text args-info))
(n (length expr-list))
(empty (clone info #:text '()))
(accu ((expr->accu empty) function)))
(clone info #:text
(append text
(.text accu)
(list (lambda (f g ta t d)
(i386:call-accu f g ta t d n))))
#:globals globals)))
((if ,test ,body)
(let* ((text-length (length text))
(test-jump->info ((test->jump->info info) test))
(test+jump-info (test-jump->info 0))
(test-length (length (.text test+jump-info)))
(body-info ((ast->info test+jump-info) body))
(text-body-info (.text body-info))
(body-text (list-tail text-body-info test-length))
(body-length (length (text->list body-text)))
(text+test-text (.text (test-jump->info body-length)))
(test-text (list-tail text+test-text text-length)))
(clone info #:text
(append text
test-text
body-text)
#:globals (.globals body-info))))
((if ,test ,then ,else)
(let* ((text-length (length text))
(test-jump->info ((test->jump->info info) test))
(test+jump-info (test-jump->info 0))
(test-length (length (.text test+jump-info)))
(then-info ((ast->info test+jump-info) then))
(text-then-info (.text then-info))
(then-text (list-tail text-then-info test-length))
(then-jump-text (list (lambda (f g ta t d) (i386:Xjump 0))))
(then-jump-length (length (text->list then-jump-text)))
(then-length (+ (length (text->list then-text)) then-jump-length))
(then+jump-info (clone then-info #:text (append text-then-info then-jump-text)))
(else-info ((ast->info then+jump-info) else))
(text-else-info (.text else-info))
(else-text (list-tail text-else-info (length (.text then+jump-info))))
(else-length (length (text->list else-text)))
(text+test-text (.text (test-jump->info then-length)))
(test-text (list-tail text+test-text text-length))
(then-jump-text (list (lambda (f g ta t d) (i386:Xjump else-length)))))
(clone info #:text
(append text
test-text
then-text
then-jump-text
else-text)
#:globals (append (.globals then-info)
(list-tail (.globals else-info) (length globals))))))
((expr-stmt (cond-expr ,test ,then ,else))
(let* ((text-length (length text))
(test-jump->info ((test->jump->info info) test))
(test+jump-info (test-jump->info 0))
(test-length (length (.text test+jump-info)))
(then-info ((ast->info test+jump-info) then))
(text-then-info (.text then-info))
(then-text (list-tail text-then-info test-length))
(then-length (length (text->list then-text)))
(jump-text (list (lambda (f g ta t d) (i386:Xjump 0))))
(jump-length (length (text->list jump-text)))
(test+then+jump-info
(clone then-info
#:text (append (.text then-info) jump-text)))
(else-info ((ast->info test+then+jump-info) else))
(text-else-info (.text else-info))
(else-text (list-tail text-else-info (length (.text test+then+jump-info))))
(else-length (length (text->list else-text)))
(text+test-text (.text (test-jump->info (+ then-length jump-length))))
(test-text (list-tail text+test-text text-length))
(jump-text (list (lambda (f g ta t d) (i386:Xjump else-length)))))
(clone info #:text
(append text
test-text
then-text
jump-text
else-text)
#:globals (.globals else-info))))
((switch ,expr (compd-stmt (block-item-list . ,cases)))
(let* ((expr ((expr->accu info) expr))
(empty (clone info #:text '()))
(case-infos (map (case->jump-info empty) cases))
(case-lengths (map (lambda (c-j) (length (text->list (.text (c-j 0))))) case-infos))
(cases-info (let loop ((cases cases) (info expr) (lengths case-lengths))
(if (null? cases) info
(let ((c-j ((case->jump-info info) (car cases))))
(loop (cdr cases) (c-j (apply + (cdr lengths))) (cdr lengths)))))))
cases-info))
((for ,init ,test ,step ,body)
(let* ((info (clone info #:text '())) ;; FIXME: goto in body...
(info ((ast->info info) init))
(init-text (.text info))
(init-locals (.locals info))
(info (clone info #:text '()))
(body-info ((ast->info info) body))
(body-text (.text body-info))
(body-length (length (text->list body-text)))
(step-info ((ast->info info) `(expr-stmt ,step)))
(step-text (.text step-info))
(step-length (length (text->list step-text)))
(test-jump->info ((test->jump->info info) test))
(test+jump-info (test-jump->info 0))
(test-length (length (text->list (.text test+jump-info))))
(skip-body-text (list (lambda (f g ta t d)
(i386:Xjump (+ body-length step-length)))))
(jump-text (list (lambda (f g ta t d)
(i386:Xjump (- (+ body-length step-length test-length))))))
(jump-length (length (text->list jump-text)))
(test-text (.text (test-jump->info jump-length))))
(clone info #:text
(append text
init-text
skip-body-text
body-text
step-text
test-text
jump-text)
#:globals (append globals (list-tail (.globals body-info) (length globals)))
#:locals locals)))
;; FIXME: support break statement (see switch/case)
((while ,test ,body)
(let* ((skip-info (lambda (body-length)
(clone info #:text (append text
(list (lambda (f g ta t d) (i386:Xjump body-length)))))))
(text (.text (skip-info 0)))
(text-length (length text))
(body-info (lambda (body-length)
((ast->info (skip-info body-length)) body)))
(body-text (list-tail (.text (body-info 0)) text-length))
(body-length (length (text->list body-text)))
(body-info (body-info body-length))
(empty (clone info #:text '()))
(test-jump->info ((test->jump->info empty) test))
(test+jump-info (test-jump->info 0))
(test-length (length (text->list (.text test+jump-info))))
(jump-text (list (lambda (f g ta t d)
(i386:Xjump (- (+ body-length test-length))))))
(jump-length (length (text->list jump-text)))
(test-text (.text (test-jump->info jump-length))))
(clone info #:text
(append
(.text body-info)
test-text
jump-text)
#:globals (.globals body-info))))
((do-while ,body ,test)
(let* ((text-length (length text))
(body-info ((ast->info info) body))
(body-text (list-tail (.text body-info) text-length))
(body-length (length (text->list body-text)))
(empty (clone info #:text '()))
(test-jump->info ((test->jump->info empty) test))
(test+jump-info (test-jump->info 0))
(test-length (length (text->list (.text test+jump-info))))
(jump-text (list (lambda (f g ta t d)
(i386:Xjump (- (+ body-length test-length))))))
(jump-length (length (text->list jump-text)))
(test-text (.text (test-jump->info jump-length))))
(clone info #:text
(append
(.text body-info)
test-text
jump-text)
#:globals (.globals body-info))))
((labeled-stmt (ident ,label) ,statement)
(let ((info (clone info #:text (append text (list label)))))
((ast->info info) statement)))
((goto (ident ,label))
(let* ((jump (lambda (n) (i386:XXjump n)))
(offset (+ (length (jump 0)) (length (text->list text)))))
(clone info #:text
(append text
(list (lambda (f g ta t d)
(jump (- (label-offset (.function info) label f) offset))))))))
;;; FIXME: only zero?!
((p-expr (ident ,name))
(clone info #:text
(append text
((ident->accu info) name)
(list (lambda (f g ta t d)
(append
(i386:accu-zero?)))))))
((p-expr (fixed ,value))
(let ((value (cstring->number value)))
(clone info #:text
(append text
(list (lambda (f g ta t d)
(append
(i386:value->accu value)
(i386:accu-zero?))))))))
((de-ref (p-expr (ident ,name)))
(clone info #:text
(append text
((ident->accu info) name)
(list (lambda (f g ta t d)
(append
(i386:byte-mem->accu)))))))
((fctn-call . ,call)
(let ((info ((ast->info info) `(expr-stmt ,o))))
(clone info #:text
(append (.text info)
(list (lambda (f g ta t d)
(i386:accu-zero?)))))))
;; FIXME
;;((post-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
((post-inc (p-expr (ident ,name)))
(clone info #:text
(append text
((ident->accu info) name)
((ident-add info) name 1)
(list (lambda (f g ta t d)
(append
(i386:accu-zero?)))))))
((post-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
((post-dec ,expr) ((ast->info info) `(expr-stmt ,o)))
((pre-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
((pre-dec ,expr) ((ast->info info) `(expr-stmt ,o)))
;; i++
((expr-stmt (post-inc (p-expr (ident ,name))))
(clone info #:text (append text ((ident-add info) name 1))))
;; ++i
((expr-stmt (pre-inc (p-expr (ident ,name))))
(or (assoc-ref locals name) barf)
(clone info #:text
(append text
((ident-add info) name 1)
((ident->accu info) name)
(list (lambda (f g ta t d)
(append
;;(i386:local->accu (local:id (assoc-ref locals name)))
(i386:accu-zero?)))))))
;; i--
((expr-stmt (post-dec (p-expr (ident ,name))))
(or (assoc-ref locals name) barf)
(clone info #:text
(append text
((ident->accu info) name)
((ident-add info) name -1)
(list (lambda (f g ta t d)
(append
;;(i386:local-add (local:id (assoc-ref locals name)) -1)
(i386:accu-zero?)))))))
;; --i
((expr-stmt (pre-dec (p-expr (ident ,name))))
(or (assoc-ref locals name) barf)
(clone info #:text
(append text
((ident-add info) name -1)
((ident->accu info) name)
(list (lambda (f g ta t d)
(append
;;(i386:local-add (local:id (assoc-ref locals name)) -1)
;;(i386:local->accu (local:id (assoc-ref locals name)))
(i386:accu-zero?)))))))
((not ,expr)
(let* ((test-info ((ast->info info) expr)))
(clone info #:text
(append (.text test-info)
(list (lambda (f g ta t d)
(append
(i386:accu-not)
(i386:accu-zero?)))))
#:globals (.globals test-info))))
((eq ,a ,b)
(let* ((base ((expr->base info) a))
(empty (clone base #:text '()))
(accu ((expr->accu empty) b)))
(clone info #:text
(append text
(.text base)
(list (lambda (f g ta t d)
(i386:push-base)))
(.text accu)
(list (lambda (f g ta t d)
(i386:pop-base)))
(list (lambda (f g ta t d)
(i386:sub-base)))))))
((ge ,a ,b)
(let* ((base ((expr->base info) a))
(empty (clone base #:text '()))
(accu ((expr->accu empty) b)))
(clone info #:text
(append text
(.text base)
(list (lambda (f g ta t d)
(i386:push-base)))
(.text accu)
(list (lambda (f g ta t d)
(i386:pop-base)))
(list (lambda (f g ta t d)
(i386:sub-base)))))))
((gt ,a ,b)
(let* ((base ((expr->base info) a))
(empty (clone base #:text '()))
(accu ((expr->accu empty) b)))
(clone info #:text
(append text
(.text base)
(list (lambda (f g ta t d)
(i386:push-base)))
(.text accu)
(list (lambda (f g ta t d)
(i386:pop-base)))
(list (lambda (f g ta t d)
(i386:sub-base)))))))
((ne ,a ,b)
(let* ((base ((expr->base info) a))
(empty (clone base #:text '()))
(accu ((expr->accu empty) b)))
(clone info #:text
(append text
(.text base)
(list (lambda (f g ta t d)
(i386:push-base)))
(.text accu)
(list (lambda (f g ta t d)
(i386:pop-base)))
(list (lambda (f g ta t d)
(append
(i386:sub-base)
(i386:xor-zf))))))))
((le ,a ,b)
(let* ((base ((expr->base info) a))
(empty (clone base #:text '()))
(accu ((expr->accu empty) b)))
(clone info #:text
(append text
(.text base)
(list (lambda (f g ta t d)
(i386:push-base)))
(.text accu)
(list (lambda (f g ta t d)
(i386:pop-base)))
(list (lambda (f g ta t d)
(i386:base-sub)))))))
((lt ,a ,b)
(let* ((base ((expr->base info) a))
(empty (clone base #:text '()))
(accu ((expr->accu empty) b)))
(clone info #:text
(append text
(.text base)
(list (lambda (f g ta t d)
(i386:push-base)))
(.text accu)
(list (lambda (f g ta t d)
(i386:pop-base)))
(list (lambda (f g ta t d)
(i386:base-sub)))))))
;; HMM
((lshift . _) ((expr->accu info) o))
((rshift . _) ((expr->accu info) o))
;; TODO: byte dinges
((Xsub ,a ,b)
(let* ((base ((expr->base info) a))
(empty (clone base #:text '()))
(accu ((expr->accu empty) b)))
(clone info #:text
(append text
(.text base)
(list (lambda (f g ta t d)
(i386:push-base)))
(.text accu)
(list (lambda (f g ta t d)
(i386:pop-base)))
(list (lambda (f g ta t d)
(i386:base-sub)))))))
((Xsub (de-ref (p-expr (ident ,a))) (de-ref (p-expr (ident ,b))))
(clone info #:text
(append text
(list (lambda (f g ta t d)
(append
(i386:local->accu (local:id (assoc-ref locals a)))
(i386:byte-mem->base)
(i386:local->accu (local:id (assoc-ref locals b)))
(i386:byte-mem->accu)
(i386:byte-sub-base)))))))
;; g_cells[0]
((array-ref (p-expr (fixed ,index)) (p-expr (ident ,array)))
(let* ((value (cstring->number value))
(type (ident->type info array))
(size (type->size info type)))
(clone info #:text
(append text
((ident->base info) array)
(list (lambda (f g ta t d)
(append
(i386:value->accu (* size index))
(if (eq? size 1)
(i386:byte-base-mem->accu)
(i386:base-mem->accu)))))))))
;; g_cells[a]
((array-ref (p-expr (ident ,index)) (p-expr (ident ,array)))
(let* ((type (ident->type info array))
(size (type->size info type)))
(clone info #:text
(append text
((ident->base info) index)
(list (lambda (f g ta t d)
(append
(i386:base->accu)
(if (< size 4) '()
(append
(i386:accu+accu)
(if (= size 12) (i386:accu+base) '())
(i386:accu-shl 2))))))
((ident->base info) array)
(list (lambda (f g ta t d)
(if (eq? size 1)
(i386:byte-base-mem->accu)
(i386:base-mem->accu))))))))
((return ,expr)
(let ((accu ((expr->accu info) expr)))
(clone accu #:text
(append (.text accu) (list (lambda (f g ta t d) (i386:ret)))))))
;; int i;
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
(if (.function info)
(clone info #:locals (add-local locals name type 0))
(clone info #:globals (append globals (list (ident->global name type 0 0))))))
;; int i = 0;
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
(let ((value (cstring->number value)))
(if (.function info)
(let* ((locals (add-local locals name type 0))
(info (clone info #:locals locals)))
(clone info #:text
(append text
((value->ident info) name value))))
(clone info #:globals (append globals (list (ident->global name type 0 value)))))))
;; char c = 'A';
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (char ,value))))))
(if (not (.function info)) decl-barf0)
(let* ((locals (add-local locals name type 0))
(info (clone info #:locals locals))
(value (char->integer (car (string->list value)))))
(clone info #:text
(append text
((value->ident info) name value)))))
;; 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)))))))
(let ((value (- (cstring->number value))))
(if (.function info)
(let* ((locals (add-local locals name type 0))
(info (clone info #:locals locals)))
(clone info #:text
(append text
((value->ident info) name value))))
(clone info #:globals (append globals (list (ident->global name type 0 value)))))))
;; int i = argc;
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
(if (not (.function info)) decl-barf2)
(let* ((locals (add-local locals name type 0))
(info (clone info #:locals locals)))
(clone info #:text
(append text
((ident->accu info) local)
((accu->ident info) name)))))
;; 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))))))
(when (not (.function info))
(stderr "o=~s\n" o)
decl-barf3)
(let* ((locals (add-local locals name type 1))
(globals (append globals (list (string->global string))))
(info (clone info #:locals locals #:globals globals)))
(clone info #:text
(append text
(list (lambda (f g ta t d)
(append
(i386:global->accu (+ (data-offset (add-s:-prefix string) g) d)))))
((accu->ident info) name)))))
;; 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))))))
(let ((value (cstring->number value)))
(if (.function info)
(let* ((locals (add-local locals name type 1))
(info (clone info #:locals locals)))
(clone info #:text
(append text
(list (lambda (f g ta t d)
(i386:value->accu value)))
((accu->ident info) name))))
(clone info #:globals (append globals (list (ident->global name type 0 value)))))))
;; char arena[20000];
((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (array-of (ident ,name) (p-expr (fixed ,count))))))
(let ((type (ast->type type)))
(if (.function info)
TODO:decl-array
(let* ((globals (.globals info))
(count (cstring->number count))
(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))))
(globals (append globals (list array))))
(clone info
#:globals globals)))))
;;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)))))))
;;(stderr "0TYPE: ~s\n" type)
(if (.function info)
(let* ((locals (add-local locals name type 1))
(info (clone info #:locals locals)))
(clone info #:text
(append text
((ident->accu info) name)
((accu->ident info) value)))) ;; FIXME: deref?
(let* ((globals (append globals (list (ident->global name type 1 0))))
(info (clone info #:globals globals)))
(clone info #:text
(append text
((ident->accu info) name)
((accu->ident info) value)))))) ;; FIXME: deref?
;; SCM tmp;
((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name))))
;;(stderr "1TYPE: ~s\n" type)
(if (.function info)
(clone info #:locals (add-local locals name type 0))
(clone info #:globals (append globals (list (ident->global name type 0 0))))))
;; SCM g_stack = 0;
((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
;;(stderr "2TYPE: ~s\n" type)
(let ((value (cstring->number value)))
(if (.function info)
(let* ((locals (add-local locals name type 0))
(info (clone info #:locals locals)))
(clone info #:text
(append text
((value->ident info) name value))))
(let ((globals (append globals (list (ident->global name type 0 value)))))
(clone info #:globals globals)))))
;; SCM g_stack = 0; // comment
((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident _) (initzer (p-expr (fixed _))))) (comment _))
((ast->info info) (list-head o (- (length o) 1))))
;; SCM i = argc;
((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
;;(stderr "3TYPE: ~s\n" type)
(if (.function info)
(let* ((locals (add-local locals name type 0))
(info (clone info #:locals locals)))
(clone info #:text
(append text
((ident->accu info) local)
((accu->ident info) name))))
(let* ((globals (append globals (list (ident->global name type 0 0))))
(info (clone info #:globals globals)))
(clone info #:text
(append text
((ident->accu info) local)
((accu->ident info) name))))))
;; 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))))
(let* ((locals (add-local locals name type 1))
(info (clone info #:locals locals))
(empty (clone info #:text '()))
(accu ((expr->accu empty) initzer)))
(clone info
#:text
(append text
(.text accu)
((accu->ident info) name)
(list (lambda (f g ta t d)
(append
;;(i386:value->base t)
;;(i386:accu+base)
(i386:value->base ta)
(i386:accu+base)))))
#:locals locals)))
;; char *p = (char*)g_cells;
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (cast (type-name (decl-spec-list (type-spec (fixed-type ,=type))) (abs-declr (pointer))) (p-expr (ident ,value)))))))
;;(stderr "6TYPE: ~s\n" type)
(if (.function info)
(let* ((locals (add-local locals name type 1))
(info (clone info #:locals locals)))
(clone info #:text
(append text
((ident->accu info) value)
((accu->ident info) name))))
(let* ((globals (append globals (list (ident->global name type 1 0))))
(here (data-offset name globals))
(there (data-offset value globals)))
(clone info
#:globals globals
#:init (append (.init info)
(list (lambda (functions globals ta t d data)
(append
(list-head data here)
;;; FIXME: type
;;; char *x = arena;
(int->bv32 (+ d (data-offset value globals)))
;;; char *y = x;
;;;(list-head (list-tail data there) 4)
(list-tail data (+ here 4))))))))))
;; char *p = g_cells;
((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (ident ,value))))))
;;(stderr "7TYPE: ~s\n" type)
(let ((type (decl->type type)))
;;(stderr "0DECL: ~s\n" type)
(if (.function info)
(let* ((locals (add-local locals name type 1))
(info (clone info #:locals locals)))
(clone info #:text
(append text
((ident->accu info) value)
((accu->ident info) name))))
(let* ((globals (append globals (list (ident->global name type 1 0))))
(here (data-offset name globals)))
(clone info
#:globals globals
#:init (append (.init info)
(list (lambda (functions globals ta t d data)
(append
(list-head data here)
;;; FIXME: type
;;; char *x = arena;p
(int->bv32 (+ d (data-offset value globals)))
(list-tail data (+ here 4)))))))))))
;; enum
((decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields)))))
(let ((type (enum->type name fields))
(constants (map ident->constant (map cadadr fields) (iota (length fields)))))
(clone info
#:types (append (.types info) (list type))
#:constants (append constants (.constants info)))))
;; struct
((decl (decl-spec-list (type-spec (struct-def (ident ,name) (field-list . ,fields)))))
(let* ((type (struct->type (list "struct" name) (map struct-field fields))))
;;(stderr "type: ~a\n" type)
(clone info #:types (append (.types info) (list type)))))
;; *p++ = b;
((expr-stmt (assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op ,op) ,b))
(when (not (equal? op "="))
(stderr "OOOPS0.0: op=~s\n" op)
barf)
(let* ((empty (clone info #:text '()))
(base ((expr->base empty) b)))
(clone info #:text
(append text
(.text base)
((base->ident-address info) name)
((ident-add info) name 1)))))
;; *p-- = b;
((expr-stmt (assn-expr (de-ref (post-dec (p-expr (ident ,name)))) (op ,op) ,b))
(when (not (equal? op "="))
(stderr "OOOPS0.0: op=~s\n" op)
barf)
(let* ((empty (clone info #:text '()))
(base ((expr->base empty) b)))
(clone info #:text
(append text
(.text base)
((base->ident-address info) name)
((ident-add info) name -1)))))
;; CAR (x) = 0
;; TYPE (x) = PAIR;
((expr-stmt (assn-expr (d-sel (ident ,field) . ,d-sel) (op ,op) ,b))
(when (not (equal? op "="))
(stderr "OOOPS0: op=~s\n" op)
barf)
(let* ((empty (clone info #:text '()))
(expr ((expr->accu* empty) `(d-sel (ident ,field) ,@d-sel))) ;; <-OFFSET
(base ((expr->base empty) b))
(type (list "struct" "scm")) ;; FIXME
(fields (type->description info type))
(size (type->size info type))
(field-size 4) ;; FIXME:4, not fixed
(offset (* field-size (1- (length (member field (reverse fields) (lambda (a b) (equal? a (cdr b)))))))) )
(clone info #:text (append text
(.text expr)
(.text base)
(list (lambda (f g ta t d)
;;(i386:byte-base->accu-ref) ;; FIXME: size
(i386:base->accu-address)
))))))
;; i = 0;
;; c = f ();
;; i = i + 48;
;; p = g_cell;
((expr-stmt (assn-expr (p-expr (ident ,name)) (op ,op) ,b))
(when (and (not (equal? op "="))
(not (equal? op "+="))
(not (equal? op "-=")))
(stderr "OOOPS1: op=~s\n" op)
barf)
(let* ((empty (clone info #:text '()))
(base ((expr->base empty) b)))
(clone info #:text (append text
(.text base)
(if (equal? op "=") '()
(append ((ident->accu info) name)
(list (lambda (f g ta t d)
(append
(if (equal? op "+=")
(i386:accu+base)
(i386:accu-base))
(i386:accu->base))))))
;;assign:
((base->ident info) name)))))
;; *p = 0;
((expr-stmt (assn-expr (de-ref (p-expr (ident ,array))) (op ,op) ,b))
(when (not (equal? op "="))
(stderr "OOOPS2: op=~s\n" op)
barf)
(let* ((empty (clone info #:text '()))
(base ((expr->base empty) b)))
(clone info #:text (append text
(.text base)
;;assign:
((base->ident-address info) array)))))
;; g_cells[0] = 65;
((expr-stmt (assn-expr (array-ref (p-expr (fixed ,index)) (p-expr (ident ,array))) (op ,op) ,b))
(when (not (equal? op "="))
(stderr "OOOPS3: op=~s\n" op)
barf)
(let* ((index (cstring->number index))
(empty (clone info #:text '()))
(base ((expr->base empty) b))
(type (ident->type info array))
(size (type->size info type))
(ptr (ident->pointer info array)))
(clone info #:text
(append text
(.text base)
(list (lambda (f g ta t d)
(i386:push-base)))
(list (lambda (f g ta t d)
(append
(i386:value->base index)
(i386:base->accu)
(if (eq? size 1) '()
(append
(if (> size 4) (i386:accu+accu) '())
(if (> size 8) (i386:accu+base) '())
(i386:accu-shl 2))))))
((ident->base info) array)
(list (lambda (f g ta t d)
(i386:accu+base)))
(list (lambda (f g ta t d)
(i386:pop-base)))
(if (eq? size 1) (list (lambda (f g ta t d)
(i386:byte-base->accu-address)))
(append
(list (lambda (f g ta t d)
(i386:base-address->accu-address)))
(if (> size 4)
(list (lambda (f g ta t d)
(append
(i386:accu+n 4)
(i386:base+n 4)
(i386:base-address->accu-address))))
'())
(if (> size 8)
(list (lambda (f g ta t d)
(append
(i386:accu+n 4)
(i386:base+n 4)
(i386:base-address->accu-address))))
'())))))))
;; g_cells[i] = c;
((expr-stmt (assn-expr (array-ref (p-expr (ident ,index)) (p-expr (ident ,array))) (op ,op) ,b))
;;(stderr "pointer_cells4[]: ~s\n" array)
(when (not (equal? op "="))
(stderr "OOOPS4: op=~s\n" op)
barf)
(let* ((empty (clone info #:text '()))
(base ((expr->base empty) b))
(type (ident->type info array))
(size (type->size info type))
(ptr (ident->pointer info array)))
(clone info #:text
(append text
(.text base)
(list (lambda (f g ta t d)
(i386:push-base)))
((ident->base info) index)
(list (lambda (f g ta t d)
(append
(i386:base->accu)
(if (eq? size 1) '()
(append
(if (> size 4) (i386:accu+accu) '())
(if (> size 8) (i386:accu+base) '())
(i386:accu-shl 2))))))
((ident->base info) array)
(list (lambda (f g ta t d)
(i386:accu+base)))
(list (lambda (f g ta t d)
(i386:pop-base)))
(if (eq? size 1) (list (lambda (f g ta t d)
(i386:byte-base->accu-address)))
(append
(list (lambda (f g ta t d)
(i386:base-address->accu-address)))
(if (> size 4)
(list (lambda (f g ta t d)
(append
(i386:accu+n 4)
(i386:base+n 4)
(i386:base-address->accu-address))))
'())
(if (> size 8)
(list (lambda (f g ta t d)
(append
(i386:accu+n 4)
(i386:base+n 4)
(i386:base-address->accu-address))))
'())))))))
;; g_functions[g_function++] = g_foo;
((expr-stmt (assn-expr (array-ref (post-inc (p-expr (ident ,index))) (p-expr (ident ,array))) (op ,op) ,b))
(when (not (equal? op "="))
(stderr "OOOPS5: op=~s\n" op)
barf)
(let* ((empty (clone info #:text '()))
(base ((expr->base empty) b))
(type (ident->type info array))
(size (type->size info type))
(ptr (ident->pointer info array)))
(clone info #:text
(append text
(.text base)
(list (lambda (f g ta t d)
(i386:push-base)))
((ident->base info) index)
(list (lambda (f g ta t d)
(append
(i386:base->accu)
(if (eq? size 1) '()
(append
(if (> size 4) (i386:accu+accu) '())
(if (> size 8) (i386:accu+base) '())
(i386:accu-shl 2))))))
((ident->base info) array)
(list (lambda (f g ta t d)
(i386:accu+base)))
(list (lambda (f g ta t d)
(i386:pop-base)))
(if (eq? size 1) (list (lambda (f g ta t d)
(i386:byte-base->accu-address)))
(append
(list (lambda (f g ta t d)
(i386:base-address->accu-address)))
(if (> size 4)
(list (lambda (f g ta t d)
(append
(i386:accu+n 4)
(i386:base+n 4)
(i386:base-address->accu-address))))
'())
(if (> size 8)
(list (lambda (f g ta t d)
(append
(i386:accu+n 4)
(i386:base+n 4)
(i386:base-address->accu-address))))
'())))
((ident-add info) index 1)))))
;; DECL
;;
;; struct f = {...};
((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer (initzer-list . ,initzers)))))
(let* ((type (decl->type type))
;;(foo (stderr "1DECL: ~s\n" type))
(fields (type->description info type))
(size (type->size info type))
(field-size 4)) ;; FIXME:4, not fixed
;;(stderr "7TYPE: ~s\n" type)
(if (.function info)
(let* ((globals (append globals (filter-map initzer->global initzers)))
(locals (let loop ((fields (cdr fields)) (locals locals))
(if (null? fields) locals
(loop (cdr fields) (add-local locals "foobar" "int" 0)))))
(locals (add-local locals name type -1))
(info (clone info #:locals locals #:globals globals))
(empty (clone info #:text '())))
(let loop ((fields (iota (length fields))) (initzers initzers) (info info))
(if (null? fields) info
(let ((offset (* field-size (car fields)))
(initzer (car initzers)))
(loop (cdr fields) (cdr initzers)
(clone info #:text
(append
(.text info)
((ident->accu info) name)
(list (lambda (f g ta t d)
(append
(i386:accu->base))))
(.text ((expr->accu empty) initzer))
(list (lambda (f g ta t d)
(i386:accu->base-address+n offset))))))))))
(let* ((globals (append globals (filter-map initzer->global initzers)))
(global (make-global name type -1 (string->list (make-string size #\nul))))
(globals (append globals (list global)))
(here (data-offset name globals))
(info (clone info #:globals globals))
(field-size 4))
(let loop ((fields (iota (length fields))) (initzers initzers) (info info))
(if (null? fields) info
(let ((offset (* field-size (car fields)))
(initzer (car initzers)))
(loop (cdr fields) (cdr initzers)
(clone info #:init
(append
(.init info)
(list (lambda (functions globals ta t d data)
(append
(list-head data (+ here offset))
(initzer->data info functions globals ta t d (car initzers))
(list-tail data (+ here offset field-size)))))))))))))))
;;char cc = g_cells[c].cdr; ==> generic?
((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer ,initzer))))
(let ((type (decl->type type)))
(if (.function info)
(let* ((locals (add-local locals name type 0))
(info (clone info #:locals locals)))
(clone info #:text
(append (.text ((expr->accu info) initzer))
((accu->ident info) name))))
(let* ((globals (append globals (list (ident->global name type 1 0))))
(here (data-offset name globals)))
(clone info
#:globals globals
#:init (append (.init info)
(list (lambda (functions globals ta t d data)
(append
(list-head data here)
(initzer->data info functions globals ta t d initzer)
(list-tail data (+ here 4)))))))))))
((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
info)
((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))) (comment ,comment))
info)
((decl (decl-spec-list (stor-spec (typedef)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
(let ((types (.types info)))
(clone info #:types (cons (cons name (assoc-ref types type)) types))))
((decl (decl-spec-list (stor-spec (typedef)) ,type) ,name)
(format (current-error-port) "SKIP: typedef=~s\n" o)
info)
((decl (@ ,at))
(format (current-error-port) "SKIP: at=~s\n" o)
info)
((decl . _)
(format (current-error-port) "SKIP: decl statement=~s\n" o)
barf
info)
(_
(format (current-error-port) "SKIP: statement=~s\n" o)
barf
info)))))
(define (initzer->data info functions globals ta t d o)
(pmatch o
((initzer (p-expr (fixed ,value))) (int->bv32 (cstring->number value)))
((initzer (neg (p-expr (fixed ,value)))) (int->bv32 (- (cstring->number value))))
((initzer (ref-to (p-expr (ident ,name))))
;;(stderr "INITZER[~a] => 0x~a\n" o (dec->hex (+ ta (function-offset name functions))))
(int->bv32 (+ ta (function-offset name functions))))
((initzer (p-expr (ident ,name)))
(let ((value (assoc-ref (.constants info) name)))
(int->bv32 value)))
((initzer (p-expr (string ,string)))
(int->bv32 (+ (data-offset (add-s:-prefix string) globals) d)))
(_ (stderr "initzer->data:SKIP: ~s\n" o)
barf
(int->bv32 0))))
(define (info->exe info)
(display "dumping elf\n" (current-error-port))
(map write-any (make-elf (.functions info) (.globals info) (.init info))))
(define (.formals o)
(pmatch o
((fctn-defn _ (ftn-declr _ ,formals) _) formals)
((fctn-defn _ (ptr-declr (pointer) (ftn-declr _ ,formals)) _) formals)
(_ (format (current-error-port) ".formals: no match: ~a\n" o)
barf)))
(define (formal->text n)
(lambda (o i)
;;(i386:formal i n)
'()
))
(define (formals->text o)
(pmatch o
((param-list . ,formals)
(let ((n (length formals)))
(list (lambda (f g ta t d)
(append
(i386:function-preamble)
(append-map (formal->text n) formals (iota n))
(i386:function-locals))))))
(_ (format (current-error-port) "formals->text: no match: ~a\n" o)
barf)))
(define (formal:ptr o)
(pmatch o
((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) . _)))
1)
((param-decl (decl-spec-list . ,decl) (param-declr (ident ,name)))
0)
(_
(stderr "formal:ptr[~a] => 0\n" o)
0)))
(define (formals->locals o)
(pmatch o
((param-list . ,formals)
(let ((n (length formals)))
(map make-local (map .name formals) (map .type formals) (map formal:ptr formals) (iota n -2 -1))))
(_ (format (current-error-port) "formals->info: no match: ~a\n" o)
barf)))
(define (function->info info)
(lambda (o)
;;(stderr "\n")
;;(stderr "formals=~a\n" (.formals o))
(let* ((name (.name o))
(text (formals->text (.formals o)))
(locals (formals->locals (.formals o))))
(format (current-error-port) "compiling ~a\n" name)
;;(stderr "locals=~a\n" locals)
(let loop ((statements (.statements o))
(info (clone info #:locals locals #:function (.name o) #:text text)))
(if (null? statements) (clone info
#:function #f
#:functions (append (.functions info) (list (cons name (.text info)))))
(let* ((statement (car statements)))
(loop (cdr statements)
((ast->info info) (car statements)))))))))
(define (ast-list->info info)
(lambda (elements)
(let loop ((elements elements) (info info))
(if (null? elements) info
(loop (cdr elements) ((ast->info info) (car elements)))))))
(define (compile)
(let* ((ast (mescc))
(info (make <info>
#:functions i386:libc
#:types i386:type-alist))
(ast (append libc ast))
(info ((ast->info info) ast))
(info ((ast->info info) _start)))
(info->exe info)))
Reference in a new issue View git blame Copy permalink