mescc: Tinycc support: Compound strings as function argument.
[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 (pke . stuff)
47   (newline (current-error-port))
48   (display ";;; " (current-error-port))
49   (write stuff (current-error-port))
50   (newline (current-error-port))
51   (car (last-pair stuff)))
52
53 (define (objects->M1 file-name objects)
54   ((compose (cut object->M1 file-name <>) merge-objects) objects))
55
56 (define (object->elf file-name o)
57   ((compose M1->elf (cut object->M1 file-name <>)) o))
58
59 (define (objects->elf file-name objects)
60   ((compose M1->elf (cut object->M1 file-name <>) merge-objects) objects))
61
62 (define (merge-objects objects)
63   (let loop ((objects (cdr objects)) (object (car objects)))
64     (if (null? objects) object
65         (loop (cdr objects)
66               `((functions . ,(alist-add (assoc-ref object 'functions) (assoc-ref (car objects) 'functions)))
67                 (globals . ,(alist-add (assoc-ref object 'globals) (assoc-ref (car objects) 'globals))))))))
68
69 (define (alist-add a b)
70   (let* ((b-keys (map car b))
71          (a (filter (lambda (f) (or (cdr f) (not (member (car f) b-keys)))) a))
72          (a-keys (map car a)))
73     (append a (filter (lambda (e) (not (member (car e) a-keys))) b))))
74
75 (define (hex2:address o)
76   (string-append "&" o))
77
78 (define (hex2:offset o)
79   (string-append "%" o))
80
81 (define (hex2:offset1 o)
82   (string-append "!" o))
83
84 (define hex? #t)
85
86 (define (hex2:immediate o)
87   (if hex? (string-append "%0x" (dec->hex o))
88       (string-append "%" (number->string o))))
89
90 (define (hex2:immediate1 o)
91   (if hex? (string-append "!0x" (dec->hex o))
92       (string-append "!" (number->string o))))
93
94 (define* (display-join o #:optional (sep ""))
95   (let loop ((o o))
96     (when (pair? o)
97       (display (car o))
98       (if (pair? (cdr o))
99           (display sep))
100       (loop (cdr o)))))
101
102 (define (object->M1 file-name o)
103   (stderr "dumping M1: object\n")
104   (let* ((functions (assoc-ref o 'functions))
105          (function-names (map car functions))
106          (globals (assoc-ref o 'globals))
107          (global-names (map car globals))
108          (strings (filter (lambda (g) (and (pair? g) (eq? (car g) #:string))) global-names)))
109     (define (string->label o)
110       (let ((index (list-index (lambda (s) (equal? s o)) strings)))
111         (if index
112             (string-append "_string_" file-name "_" (number->string index))
113             (error "no such string:" o))))
114     (define (text->M1 o)
115       (cond
116        ((char? o) (text->M1 (char->integer o)))
117        ((string? o) o)
118        ((symbol? o) (symbol->string o))
119        ((number? o) (let ((o (if (< o #x80) o (- o #x100))))
120                       (if hex? (string-append "!0x"
121                                               (if (and (>= o 0) (< o 16)) "0" "")
122                                               (number->string o 16))
123                           (string-append "!" (number->string o)))))
124        ((and (pair? o) (keyword? (car o)))
125         (pmatch o
126           ;; FIXME
127           ((#:address (#:string ,string)) (hex2:address (string->label `(#:string ,string))))
128           ((#:address (#:address ,address)) (guard (string? address))
129            (hex2:address address))
130           ((#:address (#:address ,global)) (guard (global? global))
131            (hex2:address (global->string global)))
132           ((#:address ,function) (guard (function? function))
133            (hex2:address (function->string function)))
134           ((#:address ,number) (guard (number? number))
135            (string-join (map text->M1 (int->bv32 number))))
136           ((#:string ,string)
137            (hex2:address (string->label o)))
138           ((#:address ,address) (guard (string? address)) (hex2:address address))
139           ((#:address ,global) (guard (global? global))
140            (hex2:address (global->string global)))
141           ((#:offset ,offset) (hex2:offset offset))
142           ((#:offset1 ,offset1) (hex2:offset1 offset1))
143           ((#:immediate ,immediate) (hex2:immediate immediate))
144           ((#:immediate1 ,immediate1) (hex2:immediate1 immediate1))
145           (_ (error "text->M1 no match o" o))))
146        ((pair? o) (string-join (map text->M1 o)))))
147     (define (write-function o)
148       (let ((name (car o))
149             (text (function:text (cdr o))))
150         (define (line->M1 o)
151           (cond ((eq? (car o) #:label)
152                  (display (string-append ":" (cadr o))))
153                 ((eq? (car o) #:comment)
154                  (display "\t\t\t\t\t# ")
155                  (display (text->M1 (cadr o))))
156                 ((or (string? (car o)) (symbol? (car o)))
157                  (display "\t" )
158                  (display-join (map text->M1 o) " "))
159                 (else (error "line->M1 invalid line:" o)))
160           (newline))
161         (display (string-append "    :" name "\n") (current-error-port))
162         (display (string-append "\n\n:" name "\n"))
163         (for-each line->M1 (apply append text))))
164     (define (write-global o)
165       (define (labelize o)
166         (if (not (string? o)) o
167             (let* ((label o)
168                    (function? (member label function-names))
169                    (string-label (string->label label))
170                    (string? (not (equal? string-label "_string_#f"))))
171               (cond ((and (pair? o) (global? (cdr o))) (string-append "&" (global->string o)))
172                     ((and (not string?) (not function?)) (stderr "warning: unresolved label: ~s\n" label))
173                     (else (string-append "&" label))))))
174       (let* ((label (cond
175                      ((and (pair? (car o)) (eq? (caar o) #:string))
176                       (string->label (car o)))
177                      ((global? (cdr o)) (global->string (cdr o)))
178                      (else (car o))))
179              (string? (string-prefix? "_string" label))
180              (foo (if (not (eq? (car (string->list label)) #\_))
181                       (display (string-append "    :" label "\n") (current-error-port))))
182              (data ((compose global:value cdr) o))
183              (data (filter-map labelize data))
184              (len (length data))
185              (string-max (or (and=> (getenv "M1_STRING_MAX") string->number) 256))
186              (string-data (and string? (list-head data (1- (length data))))))
187         (display (string-append "\n:" label "\n"))
188         (if (and string-data
189                  (< len string-max)
190                  (char? (car data))
191                  (eq? (last data) #\nul)
192                  (not (find (cut memq <> '(#\")) string-data))
193                  (not (any (lambda (ch)
194                              (or (and (not (memq ch '(#\tab #\newline)))
195                                       (< (char->integer ch) #x20))
196                                  (>= (char->integer ch) #x80))) string-data)))
197             (display (string-append "\"" (list->string string-data) "\""))
198             (display-join (map text->M1 data) " "))
199         (newline)))
200     (display "M1: functions\n" (current-error-port))
201     (for-each write-function (filter cdr functions))
202     (when (assoc-ref functions "main")
203       (display "\n\n:ELF_data\n") ;; FIXME
204       (display "\n\n:HEX2_data\n"))
205     (display "M1: globals\n" (current-error-port))
206     (for-each write-global globals)))