4a3e419e30
* module/language/c99/compiler.mes (make, clone): Lightweight functional GOOPS-like list-based info structure. (make-text+globals+locals): Remove. (ast->info): Rename from statement->text+globals+locals, refactor. Update callers. (function->info): Rename from function->globals, refactor. Update callers. (ast-list->info): New function.
529 lines
18 KiB
Scheme
529 lines
18 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)
|
|
((number? x) (integer->char (if (>= x 0) x (+ x 256))))
|
|
(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 <text> '<text>)
|
|
(define* (make o #:key (functions '()) (globals '()) (locals '()) (text '()))
|
|
(pmatch o
|
|
(<info> (list <info>
|
|
(cons <functions> functions)
|
|
(cons <globals> globals)
|
|
(cons <locals> locals)
|
|
(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 (.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))
|
|
(text (.text o)))
|
|
(let-keywords rest
|
|
#f
|
|
((functions functions)
|
|
(globals globals)
|
|
(locals locals)
|
|
(text text))
|
|
(make <info> #:functions functions #:globals globals #:locals locals #:text text))))))
|
|
|
|
(define (ref-local locals)
|
|
(lambda (o)
|
|
;; (stderr "IDENT REF[~a]: ~a => ~a\n" o (assoc-ref locals o) (i386:ref-local (assoc-ref locals o)))
|
|
(i386:ref-local (assoc-ref locals o))))
|
|
|
|
(define (ref-global globals)
|
|
(lambda (o)
|
|
(lambda (f g t d)
|
|
(i386:ref-global (+ (data-offset o g;;lobals
|
|
) d)))))
|
|
|
|
(define (expr->arg globals locals) ;; FIXME: get Mes curried-definitions
|
|
(lambda (o)
|
|
(pmatch o
|
|
((p-expr (fixed ,value)) (string->number value))
|
|
((p-expr (string ,string)) ((ref-global globals) string))
|
|
((p-expr (ident ,name)) ((ref-local locals) name))
|
|
|
|
((array-ref (p-expr (fixed ,value)) (p-expr (ident ,name)))
|
|
(let ((value (string->number value))
|
|
(size 4)) ;; FIXME: type: int
|
|
(lambda (f g t d)
|
|
(append
|
|
((ident->base locals) name)
|
|
(i386:value->accu (* size value)) ;; FIXME: type: int
|
|
(i386:mem->accu) ;; FIXME: type: int
|
|
(i386:push-accu) ;; hmm
|
|
))))
|
|
|
|
(_
|
|
(format (current-error-port) "SKIP expr->arg=~a\n" o)
|
|
0))))
|
|
|
|
(define (ident->accu locals)
|
|
(lambda (o)
|
|
(i386:local->accu (assoc-ref locals o))))
|
|
|
|
(define (accu->ident locals)
|
|
(lambda (o)
|
|
(i386:accu->local (assoc-ref locals o))))
|
|
|
|
(define (ident->base locals)
|
|
(lambda (o)
|
|
(i386:local->base (assoc-ref locals o))))
|
|
|
|
(define (expr->accu info)
|
|
(lambda (o)
|
|
(pmatch o
|
|
((p-expr (fixed ,value)) (string->number value))
|
|
((p-expr (ident ,name)) ((ident->accu (.locals info)) name))
|
|
(_
|
|
(format (current-error-port) "SKIP expr-accu=~a\n" o)
|
|
0)
|
|
)))
|
|
|
|
(define (string->global string)
|
|
(cons string (append (string->list string) (list #\nul))))
|
|
|
|
(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 (ast->info info)
|
|
(lambda (o)
|
|
(let ((globals (.globals info))
|
|
(locals (.locals info))
|
|
(text (.text info)))
|
|
(define (add-local name)
|
|
(acons name (1+ (or (and=> (member 1 (map cdr locals)) length) 0)) locals))
|
|
|
|
;; (stderr "S=~a\n" o)
|
|
;; (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 ~a ~a\n" name value)
|
|
info)
|
|
|
|
((compd-stmt (block-item-list . ,statements)) ((ast-list->info info) statements))
|
|
|
|
((expr-stmt (fctn-call (p-expr (ident ,name))
|
|
(expr-list (p-expr (string ,string)))))
|
|
;;(stderr "S1 string=~a\n" string)
|
|
(if (equal? name "asm") (clone info #:text (append text (list (lambda (f g t d) (asm->hex string)))))
|
|
(let ((globals (append globals (list (string->global string)))))
|
|
(clone info #:text
|
|
(append text (list (lambda (f g t d)
|
|
(i386:call f g t d
|
|
(+ t (function-offset name f))
|
|
(+ d (data-offset string globals
|
|
))))))
|
|
#:globals globals))))
|
|
|
|
((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))
|
|
;;(stderr "S1 expr-list=~a\n" expr-list)
|
|
(let* ((globals (append globals (filter-map expr->global expr-list)))
|
|
(args (map (expr->arg globals locals) 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 (gt (p-expr (ident ,name)) (p-expr (fixed ,value))) ,body)
|
|
(let* ((value (string->number value))
|
|
(info (clone info #:text '()))
|
|
(body-info ((ast->info info) body))
|
|
(body-text (.text body-info))
|
|
(body-length (length (text->list body-text))))
|
|
|
|
(clone info #:text
|
|
(append text
|
|
(list (lambda (f g t d)
|
|
(append
|
|
(i386:local-test (assoc-ref locals name) value)
|
|
(i386:jump-le body-length))))
|
|
body-text)
|
|
#:globals (.globals body-info))))
|
|
|
|
((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-info ((ast->info info) test))
|
|
(test-text (.text test-info))
|
|
(test-length (length (text->list test-text))))
|
|
|
|
(clone info #:text
|
|
(append text
|
|
(list (lambda (f g t d) (i386:jump body-length)))
|
|
body-text
|
|
test-text
|
|
(list (lambda (f g t d) (i386:jump-nz (- (+ body-length test-length))))))
|
|
#:globals (.globals body-info))))
|
|
|
|
((array-ref (p-expr (fixed ,value)) (p-expr (ident ,name)))
|
|
(let ((value (string->number value)))
|
|
(clone info #:text
|
|
(append text (list (lambda (f g t d)
|
|
(append
|
|
((ident->base locals) name)
|
|
(i386:value->accu value)
|
|
(i386:mem-byte->accu)))))))) ; FIXME: type: char
|
|
|
|
((array-ref (p-expr (ident ,name)) (p-expr (ident ,index)))
|
|
(clone info #:text
|
|
(append text (list (lambda (f g t d)
|
|
(append
|
|
((ident->base locals) name)
|
|
((ident->accu locals) index)
|
|
(i386:mem-byte->accu))))))) ; FIXME: type: char
|
|
|
|
((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))))))
|
|
|
|
((return ,expr)
|
|
(clone info #:text
|
|
(append text (list (i386:ret ((expr->accu info) expr))))))
|
|
|
|
;; 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)))
|
|
(let ((value (string->number value)))
|
|
(clone info #:text
|
|
(append text (list (lambda (f g t d)
|
|
(i386:local-assign (assoc-ref locals name) value))))
|
|
#:locals locals))))
|
|
|
|
;; 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)))
|
|
(clone info #:text
|
|
(append text (list (lambda (f g t d)
|
|
(append
|
|
((ident->accu locals) local)
|
|
((accu->ident locals) name)))))
|
|
#:locals locals)))
|
|
|
|
;; 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)))
|
|
(clone info #:text
|
|
(append text (list (lambda (f g t d)
|
|
(append
|
|
((ident->accu locals) local)
|
|
((accu->ident locals) name)))))
|
|
#:locals locals)))
|
|
|
|
;; 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)
|
|
(list (lambda (f g t d)
|
|
(i386:ret-local (assoc-ref locals name)))))
|
|
#:locals locals))))
|
|
|
|
;; 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 (string->number value)))
|
|
(clone info #:text (append text (list (lambda (f g t d) (i386:local-assign (assoc-ref locals 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) (list (lambda (f g t d) (i386:ret-local (assoc-ref locals name))))))))
|
|
|
|
(_
|
|
(format (current-error-port) "SKIP statement=~a\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")
|
|
(format (current-error-port) "compiling ~a\n" (.name o))
|
|
;;(stderr "formals=~a\n" (.formals o))
|
|
(let* ((text (formals->text (.formals o)))
|
|
(locals (formals->locals (.formals o))))
|
|
;;(stderr "locals=~a\n" locals)
|
|
(let loop ((statements (.statements o))
|
|
(info (clone info #:locals locals #:text text)))
|
|
(if (null? statements) (clone info
|
|
#: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 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 i386:libc
|
|
(list
|
|
(cons "exit" (list i386:exit))
|
|
(cons "write" (list i386:write))))
|
|
|
|
(define libc
|
|
(list
|
|
strlen
|
|
eputs
|
|
fputs
|
|
puts))
|
|
|
|
(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)))
|