;;;; File: c-codegen.scm
;;;; Copyright (C) 2004, 2005 Andreas Rottmann
;;;;
;;;; This program is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2, or (at your option) any later version.
;;;;
;;;; This program 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this software; see the file COPYING.  If not,
;;;; write to the Free Software Foundation, 675 Mass Ave, Cambridge,
;;;; MA 02139, USA.
;;;;

;;; Commentary:
;;
; This module provides the generate-wrapset method for creating
; C-based wrappers.
;;
;;; Code:

(define-module (g-wrap c-codegen)
  #:use-module (oop goops)

  #:use-module (g-wrap)
  #:use-module (g-wrap util)
;  #:use-module (g-wrap rti)
  #:use-module (srfi srfi-11)  ;; let-values
  #:use-module (srfi srfi-1)   ;; partition!

  #:export
  (global-declarations-cg global-definitions-cg
   declarations-cg initializations-cg init-finalizations-cg

   client-global-declarations-cg client-global-definitions-cg
   client-initializations-cg))

(define (output-initializer-cgs wrapset cgs port)
  (let* ((error-var (gen-c-tmp "error_var"))
	 (wrapset-name (name wrapset))
	 (wrapset-name-c-sym (any-str->c-sym-str
			      (symbol->string wrapset-name)))
	 (wrapset-init-func (string-append "gw_initialize_wrapset_"
					   wrapset-name-c-sym)))

    (define (output-initializer-cg cg)
      (let ((code (cg error-var)))
	(if (not (null? code))
	    (begin
	      (render (expand-special-forms code #f '(type range memory misc))
		      port)
	      (if (has-error-form? code)
		  (flatten-display
		   (list
		    "if ((" error-var ").status != GW_ERR_NONE)\n"
		    "  gw_handle_wrapper_error (gw__arena, &" error-var ",\n"
		    "                            \"" wrapset-init-func "\",\n"
		    "                            0);\n")
		   port))))))

    (flatten-display
     (list "{\n"
	   "  GWError " error-var ";\n"
	   "   " error-var ".status = GW_ERR_NONE;\n"
	   "   " error-var ".data = SCM_UNSPECIFIED;\n"
	   "   " error-var ".message = NULL;\n"
	   "   (void) " error-var ";\n")
     port)

    (for-each (lambda (cg) (output-initializer-cg cg)) cgs)

    (display "}\n" port)))

(define (generate-wrapset-cs wrapset port)
  (define (dsp-list lst)
    (for-each (lambda (s) (display s port)) lst))

  (define (render-client cg)
      (for-each (lambda (ws)
		  (render (cg ws) port))
		(wrapsets-depended-on wrapset)))

  (define (render-client-items cg)
      (for-each (lambda (ws)
		  (for-each (lambda (item)
			      (render (cg ws item) port))
			    (reverse (slot-ref ws 'client-items))))
	      (wrapsets-depended-on wrapset)))

  (let ((wrapset-name-c-sym (any-str->c-sym-str
			     (symbol->string (name wrapset))))
	(client-types (compute-client-types wrapset))
	(items (reverse (slot-ref wrapset 'items))))

    (define (render-items cg)
      (for-each (lambda (item)
		  (render (cg wrapset item) port))
		items))

    (define (render-client-types cg)
      (for-each (lambda (type)
		  (render (cg wrapset type) port))
		client-types))

    ;;(format #t "client types: ~S\n" client-types)
    (dsp-list
     (list
      "/* Generated by G-Wrap-TNG: an experimental wrapper engine */\n"
      "\n"))

    (render-items before-includes-cg)
    (render-client-items before-includes-cg)

    (render (global-declarations-cg wrapset) port)
    (render-items global-declarations-cg)

    (render-client-items global-declarations-cg)
    (render-client client-global-declarations-cg)
    (render-client-types client-global-declarations-cg)

    (dsp-list
     (list
      "void gw_initialize_wrapset_" wrapset-name-c-sym "(GWLangArena);\n"))

    (render (global-definitions-cg wrapset) port)
    (render-items global-definitions-cg)

    (render-client-items global-definitions-cg)
    (render-client client-global-definitions-cg)
    (render-client-types client-global-definitions-cg)

    ;; The initialization function
    (dsp-list
     (list
      "void\n"
      "gw_initialize_wrapset_" wrapset-name-c-sym "(GWLangArena gw__arena) {\n"
      "  static int gw_wrapset_initialized = 0;\n"
      "\n"))

    (render (declarations-cg wrapset) port)
    (render-items declarations-cg)

    (dsp-list
     (list
      "  if(gw_wrapset_initialized)\n"
      "   return;\n"
      ;"   scm_block_gc++;\n"
      "\n"))

    ;; TODO: deobfuscate
    (output-initializer-cgs
     wrapset
     (append!
      (list (lambda (error-var)
	      (initializations-cg wrapset error-var)))
      (map (lambda (item)
	     (lambda (error-var)
	       (client-initializations-cg wrapset item error-var)))
	   client-types)
      (map (lambda (item)
	     (lambda (error-var)
	       (initializations-cg wrapset item error-var)))
	   (let-values (((types others) (partition! (lambda (item)
						      (is-a? item <gw-type>))
						    items)))
	     (append! types others)))
      (list (lambda (error-var)
	      (init-finalizations-cg wrapset error-var)))
      (map (lambda (item)
	     (lambda (error-var)
	       (init-finalizations-cg wrapset item error-var)))
	   items))
     port)


    (dsp-list
     (list
      ;"    scm_block_gc--;\n"
      "    gw_wrapset_initialized = 1;\n"
      "}\n"))))


(define-method (generate-wrapset (lang <symbol>)
				 (wrapset <gw-wrapset>)
				 (basename <string>))
  (let ((wrapset-source-name (string-append basename ".c")))
    (call-with-output-file/cleanup
     wrapset-source-name
     (lambda (port)
       (generate-wrapset-cs wrapset port)))))

;;; Default implementations (no-ops)

(define-method (before-includes-cg (wrapset <gw-wrapset>)
				   (item <gw-item>))
  '())

(define-method (global-declarations-cg (wrapset <gw-wrapset>))
  '())

(define-method (global-declarations-cg (wrapset <gw-wrapset>)
				       (item <gw-item>))
  '())

(define-method (client-global-declarations-cg (wrapset <gw-wrapset>))
  '())

(define-method (client-global-declarations-cg (wrapset <gw-wrapset>)
					      (item <gw-item>))
  '())

(define-method (global-definitions-cg (wrapset <gw-wrapset>))
  '())

(define-method (global-definitions-cg (wrapset <gw-wrapset>)
				      (item <gw-item>))
  '())

(define-method (client-global-definitions-cg (wrapset <gw-wrapset>))
  '())

(define-method (client-global-definitions-cg (wrapset <gw-wrapset>)
					     (item <gw-item>))
  '())

(define-method (declarations-cg (wrapset <gw-wrapset>))
  '())

(define-method (declarations-cg (wrapset <gw-wrapset>) (item <gw-item>))
  '())

(define-method (initializations-cg (wrapset <gw-wrapset>) error-var)
  '())

(define-method (initializations-cg (wrapset <gw-wrapset>)
				   (item <gw-item>)
				   error-var)
  '())

(define-method (client-initializations-cg (wrapset <gw-wrapset>)
					  (item <gw-item>)
					  error-var)
  '())

(define-method (init-finalizations-cg (wrapset <gw-wrapset>) err)
  '())

(define-method (init-finalizations-cg (wrapset <gw-wrapset>)
				      (item <gw-item>) err)
  '())
