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