; vim: ft=scheme

(c-system-include "stdint.h")
(c-system-include "dlfcn.h")
(c-system-include "stdio.h")
(c-system-include "ffi.h")
(c-link "ffi")

;; make-c-null
(c-declare "void* make_c_null() { return NULL; }")
(define-c (maybe-null pointer void*) make-c-null ())

;; c-type-size
(c-declare "
    int size_of_int8_t() { return sizeof(int8_t); }
    int size_of_uint8_t() { return sizeof(uint8_t); }
    int size_of_int16_t() { return sizeof(int16_t); }
    int size_of_uint16_t() { return sizeof(uint16_t); }
    int size_of_int32_t() { return sizeof(int32_t); }
    int size_of_uint32_t() { return sizeof(uint32_t); }
    int size_of_int64_t() { return sizeof(int64_t); }
    int size_of_uint64_t() { return sizeof(uint64_t); }
    int size_of_char() { return sizeof(char); }
    int size_of_unsigned_char() { return sizeof(unsigned char); }
    int size_of_short() { return sizeof(short); }
    int size_of_unsigned_short() { return sizeof(unsigned short); }
    int size_of_int() { return sizeof(int); }
    int size_of_unsigned_int() { return sizeof(unsigned int); }
    int size_of_long() { return sizeof(long); }
    int size_of_unsigned_long() { return sizeof(unsigned long); }
    int size_of_float() { return sizeof(float); }
    int size_of_double() { return sizeof(double); }
    int size_of_pointer() { return sizeof(void*); }
")

(define-c int (size-of-int8_t size_of_int8_t) ())
(define-c int (size-of-uint8_t size_of_uint8_t) ())
(define-c int (size-of-int16_t size_of_int16_t) ())
(define-c int (size-of-uint16_t size_of_uint16_t) ())
(define-c int (size-of-int32_t size_of_int32_t) ())
(define-c int (size-of-uint32_t size_of_uint32_t) ())
(define-c int (size-of-int64_t size_of_int64_t) ())
(define-c int (size-of-uint64_t size_of_uint64_t) ())
(define-c int (size-of-char size_of_char) ())
(define-c int (size-of-unsigned-char size_of_unsigned_char) ())
(define-c int (size-of-short size_of_short) ())
(define-c int (size-of-unsigned-short size_of_unsigned_short) ())
(define-c int (size-of-int size_of_int) ())
(define-c int (size-of-unsigned-int size_of_unsigned_int) ())
(define-c int (size-of-long size_of_long) ())
(define-c int (size-of-unsigned-long size_of_unsigned_long) ())
(define-c int (size-of-float size_of_float) ())
(define-c int (size-of-double size_of_double) ())
(define-c int (size-of-pointer size_of_pointer) ())

;; shared-object-load
(define-c-const int (RTLD-NOW "RTLD_NOW"))
(define-c (maybe-null pointer void*) dlopen (string int))
(define-c (maybe-null pointer void*) dlerror ())

(c-declare "sexp is_pointer(struct sexp_struct* object) { if(sexp_cpointerp(object)) { return SEXP_TRUE; } else { return SEXP_FALSE; } }")
(define-c sexp (pointer? is_pointer) (sexp))

(c-declare "void c_bytevector_u8_set(void* pointer, int offset, uint8_t value) { *(uint8_t*)((char*)pointer + offset) = value; }")
(define-c void (c-bytevector-u8-set! c_bytevector_u8_set) ((maybe-null pointer void*) int uint8_t))

(c-declare "int8_t c_bytevector_u8_ref (void* pointer, int offset) { return *(int8_t*)((char*)pointer + offset); }")
(define-c int8_t (c-bytevector-u8-ref c_bytevector_u8_ref) ((maybe-null pointer void*) int))

(c-declare "void c_bytevector_pointer_set (void* pointer, int offset, void* value) { char* p = (char*)pointer + offset; *(char**)p = value; }")
(define-c void (c-bytevector-pointer-set! c_bytevector_pointer_set) ((pointer void*) int (maybe-null pointer void*)))

(c-declare "void* c_bytevector_pointer_ref (void* pointer, int offset) { char* p = (char*)pointer + offset; return *(char**)p; }")
(define-c (maybe-null pointer void*) (c-bytevector-pointer-ref c_bytevector_pointer_ref) ((maybe-null pointer void*) int))

(c-declare "ffi_cif cif;")
(define-c (maybe-null pointer void*) dlsym ((maybe-null pointer void*) string))

(define-c-const int (FFI-OK "FFI_OK"))
(c-declare
  "void* internal_ffi_call(
      unsigned int nargs,
      unsigned int rtype,
      unsigned int atypes[],
      void* fn,
      unsigned int rvalue_size,
      struct sexp_struct* avalues[])
    {
    ffi_type* c_atypes[nargs];
    void* c_avalues[nargs];

    int8_t vals1[nargs];
    uint8_t vals2[nargs];
    int16_t vals3[nargs];
    uint16_t vals4[nargs];
    int32_t vals5[nargs];
    uint32_t vals6[nargs];
    int64_t vals7[nargs];
    uint64_t vals8[nargs];
    char vals9[nargs];
    unsigned char vals10[nargs];
    short vals11[nargs];
    unsigned short vals12[nargs];
    int vals13[nargs];
    unsigned int vals14[nargs];
    long vals15[nargs];
    unsigned long vals16[nargs];
    float vals17[nargs];
    double vals18[nargs];
    void* vals20[nargs];

    printf(\"nargs: %i\\n\", nargs);
    for(int i = 0; i < nargs; i++) {
      printf(\"i: %i\\n\", i);
      void* arg = NULL;
      switch(atypes[i]) {
        case 1:
          c_atypes[i] = &ffi_type_sint8;
          vals1[i] = (int8_t)sexp_sint_value(avalues[i]);
          c_avalues[i] = &vals1[i];
        break;
        case 2:
          c_atypes[i] = &ffi_type_uint8;
          vals2[i] = (uint8_t)sexp_uint_value(avalues[i]);
          c_avalues[i] = &vals2[i];
        break;
        case 3:
          c_atypes[i] = &ffi_type_sint16;
          vals3[i] = (int16_t)sexp_sint_value(avalues[i]);
          c_avalues[i] = &vals3[i];
        break;
        case 4:
          c_atypes[i] = &ffi_type_uint16;
          vals4[i] = (uint16_t)sexp_uint_value(avalues[i]);
          c_avalues[i] = &vals4[i];
        break;
        case 5:
          c_atypes[i] = &ffi_type_sint32;
          vals5[i] = (int32_t)sexp_sint_value(avalues[i]);
          c_avalues[i] = &vals5[i];
        break;
        case 6:
          c_atypes[i] = &ffi_type_uint32;
          vals6[i] = (int64_t)sexp_uint_value(avalues[i]);
          c_avalues[i] = &vals6[i];
        break;
        case 7:
          c_atypes[i] = &ffi_type_sint64;
          vals7[i] = (int64_t) sexp_sint_value(avalues[i]);
          c_avalues[i] = &vals7[i];
        break;
        case 8:
          c_atypes[i] = &ffi_type_uint64;
          vals8[i] = (uint64_t)sexp_uint_value(avalues[i]);
          c_avalues[i] = &vals8[i];
        break;
        case 9:
          c_atypes[i] = &ffi_type_schar;
          vals9[i] = (char)sexp_sint_value(avalues[i]);
          c_avalues[i] = &vals9[i];
        break;
        case 10:
          c_atypes[i] = &ffi_type_uchar;
          vals10[i] = (unsigned char)sexp_uint_value(avalues[i]);
        break;
        case 11:
          c_atypes[i] = &ffi_type_sshort;
          vals11[i] = (short)sexp_sint_value(avalues[i]);
        break;
        case 12:
          c_atypes[i] = &ffi_type_ushort;
          vals12[i] = (unsigned short)sexp_uint_value(avalues[i]);
        break;
        case 13:
          c_atypes[i] = &ffi_type_sint;
          vals13[i] = (int)sexp_sint_value(avalues[i]);
          c_avalues[i] = &vals13[i];
        break;
        case 14:
          c_atypes[i] = &ffi_type_uint;
          vals14[i] = (unsigned int)sexp_uint_value(avalues[i]);
          c_avalues[i] = &vals14[i];
        break;
        case 15:
          c_atypes[i] = &ffi_type_slong;
          vals15[i] = (long)sexp_sint_value(avalues[i]);
          c_avalues[i] = &vals15[i];
        break;
        case 16:
          c_atypes[i] = &ffi_type_ulong;
          vals16[i] = (unsigned long)sexp_uint_value(avalues[i]);
          c_avalues[i] = &vals16[i];
        break;
        case 17:
          c_atypes[i] = &ffi_type_float;
          vals17[i] = (float)sexp_flonum_value(avalues[i]);
          c_avalues[i] = &vals17[i];
        break;
        case 18:
          c_atypes[i] = &ffi_type_double;
          vals18[i] = (double)sexp_flonum_value(avalues[i]);
          c_avalues[i] = &vals18[i];
        break;
        case 19:
          c_atypes[i] = &ffi_type_void;
          arg = NULL;
          c_avalues[i] = NULL;
        break;
        case 20:
          c_atypes[i] = &ffi_type_pointer;
          if(sexp_cpointerp(avalues[i])) {
            vals20[i] = sexp_cpointer_value(avalues[i]);
          } else {
            vals20[i] = NULL;
          }
          c_avalues[i] = &vals20[i];
        break;
        default:
          printf(\"Undefined argument type integer: %i, index: %i\\n\", atypes[i], i);
          //c_avalues[i] = sexp_cpointer_value(avalues[i]);
        break;
      }
    }

    ffi_type* c_rtype = &ffi_type_void;
    switch(rtype) {
      case 1: c_rtype = &ffi_type_sint8; break;
      case 2: c_rtype = &ffi_type_uint8; break;
      case 3: c_rtype = &ffi_type_sint16; break;
      case 4: c_rtype = &ffi_type_uint16; break;
      case 5: c_rtype = &ffi_type_sint32; break;
      case 6: c_rtype = &ffi_type_uint32; break;
      case 7: c_rtype = &ffi_type_sint64; break;
      case 8: c_rtype = &ffi_type_uint64; break;
      case 9: c_rtype = &ffi_type_schar; break;
      case 10: c_rtype = &ffi_type_uchar; break;
      case 11: c_rtype = &ffi_type_sshort; break;
      case 12: c_rtype = &ffi_type_ushort; break;
      case 13: c_rtype = &ffi_type_sint; break;
      case 14: c_rtype = &ffi_type_uint; break;
      case 15: c_rtype = &ffi_type_slong; break;
      case 16: c_rtype = &ffi_type_ulong; break;
      case 17: c_rtype = &ffi_type_float; break;
      case 18: c_rtype = &ffi_type_double; break;
      case 19: c_rtype = &ffi_type_void; break;
      case 20: c_rtype = &ffi_type_pointer; break;
      default:
        printf(\"Undefined return type: %i\\n\", rtype);
        c_rtype = &ffi_type_pointer;
      break;
    }

    int r = ffi_prep_cif(&cif, FFI_DEFAULT_ABI, nargs, c_rtype, c_atypes);

    void* rvalue = malloc(rvalue_size);
    ffi_call(&cif, FFI_FN(fn), rvalue, c_avalues);
    return rvalue;
  }")
(define-c (maybe-null pointer void*)
          (internal-ffi-call internal_ffi_call)
          (unsigned-int
            unsigned-int
            (array unsigned-int)
            (maybe-null pointer void*)
            unsigned-int
            (array sexp)))

(c-declare
  "void* scheme_procedure_to_pointer(sexp proc) {
    if(sexp_procedurep(proc) == 1) {
      return 0;  //&sexp_unbox_fixnum(proc);
    } else {
      printf(\"NOT A FUNCTION\\n\");
    }
    return (void*)proc;
  }")
(define-c void* (scheme-procedure-to-pointer scheme_procedure_to_pointer) (sexp))