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

2294 lines
99 KiB
Scheme
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Mes.
;;;
;;; Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; compiler.mes produces an i386 binary from the C produced by
;;; Nyacc c99.
;;; Code:
(cond-expand
(guile-2)
(guile)
(mes
(mes-use-module (srfi srfi-1))
(mes-use-module (srfi srfi-26))
(mes-use-module (mes pmatch))
(mes-use-module (nyacc lang c99 parser))
(mes-use-module (nyacc lang c99 pprint))
(mes-use-module (mes as))
(mes-use-module (mes as-i386))
(mes-use-module (mes M1))
(mes-use-module (mes optargs))
(mes-use-module (language c99 info))))
(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 (pke . stuff)
(newline (current-error-port))
(display ";;; " (current-error-port))
(write stuff (current-error-port))
(newline (current-error-port))
(car (last-pair stuff)))
(define %prefix (if (string-prefix? "@PREFIX" "@PREFIX@") (or (getenv "PREFIX") "") "@PREFIX@"))
(define mes? (pair? (current-module)))
(define %int-size 4)
(define %pointer-size %int-size)
(define* (c99-input->full-ast #:key (defines '()) (includes '()))
(let ((sys-include (if (equal? %prefix "") "include" (string-append %prefix "/share/include"))))
(parse-c99
#:inc-dirs (append includes (cons* sys-include "include" "lib" (or (and=> (getenv "C_INCLUDE_PATH") (cut string-split <> #\:)) '())))
#:cpp-defs `(
"NULL=0"
"__linux__=1"
"__i386__=1"
"POSIX=0"
"_POSIX_SOURCE=0"
"__MESC__=1"
,(if mes? "__MESC_MES__=1" "__MESC_MES__=0")
,@defines)
#:mode 'code)))
(define (ast-strip-comment o)
(pmatch o
((comment . ,comment) #f)
(((comment . ,comment) . ,t) (filter-map ast-strip-comment t))
(((comment . ,comment) . ,cdr) cdr)
((,car . (comment . ,comment)) car)
((,h . ,t) (if (list? o) (filter-map ast-strip-comment o)
(cons (ast-strip-comment h) (ast-strip-comment t))))
(_ o)))
(define (ast-strip-const o)
(pmatch o
((type-qual ,qual) (if (equal? qual "const") #f o))
((pointer (type-qual-list (type-qual ,qual)) . ,rest)
(if (equal? qual "const") `(pointer ,@rest) o))
((decl-spec-list (type-qual ,qual))
(if (equal? qual "const") #f
`(decl-spec-list (type-qual ,qual))))
((decl-spec-list (type-qual ,qual) . ,rest)
(if (equal? qual "const") `(decl-spec-list ,@rest)
`(decl-spec-list (type-qual ,qual) ,@(map ast-strip-const rest))))
((decl-spec-list (type-qual-list (type-qual ,qual)) . ,rest)
(if (equal? qual "const") `(decl-spec-list ,@rest)
`(decl-spec-list (type-qual-list (type-qual ,qual)) ,@(map ast-strip-const rest))))
((,h . ,t) (if (list? o) (filter-map ast-strip-const o)
(cons (ast-strip-const h) (ast-strip-const t))))
(_ o)))
(define (clone o . rest)
(cond ((info? o)
(let ((types (.types o))
(constants (.constants o))
(functions (.functions o))
(globals (.globals o))
(locals (.locals o))
(statics (.statics o))
(function (.function o))
(text (.text o))
(break (.break o))
(continue (.continue o)))
(let-keywords rest
#f
((types types)
(constants constants)
(functions functions)
(globals globals)
(locals locals)
(statics statics)
(function function)
(text text)
(break break)
(continue continue))
(make <info> #:types types #:constants constants #:functions functions #:globals globals #:locals locals #:statics statics #:function function #:text text #:break break #:continue continue))))))
(define (ident->constant name value)
(cons name value))
(define (enum->type-entry name fields)
(cons `("tag" ,name) (make-type 'enum 4 0 fields)))
(define (struct->type-entry name fields)
(cons `("tag" ,name) (make-type 'struct (apply + (map field:size fields)) 0 fields)))
(define (union->type-entry name fields)
(cons `("tag" ,name) (make-type 'union (apply + (map field:size fields)) 0 fields)))
(define i386:type-alist
`(("char" . ,(make-type 'builtin 1 0 #f))
("short" . ,(make-type 'builtin 2 0 #f))
("int" . ,(make-type 'builtin 4 0 #f))
("long" . ,(make-type 'builtin 4 0 #f))
;;("long long" . ,(make-type 'builtin 8 0 #f))
;;("long long int" . ,(make-type 'builtin 8 0 #f))
("long long" . ,(make-type 'builtin 4 0 #f)) ;; FIXME
("long long int" . ,(make-type 'builtin 4 0 #f))
("void" . ,(make-type 'builtin 1 0 #f))
;; FIXME sign
("unsigned char" . ,(make-type 'builtin 1 0 #f))
("unsigned short" . ,(make-type 'builtin 2 0 #f))
("unsigned short int" . ,(make-type 'builtin 2 0 #f))
("unsigned" . ,(make-type 'builtin 4 0 #f))
("unsigned int" . ,(make-type 'builtin 4 0 #f))
("unsigned long" . ,(make-type 'builtin 4 0 #f))
;; ("unsigned long long" . ,(make-type 'builtin 8 0 #f))
;; ("unsigned long long int" . ,(make-type 'builtin 8 0 #f))
("unsigned long long" . ,(make-type 'builtin 4 0 #f)) ;; FIXME
("unsigned long long int" . ,(make-type 'builtin 4 0 #f))
("float" . ,(make-type 'builtin 4 0 #f))
("double" . ,(make-type 'builtin 8 0 #f))
("long double" . ,(make-type 'builtin 16 0 #f))))
(define (field:name o)
(pmatch o
((struct (,name ,type ,size ,pointer) . ,rest) name)
((union (,name ,type ,size ,pointer) . ,rest) name)
((,name ,type ,size ,pointer) name)
(_ (error "field:name not supported:" o))))
(define (field:pointer o)
(pmatch o
((struct (,name ,type ,size ,pointer) . ,rest) pointer)
((union (,name ,type ,size ,pointer) . ,rest) pointer)
((,name ,type ,size ,pointer) pointer)
(_ (error "field:name not supported:" o))))
(define (field:size o)
(pmatch o
((struct . ,fields) (apply + (map field:size fields)))
((union . ,fields) (apply max (map field:size fields)))
((,name ,type ,size ,pointer) size)
(_ (error (format #f "field:size: ~s\n" o)))))
(define (struct:size o)
(field:size (cons 'struct (type:description o)))) ;;FIXME
(define (field:type o)
(pmatch o
((,name ,type ,size ,pointer) type)
(_ (error (format #f "field:type: ~s\n" o)))))
(define (ast->type info o)
(define (get-type o)
(let ((t (assoc-ref (.types info) o)))
(pmatch t
((typedef ,next) (or (get-type next) o))
(_ t))))
(pmatch o
(,t (guard (type? t)) t)
((p-expr ,expr) (ast->type info expr))
((pre-inc ,expr) (ast->type info expr))
((post-inc ,expr) (ast->type info expr))
((ident ,name) (ident->type info name))
((char ,value) (get-type "char"))
((fixed ,value) (get-type "int"))
((type-spec (typename ,type))
(ast->type info type))
((array-ref ,index ,array)
(ast->type info array))
((struct-ref (ident ,type))
(or (get-type type)
(let ((struct (if (pair? type) type `("tag" ,type))))
(ast->type info struct))))
((union-ref (ident ,type))
(or (get-type type)
(let ((struct (if (pair? type) type `("tag" ,type))))
(ast->type info struct))))
((struct-def (ident ,name) . _)
(ast->type info `("tag" ,name)))
((union-def (ident ,name) . _)
(ast->type info `("tag" ,name)))
((struct-def (field-list . ,fields))
(let ((fields (append-map (struct-field info) fields)))
(make-type 'struct (apply + (map field:size fields)) 0 fields)))
((union-def (field-list . ,fields))
(let ((fields (append-map (struct-field info) fields)))
(make-type 'union (apply + (map field:size fields)) 0 fields)))
((void) (ast->type info "void"))
((fixed-type ,type) (ast->type info type))
((float-type ,type) (ast->type info type))
((typename ,type) (ast->type info type))
((de-ref ,expr)
(ast->type info expr))
((d-sel (ident ,field) ,struct)
(let ((type0 (ast->type info struct)))
(ast->type info (field-type info type0 field))))
((i-sel (ident ,field) ,struct)
(let ((type0 (ast->type info struct)))
(ast->type info (field-type info type0 field))))
((ref-to ,expr) (ast->type info expr))
((pre-inc ,a) (ast->type info a))
((pre-dec ,a) (ast->type info a))
((post-inc ,a) (ast->type info a))
((post-dec ,a) (ast->type info a))
((add ,a ,b) (ast->type info a))
((sub ,a ,b) (ast->type info a))
((bitwise-and ,a ,b) (ast->type info a))
((bitwise-not ,a) (ast->type info a))
((bitwise-or ,a ,b) (ast->type info a))
((bitwise-xor ,a ,b) (ast->type info a))
((lshift ,a ,b) (ast->type info a))
((rshift ,a ,b) (ast->type info a))
((div ,a ,b) (ast->type info a))
((mod ,a ,b) (ast->type info a))
((mul ,a ,b) (ast->type info a))
((not ,a) (ast->type info a))
((neg ,a) (ast->type info a))
((eq ,a ,b) (ast->type info a))
((ge ,a ,b) (ast->type info a))
((gt ,a ,b) (ast->type info a))
((ne ,a ,b) (ast->type info a))
((le ,a ,b) (ast->type info a))
((lt ,a ,b) (ast->type info a))
((or ,a ,b) (ast->type info a))
((and ,a ,b) (ast->type info a))
((cast (type-name ,type) ,expr) ; FIXME: ignore expr?
(ast->type info type))
((cast (type-name ,type (abs-declr ,pointer)) ,expr) ; FIXME: ignore expr?
(ast->type info type))
((decl-spec-list (type-spec ,type))
(ast->type info type))
((assn-expr ,a ,op ,b)
(ast->type info a))
((enum-ref . _) (get-type "int"))
((sizeof-type . _) (get-type "int"))
((sizeof-expr . _) (get-type "int"))
((string _) (get-type "char"))
((fctn-call (p-expr (ident ,function)) . ,rest)
(or (and=> (assoc-ref (.functions info) function) function:type)
(begin
(stderr "ast->type: no such function: ~s\n" function)
(get-type "int"))))
(_ (let ((type (get-type o)))
(cond ((type? type) type)
((and (pair? type) (equal? (car type) "tag"))
(stderr "NO STRUCT YET:~s\n" (.types info))
type)
((and (pair? o) (equal? (car o) "tag"))
(stderr "NO STRUCT YET:~s\n" (.types info))
o)
(else
(stderr "types: ~s\n" (.types info))
(error "ast->type: not supported: " o)))))))
(define (ast-type->description info o)
((compose type:description (cut ast->type info <>) o)))
(define (ast-type->size info o)
;;((compose type:size (cut ast->type info <>)) o)
(let ((type (if (type? o) o
(ast->type info o))))
(if (not (type? type)) (error "ast-type->size: no such type:" o)
(type:size type))))
(define (field-field info struct field)
(let* ((xtype (if (type? struct) struct
(ast->type info struct)))
(fields (type:description xtype)))
(let loop ((fields fields))
(if (null? fields) (error (format #f "no such field: ~a in ~s" field struct))
(let ((f (car fields)))
(cond ((equal? (car f) field) f)
((and (memq (car f) '(struct union))
(find (lambda (x) (equal? (car x) field)) (cdr f))))
(else (loop (cdr fields)))))))))
(define (field-offset info struct field)
(let ((xtype (if (type? struct) struct
(ast->type info struct))))
(if (eq? (type:type xtype) 'union) 0
(let ((fields (type:description xtype)))
(let loop ((fields fields) (offset 0))
(if (null? fields) (error (format #f "no such field: ~a in ~s" field struct))
(let ((f (car fields)))
(cond ((equal? (car f) field) offset)
((and (eq? (car f) 'struct)
(find (lambda (x) (equal? (car x) field)) (cdr f))
(apply + (cons offset
(map field:size
(member field (reverse (cdr f))
(lambda (a b)
(equal? a (car b) field))))))))
((and (eq? (car f) 'union)
(find (lambda (x) (equal? (car x) field)) (cdr f))
offset))
(else (loop (cdr fields) (+ offset (field:size f))))))))))))
(define (field-pointer info struct field)
(let ((field (field-field info struct field)))
(field:pointer field)))
(define (field-size info struct field)
(let ((xtype (if (type? struct) struct
(ast->type info struct))))
(if (eq? (type:type xtype) 'union) 0
(let ((field (field-field info struct field)))
(field:size field)))))
(define (field-type info struct field)
(let ((field (field-field info struct field)))
(field:type field)))
(define (struct->fields o)
(pmatch o
(_ (guard (and (type? o) (eq? (type:type o) 'struct)))
(append-map struct->fields (type:description o)))
(_ (guard (and (type? o) (eq? (type:type o) 'union)))
(struct->fields (car (type:description o))))
((struct . ,fields)
(append-map struct->fields fields))
(_ (list o))))
(define (byte->hex.m1 o)
(string-drop o 2))
(define (asm->m1 o)
(let ((prefix ".byte "))
(if (not (string-prefix? prefix o)) (map (cut string-split <> #\space) (string-split o #\newline))
(let ((s (string-drop o (string-length prefix))))
(list (format #f "'~a'" (string-join (map byte->hex.m1 (cdr (string-split o #\space))) " ")))))))
(define (ident->variable info o)
(or (assoc-ref (.locals info) o)
(assoc-ref (.globals info) o)
(assoc-ref (.statics info) o)
(assoc-ref (.constants info) o)
(assoc-ref (.functions info) o)
(begin
(stderr "info=~s\n" info)
(error "ident->variable: undefined variabled:" o))))
(define (ident->type info o)
(let ((var (ident->variable info o)))
(cond ((global? var) (global:type var))
((local? var) (local:type var))
((assoc-ref (.constants info) o) (assoc-ref (.types info) "int"))
((pair? var) (car var))
(else (stderr "ident->type ~s => ~s\n" o var)
#f))))
(define (ident->pointer info o)
(let ((local (assoc-ref (.locals info) o)))
(if local (let* ((t ((compose type:pointer local:type) local))
(v (local:pointer local))
(p (+ (abs t) (abs v))))
(if (or (< t 0) (< v 0)) (- p) p))
(let ((global (assoc-ref (.globals info) o)))
(if global
(let* ((t ((compose type:pointer global:type) global))
;;(global:pointer (ident->variable info o))
(v (global:pointer global))
(p (+ (abs t) (abs v))))
(if (or (< t 0) (< v 0)) (- p) p))
0)))))
(define (ident->size info o)
((compose type:size (cut ident->type info <>)) o))
(define (ptr-inc o)
(if (< o 0) (1- o)
(1+ o)))
(define (ptr-dec o)
(if (< o 0) (1+ o)
(1- o)))
(define (pointer->ptr o)
(pmatch o
((pointer) 1)
((pointer ,pointer) (1+ (pointer->ptr pointer)))))
(define (expr->pointer info o)
(pmatch o
((pointer . _) (pointer->ptr o))
((p-expr (char ,value)) 0)
((p-expr (fixed ,value)) 0)
((ident ,name) (ident->pointer info name))
((p-expr ,expr) (expr->pointer info expr))
((de-ref ,expr) (ptr-dec (expr->pointer info expr)))
((assn-expr ,lhs ,op ,rhs) (expr->pointer info lhs))
((add ,a ,b) (expr->pointer info a))
((div ,a ,b) (expr->pointer info a))
((mod ,a ,b) (expr->pointer info a))
((mul ,a ,b) (expr->pointer info a))
((sub ,a ,b) (expr->pointer info a))
((neg ,a) (expr->pointer info a))
((pre-inc ,a) (expr->pointer info a))
((pre-dec ,a) (expr->pointer info a))
((post-inc ,a) (expr->pointer info a))
((post-dec ,a) (expr->pointer info a))
((ref-to ,expr) (ptr-inc (expr->pointer info expr)))
((array-ref ,index ,array)
(ptr-dec (abs (expr->pointer info array))))
((d-sel (ident ,field) ,struct)
(let ((type (ast->type info struct)))
(field-pointer info type field)))
((i-sel (ident ,field) ,struct)
(let ((type (ast->type info struct)))
(field-pointer info type field)))
((cast (type-name ,type) ,expr) ; FIXME: add expr?
(let* ((type (ast->type info type))
(pointer (type:pointer type)))
pointer))
((cast (type-name ,type (abs-declr ,pointer)) ,expr) ; FIXME: add expr?
(let* ((type (ast->type info type))
(pointer0 (type:pointer type))
(pointer1 (ptr-declr->pointer pointer))
(pointer2 (expr->pointer info expr)))
(+ pointer0 pointer1)))
((type-spec ,type)
(or (and=> (ast->type info o) type:pointer)
(begin
(stderr "expr->pointer: not supported: ~a\n" o)
0)))
((fctn-call (p-expr (ident ,function)) . ,rest)
(or (and=> (and=> (assoc-ref (.functions info) function) function:type)
(lambda (t)
(and (type? t) (type:pointer t))))
(begin
(stderr "expr->pointer: no such function: ~a\n" function)
0)))
((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (ptr-declr ,pointer ,init) . ,initzer)))
(let* ((t (expr->pointer info `(type-spec ,type)))
(i (expr->pointer info init))
(p (expr->pointer info pointer))
(e (+ (abs t) (abs i) (abs p))))
(if (or (< t 0) (< i 0)) (- e) e)))
((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr ,init . ,initzer)))
(let* ((t (expr->pointer info `(type-spec ,type)))
(i (expr->pointer info init))
(p (+ (abs t) (abs i))))
(if (or (< t 0) (< i 0)) (- p) p)))
((ptr-declr ,pointer (array-of ,array . ,rest))
(let* ((p (expr->pointer info pointer))
(a (expr->pointer info array))
(t (+ (abs p) (abs a) 2)))
(- t)))
((ptr-declr ,pointer . ,rest)
(expr->pointer info pointer))
((array-of ,array . ,rest)
(let ((a (abs (expr->pointer info array))))
(- (+ a 1))))
(_ (stderr "expr->pointer: not supported: ~s\n" o) 0)))
(define (expr->size info o)
(let ((ptr (expr->pointer info o)))
(if (or (= ptr -1)
(= ptr 0))
(ast-type->size info o)
%pointer-size)))
(define (append-text info text)
(clone info #:text (append (.text info) text)))
(define (push-global info)
(lambda (o)
(let ((ptr (ident->pointer info o)))
(cond ((< ptr 0) (list (i386:push-label `(#:address ,o))))
(else (list (i386:push-label-mem `(#:address ,o))))))))
(define (push-local locals)
(lambda (o)
(wrap-as (i386:push-local (local:id o)))))
(define (push-global-address info)
(lambda (o)
(list (i386:push-label o))))
(define (push-local-address locals)
(lambda (o)
(wrap-as (i386:push-local-address (local:id o)))))
(define push-global-de-ref push-global)
(define (push-local-de-ref info)
(lambda (o)
(let* ((local o)
(ptr (local:pointer local))
(size (if (= ptr 1) (ast-type->size info (local:type o))
4)))
(case size
((1) (wrap-as (i386:push-byte-local-de-ref (local:id o))))
((2) (wrap-as (i386:push-word-local-de-ref (local:id o))))
((4) (wrap-as (i386:push-local-de-ref (local:id o))))
(else (error (format #f "TODO: push size >4: ~a\n" size)))))))
(define (push-local-de-de-ref info)
(lambda (o)
(let* ((local o)
(ptr (local:pointer local))
(size (if (= ptr 2) (ast-type->size info (local:type o));; URG
4)))
(if (= size 1)
(wrap-as (i386:push-byte-local-de-de-ref (local:id o)))
(error "TODO int-de-de-ref")))))
(define (make-global-entry key type pointer array value)
(cons key (make-global key type pointer array value #f)))
(define (string->global-entry string)
(let ((value (append (string->list string) (list #\nul))))
(make-global-entry `(#:string ,string) "char" 0 (length value) value)))
(define (make-local-entry name type pointer array id)
(cons name (make-local type pointer array id)))
(define* (mescc:trace name #:optional (type ""))
(format (current-error-port) " :~a~a\n" name type))
(define (push-ident info)
(lambda (o)
(let ((local (assoc-ref (.locals info) o)))
(if local
(begin
(let* ((ptr (local:pointer local)))
(if (or (< ptr 0)) ((push-local-address (.locals info)) local)
((push-local (.locals info)) local))))
(let ((global (assoc-ref (.globals info) o)))
(if global
((push-global info) o) ;; FIXME: char*/int
(let ((constant (assoc-ref (.constants info) o)))
(if constant
(wrap-as (append (i386:value->accu constant)
(i386:push-accu)))
((push-global-address #f) `(#:address ,o))))))))))
(define (push-ident-address info)
(lambda (o)
(let ((local (assoc-ref (.locals info) o)))
(if local ((push-local-address (.locals info)) local)
(let ((global (assoc-ref (.globals info) o)))
(if global
((push-global-address info) o)
((push-global-address #f) `(#:address ,o))))))))
(define (push-ident-de-ref info)
(lambda (o)
(let ((local (assoc-ref (.locals info) o)))
(if local ((push-local-de-ref info) local)
((push-global-de-ref info) o)))))
(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)
(pmatch o
((p-expr (string ,string))
(let* ((globals ((globals:add-string (.globals info)) string))
(info (clone info #:globals globals)))
(append-text info ((push-global-address info) `(#:string ,string)))))
(_ (let ((info (expr->accu o info)))
(append-text info (wrap-as (i386:push-accu))))))))
(define (globals:add-string globals)
(lambda (o)
(let ((string `(#:string ,o)))
(if (assoc-ref globals string) globals
(append globals (list (string->global-entry o)))))))
(define (local->accu o)
(let* ((ptr (local:pointer o))
(type (local:type o))
(size (if (= ptr 0) (type:size type)
4)))
(cond ((< ptr 0) (wrap-as (i386:local-ptr->accu (local:id o))))
(else (wrap-as (case size
((1) (i386:byte-local->accu (local:id o)))
((2) (i386:word-local->accu (local:id o)))
(else (i386:local->accu (local:id o)))))))))
(define (ident->accu info)
(lambda (o)
(cond ((assoc-ref (.locals info) o) => local->accu)
((assoc-ref (.statics info) o)
=>
(lambda (global)
(let* ((ptr (ident->pointer info o)))
(cond ((< ptr 0) (list (i386:label->accu `(#:address ,global))))
(else (list (i386:label-mem->accu `(#:address ,global))))))))
((assoc-ref (.globals info) o)
=>
(lambda (global)
(let* ((ptr (ident->pointer info o)))
(cond ((< ptr 0) (list (i386:label->accu `(#:address ,o))))
(else (list (i386:label-mem->accu `(#:address ,o))))))))
((assoc-ref (.constants info) o)
=>
(lambda (constant) (wrap-as (i386:value->accu constant))))
(else (list (i386:label->accu `(#:address ,o)))))))
(define (ident-address->accu info)
(lambda (o)
(cond ((assoc-ref (.locals info) o)
=>
(lambda (local) (wrap-as (i386:local-ptr->accu (local:id local)))))
((assoc-ref (.statics info) o)
=>
(lambda (global) (list (i386:label->accu `(#:address ,global)))))
((assoc-ref (.globals info) o)
=>
(lambda (global) (list (i386:label->accu `(#:address ,global)))))
(else (list (i386:label->accu `(#:address ,o)))))))
(define (ident-address->base info)
(lambda (o)
(cond
((assoc-ref (.locals info) o)
=>
(lambda (local) (wrap-as (i386:local-ptr->base (local:id local)))))
((assoc-ref (.statics info) o)
=>
(lambda (global) (list (i386:label->base `(#:address ,global)))))
((assoc-ref (.globals info) o)
=>
(lambda (global) (list (i386:label->base `(#:address ,global)))))
(else (list (i386:label->base `(#:address ,o)))))))
(define (value->accu v)
(wrap-as (i386:value->accu v)))
(define (accu->local+n-text local n)
(let* ((type (local:type local))
(ptr (local:pointer local))
(size (if (= ptr -1) ((compose type:size local:type) local)
4))
(id (local:id local)))
(wrap-as (case size
((1) (i386:byte-accu->local+n id n))
((2) (i386:word-accu->local+n id n))
(else (i386:accu->local+n id n))))))
(define (accu->ident info)
(lambda (o)
(cond ((assoc-ref (.locals info) o)
=>
(lambda (local) (let ((size (->size local)))
(if (<= size 4) (wrap-as (i386:accu->local (local:id local)))
(wrap-as (i386:accu*n->local (local:id local) size))))))
((assoc-ref (.statics info) o)
=>
(lambda (global) (let ((size (->size global)))
(if (<= size 4) (wrap-as (i386:accu->label global))
(wrap-as (i386:accu*n->label global size))))))
((assoc-ref (filter (negate static-global?) (.globals info)) o)
=>
(lambda (global) (let ((size (->size global)))
(if (<= size 4) (wrap-as (i386:accu->label global))
(wrap-as (i386:accu*n->label global size)))))))))
(define (value->ident info)
(lambda (o value)
(cond ((assoc-ref (.locals info) o)
=>
(lambda (local) (wrap-as (i386:value->local (local:id local) value))))
((assoc-ref (.statics info) o)
=>
(lambda (global) (list (i386:value->label `(#:address ,global) value))))
((assoc-ref (filter (negate static-global?) (.globals info)) o)
=>
(lambda (global) (list (i386:value->label `(#:address ,global) value)))))))
(define (ident-add info)
(lambda (o n)
(cond ((assoc-ref (.locals info) o)
=>
(lambda (local) (wrap-as (i386:local-add (local:id local) n))))
((assoc-ref (.statics info) o)
=>
(lambda (global) (list (i386:label-mem-add `(#:address ,o) n))))
((assoc-ref (filter (negate static-global?) (.globals info)) o)
=>
(lambda (global) (list (i386:label-mem-add `(#:address ,global) n)))))))
(define (expr-add info)
(lambda (o n)
(let* ((info (expr->accu* o info))
(info (append-text info (wrap-as (i386:accu-mem-add n)))))
info)))
(define (ident-address-add info)
(lambda (o n)
(cond ((assoc-ref (.locals info) o)
=>
(lambda (local) (wrap-as (append (i386:push-accu)
(i386:local->accu (local:id local))
(i386:accu-mem-add n)
(i386:pop-accu)))))
((assoc-ref (.statics info) o)
=>
(lambda (global) (list (wrap-as (append (i386:push-accu)
(i386:label->accu `(#:address ,global))
(i386:accu-mem-add n)
(i386:pop-accu))))))
((assoc-ref (filter (negate static-global?) (.globals info)) o)
=>
(lambda (global) (list (wrap-as (append (i386:push-accu)
(i386:label->accu `(#:address ,global))
(i386:accu-mem-add n)
(i386:pop-accu)))))))))
(define (binop->accu info)
(lambda (a b c)
(let* ((info (expr->accu a info))
(info (expr->base b info)))
(append-text info (wrap-as c)))))
(define (wrap-as o . annotation)
`(,@annotation ,o))
(define (make-comment o)
(wrap-as `((#:comment ,o))))
(define (ast->comment o)
(if mes? '()
(begin
(pmatch o
;; Nyacc 0.80.42: missing (enum-ref (ident "fred"))
((decl (decl-spec-list (type-spec (enum-ref . _))) . _)
'())
(_ (let ((source (with-output-to-string (lambda () (pretty-print-c99 o)))))
(make-comment (string-join (string-split source #\newline) " "))))))))
(define (accu*n info n)
(append-text info (wrap-as (case n
((1) (i386:accu->base))
((2) (i386:accu+accu))
((3) (append (i386:accu->base)
(i386:accu+accu)
(i386:accu+base)))
((4) (i386:accu-shl 2))
((8) (append (i386:accu+accu)
(i386:accu-shl 2)))
((12) (append (i386:accu->base)
(i386:accu+accu)
(i386:accu+base)
(i386:accu-shl 2)))
((16) (i386:accu-shl 4))
(else (append (i386:value->base n)
(i386:accu*base)))))))
(define (accu->base-mem*n- info n)
(wrap-as
(case n
((1) (i386:byte-accu->base-mem))
((2) (i386:word-accu->base-mem))
((4) (i386:accu->base-mem))
(else (append (let loop ((i 0))
(if (>= i n) '()
(append (if (= i 0) '()
(append (i386:accu+value 4)
(i386:base+value 4)))
(case (- n i)
((1) (append (i386:accu+value -3)
(i386:base+value -3)
(i386:accu-mem->base-mem)))
((2) (append (i386:accu+value -2)
(i386:base+value -2)
(i386:accu-mem->base-mem)))
((3) (append (i386:accu+value -1)
(i386:base+value -1)
(i386:accu-mem->base-mem)))
(else (i386:accu-mem->base-mem)))
(loop (+ i 4))))))))))
(define (accu->base-mem*n info n)
(append-text info (accu->base-mem*n- info n)))
(define (expr->accu* o info)
(pmatch o
((p-expr (ident ,name))
(append-text info ((ident-address->accu info) name)))
((de-ref ,expr)
(expr->accu expr info))
((d-sel (ident ,field) ,struct)
(let* ((type (ast->type info struct))
(offset (field-offset info type field))
(info (expr->accu* struct info)))
(append-text info (wrap-as (i386:accu+value offset)))))
((i-sel (ident ,field) (fctn-call (p-expr (ident ,function)) . ,rest))
(let* ((type (ast->type info `(fctn-call (p-expr (ident ,function)) ,@rest)))
(offset (field-offset info type field))
(info (expr->accu `(fctn-call (p-expr (ident ,function)) ,@rest) info)))
(append-text info (wrap-as (i386:accu+value offset)))))
((i-sel (ident ,field) ,struct)
(let* ((type (ast->type info struct))
(offset (field-offset info type field))
(info (expr->accu* struct info)))
(append-text info (append (wrap-as (i386:mem->accu))
(wrap-as (i386:accu+value offset))))))
((array-ref ,index ,array)
(let* ((info (expr->accu index info))
(ptr (expr->pointer info array))
(size (expr->size info o))
(info (accu*n info size))
(info (expr->base array info)))
(append-text info (wrap-as (i386:accu+base)))))
(_ (error "expr->accu*: not supported: " o))))
(define (expr->accu o info)
(let ((locals (.locals info))
(constants (.constants info))
(text (.text info))
(globals (.globals info)))
(pmatch o
((expr) info)
((comma-expr) info)
((comma-expr ,a . ,rest)
(let ((info (expr->accu a info)))
(expr->accu `(comma-expr ,@rest) info)))
((p-expr (string ,string))
(let* ((globals ((globals:add-string globals) string))
(info (clone info #:globals globals)))
(append-text info (list (i386:label->accu `(#:string ,string))))))
((p-expr (fixed ,value))
(let ((value (cstring->number value)))
(append-text info (wrap-as (i386:value->accu value)))))
((neg (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 (string . ,strings))
(append-text info (list (i386:label->accu `(#:string ,(apply string-append strings))))))
((p-expr (ident ,name))
(append-text info ((ident->accu info) name)))
((initzer ,initzer)
(expr->accu initzer info))
;; offsetoff
((ref-to (i-sel (ident ,field) (cast (type-name (decl-spec-list ,struct) (abs-declr (pointer))) (p-expr (fixed ,base)))))
(let* ((type (ast->type info struct))
(offset (field-offset info type field))
(base (cstring->number base)))
(append-text info (wrap-as (i386:value->accu (+ base offset))))))
;; &foo
((ref-to (p-expr (ident ,name)))
(append-text info ((ident-address->accu info) name)))
;; &*foo
((ref-to (de-ref ,expr))
(expr->accu expr info))
((ref-to ,expr)
(expr->accu* expr info))
((sizeof-expr ,expr)
(append-text info (wrap-as (i386:value->accu (expr->size info expr)))))
((sizeof-type (type-name (decl-spec-list (type-spec (fixed-type ,name)))))
(let* ((type name)
(size (ast-type->size info type)))
(append-text info (wrap-as (i386:value->accu size)))))
((sizeof-type (type-name (decl-spec-list (type-spec (struct-ref (ident ,type))))))
(let* ((type `("tag" ,type))
(size (ast-type->size info type)))
(append-text info (wrap-as (i386:value->accu size)))))
((sizeof-type (type-name (decl-spec-list (type-spec (typename ,type)))))
(let ((size (ast-type->size info type)))
(append-text info (wrap-as (i386:value->accu size)))))
((sizeof-type (type-name (decl-spec-list ,type) (abs-declr (pointer))))
(let ((size 4))
(append-text info (wrap-as (i386:value->accu size)))))
((array-ref ,index ,array)
(let* ((info (expr->accu* o info))
(size (expr->size info o)))
(append-text info (wrap-as (case size
((1) (i386:byte-mem->accu))
((2) (i386:word-mem->accu))
((4) (i386:mem->accu))
(else '()))))))
((d-sel ,field ,struct)
(let* ((info (expr->accu* o info))
(info (append-text info (ast->comment o)))
(ptr (expr->pointer info o))
(size (if (= ptr 0) (ast-type->size info o)
4)))
(if (or (= -2 ptr) (= -1 ptr)) info
(append-text info (wrap-as (case size
((1) (i386:byte-mem->accu))
((2) (i386:word-mem->accu))
((4) (i386:mem->accu))
(else '())))))))
((i-sel ,field ,struct)
(let* ((info (expr->accu* o info))
(info (append-text info (ast->comment o)))
(ptr (expr->pointer info o))
(size (if (= ptr 0) (ast-type->size info o)
4)))
(if (or (= -2 ptr) (= ptr -1)) info
(append-text info (wrap-as (case size
((1) (i386:byte-mem->accu))
((2) (i386:word-mem->accu))
((4) (i386:mem->accu))
(else '())))))))
((de-ref ,expr)
(let* ((info (expr->accu expr info))
(size (expr->size info o)))
(append-text info (wrap-as (case size
((1) (i386:byte-mem->accu))
((2) (i386:word-mem->accu))
((4) (i386:mem->accu))
(else '()))))))
((fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list))
(if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list)))) ;; FIXME
(append-text info (wrap-as (asm->m1 arg0))))
(let* ((text-length (length text))
(args-info (let loop ((expressions (reverse expr-list)) (info info))
(if (null? expressions) info
(loop (cdr expressions) ((expr->arg info) (car expressions))))))
(n (length expr-list)))
(if (not (assoc-ref locals name))
(begin
(if (and (not (assoc name (.functions info)))
(not (assoc name globals))
(not (equal? name (.function info))))
(stderr "warning: undeclared function: ~a\n" name))
(append-text args-info (list (i386:call-label name n))))
(let* ((empty (clone info #:text '()))
(accu (expr->accu `(p-expr (ident ,name)) empty)))
(append-text args-info (append (.text accu)
(list (i386:call-accu n)))))))))
((fctn-call ,function (expr-list . ,expr-list))
(let* ((text-length (length text))
(args-info (let loop ((expressions (reverse expr-list)) (info info))
(if (null? expressions) info
(loop (cdr expressions) ((expr->arg info) (car expressions))))))
(n (length expr-list))
(empty (clone info #:text '()))
(accu (expr->accu function empty)))
(append-text args-info (append (.text accu)
(list (i386:call-accu n))))))
((cond-expr . ,cond-expr)
(ast->info `(expr-stmt ,o) info))
((post-inc ,expr)
(let* ((info (append (expr->accu expr info)))
(info (append-text info (wrap-as (i386:push-accu))))
(ptr (expr->pointer info expr))
(size (cond ((= ptr 1) (ast-type->size info expr))
((> ptr 1) 4)
(else 1)))
(info ((expr-add info) expr size))
(info (append-text info (wrap-as (i386:pop-accu)))))
info))
((post-dec ,expr)
(let* ((info (append (expr->accu expr info)))
(info (append-text info (wrap-as (i386:push-accu))))
(ptr (expr->pointer info expr))
(size (cond ((= ptr 1) (ast-type->size info expr))
((> ptr 1) 4)
(else 1)))
(info ((expr-add info) expr (- size)))
(info (append-text info (wrap-as (i386:pop-accu)))))
info))
((pre-inc ,expr)
(let* ((ptr (expr->pointer info expr))
(size (cond ((= ptr 1) (ast-type->size info expr))
((> ptr 1) 4)
(else 1)))
(info ((expr-add info) expr size))
(info (append (expr->accu expr info))))
info))
((pre-dec ,expr)
(let* ((ptr (expr->pointer info expr))
(size (cond ((= ptr 1) (ast-type->size info expr))
((> ptr 1) 4)
(else 1)))
(info ((expr-add info) expr (- size)))
(info (append (expr->accu expr info))))
info))
((add ,a (p-expr (fixed ,value)))
(let* ((ptr (expr->pointer info a))
(type (ast->type info a))
(struct? (or (and (pair? type) (equal? (car type) "tag"))
(memq (type:type type) '(struct union))))
(size (cond ((= ptr 1) (ast-type->size info a))
((> ptr 1) 4)
((and struct? (= ptr -2)) 4)
((and struct? (= ptr 2)) 4)
(else 1)))
(info (expr->accu a info))
(value (cstring->number value))
(value (* size value)))
(append-text info (wrap-as (i386:accu+value value)))))
((add ,a ,b)
(let* ((ptr (expr->pointer info a))
(ptr-b (expr->pointer info b))
(type (ast->type info a))
(struct? (or (and (pair? type) (equal? (car type) "tag"))
(memq (type:type type) '(struct union))))
(size (cond ((= ptr 1) (ast-type->size info a))
((> ptr 1) 4)
((and struct? (= ptr -2)) 4)
((and struct? (= ptr 2)) 4)
(else 1))))
(if (or (= size 1)) ((binop->accu info) a b (i386:accu+base))
(let* ((info (expr->accu b info))
(info (append-text info (wrap-as (append (i386:value->base size)
(i386:accu*base)
(i386:accu->base)))))
(info (expr->accu a info)))
(append-text info (wrap-as (i386:accu+base)))))))
((sub ,a (p-expr (fixed ,value)))
(let* ((ptr (expr->pointer info a))
(type (ast->type info a))
(struct? (or (and (pair? type) (equal? (car type) "tag"))
(memq (type:type type) '(struct union))))
(size (cond ((= ptr 1) (ast-type->size info a))
((> ptr 1) 4)
((and struct? (= ptr -2)) 4)
((and struct? (= ptr 2)) 4)
(else 1)))
(info (expr->accu a info))
(value (cstring->number value))
(value (* size value)))
(append-text info (wrap-as (i386:accu+value (- value))))))
((sub ,a ,b)
(let* ((ptr (expr->pointer info a))
(ptr-b (expr->pointer info b))
(type (ast->type info a))
(struct? (or (and (pair? type) (equal? (car type) "tag"))
(memq (type:type type) '(struct union))))
(size (cond ((= ptr 1) (ast-type->size info a))
((> ptr 1) 4)
((and struct? (= ptr -2)) 4)
((and struct? (= ptr 2)) 4)
(else 1))))
(if (or (= size 1) (or (= ptr-b -2) (= ptr-b 1)))
(let ((info ((binop->accu info) a b (i386:accu-base))))
(if (and (not (= ptr-b -2)) (not (= ptr-b 1))) info
(append-text info (wrap-as (append (i386:value->base size)
(i386:accu/base))))))
(let* ((info (expr->accu b info))
(info (append-text info (wrap-as (append (i386:value->base size)
(i386:accu*base)
(i386:accu->base)))))
(info (expr->accu a info)))
(append-text info (wrap-as (i386:accu-base)))))))
((bitwise-and ,a ,b) ((binop->accu info) a b (i386:accu-and-base)))
((bitwise-not ,expr)
(let ((info (ast->info expr info)))
(append-text info (wrap-as (i386:accu-not)))))
((bitwise-or ,a ,b) ((binop->accu info) a b (i386:accu-or-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 expr info)))
(clone info #:text
(append (.text test-info)
(wrap-as (i386:accu-negate)))
#:globals (.globals test-info))))
((neg ,expr)
(let ((info (expr->base expr info)))
(append-text info (append (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) a b (append (i386:sub-base) (i386:ge?->accu))))
((gt ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:g?->accu) (i386:accu-test))))
;; 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) a b (append (i386:sub-base) (i386:le?->accu))))
((lt ,a ,b) ((binop->accu info) a b (append (i386:sub-base) (i386:l?->accu))))
((or ,a ,b)
(let* ((info (expr->accu a info))
(here (number->string (length (.text info))))
(skip-b-label (string-append "_" (.function info) "_" here "_or_skip_b"))
(info (append-text info (wrap-as (i386:accu-test))))
(info (append-text info (wrap-as (i386:jump-nz skip-b-label))))
(info (append-text info (wrap-as (i386:accu-test))))
(info (expr->accu b info))
(info (append-text info (wrap-as (i386:accu-test))))
(info (append-text info (wrap-as `((#:label ,skip-b-label))))))
info))
((and ,a ,b)
(let* ((info (expr->accu a info))
(here (number->string (length (.text info))))
(skip-b-label (string-append "_" (.function info) "_" here "_and_skip_b"))
(info (append-text info (wrap-as (i386:accu-test))))
(info (append-text info (wrap-as (i386:jump-z skip-b-label))))
(info (append-text info (wrap-as (i386:accu-test))))
(info (expr->accu b info))
(info (append-text info (wrap-as (i386:accu-test))))
(info (append-text info (wrap-as `((#:label ,skip-b-label))))))
info))
((cast ,type ,expr)
(expr->accu expr info))
((assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op ,op) ,b)
(let* ((info (expr->accu `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b) info))
(type (ident->type info name))
(ptr (ident->pointer info name))
(size (if (> ptr 1) 4 1)))
(append-text info ((ident-add info) name size))))
((assn-expr (de-ref (post-dec (p-expr (ident ,name)))) (op ,op) ,b)
(let* ((info (expr->accu `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b) info))
(type (ident->type info name))
(ptr (ident->pointer info name))
(size (if (> ptr 1) 4 1)))
(append-text info ((ident-add info) name (- size)))))
((assn-expr ,a (op ,op) ,b)
(let* ((info (append-text info (ast->comment o)))
(ptr-a (expr->pointer info a))
(ptr-b (expr->pointer info b))
(size-a (expr->size info a))
(size-b (expr->size info b))
(info (expr->accu b info))
(info (if (equal? op "=") info
(let* ((ptr (expr->pointer info a))
(ptr-b (expr->pointer info b))
(type (ast->type info a))
(struct? (or (and (pair? type) (equal? (car type) "tag"))
(memq (type:type type) '(struct union))))
(size (cond ((= ptr 1) (ast-type->size info a))
((> ptr 1) 4)
((and struct? (= ptr -2)) 4)
((and struct? (= ptr 2)) 4)
(else 1)))
(info (if (or (= size 1) (= ptr-b 1)) info
(let ((info (append-text info (wrap-as (i386:value->base size)))))
(append-text info (wrap-as (i386:accu*base))))))
(info (append-text info (wrap-as (i386:push-accu))))
(info (expr->accu a info))
(info (append-text info (wrap-as (i386:pop-base))))
(info (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-and-base)))
((equal? op "|=") (wrap-as (i386:accu-or-base)))
((equal? op "^=") (wrap-as (i386:accu-xor-base)))
((equal? op ">>=") (wrap-as (i386:accu>>base)))
((equal? op "<<=") (wrap-as (i386:accu<<base)))
(else (error (format #f "mescc: op ~a not supported: ~a\n" op o)))))))
(cond ((not (and (= ptr 1) (= ptr-b 1))) info)
((equal? op "-=") (append-text info (wrap-as (append (i386:value->base size)
(i386:accu/base)))))
(else (error (format #f "invalid operands to binary ~s (have ~s* and ~s*)" op type (ast->type info b)))))))))
(when (and (equal? op "=")
(not (= size-a size-b))
(not (and (or (= size-a 1) (= size-a 2))
(= size-b 4)))
(not (and (= size-a 2)
(= size-b 4)))
(not (and (= size-a 4)
(or (= size-b 1) (= size-b 2)))))
(stderr "ERROR assign: ~a" (with-output-to-string (lambda () (pretty-print-c99 o))))
(stderr " size[~a]:~a != size[~a]:~a\n" ptr-a size-a ptr-b size-b))
(pmatch a
((p-expr (ident ,name))
(if (or (<= size-a 4) ;; FIXME: long long = int
(<= size-b 4)) (append-text info ((accu->ident info) name))
(let ((info (expr->base* a info)))
(accu->base-mem*n info size-a))))
(_ (let ((info (expr->base* a info)))
(accu->base-mem*n info (min size-a (max 4 size-b)))))))) ;; FIXME: long long = int
(_ (error "expr->accu: not supported: " o)))))
(define (expr->base o info)
(let* ((info (append-text info (wrap-as (i386:push-accu))))
(info (expr->accu o info))
(info (append-text info (wrap-as (append (i386:accu->base) (i386:pop-accu))))))
info))
(define (expr->base* o info)
(let* ((info (append-text info (wrap-as (i386:push-accu))))
(info (expr->accu* o info))
(info (append-text info (wrap-as (i386:accu->base))))
(info (append-text info (wrap-as (i386:pop-accu)))))
info))
(define (comment? o)
(and (pair? o) (pair? (car o)) (eq? (caar o) #:comment)))
(define (clause->info info i label last?)
(define clause-label
(string-append label "clause" (number->string i)))
(define body-label
(string-append label "body" (number->string i)))
(define (jump label)
(wrap-as (i386:jump label)))
(define (jump-nz label)
(wrap-as (i386:jump-nz label)))
(define (jump-z label)
(wrap-as (i386:jump-z label)))
(define (test->text test)
(let ((value (pmatch test
(0 0)
((p-expr (char ,value)) (char->integer (car (string->list value))))
((p-expr (ident ,constant)) (assoc-ref (.constants info) constant))
((p-expr (fixed ,value)) (cstring->number value))
((neg (p-expr (fixed ,value))) (- (cstring->number value)))
(_ (error "case test: not supported: " test)))))
(append (wrap-as (i386:accu-cmp-value value))
(jump-z body-label))))
(define (cases+jump info cases)
(let* ((info (append-text info (wrap-as `((#:label ,clause-label)))))
(next-clause-label (if last? (string-append label "break")
(string-append label "clause" (number->string (1+ i)))))
(info (append-text info (apply append cases)))
(info (if (null? cases) info
(append-text info (jump next-clause-label))))
(info (append-text info (wrap-as `((#:label ,body-label))))))
info))
(lambda (o)
(let loop ((o o) (cases '()) (clause #f))
(pmatch o
((case ,test ,statement)
(loop statement (append cases (list (test->text test))) clause))
((default ,statement)
(loop statement cases clause))
((default . ,statements)
(loop `(compd-stmt (block-item-list ,@statements)) cases clause))
((compd-stmt (block-item-list))
(loop '() cases clause))
((compd-stmt (block-item-list . ,elements))
(let ((clause (or clause (cases+jump info cases))))
(loop `(compd-stmt (block-item-list ,@(cdr elements))) cases
(ast->info (car elements) clause))))
(()
(let ((clause (or clause (cases+jump info cases))))
(if last? clause
(let ((next-body-label (string-append label "body"
(number->string (1+ i)))))
(append-text clause (wrap-as (i386:jump next-body-label)))))))
(_
(let ((clause (or clause (cases+jump info cases))))
(loop '() cases
(ast->info o clause))))))))
(define (test-jump-label->info info label)
(define (jump type . test)
(lambda (o)
(let* ((info (ast->info o info))
(info (append-text info (make-comment "jmp test LABEL")))
(jump-text (wrap-as (type label))))
(append-text info (append (if (null? test) '() (car test))
jump-text)))))
(lambda (o)
(pmatch o
((expr) info)
;; unsigned
;; ((le ,a ,b) ((jump i386:jump-ncz) o)) ; ja
;; ((lt ,a ,b) ((jump i386:jump-nc) o)) ; jae
;; ((ge ,a ,b) ((jump i386:jump-ncz) o))
;; ((gt ,a ,b) ((jump i386:jump-nc) o))
((le ,a ,b) ((jump i386:jump-g) o))
((lt ,a ,b) ((jump i386:jump-ge) o))
((ge ,a ,b) ((jump i386:jump-l) o))
((gt ,a ,b) ((jump i386:jump-le) o))
((ne ,a ,b) ((jump i386:jump-nz) o))
((eq ,a ,b) ((jump i386:jump-nz) o))
((not _) ((jump i386:jump-z) o))
((and ,a ,b)
(let* ((info ((test-jump-label->info info label) a))
(info ((test-jump-label->info info label) b)))
info))
((or ,a ,b)
(let* ((here (number->string (length (if mes? (.text info)
(filter (negate comment?) (.text info))))))
(skip-b-label (string-append label "_skip_b_" here))
(b-label (string-append label "_b_" here))
(info ((test-jump-label->info info b-label) a))
(info (append-text info (wrap-as (i386:jump skip-b-label))))
(info (append-text info (wrap-as `((#:label ,b-label)))))
(info ((test-jump-label->info info label) b))
(info (append-text info (wrap-as `((#:label ,skip-b-label))))))
info))
((array-ref ,index ,expr) (let* ((ptr (expr->pointer info expr))
(size (if (= ptr 1) (ast-type->size info expr)
4)))
((jump (if (= size 1) i386:jump-byte-z
i386:jump-z)
(wrap-as (i386:accu-zero?))) o)))
((de-ref ,expr) (let* ((ptr (expr->pointer info expr))
(size (if (= ptr 1) (ast-type->size info expr)
4)))
((jump (if (= size 1) i386:jump-byte-z
i386:jump-z)
(wrap-as (i386:accu-zero?))) o)))
((assn-expr (p-expr (ident ,name)) ,op ,expr)
((jump i386:jump-z
(append ((ident->accu info) name)
(wrap-as (i386:accu-zero?)))) o))
(_ ((jump i386:jump-z (wrap-as (i386:accu-zero?))) o)))))
(define (cstring->number s)
(let ((s (cond ((string-suffix? "ULL" s) (string-drop-right s 3))
((string-suffix? "UL" s) (string-drop-right s 2))
((string-suffix? "LL" s) (string-drop-right s 2))
((string-suffix? "L" s) (string-drop-right s 1))
(else 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 (expr->number info o)
(pmatch o
((fixed ,a) (cstring->number a))
((p-expr ,expr) (expr->number info expr))
((neg ,a)
(- (expr->number info a)))
((add ,a ,b)
(+ (expr->number info a) (expr->number info b)))
((bitwise-and ,a ,b)
(logand (expr->number info a) (expr->number info b)))
((bitwise-not ,a)
(lognot (expr->number info a)))
((bitwise-or ,a ,b)
(logior (expr->number info a) (expr->number info b)))
((div ,a ,b)
(quotient (expr->number info a) (expr->number info b)))
((mul ,a ,b)
(* (expr->number info a) (expr->number info b)))
((sub ,a ,b)
(- (expr->number info a) (expr->number info b)))
((sizeof-type (type-name (decl-spec-list (type-spec ,type))))
(ast-type->size info type))
((sizeof-expr (d-sel (ident ,field) (p-expr (ident ,struct))))
(let ((type (ident->type info struct)))
(field-size info type field)))
((sizeof-expr (i-sel (ident ,field) (p-expr (ident ,struct))))
(let ((type (ident->type info struct)))
(field-size info type field)))
((lshift ,x ,y)
(ash (expr->number info x) (expr->number info y)))
((rshift ,x ,y)
(ash (expr->number info x) (- (expr->number info y))))
((p-expr (ident ,name))
(let ((value (assoc-ref (.constants info) name)))
(or value
(error (format #f "expr->number: undeclared identifier: ~s\n" o)))))
((cast ,type ,expr) (expr->number info expr))
((cond-expr ,test ,then ,else)
(if (p-expr->bool info test) (expr->number info then) (expr->number info else)))
(,string (guard (string? string)) (cstring->number string))
(_ (error (format #f "expr->number: not supported: ~s\n" o)))))
(define (p-expr->bool info o)
(pmatch o
((eq ,a ,b) (eq? (expr->number info a) (expr->number info b)))))
(define (struct-field info)
(lambda (o)
(pmatch o
((comp-decl (decl-spec-list (type-spec (enum-ref (ident ,type))))
(comp-declr-list (comp-declr (ident ,name))))
(list (list name `("tag" ,type) 4 0)))
((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ident ,name))))
(list (list name type (ast-type->size info type) 0)))
((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ident ,name))))
(list (list name type (ast-type->size info type) 0)))
((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
(list (list name type 4 2)))
((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ftn-declr (scope (ptr-declr (pointer) (ident ,name))) (param-list . ,param-list)))))
(list (list name type 4 1)))
((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
(list (list name type 4 1)))
((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
(list (list name type 4 2)))
((comp-decl (decl-spec-list (type-spec (void))) (comp-declr-list (comp-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
(list (list name "void" 4 2)))
((comp-decl (decl-spec-list (type-spec (void))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
(list (list name "void" 4 1)))
((comp-decl (decl-spec-list (type-spec (void))) (comp-declr-list (comp-declr (ftn-declr (scope (ptr-declr (pointer) (ident ,name))) (param-list . ,param-list)))))
(list (list name "void" 4 1)))
((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
(list (list name type 4 1)))
;; FIXME: array: -1,-2-3, name??
((comp-decl (decl-spec-list (type-spec (typename ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (array-of (ident ,name) ,count)))))
(let ((size 4)
(count (expr->number info count)))
(list (list name type (* count size) -2))))
((comp-decl (decl-spec-list (type-spec ,type)) (comp-declr-list (comp-declr (array-of (ident ,name) ,count))))
(let* ((type (if (type? type) type
(ast->type info type)))
(size (ast-type->size info type))
(count (expr->number info count)))
(list (list name type (* count size) -1))))
((comp-decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (comp-declr-list (comp-declr (ptr-declr (pointer (pointer)) (ident ,name)))))
(list (list name `("tag" ,type) 4 2)))
((comp-decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
(list (list name `("tag" ,type) 4 1)))
((comp-decl (decl-spec-list (type-spec (struct-ref (ident ,type)))) (comp-declr-list (comp-declr (ident ,name))))
(let ((size (ast-type->size info `("tag" ,type))))
(list (list name `("tag" ,type) size 0))))
((comp-decl (decl-spec-list (type-spec (struct-def (field-list . ,fields)))))
(list `(struct ,@(append-map (struct-field info) fields))))
((comp-decl (decl-spec-list (type-spec (union-ref (ident ,type)))) (comp-declr-list (comp-declr (ident ,name))))
(let ((size (ast-type->size info `("tag" ,type))))
(list (list name `("tag" ,type) size 0))))
((comp-decl (decl-spec-list (type-spec (union-def (field-list . ,fields)))))
(list `(union ,@(append-map (struct-field info) fields))))
((comp-decl (decl-spec-list ,type) (comp-declr-list . ,decls)) (guard (pair? (cdr decls)))
(let loop ((decls decls))
(if (null? decls) '()
(append ((struct-field info) `(comp-decl (decl-spec-list ,type) (comp-declr-list ,(car decls))))
(loop (cdr decls))))))
(_ (error "struct-field: not supported: " o)))))
(define (local-var? o) ;; formals < 0, locals > 0
(positive? (local:id o)))
(define (ptr-declr->pointer o)
(pmatch o
((pointer) 1)
((pointer (pointer)) 2)
((pointer (pointer (pointer))) 3)
(_ (error "ptr-declr->pointer not supported: " 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: not supported:" s)))))))
(define (ast->info o info)
(let ((functions (.functions info))
(globals (.globals info))
(locals (.locals info))
(constants (.constants info))
(types (.types info))
(text (.text info)))
(pmatch o
(((trans-unit . _) . _) (ast-list->info o info))
((trans-unit . ,_) (ast-list->info _ info))
((fctn-defn . ,_) (fctn-defn->info _ info))
((cpp-stmt (define (name ,name) (repl ,value)))
info)
((cast (type-name (decl-spec-list (type-spec (void)))) _)
info)
((break)
(let ((label (car (.break info))))
(append-text info (wrap-as (i386:jump label)))))
((continue)
(let ((label (car (.continue info))))
(append-text info (wrap-as (i386:jump label)))))
;; FIXME: expr-stmt wrapper?
(trans-unit info)
((expr-stmt) info)
((compd-stmt (block-item-list . ,_)) (ast-list->info _ info))
((asm-expr ,gnuc (,null ,arg0 . string))
(append-text info (wrap-as (asm->m1 arg0))))
((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))
(if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list))))
(append-text info (wrap-as (asm->m1 arg0))))
(let* ((info (append-text info (ast->comment o)))
(info (expr->accu `(fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)) info)))
(append-text info (wrap-as (i386:accu-zero?))))))
((if ,test ,then)
(let* ((info (append-text info (ast->comment `(if ,test (ellipsis)))))
(here (number->string (length text)))
(label (string-append "_" (.function info) "_" here "_"))
(break-label (string-append label "break"))
(else-label (string-append label "else"))
(info ((test-jump-label->info info break-label) test))
(info (ast->info then info))
(info (append-text info (wrap-as (i386:jump break-label))))
(info (append-text info (wrap-as `((#:label ,break-label))))))
(clone info
#:locals locals)))
((if ,test ,then ,else)
(let* ((info (append-text info (ast->comment `(if ,test (ellipsis) (ellipsis)))))
(here (number->string (length text)))
(label (string-append "_" (.function info) "_" here "_"))
(break-label (string-append label "break"))
(else-label (string-append label "else"))
(info ((test-jump-label->info info else-label) test))
(info (ast->info then info))
(info (append-text info (wrap-as (i386:jump break-label))))
(info (append-text info (wrap-as `((#:label ,else-label)))))
(info (ast->info else info))
(info (append-text info (wrap-as `((#:label ,break-label))))))
(clone info
#:locals locals)))
;; Hmm?
((expr-stmt (cond-expr ,test ,then ,else))
(let* ((info (append-text info (ast->comment `(cond-expr ,test (ellipsis) (ellipsis)))))
(here (number->string (length text)))
(label (string-append "_" (.function info) "_" here "_"))
(else-label (string-append label "else"))
(break-label (string-append label "break"))
(info ((test-jump-label->info info else-label) test))
(info (ast->info then info))
(info (append-text info (wrap-as (i386:jump break-label))))
(info (append-text info (wrap-as `((#:label ,else-label)))))
(info (ast->info else info))
(info (append-text info (wrap-as `((#:label ,break-label))))))
info))
((switch ,expr (compd-stmt (block-item-list . ,statements)))
(let* ((info (append-text info (ast->comment `(switch ,expr (compd-stmt (block-item-list (ellipsis)))))))
(here (number->string (length text)))
(label (string-append "_" (.function info) "_" here "_"))
(break-label (string-append label "break"))
(clauses (statements->clauses statements))
(info (expr->accu expr info))
(info (clone info #:break (cons break-label (.break info))))
(info (let loop ((clauses clauses) (i 0) (info info))
(if (null? clauses) info
(loop (cdr clauses) (1+ i) ((clause->info info i label (null? (cdr clauses))) (car clauses))))))
(info (append-text info (wrap-as `((#:label ,break-label))))))
(clone info
#:locals locals
#:break (cdr (.break info)))))
((for ,init ,test ,step ,body)
(let* ((info (append-text info (ast->comment `(for ,init ,test ,step (ellipsis)))))
(here (number->string (length text)))
(label (string-append "_" (.function info) "_" here "_"))
(break-label (string-append label "break"))
(loop-label (string-append label "loop"))
(continue-label (string-append label "continue"))
(initial-skip-label (string-append label "initial_skip"))
(info (ast->info init info))
(info (clone info #:break (cons break-label (.break info))))
(info (clone info #:continue (cons continue-label (.continue info))))
(info (append-text info (wrap-as (i386:jump initial-skip-label))))
(info (append-text info (wrap-as `((#:label ,loop-label)))))
(info (ast->info body info))
(info (append-text info (wrap-as `((#:label ,continue-label)))))
(info (expr->accu step info))
(info (append-text info (wrap-as `((#:label ,initial-skip-label)))))
(info ((test-jump-label->info info break-label) test))
(info (append-text info (wrap-as (i386:jump loop-label))))
(info (append-text info (wrap-as `((#:label ,break-label))))))
(clone info
#:locals locals
#:break (cdr (.break info))
#:continue (cdr (.continue info)))))
((while ,test ,body)
(let* ((info (append-text info (ast->comment `(while ,test (ellipsis)))))
(here (number->string (length text)))
(label (string-append "_" (.function info) "_" here "_"))
(break-label (string-append label "break"))
(loop-label (string-append label "loop"))
(continue-label (string-append label "continue"))
(info (append-text info (wrap-as (i386:jump continue-label))))
(info (clone info #:break (cons break-label (.break info))))
(info (clone info #:continue (cons continue-label (.continue info))))
(info (append-text info (wrap-as `((#:label ,loop-label)))))
(info (ast->info body info))
(info (append-text info (wrap-as `((#:label ,continue-label)))))
(info ((test-jump-label->info info break-label) test))
(info (append-text info (wrap-as (i386:jump loop-label))))
(info (append-text info (wrap-as `((#:label ,break-label))))))
(clone info
#:locals locals
#:break (cdr (.break info))
#:continue (cdr (.continue info)))))
((do-while ,body ,test)
(let* ((info (append-text info (ast->comment `(do-while ,test (ellipsis)))))
(here (number->string (length text)))
(label (string-append "_" (.function info) "_" here "_"))
(break-label (string-append label "break"))
(loop-label (string-append label "loop"))
(continue-label (string-append label "continue"))
(info (clone info #:break (cons break-label (.break info))))
(info (clone info #:continue (cons continue-label (.continue info))))
(info (append-text info (wrap-as `((#:label ,loop-label)))))
(info (ast->info body info))
(info (append-text info (wrap-as `((#:label ,continue-label)))))
(info ((test-jump-label->info info break-label) test))
(info (append-text info (wrap-as (i386:jump loop-label))))
(info (append-text info (wrap-as `((#:label ,break-label))))))
(clone info
#:locals locals
#:break (cdr (.break info))
#:continue (cdr (.continue info)))))
((labeled-stmt (ident ,label) ,statement)
(let ((info (append-text info `(((#:label ,(string-append "_" (.function info) "_label_" label)))))))
(ast->info statement info)))
((goto (ident ,label))
(append-text info (wrap-as (i386:jump (string-append "_" (.function info) "_label_" label)))))
((return ,expr)
(let ((info (expr->accu expr info)))
(append-text info (append (wrap-as (i386:ret))))))
((decl . ,decl)
;;FIXME: ridiculous performance hit with mes
(let ((info (append-text info (ast->comment o))))
(decl->info info decl)))
;; ...
((gt . _) (expr->accu o info))
((ge . _) (expr->accu o info))
((ne . _) (expr->accu o info))
((eq . _) (expr->accu o info))
((le . _) (expr->accu o info))
((lt . _) (expr->accu o info))
((lshift . _) (expr->accu o info))
((rshift . _) (expr->accu o info))
;; EXPR
((expr-stmt ,expression)
(let ((info (expr->accu expression info)))
(append-text info (wrap-as (i386:accu-zero?)))))
;; FIXME: why do we get (post-inc ...) here
;; (array-ref
(_ (let ((info (expr->accu o info)))
(append-text info (wrap-as (i386:accu-zero?))))))))
(define (ast-list->info o info)
(fold ast->info info o))
(define (global->static function)
(lambda (o)
(cons (car o) (set-field (cdr o) (global:function) function))))
(define (decl-local->info info)
(lambda (o)
(pmatch o
(((decl-spec-list (stor-spec (static)) (type-spec ,type)) (init-declr-list ,init))
(let* ((function (.function info))
(i (clone info #:function #f #:globals '()))
(i ((decl->info i `(decl (decl-spec-list (type-spec ,type)) (init-declr-list ,init)))))
(statics (map (global->static function) (.globals i))))
(clone info #:statics (append statics (.statics info)))))
(_ #f))))
(define (decl-global->info info)
(lambda (o)
#f))
(define (decl->info info o)
(pmatch o
(((decl-spec-list (type-spec ,type)) (init-declr-list . ,inits))
(let* ((info (type->info info type))
(type (ast->type info type))
(pointer 0)) ; FIXME
(fold (cut init-declr->info type pointer <> <>) info (map cdr inits))))
(((decl-spec-list (type-spec ,type)))
(type->info info type))
(((decl-spec-list (stor-spec (typedef)) (type-spec ,type)) (init-declr-list (init-declr (ident ,name))))
(let* ((info (type->info info type))
(type (ast->type info type)))
(clone info #:types (acons name type (.types info)))))
(((decl-spec-list (stor-spec (,store)) (type-spec ,type)) (init-declr-list . ,inits))
(let* ((type (ast->type info type))
(pointer 0) ; FIXME
(function (.function info))
(tmp (clone info #:function #f #:globals '()))
(tmp (fold (cut init-declr->info type pointer <> <>) tmp (map cdr inits)))
(statics (map (global->static function) (.globals tmp))))
(clone info #:statics (append statics (.statics info)))))
(((@ . _))
(stderr "decl->info: skip: ~s\n" o)
info)
(_ (error "decl->info: not supported:" o))))
(define (ast->name o)
(pmatch o
((ident ,name) name)
((ptr-declr ,pointer (ident ,name)) name)
((array-of ,array . ,_) (ast->name array))
((ftn-declr (scope (ptr-declr ,pointer (ident ,name)))) name)
((ptr-declr ,pointer ,decl . ,_) (ast->name decl))
(_ (error "ast->name not supported: " o))))
(define (init-declr->count info o)
(pmatch o
((array-of (ident ,name) ,count) (expr->number info count))
(_ #f)))
(define (init->accu o info)
(pmatch o
((initzer-list (initzer ,expr)) (expr->accu expr info))
(((#:string ,string))
(append-text info (list (i386:label->accu `(#:string ,string)))))
((,number . _) (guard (number? number))
(append-text info (wrap-as (i386:value->accu 0))))
((,c . ,_) (guard (char? c)) info)
(_ (expr->accu o info))))
(define (init-struct-field local field init info)
(let* ((offset (field-offset info (local:type local) (car field)))
(pointer (field:pointer field))
(size (field:size field))
(empty (clone info #:text '())))
(clone info #:text
(append
(.text info)
(local->accu local)
(wrap-as (append (i386:accu->base)))
(wrap-as (append (i386:push-base)))
(.text (expr->accu init empty))
(wrap-as (append (i386:pop-base)))
(wrap-as (case size
((1) (i386:byte-accu->base-mem+n offset))
((2) (i386:word-accu->base-mem+n offset))
(else (i386:accu->base-mem+n offset))))))))
(define (init-array-entry local index init info)
(let* ((size (or (and (zero? (local:pointer local)) ((compose type:size local:type) local))
4))
(offset (* index size))
(empty (clone info #:text '())))
(clone info #:text
(append
(.text info)
(local->accu local)
(wrap-as (append (i386:accu->base)))
(wrap-as (append (i386:push-base)))
(.text (expr->accu init empty))
(wrap-as (append (i386:pop-base)))
(wrap-as (case size
((1) (i386:byte-accu->base-mem+n offset))
((2) (i386:word-accu->base-mem+n offset))
(else (i386:accu->base-mem+n offset))))))))
(define (init-local local o n info)
(pmatch o
(#f info)
((initzer ,init)
(init-local local init n info))
((initzer-list ,init)
(init-local local init n info))
((initzer-list . ,inits)
(let* ((type ((compose type:type local:type) local))
(struct? (or (and (pair? type) (equal? (car type) "tag"))
(memq type '(struct union)))))
(cond (struct?
(let ((fields ((compose struct->fields local:type) local)))
(fold (cut init-struct-field local <> <> <>) info fields (append inits (map (const '(p-expr (fixed "22"))) (iota (max 0 (- (length fields) (length inits)))))))))
(else (fold (cut init-local local <> <> <>) info inits (iota (length inits)))))))
(((initzer (initzer-list . ,inits)))
(fold (cut init-array-entry local <> <> <>) info (iota (length inits)) inits))
(() info)
(_ (let ((info (init->accu o info)))
(append-text info (accu->local+n-text local n))))))
(define (local->info type pointer array name o init info)
(let* ((locals (.locals info))
(id (if (or (null? locals) (not (local-var? (cdar locals)))) 1
(1+ (local:id (cdar locals)))))
(local (make-local-entry name type pointer array id))
(struct? (and (or (zero? pointer)
(= -1 pointer))
(or (and (pair? type)
(equal? (car type) "tag"))
(and (type? type)
(memq (type:type type) '(struct union))))))
(size (or (and (zero? pointer) (type? type) (type:size type))
(and struct? (and=> (ast->type info type) struct:size))
4))
(local (if (not array) local
(make-local-entry name type pointer array (+ (local:id (cdr local)) -1 (quotient (+ (* array size) 3) 4)))))
(local (if struct? (make-local-entry name type -1 array (+ (local:id (cdr local)) (quotient (+ size 3) 4)))
local))
(locals (cons local locals))
(info (clone info #:locals locals))
(local (cdr local)))
(init-local local init 0 info)))
(define (global->info type pointer array name o init info)
(let* ((size (cond ((type? type) (type:size type))
((not (zero? pointer)) 4)
(else (error "global->info: no such type:" type))))
(data (cond ((not init) (string->list (make-string size #\nul)))
(array (array-init->data (and array (* array (type:size type))) init info))
(else (let ((data (init->data init info)))
(append data (string->list (make-string (max 0 (- size (length data))) #\nul)))))))
(global (make-global-entry name type pointer array data)))
(clone info #:globals (append (.globals info) (list global)))))
(define (array-init-element->data size o info)
(pmatch o
((initzer (p-expr (string ,string)))
`((#:string ,string)))
((initzer (p-expr (fixed ,fixed)))
(int->bv32 (expr->number info fixed)))
(_ (init->data o info))
;;(_ (error "array-init-element->data: not supported: " o))
))
(define (array-init->data size o info)
(pmatch o
(((initzer (initzer-list . ,inits)))
(map (cut array-init-element->data size <> info) inits))
((initzer (p-expr (string ,string)))
(let ((data (string->list string)))
(if (not size) data
(append data (string->list (make-string (max 0 (- size (length data))) #\nul))))))
(((initzer (p-expr (string ,string))))
(let ((data (string->list string)))
(if (not size) data
(append data (string->list (make-string (max 0 (- size (length data))) #\nul))))))
((initzer (p-expr (fixed ,fixed)))
(int->bv32 (expr->number info fixed)))
(() (string->list (make-string size #\nul)))
(_ (error "array-init->data: not supported: " o))))
(define (init-declr->info type pointer o info)
(pmatch o
(((ident ,name))
(if (.function info) (local->info type pointer #f name o #f info)
(global->info type pointer #f name o #f info)))
(((ident ,name) (initzer ,init))
(let* ((strings (init->strings init info))
(info (if (null? strings) info
(clone info #:globals (append (.globals info) strings))))
(struct? (and (zero? pointer)
(or (and (pair? type) (equal? (car type) "tag"))
(memq (type:type type) '(struct union)))))
(pointer (if struct? (- (1+ (abs pointer))) pointer)))
(if (.function info) (local->info type pointer #f name o init info)
(global->info type pointer #f name o init info))))
(((ftn-declr (ident ,name) . ,_))
(let ((functions (.functions info)))
(if (member name functions) info
(let* ((type (ftn-declr:get-type info `(ftn-declr (ident ,name) ,@_)))
(function (make-function name type #f)))
(clone info #:functions (cons (cons name function) functions))))))
(((ftn-declr (scope (ptr-declr ,p (ident ,name))) ,param-list) ,init)
(let ((pointer (+ pointer (pointer->ptr p))))
(if (.function info) (local->info type pointer #f name o init info)
(global->info type pointer #f name o init info))))
(((ptr-declr ,p . ,_) . ,init)
(let ((pointer (+ pointer (pointer->ptr p))))
(init-declr->info type pointer (append _ init) info)))
(((array-of (ident ,name) ,array) . ,init)
(let* ((strings (init->strings init info))
(info (if (null? strings) info
(clone info #:globals (append (.globals info) strings))))
(array (expr->number info array))
(pointer (- (1+ pointer))))
(if (.function info) (local->info type pointer array name o init info)
(global->info type pointer array name o init info))))
(((array-of (ident ,name)) . ,init)
(let* ((strings (init->strings init info))
(info (if (null? strings) info
(clone info #:globals (append (.globals info) strings))))
(pointer (- (1+ pointer))))
(if (.function info) (local->info type pointer (length (cadar init)) name o init info)
(global->info type pointer #f name o init info))))
;; FIXME: recursion
(((array-of (array-of (ident ,name) ,array) ,array1) . ,init)
(let* ((strings (init->strings init info))
(info (if (null? strings) info
(clone info #:globals (append (.globals info) strings))))
(array (expr->number info array))
(pointer (- (+ 2 pointer))))
(if (.function info) (local->info type pointer array name o init info)
(global->info type pointer array name o init info))))
(_ (error "init-declr->info: not supported: " o))))
(define (enum-def-list->constants constants fields)
(let loop ((fields fields) (i 0) (constants constants))
(if (pair? fields)
(let ((field (car fields)))
(mescc:trace (cadr (cadr field)) " <e>")))
(if (null? fields) constants
(let* ((field (car fields))
(name (pmatch field
((enum-defn (ident ,name) . _) name)))
(i (pmatch field
((enum-defn ,name) i)
((enum-defn ,name ,exp) (expr->number #f exp))
(_ (error "not supported enum field=~s\n" field)))))
(loop (cdr fields)
(1+ i)
(append constants (list (ident->constant name i))))))))
(define (init->data o info)
(pmatch o
((p-expr ,expr) (init->data expr info))
((fixed ,fixed) (int->bv32 (expr->number info o)))
((char ,char) (int->bv32 (char->integer (string-ref char 0))))
((string ,string) `((#:string ,string)))
((string . ,strings) `((#:string ,(string-join strings ""))))
((ident ,name) (let ((var (ident->variable info name)))
`((#:address ,var))))
((initzer-list . ,initzers) (append-map (cut init->data <> info) initzers))
(((initzer (initzer-list . ,inits)))
(init->data `(initzer-list . ,inits) info))
((ref-to (p-expr (ident ,name)))
(let ((var (ident->variable info name)))
`((#:address ,var))))
((ref-to (i-sel (ident ,field) (cast (type-name (decl-spec-list ,struct) (abs-declr (pointer))) (p-expr (fixed ,base)))))
(let* ((type (ast->type info struct))
(offset (field-offset info type field))
(base (cstring->number base)))
(int->bv32 (+ base offset))))
((,char . _) (guard (char? char)) o)
((,number . _) (guard (number? number))
(append (map int->bv32 o)))
((initzer ,init) (init->data init info))
(_ (error "init->data: not supported: " o))))
(define (init->strings o info)
(let ((globals (.globals info)))
(pmatch o
((p-expr (string ,string))
(let ((g `(#:string ,string)))
(if (assoc g globals) '()
(list (string->global-entry string)))))
((p-expr (string . ,strings))
(let* ((string (string-join strings ""))
(g `(#:string ,string)))
(if (assoc g globals) '()
(list (string->global-entry string)))))
(((initzer (initzer-list . ,init)))
(append-map (cut init->strings <> info) init))
((initzer ,init)
(init->strings init info))
((initzer-list . ,init)
(append-map (cut init->strings <> info) init))
(_ '()))))
(define (type->info info o)
(pmatch o
((enum-def (ident ,name) (enum-def-list . ,fields))
(mescc:trace name " <t>")
(let* ((type-entry (enum->type-entry name fields))
(constants (enum-def-list->constants (.constants info) fields)))
(clone info
#:types (cons type-entry (.types info))
#:constants (append constants (.constants info)))))
((struct-def (ident ,name) (field-list . ,fields))
(mescc:trace name " <t>")
(let ((type-entry (struct->type-entry name (append-map (struct-field info) fields))))
(clone info #:types (cons type-entry (.types info)))))
((struct-ref . _)
info)
((union-def (ident ,name) (field-list . ,fields))
(mescc:trace name " <t>")
(let ((type-entry (union->type-entry name (append-map (struct-field info) fields))))
(clone info #:types (cons type-entry (.types info)))))
((union-ref . _)
info)
(_
(stderr "type->info: not supported: ~s\n" o)
info)))
;;; fctn-defn
(define (param-decl:get-name o)
(pmatch o
((ellipsis) #f)
((param-decl (decl-spec-list (type-spec (void)))) #f)
((param-decl _ (param-declr ,ast)) (ast->name ast))
(_ (error "param-decl:get-name not supported:" o))))
(define (fctn-defn:get-name o)
(pmatch o
((_ (ftn-declr (ident ,name) _) _) name)
((_ (ptr-declr (pointer . _) (ftn-declr (ident ,name) _)) _) name)
(_ (error "fctn-defn:get-name not supported:" o))))
(define (param-decl:get-type o info)
(pmatch o
((ellipsis) #f)
((param-decl (decl-spec-list (type-spec (void)))) #f)
((param-decl (decl-spec-list (type-spec ,type)) _) (ast->type info type))
((param-decl ,type _) (ast->type info type))
(_ (error "param-decl:get-type not supported:" o))))
(define (fctn-defn:get-formals o)
(pmatch o
((_ (ftn-declr _ ,formals) _) formals)
((_ (ptr-declr (pointer . _) (ftn-declr _ ,formals)) _) formals)
(_ (error "fctn-defn->formals: not supported:" o))))
(define (formal->text n)
(lambda (o i)
;;(i386:formal i n)
'()
))
(define (param-list->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 "param-list->text: not supported: " o))))
(define (param-decl:get-ptr o)
(pmatch o
((param-decl (decl-spec-list . ,decl) (param-declr (ident ,name) (array-of _)))
1)
((param-decl (decl-spec-list . ,decl) (param-declr (ident ,name)))
0)
((param-decl _ (param-declr (ptr-declr ,pointer (array-of _))))
(1+ (pointer->ptr pointer)))
((param-decl _ (param-declr (ptr-declr ,pointer . _)))
(pointer->ptr pointer))
((param-decl (decl-spec-list (type-spec (void))))
0)
(_ (error "param-decl:get-ptr: not supported: " o))))
(define (param-list->locals o info)
(pmatch o
((param-list . ,formals)
(let ((n (length formals)))
(map make-local-entry
(map param-decl:get-name formals)
(map (cut param-decl:get-type <> info) formals)
(map param-decl:get-ptr formals)
(map (const #f) (iota n))
(iota n -2 -1))))
(_ (error "param-list->locals: not supported:" o))))
(define (fctn-defn:get-type info o)
(pmatch o
(((decl-spec-list (type-spec ,type)) (ptr-declr ,pointer . _) ,statement)
(let ((type (ast->type info type))
(pointer (ptr-declr->pointer pointer)))
(make-type (type:type type)
(type:size type)
(+ (type:pointer type) pointer)
(type:description type))))
(((decl-spec-list (type-spec ,type)) . ,rest)
(ast->type info type))
(((decl-spec-list (stor-spec ,store) (type-spec ,type)) (ftn-declr (ident _) _) _)
(ast->type info type))
(_ (error "fctn-defn:get-type: not supported:" o))))
(define (ftn-declr:get-type info o)
(pmatch o
((ftn-declr (ident _) . _) #f)
(_ (error "fctn-decrl:get-type: not supported:" o))))
(define (fctn-defn:get-statement o)
(pmatch o
((_ (ftn-declr (ident _) _) ,statement) statement)
((_ (ptr-declr (pointer . _) (ftn-declr (ident _) . _)) ,statement) statement)
(_ (error "fctn-defn:get-statement: not supported: " o))))
(define (fctn-defn->info o info)
(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 (fctn-defn:get-name o)))
(mescc:trace name)
(let* ((type (fctn-defn:get-type info o))
(formals (fctn-defn:get-formals o))
(text (param-list->text formals))
(locals (param-list->locals formals info))
(statement (fctn-defn:get-statement o))
(info (clone info #:locals locals #:function name #:text text))
(info (ast->info statement info))
(locals (.locals info))
(local (and (pair? locals) (car locals)))
(count (and=> local (compose local:id cdr)))
(stack (and count (* count 4))))
(if (and stack (getenv "MESC_DEBUG")) (stderr " stack: ~a\n" stack))
(clone info
#:function #f
#:globals (append (.statics info) (.globals info))
#:statics '()
#:functions (append (.functions info) (list (cons name (make-function name type (assert-return (.text info))))))))))
;; exports
(define* (c99-ast->info o)
(ast->info o (make <info> #:types i386:type-alist)))
(define* (c99-input->ast #:key (defines '()) (includes '()))
(stderr "parsing: input\n")
((compose ast-strip-const ast-strip-comment) (c99-input->full-ast #:defines defines #:includes includes)))
(define* (c99-input->info #:key (defines '()) (includes '()))
(lambda ()
(let* ((info (make <info> #:types i386:type-alist))
(ast (c99-input->ast #:defines defines #:includes includes))
(foo (stderr "compiling: input\n"))
(info (ast->info ast info))
(info (clone info #:text '() #:locals '())))
info)))
(define* (info->object o)
(stderr "compiling: object\n")
`((functions . ,(filter (compose function:text cdr) (.functions o)))
(globals . ,(.globals o))))
(define* (c99-input->elf #:key (defines '()) (includes '()))
((compose object->elf info->object (c99-input->info #:defines defines #:includes includes))))
(define* (c99-input->object #:key (defines '()) (includes '()))
((compose object->M1 info->object (c99-input->info #:defines defines #:includes includes))))
Reference in New Issue View Git Blame Copy Permalink