module/mes/M1.mes

   1 ;;; -*-scheme-*-
   2
   3 ;;; Mes --- Maxwell Equations of Software
   4 ;;; Copyright © 2017 Jan Nieuwenhuizen <janneke@gnu.org>
   5 ;;;
   6 ;;; This file is part of Mes.
   7 ;;;
   8 ;;; Mes is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; Mes is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 ;;; Commentary:
  22
  23 ;;; M1.mes produces stage0' M1 object format
  24
  25 ;;; Code:
  26
  27 (cond-expand
  28  (guile)
  29  (mes
  30   (mes-use-module (srfi srfi-1))
  31   (mes-use-module (srfi srfi-26))
  32   (mes-use-module (mes as))
  33   (mes-use-module (mes elf))
  34   (mes-use-module (mes optargs))
  35   (mes-use-module (mes pmatch))
  36   (mes-use-module (language c99 info))))
  37
  38 (define (logf port string . rest)
  39   (apply format (cons* port string rest))
  40   (force-output port)
  41   #t)
  42
  43 (define (stderr string . rest)
  44   (apply logf (cons* (current-error-port) string rest)))
  45
  46 (define (objects->M1 objects)
  47   ((compose object->M1 merge-objects) objects))
  48
  49 (define (object->elf o)
  50   ((compose M1->elf object->M1) o))
  51
  52 (define (objects->elf objects)
  53   ((compose M1->elf object->M1 merge-objects) objects))
  54
  55 (define (merge-objects objects)
  56   (let loop ((objects (cdr objects)) (object (car objects)))
  57     (if (null? objects) object
  58         (loop (cdr objects)
  59               `((functions . ,(alist-add (assoc-ref object 'functions) (assoc-ref (car objects) 'functions)))
  60                 (globals . ,(alist-add (assoc-ref object 'globals) (assoc-ref (car objects) 'globals))))))))
  61
  62 (define (alist-add a b)
  63   (let* ((b-keys (map car b))
  64          (a (filter (lambda (f) (or (cdr f) (not (member (car f) b-keys)))) a))
  65          (a-keys (map car a)))
  66     (append a (filter (lambda (e) (not (member (car e) a-keys))) b))))
  67
  68 (define (hex2:address o)
  69   (string-append "&" o))
  70
  71 (define (hex2:offset o)
  72   (string-append "%" o))
  73
  74 (define (hex2:offset1 o)
  75   (string-append "!" o))
  76
  77 (define hex? #t)
  78
  79 (define (hex2:immediate o)
  80   (if hex? (string-append "%0x" (dec->hex o))
  81       (format #f "%~a" o)))
  82
  83 (define (hex2:immediate1 o)
  84   (if hex? (string-append "!0x" (dec->hex o))
  85       (format #f "!~a" o)))
  86
  87 (define (object->M1 o)
  88   (let* ((functions (assoc-ref o 'functions))
  89          (function-names (map car functions))
  90          (globals (assoc-ref o 'globals))
  91          (global-names (map car globals))
  92          (strings (filter (lambda (g) (and (pair? g) (eq? (car g) #:string))) global-names)))
  93     (define (string->label o)
  94       (let ((index (list-index (lambda (s) (equal? s o)) strings)))
  95        (format #f "string_~a" index)))
  96     (define (text->M1 o)
  97       (pmatch o
  98         ;; FIXME
  99         ((#:address (#:string ,string)) (hex2:address (string->label `(#:string ,string))))
 100         ((#:string (#:address ,address)) (hex2:address address))
 101         ((#:address (#:address ,address)) (hex2:address address))
 102
 103         ((#:string ,string) (hex2:address (string->label o)))
 104         ((#:address ,address) (hex2:address address))
 105         ((#:offset ,offset) (hex2:offset offset))
 106         ((#:offset1 ,offset1) (hex2:offset1 offset1))
 107         ((#:immediate ,immediate) (hex2:immediate immediate))
 108         ((#:immediate1 ,immediate1) (hex2:immediate1 immediate1))
 109         (_ (cond ((char? o) (text->M1 (char->integer o)))
 110                  ((string? o) (format #f "~a" o))
 111                  ((number? o) (let ((o (if (< o #x80) o (- o #x100))))
 112                                 (if hex? (string-append "!0x"
 113                                                         (if (and (>= o 0) (< o 16)) "0" "")
 114                                                         (number->string o 16))
 115                                     (string-append "!" (number->string o)))))
 116                  (else (format #f "~a" o))))))
 117     (define (write-function o)
 118       (let ((name (car o))
 119             (text (cdr o)))
 120         (define (line->M1 o)
 121           (cond ((eq? (car o) #:label)
 122                  (format #t ":~a" (cadr o)))
 123                 ((eq? (car o) #:comment)
 124                  (format #t "\t\t\t\t\t# ~a" (cadr o)))
 125                 ((or (string? (car o)) (symbol? (car o)))
 126                  (format #t "\t~a" (string-join (map text->M1 o) " ")))
 127                 (else (error "line->M1 invalid line:" o)))
 128           (newline))
 129         (format #t "\n\n:~a\n" name)
 130         (for-each line->M1 (apply append text))))
 131     (define (write-global o)
 132       (define (labelize o)
 133         (if (not (string? o)) o
 134             (let* ((label o)
 135                    (function? (member label function-names))
 136                    (string-label (string->label label))
 137                    (string? (not (equal? string-label "string_#f")))
 138                    (global? (member label global-names)))
 139               (if (or global? string?) (format #f "&~a" label)
 140                   (begin (if (not function?) (stderr "warning: unresolved label: ~s\n" label))
 141                          (format #f "&~a" label))))))
 142       (let* ((label (if (not (and (pair? (car o)) (eq? (caar o) #:string))) (car o)
 143                        (string->label (car o))))
 144              (data (cdr o))
 145              (data (filter-map labelize data))
 146              (len (length data))
 147              (string-max (or (and=> (getenv "M1_STRING_MAX") string->number) 0)))
 148         (format #t "\n:~a\n" label)
 149         (cond ((and (< len string-max)
 150                     (char? (car data))
 151                     (eq? (last data) #\nul)
 152                     (not (find (cut memq <> '(#\nul #\backspace #\return #\" #\')) (list-head data (1- (length data))))))
 153                (format #t "\"~a\"" (list->string (list-head data (1- (length data))))))
 154               (else (format #t "~a" (string-join (map text->M1 data) " "))))
 155         (newline)))
 156     (display "\n:HEX2_text")
 157     (for-each write-function (filter cdr functions))
 158     (display "\n\n:ELF_data\n") ;; FIXME
 159     (display "\n\n:HEX2_data\n")
 160     (for-each write-global globals)))