54091156b2c03d368cc6b644d63bcc61236c52b6
[mes.git] / module / mes / M1.mes
1 ;;; -*-scheme-*-
2
3 ;;; Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2017,2018 Jan (janneke) 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       (string-append "%" (number->string o))))
82
83 (define (hex2:immediate1 o)
84   (if hex? (string-append "!0x" (dec->hex o))
85       (string-append "!" (number->string o))))
86
87 (define (object->M1 o)
88   (stderr "dumping M1: object\n")
89   (let* ((functions (assoc-ref o 'functions))
90          (function-names (map car functions))
91          (file-name (car (or (assoc-ref o 'file-names) function-names)))
92          (globals (assoc-ref o 'globals))
93          (global-names (map car globals))
94          (strings (filter (lambda (g) (and (pair? g) (eq? (car g) #:string))) global-names)))
95     (define (string->label o)
96       (let ((index (list-index (lambda (s) (equal? s o)) strings)))
97         (if index
98             (string-append "_string_" file-name "_" (number->string index))
99             "")))
100     (define (text->M1 o)
101       (cond
102        ((char? o) (text->M1 (char->integer o)))
103        ((string? o) o)
104        ((symbol? o) (symbol->string o))
105        ((number? o) (let ((o (if (< o #x80) o (- o #x100))))
106                       (if hex? (string-append "!0x"
107                                               (if (and (>= o 0) (< o 16)) "0" "")
108                                               (number->string o 16))
109                           (string-append "!" (number->string o)))))
110        ((and (pair? o) (keyword? (car o)))
111         (pmatch o
112          ;; FIXME
113          ((#:address (#:string ,string)) (hex2:address (string->label `(#:string ,string))))
114          ((#:string (#:address ,address)) (hex2:address address))
115          ((#:address (#:address ,address)) (hex2:address address))
116          ((#:string ,string) (hex2:address (string->label o)))
117          ((#:address ,address) (hex2:address address))
118          ((#:offset ,offset) (hex2:offset offset))
119          ((#:offset1 ,offset1) (hex2:offset1 offset1))
120          ((#:immediate ,immediate) (hex2:immediate immediate))
121          ((#:immediate1 ,immediate1) (hex2:immediate1 immediate1))))
122        ((pair? o) (string-join (map text->M1 o)))))
123     (define (write-function o)
124       (let ((name (car o))
125             (text (cdr o)))
126         (define (line->M1 o)
127           (cond ((eq? (car o) #:label)
128                  (display (string-append ":" (cadr o))))
129                 ((eq? (car o) #:comment)
130                  (display (string-append "\t\t\t\t\t# " (text->M1 (cadr o)))))
131                 ((or (string? (car o)) (symbol? (car o)))
132                  (display (string-append "\t" (string-join (map text->M1 o) " "))))
133                 (else (error "line->M1 invalid line:" o)))
134           (newline))
135         (display (string-append "    :" name "\n") (current-error-port))
136         (display (string-append "\n\n:" name "\n"))
137         (for-each line->M1 (apply append text))))
138     (define (write-global o)
139       (define (labelize o)
140         (if (not (string? o)) o
141             (let* ((label o)
142                    (function? (member label function-names))
143                    (string-label (string->label label))
144                    (string? (not (equal? string-label "_string_#f")))
145                    (global? (member label global-names)))
146               (if (or global? string?) (string-append "&" label)
147                   (begin (if (not function?) (stderr "warning: unresolved label: ~s\n" label))
148                          (string-append "&" label))))))
149       (let* ((label (if (not (and (pair? (car o)) (eq? (caar o) #:string))) (car o)
150                         (string->label (car o))))
151              (foo (if (not (eq? (car (string->list label)) #\_))
152                       (display (string-append "    :" label "\n") (current-error-port))))
153              (data (cdr o))
154              (data (filter-map labelize data))
155              (len (length data))
156              (string-max (or (and=> (getenv "M1_STRING_MAX") string->number) 80)))
157         (display (string-append "\n:" label "\n"))
158         (cond ((and (< len string-max)
159                     (char? (car data))
160                     (eq? (last data) #\nul)
161                     (not (find (cut memq <> '(#\nul #\backspace #\return #\" #\')) (list-head data (1- (length data)))))
162                     (not (any (lambda (ch) (>= (char->integer ch) #x80)) data)))
163                (display (string-append "\"" (list->string (list-head data (1- (length data)))) "\"")))
164               (else (display (string-join (map text->M1 data) " "))))
165         (newline)))
166     (display "M1: functions\n" (current-error-port))
167     (for-each write-function (filter cdr functions))
168     (when (assoc-ref functions "main")
169       (display "\n\n:ELF_data\n") ;; FIXME
170       (display "\n\n:HEX2_data\n"))
171     (display "M1: globals\n" (current-error-port))
172     (for-each write-global globals)))