Static instance support.

[sod] / src / module-output.lisp

;;; -*-lisp-*-
;;;
;;; Output for modules
;;;
;;; (c) 2013 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; 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
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; SOD is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; 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)

;;;--------------------------------------------------------------------------
;;; Utilities.

(export 'banner)
(defun banner (title output &key (blank-line-p t))
  "Write a banner to the OUTPUT stream, starting a new section called TITLE.

   If BLANK-LINE-P is false, then leave a blank line after the banner.  (This
   is useful for a final banner at the end of a file.)"
  (format output "~&/*----- ~A ~A*/~%"
	  title
	  (make-string (- 77 2 5 1 (length title) 1 2)
		       :initial-element #\-))
  (when blank-line-p
    (terpri output)))

(export 'guard-name)
(defun guard-name (filename)
  "Return a sensible inclusion guard name for FILENAME."
  (with-output-to-string (guard)
    (let* ((pathname (make-pathname :name (pathname-name filename)
				    :type (pathname-type filename)))
	   (name (namestring pathname))
	   (uscore t))
      (dotimes (i (length name))
	(let ((ch (char name i)))
	  (cond ((alphanumericp ch)
		 (write-char (char-upcase ch) guard)
		 (setf uscore nil))
		((not uscore)
		 (write-char #\_ guard)
		 (setf uscore t))))))))

(defun guess-output-file (module type)
  "Guess the filename to use for a file TYPE, generated from MODULE.

   Here, TYPE is a filetype string.  The result is returned as a pathname."
  (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.

(export 'output-module)
(defun output-module (module reason stream)
  "Write the MODULE to STREAM, giving the output machinery the REASON.

   This is the top-level interface for producing output."
  (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
				   :stream stream
				   :file (stream-pathname stream)))))
    (with-module-environment (module)
      (hook-output module reason sequencer)
      (invoke-sequencer-items sequencer stream))))

;;;--------------------------------------------------------------------------
;;; Output implementation.

(defmethod hook-output :after ((module module) reason sequencer)

  ;; Ask the module's items to sequence themselves.
  (dolist (item (module-items module))
    (hook-output item reason sequencer)))

(defmethod hook-output ((frag code-fragment-item) reason sequencer)

  ;; Output fragments when their reasons are called up.
  (when (eq reason (code-fragment-reason frag))
    (dolist (constraint (code-fragment-constraints frag))
      (add-sequencer-constraint sequencer constraint))
    (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 ((module module) (reason (eql :h)) sequencer)
  (sequence-output (stream sequencer)

    :constraint
    (:prologue
     (:guard :start)
     (:typedefs :start) :typedefs (:typedefs :end)
     (:includes :start) :includes :early-decls (:includes :end)
     (:early-user :start) :early-user (:early-user :end)
     (:classes :start) (:classes :end)
     (:static-instances :start) :static-instances (:static-instances :end)
     (:user :start) :user (:user :end)
     (:guard :end)
     :epilogue)

    (:prologue
     (format stream "~
/* -*- mode: c; indent-tabs-mode: nil -*-
 *
 * Header file generated by SOD for ~A
 */~2%"
	     (namestring (module-name module))))

    ((:guard :start)
     (format stream "~
#ifndef ~A
#define ~:*~A

#ifdef __cplusplus
  extern \"C\" {
#endif~2%"
	     (or (get-property (module-pset module) :guard :id)
		 (guard-name (or (stream-pathname stream)
				 (guess-output-file module "H"))))))
    ((:guard :end)
     (banner "That's all, folks" stream)
     (format stream "~
#ifdef __cplusplus
  }
#endif

#endif~%"))

    ((:typedefs :start)
     (banner "Forward type declarations" stream))
    ((:typedefs :end)
     (terpri stream))

    ((:includes :start)
     (banner "External header files" stream))
    ((:includes :end)
     (terpri stream))))

(defmethod hook-output ((module module) (reason (eql :c)) sequencer)
  (sequence-output (stream sequencer)

    :constraint
    (:prologue
     (:includes :start) :includes (:includes :end)
     (:early-user :start) :early-user (:early-user :end)
     (:static-instances :start)
     (:static-instances :decls) (:static-instances :gap)
     (:static-instances :end)
     (:classes :start) (:classes :end)
     (:user :start) :user (:user :end)
     :epilogue)

    (:prologue
     (format stream "~
/* -*- mode: c; indent-tabs-mode: nil -*-
 *
 * Implementation file generated by SOD for ~A
 */~2%"
	     (namestring (module-name module))))

    (:epilogue
     (banner "That's all, folks" stream :blank-line-p nil))

    ((:includes :start)
     (banner "External header files" stream))
    ((:includes :end)
     (terpri stream))))

;;;--------------------------------------------------------------------------
;;; Output types.

(defvar *output-types* nil
  "List of known output types.")

(export 'declare-output-type)
(defun declare-output-type (reason pathname)
  "Record that REASON is a valid user-level output type.

   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)
(defun output-type-pathname (reason)
  "Return the PATHNAME template for the output type REASON.

   Report an error if there is no such output type."
  (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))
  (setf *output-types* nil)
  (declare-output-type :c (make-pathname :type "C" :case :common))
  (declare-output-type :h (make-pathname :type "H" :case :common)))

;;;----- That's all, folks --------------------------------------------------