Massive reorganization in progress.

[sod] / pre-reorg / module-output.lisp

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

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This file is part of the Simple Object Definition system.
;;;
;;; 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.

(defun banner (title output &key (blank-line-p t))
  (format output "~&/*----- ~A ~A*/~%"
	  title
	  (make-string (- 77 2 5 1 (length title) 1 2)
		       :initial-element #\-))
  (when blank-line-p
    (terpri output)))

(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))))))))

;;;--------------------------------------------------------------------------
;;; Driving output.

(defun guess-output-file (module type)
  (merge-pathnames (make-pathname :type type :case :common)
		   (module-name module)))

(defun output-module (module reason stream)
  (let ((sequencer (make-instance 'sequencer))
	(stream (if (typep stream 'position-aware-output-stream)
		    stream
		    (make-instance 'position-aware-output-stream
				   :stream stream
				   :file (or (stream-pathname stream)
					     #p"<unnamed>")))))
    (add-output-hooks module reason sequencer)
    (invoke-sequencer-items sequencer stream)))

;;;--------------------------------------------------------------------------
;;; Main output protocol implementation.

(defmethod add-output-hooks progn ((module module) reason sequencer)
  (dolist (item (module-items module))
    (add-output-hooks item reason sequencer)))

(defmethod add-output-hooks 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)))))

;;;--------------------------------------------------------------------------
;;; Header output.

(defmethod add-output-hooks progn
    ((module module) (reason (eql :h)) sequencer)
  (sequence-output (stream sequencer)
    :constraint (:prologue
		 (:guard :start)
		 (:typedefs :start) :typedefs (:typedefs :end)
		 (:includes :start) :includes (:includes :end)
		 (:classes :start) :classes (:classes :end)
		 (:guard :end)
		 :epilogue)

    (:prologue
     (format stream "~
/* -*-c-*-
 *
 * 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))))

;;;--------------------------------------------------------------------------
;;; Source output.

(defmethod add-output-hooks progn
    ((module module) (reason (eql :c)) sequencer)
  (sequence-output (stream sequencer)
    :constraint (:prologue
		 (:includes :start) :includes (:includes :end)
		 (:classes :start) (:classes :end)
		 :epilogue)

    (:prologue
     (format stream "~
/* -*-c-*-
 *
 * 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))))

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