mescc: Posixify interface.
[mes.git] / module / mescc / mescc.scm
1 ;;; -*-scheme-*-
2
3 ;;; Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2016,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 (define-module (mescc mescc)
22   #:use-module (srfi srfi-1)
23   #:use-module (srfi srfi-26)
24   #:use-module (ice-9 pretty-print)
25   #:use-module (ice-9 getopt-long)
26   #:use-module (mes guile)
27   #:use-module (mes misc)
28
29   #:use-module (mescc preprocess)
30   #:use-module (mescc compile)
31   #:use-module (mescc M1)
32   #:export (mescc:preprocess
33             mescc:compile
34             mescc:assemble
35             mescc:link))
36
37 (define (mescc:preprocess options)
38   (let* ((defines (reverse (filter-map (multi-opt 'define) options)))
39          (includes (reverse (filter-map (multi-opt 'include) options)))
40          (pretty-print/write (string->symbol (option-ref options 'write (if guile? "pretty-print" "write"))))
41          (pretty-print/write (if (eq? pretty-print/write 'pretty-print) pretty-print write))
42          (files (option-ref options '() '("a.c")))
43          (input-file-name (car files))
44          (ast-file-name (cond ((and (option-ref options 'preprocess #f)
45                                     (option-ref options 'output #f)))
46                               (else (replace-suffix input-file-name ".E"))))
47          (prefix (option-ref options 'prefix "")))
48     (with-output-to-file ast-file-name
49       (lambda _ (for-each (cut c->ast prefix defines includes write <>) files)))))
50
51 (define (c->ast prefix defines includes write file-name)
52   (with-input-from-file file-name
53     (cut write (c99-input->ast #:prefix prefix #:defines defines #:includes includes))))
54
55 (define (mescc:compile options)
56   (let* ((files (option-ref options '() '("a.c")))
57          (input-file-name (car files))
58          (M1-file-name (cond ((and (option-ref options 'compile #f)
59                                    (option-ref options 'output #f)))
60                              (else (replace-suffix input-file-name ".S"))))
61          (infos (map (cut file->info options <>) files))
62          (verbose? (option-ref options 'verbose #f)))
63     (when verbose?
64       (stderr "dumping: ~a\n" M1-file-name))
65     (with-output-to-file M1-file-name
66       (cut infos->M1 M1-file-name infos))
67     M1-file-name))
68
69 (define (file->info options file-name)
70   (cond ((.c? file-name) (c->info options file-name))
71         ((.E? file-name) (E->info options file-name))))
72
73 (define (c->info options file-name)
74   (let ((defines (reverse (filter-map (multi-opt 'define) options)))
75         (includes (reverse (filter-map (multi-opt 'include) options)))
76         (prefix (option-ref options 'prefix "")))
77     (with-input-from-file file-name
78       (cut c99-input->info #:prefix prefix #:defines defines #:includes includes))))
79
80 (define (E->info options file-name)
81   (let ((ast (with-input-from-file file-name read)))
82     (c99-ast->info ast)))
83
84 (define (mescc:assemble options)
85   (let* ((files (option-ref options '() '("a.c")))
86          (input-file-name (car files))
87          (hex2-file-name (cond ((and (option-ref options 'assemble #f)
88                                      (option-ref options 'output #f)))
89                                (else (replace-suffix input-file-name ".o"))))
90          (S-files (filter .S? files))
91          (hex2-files  M1->hex2 ) ;; FIXME
92          (source-files (filter (disjoin .c? .E?) files))
93          (infos (map (cut file->info options <>) source-files)))
94     (if (and (pair? S-files) (pair? infos))
95         (error "mixing source and object not supported:" source-files S-files))
96     (when (pair? S-files)
97       (M1->hex2 options S-files))
98     (when (pair? infos)
99       (infos->hex2 options hex2-file-name infos))
100     hex2-file-name))
101
102 (define (mescc:link options)
103   (define (library->hex2 o)
104     (prefix-file options (string-append "lib/lib" o "-mes.o")))
105   (let* ((files (option-ref options '() '("a.c")))
106          (source-files (filter (disjoin .c? .E?) files))
107          (S-files (filter .S? files))
108          (o-files (filter .o? files))
109          (input-file-name (car files))
110          (hex2-file-name (if (or (string-suffix? ".hex2" input-file-name)
111                                  (string-suffix? ".o" input-file-name)) input-file-name
112                                  (replace-suffix input-file-name ".o")))
113          (infos (map (cut file->info options <>) source-files))
114          (S-files (filter .S? files))
115          (hex2-files (filter .o? files))
116          (hex2-files (if (null? S-files) hex2-files
117                          (append hex2-files (list (M1->hex2 options S-files)))))
118          (hex2-files (if (null? infos) hex2-files
119                          (append hex2-files
120                                  (list (infos->hex2 options hex2-file-name infos)))))
121          (libraries (filter-map (multi-opt 'library) options))
122          (libraries (if (pair? libraries) libraries '("c")))
123          (hex2-libraries (map library->hex2 libraries))
124          (hex2-files (append hex2-files hex2-libraries))
125          (S-files (append S-files (map (cut replace-suffix <> ".S") hex2-libraries)))
126          (debug-info? (option-ref options 'debug-info #f))
127          (S-files (cons (replace-suffix input-file-name ".S") S-files))
128          (elf-footer (and debug-info?
129                           (or (M1->blood-elf options S-files)
130                               (exit 1)))))
131     (or (hex2->elf options hex2-files #:elf-footer elf-footer)
132         (exit 1))))
133
134 (define (infos->hex2 options hex2-file-name infos)
135   (let* ((input-file-name (car (option-ref options '() '("a.c"))))
136          (M1-file-name (replace-suffix hex2-file-name ".S"))
137          (options (acons 'compile #t options)) ; ugh
138          (options (acons 'output hex2-file-name options))
139          (verbose? (option-ref options 'verbose #f)))
140     (when verbose?
141       (stderr "dumping: ~a\n" M1-file-name))
142     (with-output-to-file M1-file-name
143       (cut infos->M1 M1-file-name infos))
144     (or (M1->hex2 options (list M1-file-name))
145         (exit 1))))
146
147 (define (M1->hex2 options M1-files)
148   (let* ((input-file-name (car (option-ref options '() '("a.c"))))
149          (M1-file-name (car M1-files))
150          (hex2-file-name (cond ((and (option-ref options 'assemble #f)
151                                      (option-ref options 'output #f)))
152                                ((option-ref options 'assemble #f)
153                                 (replace-suffix input-file-name ".o"))
154                                (else (replace-suffix M1-file-name ".o"))))
155          (verbose? (option-ref options 'verbose #f))
156          (M1 (or (getenv "M1") "M1"))
157          (command `(,M1
158                     "--LittleEndian"
159                     "--Architecture=1"
160                     "-f" ,(prefix-file options "stage0/x86.M1")
161                     ,@(append-map (cut list "-f" <>) M1-files)
162                     "-o" ,hex2-file-name)))
163     (when verbose?
164       (stderr "~a\n" (string-join command)))
165     (and (zero? (apply system* command))
166          hex2-file-name)))
167
168 (define* (hex2->elf options hex2-files #:key elf-footer)
169   (let* ((input-file-name (car (option-ref options '() '("a.c"))))
170          (elf-file-name (cond ((option-ref options 'output #f))
171                               (else (replace-suffix input-file-name ""))))
172          (verbose? (option-ref options 'verbose #f))
173          (elf-footer (or elf-footer (prefix-file options "stage0/elf32-footer-single-main.hex2")))
174          (hex2 (or (getenv "HEX2") "hex2"))
175          (command `(,hex2
176                     "--LittleEndian"
177                     "--Architecture=1"
178                     "--BaseAddress=0x1000000"
179                     "-f" ,(prefix-file options "stage0/elf32-header.hex2")
180                     "-f" ,(prefix-file options "lib/crt1.o")
181                     ,@(append-map (cut list "-f" <>) hex2-files)
182                     "-f" ,elf-footer
183                     "--exec_enable"
184                     "-o" ,elf-file-name)))
185     (when verbose?
186       (stderr "command=~s\n" command)
187       (format (current-error-port) "~a\n" (string-join command)))
188     (and (zero? (apply system* command))
189          elf-file-name)))
190
191 (define (M1->blood-elf options M1-files)
192   (let* ((M1-file-name (car M1-files))
193          (M1-blood-elf-footer (string-append M1-file-name ".blood-elf"))
194          (hex2-file-name (replace-suffix M1-file-name ".o"))
195          (blood-elf-footer (string-append hex2-file-name ".blood-elf"))
196          (verbose? (option-ref options 'verbose #f))
197          (blood-elf (or (getenv "BLOOD_ELF") "blood-elf"))
198          (command `(,blood-elf
199                       "-f" ,(prefix-file options "stage0/x86.M1")
200                       ,@(append-map (cut list "-f" <>) M1-files)
201                       "-o" ,M1-blood-elf-footer)))
202     (when verbose?
203         (format (current-error-port) "~a\n" (string-join command)))
204     (and (zero? (apply system* command))
205          (let* ((options (acons 'compile #t options)) ; ugh
206                 (options (acons 'output blood-elf-footer options)))
207            (M1->hex2 options (list M1-blood-elf-footer))))))
208
209 (define (replace-suffix file-name suffix)
210   (let* ((parts (string-split file-name #\.))
211          (base (if (pair? (cdr parts)) (drop-right parts 1))))
212     (string-append (string-join base ".") suffix)))
213
214 (define (prefix-file options file-name)
215   (let ((prefix (option-ref options 'prefix "")))
216     (define (prefix-file o)
217       (if (string-null? prefix) o (string-append prefix "/" o)))
218     (prefix-file file-name)))
219
220 (define (multi-opt option-name) (lambda (o) (and (eq? (car o) option-name) (cdr o))))
221
222 (define (.c? o) (or (string-suffix? ".c" o)
223                     (string-suffix? ".M2" o)))
224 (define (.E? o) (string-suffix? ".E" o))
225 (define (.S? o) (or (string-suffix? ".S" o)
226                     (string-suffix? ".mes-S" o)
227                     (string-suffix? "S" o)
228                     (string-suffix? ".M1" o)))
229 (define (.o? o) (or (string-suffix? ".o" o)
230                     (string-suffix? ".mes-o" o)
231                     (string-suffix? "o" o)
232                     (string-suffix? ".hex2" o)))