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