mes/module/language/c99/compiler.mes

;;; -*-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
 (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)))

(define (mescc)
  (parse-c99 #:inc-dirs (string-split (getenv "C_INCLUDE_PATH") #\:)
             #:cpp-defs '(("__GNUC__" . "0"))
             #:xdef? gnuc-xdef?))

(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)))

(define (expr->arg symbols) ;; FIXME: get Mes curried-definitions
  (lambda (o)
    (pmatch o
      ((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))))

(define (compile)
  (let* ((ast (mescc))
         (functions (filter ast:function? (cdr ast)))
         (functions (append functions _start)))
    (let loop ((functions functions) (symbols libc))
      (if (null? functions) (symbols->exe symbols)
          (loop (cdr functions) ((function->symbols symbols) (car functions)))))))