X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/a588c77a273681e3cdc85d15fc44f3ddb7da9224..6afec9101d5ea87e3df4bda2239ffd05f8154fa6:/src/frontend.lisp diff --git a/src/frontend.lisp b/src/frontend.lisp index 0336d1a..92573e7 100644 --- a/src/frontend.lisp +++ b/src/frontend.lisp @@ -7,7 +7,7 @@ ;;;----- Licensing notice --------------------------------------------------- ;;; -;;; This file is part of the Sensble Object Design, an object system for C. +;;; 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 @@ -23,9 +23,10 @@ ;;; 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)) +(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) @@ -38,6 +39,9 @@ ;;;-------------------------------------------------------------------------- ;;; 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 @@ -71,6 +75,18 @@ (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 () @@ -80,113 +96,148 @@ ;; 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* - :usage "SOURCES..." :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. - (unless (and (option-parse-try - (do-options () - (nil (rest) - (setf args rest)))) - (or builtinsp args)) - (die-usage)) + (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. - (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))))) + (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 --------------------------------------------------