(merge-pathnames (make-pathname :type type :case :common)
(module-name module)))
+(defvar *done-one-off-output* nil
+ "A list of tokens for things which should appear at most once in output.")
+
+(export 'one-off-output)
+(defun one-off-output (token sequencer item-name function)
+ "Arrange to output a thing at most once.
+
+ If there has been no previous call to `one-off-output' with the given
+ TOKEN during this output run, then arrange to call FUNCTION when the item
+ called ITEM-NAME is traversed. Otherwise do nothing."
+ (unless (member token *done-one-off-output*)
+ (push token *done-one-off-output*)
+ (add-sequencer-item-function sequencer item-name function)))
+
;;;--------------------------------------------------------------------------
;;; Main output interface.
"Write the MODULE to STREAM, giving the output machinery the REASON.
This is the top-level interface for producing output."
- (let ((sequencer (make-instance 'sequencer))
+ (let ((*print-right-margin* 77)
+ (*done-one-off-output* nil)
+ (sequencer (make-instance 'sequencer))
(stream (if (typep stream 'position-aware-output-stream)
stream
(make-instance 'position-aware-output-stream
(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)
(:prologue
(:guard :start)
(:typedefs :start) :typedefs (:typedefs :end)
- (:includes :start) :includes (:includes :end)
+ (:includes :start) :includes :early-decls (:includes :end)
(:early-user :start) :early-user (:early-user :end)
(:classes :start) (:classes :end)
(:user :start) :user (:user :end)
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)
(or (get reason 'output-type)
(error "Unknown output type `~(~A~)'" reason)))
+(export 'module-output-file)
+(defgeneric module-output-file (module output-type output-dir)
+ (:documentation
+ "Return a pathname to which the output should be written.
+
+ Specifically, if we're processing a MODULE for a particular OUTPUT-TYPE,
+ and the user has requested that output be written to OUTPUT-DIR (a
+ pathname), then return the pathname to which the output should be
+ written.
+
+ The OUTPUT-TYPE can be an `reason' symbol or a raw pathname. (Or
+ something else, of course.)"))
+
+(defmethod module-output-file
+ ((module module) (output-type symbol) output-dir)
+ (module-output-file module (output-type-pathname output-type) output-dir))
+
+(defmethod module-output-file
+ ((module module) (output-type pathname) output-dir)
+ (reduce #'merge-pathnames
+ (list output-dir output-type
+ (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))
~mdw / sod / blobdiff