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_generator,
   36          [generate_library/5,
   37           collect_prop/4,
   38           gen_foreign_library/3]).   39
   40:- use_module(library(apply)).   41:- use_module(library(filesex)).   42:- use_module(library(assertions)).   43:- use_module(library(atomics_atom)).   44:- use_module(library(codegen)).   45:- use_module(library(call_ref)).   46:- use_module(library(camel_snake)).   47:- use_module(library(extend_args)).   48:- use_module(library(extra_messages)).   49:- use_module(library(foldil)).   50:- use_module(library(foreign/foreign_props)).   51:- use_module(library(key_value)).   52:- use_module(library(lists)).   53:- use_module(library(metaprops)).   54:- use_module(library(neck)).   55:- use_module(library(nmember)).   56:- use_module(library(process)).   57:- use_module(library(readutil)).   58:- use_module(library(solution_sequences)).   59:- use_module(library(substitute)).   60:- use_module(library(terms)).   61:- use_module(library(thread)).   62:- use_module(library(transpose)).   63:- use_module(library(pairs)).   64
   65:- multifile
   66    foreign_dependency/2,
   67    gen_foreign_library/3,
   68    use_foreign_source/2,
   69    use_foreign_header/2,
   70    include_foreign_dir/2,
   71    library_foreign_dir/2,
   72    extra_compiler_opts/2,
   73    link_foreign_library/2,
   74    pkg_foreign_config/2.   75
   76:- discontiguous
   77    match_type//6,
   78    implement_type_unifier//3.   79
   80:- dynamic
   81    foreign_dependency/2,
   82    gen_foreign_library/3,
   83    use_foreign_source/2,
   84    use_foreign_header/2,
   85    include_foreign_dir/2,
   86    extra_compiler_opts/2,
   87    link_foreign_library/2,
   88    pkg_foreign_config/2.   89
   90% :- table
   91%     type_props/5.
   92
   93% user:prolog_exception_hook(ExceptionIn, ExceptionOut, Frame, CatcherFrame) :-
   94%     backtrace(40).
   95
   96
   97% Predefined foreign dependencies:
   98
   99foreign_dependency(M, HAlias) :- use_foreign_header(M, HAlias).
  100foreign_dependency(_, library('foreign/foreign_interface.h')).
  101foreign_dependency(_, library('foreign/foreign_swipl.h')).
  102
  103command_to_atom(Command, Args, Atom) :-
  104    process_create(path(Command), Args, [stdout(pipe(Out))]),
  105    read_stream_to_codes(Out, String),
  106    atom_string(Atom, String).
  107
  108language_command(for, M, path(gfortran), ValueL, ValueT) :-
  109    command_to_atom(swipl, ['--dump-runtime-variables'], Atom),
  110    atomic_list_concat(AtomL, ';\n', Atom),
  111    findall(Value,
  112            ( ( member(NameValue, AtomL),
  113                member(NameEq, ['PLCFLAGS="', 'PLLDFLAGS="']),
  114                atomics_atom([NameEq, Values, '"'], NameValue)
  115              ; extra_compiler_opts(M, Values)
  116              ),
  117              atomic_args(Values, ValueL1),
  118              member(Value, ValueL1)
  119            ),
  120            ValueL, ValueT).
  121language_command(c, M, path('swipl-ld'), ValueL, ValueT) :-
  122    findall(COpt, ( COpt = '-shared'
  123                  ; ( extra_compiler_opts(M, COpts)
  124                    ; pkg_foreign_config(M, Package),
  125                      command_to_atom('pkg-config', ['--cflags', Package], COpt1),
  126                      atom_concat(COpts, '\n', COpt1)
  127                    ),
  128                    atomic_args(COpts, COptL1),
  129                    member(COpt, COptL1)
  130                  ), ValueL, ValueT).
  131
  132intermediate_obj(M, DirSO, OptL, LibL, Source, Object) -->
  133    { file_name_extension(Base, Ext, Source),
  134      file_base_name(Base, Name),
  135      ( Ext = for,
  136        memberchk(gfortran, LibL)
  137      ->true
  138      ; Ext = c
  139      ),
  140      intermediate_obj_cmd(Ext, Name, M, DirSO, OptL, Source, Object, Command)
  141    },
  142    !,
  143    ( {is_newer(Object, Source)}
  144    ->[]
  145    ; [Ext-Command]
  146    ).
  147intermediate_obj(_, _, _, _, Source, Source) --> [].
  148
  149intermediate_obj_cmd(Ext, Name, M, DirSO, OptL, Source, Object, Compiler-Args) :-
  150    % Add a prefix to avoid problems with other files with the same base
  151    atomic_list_concat([Name, '_', Ext], NameFor),
  152    file_name_extension(NameFor, o, NameO),
  153    directory_file_path(DirSO, NameO, Object),
  154    append([OptL, ['-c', Source, '-o', Object]], FOptL),
  155    language_command(Ext, M, Compiler, Args, FOptL).
  156
  157generate_library(M, AliasSO, AliasSOPl, InitL, File) :-
  158    absolute_file_name(AliasSO, FileSO, [file_type(executable),
  159                                         relative_to(File)]),
  160    findall(FSource, ( ( use_foreign_source(M, FAlias)
  161                       ; FAlias = library('foreign/foreign_interface.c')
  162                       ; FAlias = library('foreign/foreign_swipl.c')
  163                       ),
  164                       absolute_file_name(FAlias, FSource,
  165                                          [extensions(['.c', '']),
  166                                           access(read),
  167                                           relative_to(File)])
  168                     ), FSourceL),
  169    ( forall(( Dep = File
  170             ; member(Alias, [library(foreign/foreign_generator),
  171                              library(foreign/foreign_props),
  172                              library(foreign/foreign_interface)
  173                             ]),
  174               absolute_file_name(Alias, Dep, [file_type(prolog),
  175                                               access(read),
  176                                               relative_to(File)])),
  177             is_newer(FileSO, Dep))
  178    ->print_message(informational,
  179                    format("Skipping generation of ~w interface: is up to date", [File])),
  180      compile_library(M, FileSO, File, FSourceL)
  181    ; do_generate_library(M, FileSO, File, InitL),
  182      do_generate_wrapper(M, AliasSO, AliasSOPl, File),
  183      do_compile_library(M, FileSO, File, FSourceL)
  184    ).
  185
  186compile_library(M, FileSO, File, FSourceL) :-
  187    ( forall(( member(Dep, FSourceL)
  188             ; foreign_dependency(M, HAlias),
  189               absolute_file_name(HAlias, Dep,
  190                                  [extensions(['.h','']),
  191                                   access(read),
  192                                   relative_to(File)])
  193             ),
  194             is_newer(FileSO, Dep))
  195    ->print_message(informational,
  196                    format("Skipping compilation of ~w: is up to date", [FileSO]))
  197    ; do_compile_library(M, FileSO, File, FSourceL)
  198    ).
  199
  200% Beyond MaxFLIArgs arguments we should pack foreign arguments due to a
  201% hard-coded limitation of SWI-Prolog:
  202max_fli_args(10 ).
  203
  204do_generate_wrapper(M, AliasSO, AliasSOPl, File) :-
  205    max_fli_args(MaxFLIArgs),
  206    findall(F/A, ( current_foreign_prop(Head, M, _, _, Glob),
  207                   arg(1, Glob, Opts),
  208                   \+ ( nmember(lang(Lang), Opts),
  209                        lang(Lang)
  210                      ),
  211                   \+ ( predicate_property(M:Head, number_of_clauses(X)),
  212                        X>0
  213                      ),
  214                   functor(Head, F, A)
  215                 ), IntfPIU),
  216    sort(IntfPIU, IntfPIL),
  217    atom_concat(M, '$impl', IModule),
  218    absolute_file_name(AliasSOPl, FileSOPl, [file_type(prolog),
  219                                             relative_to(File)]),
  220    save_to_file(FileSOPl,
  221                 phrase(( add_autogen_note(M),
  222                          [(:- module(IModule, IntfPIL))],
  223                          generate_aux_clauses(M),
  224                          ["",
  225                           (:- use_foreign_library(AliasSO)),
  226                           % make these symbols public:
  227                           (:- initialization(( shlib:current_library(AliasSO, _, F1, IModule, _),
  228                                                open_shared_object(F1, _Handle, [global])), now))],
  229                          findall((Head :- Body),
  230                                  ( member(F/A, IntfPIL),
  231                                    A > MaxFLIArgs,
  232                                    atomic_list_concat(['__aux_pfa_', F, '_', A], NF),
  233                                    functor(Head, F, A),
  234                                    Body =.. [NF, Head]
  235                                  ))
  236                        ))).
  237
  238atomic_args(String, ArgL) :-
  239    atomic_list_concat(ArgL1, ' ', String),
  240    subtract(ArgL1, [''], ArgL).
  241
  242do_generate_library(M, FileSO, File, InitL) :-
  243    file_name_extension(BaseFile, _, FileSO),
  244    generate_foreign_interface(M, File, InitL, BaseFile).
  245
  246
  247do_compile_library(M, FileSO, File, FSourceL) :-
  248    file_name_extension(BaseFile, _, FileSO),
  249    absolute_file_name(library(foreign/foreign_interface),
  250                       IntfPl,
  251                       [file_type(prolog), access(read), relative_to(File)]),
  252    directory_file_path(DirIntf, _, IntfPl),
  253    directory_file_path(DirSO,   _, FileSO),
  254    atom_concat(BaseFile, '_intf.c', IntfFile),
  255    findall(IDir, ( ( Dir = DirSO
  256                    ; Dir = DirIntf
  257                    ; include_foreign_dir(M, DAlias),
  258                      absolute_file_name(DAlias, Dir, [file_type(directory),
  259                                                       relative_to(File)])
  260                    ),
  261                    atom_concat('-I', Dir, IDir)
  262                  ), IDirL),
  263    CommonOptL = ['-fPIC'|IDirL],
  264    foldl(intermediate_obj(M, DirSO, CommonOptL, LibL), [IntfFile|FSourceL], FTargetL, ExtCommands, []),
  265    once(append(LibL, [], _)),
  266    findall(COpt, ( COpt = '-shared'
  267                  ; ( extra_compiler_opts(M, COpts)
  268                    ; pkg_foreign_config(M, Package),
  269                      command_to_atom('pkg-config', ['--cflags', Package], COpt1),
  270                      atom_concat(COpts, '\n', COpt1)
  271                    ),
  272                    atomic_args(COpts, COptL1),
  273                    member(COpt, COptL1)
  274                  ), COptL),
  275    findall(CLib, ( ( link_foreign_library(M, Lib)
  276                    ; member(Lib, LibL)
  277                    ),
  278                    atom_concat('-l', Lib, CLib)
  279                  ; pkg_foreign_config(M, Package),
  280                    command_to_atom('pkg-config', ['--libs', Package], CLib1),
  281                    atom_concat(CLibs, '\n', CLib1),
  282                    atomic_args(CLibs, CLibL1),
  283                    member(CLib, CLibL1)
  284                  ), CLibL, ['-o', FileSO]),
  285    findall(LDir, ( library_foreign_dir(M, DAlias),
  286                    absolute_file_name(DAlias, Dir, [file_type(directory),
  287                                                     relative_to(File)]),
  288                    atom_concat('-L', Dir, LDir)
  289                  ),
  290            LDirL),
  291    append([COptL, CommonOptL, LDirL, FTargetL, CLibL], FArgsL),
  292    keysort(ExtCommands, Sorted),
  293    group_pairs_by_key(Sorted, Grouped),
  294    concurrent_maplist(compile_1, Grouped),
  295    compile_2(path('swipl-ld')-FArgsL).
  296
  297compile_1(Ext-Commands) :- compile_1(Ext, Commands).
  298
  299% Note: Due to the presence of Fortran modules, the compilation of Fortran can
  300% not be parallelized, since Prolog is not aware of Fortran dependencies, so we
  301% compile such modules serialized
  302compile_1(for, Commands) :-            maplist(compile_2, Commands).
  303compile_1(c,   Commands) :- concurrent_maplist(compile_2, Commands).
  304
  305compile_2(Command-ArgL) :-
  306    process_create(Command, ArgL, [stdout(pipe(Out)),
  307                                   stderr(pipe(Err))]),
  308    read_string(Err, _, SErr),
  309    read_string(Out, _, SOut),
  310    close(Err),
  311    command_to_string(Command, ArgL, CommandS),
  312    catch(call_cleanup(
  313              close(Out),
  314              ( SOut = "",
  315                SErr = ""
  316              ->print_message(informational, format("~s", [CommandS]))
  317              ; print_message(warning, format("~s~s~nCommand: ~s", [SOut, SErr, CommandS]))
  318              )),
  319          Error,
  320          print_message(error, Error)).
  321
  322command_to_string(Command, ArgL, CommandS) :-
  323    ( Command = path(RCommand)
  324    ->true
  325    ; RCommand = Command
  326    ),
  327    atomic_list_concat([RCommand|ArgL], ' ', CommandS).
  328
  329generate_foreign_interface(Module, FilePl, IntL, BaseFile) :-
  330    atom_concat(BaseFile, '_impl', BaseFileImpl),
  331    file_name_extension(BaseFileImpl, h, FileImpl_h),
  332    atom_concat(BaseFile, '_intf', BaseFileIntf),
  333    file_name_extension(BaseFileIntf, h, FileIntf_h),
  334    file_name_extension(BaseFileIntf, c, FileIntf_c),
  335    directory_file_path(_, Base, BaseFile),
  336    save_to_file(FileImpl_h, generate_foreign_impl_h(Module)),
  337    save_to_file(FileIntf_h, generate_foreign_intf_h(Module, FileImpl_h)),
  338    save_to_file(FileIntf_c, generate_foreign_c(Module, Base, IntL, FilePl, FileIntf_h)).
  339
  340c_var_name(Arg, "_c_"+Arg).
  341
  342generate_foreign_intf_h(Module, FileImpl_h) -->
  343    add_autogen_note(Module),
  344    ["#ifndef __"+Module+"_INTF_H",
  345     "#define __"+Module+"_INTF_H",
  346     "",
  347     "",
  348     "#include <foreign_swipl.h>",
  349     "#include \""+FileImpl_h+"\"",
  350     "",
  351     "extern module_t __"+Module+"_impl;"],
  352    findall_tp(Module, type_props_nft(gett), declare_type(gett)),
  353    findall_tp(Module, type_props_nft(unif), declare_type(unif)),
  354    findall("extern "+Decl+";",
  355            ( current_foreign_prop(Head, _, Module, _, _, _, _, Dict, FuncName, _, BindName, _, Type),
  356              apply_dict(Head, Dict),
  357              declare_intf_head(Type, FuncName, BindName, Head, Decl)
  358            )),
  359    ["",
  360     "#endif /* __"+Module+"_INTF_H */"].
  361
  362declare_intf_head(foreign(Opts, _), _, BindName, _, Decl) :-
  363    once(( nmember(lang(Lang), Opts),
  364           lang(Lang)
  365         )),
  366    declare_intf_fimp_head(BindName, Decl).
  367declare_intf_head(foreign(Opts, _), FuncName, _, Head, Decl) :-
  368    once(nmember(lang(native), Opts)),
  369    declare_intf_head(FuncName, Head, Decl).
  370declare_intf_head(Type, _, BindName, Head, Decl) :-
  371    \+ ( Type = foreign(Opts, _),
  372         nmember(lang(Lang), Opts),
  373         lang(Lang)
  374       ),
  375    declare_intf_head(BindName, Head, Decl).
  376
  377declare_intf_fimp_head(BindName, "predicate_t "+BindName+"").
  378
  379generate_foreign_impl_h(Module) -->
  380    add_autogen_note(Module),
  381    ["#ifndef __"+Module+"_IMPL_H",
  382     "#define __"+Module+"_IMPL_H",
  383     "",
  384     "#include <foreign_interface.h>"],
  385    findall_tp(Module, type_props_nf(decl), declare_struct),
  386    declare_foreign_bind(Module),
  387    ["#endif /* __"+Module+"_IMPL_H */"].
  388
  389add_autogen_note(Module) -->
  390    ["/* NOTE: File generated automatically from "+Module+" */",
  391     ""].
  392
  393generate_foreign_c(Module, Base, InitL, FilePl, FileIntf_h) -->
  394    add_autogen_note(Module),
  395    findall("#include \""+File_h+"\"",
  396            ( use_foreign_header(Module, HAlias),
  397              absolute_file_name(HAlias, File_h, [extensions(['.h', '']),
  398                                                  access(read),
  399                                                  relative_to(FilePl)])
  400            )),
  401    ["#include \""+FileIntf_h+"\"",
  402     "",
  403     "module_t __"+Module+";",
  404     "module_t __"+Module+"_impl;"
  405    ],
  406    findall_tp(Module, type_props_nft(gett), implement_type_getter),
  407    findall_tp(Module, type_props_nft(unif), implement_type_unifier),
  408    generate_foreign_register(Module, Base, InitL),
  409    generate_foreign_intf(Module).
  410
  411generate_foreign_register(Module, Base, InitL) -->
  412    ["install_t install_"+Base+"() {",
  413     "    __system_dict_create        =PL_predicate(\"dict_create\", 3, \"system\");",
  414     "    __system_get_dict           =PL_predicate(\"get_dict\",    3, \"system\");",
  415     "    __system_put_dict           =PL_predicate(\"put_dict\",    4, \"system\");",
  416     "    __foreign_generator_call_idx=PL_predicate(\"call_idx\",    2, \"foreign_generator\");",
  417     "    __foreign_generator_idx_call=PL_predicate(\"idx_call\",    2, \"foreign_generator\");",
  418     "    __"+Module+"     =PL_new_module(PL_new_atom(\""+Module+"\"));",
  419     "    __"+Module+"_impl=PL_new_module(PL_new_atom(\""+Module+"$impl\"));"],
  420    findall_tp(Module, type_props_nft([gett, unif]), define_aux_variables),
  421    findall(Line,
  422            ( current_foreign_prop(_, M, Module, _, _, _, _, _, _, PredName, BindName, Arity, Type),
  423              write_register_sentence(Type, M, Module, PredName, Arity, BindName, Line))),
  424    foldl(generate_init, InitL),
  425    ["} /* install_"+Base+" */",
  426     ""].
  427
  428generate_init(Init) --> ["    "+Init+"();"].
  429
  430write_register_sentence(foreign(Opts, _), M, _, PredName, Arity, BindName, Line) :-
  431    nmember(lang(Lang), Opts),
  432    lang(Lang),
  433    !,
  434    write_init_import_binding(M, PredName, Arity, BindName, Line).
  435write_register_sentence(_, M, CM, PredName, Arity, BindName, Line) :-
  436    write_register_foreign_native(M, CM, PredName, Arity, BindName, Line).
  437
  438write_register_foreign_native(M, CM, PredName, Arity, BindName, L) :-
  439    max_fli_args(MaxFLIArgs),
  440    ( M == CM
  441    ->L1="    PL_register_foreign("
  442    ; L1="    PL_register_foreign_in_module(\""+M+"\","
  443    ),
  444    ( Arity =< MaxFLIArgs
  445    ->L = L1+"\""+PredName+"\", "+Arity+", "+BindName+", 0);"
  446    ; L = L1+"\"__aux_pfa_"+PredName+"_"+Arity+"\", 1, __aux_pfa_"+BindName+"_"+Arity+", 0);"
  447    ).
  448
  449write_init_import_binding(M, PN, A, BN,
  450                          "    "+BN+" = PL_predicate(\""+PN+"\", "+A+", \""+M+"\");").
  451
  452:- meta_predicate findall_tp(+,4,5,?,?).  453
  454findall_tp(Module, TypeProps, Call) -->
  455    findall(List,
  456            ( call(TypeProps, Module, TypePropLDictL, Pos, _Asr),
  457              maplist(apply_dict_tp, TypePropLDictL),
  458              phrase(type_components(Module, TypePropLDictL, Call, Pos), List)
  459            )).
  460
  461apply_dict_tp(_-TypePropLDictL) :- maplist(apply_dict_tp_2, TypePropLDictL).
  462
  463apply_dict_tp_2(t(Type, PropL, GlobL, Dict)) :- apply_dict(Type-PropL-GlobL, Dict).
  464
  465auto_generated_types(M, t(Type, PropL, GlobL, Dict), t(Type, PropS, GlobL, Dict)) -->
  466    { functor(Type, Name, _),
  467      foldl(match_unknown_type(M, Name), PropL, PropTypeL1, []),
  468      foldl(cleanup_redundant(Type, PropL), PropTypeL1, PropTypeL, []),
  469      substitute_values(PropTypeL, PropL, PropS)
  470    },
  471    foldl(add_dict(Dict), PropTypeL).
  472
  473cleanup_redundant(Type, PropL, Prop=SubType) -->
  474    ( { functor(Type, _, A),
  475        arg(A, Type, Arg),
  476        functor(SubType, _, SA),
  477        arg(SA, SubType, SubArg),
  478        Arg==SubArg,
  479        PropL==[Prop]
  480      }
  481    ->[]
  482    ; [Prop=SubType]
  483    ).
  484
  485add_dict(Dict, Prop=Type) --> [Type-[t(Type, [Prop], [], Dict)]].
  486
  487match_unknown_type(M, Name, Prop) --> match_type(Prop, M, unknown, Name, _, _), !.
  488
  489is_type(CM, Head) :-
  490    once(( prop_asr(Head, CM, check, prop, _, _, Asr),
  491           once(prop_asr(glob, type(_), _, Asr))
  492         )).
  493
  494type_props(M, TypePropLDictL, Pos, Asr) :-
  495    type_props(M, _, TypePropLDictL, Pos, Asr).
  496
  497type_props(M, Type, TypePropLDictL, Pos, Asr) :-
  498    type_props1(M, Type, TDict, Pos, Asr),
  499    type_props2(M, Type, TDict, TypePropLDictL, Asr).
  500
  501type_props2(M, Type, TDict, TypePropLDictL, Asr) :-
  502    collect_prop(Asr, M, comp, TPropL),
  503    collect_prop(Asr, M, glob, TGlobL),
  504    ( TPropL \= []
  505    ->TypePropLDictL1 = [t(Type, TPropL, TGlobL, TDict)]
  506    ; bind_type_names(M:Type, TGlobL, TypePropLDictL1)
  507    ->true
  508    ; TypePropLDictL1 = [t(Type, [], TGlobL, TDict)]
  509    ),
  510    phrase(foldl(auto_generated_types(M), TypePropLDictL1, TypePropLDictL2),
  511           TypePropLDictL3, [Type-TypePropLDictL2]),
  512    maplist(resolve_special_terms, TypePropLDictL3, TypePropLDictL).
  513
  514resolve_special_term(V, V) :- var(V).
  515resolve_special_term([], nil).
  516resolve_special_term([H|T], edge(H, T)).
  517resolve_special_term(T, T).
  518
  519resolve_special_terms(Type1-TypePropLDictL1, Type-TypePropLDictL) :-
  520    resolve_special_arg(Type1, Type),
  521    maplist(resolve_special_term2, TypePropLDictL1, TypePropLDictL).
  522
  523resolve_special_arg(Type1, Type) :-
  524    Type1 =.. List1,
  525    once(append(Left, [Last1], List1)),
  526    once(resolve_special_term(Last1, Last)),
  527    append(Left, [Last], List),
  528    Type =.. List.
  529
  530resolve_special_term2(t(Type1, PropL, GlobL, Dict), t(Type, PropL, GlobL, Dict)) :- resolve_special_arg(Type1, Type).
  531
  532type_props1(CM, Head, Dict, Pos, Asr) :-
  533    % Only consider assertions defined in this module
  534    asr_head_prop(Asr, CM, Head, check, prop, Dict, _, Pos),
  535    % But tye type definition could come from a different place
  536    is_type(CM, Head).
  537
  538type_props_nf(Opts1, Module, TypePropLDictL, Pos, Asr) :-
  539    type_props_nf(Opts1, Module, _, TypePropLDictL, Pos, Asr).
  540
  541type_props_nf(Opts1, Module, Type, TypePropLDictL, Pos, Asr) :-
  542    type_props(Module, Type, TypePropLDictL, Pos, Asr),
  543    once(( normalize_ftgen(Glob1, tgen(Opts2, _)),
  544           prop_asr(glob, Glob1, _, Asr),
  545           nmember(Opt, Opts1),
  546           nmember(Opt, Opts2)
  547         )),
  548    \+ ( normalize_ftype(Glob, NType),
  549         prop_asr(glob, Glob, _, Asr),
  550         arg(1, NType, Opts),
  551         \+ ( nmember(lang(Lang), Opts),
  552              lang(Lang)
  553            )).
  554
  555type_props_nft(Opt, Module, TypePropLDictL, Pos, Asr) :-
  556    type_props_nf(Opt, Module, Type, TypePropLDictL, Pos, Asr),
  557    % Don't create getters and unifiers for
  558    % typedefs, they are just casts:
  559    \+ type_is_tdef(Module, Type, _, _).
  560
  561define_aux_variables(dict_ini(_, Name, M, _), _, _) -->
  562    !,
  563    ["    __rtcwarn((__"+M+"_aux_keyid_index_"+Name+"=PL_pred(PL_new_functor(PL_new_atom(\"__aux_keyid_index_"+Name+"\"), 2), __"+M+"_impl))!=NULL);"].
  564define_aux_variables(dict_key_value(_, _, _, _), _, _) --> !, {fail}.
  565define_aux_variables(_, _, _) --> [].
  566
  567implement_type_getter_ini(PName, CName, Spec, Name) -->
  568    { ctype_decl(Spec, Decl1),
  569      ( Spec = array(_, _)
  570      ->Decl = Decl1
  571      ; Decl = Decl1+"*"
  572      )
  573    },
  574    ["int FI_get_"+Name+"(root_t __root, term_t "+PName+", "+Decl+" "+CName+") {"].
  575
  576c_get_argument_getter(Spec, CNameArg, PNameArg, GetArg) :-
  577    c_get_argument(Spec, in, CNameArg, PNameArg, GetArg).
  578
  579implement_type_getter_union_ini_join(SubType, Spec, Term, Name, UType) -->
  580    { term_pcname(Term, Name, PName, CName),
  581      cname_utype(SubType, CName, UType1),
  582      ( \+ref_type(Spec)
  583      ->UType = "*"+UType1
  584      ; UType = UType1
  585      ),
  586      functor(Term, Func, _),
  587      '$current_source_module'(CM)
  588    },
  589    implement_type_getter_ini(PName, CName, Spec, Name),
  590    ["    term_t __args = PL_new_term_refs(2);",
  591     "    int __utype;",
  592     "    __rtcheck(PL_unify_term(__args, PL_FUNCTOR_CHARS, \""+Func+"\", 1, PL_TERM, "+PName+"));",
  593     "    __rtcheck(__rtctype(PL_call_predicate(__"+CM+", PL_Q_NORMAL,",
  594     "                                          __foreign_generator_call_idx, __args),",
  595     "                        __args, "+Name+"));",
  596     "    __rtcheck(PL_get_integer(__args + 1, &__utype));",
  597     "    "+UType+"=__utype;"
  598    ].
  599
  600implement_type_getter_union_ini(union, Spec, Term, Name) -->
  601    implement_type_getter_union_ini_join(union, Spec, Term, Name, UType),
  602    ["    switch ("+UType+") {"].
  603implement_type_getter_union_ini(cdef,   _, _, _) --> [].
  604implement_type_getter_union_ini(struct, _, _, _) --> [].
  605implement_type_getter_union_ini(enum, Spec, Term, Name) -->
  606    implement_type_getter_union_ini_join(enum, Spec, Term, Name, _).
  607
  608implement_type_getter_union_end(union) -->
  609    ["    default:",
  610     "        return FALSE;",
  611     "    };"],
  612    implement_type_end.
  613implement_type_getter_union_end(cdef  ) --> [].
  614implement_type_getter_union_end(struct) --> [].
  615implement_type_getter_union_end(enum  ) --> implement_type_end.
  616
  617enum_elem(Name, Term, Name+"_"+Suff) :- enum_suff(Term, Suff).
  618
  619enum_suff(Term, Elem) :- functor(Term, Elem, _).
  620
  621implement_type_getter(union_ini(SubType, Spec, _), Term, Name) -->
  622    implement_type_getter_union_ini(SubType, Spec, Term, Name).
  623implement_type_getter(union_end(SubType, _), _, _) -->
  624    implement_type_getter_union_end(SubType).
  625implement_type_getter(func_ini(SubType, Spec), Term, Name) -->
  626    ( {SubType = union}
  627    ->{enum_elem(Name, Term, Elem)},
  628      ["    case "+Elem+":",
  629       "    {"]
  630    ; {func_pcname(Name, PName, CName)},
  631      implement_type_getter_ini(PName, CName, Spec, Name)
  632    ).
  633implement_type_getter(func_rec(SubType, N, Term, Name), Spec, Arg) -->
  634    { SubType = union
  635    ->enum_suff(Term, Suff),
  636      line_atom(Suff, TName),
  637      format(atom(CRecordName), "~w.~w", [TName, Arg]),
  638      format(atom(TNameArg), "~w_~w", [TName, Arg]),
  639      camel_snake(PRecordName, TNameArg),
  640      Indent = "        "
  641    ; CRecordName = Arg,
  642      camel_snake(PRecordName, Arg),
  643      Indent = "    "
  644    },
  645    { func_pcname(Name, PName, CName),
  646      CNameArg="&"+CName+"->"+CRecordName+"",
  647      PNameArg=PName+"_"+PRecordName
  648    },
  649    ( {SubType = union_type}
  650    ->{c_get_argument_getter(Spec, CNameArg, PName, GetArg)}
  651    ; [Indent+"term_t "+PNameArg+"=PL_new_term_ref();",
  652       Indent+"__rtcheck(PL_get_arg("+N+","+PName+","+PNameArg+"));"],
  653      {c_get_argument_getter(Spec, CNameArg, PNameArg, GetArg)}
  654    ),
  655    [Indent+GetArg+";"].
  656implement_type_getter(func_end(SubType, _), _, _) -->
  657    ( {SubType = union}
  658    ->["        break;",
  659       "    }"]
  660    ; implement_type_end
  661    ).
  662implement_type_getter(atomic(SubType, Name), Spec, Term) -->
  663    {enum_elem(Name, Term, Elem)},
  664    ( {SubType = union}
  665    ->{ func_pcname(Name, PName, CName1),
  666        enum_suff(Term, Suff),
  667        CName = CName1+"->"+Suff,
  668        Indent = "        "
  669      },
  670      ["    case "+Elem+":"]
  671    ; { func_pcname(Name, PName, CName),
  672        Indent = "    "
  673      },
  674      implement_type_getter_ini(PName, CName, Spec, Name)
  675    ),
  676    {c_get_argument_getter(Spec, CName, PName, GetArg)},
  677    [Indent+GetArg+";"],
  678    ( {SubType = union}
  679    ->[Indent+"break;"]
  680    ; implement_type_end
  681    ).
  682implement_type_getter(dict_ini(SubType, Name, M, _), Spec, Term) -->
  683    ( {SubType = union}
  684    ->{enum_elem(Name, Term, Elem)},
  685      ["    case "+Elem+":",
  686       "    {"]
  687    ; ["predicate_t __"+M+"_aux_keyid_index_"+Name+";"],
  688      {term_pcname(Term, Name, PName, CName)},
  690      implement_type_getter_dict_ini(M, PName, CName, Spec, Name)
  691    )
  691.
  692implement_type_getter(dict_key_value(Dict, _, N, _), Key, Value) -->
  693    {key_value_from_dict(Dict, N, Key, Value)}.
  694implement_type_getter(dict_rec(SubType, _, Term, N, Name), Spec, Arg) -->
  695    { ( SubType = union
  696      ->enum_suff(Term, Suff),
  697        format(atom(CRecordName), "~w.~w", [Suff, Arg]),
  698        Indent = "        "
  699      ; CRecordName = Arg,
  700        Indent = "    "
  701      ),
  702      term_pcname(Term, Name, PName, CName),
  703      CNameArg = "&"+CName+"->"+CRecordName,
  704      c_get_argument_getter(Spec, CNameArg, PName, GetArg)
  705    },
  706    [Indent+"    case "+N+": "+GetArg+"; break;"].
  707implement_type_getter(dict_end(SubType, _, _), _, _) -->
  708    ["        }"],
  709    ( {SubType = union}
  710    ->["        break;",
  711       "    }"]
  712    ; implement_type_end
  713    ).
  714
  715implement_type_getter_dict_ini(Module, PName, CName, Spec, Name) -->
  716    {ctype_decl(Spec, Decl)},
  717    ["static int get_pair_"+Name+"(root_t __root, term_t __keyid, term_t "+PName+", "+Decl+"* "+CName+");",
  718     ""],
  719    implement_type_getter_ini(PName, CName, Spec, Name),
  720    ["    memset("+CName+", 0, sizeof("+Decl+"));",
  721     "    FI_get_dict_t("+Name+", "+PName+", "+CName+");"
  722    ],
  723    implement_type_end,
  724    ["static int get_pair_"+Name+"(root_t __root, term_t __keyid, term_t "+PName+", "+Decl+"* "+CName+") {",
  725     "    int __index;",
  726     "    FI_get_keyid_index(__"+Module+"_aux_keyid_index_"+Name
  727     +", __keyid, __index);",
  728     "    switch (__index) {"].
  729
  730implement_type_end -->
  731    ["    return TRUE;",
  732     "}",
  733     ""].
  734
  735term_pcname(Term, NameL, Name) :-
  736    ( compound(Term)
  737    ->functor(Term, Func, _)
  738    ; Func = Term
  739    ),
  740    ( valid_csym(Func)
  741    ->Name = Func
  742    ; Name = NameL
  743    ).
  744
  745term_pcname(Term, NameL, PName, CName) :-
  746    term_pcname(Term, NameL, Name),
  747    func_pcname(Name, PName, CName).
  748
  749func_pcname(NameL, PName, CName) :-
  750    ( is_list(NameL)
  751    ->atomic_list_concat(NameL, Name)
  752    ; Name = NameL
  753    ),
  754    camel_snake(PName, Name),
  755    c_var_name(Name, CName).
  756
  757type_char(Type, Char) :- char_type(Char, Type).
  758
  759valid_csym(Func) :-
  760    atom_codes(Func, Codes),
  761    maplist(type_char(csym), Codes).
  762
  763implement_type_unifier(atomic(SubType, Name), Spec, Term) -->
  764    {enum_elem(Name, Term, Elem)},
  765    ( {SubType = union}
  766    ->{ func_pcname(Name, PName, CName1),
  767        enum_suff(Term, Suff),
  768        CName = CName1+"->"+Suff,
  769        Indent = "        "
  770      },
  771      ["    case "+Elem+":"]
  772    ; { func_pcname(Name, PName, CName),
  773        Indent = "    "
  774      },
  775      implement_type_unifier_ini(PName, CName, Name, Spec)
  776    ),
  777    { ( SubType = union
  778      ->Mode = inout
  779      ; Mode = out
  780      ),
  781      c_set_argument(Spec, Mode, CName, PName, SetArg)
  782    },
  783    [Indent+SetArg+";"],
  784    ( {SubType = union}
  785    ->[Indent+"break;"]
  786    ; implement_type_end
  787    ).
  788implement_type_unifier(union_ini(SubType, Spec, _), Term, Name) -->
  789    implement_type_unifier_union_ini(SubType, Spec, Term, Name).
  790
  791cname_utype(union, CName, CName+"->utype").
  792cname_utype(enum,  CName, CName).
  793
  794implement_type_unifier_union_ini_join(SubType, Spec, Term, Name, UType) -->
  795    { term_pcname(Term, Name, PName, CName),
  796      cname_utype(SubType, CName, UType),
  797      functor(Term, Func, _),
  798      '$current_source_module'(CM)
  799    },
  800    implement_type_unifier_ini(PName, CName, Name, Spec),
  801    ["    term_t __args = PL_new_term_refs(2);",
  802     "    __rtcheck(PL_put_integer(__args, "+UType+"));",
  803     "    __rtcheck(PL_unify_term(__args + 1, PL_FUNCTOR_CHARS, \""+Func+"\", 1, PL_TERM, "+PName+"));",
  804     "    __rtcheck(__rtctype(PL_call_predicate(__"+CM+", PL_Q_NORMAL,",
  805     "                                          __foreign_generator_idx_call, __args),",
  806     "                        __args, "+Name+"));"
  807    ].
  808
  809implement_type_unifier_union_ini(union, Spec, Term, Name) -->
  810    implement_type_unifier_union_ini_join(union, Spec, Term, Name, UType),
  811    ["    switch ("+UType+") {"].
  812implement_type_unifier_union_ini(enum, Spec, Term, Name) -->
  813    implement_type_unifier_union_ini_join(enum, Spec, Term, Name, _).
  814implement_type_unifier_union_ini(cdef,   _, _, _) --> [].
  815implement_type_unifier_union_ini(struct, _, _, _) --> [].
  816
  817implement_type_unifier(union_end(SubType, _), _, _) -->
  818    implement_type_unifier_union_end(SubType).
  819
  820implement_type_unifier_union_end(union) -->
  821    ["    default:",
  822     "        return FALSE;",
  823     "    };"],
  824    implement_type_end.
  825implement_type_unifier_union_end(cdef  ) --> [].
  826implement_type_unifier_union_end(struct) --> [].
  827implement_type_unifier_union_end(enum  ) --> implement_type_end.
  828
  829implement_type_unifier(func_ini(SubType, Spec), Term, Name) -->
  830    {func_pcname(Name, PName, CName)},
  831    ( {SubType = union}
  832    ->{enum_elem(Name, Term, Elem)},
  833      ["    case "+Elem+":",
  834       "    {"]
  835    ; implement_type_unifier_ini(PName, CName, Name, Spec),
  836      {functor(Term, Func, Arity)},
  837      ["        __rtcheck(PL_unify_functor("+PName+", PL_new_functor(PL_new_atom(\""+Func+"\"), "+Arity+")));"]
  838    ).
  839implement_type_unifier(func_rec(SubType, N, Term, Name), Spec, Arg) -->
  840    {type_unifiers_elem_names(SubType, Term, Name, Arg, Indent, PName, CNameArg, PNameArg)},
  841    ( {SubType = union_type}
  842    ->{c_set_argument(Spec, out, CNameArg, PName, SetArg)}
  843    ; [Indent+"term_t "+PNameArg+"=PL_new_term_ref();",
  844       Indent+"__rtcheck(PL_unify_arg("+N+","+PName+","+PNameArg+"));"],
  845      {c_set_argument(Spec, out, CNameArg, PNameArg, SetArg)}
  846    ),
  847    [Indent+SetArg+";"].
  848
  849type_unifiers_elem_names(SubType, Term, Name, Arg, Indent, PName, CNameArg, PNameArg) :-
  850    func_pcname(Name, PName, CName),
  851    ( SubType = union
  852    ->enum_suff(Term, Suff),
  853      line_atom(Suff, TName),
  854      format(atom(CRecordName), "~w.~w", [TName, Arg]),
  855      format(atom(TNameArg), "~w_~w", [TName, Arg]),
  856      camel_snake(PRecordName, TNameArg),
  857      Indent = "        "
  858    ; CRecordName = Arg,
  859      camel_snake(PRecordName, Arg),
  860      ( SubType = union_type
  861      ->Indent = "        "
  862      ; Indent = "    "
  863      )
  864    ),
  865    CNameArg = CName+"->"+CRecordName,
  866    PNameArg = PName+"_"+PRecordName.
  867
  868implement_type_unifier(func_end(SubType, _), _, _) -->
  869    ( {SubType = union}
  870    ->["        break;",
  871       "    }"]
  872    ; implement_type_end
  873    ).
  874implement_type_unifier(dict_ini(SubType, Name, _, _), Spec, Term) -->
  875    ( {SubType = union}
  876    ->{enum_elem(Name, Term, Elem)},
  877      ["    case "+Elem+":",
  878       "    {"]
  879    ; {func_pcname(Term, PName, CName)},
  880      implement_type_unifier_ini(PName, CName, Name, Spec)
  881    ),
  882    ["    term_t __desc=PL_new_term_ref();",
  883     "    term_t __tail=PL_copy_term_ref(__desc);"].
  884implement_type_unifier(dict_key_value(Dict, _, N, _), Key, Value) -->
  885    {key_value_from_dict(Dict, N, Key, Value)}. % Placed in 'dict' order
  886implement_type_unifier(dict_rec(SubType, _, Term, _N, NameL), Spec, Arg) -->
  887    {term_pcname(Term, NameL, Name)},
  888    {type_unifiers_elem_names(SubType, Term, Name, Arg, Indent, _, CNameArg, PNameArg)},
  889    ( {spec_pointer(Spec)}
  890    ->with_wrapper(
  891          Indent+"if("+CNameArg+") {",
  892          type_unifiers_elem_dict_settle(Spec, Arg, Indent+"    ", CNameArg, PNameArg),
  893          Indent+"}")
  894    ; type_unifiers_elem_dict_settle(Spec, Arg, Indent, CNameArg, PNameArg)
  895    ).
  896
  897type_unifiers_elem_dict_settle(Spec, Arg, Indent, CNameArg, PNameArg) -->
  898    [Indent+"term_t "+PNameArg+"=PL_new_term_ref();"],
  899    [Indent+"FI_put_desc(__tail, \""+Arg+"\", "+PNameArg+");"],
  900    {c_set_argument(Spec, out, CNameArg, PNameArg, SetArg)},
  901    [Indent+SetArg+";"].
  902
  903with_wrapper(Ini, Goal, End) -->
  904    [Ini],
  905    call(Goal),
  906    [End].
  907
  908implement_type_unifier(dict_end(SubType, _, Tag), _, Term) -->
  909    {func_pcname(Term, PName, _)},
  910    ["    __rtcheck(PL_unify_nil(__tail));",
  911     "    FI_dict_create("+PName+", \""+Tag+"\", __desc);"],
  912    ( {SubType = union}
  913    ->["        break;",
  914       "    }"]
  915    ; implement_type_end
  916    ).
  917
  918spec_pointer(chrs(_)).
  919spec_pointer(string(_)).
  920spec_pointer(ptr(_)).
  921spec_pointer(pointer-_).
  922spec_pointer(list(_)).
  923spec_pointer(tdef(_, Spec)) :- spec_pointer(Spec).
  924% spec_pointer(type(_)).
  925
  926implement_type_unifier_ini(PName, CName, Name, Spec) -->
  927    { ctype_decl(Spec, Decl),
  928      ( \+ref_type(Spec)
  929      ->DRef = ""
  930      ; DRef = "*"
  931      ),
  932      ctype_suff(Spec, Suff)
  933    },
  934    ["int FI_unify_"+Name+"(term_t "+PName+", "+Decl+DRef+" const "+CName+Suff+") {"].
  935
  936apply_name(Name=Value) :-
  937    camel_snake(Name, Arg),
  938    ignore(Value=Arg).
  939
  940apply_dict(Head, Dict) :-
  941    maplist(apply_name, Dict),
  942    term_variables(Head, Vars),
  943    fg_numbervars(Vars, 1, Dict).
  944
  945fg_numbervars([], _, _).
  946fg_numbervars([V|Vs], N, Dict) :-
  947    format(atom(T), "var_~d", [N]),
  948    succ(N, N1),
  949    ( memberchk(_=T, Dict)
  950    ->fg_numbervars([V|Vs], N1, Dict)
  951    ; V=T,
  952      fg_numbervars(Vs, N1, Dict)
  953    ).
  954
  955bind_type_names(MType, TGlobL, TypeMPropLDictL) :-
  956    predicate_property(MType, interpreted),
  957    strip_module(MType, _, Type),
  958    findall(t(Type, MPropL, TGlobL, Dict),
  959            bind_tn_clause(MType, MPropL, Dict),
  960            TypeMPropLDictL).
  961
  962:- meta_predicate
  963    bind_tn_clause(0, -, -).  964
  965bind_tn_clause(MType, MPropL, Dict) :-
  966    strip_module(MType, M, Type),
  967    catch(clause(MType, Body, Ref), _, fail),
  968    ( clause_property(Ref, file(File)),
  969      clause_property(Ref, line_count(Line)),
  970      get_dictionary(Type :- Body, File, Line, M, Dict)
  971    ->true
  972    ; Dict = []
  973    ),
  974    clause_property(Ref, module(CM)),
  975    sequence_list(Body, PropL, []),
  976    maplist(cond_qualify_with(CM), PropL, MPropL).
  977
  978ds_union_ini(SubType, Name, TPDL1) -->
  979    { TPDL1 = [TPD1|_],
  980      TPD1 = t(Type1, _, _, _),
  981      Type1 =.. Args1,
  982      append(Left, [_], Args1),
  983      append(Left, ["NUM"], ArgsN),
  984      TypeN =.. ArgsN,
  985      TPDN = t(TypeN, _, _, _),
  986      append(TPDL1, [TPDN], TPDL),
  987      !
  988    },
  989    foldil(ds_union_ini_1(SubType, Name), 0, TPDL).
  990
  991ds_union_ini_1(SubType, Name, Idx, t(Type, _, _, _)) -->
  992    { functor(Type, _, N),
  993      arg(N, Type, Term),
  994      ( SubType = enum
  995      ->format(codes(Codes), "~w", [Term]),
  996        sanitize_csym(Codes, [], CName, []),
  997        atom_codes(TName, CName),
  998        Elem = Name+"_"+TName
  999      ; enum_elem(Name, Term, Elem)
 1000      )
 1001    },
 1002    ["    "+Elem+" = "+Idx+","].
 1003
 1004sanitize_csym([],    _ ) --> [].
 1005sanitize_csym([C|L], S1) -->
 1006    ( {type_char(csym, C)}
 1007    ->S1,
 1008      [C],
 1009      {S = []}
 1010    ; [],
 1011      {S = [0'_|S1]}
 1012    ),
 1013    sanitize_csym(L, S).
 1014
 1015declare_struct_union_ini(union, Spec, TPDL, Name) -->
 1016    ["typedef enum {"],
 1017    ds_union_ini(union, Name, TPDL),
 1018    ["} "+Name+"_utype;"],
 1019    {ctype_ini(Spec, Decl)},
 1020    [Decl+" {",
 1021     "  "+Name+"_utype utype;",
 1022     "  union {"
 1023    ].
 1024declare_struct_union_ini(cdef, _, _, _) --> [].
 1025declare_struct_union_ini(struct, _, _, _) --> [].
 1026declare_struct_union_ini(enum, Spec, TPDL, Name) -->
 1027    {ctype_ini(Spec, CIni)},
 1028    [CIni+" {"],
 1029    ds_union_ini(enum, Name, TPDL),
 1030    {ctype_end(Spec, CEnd)},
 1031    ["}"+CEnd+";"].
 1032
 1033declare_struct_union_end(union, Spec) -->
 1034    {ctype_end(Spec, CEnd)},
 1035    ["  };",
 1036     "}"+CEnd+";"
 1037    ].
 1038declare_struct_union_end(cdef,   _) --> [].
 1039declare_struct_union_end(struct, _) --> [].
 1040declare_struct_union_end(enum,   _) --> [].
 1041
 1042declare_struct(union_ini(SubType, Spec, TPDL), _, Name) -->
 1043    declare_struct_union_ini(SubType, Spec, TPDL, Name).
 1044declare_struct(union_end(SubType, Spec), _, _) -->
 1045    declare_struct_union_end(SubType, Spec).
 1046declare_struct(atomic(SubType, Name), Spec, Term) -->
 1047    { ctype_decl(Spec, Decl),
 1048      ctype_suff(Spec, Suff)
 1049    },
 1050    ( {SubType = union}
 1051    ->{functor(Term, TName, _)},
 1052      ["    "+Decl+" "+TName+Suff+";"]
 1053    ; ["typedef "+Decl+" "+Name+Suff+";"]
 1054    ).
 1055declare_struct(func_ini(SubType, Spec), Term, _) -->
 1056    ( {SubType = union,
 1057       atom(Term)
 1058      }
 1059    ->[]
 1060    ; ( {SubType = union}
 1061      ->{Decl = "  struct"}
 1062      ; {ctype_ini(Spec, Decl)}
 1063      ),
 1064      [Decl+" {"]
 1065    ).
 1066declare_struct(func_end(SubType, Spec), Term, _) -->
 1067    ( {SubType = union,
 1068       atom(Term)
 1069      }
 1070    ->[]
 1071    ; ( {SubType = union}
 1072      ->{enum_suff(Term, TName)},
 1073        ["    } "+TName+";"]
 1074      ; {ctype_end(Spec, Decl)},
 1075        ["}"+Decl+";"]
 1076      )
 1077    ).
 1078declare_struct(func_rec(_, _, _, _), Spec, Name) -->
 1079    { ctype_decl(Spec, Decl),
 1080      ctype_suff(Spec, Suff)
 1081    },
 1082    ["    "+Decl+" "+Name+Suff+";"].
 1083%%
 1084declare_struct(dict_ini(_, _, _, _), Spec, _) -->
 1085    {ctype_ini(Spec, Decl)},
 1086    ["",
 1087     Decl+" {"].
 1088declare_struct(dict_key_value(Dict, Desc, N, _), Key, Value) -->
 1089    {key_value_from_desc(Dict, Desc, N, Key, Value)}.
 1090declare_struct(dict_rec(_, _, _, _, _), Spec, Name) -->
 1091    { ctype_decl(Spec, Decl),
 1092      ctype_suff(Spec, Suff)
 1093    },
 1094    ["    "+Decl+" "+Name+Suff+";"].
 1095declare_struct(dict_end(_, _, _), Spec, _) -->
 1096    {ctype_end(Spec, Decl)},
 1097    ["}"+Decl+";"].
 1098
 1099declare_type_union_ini(union, Opt, Name, Spec) -->  declare_type(Opt, Name, Spec).
 1100declare_type_union_ini(enum,  Opt, Name, Spec) -->  declare_type(Opt, Name, Spec).
 1101declare_type_union_ini(cdef,   _, _, _) --> [].
 1102declare_type_union_ini(struct, _, _, _) --> [].
 1103
 1104declare_type(Opt, Data, Type, Name) --> declare_type_(Data, Opt, Type, Name).
 1105
 1106declare_type_(atomic(_, _), _, _, _) --> [].
 1107declare_type_(union_ini(SubType, Spec, _), Opt, _, Name) -->
 1108    declare_type_union_ini(SubType, Opt, Name, Spec).
 1109declare_type_(union_end(_, _), _, _, _) --> [].
 1110declare_type_(func_ini(SubType, Spec), Opt, _, Name) -->
 1111    ( {SubType = union}
 1112    ->[]
 1113    ; declare_type(Opt, Name, Spec)
 1114    ).
 1115declare_type_(func_end(_, _), _, _, _) --> [].
 1116declare_type_(func_rec(_, _, _, _), _, _, _) --> [].
 1117declare_type_(dict_ini(_, Name, M, _), _, _, _) -->
 1118    ["predicate_t __"+M+"_aux_keyid_index_"+Name+";"].
 1119declare_type_(dict_end(_, _, _), _, _, _) --> [].
 1120declare_type_(dict_rec(_, _, _, _, _), _, _, _) --> [].
 1121
 1122declare_type(gett, Name, Spec) -->
 1123    { ctype_decl(Spec, Decl1),
 1124      ( Spec = array(_, _)
 1125      ->Decl = Decl1
 1126      ; Decl = Decl1+"*"
 1127      )
 1128    },
 1129    ["int FI_get_"+Name+"(root_t __root, term_t, "+Decl+");"].
 1130declare_type(unif, Name, Spec) -->
 1131    { ctype_decl(Spec, Decl1),
 1132      ( \+ref_type(Spec)
 1133      ->DRef = Decl1
 1134      ; DRef = Decl1+"*"
 1135      )
 1136    },
 1137    ["int FI_unify_"+Name+"(term_t, "+DRef+" const);"].
 1138
 1139generate_aux_clauses(Module) -->
 1140    findall_tp(Module, type_props, generate_aux_clauses).
 1141
 1142% This will create an efficient method to convert keys to indexes in the C side,
 1143% avoiding string comparisons.
 1144generate_aux_clauses(dict_ini(_, Name, _, _), _, _) -->
 1145    !,
 1146    {atom_concat('__aux_keyid_index_', Name, F)},
 1147    [(:- public F/2)].
 1148generate_aux_clauses(dict_key_value(Dict, _, N, _), Key, Value) -->
 1149    !,
 1150    {key_value_from_dict(Dict, N, Key, Value)}.
 1151generate_aux_clauses(dict_rec(_, _, _, N, Name), _, Key) -->
 1152    !,
 1153    { atom_concat('__aux_keyid_index_', Name, F),
 1154      Pred =.. [F, Key, N]
 1155    },
 1156    [(Pred :- true)].
 1157generate_aux_clauses(_, _, _) --> [].
 1158
 1159:- multifile
 1160    prolog:message//1. 1161
 1162prolog:message(ignored_type(Name, Arg)) -->
 1163    ["~w->~w ignored"-[Name, Arg]].
 1164
 1165prolog:message(failed_binding(TypeComponents)) -->
 1166    ["~w failed"-[TypeComponents]].
 1167
 1168:- meta_predicate type_components(+,+,5,+,?,?). 1169
 1170type_components(M, TypePropLDictL, Call, Loc) -->
 1171    foldl(type_components_1(M, Call, Loc), TypePropLDictL).
 1172
 1173type_components_1(M, Call, Loc, Type-TypePropLDictL) -->
 1174    { functor(Type, Name, _),
 1175      ( TypePropLDictL = [t(_, [], _, _)]
 1176      ->SubType = cdef,
 1177        Spec = cdef(Name)
 1178      ; forall(member(t(Type, PropL, _, _), TypePropLDictL), PropL = [])
 1179      ->SubType = enum,
 1180        length(TypePropLDictL, N),
 1181        ( member(t(_, _, GlobL, _), TypePropLDictL),
 1182          member(Glob, GlobL),
 1183          normalize_ftgen(Glob, tgen(Opts, _)),
 1184          nmember(tdef, Opts)
 1185        ->Spec = tden(Name, N)
 1186        ; Spec = enum(Name, N)
 1187        )
 1188      ; ( member(t(_, _, GlobL, _), TypePropLDictL),
 1189          member(Glob, GlobL),
 1190          normalize_ftgen(Glob, tgen(Opts, _)),
 1191          nmember(tdef, Opts)
 1192        ->Spec = tdfstr(Name)
 1193        ; Spec = struct(Name)
 1194        ),
 1195        ( TypePropLDictL = [_, _|_]
 1196        ->SubType = union,
 1197          ISpec = struct(Name)
 1198        ; SubType = struct,
 1199          ISpec = Spec
 1200        )
 1201      )
 1202    },
 1203    call(Call, union_ini(SubType, Spec, TypePropLDictL), Type, Name),
 1204    foldl(type_components_one(M, SubType, ISpec, Name, Call, Loc), TypePropLDictL),
 1205    call(Call, union_end(SubType, Spec), Type, Name).
 1206
 1207type_components_one(M, SubType, TSpec, Name, Call, Loc, t(Type, PropL, _, _)) -->
 1208    { functor(Type, _, Arity),
 1209      arg(Arity, Type, Term)
 1210    },
 1211    ( { PropL = [],
 1212        SubType \= union
 1213      }
 1214    ->[]
 1215    ; { compound(Term)
 1216      ; atom(Term),
 1217        SubType = union
 1218      }
 1219    ->call(Call, func_ini(SubType, TSpec), Term, Name),
 1220      ( {compound(Term)}
 1221      ->findall(Lines,
 1222                ( arg(N, Term, Arg),
 1223                  phrase(( { member(Prop, PropL),
 1224                             match_known_type(Prop, M, Name, Spec, Arg)
 1225                           },
 1226                           call(Call, func_rec(SubType, N, Term, Name), Spec, Arg)
 1227                         ->[]
 1228                         ; {print_message(
 1229                                warning,
 1230                                at_location(Loc, ignored_type(func(Name), Arg)))}
 1231                         ), Lines)
 1232                ))
 1233      ; { atom(Term),
 1234          SubType = union,
 1235          PropL = [Prop]
 1236        }
 1237      ->( { match_known_type(Prop, M, Name, Spec, Arg)
 1238          },
 1239          call(Call, func_rec(union_type, 1, Term, Name), Spec, Arg)
 1240        ->[]
 1241        ; {print_message(
 1242               warning,
 1243               at_location(Loc, ignored_type(func(Name), _)))}
 1244        )
 1245      ; []
 1246      ),
 1247      call(Call, func_end(SubType, TSpec), Term, Name)
 1248    ; { select(dict_t(Desc, Term), PropL, PropL1)
 1249      ; select(dict_t(Tag, Desc, Term), PropL, PropL1)
 1250      ; select(dict_join_t(Tag, Type1, Type2, Term), PropL, PropL1),
 1251        join_dict_types(Type1, M, Type2, M, Tag, Desc)
 1252      ; select(dict_extend_t(Term, Type, Tag, Desc2), PropL, PropL1),
 1253        join_type_desc(M:Type, Tag, Desc2, Desc)
 1254      }
 1255    ->{ is_dict(Desc, Tag)
 1256      ->Dict=Desc
 1257      ; dict_create(Dict, Tag, Desc)
 1258      },
 1259      {ignore(Tag = Name)},
 1260      call(Call, dict_ini(SubType, Name, M, Dict), TSpec, Term),
 1261      findall(Lines,
 1262              phrase(( call(Call, dict_key_value(Dict, Desc, N, Name), Arg, Value),
 1263                       ( { fetch_kv_prop_arg(Arg,  M, Value, PropL1, Prop),
 1264                           match_known_type(Prop, M, Name, Spec, Arg)
 1265                         },
 1266                         call(Call, dict_rec(SubType, M, Term, N, Name), Spec, Arg)
 1267                       ->[]
 1268                       ; {print_message(
 1269                              warning,
 1270                              at_location(Loc, ignored_type(dict(Name), Arg)))}
 1271                       )), Lines)),
 1272      call(Call, dict_end(SubType, M, Tag), TSpec, Term)
 1273    ; { member(Prop, PropL),
 1274        match_known_type(Prop, M, Name, Spec, Term)
 1275      }
 1276    ->call(Call, atomic(SubType, Name), Spec, Term)
 1277    ),
 1278    !.
 1279type_components_one(M, ST, TS, N, G, Loc, T) -->
 1280    {print_message(
 1281         error,
 1282         at_location(
 1283             Loc,
 1284             failed_binding(type_components_one(M, ST, TS, N, G, Loc, T))))}.
 1285
 1286key_value_from_dict(Dict, N, Key, Value) :-
 1287    S = s(0),
 1288    Value=Dict.Key,
 1289    S = s(N),
 1290    succ(N, N2),
 1291    nb_setarg(1, S, N2).
 1292
 1293key_value_from_list(Desc, N, Key, Value) :-
 1294    nth0(N, Desc, KeyValue),
 1295    key_value(KeyValue, Key, Value).
 1296
 1297key_value_from_desc(_, Desc, N, Key, Value) :-
 1298    is_list(Desc), !,
 1299    key_value_from_list(Desc, N, Key, Value).
 1300key_value_from_desc(Dict, _, N, Key, Value) :-
 1301    key_value_from_dict(Dict, N, Key, Value).
 1302
 1303fetch_kv_prop_arg(Key, CM, Value, PropL, M:Prop) :-
 1304    ( member(MProp, PropL),
 1305      strip_module(CM:MProp, M, Prop),
 1306      functor(Prop, _, N),
 1307      arg(N, Prop, Key)
 1308    ; extend_args(Value, [Key], Prop),
 1309      M=CM
 1310    ).
 1311
 1312declare_intf_head(PCN, Head, "foreign_t __aux_pfa_"+PCN+"_"+N+"(term_t __args)") :-
 1313    max_fli_args(MaxFLIArgs),
 1314    functor(Head, _, N),
 1315    N > MaxFLIArgs,
 1316    !.
 1317declare_intf_head(PCN, Head, "foreign_t "+PCN+"("+TxtL/", "+")") :-
 1318    findall("term_t "+Arg,
 1319            ( compound(Head),
 1320              arg(_, Head, Arg)
 1321            ), TxtL).
 1322
 1323declare_foreign_bind(CM) -->
 1324    findall(Line+";",
 1325            ( read_foreign_properties(Head, M, CM, Comp, Call, Succ, Glob, Bind, Type),
 1326              \+ ( Type = foreign(Opts, _),
 1327                   nmember(lang(native), Opts)
 1328                 ),
 1329              declare_impl_head(Type, Head, M, CM, Comp, Call, Succ, Glob, Bind, Line)
 1330            )).
 1331
 1332declare_impl_head(foreign(Opts, _), Head, _, _, _, _, _, _, Bind, IntfHead) :-
 1333    nmember(lang(native), Opts),
 1334    !,
 1335    Bind = (FN/_ as _/_ + _),
 1336    declare_intf_head(FN, Head, IntfHead).
 1337declare_impl_head(_, Head, M, CM, Comp, Call, Succ, Glob, (CN/_ as _ + _), Type+FHD) :-
 1338    nonvar(CN),
 1339    ( member(RS, [returns_state(_), type(_)]),
 1340      memberchk(RS, Glob)
 1341    ->Type = "int ",       % int to avoid SWI-Prolog.h dependency at this level
 1342      CHead = Head
 1343    ; member(returns(Var, _), Glob)
 1344    ->bind_argument(Head, M, CM, Comp, Call, Succ, Glob, Var, Spec, Mode),
 1345      ctype_arg_decl(Spec, Mode, Decl),
 1346      Type = Decl+" ",
 1347      Head =.. [F|Args],
 1348      once(select(Var, Args, CArgs)),
 1349      CHead =.. [F|CArgs]
 1350    ; Type = "void ",
 1351      CHead = Head
 1352    ),
 1353    declare_foreign_head(CHead, M, CM, Comp, Call, Succ, Glob, CN, FHD),
 1354    !.
 1355
 1356declare_foreign_head(Head, M, CM, Comp, Call, Succ, Glob, CN, CN+"("+ArgL/", "+")") :-
 1357    phrase(( ( {memberchk(memory_root(_), Glob)}
 1358             ->["root_t __root"]
 1359             ; []
 1360             ),
 1361             findall(
 1362                 Line,
 1363                 distinct(
 1364                     Key,
 1365                     ( compound(Head),
 1366                       arg(_, Head, Arg),
 1367                       bind_argument(Head, M, CM, Comp, Call, Succ, Glob, Arg, Spec, Mode),
 1368                       curr_arg_decl(Arg, Spec, Mode, Key-Line)
 1369                     )))
 1370           ), ArgL).
 1371
 1372extra_arg_decl(array(Spec, Dim), KeyLine) :-
 1373    ( \+ integer(Dim),
 1374      curr_arg_decl(Dim, size_t-size_t, in, KeyLine)
 1375    ; extra_arg_decl(Spec, KeyLine)
 1376    ).
 1377
 1378curr_arg_decl(_, Spec, Mode, KeyLine) :-
 1379    memberchk(Mode, [in, inout]),
 1380    extra_arg_decl(Spec, KeyLine).
 1381curr_arg_decl(Arg, Spec, Mode, Arg-(Decl+" "+Arg+Suff)) :-
 1382    ctype_barg_decl(Spec, Mode, Decl),
 1383    ctype_barg_suff(Spec, Suff).
 1384
 1385ctype_barg_decl(Spec, Mode, Decl) :-
 1386    ctype_barg_decl(Spec, Mode, Codes, []),
 1387    atom_codes(Decl, Codes).
 1388
 1389ctype_barg_suff(Spec, Suff) :-
 1390    ctype_suff(Spec, Codes, []),
 1391    atom_codes(Suff, Codes).
 1392
 1393ctype_barg_decl(Spec, Mode) -->
 1394    ctype_arg_decl(Spec, Mode),
 1395    ({ Mode = in,
 1396       \+ ref_type(Spec)
 1397     ; Spec = array(_, _)
 1398     } -> []
 1399    ; "*"
 1400    ),
 1401    ( {Mode = in}
 1402    ->" const"
 1403    ; []
 1404    ). % Ensure const correctness
 1405
 1406ctype_arg_decl(Spec, Mode) -->
 1407    ctype_decl(Spec),
 1408    ({is_ref(Spec, Mode)} -> [] ; "*").
 1409
 1410ctype_arg_decl(Spec, Mode, Decl) :-
 1411    ctype_arg_decl(Spec, Mode, Codes, []),
 1412    atom_codes(Decl, Codes).
 1413
 1414
 1415ctype_suff(array(Spec, Dim), CDim) --> "[", call(CDim, Dim), "]", ctype_suff(Spec, CDim).
 1416ctype_suff(Spec, _) -->
 1417    {member(Spec, [list(_), ptr(_), chrs(_), string(_), tdfstr(_), struct(_), term,
 1418                   tden(_, _), enum(_, _), tdef(_, _), setof(_, _), cdef(_), _-_])},
 1419    neck.
 1420
 1421ctype_suff(Spec) --> ctype_suff(Spec, acodes).
 1422
 1423is_ref(term,      _) :- !.
 1424is_ref(list(_),   _) :- !.        % Always ref
 1425is_ref(ptr(_),    _) :- !.        % Always ref
 1426is_ref(chrs(_),   _) :- !.
 1427is_ref(string(_), _) :- !.
 1428is_ref(array(_, _), _) :- !.
 1429is_ref(_, in).
 1430is_ref(_, out).
 1431% is_ref(inout, _) :- fail.
 1432% Allow pointer to NULL, the equivalent to free variables in imperative
 1433% languages --EMM
 1434
 1435% Types that are passed by reference
 1436ref_type(struct(_)).
 1437ref_type(tdfstr(_)).
 1438ref_type(tdef(_, Spec)) :- ref_type(Spec).
 1439
 1440ctype_ini(tdfstr(Name))   --> "typedef struct __", acodes(Name), " ", acodes(Name), ";\n",
 1441                              "struct __", acodes(Name).
 1442ctype_ini(struct(Name))   --> "struct ", acodes(Name).
 1443ctype_ini(tden(_, _))     --> "typedef enum".
 1444ctype_ini(enum(Name, _))  --> "enum ", acodes(Name).
 1445ctype_ini(cdef(_))        --> "".
 1446
 1447ctype_end(tdfstr(_))      --> "".
 1448ctype_end(struct(_))      --> "".
 1449ctype_end(tden(Name, _))  --> " ", acodes(Name).
 1450ctype_end(enum(_, _))     --> "".
 1451ctype_end(cdef(Name))     --> " ", acodes(Name).
 1452
 1453ctype_decl(list(Spec))     --> ctype_decl(Spec), "*".
 1454ctype_decl(array(Spec, _)) --> ctype_decl(Spec).
 1455ctype_decl(ptr(Spec))      --> ctype_decl(Spec), "*".
 1456ctype_decl(chrs(Name))     --> acodes(Name).
 1457ctype_decl(string(Name))   --> acodes(Name).
 1458ctype_decl(tdfstr(Name))   --> acodes(Name).
 1459ctype_decl(struct(Name))   --> "struct ", acodes(Name).
 1460ctype_decl(tden(Name, _))  --> acodes(Name).
 1461ctype_decl(enum(Name, _))  --> "enum ", acodes(Name).
 1462ctype_decl(term)           --> "term_t".
 1463ctype_decl(tdef(Name, _))  --> acodes(Name).
 1464ctype_decl(setof(Name, _)) --> acodes(Name).
 1465ctype_decl(cdef(Name))     --> acodes(Name).
 1466ctype_decl(_-CType)        --> acodes(CType).
 1467
 1468ctype_ini(Spec, Decl) :- phrase(ctype_ini(Spec), Codes), atom_codes(Decl, Codes).
 1469ctype_end(Spec, Decl) :- phrase(ctype_end(Spec), Codes), atom_codes(Decl, Codes).
 1470
 1471ctype_decl(Spec, Decl) :-
 1472    ctype_decl(Spec, Codes, []),
 1473    atom_codes(Decl, Codes).
 1474
 1475ctype_suff(Spec, Suff) :-
 1476    ctype_suff(Spec, Codes, []),
 1477    atom_codes(Suff, Codes).
 1478
 1479acodes(Atom, List, Tail) :-
 1480    atom_codes(Atom, Codes),
 1481    append(Codes, Tail, List).
 1482
 1483cond_qualify_with(CM, MProp1, MProp) :-
 1484    strip_module(CM:MProp1, M, Prop),
 1485    ( CM = M
 1486    ->MProp = Prop
 1487    ; MProp = M:Prop
 1488    ).
 1489
 1490:- meta_predicate collect(?,^,-). 1491collect(Tmpl, Goal, List) :-
 1492    (bagof(Tmpl, Goal, List) *-> true ; List = []).
 1493
 1494collect_props(Asr, CM, CompL, CallL, SuccL, GlobL) :-
 1495    maplist(collect_prop(Asr, CM),
 1496            [comp, call, succ, glob],
 1497            [CompL, CallL, SuccL, GlobL]).
 1498
 1499collect_prop(Asr, CM, Part, PropL) :-
 1500    collect(MProp,
 1501            (M, Prop, From)^( curr_prop_asr(Part, M:Prop, From, Asr),
 1502                              ( M \= CM
 1503                              ->MProp = M:Prop
 1504                              ; MProp = Prop
 1505                              )
 1506                            ), PropL).
 1507
 1508assertion_db(Asr, Head, M, CM, Status, Type, Comp, Call, Succ, Glob, Dict) :-
 1509    asr_head_prop(Asr, HM, Head, Status, Type, Dict, CM, _Loc),
 1510    predicate_property(HM:Head, implementation_module(M)),
 1511    collect_props(Asr, CM, Comp, Call, Succ, Glob).
 1512
 1513current_foreign_prop(Head, Module, Context, CompL, CallL, SuccL, GlobL,
 1514                     DictL, FuncName, PredName, BindName, Arity, NKeyProp) :-
 1515    current_foreign_prop(Head, Module, Type, Context, NKeyProp),
 1516    findall(Head-[MComp, MCall, MSucc, MGlob, Dict],
 1517            ( assertion_db(_, Head, Module, CM, check, Type, Comp, Call, Succ, Glob, Dict),
 1518              maplist(maplist(cond_qualify_with(CM)),
 1519                      [ Comp,  Call,  Succ,  Glob],
 1520                      [MComp, MCall, MSucc, MGlob])
 1521            ), KPropLL),
 1522    maplist(=(Head-_), KPropLL),
 1523    pairs_values(KPropLL, PropLL),
 1524    transpose(PropLL, PropTL),
 1525    maplist(append, PropTL, [CompU, CallU, SuccU, GlobU, DictL]),
 1526    maplist(sort, [CompU, CallU, SuccU, GlobU], [CompL, CallL, SuccL, GlobL]),
 1527    functor(Head, PredName, Arity),
 1528    ( member(FGlob, GlobL),
 1529      normalize_ftype(FGlob, foreign(FuncSpecs, _)),
 1530      nmember(FuncSpec, FuncSpecs),
 1531      resolve_name(FuncSpec, PredName, FuncName)
 1532    ->true
 1533    ; true
 1534    ),
 1535    ( ( member(NGlob, GlobL),
 1536        normalize_ftype(NGlob, native(BindSpecs, _)),
 1537        nmember(BindSpec, BindSpecs),
 1538        Name = PredName
 1539      ; nonvar(FuncName),
 1540        BindSpec = prefix(pl_),
 1541        Name = FuncName
 1542      ),
 1543      resolve_name(BindSpec, Name, BindName)
 1544    ->true
 1545    ).
 1546
 1547current_foreign_prop(Head, Module, Type, Context, NKeyProp) :-
 1548    asr_head_prop(Asr, HM, Head, check, Type, _, Context, _),
 1549    memberchk(Type, [pred, prop]),
 1550    predicate_property(HM:Head, implementation_module(Module)),
 1551    once(( normalize_ftype(KeyProp, NKeyProp),
 1552           prop_asr(glob, KeyProp, _, Asr)
 1553         )).
 1554
 1555resolve_name(BindName,       _,        BindName) :- atom(BindName), !.
 1556resolve_name(name(BindName), _,        BindName).
 1557resolve_name(prefix(Prefix), PredName, BindName) :- atom_concat(Prefix, PredName, BindName).
 1558resolve_name(suffix(Suffix), PredName, BindName) :- atom_concat(PredName, Suffix, BindName).
 1559
 1560read_foreign_properties(Head, M, CM, Comp, Call, Succ, Glob, CN/A as PN/BN + CheckMode, T) :-
 1561    current_foreign_prop(Head, M, CM, Comp, Call, Succ, Glob, Dict, CN, PN, BN, A, T),
 1562    ( memberchk(type(_), Glob)
 1563    ->CheckMode=(type)
 1564    ; CheckMode=pred
 1565    ),
 1566    apply_dict(Head, Dict).
 1567
 1568generate_foreign_intf(CM) -->
 1569    findall(Lines,
 1570            ( read_foreign_properties(Head, M, CM, Comp, Call, Succ, Glob, Bind, Type),
 1571              declare_impl_head(Type, Head, M, CM, Comp, Call, Succ, Glob, Bind, ImplHead),
 1572              phrase(declare_intf_impl(Type, Head, M, CM, Comp, Call, Succ, Glob, Bind, ImplHead),
 1573                     Lines))).
 1574
 1575declare_intf_impl(foreign(Opts, _), Head, M, Module, Comp, Call, Succ, Glob, Bind, ImplHead) -->
 1576    { nmember(lang(Lang), Opts),
 1577      lang(Lang)
 1578    },
 1579    !,
 1580    declare_fimp_impl(Lang, Head, M, Module, Comp, Call, Succ, Glob, Bind, ImplHead).
 1581declare_intf_impl(_, Head, M, Module, Comp, Call, Succ, Glob, Bind, ImplHead) -->
 1582    declare_forg_impl(Head, M, Module, Comp, Call, Succ, Glob, Bind, ImplHead).
 1583
 1584declare_fimp_impl(prolog, Head, M, CM, Comp, Call, Succ, Glob, Bind, ImplHead) -->
 1585    { Bind = (_/A as PN/BN + _),
 1586      declare_intf_fimp_head(BN, BNHead)
 1587    },
 1588    [BNHead+"=NULL;"],
 1589    [ImplHead+" {",
 1590     "    term_t "+BN+"_args = PL_new_term_refs("+A+");"],
 1591    ( {memberchk(parent(Var, _), Glob)}
 1592    ->["    __leaf_t *__root = LF_ROOT(LF_PTR(FI_array_ptr("+Var+")));"]
 1593    ; []
 1594    ),
 1595    bind_outs_arguments(Head, M, CM, Comp, Call, Succ, Glob, Bind),
 1596    ["} /* "+PN/A+" */",
 1597     ""].
 1598declare_fimp_impl(native, Head, _, CM, _, _, _, Glob, Bind, ImplHead) -->
 1599    { Bind = (FN/A as _/BN + _),
 1600      declare_intf_fimp_head(BN, BNHead)
 1601    },
 1602    [BNHead+"=NULL;"],
 1603    [ImplHead+" {",
 1604     "    term_t "+BN+"_args = PL_new_term_refs("+A+");"],
 1605    findall(["    __rtcheck(PL_unify_arg("+Idx+","+BN+"_args,"+Arg+"));"], arg(Idx, Head, Arg)),
 1606    bind_call_predicate(CM, Glob, BN),
 1607    ["} /* "+FN/A+" */",
 1608     ""].
 1609
 1610bind_call_predicate(CM, Glob, BN) -->
 1611    {CallPred = "PL_call_predicate(__"+CM+", PL_Q_NORMAL, "+BN+", "+BN+"_args)"},
 1612    ( { member(RS, [returns_state(_), type(_)]),
 1613        memberchk(RS, Glob)
 1614      }
 1615    ->["    int __result = "+CallPred+";"]
 1616    ; ["    __rtcwarn("+CallPred+");"]
 1617    ).
 1618
 1619declare_forg_impl(Head, M, Module, Comp, Call, Succ, Glob, Bind, _ImplHead) -->
 1620    { max_fli_args(MaxFLIArgs),
 1621      necks,
 1622      Bind = (PI as _/PCN + CheckMode),
 1623      declare_intf_head(PCN, Head, PCNH)
 1624    },
 1625    [PCNH+" {"],
 1626    ( { functor(Head, _, Arity),
 1627        Arity > MaxFLIArgs
 1628      }
 1629    ->findall(["    term_t "+Arg+" = PL_new_term_ref();",
 1630               "    __rtcheck(PL_get_arg("+N+", __args, "+Arg+"));"],
 1631              arg(N, Head, Arg))
 1632    ; []
 1633    ),
 1634    % If is variable then succeed (because is compatible)
 1635    findall("    if(PL_is_variable("+Arg+")) return TRUE;",
 1636            ( CheckMode==(type),
 1637              arg(_, Head, Arg)
 1638            )),
 1639    ["    __mkroot(__root);"],
 1640    bind_arguments(Head, M, Module, Comp, Call, Succ, Glob, Bind, Return),
 1641    ["    __delroot(__root);",
 1642     "    return "+Return+";",
 1643     "} /* "+PI+" */",
 1644     ""].
 1645
 1646c_set_argument(list(S),     _, C, A, L) :- c_set_argument_rec(list, S, C, A, L).
 1647c_set_argument(array(S, D), _, C, A, L) :- c_set_argument_array(S, D, C, A, L).
 1648c_set_argument(ptr(S),      _, C, A, L) :- c_set_argument_rec(ptr, S, C, A, L).
 1649c_set_argument(tdfstr(T),   M, C, A, L) :- c_set_argument_type(M, T, C, A, L).
 1650c_set_argument(struct(T),   M, C, A, L) :- c_set_argument_type(M, T, C, A, L).
 1651c_set_argument(tden(T, _),  M, C, A, L) :- c_set_argument_one(M, T, C, A, L).
 1652c_set_argument(enum(T, _),  M, C, A, L) :- c_set_argument_one(M, T, C, A, L).
 1653c_set_argument(cdef(T),     M, C, A, L) :- c_set_argument_one(M, T, C, A, L).
 1654c_set_argument(T-_,         M, C, A, L) :- c_set_argument_one(M, T, C, A, L).
 1655c_set_argument(chrs(_),     M, C, A, L) :- c_set_argument_chrs(M, C, A, L).
 1656c_set_argument(string(_),   M, C, A, L) :- c_set_argument_string(M, C, A, L).
 1657c_set_argument(tdef(_, S),  M, C, A, L) :- c_set_argument(S, M, C, A, L).
 1658c_set_argument(setof(_, S), M, C, A, L) :- c_set_argument_setof(M, S, C, A, L).
 1659c_set_argument(term,        _, C, A, "__rtcheck(PL_unify("+A+", "+C+"))").
 1660
 1661c_set_argument_one(out,   Type, CArg, Arg, "__rtc_FI_unify("+Type+", "+Arg+", "+CArg+")").
 1662c_set_argument_one(inout, Type, CArg, Arg, "FI_unify_inout("+Type+", "+Arg+", "+CArg+")").
 1663
 1664c_set_argument_type(out,   Type, CArg, Arg, "__rtc_FI_unify("+Type+", "+Arg+", &"+CArg+")").
 1665c_set_argument_type(inout, Type, CArg, Arg, "FI_unify_inout_type("+Type+", "+Arg+", "+CArg+")").
 1666
 1667c_set_argument_chrs(out,   CArg, Arg, "__rtc_FI_unify(chrs, "+Arg+", "+CArg+")").
 1668c_set_argument_chrs(inout, CArg, Arg, "FI_unify_inout_chrs("+Arg+", "+CArg+")").
 1669
 1670c_set_argument_string(out,   CArg, Arg, "__rtc_FI_unify(string, "+Arg+", "+CArg+")").
 1671c_set_argument_string(inout, CArg, Arg, "FI_unify_inout_string("+Arg+", "+CArg+")").
 1672
 1673c_set_argument_array(Spec, Dim, CArg, Arg, "FI_unify_array("+L+", "+CDim+", "+Arg+")") :-
 1674    Arg_ = Arg+"_",
 1675    c_var_name(Arg_, CArg_),
 1676    c_dim(Dim, CDim),
 1677    c_set_argument(Spec, out, CArg+"["+CArg_+"]", Arg_, L).
 1678
 1679c_set_argument_rec(Type, Spec, CArg, Arg, "FI_unify_"+Type+"("+L+", "+Arg+", "+CArg+")") :-
 1680    Arg_ = Arg+"_",
 1681    c_var_name(Arg_, CArg_),
 1682    c_set_argument(Spec, out, CArg_, Arg_, L).
 1683
 1684c_set_argument_setof(Mode, Spec, CArg, Arg, "FI_unify_"+Mode+"_setof("+L+", "+Type+", "+Arg+", "+CArg+")") :-
 1685    Arg_ = Arg+"_",
 1686    c_var_name(Arg_, CArg_),
 1687    ctype_decl(Spec, Type),
 1688    c_set_argument(Spec, out, CArg_, Arg_, L).
 1689
 1690c_get_argument(list(S),     M, C, A, L) :- c_get_argument_rec(M, list, S, C, A, L).
 1691c_get_argument(array(S, D), _, C, A, L) :- c_get_argument_array(S, D, C, A, L).
 1692c_get_argument(ptr(S),      M, C, A, L) :- c_get_argument_rec(M, ptr,  S, C, A, L).
 1693c_get_argument(tdfstr(T),   M, C, A, L) :- c_get_argument_type(M, T, C, A, L).
 1694c_get_argument(struct(T),   M, C, A, L) :- c_get_argument_type(M, T, C, A, L).
 1695c_get_argument(tden(T, _),  M, C, A, L) :- c_get_argument_one(M, T, C, A, L).
 1696c_get_argument(enum(T, _),  M, C, A, L) :- c_get_argument_one(M, T, C, A, L).
 1697c_get_argument(cdef(T),     M, C, A, L) :- c_get_argument_one(M, T, C, A, L).
 1698c_get_argument(T-_,         M, C, A, L) :- c_get_argument_one(M, T, C, A, L).
 1699c_get_argument(chrs(_),     M, C, A, L) :- c_get_argument_chrs(M, C, A, L).
 1700c_get_argument(string(_),   M, C, A, L) :- c_get_argument_string(M, C, A, L).
 1701c_get_argument(tdef(_, S),  M, C, A, L) :- c_get_argument(S, M, C, A, L).
 1702c_get_argument(setof(_, S), M, C, A, L) :- c_get_argument_setof(M, S, C, A, L).
 1703c_get_argument(term,        _, C, A, "*"+C+"=PL_copy_term_ref("+A+")").
 1704
 1705c_get_argument_one(in, Type, CArg, Arg, "__rtc_FI_get("+Type+", "+Arg+", "+CArg+")").
 1706c_get_argument_one(inout, Type, CArg, Arg, "FI_get_inout("+Type+", "+Arg+", "+CArg+")").
 1707
 1708c_get_argument_type(in, Type, CArg, Arg, "__rtc_FI_get("+Type+", "+Arg+", "+CArg+")").
 1709c_get_argument_type(inout, Type, CArg, Arg, "FI_get_inout("+Type+", "+Arg+", "+CArg+")").
 1710
 1711c_get_argument_chrs(in, CArg, Arg, "__rtc_FI_get(chrs, "+Arg+", "+CArg+")").
 1712c_get_argument_chrs(inout, CArg, Arg, "FI_get_inout_chrs("+Arg+", "+CArg+")").
 1713
 1714c_get_argument_string(in, CArg, Arg, "__rtc_FI_get(string, "+Arg+", "+CArg+")").
 1715c_get_argument_string(inout, CArg, Arg, "FI_get_inout_string("+Arg+", "+CArg+")").
 1716
 1717c_get_argument_array(Spec, Dim, CArg, Arg, "FI_get_array("+L+","+CDim+", "+Arg+")") :-
 1718    Arg_ = Arg+"_",
 1719    c_var_name(Arg_, CArg_),
 1720    c_dim(Dim, CDim),
 1721    c_get_argument(Spec, in, CArg+"["+CArg_+"]", Arg_, L).
 1722
 1723c_get_argument_rec(Mode, Type, Spec, CArg, Arg,
 1724                   "FI_get_"+Mode+"_"+Type+"("+L+", "+Arg+", "+CArg+")") :-
 1725    Arg_ = Arg+"_",
 1726    c_var_name(Arg_, CArg_),
 1727    c_get_argument(Spec, in, CArg_, Arg_, L).
 1728
 1729c_get_argument_setof(Mode, Spec, CArg, Arg,
 1730                     "FI_get_"+Mode+"_setof("+L+", "+Type+", "+Arg+", "+CArg+")") :-
 1731    Arg_ = Arg+"_",
 1732    c_var_name(Arg_, CArg_),
 1733    ctype_decl(Spec, Type),
 1734    c_get_argument(Spec, in, CArg_, Arg_, L).
 1735
 1736c_dim(Dim) --> {integer(Dim)}, !, acodes(Dim).
 1737c_dim(Dim) --> "_c_", acodes(Dim).
 1738
 1739c_dim(Dim, CDim) :-
 1740    c_dim(Dim, Codes, []),
 1741    atom_codes(CDim, Codes).
 1742
 1743ctype_c_suff(Spec) --> ctype_suff(Spec, c_dim).
 1744
 1745ctype_c_suff(Spec, Suff) :-
 1746    ctype_c_suff(Spec, Codes, []),
 1747    atom_codes(Suff, Codes).
 1748
 1749extra_var_def(array(Spec, Dim), Head, Arg, KeyLine) :-
 1750    ( \+ integer(Dim),
 1751      curr_bind_line(dim(Arg), Head, Dim, size_t-size_t, in, KeyLine)
 1752    ; extra_var_def(Spec, Head, Arg+"_"+Dim, KeyLine)
 1753    ).
 1754
 1755curr_bind_line(arg, Head, Arg, Spec, Mode, KeyLine) :-
 1756    memberchk(Mode, [in, inout]),
 1757    extra_var_def(Spec, Head, Arg, KeyLine).
 1758curr_bind_line(_, _, Arg, Spec, Mode, dec(Arg)-Line) :-
 1759    ctype_arg_decl(Spec, Mode, Decl),
 1760    c_var_name(Arg, CArg),
 1761    ( Spec = term
 1762    ->DN=" "+CArg+"=PL_new_term_ref();"
 1763    ; ctype_c_suff(Spec, CSuff),
 1764      DN=" "+CArg+CSuff+";"
 1765    ),
 1766    Line = "    "+Decl+DN.
 1767curr_bind_line(arg, _, Arg, Spec, Mode, KeyLine) :-
 1768    memberchk(Mode, [in, inout]),
 1769    c_var_name(Arg, CArg1),
 1770    CArg = "&"+CArg1,
 1771    c_get_argument(Spec, Mode, CArg, Arg, GetArg),
 1772    KeyLine = def(Arg)-["    "+GetArg+";"].
 1773curr_bind_line(dim(Arg), Head, Dim, _, _, def(CDim1)-LineL) :-
 1774    \+ arg(_, Head, Dim),
 1775    c_var_name(Dim, CDim1),
 1776    CDim = "&"+CDim1,
 1777    Line = "    FI_get_dim("+Arg+", "+CDim+");",
 1778    ( arg(_, Head, Arg)
 1779    ->LineL = [Line]
 1780    ; Arg = Arg2+"_"+_,
 1781      LineL = ["    term_t "+Arg+"=PL_new_term_ref();",
 1782               "    __rtcheck(PL_get_arg(1, "+Arg2+", "+Arg+"));",
 1783               Line]
 1784    ).
 1785
 1786bind_arguments(Head, M, CM, Comp, Call, Succ, Glob, Bind, Return) -->
 1787    ( {compound(Head)}
 1788    ->findall(Line,
 1789              distinct(
 1790                  Key, % This hack allows automatic definition of dimensions on input arrays
 1791                  ( arg(_, Head, Arg),
 1792                    bind_argument(Head, M, CM, Comp, Call, Succ, Glob, Arg, Spec, Mode),
 1793                    curr_bind_line(arg, Head, Arg, Spec, Mode, Key-Line)
 1794                  )
 1795              ))
 1796    ; []
 1797    ),
 1798    {generate_foreign_call(Bind-Head, M, CM, Comp, Call, Succ, Glob, Return, ForeignCall)},
 1799    [ForeignCall],
 1800    ( {compound(Head)}
 1801    ->findall("    "+SetArg+";",
 1802              ( arg(_, Head, Arg),
 1803                bind_argument(Head, M, CM, Comp, Call, Succ, Glob, Arg, Spec, Mode),
 1804                memberchk(Mode, [out, inout]),
 1805                c_var_name(Arg, CArg),
 1806                c_set_argument(Spec, Mode, CArg, Arg, SetArg)
 1807              ))
 1808    ; []
 1809    ).
 1810
 1811invert_mode(in, out).
 1812invert_mode(out, in).
 1813invert_mode(inout, inout).
 1814
 1815bind_outs_arguments(Head, M, CM, Comp, Call, Succ, Glob, (_ as _/BN +_)) -->
 1816    findall("    "+Decl+Line,
 1817            ( memberchk(returns(Arg, _), Glob)
 1818            ->bind_argument(Head, M, CM, Comp, Call, Succ, Glob, Arg, Spec, Mode),
 1819              memberchk(Mode, [out, inout]),
 1820              ctype_arg_decl(Spec, Mode, Decl),
 1821              ( Spec = term
 1822              ->Line=" "+Arg+"=PL_new_term_ref();"
 1823              ; Line=" "+Arg+";"
 1824              )
 1825            )),
 1826    ( {compound(Head)}
 1827    ->findall(["    term_t "+PArg+"="+BN+"_args + "+Idx1+";",
 1828               "    "+SetArg+";"],
 1829              ( arg(Idx, Head, Arg),
 1830                succ(Idx1, Idx),
 1831                bind_argument(Head, M, CM, Comp, Call, Succ, Glob, Arg, Spec, Mode),
 1832                memberchk(Mode, [in, inout]),
 1833                ( Mode = in,
 1834                  Spec \= struct(_),
 1835                  Spec \= tdfstr(_)
 1836                ->CArg = Arg
 1837                ; CArg = "*"+Arg
 1838                ),
 1839                PArg = "_p_"+Arg,
 1840                invert_mode(Mode, InvM),
 1841                c_set_argument(Spec, InvM, CArg, PArg, SetArg)
 1842              ))
 1843    ; []
 1844    ),
 1845    bind_call_predicate(CM, Glob, BN),
 1846    ( {compound(Head)}
 1847    ->findall(Line,
 1848              ( arg(Idx, Head, Arg),
 1849                succ(Idx1, Idx),
 1850                bind_argument(Head, M, CM, Comp, Call, Succ, Glob, Arg, Spec, Mode),
 1851                memberchk(Mode, [out, inout]),
 1852                invert_mode(Mode, InvM),
 1853                ( memberchk(returns(Arg, _), Glob)
 1854                ->CArg = "&"+Arg
 1855                ; CArg = Arg
 1856                ),
 1857                PArg = "_p_"+Arg,
 1858                c_get_argument(Spec, InvM, CArg, PArg, SetArg),
 1859                ( Mode = out,
 1860                  Line = "    term_t "+PArg+"="+BN+"_args + "+Idx1+";"
 1861                ; Line = "    "+SetArg+";"
 1862                )
 1863              )),
 1864      ( { memberchk(returns(Arg, _), Glob)
 1865        ; memberchk(returns_state(_), Glob),
 1866          Arg = "__result"
 1867        }
 1868      ->["    return "+Arg+";"]
 1869      ; []
 1870      )
 1871    ; []
 1872    ).
 1873
 1874generate_foreign_call((CN/_A as _ + _)-Head1, M, CM, Comp, Call, Succ, Glob, Return,
 1875                      "    "+HLine+CN+"("+MR+LineL/", "+");") :-
 1876    ( member(RS, [returns_state(_), type(_)]),
 1877      memberchk(RS, Glob)
 1878    ->HLine="foreign_t __result=",
 1879      Head = Head1,
 1880      Return = "__result"
 1881    ; ( member(returns(Var, _), Glob)
 1882      ->c_var_name(Var, CVar),
 1883        HLine=CVar+"=",
 1884        Head1 =.. [F|Args],
 1885        once(select(Var, Args, CArgs)),
 1886        Head =.. [F|CArgs]
 1887      ; Head = Head1,
 1888        HLine=""
 1889      ),
 1890      ( member(no_exception, Glob)
 1891      ->Return = "TRUE"
 1892      ; Return = "!PL_exception(0)"
 1893      )
 1894    ),
 1895    ( memberchk(memory_root(_), Glob)
 1896    ->MR="__root, "
 1897    ; MR=""
 1898    ),
 1899    findall(Line,
 1900            distinct(Key,
 1901                     ( compound(Head),
 1902                       arg(_, Head, Arg),
 1903                       bind_argument(Head, M, CM, Comp, Call, Succ, Glob, Arg, Spec, Mode),
 1904                       curr_arg_call(Arg, Spec, Mode, Key-Line)
 1905                     )
 1906                    ), LineL).
 1907
 1908extra_arg_call(array(Spec, Dim), KeyLine) :-
 1909    ( \+ integer(Dim),
 1910      curr_arg_call(Dim, size_t-size_t, in, KeyLine)
 1911    ; extra_arg_call(Spec, KeyLine)
 1912    ).
 1913
 1914curr_arg_call(_, Spec, Mode, KeyLine) :-
 1915    memberchk(Mode, [in, inout]),
 1916    extra_arg_call(Spec, KeyLine).
 1917curr_arg_call(Arg, Spec, Mode, Arg-(Deref+CArg)) :-
 1918    c_var_name(Arg, CArg),
 1919    ( ( Mode = in,
 1920        \+ ref_type(Spec)
 1921      ; Spec = array(_, _)
 1922      )
 1923    ->Deref = ""
 1924    ; Deref = "&"
 1925    ).
 1926
 1927:- use_module(library(sequence_list)). 1928:- use_module(library(prolog_clause), []). 1929
 1930get_dictionary(Term, File, Line, M, Dict) :-
 1931    ( prolog_clause:read_term_at_line(File, Line, M, RawTerm1, _TermPos, Dict),
 1932      ( RawTerm1 \= (_ :- _)
 1933      ->RawTerm = (RawTerm1 :- true)
 1934      ; RawTerm1 = RawTerm
 1935      ),
 1936      subsumes(RawTerm, Term) -> true
 1937    ; Dict = []
 1938    ).
 1939
 1940match_known_type(Prop, M, Name, Spec, Arg) :-
 1941    match_type(Prop, M, known, Name, Spec, Arg, _, _).
 1942
 1943match_type(M:Prop,       _, K, Name, Spec, Arg) -->
 1944    ( match_type(Prop, M, K, Name, Spec, Arg)
 1945    ->[]
 1946    ).
 1947match_type(dict_t(Desc, A), _, _, Name, Spec, A) -->
 1948    {is_dict(Desc, Tag)},
 1949    !,
 1950    match_known_type_dict(dict_t(Desc, A), Tag, A, Name, Spec).
 1951match_type(dict_t(Tag, Desc, A), _, _, Name, Spec, A) -->
 1952    {dict_create(_, Tag, Desc)},
 1953    !,
 1954    match_known_type_dict(dict_t(Tag, Desc, A), Tag, A, Name, Spec).
 1955match_type(Prop, M, K, N, Spec, A) -->
 1956    match_type_k(K, Prop, M, N, Spec, A).
 1957
 1958match_type_k(known, Prop, M, N, Spec, A) --> match_known_type(Prop, M, N, Spec, A).
 1959match_type_k(unknown, _, _, _, _, _) --> [].
 1960
 1961match_known_type_type(Type, A, M, N, MSpec, A) -->
 1962    {extend_args(Type, [A], Prop)},
 1963    match_type(Prop, M, known, N, MSpec, A).
 1964
 1965match_known_array([], T, A, M, N, MSpec, A) -->
 1966    match_known_type_type(T, A, M, N, MSpec, A).
 1967match_known_array([D|L], T, A, M, N, array(Spec, D), A) -->
 1968    match_known_array(L, T, E, M, N, Spec, E).
 1969
 1970match_known_type(atm(A),            _, _, chrs('char*'),   A) --> [].
 1971match_known_type(atom(A),           _, _, chrs('char*'),   A) --> [].
 1972match_known_type(str(A),            _, _, string('char*'), A) --> [].
 1973match_known_type(string(A),         _, _, string('char*'), A) --> [].
 1974match_known_type(ptr(A),            _, _, pointer-'void*', A) --> [].
 1975match_known_type(long(A),           _, _, long-long,       A) --> [].
 1976match_known_type(int(A),            _, _, integer-int,     A) --> [].
 1977match_known_type(int64(A),          _, _, int64-int64_t,   A) --> [].
 1978match_known_type(nnegint(A),        _, _, integer-'unsigned int', A) --> [].
 1979match_known_type(integer(A),        _, _, integer-int,     A) --> [].
 1980match_known_type(character_code(A), _, _, char_code-char,  A) --> [].
 1981match_known_type(char(A),           _, _, char-char,       A) --> [].
 1982match_known_type(num(A),            _, _, float-double,    A) --> [].
 1983match_known_type(size_t(A),         _, _, size_t-size_t,   A) --> [].
 1984match_known_type(float_t(A),        _, _, float_t-float,   A) --> [].
 1985match_known_type(number(A),         _, _, float-double,    A) --> [].
 1986match_known_type(term(A),           _, _, term,            A) --> [].
 1987match_known_type(type(Type, A),     M, N, MSpec,           A) -->
 1988    {nonvar(Type)},
 1989    match_known_type_type(Type, A, M, N, MSpec, A).
 1990match_known_type(array(Type, DimL, A), M, N, MSpec, A) -->
 1991    {nonvar(Type)},
 1992    match_known_array(DimL, Type, A, M, N, MSpec, A),
 1993    !.
 1994match_known_type(MType, M, N, MSpec, A) -->
 1995    { member(MType-MSpec, [ptr( Type, A)-ptr( Spec),
 1996                           list(Type, A)-list(Spec)])
 1997    },
 1998    necks,
 1999    {nonvar(Type)},
 2000    match_known_type_type(Type, E, M, N, Spec, E),
 2001    !.
 2002match_known_type(Type, M, _, tdef(Name, Spec), A) -->
 2003    { type_is_tdef(M, Type, Spec, A),
 2004      functor(Type, Name, _)
 2005    },
 2006    !.
 2007match_known_type(setof(Type, A), M, N, Spec, A) -->
 2008    { nonvar(Type),
 2009      extend_args(Type, [E], Prop)
 2010    },
 2011    match_type(Prop, M, known, N, PSpec, E),
 2012    { ( PSpec = tdef(Name, ESpec)
 2013      ->true
 2014      ; ESpec = PSpec,
 2015        Name = TName
 2016      ),
 2017      ( ( ESpec = enum(_, C)
 2018        ->true
 2019        ; ESpec = tden(_, C)
 2020        ),
 2021        ( C =< 16
 2022        ->TName = short
 2023        ; C =< 32
 2024        ->TName = int
 2025        ; C =< 64
 2026        ->TName = long
 2027        ; C =< 128,
 2028          current_prolog_flag(address_bits, AB),
 2029          AB >= 64
 2030        ->TName = '__int128'
 2031        )
 2032      ->Spec = setof(Name, ESpec)
 2033      ; Spec = list(PSpec)
 2034      )
 2035    }.
 2036match_known_type(Type, M, _, Spec, A) -->
 2037    { compound(Type),
 2038      functor(Type, Name, Arity),
 2039      arg(Arity, Type, A),
 2040      functor(Head, Name, Arity),
 2041      % Note: type_props will call match_unknown_type internally,
 2042      % that is why this clause is only valid for match_known_type
 2043      type_props(M, HeadTypePropLDictL, _, _)
 2044    },
 2045    ( { HeadTypePropLDictL = [Head-[t(Head2, [], _, _)]],
 2046        Head == Head2
 2047      }
 2048    ->{Spec=cdef(Name)}
 2049    ; { HeadTypePropLDictL = [Head-TypePropLDictL],
 2050        forall(member(t(Head, PropL, _, _), TypePropLDictL), PropL = [])
 2051      }
 2052    ->{ length(TypePropLDictL, N),
 2053        ( member(t(_, _, GlobL, _), TypePropLDictL),
 2054          member(Glob, GlobL),
 2055          normalize_ftgen(Glob, tgen(Opts, _)),
 2056          nmember(tdef, Opts)
 2057        ->Spec=tden(Name, N)
 2058        ; Spec=enum(Name, N)
 2059        )
 2060      }
 2061    ; { member(_-TypePropLDictL, HeadTypePropLDictL),
 2062        member(t(Head, PropL, GlobL, _), TypePropLDictL),
 2063        PropL \= []
 2064      }
 2065    ->( { PropL = [setof(EType, A)],
 2066          nonvar(EType)
 2067        }
 2068      ->{ Spec=setof(Name, ESpec),
 2069          extend_args(EType, [E], EProp)
 2070        },
 2071        match_type(EProp, M, known, Name, ESpec, E)
 2072      ; { member(Glob, GlobL),
 2073          normalize_ftgen(Glob, tgen(Opts, _)),
 2074          nmember(tdef, Opts)
 2075        ->Spec=tdfstr(Name)
 2076        ; Spec=struct(Name)
 2077        }
 2078      )
 2079    ),
 2080    !.
 2081
 2082match_known_type_dict(Prop, Tag, A, Name, struct(TypeName)) -->
 2083    { atomic_list_concat([Name, '_', Tag], TypeName),
 2084      Type =.. [TypeName, A]
 2085    },
 2086    [Prop=Type].
 2087
 2088type_is_tdef(M, Type, Spec, A) :-
 2089    compound(Type),
 2090    functor(Type, TName, Arity),
 2091    arg(Arity, Type, A),
 2092    functor(Head, TName, Arity),
 2093    type_props1(M, Head, _, _, Asr),
 2094    \+ curr_prop_asr(comp, _, _, Asr),
 2095    bind_type_names(M:Head, [], TypeMPropLDictL),
 2096    TypeMPropLDictL = [t(Head, [Prop], _, _)],
 2097    arg(Arity, Head, A),
 2098    arg(Arity, Prop, B),
 2099    A==B,
 2100    match_known_type(Prop, M, TName, Spec, A),
 2101    !.
 2102
 2103bind_argument(Head, M, CM, CompL, CallL, SuccL, GlobL, Arg, Spec, Mode) :-
 2104    functor(Head, Name, _),
 2105    ( member(Comp, CompL),
 2106      once(match_known_type(Comp, CM, Name, Spec, Arg1)),
 2107      Arg1 == Arg
 2108    ->true
 2109    ; true
 2110    ),
 2111    ( member(Call, CallL),
 2112      once(match_known_type(Call, CM, Name, Spec, Arg1)),
 2113      Arg1 == Arg
 2114    ->Mode = in
 2115    ; true
 2116    ),
 2117    ( member(Succ, SuccL),
 2118      once(match_known_type(Succ, CM, Name, Spec, Arg1)),
 2119      Arg1 == Arg
 2120    ->Mode = out
 2121    ; true
 2122    ),
 2123    ( memberchk(type(_), GlobL),
 2124      once(match_known_type(Head, M, Name, Spec, Arg1)),
 2125      Arg1 == Arg
 2126    ->Mode = in
 2127    ; true
 2128    ),
 2129    ignore(Mode = inout),
 2130    ignore(Spec = term).
 2131
 2132:- public call_idx/2. 2133:- meta_predicate call_idx(0, -). 2134call_idx(Call, Idx) :-
 2135    findall(Ref, once(call_ref(Call, Ref)), [Ref]), % avoid unifications
 2136    nth_clause(_, Idx1, Ref),
 2137    succ(Idx, Idx1).
 2138
 2139:- public idx_call/2. 2140:- meta_predicate idx_call(+, 0). 2141idx_call(Idx1, Call) :-
 2142    succ(Idx1, Idx),
 2143    nth_clause(Call, Idx, Ref),
 2144    clause(Call, _, Ref)