1/*  Part of Run-Time Checker for Assertions
    2
    3    Author:        Edison Mera
    4    E-mail:        efmera@gmail.com
    5    WWW:           https://github.com/edisonm/refactor
    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(rtchecks,
   36          [(rtcheck)/1,
   37           unrtcheck/1,
   38           rtcheck_wrap/2,
   39           with_rtchecks/1,
   40           op(1150, fx, rtcheck)
   41          ]).   42
   43:- discontiguous '$exported_op'/3.   44:- use_module(library(apply)).   45:- reexport(library(compound_expand)).   46:- use_module(library(neck)).   47:- use_module(library(assertions)).   48:- use_module(library(metaprops)).   49:- use_module(library(ppntprops)).   50:- use_module(library(prolog_wrap)).   51:- use_module(library(rtcprops), []).   52:- use_module(library(ctrtchecks)).   53:- use_module(system:library(rtchecks_rt)).   54:- use_module(library(qualify_meta_goal)).   55:- use_module(library(group_pairs_or_sort)).   56:- after(assertions).   57:- init_expansors.   58
   59:- multifile
   60    prolog:rename_predicate/2.   61
   62wrap_asr_rtcheck(Asr, rtcheck(Asr)).
   63
   64rtcheck_wrap(M, G, CM, RAsrL) :-
   65    wrap_predicate(M:G, rtchecks, W, rtcheck_pred(W, M, CM, RAsrL)).
   66
   67rtcheck_wrap_each(M, G, P, P-AsrL) :-
   68    qualify_meta_goal(G, M, CM, P),
   69    maplist(wrap_asr_rtcheck, AsrL, RAsrL),
   70    rtcheck_wrap(M, G, CM, RAsrL).
   71
   72rtcheck_wrap(M, G) :-
   73    functor(G, F, A),
   74    functor(P, F, A),
   75    collect_asrs(F/A, M, L, []),
   76    % Note: L could have 0 or 1 elements
   77    maplist(rtcheck_wrap_each(M, G, P), L).
   78
   79wrappers(Var) -->
   80    { var(Var),
   81      !,
   82      instantiation_error(Var)
   83    }.
   84wrappers((A,B)) -->
   85    wrappers(A),
   86    wrappers(B).
   87wrappers(Name//Arity) -->
   88    { atom(Name), integer(Arity), Arity >= 0,
   89      Arity1 is Arity+2
   90    },
   91    wrappers(Name/Arity1).
   92wrappers(Name/Arity) -->
   93    { atom(Name), integer(Arity), Arity >= 0,
   94      functor(Head, Name, Arity),
   95      prolog_load_context(module, Module)
   96    },
   97    ['$rtchecked'(Head)],
   98    [(:- initialization(rtcheck_wrap(Module, Head)))].
   99
  100collect_asrs(Var, _) -->
  101    { var(Var),
  102      !,
  103      instantiation_error(Var)
  104    }.
  105collect_asrs((A,B), M) -->
  106    !,
  107    collect_asrs(A, M),
  108    collect_asrs(B, M).
  109collect_asrs(Name//Arity, M) -->
  110    { atom(Name), integer(Arity), Arity >= 0,
  111      !,
  112      Arity1 is Arity+2
  113    },
  114    collect_asrs(Name/Arity1, M).
  115collect_asrs(Name/Arity, M) -->
  116    { atom(Name), integer(Arity), Arity >= 0,
  117      functor(H, Name, Arity)
  118    },
  119    ( { findall(H-Asr, current_assertion(rt, H, M, Asr), PIAsrLL),
  120        group_pairs_or_sort(PIAsrLL, [H-AsrL])
  121      }
  122    ->[H-AsrL]
  123    ; []
  124    ).
  125
  126:- meta_predicate
  127    rtcheck(:),
  128    unrtcheck(:).  129
  130rtcheck(M:PIList) :-
  131    collect_asrs(PIList, M, PIL, []),
  132    rtcheck2(M-PIL).
  133
  134unrtcheck(M:PIList) :-
  135    collect_asrs(PIList, M, PIL, []),
  136    unrtcheck2(M-PIL).
  137
  138generate_rtchecks(Preds, Clauses) :-
  139    phrase(( ( { '$current_source_module'(CM),
  140                 '$defined_predicate'(CM:'$rtchecked'(_))
  141               }
  142             ->[]
  143             ; [(:- discontiguous('$rtchecked'/1)),
  144                (:- public '$rtchecked'/1)]
  145             ),
  146             wrappers(Preds)
  147           ), Clauses).
  148
  149term_expansion((:- rtcheck(Preds)), Clauses) :-
  150    generate_rtchecks(Preds, Clauses).
  151
  152term_expansion(assertions:asr_head_prop(Asr, M, Pred, Status, Type, Dict, Ctx, From),
  153               [assertions:asr_head_prop(Asr, M, Pred, Status, Type, Dict, Ctx, From)|Clauses]) :-
  154    current_prolog_flag(rtchecks_static, StaticL),
  155    memberchk(Status, StaticL),
  156    Type \= (prop),
  157    \+ prop_asr(Pred, M, _, (prop), _, _, _),
  158    is_valid_status_type(Status, Type),
  159    \+ ( '$current_source_module'(CM),
  160         '$defined_predicate'(CM:'$rtchecked'(_)),
  161         CM:'$rtchecked'(Pred)
  162       ),
  163    functor(Pred, Func, Arity),
  164    generate_rtchecks(Func/Arity, Clauses).
  165
  166:- multifile
  167    sandbox:safe_directive/1.
 sandbox:safe_directive(+Directive) is semidet
Allow rtchecks directives that affect locally defined predicates.
  173sandbox:safe_directive(Dir) :-
  174    ground(Dir),
  175    local_rtchecks_dir(Dir).
  176
  177local_rtchecks_dir(rtcheck(Preds)) :-
  178    local_preds(Preds).
  179
  180local_preds((A,B)) :-
  181    local_preds(A),
  182    local_preds(B).
  183
  184local_preds(Name/Arity) :-
  185    atom(Name), integer(Arity).
  186local_preds(Name//Arity) :-
  187    atom(Name), integer(Arity).
  188
  189:- meta_predicate with_rtchecks(0 ).  190with_rtchecks(Goal) :-
  191    collect_rtcheckable_preds(GLLL),
  192    setup_call_cleanup(
  193        ( rtchecks_disable,
  194          wrap_ppcheck,
  195          maplist(rtcheck2, GLLL),
  196          rtchecks_enable
  197        ),
  198        Goal,
  199        ( rtchecks_disable,
  200          maplist(unrtcheck2, GLLL),
  201          unwrap_ppcheck,
  202          rtchecks_enable
  203        )).
  204
  205rtcheck2(M-GLL) :-
  206    discontiguous(M:'$rtchecked'/1),
  207    dynamic(M:'$rtchecked'/1),
  208    public(M:'$rtchecked'/1),
  209    maplist(rtcheck2(M), GLL).
  210
  211rtcheck2(M, (CM:G)-AsrL) :-
  212    maplist(wrap_asr_rtcheck, AsrL, RAsrL),
  213    dyn_rtcheck_record(G, M),
  214    rtcheck_wrap(M, G, CM, RAsrL).
  215
  216ppassertion_type_goal(Goal, Status, Call, Loc) :-
  217    pp_status(Status),
  218    ( Goal =.. [Status, Call],
  219      Loc = []
  220    ; Goal =.. [Status, Call, Loc]
  221    ),
  222    neck.
  223
  224wrap_ppcheck :-
  225    forall(ppassertion_type_goal(Goal, Status, Call, Loc),
  226           wrap_predicate(ppntprops:Goal, rtchecks, _, rtcheck_call(Status, Call, Loc))).
  227
  228unwrap_ppcheck :-
  229    forall(( pp_status(Status),
  230             member(Arity, [1, 2])
  231           ),
  232           unwrap_predicate(ppntprops:Status/Arity, rtchecks)).
  233
  234dyn_rtcheck_record(Head, M) :-
  235    (   M:'$rtchecked'(Head)
  236    ->  true
  237    ;   assertz(M:'$rtchecked'(Head))
  238    ).
  239
  240unrtcheck2(M-GLL) :-
  241    dynamic(M:'$rtchecked'/1),
  242    maplist(unrtcheck2(M), GLL).
  243
  244unrtcheck2(M, H-_) :-
  245    functor(H, F, A),
  246    (   M:'$rtchecked'(H)
  247    ->  retractall(M:'$rtchecked'(H)),
  248        unwrap_predicate(M:F/A, rtchecks)
  249    ;   true
  250    ).
  251
  252collect_rtcheckable_preds(Groups) :-
  253    findall(M-((CM:G)-Asr),
  254            ( current_assertion(rt, H, M, Asr),
  255              functor(H, F, A),
  256              functor(G, F, A),
  257              qualify_meta_goal(G, M, CM, H)
  258            ), PIAsrLL),
  259    group_pairs_or_sort(PIAsrLL, Groups)