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           sgen/1,
   61           tgen/1,
   62           tgen/2,
   63           dict_t/2,
   64           dict_t/3,
   65           dict_join_t/4,
   66           dict_extend_t/4,
   67           join_dict_types/6,
   68           join_type_desc/4]).   69
   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:- type foreign_spec/1.
   78
   79foreign_spec(name(  Name  )) :- atm(Name).
   80foreign_spec(prefix(Prefix)) :- atm(Prefix).
   81foreign_spec(suffix(Suffix)) :- atm(Suffix).
   82foreign_spec(lang(Lang)) :- lang(Lang).
   83
   84:- type lang/1.
   85lang(prolog).
   86lang(native).
   87
   88normalize_ftype(native( O, G), native( O, G)).
   89normalize_ftype(foreign(O, G), foreign(O, G)).
   90normalize_ftype(fimport(O, G), foreign([lang(prolog), O], G)).
   91normalize_ftype(native(    G), native( [prefix(pl_)], G)).
   92normalize_ftype(foreign(   G), foreign([prefix('')], G)).
   93normalize_ftype(fimport(   G), foreign([lang(prolog), prefix('')], G)).
   94normalize_ftype(nimport(O, G), foreign([lang(native), O], G)).
   95normalize_ftype(nimport(   G), foreign([lang(native), prefix('')], G)).
   96
   97:- type ftype_spec/1.
   98
   99ftype_spec(tdef). % Use typedef to implement the type
  100ftype_spec(decl). % Generate the equivalent struct/enum declaration for the given type
  101ftype_spec(gett). % Generate the getter of the given type
  102ftype_spec(unif). % Generate the unifier of the given type
  103
  104normalize_ftgen(tgen(   G), tgen([tdef, decl, gett, unif], G)).
  105normalize_ftgen(sgen(   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 sgen(callable).
  129:- global tgen(callable).
  130:- global tgen(nlist(ftype_spec), callable).
  131
  132H :-
  133    ( normalize_ftype(H, N)
  134    ; normalize_ftgen(H, N)
  135    ),
  136    ( H == N
  137    ->functor(H, _, A),
  138      arg(A, H, G),
  139      B = call(G)
  140    ; B = N
  141    ),
  142    necki,
  143    B.
  144
  145:- global returns/2.
  146returns(_, G) :- call(G).
  147
  148:- global parent/2.
  149parent(_, G) :- call(G).
  150
  151:- global returns_state/1.
  152returns_state(G) :- call(G).
  153
  154:- global memory_root/1.
  155memory_root(G) :- call(G).
  156
  157:- type float_t/1 # "Defines a float".
  158float_t(Num) :- num(Num).
  159
  160:- type ptr/1 # "Defines a void pointer".
  161ptr(Ptr) :- int(Ptr).
  162
  163:- type long/1 # "Defines a long integer".
  164long(Long) :- int(Long).
  165
  166:- type size_t/1 # "Defines a size".
  167size_t(Size) :- nnegint(Size).
  168
  169:- type int64/1 # "Defines a 64 bits integer".
  170int64(I) :- int(I).
  171
  172%!  array(:Type, Dimensions:list(nnegint), Array)
  173%
  174%   Defines an array of dimensions Dimentions. In Prolog an array is implemented
  175%   as nested terms, with a functor arity equal to the dimension at each
  176%   level. In the foreign language is the typical array structure.  Note that we
  177%   use functor since they are equivalent to arrays in Prolog.
  178
  179:- type array(1, list(size_t), term).
  180:- meta_predicate array(1, +, ?).  181
  182array(Type, DimL, Array) :-
  183    array_(DimL, Type, Array).
  184
  185array_([], T, V) :- type(T, V).
  186array_([Dim|DimL], T, V) :-
  187    size_t(Dim),
  188    functor(V, v, Dim),
  189    mapargs(array_(DimL, T), V).
  190
  191%!  setof(:Type, ?Set)
  192%
  193%   Set is a set of Type.  The actual implementation would be a bit tricky,
  194%   but for now we simple use list/2.
  195
  196:- type setof/2 # "Defines a set of elements".
  197
  198:- meta_predicate setof(1, ?).  199
  200setof(Type, List) :-
  201    list(Type, List).
  202
  203%!  ptr(:Type, ?Ptr)
  204%
  205%   Defines a typed pointer. Note that if the value was allocated dynamically by
  206%   foreign_interface, it allows its usage as parent in FI_new_child_value/array
  207%   in the C side to perform semi-automatic memory management
  208
  209:- type ptr/2.
  210
  211:- meta_predicate ptr(1, ?).  212
  213ptr(Type, Ptr) :-
  214    call(Type, Ptr).
  215
  216prolog:called_by(dict_t(Desc, _), foreign_props, M, L) :-
  217    called_by_dict_t(Desc, M, L).
  218prolog:called_by(dict_t(_, Desc, _), foreign_props, M, L) :-
  219    called_by_dict_t(Desc, M, L).
  220
  221called_by_dict_t(Desc, CM, L) :-
  222    nonvar(Desc),
  223    dict_create(Dict, _Tag, Desc),
  224    findall(M:P,
  225            ( MType=Dict._Key,
  226              strip_module(CM:MType, M, T),
  227              nonvar(T),
  228              extend_args(T, [_], P)
  229            ), L).
  230
  231:- type dict_t/2.
  232:- meta_predicate dict_t(:, ?).  233dict_t(Desc, Term) :-
  234    dict_t(_, Desc, Term).
  235
  236:- type dict_t/3.
  237:- meta_predicate dict_t(?, :, ?).  238dict_t(Tag, M:Desc, Term) :-
  239    dict_mq(Desc, M, Tag, Dict),
  240    dict_pairs(Term, Tag, Pairs),
  241    maplist(dict_kv(Dict), Pairs).
  242
  243:- type dict_join_t/4.
  244:- meta_predicate dict_join_t(?, ?, 1, 1).  245dict_join_t(Term, Tag, M1:Type1, M2:Type2) :-
  246    join_dict_types(Type1, M1, Type2, M2, Tag, Dict),
  247    dict_pairs(Term, Tag, Pairs),
  248    maplist(dict_kv(Dict), Pairs).
  249
  250:- type dict_extend_t/4.
  251:- meta_predicate dict_extend_t(1, ?, +, ?).  252dict_extend_t(Type, Tag, Desc, Term) :-
  253    join_type_desc(Type, Tag, Desc, Dict),
  254    dict_pairs(Term, Tag, Pairs),
  255    maplist(dict_kv(Dict), Pairs).
  256
  257:- meta_predicate join_type_desc(1, ?, +, -).  258join_type_desc(M:Type, Tag, Desc2, Dict) :-
  259    type_desc(M:Type, Desc1),
  260    join_dict_descs(M:Desc1, M:Desc2, Tag, Dict).
  261
  262dict_mq(M:Desc, _, Tag, Dict) :- !,
  263    dict_mq(Desc, M, Tag, Dict).
  264dict_mq(Desc, M, Tag, Dict) :-
  265    dict_create(Dict, Tag, Desc),
  266    forall(Value=Dict.Key, nb_set_dict(Key, Dict, M:Value)).
  267
  268dict_kv(Dict, Key-Value) :-
  269    Type=Dict.Key,
  270    call(Type, Value).
  271
  272:- pred extend_one_arg(1, -goal) is det.
  273
  274extend_one_arg(Call1, Call) :- extend_args(Call1, [_], Call).
  275
  276type_desc(MType, Desc) :-
  277    extend_one_arg(MType, MCall),
  278    clause(MCall, dict_t(_, Desc, _)).
  279
  280join_dict_types(Type1, M1, Type2, M2, Tag, Dict) :-
  281    type_desc(M1:Type1, Desc1),
  282    type_desc(M2:Type2, Desc2),
  283    join_dict_descs(M1:Desc1, M2:Desc2, Tag, Dict).
  284
  285join_dict_descs(M1:Desc1, M2:Desc2, Tag, Dict) :-
  286    dict_mq(Desc1, M1, Tag, Dict1),
  287    dict_mq(Desc2, M2, Tag, Dict2),
  288    Dict=Dict1.put(Dict2),
  289    assertion(Dict=Dict2.put(Dict1))