1/*  Part of Assertion Reader for SWI-Prolog
    2
    3    Author:        Edison Mera
    4    E-mail:        efmera@gmail.com
    5    WWW:           https://github.com/edisonm/assertions
    6    Copyright (C): 2017, Process Design Center, Breda, The Netherlands.
    7    All rights reserved.
    8
    9    Redistribution and use in source and binary forms, with or without
   10    modification, are permitted provided that the following conditions
   11    are met:
   12
   13    1. Redistributions of source code must retain the above copyright
   14       notice, this list of conditions and the following disclaimer.
   15
   16    2. Redistributions in binary form must reproduce the above copyright
   17       notice, this list of conditions and the following disclaimer in
   18       the documentation and/or other materials provided with the
   19       distribution.
   20
   21    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   22    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   23    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
   24    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
   25    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
   26    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
   27    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
   28    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   29    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
   30    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
   31    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
   32    POSSIBILITY OF SUCH DAMAGE.
   33*/
   34
   35:- module(foreign_props,
   36          [foreign/1,
   37           foreign/2,
   38           foreign_spec/1,
   39           (native)/1,
   40           (native)/2,
   41           normalize_ftype/2,
   42           normalize_ftgen/2,
   43           fimport/1,
   44           fimport/2,
   45           nimport/1,
   46           nimport/2,
   47           int64/1,
   48           lang/1,
   49           long/1,
   50           returns/2,
   51           parent/2,
   52           returns_state/1,
   53           memory_root/1,
   54           ptr/1,
   55           ptr/2,
   56           array/3,
   57           setof/2,
   58           float_t/1,
   59           size_t/1,
   60           tgen/1,
   61           tgen/2,
   62           dict_t/2,
   63           dict_t/3,
   64           dict_join_t/4,
   65           dict_extend_t/4,
   66           join_dict_types/6,
   67           join_type_desc/4]).   68
   69:- use_module(library(apply)).   70:- use_module(library(assertions)).   71:- use_module(library(metaprops)).   72:- use_module(library(plprops)).   73:- use_module(library(extend_args)).   74:- use_module(library(mapargs)).   75:- use_module(library(neck)).   76
   77:- init_expansors.   78
   79:- type foreign_spec/1.
   80
   81foreign_spec(name(  Name  )) :- atm(Name).
   82foreign_spec(prefix(Prefix)) :- atm(Prefix).
   83foreign_spec(suffix(Suffix)) :- atm(Suffix).
   84foreign_spec(lang(Lang)) :- lang(Lang).
   85
   86:- type lang/1.
   87lang(prolog).
   88lang(native).
   89
   90normalize_ftype(native( O, G), native( O, G)).
   91normalize_ftype(foreign(O, G), foreign(O, G)).
   92normalize_ftype(fimport(O, G), foreign([lang(prolog), O], G)).
   93normalize_ftype(native(    G), native( [prefix(pl_)], G)).
   94normalize_ftype(foreign(   G), foreign([prefix('')], G)).
   95normalize_ftype(fimport(   G), foreign([lang(prolog), prefix('')], G)).
   96normalize_ftype(nimport(O, G), foreign([lang(native), O], G)).
   97normalize_ftype(nimport(   G), foreign([lang(native), prefix('')], G)).
   98
   99:- type ftype_spec/1.
  100
  101ftype_spec(decl). % Generate the equivalent struct/enum declaration for the given type
  102ftype_spec(gett). % Generate the getter of the given type
  103ftype_spec(unif). % Generate the unifier of the given type
  104
  105normalize_ftgen(tgen(   G), tgen([decl, gett, unif], G)).
  106normalize_ftgen(tgen(O, G), tgen(O, G)).
  107
  108%!  native(+ForeignSpec, :Predicate)
  109%
  110%   Predicate is implemented in C as specified by ForeignSpec.
  111
  112%!  native(:Predicate)
  113%
  114%   Predicate is implemented in C with a pl_ prefix.
  115
  116%!  tgen(:FTypeSpec, :Predicate)
  117%
  118%   Type is implemented in C as specified by FTypeSpec.
  119
  120:- global native( nlist(foreign_spec), callable).
  121:- global foreign(nlist(foreign_spec), callable).
  122:- global fimport(nlist(foreign_spec), callable).
  123:- global nimport(nlist(foreign_spec), callable).
  124:- global native( callable).
  125:- global foreign(callable).
  126:- global fimport(callable).
  127:- global nimport(callable).
  128:- global tgen(callable).
  129:- global tgen(nlist(ftype_spec), callable).
  130
  131H :-
  132    ( normalize_ftype(H, N)
  133    ; normalize_ftgen(H, N)
  134    ),
  135    ( H == N
  136    ->functor(H, _, A),
  137      arg(A, H, G),
  138      B = call(G)
  139    ; B = N
  140    ),
  141    necki,
  142    B.
  143
  144:- global returns/2.
  145returns(_, G) :- call(G).
  146
  147:- global parent/2.
  148parent(_, G) :- call(G).
  149
  150:- global returns_state/1.
  151returns_state(G) :- call(G).
  152
  153:- global memory_root/1.
  154memory_root(G) :- call(G).
  155
  156:- type float_t/1 # "Defines a float".
  157float_t(Num) :- num(Num).
  158
  159:- type ptr/1 # "Defines a void pointer".
  160ptr(Ptr) :- int(Ptr).
  161
  162:- type long/1 # "Defines a long integer".
  163long(Long) :- int(Long).
  164
  165:- type size_t/1 # "Defines a size".
  166size_t(Size) :- nnegint(Size).
  167
  168:- type int64/1 # "Defines a 64 bits integer".
  169int64(I) :- int(I).
  170
  171%!  array(:Type, Dimensions:list(nnegint), Array)
  172%
  173%   Defines an array of dimensions Dimentions. In Prolog an array is implemented
  174%   as nested terms, with a functor arity equal to the dimension at each
  175%   level. In the foreign language is the typical array structure.  Note that we
  176%   use functor since they are equivalent to arrays in Prolog.
  177
  178:- type array(1, list(size_t), term).
  179:- meta_predicate array(1, +, ?).  180
  181array(Type, DimL, Array) :-
  182    array_(DimL, Type, Array).
  183
  184array_([], T, V) :- type(T, V).
  185array_([Dim|DimL], T, V) :-
  186    size_t(Dim),
  187    functor(V, v, Dim),
  188    mapargs(array_(DimL, T), V).
  189
  190%!  setof(:Type, ?Set)
  191%
  192%   Set is a set of Type.  The actual implementation would be a bit tricky,
  193%   but for now we simple use list/2.
  194
  195:- type setof/2 # "Defines a set of elements".
  196
  197:- meta_predicate setof(1, ?).  198
  199setof(Type, List) :-
  200    list(Type, List).
  201
  202%!  ptr(:Type, ?Ptr)
  203%
  204%   Defines a typed pointer. Note that if the value was allocated dynamically by
  205%   foreign_interface, it allows its usage as parent in FI_new_child_value/array
  206%   in the C side to perform semi-automatic memory management
  207
  208:- type ptr/2.
  209
  210:- meta_predicate ptr(1, ?).  211
  212ptr(Type, Ptr) :-
  213    call(Type, Ptr).
  214
  215prolog:called_by(dict_t(Desc, _), foreign_props, M, L) :-
  216    called_by_dict_t(Desc, M, L).
  217prolog:called_by(dict_t(_, Desc, _), foreign_props, M, L) :-
  218    called_by_dict_t(Desc, M, L).
  219
  220called_by_dict_t(Desc, CM, L) :-
  221    nonvar(Desc),
  222    dict_create(Dict, _Tag, Desc),
  223    findall(M:P,
  224            ( MType=Dict._Key,
  225              strip_module(CM:MType, M, T),
  226              nonvar(T),
  227              extend_args(T, [_], P)
  228            ), L).
  229
  230:- type dict_t/2.
  231:- meta_predicate dict_t(:, ?).  232dict_t(Desc, Term) :-
  233    dict_t(_, Desc, Term).
  234
  235:- type dict_t/3.
  236:- meta_predicate dict_t(?, :, ?).  237dict_t(Tag, M:Desc, Term) :-
  238    dict_mq(Desc, M, Tag, Dict),
  239    dict_pairs(Term, Tag, Pairs),
  240    maplist(dict_kv(Dict), Pairs).
  241
  242:- type dict_join_t/4.
  243:- meta_predicate dict_join_t(?, ?, 1, 1).  244dict_join_t(Term, Tag, M1:Type1, M2:Type2) :-
  245    join_dict_types(Type1, M1, Type2, M2, Tag, Dict),
  246    dict_pairs(Term, Tag, Pairs),
  247    maplist(dict_kv(Dict), Pairs).
  248
  249:- type dict_extend_t/4.
  250:- meta_predicate dict_extend_t(1, ?, +, ?).  251dict_extend_t(Type, Tag, Desc, Term) :-
  252    join_type_desc(Type, Tag, Desc, Dict),
  253    dict_pairs(Term, Tag, Pairs),
  254    maplist(dict_kv(Dict), Pairs).
  255
  256:- meta_predicate join_type_desc(1, ?, +, -).  257join_type_desc(M:Type, Tag, Desc2, Dict) :-
  258    type_desc(M:Type, Desc1),
  259    join_dict_descs(M:Desc1, M:Desc2, Tag, Dict).
  260
  261dict_mq(M:Desc, _, Tag, Dict) :- !,
  262    dict_mq(Desc, M, Tag, Dict).
  263dict_mq(Desc, M, Tag, Dict) :-
  264    dict_create(Dict, Tag, Desc),
  265    forall(Value=Dict.Key, nb_set_dict(Key, Dict, M:Value)).
  266
  267dict_kv(Dict, Key-Value) :-
  268    Type=Dict.Key,
  269    call(Type, Value).
  270
  271:- pred extend_one_arg(1, -goal) is det.
  272
  273extend_one_arg(Call1, Call) :- extend_args(Call1, [_], Call).
  274
  275type_desc(MType, Desc) :-
  276    extend_one_arg(MType, MCall),
  277    clause(MCall, dict_t(_, Desc, _)).
  278
  279join_dict_types(Type1, M1, Type2, M2, Tag, Dict) :-
  280    type_desc(M1:Type1, Desc1),
  281    type_desc(M2:Type2, Desc2),
  282    join_dict_descs(M1:Desc1, M2:Desc2, Tag, Dict).
  283
  284join_dict_descs(M1:Desc1, M2:Desc2, Tag, Dict) :-
  285    dict_mq(Desc1, M1, Tag, Dict1),
  286    dict_mq(Desc2, M2, Tag, Dict2),
  287    Dict=Dict1.put(Dict2),
  288    assertion(Dict=Dict2.put(Dict1))