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