2432 lines
113 KiB
Scheme
2432 lines
113 KiB
Scheme
;;; -*-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 (mes pmatch))
|
|
(mes-use-module (nyacc lang c99 parser))
|
|
(mes-use-module (mes elf-util))
|
|
(mes-use-module (mes elf))
|
|
(mes-use-module (mes as-i386))
|
|
(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 "") "libc/include" (string-append %prefix "/include"))))
|
|
(parse-c99
|
|
#:inc-dirs (append includes (cons* "." "libc" "src" "out" "out/src" include (string-split (getenv "C_INCLUDE_PATH") #\:)))
|
|
#: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* (c99-input->ast #:key (defines '()) (includes '()))
|
|
(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 <init> '<init>)
|
|
(define <locals> '<locals>)
|
|
(define <function> '<function>)
|
|
(define <text> '<text>)
|
|
(define <break> '<break>)
|
|
|
|
(define* (make o #:key (types '()) (constants '()) (functions '()) (globals '()) (init '()) (locals '()) (function #f) (text '()) (break '()))
|
|
(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)
|
|
(cons <break> break)))))
|
|
|
|
(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 (.break o)
|
|
(pmatch o
|
|
((<info> . ,alist) (assq-ref alist <break>))))
|
|
|
|
(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))
|
|
(break (.break o)))
|
|
(let-keywords rest
|
|
#f
|
|
((types types)
|
|
(constants constants)
|
|
(functions functions)
|
|
(globals globals)
|
|
(init init)
|
|
(locals locals)
|
|
(function function)
|
|
(text text)
|
|
(break break))
|
|
(make <info> #:types types #:constants constants #:functions functions #:globals globals #:init init #:locals locals #:function function #:text text #:break break))))))
|
|
|
|
(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)
|
|
(wrap-as (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)
|
|
(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 (string->global string)
|
|
(make-global (add-s:-prefix string) "string" 0 (append (string->list string) (list #\nul))))
|
|
|
|
(define (int->global value)
|
|
(make-global (add-s:-prefix (number->string value)) "int" 0 (int->bv32 value)))
|
|
|
|
(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
|
|
(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)))
|
|
(error "TODO:push-function: " o)))))))))
|
|
|
|
(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 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 (add-s:-prefix 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) (add-s:-prefix 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 `(lambda (f g ta t d)
|
|
(i386:global->accu (+ (data-offset ,o g) d)))))
|
|
((1) (list `(lambda (f g ta t d)
|
|
(i386:global-address->accu (+ (data-offset ,o g) d)))))
|
|
|
|
((2) (list `(lambda (f g ta t d)
|
|
(append (i386:value->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 (wrap-as (i386:value->accu constant))
|
|
(list `(lambda (f g ta t d)
|
|
(i386:global->accu (+ ta (function-offset ,o f)))))))))))
|
|
|
|
(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)))
|
|
;;(stderr "ident->accu ~a => ~a\n" o ptr)
|
|
(wrap-as (i386:local-ptr->accu (local:id local))))
|
|
(if global
|
|
(let ((ptr (ident->pointer info o)))
|
|
(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)
|
|
(append (i386:value->accu (+ (data-offset ,o g) d))))))))
|
|
(list `(lambda (f g ta t d)
|
|
(i386:global->accu (+ ta (function-offset ,o f))))))))))
|
|
|
|
(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
|
|
(let ((ptr (ident->pointer info o)))
|
|
(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)
|
|
(append (i386:value->base (+ (data-offset ,o g) d))))))))
|
|
(error "TODO ident-address->base" 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
|
|
(let ((ptr (local:pointer local)))
|
|
(case ptr
|
|
(else (wrap-as (i386:accu->local (local:id local))))))
|
|
(let ((ptr (ident->pointer info o)))
|
|
(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 (wrap-as (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
|
|
(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 `(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 (wrap-as (i386:local-add (local:id local) n))
|
|
(list `(lambda (f g ta t d)
|
|
(i386:global-add (+ (data-offset ,o g) d) ,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 `(lambda (f g ta t d)
|
|
(append (i386:push-accu)
|
|
(i386:global->accu (+ (data-offset ,o g) d))
|
|
(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 `(lambda (f g ta t d)
|
|
(i386:global->base (+ (data-offset ,o g) d)))))
|
|
((2) (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 (wrap-as (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 ((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 (append globals (list (string->global string))))
|
|
(info (clone info #:globals globals)))
|
|
(append-text info (list `(lambda (f g ta t d)
|
|
(i386:global->accu (+ (data-offset ,(add-s:-prefix string) g) d)))))))
|
|
|
|
((p-expr (string . ,strings))
|
|
(append-text info (list `(lambda (f g ta t d)
|
|
(i386:global->accu (+ (data-offset ,(add-s:-prefix (apply string-append strings)) g) d))))))
|
|
((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))
|
|
(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)))
|
|
(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))
|
|
(fields (or (type->description info type) '()))
|
|
(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)
|
|
(fields (or (type->description info type) '()))
|
|
(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))
|
|
(fields (or (type->description info type) '()))
|
|
(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))
|
|
(fields (or (type->description info type) '()))
|
|
(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 '())))))))
|
|
|
|
;; 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)))
|
|
(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))
|
|
(fields (or (type->description info type) '()))
|
|
(field-size 4) ;; FIXME:4, not fixed
|
|
(rest (or (member field (reverse fields) (lambda (a b) (equal? a (cdr b))))
|
|
(begin
|
|
(stderr "no field:~a\n" field)
|
|
'())))
|
|
(offset (* field-size (1- (length rest))))
|
|
(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))
|
|
(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)))
|
|
(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->hex 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 (and (not (assoc-ref locals name))
|
|
(assoc name (.functions info)))
|
|
(append-text args-info (list `(lambda (f g ta t d)
|
|
(i386:call f g ta t d (+ t (function-offset ,name f)) ,n))))
|
|
(let* ((empty (clone info #:text '()))
|
|
(accu ((expr->accu empty) `(p-expr (ident ,name)))))
|
|
(append-text args-info (append (.text accu)
|
|
(list `(lambda (f g ta t d)
|
|
(i386:call-accu f g ta t d ,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 `(lambda (f g ta t d)
|
|
(i386:call-accu f g ta t d ,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* ((empty (clone info #:text '()))
|
|
(b-length (length (append (i386:Xjump-nz 0)
|
|
(i386:accu-test))))
|
|
(info ((expr->accu info) a))
|
|
(info (append-text info (wrap-as (i386:accu-test))))
|
|
(info (append-text info (wrap-as (append (i386:Xjump-nz (- b-length 1))
|
|
(i386:accu-test)))))
|
|
(info ((expr->accu info) b))
|
|
(info (append-text info (wrap-as (i386:accu-test)))))
|
|
info))
|
|
|
|
((and ,a ,b)
|
|
(let* ((empty (clone info #:text '()))
|
|
(b-length (length (append (i386:Xjump-z 0)
|
|
(i386:accu-test))))
|
|
(info ((expr->accu info) a))
|
|
(info (append-text info (wrap-as (i386:accu-test))))
|
|
(info (append-text info (wrap-as (append (i386:Xjump-z (- b-length 1))
|
|
(i386:accu-test)))))
|
|
(info ((expr->accu info) b))
|
|
(info (append-text info (wrap-as (i386:accu-test)))))
|
|
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 ((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))
|
|
(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))))))))
|
|
(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)
|
|
(i386:base->accu)))))
|
|
((array-ref ,index (p-expr (ident ,array)))
|
|
(let* ((type (ident->type info array))
|
|
(size (type->size info type))
|
|
(info (append-text info (wrap-as (append (i386:push-accu)))))
|
|
(info ((expr->accu* info) a))
|
|
(info (append-text info (wrap-as (append (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)
|
|
(list `(lambda (f g ta t d) ,(cons 'list o))))
|
|
|
|
(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))
|
|
(fields (or (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))))))))
|
|
(info ((expr->accu* info) `(array-ref ,index (p-expr (ident ,array))))))
|
|
(append-text info (wrap-as (append (i386:accu+value offset))))))
|
|
|
|
((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)))
|
|
(append-text info (append ((ident->accu info) name)
|
|
(wrap-as (i386:accu+value offset))))))
|
|
|
|
(_ (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 (* 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)
|
|
(,name name)
|
|
(_ (error "decl->type: unsupported: " o))))
|
|
|
|
(define (expr->global o)
|
|
(pmatch o
|
|
((p-expr (string ,string)) (string->global string))
|
|
((p-expr (fixed ,value)) (int->global (cstring->number value)))
|
|
(_ #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 (clause->jump-info info)
|
|
(define (jump n)
|
|
(wrap-as (i386:Xjump n)))
|
|
(define (jump-nz n)
|
|
(wrap-as (i386:Xjump-nz n)))
|
|
(define (jump-z n)
|
|
(wrap-as (i386:Xjump-z n)))
|
|
(define (statement->info info body-length)
|
|
(lambda (o)
|
|
(pmatch o
|
|
((break) (append-text info (jump body-length)))
|
|
(_ ((ast->info info) o)))))
|
|
(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)))))
|
|
(lambda (n)
|
|
(append (wrap-as (i386:accu-cmp-value value))
|
|
(jump-z (+ (length (object->list (jump 0)))
|
|
(if (= n 0) 0
|
|
(* n (length (object->list ((test->text 0) 0)))))))))))
|
|
(define (cases+jump cases clause-length)
|
|
(append-text info
|
|
(append
|
|
(append-map (lambda (t i) (t i)) cases (reverse (iota (length cases))))
|
|
(if (null? cases) '()
|
|
(jump clause-length)))))
|
|
(lambda (o)
|
|
(lambda (body-length)
|
|
(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 cases 0))))
|
|
(loop `(compd-stmt (block-item-list ,@(cdr elements))) cases
|
|
((statement->info clause body-length) (car elements)))))
|
|
(()
|
|
(let* ((cases-length (length (.text (cases+jump cases 0))))
|
|
(clause-text (list-tail (.text clause) cases-length))
|
|
(clause-length (length (object->list clause-text))))
|
|
(clone clause #:text
|
|
(append (.text (cases+jump cases clause-length))
|
|
clause-text))))
|
|
(_
|
|
(let ((clause (or clause (cases+jump cases 0))))
|
|
(loop '() cases
|
|
((statement->info clause body-length) o)))))))))
|
|
|
|
(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)
|
|
(wrap-as (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* ((globals (.globals info))
|
|
(text (.text info))
|
|
(info (clone info #:text '()))
|
|
|
|
(a-jump ((test->jump->info info) a))
|
|
(a-text (.text (a-jump 0)))
|
|
(a-length (length (object->list a-text)))
|
|
|
|
(b-jump ((test->jump->info info) b))
|
|
(b-text (.text (b-jump 0)))
|
|
(b-length (length (object->list b-text))))
|
|
|
|
(lambda (body-length)
|
|
(let* ((info (append-text info text))
|
|
(a-info (a-jump (+ b-length body-length)))
|
|
(info (append-text info (.text a-info)))
|
|
(b-info (b-jump body-length))
|
|
(info (append-text info (.text b-info))))
|
|
(clone info
|
|
#:globals (append globals
|
|
(list-tail (.globals a-info) (length globals))
|
|
(list-tail (.globals b-info) (length globals))))))))
|
|
|
|
((or ,a ,b)
|
|
(let* ((globals (.globals info))
|
|
(text (.text info))
|
|
(info (clone info #:text '()))
|
|
|
|
(a-jump ((test->jump->info info) a))
|
|
(a-text (.text (a-jump 0)))
|
|
(a-length (length (object->list a-text)))
|
|
|
|
(jump-text (wrap-as (i386:Xjump 0)))
|
|
(jump-length (length (object->list jump-text)))
|
|
|
|
(b-jump ((test->jump->info info) b))
|
|
(b-text (.text (b-jump 0)))
|
|
(b-length (length (object->list b-text)))
|
|
|
|
(jump-text (wrap-as (i386:Xjump b-length))))
|
|
|
|
(lambda (body-length)
|
|
(let* ((info (append-text info text))
|
|
(a-info (a-jump jump-length))
|
|
(info (append-text info (.text a-info)))
|
|
(info (append-text info jump-text))
|
|
(b-info (b-jump body-length))
|
|
(info (append-text info (.text b-info))))
|
|
(clone info
|
|
#:globals (append globals
|
|
(list-tail (.globals a-info) (length globals))
|
|
(list-tail (.globals b-info) (length globals))))))))
|
|
|
|
((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:Xjump-z
|
|
(append
|
|
((ident->accu info) name)
|
|
(wrap-as (i386:accu-zero?)))) o))
|
|
|
|
(_ ((jump i386:Xjump-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))))
|
|
(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 (typename ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
|
|
(cons type name)) ;; 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)))))
|
|
(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
|
|
((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
|
|
(cons type name)) ;; FIXME: **
|
|
((comp-decl (decl-spec-list (type-spec (void))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
|
|
(cons '(void) name)) ;; 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)))))
|
|
(cons '(void) name))
|
|
((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
|
|
(cons '(void) name))
|
|
;; FIXME: BufferedFile *include_stack[INCLUDE_STACK_SIZE];
|
|
((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (array-of (ident ,name) (p-expr (fixed ,size)))))))
|
|
(cons type name)) ;; FIXME: decl, array size
|
|
((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (array-of (ident ,name) (p-expr (fixed ,size))))))
|
|
(cons type name))
|
|
;; 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)))))
|
|
(cons type name))
|
|
((comp-decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
|
|
(cons type name))
|
|
(_ (error "struct-field: unsupported: " o))))
|
|
|
|
(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))
|
|
("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 (type->size 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))
|
|
((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 (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))
|
|
((decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qual))
|
|
(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)
|
|
(append-text info (wrap-as (i386:Xjump (- (car (.break info)) (length (object->list text)))))))
|
|
|
|
;; 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->hex arg0))))
|
|
(let ((info ((expr->accu info) `(fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))))
|
|
(append-text info (wrap-as (i386:accu-zero?))))))
|
|
|
|
((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 (object->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 (wrap-as (i386:Xjump 0)))
|
|
(then-jump-length (length (object->list then-jump-text)))
|
|
(then-length (+ (length (object->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 (object->list else-text)))
|
|
|
|
(text+test-text (.text (test-jump->info then-length)))
|
|
(test-text (list-tail text+test-text text-length))
|
|
(then-jump-text (wrap-as (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))))))
|
|
|
|
;; Hmm?
|
|
((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 (object->list then-text)))
|
|
|
|
(jump-text (wrap-as (i386:Xjump 0)))
|
|
(jump-length (length (object->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 (object->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 (wrap-as (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 . ,statements)))
|
|
(let* ((clauses (statements->clauses statements))
|
|
(expr ((expr->accu info) expr))
|
|
(empty (clone info #:text '()))
|
|
(clause-infos (map (clause->jump-info empty) clauses))
|
|
(clause-lengths (map (lambda (c-j) (length (object->list (.text (c-j 0))))) clause-infos))
|
|
(clauses-info (let loop ((clauses clauses) (info expr) (lengths clause-lengths))
|
|
(if (null? clauses) info
|
|
(let ((c-j ((clause->jump-info info) (car clauses))))
|
|
(loop (cdr clauses) (c-j (apply + (cdr lengths))) (cdr lengths)))))))
|
|
clauses-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 (object->list body-text)))
|
|
|
|
(step-info ((expr->accu info) step))
|
|
(step-text (.text step-info))
|
|
(step-length (length (object->list step-text)))
|
|
|
|
(test-jump->info ((test->jump->info info) test))
|
|
(test+jump-info (test-jump->info 0))
|
|
(test-length (length (object->list (.text test+jump-info))))
|
|
|
|
(skip-body-text (wrap-as (i386:Xjump (+ body-length step-length))))
|
|
|
|
(jump-text (wrap-as (i386:Xjump (- (+ body-length step-length test-length)))))
|
|
(jump-length (length (object->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)))
|
|
|
|
((while ,test ,body)
|
|
(let* ((skip-info (lambda (body-length test-length)
|
|
(clone info
|
|
#:text (append text (wrap-as (i386:Xjump body-length)))
|
|
#:break (cons (+ (length (object->list text)) body-length test-length
|
|
(length (i386:Xjump 0)))
|
|
(.break info)))))
|
|
(text (.text (skip-info 0 0)))
|
|
(text-length (length text))
|
|
(body-info (lambda (body-length test-length)
|
|
((ast->info (skip-info body-length test-length)) body)))
|
|
|
|
(body-text (list-tail (.text (body-info 0 0)) text-length))
|
|
(body-length (length (object->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 (object->list (.text test+jump-info))))
|
|
|
|
(jump-text (wrap-as (i386:Xjump (- (+ body-length test-length)))))
|
|
(jump-length (length (object->list jump-text)))
|
|
|
|
(test-text (.text (test-jump->info jump-length)))
|
|
|
|
(body-info (body-info body-length (length (object->list test-text)))))
|
|
|
|
(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 (object->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 (object->list (.text test+jump-info))))
|
|
|
|
(jump-text (wrap-as (i386:Xjump (- (+ body-length test-length)))))
|
|
(jump-length (length (object->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 (append-text info (list label))))
|
|
((ast->info info) statement)))
|
|
|
|
((goto (ident ,label))
|
|
(let* ((jump (lambda (n) (i386:XXjump n)))
|
|
(offset (+ (length (jump 0)) (length (object->list text)))))
|
|
(append-text info (append
|
|
(list `(lambda (f g ta t d)
|
|
(i386:XXjump (- (label-offset ,(.function info) ,label f) ,offset))))))))
|
|
|
|
((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 (append globals (list (string->global string))))
|
|
(info (clone info #:locals locals #:globals globals)))
|
|
(append-text info (append
|
|
(list `(lambda (f g ta t d)
|
|
(append
|
|
(i386:global->accu (+ (data-offset ,(add-s:-prefix string) g) d)))))
|
|
((accu->ident info) name))))
|
|
(let* ((global (string->global string))
|
|
(globals (append globals (list global)))
|
|
(size 4)
|
|
(global (make-global name type 1 (string->list (make-string size #\nul))))
|
|
(globals (append globals (list global)))
|
|
(info (clone info #:globals globals)))
|
|
(clone info #:init
|
|
(append
|
|
(.init info)
|
|
(list
|
|
`(lambda (f g ta t d data)
|
|
(let (((here (data-offset ,name g))))
|
|
(append
|
|
(list-head data here)
|
|
(initzer->data f g ta t d '(initzer (p-expr (string ,string))))
|
|
(list-tail data (+ here ,size)))))))))))
|
|
|
|
;; char const *p;
|
|
((decl (decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qualifier)) (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;
|
|
((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 = 0;
|
|
;;((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer (pointer)) (ident ,name)) (initzer (p-expr (fixed ,value)))))))
|
|
|
|
;; 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* ((globals (append globals (list (ident->global name type 2 0))))
|
|
(value (assoc-ref constants b)))
|
|
(clone info
|
|
#:globals globals
|
|
#:init (append (.init info)
|
|
(list
|
|
`(lambda (f g ta t d data)
|
|
(let ((here (data-offset ,name g)))
|
|
(append
|
|
(list-head data here)
|
|
(initzer->data f g ta t d '(p-expr (fixed ,value)))
|
|
(list-tail data (+ here 4)))))))))))
|
|
|
|
;; 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 local) (* count size))))
|
|
(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 local) (* count size))))
|
|
(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* ((locals (add-local locals name `("struct" ,type) 1))
|
|
(info (clone info #:locals locals)))
|
|
info)
|
|
(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)
|
|
(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))))))
|
|
(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)
|
|
(list `(lambda (f g ta t d)
|
|
(append (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)))))))
|
|
(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 0)))))
|
|
(clone info
|
|
#:globals globals
|
|
#:init (append (.init info)
|
|
(list
|
|
`(lambda (f g ta t d data)
|
|
(let ((here (data-offset ,name g))
|
|
(there (data-offset ,value g)))
|
|
(append
|
|
(list-head data here)
|
|
;; FIXME: type
|
|
;; char *x = arena;
|
|
(int->bv32 (+ d (data-offset ,value g)))
|
|
;; 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))))))
|
|
(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 0)))))
|
|
(clone info
|
|
#:globals globals
|
|
#:init (append (.init info)
|
|
(list `(lambda (f g ta t d data)
|
|
(let ((here (data-offset ,name g)))
|
|
(append
|
|
(list-head data here)
|
|
;; FIXME: type
|
|
;; char *x = arena;p
|
|
(int->bv32 (+ d (data-offset ,value g)))
|
|
(list-tail data (+ here 4))))))))))))
|
|
|
|
;; 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 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))))
|
|
(globals (append globals entries (list global)))
|
|
(info (clone info #:globals globals)))
|
|
(clone info #:init
|
|
(append
|
|
(.init info)
|
|
(list
|
|
`(lambda (f g ta t d data)
|
|
(let ((here (data-offset ,name g)))
|
|
(append
|
|
(list-head data here)
|
|
(append-map
|
|
(lambda (i)
|
|
(initzer->data f g ta t d i))
|
|
',initzers)
|
|
(list-tail data (+ here ,size))))))))))))
|
|
|
|
;;
|
|
;; 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))
|
|
(fields (type->description info type))
|
|
(size (type->size info type))
|
|
(field-size 4) ;; FIXME:4, not fixed
|
|
(initzers (map (initzer->non-const info) initzers)))
|
|
(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)
|
|
(wrap-as (append (i386:accu->base)))
|
|
(.text ((expr->accu empty) initzer))
|
|
(wrap-as (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)))
|
|
(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 (f g ta t d data)
|
|
(let ((here (data-offset ,name g)))
|
|
(append
|
|
(list-head data (+ here ,offset))
|
|
(initzer->data f g 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))
|
|
(initzer ((initzer->non-const info) initzer)))
|
|
(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)))))
|
|
(clone info
|
|
#:globals globals
|
|
#:init (append (.init info)
|
|
(list
|
|
`(lambda (f g ta t d data)
|
|
(let ((here (data-offset ,name g)))
|
|
(append
|
|
(list-head data here)
|
|
(initzer->data f g 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)))))
|
|
(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 const* itoa ();
|
|
((decl (decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qual)) (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-qual ,qual) (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)
|
|
|
|
;; ST_DATA const int reg_classes[NB_REGS];
|
|
((decl (decl-spec-list (stor-spec (extern)) (type-qual ,qual) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (array-of (ident ,name) (p-expr (fixed ,size))))))
|
|
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))))))))
|
|
|
|
|
|
;; const char *target; silly notation, const always operates to the LEFT (except when there's no left)
|
|
((decl (decl-spec-list (type-qual ,qual) (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))
|
|
((ast->info info)
|
|
`(decl (decl-spec-list (type-spec (fixed-type ,type)) (type-qual ,qual)) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)))))))
|
|
|
|
((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 f g 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))))
|
|
(int->bv32 (+ ta (function-offset name f))))
|
|
((initzer (p-expr (string ,string)))
|
|
(int->bv32 (+ (data-offset (add-s:-prefix string) g) d)))
|
|
(_ (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) "compiling: ~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 current-eval
|
|
(let ((module (current-module)))
|
|
(lambda (e) (eval e module))))
|
|
|
|
(define (object->list object)
|
|
(text->list (map current-eval object)))
|
|
|
|
(define (dec->xhex o)
|
|
(string-append "#x" (dec->hex (if (>= o 0) o (+ o #x100)))))
|
|
|
|
(define (write-lambda o)
|
|
(newline)
|
|
(display " ")
|
|
(if (or (not (pair? o))
|
|
(not (eq? (caaddr o) 'list))) (write o)
|
|
(list (car o) (cadr o)
|
|
(display (string-append "(lambda (f g ta t d) (list "
|
|
(string-join (map dec->xhex (cdaddr o)) " ")
|
|
"))")))))
|
|
|
|
(define (write-function o)
|
|
(stderr "function: ~s\n" (car o))
|
|
(newline)
|
|
(display " (")
|
|
(write (car o)) (display " ")
|
|
(if (not (cdr o)) (display ". #f")
|
|
(for-each write-lambda (cdr o)))
|
|
(display ")"))
|
|
|
|
(define (write-info o)
|
|
(stderr "object:\n")
|
|
(display "(make <info>\n")
|
|
(display " #:types\n '") (pretty-print (.types o) #:width 80)
|
|
(display " #:constants\n '") (pretty-print (.constants o) #:width 80)
|
|
(display " #:functions '(") (for-each write-function (.functions o)) (display ")") (newline)
|
|
(stderr "globals:\n")
|
|
(display " #:globals\n '") (pretty-print (.globals o) #:width 80)
|
|
(stderr "init:\n")
|
|
(display " #:init\n '") (pretty-print (.init o) #:width 80)
|
|
(display ")\n"))
|
|
|
|
(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 (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)))
|
|
(error "procedure: write-any:" x))
|
|
(else (stderr "write-any: ~a\n" x) (error "write-any: else: " x)))))
|
|
|
|
(define (info->elf info)
|
|
(display "dumping elf\n" (current-error-port))
|
|
(for-each write-any (make-elf (filter cdr (.functions info)) (.globals info) (.init info))))
|
|
|
|
(define (function:object->text o)
|
|
(cons (car o) (and (cdr o) (map current-eval (cdr o)))))
|
|
|
|
(define (init:object->text o)
|
|
(current-eval o))
|
|
|
|
(define (info:object->text o)
|
|
(clone o
|
|
#:functions (map function:object->text (.functions o))
|
|
#:init (map init:object->text (.init o))))
|
|
|
|
(define* (c99-ast->info ast)
|
|
((ast->info (make <info> #:types i386:type-alist)) ast))
|
|
|
|
(define* (c99-input->elf #:key (defines '()) (includes '()))
|
|
((compose info->elf info:object->text (c99-input->info #:defines defines #:includes includes))))
|
|
|
|
(define* (c99-input->object #:key (defines '()) (includes '()))
|
|
((compose write-info (c99-input->info #:defines defines #:includes includes))))
|
|
|
|
(define (object->elf info)
|
|
((compose info->elf info:object->text) info))
|
|
|
|
(define (infos->object infos)
|
|
((compose write-info merge-infos) infos))
|
|
|
|
(define (infos->elf infos)
|
|
((compose object->elf merge-infos) infos))
|
|
|
|
(define (merge-infos infos)
|
|
(let loop ((infos infos) (info (make <info>)))
|
|
(if (null? infos) info
|
|
(loop (cdr infos)
|
|
(clone info
|
|
#:types (alist-add (.types info) (.types (car infos)))
|
|
#:constants (alist-add (.constants info) (.constants (car infos)))
|
|
#:functions (alist-add (.functions info) (.functions (car infos)))
|
|
#:globals (alist-add (.globals info) (.globals (car infos)))
|
|
#:init (append (.init info) (.init (car infos))))))))
|
|
|
|
(define (alist-add a b)
|
|
(let* ((b-keys (map car b))
|
|
(a (filter (lambda (f) (or (cdr f) (not (member f b-keys)))) a))
|
|
(a-keys (map car a)))
|
|
(append a (filter (lambda (e) (not (member (car e) a-keys))) b))))
|