mescc: Produce object files in hex2 format, remove hex3.
[mes.git] / module / mes / hex2.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 ;;; hex2.mes produces stage0' hex2 object format
24
25 ;;; Code:
26
27 (cond-expand
28  (guile)
29  (mes
30   (mes-use-module (srfi srfi-1))
31   (mes-use-module (mes elf-util))
32   (mes-use-module (mes elf))
33   (mes-use-module (mes optargs))
34   (mes-use-module (mes pmatch))))
35
36 (define (logf port string . rest)
37   (apply format (cons* port string rest))
38   (force-output port)
39   #t)
40
41 (define (stderr string . rest)
42   (apply logf (cons* (current-error-port) string rest)))
43
44 (define (objects->hex2 objects)
45   ((compose object->hex2 merge-objects) objects))
46
47 (define (objects->elf objects)
48   (error "->ELF support dropped, use hex2"))
49
50 (define (merge-objects objects)
51   (let loop ((objects (cdr objects)) (object (car objects)))
52     (if (null? objects) object
53         (loop (cdr objects)
54               `((functions . ,(alist-add (assoc-ref object 'functions) (assoc-ref (car objects) 'functions)))
55                 (globals . ,(alist-add (assoc-ref object 'globals) (assoc-ref (car objects) 'globals))))))))
56
57 (define (alist-add a b)
58   (let* ((b-keys (map car b))
59          (a (filter (lambda (f) (or (cdr f) (not (member (car f) b-keys)))) a))
60          (a-keys (map car a)))
61     (append a (filter (lambda (e) (not (member (car e) a-keys))) b))))
62
63 (define (hex2:address o)
64   (string-append "&" o))
65
66 (define (hex2:offset o)
67   (string-append "%" o))
68
69 (define (hex2:offset1 o)
70   (string-append "!" o))
71
72 (define (object->hex2 o)
73   (let* ((functions (assoc-ref o 'functions))
74          (function-names (map car functions))
75          (globals (assoc-ref o 'globals))
76          (global-names (map car globals))
77          (strings (filter (lambda (g) (and (pair? g) (eq? (car g) #:string))) global-names)))
78     (define (string->label o)
79       (let ((index (list-index (lambda (s) (equal? s o)) strings)))
80         ;;;(if (not index) (error "no such string:" o))
81        (format #f "string_~a" index)))
82     (define (text->hex2 o)
83       (pmatch o
84         ;; FIXME
85         ((#:address (#:string ,string)) (hex2:address (string->label `(#:string ,string))))
86         ((#:string (#:address ,address)) (hex2:address address))
87         ((#:address (#:address ,address)) (hex2:address address))
88
89         ((#:string ,string) (hex2:address (string->label o)))
90         ((#:address ,address) (hex2:address address))
91         ((#:offset ,offset) (hex2:offset offset))
92         ((#:offset1 ,offset1) (hex2:offset1 offset1))
93         (_ (cond ((char? o) (text->hex2 (char->integer o)))
94                  ((string? o) (format #f "~a" o))
95                  ((number? o) (string-append (if (and (>= o 0) (< o 16)) "0" "")
96                                              (number->string
97                                               (if (>= o 0) o (+ o #x100))
98                                               16)))
99                  (else (format #f "~a" o))))))
100     (define (write-function o)
101       (let ((name (car o))
102             (text (cdr o)))
103         (define (line->hex2 o)
104           (cond ((null? o))
105                 ((not (pair? o))
106                  (display (text->hex2 o)))
107                 ((string? (car o))
108                  (format #t ";; ~a" (car o))
109                  (display (string-join (map text->hex2 (cdr o)) " ")))
110                 ((number? (car o))
111                  (display (string-join (map text->hex2 o) " ")))
112                 ((eq? (car o) #:label)
113                  ;;FIXME: more support for local labels?
114                  ;;(format #t ":local_~a_~a" name (cadr o))
115                  ;;(format #t ":~a_~a" name (cadr o))
116                  (format #t ":~a" (cadr o)))
117                 ((eq? (car o) #:comment)
118                  (format #t "  # ~a" (cadr o)))
119                 ;; ((and (pair? (car o)) (eq? (caar o) #:label))
120                 ;;  (write (car o)))
121                 (else (error "line->hex2 invalid line:" o)))
122           (newline))
123         (format #t "\n\n:~a\n" name)
124         (for-each line->hex2 text)))
125     (define (write-global o)
126       (define (labelize o)
127         (if (not (string? o)) o
128             (let* ((label o)
129                    (function? (member label function-names))
130                    (string-label (string->label label))
131                    (string? (not (equal? string-label "string_#f")))
132                    (global? (member label global-names)))
133               (if (or global? string?) (format #f "&~a" label)
134                   (begin (if (not function?) (stderr "warning: unresolved label: ~s\n" label))
135                          (format #f "&~a" label))))))
136       (let* ((label (if (not (and (pair? (car o)) (eq? (caar o) #:string))) (car o)
137                        (string->label (car o))))
138              (data (cdr o))
139              (data (filter-map labelize data)))
140         (format #t "\n:~a\n" label)
141         (display (string-join (map text->hex2 data) " "))
142         (newline)))
143     (display "\n:HEX2_text")
144     (for-each write-function (filter cdr functions))
145     (display "\n\n:ELF_data\n") ;; FIXME
146     (display "\n\n:HEX2_data\n")
147     (for-each write-global globals)))