;;;; File: g-wrap.scm
;;;; Copyright (C) 1996, 1997,1998 Christopher Lee
;;;; Copyright (C) 1999, 2000 Rob Browning
;;;; 
;;;; This program 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, 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 General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU 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.
;;;; 

(define-module (g-wrap)
  :use-module (g-wrap output-file)
  :use-module (g-wrap sorting)
  ;; FIXME: What does this one do?
  :use-module (g-wrap g-translate))

(use-modules (ice-9 slib))

(define *available-modules* (make-hash-table 31))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Utility functions

;; Translate any string to a string suitable for use as a C var or func name.
(define-public (gw:any-str->c-sym-str name)
  (define (char->string-replacement char)
    (cond
     ((char=? char #\?) "_p")
     ((char-alphabetic? char) (string char))
     ((char-numeric? char) (string char))
     (else "_")))

  (apply
   string-append
   (map
    char->string-replacement
    (string->list name))))

(define (scm-form-str->safe-c-str name)
  (define (char->string-replacement char)
    (if (char=? char #\")
        "\\\""
        (string char)))
  (apply
   string-append
   (map
    char->string-replacement
    (string->list name))))

(define (gw:write outfile section-sym . text-lst)
  (outfile:add-to-section outfile section-sym text-lst))

(define (gw:trans-write outfile section-sym trans-assq text)
  (gw:write outfile section-sym (translate-str text trans-assq)))

(define (split-at-char char str)
  (let ((len (string-length str)))
    (let loop ((i 0)
	       (start 0)
	       (strings '()))
      (cond
       ((= i len)
	(reverse (cons (substring str start i) strings))) ;; return line
       ((eq? (string-ref str i) char)
	(loop (+ i 1) (+ i 1) (cons (substring str start i) strings)))
       (else
	(loop (+ i 1) start strings))))))

(define (gen-c-comment input-text)
  (let ((text
         (apply
          string-append
          (map (lambda (str)
                 (split-at-char #\newline (flatten-string str)))
               input-text))))
    (cond
     ((null? text) '())
     (else
      (let loop ((txt (cdr text))
		 (out (list (list "/* " (car text) "\n"))))
	(cond 
	 ((null? txt) (reverse (cons " */\n" out))) ;; return line
	 (else
	  (loop (cdr txt)
		(cons (list " * " (car txt) "\n") out)))))))))

(define (symlist? obj)
  (define (every? pred some-list)
    (if (null? some-list)
        #t
        (and (pred (car some-list))
             (every? pred (cdr some-list)))))            
  (every? symbol? obj))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The top-level g-wrap module data-structure

(define *gw-module-rtd*
  (make-record-type "gw:module"
                    '(name
                      wrapped-types
                      modules-depended-on
                      foreign-types-used
                      scm-file
                      c-file
                      h-file
                      doc-file
                      pre-c-lib-scmcodegen
                      pre-header-ccodegen
                      declarations-ccodegen
                      definitions-ccodegen
                      init-ccodegen
                      generated-header-file
                      guile-module
                      guile-module-exports ; this is a hack!
                      )))

(define-public gw:module-get-name
  (record-accessor *gw-module-rtd* 'name))

(define gw:module-set-wrapped-types!
  (record-modifier *gw-module-rtd* 'wrapped-types))
(define gw:module-get-wrapped-types
  (record-accessor *gw-module-rtd* 'wrapped-types))

(define gw:module-set-modules-depended-on!
  (record-modifier *gw-module-rtd* 'modules-depended-on))
(define gw:module-get-modules-depended-on
  (record-accessor *gw-module-rtd* 'modules-depended-on))

(define gw:module-set-foreign-types-used!
  (record-modifier *gw-module-rtd* 'foreign-types-used))
(define gw:module-get-foreign-types-used
  (record-accessor *gw-module-rtd* 'foreign-types-used))

(define gw:module-set-scm-file!
  (record-modifier *gw-module-rtd* 'scm-file))
(define gw:module-get-scm-file
  (record-accessor *gw-module-rtd* 'scm-file))

(define gw:module-set-c-file!
  (record-modifier *gw-module-rtd* 'c-file))
(define gw:module-get-c-file
  (record-accessor *gw-module-rtd* 'c-file))

(define gw:module-set-h-file!
  (record-modifier *gw-module-rtd* 'h-file))
(define gw:module-get-h-file
  (record-accessor *gw-module-rtd* 'h-file))

(define gw:module-set-doc-file!
  (record-modifier *gw-module-rtd* 'doc-file))
(define gw:module-get-doc-file
  (record-accessor *gw-module-rtd* 'doc-file))

(define-public gw:module-set-pre-header-ccodegen!
  (let ((modifier
         (record-modifier *gw-module-rtd* 'pre-header-ccodegen)))
    (lambda (module val)
      (set! module (string->module-if-needed-or-error
                    module
                    "gw:module-set-pre-header-ccodegen!"))
      (modifier module val))))
  
(define-public gw:module-get-pre-header-ccodegen
  (let ((accessor
         (record-accessor *gw-module-rtd* 'pre-header-ccodegen)))
    (lambda (module)
      (set! module (string->module-if-needed-or-error
                    module
                    "gw:module-get-pre-header-ccodegen"))
      (accessor module))))

(define-public gw:module-set-declarations-ccodegen!
  (let ((modifier
         (record-modifier *gw-module-rtd* 'declarations-ccodegen)))
    (lambda (module val)
      (set! module (string->module-if-needed-or-error
                    module
                    "gw:module-set-declarations-ccodegen!"))
      (modifier module val))))
(define-public gw:module-get-declarations-ccodegen
  (let ((accessor
         (record-accessor *gw-module-rtd* 'declarations-ccodegen)))
    (lambda (module)
      (set! module (string->module-if-needed-or-error
                    module
                    "gw:module-get-declarations-ccodegen"))
      (accessor module))))

(define-public gw:module-set-definitions-ccodegen!
  (let ((modifier
         (record-modifier *gw-module-rtd* 'definitions-ccodegen)))
    (lambda (module val)
      (set! module (string->module-if-needed-or-error
                    module
                    "gw:module-set-definitions-ccodegen!"))
      
      (modifier module val))))
(define-public gw:module-get-definitions-ccodegen
  (let ((accessor
         (record-accessor *gw-module-rtd* 'definitions-ccodegen)))
    (lambda (module)
      (set! module (string->module-if-needed-or-error
                    module
                    "gw:module-get-definitions-ccodegen"))
      (accessor module))))

(define-public gw:module-set-init-ccodegen!
  (let ((modifier
         (record-modifier *gw-module-rtd* 'init-ccodegen)))
    (lambda (module val)
      (set! module (string->module-if-needed-or-error
                    module
                    "gw:module-set-init-ccodegen!"))
      (modifier module val))))
(define-public gw:module-get-init-ccodegen
  (let ((accessor
         (record-accessor *gw-module-rtd* 'init-ccodegen)))
    (lambda (module)
      (set! module (string->module-if-needed-or-error
                    module
                    "gw:module-get-init-ccodegen"))
      (accessor module))))

(define-public gw:module-set-pre-c-lib-scmcodegen!
  (let ((modifier
         (record-modifier *gw-module-rtd* 'pre-c-lib-scmcodegen)))
    (lambda (module val)
      (set! module (string->module-if-needed-or-error
                    module
                    "gw:module-set-pre-c-lib-scmcodegen!"))
      (modifier module val))))
(define-public gw:module-get-pre-c-lib-scmcodegen
  (let ((accessor
         (record-accessor *gw-module-rtd* 'pre-c-lib-scmcodegen)))
    (lambda (module)
      (set! module (string->module-if-needed-or-error
                    module
                    "gw:module-get-pre-c-lib-scmcodegen"))
      (accessor module))))

(define gw:module-set-generated-header-file!
  (record-modifier *gw-module-rtd* 'generated-header-file))
(define gw:module-get-generated-header-file
  (record-accessor *gw-module-rtd* 'generated-header-file))

(define-public gw:module-set-guile-module!
  (record-modifier *gw-module-rtd* 'guile-module))
(define-public gw:module-get-guile-module
  (record-accessor *gw-module-rtd* 'guile-module))

;; FIXME: we probably shouldn't be doing things this way, but until
;; g-wrap gathers and retains function signature data at runtime,
;; we're kinda stuck.
(define gw:module-set-guile-module-exports!
  (record-modifier *gw-module-rtd* 'guile-module-exports))
(define gw:module-get-guile-module-exports
  (record-accessor *gw-module-rtd* 'guile-module-exports))

(define (gw:module-add-guile-module-export! module scheme-sym)
  (gw:module-set-guile-module-exports!
   module
   (cons scheme-sym
         (gw:module-get-guile-module-exports module))))
   
(define make-gw-module
  ;; Just create the record and set all the fields to #f.
  (let ((constructor (record-constructor *gw-module-rtd* '(name))))
    (lambda (name)
      (let ((result (constructor name)))
        ;; initial, non-#f values.
        (gw:module-set-wrapped-types! result '())
        (gw:module-set-modules-depended-on! result '())
        (gw:module-set-foreign-types-used! result (make-hash-table 31))
        (gw:module-set-guile-module-exports! result '())
        result))))

(define (guile-module-name->c-registration-strlist name-symlist)
  (separate-by (map symbol->string name-symlist) " "))

(define (guile-module-name->c-sym-name-strlist name-symlist)
  (separate-by
   (map (lambda (s) (gw:any-str->c-sym-str (symbol->string s)))
        name-symlist)
   "_"))

(define (gw:module-add-type! module type-obj)
  (gw:module-set-wrapped-types!
   module 
   (cons
    (cons (gw:type-get-name type-obj)
          type-obj)
    (gw:module-get-wrapped-types module))))

(define (gw:module-lookup-type-and-mark-foreign main-module type-name-sym)
  (let* ((types (gw:module-get-wrapped-types main-module))
         (type-in-main-module (assq type-name-sym types)))
    (if type-in-main-module
        (cdr type-in-main-module)
        (let loop ((places-to-look
                    (gw:module-get-modules-depended-on main-module)))

          (if (null? places-to-look)
              (error "get-type: type not found:" type-name-sym))

          (let* ((module (car places-to-look))
                 (types (gw:module-get-wrapped-types module))
                 (type-cc (assq type-name-sym types)))
            (if (not type-cc)
                (loop (cdr places-to-look))
                (begin
                  (hashq-set! 
                   (gw:module-get-foreign-types-used main-module)
                   type-name-sym
                   #t)
                  (cdr type-cc))))))))

(define-public (gw:available-modules)
  *available-modules*)

(defmacro string->module-if-needed-or-error (module func-name)
  `(if (not (string? ,module))
       ,module
       (let ((actual-module (hash-ref *available-modules* ,module #f)))
         (or actual-module
             (error (string-append ,func-name
                                   " - module \""
                                   ,module "\" does not exist."))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Function spec parameter data
;;;
;;; FIXME: this is leftover stuff that should probably be reworked.

(define (make-param name type number extras? options)
  (define (make-rest-arg-scm-name count)
    (list
     "SCM_CAR("
     (let loop ((i 0))
       (cond ((>= i count) "scm_restargs")
             (else
              (list
               "SCM_CDR(" (loop (+ i 1)) ")"))))
     ")"))
  (let* ((c-name (string-append "param" (number->string number)))
         (scm-name (if (and extras? (>= number 9))
                       (make-rest-arg-scm-name (- number 9))
                       (string-append "scm_" c-name))))
    (vector name
            c-name
            scm-name
            type 
            number
            options)))

(define-public (gw:param-get-name x) (vector-ref x 0))
(define-public (gw:param-get-c-name x) (vector-ref x 1))
(define-public (gw:param-get-scm-name x) (vector-ref x 2))
(define-public (gw:param-get-type x) (vector-ref x 3))
(define-public (gw:param-get-number x) (vector-ref x 4))
(define-public (gw:param-get-options x) (vector-ref x 5))

(define-public (gw:param-get-proper-c-type-name x)
  (if (memq 'gw:const (gw:param-get-options x))
      (gw:type-get-c-const-type-name (gw:param-get-type x))
      (gw:type-get-c-type-name (gw:param-get-type x))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Function spec return value data
;;;
;;; FIXME: this is leftover stuff that should probably be reworked.

;; A return-type can be a symbol (naming the type) or a list of the form
;; '(type [ options ... ]).

(define (result-spec->result spec module)
  (let ((type (if (pair? spec) (car spec) spec))
        (options (if (pair? spec) (cdr spec) '())))
    
    (set! type (gw:module-lookup-type-and-mark-foreign module type))
    (cons type options)))

(define-public (gw:result-get-type r) (car r))
(define-public (gw:result-get-options r) (cdr r))
(define-public (gw:result-get-c-name r) "gw__c_result")
(define-public (gw:result-get-scm-name r) "gw__scm_result")

(define-public (gw:result-get-proper-c-type-name x)
  (if (memq 'gw:const (gw:result-get-options x))
      (gw:type-get-c-const-type-name (gw:result-get-type x))
      (gw:type-get-c-type-name (gw:result-get-type x))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; basic type data
;;;
;;; This data structure is what all other types are based on.
;;; Basically, in order to specify any other wrapped type, you create
;;; one of these and put the right things in its fields.
;;;
;;; It is a hash, and all keys starting with gw: are reserved by
;;; g-wrap, the others may be used by anyone building a new, specific
;;; kind of type on top of one of these.
;;;
;;; what happens with arg options?
;;;
;;; relevant fields:
;;; 
;;; gw:name -- something like 'GList
;;; gw:c-type-name -- something like "GList *"
;;; gw:provided-by -- pointer to the module providing the type.

;;; gw:pre-c-lib-scmcodegen (type client-only?)
;;; gw:init-ccodegen (type client-only?)
;;; gw:global-ccodegen (type client-only?)

;;; gw:pre-type-test-arg-ccodegen (param)
;;; gw:scm-arg-type-test-ccodegen (param)
;;; gw:pre-call-result-ccodegen (result)
;;; gw:pre-call-arg-ccodegen (param)
;;; gw:call-ccodegen (result func-call-code)
;;; gw:post-call-arg-ccodegen (param)
;;; gw:post-call-result-ccodegen (result)

(define-public (gw:wrap-type module name-sym c-type-name c-const-type-name)
  (let ((result (make-hash-table 17)))
    (set! module (string->module-if-needed-or-error module "gw:wrap-type"))
    (hashq-set! result 'gw:name name-sym)    
    (hashq-set! result 'gw:c-type-name c-type-name)
    (hashq-set! result 'gw:c-const-type-name c-const-type-name)
    (hashq-set! result 'gw:provided-by module)
    (gw:module-add-type! module result)
    result))

(define-public (gw:type-get-name t)
  (hashq-ref t 'gw:name))
(define-public (gw:type-get-c-type-name t)
  (hashq-ref t 'gw:c-type-name))
(define-public (gw:type-get-c-const-type-name t)
  (hashq-ref t 'gw:c-const-type-name))

;; Not sure this should be public, and even if it should, I'm not sure
;; I like the name -- may need to think of a better one.
;;(define-public (gw:type-get-provided-by t)
;;  (hashq-ref t 'gw:provided-by generator))

(define-public (gw:type-set-pre-c-lib-scmcodegen! t generator)
  (hashq-set! t 'gw:pre-c-lib-scmcodegen generator))
(define-public (gw:type-set-init-ccodegen! t generator)
  (hashq-set! t 'gw:init-ccodegen generator))
(define-public (gw:type-set-global-ccodegen! t generator)
  (hashq-set! t 'gw:global-ccodegen generator))

(define-public (gw:type-set-pre-type-test-arg-ccodegen! t generator)
  (hashq-set! t 'gw:pre-type-test-arg-ccodegen generator))
(define-public (gw:type-set-scm-arg-type-test-ccodegen! t generator)
  (hashq-set! t 'gw:scm-arg-type-test-ccodegen generator))
(define-public (gw:type-set-pre-call-result-ccodegen! t generator)
  (hashq-set! t 'gw:pre-call-result-ccodegen generator))
(define-public (gw:type-set-pre-call-arg-ccodegen! t generator)
  (hashq-set! t 'gw:pre-call-arg-ccodegen generator))
(define-public (gw:type-set-call-ccodegen! t generator)
  (hashq-set! t 'gw:call-ccodegen generator))
(define-public (gw:type-set-post-call-arg-ccodegen! t generator)
  (hashq-set! t 'gw:post-call-arg-ccodegen generator))
(define-public (gw:type-set-post-call-result-ccodegen! t generator)
  (hashq-set! t 'gw:post-call-result-ccodegen generator))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Non native type object funcs.
;;;
;;; non-native types are ones that have a representation on the C
;;; side, but none on the scheme side.  For these, g-wrap will
;;; generate a scheme side "proxy" that contains the C side data
;;; pointer.  For these types, issues of ownership (wrt deallocation)
;;; are critical, and g-wrap helps handle that automatically.
;;;
;;; The wraptime fields of a non-native type are:
;;;   name -- <symbol> g-wrap type name
;;;   c-type-name -- <string>
;;;
;;;   pre-c-lib-scmcodegen
;;;   global-ccodegen
;;;   init-ccodegen

;;;   scm-rep-type-test-ccodegen -- thunk producing ccode to check that this arg is *really* OK (happens after WCP type check).

;;; these three not-implemented-yet.
;;;   pre-call-arg-ccodegen - called after ptr has been extracted.
;;;   post-call-arg-ccodegen - called before result-ccodgen
;;;   pre-call-result-ccodegen - called after SCM result has been created.

;;;   print-ccode -- thunk producing ccode to override default printer.
;;;   equal?-ccode -- thunk producing ccode to compare C side reps.
;;;   gc-mark-ccode -- code to "mark" this object's SCM contents.
;;;   cleanup-c-rep-ccode -- thunk producing ccode to "clean up" the C side rep.

;;; print -- (type result-var wcp-var port-var writing?-var)
;;; equal -- (type result-var wcp-a-var wcp-b-var)
;;; gc-mark -- (type result-var wcp-var)
;;; cleanup -- (type result-var wcp-a-var)

(define-public (gw:wrap-non-native-type module
                                        name-sym
                                        c-type-name c-const-type-name)
    
  (define (generate-print-func type func-name)
    (let ((func-ccodegen (hashq-ref type 'nnt:print-ccodegen #f)))
      (list "int\n"
            func-name "(SCM gw__wcp, SCM gw__port, char gw__writing_p) {\n"
            "  int gw__result;\n"
            (func-ccodegen type
                           "gw__result"
                           "gw__wcp"
                           "gw__port"
                           "gw__writing_p")
            "}\n")))
  
  (define (generate-equal?-func type func-name)
    (let ((func-ccodegen (hashq-ref type 'nnt:equal?-ccodegen #f)))
      (list "int\n"
            func-name "(SCM gw__wcp_a, SCM gw__wcp_b) {\n"
            "  int gw__result;\n"
            (func-ccodegen type "gw__result" "gw__wcp_a" "gw__wcp_b")
            "}\n")))
  
  (define (generate-gc-mark-func type func-name)
    (let ((func-ccodegen (hashq-ref type 'nnt:gc-mark-ccodegen #f)))
      (list "SCM\n"
            func-name "(SCM gw__wcp) {\n"
            "  SCM gw__result;\n"
            (func-ccodegen type "gw__result" "gw__wcp")
            "}\n")))
  
  (define (generate-cleanup-func type func-name)
    (let ((func-ccodegen (hashq-ref type 'nnt:gc-mark-ccodegen #f)))
      (list "scm_sizet\n"
            func-name "(SCM gw__wcp) {\n"
            "  scm_sizet gw__result;\n"
            (func-ccodegen type "gw__result" "gw__wcp")
            "}\n")))
  
  (define (global-ccodegen type client-only?)    
    (let* ((wct-var-name (hashq-ref type 'nnt:wct-var-name #f))
           (print-func-name (hashq-ref type 'nnt:print-func-name #f))
           (equal?-func-name (hashq-ref type 'nnt:equal?-func-name #f))
           (gc-mark-func-name (hashq-ref type 'nnt:gc-mark-func-name #f))
           (cleanup-func-name (hashq-ref type 'nnt:cleanup-func-name #f))
           (native-global-ccodegen (hashq-ref type 'nnt:global-ccodegen #f)))
      (list
       (list "static SCM " wct-var-name " = SCM_BOOL_F;\n")
       (if print-func-name (generate-print-func type print-func-name) '())
       (if equal?-func-name (generate-equal?-func type equal-func-name) '())
       (if gc-mark-func-name (generate-gc-mark-func type gc-mark-func-name) '())
       (if cleanup-func-name (generate-cleanup-func type cleanup-func-name) '())
       (if native-global-ccodegen
           (native-global-ccodegen type client-only?)
           '()))))
  
  (define (pre-c-lib-scmcodegen type client-only?)
    (let* ((wcp-type-name (gw:type-get-name type))
           (native-scmcodegen (hashq-ref type 'nnt:pre-c-lib-scmcodegen #f)))
      
      (list
       (if client-only?
           '()
           (list "(export " wcp-type-name ")\n"))
       
       (if native-scmcodegen
           (native-scmcodegen type client-only?)
           '()))))
       
  (define (init-ccodegen type client-only?)
    (let* ((wct-var-name (hashq-ref type 'nnt:wct-var-name #f))
           (wcp-type-name (gw:type-get-name type))
           (equal-func (hashq-ref type 'nnt:equal-func-name "NULL"))
           (print-func (hashq-ref type 'nnt:print-func-name "NULL"))
           (mark-func (hashq-ref type 'nnt:gc-mark-func-name "NULL"))
           (cleanup-func (hashq-ref type 'nnt:cleanup-func-name "NULL"))
           (native-init-ccodegen (hashq-ref type 'nnt:init-ccodegen #f)))

      (list
       (if client-only?
           (list
            "    " wct-var-name " = gh_eval_str(\"" wcp-type-name "\");\n")
           (list
            "    " wct-var-name " = "
            "gw_wct_create("
            "\"" wcp-type-name "\", "
            equal-func ", "
            print-func ", "
            mark-func ", "
            cleanup-func ");\n"
     
            "  gh_define(\"" wcp-type-name "\", " wct-var-name ");\n"
            ))
       
       (if native-init-ccodegen
           (native-init-ccodegen type client-only?)
           '()))))
  
  (define (type-check-scm-rep-gen param)
    (let* ((type (gw:param-get-type param))
           (native-type-test-ccodegen
            (hashq-ref type 'nnt:scm-rep-type-test-ccodegen #f))
           (wct-var-name (hashq-ref type 'nnt:wct-var-name #f)))
      (list
       (list
        "(" (gw:param-get-scm-name param) " == SCM_BOOL_F) || "
        "gw_wcp_is_of_type_p(" wct-var-name ", " (gw:param-get-scm-name param) ")")
       (if native-type-test-ccodegen
           (list " && " (native-type-test-codegen type param))
           '()))))
  
  (define (pre-call-result-gen result)
    (let ((ret-type (gw:result-get-type result)))
      (list "{\n"
            "    " (gw:result-get-proper-c-type-name result)
            " "  (gw:result-get-c-name result) ";\n")))

  (define (pre-call-arg-gen param)
    (let ((scm-name (gw:param-get-scm-name param))
          (c-name (gw:param-get-c-name param)))
      (list
       "if(" scm-name " == SCM_BOOL_F) " c-name " = NULL;\n"
       "else " c-name " = gw_wcp_get_ptr(" scm-name ");\n")))
  
  (define (c-func-call-gen result func-call-code)
    (list (gw:result-get-c-name result) " = " func-call-code ";\n"))

  (define (post-call-result-gen result)
    (let* ((type (gw:result-get-type result))
           (scm-name (gw:result-get-scm-name result))
           (c-name (gw:result-get-c-name result))
           (wct-var-name (hashq-ref type 'nnt:wct-var-name #f)))
      (list
       "if(" c-name " == NULL) " scm-name " = SCM_BOOL_F;\n"
       "else "
       scm-name
       " = gw_wcp_assimilate_ptr((void *) " c-name ", " wct-var-name ");\n"
       "}\n")))
  
  (let ((result (gw:wrap-type module name-sym c-type-name c-const-type-name)))

    (hashq-set! result 'gw:pre-c-lib-scmcodegen pre-c-lib-scmcodegen)

    (hashq-set! result 'gw:global-ccodegen global-ccodegen)
    (hashq-set! result 'gw:init-ccodegen init-ccodegen)

    (hashq-set! result 'gw:scm-arg-type-test-ccodegen type-check-scm-rep-gen)
    (hashq-set! result 'gw:pre-call-result-ccodegen pre-call-result-gen)
    (hashq-set! result 'gw:pre-call-arg-ccodegen pre-call-arg-gen)
    (hashq-set! result 'gw:call-ccodegen c-func-call-gen)
    (hashq-set! result 'gw:post-call-result-ccodegen post-call-result-gen)
    
    (hashq-set! result
                'nnt:wct-var-name
                (string-append
                 "gw__wct_info_for_"
                 (gw:any-str->c-sym-str
                  (symbol->string (gw:type-get-name result)))))
    
    result))

(define-public (gw:non-native-type-set-pre-c-lib-scmcodegen! t generator)
  (hashq-set! t 'nnt:pre-c-lib-scmcodegen generator))

(define-public (gw:non-native-type-set-global-ccodegen! t generator)
  (hashq-set! t 'nnt:global-ccodegen generator))

(define-public (gw:non-native-type-set-init-ccodegen! t generator)
  (hashq-set! t 'nnt:init-ccodegen generator))

(define-public (gw:non-native-type-set-scm-rep-type-test-ccodegen! t generator)
  (hashq-set! result 'nnt:scm-rep-type-test-ccodegen generator))

(define-public (gw:non-native-type-set-print-ccodegen! t generator)
  (hashq-set! t 'nnt:print-func-name
              (string-append "gw__nnt_print_for_"
                             (gw:any-str->c-sym-str
                              (hashq-ref type 'gw:c-type-name #f))))
  (hashq-set! t 'nnt:print-ccodegen generator))

(define-public (gw:non-native-type-set-equal?-ccodegen! t generator)
  (hashq-set! t 'nnt:equal?-func-name
              (string-append "gw__nnt_equal_p_for_"
                             (gw:any-str->c-sym-str
                              (hashq-ref type 'gw:c-type-name #f))))
  (hashq-set! t 'nnt:equal?-ccodegen generator))

(define-public (gw:non-native-type-set-gc-mark-ccodegen! t generator)
  (hashq-set! t 'nnt:gc-mark-func-name
              (string-append "gw__nnt_gc_mark_for_"
                             (gw:any-str->c-sym-str
                              (hashq-ref type 'gw:c-type-name #f))))
  (hashq-set! t 'nnt:gc-mark-ccodegen generator))

(define-public (gw:non-native-type-set-cleanup-c-rep-ccodegen! t generator)
  (hashq-set! t 'nnt:cleanup-func-name
              (string-append "gw__nnt_cleanup_for_"
                             (gw:any-str->c-sym-str
                              (hashq-ref type 'gw:c-type-name #f))))
  (hashq-set! t 'nnt:cleanup-ccodegen generator))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Enumeration wrapper type.
;;;

(define-public (gw:wrap-enumeration module
                                    name-sym
                                    c-type-name c-const-type-name)
  
  (define (enum-c-sym type)
    (gw:any-str->c-sym-str (hashq-ref type 'gw:c-type-name #f)))
  
  (define (val->int-var-name type)
    (string-append "gw__enum_" (enum-c-sym type) "_val_to_int_scm_func"))
  
  (define (val->int-scm-func-name type)
    (let* ((enum-name (hashq-ref type 'gw:name #f)))
      (string-append "gw:enum-" (symbol->string enum-name) "-val->int")))
  
  (define (val->int-c-func-name type)
    (string-append "gw__enum_" (enum-c-sym type) "_val_to_int"))
  
  (define (val->sym-var-name type)
    (string-append "gw__enum_" (enum-c-sym type) "_val_to_sym_scm_func"))
  
  (define (val->sym-scm-func-name type)
    (let* ((enum-name (hashq-ref type 'gw:name #f)))
      (string-append "gw:enum-" (symbol->string enum-name) "-val->sym")))
  
  (define (val->sym-c-func-name type)
    (string-append "gw__enum_" (enum-c-sym type) "_val_to_sym"))
  
  (define (global-gen type client-only?)
    (list
     "SCM " (val->int-var-name type) ";\n"
     "SCM " (val->sym-var-name type) ";\n"
     
     (if client-only?
         '()
         (let* ((enum-c-name (hashq-ref type 'gw:c-type-name #f))
                (substitutions
                 `((enum-c-type-name ,enum-c-name)
                   (enum-c-sym ,(enum-c-sym type))
                   (val-to-int-func ,(val->int-var-name type))
                   (val-to-sym-func ,(val->sym-var-name type))
                   (val->int-c-func-name ,(val->int-c-func-name type))
                   (val->sym-c-func-name ,(val->sym-c-func-name type))
                   (val->sym-logic
                    ,(map
                      (lambda (enum-val)
                        (let ((c-sym (car enum-val))
                              (scm-sym (cdr enum-val)))
                          (list
                           "\n"
                           "  if(gw__enum_val == " c-sym ") {\n"
                           "    if(!gw__return_all_syms) return gh_symbol2scm(\"" scm-sym "\");\n"
                           "    gw__scm_result =\n"
                           "      gh_cons(gh_symbol2scm(\"" scm-sym "\"), gw__scm_result);\n"
                           "  }\n")))
                      (hashq-ref type 'enum:values)))
                   (val->int-logic
                    ,(map
                      (lambda (enum-val)
                        (let ((c-sym (car enum-val))
                              (scm-sym (cdr enum-val)))
                          (list
                           "\n"
                           "  if(strcmp(gw__symstr, \"" scm-sym "\") == 0) {\n"
                           "    free(gw__symstr);\n"
                           "    return gh_long2scm(" c-sym ");\n"
                           "  }\n")))
                      (hashq-ref type 'enum:values))))))
           
           (translate-str "\
static SCM
%val->sym-c-func-name%(SCM gw__scm_val, SCM gw__scm_show_all_p) {
  %enum-c-type-name% gw__enum_val;
  SCM gw__scm_result = SCM_EOL;

  int gw__return_all_syms = (gw__scm_show_all_p != SCM_BOOL_F);

  if(gh_symbol_p(gw__scm_val)) {
    SCM gw__scm_int_value = gh_call1(%val-to-int-func%,
                                     gw__scm_val);
    if(gw__scm_int_value == SCM_BOOL_F) return SCM_EOL;
    if(!gw__return_all_syms) return gw__scm_val;
    gw__enum_val = gh_scm2long(gw__scm_int_value);
  } else {
    /* this better be an int */
    gw__enum_val = gh_scm2long(gw__scm_val);
  }

  %val->sym-logic%
  
  return(gw__scm_result);
}

static SCM
%val->int-c-func-name%(SCM gw__scm_val) {
  char *gw__symstr = NULL;

  if(gh_exact_p(gw__scm_val)) {
    SCM gw__scm_existing_sym = gh_call2(%val-to-sym-func%,
                                        gw__scm_val,
                                        SCM_BOOL_F);
    if(gw__scm_existing_sym == SCM_BOOL_F) {
      return SCM_BOOL_F; 
    } else {
      return gw__scm_val;
    }
  }

  gw__symstr = gh_symbol2newstr(gw__scm_val, NULL);

  %val->int-logic%

  free(gw__symstr);
  return SCM_BOOL_F;
}
"
                     substitutions)))))

  (define (init-gen type client-only?)
    (if
     client-only?
     (list
      (val->int-var-name type)
      " = gh_lookup(\"" (val->int-scm-func-name type) "\");\n"
      (val->sym-var-name type)
      " = gh_lookup(\"" (val->sym-scm-func-name type) "\");\n")
     
     (list
      "\n"
      "    " (val->int-var-name type) " =\n"
      "      gh_new_procedure(\"" (val->int-scm-func-name type) "\",\n"
      "                       " (val->int-c-func-name type) ",\n"
      "                       1, 0, 0);\n"
      "    " (val->sym-var-name type) " =\n"
      "      gh_new_procedure(\"" (val->sym-scm-func-name type) "\",\n"
      "                       " (val->sym-c-func-name type) ",\n"
      "                       2, 0, 0);\n")))
  
  (define (pre-c-lib-scmgen type client-only?)
    (if client-only?
        '()
        (list
         "(export " (val->int-scm-func-name type) ")\n"
         "(export " (val->sym-scm-func-name type) ")\n")))

  (define (pre-type-test-arg-gen param)
    (let* ((type (gw:param-get-type param))
           (scm-name (gw:param-get-scm-name param))
           (enum-name (hashq-ref type 'gw:name #f))
           (c-name (gw:param-get-c-name param)))
      (list scm-name
            " = gh_call1(" (val->int-var-name type) ", " scm-name ");")))
  
  (define (type-check-scm-rep-gen param)
    (let* ((scm-name (gw:param-get-scm-name param)))
      (list "gh_exact_p(" scm-name ")")))
  
  (define (pre-call-result-gen result)
    (let ((ret-type (gw:result-get-type result)))
      (list "{\n"
            "    " (hashq-ref ret-type 'gw:c-type-name #f)
            " "  (gw:result-get-c-name result) ";\n")))
  
  (define (pre-call-arg-gen param)
    (let* ((scm-name (gw:param-get-scm-name param))
           (c-name (gw:param-get-c-name param)))
      (list c-name " = gh_scm2long(" scm-name ");\n")))
  
  (define (c-func-call-gen result func-call-code)
    (list (gw:result-get-c-name result) " = " func-call-code ";\n"))
  
  (define (post-call-result-gen result)
    (let* ((scm-name (gw:result-get-scm-name result))
           (c-name (gw:result-get-c-name result)))
      (list
       (list scm-name " = gh_long2scm(" c-name ");\n")
       "  }\n")))
  
  (set! module (string->module-if-needed-or-error
                module
                "gw:wrap-native-type"))

  (let ((result (gw:wrap-type module name-sym c-type-name c-const-type-name)))
    (hashq-set! result 'enum:values '())

    (hashq-set! result 'gw:global-ccodegen global-gen)
    (hashq-set! result 'gw:pre-c-lib-scmcodegen pre-c-lib-scmgen)
    (hashq-set! result 'gw:init-ccodegen init-gen)
    (hashq-set! result 'gw:pre-type-test-arg-ccodegen
                pre-type-test-arg-gen)
    (hashq-set! result 'gw:scm-arg-type-test-ccodegen type-check-scm-rep-gen)
    (hashq-set! result 'gw:pre-call-result-ccodegen pre-call-result-gen)
    (hashq-set! result 'gw:pre-call-arg-ccodegen pre-call-arg-gen)
    (hashq-set! result 'gw:call-ccodegen c-func-call-gen)
    (hashq-set! result 'gw:post-call-result-ccodegen post-call-result-gen)

    result))

(define-public (gw:enum-add-value! enum c-val-namestr scheme-sym)
  ;; FIXME: need checking for duplicate values here...
  (hashq-set! enum 'enum:values
              (cons (cons c-val-namestr scheme-sym)
                    (hashq-ref enum 'enum:values))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Documentation code.

(define type-index-generator #f)
(define function-index-generator #f)
(define constant-index-generator #f)

(define (make-index-generator kind)
  (let ((elements '())
	(category #f)
	(title #f))
    (let ((add-element (lambda (el)
			  (set! elements (cons el elements))))
	  (elements->html
	   (lambda ()
	     (if (null? elements)
		 (list "<p>(no " category " defined)</p>\n")
		 (list
		  "<h3>" title "</h3>"
		  (separate-by
		   (map 
		    (lambda (item)
		      (list 
		       "<a href=\"#" category "-" item "\">" item "</a>"))
                    (sort (map
                           (lambda (x)
                             (if (symbol? x)
                                 (symbol->string x)
                                 x))
                           elements)
                          string<?))
		   " |\n")
		  "\n")))))
      (let ((info
	     (assq kind '((constants "constants" "Constants")
			  (functions "functions" "Functions")
			  (types     "types"     "Types")))))
	(if (not info)
	    (error 
	     "make-index-generator: use constants, functions or types"))
	(set! category (cadr info))
	(set! title (caddr info)))

      (lambda (dispatch-command)
	(case dispatch-command
	  ((add) add-element)
	  ((output) elements->html)
	  (else
	   (error "index-generator: don't know command " dispatch-command))))
      )))
	  
(define (gwrap-c-doc-type module type description)
  (let ((output (gw:module-get-doc-file module)))
    (outfile:add-to-section
     output 'types 
     (list
      "  <dt> <a name=\"types-" type "\">"
      "<strong>type <em>" type "</em></strong></a>\n"
      "  <dd> " description "\n"))))

(define (gwrap-c-doc-function module scheme-name declaration description)
  (let ((output (gw:module-get-doc-file module)))
    (outfile:add-to-section 
     output 'functions
     (list
      "  <dt> <a name=\"functions-" scheme-name "\">"
      "<strong>" declaration "</strong></a>\n"
      "  <dd> " description "\n"))))

(define (gwrap-c-doc-constant module constant type description)
  (let ((output (gw:module-get-doc-file module)))
    (outfile:add-to-section 
     output 'constants
     (list
      "  <dt> <a name=\"constants-" constant "\"><strong>constant <tt>"
      constant 
      "</tt> (type <em>" type "</em></strong>)</a>\n"
      "  <dd> " description "\n"))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Wrapping code.

;; g-wrap-module-name

(define scm-file-tmpl "\
;; Generated by G-Wrap: an experimental Guile C API-wrapper engine.
(define-module %guile-module-name%)

%module-pre-c-lib-scmcode%

%type-pre-c-lib-scmcode%
    
(cond
 ((or (string=? (version) \"1.3\")
      (string=? (version) \"1.3.4\"))
  (dynamic-call \"gw_init_module_%module-name-c-sym%\"
                (dynamic-link \"lib%g-wrap-module-name%.so\")))
 (else
  (dynamic-call \"gw_init_module_%module-name-c-sym%\"
                (dynamic-link \"lib%g-wrap-module-name%\"))))

;; (not implemented yet) %post-c-lib-scmcode%

;; (not implemented yet) %type-post-c-lib-scmcode%

")

(define c-file-tmpl "\
/* Generated by G-Wrap: an experimental Guile function-wrapper engine */

%module-pre-header-code%

#include <guile/gh.h>
#include <libguile.h>
#include <string.h>

#include \"%module-header-name%\"

%module-declarations%

%module-definitions%

%type-global-code%

%module-functions%

void
gw_init_module_%module-name-c-sym%() {
  static int gw_module_initialized = 0;

  if(!gw_module_initialized) {
    gw_initialize();

    /* needed for gw:module-register-runtime (at least) */
    if(strcmp(\"g-wrapped gw-runtime\", \"%guile-module-reg-name%\") != 0) {
      gh_eval_str(\"(use-modules (g-wrapped gw-runtime))\");
      gh_eval_str(\"(gw:module-register-runtime \\\"%module-name%\\\")\");
    }

    %module-init-code%

    %type-init-code%

    gw_module_initialized = 1;
  }
}
")
(define h-file-tmpl "\
/* Generated by G-Wrap: an experimental Guile function-wrapper engine */

#ifndef %module-header-def-sym%
#define %module-header-def-sym%
#ifdef __cplusplus
extern \"C\" {
#endif

void gw_init_module_%module-name-c-sym%(void);

#ifdef __cplusplus
}
#endif
#endif
")
(define doc-file-tmpl "\
<html> <head>\n<title>Documentation for %module-name%</title>
</head>
<body text=\"#000000\" bgcolor=\"#ffffff\">
<h1> Documentation for %module-name%</h1>
<!-- Generated by G-Wrap -->

<h2>Index</h2>
%type-index%
%fn-index%
%const-index%

<h2>Types</h2>
<dl>
%types%
</dl>

<h2>Constants</h2>
<dl>
%constants%
</dl>

<h2>Functions</h2>
<dl>
%functions%
</dl>
")
(define gen-header-tmpl "\
#ifndef %generated-header-def-sym%
#define %generated-header-def-sym%
/* This header was automatically generated by G-WRAP version XXX.
 *  You should not edit this file manually.
 */

%generated-header-includes%
#ifdef __cplusplus
extern \"C\" {
#endif

%generated-header-declarations%
#ifdef __cplusplus
}
#endif
#endif
")

(define-public (gw:new-module module-name)
  (let ((module (make-gw-module module-name))
        (existing-module (hash-ref *available-modules* module-name)))

    (if existing-module
        (error (string-append 
                "gw:new-module: module "
                module-name " already exists.") existing-module)
        (hash-set! *available-modules* module-name module))
    
    (gw:module-set-c-file!
     module
     (text->outfile (string-append module-name ".c")
                    c-file-tmpl
                    '()))
    
    (gw:module-set-h-file!
     module
     (text->outfile (string-append module-name ".h")
                    h-file-tmpl '()))
    
    (set! type-index-generator (make-index-generator 'types))
    (set! function-index-generator (make-index-generator 'functions))
    (set! constant-index-generator (make-index-generator 'constants))
    
    (gw:module-set-doc-file!
     module
     (text->outfile
      (string-append module-name ".html")
      doc-file-tmpl
      `((type-index . ,type-index-generator)
        (fn-index . ,function-index-generator)
        (const-index . ,constant-index-generator))))
    module))

(define (add-global-and-init-code-for-module module)
  (define (add-global-and-init-code-from-module output-module
                                                from-module
                                                client-only?)
    (let ((c-file (gw:module-get-c-file output-module))
          (scm-file (gw:module-get-scm-file output-module))
          (guile-module-exports
           (gw:module-get-guile-module-exports from-module))
          (pre-header-ccodegen
           (gw:module-get-pre-header-ccodegen from-module))
          (declarations-ccodegen
           (gw:module-get-declarations-ccodegen from-module))
          (definitions-ccodegen
            (gw:module-get-definitions-ccodegen from-module))
          (pre-c-lib-scmcodegen
           (gw:module-get-pre-c-lib-scmcodegen from-module))
          (init-ccodegen
           (gw:module-get-init-ccodegen from-module)))
            
      (if (and scm-file pre-c-lib-scmcodegen)
          (gw:write scm-file 'module-pre-c-lib-scmcode
                    (pre-c-lib-scmcodegen client-only?)))

      (if (and (not client-only?) scm-file guile-module-exports)
          (for-each
           (lambda (sym)
             (gw:write scm-file 'module-pre-c-lib-scmcode
                       (list "(export " (symbol->string sym) ")\n")))
           (reverse guile-module-exports)))

      (if pre-header-ccodegen
          (gw:write c-file 'module-pre-header-code
                    (pre-header-ccodegen client-only?)))
      (if declarations-ccodegen
          (gw:write c-file 'module-declarations
                    (declarations-ccodegen client-only?)))
      (if definitions-ccodegen
          (gw:write c-file 'module-definitions
                    (definitions-ccodegen type client-only?)))  
      (if init-ccodegen
          (gw:write c-file 'module-init-code
                    (init-ccodegen client-only?)))
      ))
  
  ;; add code for all depended-on-types
  (for-each
   (lambda (depended-on-module)
     (add-global-and-init-code-from-module module depended-on-module #t))
   (gw:module-get-modules-depended-on module))
  
  (add-global-and-init-code-from-module module module #f))

(define (add-global-and-init-code-for-type module type client-only?)
  (let ((c-file (gw:module-get-c-file module))
        (scm-file (gw:module-get-scm-file module))
        (pre-c-lib-scmcodegen (hashq-ref type 'gw:pre-c-lib-scmcodegen #f))
        (global-ccodegen (hashq-ref type 'gw:global-ccodegen #f))
        (init-ccodegen (hashq-ref type 'gw:init-ccodegen #f)))
    
    (if (and scm-file pre-c-lib-scmcodegen)
        (gw:write scm-file 'type-pre-c-lib-scmcode
                  (pre-c-lib-scmcodegen type client-only?)))
    
    (if global-ccodegen
        (gw:write c-file 'type-global-code
                  (global-ccodegen type client-only?)))
    
    (if init-ccodegen
        (gw:write c-file 'type-init-code
                  (init-ccodegen type client-only?)))
    ))

(define (add-global-and-init-code-for-types module)
  (let ((c-file (gw:module-get-c-file module)))
    ;; add code for all depended-on-types
    
    ;;(display "adding type global and init code for module ")
    ;;(display (gw:module-get-name module))
    ;;(newline)
    ;;(display "  foreign-types-used: ")
    ;;(display (gw:module-get-foreign-types-used module))
    ;;(newline)
    
    (for-each
     (lambda (depended-on-module)
       (let* ((dep-guile-module (gw:module-get-guile-module depended-on-module))
              (dep-name (gw:module-get-name depended-on-module))
              (dep-c-sym (gw:any-str->c-sym-str dep-name)))
         
         ;; include module's defs.
         (gw:write
          c-file 'type-init-code
          (list
           "\n    " 
           (if dep-guile-module
               (gw:inline-scheme `(use-modules ,dep-guile-module))
               `("gw_init_module_" ,dep-c-sym "()\n")))))
       
       (for-each
        (lambda (type)
          ;;(display "checking if ")
          ;;(display (hashq-ref type 'gw:name #f))
          ;;(display " is needed foreign type in module ")
          ;;(display (gw:module-get-name module))
          ;;(display "...")
          (if (not (hashq-ref 
                    (gw:module-get-foreign-types-used module)
                    (hashq-ref type 'gw:name #f)))
              (begin
                #t)
                ;;(display "no\n"))
              (begin
                ;;(display "yes\n")
                (add-global-and-init-code-for-type module type #t))))
        (map cdr (gw:module-get-wrapped-types depended-on-module))))
     (gw:module-get-modules-depended-on module))
    
    ;; now add code for the current module if we're generating...
    (for-each
     (lambda (type) (add-global-and-init-code-for-type module type #f))
     (map cdr (gw:module-get-wrapped-types module)))))

(define-public (gw:inline-scheme . code-chunks)
  (map
   (lambda (chunk)
     (list "gh_eval_str(\""
           (scm-form-str->safe-c-str
            (call-with-output-string
             (lambda (port)
               (write chunk port))))
           "\");\n"))
   code-chunks))


(define-public (gw:generate-module module . options)
  
  (set! module (string->module-if-needed-or-error
                module
                "gw:generate-module"))
  
  ;; There are guile wrapper specific bits here (as elsewhere) that
  ;; will have to be factored out when we go back to supporting other
  ;; wrapper langauges.
  (let* ((module-name (gw:module-get-name module))
         (module-header-name (string-append module-name ".h"))
         (h-file (gw:module-get-h-file module))
         (c-file (gw:module-get-c-file module))
         (scm-file #f)
         ;; options
         (api-language (or (assq-ref options 'api-language) 'c))
         (wrapper-language (or (assq-ref options 'wrapper-language) 'guile))
         ;; other
         (guile-module (gw:module-get-guile-module module))
         (guile-module-reg-name
          (if guile-module
              (guile-module-name->c-registration-strlist guile-module)
              ""))
         (module-name-c-sym (gw:any-str->c-sym-str module-name)))

    (if (not (eq? wrapper-language 'guile))
        (error "g-wrap: can't generate wrappers for requested language: "
               wrapper-language))
    
    (gw:write c-file 'module-name module-name)
    (gw:write c-file 'module-header-name module-header-name)
    (gw:write c-file 'guile-module-reg-name guile-module-reg-name)
    (gw:write c-file 'module-name-c-sym module-name-c-sym)
    
    (gw:write h-file
              'module-header-def-sym
              (make-header-def-sym module-header-name))
    (gw:write h-file 'module-name-c-sym module-name-c-sym)

    ;; Write a module initialization function, if needed
    (if guile-module
        (let ((guile-module-name-c-sym
               (guile-module-name->c-sym-name-strlist guile-module)))

          (set! scm-file (text->outfile (string-append module-name ".scm")
                                        scm-file-tmpl
                                        '()))

          (gw:module-set-scm-file! module scm-file)

          (gw:write scm-file 'guile-module-name
                    (call-with-output-string
                     (lambda (port)
                       (write guile-module port))))
          (gw:write scm-file 'g-wrap-module-name module-name)
          (gw:write scm-file 'module-name-c-sym module-name-c-sym)))

    (add-global-and-init-code-for-module module)
    (add-global-and-init-code-for-types module)
    (outfile:close c-file)
    (if scm-file (outfile:close scm-file))
    (outfile:close (gw:module-get-h-file module))
    (outfile:close (gw:module-get-doc-file module))
    (let ((gen-header (gw:module-get-generated-header-file module)))
      (if gen-header
          (outfile:close gen-header)))))

; (define-public (new-constant sym-name type varb . options)
;   (set! sym-name (prefix-name sym-name))
;   (let ((description (fn-option options 'doc (lambda () '()))))
;     (gwrap-c-doc-constant sym-name type description))
;   (if constant-index-generator
;       ((constant-index-generator 'add) sym-name))
;   (gwrap-c-output-c
;    'type-inits
;    "  scm_sysintern (\"" sym-name "\", "
;    (make-conversion-to-scm (get-type type) varb)
;    ");\n"))

(define-public (gw:module-depends-on module depended-on-module)
  (set! module (string->module-if-needed-or-error
                module
                "gw:module-depends-on"))
  (set! depended-on-module (string->module-if-needed-or-error
                            depended-on-module
                            "gw:module-depends-on"))
  
  (gw:module-set-modules-depended-on!
   module 
   (cons 
    depended-on-module
    (gw:module-get-modules-depended-on module))))

(define (make-header-def-sym filename)
  (string-append "__"
                 (str-translate (string-upcase! (string-copy filename))
                                "- ." (vector "_" "_" "_"))
                 "__"))

(define-public (gw:generate-header module headername)
  (set! module (string->module-if-needed-or-error
                module
                "gw:generate-header"))
  (let ((subs `((header-def-sym ,(make-header-def-sym headername)))))
    (gw:module-set-generated-header-file!
     module
     (gw:make-outfile-text 'gen-header-file headername gen-header-tmpl subs))))

(define-public (gw:wrap-function 
                module
                scheme-sym
                result-spec
                c-name
                param-specs
                .
                new-description)
  
  (set! module (string->module-if-needed-or-error module "gw:wrap-function"))
  
  (let* ((params (make-params param-specs module))
         (result (result-spec->result result-spec module))
         (c-output (gw:module-get-c-file module))
         (description
          (list
           (param-specs->description-head 
            scheme-sym (gw:result-get-type result) param-specs)
           new-description))
         (orig-doc  new-description)
         (orig-args (if param-specs param-specs '()))
         (result-type (gw:result-get-type result))
         (result-options (gw:result-get-options result)))
    
    (if function-index-generator
        ((function-index-generator 'add) scheme-sym))

    (gwrap-c-doc-function module
                          scheme-sym
                          (caar description) 
                          (list "<em>" (cdar description) "</em><br>\n"
                                (cdr description)))

    (let ((gen-header-file (gw:module-get-generated-header-file module)))
      (if gen-header-file
          (let ((subs
                 `((doc    ,(gen-c-comment orig-doc))
                   (ret    ,(gw:result-get-proper-c-type-name result))
                   (fnname ,c-name)
                   (args   ,(separate-by 
                             (map 
                              (lambda (param)
                                (list (gw:param-get-proper-c-type-name param)
                                      " " (gw:param-get-name param)))
                              params)
                             ", ")))))
            (gw:trans-write gen-header-file 'declarations subs
                            "%doc%%ret% %fnname% (%args%);\n\n"))))
    
    (let* ((types (map gw:param-get-type params))
           (nargs (length types))
           (fn-c-wrapper (string-append "gwrap_" c-name))
           (fn-c-string  (string-append "gwrap_" c-name "_s"))
           (use-extra-params? (> (length types) 10)))
      (let ((subs
             `((fn-c-string  ,fn-c-string)

               (scheme-sym  ,scheme-sym)

               (fn-c-wrapper ,fn-c-wrapper)

               (param-decl ,(make-param-declarations params use-extra-params?))

               (c-param-protos ,(make-c-param-protos params))

               (pre-type-test-args-code
                ,(map 
                  (lambda (type param)
                    (let ((ccodegen
                           (hashq-ref
                            type
                            'gw:pre-type-test-arg-ccodegen #f)))
                      (if ccodegen
                          (ccodegen param)
                          "")))
                  types params))

               (extra-param-assertions
                ,(if use-extra-params?
                     (make-extra-param-assertions 
                      (- (length params) 9) scheme-sym)
                     ""))

               (param-assertions
                ,(make-param-assertions params types fn-c-string))
               
               (pre-call-result-code
                ,(let ((pre-call-ccodegen
                        (hashq-ref result-type
                                   'gw:pre-call-result-ccodegen #f)))
                   (if pre-call-ccodegen
                       (pre-call-ccodegen result)
                       "/* no pre-call result code requested */\n")))
               
               (pre-call-args-code
                ,(map 
                  (lambda (type param)
                    (let ((pre-call-ccodegen
                           (hashq-ref type
                                      'gw:pre-call-arg-ccodegen #f)))
                      (if pre-call-ccodegen
                          (pre-call-ccodegen param)
                          "")))
                  types params))
               
               (call-code
                ,(let ((call-ccodegen
                        (hashq-ref result-type 'gw:call-ccodegen #f))
                       (func-call-code
                        (list c-name "(" (make-param-list params) ")")))
                   (if call-ccodegen
                       (call-ccodegen result func-call-code)
                       "/* no function call requested! */\n")))
               
               ;; insert the post-call args code in the opposite order
               ;; of the pre-call code
               (post-call-args-code
                ,(map
                  (lambda (type param)
                    (let ((post-call-ccodegen
                           (hashq-ref type
                                      'gw:post-call-arg-ccodegen #f)))
                      (if post-call-ccodegen
                          (post-call-ccodegen param)
                          "")))
                  (reverse types) (reverse params)))
               
               (post-call-result-code
                ,(let ((post-call-ccodegen
                        (hashq-ref result-type
                                   'gw:post-call-result-ccodegen
                                   #f)))
                   (if post-call-ccodegen
                       (post-call-ccodegen result)
                       "/* no post-call result code requested */\n"))))))
        
        (gw:trans-write
         c-output 'module-functions subs "\
static char * %fn-c-string% = \"%scheme-sym%\";
static SCM %fn-c-wrapper%  (%param-decl%) {
  SCM gw__scm_result;
  %c-param-protos%
     
  /* pre-type-test args code */
  %pre-type-test-args-code%

  /* type checks */
  %extra-param-assertions%
  %param-assertions%

  /* pre-call code */
  %pre-call-result-code%
  %pre-call-args-code%

  /* Call function */
  SCM_DEFER_INTS;
  %call-code%
  SCM_ALLOW_INTS;

  /* post-call code */
  %post-call-args-code%
  %post-call-result-code%

  return(gw__scm_result);
}\n\n"))
      
      (let ((indent-str "                     "))

        (gw:module-add-guile-module-export! module scheme-sym)
        
        (gw:write c-output 'module-init-code
                  "    gh_new_procedure(" fn-c-string ",\n"
                  
                  indent-str
                  ;;(if (eq? (gw:module-get-api-language module) 'c++)
                  ;;    "(SCM (*) (...))"
                  ;;    "(SCM (*) ())")
                  "(SCM (*) ())"
                  " " fn-c-wrapper ",\n"
                  indent-str (if use-extra-params? 9 nargs) ",\n"
                  indent-str "0,\n" 
                  indent-str (if use-extra-params? "1" "0")
                  ");\n")
        (gw:write c-output 'module-init-code
                  "    gw_add_description("
                  "scm_cons("
                  "SCM_CAR(scm_intern0(" 
                  fn-c-string
                  ")), "
                  "gh_str02scm("
                  (list "\"" 
                        (str-translate (flatten-string description)
                                       "\n\""
                                       (vector "\\n\\\n" "\\\""))
                        "\"")
                  ")));\n")))))

(define (param-specs->description-head scheme-sym ret-type param-list)
  (list
   (list 
    "(" scheme-sym (map (lambda (x) (list " " (cadr x))) param-list) ")\n")
   (if (null? param-list)
       ""
       (list (separate-by
	      (map (lambda (x) (list (cadr x) " is a " (car x))) param-list)
	      ", ")
	     ".\n"))
   (if (eq? 'void (gw:type-get-name ret-type))
       " No return value.\n"
       (list " Returns " (gw:type-get-name ret-type) ".\n"))))


;;; Utility functions

(define (make-params param-specs module)
  (let ((extras? (> (length param-specs) 10)))
    (let loop ((remainder param-specs) (n 0))
      (if (null? remainder)
          '()
          (let* ((param-spec (car remainder))
                 (spec-name (cadr param-spec))
                 (spec-type (if (list? (car param-spec))
                                (caar param-spec)
                                (car param-spec)))
                 (spec-options (if (list? (car param-spec))
                                   (cdar param-spec)
                                   '())))

            (set! spec-type
                  (gw:module-lookup-type-and-mark-foreign module spec-type))
            
            (cons
             (make-param spec-name spec-type n extras? spec-options)
             (loop (cdr remainder) (+ n 1))))))))

(define (make-param-declarations param-list extras?)
  (let loop ((params param-list)
	     (index  0))
    (cond ((null? params) 
	   '())
	  ((and (= index 9) extras?)
	   "SCM scm_restargs ")
	  (else
	   (cons
	    (list
	     "SCM " (gw:param-get-scm-name (car params)) 
	     (if (null? (cdr params))
		 " "
		 ", "))
	    (loop (cdr params) (+ index 1)))))))

(define (make-c-param-protos params)  
  (map
   (lambda (param)
     (list "  " (gw:param-get-proper-c-type-name param)
           " " (gw:param-get-c-name param) ";\n"))
   params))

(define (make-extra-param-assertions n-extra-params procname)
  (list
   "  if (" n-extra-params 
   " != SCM_INUM(scm_length(scm_restargs))) {\n"
   "    scm_wrong_num_args(scm_makfrom0str(\"" procname "\"));\n"
   "  }\n"
   ))

(define (make-param-assertions params types fn-c-string)
  (define (make-param-assertion param type)
    (let* ((type-check-ccodegen
            (hashq-ref type 'gw:scm-arg-type-test-ccodegen #f)))
      (if (not type-check-ccodegen)
          ""
          (list
           "  SCM_ASSERT("
           (type-check-ccodegen param) ","
           (gw:param-get-scm-name param) ","
           "SCM_ARG" 
           (if (< (gw:param-get-number param) 5)
               (+ 1 (gw:param-get-number param))
               "n")
           ","
           fn-c-string ");\n"))))
  (map make-param-assertion params types))

(define (make-param-list params)  
  (cond ((null? params) '())
	(else
	 (cons
	  (list 
	   (gw:param-get-c-name (car params))
	   (if (null? (cdr params))
	       ""
	       ", "))
	  (make-param-list (cdr params))))))

;(define (make-param-assignments params)
;  (cond ((null? params) ())
;        (else
;         (cons
;          (list
;           "  " (gw:param-get-c-name (car params)) " = " 
;           (gw:wrapped-type-get-scm->c-ccode (gw:param-get-type (car params))
;                                             (gw:param-get-scm-name (car params)))
;           ";\n")
;          (make-param-assignments (cdr params))))))

;; Now suck in all the standard definitions.
(use-modules (g-wrapped gw-runtime-spec))