;; -*- mode: scheme; coding: utf-8 -*-

;;;;
;;;; Copyright (C) 2022 - 2024
;;;; Free Software Foundation, Inc.

;;;; This file is part of GNU G-Golf

;;;; GNU G-Golf 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 3 of the
;;;; License, or (at your option) any later version.

;;;; GNU G-Golf 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 GNU G-Golf.  If not, see
;;;; <https://www.gnu.org/licenses/lgpl.html>.
;;;;

;;; Commentary:

;;; Code:


(define-module (g-golf hl-api callable)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (ice-9 receive)
  #:use-module ((srfi srfi-1)
                #:select (delete-duplicates third filter-map))
  #:use-module (oop goops)
  #:use-module (g-golf support)
  #:use-module (g-golf gi)
  #:use-module (g-golf glib)
  #:use-module (g-golf gobject)
  #:use-module (g-golf override)
  #:use-module (g-golf hl-api n-decl)
  #:use-module (g-golf hl-api gtype)
  #:use-module (g-golf hl-api gobject)
  #:use-module (g-golf hl-api events)
  #:use-module (g-golf hl-api argument)
  #:use-module (g-golf hl-api closure)
  #:use-module (g-golf hl-api ccc)
  #:use-module (g-golf hl-api utils)

  #:duplicates (merge-generics
		replace
		warn-override-core
		warn
		last)

  #:export (preserve-g-value-ptr?
            callable-prepare-gi-arguments
            scm->gi-argument
            callable-return-value->scm
            callable-args-out->scm
            callable-arg-out->scm
            gi-argument->scm))


#;(g-export )


(define-method (initialize (self <callable>) initargs)
  (let* ((info (or (get-keyword #:info initargs #f)
                   (error "Missing #:info initarg: " initargs)))
         (namespace (get-keyword #:namespace initargs #f))
         (g-name (get-keyword #:g-name initargs (g-base-info-get-name info)))
         (name (get-keyword #:name initargs (g-name->name g-name)))
         (return-type-info (g-callable-info-get-return-type info))
         (return-type (g-type-info-get-tag return-type-info))
         (is-method? (g-callable-info-is-method info))
         (iot (g-callable-info-get-instance-ownership-transfer info)))
    (next-method)
    (receive (type-desc sub-type-desc)
        (type-description return-type-info
                          #:type-tag return-type
                          #:is-method? is-method?)
      (g-base-info-unref return-type-info)
      (mslot-set! self
                  'namespace (g-base-info-get-namespace info)
                  'g-name g-name
                  'name name
                  'can-throw-gerror (g-callable-info-can-throw-gerror info)
                  'is-method? is-method?
                  'caller-owns (g-callable-info-get-caller-owns info)
                  'instance-ownership-transfer iot
                  'return-type return-type
                  'type-desc type-desc
                  'sub-type-desc sub-type-desc
                  'is-enum? (and (eq? return-type 'interface)
                                      (match type-desc
                                        ((type name gi-type g-type)
                                         (or (eq? type 'enum)
                                             (eq? type 'flags)))))

                  'may-return-null? (g-callable-info-may-return-null info))
      (initialize-callable-arguments self))))

#;(define-method* (describe (self <callable>) #:key (port #t))
  (next-method self #:port port)
  (if (boolean? port)
      (newline)
      (newline port))
  (for-each (lambda (argument)
              (describe argument #:port port)
              (if (boolean? port)
                  (newline)
                  (newline port)))
      (!arguments self)))

(define-method (describe (self <callable>))
  (next-method)
  (newline)
  (for-each (lambda (argument)
              (describe argument)
              (newline))
      (!arguments self)))

(define (initialize-callable-arguments callable)
  (let* ((info (!info callable))
         (override? (!override? callable))
         (is-method? (!is-method? callable))
         (n-arg (g-callable-info-get-n-args info))
         (args (if is-method?
                   (list (make-instance-argument info))
                   '())))
    (let loop ((i 0)
               (arg-pos (length args))
               (al-pos '())
               (arguments args)
               (n-gi-arg-in (length args))
               (args-in args)
               (n-gi-arg-inout 0)
               (n-gi-arg-out 0)
               (args-out '()))
      (if (= i n-arg)
          ;; we need to complete al-pos (array length position (arg))
          ;; considering the returned value, which can be an array, the
          ;; length of which could be specified by an out arg.
          (let ((al-pos (al-pos-check callable 'out al-pos)))
            (initialize-callable-arguments-final-steps callable
                                                       (if is-method? (+ n-arg 1) n-arg)
                                                       (reverse al-pos)
                                                       (reverse arguments)
                                                       (reverse args-in)
                                                       (reverse args-out)
                                                       n-gi-arg-in
                                                       n-gi-arg-out))
          (let* ((arg-info (g-callable-info-get-arg info i))
                 (argument (make <argument> #:info arg-info #:is-method? is-method?)))
            (case (!direction argument)
              ((in)
               (mslot-set! argument
                           'arg-pos (if override?
                                        arg-pos
                                        (+ (- arg-pos n-gi-arg-out) n-gi-arg-inout))
                           'gi-argument-in-bv-pos n-gi-arg-in)
               (loop (+ i 1)
                     (+ arg-pos 1)
                     (al-pos-check argument 'in al-pos)
                     (cons argument arguments)
                     (+ n-gi-arg-in 1)
                     (cons argument args-in)
                     n-gi-arg-inout
                     n-gi-arg-out
                     args-out))
              ((inout)
               (mslot-set! argument
                           'arg-pos (if override?
                                        arg-pos
                                        (+ (- arg-pos n-gi-arg-out) n-gi-arg-inout))
                           'gi-argument-in-bv-pos n-gi-arg-in
                           'gi-argument-out-bv-pos n-gi-arg-out)
               (loop (+ i 1)
                     (+ arg-pos 1)
                     (al-pos-check argument 'inout al-pos)
                     (cons argument arguments)
                     (+ n-gi-arg-in 1)
                     (cons argument args-in)
                     (+ n-gi-arg-inout 1)
                     (+ n-gi-arg-out 1)
                     (cons argument args-out)))
              ((out)
               (mslot-set! argument
                           'arg-pos arg-pos
                           'gi-argument-out-bv-pos n-gi-arg-out)
               (loop (+ i 1)
                     (+ arg-pos 1)
                     (al-pos-check argument 'out al-pos)
                     (cons argument arguments)
                     n-gi-arg-in
                     args-in
                     n-gi-arg-inout
                     (+ n-gi-arg-out 1)
                     (cons argument args-out)))))))))

(define (al-pos-check clb/arg direction al-pos)
  (let ((type-tag (if (is-a? clb/arg <callable>)
                      (!return-type clb/arg)
                      (!type-tag clb/arg))))
    (case type-tag
      ((array)
       (match (!type-desc clb/arg)
         ((array fixed-size is-zero-terminated param-n param-tag ptr-array)
          (if (= param-n -1)
              al-pos
              (if (is-a? clb/arg <callable>)
                  (cons (list -1
                              -1
                              param-n
                              direction)
                        al-pos)
                  (let* ((arg-pos (!arg-pos clb/arg))
                         (u-args-ar-pos (if (< param-n arg-pos) ;; [1]
                                            (- arg-pos
                                               (+ (length al-pos) 1))
                                            (- arg-pos (length al-pos)))))
                    (cons (list u-args-ar-pos
                                arg-pos ;; 'real' array pos [2]
                                param-n
                                direction)
                          al-pos)))))))
      (else
       al-pos))))

;; [1]

;; u-arg-ar-pos are 'shifted' to the left - compared to their 'real'
;; cble-args-ar-pos - by an amount that depens on both previous al args,
;; and whether the one being processed has its al-pos, param-n,
;; preceeding or following the array pos itself.

;; [2]

;; the 'real' array pos is the offset of the array arg in the (complete)
;; cble-args list - we need it to construct the cble-args list

(define (initialize-callable-arguments-final-steps callable
                                                   n-arg
                                                   al-pos
                                                   arguments
                                                   args-in
                                                   args-out
                                                   n-gi-arg-in
                                                   n-gi-arg-out)
  (let* ((gi-args-in-bv (if (> n-gi-arg-in 0)
                            (make-bytevector (* %gi-argument-size
                                                n-gi-arg-in)
                                             0)
                            #f))
         (gi-args-in (if gi-args-in-bv
                         (bytevector->pointer gi-args-in-bv)
                         %null-pointer))
         (gi-args-out-bv (if (> n-gi-arg-out 0)
                             (make-bytevector (* %gi-argument-size
                                                 n-gi-arg-out)
                                              0)
                             #f))
         (gi-args-out (if gi-args-out-bv
                          (bytevector->pointer gi-args-out-bv)
                          %null-pointer))
         ;; we need to remove duplicate entries, as shown by one of the tests
         ;; gi_marshalling_tests_multi_array_key_value_in, in this case both
         ;; arrays are mentionning their array-length as 0 (the array length
         ;; arg pos in the original test function definition. but we can't
         ;; keep both, otherwise it would provoque 2 additional args at
         ;; runtime.
         (al-pos (delete-duplicates al-pos
                                    (lambda (x y)
                                      ;; x y pattern (u-pos c-pos l-pos direction)
                                      ;; we only keep one al-pos list per each l-pos
                                      ;; distinct value
                                      (= (third x) (third y)))))
         (al-pos-in (filter-map (lambda (item)
                                  (match item
                                    ((u-pos c-pos l-pos direction)
                                     (case direction
                                       ((in inout) item)
                                       (else #f)))))
                        al-pos)))
    (when gi-args-in-bv
      (finalize-callable-arguments args-in gi-args-in-bv !gi-argument-in))
    (when gi-args-out-bv
      (finalize-callable-arguments args-out gi-args-out-bv !gi-argument-out))
    (for-each (lambda (item)
                (match item
                  ((u-pos c-pos l-pos direction)
                   (set! (!al-arg? (list-ref arguments l-pos)) item))))
        al-pos)
    (mslot-set! callable
                'n-arg n-arg
                'al-pos al-pos
                'al-pos-in al-pos-in
                'n-al-pos-in (length al-pos-in)
                'arguments arguments
                'n-gi-arg-in n-gi-arg-in
                'args-in args-in
                'gi-args-in gi-args-in
                'gi-args-in-bv gi-args-in-bv
                'n-gi-arg-out n-gi-arg-out
                'args-out args-out
                'gi-args-out gi-args-out
                'gi-args-out-bv gi-args-out-bv
                'gi-arg-result (make-gi-argument))))

(define (finalize-callable-arguments args gi-args-bv gi-argument-acc)
  (let loop ((args args)
             (i 0))
    (match args
      (() #t)
      ((arg . rest)
       (set! (gi-argument-acc arg)
             (bytevector->pointer gi-args-bv
                                  (* i %gi-argument-size)))
       (loop rest
             (+ i 1))))))

(define (callable-prepare-gi-arguments callable args)
  (let* ((args-length (length args))
         (n-arg (!n-arg callable))
         (n-arg-in (!n-gi-arg-in callable))
         (al-pos-in (!al-pos-in callable))
         (n-al-pos-in (!n-al-pos-in callable))
         (effective-n-arg-in (- n-arg-in n-al-pos-in))
         (override? (!override? callable)))
    (if (or (and (or override?
                     (is-a? callable <callback>))
                 (= args-length n-arg))
            (= args-length effective-n-arg-in))
        (let ((clb-args (if (null? al-pos-in)
                            args
                            (u-args->cble-args n-arg-in args al-pos-in))))
          (callable-prepare-gi-args-in callable clb-args)
          (callable-prepare-gi-args-out callable clb-args args-length n-arg)
          clb-args)
        (scm-error 'wrong-arg-nb #f "Wrong number of arguments: ~A ~S"
                   (list (!name callable) args) #f))))

#!

;; example - to play with

(define cble-args
  '(e0 3 (ar1-0 ar1-1 ar1-2) e3 (ar2-0) 1 e6 2 (ar3-0 ar3-1)))

(define u-args
  '(e0 (ar1-0 ar1-1 ar1-2) e3 (ar2-0) e6 (ar3-0 ar3-1)))

(define al-pos
  '((1 2 1)	;; [1]
    (3 4 5)
    (5 8 7)))

;; [1]

;; an al-pos (array length position) entry is made of 3 items, which are
;; named (when calling match upon such an al-pos entry) u-pos c-pos
;; l-pos, integers that correspond to:

;;   u-pos 	the position of the array in the user args list
;;   c-pos 	the position of the array in the callable args list
;;   l-pos)	the position of the aray length in the callable args list

!#

(define (u-args->cble-args n-arg-in u-args al-pos-in)
  (if (null? al-pos-in)
      u-args
      (let loop ((i 0)
                 (args u-args)
                 (al-pos-in al-pos-in)
                 (cble-args '()))
        (if (= i n-arg-in)
            (reverse! cble-args)
            (if (null? al-pos-in)
                (loop (+ i 1)
                      (cdr args)
                      '()
                      (cons (car args) cble-args))
                (match (car al-pos-in)
                  ((u-pos c-pos l-pos direction)
                   (if (= i l-pos)
                       (let ((ar (list-ref u-args u-pos)))
                         (loop (+ i 1)
                               args
                               (cdr al-pos-in)
                               (cons (cond ((list? ar) (length ar))
                                           ((string? ar) (string-utf8-length ar))
                                           ;; #f is also admitted as an empty array
                                           ((not ar) 0)
                                           (else
                                            (error "What array is this " ar)))
                                     cble-args)))
                       (loop (+ i 1)
                             (cdr args)
                             al-pos-in
                             (cons (car args) cble-args))))
                  (else
                   (error "What al-pos-in is this:" (car al-pos-in)))))))))

(define %maybe-null-exceptions
  '(child-setup-data-destroy
    destroy
    notify)) ;; all destroy notify callback can be NULL

(define (maybe-null-exception? name)
  (memq name %maybe-null-exceptions))

(define (callable-prepare-gi-args-in callable args)
  (let ((is-method? (!is-method? callable))
        (g-value-ptr? (preserve-g-value-ptr? callable)))
    (let loop ((arguments (!args-in callable)))
      (match arguments
        (() 'done)
        ((argument . rest)
         (let* ((arg-pos (!arg-pos argument))
                (value (list-ref args arg-pos))
                (is-pointer? (!is-pointer? argument))
                (gi-argument (!gi-argument-in argument))
                (field (!gi-argument-field argument)))
           (scm->gi-argument (!type-tag argument)
                             (!type-desc argument)
                             gi-argument
                             value
                             argument
                             args
                             #:may-be-null-acc !may-be-null?
                             #:is-method? is-method?
                             #:forced-type (!forced-type argument)
                             #:g-value-ptr? (assq-ref g-value-ptr? arg-pos)
                             #:direction (!direction argument)
                             #:transfer (!transfer argument))
           (loop rest)))))))

(define* (scm->gi-argument type-tag
                           type-desc
                           gi-argument	;; or an ffi-arg
                           value	;; the scheme value
                           clb/arg	;; a <callable> or an <argument> instance
                           args
                           #:key
                           (ffi-arg? #f)
                           (may-be-null-acc #f)
                           (is-method? #f)
                           (forced-type #f)
                           (g-value-ptr? #f)
                           (direction 'n/a)
                           (transfer #f))
  (when (%debug)
    #;(dimfi " " 'scm->gi-argument)
    (dimfi (format #f "(-) ~16,,,' @A:" (!name clb/arg)) value)
    (dimfi (format #f "~20,,,' @A:" 'type-tag) type-tag)
    (dimfi (format #f "~20,,,' @A:" 'type-desc) type-desc)
    (dimfi (format #f "~20,,,' @A:" 'forced-type) forced-type)
    (dimfi (format #f "~20,,,' @A:" 'direction) direction)
    (dimfi (format #f "~20,,,' @A:" 'ffi-arg?) ffi-arg?))
  (let ((may-be-null? (may-be-null-acc clb/arg)))
    ;; clearing references kept from a previous call.
    (mslot-set! clb/arg
                'string-pointer #f
                'callback-closure #f
                'bv-cache #f
                'bv-cache-ptr #f)
    (case type-tag
      ((interface)
       (match type-desc
         ((type name gi-type g-type)
          (case type
            ((enum
              flags)
             (let ((val (case type
                          ((enum)
                           (or (enum->value gi-type value)
                               (error "No such symbol " value " in " gi-type)))
                          ((flags)
                           (or (flags->integer gi-type value)
                               (error "No such flags " value " in " gi-type))))))
               (case direction
                 ((inout)
                  ;; we need 1 further indirection
                  (receive (make-bv bv-ref bv-set!)
                      (gi-type-tag->bv-acc 'int32)
                    (let* ((bv-cache (!bv-cache clb/arg))
                           (bv-cache-ptr (!bv-cache-ptr clb/arg))
                           (bv (or bv-cache (make-bv 1 0)))
                           (bv-ptr (or bv-cache-ptr
                                       (bytevector->pointer bv))))
                      (unless bv-cache
                        (mslot-set! clb/arg
                                    'bv-cache bv
                                    'bv-cache-ptr bv-ptr))
                      (bv-set! bv 0 val)
                      (gi-argument-set! gi-argument 'v-pointer bv-ptr))))
                 (else
                  (gi-argument-set! gi-argument 'v-int val)))))
            ((struct)
             (let ((foreign
                    (case name
                      ((void
                        g-value)
                       ;; Struct for which the (symbol) name is void should be
                       ;; considerd opaque.  Functions and methods that use
                       ;; GValue(s) should be overridden-ed/manually wrapped to
                       ;; initialize those g-value(s) - and here, value is
                       ;; supposed to (always) be a valid pointer to an
                       ;; initialized GValue.
                       (or value %null-pointer))
                      ((g-closure)
                       ;; FIXME - as till this patch we accepted a pointer (to
                       ;; a GClosure), we'll keep that possibility for now, but
                       ;; later we should only accept procedure ...
                       (if value
                           (if (procedure? value)
                               (!g-closure (make <closure>
                                             #:function value
                                             #:g-value-ptr? g-value-ptr?))
                               value)
                           %null-pointer))
                      (else
                       (if (or (!is-opaque? gi-type)
                               (!is-semi-opaque? gi-type))
                           (or value %null-pointer)
                           (scm->gi-struct value (list gi-type transfer)))))))
               (gi-argument-set! gi-argument 'v-pointer
                                 (case direction
                                   ((inout)
                                    ;; we need 1 further indirection
                                    (let* ((bv (make-bytevector (sizeof '*) 0))
                                           (bv-ptr (bytevector->pointer bv)))
                                      (bv-ptr-set! bv-ptr foreign)
                                      bv-ptr))
                                   (else
                                    foreign)))))
            ((union)
             (gi-argument-set! gi-argument 'v-pointer value))
            ((object
              interface)
             (gi-argument-set! gi-argument 'v-pointer
                               (if value
                                   (!g-inst value)
                                   (if may-be-null?
                                       %null-pointer
                                       (error "Invalid argument: " value)))))
            ((callback)
             (let ((%g-golf-callback-closure
                    (@ (g-golf hl-api callback) g-golf-callback-closure)))
               (gi-argument-set! gi-argument 'v-pointer
                                 (if value
                                     (receive (native-ptr callback-closure)
                                         (%g-golf-callback-closure gi-type value)
                                       (set! (!callback-closure clb/arg) callback-closure)
                                       native-ptr)
                                     (if (or may-be-null?
                                             (>= (!destroy clb/arg) 0)
                                             ;; caution, check against the clb/arg name,
                                             ;; not the type-desc name, which is #f
                                             (maybe-null-exception? (!name clb/arg)))
                                         #f
                                         (error "Invalid argument: " value))))))))))
      ((array)
       (if (or (not value)
               (null? value))
           (if may-be-null?
               (gi-argument-set! gi-argument 'v-pointer #f)
               (error "Invalid array argument: " value))
           (let* ((array (scm->gi-array value
                                        (list type-desc
                                              (!sub-type-desc clb/arg)
                                              transfer)))
                  (array-ptr (if (pointer? array)
                                 ;; scm->gi-array may return a pointer already,
                                 ;; such as for strings, filename ...
                                 array
                                 (bytevector->pointer array))))
             (case direction
               ((inout)
                ;; we need 1 further indirection
                (let* ((bv (make-bytevector (sizeof '*) 0))
                       (bv-ptr (bytevector->pointer bv)))
                  (mslot-set! clb/arg
                              'bv-cache bv
                              'bv-cache-ptr bv-ptr)
                  (bv-ptr-set! bv-ptr array-ptr)
                  (gi-argument-set! gi-argument 'v-pointer bv-ptr)))
               (else
                (unless (eq? transfer 'everything)
                  (mslot-set! clb/arg
                              'bv-cache array
                              'bv-cache-ptr array-ptr))
                (gi-argument-set! gi-argument 'v-pointer array-ptr))))))
      ((glist
        gslist)
       (if (or (not value)
               (null? value))
           (if may-be-null?
               (gi-argument-set! gi-argument 'v-pointer #f)
               (error "Invalid glist argument: " value))
           (let ((g-first (case type-tag
                            ((glist)
                             (scm->gi-glist value type-desc))
                            ((gslist)
                             (scm->gi-gslist value type-desc)))))
             (case direction
               ((inout)
                ;; we need 1 further indirection
                (let* ((bv (make-bytevector (sizeof '*) 0))
                       (bv-ptr (bytevector->pointer bv)))
                  (slot-set! clb/arg 'bv-cache-ptr bv-ptr)
                  (bv-ptr-set! bv-ptr g-first)
                  (gi-argument-set! gi-argument 'v-pointer bv-ptr)))
               (else
                (unless (eq? transfer 'everything)
                  (slot-set! clb/arg 'bv-cache-ptr g-first))
                (gi-argument-set! gi-argument 'v-pointer g-first))))))
      ((ghash
        error)
       (if (not value)
           (if may-be-null?
               (gi-argument-set! gi-argument 'v-pointer #f)
               (error "Invalid " type-tag " argument: " value))
           (warning "Unimplemented type" (symbol->string type-tag))))
      ((utf8
        filename)
       ;; we need to keep a reference to string pointers, otherwise the
       ;; C string will be freed, which might happen before the C call
       ;; actually occurred.
       (if (not value)
           (if may-be-null?
               (gi-argument-set! gi-argument 'v-pointer #f)
               (error "Invalid " type-tag " argument: " #f))
           (let ((foreign (string->pointer value "utf8")))
             (set! (!string-pointer clb/arg) foreign)
             ;; don't use 'v-string, which expects a string, calls
             ;; string->pointer (and does not keep a reference).
             (gi-argument-set! gi-argument 'v-pointer
                                 (case direction
                                   ((inout)
                                    ;; we need 1 further indirection
                                    (let* ((bv (make-bytevector (sizeof '*) 0))
                                           (bv-ptr (bytevector->pointer bv)))
                                      (bv-ptr-set! bv-ptr foreign)
                                      bv-ptr))
                                   (else
                                    foreign))))))
      (else
       ;; Here starts fundamental types. However, we still need to check
       ;; the forced-type slot-value, and when it is a pointer, allocate
       ;; mem for the type-tag, then set the value and initialize the
       ;; gi-argument to a pointer to the alocated mem.
       (case forced-type
         ((pointer)
          ;; in this case, unlike i wrongly tought before this patch,
          ;; may-be-null? (can be) is #f, as we need a valid pointer,
          ;; which is dereferenced to retreive the 'out argument value.
          (case type-tag
            ((boolean
              int8 uint8
              int16 uint16
              int32 uint32
              int64 uint64
              float double
              gtype)
             (receive (make-bv bv-ref bv-set!)
                 (gi-type-tag->bv-acc type-tag)
               (if ffi-arg?
                   (let* ((foreign (gi-argument-ref gi-argument 'v-pointer))
                          (bv-ptr (dereference-pointer foreign))
                          (bv-size (sizeof (primitive-eval type-tag)))
                          (bv (pointer->bytevector bv-ptr bv-size)))
                     (bv-set! bv 0 value))
                   (let* ((bv-cache (!bv-cache clb/arg))
                          (bv-cache-ptr (!bv-cache-ptr clb/arg))
                          (bv (or bv-cache (make-bv 1 0)))
                          (bv-ptr (or bv-cache-ptr
                                      (bytevector->pointer bv))))
                     (unless bv-cache
                       (mslot-set! clb/arg
                                   'bv-cache bv
                                   'bv-cache-ptr bv-ptr))
                     (bv-set! bv 0
                              (case type-tag
                                ((boolean) (if value 1 0))
                                (else value)))
                     (gi-argument-set! gi-argument 'v-pointer bv-ptr)))))
            ((void)
             ;; Till proved wrong, we'll consider those opaque
             ;; pointers.
             (gi-argument-set! gi-argument 'v-pointer value))
            (else
             (warning "Unimplemented (pointer to): " type-tag))))
         (else
          (gi-argument-set! gi-argument
                            (gi-type-tag->field type-tag)
                            value)))))))

(define (callable-prepare-gi-args-out callable args args-length n-arg)
  (let ((n-gi-arg-out (!n-gi-arg-out callable))
        (args-out (!args-out callable)))
    (let loop ((i 0))
      (if (= i n-gi-arg-out)
          #t
          (let ((arg-out (list-ref args-out i)))
            (cond ((eq? (!direction arg-out) 'inout)
                   ;; Then we 'merely' copy the content of the
                   ;; gi-argument-in to the gi-argument-out.
                   (let ((gi-argument-size %gi-argument-size)
                         (in-bv (!gi-args-in-bv callable))
                         (in-bv-pos (!gi-argument-in-bv-pos arg-out))
                         (out-bv (!gi-args-out-bv callable))
                         (out-bv-pos (!gi-argument-out-bv-pos arg-out)))
                     (bytevector-copy! in-bv
                                       (* in-bv-pos gi-argument-size)
                                       out-bv
                                       (* out-bv-pos gi-argument-size)
                                       gi-argument-size)))
                  ((and (!override? callable)
                        (= args-length n-arg))
                   ;; Then all 'out argument(s) have been provided, as a
                   ;; pointer, and what ever they point to must have
                   ;; been initialized - see (g-golf override gtk) for
                   ;; some exmples.
                   (let* ((arg-pos (!arg-pos arg-out))
                          (arg (list-ref args arg-pos)))
                     (gi-argument-set! (!gi-argument-out arg-out) 'v-pointer
                                       (scm->gi arg 'pointer))))
                  (else
                   (let* ((type-tag (!type-tag arg-out))
                          (type-desc (!type-desc arg-out))
                          (is-pointer? (!is-pointer? arg-out))
                          (may-be-null? (!may-be-null? arg-out))
                          (is-caller-allocate? (!is-caller-allocate? arg-out))
                          (forced-type (!forced-type arg-out))
                          (gi-argument-out (!gi-argument-out arg-out))
                          (field (!gi-argument-field arg-out)))
                     (case type-tag
                       ((interface)
                        (match type-desc
                          ((type name gi-type g-type)
                           (case type
                             ((enum
                               flags)
                              (let ((bv (make-bytevector (sizeof int) 0)))
                                (gi-argument-set! gi-argument-out 'v-pointer
                                                  (bytevector->pointer bv))))
                             ((struct)
                              (case name
                                ((g-value)
                                 (gi-argument-set! gi-argument-out 'v-pointer
                                                   (g-value-new))) ;; an empty GValue
                                (else
                                 (if is-caller-allocate?
                                     (let* ((bv (make-bytevector (!size gi-type) 0))
                                            (bv-ptr (bytevector->pointer bv)))
                                       (mslot-set! arg-out
                                                   'bv-cache bv
                                                   'bv-cache-ptr bv-ptr)
                                       (gi-argument-set! gi-argument-out 'v-pointer bv-ptr))
                                     (let ((bv (make-bytevector (sizeof '*) 0)))
                                       (mslot-set! arg-out
                                                   'bv-cache #f
                                                   'bv-cache-ptr #f)
                                       (gi-argument-set! gi-argument-out 'v-pointer
                                                         (bytevector->pointer bv)))))))

                             ((object
                               interface)
                              (if is-pointer?
                                  (let ((bv (make-bytevector (sizeof '*) 0)))
                                    (gi-argument-set! gi-argument-out 'v-pointer
                                                      (bytevector->pointer bv)))
                                  (gi-argument-set! gi-argument-out 'v-pointer
                                                    %null-pointer)))))))
                       ((array)
                        (match type-desc
                          ((array fixed-size is-zero-terminated param-n param-tag ptr-array)
                           (let* ((bv (if is-caller-allocate?
                                          (case param-tag
                                            ((interface)
                                             ;; likely an array of struct
                                             (match (!sub-type-desc arg-out)
                                               ((type r-name gi-struct id)
                                                (case type
                                                  ((struct)
                                                   (let* ((s-size (!size gi-struct))
                                                          (n-item fixed-size))
                                                     (make-bytevector (* n-item s-size))))
                                                  (else
                                                   (error "what array description is this?"))))))
                                            (else
                                             (receive (make-bv bv-ref bv-set!)
                                                 (gi-type-tag->bv-acc param-tag)
                                               (make-bv fixed-size))))
                                          (make-bytevector (sizeof '*))))
                                  (bv-ptr (bytevector->pointer bv)))
                             (mslot-set! arg-out
                                         'bv-cache bv
                                         'bv-cache-ptr bv-ptr)
                             (gi-argument-set! gi-argument-out 'v-pointer bv-ptr)))))
                       ((glist
                         gslist)
                        (if is-pointer?
                            (let ((bv (make-bytevector (sizeof '*) 0)))
                              (gi-argument-set! gi-argument-out 'v-pointer
                                                (bytevector->pointer bv)))
                            (gi-argument-set! gi-argument-out 'v-pointer
                                              %null-pointer)))
                       ((ghash)
                        (warning "Unimplemented type" (symbol->string type-tag))
                        (gi-argument-set! gi-argument-out 'v-pointer %null-pointer))
                       ((error)
                        (gi-argument-set! gi-argument-out 'v-pointer (gi-pointer-new)))
                       ((utf8
                         filename)
                        (if is-pointer?
                            (let ((bv (make-bytevector (sizeof '*) 0)))
                              (gi-argument-set! gi-argument-out 'v-pointer
                                                (bytevector->pointer bv)))
                            (gi-argument-set! gi-argument-out 'v-pointer
                                              %null-pointer)))
                       ((boolean
                         int8 uint8
                         int16 uint16
                         int32 uint32
                         int64 uint64
                         float double
                         gtype)
                        (let* ((field (gi-type-tag->field type-tag))
                               (type (assq-ref %gi-argument-desc field))
                               (bv (make-bytevector (sizeof type) 0)))
                          (gi-argument-set! gi-argument-out 'v-pointer
                                            (bytevector->pointer bv))))
                       (else
                        ;; not sure, but this shouldn't arm.
                        (warning "Unimplemented type" (symbol->string type-tag))
                        (gi-argument-set! gi-argument-out 'v-ulong 0))))))
            (loop (+ i 1)))))))

(define (callable-args-out->scm callable u-args)
  ;; some out arg(s) are array length (for other out arg(s)) and need to
  ;; be retrieved first, as they are required to build the corresponding
  ;; array.
  (receive (al-out-args out-args)
      (split-out-args (!args-out callable))
    (let* ((al-out-arg-vals (map (lambda (arg)
                                   (let ((arg-pos (!arg-pos arg)))
                                     (cons arg-pos
                                           (callable-arg-out->scm arg))))
                              al-out-args))
           (out-arg-vals (map (lambda (arg)
                                (cons (!arg-pos arg)
                                      (callable-arg-out->scm arg
                                                             #:al-alist al-out-arg-vals)))
                           out-args))
           (out-args (sort (append al-out-arg-vals
                                   out-arg-vals)
                           (lambda (a b)
                             (< (car a) (car b))))))
      (values (map cdr out-args)
              al-out-arg-vals))))

(define* (callable-arg-out->scm argument
                                #:key (al-alist '()))
  (let* ((type-tag (!type-tag argument))
         (type-desc (!type-desc argument))
         (gi-argument (!gi-argument-out argument))
         (is-caller-allocate? (!is-caller-allocate? argument))
         (forced-type (!forced-type argument))
         (is-pointer? (!is-pointer? argument))
         (value (gi-argument->scm type-tag
                                  type-desc
                                  gi-argument
                                  argument ;; the type-desc instance 'owner'
                                  #:is-caller-allocate? is-caller-allocate?
                                  #:forced-type forced-type
                                  #:is-pointer? is-pointer?
                                  #:direction (!direction argument)
                                  #:transfer (!transfer argument)
                                  #:al-alist al-alist)))
    (when (%debug)
      (let ((n-pos (string-length (format #f "~A" value))))
        (dimfi (format #f "~?"
                       (string-append "~A ~"
                                      (number->string (- 30 n-pos))
                                      ",,,' @A")
                       (list (format #f "~20,,,' @A: ~S" (!name argument) value)
                             " [ out arg ]")))))
    value))

(define* (callable-return-value->scm callable #:key (al-alist '()))
  (let* ((type-tag (!return-type callable))
         (type-desc (!type-desc callable))
         (gi-argument (!gi-arg-result callable))
         (value (gi-argument->scm type-tag
                                  type-desc
                                  gi-argument
                                  callable ;; the type-desc instance 'owner'
                                  #:transfer (!caller-owns callable)
                                  #:al-alist al-alist)))
    (when (%debug)
      #;(dimfi (format #f "~4,,,' @A" " =>") value "[" (!name callable) "]")
      (dimfi (format #f "~4,,,' @A" " =>") value))
    value))

(define* (gi-argument->scm type-tag type-desc gi-argument clb/arg
                           #:key
                           (is-caller-allocate? #f)
                           (forced-type #f)
                           (is-pointer? #f)
                           (g-value-ptr? #f)
                           (direction 'n/a)
                           (transfer #f)
                           (al-alist '()))
  ;; forced-type is only used for 'inout and 'out arguments, in which
  ;; case it is 'pointer - see 'simple' types below.

  ;; clb/arg is the instance that owns the type-desc, which might need to
  ;; be updated - see the comment in the 'interface/'object section of
  ;; the code below, as well as the comment in registered-type->gi-type
  ;; which explains why/when this might happen.
  (case type-tag
    ((interface)
     (match type-desc
       ((type name gi-type g-type)
        (case type
          ((enum
            flags)
           (let ((val
                  (case direction
                    ((inout out)
                     (let* ((foreign (gi-argument-ref gi-argument 'v-pointer))
                            (bv (pointer->bytevector foreign (sizeof int))))
                       (s32vector-ref bv 0)))
                    (else
                     (gi-argument-ref gi-argument 'v-int)))))
             (case type
               ((enum)
                (enum->symbol gi-type val))
               ((flags)
                (integer->flags gi-type val)))))
          ((struct)
           (let* ((gi-arg-val (gi-argument-ref gi-argument 'v-pointer))
                  (foreign (if is-pointer?
                               (and gi-arg-val
                                    (gi->scm (dereference-pointer gi-arg-val)
                                             'pointer))
                               gi-arg-val)))
             (and foreign
                  (case name
                    ((g-value)
                     (if g-value-ptr?
                         foreign
                         (g-value-ref foreign)))
                    (else
                     (if (or (!is-opaque? gi-type)
                             (!is-semi-opaque? gi-type))
                         (let ((bv (slot-ref clb/arg 'bv-cache))
                               (bv-ptr (slot-ref clb/arg 'bv-cache-ptr)))
                           (if bv
                               (begin
                                 (g-boxed-sa-guard bv-ptr bv)
                                 bv-ptr)
                               ;; when bv is #f, it (indirectly) means that
                               ;; memory is allocated by the callee, so we don't
                               ;; need (g-boxed-ga-guard foreign g-type)
                               foreign))
                         (gi-struct->scm foreign (list gi-type transfer))))))))
          ((union)
           (let ((foreign (gi-argument-ref gi-argument 'v-pointer)))
             (case name
               ((gdk-event)
                 ;; This means that we are in gdk3/gtk3 environment,
                 ;; where the <gdk-event> class and accessors are (must
                 ;; be) defined dynamically - hence (gdk-event-class)
                (and foreign
                     (make (gdk-event-class) #:event foreign)))
               (else
                foreign))))
          ((object
            interface)
           (let* ((gi-arg-val (gi-argument-ref gi-argument 'v-pointer))
                  (foreign (if is-pointer?
                               (dereference-pointer gi-arg-val)
                               gi-arg-val)))
             (case name
               ((<g-param>)
                (gi-pointer->scm foreign))
               (else
                (and foreign
                     (not (null-pointer? foreign))
                     (receive (class name g-type)
                         (g-object-find-class foreign)
                       (make class #:g-inst foreign)))))))))))
    ((array)
     (let* ((gi-arg-val (gi-argument-ref gi-argument 'v-pointer))
            (foreign (and gi-arg-val
                          (if is-caller-allocate?
                              gi-arg-val
                              (case direction
                                ((inout out)
                                 (dereference-pointer gi-arg-val))
                                (else
                                 gi-arg-val))))))
       (and foreign
            (gi-array->scm foreign
                           (list type-desc
                                 (!sub-type-desc clb/arg)
                                 transfer
                                 ;; the array length can be given by an out arg
                                 al-alist)))))
    ((glist
      gslist)
     (let* ((gi-arg-val (gi-argument-ref gi-argument 'v-pointer))
            (g-first (and gi-arg-val
                          (if is-caller-allocate?
                              gi-arg-val
                              (case direction
                                ((inout out)
                                 (dereference-pointer gi-arg-val))
                                (else
                                 gi-arg-val))))))
       (and g-first
            (case type-tag
              ((glist)
               (gi-glist->scm g-first (list type-desc transfer)))
              ((gslist)
               (gi-gslist->scm g-first (list type-desc transfer)))))))
    ((ghash)
     (warning "Unimplemented type" (symbol->string type-tag)))
    ((error)
     (let* ((gi-arg-val (gi-argument-ref gi-argument 'v-pointer))
            (foreign (and gi-arg-val
                          (if is-caller-allocate?
                              gi-arg-val
                              (case direction
                                ((inout out)
                                 (gi-pointer->scm (dereference-pointer gi-arg-val)))
                                (else
                                 gi-arg-val))))))
       (and foreign
            (gi-struct->scm foreign
                            (list (gi-cache-ref 'boxed 'g-error)
                                  transfer)))))
    ((utf8
      filename)
     (let* ((gi-arg-val (gi-argument-ref gi-argument 'v-pointer))
            (foreign (if is-pointer?
                         (dereference-pointer gi-arg-val)
                         gi-arg-val)))
       (gi->scm foreign 'string)))
    ((void)
     (let* ((gi-arg-val (gi-argument-ref gi-argument 'v-pointer))
            (foreign (if is-pointer?
                         (dereference-pointer gi-arg-val)
                         gi-arg-val)))
       (gi->scm foreign 'pointer)))
    (else
     ;; Here starts 'simple' types, but we still need to check the
     ;; forced-type: when it is 'pointer (which happens for 'inout and
     ;; 'out arguments, not for returned values), the the gi-argument
     ;; holds a pointer to the value, otherwise, it holds the value.
     (case forced-type
       ((pointer)
        (let ((foreign (gi-argument-ref gi-argument 'v-pointer)))
          (and foreign
               (case type-tag
                 ((boolean
                   int8 uint8
                   int16 uint16
                   int32 uint32
                   int64 uint64
                   float double
                   gtype)
                  (receive (make-bv bv-ref bv-set!)
                      (gi-type-tag->bv-acc type-tag)
                    (let* ((field (gi-type-tag->field type-tag))
                           (type (assq-ref %gi-argument-desc field))
                           (bv (pointer->bytevector foreign (sizeof type)))
                           (val (bv-ref bv 0)))
                      (case type-tag
                        ((boolean)
                         (gi->scm val 'boolean))
                        (else
                         val)))))
                 ((void)
                  ;; Till proved wrong, we'll consider those opaque
                  ;; pointers.
                  foreign)
                 (else
                  (warning "Unimplemeted (pointer to) type-tag: " type-tag)
                  (gi->scm foreign 'pointer))))))
       (else
        (gi-argument-ref gi-argument
                         (gi-type-tag->field type-tag)))))))


;;;
;;; Method instance argument
;;;

(define (make-instance-argument info)
  (let* ((container (g-base-info-get-container info))
         (g-name (g-base-info-get-name container))
         (name (g-name->name g-name))
         (type (g-base-info-get-type container)))
    (receive (g-type r-name gi-type)
        (registered-type->gi-type container type)
      (g-base-info-unref container)
      (make <argument>
        #:info 'instance
        #:g-name g-name
        #:name name
        #:direction 'in
        #:type-tag 'interface
        #:type-desc (list type r-name gi-type g-type)
        #:is-enum? #f
        #:forced-type 'pointer
        #:is-pointer? #t
        #:may-be-null? #f
        #:arg-pos 0 ;; always the first argument
        #:gi-argument-field 'v-pointer))))


;;;
;;; g-closure preserve g-value ptr
;;;

;; Below, when that applies, we return an alist, the key being the arg
;; pos expecting a GClosure (ptr), and the value, the pos of the
;; GClosure arg(s) for which the g-closure-marshal should preserve the
;; GValue pointer(s) to call the scheme (user closure) procedure.

(define (preserve-g-value-ptr? callable)
  (case (!name callable)
    ((get-property
      set-property)
     #t)
    ((g-object-bind-property-full)
     '((5 . (1 2))       ;; tranform-to		input output
       (6 . (1 2))))     ;; transform-from	input output
    (else
     #f)))


;;;
;;; utils
;;;

(define (split-out-args args)
  (let loop ((args args)
             (al-out-args '())
             (out-args '()))
    (match args
      (()
       (values (reverse al-out-args)
               (reverse out-args)))
      ((arg . rest)
       (if (!al-arg? arg)
           (loop rest
                 (cons arg al-out-args)
                 out-args)
           (loop rest
                 al-out-args
                 (cons arg out-args)))))))
