Update automatically managed build utilities.

[sod] / src / frontend.lisp

;;; -*-lisp-*-
;;;
;;; User interface
;;;
;;; (c) 2013 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This file is part of the Sensble Object Design, an object system for C.
;;;
;;; SOD is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; SOD is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with SOD; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

(cl:defpackage #:sod-frontend
  (:use #:common-lisp #:optparse #:sod #:sod-parser)
  (:shadowing-import-from #:optparse #:int))

(cl:in-package #:sod-frontend)

;;;--------------------------------------------------------------------------
;;; Preparation for dumping.

(clear-the-decks)
(exercise)

;;;--------------------------------------------------------------------------
;;; The main program.

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defopthandler dirpath (var arg) ()
    "Convert the argument into a pathname with a directory component
     and no file component, suitable for merging."

    ;; This is really fiddly and annoying.  Unix pathnames don't tell you
    ;; whether the thing named is meant to be a directory or not, and
    ;; implementations differ as to how they cope with pathnames which do or
    ;; don't name directories when they're expecting files, or vice versa.

    (let ((path (ignore-errors (pathname arg))))
      (cond ((null path)
             ;; The namestring couldn't be parsed, or something else went
             ;; horribly wrong.

             (option-parse-error "Can't parse `~A' as a path" arg))

            #+unix
            ((or (pathname-name path) (pathname-type path))
             ;; If this is Unix, or similar, then stick the filename piece on
             ;; the end of the directory and hope that was sensible.

             (setf var (make-pathname
                        :name nil :type nil :defaults path
                        :directory (append (or (pathname-directory path)
                                               (list :relative))
                                           (list (file-namestring path))))))

            (t
             ;; This actually looks like a plain directory name.

             (setf var path))))))

(export 'main)
(defun main ()

  ;; Initialize the argument parser.
  (set-command-line-arguments)

  ;; Collect information from the command line options.
  (let ((output-reasons nil)
        (output-path (make-pathname :directory '(:relative)))
        (builtinsp nil)
        (stdoutp nil)
        (args nil))

    ;; Option definitions.
    (define-program
      :help "Process SOD input files to produce (e.g.) C output."
      :version *sod-version*
      :usage "SOURCES..."
      :options (options
                (help-options :short-version #\V)
                "Translator options"
                (#\I "include" (:arg "DIR")
                     ("Search DIR for module imports.")
                     (list *module-dirs* 'string))
                ("builtins"
                     ("Process the builtin `sod-base' module.")
                     (set builtinsp))
                (#\d "directory" (:arg "DIR")
                     ("Write output files to DIR.")
                     (dirpath output-path))
                (#\p "stdout"
                     ("Write output files to standard output.")
                     (set stdoutp))
                (#\t "type" (:arg "OUT-TYPE")
                     ("Produce output of type OUT-TYPE.")
                     (list output-reasons 'keyword))))

    ;; Actually parse the options.
    (unless (and (option-parse-try
                   (do-options ()
                     (nil (rest)
                          (setf args rest))))
                 (or builtinsp args))
      (die-usage))

    ;; Do the main parsing job.
    (multiple-value-bind (hunoz nerror nwarn)
        (count-and-report-errors ()
          (with-default-error-location ((make-file-location *program-name*))

            (flet ((hack-module (module)
                     ;; Process the MODULE, writing out the generated code.

                     ;; Work through each output type in turn.
                     (dolist (reason output-reasons)

                       ;; Arrange to be able to recover from errors.
                       (restart-case

                           ;; Collect information for constructing the output
                           ;; filenames here.  In particular,
                           ;; `output-type-pathname' will sanity-check the
                           ;; output type for us, which is useful even if
                           ;; we're writing to stdout.
                           (let ((outpath (output-type-pathname reason))
                                 (modpath (module-name module)))

                             (if stdoutp

                                 ;; If we're writing to stdout then just do
                                 ;; that.
                                 (output-module module reason
                                                *standard-output*)

                                 ;; Otherwise we have to construct an output
                                 ;; filename the hard way.
                                 (with-open-file
                                     (stream
                                      (reduce #'merge-pathnames
                                              (list output-path
                                                    outpath
                                                    (make-pathname
                                                     :directory nil
                                                     :defaults modpath))
                                              :from-end t)
                                      :direction :output
                                      :if-exists :supersede
                                      :if-does-not-exist :create)
                                   (output-module module reason stream))))

                         ;; Error recovery.
                         (continue ()
                           :report (lambda (stream)
                                     (format stream
                                             "Skip output type `~(~A~)'"
                                             reason))
                           nil)))))

              ;; If we're writing the builtin module then now seems like a
              ;; good time to do that.
              (when builtinsp
                (hack-module *builtin-module*))

              ;; Parse and write out the remaining modules.
              (dolist (arg args)
                (hack-module (read-module arg))))))

      ;; Report on how well everything worked.
      (declare (ignore hunoz))
      (when (or (plusp nerror) (plusp nwarn))
        (format *error-output* "~A: Finished with~
                                ~[~:; ~:*~D error~:P~[~:; and~]~:*~]~
                                ~[~:; ~:*~D warning~:P~]~%"
                *program-name* nerror nwarn))

      ;; Exit with a sensible status.
      (exit (if (plusp nerror) 2 0)))))

;;;----- That's all, folks --------------------------------------------------