mes/module/mes/M1.mes

;;; -*-scheme-*-

;;; Mes --- Maxwell Equations of Software
;;; Copyright © 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:

;;; M1.mes produces stage0' M1 object format

;;; Code:

(cond-expand
 (guile)
 (mes
  (mes-use-module (srfi srfi-1))
  (mes-use-module (srfi srfi-26))
  (mes-use-module (mes as))
  (mes-use-module (mes elf))
  (mes-use-module (mes optargs))
  (mes-use-module (mes pmatch))))

(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 (objects->M1 objects)
  ((compose object->M1 merge-objects) objects))

(define (object->elf o)
  ((compose M1->elf object->M1) o))

(define (objects->elf objects)
  ((compose M1->elf object->M1 merge-objects) objects))

(define (merge-objects objects)
  (let loop ((objects (cdr objects)) (object (car objects)))
    (if (null? objects) object
        (loop (cdr objects)
              `((functions . ,(alist-add (assoc-ref object 'functions) (assoc-ref (car objects) 'functions)))
                (globals . ,(alist-add (assoc-ref object 'globals) (assoc-ref (car objects) 'globals))))))))

(define (alist-add a b)
  (let* ((b-keys (map car b))
         (a (filter (lambda (f) (or (cdr f) (not (member (car f) b-keys)))) a))
         (a-keys (map car a)))
    (append a (filter (lambda (e) (not (member (car e) a-keys))) b))))

(define (hex2:address o)
  (string-append "&" o))

(define (hex2:offset o)
  (string-append "%" o))

(define (hex2:offset1 o)
  (string-append "!" o))

(define (hex2:immediate o)
  (string-append "%0x" (dec->hex o)))

(define (hex2:immediate1 o)
  (string-append "!0x" (dec->hex o)))

(define (object->M1 o)
  (let* ((functions (assoc-ref o 'functions))
         (function-names (map car functions))
         (globals (assoc-ref o 'globals))
         (global-names (map car globals))
         (strings (filter (lambda (g) (and (pair? g) (eq? (car g) #:string))) global-names)))
    (define (string->label o)
      (let ((index (list-index (lambda (s) (equal? s o)) strings)))
       (format #f "string_~a" index)))
    (define (text->M1 o)
      (pmatch o
        ;; FIXME
        ((#:address (#:string ,string)) (hex2:address (string->label `(#:string ,string))))
        ((#:string (#:address ,address)) (hex2:address address))
        ((#:address (#:address ,address)) (hex2:address address))

        ((#:string ,string) (hex2:address (string->label o)))
        ((#:address ,address) (hex2:address address))
        ((#:offset ,offset) (hex2:offset offset))
        ((#:offset1 ,offset1) (hex2:offset1 offset1))
        ((#:immediate ,immediate) (hex2:immediate immediate))
        ((#:immediate1 ,immediate1) (hex2:immediate1 immediate1))
        (_ (cond ((char? o) (text->M1 (char->integer o)))
                 ((string? o) (format #f "~a" o))
                 ((number? o) (let ((o (if (< o #x80) o (- o #x100))))
                                (string-append "!0x"
                                               (if (and (>= o 0) (< o 16)) "0" "")
                                               (number->string o 16))))
                 (else (format #f "~a" o))))))
    (define (write-function o)
      (let ((name (car o))
            (text (cdr o)))
        (define (line->M1 o)
          (cond ((eq? (car o) #:label)
                 (format #t ":~a" (cadr o)))
                ((eq? (car o) #:comment)
                 (format #t "\t\t\t\t\t# ~a" (cadr o)))
                ((or (string? (car o)) (symbol? (car o)))
                 (format #t "\t~a" (string-join (map text->M1 o) " ")))
                (else (error "line->M1 invalid line:" o)))
          (newline))
        (format #t "\n\n:~a\n" name)
        (for-each line->M1 (apply append text))))
    (define (write-global o)
      (define (labelize o)
        (if (not (string? o)) o
            (let* ((label o)
                   (function? (member label function-names))
                   (string-label (string->label label))
                   (string? (not (equal? string-label "string_#f")))
                   (global? (member label global-names)))
              (if (or global? string?) (format #f "&~a" label)
                  (begin (if (not function?) (stderr "warning: unresolved label: ~s\n" label))
                         (format #f "&~a" label))))))
      (let* ((label (if (not (and (pair? (car o)) (eq? (caar o) #:string))) (car o)
                       (string->label (car o))))
             (data (cdr o))
             (data (filter-map labelize data)))
        (format #t "\n:~a\n" label)
        (cond ((and (char? (car data))
                    ;; FIXME: 0 in M1 strings
                    (not (find (cut eq? #\nul <>) (list-head data (1- (length data)))))
                    ;; FIXME: " in M1 strings
                    (not (find (cut member <> '(#\" #\' #\backspace)) data))
                    (eq? (last data)= #\nul))
               (format #t "\"~a\"" (list->string (list-head data (1- (length data))))))
              (else (format #t "~a" (string-join (map text->M1 data) " "))))
        (newline)))
    (display "\n:HEX2_text")
    (for-each write-function (filter cdr functions))
    (display "\n\n:ELF_data\n") ;; FIXME
    (display "\n\n:HEX2_data\n")
    (for-each write-global globals)))