3 ;;; Output handling for modules
5 ;;; (c) 2009 Straylight/Edgeware
8 ;;;----- Licensing notice ---------------------------------------------------
10 ;;; This file is part of the Simple Object Definition system.
12 ;;; SOD is free software; you can redistribute it and/or modify
13 ;;; it under the terms of the GNU General Public License as published by
14 ;;; the Free Software Foundation; either version 2 of the License, or
15 ;;; (at your option) any later version.
17 ;;; SOD is distributed in the hope that it will be useful,
18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;;; GNU General Public License for more details.
22 ;;; You should have received a copy of the GNU General Public License
23 ;;; along with SOD; if not, write to the Free Software Foundation,
24 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
28 ;;;--------------------------------------------------------------------------
31 (defun banner (title output &key (blank-line-p t))
32 (format output "~&/*----- ~A ~A*/~%"
34 (make-string (- 77 2 5 1 (length title) 1 2)
35 :initial-element #\-))
39 (defun guard-name (filename)
40 "Return a sensible inclusion guard name for FILENAME."
41 (with-output-to-string (guard)
42 (let* ((pathname (make-pathname :name (pathname-name filename)
43 :type (pathname-type filename)))
44 (name (namestring pathname))
46 (dotimes (i (length name))
47 (let ((ch (char name i)))
48 (cond ((alphanumericp ch)
49 (write-char (char-upcase ch) guard)
52 (write-char #\_ guard)
53 (setf uscore t))))))))
55 ;;;--------------------------------------------------------------------------
58 (defun guess-output-file (module type)
59 (merge-pathnames (make-pathname :type type :case :common)
60 (module-name module)))
62 (defun output-module (module reason stream)
63 (let ((sequencer (make-instance 'sequencer))
64 (stream (if (typep stream 'position-aware-output-stream)
66 (make-instance 'position-aware-output-stream
68 :file (or (stream-pathname stream)
70 (add-output-hooks module reason sequencer)
71 (invoke-sequencer-items sequencer stream)))
73 ;;;--------------------------------------------------------------------------
74 ;;; Main output protocol implementation.
76 (defmethod add-output-hooks progn ((module module) reason sequencer)
77 (dolist (item (module-items module))
78 (add-output-hooks item reason sequencer)))
80 (defmethod add-output-hooks progn
81 ((frag code-fragment-item) reason sequencer)
82 (when (eq reason (code-fragment-reason frag))
83 (dolist (constraint (code-fragment-constraints frag))
84 (add-sequencer-constraint sequencer constraint))
85 (add-sequencer-item-function sequencer (code-fragment-name frag)
87 (write (code-fragment frag)
92 ;;;--------------------------------------------------------------------------
95 (defmethod add-output-hooks progn
96 ((module module) (reason (eql :h)) sequencer)
97 (sequence-output (stream sequencer)
98 :constraint (:prologue
100 (:typedefs :start) :typedefs (:typedefs :end)
101 (:includes :start) :includes (:includes :end)
102 (:classes :start) :classes (:classes :end)
110 * Header file generated by SOD for ~A
112 (namestring (module-name module))))
122 (or (get-property (module-pset module) :guard :id)
123 (guard-name (or (stream-pathname stream)
124 (guess-output-file module "H"))))))
126 (banner "That's all, folks" stream)
135 (banner "Forward type declarations" stream))
140 (banner "External header files" stream))
144 ;;;--------------------------------------------------------------------------
147 (defmethod add-output-hooks progn
148 ((module module) (reason (eql :c)) sequencer)
149 (sequence-output (stream sequencer)
150 :constraint (:prologue
151 (:includes :start) :includes (:includes :end)
152 (:classes :start) (:classes :end)
159 * Implementation file generated by SOD for ~A
161 (namestring (module-name module))))
164 (banner "That's all, folks" stream :blank-line-p nil))
167 (banner "External header files" stream))
171 ;;;----- That's all, folks --------------------------------------------------