;;; -*-lisp-*-
;;;
;;; Code generation protocol implementation
;;;
;;; (c) 2009 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This file is part of the Sensible 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)

;;;--------------------------------------------------------------------------
;;; Temporary names.

(export '(temporary-argument temporary-function))
(defclass temporary-argument (temporary-name) ())
(defclass temporary-function (temporary-name) ())

(export 'temporary-variable)
(defclass temporary-variable (temporary-name)
  ((in-use-p :initarg :in-use-p :initform nil
	     :type boolean :accessor var-in-use-p)))

(define-module-var *temporary-index* 0
  "Index for temporary name generation.

   This is automatically reset to zero before the output functions are
   invoked to write a file.  This way, we can ensure that the same output
   file is always produced from the same input.")

(define-clear-the-decks reset-codegen-index
  (setf *temporary-index* 0))

(defmethod commentify-argument-name ((name temporary-name))
  nil)

(defun temporary-function ()
  "Return a temporary function name."
  (make-instance 'temporary-function
		 :tag (prog1 *temporary-index* (incf *temporary-index*))))

(defmethod format-temporary-name ((var temporary-name) stream)
  (format stream "~A" (temp-tag var)))
(defmethod format-temporary-name ((var temporary-argument) stream)
  (format stream "sod__a~A" (temp-tag var)))
(defmethod format-temporary-name ((var temporary-variable) stream)
  (format stream "sod__v~A" (temp-tag var)))
(defmethod format-temporary-name ((var temporary-function) stream)
  (format stream "sod__f~A" (temp-tag var)))

(defmethod print-object ((var temporary-name) stream)
  (if *print-escape*
      (print-unreadable-object (var stream :type t)
	(prin1 (temp-tag var) stream))
      (format-temporary-name var stream)))

;;;--------------------------------------------------------------------------
;;; Instruction types.

;; Compound statements.

;; HACK: use gensyms for the `condition' slots to avoid leaking the slot
;; names, since the symbol `condition' actually comes from the `common-lisp'
;; package.  The `definst' machinery will symbolicate the various associated
;; methods correctly despite this subterfuge.

(definst if (stream :export t) (#1=#:cond conseq alt)
  (format-compound-statement (stream conseq alt)
    (format stream "if (~A)" #1#))
  (when alt
    (format-compound-statement (stream alt)
      (write-string "else" stream))))

(definst while (stream :export t) (#1=#:cond body)
  (format-compound-statement (stream body)
    (format stream "while (~A)" #1#)))

(definst do-while (stream :export t) (body #1=#:cond)
  (format-compound-statement (stream body :space)
    (write-string "do" stream))
  (format stream "while (~A);" #1#))

;; Special varargs hacks.

(definst va-start (stream :export t) (ap arg)
  (format stream "va_start(~@<~A, ~_~A~:>);" ap arg))

(definst va-copy (stream :export t) (to from)
  (format stream "va_copy(~@<~A, ~_~A~:>);" to from))

(definst va-end (stream :export t) (ap)
  (format stream "va_end(~A);" ap))

;; Expressions.

;; HACK: use a gensym for the `func' slot to avoid leaking the slot name,
;; since the symbol `func' is exported from our package.
(definst call (stream :export t) (#1=#:func args)
  (format stream "~A(~@<~{~A~^, ~_~}~:>)" #1# args))

;;;--------------------------------------------------------------------------
;;; Code generator objects.

(defclass basic-codegen ()
  ((vars :initarg :vars :initform nil :type list :accessor codegen-vars)
   (insts :initarg :insts :initform nil :type list :accessor codegen-insts)
   (temp-index :initarg :temp-index :initform 0
	       :type fixnum :accessor codegen-temp-index))
  (:documentation
   "Base class for code generator state.

   This contains the bare essentials for supporting the `emit-inst' and
   `ensure-var' protocols; see the documentation for those generic functions
   for more details.

   This class isn't abstract.  A full `codegen' object uses instances of this
   to keep track of pending functions which haven't been completed yet.

   Just in case that wasn't clear enough: this is nothing to do with the
   BASIC language."))

(defmethod emit-inst ((codegen basic-codegen) inst)
  (push inst (codegen-insts codegen)))

(defmethod emit-insts ((codegen basic-codegen) insts)
  (asetf (codegen-insts codegen) (revappend insts it)))

(defmethod emit-decl ((codegen basic-codegen) inst)
  (push inst (codegen-vars codegen)))

(defmethod emit-decls ((codegen basic-codegen) insts)
  (asetf (codegen-vars codegen) (revappend insts it)))

(defmethod ensure-var ((codegen basic-codegen) name type &optional init)
  (let* ((vars (codegen-vars codegen))
	 (var (find name
		    (remove-if-not (lambda (var) (typep var 'var-inst)) vars)
		    :key #'inst-name :test #'equal)))
    (cond ((not var)
	   (setf (codegen-vars codegen)
		 (cons (make-var-inst name type init) vars)))
	  ((not (c-type-equal-p type (inst-type var)))
	   (error "(Internal) Redefining type for variable ~A." name)))
    name))

(export 'codegen)
(defclass codegen (basic-codegen)
  ((functions :initform nil :type list :accessor codegen-functions)
   (stack :initform nil :type list :accessor codegen-stack))
  (:documentation
   "A full-fat code generator which can generate and track functions.

   This is the real deal.  Subclasses may which to attach additional state
   for convenience's sake, but this class is self-contained.  It supports the
   `codegen-push', `codegen-pop' and `codegen-pop-function' protocols."))

(defmethod codegen-push ((codegen codegen))
  (with-slots (vars insts temp-index stack) codegen
    (push (make-instance 'basic-codegen
			 :vars vars
			 :insts insts
			 :temp-index temp-index)
	  stack)
    (setf vars nil insts nil temp-index 0)))

(defmethod codegen-pop ((codegen codegen))
  (with-slots (vars insts temp-index stack) codegen
    (multiple-value-prog1
	(values (nreverse vars) (nreverse insts))
      (let ((sub (pop stack)))
	(setf vars (codegen-vars sub)
	      insts (codegen-insts sub)
	      temp-index (codegen-temp-index sub))))))

(defmethod codegen-add-function ((codegen codegen) function)
  (with-slots (functions) codegen
    (setf functions (nconc functions (list function)))))

(defmethod temporary-var ((codegen basic-codegen) type)
  (with-slots (vars temp-index) codegen
    (or (some (lambda (var)
		(let ((name (inst-name var)))
		  (if (and (not (var-in-use-p name))
			   (c-type-equal-p type (inst-type var)))
		      name
		      nil)))
	      (remove-if-not (lambda (var) (typep var 'var-inst)) vars))
	(let* ((name (make-instance 'temporary-variable
				    :in-use-p t
				    :tag (prog1 temp-index
					   (incf temp-index)))))
	  (push (make-var-inst name type nil) vars)
	  name))))

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