swicffi - Use C/C++ Runtimes from SWI-Prolog using only headers

    7:- module(swicffi,[install_cffi/2,cffi_tests/0,to_forms/2,cffi_eval/1,cffi_test/1]).    8:- reexport(swicli). 
    9
   10
   11:- style_check(-singleton).   12:- style_check(-discontiguous).   13:- set_prolog_flag(double_quotes, codes). 
   14
   15/*
   16% TODO
   17
   18
   19defctype(PrologName,CType,Comment)  http://common-lisp.net/project/cffi/manual/html_node/defctype.html
   20
   21
   226.1 Built-In Types
   23
   24— Foreign Type: :char
   25— Foreign Type: :unsigned-char
   26— Foreign Type: :short
   27— Foreign Type: :unsigned-short
   28— Foreign Type: :int
   29— Foreign Type: :unsigned-int
   30— Foreign Type: :long
   31— Foreign Type: :unsigned-long
   32— Foreign Type: :long-long
   33— Foreign Type: :unsigned-long-long
   34These types correspond to the native C integer types according to the ABI of the Lisp implementation's host system.
   35
   36:long-long and :unsigned-long-long are not supported natively on all implementations. However, they are emulated by mem-ref and mem-set.
   37
   38When those types are not available, the symbol cffi-sys::no-long-long is pushed into *features*.
   39
   40— Foreign Type: :uchar
   41— Foreign Type: :ushort
   42— Foreign Type: :uint
   43— Foreign Type: :ulong
   44— Foreign Type: :llong
   45— Foreign Type: :ullong
   46For convenience, the above types are provided as shortcuts for unsigned-char, unsigned-short, unsigned-int, unsigned-long, long-long and unsigned-long-long, respectively.
   47
   48— Foreign Type: :int8
   49— Foreign Type: :uint8
   50— Foreign Type: :int16
   51— Foreign Type: :uint16
   52— Foreign Type: :int32
   53— Foreign Type: :uint32
   54— Foreign Type: :int64
   55— Foreign Type: :uint64
   56Foreign integer types of specific sizes, corresponding to the C types defined in stdint.h.
   57
   58— Foreign Type: :float
   59— Foreign Type: :double
   60On all systems, the :float and :double types represent a C float and double, respectively. On most but not all systems, :float and :double represent a Lisp single-float and double-float, respectively. It is not so useful to consider the relationship between Lisp types and C types as isomorphic, as simply to recognize the relationship, and relative precision, among each respective category.
   61
   62— Foreign Type: :long-double
   63This type is only supported on SCL.
   64
   65— Foreign Type: :pointer &optional type
   66A foreign pointer to an object of any type, corresponding to void *. You can optionally specify type of pointer (e.g. (:pointer :char)). Although CFFI won't do anything with that information yet, it is useful for documentation purposes.
   67
   68— Foreign Type: :void
   69No type at all. Only valid as the return type of a function.
   70
   71
   72
   73struct person { int number; char* reason; };
   74
   75  The equivalent defcstruct form follows:
   76
   77(defcstruct person (number :int) (reason :string))
   78
   79
   80Dictionary
   81
   82convert-from-foreign
   83convert-to-foreign
   84defbitfield
   85defcstruct
   86defcunion
   87defctype
   88defcenum
   89define-foreign-type
   90define-parse-method
   91foreign-bitfield-symbols
   92foreign-bitfield-value
   93foreign-enum-keyword
   94foreign-enum-value
   95foreign-slot-names
   96foreign-slot-offset
   97foreign-slot-pointer
   98foreign-slot-value
   99foreign-type-alignment
  100foreign-type-size
  101free-converted-object
  102free-translated-object
  103translate-from-foreign
  104translate-to-foreign
  105translate-into-foreign-memory
  106with-foreign-slots
  107
  108*/
  109install_cffi(_Module,File):-read_file_to_codes(File,Codes,[]),to_forms(Codes,Forms),cffi_eval(Forms).
  110
  111:- meta_predicate debug_call(0).  112
  113char_atom(S):-atom(S),atom_length(S,1).
  114
  115to_forms(Atom, Expr):- atom(Atom),!,atom_codes(Atom,String),!,cto_forms(String, Expr).
  116to_forms(String, Expr):- string(String),string_codes(String,Codes),!,cto_forms(Codes, Expr).
  117to_forms([S|Source],Expr):-char_atom(S),atom_chars(Atom,[S|Source]),!,to_forms(Atom,Expr).
  118to_forms([S|Source],Expr):-integer(S),cto_forms([S|Source],Expr).
  119to_forms(O,O).
  120
  121cto_forms(Source,Expr):-white(Source,Start), sexprs(Expr,Start,[]),!.
  122
  123cffi_test(Code):-to_forms(Code,Forms),cffi_eval(Forms).
  124echo_forms(Code):-to_forms(Code,Forms),portray(echo_forms:-Forms).
  125
  126cffi_eval(Forms):-is_list(Forms),last(Forms,LL),is_list(LL),!,forall(member(F,Forms),cffi_eval1(F)).
  127cffi_eval(Forms):-is_list(Forms),to_forms(Forms,Next), Forms \=@= Next, !, cffi_eval(Next).
  128cffi_eval(Forms):-to_forms(Forms,Next), Forms \=@= Next, !, cffi_eval(Next).
  129cffi_eval(F):-cffi_eval1(F).
  130
  131/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  132   Parsing (Using LISPy CFFI File format)
  133   Dont be confused when you are seeing S-Expressions in this library
  134   I am merely using Trisk;s S-Expresssion parser (from lisprolog.pl with no incentives yet to strip out unused parts)
  135   Why? There has been 20+ years developing the Lisp FFI design and tests to be leveraged and no incentive (see as it as a 
  136   distraction at least to msyelf) to copy the entire technology from S to P (prolog terms) syntax.
  137   Ammusingly the SWI-Prolog interface     is available in S format and not  P 
  138   https://github.com/logicmoo/swicli/blob/master/cffi-tests/swi-prolog.cffi
  139   So for those who think it needs to become P .. Please go ahead and get the processes started, I wil continue to
  140   develop the technology to enable either.
  141- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  142
  143
  144eoln(10).
  145
  146blank --> [C], {C =< 32}, white.
  147blank --> ";", comment, white.
  148
  149white --> blank.
  150white --> [].
  151
  152comment --> [C], {eoln(C)}, !.
  153comment --> [C], comment.
  154
  155sexprs([H|T]) --> sexpr(H), !, sexprs(T).
  156sexprs([]) --> [].
  157
  158sexpr(L)                      --> "(", !, white, sexpr_list(L), white.
  159sexpr(vec(V))                 --> "#(", !, sexpr_vector(V), white.
  160sexpr(boo(t))                 --> "#t", !, white.
  161sexpr(boo(f))                 --> "#f", !, white.
  162sexpr(chr(N))                 --> "#\\", [C], !, {N is C}, white.
  163sexpr(str(S))                 --> """", !, sexpr_string(S), white.
  164sexpr([quote,E])              --> "'", !, white, sexpr(E).
  165sexpr([quasiquote,E])         --> "`", !, white, sexpr(E).
  166sexpr(['unquote-splicing',E]) --> ",@", !, white, sexpr(E).
  167sexpr([unquote,E])            --> ",", !, white, sexpr(E).
  168sexpr(E)                      --> sym_or_num(E), white.
  169
  170sexpr_list([]) --> ")", !.
  171sexpr_list(_) --> ".", [C], {\+ sym_char(C), !, fail}.
  172sexpr_list([Car|Cdr]) --> sexpr(Car), !, sexpr_rest(Cdr).
  173
  174sexpr_rest([]) --> ")", !.
  175sexpr_rest(E) --> ".", [C], {\+ sym_char(C)}, !, sexpr(E,C), !, ")".
  176sexpr_rest([Car|Cdr]) --> sexpr(Car), !, sexpr_rest(Cdr).
  177
  178sexpr_vector([]) --> ")", !.
  179sexpr_vector([First|Rest]) --> sexpr(First), !, sexpr_vector(Rest).
  180
  181sexpr_string(Str) --> sexpr_ascii(Codes),{string_codes(Str,Codes)}.
  182
  183sexpr_ascii([]) --> """", !.
  184sexpr_ascii([C|S]) --> chr(C), sexpr_ascii(S).
  185
  186chr(92) --> "\\\\", !.
  187chr(34) --> "\\\"", !.
  188chr(N)  --> [C], {C >= 32, N is C}.
  189
  190sym_or_num(E) --> [C], {sym_char(C)}, sym_string(S), {string_to_atom([C|S],E)}.
  191
  192sym_string([H|T]) --> [H], {sym_char(H)}, sym_string(T).
  193sym_string([]) --> [].
  194
  195number(N) --> unsigned_number(N).
  196number(N) --> "-", unsigned_number(M), {N is -M}.
  197number(N) --> "+", unsigned_number(N).
  198
  199unsigned_number(N) --> digit(X), unsigned_number(X,N).
  200unsigned_number(N,M) --> digit(X), {Y is N*10+X}, unsigned_number(Y,M).
  201unsigned_number(N,N) --> [].
  202
  203digit(N) --> [C], {C >= 48, C =<57, N is C-48}.
  204
  205% . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
  206
  207sexpr(E,C,X,Z) :- white([C|X],Y), sexpr(E,Y,Z).
  208
  209sym_char(C) :- C > 32, \+ member(C,";()#""',`").
  210
  211string_to_atom(S,N) :- number(N,S,[]), !.
  212string_to_atom(S,O) :- lowcase(S,L), name(I,L),trim_left(I,'cffi:',O).
  213
  214trim_left(All,Left,Right):-atom_concat(Left,Right,All)->true;All=Right.
  215
  216lowcase(C,C).
  217lowcase([],[]).
  218lowcase([C1|T1],[C2|T2]) :- lowercase(C1,C2), lowcase(T1,T2).
  219
  220lowercase(C1,C2) :- C1 >= 65, C1 =< 90, !, C2 is C1+32.
  221lowercase(C,C).
  222
  223
  224reader_tests:- cffi_test("()").
  225% Append:
  226reader_tests:- 
  227   echo_forms("
  228      (  (defun append (x y)
  229          (if x
  230              (cons (car x) (append (cdr x) y))
  231            y))
  232
  233        (append '(a b) '(3 4 5))
  234
  235        (defun fib (n)
  236          (if (= 0 n) 0
  237            (if (= 1 n)
  238                1
  239              (+ (fib (- n 1)) (fib (- n 2))))))
  240        (fib 24)
  241
  242        (defun fib (n) (if (= 0 n) 0 (fib1 0 1 1 n)))
  243
  244        (defun fib1 (f1 f2 i to) (if (= i to) f2 (fib1 f2 (+ f1 f2) (+ i 1) to)))
  245        (fib 250)
  246  ( (defun fib (n)
  247          (setq f (cons 0 1))
  248          (setq i 0)
  249          (while (< i n)
  250            (setq f (cons (cdr f) (+ (car f) (cdr f))))
  251            (setq i (+ i 1)))
  252          (car f))
  253
  254        (fib 350)
  255
  256        (defun map (f xs)
  257          (if xs
  258              (cons (eval (list f (car xs))) (map f (cdr xs)))
  259            ())))
  260 ;;
  261        (defun plus1 (x) (+ 1 x))
  262
  263        (map 'plus1 '(1 2 3)))
  264      "
  265      ).
  266/*
  267// int printf( const char *format [, argument]... )
  268
  269[DllImport("msvcrt.dll", CharSet=CharSet.Ansi, CallingConvention=CallingConvention.Cdecl)]
  270public static extern int printf(String format, int i, double d); 
  271
  272[DllImport("msvcrt.dll", CharSet=CharSet.Ansi, CallingConvention=CallingConvention.Cdecl)]
  273public static extern int printf(String format, int i, String s); 
  274}
  275*/
  276
  277:-set_prolog_flag(double_quotes, string). 
  278
  279
  280debug_call(Call):- catch((Call,debug(swicffi,'SUCCEED: ~q.~n',[Call])),E,(debug(swicffi), debug(swicffi,'ERROR: ~q.~n',[E=Call]),throw(E))) *-> true; debug(swicffi,'FAILED: ~q.~n',[Call]) .
  281:-debug(swicffi).  282
  283cffi_eval1(F):-debug_call(cffi_eval2(F)).
  284
  285cffi_eval2([F,Unmanaged0|Fields]):-once(cffi_to_keyword(Unmanaged0,Unmanaged)),Unmanaged0 \=@= Unmanaged,cffi_eval2([F,Unmanaged|Fields]).
  286cffi_eval2([defcstruct,Unmanaged0|Fields]):-cffi_to_keyword(Unmanaged0,Unmanaged),cffi_to_args(Fields,ParamTypes),!,
  287   cli_compile_cstruct(Unmanaged,ParamTypes,ResultCode).
  288cffi_eval2([defcfun,[Unmanaged0,Managed0]|ReturnTypeArgs]):-maplist(cffi_to_keyword,[Unmanaged0,Managed0],[Unmanaged,Managed]), cffi_to_args(ReturnTypeArgs,[ReturnType|ParamTypes]),!,
  289   cli_compile_cfun(Unmanaged,Managed,ReturnType,ParamTypes,ResultCode).
  290cffi_eval2(F):-is_list(F),C=..F,cffi_eval3(C).
  291cffi_eval2(F):-cffi_eval3(F).
  292
  293cffi_eval3(F):-predicate_property(F,visible),format(':-~q. ~n',[F]),!,debug_call(F),cffi_db_assert(F),!.
  294cffi_eval3(F):-cffi_eval4(F),!.
  295
  296cffi_eval4(F):-predicate_property(F,visible),format(':-~q. ~n',[F]),cffi_db_assert(F).
  297cffi_eval4(F):-format('delay:- ~q.~n',[F]),cffi_db_assert(F).
  298
  299cffi_db_assert(C):-C=..[F|ARGS],functor(C,F,A),atom_concat('cdb_',F,DBF),asserta_new(cdb_definer(DBF,A,F)),DB=..[DBF|ARGS],asserta_new(DB).
  300
  301asserta_new(DB):-functor(DB,F,A),dynamic(F/A),ignore(retract(DB)),asserta(DB).
  302
  303
  304:-dynamic(cdb_defctype/2).  305
  306cffi_to_args(List,Out):-maplist(cffi_to_param,List,Out).
  307
  308
  309cffi_to_keyword(str(S),A):-atom_string(A,S),!.
  310cffi_to_keyword(A,A).
  311
  312cffi_to_param([N0,T],p(O,N)):-cffi_to_keyword(N0,N),cffi_to_param(T,O),!.
  313cffi_to_param(str(S),O):-atom_string(A,S),!,cffi_to_param(A,O),!.
  314cffi_to_param(T,T):-cdb_defctype(T,':pointer'),!.
  315cffi_to_param(T,T):-cdb_defctype(_,T),!.
  316cffi_to_param(T,O):-cdb_defctype(T,B),!,cffi_to_param(B,O),!.
  317cffi_to_param(T,O):-cffi_to_keyword(T,O),!.
  318
  319
  320cli_compile_cfun(Unmanaged,Managed,ReturnType,ParamTypes,ResultCode):-cdb_cli_get_dll(DLL,_),cffi_eval4(cfun(DLL,Unmanaged,Managed,ReturnType,ParamTypes)).
  321cli_compile_cstruct(Unmanaged,ParamTypes,ResultCode):-cffi_eval4(cli_compile_cstruct(Unmanaged,ParamTypes,ResultCode)).
  322'load-foreign-library'(Str):-cffi_eval4(cli_get_dll(Str,R)).
  323defctype(Managed,Unmanaged):-asserta(cdb_defctype(Managed,Unmanaged)).
  324
  325
  326display_class(O):- forall((cli_memb(O,PP),\+ contains_var(static(true),PP),cli_cast(PP,'System.Reflection.MemberInfo',MI),
  327  cli_get(MI,['DeclaringType','Namespace'],DT)   % DT\="System", DT\="System.Reflection",
  328  ),writeln(cli_memb(O,PP))).
  329
  330cffi_tests :- forall(cffi_test,true).
  331
  332cffi_test :- cli_compile_enum(int,'MyEnum',['Low'(0),'High'(100)],[],O),display_class(O).
  333cffi_test :- cli_compile_type_raw([],[],"MyType",[f('Low',int(0),[],[]),f('High',int(100),['Static'],[])],['FlagsAttribute'],O),display_class(O).
  334cffi_test_disabled :- cli_compile_type([int],[],"MyType",[f('Low'(0)),f('High'(100))],['FlagsAttribute'],_).
  335
  336cffi_test_disabled :- cli_compile_type(class([f(intValue,int(3))],foo,[]),NewClass),cli_new(NewClass,[],Instance),cli_get(Instance,intValue,Out).  %  it will return Out = 3.
  337
  338cffi_test:-cffi_test('
  339
  340  (defcunion uint32-bytes
  341    (int-value :unsigned-int)
  342    (bytes :unsigned-char :count 4))
  343
  344(defcenum my-boolean
  345    :no
  346    :yes)
  347
  348 (ql:quickload :cffi)
  349
  350(defcstruct person (number :int) (reason :string))
  351
  352(cffi:load-foreign-library "user32.dll")
  353 
  354(cffi:defctype hwnd :unsigned-int)
  355 
  356(cffi:defcfun ("MessageBoxA" message-box) :int
  357  (wnd     hwnd)
  358  (text    :string)
  359  (caption :string)
  360  (type    :unsigned-int))
  361
  362(message-box 0 "hello" "world" 0)  
  363
  364   (define-foreign-type my-string-type ()
  365    ((encoding :reader string-type-encoding :initarg :encoding))
  366    (:actual-type :pointer))
  367
  368 (foreign-funcall "getenv" :string "SHELL" :string)
  369
  370 (with-foreign-string (str "abcdef")
  371          (foreign-funcall "strlen" :string str :int))
  372').
  373
  374
  375% cffi_test :- forall(reader_tests,true).
  376% works!
  377cffi_test :- \+ cli_is_windows, cli_get_dll('libc.so.6',DLL),cli_call(DLL,printf,["Linux I have been clicked %d times", 2],O).
  378cffi_test :- cli_is_windows, cli_get_dll('msvcrt',DLL), cli_cast(0,int,Zero), cli_call(DLL,printf,["Win32 I have been clicked %d times", 2],Zero).
  379% cffi_test :- cli_is_windows, cli_get_dll('msvcrt',DLL), cli_cast(0,int,Zero), cli_call(DLL,mspec(printf(':string',':int'),int),["Win32 I have been clicked %d times", 2],Zero).
  380
  381% cffi_test :- install_cffi('snake-tail',pack('swicli/cffi-tests/swi-prolog.cffi')),module(swicffi),prolog.
  382% cffi_test:- cli_compile_enum(int,'MyEnum',['Low'(0),'High'(100)],[],O),cli_memb(O,M),writeq(M),nl,fail.
  383% cffi_test:- cli_memb(string,M),cli_compile_member(M,_Out),fail.
  384% cffi_test:- cli_memb(int,M),cli_compile_member(M,_Out),fail.
  385
  386% cffi_test:- cli_compile_enum(int,'MyEnum',['Low'(0),'High'(100)],[],O),display_class(O).
  387
  388
  389:-dynamic(cdb_definer/3).  390% cffi_test:-listing(cdb_definer/3).