
;; Copyright (C) 2020, 2021 Tommi Höynälänmaa

;; This file is part of Theme-D-Golf.

;; You can redistribute and/or modify this file under the terms of the
;; GNU General Public License as published by the Free Software
;; Foundation, either version 3 of the License, or (at your option) any
;; later version.

;; This file 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 program. If not, see https://www.gnu.org/licenses/.


(define-module (guile-theme-d-intr-support code-generation)
  #:export
  (<golf-generator>
   <intr-entity>
   <intr-function>
   <intr-type>
   <intr-object>
   <intr-property>
   <intr-enum>
   <intr-flags>
   <intr-struct>
   <intr-union>
   <intr-interface>
   get-golf-imports
   get-namespace-versions
   gi-import-info1
   get-method-name
   suitable-for-method?
   process-explicit-names))


;; (eval-when (expand load eval)
;;   (use-modules (oop goops))

;;   (default-duplicate-binding-handler
;;     '(merge-generics replace warn-override-core warn last))

;;   (use-modules (g-golf)))

(use-modules (oop goops))

(default-duplicate-binding-handler
  '(merge-generics replace warn-override-core warn last))

;; (use-modules (g-golf))

;;  (gi-import-by-name "GObject" "Object"))
;;  (gi-import "GObject"))


(use-modules (g-golf gi))
(use-modules (g-golf gobject type-info))
(use-modules (g-golf hl-api ccc))
(use-modules (g-golf hl-api callable))
(use-modules (g-golf hl-api function))
(use-modules (g-golf hl-api argument))
(use-modules (g-golf hl-api n-decl))
(use-modules (g-golf override override))
(use-modules (ice-9 regex))
(use-modules (ice-9 match))
(use-modules (ice-9 receive))
(use-modules (rnrs lists))
(use-modules (rnrs exceptions))
(use-modules (srfi srfi-1))
(use-modules (th-scheme-utilities stdutils))
(import (except (rnrs base) map))

(define-class <golf-generator> ()
  (l-rejected-functions #:init-keyword #:l-rejected-functions)
  (l-rejected-methods #:init-keyword #:l-rejected-methods)
  (l-overridden-functions #:init-keyword #:l-overridden-functions)
  (l-explicit-names #:init-keyword #:l-explicit-names
		    #:init-value '())
  (l-strip-boolean-result #:init-keyword #:l-strip-boolean-result
			  #:init-value '())
  (l-all-entities #:init-value '())
  (l-imported-types #:init-value '())
  (l-imported-only-type #:init-value '())
  (l-imported-functions #:init-value '())
  (l-toplevel-functions #:init-value '())
  (al-versions #:init-keyword #:al-versions)
  (debug? #:init-keyword #:debug?)
  (generate-methods? #:init-keyword #:generate-methods?)
  (check-procedures? #:init-keyword #:check-procedures?))

(define-class <intr-entity> ()
  (str-namespace #:init-keyword #:str-namespace)
  (str-name #:init-keyword #:str-name)
  (s-target-name #:init-keyword #:s-target-name))

(define-class <intr-type> (<intr-entity>)
  (l-methods #:init-keyword #:l-methods))

(define-class <intr-object> (<intr-type>)
  (l-supers #:init-keyword #:l-supers)
  (l-properties #:init-keyword #:l-properties))

(define-class <intr-property> (<intr-entity>)
  (s-class-name #:init-keyword #:s-class-name)
  (has-getter? #:init-keyword #:has-getter?)
  (has-setter? #:init-keyword #:has-setter?)
  (s-getter-name #:init-keyword #:s-getter-name)
  (s-setter-name #:init-keyword #:s-setter-name)
  (s-accessor-name #:init-keyword #:s-accessor-name))

(define-class <intr-function> (<intr-entity>)
  (l-argument-types #:init-keyword #:l-argument-types)
  (x-return-type #:init-keyword #:x-return-type)
  (n-return-values #:init-keyword #:n-return-values)
  (method? #:init-keyword #:method?)
  (str-base #:init-keyword #:str-base))

(define-class <intr-interface> (<intr-type>))

(define-class <intr-enum> (<intr-type>))

(define-class <intr-flags> (<intr-type>))

(define-class <intr-struct> (<intr-type>)
  (is-opaque? #:init-keyword #:is-opaque? #:init-value #f)
  (is-semi-opaque? #:init-keyword #:is-semi-opaque? #:init-value #f)
  (l-field-types #:init-keyword #:l-field-types #:init-value '()))

(define-class <intr-union> (<intr-type>))

(define %gi-imported-base-info-types1 '())

(define gl-al-type-name-map
  (list
   (cons 'void '<none>)
   (cons 'int8 '<integer>)
   (cons 'uint8 '<integer>)
   (cons 'int16 '<integer>)
   (cons 'uint16 '<integer>)
   (cons 'int32 '<integer>)
   (cons 'uint32 '<integer>)
   (cons 'int64 '<integer>)
   (cons 'uint64 '<integer>)
   (cons 'boolean '<boolean>)
   (cons 'double '<real>)
   (cons 'float '<real>)
   ;; Not sure about the following.
   (cons 'unichar '<character>)
   (cons 'utf8 '<string>)
   (cons 'filename '<string>)
   ;; Think about the following.
   (cons 'glist '<object>)
   ;; Think about the following.
   (cons 'array '<object>)
   (cons 'interface '<object>)
   (cons 'callback '<object>)
   (cons 'gtype '<object>)
   (cons 'ghash '<object>)))


(define (process-explicit-names l-raw)
  (map (lambda (x)
	 (strong-assert (and (list? x) (= (length x) 3)))
	 (cons (cons (car x) (cadr x)) (caddr x)))
       l-raw))


(define (my-get-name my-name)
  (string->symbol
   (string-append
    "<"
    (symbol->string (g-name->name my-name))
    ">")))


(define (get-golf-imports str-filename)
  (assert (string? str-filename))
  (let ((ip (open-input-file str-filename)))
    (if ip
	(let ((sx-contents (read ip)))
	  (close-input-port ip)
	  (if (and (list? sx-contents)
		   (not (null? sx-contents))
		   (eq? (car sx-contents) 'intr-entities))
	      (cdr sx-contents)
	      (raise 'invalid-config-file)))
	(raise 'config-file-not-found))))


(define (get-namespace-versions l-data)
  (let ((al-versions '()))
    (for-each
     (lambda (l-entry)
       (if (and (list? l-entry) (not-null? l-entry)
		(eq? (car l-entry) 'version))
	   (if (= (length l-entry) 3)
	       (let ((s-namespace (cadr l-entry))
		     (str-version (caddr l-entry)))
		 (if (and (symbol? s-namespace)
			  (string? str-version))
		     (set! al-versions
			   (cons (cons (symbol->string s-namespace)
				       str-version)
				 al-versions))
		     (raise (list 'version-entry-syntax-error
				  (cons 'x-namespace s-namespace)
				  (cons 'x-version str-version)))))
	       (raise (list 'invalid-version-entry-length
			    (cons 'l-entry l-entry))))))
     l-data)
    al-versions))


(define (make-target-class-name s-namespace s-class-name)
  (if s-namespace
      (let* ((str-namespace (g-studly-caps-expand (symbol->string s-namespace)))
	     (str-class-name (g-studly-caps-expand
			      (symbol->string s-class-name)))
	     (str-final-name (string-append "<" str-namespace "-"
					    str-class-name ">"))
	     (s-final-name (string->symbol str-final-name)))
	s-final-name)
      (let* ((str-class-name (g-studly-caps-expand
			      (symbol->string s-class-name)))
	     (str-final-name (string-append "<" str-class-name ">"))
	     (s-final-name (string->symbol str-final-name)))
	s-final-name)))


(define (gi-import-info1 info generator toplevel? methods?)
  (assert (is-a? generator <golf-generator>))
  (assert (boolean? toplevel?))
  (let ((i-type (g-base-info-get-type info)))
    ;; (unless (memq i-type
    ;;               %gi-base-info-types)
    ;;   (push! i-type %gi-base-info-types))
    (case i-type
      ((enum)
       (unless (memq i-type
		     %gi-imported-base-info-types1)
	 (push! i-type %gi-imported-base-info-types1))
       (gi-import-enum1 info generator toplevel? methods?))
      ((flags)
       (unless (memq i-type
		     %gi-imported-base-info-types1)
	 (push! i-type %gi-imported-base-info-types1))
       (gi-import-flags1 info generator toplevel? methods?))
      ((struct)
       (unless (memq i-type
		     %gi-imported-base-info-types1)
	 (push! i-type %gi-imported-base-info-types1))
       (gi-import-struct1 info generator toplevel? methods?))
      ((union)
       (unless (memq i-type
		     %gi-imported-base-info-types1)
	 (push! i-type %gi-imported-base-info-types1))
       (gi-import-union1 info generator toplevel? methods?))
      ((function)
       (unless (memq i-type
		     %gi-imported-base-info-types1)
	 (push! i-type %gi-imported-base-info-types1))
       (gi-import-function1 info generator toplevel?))
      ((object)
       (unless (memq i-type
		     %gi-imported-base-info-types1)
	 (push! i-type %gi-imported-base-info-types1))

       ;; TBR
       ;; (display "class: ")
       ;; (display (g-base-info-get-name info))
       ;; (newline)
       
       (gi-import-object1 info generator toplevel? methods?))
      ((interface)
       ;; GObject interfaces are not understood by the Theme-D type system
       ;; so we may not generate methods here.
       (unless (memq i-type
		     %gi-imported-base-info-types1)
	 (push! i-type %gi-imported-base-info-types1))
       (gi-import-interface1 info generator toplevel? methods?))
      #;((callback)
      (unless (memq i-type
      %gi-imported-base-info-types)
      (push! i-type %gi-imported-base-info-types))
      (gi-import-callback info))
      (else
       (if (slot-ref generator 'debug?)
           (begin
	     (display "Entity ")
	     (display (g-base-info-get-name info))
	     (display " not imported.")
	     (newline)
	     (display "type: ")
	     (display i-type)
	     (newline)))
       'nothing))))


(define (g-object-class-precedence-list info)
  (let loop ((parent (g-object-info-get-parent info))
             (results (list (list info
                                  (g-base-info-get-namespace info)
                                  (g-object-info-get-type-name info)))))
    (if (or (not parent) (null-pointer? parent))
        (reverse! results)
        (loop (g-object-info-get-parent parent)
              (cons (list parent
                          (g-base-info-get-namespace parent)
                          (g-object-info-get-type-name parent))
                    results)))))


(define (is-g-object-subclass? info-cpl)
  (letrec ((is-g-object-info-cpl-item?
            (lambda (what info-cpl-item)
              (match info-cpl-item
                ((info namespace name)
                 (string=? name what))))))
    (member "GObject" info-cpl is-g-object-info-cpl-item?)))


(define* (g-object-info-cpl info #:key (reversed-order? #f))
  (let  loop ((parent (g-object-info-get-parent info))
              (results (list (list info
                                   (g-base-info-get-namespace info)
                                   (g-object-info-get-type-name info)))))
    (if (not parent)
        (if reversed-order? results (reverse! results))
        (loop (g-object-info-get-parent parent)
              (cons (list parent
                          (g-base-info-get-namespace parent)
                          (g-object-info-get-type-name parent))
                    results)))))


(define (gi-import-object1 info generator toplevel? methods?)
  (assert (is-a? generator <golf-generator>))

  ;; TBR
  ;; (display "gi-import-object1 ENTER\n")
  ;; (display methods?)
  ;; (newline)
  
  ;; (let ((dbg-event? (equal? (g-base-info-get-name info) "Event")))
    ;; (if dbg-event? (display "Event HEP\n"))
  (let ((r-info-cpl (g-object-info-cpl info #:reversed-order? #t)))
    ;; (display r-info-cpl)
    ;; (newline)
    (unless (is-g-object-subclass? r-info-cpl)

      ;; TBR
      ;; (display "not g-object subclass\n")
      
      (match r-info-cpl
	     ((parent . rest)
	      (g-object-import-with-supers1
	       parent '() generator methods?))))
    (let loop ((r-info-cpl r-info-cpl))
      (match r-info-cpl
             ((item)
	      (g-object-import-with-supers1 item '() generator methods?))
             ((parent child . rest)
	      (g-object-import1 child parent generator methods?)
	      (loop (cons child rest)))))))

  ;; TBR
  ;; (display "gi-import-object1 EXIT\n"))


(define (add-entity generator entity)
  (assert (is-a? generator <golf-generator>))
  (slot-set! generator 'l-all-entities
	     (cons entity (slot-ref generator 'l-all-entities))))


(define (add-imported-type generator gi-name)
  (assert (is-a? generator <golf-generator>))
  (slot-set! generator 'l-imported-types
	     (cons
	      gi-name
	      (slot-ref generator 'l-imported-types))))


(define (add-imported-only-type generator gi-name)
  (assert (is-a? generator <golf-generator>))
  (slot-set! generator 'l-imported-only-type
	     (cons
	      gi-name
	      (slot-ref generator 'l-imported-only-type))))


(define (remove-type1 generator gi-name)
  (assert (is-a? generator <golf-generator>))
  (slot-set! generator 'l-imported-only-type
	     (delete
	      gi-name
	      (slot-ref generator 'l-imported-only-type))))


(define (add-imported-function generator s-target-name)
  (assert (is-a? generator <golf-generator>))
  (assert (symbol? s-target-name))
  (slot-set! generator 'l-imported-functions
	     (cons
	      s-target-name
	      (slot-ref generator 'l-imported-functions))))


(define (gi-import-function1 info generator toplevel?)
  (assert (is-a? generator <golf-generator>))
  (let ((intr-function (gi-make-function-entry info generator "")))
    (add-entity generator intr-function)
    (if toplevel?
	(slot-set! generator 'l-toplevel-functions
		   (cons intr-function
			 (slot-ref generator 'l-toplevel-functions))))))


(define (g-object-import1 child parent generator methods?)
  (assert (is-a? generator <golf-generator>))

  ;; TBR
  ;; (display "g-object-import1\n")
  
  (match parent
	 ((p-info p-namespace p-name)
	  (let* ((p-r-type (g-registered-type-info-get-g-type p-info))
		 (p-gi-name (g-type-name p-r-type))
		 (p-c-name (g-name->class-name p-gi-name)))
	    (g-object-import-with-supers1 child
					  (list p-c-name)
					  generator
					  methods?)))))

(define (g-object-import-with-supers1 child supers generator methods?)
  (assert (is-a? generator <golf-generator>))

  ;; TBR
  ;; (display "g-object-import-with-supers1\n")
  
  (match child
	 ((info namespace name)
	  ;; (unless (member namespace
	  ;; 		  (g-irepository-get-loaded-namespaces)
	  ;; 		  string=?)
	  ;;   g-irepository-require namespace)
	  
	  ;; TBR
	  ;; (display "g-object-import-with-supers1/2\n")
  
	  (let* ((r-type (g-registered-type-info-get-g-type info))
		 (gi-name (g-type-name r-type))
		 (str-basename (g-studly-caps-expand gi-name))
		 (s-target-name (g-name->class-name gi-name)))
	    (cond
	     ((not (member gi-name (slot-ref generator 'l-imported-types)))
	      (let* ((str-name (g-base-info-get-name info))
		     (str-namespace (g-base-info-get-namespace info))
		     (intr-object
		      (make <intr-object>
			#:str-namespace str-namespace
			#:str-name str-name
			#:s-target-name s-target-name
			#:l-methods '()
			#:l-supers supers
			#:l-properties '())))
		(add-entity generator intr-object)
		(add-imported-type generator gi-name)
		(if methods?
		    (begin
		      (gi-import-methods1 info intr-object generator
					  g-object-info-get-n-methods
					  g-object-info-get-method
					  str-basename)
		      (gi-import-properties1 info intr-object generator
					     str-basename
					     s-target-name))
		    (add-imported-only-type generator gi-name))))
	     ((and methods?
		   (member gi-name (slot-ref generator 'l-imported-only-type)))
	      (let* ((str-name (g-base-info-get-name info))
		     (str-namespace (g-base-info-get-namespace info))
		     (intr-object
		      (make <intr-object>
			#:str-namespace str-namespace
			#:str-name str-name
			#:s-target-name s-target-name
			#:l-methods '()
			#:l-supers supers
			#:l-properties '())))
		(remove-type1 generator gi-name)
		(add-imported-type generator gi-name)
		(gi-import-methods1 info intr-object generator
				    g-object-info-get-n-methods
				    g-object-info-get-method
				    str-basename)
		(gi-import-properties1 info intr-object generator
				       str-basename
				       s-target-name))))))))


(define (gi-import-nonobj-type info generator toplevel? methods?
			       create-intr
			       get-n-methods
			       get-method)
  (assert (is-a? generator <golf-generator>))
  (let* ((str-name (g-base-info-get-name info))
	 (str-namespace (g-base-info-get-namespace info))
	 (s-name (string->symbol str-name))
	 (s-namespace (string->symbol str-namespace))
	 ;; (p-explicit (assoc (cons s-namespace s-name)
	 ;;		    (slot-ref generator 'l-explicit-names)))
	 ;; (r-type (g-registered-type-info-get-g-type info))
         ;; (gi-name
	 ;;  (if p-explicit
	 ;;      (symbol->string (cdr p-explicit))
	 ;;      (g-type-name r-type)))
	 (gi-name (gi-registered-type-info-name info))
	 (str-basename (g-studly-caps-expand gi-name))
         (s-target-name (g-name->class-name gi-name)))
    (cond
     ((not (member gi-name (slot-ref generator 'l-imported-types)))
      (let* ((str-name (g-base-info-get-name info))
	     (str-namespace (g-base-info-get-namespace info))
	     (intr
	      (create-intr str-namespace str-name s-target-name)))
	(add-entity generator intr)
	(add-imported-type generator gi-name)
	(if methods?
	    (gi-import-methods1 info intr generator
				get-n-methods
				get-method
				str-basename)
	    (add-imported-only-type generator gi-name))))	    
     ((and methods?
	   (member gi-name (slot-ref generator 'l-imported-only-type)))
      (let* ((str-name (g-base-info-get-name info))
	     (str-namespace (g-base-info-get-namespace info))
	     (intr
	      (create-intr str-namespace str-name s-target-name)))
	(remove-type1 generator gi-name)
	(gi-import-methods1 info intr generator
			    get-n-methods
			    get-method
			    str-basename))))))


(define (gi-import-interface1 info generator toplevel? methods?)
  (let ((create-intr
	 (lambda (str-namespace str-name s-target-name)
	   (make <intr-interface>
	     #:str-namespace str-namespace
	     #:str-name str-name
	     #:s-target-name s-target-name
	     #:l-methods '()))))	   
    (gi-import-nonobj-type info generator toplevel? methods?
			   create-intr
			   g-interface-info-get-n-methods
			   g-interface-info-get-method)))


(define (get-struct-field-types l-types)
  (map
   (lambda (x-type)
     (let ((p (assq x-type gl-al-type-name-map)))
       (if p (cdr p) '<object>)))
   l-types))


(define (gi-import-struct1 info generator toplevel? methods?)
  (let* ((gi (gi-import-struct info))
	 (is-opaque? (!is-opaque? gi))
	 (is-semi-opaque? (!is-semi-opaque? gi))
	 (l-field-types (get-struct-field-types (!field-types gi))))
    (let ((create-intr
	   (lambda (str-namespace str-name s-target-name)
	     (make <intr-struct>
	       #:str-namespace str-namespace
	       #:str-name str-name
	       #:s-target-name s-target-name
	       #:l-methods '()
	       #:is-opaque? is-opaque?
	       #:is-semi-opaque? is-semi-opaque?
	       #:l-field-types l-field-types))))	   
      (gi-import-nonobj-type info generator toplevel? methods?
			     create-intr
			     g-struct-info-get-n-methods
			     g-struct-info-get-method))))


(define (gi-import-union1 info generator toplevel? methods?)
  (let ((create-intr
	 (lambda (str-namespace str-name s-target-name)
	   (make <intr-union>
	     #:str-namespace str-namespace
	     #:str-name str-name
	     #:s-target-name s-target-name
	     #:l-methods '()))))	   
    (gi-import-nonobj-type info generator toplevel? methods?
			   create-intr
			   g-union-info-get-n-methods
			   g-union-info-get-method)))


(define (gi-import-enum1 info generator toplevel? methods?)
  (let ((create-intr
	 (lambda (str-namespace str-name s-target-name)
	   (make <intr-enum>
	     #:str-namespace str-namespace
	     #:str-name str-name
	     #:s-target-name s-target-name
	     #:l-methods '()))))	   
    (gi-import-nonobj-type info generator toplevel? methods?
			   create-intr
			   g-enum-info-get-n-methods
			   g-enum-info-get-method)))


(define (gi-import-flags1 info generator toplevel? methods?)
  (let ((create-intr
	 (lambda (str-namespace str-name s-target-name)
	   (make <intr-flags>
	     #:str-namespace str-namespace
	     #:str-name str-name
	     #:s-target-name s-target-name
	     #:l-methods '()))))	   
    ;; G-Golf uses enum accessors for flags.
    (gi-import-nonobj-type info generator toplevel? methods?
			   create-intr
			   g-enum-info-get-n-methods
			   g-enum-info-get-method)))


(define (gi-import-methods1 info intr-type generator
			    get-n-methods get-method
			    str-basename)
  (assert (is-a? generator <golf-generator>))
  (assert (procedure? get-n-methods))
  (assert (procedure? get-method))
  (assert (string? str-basename))
  (let ((n-method (get-n-methods info))
	(l-methods '()))
    (do ((i 0
            (+ i 1)))
        ((= i n-method))
      (let* ((m-info (get-method info i))
	     (intf-method
	      (gi-make-function-entry m-info generator str-basename)))
	(set! l-methods (cons intf-method l-methods))
	(add-entity generator intf-method)
	(add-imported-function generator
			       (slot-ref intf-method 's-target-name))
	(gi-check-method m-info generator)))
    (slot-set! intr-type 'l-methods l-methods)))


(define (gi-check-method info generator)
  (assert (is-a? generator <golf-generator>))
  (let ((return-type (g-callable-info-get-return-type info)))
    (if (eq? (g-type-info-get-tag return-type) 'interface)
	(gi-import-info1 (g-type-info-get-interface return-type)
			 generator #f #f)))
  (let ((n (g-callable-info-get-n-args info)))
    (do ((i 0 (+ i 1))) ((>= i n))
      (let* ((info-arg (g-callable-info-get-arg info i))
	     (tp (g-arg-info-get-type info-arg)))
	(if (eq? (g-type-info-get-tag tp) 'interface)
	    (let ((x-intf (g-type-info-get-interface tp)))
	      (gi-import-info1 x-intf generator #f #f)))))))


(define (gi-import-properties1 info intr-object generator
			       str-basename s-class-name)
  (assert (is-a? intr-object <intr-object>))
  (assert (is-a? generator <golf-generator>))
  (assert (string? str-basename))
  (assert (symbol? s-class-name))
  (let ((i-count (g-object-info-get-n-properties info))
	(l-properties '()))
    (do ((i 0 (+ i 1))) ((>= i i-count))
      (let* ((info-prop (g-object-info-get-property info i))
	     (str-prop-name (g-base-info-get-name info-prop))
	     (str-accessor-name (string-append "!" str-prop-name))
	     (s-accessor-name (string->symbol str-accessor-name))
	     (l-prop-flags (g-property-info-get-flags info-prop))
	     (str-getter-name
	      (string-append str-basename "-get-" str-prop-name))
	     (s-getter-name (string->symbol str-getter-name))
	     (str-setter-name
	      (string-append str-basename "-set-" str-prop-name))
	     (s-setter-name (string->symbol str-setter-name))
	     (l-imported-functions
	      (slot-ref generator 'l-imported-functions))
	     (def-getter?
	       (and (member 'readable l-prop-flags)
		    (not (member s-getter-name
				 l-imported-functions))))
	     (def-setter?
	       (and (member 'writable l-prop-flags)
		    (not (member s-setter-name
				 l-imported-functions))))
	     (intr-property
	      (make <intr-property>
		#:str-namespace '()
		#:str-name str-prop-name
		#:s-target-name '()
		#:s-class-name s-class-name
		#:has-getter? def-getter?
		#:has-setter? def-setter?
		#:s-getter-name s-getter-name
		#:s-setter-name s-setter-name
		#:s-accessor-name s-accessor-name)))
	(add-entity generator intr-property)
	(set! l-properties (cons intr-property l-properties))))
    (slot-set! intr-object 'l-properties l-properties)))


(define (get-target-type type-desc)
  (let* ((base-type
	  (cond
	   ((list? type-desc)
	    (cond
	     ((eq? (car type-desc) 'object)
	      (cadr type-desc))
	     ((and (eq? (car type-desc) 'struct)
		   (eq? (cadr type-desc) 'g-value))
	      '<object>)
	     ((eq? (car type-desc) 'struct)
	      ;; '<pointer>)
	      (my-get-name (!g-name (caddr type-desc))))
	     ((eq? (car type-desc) 'glist)
	      '<list>)
	     ((eq? (car type-desc) 'gslist)
	      '<list>)
	     ((eq? (car type-desc) 'enum)
	      '<symbol>)
	     ((eq? (car type-desc) 'flags)
	      '(:uniform-list <symbol>))
	     ((eq? (car type-desc) 'union)
	      ;; '<pointer>)
	      (my-get-name (!g-name (caddr type-desc))))
	     ((eq? (car type-desc) 'interface)
	      '<object>)
	     ((eq? (car type-desc) 'byte-array)
	      '<bytevector>)
	     ((eq? (car type-desc) 'ptr-array)
	      '<object>)
	     ((eq? (car type-desc) 'callback)
	      '<object>)
	     ;; Don't know what the following is.
	     ((eq? (car type-desc) 'c)
	      '<object>)
	     (else
	      (display type-desc)
	      (newline)
	      (raise 'cannot-parse-argument-type))))
	   ((symbol? type-desc)
	    ;; We can have void as an argument type. This may be a bug in G-Golf.
	    (if (eq? type-desc 'void)
		'<object>
		(let ((p (assq type-desc gl-al-type-name-map)))
		  (if p (cdr p) type-desc))))
	   (else
	    (display type-desc)
	    (newline)
	    (raise 'cannot-parse-argument-type)))))
    base-type))

(define (get-target-type0 tag type1 return?)
  (case tag
   ((interface)
    (if (eq? type1 'void)
	(if return? '<none> '<object>)
	(get-target-type type1)))
   ((void)
    (if return? '<none> '<object>))
   ((boolean)
    '<boolean>)
   ((int64 uint64 int32 uint32 int16 uint16 int8 uint8)
    '<integer>)
   ((double float)
    '<real>)
   ((utf8 filename)
    '<string>)
   ((unichar)
    '<character>)
   ((glist gslist) '<list>)
   ((array)
    '<object>)
   ((gtype)
    '<symbol>)
   (else
    (raise (list 'unknown-type-tag (cons 'tag tag))))))


(define (get-target-type1 tag type1 may-return-null? return?)
  (let ((x (get-target-type0 tag type1 return?)))
    (if (or (not may-return-null?)
	    (eq? x '<object>)
	    (eq? x '<boolean>))
	x
	(list ':alt-maybe x))))


(define (get-argument-type x-arg)
  (let ((tag (!type-tag x-arg))
	(type-desc (!type-desc x-arg))
	(may-be-null? (!may-be-null? x-arg)))
    (get-target-type1 tag type-desc may-be-null? #f)))


(define (get-first-out-arg l-arguments)
  (car (filter (lambda (gi-arg) (eq? (!direction gi-arg) 'out)) l-arguments)))


(define (get-out-args l-arguments)
  (filter (lambda (gi-arg) (eq? (!direction gi-arg) 'out)) l-arguments))


(define (gi-make-function-entry info generator str-base)
  (assert (is-a? generator <golf-generator>))
  (assert (string? str-base))
  (let ((namespace (g-base-info-get-namespace info)))
    ;; (if (not (gi-namespace-import-exception? namespace))
    (receive (namespace b-name name m-name c-name)
	(gi-function-info-names info namespace)
      ;; (display "gi-make-function-entry\n")
      ;; (display name)
      ;; (newline)
      (let* ((str-name (g-base-info-get-name info))
	     ;; (x-function (gi-import-function info))
	     (x-function
	      (make <function>
		#:info info
		#:namespace namespace
		#:g-name b-name
		#:name name
		#:m-name m-name
		#:c-name c-name
		#:override? (gi-override? c-name)))
	     ;; (or (gi-cache-ref 'function name)
	     ;;     (let ((f-inst (make <function>
	     ;; 		      #:info info
	     ;; 		      #:namespace namespace
	     ;; 		      #:g-name b-name
	     ;; 		      #:name name
	     ;; 		      #:m-name m-name
	     ;; 		      #:c-name c-name
	     ;; 		      #:override? (gi-override? c-name))))
	     ;; 	(gi-cache-set! 'function name)
	     ;; 	(if (!is-method? f-inst)
	     ;; 	    (gi-add-method-* f-inst)
	     ;; 	    (gi-add-procedure f-inst))
	     ;; 	f-inst)))
	     (s-name (!name x-function))
	     ;; (tmp
	     ;;  (begin
	     ;;    (display "function name: ")
	     ;;    (display s-name)
	     ;;    (newline)
	     ;;    #f))
	     (l-arguments0 (!arguments x-function))
	     (l-arguments
	      (filter (lambda (gi-arg) (not (eq? (!direction gi-arg) 'out)))
		      l-arguments0))
	     (l-argument-types (map get-argument-type l-arguments))
	     (x-return-type-tag (!return-type x-function))
	     (x-return-type0 (!type-desc x-function))
	     (l-out-args (get-out-args l-arguments0))
	     (n-out-args (length l-out-args))
	     ;; (x-return-type
	     ;;  (if (and (> n-out-args 0)
	     ;; 	   (eq? x-return-type0 'void))
	     ;;      ;; Multiple return values won't probably work with Theme-D.
	     ;;      (if (= n-out-args 1)
	     ;; 	  (get-argument-type (get-first-out-arg l-arguments0))
	     ;; 	  '<object>)
	     ;;      (get-return-type x-return-type0 (!may-return-null? x-function))))
	     (strip-first?
	      (if (memq s-name (slot-ref generator 'l-strip-boolean-result))
		  #t
		  #f))
	     (x-return-type
	      (if strip-first?
		  (if (eq? x-return-type-tag 'boolean)
		      (cond
		       ((= n-out-args 0)
			;; Not sure about the following
			'<none>)
		       ((= n-out-args 1)
			(get-argument-type (car l-out-args)))
		       (else
			(map get-argument-type l-out-args)))
		      (raise (list 'invalid-function-to-strip
				   (cons 's-name s-name))))
		  (if (= n-out-args 0)
		      (get-target-type1 x-return-type-tag
					x-return-type0
					(!may-return-null? x-function)
					#t)
		      (cond
		       ((not (eq? x-return-type0 'void))
			(cons
			 ;; For a void argument the component type has to be
			 ;; <object>.
			 ;; That's why we pass #f as the third paramater here.
			 (get-target-type1 x-return-type-tag
					   x-return-type0
					   (!may-return-null? x-function)
					   #f)
			 (map get-argument-type l-out-args)))
		       ((= n-out-args 1)
			(get-argument-type (car l-out-args)))
		       (else
			(map get-argument-type l-out-args))))))
	     (n-return-values
	      (+ (if (or strip-first? (eq? x-return-type0 'void)) 0 1)
		 n-out-args))
	     (method? (gi-function-info-is-method? info))
	     (intr-function
	      (make <intr-function>
		#:str-namespace namespace
		#:str-name str-name
		#:s-target-name s-name
		#:l-argument-types l-argument-types
		#:x-return-type x-return-type
		#:n-return-values n-return-values
		#:method? method?
		#:str-base str-base)))
	(assert (not (and method? (string-null? str-base))))

	;; TBR
	;; (display "gi-make-function-entry EXIT\n")
	;; (display (class-of intr-function))
	;; (newline)
	
	intr-function))))

(define-method (get-method-name (intr-function <intr-function>))
  (let* ((str-base (slot-ref intr-function 'str-base))
	 (s-name (slot-ref intr-function 's-target-name))
	 (str-regexp (string-append "^" str-base "-"))
	 (str-name (symbol->string s-name))
	 (x-match (string-match str-regexp str-name)))
    (if x-match
	(let ((s-method-name
	       (string->symbol
		(substring str-name
			   (+ (string-length str-base) 1)))))
	  s-method-name)
	'())))

(define (suitable-for-method? l-argument-types)
  (not (for-all (lambda (x) (eq? x '<pointer>)) l-argument-types)))

