artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity
mes/module/mescc/compile.scm
Ekaitz Zarraga 47cffc5d2a mescc: Fix switch statements' fallthrough 
Flattens case structures as nyacc is giving consecutive cases as a
nested block like:

    (case testA
      (case testB
        (case testC BODY)))

We convert to:

    ((case testA (expr-stmt))
     (case testB (expr-stmt))
     (case testC BODY))

And then treat them as independent cases. For the fallthrough we just
add a jump to each case's body right before its clause (each of the case
blocks is responsible of adding its own jump to its body):

        // This doesn't have it because it's the first
    CASE1:
        testA
    CASE1_BODY:

        goto CASE2_BODY
    CASE2:
        testB
    CASE2_BODY:

        goto CASE3_BODY
    CASE3:
        testB
    CASE3_BODY:

This enables complex fallthrough schemes comparing to what was done
before.

* module/mescc/compile.scm (ast->info)[switch]{flatten-cases}: New
variable.
(ast->info)[switch]{statements}: Use flatten-cases on it.
(switch->expr): Remove unneeded matchers and add jumps to body.
* build-aux/check-mescc.sh(xfail-tests): Remove
lib/tests/scaffold/66-local-char-array.c.
2023-11-05 09:45:31 +01:00

2699 lines
123 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.

;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018,2019,2020,2021 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2023 Andrius Štikonas <andrius@stikonas.eu>
;;; Copyright © 2023 Ekaitz Zarraga <ekaitz@elenq.tech>
;;; Copyright © 2021 W. J. van der Laan <laanwj@protonmail.com>
;;;
;;; This file is part of GNU Mes.
;;;
;;; GNU 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.
;;;
;;; GNU 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 GNU Mes. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(define-module (mescc compile)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-26)
#:use-module (system base pmatch)
#:use-module (ice-9 optargs)
#:use-module (ice-9 pretty-print)
#:use-module (nyacc lang c99 pprint)
#:use-module (mes guile)
#:use-module (mes misc)
#:use-module (mescc preprocess)
#:use-module (mescc info)
#:use-module (mescc as)
#:use-module (mescc i386 as)
#:use-module (mescc M1)
#:export (c99-ast->info
c99-input->info
c99-input->object))
(define mes? (pair? (current-module)))
(define mes-or-reproducible? #t)
(define (cc-amd? info) #f) ; use AMD calling convention?
;; (define %reduced-register-count #f) ; use all registers?
(define %reduced-register-count 2) ; use reduced instruction set
(define (max-registers info)
(if %reduced-register-count %reduced-register-count
(length (append (.registers info) (.allocated info)))))
(define* (c99-input->info info #:key (prefix "") (defines '()) (includes '()) (arch "") verbose?)
(let ((ast (c99-input->ast #:prefix prefix #:defines defines #:includes includes #:arch arch #:verbose? verbose?)))
(c99-ast->info info ast #:verbose? verbose?)))
(define* (c99-ast->info info o #:key verbose?)
(when verbose?
(format (current-error-port) "compiling: input\n")
(set! mescc:trace mescc:trace-verbose))
(let ((info (ast->info o info)))
(clean-info info)))
(define (clean-info o)
(make <info>
#:functions (filter (compose pair? function:text cdr) (.functions o))
#:globals (.globals o)
#:types (.types o)))
(define (ident->constant name value)
(cons name value))
(define (enum->type-entry name fields)
(cons `(tag ,name) (make-type 'enum 4 fields)))
(define (struct->type-entry info name fields)
(let ((size (apply + (map (compose (cut ->size <> info) cdr) fields))))
(cons `(tag ,name) (make-type 'struct size fields))))
(define (union->type-entry info name fields)
(let ((size (apply max (map (compose (cut ->size <> info) cdr) fields))))
(cons `(tag ,name) (make-type 'union size fields))))
(define (signed? o)
(let ((type (->type o)))
(cond ((type? type) (eq? (type:type type) 'signed))
(else #f))))
(define (unsigned? o)
(let ((type (->type o)))
(cond ((type? type) (eq? (type:type type) 'unsigned))
(else #t))))
(define (->size o info)
(cond ((and (type? o) (eq? (type:type o) 'union))
(apply max (map (compose (cut ->size <> info) cdr) (struct->fields o))))
((type? o) (type:size o))
((pointer? o) (->size (get-type "*" info) info))
((c-array? o) (* (c-array:count o) ((compose (cut ->size <> info) c-array:type) o)))
((local? o) ((compose (cut ->size <> info) local:type) o))
((global? o) ((compose (cut ->size <> info) global:type) o))
((bit-field? o) ((compose (cut ->size <> info) bit-field:type) o))
((and (pair? o) (pair? (car o)) (bit-field? (cdar o))) ((compose (cut ->size <> info) cdar) o))
((string? o) (->size (get-type o info) info))
(else (error "->size>: not a <type>:" o))))
(define (ast->type o info)
(define (type-helper o info)
(if (getenv "MESC_DEBUG")
(format (current-error-port) "type-helper: ~s\n" o))
(pmatch o
(,t (guard (type? t)) t)
(,p (guard (pointer? p)) p)
(,a (guard (c-array? a)) a)
(,b (guard (bit-field? b)) b)
((char ,value) (get-type "char" info))
((enum-ref . _) (get-type "default" info))
((fixed ,value)
(let ((type (cond ((string-suffix? "ULL"value) "unsigned long long")
((string-suffix? "UL" value) "unsigned long")
((string-suffix? "U" value) "unsigned")
((string-suffix? "LL" value) "long long")
((string-suffix? "L" value) "long")
(else "default"))))
(get-type type info)))
((float ,float) (get-type "float" info))
((void) (get-type "void" info))
((ident ,name) (ident->type info name))
((tag ,name) (or (get-type o info)
o))
(,name (guard (string? name))
(let ((type (get-type name info)))
(ast->type type info)))
((type-name (decl-spec-list ,type) (abs-declr (pointer . ,pointer)))
(let ((rank (pointer->rank `(pointer ,@pointer)))
(type (ast->type type info)))
(rank+= type rank)))
((type-name ,type) (ast->type type info))
((type-spec ,type) (ast->type type info))
((sizeof-expr ,expr) (get-type "unsigned" info))
((sizeof-type ,type) (get-type "unsigned" info))
((string ,string) (make-c-array (get-type "char" info) (1+ (string-length string))))
((decl-spec-list (type-spec ,type)) (ast->type type info))
((fctn-call (p-expr (ident ,name)) . _)
(or (and=> (assoc-ref (.functions info) name) function:type)
(get-type "default" info)))
((fctn-call (de-ref (p-expr (ident ,name))) . _)
(or (and=> (assoc-ref (.functions info) name) function:type)
(get-type "default" info)))
((fixed-type ,type) (ast->type type info))
((float-type ,type) (ast->type type info))
((type-spec ,type) (ast->type type info))
((typename ,type) (ast->type type info))
((array-ref ,index ,array) (rank-- (ast->type array info)))
((de-ref ,expr) (rank-- (ast->type expr info)))
((ref-to ,expr) (rank++ (ast->type expr info)))
((p-expr ,expr) (ast->type expr info))
((pre-inc ,expr) (ast->type expr info))
((post-inc ,expr) (ast->type expr info))
((struct-ref (ident ,type))
(or (get-type type info)
(let ((struct (if (pair? type) type `(tag ,type))))
(ast->type struct info))))
((union-ref (ident ,type))
(or (get-type type info)
(let ((struct (if (pair? type) type `(tag ,type))))
(ast->type struct info))))
((struct-def (ident ,name) . _)
(ast->type `(tag ,name) info))
((union-def (ident ,name) . _)
(ast->type `(tag ,name) info))
((struct-def (field-list . ,fields))
(let ((fields (append-map (struct-field info) fields)))
(make-type 'struct (apply + (map (cut field:size <> info) fields)) fields)))
((union-def (field-list . ,fields))
(let ((fields (append-map (struct-field info) fields)))
(make-type 'union (apply + (map (cut field:size <> info) fields)) fields)))
((enum-def (enum-def-list . ,fields))
(get-type "default" info))
((d-sel (ident ,field) ,struct)
(let ((type0 (ast->type struct info)))
(ast->type (field-type info type0 field) info)))
((i-sel (ident ,field) ,struct)
(let ((type0 (ast->type (rank-- (ast->type struct info)) info)))
(ast->type (field-type info type0 field) info)))
;; arithmetic
((pre-inc ,a) (ast->type a info))
((pre-dec ,a) (ast->type a info))
((post-inc ,a) (ast->type a info))
((post-dec ,a) (ast->type a info))
((add ,a ,b) (ast->type a info))
((sub ,a ,b) (ast->type a info))
((bitwise-and ,a ,b) (ast->type a info))
((bitwise-not ,a) (ast->type a info))
((bitwise-or ,a ,b) (ast->type a info))
((bitwise-xor ,a ,b) (ast->type a info))
((lshift ,a ,b) (ast->type a info))
((rshift ,a ,b) (ast->type a info))
((div ,a ,b) (ast->type a info))
((mod ,a ,b) (ast->type a info))
((mul ,a ,b) (ast->type a info))
((not ,a) (ast->type a info))
((pos ,a) (ast->type a info))
((neg ,a) (ast->type a info))
((eq ,a ,b) (ast->type a info))
((ge ,a ,b) (ast->type a info))
((gt ,a ,b) (ast->type a info))
((ne ,a ,b) (ast->type a info))
((le ,a ,b) (ast->type a info))
((lt ,a ,b) (ast->type a info))
;; logical
((or ,a ,b) (ast->type a info))
((and ,a ,b) (ast->type a info))
((cast (type-name ,type) ,expr) (ast->type type info))
((cast (type-name ,type (abs-declr ,pointer)) ,expr)
(let ((rank (pointer->rank pointer)))
(rank+= (ast->type type info) rank)))
((decl-spec-list (type-spec ,type)) (ast->type type info))
;; ;; `typedef int size; void foo (unsigned size u)
((decl-spec-list (type-spec ,type) (type-spec ,type2))
(ast->type type info))
((assn-expr ,a ,op ,b) (ast->type a info))
((cond-expr _ ,a ,b) (ast->type a info))
(_ (get-type o info))))
(let ((type (type-helper o info)))
(cond ((or (type? type)
(pointer? type) type
(c-array? type)) type)
((and (equal? type o) (pair? type) (eq? (car type) 'tag)) o)
((equal? type o)
(error "ast->type: not supported: " o))
(else (ast->type type info)))))
(define (ast->basic-type o info)
(let ((type (->type (ast->type o info))))
(cond ((type? type) type)
((equal? type o) o)
(else (ast->type type info)))))
(define (get-type o info)
(let ((t (assoc-ref (.types info) o)))
(pmatch t
((typedef ,next) (or (get-type next info) o))
(_ t))))
(define (ast-type->size info o)
(let ((type (->type (ast->type o info))))
(cond ((type? type) (type:size type))
(else (format (current-error-port) "error: ast-type->size: ~s => ~s\n" o type)
4))))
(define (field:name o)
(pmatch o
((struct (,name ,type ,size ,pointer) . ,rest) name)
((union (,name ,type ,size ,pointer) . ,rest) name)
((,name . ,type) 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) (->rank type))
(_ (error "field:pointer not supported:" o))))
(define (field:size o info)
(pmatch o
((struct . ,type) (apply + (map (cut field:size <> info) (struct->fields type))))
((union . ,type) (apply max (map (cut field:size <> info) (struct->fields type))))
((,name . ,type) (->size type info))
(_ (error (format #f "field:size: ~s\n" o)))))
(define (field-field info struct field)
(let ((fields (type:description struct)))
(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)) (type? (cdr f))
(find (lambda (x) (equal? (car x) field)) (struct->fields (cdr f)))))
((eq? (car f) 'bits) (assoc field (cdr f)))
(else (loop (cdr fields)))))))))
(define (field-offset info struct field)
(if (eq? (type:type struct) 'union) 0
(let ((fields (type:description struct)))
(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) (type? (cdr f)))
(let ((fields (type:description (cdr f))))
(find (lambda (x) (equal? (car x) field)) fields)
(apply + (cons offset
(map (cut field:size <> info)
(member field (reverse fields)
(lambda (a b)
(equal? a (car b) field))))))))
((and (eq? (car f) 'union) (type? (cdr f))
(let ((fields (struct->fields (cdr f))))
(and (find (lambda (x) (equal? (car x) field)) fields)
offset))))
((and (eq? (car f) 'bits) (assoc-ref (cdr f) field)) offset)
(else (loop (cdr fields) (+ offset (field:size f info)))))))))))
(define (field-pointer info struct field)
(let ((field (field-field info struct field)))
(field:pointer field)))
(define (field-size info struct field)
(let ((field (field-field info struct field)))
(field:size field info)))
(define (field-type info struct field)
(let ((field (field-field info struct field)))
(ast->type (cdr field) info)))
(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)))
(append-map struct->fields (type:description o)))
((struct . ,type) (list (car (type:description type))))
((union . ,type) (list (car (type:description type))))
((bits . ,bits) bits)
(_ (list o))))
(define (struct->init-fields o) ;; FIXME REMOVEME: non-recursive unroll
(pmatch o
(_ (guard (and (type? o) (eq? (type:type o) 'struct)))
(append-map struct->init-fields (type:description o)))
(_ (guard (and (type? o) (eq? (type:type o) 'union)))
(list (car (type:description o))))
((struct . ,type) (struct->init-fields type))
((union . ,type) (list (car (type:description type))))
(_ (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 (.statics info) o)
(assoc-ref (filter (negate static-global?) (.globals info)) o)
(assoc-ref (.constants info) o)
(assoc-ref (.functions info) o)
(begin
(error "ident->variable: undefined variable:" o))))
(define (static-global? o)
((compose global:function cdr) o))
(define (string-global? o)
(and (pair? (car o))
(eq? (caar o) #:string)))
(define (ident->type info o)
(let ((var (ident->variable info o)))
(cond ((global? var) (global:type var))
((local? var) (local:type var))
((function? var) (function:type var))
((assoc-ref (.constants info) o) (assoc-ref (.types info) "default"))
((pair? var) (car var))
(else (format (current-error-port) "error: ident->type ~s => ~s\n" o var)
#f))))
(define (local:pointer o)
(->rank o))
(define (ident->rank info o)
(->rank (ident->variable info o)))
(define (ident->size info o)
((compose type:size (cut ident->type info <>)) o))
(define (pointer->rank o)
(pmatch o
((pointer) 1)
((pointer ,pointer) (1+ (pointer->rank pointer)))))
(define (expr->rank info o)
(->rank (ast->type o info)))
(define (ast->size o info)
(->size (ast->type o info) info))
(define (append-text info text)
(clone info #:text (append (.text info) text)))
(define (make-global-entry name storage type value)
(cons name (make-global name type value storage #f)))
(define (string->global-entry string)
(let ((value (append (string->list string) (list #\nul))))
(make-global-entry `(#:string ,string) '() "char" value)))
(define (make-local-entry name type id)
(cons name (make-local name type id)))
(define* (mescc:trace-verbose name #:optional (type ""))
(format (current-error-port) " :~a~a\n" name type))
(define* (mescc:trace name #:optional (type ""))
#t)
(define (expr->arg o i info)
(pmatch o
((p-expr (string ,string))
(let* ((globals ((globals:add-string (.globals info)) string))
(info (clone info #:globals globals))
(info (allocate-register info))
(info (append-text info (wrap-as (as info 'label->arg `(#:string ,string) i))))
(no-swap? (zero? (.pushed info)))
(info (if (cc-amd? info) info (free-register info)))
(info (if no-swap? info
(append-text info (wrap-as (as info 'swap-r1-stack))))))
info))
(_ (let* ((info (expr->register o info))
(info (append-text info (wrap-as (as info 'r->arg i))))
(no-swap? (zero? (.pushed info)))
(info (if (cc-amd? info) info (free-register info)))
(info (if no-swap? info
(append-text info (wrap-as (as info 'swap-r1-stack))))))
info))))
(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 (ident->r info)
(lambda (o)
(cond ((assoc-ref (.locals info) o) => (cut local->r <> info))
((assoc-ref (.statics info) o) => (cut global->r <> info))
((assoc-ref (filter (negate static-global?) (.globals info)) o) => (cut global->r <> info))
((assoc-ref (.constants info) o) => (cut value->r <> info))
(else (wrap-as (as info 'label->r `(#:address ,o)))))))
(define (value->r o info)
(wrap-as (as info 'value->r o)))
(define (local->r o info)
(let* ((type (local:type o)))
(cond ((or (c-array? type)
(structured-type? type))
(wrap-as (as info 'local-ptr->r (local:id o))))
(else (append (wrap-as (as info 'local->r (local:id o)))
(convert-r0 info type))))))
(define (global->r o info)
(let ((type (global:type o)))
(cond ((or (c-array? type)
(structured-type? type)) (wrap-as (as info 'label->r `(#:address ,o))))
(else (append (wrap-as (as info 'label-mem->r `(#:address ,o)))
(convert-r0 info type))))))
(define (ident-address->r info)
(lambda (o)
(cond ((assoc-ref (.locals info) o)
=>
(lambda (local) (wrap-as (as info 'local-ptr->r (local:id local)))))
((assoc-ref (.statics info) o)
=>
(lambda (global) (wrap-as (as info 'label->r `(#:address ,global)))))
((assoc-ref (filter (negate static-global?) (.globals info)) o)
=>
(lambda (global) (wrap-as (as info 'label->r `(#:address ,global)))))
(else (wrap-as (as info 'label->r `(#:address ,o)))))))
(define (r->local+n-text info local n)
(let* ((id (local:id local))
(type (local:type local))
(type* (cond
((pointer? type) type)
((c-array? type) (c-array:type type))
((type? type) type)
(else
(format (current-error-port) "unexpected type: ~s\n" type)
type)))
(size (->size type* info))
(reg-size (->size "*" info))
(size (if (= size reg-size) 0 size)))
(case size
((0) (wrap-as (as info 'r->local+n id n)))
((1) (wrap-as (as info 'byte-r->local+n id n)))
((2) (wrap-as (as info 'word-r->local+n id n)))
((4) (wrap-as (as info 'long-r->local+n id n)))
(else
(format (current-error-port) "unexpected size:~s\n" size)
(wrap-as (as info 'r->local+n id n))))))
(define (r->ident info)
(lambda (o)
(cond ((assoc-ref (.locals info) o)
=>
(lambda (local) (let ((size (->size local info))
(r-size (->size "*" info)))
(wrap-as (as info 'r->local (local:id local))))))
((assoc-ref (.statics info) o)
=>
(lambda (global) (let* ((size (->size global info))
(reg-size (->size "*" info))
(size (if (= size reg-size) 0 size)))
(case size
((0) (wrap-as (as info 'r->label global)))
((1) (wrap-as (as info 'r->byte-label global)))
((2) (wrap-as (as info 'r->word-label global)))
((4) (wrap-as (as info 'r->long-label global)))
(else (wrap-as (as info 'r->label global)))))))
((assoc-ref (filter (negate static-global?) (.globals info)) o)
=>
(lambda (global) (let* ((size (->size global info))
(reg-size (->size "*" info))
(size (if (= size reg-size) 0 size)))
(case size
((0) (wrap-as (as info 'r->label global)))
((1) (wrap-as (as info 'r->byte-label global)))
((2) (wrap-as (as info 'r->word-label global)))
((4) (wrap-as (as info 'r->long-label global)))
(else (wrap-as (as info 'r->label global))))))))))
(define (ident-add info)
(lambda (o n)
(cond ((assoc-ref (.locals info) o)
=>
(lambda (local) (wrap-as (as info 'local-add (local:id local) n))))
((assoc-ref (.statics info) o)
=>
(lambda (global)
(let* ((size (->size global info))
(reg-size (->size "*" info))
(size (if (= size reg-size) 0 size)))
(case size
((0) (wrap-as (as info 'label-mem-add `(#:address ,o) n)))
((1) (wrap-as (as info 'byte-label-mem-add `(#:address ,o) n)))
((2) (wrap-as (as info 'word-label-mem-add `(#:address ,o) n)))
((4) (wrap-as (as info 'long-mem-add `(#:address ,o) n)))
(else (as info 'label-mem-add `(#:address ,o) n))))))
((assoc-ref (filter (negate static-global?) (.globals info)) o)
=>
(lambda (global)
(let* ((size (->size global info))
(reg-size (->size "*" info))
(size (if (= size reg-size) 0 size)))
(case size
((0) (wrap-as (as info 'label-mem-add `(#:address ,o) n)))
((1) (wrap-as (as info 'byte-label-mem-add `(#:address ,o) n)))
((2) (wrap-as (as info 'word-label-mem-add `(#:address ,o) n)))
((4) (wrap-as (as info 'long-mem-add `(#:address ,o) n)))
(else (as info 'label-mem-add `(#:address ,o) n)))))))))
(define (make-comment o)
(wrap-as `((#:comment ,o))))
(define (ast->comment o)
(if mes-or-reproducible? '()
(let* ((source (with-output-to-string (lambda () (pretty-print-c99 o))))
;; Nyacc fixups
(source (string-substitute source "\\" "\\\\"))
(source (string-substitute source "'\\'" "'\\\\'"))
(source (string-substitute source "'\"'" "'\\\"'"))
(source (string-substitute source "'''" "'\\''"))
(source (string-substitute source "\n" "\\n"))
(source (string-substitute source "\r" "\\r")))
(make-comment source))))
(define (r*n info n)
(case n
((1) info)
((2) (append-text info (wrap-as (as info 'r+r))))
((3) (let* ((info (allocate-register info))
(info (append-text info (wrap-as (append (as info 'r0->r1)
(as info 'r+r)
(as info 'r0+r1)))))
(info (free-register info)))
info))
((4) (append-text info (wrap-as (as info 'shl-r 2))))
((5) (let* ((info (allocate-register info))
(info (append-text info (wrap-as (append (as info 'r0->r1)
(as info 'r+r)
(as info 'r+r)
(as info 'r0+r1)))))
(info (free-register info)))
info))
((6) (let* ((info (allocate-register info))
(info (append-text info (wrap-as (append (as info 'r0->r1)
(as info 'r+r)
(as info 'r0+r1)))))
(info (free-register info))
(info (append-text info (wrap-as (append (as info 'shl-r 1))))))
info))
((8) (append-text info (wrap-as (append (as info 'shl-r 3)))))
((10) (let* ((info (allocate-register info))
(info (append-text info (wrap-as (append (as info 'r0->r1)
(as info 'r+r)
(as info 'r+r)
(as info 'r0+r1)))))
(info (free-register info))
(info (append-text info (wrap-as (append (as info 'shl-r 1))))))
info))
((12) (let* ((info (allocate-register info))
(info (append-text info (wrap-as (append (as info 'r0->r1)
(as info 'r+r)
(as info 'r0+r1)))))
(info (free-register info))
(info (append-text info (wrap-as (append (as info 'shl-r 2))))))
info))
((16) (append-text info (wrap-as (as info 'shl-r 4))))
((20) (let* ((info (allocate-register info))
(info (append-text info (wrap-as (append (as info 'r0->r1)
(as info 'r+r)
(as info 'r+r)
(as info 'r0+r1)))))
(info (free-register info))
(info (append-text info (wrap-as (append (as info 'shl-r 2))))))
info))
((24) (let* ((info (allocate-register info))
(info (append-text info (wrap-as (append (as info 'r0->r1)
(as info 'r+r)
(as info 'r0+r1)))))
(info (free-register info))
(info (append-text info (wrap-as (append (as info 'shl-r 3))))))
info))
(else (let* ((info (allocate-register info))
(info (append-text info (wrap-as (as info 'value->r n))))
(info (append-text info (wrap-as (as info 'r0*r1))))
(info (free-register info)))
info))))
(define (allocate-register info)
(let ((registers (.registers info))
(allocated (.allocated info)))
(if (< (length allocated) (max-registers info))
(clone info #:allocated (cons (car registers) (.allocated info)) #:registers (cdr registers))
(let* ((info (clone info #:pushed (1+ (.pushed info))))
(info (append-text info (wrap-as (append (as info 'push-r0)
(as info 'r1->r0))))))
info))))
(define (free-register info)
(let ((allocated (.allocated info))
(pushed (.pushed info)))
(if (zero? pushed)
(clone info #:allocated (cdr allocated) #:registers (cons (car allocated) (.registers info)))
(let* ((info (clone info #:pushed (1- pushed)))
(info (append-text info (wrap-as (append (as info 'r0->r1)
(as info 'pop-r0))))))
info))))
(define (push-register r info)
(append-text info (wrap-as (as info 'push-register r))))
(define (pop-register r info)
(append-text info (wrap-as (as info 'pop-register r))))
(define (r0->r1-mem*n- info n size)
(let ((reg-size (->size "*" info)))
(wrap-as
(cond
((= n 1) (as info 'byte-r0->r1-mem))
((= n 2) (cond ((= size 1) (append (as info 'byte-r0->r1-mem)
(as info 'r+value 1)
(as info 'value->r0 0)
(as info 'byte-r0->r1-mem)))
(else (as info 'word-r0->r1-mem))))
((= n 4) (as info 'long-r0->r1-mem))
((and (= n 8) (or (= reg-size 8)
(= size 4)))
(cond ((= size 4) (append (as info 'long-r0->r1-mem)
(as info 'r+value 4)
(as info 'value->r0 0)
(as info 'long-r0->r1-mem)))
((and (= size 8) (= reg-size 8)) (as info 'quad-r0->r1-mem))
(else (error "r0->r1-mem*n-: not supported"))))
(else (let loop ((i 0))
(if (>= i n) '()
(case (- n i)
((1) (as info 'byte-r0-mem->r1-mem))
((2) (as info 'word-r0-mem->r1-mem))
((3) (append (as info 'word-r0-mem->r1-mem)
(as info 'r+value 2)
(as info 'r0+value 2)
(loop (+ i 2))))
((4) (append (as info 'long-r0-mem->r1-mem)))
(else (append (as info 'r0-mem->r1-mem)
(as info 'r+value reg-size)
(as info 'r0+value reg-size)
(loop (+ i reg-size))))))))))))
(define (r0->r1-mem*n info n size)
(append-text info (r0->r1-mem*n- info n size)))
(define (expr->register* o info)
(pmatch o
((p-expr (ident ,name))
(let ((info (allocate-register info)))
(append-text info ((ident-address->r info) name))))
((de-ref ,expr)
(expr->register expr info))
((d-sel (ident ,field) ,struct)
(let* ((type (ast->basic-type struct info))
(offset (field-offset info type field))
(info (expr->register* struct info)))
(append-text info (wrap-as (as info 'r+value offset)))))
((i-sel (ident ,field) (fctn-call (p-expr (ident ,function)) . ,rest))
(let* ((type (ast->basic-type `(fctn-call (p-expr (ident ,function)) ,@rest) info))
(offset (field-offset info type field))
(info (expr->register `(fctn-call (p-expr (ident ,function)) ,@rest) info)))
(append-text info (wrap-as (as info 'r+value offset)))))
((i-sel (ident ,field) ,struct)
(let* ((type (ast->basic-type struct info))
(offset (field-offset info type field))
(info (expr->register* struct info))
(type (ast->type struct info)))
(append-text info (append (if (c-array? type) '()
(wrap-as (as info 'mem->r)))
(wrap-as (as info 'r+value offset))))))
((array-ref ,index ,array)
(let* ((info (expr->register index info))
(size (ast->size o info))
(info (r*n info size))
(info (expr->register array info))
(info (append-text info (wrap-as (as info 'r0+r1))))
(info (free-register info)))
info))
((cast ,type ,expr)
(expr->register `(ref-to ,expr) info))
((add ,a ,b)
(let* ((rank (expr->rank info a))
(rank-b (expr->rank info b))
(type (ast->basic-type a info))
(struct? (structured-type? type))
(reg-size (->size "*" info))
(size (cond ((= rank 1) (ast-type->size info a))
((> rank 1) reg-size)
((and struct? (= rank 2)) reg-size)
(else 1))))
(if (or (= size 1)) ((binop->r* info) a b 'r0+r1)
(let* ((info (expr->register b info))
(info (allocate-register info))
(info (append-text info (wrap-as (append (as info 'value->r size)
(as info 'r0*r1)))))
(info (free-register info))
(info (expr->register* a info))
(info (append-text info (wrap-as (as info 'r0+r1))))
(info (free-register info)))
info))))
((sub ,a ,b)
(let* ((rank (expr->rank info a))
(rank-b (expr->rank info b))
(type (ast->basic-type a info))
(struct? (structured-type? type))
(size (->size type info))
(reg-size (->size "*" info))
(size (cond ((= rank 1) size)
((> rank 1) reg-size)
((and struct? (= rank 2)) reg-size)
(else 1))))
(if (or (= size 1) (or (= rank-b 2) (= rank-b 1)))
(let ((info ((binop->r* info) a b 'r0-r1)))
(if (and (not (= rank-b 2)) (not (= rank-b 1))) info
;; FIXME: c&p 1158
(let* ((info (allocate-register info))
(info (append-text info (wrap-as (append
(as info 'value->r size)
(as info 'swap-r0-r1)
(as info 'r0/r1 #f)))))
(info (append-text info (wrap-as (append (as info 'swap-r0-r1)))))
(free-register info))
info)))
(let* ((info (expr->register* b info))
(info (allocate-register info))
(info (append-text info (wrap-as (append (as info 'value->r size)
(as info 'r0*r1)))))
(info (free-register info))
(info (expr->register* a info))
(info (append-text info (wrap-as (append (as info 'swap-r0-r1)))))
(info (append-text info (wrap-as (as info 'r0-r1))))
(info (free-register info)))
info))))
((post-dec ,expr)
(let* ((info (expr->register* expr info))
(post (clone info #:text '()))
(post (allocate-register post))
(post (append-text post (wrap-as (as post 'r0->r1))))
(rank (expr->rank post expr))
(reg-size (->size "*" info))
(size (cond ((= rank 1) (ast-type->size post expr))
((> rank 1) reg-size)
(else 1)))
(post ((expr-add post) expr (- size))))
(clone info #:post (.text post))))
((post-inc ,expr)
(let* ((info (expr->register* expr info))
(post (clone info #:text '()))
(post (allocate-register post))
(post (append-text post (wrap-as (as post 'r0->r1))))
(rank (expr->rank post expr))
(reg-size (->size "*" info))
(size (cond ((= rank 1) (ast-type->size post expr))
((> rank 1) reg-size)
(else 1)))
(post ((expr-add post) expr size)))
(clone info #:post (.text post))))
((pre-dec ,expr)
(let* ((rank (expr->rank info expr))
(reg-size (->size "*" info))
(size (cond ((= rank 1) (ast-type->size info expr))
((> rank 1) reg-size)
(else 1)))
(info ((expr-add info) expr (- size)))
(info (append (expr->register* expr info))))
info))
((pre-inc ,expr)
(let* ((rank (expr->rank info expr))
(reg-size (->size "*" info))
(size (cond ((= rank 1) (ast-type->size info expr))
((> rank 1) reg-size)
(else 1)))
(info ((expr-add info) expr size))
(info (append (expr->register* expr info))))
info))
(_ (error "expr->register*: not supported: " o))))
(define (expr-add info)
(lambda (o n)
(let* ((info (expr->register* o info))
(size (ast->size o info))
(reg-size (->size "*" info))
(size (if (= size reg-size) 0 size))
(info (append-text info (wrap-as (append (as info
(case size
((0) 'r-mem-add)
((1) 'r-byte-mem-add)
((2) 'r-word-mem-add)
((4) 'r-long-mem-add)) n))))))
(free-register info))))
(define (expr->register o info)
(let* ((locals (.locals info))
(text (.text info))
(globals (.globals info))
(r-size (->size "*" info)))
(define (helper)
(pmatch o
((expr) info)
((comma-expr)
(allocate-register info))
((comma-expr ,a . ,rest)
(let* ((info (expr->register a info))
(info (free-register info)))
(expr->register `(comma-expr ,@rest) info)))
((p-expr (string ,string))
(let* ((globals ((globals:add-string globals) string))
(info (clone info #:globals globals))
(info (allocate-register info)))
(append-text info (wrap-as (as info 'label->r `(#:string ,string))))))
((p-expr (string . ,strings))
(let* ((string (apply string-append strings))
(globals ((globals:add-string globals) string))
(info (clone info #:globals globals))
(info (allocate-register info)))
(append-text info (wrap-as (as info 'label->r `(#:string ,string))))))
((p-expr (fixed ,value))
(let* ((value (cstring->int value))
(reg-size (->size "*" info))
(info (allocate-register info))
(info (append-text info (wrap-as (as info 'value->r value)))))
(if (or #t (> value 0) (= reg-size 4)) info
(append-text info (wrap-as (as info 'long-signed-r))))))
((p-expr (float ,value))
(let ((value (cstring->float value))
(info (allocate-register info)))
(append-text info (wrap-as (as info 'value->r value)))))
((neg (p-expr (fixed ,value)))
(let* ((value (- (cstring->int value)))
(info (allocate-register info))
(info (append-text info (append (wrap-as (as info 'value->r value)))))
(reg-size (->size "*" info)))
(if (or #t (> value 0) (= reg-size 4)) info
(append-text info (wrap-as (as info 'long-signed-r))))))
((p-expr (char ,char))
(let ((char (char->integer (car (string->list char))))
(info (allocate-register info)))
(append-text info (wrap-as (as info 'value->r char)))))
(,char (guard (char? char))
(let ((info (allocate-register info)))
(append-text info (wrap-as (as info 'value->r (char->integer char))))))
((p-expr (ident ,name))
(let ((info (allocate-register info)))
(append-text info ((ident->r info) name))))
((initzer ,initzer)
(expr->register initzer info))
(((initzer ,initzer))
(expr->register 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->basic-type struct info))
(offset (field-offset info type field))
(base (cstring->int base))
(info (allocate-register info)))
(append-text info (wrap-as (as info 'value->r (+ base offset))))))
;; &foo
((ref-to (p-expr (ident ,name)))
(let ((info (allocate-register info)))
(append-text info ((ident-address->r info) name))))
;; &*foo
((ref-to (de-ref ,expr))
(expr->register expr info))
((ref-to ,expr)
(expr->register* expr info))
((sizeof-expr ,expr)
(let ((info (allocate-register info)))
(append-text info (wrap-as (as info 'value->r (ast->size expr info))))))
((sizeof-type ,type)
(let ((info (allocate-register info)))
(append-text info (wrap-as (as info 'value->r (ast->size type info))))))
((array-ref ,index ,array)
(let* ((info (expr->register* o info))
(type (ast->type o info)))
(append-text info (mem->r type info))))
((d-sel ,field ,struct)
(let* ((info (expr->register* o info))
(info (append-text info (ast->comment o)))
(type (ast->type o info))
(size (->size type info))
(array? (c-array? type)))
(if array? info
(append-text info (mem->r type info)))))
((i-sel ,field ,struct)
(let* ((info (expr->register* o info))
(info (append-text info (ast->comment o)))
(type (ast->type o info))
(size (->size type info))
(array? (c-array? type)))
(if array? info
(append-text info (mem->r type info)))))
((de-ref ,expr)
(let* ((info (expr->register expr info))
(type (ast->type o info)))
(append-text info (mem->r type info))))
((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 (allocate-register info))
(allocated (.allocated info))
(pushed (.pushed info))
(registers (.registers info))
(info (fold push-register info (cdr allocated)))
(reg-size (->size "*" info))
(info (if (cc-amd? info) (fold expr->arg info expr-list (iota (length expr-list)))
(fold-right expr->arg info expr-list (reverse (iota (length expr-list))))))
(info (clone info #:allocated '() #:pushed 0 #:registers (append (reverse allocated) registers)))
(n (length expr-list))
(info (if (not (assoc-ref locals name))
(begin
(when (and (not (assoc name (.functions info)))
(not (assoc name globals))
(not (equal? name (.function info))))
(format (current-error-port) "warning: undeclared function: ~a\n" name))
(append-text info (wrap-as (as info 'call-label name n))))
(let* ((info (expr->register `(p-expr (ident ,name)) info))
(info (append-text info (wrap-as (as info 'call-r n)))))
info)))
(info (clone info #:allocated allocated #:pushed pushed #:registers registers))
(info (if (null? (cdr allocated)) info
(append-text info (wrap-as (as info 'return->r)))))
(info (fold-right pop-register info (cdr allocated))))
info)))
((fctn-call ,function (expr-list . ,expr-list))
(let* ((info (append-text info (ast->comment o)))
(info (allocate-register info))
(allocated (.allocated info))
(pushed (.pushed info))
(registers (.registers info))
(info (fold push-register info (cdr allocated)))
(reg-size (->size "*" info))
(info (if (cc-amd? info) (fold expr->arg info expr-list (iota (length expr-list)))
(fold-right expr->arg info expr-list (reverse (iota (length expr-list))))))
(info (fold (lambda (x info) (free-register info)) info (.allocated info)))
(n (length expr-list))
(function (pmatch function
((de-ref ,function) function)
(_ function)))
(info (expr->register function info))
(info (append-text info (wrap-as (as info 'call-r n))))
(info (free-register info))
(info (clone info #:allocated allocated #:pushed pushed #:registers registers))
(info (if (null? (cdr allocated)) info
(append-text info (wrap-as (as info 'return->r)))))
(info (fold-right pop-register info (cdr allocated))))
info))
((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 (expr->register then info))
(info (free-register info))
(info (append-text info (wrap-as (as info 'jump break-label))))
(info (append-text info (wrap-as `((#:label ,else-label)))))
(info (expr->register else info))
(info (free-register info))
(info (append-text info (wrap-as `((#:label ,break-label)))))
(info (allocate-register info)))
info))
((post-inc ,expr)
(let* ((info (append (expr->register expr info)))
(rank (expr->rank info expr))
(reg-size (->size "*" info))
(size (cond ((= rank 1) (ast-type->size info expr))
((> rank 1) reg-size)
(else 1)))
(info ((expr-add info) expr size)))
info))
((post-dec ,expr)
(let* ((info (append (expr->register expr info)))
(rank (expr->rank info expr))
(reg-size (->size "*" info))
(size (cond ((= rank 1) (ast-type->size info expr))
((> rank 1) reg-size)
(else 1)))
(info ((expr-add info) expr (- size))))
info))
((pre-inc ,expr)
(let* ((rank (expr->rank info expr))
(reg-size (->size "*" info))
(size (cond ((= rank 1) (ast-type->size info expr))
((> rank 1) reg-size)
(else 1)))
(info ((expr-add info) expr size))
(info (append (expr->register expr info))))
info))
((pre-dec ,expr)
(let* ((rank (expr->rank info expr))
(reg-size (->size "*" info))
(size (cond ((= rank 1) (ast-type->size info expr))
((> rank 1) reg-size)
(else 1)))
(info ((expr-add info) expr (- size)))
(info (append (expr->register expr info))))
info))
((add ,a (p-expr (fixed ,value)))
(let* ((rank (expr->rank info a))
(type (ast->basic-type a info))
(struct? (structured-type? type))
(reg-size (->size "*" info))
(size (cond ((= rank 1) (ast-type->size info a))
((> rank 1) reg-size)
((and struct? (= rank 2)) reg-size)
(else 1)))
(info (expr->register a info))
(value (cstring->int value))
(value (* size value)))
(append-text info (wrap-as (as info 'r+value value)))))
((add ,a ,b)
(let* ((rank (expr->rank info a))
(rank-b (expr->rank info b))
(type (ast->basic-type a info))
(struct? (structured-type? type))
(reg-size (->size "*" info))
(size (cond ((= rank 1) (ast-type->size info a))
((> rank 1) reg-size)
((and struct? (= rank 2)) reg-size)
(else 1))))
(if (or (= size 1)) ((binop->r info) a b 'r0+r1)
(let* ((info (expr->register b info))
(info (allocate-register info))
(info (append-text info (wrap-as (append (as info 'value->r size)
(as info 'r0*r1)))))
(info (free-register info))
(info (expr->register a info))
(info (append-text info (wrap-as (as info 'r0+r1))))
(info (free-register info)))
info))))
((sub ,a (p-expr (fixed ,value)))
(let* ((rank (expr->rank info a))
(type (ast->basic-type a info))
(struct? (structured-type? type))
(size (->size type info))
(reg-size (->size "*" info))
(size (cond ((= rank 1) size)
((> rank 1) reg-size)
((and struct? (= rank 2)) reg-size)
(else 1)))
(info (expr->register a info))
(value (cstring->int value))
(value (* size value)))
(append-text info (wrap-as (as info 'r+value (- value))))))
((sub ,a ,b)
(let* ((rank (expr->rank info a))
(rank-b (expr->rank info b))
(type (ast->basic-type a info))
(struct? (structured-type? type))
(size (->size type info))
(reg-size (->size "*" info))
(size (cond ((= rank 1) size)
((> rank 1) reg-size)
((and struct? (= rank 2)) reg-size)
(else 1))))
(if (or (= size 1) (or (= rank-b 2) (= rank-b 1)))
(let ((info ((binop->r info) a b 'r0-r1)))
(if (and (not (= rank-b 2)) (not (= rank-b 1))) info
;; FIXME: c&p 792
(let* ((info (allocate-register info))
(info (append-text info (wrap-as (append (as info 'value->r size)
(as info 'r0/r1 #f)))))
(info (free-register info)))
info)))
(let* ((info (expr->register b info))
(info (allocate-register info))
(info (append-text info (wrap-as (append (as info 'value->r size)
(as info 'r0*r1)))))
(info (free-register info))
(info (expr->register a info))
(info (append-text info (wrap-as (append (as info 'swap-r0-r1)))))
(info (append-text info (wrap-as (as info 'r0-r1))))
(info (free-register info)))
info))))
((bitwise-and ,a ,b) ((binop->r info) a b 'r0-and-r1))
((bitwise-not ,expr)
(let ((info (expr->register expr info)))
(append-text info (wrap-as (as info 'not-r)))))
((bitwise-or ,a ,b) ((binop->r info) a b 'r0-or-r1))
((bitwise-xor ,a ,b) ((binop->r info) a b 'r0-xor-r1))
((lshift ,a ,b)
(let* ((type-a (ast->type a info))
(default (get-type "default" info))
(type (if (> (->size type-a info) (->size default info)) type-a
default))
(info ((binop->r info) a b 'r0<<r1)))
(append-text info (convert-r0 info type))))
((rshift ,a ,b)
(let* ((type-a (ast->type a info))
(default (get-type "default" info))
(type (if (> (->size type-a info) (->size default info)) type-a
default))
(info ((binop->r info) a b (if (signed? type) 'r0>>r1-signed 'r0>>r1))))
(append-text info (convert-r0 info type))))
((div ,a ,b)
((binop->r info) a b 'r0/r1
(signed? (ast->type a info))))
((mod ,a ,b) ((binop->r info) a b 'r0%r1
(signed? (ast->type a info))))
((mul ,a ,b) ((binop->r info) a b 'r0*r1))
((not ,expr)
(let* ((info (expr->register expr info))
(info (append-text info (wrap-as (as info 'test-r))))
(info (append-text info (wrap-as (as info 'r-negate)))))
(append-text info (wrap-as (as info 'test-r))))) ;; hmm, use ast->info?
((pos ,expr)
(expr->register expr info))
((neg ,expr)
(let* ((info (expr->register expr info))
(info (allocate-register info))
(info (append-text info (append (wrap-as (as info 'value->r 0))
(wrap-as (as info 'swap-r0-r1))
(wrap-as (as info 'r0-r1)))))
(info (free-register info)))
info))
((eq ,a ,b) (let ((info ((binop->r info) a b 'r0-cmp-r1)))
(append-text info (wrap-as (as info 'zf->r)))))
((ge ,a ,b)
(let* ((type-a (ast->type a info))
(type-b (ast->type b info))
(info ((binop->r info) a b 'r0-cmp-r1))
(test->r (if (or (unsigned? type-a) (unsigned? type-b)) 'ae?->r 'ge?->r))
(info (append-text info (wrap-as (as info test->r))))
(info (append-text info (wrap-as (as info 'test-r)))))
info))
((gt ,a ,b)
(let* ((type-a (ast->type a info))
(type-b (ast->type b info))
(info ((binop->r info) a b 'r0-cmp-r1))
(test->r (if (or (unsigned? type-a) (unsigned? type-b)) 'a?->r 'g?->r))
(info (append-text info (wrap-as (as info test->r))))
(info (append-text info (wrap-as (as info 'test-r)))))
info))
((ne ,a ,b) (let* ((info ((binop->r info) a b 'r0-r1))
(info (append-text info (wrap-as (as info 'test-r))))
(info (append-text info (wrap-as (as info 'xor-zf))))
(info (append-text info (wrap-as (as info 'zf->r)))))
info))
((le ,a ,b)
(let* ((type-a (ast->type a info))
(type-b (ast->type b info))
(info ((binop->r info) a b 'r0-cmp-r1))
(test->r (if (or (unsigned? type-a) (unsigned? type-b)) 'be?->r 'le?->r))
(info (append-text info (wrap-as (as info test->r))))
(info (append-text info (wrap-as (as info 'test-r)))))
info))
((lt ,a ,b)
(let* ((type-a (ast->type a info))
(type-b (ast->type b info))
(info ((binop->r info) a b 'r0-cmp-r1))
(test->r (if (or (unsigned? type-a) (unsigned? type-b)) 'b?->r 'l?->r))
(info (append-text info (wrap-as (as info test->r))))
(info (append-text info (wrap-as (as info 'test-r)))))
info))
((or ,a ,b)
(let* ((info (expr->register 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 (as info 'test-r))))
(info (append-text info (wrap-as (as info 'jump-nz skip-b-label))))
(info (append-text info (wrap-as (as info 'test-r))))
(info (free-register info))
(info (expr->register b info))
(info (append-text info (wrap-as (as info 'test-r))))
(info (append-text info (wrap-as `((#:label ,skip-b-label))))))
info))
((and ,a ,b)
(let* ((info (expr->register 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 (as info 'test-r))))
(info (append-text info (wrap-as (as info 'jump-z skip-b-label))))
(info (append-text info (wrap-as (as info 'test-r))))
(info (free-register info))
(info (expr->register b info))
(info (append-text info (wrap-as (as info 'test-r))))
(info (append-text info (wrap-as `((#:label ,skip-b-label))))))
info))
((cast ,type ,expr)
(let ((info (expr->register expr info))
(type (ast->type o info)))
(append-text info (convert-r0 info type))))
((assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op ,op) ,b)
(let* ((info (expr->register `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b) info))
(type (ident->type info name))
(rank (ident->rank info name))
(reg-size (->size "*" info))
(size (cond ((= rank 1) (ast-type->size info `(p-expr (ident ,name))))
((> rank 1) reg-size)
(else 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->register `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b) info))
(type (ident->type info name))
(rank (ident->rank info name))
(reg-size (->size "*" info))
(size (cond ((= rank 1) (ast-type->size info `(p-expr (ident ,name))))
((> rank 1) reg-size)
(else 1))))
(append-text info ((ident-add info) name (- size)))))
((assn-expr ,a (op ,op) ,b)
(let* ((info (append-text info (ast->comment o)))
(type (ast->type a info))
(rank (->rank type))
(type-b (ast->type b info))
(rank-b (->rank type-b))
(reg-size (->size "*" info))
(size (if (zero? rank) (->size type info) reg-size))
(size-b (if (zero? rank-b) (->size type-b info) reg-size))
(info (expr->register b info))
(info (if (equal? op "=") info
(let* ((struct? (structured-type? type))
(size (cond ((= rank 1) (ast-type->size info a))
((> rank 1) reg-size)
((and struct? (= rank 2)) reg-size)
(else 1)))
(info (if (or (= size 1) (= rank-b 1)) info
(let* ((info (allocate-register info))
(info (append-text info (wrap-as (as info 'value->r size))))
(info (append-text info (wrap-as (as info 'r0*r1))))
(info (free-register info)))
info)))
(info (expr->register a info))
(info (append-text info (wrap-as (as info 'swap-r0-r1))))
(signed? (signed? type))
(info (append-text info (cond ((equal? op "+=") (wrap-as (as info 'r0+r1)))
((equal? op "-=") (wrap-as (as info 'r0-r1)))
((equal? op "*=") (wrap-as (as info 'r0*r1)))
((equal? op "/=") (wrap-as (as info 'r0/r1 signed?)))
((equal? op "%=") (wrap-as (as info 'r0%r1 signed?)))
((equal? op "&=") (wrap-as (as info 'r0-and-r1)))
((equal? op "|=") (wrap-as (as info 'r0-or-r1)))
((equal? op "^=") (wrap-as (as info 'r0-xor-r1)))
((equal? op ">>=") (wrap-as (as info (if signed? 'r0>>r1-signed 'r0>>r1))))
((equal? op "<<=") (wrap-as (as info 'r0<<r1)))
(else (error (format #f "mescc: op ~a not supported: ~a\n" op o))))))
(info (free-register info)))
(cond ((not (and (= rank 1) (= rank-b 1))) info)
((equal? op "-=") (let* ((info (allocate-register info))
(info (append-text info (wrap-as (append (as info 'value->r size)
(as info 'r0/r1 signed?)))))
(info (free-register info)))
info))
(else (error (format #f "invalid operands to binary ~s (have ~s* and ~s*) " op type (ast->basic-type b info)))))))))
(when (and (equal? op "=")
(not (= size size-b))
(not (and (or (= size 1) (= size 2))
(or (= size-b 2) (= size-b 4) (= size-b reg-size))))
(not (and (= size 2)
(= size-b 4)))
(not (and (= size 2)
(= size-b reg-size)))
(not (and (= size reg-size)
(or (= size-b 1) (= size-b 2) (= size-b 4)))))
(format (current-error-port) "ERROR assign: ~a" (with-output-to-string (lambda () (pretty-print-c99 o))))
(format (current-error-port) " size[~a]:~a != size[~a]:~a\n" rank size rank-b size-b))
(pmatch a
((p-expr (ident ,name))
(if (or (<= size r-size)
(<= size-b r-size)) (append-text info ((r->ident info) name))
(let* ((info (expr->register* a info))
(info (r0->r1-mem*n info size size-b)))
(free-register info))))
(_ (let* ((info (expr->register* a info))
(reg-size (->size "*" info))
(info (if (not (bit-field? type)) info
(let* ((bit (bit-field:bit type))
(bits (bit-field:bits type))
(set-mask (- (ash bits 1) 1))
(shifted-set-mask (ash set-mask bit))
(clear-mask (logxor shifted-set-mask
(if (= reg-size 4)
#b11111111111111111111111111111111
#b1111111111111111111111111111111111111111111111111111111111111111)))
(info (append-text info (wrap-as (as info 'swap-r0-r1))))
(info (allocate-register info))
(info (append-text info (wrap-as (as info 'r2->r0))))
(info (append-text info (wrap-as (as info 'swap-r0-r1))))
(info (append-text info (wrap-as (as info 'mem->r))))
(info (append-text info (wrap-as (as info 'r-and clear-mask))))
(info (append-text info (wrap-as (as info 'swap-r0-r1))))
(info (append-text info (wrap-as (as info 'r-and set-mask))))
(info (append-text info (wrap-as (as info 'shl-r bit))))
(info (append-text info (wrap-as (as info 'r0-or-r1))))
(info (free-register info))
(info (append-text info (wrap-as (as info 'swap-r0-r1)))))
info)))
(info (r0->r1-mem*n info
(min size (max reg-size size-b))
(min size (max reg-size size-b))))
(info (free-register info)))
info)))))
(_ (error "expr->register: not supported: " o))))
(let ((info (helper)))
(if (null? (.post info)) info
(append-text (clone info #:post '()) (.post info))))))
(define (mem->r type info)
(let* ((size (->size type info))
(reg-size (->size "*" info))
(size (if (= size reg-size) 0 size)))
(case size
((0) (wrap-as (as info 'mem->r)))
((1) (append (wrap-as (as info 'byte-mem->r)) (convert-r0 info type)))
((2) (append (wrap-as (as info 'word-mem->r)) (convert-r0 info type)))
((4) (append (wrap-as (as info 'long-mem->r)) (convert-r0 info type)))
(else '()))))
(define (convert-r0 info type)
(if (not (type? type)) '()
(let ((sign (signed? type))
(size (->size type info))
(reg-size (->size "*" info)))
(cond ((and (= size 1) sign)
(wrap-as (as info 'byte-signed-r)))
((= size 1)
(wrap-as (as info 'byte-r))
;;(wrap-as (as info 'byte-signed-r))
)
((and (= size 2) sign)
(wrap-as (as info 'word-signed-r)))
((= size 2)
(wrap-as (as info 'word-r))
;;(wrap-as (as info 'word-signed-r))
)
((and (> reg-size 4) (= size 4) sign)
(wrap-as (as info 'long-signed-r)))
((and (> reg-size 4) (= size 4))
;; for 17-unsigned-le
(wrap-as (as info 'long-signed-r)) ; huh, why not long-r?
;; for a0-call-trunc-int
;;(wrap-as (as info 'long-r))
)
(else '())))))
(define (binop->r info)
(lambda (a b c . rest)
(let* ((info (expr->register a info))
(info (expr->register b info))
(info (append-text info (wrap-as (apply as info (cons c rest))))))
(free-register info))))
(define (binop->r* info)
(lambda (a b c)
(let* ((info (expr->register* a info))
(info (expr->register b info))
(info (append-text info (wrap-as (as info c)))))
(free-register info))))
(define (wrap-as o . annotation)
`(,@annotation ,o))
(define (comment? o)
(and (pair? o) (pair? (car o)) (eq? (caar o) #:comment)))
(define (test-jump-label->info info label)
(define (jump type . test)
(lambda (o)
(let* ((info (expr->register o info))
(info (append-text info (make-comment "jmp test LABEL")))
(jump-text (wrap-as (as info type label)))
(info (append-text info (append (if (null? test) '() ((car test) info))
jump-text)))
(info (free-register info)))
info)))
(lambda (o)
(pmatch o
((expr) info)
((le ,a ,b) ((jump 'jump-z) o))
((lt ,a ,b) ((jump 'jump-z) o))
((ge ,a ,b) ((jump 'jump-z) o))
((gt ,a ,b) ((jump 'jump-z) o))
((ne ,a ,b) ((jump 'jump-nz) o))
((eq ,a ,b) ((jump 'jump-nz) o))
((not _) ((jump '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-or-reproducible? (.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 (as info '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* ((rank (expr->rank info expr))
(reg-size (->size "*" info))
(size (if (= rank 1) (ast-type->size info expr)
reg-size)))
((jump (if (= size 1) 'jump-byte-z
'jump-z)
(lambda (info) (wrap-as (as info 'r-zero?)))) o)))
((de-ref ,expr) (let* ((rank (expr->rank info expr))
(r-size (->size "*" info))
(size (if (= rank 1) (ast-type->size info expr)
r-size)))
((jump (if (= size 1) 'jump-byte-z
'jump-z)
(lambda (info) (wrap-as (as info 'r-zero?)))) o)))
((assn-expr (p-expr (ident ,name)) ,op ,expr)
((jump 'jump-z
(lambda (info)
(append ((ident->r info) name)
(wrap-as (as info 'r-zero?))))) o))
(_ ((jump 'jump-z (lambda (info) (wrap-as (as info 'r-zero?)))) o)))))
(define (cstring->int o)
(let ((o (cond ((string-suffix? "ULL" o) (string-drop-right o 3))
((string-suffix? "UL" o) (string-drop-right o 2))
((string-suffix? "U" o) (string-drop-right o 1))
((string-suffix? "LL" o) (string-drop-right o 2))
((string-suffix? "L" o) (string-drop-right o 1))
(else o))))
(or (cond ((string-prefix? "0x" o) (string->number (string-drop o 2) 16))
((string-prefix? "0b" o) (string->number (string-drop o 2) 2))
((string-prefix? "0" o) (string->number o 8))
(else (string->number o)))
(error "cstring->int: not supported:" o))))
(define (cstring->float o)
(or (string->number o)
(error "cstring->float: not supported:" o)))
(define (try-expr->number info o)
(pmatch o
((fixed ,a) (cstring->int a))
((p-expr ,expr) (expr->number info expr))
((pos ,a)
(expr->number info a))
((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)
(->size (ast->type type info) info))
((sizeof-expr ,expr)
(->size (ast->type expr info) info))
((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->int string))
((ident ,name) (assoc-ref (.constants info) name))
(_ #f)))
(define (expr->number info o)
(or (try-expr->number info o)
(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-def (ident ,name) (enum-def-list . ,fields)))) (comp-declr-list . ,decls))
(append-map (lambda (o)
((struct-field info) `(comp-decl (decl-spec-list (type-spec "int")) (comp-declr-list ,o))))
decls))
((comp-decl (decl-spec-list (type-spec ,type)) (comp-declr-list (comp-declr (ident ,name))))
(list (cons name (ast->type type info))))
((comp-decl (decl-spec-list (type-spec ,type)) (comp-declr-list (comp-declr (ptr-declr ,pointer (ident ,name)))))
(let ((rank (pointer->rank pointer)))
(list (cons name (rank+= (ast->type type info) rank)))))
((comp-decl (decl-spec-list (type-spec ,type)) (comp-declr-list (comp-declr (ftn-declr (scope (ptr-declr ,pointer (ident ,name))) _))))
(let ((rank (pointer->rank pointer)))
(list (cons name (rank+= (ast->type type info) rank)))))
((comp-decl (decl-spec-list (type-spec ,type)) (comp-declr-list (comp-declr (ptr-declr ,pointer (array-of (ident ,name) ,count)))))
(let ((rank (pointer->rank pointer))
(count (expr->number info count)))
(list (cons name (make-c-array (rank+= type rank) count)))))
((comp-decl (decl-spec-list (type-spec ,type)) (comp-declr-list (comp-declr (array-of (ident ,name) ,count))))
(let ((count (expr->number info count)))
(list (cons name (make-c-array (ast->type type info) count)))))
((comp-decl (decl-spec-list (type-spec (struct-def (field-list . ,fields)))))
(let ((fields (append-map (struct-field info) fields)))
(list (cons 'struct (make-type 'struct (apply + (map (cut field:size <> info) fields)) fields)))))
((comp-decl (decl-spec-list (type-spec (union-def (field-list . ,fields)))))
(let ((fields (append-map (struct-field info) fields)))
(list (cons 'union (make-type 'union (apply + (map (cut field:size <> info) fields)) fields)))))
((comp-decl (decl-spec-list (type-spec ,type)) (comp-declr-list (comp-declr (bit-field (ident ,name) (p-expr (fixed ,bits)))) . ,fields))
(let ((type (ast->type type info)))
(list (cons 'bits (let loop ((o `((comp-declr (bit-field (ident ,name) (p-expr (fixed ,bits)))) . ,fields)) (bit 0))
(if (null? o) '()
(let ((field (car o)))
(pmatch field
((comp-declr (bit-field (ident ,name) (p-expr (fixed ,bits))))
(let ((bits (cstring->int bits)))
(cons (cons name (make-bit-field type bit bits))
(loop (cdr o) (+ bit bits)))))
(_ (error "struct-field: not supported:" field o))))))))))
((comp-decl (decl-spec-list ,type) (comp-declr-list . ,decls))
(append-map (lambda (o)
((struct-field info) `(comp-decl (decl-spec-list ,type) (comp-declr-list ,o))))
decls))
(_ (error "struct-field: not supported: " o)))))
(define (local-var? o) ;; formals < 0, locals > 0
(positive? (local:id o)))
(define (ptr-declr->rank o)
(pmatch o
((pointer) 1)
((pointer (pointer)) 2)
((pointer (pointer (pointer))) 3)
(_ (error "ptr-declr->rank not supported: " o))))
(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 (as info 'jump label)))))
((continue)
(let ((label (car (.continue info))))
(append-text info (wrap-as (as info 'jump label)))))
;; FIXME: expr-stmt wrapper?
(trans-unit info)
((expr-stmt) info)
((compd-stmt (block-item-list . ,_))
(let* ((locals (.locals info))
(info (ast-list->info _ info)))
(clone info #:locals locals)))
((asm-expr ,gnuc (,null ,arg0 . string))
(append-text info (wrap-as (asm->m1 arg0))))
;; Nyacc 0.90.2
((asm-expr ,gnuc (string ,arg0))
(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 (expr->register `(fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)) info))
(info (free-register info))
(info (append-text info (wrap-as (as info 'r-zero?)))))
info)))
((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 (as info '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 (as info '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 (expr->register `(cond-expr ,test ,then ,else) info)))
(free-register info)))
((switch ,expr (compd-stmt (block-item-list . ,statements)))
(define (clause? o)
(pmatch o
((case . _) 'case)
((default . _) 'default)
((labeled-stmt _ ,statement) (clause? statement))
(_ #f)))
(define clause-number
(let ((i 0))
(lambda (o)
(let ((n i))
(when (clause? (car o))
(set! i (1+ i)))
n))))
(define (flatten-cases c)
(define (flatten-case o)
(pmatch o
((case ,test (case . ,body))
(cons `(case ,test (expr-stmt)) (flatten-case `(case ,@body))))
((case ,test ,case-body (case . ,body))
(cons `(case ,test ,case-body) (flatten-case `(case ,@body))))
((default (case . ,body))
(cons `(default (expr-stmt)) (flatten-case `(case ,@body))))
((default ,default-body (case . ,body))
(cons `(default ,default-body) (flatten-case `(case ,@body))))
((case ,test (default . ,body))
(cons `(case ,test (expr-stmt)) (flatten-case `(default ,@body))))
((default ,rest)
(list o))
((case ,test)
(list o))
((case ,test ,expr)
(list o))
(,s (list s))))
(fold (lambda (x acc) (append acc (flatten-case x))) '() c))
(let* ((info (append-text info (ast->comment `(switch ,expr (compd-stmt (block-item-list (ellipsis)))))))
(statements (flatten-cases statements))
(here (number->string (length text)))
(label (string-append "_" (.function info) "_" here "_"))
(break-label (string-append label "break"))
(info (expr->register expr info))
(info (clone info #:break (cons break-label (.break info))))
(count (length (filter clause? statements)))
(default? (find (cut eq? <> 'default) (map clause? statements)))
(info (fold (cut switch->info #t label (1- count) <> <> <>) info statements
(unfold null? clause-number cdr statements)))
(last-clause-label (string-append label "clause" (number->string count)))
(default-label (string-append label "default"))
(info (if (not default?) info
(append-text info (wrap-as (as info 'jump break-label)))))
(info (append-text info (wrap-as `((#:label ,last-clause-label)))))
(info (if (not default?) info
(append-text info (wrap-as (as info 'jump default-label)))))
(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 (as info '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 (if (equal? step '(expr)) info
(let ((info (expr->register step info)))
(free-register 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 (as info '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 (as info '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 (as info '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 (as info '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 (as info 'jump (string-append "_" (.function info) "_label_" label)))))
((return (expr))
(let ((info (fold (lambda (x info) (free-register info)) info (.allocated info))))
(append-text info (append (wrap-as (as info 'ret))))))
((return ,expr)
(let* ((info (fold (lambda (x info) (free-register info)) info (.allocated info)))
(info (expr->register expr info))
(info (free-register info)))
(append-text info (append (wrap-as (as info 'ret))))))
((decl . ,decl)
(let ((info (append-text info (ast->comment o))))
(decl->info info decl)))
((gt . _) (free-register (expr->register o info)))
((ge . _) (free-register (expr->register o info)))
((ne . _) (free-register (expr->register o info)))
((eq . _) (free-register (expr->register o info)))
((le . _) (free-register (expr->register o info)))
((lt . _) (free-register (expr->register o info)))
((lshift . _) (free-register (expr->register o info)))
((rshift . _) (free-register (expr->register o info)))
((expr-stmt ,expression)
(let* ((info (expr->register expression info))
(info (append-text info (wrap-as (as info 'r-zero?)))))
(fold (lambda (x info) (free-register info)) info (.allocated info))))
(_ (let* ((info (expr->register o info))
(info (append-text info (wrap-as (as info 'r-zero?)))))
(fold (lambda (x info) (free-register info)) info (.allocated info)))))))
(define (ast-list->info o info)
(fold ast->info info o))
(define (switch->info clause? label count o i info)
(let* ((i-string (number->string i))
(i+1-string (number->string (1+ i)))
(body-label (string-append label "body" i-string))
(clause-label (string-append label "clause" i-string))
(first? (= i 0))
(last? (= i count))
(break-label (string-append label "break"))
(next-clause-label (string-append label "clause" i+1-string))
(default-label (string-append label "default")))
(define (jump label)
(wrap-as (as info 'jump label)))
(pmatch o
((case ,test)
(define (jump-nz label)
(wrap-as (as info 'jump-nz label)))
(define (jump-z label)
(wrap-as (as info '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->int value))
((neg (p-expr (fixed ,value))) (- (cstring->int value)))
(_ (error "case test: not supported: " test)))))
(append (wrap-as (as info 'r-cmp-value value))
(jump-z body-label))))
(let ((info (if clause? (append-text info (wrap-as `((#:label ,clause-label))))
info)))
(append-text info (test->text test))))
((case ,test (default . ,rest))
(let ((info (if clause? (append-text info (wrap-as `((#:label ,clause-label))))
info)))
(fold (cut switch->info #f label count <> i <>) info (cons `(case ,test) `(default ,@rest)))))
((case ,test ,statement)
(let* ((info (if first? info (append-text info (jump body-label)))) ; Enables fallthrough
(info (if clause? (append-text info (wrap-as `((#:label ,clause-label))))
info))
(info (switch->info #f label count `(case ,test) i info))
(info (append-text info (jump next-clause-label)))
(info (append-text info (wrap-as `((#:label ,body-label)))))
(info (ast->info statement info)))
info))
((default (case . ,case1) . ,rest)
(let* ((info (if clause? (append-text info (wrap-as `((#:label ,clause-label))))
info))
(info (if last? info
(append-text info (jump next-clause-label))))
(info (append-text info (wrap-as `((#:label ,default-label)))))
(info (append-text info (jump body-label)))
(info (append-text info (wrap-as `((#:label ,body-label))))))
(fold (cut switch->info #f label count <> i <>) info `((case ,@case1) ,@rest))))
(default
(let* ((info (if clause? (append-text info (wrap-as `((#:label ,clause-label))))
info))
(info (if last? info
(append-text info (jump next-clause-label))))
(info (append-text info (wrap-as `((#:label ,default-label)))))
(info (append-text info (jump body-label)))
(info (append-text info (wrap-as `((#:label ,body-label))))))
info))
((default ,statement)
(let* ((info (if clause? (append-text info (wrap-as `((#:label ,clause-label))))
info))
(info (if last? info
(append-text info (jump next-clause-label))))
(info (append-text info (wrap-as `((#:label ,default-label)))))
(info (append-text info (wrap-as `((#:label ,body-label))))))
(ast->info statement info)))
((default ,statement ,rest)
(let* ((info (if clause? (append-text info (wrap-as `((#:label ,clause-label))))
info))
(info (if last? info
(append-text info (jump next-clause-label))))
(info (append-text info (wrap-as `((#:label ,default-label)))))
(info (append-text info (wrap-as `((#:label ,body-label))))))
(fold ast->info (ast->info statement info) rest)))
((labeled-stmt (ident ,goto-label) ,statement)
(let ((info (append-text info `(((#:label ,(string-append "_" (.function info) "_label_" goto-label)))))))
(switch->info clause? label count statement i info)))
(_ (ast->info o info)))))
(define (global->static function)
(lambda (o)
(cons (car o) (set-field (cdr o) (global:function) function))))
(define (decl->info info o)
(pmatch o
(((decl-spec-list (type-spec ,type)) (init-declr-list . ,inits))
(let* ((info (type->info type #f info))
(type (ast->type type info)))
(fold (cut init-declr->info type 'storage <> <>) info (map cdr inits))))
(((decl-spec-list (type-spec ,type)))
(type->info type #f info))
(((decl-spec-list (stor-spec (typedef)) (type-spec ,type)) (init-declr-list (init-declr (ident ,name))))
(let* ((info (type->info type name info))
(type (ast->type type info)))
(clone info #:types (acons name type (.types info)))))
;; FIXME: recursive types, pointer, array
(((decl-spec-list (stor-spec (typedef)) (type-spec ,type)) (init-declr-list (init-declr (array-of (ident ,name) ,count))))
(let* ((info (type->info type name info))
(type (ast->type type info))
(count (expr->number info count))
(type (make-c-array type count)))
(clone info #:types (acons name type (.types info)))))
(((decl-spec-list (stor-spec (typedef)) (type-spec ,type)) (init-declr-list (init-declr (ptr-declr ,pointer (ident ,name)))))
(let* ((info (type->info type name info))
(type (ast->type type info))
(rank (pointer->rank pointer))
(type (rank+= type rank)))
(clone info #:types (acons name type (.types info)))))
(((decl-spec-list (stor-spec (,store)) (type-spec ,type)) (init-declr-list . ,inits))
(let* ((info (type->info type #f info))
(type (ast->type type info))
(function (.function info)))
(if (not function) (fold (cut init-declr->info type store <> <>) info (map cdr inits))
(let* ((tmp (clone info #:function #f #:globals '()))
(tmp (fold (cut init-declr->info type store <> <>) tmp (map cdr inits)))
(statics (map (global->static function) (.globals tmp)))
(strings (filter string-global? (.globals tmp))))
(clone info #:globals (append (.globals info) strings)
#:statics (append statics (.statics info)))))))
(((decl-spec-list (stor-spec (,store)) (type-spec ,type)))
(type->info type #f info))
(((@ . _))
(format (current-error-port) "decl->info: skip: ~s\n" o)
info)
(_ (error "decl->info: not supported:" o))))
(define (ast->name o)
(pmatch o
((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))
((ptr-declr ,pointer (ident ,name)) name)
(_ (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->r o info)
(pmatch o
((initzer-list (initzer ,expr))
(expr->register expr info))
(((#:string ,string))
(expr->register `(p-expr (string ,string)) info))
((,number . _) (guard (number? number))
(expr->register `(p-expr (fixed 0)) info))
((,c . ,_) (guard (char? c))
info)
(_
(expr->register o info))))
(define (init-struct-field local field n init info)
(let* ((offset (field-offset info (local:type local) (car field)))
(size (field:size field info))
(offset (+ offset (* n size)))
(info (expr->register init info))
(info (allocate-register info))
(info (append-text info (local->r local info)))
(info (append-text info (wrap-as (as info 'r+value offset))))
(reg-size (->size "*" info))
(size (min size reg-size))
(info (r0->r1-mem*n info size size))
(info (free-register info))
(info (free-register info)))
info))
(define (init-struct-struct-field local type offset field init info)
(let* ((offset (+ offset (field-offset info type (car field))))
(size (field:size field info))
(info (expr->register init info))
(info (allocate-register info))
(info (append-text info (local->r local info)))
(info (append-text info (wrap-as (as info 'r+value offset))))
(reg-size (->size "*" info))
(size (min size reg-size))
(info (r0->r1-mem*n info size size))
(info (free-register info))
(info (free-register info)))
info))
(define (init-array-entry local index init info)
(let* ((type (local:type local))
(size (cond ((pointer? type) (->size "*" info))
((and (c-array? type) ((compose pointer? c-array:type) type)) (->size "*" info))
((c-array? type) ((compose type:size c-array:type) type))
(else (type:size type))))
(offset (* index size))
(info (expr->register init info))
(info (allocate-register info))
(info (append-text info (local->r local info)))
(info (append-text info (wrap-as (as info 'r+value offset))))
(reg-size (->size "*" info))
(size (min size reg-size))
(info (r0->r1-mem*n info size size))
(info (fold (lambda (x info) (free-register info)) info (.allocated info))))
info))
(define (init-local local o n info)
(pmatch o
(#f info)
((initzer ,init)
(init-local local init n info))
((initzer-list . ,inits)
(let ((local-type (local:type local)))
(cond ((structured-type? local)
(let* ((fields (struct->init-fields local-type))
(field+counts (let loop ((fields fields))
(if (null? fields) '()
(let* ((field (car fields))
(type (cdr field)))
(cond ((c-array? type)
(append (map
(lambda (i)
(let ((field (cons (car field) (c-array:type type))))
(cons field i)))
(iota (c-array:count type)))
(loop (cdr fields))))
(else
(cons (cons field 0) (loop (cdr fields))))))))))
(let loop ((field+counts field+counts) (inits inits) (info info))
(if (null? field+counts) info
(let* ((field (caaar field+counts))
(type (cdaar field+counts)))
(if (and (type? type)
(eq? (type:type type) 'struct))
(let* ((field-fields (type:description type))
(field-inits (list-head inits (max (length inits) (length field-fields))))
(missing (max 0 (- (length field-fields) (length field-inits))))
(field-inits+ (append field-inits (map (const '(p-expr (fixed "0"))) (iota missing))))
(offset (field-offset info local-type field))
;; (info (init-local local `(initzer-list ,field-inits) n info))
;; crap, howto recurse? -- would need new local for TYPE
;; just do two deep for now
(info (fold (cut init-struct-struct-field local type offset <> <> <>) info field-fields field-inits+)))
(loop (list-tail field+counts (min (length field+counts) (length field-fields)))
(list-tail inits (min (length field-inits) (length field-inits))) info))
(let* ((missing (max 0 (- (length field+counts) (length inits))))
(counts (map cdr field+counts))
(fields (map car field+counts))
(info (fold (cut init-struct-field local <> <> <> <>) info fields counts (append inits (map (const '(p-expr (fixed "0"))) (iota missing))))))
;; bah, loopme!
;;(loop (list-tail field+counts (length field-fields)) (list-tail inits (length field-inits)) info)
info)))))))
(else
(let* ((type (local:type local))
(type (if (c-array? type) (c-array:type type) type))
(size (->size type info)))
(fold (cut init-local local <> <> <>) info inits (iota (length inits) 0 size)))))))
(,string (guard (string? string))
(let ((inits (string->list string)))
(fold (cut init-array-entry local <> <> <>) info (iota (length inits)) inits)))
(((initzer (initzer-list . ,inits)))
(init-local local (car o) n info))
(() info)
(_ (let* ((info (init->r o info))
(info (append-text info (r->local+n-text info local n))))
(free-register info)))))
(define (local->info type 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 id))
(pointer (->rank (cdr local)))
(array? (or (and (c-array? type) type)
(and (pointer? type)
(c-array? (pointer:type type))
(pointer:type type))
(and (pointer? type)
(pointer? (pointer:type type))
(c-array? (pointer:type (pointer:type type)))
(pointer:type (pointer:type type)))))
(struct? (structured-type? type))
(size (->size type info))
(string (and array? (array-init->string init)))
(init (or string init))
(reg-size (->size "*" info))
(local (if (not array?) local
(let ((size (or (and string (max size (1+ (string-length string))))
size)))
(make-local-entry name type (+ (local:id (cdr local)) -1 (quotient (+ size (1- reg-size)) reg-size))))))
(local (if struct? (make-local-entry name type (+ (local:id (cdr local)) (quotient (+ size (1- reg-size)) reg-size)))
local))
(locals (cons local locals))
(info (clone info #:locals locals))
(local (cdr local)))
(init-local local init 0 info)))
(define (global->info storage type name o init info)
(let* ((rank (->rank type))
(size (->size type info))
(data (cond ((not init) (string->list (make-string size #\nul)))
((c-array? type)
(let* ((string (array-init->string init))
(size (or (and string (max size (1+ (string-length string))))
size))
(data (or (and=> string string->list)
(array-init->data type size init info))))
(append data (string->list (make-string (max 0 (- size (length data))) #\nul)))))
((structured-type? type)
(let ((data (init->data type init info)))
(append data (string->list (make-string (max 0 (- size (length data))) #\nul)))))
(else
(let ((data (init->data type init info)))
(append data (string->list (make-string (max 0 (- size (length data))) #\nul)))))))
(global (make-global-entry name storage type data)))
(clone info #:globals (append (.globals info) (list global)))))
(define (array-init-element->data type o info)
(pmatch o
((initzer (p-expr (string ,string)))
(let ((reg-size (->size "*" info)))
(if (= reg-size 8) `((#:string ,string) "%0")
`((#:string ,string)))))
((initzer (p-expr (fixed ,fixed)))
(if (structured-type? type)
(let ((fields (map cdr (struct->init-fields type))))
(int->bv type (expr->number info fixed) info))
(int->bv type (expr->number info fixed) info)))
((initzer (initzer-list . ,inits))
(cond ((structured-type? type)
(let* ((fields (map cdr (struct->init-fields type)))
(missing (max 0 (- (length fields) (length inits))))
(inits (append inits
(map (const '(fixed "0")) (iota missing)))))
(map (cut array-init-element->data <> <> info) fields inits)))
((c-array? type)
(let* ((missing (max 0 (- (c-array:count type) (length inits))))
(inits (append inits
(map (const '(fixed "0")) (iota missing)))))
(map (cut array-init-element->data (c-array:type type) <> info) inits)))
(else
(format (current-error-port) "array-init-element->data: oops:~s\n" o)
(format (current-error-port) "type:~s\n" type)
(error "array-init-element->data: not supported: " o))))
(_ (init->data type o info))
(_ (error "array-init-element->data: not supported: " o))))
(define (array-init->data type size o info)
(pmatch o
((initzer (initzer-list . ,inits))
(let ((type (c-array:type type)))
(if (structured-type? type)
(let* ((init-fields (struct->init-fields type)) ;; FIXME
(count (length init-fields)))
(let loop ((inits inits))
(if (null? inits) '()
(let ((init (car inits)))
(pmatch init
((initzer (initzer-list . ,car-inits))
(append (array-init-element->data type init info)
(loop (cdr inits))))
(_
(let* ((count (min (length inits) (length init-fields)))
(field-inits (list-head inits count)))
(append (array-init-element->data type `(initzer-list ,@field-inits) info)
(loop (list-tail inits count))))))))))
(map (cut array-init-element->data type <> info) inits))))
(((initzer (initzer-list . ,inits)))
(array-init->data type size (car o) info))
((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))))
(array-init->data type size (car o) info))
((initzer (p-expr (string . ,strings)))
(let ((data (string->list (apply string-append strings))))
(if (not size) data
(append data (string->list (make-string (max 0 (- size (length data))) #\nul))))))
(((initzer (p-expr (string . ,strings))))
(array-init->data type size (car o) info))
((initzer (p-expr (fixed ,fixed)))
(int->bv type (expr->number info fixed) info))
(() (string->list (make-string size #\nul)))
(_ (error "array-init->data: not supported: " o))))
(define (array-init->string o)
(pmatch o
((p-expr (string ,string)) string)
((p-expr (string . ,strings)) (apply string-append strings))
((initzer ,init) (array-init->string init))
(((initzer ,init)) (array-init->string init))
((initzer-list (initzer (p-expr (char ,c))) . ,inits)
(list->string (map (lambda (i) (pmatch i
((initzer (p-expr (char ,c))) ((compose car string->list) c))
((initzer (p-expr (fixed ,fixed)))
(let ((value (cstring->int fixed)))
(if (and (>= value 0) (<= value 255))
(integer->char value)
(error "array-init->string: not supported:" i o))))
(_ (error "array-init->string: not supported:" i o))))
(cdr o))))
(_ #f)))
(define (init-declr->info type storage o info)
(pmatch o
(((ident ,name))
(if (.function info) (local->info type name o #f info)
(global->info storage type 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)))))
(if (.function info) (local->info type name o init info)
(global->info storage type name o init info))))
(((ftn-declr (ident ,name) . ,_))
(let ((functions (.functions info)))
(if (member name functions) info
(let ((function (make-function name type #f)))
(clone info #:functions (cons (cons name function) functions))))))
(((ftn-declr (scope (ptr-declr ,pointer (ident ,name))) ,param-list) ,init)
(let* ((rank (pointer->rank pointer))
(type (rank+= type rank)))
(if (.function info) (local->info type name o init info)
(global->info storage type name o init info))))
(((ftn-declr (scope (ptr-declr ,pointer (ident ,name))) ,param-list))
(let* ((rank (pointer->rank pointer))
(type (rank+= type rank)))
(if (.function info) (local->info type name o '() info)
(global->info storage type name o '() info))))
(((ptr-declr ,pointer . ,_) . ,init)
(let* ((rank (pointer->rank pointer))
(type (rank+= type rank)))
(init-declr->info type storage (append _ init) info)))
(((array-of (ident ,name) ,count) . ,init)
(let* ((strings (init->strings init info))
(info (if (null? strings) info
(clone info #:globals (append (.globals info) strings))))
(count (expr->number info count))
(type (make-c-array type count)))
(if (.function info) (local->info type name o init info)
(global->info storage type 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))))
(count (length (cadar init)))
(type (make-c-array type count)))
(if (.function info) (local->info type name o init info)
(global->info storage type name o init info))))
;; FIXME: recursion
(((array-of (array-of (ident ,name) ,count1) ,count) . ,init)
(let* ((strings (init->strings init info))
(info (if (null? strings) info
(clone info #:globals (append (.globals info) strings))))
(count (expr->number info count))
(count1 (expr->number info count1))
(type (make-c-array (make-c-array type count1) count)))
(if (.function info) (local->info type name o init info)
(global->info storage type 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 type o info)
(pmatch o
((p-expr ,expr) (init->data type expr info))
((fixed ,fixed) (int->bv type (expr->number info o) info))
((char ,char) (int->bv type (char->integer (string-ref char 0)) info))
((string ,string)
(let ((reg-size (->size "*" info)))
(if (= reg-size 8) `((#:string ,string) "%0")
`((#:string ,string)))))
((string . ,strings)
(let ((reg-size (->size "*" info)))
(if (= reg-size 8) `((#:string ,(string-join strings "")) "%0")
`((#:string ,(string-join strings ""))))))
((ident ,name) (let ((var (ident->variable info name)))
(if (number? var) (int->bv type var info)
`((#:address ,var)))))
((initzer-list . ,inits)
(cond ((structured-type? type)
(map (cut init->data <> <> info) (map cdr (struct->init-fields type)) inits))
((c-array? type)
(let ((size (->size type info)))
(array-init->data type size `(initzer ,o) info)))
(else
(append-map (cut init->data type <> info) inits))))
(((initzer (initzer-list . ,inits)))
(init->data type `(initzer-list . ,inits) info))
((ref-to (p-expr (ident ,name)))
(let ((var (ident->variable info name))
(reg-size (->size "*" info)))
`((#:address ,var)
,@(if (= reg-size 8) '((#:address 0))
'()))))
((ref-to (i-sel (ident ,field) (cast (type-name (decl-spec-list ,struct) (abs-declr (pointer))) (p-expr (fixed ,base)))))
(let* ((type (ast->type struct info))
(offset (field-offset info type field))
(base (cstring->int base)))
(int->bv type (+ base offset) info)))
((,char . _) (guard (char? char)) o)
((,number . _) (guard (number? number))
(append (map (cut int->bv <> <> info) type o)))
((initzer ,init) (init->data type init info))
(((initzer ,init)) (init->data type init info))
((cast _ ,expr) (init->data type expr info))
(() '())
(_ (let ((number (try-expr->number info o)))
(cond (number (int->bv type number info))
(else (error "init->data: not supported: " o)))))))
(define (int->bv type o info)
(let ((size (->size type info)))
(case size
((1) (int->bv8 o))
((2) (int->bv16 o))
((4) (int->bv32 o))
((8) (int->bv64 o))
(else (int->bv64 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 ,init))
(init->strings init info))
((initzer-list . ,init)
(append-map (cut init->strings <> info) init))
(_ '()))))
(define (type->info o name info)
(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)))))
((enum-def (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 (field-list . ,fields))
(mescc:trace name " <t>")
(let* ((info (fold field->info info fields))
(type-entry (struct->type-entry info name (append-map (struct-field info) fields))))
(clone info #:types (cons type-entry (.types info)))))
((struct-def (ident ,name) (field-list . ,fields))
(mescc:trace name " <t>")
(let* ((info (fold field->info info fields))
(type-entry (struct->type-entry info name (append-map (struct-field info) fields))))
(clone info #:types (cons type-entry (.types info)))))
((union-def (ident ,name) (field-list . ,fields))
(mescc:trace name " <t>")
(let ((type-entry (union->type-entry info name (append-map (struct-field info) fields))))
(clone info #:types (cons type-entry (.types info)))))
((union-def (field-list . ,fields))
(mescc:trace name " <t>")
(let ((type-entry (union->type-entry info name (append-map (struct-field info) fields))))
(clone info #:types (cons type-entry (.types info)))))
((enum-ref . _) info)
((struct-ref . _) info)
((typename ,name) info)
((union-ref . _) info)
((fixed-type . _) info)
((float-type . _) info)
((void) info)
(_ ;;(error "type->info: not supported:" o)
info
)))
(define (field->info o info)
(pmatch o
((comp-decl (decl-spec-list (type-spec (struct-def (ident ,name) (field-list . ,fields)))) . _)
(let* ((fields (append-map (struct-field info) fields))
(struct (make-type 'struct (apply + (map (cut field:size <> info) fields)) fields)))
(clone info #:types (acons `(tag ,name) struct (.types info)))))
((comp-decl (decl-spec-list (type-spec (union-def (ident ,name) (field-list . ,fields)))) . _)
(let* ((fields (append-map (struct-field info) fields))
(union (make-type 'union (apply + (map (cut field:size <> info) fields)) fields)))
(clone info #:types (acons `(tag ,name) union (.types info))) ))
((comp-decl (decl-spec-list (type-spec (enum-def (enum-def-list . ,fields)))) . _)
(let ((constants (enum-def-list->constants (.constants info) fields)))
(clone info
#:constants (append constants (.constants info)))))
((comp-decl (decl-spec-list (type-spec (enum-def (ident ,name) (enum-def-list . ,fields)))) . _)
(let ((constants (enum-def-list->constants (.constants info) fields))
(type-entry (enum->type-entry name fields)))
(clone info
#:types (cons type-entry (.types info))
#:constants (append constants (.constants info)))))
(_ 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)
((_ (ftn-declr (scope (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)) (ast->type type info))
((param-decl (decl-spec-list (type-spec ,type)) (param-declr (ptr-declr ,pointer (ident ,name))))
(let ((rank (pointer->rank pointer)))
(rank+= (ast->type type info) rank)))
((param-decl (decl-spec-list ,type) (param-declr (ptr-declr ,pointer (array-of _))))
(let ((rank (pointer->rank pointer)))
(rank+= (ast->type type info) (1+ rank))))
((param-decl ,type _) (ast->type type info))
(_ (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 info)
(pmatch o
((param-list . ,formals)
(let ((n (length formals)))
(wrap-as (append (as info 'function-preamble formals)
(append-map (formal->text n) formals (iota n))
(as info 'function-locals)))))
(_ (error "param-list->text: 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)
(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 type info))
(rank (ptr-declr->rank pointer)))
(if (zero? rank) type
(make-pointer type rank))))
(((decl-spec-list (stor-spec ,store) (type-spec ,type)) (ptr-declr ,pointer . _) ,statement)
(let* ((type (ast->type type info))
(rank (ptr-declr->rank pointer)))
(if (zero? rank) type
(make-pointer type rank))))
(((decl-spec-list (type-spec ,type)) . _)
(ast->type type info))
(((decl-spec-list (stor-spec ,store) (type-spec ,type)) . _)
(ast->type type info))
(_ (error "fctn-defn:get-type: not supported:" o))))
(define (fctn-defn:get-statement o)
(pmatch o
((_ (ftn-declr (ident _) _) ,statement) statement)
((_ (ftn-declr (scope (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 (as info '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 info))
(locals (param-list->locals formals info))
(statement (fctn-defn:get-statement o))
(function (cons name (make-function name type '())))
(functions (cons function (.functions info)))
(info (clone info #:locals locals #:function name #:text text #:functions functions #:statics '()))
(info (ast->info statement info))
(locals (.locals info))
(local (and (pair? locals) (car locals)))
(count (and=> local (compose local:id cdr)))
(reg-size (->size "*" info))
(stack (and count (* count reg-size))))
(if (and stack (getenv "MESC_DEBUG")) (format (current-error-port) " 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))))))))))
Reference in a new issue View git blame Copy permalink