2016-12-31 08:03:07 +00:00
|
|
|
;;; -*-scheme-*-
|
|
|
|
|
|
|
|
;;; Mes --- Maxwell Equations of Software
|
|
|
|
;;; Copyright © 2016 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
|
2017-04-02 09:55:37 +00:00
|
|
|
(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))))
|
|
|
|
|
|
|
|
;;(define (gnuc-xdef? name mode) (if (equal? name "__GNUC__") #f (env? mode 'code)))
|
|
|
|
;;(define (gnuc-xdef? name mode) (equal? name "__GNUC__"))
|
|
|
|
(define (gnuc-xdef? name mode)
|
|
|
|
(cond ((equal? name "__GNUC__") #t)
|
|
|
|
((equal? name "asm") #f)))
|
2016-12-31 08:03:07 +00:00
|
|
|
|
|
|
|
(define (mescc)
|
2017-04-02 09:55:37 +00:00
|
|
|
(parse-c99 #:inc-dirs (string-split (getenv "C_INCLUDE_PATH") #\:)
|
|
|
|
#:cpp-defs '(("__GNUC__" . "0"))
|
|
|
|
#:xdef? gnuc-xdef?))
|
2016-12-31 08:03:07 +00:00
|
|
|
|
|
|
|
(define (write-any x)
|
|
|
|
(write-char (if (char? x) x (integer->char (if (>= x 0) x (+ x 256))))))
|
|
|
|
|
|
|
|
(define (ast:function? o)
|
|
|
|
(and (pair? o) (eq? (car o) 'fctn-defn)))
|
|
|
|
|
|
|
|
(define (.name o)
|
|
|
|
(pmatch o
|
|
|
|
((fctn-defn _ (ftn-declr (ident ,name) _) _) name)))
|
|
|
|
|
|
|
|
(define (.statements o)
|
|
|
|
(pmatch o
|
|
|
|
((fctn-defn _ (ftn-declr (ident ,name) _) (compd-stmt (block-item-list . ,statements))) statements)))
|
|
|
|
|
2017-04-02 09:55:37 +00:00
|
|
|
(define (expr->arg symbols) ;; FIXME: get Mes curried-definitions
|
|
|
|
(lambda (o)
|
2016-12-31 08:03:07 +00:00
|
|
|
(pmatch o
|
2017-04-02 09:55:37 +00:00
|
|
|
((p-expr (fixed ,value)) (string->number value))
|
|
|
|
((p-expr (string ,string)) (data-offset symbols string))
|
|
|
|
(_
|
|
|
|
(format (current-error-port) "SKIPPING expr=~a\n" o)
|
|
|
|
0))))
|
|
|
|
|
|
|
|
(define (expr->symbols o)
|
|
|
|
(pmatch o
|
|
|
|
((p-expr (string ,string)) (string->symbols string))
|
|
|
|
(_ #f)))
|
|
|
|
|
|
|
|
(define make-text+symbols cons)
|
|
|
|
(define .text car)
|
|
|
|
(define .symbols cdr)
|
|
|
|
|
|
|
|
(define (dec->hex o)
|
|
|
|
(number->string o 16))
|
|
|
|
|
|
|
|
(define (statement->text+symbols text+symbols)
|
|
|
|
(lambda (o)
|
|
|
|
(let* ((text (.text text+symbols))
|
|
|
|
(symbols (.symbols text+symbols))
|
|
|
|
(text-list (append-map (lambda (f) (f '() 0 0)) text))
|
|
|
|
(prefix-list (symbols->text symbols 0 0))
|
|
|
|
(statement-offset (- (+ (length prefix-list) (length text-list)))))
|
|
|
|
(pmatch o
|
|
|
|
((expr-stmt (fctn-call (p-expr (ident ,name))
|
|
|
|
(expr-list (p-expr (string ,string)))))
|
|
|
|
(make-text+symbols
|
|
|
|
(append text
|
|
|
|
(list (lambda (s t d)
|
|
|
|
(i386:call (+ t
|
|
|
|
(function-offset name s)
|
|
|
|
statement-offset)
|
|
|
|
(+ d (data-offset string s))))))
|
|
|
|
(append symbols (list (string->symbols string)))));; FIXME: ->symbolSXX
|
|
|
|
|
|
|
|
((expr-stmt (fctn-call (p-expr (ident ,name)) (expr-list . ,expr-list)))
|
|
|
|
(let ((args (map (expr->arg symbols) expr-list)))
|
|
|
|
(make-text+symbols
|
|
|
|
(append text
|
|
|
|
(list (lambda (s t d) (apply i386:call (cons (+ t (function-offset name s) statement-offset) args)))))
|
|
|
|
(append symbols (filter-map expr->symbols expr-list)))))
|
|
|
|
|
|
|
|
((return (p-expr (fixed ,value)))
|
|
|
|
(let ((value (string->number value)))
|
|
|
|
(make-text+symbols (append text (list (lambda _ (i386:ret)))) symbols)))
|
|
|
|
|
|
|
|
(_
|
|
|
|
(format (current-error-port) "SKIPPING S=~a\n" o)
|
|
|
|
text+symbols)))))
|
|
|
|
|
|
|
|
(define (symbols->exe symbols)
|
|
|
|
(display "dumping elf\n" (current-error-port))
|
|
|
|
(map write-any (make-elf symbols)))
|
|
|
|
|
|
|
|
(define (.formals o)
|
|
|
|
(pmatch o
|
|
|
|
((fctn-defn _ (ftn-declr _ ,formals) _) formals)
|
|
|
|
(_ (format (current-error-port) ".formals: no match: ~a\n" o)
|
|
|
|
barf)))
|
|
|
|
|
|
|
|
(define (formal->text o)
|
|
|
|
'(#x58)) ;; pop %eax
|
|
|
|
|
|
|
|
(define (formals->text o)
|
|
|
|
(pmatch o
|
|
|
|
((param-list . ,formals)
|
|
|
|
(list (lambda (s t d)
|
|
|
|
(append
|
|
|
|
'(#x5f) ;; pop %edi
|
|
|
|
(append-map formal->text formals)
|
|
|
|
'(#x57) ;; push %edi
|
|
|
|
))))
|
|
|
|
(_ (format (current-error-port) "formals->text+data: no match: ~a\n" o)
|
|
|
|
barf)))
|
|
|
|
|
|
|
|
(define (string->symbols string)
|
|
|
|
(make-data string (string->list string)))
|
|
|
|
|
|
|
|
(define (function->symbols symbols)
|
|
|
|
(lambda (o)
|
|
|
|
(format (current-error-port) "compiling ~a\n" (.name o))
|
|
|
|
(let* ((text (formals->text (.formals o)))
|
|
|
|
(text-offset (length (symbols->text symbols 0 0))))
|
|
|
|
(let loop ((statements (.statements o))
|
|
|
|
(text+symbols (make-text+symbols text symbols)))
|
|
|
|
(if (null? statements) (append (.symbols text+symbols) (list (make-function (.name o) (.text text+symbols))))
|
|
|
|
(let* ((statement (car statements)))
|
|
|
|
(loop (cdr statements)
|
|
|
|
((statement->text+symbols text+symbols) (car statements)))))))))
|
|
|
|
|
|
|
|
(define _start
|
|
|
|
(let* ((ast (with-input-from-string
|
|
|
|
"int _start () {main(0,0);exit (0);}"
|
|
|
|
parse-c99))
|
|
|
|
(functions (filter ast:function? (cdr ast))))
|
|
|
|
(list (find (lambda (x) (equal? (.name x) "_start")) functions))))
|
|
|
|
|
|
|
|
(define libc
|
|
|
|
(list
|
|
|
|
(make-function "eputs" (list i386:eputs))
|
|
|
|
(make-function "exit" (list i386:exit))
|
|
|
|
(make-function "puts" (list i386:puts))))
|
2016-12-31 08:03:07 +00:00
|
|
|
|
|
|
|
(define (compile)
|
|
|
|
(let* ((ast (mescc))
|
|
|
|
(functions (filter ast:function? (cdr ast)))
|
2017-04-02 09:55:37 +00:00
|
|
|
(functions (append functions _start)))
|
|
|
|
(let loop ((functions functions) (symbols libc))
|
|
|
|
(if (null? functions) (symbols->exe symbols)
|
|
|
|
(loop (cdr functions) ((function->symbols symbols) (car functions)))))))
|