;;; -*-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)
 (guile-2)
 (mes
  (mes-use-module (srfi srfi-1))
  (mes-use-module (srfi srfi-1))))


(define (int->bv32 value)
  (let ((bv (make-bytevector 4)))
    (bytevector-u32-native-set! bv 0 value)
    bv))

(define (int->bv16 value)
  (let ((bv (make-bytevector 2)))
    (bytevector-u16-native-set! bv 0 value)
    bv))

(define (make-global name type pointer value)
  (cons name (list type pointer value)))

(define global:type car)
(define global:pointer cadr)
(define global:value caddr)

(define (dec->hex o)
  (cond ((number? o) (number->string o 16))
        ((char? o) (number->string (char->integer o) 16))
        (else (format #f "~s" o))))

(define (functions->lines functions)
  (filter (lambda (x) (not (and (pair? x) (pair? (car x)) (member (caar x) '(#:comment #:label))))) (append-map cdr functions))
  ;;(append-map cdr functions)
  )

(define (text->list o)
  (append-map cdr o))

(define functions->text
  (let ((cache '()))
    (lambda (functions globals ta t d)
      (let ((text (or (assoc-ref cache (cons ta (map car functions)))
                      (let ((text (apply append (functions->lines functions))))
                    (set! cache (assoc-set! cache (cons ta (map car functions)) text))
                    text))))
        (if (= ta 0) text
            (let loop ((f functions))
              (if (null? f) '()
                  (append ((function->text functions globals ta t d) (car f))
                          (loop (cdr f))))))))))

(define (function->text functions globals ta t d)
  (lambda (o)
    (let ((text (apply append (cdr o)))
          (offset (function-offset (car o) functions)))
      (let loop ((text text) (off offset))
        (if (null? text) '()
            (let ((label (car text)))
              (if (number? label) (cons label (loop (cdr text) (1+ off)))
                  (if (and (pair? label) (member (car label) '(#:comment #:label))) (loop (cdr text) off)
                      (let* ((prefix (cond ((and (pair? (cdr text))
                                                 (pair? (cddr text))
                                                 (boolean? (caddr text))) 4)
                                           ((and (pair? (cdr text))
                                                 (boolean? (cadr text))) 2)
                                           (else 1)))
                             ;; (foo (format (current-error-port) "LABEL=~s\n" label))
                             ;; (foo (format (current-error-port) "  prefix=~s\n" prefix))
                             (address? (and (pair? label) (eq? (car label) #:address)))
                             (local? (and (pair? label) (eq? (car label) #:local)))
                             (relative? (and (pair? label) (eq? (car label) #:relative)))
                             (label (if (or address? local? relative?) (cadr label) label))
                             (function-address (function-offset label functions))
                             (data-address (data-offset label globals))
                             (label-address (label-offset (car o) `((#:label ,label)) functions))
                             ;; (foo (format (current-error-port) "  address?=~s\n" address?))
                             ;; (foo (format (current-error-port) "  d=~s\n" data-address))
                             ;; (foo (format (current-error-port) "  f=~s\n" function-address))
                             ;; (foo (format (current-error-port) "  l=~s\n" label-address))
                             (address (or (and local?
                                               (and=> label-address (lambda (a) (- a (- off offset) prefix))))
                                          (and=> data-address (lambda (a) (+ a d)))
                                          (if address?
                                              (and=> function-address (lambda (a) (+ a ta)))
                                              (and=> function-address (lambda (a) (- a off prefix))))
                                          (error "unresolved label: " label))))
                        (append ((case prefix ((1) list) ((2) int->bv16) ((4) int->bv32)) address)
                                (loop (list-tail text prefix) (+ off prefix))))))))))))

(define (function-prefix name functions)
  ;; FIXME
  ;;(member name (reverse functions) (lambda (a b) (equal? (car b) name)))
  (let* ((x functions)
         (x (if (and (pair? x) (equal? (caar x) "_start")) (reverse x) x)))
    (member name x (lambda (a b) (equal? (car b) name)))))

(define function-offset
  (let ((cache '()))
    (lambda (name functions)
      (or (assoc-ref cache name)
          (let* ((functions (if (and (pair? functions) (equal? (caar functions) "_start")) functions (reverse functions)))
                 (prefix (and=> (function-prefix name functions) cdr))
                 (offset (and prefix
                              (if (null? prefix) 0
                                  (+ (length (functions->text (list (car prefix)) '() 0 0 0))
                                     (if (null? (cdr prefix)) 0
                                         (function-offset (caar prefix) functions)))))))
            (if (and offset (or (equal? name "_start") (> offset 0))) (set! cache (assoc-set! cache name offset)))
            offset)))))

(define label-offset
  (let ((cache '()))
    (lambda (function label functions)
      (or (assoc-ref cache (cons function label))
          (let ((prefix (function-prefix function functions)))
            (if (not prefix) 0
                (let* ((function-entry (car prefix))
                       (offset (let loop ((text (cdr function-entry)))
                                 ;; FIXME: unresolved label
                                 ;;(if (null? text) (error "unresolved label:"))
                                 (if (or (null? text) (equal? (car text) label)) 0
                                     (let* ((t (car text))
                                            (n (if (and (pair? (car t))
                                                        (member (caar t) '(#:label #:comment))) 0 (length t))))
                                       (+ (loop (cdr text)) n))))))
                  (when (> offset 0)
                    (set! cache (assoc-set! cache (cons function label) offset)))
                  offset)))))))

(define (globals->data functions globals t d)
  (let loop ((text (append-map cdr globals)))
    (if (null? text) '()
        (let ((label (car text)))
          (if (or (char? label) (number? label)) (cons label (loop (cdr text)))
              (let* ((prefix (if (and (pair? (cdr text))
                                      (pair? (cddr text))
                                      (boolean? (caddr text))) 4
                                      2))
                     (function-address (function-offset label functions))
                     (data-address (data-offset label globals))
                     (address (or (and=> data-address (lambda (a) (+ a d)))
                                  (and=> function-address (lambda (a) (+ a t)))
                                  (error "unresolved label: " label))))
                      (append ((if (= prefix 2) int->bv16 int->bv32) address)
                              (loop (list-tail text prefix)))))))))

(define (simple-globals->data globals)
  (append-map cdr globals))

(define data-offset
  (let ((cache '()))
    (lambda (name globals)
      (or (assoc-ref cache name)
          (let ((prefix (member name (reverse globals)
                                (lambda (a b)
                                  (equal? (car b) name)))))
            (and prefix
                 (let ((offset (length (simple-globals->data (cdr prefix)))))
                   (set! cache (assoc-set! cache name offset))
                   offset)))))))