+;;; -*-lisp-*-
+;;;
+;;; Output for modules
+;;;
+;;; (c) 2013 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble 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)))
+
+;;;--------------------------------------------------------------------------
+;;; 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 ((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>")))))
+ (hook-output module reason sequencer)
+ (invoke-sequencer-items sequencer stream)))
+
+;;;--------------------------------------------------------------------------
+;;; Output implementation.
+
+(defmethod hook-output progn ((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 progn ((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))
+ (add-sequencer-item-function sequencer (code-fragment-name frag)
+ (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)
+
+ :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))))
+
+(defmethod hook-output 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 --------------------------------------------------
~mdw / sod / commitdiff