src/classes.lisp, src/class-layout-proto.lisp: Docstring fixes.

[sod] / src / frontend.lisp

diff --git a/src/frontend.lisp b/src/frontend.lisp
index b1fb0d97951ef58091dacb00af989e017cbb4cc7..9ed6f3084acb1396568e6986e1817d6d87b3473b 100644 (file)
--- a/src/frontend.lisp
+++ b/src/frontend.lisp
@@ -23,29 +23,169 @@
 ;;; along with SOD; if not, write to the Free Software Foundation,
 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
 ;;; 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)
+(cl:defpackage #:sod-frontend
+  (:use #:common-lisp #:optparse #:sod #:sod-parser)
+  (:shadowing-import-from #:optparse "INT"))
+
+(cl:in-package #:sod-frontend)

 
 ;;;--------------------------------------------------------------------------
 ;;; The main program.
 
 
 ;;;--------------------------------------------------------------------------
 ;;; 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 ()
 (export 'main)
 (defun main ()

+
+  ;; Initialize the argument parser.

   (set-command-line-arguments)
 
   (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)))
+       (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)
+               "Crazy 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))
+
+    ;; Prepare the builtins.
+    (make-builtin-module)
+
+    ;; 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
+               (clear-the-decks)
+               (hack-module *builtin-module*))
+
+             ;; Parse and write out the remaining modules.
+             (dolist (arg args)
+               (clear-the-decks)
+               (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 --------------------------------------------------
 
 ;;;----- That's all, folks --------------------------------------------------