X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/a07d8d005f69c0f9f5da2e09c6ee39cb1e1801aa..dea4d05507e59ab779ed4bb209e05971d87e260c:/pre-reorg/module-output.lisp?ds=sidebyside

diff --git a/pre-reorg/module-output.lisp b/pre-reorg/module-output.lisp
new file mode 100644
index 0000000..891ff54
--- /dev/null
+++ b/pre-reorg/module-output.lisp
@@ -0,0 +1,171 @@
+;;; -*-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 --------------------------------------------------