src/parser/floc-proto.lisp: Use correct function for constructing conditions.

[sod] / src / frontend.lisp

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

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This file is part of the Sensible 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.

(eval-when (:compile-toplevel :load-toplevel :execute)
  (handler-bind ((warning #'muffle-warning))
    (cl:defpackage #:sod-frontend
      (:use #:common-lisp #:sod-utilities #:optparse #:sod #:sod-parser))))

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

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

(clear-the-decks)
(exercise)

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

(defvar-unbound *option-parser*
  "The program's main option parser.")

(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))))))

(defun update-usage ()
  (setf *usage* (simple-usage *options* "SOURCES...")))

(export 'augment-options)
(defun augment-options (options)
  "Add OPTIONS to the program's options list."
  (asetf *options* (append it options))
  (setf (op-options *option-parser*) *options*)
  (update-usage))

(use-package "SOD-FRONTEND" "SOD-USER")

(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)))
	(backtracep nil)
	(builtinsp nil)
	(stdoutp nil)
	(track-deps-p nil)
	(args nil))

    ;; Option definitions.
    (define-program
      :help "Process SOD input files to produce (e.g.) C output."
      :version *sod-version*
      :options (options
		(help-options :short-version #\V)
		"Translator options"
		(#\I "include" (:arg "DIR")
		     ("Search DIR for module imports.")
		     (list *module-dirs* 'string))
		("backtrace"
		     ("Print a Lisp backtrace on error (for debugging).")
		     (set backtracep))
		("builtins"
		     ("Process the builtin `sod-base' module.")
		     (set builtinsp))
		(#\d "directory" (:arg "DIR")
		     ("Write output files to DIR.")
		     (dirpath output-path))
		(#\e "eval" (:arg "LISP")
		     ("Evaluate raw Lisp code.")
		     (lambda (lisp)
		       (handler-case
			   (let ((*package* (find-package "SOD-USER")))
			     (eval (read-from-string lisp)))
			 (error (error)
			   (option-parse-error "~A" error)))))
		(#\l "load" (:arg "FILE")
		     ("Load a file of Lisp code.")
		     (lambda (file)
		       (let ((file (merge-pathnames file
						    (make-pathname
						     :type "LISP"
						     :case :common))))
			 (handler-case
			     (let ((*package* (find-package "SOD-USER")))
			       (find-file *default-pathname-defaults* file
					  "Lisp file"
					  (lambda (path true)
					    (declare (ignore path))
					    (load true
						  :verbose nil
						  :print nil))))
			   (error (error)
			     (option-parse-error "~A" error))))))
		(#\M "track-dependencies"
		     "Write make(1) fragments recording dependencies."
		     (set track-deps-p))
		(#\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))))
    (update-usage)

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

    ;; Do the main parsing job.
    (labels ((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
		     (cond

		       (stdoutp
			;; If we're writing to stdout then use
			;; `output-type-pathname' to check the output type
			;; for us.

			(output-type-pathname reason)
			(output-module module reason *standard-output*))

		       (t
			;; Otherwise we have to construct an output
			;; filename the hard way.
			(with-open-file
			    (stream
			     (module-output-file module reason output-path)
			     :direction :output
			     :if-exists :supersede
			     :if-does-not-exist :create)
			  (output-module module reason stream))

			(when track-deps-p
			  (write-dependency-file module reason
						 output-path))))

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

	     (hack-modules ()

	       ;; If there are no output types then there's nothing to do.
	       (unless output-reasons
		 (error "No output types given: nothing to do"))

	       ;; 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)
		 (let ((module (read-module arg)))
		   (when (zerop (module-errors module))
		     (hack-module module))))))

      (if backtracep (hack-modules)
	  (multiple-value-bind (hunoz nerror nwarn)
	      (count-and-report-errors ()
		(with-default-error-location
		    ((make-file-location *program-name*))
		  (hack-modules)))
	    (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 (if (plusp nerror) 2 0)))))))

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