;;;; lazy-ffi-support.scm
;
; Copyright (c) 2000-2011, Felix L. Winkelmann
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
; conditions are met:
;
;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
;     disclaimer.
;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
;     disclaimer in the documentation and/or other materials provided with the distribution.
;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
;     products derived from this software without specific prior written permission.
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
; POSSIBILITY OF SUCH DAMAGE.


(module lazy-ffi (lazy-ffi:module
		  lazy-ffi:function-ptr
		  lazy-ffi:function)

(import scheme chicken (except foreign foreign-declare))
(use srfi-1 srfi-69 easyffi)

(cond-expand
 (debug
  (define-syntax dbg
    (syntax-rules ()
      ((_ . args) (print . args)))))
 (else
  (define-syntax dbg
    (syntax-rules ()
      ((_ . args) #f)))))

(define-syntax switch
  (syntax-rules (else)
    ((_ "clause" tmp ()) (void))
    ((_ "clause" tmp ((else . body)))
     (let () . body))
    ((_ "clause" tmp ((val . body) . more))
     (if (eq? tmp val)
	 (let () . body)
	 (switch "clause" tmp more)))
    ((_ exp clause ...)
     (let ((tmp exp))
       (switch "clause" tmp (clause ...))))))

#>
#ifdef __MINGW32__
# include <windows.h>
# define RTLD_LAZY           0
# define RTLD_GLOBAL         0
# define dlopen(fn, t)       LoadLibrary(fn)
# define dlsym(h, f)         GetProcAddress(h, f)
#else
# include <dlfcn.h>
#endif
#if defined(C_MACOSX)
# include <ffi/ffi.h>
#else
# include <ffi.h>
#endif
<#

(foreign-parse #<<EOF
const ___fixnum RTLD_LAZY, RTLD_GLOBAL;

void *dlopen(char *, ___fixnum);
void *dlsym(void *, char *);
EOF
)

(foreign-parse/declare #<<EOF

#define LAZY_VOID_TYPE       0
#define LAZY_INT_TYPE        1
#define LAZY_DOUBLE_TYPE     2
#define LAZY_PTR_TYPE        3
#define LAZY_CHAR_TYPE       4
#define LAZY_SCHEME_TYPE     5
#define LAZY_SCHEME_PTR_TYPE 6
#define LAZY_STRING_TYPE     7
#define LAZY_UINT_TYPE       8

#define LAZY_OK            0
#define LAZY_BAD_TYPE      1
#define LAZY_BAD_CIF       2
#define LAZY_BAD_ARG       3
#define LAZY_BAD_RTYPE     4

static ___fixnum call_lazy(void *fptr, ___scheme_value args, ___fixnum n, int rtype, ___scheme_value atypelist,
                           ___scheme_value result)
{
  int i;
  unsigned int ui;
  ffi_status s;
  ffi_cif cif;
  void **avalues = alloca(n * sizeof(void *));
  ffi_type **atypes = alloca(n * sizeof(ffi_type *));
  void **avptr = avalues;
  ffi_type **atptr = atypes;
  ffi_type *rt;
  ___scheme_value arg;
  void *ptr, *resultb = alloca(8);

  switch(rtype) {
  case LAZY_VOID_TYPE: rt = &ffi_type_void; break;
  case LAZY_INT_TYPE: rt = &ffi_type_sint; break;
  case LAZY_UINT_TYPE: rt = &ffi_type_uint; break;
  case LAZY_DOUBLE_TYPE: rt = &ffi_type_double; break;
  case LAZY_SCHEME_PTR_TYPE:
  case LAZY_SCHEME_TYPE:
  case LAZY_STRING_TYPE:
  case LAZY_PTR_TYPE: rt = &ffi_type_pointer; break;
  case LAZY_CHAR_TYPE: rt = &ffi_type_uint8; break;
  default: return LAZY_BAD_TYPE;
  }

  for(i = 0; i < n; ++i) {
    arg = C_u_i_car(args);

    switch(C_unfix(C_u_i_car(atypelist))) {
    case LAZY_INT_TYPE:
      ptr = alloca(sizeof(int));
      *((int *)ptr) = C_num_to_int(arg);
      *(atptr++) = &ffi_type_sint;
      *(avptr++) = ptr;
      break;

    case LAZY_UINT_TYPE:
      ptr = alloca(sizeof(int));
      *((int *)ptr) = C_num_to_unsigned_int(arg);
      *(atptr++) = &ffi_type_uint;
      *(avptr++) = ptr;
      break;

    case LAZY_CHAR_TYPE:
      ptr = alloca(sizeof(int));
      *((char *)ptr) = C_character_code(arg);
      *(atptr++) = &ffi_type_uint8;
      *(avptr++) = ptr;
      break;

    case LAZY_DOUBLE_TYPE:
      *(atptr++) = &ffi_type_double;
      *(avptr++) = C_data_pointer(arg);
      break;

    case LAZY_SCHEME_PTR_TYPE:
      if(C_immediatep(arg)) return LAZY_BAD_ARG;

      /* fall through... */

    case LAZY_STRING_TYPE:
      ptr = alloca(sizeof(void *));
      *(atptr++) = &ffi_type_pointer;
      *(avptr++) = ptr;

      if(arg == C_SCHEME_FALSE) *((void **)ptr) = NULL;
      else *((void **)ptr) = C_data_pointer(arg);

      break;

    case LAZY_PTR_TYPE:
      ptr = alloca(sizeof(void *));
      *(atptr++) = &ffi_type_pointer;
      *(avptr++) = ptr;

      if(arg == C_SCHEME_FALSE) *((void **)ptr) = NULL;
      else *((void **)ptr) = (void *)C_block_item(arg, 0);

      break;

    case LAZY_SCHEME_TYPE:
      *(atptr++) = &ffi_type_pointer;
      *(avptr++) = (void *)arg;
      break;

    default: return LAZY_BAD_TYPE;
    }

    atypelist = C_u_i_cdr(atypelist);
    args = C_u_i_cdr(args);
  }

  s = ffi_prep_cif(&cif, FFI_DEFAULT_ABI, n, rt, atypes);

  if(s != FFI_OK) return LAZY_BAD_CIF;

  ffi_call(&cif, fptr, resultb, avalues);

  switch(rtype) {
  case LAZY_INT_TYPE:
    i = *((int *)resultb);

    if(C_fitsinfixnump(i)) C_set_block_item(result, 0, C_fix(i));
    else *((double *)C_data_pointer(C_block_item(result, 1))) = (double)i;

    break;
  case LAZY_UINT_TYPE:
    ui = *((unsigned int *)resultb);

    if(C_ufitsinfixnump(ui)) C_set_block_item(result, 0, C_fix(ui));
    else *((double *)C_data_pointer(C_block_item(result, 1))) = (double)ui;

    break;
  case LAZY_DOUBLE_TYPE: *((double *)C_data_pointer(result)) = *((double *)resultb); break;
  case LAZY_STRING_TYPE:
  case LAZY_PTR_TYPE: C_set_block_item(result, 0, (C_word)*((void **)resultb)); break;
  case LAZY_CHAR_TYPE: C_set_block_item(result, 0, C_make_character(*((char *)resultb))); break;
  case LAZY_SCHEME_TYPE: C_set_block_item(result, 0, *((C_word *)resultb)); break;
  case LAZY_VOID_TYPE: break;
  default: return LAZY_BAD_RTYPE;
  }

  return LAZY_OK;
}


___safe ___fixnum call_lazy_safe(void *fptr, ___scheme_value args, ___fixnum n, int rtype, ___scheme_value atypelist,
                                     ___scheme_value result)
{
  return call_lazy(fptr, args, n, rtype, atypelist, result);
}
EOF
)


(define *modules* '())
(define *handles* (make-hash-table))

(define (lazy-ffi:module name)
  (set! *modules* (lset-adjoin eq? *modules* (and name (string->symbol name))) ) )

(define (lookup-symbol name)
  (let loop ([ms *modules*])
    (if (null? ms)
	(error 'lazy-ffi:function "can not resolve external symbol" name)
	(let* ([m (car ms)]
	       [h (or (hash-table-ref/default *handles* m #f)
		      (and-let* ([h (dlopen (and m (symbol->string m))
					    (fxior RTLD_LAZY RTLD_GLOBAL))])
			(hash-table-set! *handles* m h)
			(dbg "[dlopened: " m "]")
			h)
		      (begin
			(##sys#warn "can not open library" m)
			#f) ) ] )
	  (if h
	      (let ([ptr (dlsym h (symbol->string name))])
		(dbg "[resolving " name " in " m "]")
		(or ptr
		    (let ([s2 (##sys#string-append "_" (symbol->string name))])
		      (let ([ptr (dlsym h s2)])
			(dbg "[resolving " s2 " in " m "]")
			(or ptr
			    (loop (cdr ms)) ) ) ) ) )
	      (loop (cdr ms)) ) ) ) ) )

(define (type-code t loc)
  (case t
    [(unsigned-int:) LAZY_UINT_TYPE]
    [(bool: int:) LAZY_INT_TYPE]
    [(void:) LAZY_VOID_TYPE]
    [(char:) LAZY_CHAR_TYPE]
    [(float: double:) LAZY_DOUBLE_TYPE]
    [(pointer:) LAZY_PTR_TYPE]
    [(string: symbol:) LAZY_STRING_TYPE]
    [(scheme-pointer: byte-vector:) LAZY_SCHEME_PTR_TYPE]
    [(scheme-object:) LAZY_SCHEME_TYPE]
    [(u8vector: s8vector: u16vector: s16vector: u32vector: s32vector: f32fector: f64vector:) LAZY_SCHEME_PTR_TYPE]
    [else (error loc "invalid ffi type" t)] ) )

(define (check-arg x t loc)
  (switch t
    [LAZY_INT_TYPE
     (cond [(boolean? x) (if x 1 0)]
	   [else x] ) ]
    [LAZY_UINT_TYPE
     (cond [(boolean? x) (if x 1 0)]
	   [else x] ) ]
    [LAZY_DOUBLE_TYPE (exact->inexact x)]
    [LAZY_CHAR_TYPE
     (##sys#check-char x 'lazy-ffi:function)
     x]
    [LAZY_PTR_TYPE
     (when x (##sys#check-special x 'lazy-ffi:function))
     x]
    [LAZY_STRING_TYPE
     (cond [(string? x) (##sys#make-c-string x)]
	   [(symbol? x) (##sys#make-c-string (##sys#slot x 1))]
	   [else (error loc "bad argument type - not a string or symbol" x)] ) ]
    [LAZY_SCHEME_PTR_TYPE
     (if (##sys#immediate? x)
	 (error loc "immediate object can not be passes as pointer" x)
	 x) ]
    [else x] ) )

(define (srfi-4-vector? x)
  (and (not (##sys#immediate? x))
       (##sys#generic-structure? x)
       (memq (##sys#slot x 0) '(u8vector s8vector u16vector s16vector u32vector s32vector f32vector f64vector)) ) )

(define (val-type-code x)
  (cond [(or (boolean? x) (fixnum? x)) LAZY_INT_TYPE]
	[(char? x) LAZY_CHAR_TYPE]
	[(number? x) LAZY_DOUBLE_TYPE]
	[(or (symbol? x) (string? x)) LAZY_STRING_TYPE]
	[(##sys#immediate? x) LAZY_SCHEME_TYPE]
	[(srfi-4-vector? x) LAZY_SCHEME_PTR_TYPE]
	[(or (##core#inline "C_pointerp" x)
	     (##core#inline "C_locativep" x)
	     (##core#inline "C_taggedpointerp" x)
	     (##core#inline "C_swigpointerp" x) )
	 LAZY_PTR_TYPE]
	[else LAZY_SCHEME_PTR_TYPE] ) )

(define-inline (make-flonum)
  (##core#inline_allocate ("C_a_i_flonum" 4) 0)) ;XXX words-per-flonum

(define ((function-wrapper name ptr) . args)
  (let ([rtype LAZY_VOID_TYPE]
	[rtypename #f]
	[safe #f]
	[result #f] )
    (let loop ([args args] [argvals '()] [argtypes '()])
      (if (null? args)
	  (begin
	    (dbg "[call: " name " " (reverse argvals) " " (reverse argtypes) " -> " rtype "]")
	    (let ([c ((if safe call_lazy_safe call_lazy)
		      ptr
		      (reverse argvals)
		      (length argvals)
		      rtype
		      (reverse argtypes)
		      result) ] )
	      (switch c
		[LAZY_OK
		 (switch rtype
		   [LAZY_INT_TYPE (or (##sys#slot result 0) (##sys#slot result 1))]
		   [LAZY_UINT_TYPE (or (##sys#slot result 0) (##sys#slot result 1))]
		   [LAZY_CHAR_TYPE (##sys#slot result 0)]
		   [LAZY_VOID_TYPE (void)]
		   [LAZY_STRING_TYPE
		    (let ([str (##sys#peek-c-string result 0)])
		      (if (eq? rtypename symbol:)
			  (##sys#intern-symbol str)
			  str) ) ]
		   [LAZY_SCHEME_TYPE (##sys#slot result 0)]
		   [LAZY_PTR_TYPE (and (not (##sys#null-pointer? result)) result)]
		   [else result] ) ]
		[LAZY_BAD_ARG (error name "error while calling foreign function - argument has invalid type")]
		[LAZY_BAD_TYPE (error name "error while calling foreign function - invalid type code")]
		[LAZY_BAD_RTYPE (error name "error while calling foreign function - invalid return type code")]
		[else (error name "error while calling foreign function - could not create context")] ) ) )
	  (let ([arg (car args)])
	    (case arg
	      [(safe:)
	       (set! safe (cadr args))
	       (loop (cddr args) argvals argtypes) ]
	      [(return:)
	       (set! rtypename (cadr args))
	       (set! rtype (type-code rtypename name))
	       (set! result
		 (switch rtype
		   [LAZY_INT_TYPE (vector #f (make-flonum))]
		   [LAZY_UINT_TYPE (vector #f (make-flonum))]
		   [LAZY_CHAR_TYPE (vector 0)]
		   [LAZY_DOUBLE_TYPE (make-flonum)]
		   [LAZY_SCHEME_TYPE (vector #f)]
		   [LAZY_PTR_TYPE (##sys#make-pointer)]
		   [LAZY_STRING_TYPE (##sys#make-pointer)]
		   [else #f] ) )
	       (loop (cddr args) argvals argtypes) ]
	      [(int: void: double: pointer: unsigned-int:)
	       (let* ([x (cadr args)]
		      [t (type-code arg name)] )
		 (loop (cddr args)
		       (cons (check-arg x t name) argvals)
		       (cons t argtypes) ) ) ]
	      [(string: symbol:)
	       (let ([x (cadr args)])
		 (loop (cddr args)
		       (cons (check-arg x LAZY_STRING_TYPE name) argvals)
		       (cons LAZY_STRING_TYPE argtypes)) ) ]
	      [(scheme-object:)
	       (loop (cddr args) (cons (cadr args) argvals) (cons LAZY_SCHEME_TYPE argtypes)) ]
	      [(scheme-pointer: byte-vector:)
	       (loop (cddr args)
		     (cons (check-arg (cadr args) LAZY_SCHEME_PTR_TYPE name) argvals)
		     (cons LAZY_SCHEME_PTR_TYPE argtypes) ) ]
	      [else
	       (cond [(string? arg)
		      (loop (cdr args)
			    (cons (##sys#make-c-string arg) argvals)
			    (cons LAZY_STRING_TYPE argtypes)) ]
		     [(symbol? arg)
		      (loop (cdr args)
			    (cons (##sys#make-c-string (##sys#slot arg 1)) argvals)
			    (cons LAZY_STRING_TYPE argtypes)) ]
		     [(srfi-4-vector? arg)
		      (loop (cdr args)
			    (cons (##sys#slot arg 1) argvals)
			    (cons LAZY_SCHEME_PTR_TYPE argtypes) ) ]
		     [else
		      (loop (cdr args)
			    (cons arg argvals)
			    (cons (val-type-code arg) argtypes)) ] ) ] ) ) ) ) ) )

(define (lazy-ffi:function name uid)
  (if (##sys#symbol-has-toplevel-binding? uid)
      (##sys#slot uid 0)
      (let* ([ptr (lookup-symbol name)]
	     [proc (function-wrapper name ptr)] )
	(##sys#setslot uid 0 proc)
	proc) ) )

(define (lazy-ffi:function-ptr ptr)
  (function-wrapper "<pointer>" ptr) )

)