scripts/mescc

   1 #! /bin/sh
   2 # -*-scheme-*-
   3 mes_p=$(type -p mes)
   4 if [ '(' -z "$mes_p" -a -z "$MES" ')' -o "$MES" = "guile" -o "$MES" = "mes.guile" ]; then
   5     GODIR=${GODIR-@GODIR@}
   6     GUILEDIR=${GUILEDIR-@GUILEDIR@}
   7     [ "$GODIR" = @"GODIR"@ ] && GODIR=$(dirname $0)
   8     [ "$GUILEDIR" = @"GUILEDIR"@ ] && GUILEDIR=$(dirname $0)/../guile
   9     export GUILE_AUTO_COMPILE=${GUILE_AUTO_COMPILE-0}
  10     GUILE_LOAD_COMPILED_PATH=$GODIR:$GUILE_LOAD_COMPILED_PATH
  11     exec ${GUILE-guile} -L $GUILEDIR -e '(mescc)' -s "$0" "$@"
  12 else
  13     MES=${MES-$(dirname $0)/mes}
  14     PREFIX=${PREFIX-@PREFIX@}
  15     if [ "$MES_PREFIX" = @PREFIX""@ ]
  16     then
  17         MES_PREFIX=$(cd $(dirname $0)/.. && pwd)
  18         export MES_PREFIX
  19     else
  20         MES_PREFIX=${MES_PREFIX-$PREFIX/share/mes}
  21     fi
  22     MES_MODULEDIR=${MES_MODULEDIR-$MES_PREFIX/"module"}
  23     export MES_MODULEDIR
  24     $MES -s $0 "$@"
  25     exit $?
  26 fi
  27 !#
  28
  29 ;;; Mes --- Maxwell Equations of Software
  30 ;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
  31 ;;;
  32 ;;; This file is part of Mes.
  33 ;;;
  34 ;;; Mes is free software; you can redistribute it and/or modify it
  35 ;;; under the terms of the GNU General Public License as published by
  36 ;;; the Free Software Foundation; either version 3 of the License, or (at
  37 ;;; your option) any later version.
  38 ;;;
  39 ;;; Mes is distributed in the hope that it will be useful, but
  40 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  41 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  42 ;;; GNU General Public License for more details.
  43 ;;;
  44 ;;; You should have received a copy of the GNU General Public License
  45 ;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
  46
  47 #!
  48 Run with Guile-1.8:
  49 GUILE='~/src/guile-1.8/build/pre-inst-guile --debug -q' scripts/mescc
  50 !#
  51
  52 (define-module (mescc)
  53   #:use-module (language c99 info)
  54   #:use-module (language c99 compiler)
  55   #:use-module (mes elf)
  56   #:use-module (mes M1)
  57   #:use-module (ice-9 getopt-long)
  58   #:use-module (ice-9 pretty-print)
  59   #:use-module (srfi srfi-1)
  60   #:use-module (srfi srfi-26)
  61   #:export (main))
  62
  63 (define %prefix (if (string-prefix? "@PREFIX" "@PREFIX@") (or (getenv "MES_PREFIX") "") "@PREFIX@"))
  64
  65 (cond-expand
  66  (mes
  67   (define %scheme "mes")
  68   (define (set-port-encoding! port encoding) #t))
  69  (guile-2
  70   (define %scheme "guile")
  71   (define-macro (mes-use-module . rest) #t)
  72   (module-define! (resolve-module '(language c99 compiler)) '%prefix %prefix))
  73  (guile
  74   (use-modules (ice-9 syncase))
  75   (define %scheme "guile")
  76   (define-macro (mes-use-module . rest) #t)
  77   (module-define! (resolve-module '(language c99 compiler)) '%prefix %prefix)))
  78
  79 (define guile? (equal? %scheme "guile"))
  80
  81 (mes-use-module (mes guile))
  82 (mes-use-module (mes getopt-long))
  83 (mes-use-module (mes pretty-print))
  84 (mes-use-module (language c99 info))
  85 (mes-use-module (language c99 compiler))
  86 (mes-use-module (mes display))
  87 (mes-use-module (mes elf))
  88 (mes-use-module (mes M1))
  89 (mes-use-module (srfi srfi-1))
  90 (mes-use-module (srfi srfi-26))
  91
  92 (format (current-error-port) "mescc[~a]...\n" %scheme)
  93
  94 (define (parse-opts args)
  95   (let* ((option-spec
  96           '((c (single-char #\c))
  97             (define (single-char #\D) (value #t))
  98             (E (single-char #\E))
  99             (g (single-char #\g))
 100             (help (single-char #\h))
 101             (include (single-char #\I) (value #t))
 102             (o (single-char #\o) (value #t))
 103             (version (single-char #\V))
 104             (write (single-char #\w) (value #t))))
 105          (options (getopt-long args option-spec))
 106          (help? (option-ref options 'help #f))
 107          (files (option-ref options '() '()))
 108          (usage? (and (not help?) (null? files)))
 109          (version? (option-ref options 'version #f)))
 110     (or
 111      (and version?
 112           (format (current-output-port) "mescc (mes) ~a\n" %version))
 113      (and (or help? usage?)
 114           (format (or (and usage? (current-error-port)) (current-output-port)) "\
 115 Usage: mescc [OPTION]... FILE...
 116   -c                 compile and assemble, but do not link
 117   -D DEFINE          define DEFINE
 118   -E                 preprocess only; do not compile, assemble or link
 119   -g                 add debug info [GDB, objdump] TODO: hex2 footer
 120   -h, --help         display this help and exit
 121   -I DIR             append DIR to include path
 122   -o FILE            write output to FILE
 123   -v, --version      display version and exit
 124   -w,--write=TYPE    dump Nyacc AST using TYPE {pretty-print,write}
 125
 126 Environment variables:
 127
 128   MES=BINARY         run on mes-executable BINARY {mes,guile}
 129   MES_DEBUG=LEVEL    show debug output with verbosity LEVEL {0..5}
 130   NYACC_TRACE=1      show Nyacc progress
 131 ")
 132           (exit (or (and usage? 2) 0)))
 133      options)))
 134
 135 (define (read-object file)
 136   (let ((char (with-input-from-file file read-char)))
 137     (if (eq? char #\#) (error "hex2 format not supported:" file)))
 138   (with-input-from-file file read))
 139
 140 (define (main:ast->info file)
 141   (let ((ast (with-input-from-file file read)))
 142     (c99-ast->info ast)))
 143
 144 (define (source->ast write defines includes)
 145   (lambda (file)
 146     (with-input-from-file file
 147       (lambda ()
 148         (write (c99-input->ast #:defines defines #:includes includes))))))
 149
 150 (define (source->info defines includes)
 151   (lambda (file)
 152     (with-input-from-file file
 153       (lambda ()
 154         ((c99-input->info #:defines defines #:includes includes))))))
 155
 156 (define (ast? o)
 157   (or (string-suffix? ".E" o)
 158       (string-suffix? (string-append "." %scheme "-E") o)
 159       (string-suffix? "-E" o)))
 160
 161 (define (object? o)
 162   (or (string-suffix? ".o" o)
 163       (string-suffix? (string-append "." %scheme "-o") o)
 164       (string-suffix? "-o" o)))
 165
 166 (define (main args)
 167   (let* ((options (parse-opts args))
 168          (files (option-ref options '() '()))
 169          (file (car files))
 170          (preprocess? (option-ref options 'E #f))
 171          (compile? (option-ref options 'c #f))
 172          (debug-info? (option-ref options 'g #f))
 173          (asts (filter ast? files))
 174          (objects (filter object? files))
 175          (sources (filter (cut string-suffix? ".c" <>) files))
 176          (base (substring file (1+ (or (string-rindex file #\/) -1)) (- (string-length file) 2)))
 177          (out (option-ref options 'o (cond (compile? (string-append base ".o"))
 178                                            (preprocess? (string-append base ".E"))
 179                                            (else "a.out"))))
 180          (multi-opt (lambda (option) (lambda (o) (and (eq? (car o) option) (cdr o)))))
 181          (defines (reverse (filter-map (multi-opt 'define) options)))
 182          (includes (reverse (filter-map (multi-opt 'include) options)))
 183          (pretty-print/write (string->symbol (option-ref options 'write (if guile? "pretty-print" "write"))))
 184          (pretty-print/write (if (eq? pretty-print/write 'pretty-print) pretty-print write)))
 185     (when (getenv "MES_DEBUG")
 186       (setenv "NYACC_TRACE" "yes")
 187       (format (current-error-port) "options=~s\n" options)
 188       (format (current-error-port) "output: ~a\n" out))
 189     (if (and (pair? sources) (pair? objects)) (error "cannot mix source and object files:" files))
 190     (with-output-to-file out
 191       (lambda ()
 192         (if (and (not compile?)
 193                  (not preprocess?)) (set-port-encoding! (current-output-port) "ISO-8859-1"))
 194         (cond ((pair? objects) (let ((objects (map read-object objects)))
 195                                  (if compile? (objects->M1 objects)
 196                                      (objects->elf objects))))
 197               ((pair? asts) (let* ((infos (map main:ast->info asts))
 198                                    (objects (map info->object infos)))
 199                               (if compile? (objects->M1 objects)
 200                                   (objects->elf objects))))
 201               ((pair? sources) (if preprocess? (map (source->ast pretty-print/write defines includes) sources)
 202                                    (let* ((infos (map (source->info defines includes) sources))
 203                                           (objects (map info->object infos)))
 204                                      (if compile? (objects->M1 objects)
 205                                          (objects->elf objects))))))))))
 206
 207 (main (command-line))
 208 'done