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