mescc: Fix dumping of strings > M1_STRING_MAX.
[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* (display-join o #:optional (sep ""))
88   (let loop ((o o))
89     (when (pair? o)
90       (display (car o))
91       (if (pair? (cdr o))
92           (display sep))
93       (loop (cdr o)))))
94
95 (define (object->M1 o)
96   (stderr "dumping M1: object\n")
97   (let* ((functions (assoc-ref o 'functions))
98          (function-names (map car functions))
99          (file-name (car (or (assoc-ref o 'file-names) function-names)))
100          (globals (assoc-ref o 'globals))
101          (global-names (map car globals))
102          (strings (filter (lambda (g) (and (pair? g) (eq? (car g) #:string))) global-names)))
103     (define (string->label o)
104       (let ((index (list-index (lambda (s) (equal? s o)) strings)))
105         (if index
106             (string-append "_string_" file-name "_" (number->string index))
107             "")))
108     (define (text->M1 o)
109       (cond
110        ((char? o) (text->M1 (char->integer o)))
111        ((string? o) o)
112        ((symbol? o) (symbol->string o))
113        ((number? o) (let ((o (if (< o #x80) o (- o #x100))))
114                       (if hex? (string-append "!0x"
115                                               (if (and (>= o 0) (< o 16)) "0" "")
116                                               (number->string o 16))
117                           (string-append "!" (number->string o)))))
118        ((and (pair? o) (keyword? (car o)))
119         (pmatch o
120          ;; FIXME
121          ((#:address (#:string ,string)) (hex2:address (string->label `(#:string ,string))))
122          ((#:string (#:address ,address)) (hex2:address address))
123          ((#:address (#:address ,address)) (hex2:address address))
124          ((#:string ,string) (hex2:address (string->label o)))
125          ((#:address ,address) (hex2:address address))
126          ((#:offset ,offset) (hex2:offset offset))
127          ((#:offset1 ,offset1) (hex2:offset1 offset1))
128          ((#:immediate ,immediate) (hex2:immediate immediate))
129          ((#:immediate1 ,immediate1) (hex2:immediate1 immediate1))))
130        ((pair? o) (string-join (map text->M1 o)))))
131     (define (write-function o)
132       (let ((name (car o))
133             (text (cdr o)))
134         (define (line->M1 o)
135           (cond ((eq? (car o) #:label)
136                  (display (string-append ":" (cadr o))))
137                 ((eq? (car o) #:comment)
138                  (display "\t\t\t\t\t# ")
139                  (display (text->M1 (cadr o))))
140                 ((or (string? (car o)) (symbol? (car o)))
141                  (display "\t" )
142                  (display-join (map text->M1 o) " "))
143                 (else (error "line->M1 invalid line:" o)))
144           (newline))
145         (display (string-append "    :" name "\n") (current-error-port))
146         (display (string-append "\n\n:" name "\n"))
147         (for-each line->M1 (apply append text))))
148     (define (write-global o)
149       (define (labelize o)
150         (if (not (string? o)) o
151             (let* ((label o)
152                    (function? (member label function-names))
153                    (string-label (string->label label))
154                    (string? (not (equal? string-label "_string_#f")))
155                    (global? (member label global-names)))
156               (if (or global? string?) (string-append "&" label)
157                   (begin (if (not function?) (stderr "warning: unresolved label: ~s\n" label))
158                          (string-append "&" label))))))
159       (let* ((label (if (not (and (pair? (car o)) (eq? (caar o) #:string))) (car o)
160                         (string->label (car o))))
161              (string? (string-prefix? "_string" label))
162              (foo (if (not (eq? (car (string->list label)) #\_))
163                       (display (string-append "    :" label "\n") (current-error-port))))
164              (data (cdr o))
165              (data (filter-map labelize data))
166              (len (length data))
167              (string-max (or (and=> (getenv "M1_STRING_MAX") string->number) 256))
168              (string-data (and string? (list-head data (1- (length data))))))
169         (display (string-append "\n:" label "\n"))
170         (if (and string-data
171                  (< len string-max)
172                  (char? (car data))
173                  (eq? (last data) #\nul)
174                  (not (find (cut memq <> '(#\")) string-data))
175                  (not (any (lambda (ch)
176                              (or (and (not (memq ch '(#\tab #\newline)))
177                                       (< (char->integer ch) #x20))
178                                  (>= (char->integer ch) #x80))) string-data)))
179             (display (string-append "\"" (list->string string-data) "\""))
180             (display-join (map text->M1 data) " "))
181         (newline)))
182     (display "M1: functions\n" (current-error-port))
183     (for-each write-function (filter cdr functions))
184     (when (assoc-ref functions "main")
185       (display "\n\n:ELF_data\n") ;; FIXME
186       (display "\n\n:HEX2_data\n"))
187     (display "M1: globals\n" (current-error-port))
188     (for-each write-global globals)))