Early work-in-progress.

[sod] / output.lisp

;;; -*-lisp-*-
;;;
;;; Output driver for SOD translator
;;;
;;; (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)))

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

(defun write-module-header (module)
  (let* ((file (merge-pathnames (make-pathname :type "H" :case :common)
				(module-name module)))
	 (fakename (make-pathname :name (pathname-name file)
				  :type (pathname-type file))))
    (with-open-file (uoutput file
			     :direction :output
			     :if-exists :supersede
			     :if-does-not-exist :create)
      (let ((output (make-instance 'position-aware-output-stream
				   :stream uoutput
				   :file fakename)))

	;; Format the header and guards.
	(format output "~
/* -*-c-*-
 *
 * Header file generated by SOD for ~A
 */

#ifndef ~A
#define ~:*~A

#ifdef __cplusplus
  extern \"C\" {
#endif~%"
		(namestring (module-name module))
		(or (getf (module-plist module) 'include-guard)
		    (with-output-to-string (guard)
		      (let ((name (namestring file))
			    (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)))))))))

	  ;; Forward declarations of all the structures and types.  Nothing
	  ;; interesting gets said here; this is just so that the user code
	  ;; can talk meainingfully about the things we're meant to be
	  ;; defining here.
	  ;;
	  ;; FIXME

	  ;; The user fragments.
	  (when (module-header-fragments module)
	    (banner "User code" output)
	    (dolist (frag (module-header-fragments module))
	      (write-fragment frag output)))

	  ;; The definitions of the necessary structures.
	  ;;
	  ;; FIXME

	  ;; The definitions of the necessary direct-methods.
	  ;;
	  ;; FIXME

	  ;; The trailer section.
	  (banner "That's all, folks" output)
	  (format output "~
#ifdef __cplusplus
  }
#endif

#endif~%")))))

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

(defun write-module-source (module)
  (let* ((file (merge-pathnames (make-pathname :type "C" :case :common)
				(module-name module)))
	 (fakename (make-pathname :name (pathname-name file)
				  :type (pathname-type file))))
    (with-open-file (uoutput file
			     :direction :output
			     :if-exists :supersede
			     :if-does-not-exist :create)
      (let ((output (make-instance 'position-aware-output-stream
				   :stream uoutput
				   :file fakename)))

	;; Format the header.
	(format output "~
/* -*-c-*-
 *
 * Source file generated by SOD for ~A
 */~%"
		(namestring (module-name module)))

	  ;; The user fragments.
	  (when (module-source-fragments module)
	    (banner "User code" output)
	    (dolist (frag (module-source-fragments module))
	      (write-fragment frag output)))

	  ;; The definitions of the necessary tables.
	  ;;
	  ;; FIXME

	  ;; The definitions of the necessary effective-methods.
	  ;;
	  ;; FIXME

	  ;; The trailer section.
	  (banner "That's all, folks" output :blank-line-p nil)))))

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