andrius
/
mes
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
mes/module/language/c99/compiler.mes

2154 lines
102 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)
(guile)
(mes
(mes-use-module (srfi srfi-26))
(mes-use-module (mes pmatch))
(mes-use-module (nyacc lang c99 parser))
(mes-use-module (nyacc lang c99 pprint))
(mes-use-module (mes as))
(mes-use-module (mes as-i386))
(mes-use-module (mes M1))
(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 %datadir (if (string-prefix? "@DATADIR" "@DATADIR@") "" "@DATADIR@"))
(define %docdir (if (string-prefix? "@DOCDIR" "@DOCDIR@") "doc/" "@DOCDIR@"))
(define %moduledir "module/")
(define %prefix (if (string-prefix? "@PREFIX" "@PREFIX@") "" "@PREFIX@"))
(define %version (if (string-prefix? "@VERSION" "@VERSION@") "git" "@VERSION@"))
(define mes? (pair? (current-module)))
(define* (c99-input->full-ast #:key (defines '()) (includes '()))
(let ((include (if (equal? %prefix "") "mlibc/include" (string-append %prefix "/share/mlibc/include"))))
(parse-c99
#:inc-dirs (append includes (cons* "." "mlibc" "src" "out" "out/src" include (or (and=> (getenv "C_INCLUDE_PATH") (cut string-split <> #\:)) '())))
#:cpp-defs `(
"POSIX=0"
"_POSIX_SOURCE=0"
"__GNUC__=0" ;; FIXME: TCC uses #ifdef __GNUC__, but NYACC needs it for #if __GNUC__
"__MESC__=1"
"EOF=-1"
"STDIN=0"
"STDOUT=1"
"STDERR=2"
"INT_MIN=-2147483648"
"INT_MAX=2147483647"
"FIXED_PRIMITIVES=1"
,(if mes? "__MESC_MES__=1" "__MESC_MES__=0")
,(string-append "DATADIR=\"" %datadir "\"")
,(string-append "DOCDIR=\"" %docdir "\"")
,(string-append "PREFIX=\"" %prefix "\"")
,(string-append "MODULEDIR=\"" %moduledir "\"")
,(string-append "VERSION=\"" %version "\"")
,@defines
)
#:mode 'code)))
(define (ast-strip-comment o)
(pmatch o
((comment . ,comment) #f)
(((comment . ,comment) . ,t) (filter-map ast-strip-comment t))
(((comment . ,comment) . ,cdr) cdr)
((,car . (comment . ,comment)) car)
((,h . ,t) (if (list? o) (filter-map ast-strip-comment o)
(cons (ast-strip-comment h) (ast-strip-comment t))))
(_ o)))
(define (ast-strip-const o)
(pmatch o
((type-qual ,qual) (if (equal? qual "const") #f o))
((decl-spec-list (type-qual ,qual) . ,rest)
(if (equal? qual "const") `(decl-spec-list ,@rest)
`(decl-spec-list (type-qual ,qual) ,@(map ast-strip-const rest))))
((,h . ,t) (if (list? o) (filter-map ast-strip-const o)
(cons (ast-strip-const h) (ast-strip-const t))))
(_ o)))
(define* (c99-input->ast #:key (defines '()) (includes '()))
((compose ast-strip-const ast-strip-comment) (c99-input->full-ast #:defines defines #:includes includes)))
(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)
((fctn-defn _ (ptr-declr (pointer (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)
((param-decl _ (param-declr (ptr-declr (pointer (pointer)) (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)
((fctn-defn _ (ptr-declr (pointer (pointer)) (ftn-declr (ident ,name) _)) (compd-stmt (block-item-list . ,statements))) statements)
(_ (error ".statements: unsupported: " o))))
(define <info> '<info>)
(define <types> '<types>)
(define <constants> '<constants>)
(define <functions> '<functions>)
(define <globals> '<globals>)
(define <locals> '<locals>)
(define <function> '<function>)
(define <text> '<text>)
(define <break> '<break>)
(define <continue> '<continue>)
(define* (make o #:key (types '()) (constants '()) (functions '()) (globals '()) (locals '()) (function #f) (text '()) (break '()) (continue '()))
(pmatch o
(<info> (list <info>
(cons <types> types)
(cons <constants> constants)
(cons <functions> functions)
(cons <globals> globals)
(cons <locals> locals)
(cons <function> function)
(cons <text> text)
(cons <break> break)
(cons <continue> continue)))))
(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 (.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 (.break o)
(pmatch o
((<info> . ,alist) (assq-ref alist <break>))))
(define (.continue o)
(pmatch o
((<info> . ,alist) (assq-ref alist <continue>))))
(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))
(locals (.locals o))
(function (.function o))
(text (.text o))
(break (.break o))
(continue (.continue o)))
(let-keywords rest
#f
((types types)
(constants constants)
(functions functions)
(globals globals)
(locals locals)
(function function)
(text text)
(break break)
(continue continue))
(make <info> #:types types #:constants constants #:functions functions #:globals globals #:locals locals #:function function #:text text #:break break #:continue continue))))))
(define (push-global globals)
(lambda (o)
(list (i386:push-label-mem `(#:address ,o)))))
(define (push-local locals)
(lambda (o)
(wrap-as (i386:push-local (local:id o)))))
(define (push-global-address globals)
(lambda (o)
(list (i386:push-label o))))
(define (push-local-address locals)
(lambda (o)
(wrap-as (i386:push-local-address (local:id o)))))
(define push-global-de-ref push-global)
(define (push-local-de-ref info)
(lambda (o)
(let* ((local o)
(ptr (local:pointer local))
(size (if (= ptr 1) (type->size info (local:type o))
4)))
(if (= size 1)
(wrap-as (i386:push-byte-local-de-ref (local:id o)))
(wrap-as (i386:push-local-de-ref (local:id o)))))))
(define (push-local-de-de-ref info)
(lambda (o)
(let* ((local o)
(ptr (local:pointer local))
(size (if (= ptr 2) (type->size info (local:type o));; URG
4)))
(if (= size 1)
(wrap-as (i386:push-byte-local-de-de-ref (local:id o)))
(error "TODO int-de-de-ref")))))
(define (make-global name type pointer value)
(cons name (list type pointer value)))
(define global:type car)
(define global:pointer cadr)
(define global:value caddr)
(define (string->global string)
(make-global `(#:string ,string) "string" 0 (append (string->list string) (list #\nul))))
(define (int->global value)
(make-global (number->string value) "int" 0 (int->bv32 value)))
(define (ident->global name type pointer value)
(make-global name type pointer (if (pair? value) value (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
(begin
(let* ((ptr (local:pointer local))
(size (if (= ptr 1) (type->size info (local:type local))
4)))
(if (= ptr -1) ((push-local-address (.locals info)) local)
((push-local (.locals info)) local))))
(let ((global (assoc-ref (.globals info) o)))
(if global
((push-global (.globals info)) o) ;; FIXME: char*/int
(let ((constant (assoc-ref (.constants info) o)))
(if constant
(wrap-as (append (i386:value->accu constant)
(i386:push-accu)))
((push-global-address #f) `(#:address ,o))))))))))
(define (push-ident-address info)
(lambda (o)
(let ((local (assoc-ref (.locals info) o)))
(if local ((push-local-address (.locals info)) local)
(let ((global (assoc-ref (.globals info) o)))
(if global
((push-global-address (.globals info)) o)
((push-global-address #f) `(#:address ,o))))))))
(define (push-ident-de-ref info)
(lambda (o)
(let ((local (assoc-ref (.locals info) o)))
(if local ((push-local-de-ref info) local)
((push-global-de-ref (.globals info)) o)))))
(define (push-ident-de-de-ref info)
(lambda (o)
(let ((local (assoc-ref (.locals info) o)))
(if local ((push-local-de-de-ref info) local)
(error "TODO: global push-local-de-de-ref")))))
(define (expr->arg info)
(lambda (o)
(let ((info ((expr->accu info) o)))
(append-text info (wrap-as (i386:push-accu))))))
(define (globals:add-string globals)
(lambda (o)
(let ((string `(#:string ,o)))
(if (assoc-ref globals string) globals
(append globals (list (string->global o)))))))
(define (expr->arg info) ;; FIXME: get Mes curried-definitions
(lambda (o)
(let ((text (.text info)))
(pmatch o
((p-expr (string ,string))
(let* ((globals ((globals:add-string (.globals info)) string))
(info (clone info #:globals globals)))
(append-text info ((push-global-address info) `(#:string ,string)))))
((p-expr (ident ,name))
(append-text info ((push-ident info) name)))
((cast (type-name (decl-spec-list (type-spec (fixed-type _)))
(abs-declr (pointer)))
,cast)
((expr->arg info) cast))
((cast (type-name (decl-spec-list (type-spec (fixed-type ,type)))) ,cast)
((expr->arg info) cast))
((de-ref (p-expr (ident ,name)))
(append-text info ((push-ident-de-ref info) name)))
((de-ref (de-ref (p-expr (ident ,name))))
(append-text info ((push-ident-de-de-ref info) name)))
((ref-to (p-expr (ident ,name)))
(append-text info ((push-ident-address info) name)))
(_ (append-text ((expr->accu info) o)
(wrap-as (i386:push-accu))))))))
;; FIXME: see ident->base
(define (ident->accu info)
(lambda (o)
(let ((local (assoc-ref (.locals info) o))
(global (assoc-ref (.globals info) o))
(constant (assoc-ref (.constants info) o)))
(if local
(let* ((ptr (local:pointer local))
(type (ident->type info o))
(size (if (= ptr 0) (type->size info type)
4)))
(case ptr
((-1) (wrap-as (i386:local-ptr->accu (local:id local))))
((1) (wrap-as (i386:local->accu (local:id local))))
(else
(wrap-as (if (= size 1) (i386:byte-local->accu (local:id local))
(i386:local->accu (local:id local)))))))
(if global
(let* ((ptr (ident->pointer info o))
(type (ident->type info o))
(size (if (= ptr 1) (type->size info type)
4)))
(case ptr
((-1) (list (i386:label->accu `(#:address ,o))))
((1) (list (i386:label-mem->accu `(#:address ,o))))
((2) (list (i386:label->accu `(#:address ,o))))
(else (list (i386:label-mem->accu `(#:address ,o))))))
(if constant (wrap-as (i386:value->accu constant))
(list (i386:label->accu `(#:address ,o)))))))))
(define (ident-address->accu info)
(lambda (o)
(let ((local (assoc-ref (.locals info) o))
(global (assoc-ref (.globals info) o))
(constant (assoc-ref (.constants info) o)))
(if local (let* ((ptr (local:pointer local))
(type (ident->type info o))
(size (if (= ptr 1) (type->size info type)
4)))
(wrap-as (i386:local-ptr->accu (local:id local))))
(if global (list (i386:label->accu `(#:address ,o)))
(list (i386:label->accu `(#:address ,o))))))))
(define (ident-address->base info)
(lambda (o)
(let ((local (assoc-ref (.locals info) o))
(global (assoc-ref (.globals info) o))
(constant (assoc-ref (.constants info) o)))
(if local
(let* ((ptr (local:pointer local))
(type (ident->type info o))
(size (if (= ptr 1) (type->size info type)
4)))
(wrap-as (i386:local-ptr->base (local:id local))))
(if global (list (i386:label->base `(#:address ,o)))
(list (i386:label->accu `(#:address ,o))))))))
(define (value->accu v)
(wrap-as (i386:value->accu v)))
(define (accu->ident info)
(lambda (o)
(let ((local (assoc-ref (.locals info) o)))
(if local (wrap-as (i386:accu->local (local:id local)))
(let ((ptr (ident->pointer info o)))
(list (i386:accu->label `(#:address ,o))))))))
(define (base->ident info)
(lambda (o)
(let ((local (assoc-ref (.locals info) o)))
(if local (wrap-as (i386:base->local (local:id local)))
(list (i386:base->label `(#:address ,o)))))))
(define (base->ident-address info)
(lambda (o)
(let ((local (assoc-ref (.locals info) o)))
(if local
(let* ((ptr (local:pointer local))
(type (ident->type info o))
(size (if (= ptr 1) (type->size info type)
4)))
(wrap-as (append (i386:local->accu (local:id local))
(if (= size 1) (i386:byte-base->accu-address)
(i386:byte-base->accu-address)))))
(error "TODO:base->ident-address-global" o)))))
(define (value->ident info)
(lambda (o value)
(let ((local (assoc-ref (.locals info) o)))
(if local (wrap-as (i386:value->local (local:id local) value))
(list (i386:value->label `(#:address ,o) value))))))
(define (ident-add info)
(lambda (o n)
(let ((local (assoc-ref (.locals info) o)))
(if local (wrap-as (i386:local-add (local:id local) n))
(list (i386:label-mem-add `(#:address ,o) n))))))
(define (ident-address-add info)
(lambda (o n)
(let ((local (assoc-ref (.locals info) o)))
(if local (wrap-as (append (i386:push-accu)
(i386:local->accu (local:id local))
(i386:accu-mem-add n)
(i386:pop-accu)))
(list (wrap-as (append (i386:push-accu)
(i386:label->accu `(#:address ,o))
(i386:accu-mem-add n)
(i386:pop-accu))))))))
;; FIXME: see ident->accu
(define (ident->base info)
(lambda (o)
(let ((local (assoc-ref (.locals info) o)))
(if local
(let* ((ptr (local:pointer local))
(type (ident->type info o))
(size (if (and type (= ptr 1)) (type->size info type)
4)))
(case ptr
((-1) (wrap-as (i386:local-ptr->base (local:id local))))
((1) (wrap-as (i386:local->base (local:id local))))
(else
(wrap-as (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)))
(case ptr
((-1) (list (i386:label->base `(#:address ,o))))
((2) (list (i386:label->base `(#:address ,o))))
(else (list (i386:label-mem->base `(#:address ,o))))))
(let ((constant (assoc-ref (.constants info) o)))
(if constant (wrap-as (i386:value->base constant))
(list (i386:label->base `(#:address ,o)))))))))))
(define (expr->accu info)
(lambda (o)
(let ((locals (.locals info))
(constants (.constants info))
(text (.text info))
(globals (.globals info)))
(define (add-local locals name type pointer)
(let* ((id (if (or (null? locals) (not (local? (cdar locals)))) 1
(1+ (local:id (cdar locals)))))
(locals (cons (make-local name type pointer id) locals)))
locals))
(pmatch o
((expr) info)
((p-expr (string ,string))
(let* ((globals ((globals:add-string globals) string))
(info (clone info #:globals globals)))
(append-text info (list (i386:label->accu `(#:string ,string))))))
((p-expr (string . ,strings))
(append-text info (list (i386:label->accu `(#:string ,(apply string-append strings))))))
((p-expr (fixed ,value))
(append-text info (value->accu (cstring->number value))))
((p-expr (ident ,name))
(append-text info ((ident->accu info) name)))
((initzer ,initzer) ((expr->accu info) initzer))
;; &foo
((ref-to (p-expr (ident ,name)))
(append-text info ((ident-address->accu info) name)))
;; &f.field
((ref-to (d-sel (ident ,field) (p-expr (ident ,array))))
(let* ((type (ident->type info array))
(offset (field-offset info type field))
(text (.text info)))
(append-text info (append ((ident->accu info) array)
(wrap-as (i386:accu+n offset))))))
;; &a[x];
((ref-to (array-ref ,index (p-expr (ident ,array))))
((expr->accu* info) `(array-ref ,index (p-expr (ident ,array)))))
((sizeof-expr (p-expr (ident ,name)))
(let* ((type (ident->type info name))
(size (type->size info type)))
(append-text info (wrap-as (i386:value->accu size)))))
((sizeof-type (type-name (decl-spec-list (type-spec (fixed-type ,name)))))
(let* ((type name)
(size (type->size info type)))
(append-text info (wrap-as (i386:value->accu size)))))
((sizeof-type (type-name (decl-spec-list (type-spec (struct-ref (ident ,name))))))
(let* ((type (list "struct" name))
(size (type->size info type)))
(append-text info (wrap-as (i386:value->accu size)))))
((sizeof-type (type-name (decl-spec-list (type-spec (struct-ref (ident ,name))))))
(let* ((type (list "struct" name))
(size (type->size info type)))
(append-text info (wrap-as (i386:value->accu size)))))
;; c+p expr->arg
;; g_cells[<expr>]
((array-ref ,index (p-expr (ident ,array)))
(let* ((type (ident->type info array))
(ptr (ident->pointer info array))
(size (if (< ptr 2) (type->size info type)
4))
(info ((expr->accu* info) o)))
(append-text info (wrap-as (append (case size
((1) (i386:byte-mem->accu))
((4) (i386:mem->accu))
(else '())))))))
;; foo.bar[baz])
((array-ref ,index (d-sel (ident ,field) (p-expr (ident ,struct))))
(let ((info ((expr->accu* info) o)))
(append-text info (wrap-as (i386:mem->accu)))))
;; foo->bar[baz])
((array-ref ,index (i-sel (ident ,field) (p-expr (ident ,struct))))
(let ((info ((expr->accu* info) o)))
(append-text info (wrap-as (i386:mem->accu)))))
;; f.field
((d-sel (ident ,field) (p-expr (ident ,array)))
(let* ((type (ident->type info array))
(offset (field-offset info type field))
(text (.text info)))
(append-text info (append ((ident->accu info) array)
(wrap-as (i386:mem+n->accu offset))))))
((d-sel (ident ,field) (array-ref ,index (p-expr (ident ,array))))
(let* ((type (ident->type info array))
(offset (field-offset info type field))
(info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array))))))
(append-text info (wrap-as (i386:mem+n->accu offset)))))
((i-sel (ident ,field) (p-expr (ident ,array)))
(let* ((type (ident->type info array))
(offset (field-offset info type field))
(text (.text info)))
(append-text info (append ((ident-address->accu info) array)
(wrap-as (i386:mem->accu))
(wrap-as (i386:mem+n->accu offset))))))
;;; FIXME: FROM INFO ...only zero?!
((p-expr (fixed ,value))
(let ((value (cstring->number value)))
(append-text info (wrap-as (i386:value->accu value)))))
((p-expr (char ,char))
(let ((char (char->integer (car (string->list char)))))
(append-text info (wrap-as (i386:value->accu char)))))
((p-expr (ident ,name))
(append-text info ((ident->accu info) name)))
((de-ref (p-expr (ident ,name)))
(let* ((type (ident->type info name))
(ptr (ident->pointer info name))
(size (if (= ptr 1) (type->size info type)
4)))
(append-text info (append ((ident->accu info) name)
(wrap-as (if (= size 1) (i386:byte-mem->accu)
(i386:mem->accu)))))))
((de-ref (post-inc (p-expr (ident ,name))))
(let* ((info ((expr->accu info) `(de-ref (p-expr (ident ,name)))))
(type (ident->type info name))
(ptr (ident->pointer info name))
(size (if (= ptr 1) (type->size info type)
4)))
(append-text info ((ident-add info) name size))))
((de-ref ,expr)
(let ((info ((expr->accu info) expr)))
(append-text info (wrap-as (i386:byte-mem->accu))))) ;; FIXME: byte
((fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list))
(if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list)))) ;; FIXME
(append-text info (wrap-as (asm->m1 arg0))))
(let* ((text-length (length text))
(args-info (let loop ((expressions (reverse expr-list)) (info info))
(if (null? expressions) info
(loop (cdr expressions) ((expr->arg info) (car expressions))))))
(n (length expr-list)))
(if (not (assoc-ref locals name))
(begin
(if (and (not (assoc name (.functions info)))
(not (assoc name globals)))
(stderr "warning: undeclared function: ~a\n" name))
(append-text args-info (list (i386:call-label name n))))
(let* ((empty (clone info #:text '()))
(accu ((expr->accu empty) `(p-expr (ident ,name)))))
(append-text args-info (append (.text accu)
(list (i386:call-accu n)))))))))
((fctn-call ,function (expr-list . ,expr-list))
(let* ((text-length (length text))
(args-info (let loop ((expressions (reverse expr-list)) (info info))
(if (null? expressions) info
(loop (cdr expressions) ((expr->arg info) (car expressions))))))
(n (length expr-list))
(empty (clone info #:text '()))
(accu ((expr->accu empty) function)))
(append-text args-info (append (.text accu)
(list (i386:call-accu n))))))
((cond-expr . ,cond-expr)
((ast->info info) `(expr-stmt ,o)))
((post-inc (p-expr (ident ,name)))
(let* ((type (ident->type info name))
(ptr (ident->pointer info name))
(size (if (> ptr 1) 4 1)))
(append-text info (append ((ident->accu info) name)
((ident-add info) name size)))))
((post-dec (p-expr (ident ,name)))
(or (assoc-ref locals name) (begin (stderr "i-- ~a\n" name) (error "undefined identifier: " name)))
(append-text info (append ((ident->accu info) name)
((ident-add info) name -1))))
((pre-inc (p-expr (ident ,name)))
(or (assoc-ref locals name) (begin (stderr "++i ~a\n" name) (error "undefined identifier: " name)))
(append-text info (append ((ident-add info) name 1)
((ident->accu info) name))))
((pre-dec (p-expr (ident ,name)))
(or (assoc-ref locals name) (begin (stderr "--i ~a\n" name) (error "undefined identifier: " name)))
(append-text info (append ((ident-add info) name -1)
((ident->accu info) name))))
((add ,a ,b) ((binop->accu info) a b (i386:accu+base)))
((sub ,a ,b) ((binop->accu info) a b (i386:accu-base)))
((bitwise-or ,a ,b) ((binop->accu info) a b (i386:accu-or-base)))
((bitwise-and ,a ,b) ((binop->accu info) a b (i386:accu-and-base)))
((bitwise-xor ,a ,b) ((binop->accu info) a b (i386:accu-xor-base)))
((lshift ,a ,b) ((binop->accu info) a b (i386:accu<<base)))
((rshift ,a ,b) ((binop->accu info) a b (i386:accu>>base)))
((div ,a ,b) ((binop->accu info) a b (i386:accu/base)))
((mod ,a ,b) ((binop->accu info) a b (i386:accu%base)))
((mul ,a ,b) ((binop->accu info) a b (i386:accu*base)))
((not ,expr)
(let* ((test-info ((ast->info info) expr)))
(clone info #:text
(append (.text test-info)
(wrap-as (i386:accu-not)))
#:globals (.globals test-info))))
((neg (p-expr (fixed ,value)))
(append-text info (value->accu (- (cstring->number value)))))
((neg (p-expr (ident ,name)))
(append-text info (append ((ident->base info) name)
(wrap-as (i386:value->accu 0))
(wrap-as (i386:sub-base)))))
((eq ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:z->accu))))
((ge ,a ,b) ((binop->accu info) b a (i386:sub-base)))
((gt ,a ,b) ((binop->accu info) b a (i386:sub-base)))
;; FIXME: set accu *and* flags
((ne ,a ,b) ((binop->accu info) a b (append (i386:push-accu)
(i386:sub-base)
(i386:nz->accu)
(i386:accu<->stack)
(i386:sub-base)
(i386:xor-zf)
(i386:pop-accu))))
((ne ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:xor-zf))))
((le ,a ,b) ((binop->accu info) b a (i386:base-sub)))
((lt ,a ,b) ((binop->accu info) b a (i386:base-sub)))
((or ,a ,b)
(let* ((info ((expr->accu info) a))
(here (number->string (length (.text info))))
(skip-b-label (string-append (.function info) "_" here "_or_skip_b"))
(info (append-text info (wrap-as (i386:accu-test))))
(info (append-text info (wrap-as (i386:jump-nz skip-b-label))))
(info (append-text info (wrap-as (i386:accu-test))))
(info ((expr->accu info) b))
(info (append-text info (wrap-as (i386:accu-test))))
(info (append-text info (wrap-as `((#:label ,skip-b-label))))))
info))
((and ,a ,b)
(let* ((info ((expr->accu info) a))
(here (number->string (length (.text info))))
(skip-b-label (string-append (.function info) "_" here "_and_skip_b"))
(info (append-text info (wrap-as (i386:accu-test))))
(info (append-text info (wrap-as (i386:jump-z skip-b-label))))
(info (append-text info (wrap-as (i386:accu-test))))
(info ((expr->accu info) b))
(info (append-text info (wrap-as (i386:accu-test))))
(info (append-text info (wrap-as `((#:label ,skip-b-label))))))
info))
((cast ,cast ,o)
((expr->accu info) o))
((assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op ,op) ,b)
(let ((info ((expr->accu info) `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b))))
(append-text info ((ident-add info) name 1)))) ;; FIXME: size
((assn-expr (de-ref (post-dec (p-expr (ident ,name)))) (op ,op) ,b)
(let ((info ((expr->accu info) `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b))))
(append-text info ((ident-add info) name -1)))) ;; FIXME: size
((assn-expr ,a (op ,op) ,b)
(let* ((info (append-text info (ast->comment o)))
(info ((expr->accu info) b))
(info (if (equal? op "=") info
(let* ((info (append-text info (wrap-as (i386:push-accu))))
(info ((expr->accu info) a))
(info (append-text info (wrap-as (i386:pop-base)))))
(append-text info (cond ((equal? op "+=") (wrap-as (i386:accu+base)))
((equal? op "-=") (wrap-as (i386:accu-base)))
((equal? op "*=") (wrap-as (i386:accu*base)))
((equal? op "/=") (wrap-as (i386:accu/base)))
((equal? op "%=") (wrap-as (i386:accu%base)))
((equal? op "|=") (wrap-as (i386:accu-or-base)))
(else (error "mescc: op ~a not supported: ~a\n" op o))))))))
(pmatch a
((p-expr (ident ,name)) (append-text info ((accu->ident info) name)))
((d-sel (ident ,field) ,p-expr)
(let* ((type (p-expr->type info p-expr))
(offset (field-offset info type field))
(info (append-text info (wrap-as (i386:push-accu))))
(info ((expr->accu* info) a))
(info (append-text info (wrap-as (i386:pop-base)))))
(append-text info (wrap-as (i386:base->accu-address))))) ; FIXME: size
;; FIXME: c&p above
((de-ref (p-expr (ident ,array)))
(let* ((type (ident->type info array))
(ptr (ident->pointer info array))
(size (if (> ptr 1) 4 1)))
(append-text info (append (wrap-as (i386:accu->base))
((base->ident-address info) array)))))
((array-ref ,index (d-sel (ident ,field) (p-expr (ident ,struct))))
(let* ((info (append-text info (wrap-as (i386:push-accu))))
(info ((expr->accu* info) a))
(info (append-text info (wrap-as (i386:pop-base)))))
(append-text info (wrap-as (i386:base->accu-address)))))
((array-ref ,index (i-sel (ident ,field) (p-expr (ident ,struct))))
(let* ((info (append-text info (wrap-as (i386:push-accu))))
(info ((expr->accu* info) a))
(info (append-text info (wrap-as (i386:pop-base)))))
(append-text info (wrap-as (i386:base->accu-address)))))
((array-ref ,index (p-expr (ident ,array)))
(let* ((type (ident->type info array))
(size (type->size info type))
(info (append-text info (wrap-as (i386:push-accu))))
(info ((expr->accu* info) a))
(info (append-text info (wrap-as (i386:pop-base)))))
(append-text info
(append (if (eq? size 1) (wrap-as (i386:byte-base->accu-address))
(if (<= size 4) (wrap-as (i386:base->accu-address))
(append
(wrap-as (i386:base-address->accu-address))
(wrap-as (append (i386:accu+n 4)
(i386:base+n 4)
(i386:base-address->accu-address)))
(if (<= size 8) '()
(wrap-as (append (i386:accu+n 4)
(i386:base+n 4)
(i386:base-address->accu-address)))))))))))
(_ (error "expr->accu: unsupported assign: " a)))))
(_ (error "expr->accu: unsupported: " o))))))
(define (expr->base info)
(lambda (o)
(let* ((info (append-text info (wrap-as (i386:push-accu))))
(info ((expr->accu info) o))
(info (append-text info (wrap-as (append (i386:accu->base) (i386:pop-accu))))))
info)))
(define (binop->accu info)
(lambda (a b c)
(let* ((info ((expr->accu info) a))
(info ((expr->base info) b)))
(append-text info (wrap-as c)))))
(define (append-text info text)
(clone info #:text (append (.text info) text)))
(define (wrap-as o . annotation)
`(,@annotation ,o))
(define (make-comment o)
(wrap-as `((#:comment ,o))))
(define (ast->comment o)
(let ((source (with-output-to-string (lambda () (pretty-print-c99 o)))))
(make-comment (string-join (string-split source #\newline) " "))))
(define (expr->accu* info)
(lambda (o)
(pmatch o
;; g_cells[<expr>]
((array-ref ,index (p-expr (ident ,array)))
(let* ((info ((expr->accu info) index))
(type (ident->type info array))
(ptr (ident->pointer info array))
(size (if (< ptr 2) (type->size info type)
4)))
(append-text info (append (wrap-as (append (i386:accu->base)
(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)
(wrap-as (i386:accu+base))))))
;; g_cells[<expr>].type
((d-sel (ident ,field) (array-ref ,index (p-expr (ident ,array))))
(let* ((type (ident->type info array))
(offset (field-offset info type field))
(info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array))))))
(append-text info (wrap-as (i386:accu+value offset)))))
((d-sel (ident ,field) (p-expr (ident ,name)))
(let* ((type (ident->type info name))
(offset (field-offset info type field))
(text (.text info)))
(append-text info (append ((ident->accu info) name)
(wrap-as (i386:accu+value offset))))))
;; foo.bar[baz]
((array-ref ,index (d-sel (ident ,field) (p-expr (ident ,name))))
(let* ((type (ident->type info name))
(offset (field-offset info type field))
(info ((expr->accu info) index)))
(append-text info (append (wrap-as (append (i386:accu-shl 2) ;; FIXME: assume size=4
(i386:push-accu)))
((ident-address->accu info) name)
(wrap-as (append (i386:accu+value offset)
(i386:pop-base)
(i386:accu+base)))))))
;; foo->bar[baz]
((array-ref ,index (i-sel (ident ,field) (p-expr (ident ,name))))
(let* ((type (ident->type info name))
(offset (field-offset info type field))
(info ((expr->accu info) index)))
(append-text info (append (wrap-as (append (i386:accu-shl 2) ;; FIXME: assume size=4
(i386:push-accu)))
((ident->accu info) name)
(wrap-as (append (i386:accu+value offset)
(i386:pop-base)
(i386:accu+base)))))))
(_ (error "expr->accu*: unsupported: " o)))))
(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 (apply + (map field:size fields)) fields))
(define i386:type-alist
'(("char" . (builtin 1 #f))
("short" . (builtin 2 #f))
("int" . (builtin 4 #f))
("long" . (builtin 4 #f))
("long long" . (builtin 8 #f))
;; FIXME sign
("unsigned char" . (builtin 1 #f))
("unsigned short" . (builtin 2 #f))
("unsigned" . (builtin 4 #f))
("unsigned int" . (builtin 4 #f))
("unsigned long" . (builtin 4 #f))
("unsigned long long" . (builtin 8 #f))))
(define (field:size o)
(pmatch o
((,name ,type ,size ,pointer) size)
(_ 4)))
(define (type->size info o)
(pmatch o
((decl-spec-list (type-spec (fixed-type ,type)))
(type->size info type))
((decl-spec-list (type-qual ,qual) (type-spec (fixed-type ,type)))
(type->size info type))
((struct-ref (ident ,type))
(type->size info `("struct" ,type)))
(_ (let ((type (get-type (.types info) o)))
(if type (cadr type)
(error "type->size: unsupported: " o))))))
(define (field-offset info struct field)
(let* ((fields (type->description info struct))
(prefix (and=> (member field (reverse fields) (lambda (a b) (equal? a (car b)))) cdr
)))
(apply + (map field:size prefix))))
(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 (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)
(,name name)
(_ (error "decl->type: unsupported: " o))))
(define (expr->global globals)
(lambda (o)
(pmatch o
((p-expr (string ,string))
(let ((g `(#:string ,string)))
(or (assoc g globals)
(string->global string))))
;;((p-expr (fixed ,value)) (int->global (cstring->number value)))
(_ #f))))
(define (initzer->global globals)
(lambda (o)
(pmatch o
((initzer ,initzer) ((expr->global globals) initzer))
(_ #f))))
(define (byte->hex.m1 o)
(string-drop o 2))
(define (asm->m1 o)
(let ((prefix ".byte "))
(if (not (string-prefix? prefix o)) (map (cut string-split <> #\space) (string-split o #\newline))
(let ((s (string-drop o (string-length prefix))))
(list (format #f "'~a'" (string-join (map byte->hex.m1 (cdr (string-split o #\space))) " ")))))))
(define (clause->info info i label last?)
(define clause-label
(string-append label "clause" (number->string i)))
(define body-label
(string-append label "body" (number->string i)))
(define (jump label)
(wrap-as (i386:jump label)))
(define (jump-nz label)
(wrap-as (i386:jump-nz label)))
(define (jump-z label)
(wrap-as (i386:jump-z label)))
(define (test->text test)
(let ((value (pmatch test
(0 0)
((p-expr (char ,value)) (char->integer (car (string->list value))))
((p-expr (ident ,constant)) (assoc-ref (.constants info) constant))
((p-expr (fixed ,value)) (cstring->number value))
((neg (p-expr (fixed ,value))) (- (cstring->number value)))
(_ (error "case test: unsupported: " test)))))
(append (wrap-as (i386:accu-cmp-value value))
(jump-z body-label))))
(define (cases+jump info cases)
(let* ((info (append-text info (wrap-as `((#:label ,clause-label)))))
(next-clause-label (if last? (string-append label "break")
(string-append label "clause" (number->string (1+ i)))))
(info (append-text info (apply append cases)))
(info (if (null? cases) info
(append-text info (jump next-clause-label))))
(info (append-text info (wrap-as `((#:label ,body-label))))))
info))
(lambda (o)
(let loop ((o o) (cases '()) (clause #f))
(pmatch o
((case ,test ,statement)
(loop statement (append cases (list (test->text test))) clause))
((default ,statement)
(loop statement cases clause))
((compd-stmt (block-item-list))
(loop '() cases clause))
((compd-stmt (block-item-list . ,elements))
(let ((clause (or clause (cases+jump info cases))))
(loop `(compd-stmt (block-item-list ,@(cdr elements))) cases
((ast->info clause) (car elements)))))
(()
(let ((clause (or clause (cases+jump info cases))))
(if last? clause
(let ((next-body-label (string-append label "body"
(number->string (1+ i)))))
(append-text clause (wrap-as (i386:jump next-body-label)))))))
(_
(let ((clause (or clause (cases+jump info cases))))
(loop '() cases
((ast->info clause) o))))))))
(define (test-jump-label->info info label)
(define (jump type . test)
(lambda (o)
(let* ((info ((ast->info info) o))
(info (append-text info (make-comment "jmp test LABEL")))
(jump-text (wrap-as (type label))))
(append-text info (append (if (null? test) '() (car test))
jump-text)))))
(lambda (o)
(pmatch o
;; unsigned
;; ((le ,a ,b) ((jump i386:jump-ncz) o)) ; ja
;; ((lt ,a ,b) ((jump i386:jump-nc) o)) ; jae
;; ((ge ,a ,b) ((jump i386:jump-ncz) o))
;; ((gt ,a ,b) ((jump i386:jump-nc) o))
((le ,a ,b) ((jump i386:jump-g) o))
((lt ,a ,b) ((jump i386:jump-ge) o))
((ge ,a ,b) ((jump i386:jump-g) o))
((gt ,a ,b) ((jump i386:jump-ge) o))
((ne ,a ,b) ((jump i386:jump-nz) o))
((eq ,a ,b) ((jump i386:jump-nz) o))
((not _) ((jump i386:jump-z) o))
((and ,a ,b)
(let* ((info ((test-jump-label->info info label) a))
(info ((test-jump-label->info info label) b)))
info))
((or ,a ,b)
(let* ((here (number->string (length (.text info))))
(skip-b-label (string-append label "_skip_b_" here))
(b-label (string-append label "_b_" here))
(info ((test-jump-label->info info b-label) a))
(info (append-text info (wrap-as (i386:jump skip-b-label))))
(info (append-text info (wrap-as `((#:label ,b-label)))))
(info ((test-jump-label->info info label) b))
(info (append-text info (wrap-as `((#:label ,skip-b-label))))))
info))
((array-ref . _) ((jump i386:jump-byte-z
(wrap-as (i386:accu-zero?))) o))
((de-ref _) ((jump i386:jump-byte-z
(wrap-as (i386:accu-zero?))) o))
((assn-expr (p-expr (ident ,name)) ,op ,expr)
((jump i386:jump-z
(append ((ident->accu info) name)
(wrap-as (i386:accu-zero?)))) o))
(_ ((jump i386:jump-z (wrap-as (i386:accu-zero?))) o)))))
(define (cstring->number s)
(cond ((string-prefix? "0x" s) (string->number (string-drop s 2) 16))
((string-prefix? "0b" s) (string->number (string-drop s 2) 2))
((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))))
(list name type 4))
((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ident ,name))))
(list name type 4))
((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ident ,name))))
(list name type 4))
((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
(list name type 4)) ;; FIXME: **
((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-list)))))
(list name type 4)) ;; FIXME function / int
((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
(list name type 4)) ;; FIXME: ptr/char
((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
(list name type 4)) ;; FIXME: **
((comp-decl (decl-spec-list (type-spec (void))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
(list name '(void) 4)) ;; FIXME: *
((comp-decl (decl-spec-list (type-spec (void))) (comp-declr-list (comp-declr (ftn-declr (scope (ptr-declr (pointer) (ident ,name))) (param-list . ,param-list)))))
(list name '(void) 4))
((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
(list name '(void) 4))
((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (array-of (ident ,name) (p-expr (fixed ,count)))))))
(let ((size 4)
(count (cstring->number count)))
(list name type (* count size) 0)))
((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (array-of (ident ,name) (p-expr (fixed ,count))))))
(let ((size 4)
(count (cstring->number count)))
(list name type (* count size) 0)))
((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (array-of (ident ,name) (p-expr (fixed ,count))))))
(let ((size 4)
(count (cstring->number count)))
(list name type (* count size) 0)))
;; struct InlineFunc **inline_fns;
((comp-decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (comp-declr-list (comp-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
(list name type 4))
((comp-decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
(list name type 4))
(_ (error "struct-field: unsupported: " o))))
(define (ident->decl info o)
(or (assoc-ref (.locals info) o)
(assoc-ref (.globals info) o)
(begin
(stderr "NO IDENT: ~a\n" 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 (p-expr->type info o)
(pmatch o
((p-expr (ident ,name)) (ident->type info name))
((array-ref ,index (p-expr (ident ,array)))
(ident->type info array))
(_ (error "p-expr->type: unsupported: " o))))
(define (get-type types o)
(let ((t (assoc-ref types o)))
(pmatch t
((typedef ,next) (get-type types next))
(_ t))))
(define (type->description info o)
(pmatch o
((decl-spec-list (type-spec (fixed-type ,type)))
(type->description info type))
((struct-ref (ident ,type))
(type->description info `("struct" ,type)))
(_ (let ((type (get-type (.types info) o)))
(if (not type) (stderr "TYPES=~s\n" (.types info)))
(if type (caddr type)
(error "type->description: unsupported:" o))))))
(define (local? o) ;; formals < 0, locals > 0
(positive? (local:id o)))
(define (statements->clauses statements)
(let loop ((statements statements) (clauses '()))
(if (null? statements) clauses
(let ((s (car statements)))
(pmatch s
((case ,test (compd-stmt (block-item-list . _)))
(loop (cdr statements) (append clauses (list s))))
((case ,test (break))
(loop (cdr statements) (append clauses (list s))))
((case ,test) (loop (cdr statements) (append clauses (list s))))
((case ,test ,statement)
(let loop2 ((statement statement) (heads `((case ,test))))
(define (heads->case heads statement)
(if (null? heads) statement
(append (car heads) (list (heads->case (cdr heads) statement)))))
(pmatch statement
((case ,t2 ,s2) (loop2 s2 (append heads `((case ,t2)))))
((default ,s2) (loop2 s2 (append heads `((default)))))
((compd-stmt (block-item-list . _)) (loop (cdr statements) (append clauses (list (heads->case heads statement)))))
(_ (let loop3 ((statements (cdr statements)) (c (list statement)))
(if (null? statements) (loop statements (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@c))))))
(let ((s (car statements)))
(pmatch s
((case . _) (loop statements (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@c)))))))
((default _) (loop statements (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@c)))))))
((break) (loop (cdr statements) (append clauses (list (heads->case heads `(compd-stmt (block-item-list ,@(append c (list s)))))))))
(_ (loop3 (cdr statements) (append c (list s))))))))))))
((default (compd-stmt (block-item-list _)))
(loop (cdr statements) (append clauses (list s))))
((default . ,statement)
(let loop2 ((statements (cdr statements)) (c statement))
(if (null? statements) (loop statements (append clauses (list `(default ,@c))))
(let ((s (car statements)))
(pmatch s
((compd-stmt (block-item-list . _)) (loop (cdr statements) (append clauses (list `(default ,s)))))
((case . _) (loop statements (append clauses (list `(default (compd-stmt (block-item-list ,@c)))))))
((default _) (loop statements (append clauses (list `(default (compd-stmt (block-item-list ,@c)))))))
((break) (loop (cdr statements) (append clauses (list `(default (compd-stmt (block-item-list ,@(append c (list s)))))))))
(_ (loop2 (cdr statements) (append c (list s)))))))))
(_ (error "statements->clauses: unsupported:" s)))))))
(define (ast->info info)
(lambda (o)
(let ((functions (.functions info))
(globals (.globals info))
(locals (.locals info))
(constants (.constants info))
(types (.types info))
(text (.text info)))
(define (add-local locals name type pointer)
(let* ((id (if (or (null? locals) (not (local? (cdar locals)))) 1
(1+ (local:id (cdar locals)))))
(locals (cons (make-local name type pointer id) locals)))
locals))
(define (declare name)
(if (member name functions) info
(clone info #:functions (cons (cons name #f) functions))))
(pmatch o
(((trans-unit . _) . _)
((ast-list->info info) o))
((trans-unit . ,elements)
((ast-list->info info) elements))
((fctn-defn . _) ((function->info info) o))
((cpp-stmt (define (name ,name) (repl ,value)))
info)
((cast (type-name (decl-spec-list (type-spec (void)))) _)
info)
((break)
(let ((label (car (.break info))))
(append-text info (wrap-as (i386:jump label)))))
((continue)
(let ((label (car (.continue info))))
(append-text info (wrap-as (i386:jump label)))))
;; FIXME: expr-stmt wrapper?
(trans-unit info)
((expr-stmt) info)
((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))))
(append-text info (wrap-as (asm->m1 arg0))))
(let* ((info (append-text info (ast->comment o)))
(info ((expr->accu info) `(fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))))
(append-text info (wrap-as (i386:accu-zero?))))))
((if ,test ,then)
(let* ((info (append-text info (ast->comment `(if ,test (ellipsis)))))
(here (number->string (length text)))
(label (string-append (.function info) "_" here "_"))
(break-label (string-append label "break"))
(else-label (string-append label "else"))
(info ((test-jump-label->info info break-label) test))
(info ((ast->info info) then))
(info (append-text info (wrap-as (i386:jump break-label))))
(info (append-text info (wrap-as `((#:label ,break-label))))))
(clone info
#:locals locals)))
((if ,test ,then ,else)
(let* ((info (append-text info (ast->comment `(if ,test (ellipsis) (ellipsis)))))
(here (number->string (length text)))
(label (string-append (.function info) "_" here "_"))
(break-label (string-append label "break"))
(else-label (string-append label "else"))
(info ((test-jump-label->info info else-label) test))
(info ((ast->info info) then))
(info (append-text info (wrap-as (i386:jump break-label))))
(info (append-text info (wrap-as `((#:label ,else-label)))))
(info ((ast->info info) else))
(info (append-text info (wrap-as `((#:label ,break-label))))))
(clone info
#:locals locals)))
;; Hmm?
((expr-stmt (cond-expr ,test ,then ,else))
(let* ((info (append-text info (ast->comment `(cond-expr ,test (ellipsis) (ellipsis)))))
(here (number->string (length text)))
(label (string-append (.function info) "_" here "_"))
(else-label (string-append label "else"))
(break-label (string-append label "break"))
(info ((test-jump-label->info info else-label) test))
(info ((ast->info info) then))
(info (append-text info (wrap-as (i386:jump break-label))))
(info (append-text info (wrap-as `((#:label ,else-label)))))
(info ((ast->info info) else))
(info (append-text info (wrap-as `((#:label ,break-label))))))
info))
((switch ,expr (compd-stmt (block-item-list . ,statements)))
(let* ((info (append-text info (ast->comment `(switch ,expr (compd-stmt (block-item-list (ellipsis)))))))
(here (number->string (length text)))
(label (string-append (.function info) "_" here "_"))
(break-label (string-append label "break"))
(clauses (statements->clauses statements))
(info ((expr->accu info) expr))
(info (clone info #:break (cons break-label (.break info))))
(info (let loop ((clauses clauses) (i 0) (info info))
(if (null? clauses) info
(loop (cdr clauses) (1+ i) ((clause->info info i label (null? (cdr clauses))) (car clauses))))))
(info (append-text info (wrap-as `((#:label ,break-label))))))
(clone info
#:locals locals
#:break (cdr (.break info)))))
((for ,init ,test ,step ,body)
(let* ((info (append-text info (ast->comment `(for ,init ,test ,step (ellipsis)))))
(here (number->string (length text)))
(label (string-append (.function info) "_" here "_"))
(break-label (string-append label "break"))
(loop-label (string-append label "loop"))
(continue-label (string-append label "continue"))
(initial-skip-label (string-append label "initial_skip"))
(info ((ast->info info) init))
(info (clone info #:break (cons break-label (.break info))))
(info (clone info #:continue (cons continue-label (.continue info))))
(info (append-text info (wrap-as (i386:jump initial-skip-label))))
(info (append-text info (wrap-as `((#:label ,loop-label)))))
(info ((ast->info info) body))
(info (append-text info (wrap-as `((#:label ,continue-label)))))
(info ((expr->accu info) step))
(info (append-text info (wrap-as `((#:label ,initial-skip-label)))))
(info ((test-jump-label->info info break-label) test))
(info (append-text info (wrap-as (i386:jump loop-label))))
(info (append-text info (wrap-as `((#:label ,break-label))))))
(clone info
#:locals locals
#:break (cdr (.break info))
#:continue (cdr (.continue info)))))
((while ,test ,body)
(let* ((info (append-text info (ast->comment `(while ,test (ellipsis)))))
(here (number->string (length text)))
(label (string-append (.function info) "_" here "_"))
(break-label (string-append label "break"))
(loop-label (string-append label "loop"))
(continue-label (string-append label "continue"))
(info (append-text info (wrap-as (i386:jump continue-label))))
(info (clone info #:break (cons break-label (.break info))))
(info (clone info #:continue (cons continue-label (.continue info))))
(info (append-text info (wrap-as `((#:label ,loop-label)))))
(info ((ast->info info) body))
(info (append-text info (wrap-as `((#:label ,continue-label)))))
(info ((test-jump-label->info info break-label) test))
(info (append-text info (wrap-as (i386:jump loop-label))))
(info (append-text info (wrap-as `((#:label ,break-label))))))
(clone info
#:locals locals
#:break (cdr (.break info))
#:continue (cdr (.continue info)))))
((do-while ,body ,test)
(let* ((info (append-text info (ast->comment `(do-while ,test (ellipsis)))))
(here (number->string (length text)))
(label (string-append (.function info) "_" here "_"))
(break-label (string-append label "break"))
(loop-label (string-append label "loop"))
(continue-label (string-append label "continue"))
(info (clone info #:break (cons break-label (.break info))))
(info (clone info #:continue (cons continue-label (.continue info))))
(info (append-text info (wrap-as `((#:label ,loop-label)))))
(info ((ast->info info) body))
(info (append-text info (wrap-as `((#:label ,continue-label)))))
(info ((test-jump-label->info info break-label) test))
(info (append-text info (wrap-as (i386:jump loop-label))))
(info (append-text info (wrap-as `((#:label ,break-label))))))
(clone info
#:locals locals
#:break (cdr (.break info))
#:continue (cdr (.continue info)))))
((labeled-stmt (ident ,label) ,statement)
(let ((info (append-text info `(((#:label ,(string-append (.function info) "_label_" label)))))))
((ast->info info) statement)))
((goto (ident ,label))
(append-text info (wrap-as (i386:jump (string-append (.function info) "_label_" label)))))
((return ,expr)
(let ((info ((expr->accu info) expr)))
(append-text info (append (wrap-as (i386:ret))))))
;; DECL
;; 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))))))
;; enum e i;
((decl (decl-spec-list (type-spec (enum-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name))))
(let ((type "int")) ;; FIXME
(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)))
(append-text info ((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)) (error "ast->info: unsupported: " o))
(let* ((locals (add-local locals name type 0))
(info (clone info #:locals locals))
(value (char->integer (car (string->list value)))))
(append-text info ((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)))
(append-text info ((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)) (error "ast->info: unsupported: " o))
(let* ((locals (add-local locals name type 0))
(info (clone info #:locals locals)))
(append-text info (append ((ident->accu info) local)
((accu->ident info) name)))))
;; char *p = "foo";
((decl (decl-spec-list (type-spec (fixed-type ,type)) . _) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (string ,string))))))
(if (.function info)
(let* ((locals (add-local locals name type 1))
(globals ((globals:add-string globals) string))
(info (clone info #:locals locals #:globals globals)))
(append-text info (append
(list (i386:label->accu `(#:string ,string)))
((accu->ident info) name))))
(let* ((globals ((globals:add-string globals) string))
(size 4)
(global (make-global name type 1 (initzer->data `(initzer (p-expr (string ,string))))))
(globals (append globals (list global))))
(clone info #:globals globals))))
;; char *p;
((decl (decl-spec-list (type-spec (fixed-type ,type)) . _) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
(if (.function info)
(let* ((locals (add-local locals name type 1))
(info (clone info #:locals locals)))
(append-text info (append (wrap-as (i386:value->accu 0))
((accu->ident info) name))))
(let ((globals (append globals (list (ident->global name type 1 0)))))
(clone info #:globals globals))))
;; 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)))
(append-text info (append (wrap-as (i386:value->accu value))
((accu->ident info) name))))
(clone info #:globals (append globals (list (ident->global name type 1 value)))))))
;; FILE *p;
((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
(if (.function info)
(let* ((locals (add-local locals name type 1))
(info (clone info #:locals locals)))
(append-text info (append (wrap-as (i386:value->accu 0))
((accu->ident info) name))))
(let ((globals (append globals (list (ident->global name type 1 0)))))
(clone info #:globals globals))))
;; FILE *p = 0;
((decl (decl-spec-list (type-spec (typename ,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)))
(append-text info (append (wrap-as (i386:value->accu value))
((accu->ident info) name))))
(clone info #:globals (append globals (list (ident->global name type 1 value)))))))
;; char **p;
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
(if (.function info)
(let* ((locals (add-local locals name type 2))
(info (clone info #:locals locals)))
(append-text info (append (wrap-as (i386:value->accu 0))
((accu->ident info) name))))
(let ((globals (append globals (list (ident->global name type 2 0)))))
(clone info #:globals globals))))
;; char **p = g_environment;
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer (pointer)) (ident ,name)) (initzer (p-expr (ident ,b)))))) ;; FIXME: initzer
(if (.function info)
(let* ((locals (add-local locals name type 2))
(info (clone info #:locals locals)))
(append-text info (append
((ident->accu info) b)
((accu->ident info) name))))
(let* ((value (assoc-ref constants b))
(global (ident->global name type 2 (initzer->data `(p-expr (fixed ,value)))))
(globals (append globals (list global))))
(clone info #:globals globals))))
;; struct foo bar[2];
;; 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)
(let* ((local (car (add-local locals name type -1)))
(count (string->number count))
(size (type->size info type))
(local (make-local name type -1 (+ (local:id (cdr local)) -1 (quotient (+ (* count size) 3) 4))))
(locals (cons local locals))
(info (clone info #:locals locals)))
info)
(let* ((globals (.globals info))
(count (cstring->number count))
(size (type->size info type))
(array (make-global name type -1 (string->list (make-string (* count size) #\nul))))
(globals (append globals (list array))))
(clone info #:globals globals)))))
;; char* a[10];
((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr (pointer) (array-of (ident ,name) (p-expr (fixed ,count)))))))
(let ((type (ast->type type)))
(if (.function info)
(let* ((local (car (add-local locals name type -1)))
(count (string->number count))
(size (type->size info type))
(local (make-local name type 1 (+ (local:id (cdr local)) -1 (quotient (+ (* count size) 3) 4))))
(locals (cons local locals))
(info (clone info #:locals locals)))
info)
(let* ((globals (.globals info))
(count (cstring->number count))
(size (type->size info type))
(array (make-global name type 1 (string->list (make-string (* count size) #\nul))))
(globals (append globals (list array))))
(clone info #:globals globals)))))
;; struct foo bar;
((decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name))))
(if (.function info)
(let* ((size (type->size info (list "struct" type)))
(local (car (add-local locals name type 1)))
(local (make-local name `("struct" ,type) -1 (+ (local:id (cdr local)) -1 (quotient (+ size 3) 4))))
(locals (cons local locals)))
(clone info #:locals locals))
(let* ((size (type->size info (list "struct" type)))
(global (make-global name (list "struct" type) -1 (string->list (make-string size #\nul))))
(globals (append globals (list global)))
(info (clone info #:globals globals)))
info)))
;;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)))))))
(if (.function info)
(let* ((locals (add-local locals name `("struct" ,type) 1))
(info (clone info #:locals locals)))
(append-text info (append ((ident->accu info) name)
((accu->ident info) value)))) ;; FIXME: deref?
(let* ((globals (append globals (list (ident->global name `("struct" ,type) 1 0))))
(info (clone info #:globals globals)))
(append-text info (append ((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))))
(if (.function info)
(let ((size (type->size info type)))
(if (<= size 4) (clone info #:locals (add-local locals name type 0))
(let* ((local (car (add-local locals name type 1)))
(local (make-local name type -1 (+ (local:id (cdr local)) -1 (quotient (+ size 3) 4))))
(locals (cons local locals)))
(clone info #:locals locals))))
(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))))))
(let ((value (cstring->number value)))
(if (.function info)
(let* ((locals (add-local locals name type 0))
(info (clone info #:locals locals)))
(append-text info ((value->ident info) name value)))
(let ((globals (append globals (list (ident->global name type 0 value)))))
(clone info #:globals globals)))))
;; SCM i = argc;
((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
(if (.function info)
(let* ((locals (add-local locals name type 0))
(info (clone info #:locals locals)))
(append-text info (append ((ident->accu info) local)
((accu->ident info) name))))
(let* ((globals (append globals (list (ident->global name type 0 0))))
(info (clone info #:globals globals)))
(append-text info (append ((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)
(wrap-as (append (i386:label->base `(#:address "_start"))
(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)))))))
(if (.function info)
(let* ((locals (add-local locals name type 1))
(info (clone info #:locals locals)))
(append-text info (append ((ident->accu info) value)
((accu->ident info) name))))
(let ((globals (append globals (list (ident->global name type 1 `(,value #f #f #f))))))
(clone info #:globals globals))))
;; 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))))))
(let ((type (decl->type type)))
(if (.function info)
(let* ((locals (add-local locals name type 1))
(info (clone info #:locals locals)))
(append-text info (append ((ident->accu info) value)
((accu->ident info) name))))
(let ((globals (append globals (list (ident->global name type 1 `(,value #f #f #f))))))
(clone info #:globals globals)))))
;; enum foo { };
((decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields)))))
(let ((type (enum->type name fields))
(constants (enum-def-list->constants constants fields)))
(clone info
#:types (append types (list type))
#:constants (append constants (.constants info)))))
;; enum {};
((decl (decl-spec-list (type-spec (enum-def (enum-def-list . ,fields)))))
(let ((constants (enum-def-list->constants constants fields)))
(clone info
#:constants (append constants (.constants info)))))
;; FIXME TCC/Nyacc madness here: extra parentheses around struct name?!?
;; struct (FOO) WTF?
((decl (decl-spec-list (type-spec (struct-def (ident (,name)) (field-list . ,fields)))))
(let ((type (struct->type (list "struct" name) (map struct-field fields))))
(clone info #:types (append types (list type)))))
((decl (decl-spec-list (type-spec (struct-def (ident (,type)) (field-list . ,fields))))
(init-declr-list (init-declr (ident ,name))))
(let ((info ((ast->info info) `(decl (decl-spec-list (type-spec (struct-def (ident ,type) (field-list . ,fields))))))))
((ast->info info)
`(decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name)))))))
;; struct foo* bar = expr;
((decl (decl-spec-list (type-spec (struct-ref (ident (,type))))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (ref-to (p-expr (ident ,value)))))))
(if (.function info) (let* ((locals (add-local locals name (list "struct" type) 1))
(info (clone info #:locals locals)))
(append-text info (append ((ident-address->accu info) value)
((accu->ident info) name))))
(error "ast->info: unsupported global:" o)))
;; END FIXME -- dupe of the below
;; 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))))
(clone info #:types (cons type types))))
;; struct foo {} bar;
((decl (decl-spec-list (type-spec (struct-def (ident ,type) (field-list . ,fields))))
(init-declr-list (init-declr (ident ,name))))
(let ((info ((ast->info info) `(decl (decl-spec-list (type-spec (struct-def (ident ,type) (field-list . ,fields))))))))
((ast->info info)
`(decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name)))))))
;; struct foo* bar = expr;
((decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (ref-to (p-expr (ident ,value)))))))
(if (.function info) (let* ((locals (add-local locals name (list "struct" type) 1))
(info (clone info #:locals locals)))
(append-text info (append ((ident-address->accu info) value)
((accu->ident info) name))))
(error "ast->info: unsupported global:" o)))
;; char *p = &bla;
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (ref-to (p-expr (ident ,value)))))))
(let ((type (decl->type type)))
(if (.function info)
(let* ((locals (add-local locals name type 1))
(info (clone info #:locals locals)))
(append-text info (append ((ident-address->accu info) value)
((accu->ident info) name))))
(error "TODO" o))))
;; char **p = &bla;
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer (pointer)) (ident ,name)) (initzer (ref-to (p-expr (ident ,value)))))))
(let ((type (decl->type type)))
(if (.function info)
(let* ((locals (add-local locals name type 2))
(info (clone info #:locals locals)))
(append-text info (append ((ident-address->accu info) value)
((accu->ident info) name))))
(error "TODO" o))))
;; char *p = bla[0];
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (array-ref ,index (p-expr (ident ,array)))))))
(if (.function info)
(let* ((locals (add-local locals name type 1))
(info (clone info #:locals locals))
(info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array))))))
(append-text info ((accu->ident info) name)))
(error "TODO" o)))
;; char *foo = &bar[0];
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (ref-to (array-ref ,index (p-expr (ident ,array))))))))
(if (.function info)
(let* ((locals (add-local locals name type 1))
(info (clone info #:locals locals))
(info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array))))))
(append-text info ((accu->ident info) name)))
(error "TODO" o)))
;; char *p = *bla;
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (de-ref (p-expr (ident ,value)))))))
(if (.function info)
(let* ((locals (add-local locals name type 1))
(info (clone info #:locals locals))
(local (assoc-ref (.locals info) name)))
(append-text info (append ((ident->accu info) value)
(wrap-as (i386:mem->accu))
((accu->ident info) name))))
(error "TODO" o)))
;; DECL
;; char *bla[] = {"a", "b"};
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (array-of (ident ,name))) (initzer (initzer-list . ,initzers)))))
(let* ((type (decl->type type))
(entries (map (initzer->global globals) initzers))
(entry-size 4)
(size (* (length entries) entry-size))
(initzers (map (initzer->non-const info) initzers)))
(if (.function info)
(error "TODO: <type> x[] = {};" o)
(let* (;;(global (make-global name type 2 (string->list (make-string size #\nul))))
(global (make-global name type 2 (append-map initzer->data initzers)))
(global-names (map car globals))
(entries (filter (lambda (g) (and g (not (member (car g) global-names)))) entries))
(globals (append globals entries (list global))))
(clone info #:globals globals)))))
;;
;; struct f = {...};
((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ident ,name) (initzer (initzer-list . ,initzers)))))
(let* ((info (append-text info (ast->comment o)))
(type (decl->type type))
(fields (type->description info type))
(size (type->size info type))
(initzers (map (initzer->non-const info) initzers)))
(if (.function info)
(let* ((initzer-globals (filter-map (initzer->global globals) initzers))
(global-names (map car globals))
(initzer-globals (filter (lambda (g) (and g (not (member (car g) global-names)))) initzer-globals))
(globals (append globals initzer-globals))
(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 fields) (initzers initzers) (info info))
(if (null? fields) info
(let ((offset (field-offset info type (caar fields)))
(initzer (car initzers)))
(loop (cdr fields) (cdr initzers)
(clone info #:text
(append
(.text info)
((ident->accu info) name)
(wrap-as (append (i386:accu->base)))
(.text ((expr->accu empty) initzer))
(wrap-as (i386:accu->base-address+n offset)))))))))
(let* ((initzer-globals (filter-map (initzer->global globals) initzers))
(global-names (map car globals))
(initzer-globals (filter (lambda (g) (and g (not (member (car g) global-names)))) initzer-globals))
(globals (append globals initzer-globals))
(global (make-global name type 2 (append-map initzer->data initzers)))
(globals (append globals (list global))))
(clone info #:globals globals)))))
;;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))
(initzer ((initzer->non-const info) initzer))
(info (append-text info (ast->comment o))))
(if (.function info)
(let* ((locals (add-local locals name type 0))
(info (clone info #:locals locals))
(info ((expr->accu info) initzer)))
(append-text info ((accu->ident info) name)))
(let* ((global (make-global name type 2 (initzer->data initzer)))
(globals (append globals (list global))))
(clone info #:globals globals)))))
((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
(declare name))
((decl (decl-spec-list (stor-spec (typedef)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
(clone info #:types (cons (cons name (get-type types type)) types)))
;; int foo ();
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
(declare name))
;; void foo ();
((decl (decl-spec-list (type-spec (void))) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
(declare name))
;; void foo (*);
((decl (decl-spec-list (type-spec (void))) (init-declr-list (init-declr (ptr-declr (pointer) (ftn-declr (ident ,name) (param-list . ,param-list))))))
(declare name))
;; char *strcpy ();
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ftn-declr (ident ,name) (param-list . ,param-list))))))
(declare name))
;; printf (char const* format, ...)
((decl (decl-spec-list ,type) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list ,param-list . (ellipsis))))))
(declare name))
;; <name> tcc_new
((decl (decl-spec-list ,type) (init-declr-list (init-declr (ptr-declr (pointer) (ftn-declr (ident ,name) (param-list . ,param-list))))))
(declare name))
;; extern type foo ()
((decl (decl-spec-list (stor-spec (extern)) ,type) (init-declr-list (init-declr (ftn-declr (ident ,name) (param-list . ,param-list)))))
(declare name))
;; struct TCCState;
((decl (decl-spec-list (type-spec (struct-ref (ident ,name)))))
info)
;; extern type global;
((decl (decl-spec-list (stor-spec (extern)) ,type) (init-declr-list (init-declr (ident ,name))))
info)
;; ST_DATA struct TCCState *tcc_state;
((decl (decl-spec-list (stor-spec (extern)) (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
info)
;; ST_DATA int ch, tok; -- TCC, why oh why so difficult?
((decl (decl-spec-list (stor-spec (extern)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name)) . ,rest))
info)
;; ST_DATA const int *macro_ptr;
((decl (decl-spec-list (stor-spec (extern)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
info)
;; ST_DATA TokenSym **table_ident;
((decl (decl-spec-list (stor-spec (extern)) (type-spec (typename ,type))) (init-declr-list (init-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
info)
;; ST_DATA Section *text_section, *data_section, *bss_section; /* predefined sections */
((decl (decl-spec-list (stor-spec (extern)) (type-spec (typename ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name))) . ,rest))
info)
;; ST_DATA void **sym_pools;
((decl (decl-spec-list (stor-spec (extern)) (type-spec (void))) (init-declr-list (init-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
info)
;; ST_DATA CType char_pointer_type, func_old_type, int_type, size_type;
((decl (decl-spec-list (stor-spec (extern)) (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name)) . ,rest))
info)
;; ST_DATA SValue __vstack[1+/*to make bcheck happy*/ VSTACK_SIZE], *vtop;
;; Yay, let's hear it for the T-for Tiny in TCC!?
((decl (decl-spec-list (stor-spec (extern)) (type-spec (typename ,type))) (init-declr-list (init-declr (array-of (ident ,name) (add (p-expr (fixed ,a)) (p-expr (fixed ,b))))) (init-declr (ptr-declr (pointer) (ident ,name2)))))
info)
;; ST_DATA char *funcname;
((decl (decl-spec-list (stor-spec (extern)) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
info)
;; int i = 0, j = 0;
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) . ,initzer) . ,rest))
(let loop ((inits `((init-declr (ident ,name) ,@initzer) ,@rest)) (info info))
(if (null? inits) info
(loop (cdr inits)
((ast->info info)
`(decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list ,(car inits))))))))
;; char *foo[0], *bar;
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (array-of (ident ,name) ,index)) . ,rest))
(let loop ((inits `((init-declr (array-of (ident ,name) ,index)) ,@rest)) (info info))
(if (null? inits) info
(loop (cdr inits)
((ast->info info)
`(decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list ,(car inits))))))))
((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-ref (ident (,type))))) (init-declr-list (init-declr (ident ,name))))
(clone info #:types (cons (cons name (or (get-type types type) `(typedef ("struct" ,type)))) types)))
((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name))))
(clone info #:types (cons (cons name (or (get-type types type) `(typedef ("struct" ,type)))) types)))
((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-ref (ident ,type)))) (init-declr-list (init-declr (ident ,name))))
(clone info #:types (cons (cons name (or (get-type types type) `(typedef ("struct" ,type)))) types)))
((decl (decl-spec-list (stor-spec (typedef)) (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name))))
(clone info #:types (cons (cons name (or (get-type types type) `(typedef ,type))) types)))
((decl (decl-spec-list (stor-spec (typedef)) (type-spec (struct-def ,field-list))) (init-declr-list (init-declr (ident ,name))))
(let ((info ((ast->info info) `(decl (decl-spec-list (type-spec (struct-def (ident ,name) ,field-list))) (init-declr-list (init-declr (ident ,name)))))))
(clone info #:types (cons (cons name (or (get-type types `("struct" ,name)) `(typedef ,name))) 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 . _) (error "ast->info: unsupported: " o))
;; ...
((gt . _) ((expr->accu info) o))
((ge . _) ((expr->accu info) o))
((ne . _) ((expr->accu info) o))
((eq . _) ((expr->accu info) o))
((le . _) ((expr->accu info) o))
((lt . _) ((expr->accu info) o))
((lshift . _) ((expr->accu info) o))
((rshift . _) ((expr->accu info) o))
;; EXPR
((expr-stmt ,expression)
(let ((info ((expr->accu info) expression)))
(append-text info (wrap-as (i386:accu-zero?)))))
;; FIXME: why do we get (post-inc ...) here
;; (array-ref
(_ (let ((info ((expr->accu info) o)))
(append-text info (wrap-as (i386:accu-zero?)))))))))
(define (enum-def-list->constants constants fields)
(let loop ((fields fields) (i 0) (constants constants))
(if (null? fields) constants
(let* ((field (car fields))
(name (pmatch field
((enum-defn (ident ,name) . _) name)))
(i (pmatch field
((enum-defn ,name (p-expr (fixed ,value))) (cstring->number value))
((enum-defn ,name) i)
((enum-defn ,name (add (p-expr (fixed ,a)) (p-expr (fixed ,b))))
(+ (cstring->number a) (cstring->number b)))
((enum-defn ,name (sub (p-expr (fixed ,a)) (p-expr (fixed ,b))))
(- (cstring->number a) (cstring->number b)))
(_ (error "not supported enum field=~s\n" field)))))
(loop (cdr fields)
(1+ i)
(append constants (list (ident->constant name i))))))))
(define (initzer->non-const info)
(lambda (o)
(pmatch o
((initzer (p-expr (ident ,name)))
(let ((value (assoc-ref (.constants info) name)))
`(initzer (p-expr (fixed ,(number->string value))))))
(_ o))))
(define (initzer->data 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)))) `(,name #f #f #f))
((initzer (p-expr (string ,string))) `((#:string ,string) #f #f #f))
(_ (error "initzer->data: unsupported: " o))))
(define (.formals o)
(pmatch o
((fctn-defn _ (ftn-declr _ ,formals) _) formals)
((fctn-defn _ (ptr-declr (pointer) (ftn-declr _ ,formals)) _) formals)
((fctn-defn _ (ptr-declr (pointer (pointer)) (ftn-declr _ ,formals)) _) formals)
(_ (error ".formals: " o))))
(define (formal->text n)
(lambda (o i)
;;(i386:formal i n)
'()
))
(define (formals->text o)
(pmatch o
((param-list . ,formals)
(let ((n (length formals)))
(wrap-as (append (i386:function-preamble)
(append-map (formal->text n) formals (iota n))
(i386:function-locals)))))
(_ (error "formals->text: unsupported: " o))))
(define (formal:ptr o)
(pmatch o
((param-decl (decl-spec-list . ,decl) (param-declr (ident ,name)))
0)
((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) (array-of (ident ,name)))))
2)
((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) (ident ,name))))
1)
((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer) . _)))
1)
((param-decl (decl-spec-list . ,decl) (param-declr (ptr-declr (pointer (pointer)) (ident ,name))))
2)
(_
(stderr "formal:ptr[~a] => ~a\n" o 0)
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))))
(_ (error "formals->locals: unsupported: " o))))
(define (function->info info)
(lambda (o)
(define (assert-return text)
(let ((return (wrap-as (i386:ret))))
(if (equal? (list-tail text (- (length text) (length return))) return) text
(append text return))))
(let* ((name (.name o))
(formals (.formals o))
(text (formals->text formals))
(locals (formals->locals formals)))
(format (current-error-port) " :~a\n" name)
(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 (assert-return (.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* (c99-input->info #:key (defines '()) (includes '()))
(lambda ()
(let* ((info (make <info> #:types i386:type-alist))
(foo (stderr "parsing: input\n"))
(ast (c99-input->ast #:defines defines #:includes includes))
(foo (stderr "compiling: input\n"))
(info ((ast->info info) ast))
(info (clone info #:text '() #:locals '())))
info)))
(define* (info->object o)
`((functions . ,(.functions o))
(globals . ,(map (lambda (g) (cons (car g) (global:value (cdr g)))) (.globals o)))))
(define* (c99-ast->info ast)
((ast->info (make <info> #:types i386:type-alist)) ast))
(define* (c99-input->elf #:key (defines '()) (includes '()))
((compose object->elf info->object (c99-input->info #:defines defines #:includes includes))))
(define* (c99-input->object #:key (defines '()) (includes '()))
((compose object->M1 info->object (c99-input->info #:defines defines #:includes includes))))
Reference in New Issue View Git Blame Copy Permalink