Very ragged 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)

;;;--------------------------------------------------------------------------
;;; Sequencing machinery.

(defclass sequencer-item ()
  ((name :initarg :name
	 :reader sequencer-item-name)
   (functions :initarg :functions
	      :initform nil
	      :type list
	      :accessor sequencer-item-functions))
  (:documentation
   "Represents a distinct item to be sequenced by a SEQUENCER.

   A SEQUENCER-ITEM maintains a list of FUNCTIONS which are invoked when the
   sequencer is invoked.  This class is not intended to be subclassed."))

(defmethod print-object ((item sequencer-item) stream)
  (print-unreadable-object (item stream :type t)
    (prin1 (sequencer-item-name item) stream)))

(defclass sequencer ()
  ((constraints :initarg :constraints
		:initform nil
		:type list
		:accessor sequencer-constraints)
   (table :initform (make-hash-table :test #'equal)
	  :reader sequencer-table))
  (:documentation
   "A sequencer tracks items and invokes them in the proper order.

   The job of a SEQUENCER object is threefold.  Firstly, it collects
   sequencer items and stores them in its table indexed by name.  Secondly,
   it gathers CONSTRAINTS, which impose an ordering on the items.  Thirdly,
   it can be instructed to invoke the items in an order compatible with the
   established constraints.

   Sequencer item names may may any kind of object which can be compared with
   EQUAL.  In particular, symbols, integers and strings are reasonable
   choices for atomic names, and lists work well for compound names -- so
   it's possible to construct a hierarchy."))

(defgeneric ensure-sequencer-item (sequencer name)
  (:documentation
   "Arrange that SEQUENCER has a sequencer-item called NAME.

   Returns the corresponding SEQUENCER-ITEM object."))

(defgeneric add-sequencer-constraint (sequencer constraint)
  (:documentation
   "Attach the given CONSTRAINT to an SEQUENCER.

   The CONSTRAINT should be a list of sequencer-item names; see
   ENSURE-SEQUENCER-ITEM for what they look like.  Note that the names
   needn't have been declared in advance; indeed, they needn't be mentioned
   anywhere else at all."))

(defgeneric add-sequencer-item-function (sequencer name function)
  (:documentation
   "Arranges to call FUNCTION when the item called NAME is traversed.

   More than one function can be associated with a given sequencer item.
   They are called in the same order in which they were added.

   Note that an item must be mentioned in at least one constraint in order to
   be traversed by INVOKE-SEQUENCER-ITEMS.  If there are no special ordering
   requirments for a particular item, then the trivial constraint (NAME) will
   suffice."))

(defgeneric invoke-sequencer-items (sequencer &rest arguments)
  (:documentation
   "Invoke functions attached to the SEQUENCER's items in the right order.

   Each function is invoked in turn with the list of ARGUMENTS.  The return
   values of the functions are discarded."))

(defmethod ensure-sequencer-item ((sequencer sequencer) name)
  (with-slots (table) sequencer
    (or (gethash name table)
	(setf (gethash name table)
	      (make-instance 'sequencer-item :name name)))))

(defmethod add-sequencer-constraint ((sequencer sequencer) (constraint list))
  (let ((converted-constraint (mapcar (lambda (name)
					(ensure-sequencer-item sequencer
							       name))
				      constraint)))
    (with-slots (constraints) sequencer
      (pushnew converted-constraint constraints :test #'equal))))

(defmethod add-sequencer-item-function ((sequencer sequencer) name function)
  (let ((item (ensure-sequencer-item sequencer name)))
    (pushnew function (sequencer-item-functions item))))

(defmethod invoke-sequencer-items ((sequencer sequencer) &rest arguments)
  (dolist (item (merge-lists (reverse (sequencer-constraints sequencer))))
    (dolist (function (reverse (sequencer-item-functions item)))
      (apply function arguments))))

;;;--------------------------------------------------------------------------
;;; Output preparation.

(defgeneric add-output-hooks (object reason sequencer)
  (:documentation
   "Announces the intention to write SEQUENCER, with a particular REASON.

   The SEQUENCER is an SEQUENCER instance; the REASON will be a symbol which
   can be matched using an EQL-specializer.  In response, OBJECT should add
   any constrains and item functions that it wishes, and pass the
   announcement to its sub-objects.")
  (:method-combination progn)
  (:method progn (object reason sequencer)
    nil))

(defvar *seen-announcement*)		;Keep me unbound!
#+hmm
(defmethod add-output-hooks :around (object reason sequencer &rest stuff)
  "Arrange not to invoke any object more than once during a particular
   announcement."
  (declare (ignore stuff))
  (cond ((not (boundp '*seen-announcement*))
	 (let ((*seen-announcement* (make-hash-table)))
	   (setf (gethash object *seen-announcement*) t)
	   (call-next-method)))
	((gethash object *seen-announcement*)
	 nil)
	(t
	 (setf (gethash object *seen-announcement*) t)
	 (call-next-method))))

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