chiark - git - mdw - sod/blob - src/frontend.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; User interface
   4 ;;;
   5 ;;; (c) 2013 Straylight/Edgeware
   6 ;;;
   7
   8 ;;;----- Licensing notice ---------------------------------------------------
   9 ;;;
  10 ;;; This file is part of the Sensble Object Design, an object system for C.
  11 ;;;
  12 ;;; SOD is free software; you can redistribute it and/or modify
  13 ;;; it under the terms of the GNU General Public License as published by
  14 ;;; the Free Software Foundation; either version 2 of the License, or
  15 ;;; (at your option) any later version.
  16 ;;;
  17 ;;; SOD is distributed in the hope that it will be useful,
  18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;;; GNU General Public License for more details.
  21 ;;;
  22 ;;; You should have received a copy of the GNU General Public License
  23 ;;; along with SOD; if not, write to the Free Software Foundation,
  24 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  25
  26 (cl:defpackage #:sod-frontend
  27   (:use #:common-lisp #:optparse #:sod #:sod-parser)
  28   (:shadowing-import-from #:optparse "INT"))
  29
  30 (cl:in-package #:sod-frontend)
  31
  32 ;;;--------------------------------------------------------------------------
  33 ;;; The main program.
  34
  35 (eval-when (:compile-toplevel :load-toplevel :execute)
  36   (defopthandler dirpath (var arg) ()
  37     "Convert the argument into a pathname with a directory component
  38      and no file component, suitable for merging."
  39
  40     ;; This is really fiddly and annoying.  Unix pathnames don't tell you
  41     ;; whether the thing named is meant to be a directory or not, and
  42     ;; implementations differ as to how they cope with pathnames which do or
  43     ;; don't name directories when they're expecting files, or vice versa.
  44
  45     (let ((path (ignore-errors (pathname arg))))
  46       (cond ((null path)
  47              ;; The namestring couldn't be parsed, or something else went
  48              ;; horribly wrong.
  49
  50              (option-parse-error "Can't parse `~A' as a path" arg))
  51
  52             #+unix
  53             ((or (pathname-name path) (pathname-type path))
  54              ;; If this is Unix, or similar, then stick the filename piece on
  55              ;; the end of the directory and hope that was sensible.
  56
  57              (setf var (make-pathname
  58                         :name nil :type nil :defaults path
  59                         :directory (append (or (pathname-directory path)
  60                                                (list :relative))
  61                                            (list (file-namestring path))))))
  62
  63             (t
  64              ;; This actually looks like a plain directory name.
  65
  66              (setf var path))))))
  67
  68 (export 'main)
  69 (defun main ()
  70
  71   ;; Initialize the argument parser.
  72   (set-command-line-arguments)
  73
  74   ;; Collect information from the command line options.
  75   (let ((output-reasons nil)
  76         (output-path (make-pathname :directory '(:relative)))
  77         (builtinsp nil)
  78         (stdoutp nil)
  79         (args nil))
  80
  81     ;; Option definitions.
  82     (define-program
  83       :help "Process SOD input files to produce (e.g.) C output."
  84       :version *sod-version*
  85       :usage "SOURCES..."
  86       :options (options
  87                 (help-options :short-version #\V)
  88                 "Translator options"
  89                 (#\I "include" (:arg "DIR")
  90                      ("Search DIR for module imports.")
  91                      (list *module-dirs* 'string))
  92                 ("builtins"
  93                      ("Process the builtin `sod-base' module.")
  94                      (set builtinsp))
  95                 (#\d "directory" (:arg "DIR")
  96                      ("Write output files to DIR.")
  97                      (dirpath output-path))
  98                 (#\p "stdout"
  99                      ("Write output files to standard output.")
 100                      (set stdoutp))
 101                 (#\t "type" (:arg "OUT-TYPE")
 102                      ("Produce output of type OUT-TYPE.")
 103                      (list output-reasons 'keyword))))
 104
 105     ;; Actually parse the options.
 106     (unless (and (option-parse-try
 107                    (do-options ()
 108                      (nil (rest)
 109                           (setf args rest))))
 110                  (or builtinsp args))
 111       (die-usage))
 112
 113     ;; Prepare the builtins.
 114     (make-builtin-module)
 115
 116     ;; Do the main parsing job.
 117     (multiple-value-bind (hunoz nerror nwarn)
 118         (count-and-report-errors ()
 119           (with-default-error-location ((make-file-location *program-name*))
 120
 121             (flet ((hack-module (module)
 122                      ;; Process the MODULE, writing out the generated code.
 123
 124                      ;; Work through each output type in turn.
 125                      (dolist (reason output-reasons)
 126
 127                        ;; Arrange to be able to recover from errors.
 128                        (restart-case
 129
 130                            ;; Collect information for constructing the output
 131                            ;; filenames here.  In particular,
 132                            ;; `output-type-pathname' will sanity-check the
 133                            ;; output type for us, which is useful even if
 134                            ;; we're writing to stdout.
 135                            (let ((outpath (output-type-pathname reason))
 136                                  (modpath (module-name module)))
 137
 138                              (if stdoutp
 139
 140                                  ;; If we're writing to stdout then just do
 141                                  ;; that.
 142                                  (output-module module reason
 143                                                 *standard-output*)
 144
 145                                  ;; Otherwise we have to construct an output
 146                                  ;; filename the hard way.
 147                                  (with-open-file
 148                                      (stream
 149                                       (reduce #'merge-pathnames
 150                                               (list output-path
 151                                                     outpath
 152                                                     (make-pathname
 153                                                      :directory nil
 154                                                      :defaults modpath))
 155                                               :from-end t)
 156                                       :direction :output
 157                                       :if-exists :supersede
 158                                       :if-does-not-exist :create)
 159                                    (output-module module reason stream))))
 160
 161                          ;; Error recovery.
 162                          (continue ()
 163                            :report (lambda (stream)
 164                                      (format stream
 165                                              "Skip output type `~(~A~)'"
 166                                              reason))
 167                            nil)))))
 168
 169               ;; If we're writing the builtin module then now seems like a
 170               ;; good time to do that.
 171               (when builtinsp
 172                 (clear-the-decks)
 173                 (hack-module *builtin-module*))
 174
 175               ;; Parse and write out the remaining modules.
 176               (dolist (arg args)
 177                 (clear-the-decks)
 178                 (hack-module (read-module arg))))))
 179
 180       ;; Report on how well everything worked.
 181       (declare (ignore hunoz))
 182       (when (or (plusp nerror) (plusp nwarn))
 183         (format *error-output* "~A: Finished with~
 184                                 ~[~:; ~:*~D error~:P~[~:; and~]~:*~]~
 185                                 ~[~:; ~:*~D warning~:P~]~%"
 186                 *program-name* nerror nwarn))
 187
 188       ;; Exit with a sensible status.
 189       (exit (if (plusp nerror) 2 0)))))
 190
 191 ;;;----- That's all, folks --------------------------------------------------