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
   (set-port-encoding! (current-output-port) "ISO-8859-1"))
  (mes
   (mes-use-module (nyacc lang c99 parser))
   (mes-use-module (mes pmatch))
   (mes-use-module (mes elf))
   (mes-use-module (mes libc-i386))))

(define (mescc)
  (parse-c99 #:inc-dirs '()))

(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 (statement->data o)
  (pmatch o
    ((expr-stmt (fctn-call (p-expr (ident ,name))
                           (expr-list (p-expr (string ,string)))))
     (string->list string))
    ((for (decl (decl-spec-list (type-spec (fixed-type ,type)))
                  (init-declr-list (init-declr (ident ,identifier)
                                               (initzer (p-expr (fixed ,start))))))
            (lt (p-expr (ident _)) (p-expr (fixed ,test)))
            ,step ;;(pre-inc (p-expr (ident i)))
            ,statement)
     (statement->data statement))
    (_ '())))

(define (statement->text data o)
  (let ((offset (length data)))
    (pmatch o
      ((expr-stmt (fctn-call (p-expr (ident ,name))
                             (expr-list (p-expr (string ,string)))))
       (list (lambda (data) (i386:puts (+ data offset) (string-length string)))))
      ((for (decl (decl-spec-list (type-spec (fixed-type ,type)))
                  (init-declr-list (init-declr (ident ,identifier)
                                               (initzer (p-expr (fixed ,start))))))
            (lt (p-expr (ident _)) (p-expr (fixed ,test)))
            ,step ;;(pre-inc (p-expr (ident i)))
            ,statement)
       (display "start:" (current-error-port))
       (display start (current-error-port))
       (newline (current-error-port))

       (display "test:" (current-error-port))
       (display test (current-error-port))
       (newline (current-error-port))

       ;; (display "step:" (current-error-port))
       ;; (display step (current-error-port))
       ;; (newline (current-error-port))
       ;; 
       (display "for-statement:" (current-error-port))
       (display statement (current-error-port))
       (newline (current-error-port))

       (let ((start (string->number start))
             (test (string->number test))
             (step 1)
             (statement (car (statement->text data statement))))
         
         (display "2start:" (current-error-port))
         (display start (current-error-port))
         (newline (current-error-port))

         (display "2for-statement:" (current-error-port))
         (display statement (current-error-port))
         (newline (current-error-port))

         (list (lambda (d) (i386:for start test step (statement d))))))

      ((return (p-expr (fixed ,value)))
       (let ((value (string->number value)))
        (list (lambda (data) (i386:exit value)))))
      (_ '()))))

(define (function->text+data o)
  (let loop ((statements (.statements o)) (text '()) (data '()))
    (display "text:" (current-error-port))
    (display text (current-error-port))
    (newline (current-error-port))
    (if (null? statements) (values text data)
        (let* ((statement (car statements)))
          (display "statement:" (current-error-port))
          (display statement (current-error-port))
          (newline (current-error-port))
          (loop (cdr statements)
                (append text (statement->text data statement))
                (append data (statement->data statement)))))))

(define (text+data->exe text data)
  (display "dumping to a.out:\n" (current-error-port))
  (map write-any (make-elf (lambda (data)
                             (append-map (lambda (f) (f data)) text)) data)))

(define (compile)
  (let* ((ast (mescc))
         (functions (filter ast:function? (cdr ast)))
         (main (find (lambda (x) (equal? (.name x) "main")) functions)))
    (display "AST" (current-error-port))
    (pretty-print ast (current-error-port))
    (format (current-error-port) "functions~a\n" functions)
    (format (current-error-port) "main~a\n" main)
    (call-with-values
        (lambda () (function->text+data main))
      text+data->exe)))