src/module-parse.lisp (code): Allow setting constraints without a fragment.

[sod] / src / module-output.lisp

diff --git a/src/module-output.lisp b/src/module-output.lisp
index fe04f2b7460a15fc2696672de8cf983503a2576f..78951768da3b9a1b1e08f495d8cfdc3ec7af1e46 100644 (file)
--- a/src/module-output.lisp
+++ b/src/module-output.lisp
@@ -114,12 +114,13 @@ (defmethod hook-output progn ((frag code-fragment-item) reason sequencer)
   (when (eq reason (code-fragment-reason frag))
     (dolist (constraint (code-fragment-constraints frag))
       (add-sequencer-constraint sequencer constraint))
-    (add-sequencer-item-function sequencer (code-fragment-name frag)
-                                (lambda (stream)
-                                  (write (code-fragment frag)
-                                         :stream stream
-                                         :pretty nil
-                                         :escape nil)))))
+    (awhen (code-fragment-name frag)
+      (add-sequencer-item-function sequencer it
+                                  (lambda (stream)
+                                    (write (code-fragment frag)
+                                           :stream stream
+                                           :pretty nil
+                                           :escape nil))))))
 
 (defmethod hook-output progn ((module module) (reason (eql :h)) sequencer)
   (sequence-output (stream sequencer)
@@ -212,6 +213,7 @@ (defun declare-output-type (reason pathname)
 
    The output file name will be constructed by merging the module's pathname
    with PATHNAME."
+  (pushnew reason *output-types*)
   (setf (get reason 'output-type) pathname))
 
 (export 'output-type-pathname)
@@ -246,6 +248,51 @@ (defmethod module-output-file
                (make-pathname :directory nil
                               :defaults (module-name module)))))
 
+(export 'write-dependency-file)
+(defgeneric write-dependency-file (module reason output-dir)
+  (:documentation
+   "Write a dependency-tracking make(1) fragment.
+
+   Specifically, we've processed a MODULE for a particular REASON (a
+   symbol), and the user has requested that output be written to OUTPUT-DIR
+   (a pathname): determine a suitable output pathname and write a make(1)
+   fragment explaining that the output file we've made depends on all of the
+   files we had to read to load the module."))
+
+(defmethod write-dependency-file ((module module) reason output-dir)
+  (let* ((common-case
+         ;; Bletch.  We want to derive the filetype from the one we're
+         ;; given, but we need to determine the environment's preferred
+         ;; filetype case to do that.  Make a pathname and inspect it to
+         ;; find out how to do this.
+
+         (if (upper-case-p
+                          (char (pathname-type (make-pathname
+                                                :type "TEST"
+                                                :case :common))
+                                0))
+                         #'string-upcase
+                         #'string-downcase))
+
+        (outpath (output-type-pathname reason))
+        (deppath (make-pathname :type (concatenate 'string
+                                                   (pathname-type outpath)
+                                                   (funcall common-case
+                                                            "-DEP"))
+                                :defaults outpath))
+        (outfile (module-output-file module reason output-dir))
+        (depfile (module-output-file module deppath output-dir)))
+
+    (with-open-file (dep depfile
+                    :direction :output
+                    :if-exists :supersede
+                    :if-does-not-exist :create)
+      (format dep "### -*-makefile-*-~%~
+                  ~A:~{ \\~%   ~A~}~%"
+             outfile
+             (cons (module-name module)
+                   (module-files module))))))
+
 (define-clear-the-decks reset-output-types
   "Clear out the registered output types."
   (dolist (reason *output-types*) (remprop reason 'output-type))