build: Use released M0 intead of M1.
[mes.git] / 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
37 (define (logf port string . rest)
38   (apply format (cons* port string rest))
39   (force-output port)
40   #t)
41
42 (define (stderr string . rest)
43   (apply logf (cons* (current-error-port) string rest)))
44
45 (define (objects->M1 objects)
46   ((compose object->M1 merge-objects) objects))
47
48 (define (object->elf o)
49   ((compose M1->elf object->M1) o))
50
51 (define (objects->elf objects)
52   ((compose M1->elf object->M1 merge-objects) objects))
53
54 (define (merge-objects objects)
55   (let loop ((objects (cdr objects)) (object (car objects)))
56     (if (null? objects) object
57         (loop (cdr objects)
58               `((functions . ,(alist-add (assoc-ref object 'functions) (assoc-ref (car objects) 'functions)))
59                 (globals . ,(alist-add (assoc-ref object 'globals) (assoc-ref (car objects) 'globals))))))))
60
61 (define (alist-add a b)
62   (let* ((b-keys (map car b))
63          (a (filter (lambda (f) (or (cdr f) (not (member (car f) b-keys)))) a))
64          (a-keys (map car a)))
65     (append a (filter (lambda (e) (not (member (car e) a-keys))) b))))
66
67 (define (hex2:address o)
68   (string-append "&" o))
69
70 (define (hex2:offset o)
71   (string-append "%" o))
72
73 (define (hex2:offset1 o)
74   (string-append "!" o))
75
76 (define hex? #f) ; We need unreleased messc-tools 0.2 wih 0xXX support for this
77
78 (define (hex2:immediate o)
79   (if hex? (string-append "%0x" (dec->hex o))
80       (format #f "%~a" o)))
81
82 (define (hex2:immediate1 o)
83   (if hex? (string-append "!0x" (dec->hex o))
84       (format #f "!~a" o)))
85
86 (define (object->M1 o)
87   (let* ((functions (assoc-ref o 'functions))
88          (function-names (map car functions))
89          (globals (assoc-ref o 'globals))
90          (global-names (map car globals))
91          (strings (filter (lambda (g) (and (pair? g) (eq? (car g) #:string))) global-names)))
92     (define (string->label o)
93       (let ((index (list-index (lambda (s) (equal? s o)) strings)))
94        (format #f "string_~a" index)))
95     (define (text->M1 o)
96       (pmatch o
97         ;; FIXME
98         ((#:address (#:string ,string)) (hex2:address (string->label `(#:string ,string))))
99         ((#:string (#:address ,address)) (hex2:address address))
100         ((#:address (#:address ,address)) (hex2:address address))
101
102         ((#:string ,string) (hex2:address (string->label o)))
103         ((#:address ,address) (hex2:address address))
104         ((#:offset ,offset) (hex2:offset offset))
105         ((#:offset1 ,offset1) (hex2:offset1 offset1))
106         ((#:immediate ,immediate) (hex2:immediate immediate))
107         ((#:immediate1 ,immediate1) (hex2:immediate1 immediate1))
108         (_ (cond ((char? o) (text->M1 (char->integer o)))
109                  ((string? o) (format #f "~a" o))
110                  ((number? o) (let ((o (if (< o #x80) o (- o #x100))))
111                                 (if hex? (string-append "!0x"
112                                                         (if (and (>= o 0) (< o 16)) "0" "")
113                                                         (number->string o 16))
114                                     (string-append "!" (number->string o)))))
115                  (else (format #f "~a" o))))))
116     (define (write-function o)
117       (let ((name (car o))
118             (text (cdr o)))
119         (define (line->M1 o)
120           (cond ((eq? (car o) #:label)
121                  (format #t ":~a" (cadr o)))
122                 ((eq? (car o) #:comment)
123                  (format #t "\t\t\t\t\t# ~a" (cadr o)))
124                 ((or (string? (car o)) (symbol? (car o)))
125                  (format #t "\t~a" (string-join (map text->M1 o) " ")))
126                 (else (error "line->M1 invalid line:" o)))
127           (newline))
128         (format #t "\n\n:~a\n" name)
129         (for-each line->M1 (apply append text))))
130     (define (write-global o)
131       (define (labelize o)
132         (if (not (string? o)) o
133             (let* ((label o)
134                    (function? (member label function-names))
135                    (string-label (string->label label))
136                    (string? (not (equal? string-label "string_#f")))
137                    (global? (member label global-names)))
138               (if (or global? string?) (format #f "&~a" label)
139                   (begin (if (not function?) (stderr "warning: unresolved label: ~s\n" label))
140                          (format #f "&~a" label))))))
141       (let* ((label (if (not (and (pair? (car o)) (eq? (caar o) #:string))) (car o)
142                        (string->label (car o))))
143              (data (cdr o))
144              (data (filter-map labelize data)))
145         (format #t "\n:~a\n" label)
146         (cond ((and (char? (car data))
147                     ;; FIXME: 0 in M1 strings
148                     (not (find (cut eq? #\nul <>) (list-head data (1- (length data)))))
149                     ;; FIXME: " in M1 strings
150                     (not (find (cut member <> '(#\" #\' #\backspace)) data))
151                     (eq? (last data)= #\nul))
152                (format #t "\"~a\"" (list->string (list-head data (1- (length data))))))
153               (else (format #t "~a" (string-join (map text->M1 data) " "))))
154         (newline)))
155     (display "\n:HEX2_text")
156     (for-each write-function (filter cdr functions))
157     (display "\n\n:ELF_data\n") ;; FIXME
158     (display "\n\n:HEX2_data\n")
159     (for-each write-global globals)))