1102 lines
40 KiB
Scheme
1102 lines
40 KiB
Scheme
;;; -*-scheme-*-
|
|
|
|
;;; Mes --- Maxwell Equations of Software
|
|
;;; Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
|
|
;;;
|
|
;;; This file is part of Mes.
|
|
;;;
|
|
;;; Mes is free software; you can redistribute it and/or modify it
|
|
;;; under the terms of the GNU General Public License as published by
|
|
;;; the Free Software Foundation; either version 3 of the License, or (at
|
|
;;; your option) any later version.
|
|
;;;
|
|
;;; Mes is distributed in the hope that it will be useful, but
|
|
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;;; GNU General Public License for more details.
|
|
;;;
|
|
;;; You should have received a copy of the GNU General Public License
|
|
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
;;; Commentary:
|
|
|
|
;;; compiler.mes produces an i386 binary from the C produced by
|
|
;;; Nyacc c99.
|
|
|
|
;;; Code:
|
|
|
|
(cond-expand
|
|
(guile-2
|
|
(set-port-encoding! (current-output-port) "ISO-8859-1"))
|
|
(guile)
|
|
(mes
|
|
(mes-use-module (nyacc lang c99 parser))
|
|
(mes-use-module (mes elf-util))
|
|
(mes-use-module (mes pmatch))
|
|
(mes-use-module (mes elf))
|
|
(mes-use-module (mes libc-i386))
|
|
(mes-use-module (mes optargs))))
|
|
|
|
(define (logf port string . rest)
|
|
(apply format (cons* port string rest))
|
|
(force-output port)
|
|
#t)
|
|
|
|
(define (stderr string . rest)
|
|
(apply logf (cons* (current-error-port) string rest)))
|
|
|
|
(define (gnuc-xdef? name mode) (if (equal? name "__GNUC__") #f (eq? mode 'code)))
|
|
|
|
(define (mescc)
|
|
(parse-c99
|
|
#:inc-dirs (string-split (getenv "C_INCLUDE_PATH") #\:)
|
|
#:cpp-defs '(
|
|
("__GNUC__" . "0")
|
|
("__NYACC__" . "1")
|
|
("VERSION" . "0.4")
|
|
("PREFIX" . "")
|
|
)
|
|
#:xdef? gnuc-xdef?
|
|
#:mode 'code
|
|
))
|
|
|
|
(define (write-any x)
|
|
(write-char (cond ((char? x) x)
|
|
((and (number? x) (< (+ x 256) 0)) (format (current-error-port) "***BROKEN*** x=~a\n" x) (integer->char #xaa))
|
|
((number? x) (integer->char (if (>= x 0) x (+ x 256))))
|
|
((procedure? x)
|
|
(stderr "write-any: proc: ~a\n" x)
|
|
(stderr " ==> ~a\n" (map dec->hex (x '() '() 0 0)))
|
|
barf)
|
|
(else (stderr "write-any: ~a\n" x) barf))))
|
|
|
|
(define (ast:function? o)
|
|
(and (pair? o) (eq? (car o) 'fctn-defn)))
|
|
|
|
(define (.name o)
|
|
(pmatch o
|
|
((fctn-defn _ (ftn-declr (ident ,name) _) _) name)
|
|
((fctn-defn _ (ptr-declr (pointer) (ftn-declr (ident ,name) _)) _) name)
|
|
((param-decl _ (param-declr (ident ,name))) name)
|
|
((param-decl _ (param-declr (ptr-declr (pointer) (ident ,name)))) name)
|
|
((param-decl _ (param-declr (ptr-declr (pointer) (array-of (ident ,name))))) name)
|
|
(_
|
|
(format (current-error-port) "SKIP .name =~a\n" o))))
|
|
|
|
(define (.statements o)
|
|
(pmatch o
|
|
((fctn-defn _ (ftn-declr (ident ,name) _) (compd-stmt (block-item-list . ,statements))) statements)
|
|
((fctn-defn _ (ptr-declr (pointer) (ftn-declr (ident ,name) _)) (compd-stmt (block-item-list . ,statements))) statements)))
|
|
|
|
(define <info> '<info>)
|
|
(define <functions> '<functions>)
|
|
(define <globals> '<globals>)
|
|
(define <locals> '<locals>)
|
|
(define <function> '<function>)
|
|
(define <text> '<text>)
|
|
(define* (make o #:key (functions '()) (globals '()) (locals '()) (function #f) (text '()))
|
|
(pmatch o
|
|
(<info> (list <info>
|
|
(cons <functions> functions)
|
|
(cons <globals> globals)
|
|
(cons <locals> locals)
|
|
(cons <function> function)
|
|
(cons <text> text)))))
|
|
|
|
(define (.functions o)
|
|
(pmatch o
|
|
((<info> . ,alist) (assq-ref alist <functions>))))
|
|
|
|
(define (.globals o)
|
|
(pmatch o
|
|
((<info> . ,alist) (assq-ref alist <globals>))))
|
|
|
|
(define (.locals o)
|
|
(pmatch o
|
|
((<info> . ,alist) (assq-ref alist <locals>))))
|
|
|
|
(define (.function o)
|
|
(pmatch o
|
|
((<info> . ,alist) (assq-ref alist <function>))))
|
|
|
|
(define (.text o)
|
|
(pmatch o
|
|
((<info> . ,alist) (assq-ref alist <text>))))
|
|
|
|
(define (info? o)
|
|
(and (pair? o) (eq? (car o) <info>)))
|
|
|
|
(define (clone o . rest)
|
|
(cond ((info? o)
|
|
(let ((functions (.functions o))
|
|
(globals (.globals o))
|
|
(locals (.locals o))
|
|
(function (.function o))
|
|
(text (.text o)))
|
|
(let-keywords rest
|
|
#f
|
|
((functions functions)
|
|
(globals globals)
|
|
(locals locals)
|
|
(function function)
|
|
(text text))
|
|
(make <info> #:functions functions #:globals globals #:locals locals #:function function #:text text))))))
|
|
|
|
(define (push-global-ref globals)
|
|
(lambda (o)
|
|
(lambda (f g t d)
|
|
(i386:push-global-ref (+ (data-offset o g) d)))))
|
|
|
|
(define (push-global globals)
|
|
(lambda (o)
|
|
(lambda (f g t d)
|
|
(i386:push-global (+ (data-offset o g) d)))))
|
|
|
|
(define (push-ident globals locals)
|
|
(lambda (o)
|
|
(let ((local (assoc-ref locals o)))
|
|
(if local (i386:push-local local)
|
|
((push-global globals) o)))))
|
|
|
|
(define (push-ident-ref globals locals)
|
|
(lambda (o)
|
|
(let ((local (assoc-ref locals o)))
|
|
(if local (i386:push-local-ref local)
|
|
((push-global-ref globals) o)))))
|
|
|
|
(define (expr->arg info) ;; FIXME: get Mes curried-definitions
|
|
(lambda (o)
|
|
(pmatch o
|
|
((p-expr (fixed ,value)) (cstring->number value))
|
|
((p-expr (string ,string)) ((push-global-ref (.globals info)) string))
|
|
((p-expr (ident ,name))
|
|
((push-ident (.globals info) (.locals info)) name))
|
|
|
|
((array-refo (p-expr (fixed ,value)) (p-expr (ident ,name)))
|
|
(let ((value (cstring->number value))
|
|
(size 4)) ;; FIXME: type: int
|
|
(lambda (f g t d)
|
|
(append
|
|
((ident->base (.locals info)) name)
|
|
(i386:value->accu (* size value)) ;; FIXME: type: int
|
|
(i386:base-mem->accu) ;; FIXME: type: int
|
|
(i386:push-accu) ;; hmm
|
|
))))
|
|
((ref-to (p-expr (ident ,name)))
|
|
(lambda (f g t d)
|
|
((push-ident-ref (.globals info) (.locals info)) name)))
|
|
((cast (type-name (decl-spec-list (type-spec (fixed-type _)))
|
|
(abs-declr (pointer)))
|
|
,cast)
|
|
((expr->arg info) cast))
|
|
(_
|
|
(format (current-error-port) "SKIP expr->arg=~a\n" o)
|
|
0))))
|
|
|
|
(define (ident->accu info)
|
|
(lambda (o)
|
|
(let ((local (assoc-ref (.locals info) o)))
|
|
(if local
|
|
(list (lambda (f g t d)
|
|
(i386:local->accu local)))
|
|
(list (lambda (f g t d)
|
|
(i386:global->accu (+ (data-offset o g) d))))))))
|
|
|
|
(define (accu->ident info)
|
|
(lambda (o)
|
|
(let ((local (assoc-ref (.locals info) o)))
|
|
(if local
|
|
(list (lambda (f g t d)
|
|
(i386:accu->local local)))
|
|
(list (lambda (f g t d)
|
|
(i386:accu->global (+ (data-offset o g) d))))))))
|
|
|
|
(define (value->ident info)
|
|
(lambda (o value)
|
|
(let ((local (assoc-ref (.locals info) o)))
|
|
(if local
|
|
(list (lambda (f g t d)
|
|
(i386:value->local local value)))
|
|
(list (lambda (f g t d)
|
|
(i386:value->global (+ (data-offset o g) d) value)))))))
|
|
|
|
(define (ident-address->accu info)
|
|
(lambda (o)
|
|
(let ((local (assoc-ref (.locals info) o)))
|
|
(if local
|
|
(list (lambda (f g t d)
|
|
(i386:local-address->accu local)))
|
|
(list (lambda (f g t d)
|
|
(i386:global->accu (+ (data-offset o g) d))))))))
|
|
|
|
(define (ident->base info)
|
|
(lambda (o)
|
|
(let ((local (assoc-ref (.locals info) o)))
|
|
(if local
|
|
(list (lambda (f g t d)
|
|
(i386:local->base local)))
|
|
(list (lambda (f g t d)
|
|
(i386:global->base (+ (data-offset o g) d))))))))
|
|
|
|
(define (expr->accu info)
|
|
(lambda (o)
|
|
(pmatch o
|
|
((p-expr (fixed ,value)) (cstring->number value))
|
|
((p-expr (ident ,name)) (car ((ident->accu info) name)))
|
|
((fctn-call . _) ((ast->info info) `(expr-stmt ,o)))
|
|
((not (fctn-call . _)) ((ast->info info) o))
|
|
((sub . _) ((ast->info info) o)) ;; FIXME: expr-stmt
|
|
((neg (p-expr (fixed ,value))) (- (cstring->number value)))
|
|
(_
|
|
(format (current-error-port) "SKIP expr->accu=~a\n" o)
|
|
0)
|
|
)))
|
|
|
|
(define (string->global string)
|
|
(cons string (append (string->list string) (list #\nul))))
|
|
|
|
(define (ident->global name value)
|
|
(cons name (int->bv32 value)))
|
|
|
|
(define (expr->global o)
|
|
(pmatch o
|
|
((p-expr (string ,string)) (string->global string))
|
|
(_ #f)))
|
|
|
|
(define (dec->hex o)
|
|
(number->string o 16))
|
|
|
|
(define (byte->hex o)
|
|
(string->number (string-drop o 2) 16))
|
|
|
|
(define (asm->hex o)
|
|
(let ((prefix ".byte "))
|
|
(if (not (string-prefix? prefix o)) (begin (stderr "SKIP:~a\n" o)'())
|
|
(let ((s (string-drop o (string-length prefix))))
|
|
(map byte->hex (string-split s #\space))))))
|
|
|
|
(define (test->jump->info info)
|
|
(define (jump type)
|
|
(lambda (o)
|
|
(let* ((text (.text info))
|
|
(info (clone info #:text '()))
|
|
(info ((ast->info info) o))
|
|
(jump-text (lambda (body-length)
|
|
(list (lambda (f g t d) (type body-length))))))
|
|
(lambda (body-length)
|
|
(clone info #:text
|
|
(append text
|
|
(.text info)
|
|
(jump-text body-length)))))))
|
|
(lambda (o)
|
|
(pmatch o
|
|
((lt ,a ,b) ((jump i386:jump-nc) o))
|
|
((gt ,a ,b) ((jump i386:jump-nc) o))
|
|
((ne ,a ,b) ((jump i386:jump-nz) o))
|
|
((eq ,a ,b) ((jump i386:jump-nz) o))
|
|
((not _) ((jump i386:jump-z) o))
|
|
((and ,a ,b)
|
|
(let* ((text (.text info))
|
|
(info (clone info #:text '()))
|
|
|
|
(a-jump ((test->jump->info info) a))
|
|
(a-text (.text (a-jump 0)))
|
|
(a-length (length (text->list a-text)))
|
|
|
|
(b-jump ((test->jump->info info) b))
|
|
(b-text (.text (b-jump 0)))
|
|
(b-length (length (text->list b-text))))
|
|
|
|
(lambda (body-length)
|
|
(clone info #:text
|
|
(append text
|
|
(.text (a-jump (+ b-length body-length)))
|
|
(.text (b-jump body-length)))))))
|
|
((array-ref . _) ((jump i386:jump-byte-z) o))
|
|
((de-ref _) ((jump i386:jump-byte-z) o))
|
|
(_ ((jump i386:jump-z) o)))))
|
|
|
|
(define (cstring->number s)
|
|
(if (string-prefix? "0" s) (string->number s 8)
|
|
(string->number s)))
|
|
|
|
(define (ast->info info)
|
|
(lambda (o)
|
|
(let ((globals (.globals info))
|
|
(locals (.locals info))
|
|
(text (.text info)))
|
|
(define (add-local name)
|
|
(let ((locals (acons name (1+ (length (filter positive? (map cdr locals)))) locals)))
|
|
locals))
|
|
|
|
;;(stderr "\nS=~a\n" o)
|
|
;; (stderr " text=~a\n" text)
|
|
;; (stderr " info=~a\n" info)
|
|
;; (stderr " globals=~a\n" globals)
|
|
(pmatch o
|
|
(((trans-unit . _) . _) ((ast-list->info info) o))
|
|
((trans-unit . ,elements) ((ast-list->info info) elements))
|
|
((fctn-defn . _) ((function->info info) o))
|
|
((comment . _) info)
|
|
((cpp-stmt (define (name ,name) (repl ,value)))
|
|
(stderr "SKIP: #define ~s ~s\n" name value)
|
|
info)
|
|
|
|
;; ;
|
|
((expr-stmt) info)
|
|
|
|
((compd-stmt (block-item-list . ,statements)) ((ast-list->info info) statements))
|
|
|
|
((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))
|
|
(if (equal? name "asm") (let ((arg0 (cadr (cadar expr-list)))) ;; FIXME
|
|
(clone info #:text (append text (list (lambda (f g t d) (asm->hex arg0))))))
|
|
(let* ((globals (append globals (filter-map expr->global expr-list)))
|
|
(info (clone info #:globals globals))
|
|
(args (map (expr->arg info) expr-list)))
|
|
(clone info #:text
|
|
(append text (list (lambda (f g t d)
|
|
(apply i386:call (cons* f g t d
|
|
(+ t (function-offset name f)) args)))))
|
|
#:globals globals))))
|
|
|
|
((if ,test ,body)
|
|
(let* ((text-length (length text))
|
|
|
|
(test-jump->info ((test->jump->info info) test))
|
|
(test+jump-info (test-jump->info 0))
|
|
(test-length (length (.text test+jump-info)))
|
|
|
|
(body-info ((ast->info test+jump-info) body))
|
|
(text-body-info (.text body-info))
|
|
(body-text (list-tail text-body-info test-length))
|
|
(body-length (length (text->list body-text)))
|
|
|
|
(text+test-text (.text (test-jump->info body-length)))
|
|
(test-text (list-tail text+test-text text-length)))
|
|
|
|
(clone info #:text
|
|
(append text
|
|
test-text
|
|
body-text)
|
|
#:globals (.globals body-info))))
|
|
|
|
((expr-stmt (cond-expr ,test ,then ,else))
|
|
(let* ((text-length (length text))
|
|
|
|
(test-jump->info ((test->jump->info info) test))
|
|
(test+jump-info (test-jump->info 0))
|
|
(test-length (length (.text test+jump-info)))
|
|
|
|
(then-info ((ast->info test+jump-info) then))
|
|
(text-then-info (.text then-info))
|
|
(then-text (list-tail text-then-info test-length))
|
|
(then-length (length (text->list then-text)))
|
|
|
|
(jump-text (list (lambda (f g t d) (i386:jump 0))))
|
|
(jump-length (length (text->list jump-text)))
|
|
(test+then+jump-info
|
|
(clone then-info
|
|
#:text (append (.text then-info) jump-text)))
|
|
|
|
(else-info ((ast->info test+then+jump-info) else))
|
|
(text-else-info (.text else-info))
|
|
(else-text (list-tail text-else-info (length (.text test+then+jump-info))))
|
|
(else-length (length (text->list else-text)))
|
|
|
|
(text+test-text (.text (test-jump->info (+ then-length jump-length))))
|
|
(test-text (list-tail text+test-text text-length))
|
|
(jump-text (list (lambda (f g t d) (i386:jump else-length)))))
|
|
|
|
(clone info #:text
|
|
(append text
|
|
test-text
|
|
then-text
|
|
jump-text
|
|
else-text)
|
|
#:globals (.globals else-info))))
|
|
|
|
((for ,init ,test ,step ,body)
|
|
(let* ((info (clone info #:text '()))
|
|
|
|
(info ((ast->info info) init))
|
|
|
|
(init-text (.text info))
|
|
(init-locals (.locals info))
|
|
(info (clone info #:text '()))
|
|
|
|
(body-info ((ast->info info) body))
|
|
(body-text (.text body-info))
|
|
(body-length (length (text->list body-text)))
|
|
|
|
(step-info ((ast->info info) `(expr-stmt ,step)))
|
|
(step-text (.text step-info))
|
|
(step-length (length (text->list step-text)))
|
|
|
|
(test-jump->info ((test->jump->info info) test))
|
|
(test+jump-info (test-jump->info 0))
|
|
(test-length (length (text->list (.text test+jump-info))))
|
|
|
|
(skip-body-text (list (lambda (f g t d) (i386:jump (+ 2 body-length step-length))))) ;; FIXME: 2
|
|
|
|
(jump-text (list (lambda (f g t d) (i386:jump (- (+ body-length step-length test-length))))))
|
|
(jump-length (length (text->list jump-text)))
|
|
|
|
(test-text (.text (test-jump->info jump-length))))
|
|
|
|
(clone info #:text
|
|
(append text
|
|
init-text
|
|
skip-body-text
|
|
body-text
|
|
step-text
|
|
test-text
|
|
jump-text)
|
|
#:globals (append globals (.globals body-info)) ;; FIXME
|
|
#:locals locals)))
|
|
|
|
((while ,test ,body)
|
|
(let* ((info (clone info #:text '()))
|
|
(body-info ((ast->info info) body))
|
|
(body-text (.text body-info))
|
|
(body-length (length (text->list body-text)))
|
|
|
|
(test-jump->info ((test->jump->info info) test))
|
|
(test+jump-info (test-jump->info 0))
|
|
(test-length (length (text->list (.text test+jump-info))))
|
|
|
|
|
|
(skip-body-text (list (lambda (f g t d) (i386:jump (+ 2 body-length))))) ;; FIXME: 2
|
|
|
|
(jump-text (list (lambda (f g t d) (i386:jump (- (+ body-length test-length))))))
|
|
(jump-length (length (text->list jump-text)))
|
|
|
|
(test-text (.text (test-jump->info jump-length))))
|
|
|
|
(clone info #:text
|
|
(append text
|
|
skip-body-text
|
|
body-text
|
|
test-text
|
|
jump-text)
|
|
#:globals (.globals body-info))))
|
|
|
|
((labeled-stmt (ident ,label) ,statement)
|
|
(let ((info (clone info #:text (append text (list label)))))
|
|
((ast->info info) statement)))
|
|
|
|
((goto (ident ,label))
|
|
(let ((offset (length (text->list text))))
|
|
(clone info #:text
|
|
(append text
|
|
(list (lambda (f g t d)
|
|
(i386:jump (- (label-offset (.function info) label f) offset))))))))
|
|
|
|
((p-expr (ident ,name))
|
|
(clone info #:text
|
|
(append text
|
|
(list (lambda (f g t d)
|
|
(append
|
|
(i386:local->accu (assoc-ref locals name))
|
|
(i386:accu-zero?)))))))
|
|
|
|
((p-expr (fixed ,value))
|
|
(let ((value (cstring->number value)))
|
|
(clone info #:text
|
|
(append text
|
|
(list (lambda (f g t d)
|
|
(append
|
|
(i386:value->accu value)
|
|
(i386:accu-zero?))))))))
|
|
|
|
((de-ref (p-expr (ident ,name)))
|
|
(clone info #:text
|
|
(append text
|
|
(list (lambda (f g t d)
|
|
(append
|
|
(i386:local->accu (assoc-ref locals name))
|
|
(i386:byte-mem->accu)))))))
|
|
|
|
((fctn-call . ,call)
|
|
(let ((info ((ast->info info) `(expr-stmt ,o))))
|
|
(clone info #:text
|
|
(append (.text info)
|
|
(list (lambda (f g t d)
|
|
(i386:accu-zero?)))))))
|
|
|
|
;; FIXME
|
|
;;((post-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
|
|
((post-inc (p-expr (ident ,name)))
|
|
(clone info #:text
|
|
(append text (list (lambda (f g t d)
|
|
(append
|
|
(i386:local->accu (assoc-ref locals name))
|
|
(i386:local-add (assoc-ref locals name) 1)
|
|
(i386:accu-zero?)))))))
|
|
((post-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
|
|
((post-dec ,expr) ((ast->info info) `(expr-stmt ,o)))
|
|
((pre-inc ,expr) ((ast->info info) `(expr-stmt ,o)))
|
|
((pre-dec ,expr) ((ast->info info) `(expr-stmt ,o)))
|
|
|
|
;; i++
|
|
((expr-stmt (post-inc (p-expr (ident ,name))))
|
|
(clone info #:text
|
|
(append text (list (lambda (f g t d)
|
|
(i386:local-add (assoc-ref locals name) 1))))))
|
|
|
|
;; ++i
|
|
((expr-stmt (pre-inc (p-expr (ident ,name))))
|
|
(clone info #:text
|
|
(append text (list (lambda (f g t d)
|
|
(append
|
|
(i386:local-add (assoc-ref locals name) 1)
|
|
(i386:local->accu (assoc-ref locals name))
|
|
(i386:accu-zero?)))))))
|
|
|
|
;; i--
|
|
((expr-stmt (post-dec (p-expr (ident ,name))))
|
|
(clone info #:text
|
|
(append text (list (lambda (f g t d)
|
|
(append
|
|
(i386:local->accu (assoc-ref locals name))
|
|
(i386:local-add (assoc-ref locals name) -1)
|
|
(i386:accu-zero?)))))))
|
|
|
|
;; --i
|
|
((expr-stmt (pre-dec (p-expr (ident ,name))))
|
|
(clone info #:text
|
|
(append text (list (lambda (f g t d)
|
|
(append
|
|
(i386:local-add (assoc-ref locals name) -1)
|
|
(i386:local->accu (assoc-ref locals name))
|
|
(i386:accu-zero?)))))))
|
|
|
|
((not ,expr)
|
|
(let* ((test-info ((ast->info info) expr)))
|
|
(clone info #:text
|
|
(append (.text test-info)
|
|
(list (lambda (f g t d)
|
|
(append
|
|
(i386:accu-not)
|
|
(i386:accu-zero?)))))
|
|
#:globals (.globals test-info))))
|
|
|
|
((eq (p-expr (ident ,a)) (p-expr (fixed ,b)))
|
|
(let ((b (cstring->number b)))
|
|
(clone info #:text
|
|
(append text
|
|
((ident->base info) a)
|
|
(list (lambda (f g t d)
|
|
(append
|
|
(i386:value->accu b)
|
|
(i386:sub-base))))))))
|
|
|
|
((eq (p-expr (ident ,a)) (p-expr (char ,b)))
|
|
(let ((b (char->integer (car (string->list b)))))
|
|
(clone info #:text
|
|
(append text
|
|
((ident->base info) a)
|
|
(list (lambda (f g t d)
|
|
(append
|
|
(i386:value->accu b)
|
|
(i386:sub-base))))))))
|
|
|
|
((eq (p-expr (ident ,a)) (neg (p-expr (fixed ,b))))
|
|
(let ((b (- (cstring->number b))))
|
|
(clone info #:text
|
|
(append text
|
|
((ident->base info) a)
|
|
(list (lambda (f g t d)
|
|
(append
|
|
(i386:value->accu b)
|
|
(i386:sub-base))))))))
|
|
|
|
((eq (fctn-call . ,call) (p-expr (fixed ,b)))
|
|
(let ((b (cstring->number b))
|
|
(info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
|
|
(clone info #:text
|
|
(append text
|
|
(.text info)
|
|
(list (lambda (f g t d)
|
|
(append
|
|
(i386:value->base b)
|
|
(i386:sub-base))))))))
|
|
|
|
((eq (fctn-call . ,call) (p-expr (char ,b)))
|
|
(let ((b (char->integer (car (string->list b))))
|
|
(info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
|
|
(clone info #:text
|
|
(append text
|
|
(.text info)
|
|
(list (lambda (f g t d)
|
|
(append
|
|
(i386:value->base b)
|
|
(i386:sub-base))))))))
|
|
|
|
((cast (type-name (decl-spec-list (type-spec (void)))) _)
|
|
info)
|
|
|
|
((eq (fctn-call . ,call) (p-expr (ident ,b)))
|
|
(let ((info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
|
|
(clone info #:text
|
|
(append text
|
|
(.text info)
|
|
((ident->base info) b)
|
|
(list (lambda (f g t d)
|
|
(append
|
|
(i386:sub-base))))))))
|
|
|
|
((eq (de-ref (p-expr (ident ,a))) (de-ref (p-expr (ident ,b))))
|
|
(clone info #:text
|
|
(append text
|
|
(list (lambda (f g t d)
|
|
(append
|
|
(i386:local->accu (assoc-ref locals a))
|
|
(i386:byte-mem->base)
|
|
(i386:local->accu (assoc-ref locals b))
|
|
(i386:byte-mem->accu)
|
|
(i386:byte-test-base)))))))
|
|
|
|
((gt (p-expr (ident ,a)) (p-expr (fixed ,b)))
|
|
(let ((b (cstring->number b)))
|
|
(clone info #:text
|
|
(append text
|
|
((ident->base info) a)
|
|
(list (lambda (f g t d)
|
|
(append
|
|
(i386:value->accu b)
|
|
(i386:sub-base))))))))
|
|
|
|
((gt (p-expr (ident ,a)) (neg (p-expr (fixed ,b))))
|
|
(let ((b (- (cstring->number b))))
|
|
(clone info #:text
|
|
(append text
|
|
((ident->base info) a)
|
|
(list (lambda (f g t d)
|
|
(append
|
|
(i386:value->accu b)
|
|
(i386:sub-base))))))))
|
|
|
|
|
|
((ne (p-expr (ident ,a)) (p-expr (fixed ,b)))
|
|
(let ((b (cstring->number b)))
|
|
(clone info #:text
|
|
(append text
|
|
((ident->base info) a)
|
|
(list (lambda (f g t d)
|
|
(append
|
|
(i386:value->accu b)
|
|
(i386:sub-base)
|
|
(i386:xor-zf))))))))
|
|
|
|
((ne (p-expr (ident ,a)) (neg (p-expr (fixed ,b))))
|
|
(let ((b (- (cstring->number b))))
|
|
(clone info #:text
|
|
(append text
|
|
((ident->base info) a)
|
|
(list (lambda (f g t d)
|
|
(append
|
|
(i386:value->accu b)
|
|
(i386:sub-base)
|
|
(i386:xor-zf))))))))
|
|
|
|
((ne (fctn-call . ,call) (p-expr (fixed ,b)))
|
|
(let ((b (cstring->number b))
|
|
(info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
|
|
(clone info #:text
|
|
(append text
|
|
(.text info)
|
|
(list (lambda (f g t d)
|
|
(append
|
|
(i386:value->base b)
|
|
(i386:sub-base)
|
|
(i386:xor-zf))))))))
|
|
|
|
((ne (fctn-call . ,call) (p-expr (ident ,b)))
|
|
(let ((info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
|
|
(clone info #:text
|
|
(append text
|
|
(.text info)
|
|
((ident->base info) b)
|
|
(list (lambda (f g t d)
|
|
(append
|
|
(i386:sub-base)
|
|
(i386:xor-zf))))))))
|
|
|
|
((ne (de-ref (p-expr (ident ,a))) (de-ref (p-expr (ident ,b))))
|
|
(clone info #:text
|
|
(append text
|
|
(list (lambda (f g t d)
|
|
(append
|
|
(i386:local->accu (assoc-ref locals a))
|
|
(i386:byte-mem->base)
|
|
(i386:local->accu (assoc-ref locals b))
|
|
(i386:byte-mem->accu)
|
|
(i386:byte-test-base)
|
|
(i386:xor-zf)))))))
|
|
|
|
((lt (p-expr (ident ,a)) (p-expr (fixed ,b)))
|
|
(let ((b (cstring->number b)))
|
|
(clone info #:text
|
|
(append text
|
|
((ident->base info) a)
|
|
(list (lambda (f g t d)
|
|
(append
|
|
(i386:value->accu b)
|
|
(i386:base-sub))))))))
|
|
|
|
((sub (de-ref (p-expr (ident ,a))) (de-ref (p-expr (ident ,b))))
|
|
(clone info #:text
|
|
(append text
|
|
(list (lambda (f g t d)
|
|
(append
|
|
(i386:local->accu (assoc-ref locals a))
|
|
(i386:byte-mem->base)
|
|
(i386:local->accu (assoc-ref locals b))
|
|
(i386:byte-mem->accu)
|
|
(i386:byte-sub-base)))))))
|
|
|
|
((array-ref (p-expr (fixed ,value)) (p-expr (ident ,name)))
|
|
(let ((value (cstring->number value)))
|
|
(clone info #:text
|
|
(append text
|
|
((ident->base info) name)
|
|
(list (lambda (f g t d)
|
|
(append
|
|
(i386:value->accu value)
|
|
(i386:byte-base-mem->accu)))))))) ; FIXME: type: char
|
|
|
|
((array-ref (p-expr (ident ,name)) (p-expr (ident ,index)))
|
|
(clone info #:text
|
|
(append text
|
|
((ident->base info) name)
|
|
((ident->accu info) index)
|
|
(list (lambda (f g t d)
|
|
(i386:byte-base-mem->accu)))))) ; FIXME: type: char
|
|
|
|
((return ,expr)
|
|
(let ((accu ((expr->accu info) expr)))
|
|
(if (info? accu)
|
|
(clone accu #:text
|
|
(append (.text accu) (list (i386:ret (lambda _ '())))))
|
|
(clone info #:text
|
|
(append text (list (i386:ret accu)))))))
|
|
|
|
;; int i;
|
|
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name))))
|
|
(clone info #:locals (add-local name)))
|
|
|
|
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
|
|
(let* ((locals (add-local name))
|
|
(info (clone info #:locals locals)))
|
|
(let ((value (cstring->number value)))
|
|
(clone info #:text
|
|
(append text ((value->ident info) name value))))))
|
|
|
|
;; int i = argc;
|
|
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
|
|
(let* ((locals (add-local name))
|
|
(info (clone info #:locals locals)))
|
|
(clone info #:text
|
|
(append text
|
|
((ident->accu info) local)
|
|
((accu->ident info) name)))))
|
|
|
|
;; char *p = "t.c";
|
|
;;(decl (decl-spec-list (type-spec (fixed-type "char"))) (init-declr-list (init-declr (ptr-declr (pointer) (ident "p")) (initzer (p-expr (string "t.c\n"))))))
|
|
((decl (decl-spec-list (type-spec (fixed-type _))) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (string ,value))))))
|
|
(let* ((locals (add-local name))
|
|
(globals (append globals (list (string->global value))))
|
|
(info (clone info #:locals locals #:globals globals)))
|
|
(clone info #:text
|
|
(append text
|
|
(list (lambda (f g t d)
|
|
(append
|
|
(i386:global->accu (+ (data-offset value g) d)))))
|
|
((accu->ident info) name)))))
|
|
|
|
;; SCM g_stack = 0;
|
|
((decl (decl-spec-list (type-spec (typename _))) (init-declr-list (init-declr (ident _) (initzer (p-expr (fixed _))))) (comment _))
|
|
((ast->info info) (list-head o (- (length o) 1))))
|
|
|
|
((decl (decl-spec-list (type-spec (typename _))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (fixed ,value))))))
|
|
(if (.function info)
|
|
(let* ((locals (add-local name))
|
|
(globals (append globals (list (string->global value))))
|
|
(info (clone info #:locals locals #:globals globals)))
|
|
(clone info #:text
|
|
(append text
|
|
(list (lambda (f g t d)
|
|
(append
|
|
(i386:global->accu (+ (data-offset value g) d)))))
|
|
((accu->ident info) name))))
|
|
(let* ((value (length (globals->data globals)))
|
|
(globals (append globals (list (ident->global name value)))))
|
|
(clone info #:globals globals))))
|
|
|
|
;; SCM i = argc;
|
|
((decl (decl-spec-list (type-spec (typename ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
|
|
(let* ((locals (add-local name))
|
|
(info (clone info #:locals locals)))
|
|
(clone info #:text
|
|
(append text
|
|
((ident->accu info) local)
|
|
((accu->ident info) name)))))
|
|
|
|
;; int i = f ();
|
|
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (fctn-call . ,call)))))
|
|
(let* ((locals (add-local name))
|
|
(info (clone info #:locals locals)))
|
|
(let ((info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
|
|
(clone info
|
|
#:text
|
|
(append (.text info)
|
|
((accu->ident info) name))
|
|
#:locals locals))))
|
|
|
|
;; SCM x = car (e);
|
|
((decl (decl-spec-list (type-spec (typename _))) (init-declr-list (init-declr (ident ,name) (initzer (fctn-call . ,call)))))
|
|
(let* ((locals (add-local name))
|
|
(info (clone info #:locals locals)))
|
|
(let ((info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
|
|
(clone info
|
|
#:text
|
|
(append (.text info)
|
|
((accu->ident info) name))))))
|
|
|
|
;; i = 0;
|
|
((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (p-expr (fixed ,value))))
|
|
;;(stderr "RET LOCAL[~a]: ~a\n" name (assoc-ref locals name))
|
|
(let ((value (cstring->number value)))
|
|
(clone info #:text (append text ((value->ident info) name value)))))
|
|
|
|
;; i = 0; ...from for init FIXME
|
|
((assn-expr (p-expr (ident ,name)) (op _) (p-expr (fixed ,value)))
|
|
(let ((value (cstring->number value)))
|
|
(clone info #:text (append text ((value->ident info) name value)))))
|
|
|
|
((expr-stmt (assn-expr (p-expr (ident ,name)) (op _) (fctn-call . ,call)))
|
|
(let* ((info ((ast->info info) `(expr-stmt (fctn-call ,@call)))))
|
|
(clone info #:text (append (.text info) ((accu->ident info) name)))))
|
|
|
|
(_
|
|
(format (current-error-port) "SKIP statement=~s\n" o)
|
|
info)))))
|
|
|
|
(define (info->exe info)
|
|
(display "dumping elf\n" (current-error-port))
|
|
(map write-any (make-elf (.functions info) (.globals info))))
|
|
|
|
(define (.formals o)
|
|
(pmatch o
|
|
((fctn-defn _ (ftn-declr _ ,formals) _) formals)
|
|
((fctn-defn _ (ptr-declr (pointer) (ftn-declr _ ,formals)) _) formals)
|
|
(_ (format (current-error-port) ".formals: no match: ~a\n" o)
|
|
barf)))
|
|
|
|
(define (formal->text n)
|
|
(lambda (o i)
|
|
;;(i386:formal i n)
|
|
'()
|
|
))
|
|
|
|
(define (formals->text o)
|
|
(pmatch o
|
|
((param-list . ,formals)
|
|
(let ((n (length formals)))
|
|
(list (lambda (f g t d)
|
|
(append
|
|
(i386:function-preamble)
|
|
(append-map (formal->text n) formals (iota n))
|
|
(i386:function-locals))))))
|
|
(_ (format (current-error-port) "formals->text: no match: ~a\n" o)
|
|
barf)))
|
|
|
|
(define (formals->locals o)
|
|
(pmatch o
|
|
((param-list . ,formals)
|
|
(let ((n (length formals)))
|
|
;;(stderr "FORMALS: ~a ==> ~a\n" formals n)
|
|
(map cons (map .name formals) (iota n -2 -1))))
|
|
(_ (format (current-error-port) "formals->info: no match: ~a\n" o)
|
|
barf)))
|
|
|
|
(define (function->info info)
|
|
(lambda (o)
|
|
;;(stderr "\n")
|
|
;;(stderr "formals=~a\n" (.formals o))
|
|
(let* ((name (.name o))
|
|
(text (formals->text (.formals o)))
|
|
(locals (formals->locals (.formals o))))
|
|
(format (current-error-port) "compiling ~a\n" name)
|
|
;;(stderr "locals=~a\n" locals)
|
|
(let loop ((statements (.statements o))
|
|
(info (clone info #:locals locals #:function name #:text text)))
|
|
(if (null? statements) (clone info
|
|
#:function #f
|
|
#:functions (append (.functions info) (list (cons (.name o) (.text info)))))
|
|
(let* ((statement (car statements)))
|
|
(loop (cdr statements)
|
|
((ast->info info) (car statements)))))))))
|
|
|
|
(define (ast-list->info info)
|
|
(lambda (elements)
|
|
(let loop ((elements elements) (info info))
|
|
(if (null? elements) info
|
|
(loop (cdr elements) ((ast->info info) (car elements)))))))
|
|
|
|
(define _start
|
|
(let* ((argc-argv
|
|
(string-append ".byte"
|
|
" 0x89 0xe8" ; mov %ebp,%eax
|
|
" 0x83 0xc0 0x08" ; add $0x8,%eax
|
|
" 0x50" ; push %eax
|
|
" 0x89 0xe8" ; mov %ebp,%eax
|
|
" 0x83 0xc0 0x04" ; add $0x4,%eax
|
|
" 0x0f 0xb6 0x00" ; movzbl (%eax),%eax
|
|
" 0x50" ; push %eax
|
|
))
|
|
(ast (with-input-from-string
|
|
|
|
(string-append "int _start () {int i;asm(\"" argc-argv "\");i=main ();exit (i);}")
|
|
parse-c99)))
|
|
ast))
|
|
|
|
(define strlen
|
|
(let* ((ast (with-input-from-string
|
|
"
|
|
int
|
|
strlen (char const* s)
|
|
{
|
|
int i = 0;
|
|
while (s[i]) i++;
|
|
return i;
|
|
}
|
|
"
|
|
;;paredit:"
|
|
parse-c99)))
|
|
ast))
|
|
|
|
(define getchar
|
|
(let* ((ast (with-input-from-string
|
|
"
|
|
int
|
|
getchar ()
|
|
{
|
|
char c;
|
|
int r = read (g_stdin, &c, 1);
|
|
//int r = read (0, &c, 1);
|
|
if (r < 1) return -1;
|
|
return c;
|
|
}
|
|
"
|
|
;;paredit:"
|
|
parse-c99)))
|
|
ast))
|
|
|
|
(define putchar
|
|
(let* ((ast (with-input-from-string
|
|
"
|
|
int
|
|
putchar (int c)
|
|
{
|
|
//write (STDOUT, s, strlen (s));
|
|
//int i = write (STDOUT, s, strlen (s));
|
|
write (1, (char*)&c, 1);
|
|
return 0;
|
|
}
|
|
"
|
|
;;paredit:"
|
|
parse-c99)))
|
|
ast))
|
|
|
|
(define eputs
|
|
(let* ((ast (with-input-from-string
|
|
"
|
|
int
|
|
eputs (char const* s)
|
|
{
|
|
//write (STDERR, s, strlen (s));
|
|
//write (2, s, strlen (s));
|
|
int i = strlen (s);
|
|
write (2, s, i);
|
|
return 0;
|
|
}
|
|
"
|
|
;;paredit:"
|
|
parse-c99)))
|
|
ast))
|
|
|
|
(define fputs
|
|
(let* ((ast (with-input-from-string
|
|
"
|
|
int
|
|
fputs (char const* s, int fd)
|
|
{
|
|
int i = strlen (s);
|
|
write (fd, s, i);
|
|
return 0;
|
|
}
|
|
"
|
|
;;paredit:"
|
|
parse-c99)))
|
|
ast))
|
|
|
|
(define puts
|
|
(let* ((ast (with-input-from-string
|
|
"
|
|
int
|
|
puts (char const* s)
|
|
{
|
|
//write (STDOUT, s, strlen (s));
|
|
//int i = write (STDOUT, s, strlen (s));
|
|
int i = strlen (s);
|
|
write (1, s, i);
|
|
return 0;
|
|
}
|
|
"
|
|
;;paredit:"
|
|
parse-c99)))
|
|
ast))
|
|
|
|
(define strcmp
|
|
(let* ((ast (with-input-from-string
|
|
"
|
|
int
|
|
strcmp (char const* a, char const* b)
|
|
{
|
|
while (*a && *b && *a == *b)
|
|
{
|
|
a++;b++;
|
|
}
|
|
return *a - *b;
|
|
}
|
|
"
|
|
;;paredit:"
|
|
parse-c99)))
|
|
ast))
|
|
|
|
(define i386:libc
|
|
(list
|
|
(cons "exit" (list i386:exit))
|
|
(cons "open" (list i386:open))
|
|
(cons "read" (list i386:read))
|
|
(cons "write" (list i386:write))))
|
|
|
|
(define libc
|
|
(list
|
|
strlen
|
|
getchar
|
|
putchar
|
|
eputs
|
|
fputs
|
|
puts
|
|
strcmp))
|
|
|
|
(define (compile)
|
|
(let* ((ast (mescc))
|
|
(info (make <info> #:functions i386:libc))
|
|
(info ((ast->info info) libc))
|
|
(info ((ast->info info) ast))
|
|
(info ((ast->info info) _start)))
|
|
(info->exe info)))
|