5 ;;; (c) 2013 Straylight/Edgeware
8 ;;;----- Licensing notice ---------------------------------------------------
10 ;;; This file is part of the Sensible Object Design, an object system for C.
12 ;;; SOD is free software; you can redistribute it and/or modify
13 ;;; it under the terms of the GNU General Public License as published by
14 ;;; the Free Software Foundation; either version 2 of the License, or
15 ;;; (at your option) any later version.
17 ;;; SOD is distributed in the hope that it will be useful,
18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;;; GNU General Public License for more details.
22 ;;; You should have received a copy of the GNU General Public License
23 ;;; along with SOD; if not, write to the Free Software Foundation,
24 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
26 (eval-when (:compile-toplevel :load-toplevel :execute)
27 (handler-bind ((warning #'muffle-warning))
28 (cl:defpackage #:sod-frontend
29 (:use #:common-lisp #:sod-utilities #:optparse #:sod #:sod-parser)
30 (:shadowing-import-from #:optparse #:int))))
32 (cl:in-package #:sod-frontend)
34 ;;;--------------------------------------------------------------------------
35 ;;; Preparation for dumping.
40 ;;;--------------------------------------------------------------------------
43 (defvar-unbound *option-parser*
44 "The program's main option parser.")
46 (eval-when (:compile-toplevel :load-toplevel :execute)
47 (defopthandler dirpath (var arg) ()
48 "Convert the argument into a pathname with a directory component
49 and no file component, suitable for merging."
51 ;; This is really fiddly and annoying. Unix pathnames don't tell you
52 ;; whether the thing named is meant to be a directory or not, and
53 ;; implementations differ as to how they cope with pathnames which do or
54 ;; don't name directories when they're expecting files, or vice versa.
56 (let ((path (ignore-errors (pathname arg))))
58 ;; The namestring couldn't be parsed, or something else went
61 (option-parse-error "Can't parse `~A' as a path" arg))
64 ((or (pathname-name path) (pathname-type path))
65 ;; If this is Unix, or similar, then stick the filename piece on
66 ;; the end of the directory and hope that was sensible.
68 (setf var (make-pathname
69 :name nil :type nil :defaults path
70 :directory (append (or (pathname-directory path)
72 (list (file-namestring path))))))
75 ;; This actually looks like a plain directory name.
79 (defun update-usage ()
80 (setf *usage* (simple-usage *options* "SOURCES...")))
82 (export 'augment-options)
83 (defun augment-options (options)
84 "Add OPTIONS to the program's options list."
85 (asetf *options* (append it options))
86 (setf (op-options *option-parser*) *options*)
89 (use-package "SOD-FRONTEND" "SOD-USER")
94 ;; Initialize the argument parser.
95 (set-command-line-arguments)
97 ;; Collect information from the command line options.
98 (let ((output-reasons nil)
99 (output-path (make-pathname :directory '(:relative)))
106 ;; Option definitions.
108 :help "Process SOD input files to produce (e.g.) C output."
109 :version *sod-version*
111 (help-options :short-version #\V)
113 (#\I "include" (:arg "DIR")
114 ("Search DIR for module imports.")
115 (list *module-dirs* 'string))
117 ("Print a Lisp backtrace on error (for debugging).")
120 ("Process the builtin `sod-base' module.")
122 (#\d "directory" (:arg "DIR")
123 ("Write output files to DIR.")
124 (dirpath output-path))
125 (#\e "eval" (:arg "LISP")
126 ("Evaluate raw Lisp code.")
129 (let ((*package* (find-package "SOD-USER")))
130 (eval (read-from-string lisp)))
132 (option-parse-error "~A" error)))))
133 (#\l "load" (:arg "FILE")
134 ("Load a file of Lisp code.")
136 (let ((file (merge-pathnames file
141 (let ((*package* (find-package "SOD-USER")))
142 (find-file *default-pathname-defaults* file
145 (declare (ignore path))
150 (option-parse-error "~A" error))))))
151 (#\M "track-dependencies"
152 "Write make(1) fragments recording dependencies."
155 ("Write output files to standard output.")
157 (#\t "type" (:arg "OUT-TYPE")
158 ("Produce output of type OUT-TYPE.")
159 (list output-reasons 'keyword))))
162 ;; Actually parse the options.
163 (let ((*option-parser* (make-option-parser)))
164 (unless (and (option-parse-try
165 (do-options (:parser *option-parser*)
171 ;; Do the main parsing job.
172 (labels ((hack-module (module)
173 ;; Process the MODULE, writing out the generated code.
175 ;; Work through each output type in turn.
176 (dolist (reason output-reasons)
178 ;; Arrange to be able to recover from errors.
183 ;; If we're writing to stdout then use
184 ;; `output-type-pathname' to check the output type
187 (output-type-pathname reason)
188 (output-module module reason *standard-output*))
191 ;; Otherwise we have to construct an output
192 ;; filename the hard way.
195 (module-output-file module reason output-path)
197 :if-exists :supersede
198 :if-does-not-exist :create)
199 (output-module module reason stream))
202 (write-dependency-file module reason
207 :report (lambda (stream)
209 "Skip output type `~(~A~)'"
215 ;; If there are no output types then there's nothing to do.
216 (unless output-reasons
217 (error "No output types given: nothing to do"))
219 ;; If we're writing the builtin module then now seems like a
220 ;; good time to do that.
222 (hack-module *builtin-module*))
224 ;; Parse and write out the remaining modules.
226 (let ((module (read-module arg)))
227 (when (zerop (module-errors module))
228 (hack-module module))))))
230 (if backtracep (hack-modules)
231 (multiple-value-bind (hunoz nerror nwarn)
232 (count-and-report-errors ()
233 (with-default-error-location
234 ((make-file-location *program-name*))
236 (declare (ignore hunoz))
237 (when (or (plusp nerror) (plusp nwarn))
238 (format *error-output* "~A: Finished with~
239 ~[~:; ~:*~D error~:P~[~:; and~]~:*~]~
240 ~[~:; ~:*~D warning~:P~]~%"
241 *program-name* nerror nwarn))
242 (exit (if (plusp nerror) 2 0)))))))
244 ;;;----- That's all, folks --------------------------------------------------