mescc: Support -nodefaultlibs, -nostartfiles, -nostdlib.
[mes.git] / module / mescc / mescc.scm
1 ;;; GNU Mes --- Maxwell Equations of Software
2 ;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
3 ;;;
4 ;;; This file is part of GNU Mes.
5 ;;;
6 ;;; GNU Mes is free software; you can redistribute it and/or modify it
7 ;;; under the terms of the GNU General Public License as published by
8 ;;; the Free Software Foundation; either version 3 of the License, or (at
9 ;;; your option) any later version.
10 ;;;
11 ;;; GNU Mes is distributed in the hope that it will be useful, but
12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14 ;;; GNU General Public License for more details.
15 ;;;
16 ;;; You should have received a copy of the GNU General Public License
17 ;;; along with GNU Mes.  If not, see <http://www.gnu.org/licenses/>.
18
19 (define-module (mescc mescc)
20   #:use-module (srfi srfi-1)
21   #:use-module (srfi srfi-26)
22   #:use-module (ice-9 pretty-print)
23   #:use-module (ice-9 getopt-long)
24   #:use-module (mes guile)
25   #:use-module (mes misc)
26
27   #:use-module (mescc i386 info)
28   #:use-module (mescc x86_64 info)
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 GUILE-with-output-to-file with-output-to-file)
38 (define (with-output-to-file file-name thunk)
39   (if (equal? file-name "-") (thunk)
40       (GUILE-with-output-to-file file-name thunk)))
41
42 (define (mescc:preprocess options)
43   (let* ((pretty-print/write (string->symbol (option-ref options 'write (if guile? "pretty-print" "write"))))
44          (pretty-print/write (if (eq? pretty-print/write 'pretty-print) pretty-print write))
45          (files (option-ref options '() '("a.c")))
46          (input-file-name (car files))
47          (ast-file-name (cond ((and (option-ref options 'preprocess #f)
48                                     (option-ref options 'output #f)))
49                               (else (replace-suffix input-file-name ".E"))))
50          (dir (dirname input-file-name))
51          (defines (reverse (filter-map (multi-opt 'define) options)))
52          (includes (reverse (filter-map (multi-opt 'include) options)))
53          (includes (cons dir includes))
54          (prefix (option-ref options 'prefix ""))
55          (machine (option-ref options 'machine "32"))
56          (arch (if (equal? machine "32") "__i386__=1" "__x86_64__=1"))
57          (defines (cons arch defines)))
58     (with-output-to-file ast-file-name
59       (lambda _ (for-each (cut c->ast prefix defines includes write <>) files)))))
60
61 (define (c->ast prefix defines includes write file-name)
62   (with-input-from-file file-name
63     (cut write (c99-input->ast #:prefix prefix #:defines defines #:includes includes))))
64
65 (define (mescc:compile options)
66   (let* ((files (option-ref options '() '("a.c")))
67          (input-file-name (car files))
68          (M1-file-name (cond ((and (option-ref options 'compile #f)
69                                    (option-ref options 'output #f)))
70                              (else (replace-suffix input-file-name ".S"))))
71          (infos (map (cut file->info options <>) files))
72          (verbose? (option-ref options 'verbose #f))
73          (align? (option-ref options 'align #f)))
74     (when verbose?
75       (stderr "dumping: ~a\n" M1-file-name))
76     (with-output-to-file M1-file-name
77       (cut infos->M1 M1-file-name infos #:align? align?))
78     M1-file-name))
79
80 (define (file->info options file-name)
81   (cond ((.c? file-name) (c->info options file-name))
82         ((.E? file-name) (E->info options file-name))))
83
84 (define (c->info options file-name)
85   (let* ((defines (reverse (filter-map (multi-opt 'define) options)))
86          (includes (reverse (filter-map (multi-opt 'include) options)))
87          (dir (dirname file-name))
88          (includes (cons dir includes))
89          (prefix (option-ref options 'prefix ""))
90          (machine (option-ref options 'machine "32"))
91          (info (if (equal? machine "32") (x86-info)  (x86_64-info)))
92          (arch (if (equal? machine "32") "__i386__=1" "__x86_64__=1"))
93          (defines (cons arch defines)))
94     (with-input-from-file file-name
95       (cut c99-input->info info #:prefix prefix #:defines defines #:includes includes))))
96
97 (define (E->info options file-name)
98   (let* ((ast (with-input-from-file file-name read))
99          (machine (option-ref options 'machine "32"))
100          (info (if (equal? machine "32") (x86-info)  (x86_64-info))))
101     (c99-ast->info info ast)))
102
103 (define (mescc:assemble options)
104   (let* ((files (option-ref options '() '("a.c")))
105          (input-file-name (car files))
106          (hex2-file-name (cond ((and (option-ref options 'assemble #f)
107                                      (option-ref options 'output #f)))
108                                (else (replace-suffix input-file-name ".o"))))
109          (S-files (filter .S? files))
110          (hex2-files  M1->hex2 ) ;; FIXME
111          (source-files (filter (disjoin .c? .E?) files))
112          (infos (map (cut file->info options <>) source-files)))
113     (if (and (pair? S-files) (pair? infos))
114         (error "mixing source and object not supported:" source-files S-files))
115     (when (pair? S-files)
116       (M1->hex2 options S-files))
117     (when (pair? infos)
118       (infos->hex2 options hex2-file-name infos))
119     hex2-file-name))
120
121 (define (mescc:link options)
122   (let* ((files (option-ref options '() '("a.c")))
123          (source-files (filter (disjoin .c? .E?) files))
124          (S-files (filter .S? files))
125          (o-files (filter .o? files))
126          (input-file-name (car files))
127          (hex2-file-name (if (or (string-suffix? ".hex2" input-file-name)
128                                  (string-suffix? ".o" input-file-name)) input-file-name
129                                  (replace-suffix input-file-name ".o")))
130          (infos (map (cut file->info options <>) source-files))
131          (S-files (filter .S? files))
132          (hex2-files (filter .o? files))
133          (hex2-files (if (null? S-files) hex2-files
134                          (append hex2-files (list (M1->hex2 options S-files)))))
135          (hex2-files (if (null? infos) hex2-files
136                          (append hex2-files
137                                  (list (infos->hex2 options hex2-file-name infos)))))
138          (default-libraries (if (or (option-ref options 'nodefaultlibs #f)
139                                     (option-ref options 'nostdlib #f)) '()
140                                     '("c")))
141          (libraries (filter-map (multi-opt 'library) options))
142          (libraries (delete-duplicates (append libraries default-libraries)))
143          (hex2-libraries (map (cut find-library options ".o" <>) libraries))
144          (hex2-files (append hex2-files hex2-libraries))
145          (S-files (append S-files (map (cut find-library options ".S" <>)  libraries)))
146          (debug-info? (option-ref options 'debug-info #f))
147          (S-files (cons (replace-suffix input-file-name ".S") S-files))
148          (elf-footer (and debug-info?
149                           (or (M1->blood-elf options S-files)
150                               (exit 1)))))
151     (or (hex2->elf options hex2-files #:elf-footer elf-footer)
152         (exit 1))))
153
154 (define (infos->hex2 options hex2-file-name infos)
155   (let* ((input-file-name (car (option-ref options '() '("a.c"))))
156          (M1-file-name (replace-suffix hex2-file-name ".S"))
157          (options (acons 'compile #t options)) ; ugh
158          (options (acons 'output hex2-file-name options))
159          (verbose? (option-ref options 'verbose #f))
160          (align? (option-ref options 'align #f)))
161     (when verbose?
162       (stderr "dumping: ~a\n" M1-file-name))
163     (with-output-to-file M1-file-name
164       (cut infos->M1 M1-file-name infos #:align? align?))
165     (or (M1->hex2 options (list M1-file-name))
166         (exit 1))))
167
168 (define (M1->hex2 options M1-files)
169   (let* ((input-file-name (car (option-ref options '() '("a.c"))))
170          (M1-file-name (car M1-files))
171          (hex2-file-name (cond ((and (option-ref options 'assemble #f)
172                                      (option-ref options 'output #f)))
173                                ((option-ref options 'assemble #f)
174                                 (replace-suffix input-file-name ".o"))
175                                (else (replace-suffix M1-file-name ".o"))))
176          (machine (option-ref options 'machine "32"))
177          (architecture (cond
178                         ((equal? machine "32") "1")
179                         ((equal? machine "64") "2")
180                         (else "1")))
181          (m1-macros (cond
182                      ((equal? machine "32") "x86.M1")
183                      ((equal? machine "64") "x86_64.M1")
184                      (else "x86.M1")))
185          (verbose? (option-ref options 'verbose #f))
186          (M1 (or (getenv "M1") "M1"))
187          (command `(,M1
188                     "--LittleEndian"
189                     "--Architecture" ,architecture
190                     "-f" ,(arch-find options m1-macros)
191                     ,@(append-map (cut list "-f" <>) M1-files)
192                     "-o" ,hex2-file-name)))
193     (when verbose?
194       (stderr "~a\n" (string-join command)))
195     (and (zero? (apply assert-system* command))
196          hex2-file-name)))
197
198 (define* (hex2->elf options hex2-files #:key elf-footer)
199   (let* ((input-file-name (car (option-ref options '() '("a.c"))))
200          (elf-file-name (cond ((option-ref options 'output #f))
201                               (else (replace-suffix input-file-name ""))))
202          (verbose? (option-ref options 'verbose #f))
203          (hex2 (or (getenv "HEX2") "hex2"))
204          (machine (option-ref options 'machine "32"))
205          (architecture (cond
206                          ((equal? machine "32") "1")
207                          ((equal? machine "64") "2")
208                          (else "1")))
209          (base-address (option-ref options 'base-address "0x1000000"))
210          (elf-footer (or elf-footer
211                          (arch-find options (string-append
212                                              "elf" machine "-footer-single-main.hex2"))))
213          (start-files (if (or (option-ref options 'nostartfiles #f)
214                               (option-ref options 'nostdlib #f)) '()
215                               `("-f" ,(arch-find options "crt1.o"))))
216          (command `(,hex2
217                     "--LittleEndian"
218                     "--Architecture" ,architecture
219                     "--BaseAddress" ,base-address
220                     "-f" ,(arch-find options (string-append "elf" machine "-header.hex2"))
221                     ,@start-files
222                     ,@(append-map (cut list "-f" <>) hex2-files)
223                     "-f" ,elf-footer
224                     "--exec_enable"
225                     "-o" ,elf-file-name)))
226     (when verbose?
227       (stderr "~a\n" (string-join command)))
228     (and (zero? (apply assert-system* command))
229          elf-file-name)))
230
231 (define (M1->blood-elf options M1-files)
232   (let* ((M1-file-name (car M1-files))
233          (M1-blood-elf-footer (string-append M1-file-name ".blood-elf"))
234          (hex2-file-name (replace-suffix M1-file-name ".o"))
235          (blood-elf-footer (string-append hex2-file-name ".blood-elf"))
236          (verbose? (option-ref options 'verbose #f))
237          (blood-elf (or (getenv "BLOOD_ELF") "blood-elf"))
238          (machine (option-ref options 'machine "32"))
239          (m1-macros (cond
240                      ((equal? machine "32") "x86.M1")
241                      ((equal? machine "64") "x86_64.M1")
242                      (else "x86.M1")))
243          (command `(,blood-elf
244                       "-f" ,(arch-find options m1-macros)
245                       ,@(append-map (cut list "-f" <>) M1-files)
246                       "-o" ,M1-blood-elf-footer)))
247     (when verbose?
248         (format (current-error-port) "~a\n" (string-join command)))
249     (and (zero? (apply assert-system* command))
250          (let* ((options (acons 'compile #t options)) ; ugh
251                 (options (acons 'output blood-elf-footer options)))
252            (M1->hex2 options (list M1-blood-elf-footer))))))
253
254 (define (replace-suffix file-name suffix)
255   (let* ((parts (string-split file-name #\.))
256          (base (if (pair? (cdr parts)) (drop-right parts 1)))
257          (old-suffix (last parts))
258          (program-prefix (cond ((string-prefix? "x86-mes-" old-suffix) ".x86-mes-")
259                                ((string-prefix? "x86_64-mes-" old-suffix) ".x86_64-mes-")
260                                (else "."))))
261     (if (string-null? suffix)
262         (if (string-null? program-prefix) (string-join base ".")
263             (string-append (string-drop program-prefix 1) (string-join base ".")))
264         (string-append (string-join base ".") program-prefix (string-drop suffix 1)))))
265
266 (define (find-library options ext o)
267   (arch-find options (string-append "lib" o ext)))
268
269 (define* (arch-find options file-name)
270   (let* ((srcdest (or (getenv "srcdest") ""))
271          (srcdir-lib (string-append srcdest "lib"))
272          (machine (option-ref options 'machine "32"))
273          (arch (cond
274                 ((equal? machine "32") "x86-mes")
275                 ((equal? machine "64") "x86_64-mes")
276                 (else "x86-mes")))
277          (path (cons* srcdir-lib
278                       (prefix-file options "lib")
279                       (filter-map (multi-opt 'library-dir) options)))
280          (arch-file-name (string-append arch "/" file-name))
281          (verbose? (option-ref options 'verbose #f)))
282     (let ((file (search-path path arch-file-name)))
283       (when verbose?
284         (stderr "arch-find=~s\n" arch-file-name)
285         (stderr "     path=~s\n" path)
286         (stderr "  => ~s\n" file))
287       (or file
288           (error (format #f "mescc: file not found: ~s" arch-file-name))))))
289
290 (define (prefix-file options file-name)
291   (let ((prefix (option-ref options 'prefix "")))
292     (define (prefix-file o)
293       (if (string-null? prefix) o (string-append prefix "/" o)))
294     (prefix-file file-name)))
295
296 (define (assert-system* . args)
297   (let ((status (apply system* args)))
298     (when (not (zero? status))
299       (stderr "mescc: failed: ~a\n" (string-join args))
300       (exit (status:exit-val status)))
301     status))
302
303 (define (multi-opt option-name) (lambda (o) (and (eq? (car o) option-name) (cdr o))))
304
305 (define (.c? o) (or (string-suffix? ".c" o)
306                     (string-suffix? ".M2" o)))
307 (define (.E? o) (or (string-suffix? ".E" o)
308                     (string-suffix? ".mes-E" o)
309                     (string-suffix? ".x86-mes-E" o)
310                     (string-suffix? ".x86_64-mes-E" o)))
311 (define (.S? o) (or (string-suffix? ".S" o)
312                     (string-suffix? ".mes-S" o)
313                     (string-suffix? ".x86-mes-S" o)
314                     (string-suffix? ".x86_64-mes-S" o)
315                     (string-suffix? "S" o)
316                     (string-suffix? ".M1" o)))
317 (define (.o? o) (or (string-suffix? ".o" o)
318                     (string-suffix? ".mes-o" o)
319                     (string-suffix? ".x86-mes-o" o)
320                     (string-suffix? ".x86_64-mes-o" o)
321                     (string-suffix? ".hex2" o)))