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 Sensible 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 ;;; Preparation for dumping.
  34
  35 (clear-the-decks)
  36 (exercise)
  37
  38 ;;;--------------------------------------------------------------------------
  39 ;;; The main program.
  40
  41 (eval-when (:compile-toplevel :load-toplevel :execute)
  42   (defopthandler dirpath (var arg) ()
  43     "Convert the argument into a pathname with a directory component
  44      and no file component, suitable for merging."
  45
  46     ;; This is really fiddly and annoying.  Unix pathnames don't tell you
  47     ;; whether the thing named is meant to be a directory or not, and
  48     ;; implementations differ as to how they cope with pathnames which do or
  49     ;; don't name directories when they're expecting files, or vice versa.
  50
  51     (let ((path (ignore-errors (pathname arg))))
  52       (cond ((null path)
  53              ;; The namestring couldn't be parsed, or something else went
  54              ;; horribly wrong.
  55
  56              (option-parse-error "Can't parse `~A' as a path" arg))
  57
  58             #+unix
  59             ((or (pathname-name path) (pathname-type path))
  60              ;; If this is Unix, or similar, then stick the filename piece on
  61              ;; the end of the directory and hope that was sensible.
  62
  63              (setf var (make-pathname
  64                         :name nil :type nil :defaults path
  65                         :directory (append (or (pathname-directory path)
  66                                                (list :relative))
  67                                            (list (file-namestring path))))))
  68
  69             (t
  70              ;; This actually looks like a plain directory name.
  71
  72              (setf var path))))))
  73
  74 (export 'main)
  75 (defun main ()
  76
  77   ;; Initialize the argument parser.
  78   (set-command-line-arguments)
  79
  80   ;; Collect information from the command line options.
  81   (let ((output-reasons nil)
  82         (output-path (make-pathname :directory '(:relative)))
  83         (backtracep nil)
  84         (builtinsp nil)
  85         (stdoutp nil)
  86         (args nil))
  87
  88     ;; Option definitions.
  89     (define-program
  90       :help "Process SOD input files to produce (e.g.) C output."
  91       :version *sod-version*
  92       :usage "SOURCES..."
  93       :options (options
  94                 (help-options :short-version #\V)
  95                 "Translator options"
  96                 (#\I "include" (:arg "DIR")
  97                      ("Search DIR for module imports.")
  98                      (list *module-dirs* 'string))
  99                 ("backtrace"
 100                      ("Print a Lisp backtrace on error (for debugging).")
 101                      (set backtracep))
 102                 ("builtins"
 103                      ("Process the builtin `sod-base' module.")
 104                      (set builtinsp))
 105                 (#\d "directory" (:arg "DIR")
 106                      ("Write output files to DIR.")
 107                      (dirpath output-path))
 108                 (#\p "stdout"
 109                      ("Write output files to standard output.")
 110                      (set stdoutp))
 111                 (#\t "type" (:arg "OUT-TYPE")
 112                      ("Produce output of type OUT-TYPE.")
 113                      (list output-reasons 'keyword))))
 114
 115     ;; Actually parse the options.
 116     (unless (and (option-parse-try
 117                    (do-options ()
 118                      (nil (rest)
 119                           (setf args rest))))
 120                  (or builtinsp args))
 121       (die-usage))
 122
 123     ;; Do the main parsing job.
 124     (labels ((hack-module (module)
 125                ;; Process the MODULE, writing out the generated code.
 126
 127                ;; Work through each output type in turn.
 128                (dolist (reason output-reasons)
 129
 130                  ;; Arrange to be able to recover from errors.
 131                  (restart-case
 132
 133                      ;; Collect information for constructing the output
 134                      ;; filenames here.  In particular,
 135                      ;; `output-type-pathname' will sanity-check the
 136                      ;; output type for us, which is useful even if
 137                      ;; we're writing to stdout.
 138                      (let ((outpath (output-type-pathname reason))
 139                            (modpath (module-name module)))
 140
 141                        (if stdoutp
 142
 143                            ;; If we're writing to stdout then just do
 144                            ;; that.
 145                            (output-module module reason
 146                                           *standard-output*)
 147
 148                            ;; Otherwise we have to construct an output
 149                            ;; filename the hard way.
 150                            (with-open-file
 151                                (stream
 152                                 (reduce #'merge-pathnames
 153                                         (list output-path
 154                                               outpath
 155                                               (make-pathname
 156                                                :directory nil
 157                                                :defaults modpath))
 158                                         :from-end t)
 159                                 :direction :output
 160                                 :if-exists :supersede
 161                                 :if-does-not-exist :create)
 162                              (output-module module reason stream))))
 163
 164                    ;; Error recovery.
 165                    (continue ()
 166                      :report (lambda (stream)
 167                                (format stream
 168                                        "Skip output type `~(~A~)'"
 169                                        reason))
 170                      nil))))
 171
 172              (hack-modules ()
 173
 174                ;; If there are no output types then there's nothing to do.
 175                (unless output-reasons
 176                  (error "No output types given: nothing to do"))
 177
 178                ;; If we're writing the builtin module then now seems like a
 179                ;; good time to do that.
 180                (when builtinsp
 181                  (hack-module *builtin-module*))
 182
 183                ;; Parse and write out the remaining modules.
 184                (dolist (arg args)
 185                  (hack-module (read-module arg)))))
 186
 187       (if backtracep (hack-modules)
 188           (multiple-value-bind (hunoz nerror nwarn)
 189               (count-and-report-errors ()
 190                 (with-default-error-location
 191                     ((make-file-location *program-name*))
 192                   (hack-modules)))
 193             (declare (ignore hunoz))
 194             (when (or (plusp nerror) (plusp nwarn))
 195               (format *error-output* "~A: Finished with~
 196                                       ~[~:; ~:*~D error~:P~[~:; and~]~:*~]~
 197                                       ~[~:; ~:*~D warning~:P~]~%"
 198                       *program-name* nerror nwarn))
 199             (exit (if (plusp nerror) 2 0)))))))
 200
 201 ;;;----- That's all, folks --------------------------------------------------