# FFI (based on http://logand.com/mplisp/src/mod/ffi.l)
(def 'ffi:Float '(double float))   # types that are considered floating-point numbers
(de ffi (Name Incs Fns . Prg)   # create an FFI module; each function is exposed as Name:_FnName
   (unless (pair Name) (setq Name (list Name)))
   (let (Path (cadr Name)  Name (car Name)  CFile (pack Path Name ".c"))
      (out CFile   # generate C file
         (prinl "/* Generated for PicoLisp FFI */")
         (prinl "#include \"" (path "@src/pico.h") "\"")
         (for Inc Incs
            (prinl "#include \"" Inc "\"") )
         (prinl)
         (prinl "#define ffi_def_fn(name)  any _##name(any ex) ")   # ex is arguments
         (prinl "#define ffi_def_scl()  float scl = pow(10, unBox(val(Scl)));")   # scl is a scale as 10^(*Scl)
         (prinl "#define ffi_def_vars()  any x = ex, r;")   # x is current argument, r is temp var
         (prinl "#define ffi_next_arg()  x = cdr(x);")
         (prinl "#define ffi_unbox(t, v)  r = EVAL(car(x)); NeedNum(ex, r); t v = (t) unBox(r);")
         (prinl "#define ffi_unbox_ptr(t, v)  t v; r = EVAL(car(x)); if (isNil(r)) {v = NULL;} else {NeedNum(ex, r); v = (t) unDig(r);}")
         (prinl "#define ffi_unbox_str(v)  r = evSym(x); char v[bufSize(r)]; bufString(r, v);")
         #~ (prinl "#define ffi_unbox_float(t, v)  t v = (t) evDouble(ex, x) / scl;")
         (prinl "#define ffi_unbox_float(t, v)  r = EVAL(car(x)); NeedNum(ex, r); t v = (t) unBox(r) / scl;")
         (prinl "#define ffi_unbox_bool(v)  int v = x == Nil ? 0 : 1;")
         (prinl "#define ffi_box(v)  boxCnt(v)")
         (prinl "#define ffi_box_ptr(v)  (v == NULL ? Nil : box((word) v))")
         (prinl "#define ffi_box_str(v)  mkStr(v)")
         #~ (prinl "#define ffi_box_float(v)  doubleToNum((v) * scl)")
         (prinl "#define ffi_box_float(v)  boxCnt(v * scl)")
         (prinl "#define ffi_box_bool(v)  ((v) ? T : Nil)")
         (prinl "#define ffi_box_void()  Nil")
         (prinl)
         (for Fn Fns
            (apply ffi:wrap (cddr Fn) (car Fn) (cadr Fn)))
         (run Prg 1) )   # any printed output is included in the file
      (apply 'call (append   # compile as a dynamic library (see src/Makefile, lib/gcc.l)
         '(gcc -m32 -shared -export-dynamic
            -O -falign-functions -fomit-frame-pointer -fPIC   #! -fPIC is used to prevent "warning: creating a DT_TEXTREL in object"
            -pipe -D_GNU_SOURCE -D_FILE_OFFSET_BITS=64
            -W -Wimplicit -Wreturn-type -Wformat -Wuninitialized -Wstrict-prototypes)   #! no -Wunused because likely in generated file
         (list '-o (pack (path "@lib/") Name) CFile) ))))
(de ffi:wrap (Ret Name . @)   # wrap C function as FFI function callable from Lisp
   (let (Args (rest)  Tab "   ")
      (when (== 'void Ret) (off Ret))
      # define wrapper function (prefixed with '_')
         (prinl "ffi_def_fn(" Name ") {   // " Ret " " Name "(" (glue ", " Args) ")")
         (when (mmeq ffi:Float (append (list Ret) Args))
            (prinl Tab "ffi_def_scl();") )
         (prinl Tab "ffi_def_vars();")
      # unwrap arguments
         (for (I . A) Args
            (prinl Tab "ffi_next_arg(); " (ffi:toC A (pack "r" I))) )
      # call function
         (prin Tab (when Ret (list (if (== 'bool Ret) 'int Ret) " r0 = ")) Name "(")
         (for (I . _) Args
            (when (> I 1) (prin ", "))
            (prin "r" I))
         (prinl ");")
      # return wrapped result
         (prinl "   return " (ffi:fromC Ret "r0") "; }^J") ))
(de ffi:toC (Type V)   # unwrap Lisp value to be C value
   (cond
      ((== 'bool Type) (pack "ffi_unbox_bool(" V ");"))
      ((memq Type ffi:Float) (pack "ffi_unbox_float(" Type ", " V ");"))
      ((== 'char* Type) (pack "ffi_unbox_str(" V ");"))
      ((= "*" (last (chop Type))) (pack "ffi_unbox_ptr(" Type ", " V ")"))
      (T (pack "ffi_unbox(" Type ", " V ");")) ))
(de ffi:fromC (Type V)   # wrap C value to be Lisp value
   (cond
      ((not Type) "ffi_box_void()")
      ((== 'null Type) "ffi_box_null()")
      ((== 'bool Type) (pack "ffi_box_bool(" V ")"))
      ((memq Type ffi:Float) (pack "ffi_box_float(" V ")"))
      ((== 'char* Type) (pack "ffi_box_str(" V ")"))
      ((= "*" (last (chop Type))) (pack "ffi_box_ptr(" V ")"))
      (T (pack "ffi_box(" V ")")) ))

# test
(let (*Scl 4)
   (ffi '("c" "/tmp/") '("fnmatch.h") '(
      (bool isalpha int)
      (double ceil double)
      (float floorf float)
      (double pow double double)
      (size_t strlen char*)
      (char* strncat char* char* size_t)
      (void* malloc size_t)
      (void free void*)
      (time_t time time_t*)
      (struct\ tm* localtime time_t*)
      (char* asctime struct\ tm*)
      (int fnmatch char* char* int) )

      (prinl "
         void* checkPtr(void* p) {
            puts(p == NULL ? \"NULL\" : \"NOT NULL\");
            return p; }
         ffi_def_fn(checkPtr) {
            ffi_def_vars();
            ffi_next_arg(); ffi_unbox_ptr(void*, r1);
            void* r0 = checkPtr(r1);
            return ffi_box_ptr(r0); }
         " ))
   (test T (c:_isalpha (char "A")))
   (test NIL (c:_isalpha (char "1")))
   (test (any "2.0") (c:_ceil (any "1.23")))
   (test (any "1.0") (c:_floorf (any "1.23")))
   (test (any "1.4142") (c:_pow (any "2.0") (any "0.5")))
   (test 5 (c:_strlen "abcde"))
   (test "abcde" (c:_strncat "abc" "def" 2))
   (let (Ptr (c:_malloc 128))
      (finally (c:_free Ptr)
         (test Ptr (c:_checkPtr Ptr))
         (test NIL (c:_checkPtr NIL))
         (c:_time Ptr)
         (prin (c:_asctime (c:_localtime Ptr))) ))
   (test 0 (c:_fnmatch "a*.c" "abc.c" 0)) )