X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/1d8cc67a3f4ded443f5efc673a616883cbae9c50..refs/heads/mdw/progfmt:/src/frontend.lisp diff --git a/src/frontend.lisp b/src/frontend.lisp index b1fb0d9..a00a8bb 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,29 +23,219 @@ ;;; along with SOD; if not, write to the Free Software Foundation, ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -(cl:in-package #:sod) +(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) ;;;-------------------------------------------------------------------------- ;;; 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) - (define-program - :help "Probably ought to write this." - :version "0.1.0" - :usage nil - :options (options - (help-options :short-version #\V) - "Crazy options" - )) - - (unless (option-parse-try - (do-options () - (nil (rest) - (format t "My arguments are ~S~%" rest)))) - (die-usage)) - (exit)) + ;; 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")) + (token (cons 'token nil))) + (with-input-from-string (in lisp) + (loop (let ((form (read in nil token))) + (when (eq form token) (return)) + (eval form))))) + (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)) + (uiop:quit (if (plusp nerror) 2 0))))))) ;;;----- That's all, folks --------------------------------------------------