plunit.pl

View source with formatted comments or as raw
    1/*  Part of SWI-Prolog
    2
    3    Author:        Jan Wielemaker
    4    E-mail:        J.Wielemaker@vu.nl
    5    WWW:           http://www.swi-prolog.org
    6    Copyright (c)  2006-2015, University of Amsterdam
    7                              VU University Amsterdam
    8    All rights reserved.
    9
   10    Redistribution and use in source and binary forms, with or without
   11    modification, are permitted provided that the following conditions
   12    are met:
   13
   14    1. Redistributions of source code must retain the above copyright
   15       notice, this list of conditions and the following disclaimer.
   16
   17    2. Redistributions in binary form must reproduce the above copyright
   18       notice, this list of conditions and the following disclaimer in
   19       the documentation and/or other materials provided with the
   20       distribution.
   21
   22    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   23    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   24    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
   25    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
   26    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
   27    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
   28    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
   29    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   30    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
   31    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
   32    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
   33    POSSIBILITY OF SUCH DAMAGE.
   34*/
   35
   36:- module(plunit,
   37          [ set_test_options/1,         % +Options
   38            begin_tests/1,              % +Name
   39            begin_tests/2,              % +Name, +Options
   40            end_tests/1,                % +Name
   41            run_tests/0,                % Run all tests
   42            run_tests/1,                % Run named test-set
   43            load_test_files/1,          % +Options
   44            running_tests/0,            % Prints currently running test
   45            test_report/1               % +What
   46          ]).   47
   48/** <module> Unit Testing
   49
   50Unit testing environment for SWI-Prolog and   SICStus Prolog. For usage,
   51please visit http://www.swi-prolog.org/pldoc/package/plunit.html.
   52
   53@author         Jan Wielemaker
   54@license        GPL+SWI-exception or Artistic 2.0
   55*/
   56
   57:- use_module(library(apply)).   58:- use_module(library(ordsets), [ord_intersection/3]).   59:- meta_predicate valid_options(+, 1).   60
   61
   62                 /*******************************
   63                 *    CONDITIONAL COMPILATION   *
   64                 *******************************/
   65
   66:- discontiguous
   67    user:term_expansion/2.   68
   69:- dynamic
   70    include_code/1.   71
   72including :-
   73    include_code(X),
   74    !,
   75    X == true.
   76including.
   77
   78if_expansion((:- if(G)), []) :-
   79    (   including
   80    ->  (   catch(G, E, (print_message(error, E), fail))
   81        ->  asserta(include_code(true))
   82        ;   asserta(include_code(false))
   83        )
   84    ;   asserta(include_code(else_false))
   85    ).
   86if_expansion((:- else), []) :-
   87    (   retract(include_code(X))
   88    ->  (   X == true
   89        ->  X2 = false
   90        ;   X == false
   91        ->  X2 = true
   92        ;   X2 = X
   93        ),
   94        asserta(include_code(X2))
   95    ;   throw_error(context_error(no_if),_)
   96    ).
   97if_expansion((:- endif), []) :-
   98    retract(include_code(_)),
   99    !.
  100
  101if_expansion(_, []) :-
  102    \+ including.
  103
  104user:term_expansion(In, Out) :-
  105    prolog_load_context(module, plunit),
  106    if_expansion(In, Out).
  107
  108swi     :- catch(current_prolog_flag(dialect, swi), _, fail), !.
  109swi     :- catch(current_prolog_flag(dialect, yap), _, fail).
  110sicstus :- catch(current_prolog_flag(system_type, _), _, fail).
  111
  112
  113:- if(swi).  114throw_error(Error_term,Impldef) :-
  115    throw(error(Error_term,context(Impldef,_))).
  116
  117:- set_prolog_flag(generate_debug_info, false).  118:- use_module(library(option)).  119:- use_module(library(pairs)).  120
  121current_test_flag(Name, Value) :-
  122    current_prolog_flag(Name, Value).
  123
  124set_test_flag(Name, Value) :-
  125    create_prolog_flag(Name, Value, []).
  126
  127% ensure expansion to avoid tracing
  128goal_expansion(forall(C,A),
  129               \+ (C, \+ A)).
  130goal_expansion(current_module(Module,File),
  131               module_property(Module, file(File))).
  132
  133:- if(current_prolog_flag(dialect, yap)).  134
  135'$set_predicate_attribute'(_, _, _).
  136
  137:- endif.  138:- endif.  139
  140:- if(sicstus).  141throw_error(Error_term,Impldef) :-
  142    throw(error(Error_term,i(Impldef))). % SICStus 3 work around
  143
  144:- use_module(swi).                     % SWI-Compatibility
  145:- use_module(library(terms)).  146:- op(700, xfx, =@=).  147
  148'$set_source_module'(_, _).
  149
  150%!  current_test_flag(?Name, ?Value) is nondet.
  151%
  152%   Query  flags  that  control  the    testing   process.  Emulates
  153%   SWI-Prologs flags.
  154
  155:- dynamic test_flag/2. % Name, Val
  156
  157current_test_flag(optimise, Val) :-
  158    current_prolog_flag(compiling, Compiling),
  159    (   Compiling == debugcode ; true % TBD: Proper test
  160    ->  Val = false
  161    ;   Val = true
  162    ).
  163current_test_flag(Name, Val) :-
  164    test_flag(Name, Val).
  165
  166
  167%!  set_test_flag(+Name, +Value) is det.
  168
  169set_test_flag(Name, Val) :-
  170    var(Name),
  171    !,
  172    throw_error(instantiation_error, set_test_flag(Name,Val)).
  173set_test_flag( Name, Val ) :-
  174    retractall(test_flag(Name,_)),
  175    asserta(test_flag(Name, Val)).
  176
  177:- op(1150, fx, thread_local).  178
  179user:term_expansion((:- thread_local(PI)), (:- dynamic(PI))) :-
  180    prolog_load_context(module, plunit).
  181
  182:- endif.  183
  184                 /*******************************
  185                 *            IMPORTS           *
  186                 *******************************/
  187
  188:- use_module(library(lists)).  189
  190:- initialization
  191   (   current_test_flag(test_options, _)
  192   ->  true
  193   ;   set_test_flag(test_options,
  194                 [ run(make),       % run tests on make/0
  195                   sto(false)
  196                 ])
  197   ).  198
  199%!  set_test_options(+Options)
  200%
  201%   Specifies how to deal with test suites.  Defined options are:
  202%
  203%           * load(+Load)
  204%           Whether or not the tests must be loaded.  Values are
  205%           =never=, =always=, =normal= (only if not optimised)
  206%
  207%           * run(+When)
  208%           When the tests are run.  Values are =manual=, =make=
  209%           or make(all).
  210%
  211%           * silent(+Bool)
  212%           If =true= (default =false=), report successful tests
  213%           using message level =silent=, only printing errors and
  214%           warnings.
  215%
  216%           * sto(+Bool)
  217%           How to test whether code is subject to occurs check
  218%           (STO).  If =false= (default), STO is not considered.
  219%           If =true= and supported by the hosting Prolog, code
  220%           is run in all supported unification mode and reported
  221%           if the results are inconsistent.
  222%
  223%           * cleanup(+Bool)
  224%           If =true= (default =false), cleanup report at the end
  225%           of run_tests/1.  Used to improve cooperation with
  226%           memory debuggers such as dmalloc.
  227
  228set_test_options(Options) :-
  229    valid_options(Options, global_test_option),
  230    set_test_flag(test_options, Options).
  231
  232global_test_option(load(Load)) :-
  233    must_be(oneof([never,always,normal]), Load).
  234global_test_option(run(When)) :-
  235    must_be(oneof([manual,make,make(all)]), When).
  236global_test_option(silent(Bool)) :-
  237    must_be(boolean, Bool).
  238global_test_option(sto(Bool)) :-
  239    must_be(boolean, Bool).
  240global_test_option(cleanup(Bool)) :-
  241    must_be(boolean, Bool).
  242
  243
  244%!  loading_tests
  245%
  246%   True if tests must be loaded.
  247
  248loading_tests :-
  249    current_test_flag(test_options, Options),
  250    option(load(Load), Options, normal),
  251    (   Load == always
  252    ->  true
  253    ;   Load == normal,
  254        \+ current_test_flag(optimise, true)
  255    ).
  256
  257                 /*******************************
  258                 *            MODULE            *
  259                 *******************************/
  260
  261:- dynamic
  262    loading_unit/4,                 % Unit, Module, File, OldSource
  263    current_unit/4,                 % Unit, Module, Context, Options
  264    test_file_for/2.                % ?TestFile, ?PrologFile
  265
  266%!  begin_tests(+UnitName:atom) is det.
  267%!  begin_tests(+UnitName:atom, Options) is det.
  268%
  269%   Start a test-unit. UnitName is the  name   of  the test set. the
  270%   unit is ended by :- end_tests(UnitName).
  271
  272begin_tests(Unit) :-
  273    begin_tests(Unit, []).
  274
  275begin_tests(Unit, Options) :-
  276    valid_options(Options, test_set_option),
  277    make_unit_module(Unit, Name),
  278    source_location(File, Line),
  279    begin_tests(Unit, Name, File:Line, Options).
  280
  281:- if(swi).  282begin_tests(Unit, Name, File:Line, Options) :-
  283    loading_tests,
  284    !,
  285    '$set_source_module'(Context, Context),
  286    (   current_unit(Unit, Name, Context, Options)
  287    ->  true
  288    ;   retractall(current_unit(Unit, Name, _, _)),
  289        assert(current_unit(Unit, Name, Context, Options))
  290    ),
  291    '$set_source_module'(Old, Name),
  292    '$declare_module'(Name, test, Context, File, Line, false),
  293    discontiguous(Name:'unit test'/4),
  294    '$set_predicate_attribute'(Name:'unit test'/4, trace, false),
  295    discontiguous(Name:'unit body'/2),
  296    asserta(loading_unit(Unit, Name, File, Old)).
  297begin_tests(Unit, Name, File:_Line, _Options) :-
  298    '$set_source_module'(Old, Old),
  299    asserta(loading_unit(Unit, Name, File, Old)).
  300
  301:- else.  302
  303% we cannot use discontiguous as a goal in SICStus Prolog.
  304
  305user:term_expansion((:- begin_tests(Set)),
  306                    [ (:- begin_tests(Set)),
  307                      (:- discontiguous(test/2)),
  308                      (:- discontiguous('unit body'/2)),
  309                      (:- discontiguous('unit test'/4))
  310                    ]).
  311
  312begin_tests(Unit, Name, File:_Line, Options) :-
  313    loading_tests,
  314    !,
  315    (   current_unit(Unit, Name, _, Options)
  316    ->  true
  317    ;   retractall(current_unit(Unit, Name, _, _)),
  318        assert(current_unit(Unit, Name, -, Options))
  319    ),
  320    asserta(loading_unit(Unit, Name, File, -)).
  321begin_tests(Unit, Name, File:_Line, _Options) :-
  322    asserta(loading_unit(Unit, Name, File, -)).
  323
  324:- endif.  325
  326%!  end_tests(+Name) is det.
  327%
  328%   Close a unit-test module.
  329%
  330%   @tbd    Run tests/clean module?
  331%   @tbd    End of file?
  332
  333end_tests(Unit) :-
  334    loading_unit(StartUnit, _, _, _),
  335    !,
  336    (   Unit == StartUnit
  337    ->  once(retract(loading_unit(StartUnit, _, _, Old))),
  338        '$set_source_module'(_, Old)
  339    ;   throw_error(context_error(plunit_close(Unit, StartUnit)), _)
  340    ).
  341end_tests(Unit) :-
  342    throw_error(context_error(plunit_close(Unit, -)), _).
  343
  344%!  make_unit_module(+Name, -ModuleName) is det.
  345%!  unit_module(+Name, -ModuleName) is det.
  346
  347:- if(swi).  348
  349unit_module(Unit, Module) :-
  350    atom_concat('plunit_', Unit, Module).
  351
  352make_unit_module(Unit, Module) :-
  353    unit_module(Unit, Module),
  354    (   current_module(Module),
  355        \+ current_unit(_, Module, _, _),
  356        predicate_property(Module:H, _P),
  357        \+ predicate_property(Module:H, imported_from(_M))
  358    ->  throw_error(permission_error(create, plunit, Unit),
  359                    'Existing module')
  360    ;  true
  361    ).
  362
  363:- else.  364
  365:- dynamic
  366    unit_module_store/2.  367
  368unit_module(Unit, Module) :-
  369    unit_module_store(Unit, Module),
  370    !.
  371
  372make_unit_module(Unit, Module) :-
  373    prolog_load_context(module, Module),
  374    assert(unit_module_store(Unit, Module)).
  375
  376:- endif.  377
  378                 /*******************************
  379                 *           EXPANSION          *
  380                 *******************************/
  381
  382%!  expand_test(+Name, +Options, +Body, -Clause) is det.
  383%
  384%   Expand test(Name, Options) :-  Body  into   a  clause  for
  385%   'unit test'/4 and 'unit body'/2.
  386
  387expand_test(Name, Options0, Body,
  388            [ 'unit test'(Name, Line, Options, Module:'unit body'(Id, Vars)),
  389              ('unit body'(Id, Vars) :- !, Body)
  390            ]) :-
  391    source_location(_File, Line),
  392    prolog_load_context(module, Module),
  393    atomic_list_concat([Name, '@line ', Line], Id),
  394    term_variables(Options0, OptionVars0), sort(OptionVars0, OptionVars),
  395    term_variables(Body, BodyVars0), sort(BodyVars0, BodyVars),
  396    ord_intersection(OptionVars, BodyVars, VarList),
  397    Vars =.. [vars|VarList],
  398    (   is_list(Options0)           % allow for single option without list
  399    ->  Options1 = Options0
  400    ;   Options1 = [Options0]
  401    ),
  402    maplist(expand_option, Options1, Options2),
  403    valid_options(Options2, test_option),
  404    valid_test_mode(Options2, Options).
  405
  406expand_option(Var, _) :-
  407    var(Var),
  408    !,
  409    throw_error(instantiation_error,_).
  410expand_option(A == B, true(A==B)) :- !.
  411expand_option(A = B, true(A=B)) :- !.
  412expand_option(A =@= B, true(A=@=B)) :- !.
  413expand_option(A =:= B, true(A=:=B)) :- !.
  414expand_option(error(X), throws(error(X, _))) :- !.
  415expand_option(exception(X), throws(X)) :- !. % SICStus 4 compatibility
  416expand_option(error(F,C), throws(error(F,C))) :- !. % SICStus 4 compatibility
  417expand_option(true, true(true)) :- !.
  418expand_option(O, O).
  419
  420valid_test_mode(Options0, Options) :-
  421    include(test_mode, Options0, Tests),
  422    (   Tests == []
  423    ->  Options = [true(true)|Options0]
  424    ;   Tests = [_]
  425    ->  Options = Options0
  426    ;   throw_error(plunit(incompatible_options, Tests), _)
  427    ).
  428
  429test_mode(true(_)).
  430test_mode(all(_)).
  431test_mode(set(_)).
  432test_mode(fail).
  433test_mode(throws(_)).
  434
  435
  436%!  expand(+Term, -Clauses) is semidet.
  437
  438expand(end_of_file, _) :-
  439    loading_unit(Unit, _, _, _),
  440    !,
  441    end_tests(Unit),                % warn?
  442    fail.
  443expand((:-end_tests(_)), _) :-
  444    !,
  445    fail.
  446expand(_Term, []) :-
  447    \+ loading_tests.
  448expand((test(Name) :- Body), Clauses) :-
  449    !,
  450    expand_test(Name, [], Body, Clauses).
  451expand((test(Name, Options) :- Body), Clauses) :-
  452    !,
  453    expand_test(Name, Options, Body, Clauses).
  454expand(test(Name), _) :-
  455    !,
  456    throw_error(existence_error(body, test(Name)), _).
  457expand(test(Name, _Options), _) :-
  458    !,
  459    throw_error(existence_error(body, test(Name)), _).
  460
  461:- if(swi).  462:- multifile
  463    system:term_expansion/2.  464:- endif.  465
  466system:term_expansion(Term, Expanded) :-
  467    (   loading_unit(_, _, File, _)
  468    ->  source_location(File, _),
  469        expand(Term, Expanded)
  470    ).
  471
  472
  473                 /*******************************
  474                 *             OPTIONS          *
  475                 *******************************/
  476
  477:- if(swi).  478:- use_module(library(error)).  479:- else.  480must_be(list, X) :-
  481    !,
  482    (   is_list(X)
  483    ->  true
  484    ;   is_not(list, X)
  485    ).
  486must_be(Type, X) :-
  487    (   call(Type, X)
  488    ->  true
  489    ;   is_not(Type, X)
  490    ).
  491
  492is_not(Type, X) :-
  493    (   ground(X)
  494    ->  throw_error(type_error(Type, X), _)
  495    ;   throw_error(instantiation_error, _)
  496    ).
  497:- endif.  498
  499%!  valid_options(+Options, :Pred) is det.
  500%
  501%   Verify Options to be a list of valid options according to
  502%   Pred.
  503%
  504%   @throws =type_error= or =instantiation_error=.
  505
  506valid_options(Options, Pred) :-
  507    must_be(list, Options),
  508    verify_options(Options, Pred).
  509
  510verify_options([], _).
  511verify_options([H|T], Pred) :-
  512    (   call(Pred, H)
  513    ->  verify_options(T, Pred)
  514    ;   throw_error(domain_error(Pred, H), _)
  515    ).
  516
  517
  518%!  test_option(+Option) is semidet.
  519%
  520%   True if Option is a valid option for test(Name, Options).
  521
  522test_option(Option) :-
  523    test_set_option(Option),
  524    !.
  525test_option(true(_)).
  526test_option(fail).
  527test_option(throws(_)).
  528test_option(all(_)).
  529test_option(set(_)).
  530test_option(nondet).
  531test_option(fixme(_)).
  532test_option(forall(X)) :-
  533    must_be(callable, X).
  534
  535%!  test_option(+Option) is semidet.
  536%
  537%   True if Option is a valid option for :- begin_tests(Name,
  538%   Options).
  539
  540test_set_option(blocked(X)) :-
  541    must_be(ground, X).
  542test_set_option(condition(X)) :-
  543    must_be(callable, X).
  544test_set_option(setup(X)) :-
  545    must_be(callable, X).
  546test_set_option(cleanup(X)) :-
  547    must_be(callable, X).
  548test_set_option(sto(V)) :-
  549    nonvar(V), member(V, [finite_trees, rational_trees]).
  550
  551
  552                 /*******************************
  553                 *        RUNNING TOPLEVEL      *
  554                 *******************************/
  555
  556:- thread_local
  557    passed/5,                       % Unit, Test, Line, Det, Time
  558    failed/4,                       % Unit, Test, Line, Reason
  559    failed_assertion/7,             % Unit, Test, Line, ALoc, STO, Reason, Goal
  560    blocked/4,                      % Unit, Test, Line, Reason
  561    sto/4,                          % Unit, Test, Line, Results
  562    fixme/5.                        % Unit, Test, Line, Reason, Status
  563
  564:- dynamic
  565    running/5.                      % Unit, Test, Line, STO, Thread
  566
  567%!  run_tests is semidet.
  568%!  run_tests(+TestSet) is semidet.
  569%
  570%   Run  tests  and  report  about    the   results.  The  predicate
  571%   run_tests/0 runs all known  tests  that   are  not  blocked. The
  572%   predicate run_tests/1 takes a  specification   of  tests to run.
  573%   This  is  either  a  single   specification    or   a   list  of
  574%   specifications. Each single specification is  either the name of
  575%   a test-unit or a term <test-unit>:<test>, denoting a single test
  576%   within a unit.
  577
  578run_tests :-
  579    cleanup,
  580    setup_call_cleanup(
  581        setup_trap_assertions(Ref),
  582        run_current_units,
  583        report_and_cleanup(Ref)).
  584
  585run_current_units :-
  586    forall(current_test_set(Set),
  587           run_unit(Set)),
  588    check_for_test_errors.
  589
  590report_and_cleanup(Ref) :-
  591    cleanup_trap_assertions(Ref),
  592    report,
  593    cleanup_after_test.
  594
  595run_tests(Set) :-
  596    cleanup,
  597    setup_call_cleanup(
  598        setup_trap_assertions(Ref),
  599        run_unit_and_check_errors(Set),
  600        report_and_cleanup(Ref)).
  601
  602run_unit_and_check_errors(Set) :-
  603    run_unit(Set),
  604    check_for_test_errors.
  605
  606run_unit([]) :- !.
  607run_unit([H|T]) :-
  608    !,
  609    run_unit(H),
  610    run_unit(T).
  611run_unit(Spec) :-
  612    unit_from_spec(Spec, Unit, Tests, Module, UnitOptions),
  613    (   option(blocked(Reason), UnitOptions)
  614    ->  info(plunit(blocked(unit(Unit, Reason))))
  615    ;   setup(Module, unit(Unit), UnitOptions)
  616    ->  info(plunit(begin(Spec))),
  617        forall((Module:'unit test'(Name, Line, Options, Body),
  618                matching_test(Name, Tests)),
  619               run_test(Unit, Name, Line, Options, Body)),
  620        info(plunit(end(Spec))),
  621        (   message_level(silent)
  622        ->  true
  623        ;   format(user_error, '~N', [])
  624        ),
  625        cleanup(Module, UnitOptions)
  626    ;   true
  627    ).
  628
  629unit_from_spec(Unit, Unit, _, Module, Options) :-
  630    atom(Unit),
  631    !,
  632    (   current_unit(Unit, Module, _Supers, Options)
  633    ->  true
  634    ;   throw_error(existence_error(unit_test, Unit), _)
  635    ).
  636unit_from_spec(Unit:Tests, Unit, Tests, Module, Options) :-
  637    atom(Unit),
  638    !,
  639    (   current_unit(Unit, Module, _Supers, Options)
  640    ->  true
  641    ;   throw_error(existence_error(unit_test, Unit), _)
  642    ).
  643
  644
  645matching_test(X, X) :- !.
  646matching_test(Name, Set) :-
  647    is_list(Set),
  648    memberchk(Name, Set).
  649
  650cleanup :-
  651    thread_self(Me),
  652    retractall(passed(_, _, _, _, _)),
  653    retractall(failed(_, _, _, _)),
  654    retractall(failed_assertion(_, _, _, _, _, _, _)),
  655    retractall(blocked(_, _, _, _)),
  656    retractall(sto(_, _, _, _)),
  657    retractall(fixme(_, _, _, _, _)),
  658    retractall(running(_,_,_,_,Me)).
  659
  660cleanup_after_test :-
  661    current_test_flag(test_options, Options),
  662    option(cleanup(Cleanup), Options, false),
  663    (   Cleanup == true
  664    ->  cleanup
  665    ;   true
  666    ).
  667
  668
  669%!  run_tests_in_files(+Files:list) is det.
  670%
  671%   Run all test-units that appear in the given Files.
  672
  673run_tests_in_files(Files) :-
  674    findall(Unit, unit_in_files(Files, Unit), Units),
  675    (   Units == []
  676    ->  true
  677    ;   run_tests(Units)
  678    ).
  679
  680unit_in_files(Files, Unit) :-
  681    is_list(Files),
  682    !,
  683    member(F, Files),
  684    absolute_file_name(F, Source,
  685                       [ file_type(prolog),
  686                         access(read),
  687                         file_errors(fail)
  688                       ]),
  689    unit_file(Unit, Source).
  690
  691
  692                 /*******************************
  693                 *         HOOKING MAKE/0       *
  694                 *******************************/
  695
  696%!  make_run_tests(+Files)
  697%
  698%   Called indirectly from make/0 after Files have been reloaded.
  699
  700make_run_tests(Files) :-
  701    current_test_flag(test_options, Options),
  702    option(run(When), Options, manual),
  703    (   When == make
  704    ->  run_tests_in_files(Files)
  705    ;   When == make(all)
  706    ->  run_tests
  707    ;   true
  708    ).
  709
  710:- if(swi).  711
  712unification_capability(sto_error_incomplete).
  713% can detect some (almost all) STO runs
  714unification_capability(rational_trees).
  715unification_capability(finite_trees).
  716
  717set_unification_capability(Cap) :-
  718    cap_to_flag(Cap, Flag),
  719    set_prolog_flag(occurs_check, Flag).
  720
  721current_unification_capability(Cap) :-
  722    current_prolog_flag(occurs_check, Flag),
  723    cap_to_flag(Cap, Flag),
  724    !.
  725
  726cap_to_flag(sto_error_incomplete, error).
  727cap_to_flag(rational_trees, false).
  728cap_to_flag(finite_trees, true).
  729
  730:- else.  731:- if(sicstus).  732
  733unification_capability(rational_trees).
  734set_unification_capability(rational_trees).
  735current_unification_capability(rational_trees).
  736
  737:- else.  738
  739unification_capability(_) :-
  740    fail.
  741
  742:- endif.  743:- endif.  744
  745                 /*******************************
  746                 *      ASSERTION HANDLING      *
  747                 *******************************/
  748
  749:- if(swi).  750
  751:- dynamic prolog:assertion_failed/2.  752
  753setup_trap_assertions(Ref) :-
  754    asserta((prolog:assertion_failed(Reason, Goal) :-
  755                    test_assertion_failed(Reason, Goal)),
  756            Ref).
  757
  758cleanup_trap_assertions(Ref) :-
  759    erase(Ref).
  760
  761test_assertion_failed(Reason, Goal) :-
  762    thread_self(Me),
  763    running(Unit, Test, Line, STO, Me),
  764    (   catch(get_prolog_backtrace(10, Stack), _, fail),
  765        assertion_location(Stack, AssertLoc)
  766    ->  true
  767    ;   AssertLoc = unknown
  768    ),
  769    current_test_flag(test_options, Options),
  770    report_failed_assertion(Unit, Test, Line, AssertLoc,
  771                            STO, Reason, Goal, Options),
  772    assert_cyclic(failed_assertion(Unit, Test, Line, AssertLoc,
  773                                   STO, Reason, Goal)).
  774
  775assertion_location(Stack, File:Line) :-
  776    append(_, [AssertFrame,CallerFrame|_], Stack),
  777    prolog_stack_frame_property(AssertFrame,
  778                                predicate(prolog_debug:assertion/1)),
  779    !,
  780    prolog_stack_frame_property(CallerFrame, location(File:Line)).
  781
  782report_failed_assertion(Unit, Test, Line, AssertLoc,
  783                        STO, Reason, Goal, _Options) :-
  784    print_message(
  785        error,
  786        plunit(failed_assertion(Unit, Test, Line, AssertLoc,
  787                                STO, Reason, Goal))).
  788
  789:- else.  790
  791setup_trap_assertions(_).
  792cleanup_trap_assertions(_).
  793
  794:- endif.  795
  796
  797
  798
  799
  800                 /*******************************
  801                 *         RUNNING A TEST       *
  802                 *******************************/
  803
  804%!  run_test(+Unit, +Name, +Line, +Options, +Body) is det.
  805%
  806%   Run a single test.
  807
  808run_test(Unit, Name, Line, Options, Body) :-
  809    option(forall(Generator), Options),
  810    !,
  811    unit_module(Unit, Module),
  812    term_variables(Generator, Vars),
  813    forall(Module:Generator,
  814           run_test_once(Unit, @(Name,Vars), Line, Options, Body)).
  815run_test(Unit, Name, Line, Options, Body) :-
  816    run_test_once(Unit, Name, Line, Options, Body).
  817
  818run_test_once(Unit, Name, Line, Options, Body) :-
  819    current_test_flag(test_options, GlobalOptions),
  820    option(sto(false), GlobalOptions, false),
  821    !,
  822    current_unification_capability(Type),
  823    begin_test(Unit, Name, Line, Type),
  824    run_test_6(Unit, Name, Line, Options, Body, Result),
  825    end_test(Unit, Name, Line, Type),
  826    report_result(Result, Options).
  827run_test_once(Unit, Name, Line, Options, Body) :-
  828    current_unit(Unit, _Module, _Supers, UnitOptions),
  829    option(sto(Type), UnitOptions),
  830    \+ option(sto(_), Options),
  831    !,
  832    current_unification_capability(Cap0),
  833    call_cleanup(run_test_cap(Unit, Name, Line, [sto(Type)|Options], Body),
  834                 set_unification_capability(Cap0)).
  835run_test_once(Unit, Name, Line, Options, Body) :-
  836    current_unification_capability(Cap0),
  837    call_cleanup(run_test_cap(Unit, Name, Line, Options, Body),
  838                 set_unification_capability(Cap0)).
  839
  840run_test_cap(Unit, Name, Line, Options, Body) :-
  841    (   option(sto(Type), Options)
  842    ->  unification_capability(Type),
  843        set_unification_capability(Type),
  844        begin_test(Unit, Name, Line, Type),
  845        run_test_6(Unit, Name, Line, Options, Body, Result),
  846        end_test(Unit, Name, Line, Type),
  847        report_result(Result, Options)
  848    ;   findall(Key-(Type+Result),
  849                test_caps(Type, Unit, Name, Line, Options, Body, Result, Key),
  850                Pairs),
  851        group_pairs_by_key(Pairs, Keyed),
  852        (   Keyed == []
  853        ->  true
  854        ;   Keyed = [_-Results]
  855        ->  Results = [_Type+Result|_],
  856            report_result(Result, Options)          % consistent results
  857        ;   pairs_values(Pairs, ResultByType),
  858            report_result(sto(Unit, Name, Line, ResultByType), Options)
  859        )
  860    ).
  861
  862%!  test_caps(-Type, +Unit, +Name, +Line, +Options, +Body, -Result, -Key) is nondet.
  863
  864test_caps(Type, Unit, Name, Line, Options, Body, Result, Key) :-
  865    unification_capability(Type),
  866    set_unification_capability(Type),
  867    begin_test(Unit, Name, Line, Type),
  868    run_test_6(Unit, Name, Line, Options, Body, Result),
  869    end_test(Unit, Name, Line, Type),
  870    result_to_key(Result, Key),
  871    Key \== setup_failed.
  872
  873result_to_key(blocked(_, _, _, _), blocked).
  874result_to_key(failure(_, _, _, How0), failure(How1)) :-
  875    ( How0 = succeeded(_T) -> How1 = succeeded ; How0 = How1 ).
  876result_to_key(success(_, _, _, Determinism, _), success(Determinism)).
  877result_to_key(setup_failed(_,_,_), setup_failed).
  878
  879report_result(blocked(Unit, Name, Line, Reason), _) :-
  880    !,
  881    assert(blocked(Unit, Name, Line, Reason)).
  882report_result(failure(Unit, Name, Line, How), Options) :-
  883    !,
  884    failure(Unit, Name, Line, How, Options).
  885report_result(success(Unit, Name, Line, Determinism, Time), Options) :-
  886    !,
  887    success(Unit, Name, Line, Determinism, Time, Options).
  888report_result(setup_failed(_Unit, _Name, _Line), _Options).
  889report_result(sto(Unit, Name, Line, ResultByType), Options) :-
  890    assert(sto(Unit, Name, Line, ResultByType)),
  891    print_message(error, plunit(sto(Unit, Name, Line))),
  892    report_sto_results(ResultByType, Options).
  893
  894report_sto_results([], _).
  895report_sto_results([Type+Result|T], Options) :-
  896    print_message(error, plunit(sto(Type, Result))),
  897    report_sto_results(T, Options).
  898
  899
  900%!  run_test_6(+Unit, +Name, +Line, +Options, :Body, -Result) is det.
  901%
  902%   Result is one of:
  903%
  904%           * blocked(Unit, Name, Line, Reason)
  905%           * failure(Unit, Name, Line, How)
  906%           * success(Unit, Name, Line, Determinism, Time)
  907%           * setup_failed(Unit, Name, Line)
  908
  909run_test_6(Unit, Name, Line, Options, _Body,
  910           blocked(Unit, Name, Line, Reason)) :-
  911    option(blocked(Reason), Options),
  912    !.
  913run_test_6(Unit, Name, Line, Options, Body, Result) :-
  914    option(all(Answer), Options),                  % all(Bindings)
  915    !,
  916    nondet_test(all(Answer), Unit, Name, Line, Options, Body, Result).
  917run_test_6(Unit, Name, Line, Options, Body, Result) :-
  918    option(set(Answer), Options),                  % set(Bindings)
  919    !,
  920    nondet_test(set(Answer), Unit, Name, Line, Options, Body, Result).
  921run_test_6(Unit, Name, Line, Options, Body, Result) :-
  922    option(fail, Options),                         % fail
  923    !,
  924    unit_module(Unit, Module),
  925    (   setup(Module, test(Unit,Name,Line), Options)
  926    ->  statistics(runtime, [T0,_]),
  927        (   catch(Module:Body, E, true)
  928        ->  (   var(E)
  929            ->  statistics(runtime, [T1,_]),
  930                Time is (T1 - T0)/1000.0,
  931                Result = failure(Unit, Name, Line, succeeded(Time)),
  932                cleanup(Module, Options)
  933            ;   Result = failure(Unit, Name, Line, E),
  934                cleanup(Module, Options)
  935            )
  936        ;   statistics(runtime, [T1,_]),
  937            Time is (T1 - T0)/1000.0,
  938            Result = success(Unit, Name, Line, true, Time),
  939            cleanup(Module, Options)
  940        )
  941    ;   Result = setup_failed(Unit, Name, Line)
  942    ).
  943run_test_6(Unit, Name, Line, Options, Body, Result) :-
  944    option(true(Cmp), Options),
  945    !,
  946    unit_module(Unit, Module),
  947    (   setup(Module, test(Unit,Name,Line), Options) % true(Binding)
  948    ->  statistics(runtime, [T0,_]),
  949        (   catch(call_det(Module:Body, Det), E, true)
  950        ->  (   var(E)
  951            ->  statistics(runtime, [T1,_]),
  952                Time is (T1 - T0)/1000.0,
  953                (   catch(Module:Cmp, E, true)
  954                ->  (   var(E)
  955                    ->  Result = success(Unit, Name, Line, Det, Time)
  956                    ;   Result = failure(Unit, Name, Line, cmp_error(Cmp, E))
  957                    )
  958                ;   Result = failure(Unit, Name, Line, wrong_answer(Cmp))
  959                ),
  960                cleanup(Module, Options)
  961            ;   Result = failure(Unit, Name, Line, E),
  962                cleanup(Module, Options)
  963            )
  964        ;   Result = failure(Unit, Name, Line, failed),
  965            cleanup(Module, Options)
  966        )
  967    ;   Result = setup_failed(Unit, Name, Line)
  968    ).
  969run_test_6(Unit, Name, Line, Options, Body, Result) :-
  970    option(throws(Expect), Options),
  971    !,
  972    unit_module(Unit, Module),
  973    (   setup(Module, test(Unit,Name,Line), Options)
  974    ->  statistics(runtime, [T0,_]),
  975        (   catch(Module:Body, E, true)
  976        ->  (   var(E)
  977            ->  Result = failure(Unit, Name, Line, no_exception),
  978                cleanup(Module, Options)
  979            ;   statistics(runtime, [T1,_]),
  980                Time is (T1 - T0)/1000.0,
  981                (   match_error(Expect, E)
  982                ->  Result = success(Unit, Name, Line, true, Time)
  983                ;   Result = failure(Unit, Name, Line, wrong_error(Expect, E))
  984                ),
  985                cleanup(Module, Options)
  986            )
  987        ;   Result = failure(Unit, Name, Line, failed),
  988            cleanup(Module, Options)
  989        )
  990    ;   Result = setup_failed(Unit, Name, Line)
  991    ).
  992
  993
  994%!  non_det_test(+Expected, +Unit, +Name, +Line, +Options, +Body, -Result)
  995%
  996%   Run tests on non-deterministic predicates.
  997
  998nondet_test(Expected, Unit, Name, Line, Options, Body, Result) :-
  999    unit_module(Unit, Module),
 1000    result_vars(Expected, Vars),
 1001    statistics(runtime, [T0,_]),
 1002    (   setup(Module, test(Unit,Name,Line), Options)
 1003    ->  (   catch(findall(Vars, Module:Body, Bindings), E, true)
 1004        ->  (   var(E)
 1005            ->  statistics(runtime, [T1,_]),
 1006                Time is (T1 - T0)/1000.0,
 1007                (   nondet_compare(Expected, Bindings, Unit, Name, Line)
 1008                ->  Result = success(Unit, Name, Line, true, Time)
 1009                ;   Result = failure(Unit, Name, Line, wrong_answer(Expected, Bindings))
 1010                ),
 1011                cleanup(Module, Options)
 1012            ;   Result = failure(Unit, Name, Line, E),
 1013                cleanup(Module, Options)
 1014            )
 1015        )
 1016    ;   Result = setup_failed(Unit, Name, Line)
 1017    ).
 1018
 1019
 1020%!  result_vars(+Expected, -Vars) is det.
 1021%
 1022%   Create a term v(V1, ...) containing all variables at the left
 1023%   side of the comparison operator on Expected.
 1024
 1025result_vars(Expected, Vars) :-
 1026    arg(1, Expected, CmpOp),
 1027    arg(1, CmpOp, Vars).
 1028
 1029%!  nondet_compare(+Expected, +Bindings, +Unit, +Name, +Line) is semidet.
 1030%
 1031%   Compare list/set results for non-deterministic predicates.
 1032%
 1033%   @tbd    Properly report errors
 1034%   @bug    Sort should deal with equivalence on the comparison
 1035%           operator.
 1036
 1037nondet_compare(all(Cmp), Bindings, _Unit, _Name, _Line) :-
 1038    cmp(Cmp, _Vars, Op, Values),
 1039    cmp_list(Values, Bindings, Op).
 1040nondet_compare(set(Cmp), Bindings0, _Unit, _Name, _Line) :-
 1041    cmp(Cmp, _Vars, Op, Values0),
 1042    sort(Bindings0, Bindings),
 1043    sort(Values0, Values),
 1044    cmp_list(Values, Bindings, Op).
 1045
 1046cmp_list([], [], _Op).
 1047cmp_list([E0|ET], [V0|VT], Op) :-
 1048    call(Op, E0, V0),
 1049    cmp_list(ET, VT, Op).
 1050
 1051%!  cmp(+CmpTerm, -Left, -Op, -Right) is det.
 1052
 1053cmp(Var  == Value, Var,  ==, Value).
 1054cmp(Var =:= Value, Var, =:=, Value).
 1055cmp(Var  =  Value, Var,  =,  Value).
 1056:- if(swi). 1057cmp(Var =@= Value, Var, =@=, Value).
 1058:- else. 1059:- if(sicstus). 1060cmp(Var =@= Value, Var, variant, Value). % variant/2 is the same =@=
 1061:- endif. 1062:- endif. 1063
 1064
 1065%!  call_det(:Goal, -Det) is nondet.
 1066%
 1067%   True if Goal succeeded.  Det is unified to =true= if Goal left
 1068%   no choicepoints and =false= otherwise.
 1069
 1070:- if((swi|sicstus)). 1071call_det(Goal, Det) :-
 1072    call_cleanup(Goal,Det0=true),
 1073    ( var(Det0) -> Det = false ; Det = true ).
 1074:- else. 1075call_det(Goal, true) :-
 1076    call(Goal).
 1077:- endif. 1078
 1079%!  match_error(+Expected, +Received) is semidet.
 1080%
 1081%   True if the Received errors matches the expected error. Matching
 1082%   is based on subsumes_term/2.
 1083
 1084match_error(Expect, Rec) :-
 1085    subsumes_term(Expect, Rec).
 1086
 1087%!  setup(+Module, +Context, +Options) is semidet.
 1088%
 1089%   Call the setup handler and  fail  if   it  cannot  run  for some
 1090%   reason. The condition handler is  similar,   but  failing is not
 1091%   considered an error.  Context is one of
 1092%
 1093%       * unit(Unit)
 1094%       If it is the setup handler for a unit
 1095%       * test(Unit,Name,Line)
 1096%       If it is the setup handler for a test
 1097
 1098setup(Module, Context, Options) :-
 1099    option(condition(Condition), Options),
 1100    option(setup(Setup), Options),
 1101    !,
 1102    setup(Module, Context, [condition(Condition)]),
 1103    setup(Module, Context, [setup(Setup)]).
 1104setup(Module, Context, Options) :-
 1105    option(setup(Setup), Options),
 1106    !,
 1107    (   catch(call_ex(Module, Setup), E, true)
 1108    ->  (   var(E)
 1109        ->  true
 1110        ;   print_message(error, plunit(error(setup, Context, E))),
 1111            fail
 1112        )
 1113    ;   print_message(error, error(goal_failed(Setup), _)),
 1114        fail
 1115    ).
 1116setup(Module, Context, Options) :-
 1117    option(condition(Setup), Options),
 1118    !,
 1119    (   catch(call_ex(Module, Setup), E, true)
 1120    ->  (   var(E)
 1121        ->  true
 1122        ;   print_message(error, plunit(error(condition, Context, E))),
 1123            fail
 1124        )
 1125    ;   fail
 1126    ).
 1127setup(_,_,_).
 1128
 1129%!  call_ex(+Module, +Goal)
 1130%
 1131%   Call Goal in Module after applying goal expansion.
 1132
 1133call_ex(Module, Goal) :-
 1134    Module:(expand_goal(Goal, GoalEx),
 1135                GoalEx).
 1136
 1137%!  cleanup(+Module, +Options) is det.
 1138%
 1139%   Call the cleanup handler and succeed.   Failure  or error of the
 1140%   cleanup handler is reported, but tests continue normally.
 1141
 1142cleanup(Module, Options) :-
 1143    option(cleanup(Cleanup), Options, true),
 1144    (   catch(call_ex(Module, Cleanup), E, true)
 1145    ->  (   var(E)
 1146        ->  true
 1147        ;   print_message(warning, E)
 1148        )
 1149    ;   print_message(warning, goal_failed(Cleanup, '(cleanup handler)'))
 1150    ).
 1151
 1152success(Unit, Name, Line, Det, _Time, Options) :-
 1153    memberchk(fixme(Reason), Options),
 1154    !,
 1155    (   (   Det == true
 1156        ;   memberchk(nondet, Options)
 1157        )
 1158    ->  put_char(user_error, +),
 1159        Ok = passed
 1160    ;   put_char(user_error, !),
 1161        Ok = nondet
 1162    ),
 1163    flush_output(user_error),
 1164    assert(fixme(Unit, Name, Line, Reason, Ok)).
 1165success(Unit, Name, Line, _, _, Options) :-
 1166    failed_assertion(Unit, Name, Line, _,_,_,_),
 1167    !,
 1168    failure(Unit, Name, Line, assertion, Options).
 1169success(Unit, Name, Line, Det, Time, Options) :-
 1170    assert(passed(Unit, Name, Line, Det, Time)),
 1171    (   (   Det == true
 1172        ;   memberchk(nondet, Options)
 1173        )
 1174    ->  put_char(user_error, .)
 1175    ;   unit_file(Unit, File),
 1176        print_message(warning, plunit(nondet(File, Line, Name)))
 1177    ),
 1178    flush_output(user_error).
 1179
 1180failure(Unit, Name, Line, _, Options) :-
 1181    memberchk(fixme(Reason), Options),
 1182    !,
 1183    put_char(user_error, -),
 1184    flush_output(user_error),
 1185    assert(fixme(Unit, Name, Line, Reason, failed)).
 1186failure(Unit, Name, Line, E, Options) :-
 1187    report_failure(Unit, Name, Line, E, Options),
 1188    assert_cyclic(failed(Unit, Name, Line, E)).
 1189
 1190%!  assert_cyclic(+Term) is det.
 1191%
 1192%   Assert  a  possibly  cyclic  unit   clause.  Current  SWI-Prolog
 1193%   assert/1 does not handle cyclic terms,  so we emulate this using
 1194%   the recorded database.
 1195%
 1196%   @tbd    Implement cycle-safe assert and remove this.
 1197
 1198:- if(swi). 1199assert_cyclic(Term) :-
 1200    acyclic_term(Term),
 1201    !,
 1202    assert(Term).
 1203assert_cyclic(Term) :-
 1204    Term =.. [Functor|Args],
 1205    recorda(cyclic, Args, Id),
 1206    functor(Term, _, Arity),
 1207    length(NewArgs, Arity),
 1208    Head =.. [Functor|NewArgs],
 1209    assert((Head :- recorded(_, Var, Id), Var = NewArgs)).
 1210:- else. 1211:- if(sicstus). 1212:- endif. 1213assert_cyclic(Term) :-
 1214    assert(Term).
 1215:- endif. 1216
 1217
 1218                 /*******************************
 1219                 *            REPORTING         *
 1220                 *******************************/
 1221
 1222%!  begin_test(Unit, Test, Line, STO) is det.
 1223%!  end_test(Unit, Test, Line, STO) is det.
 1224%
 1225%   Maintain running/5 and report a test has started/is ended using
 1226%   a =silent= message:
 1227%
 1228%       * plunit(begin(Unit:Test, File:Line, STO))
 1229%       * plunit(end(Unit:Test, File:Line, STO))
 1230%
 1231%   @see message_hook/3 for intercepting these messages
 1232
 1233begin_test(Unit, Test, Line, STO) :-
 1234    thread_self(Me),
 1235    assert(running(Unit, Test, Line, STO, Me)),
 1236    unit_file(Unit, File),
 1237    print_message(silent, plunit(begin(Unit:Test, File:Line, STO))).
 1238
 1239end_test(Unit, Test, Line, STO) :-
 1240    thread_self(Me),
 1241    retractall(running(_,_,_,_,Me)),
 1242    unit_file(Unit, File),
 1243    print_message(silent, plunit(end(Unit:Test, File:Line, STO))).
 1244
 1245%!  running_tests is det.
 1246%
 1247%   Print the currently running test.
 1248
 1249running_tests :-
 1250    running_tests(Running),
 1251    print_message(informational, plunit(running(Running))).
 1252
 1253running_tests(Running) :-
 1254    findall(running(Unit:Test, File:Line, STO, Thread),
 1255            (   running(Unit, Test, Line, STO, Thread),
 1256                unit_file(Unit, File)
 1257            ), Running).
 1258
 1259
 1260%!  check_for_test_errors is semidet.
 1261%
 1262%   True if there are no errors, otherwise false.
 1263
 1264check_for_test_errors :-
 1265    number_of_clauses(failed/4, Failed),
 1266    number_of_clauses(failed_assertion/7, FailedAssertion),
 1267    number_of_clauses(sto/4, STO),
 1268    Failed+FailedAssertion+STO =:= 0.     % fail on errors
 1269
 1270
 1271%!  report is det.
 1272%
 1273%   Print a summary of the tests that ran.
 1274
 1275report :-
 1276    number_of_clauses(passed/5, Passed),
 1277    number_of_clauses(failed/4, Failed),
 1278    number_of_clauses(failed_assertion/7, FailedAssertion),
 1279    number_of_clauses(blocked/4, Blocked),
 1280    number_of_clauses(sto/4, STO),
 1281    (   Passed+Failed+FailedAssertion+Blocked+STO =:= 0
 1282    ->  info(plunit(no_tests))
 1283    ;   Failed+FailedAssertion+Blocked+STO =:= 0
 1284    ->  report_fixme,
 1285        info(plunit(all_passed(Passed)))
 1286    ;   report_blocked,
 1287        report_fixme,
 1288        report_failed_assertions,
 1289        report_failed,
 1290        report_sto,
 1291        info(plunit(passed(Passed)))
 1292    ).
 1293
 1294number_of_clauses(F/A,N) :-
 1295    (   current_predicate(F/A)
 1296    ->  functor(G,F,A),
 1297        findall(t, G, Ts),
 1298        length(Ts, N)
 1299    ;   N = 0
 1300    ).
 1301
 1302report_blocked :-
 1303    number_of_clauses(blocked/4,N),
 1304    N > 0,
 1305    !,
 1306    info(plunit(blocked(N))),
 1307    (   blocked(Unit, Name, Line, Reason),
 1308        unit_file(Unit, File),
 1309        print_message(informational,
 1310                      plunit(blocked(File:Line, Name, Reason))),
 1311        fail ; true
 1312    ).
 1313report_blocked.
 1314
 1315report_failed :-
 1316    number_of_clauses(failed/4, N),
 1317    info(plunit(failed(N))).
 1318
 1319report_failed_assertions :-
 1320    number_of_clauses(failed_assertion/7, N),
 1321    info(plunit(failed_assertions(N))).
 1322
 1323report_sto :-
 1324    number_of_clauses(sto/4, N),
 1325    info(plunit(sto(N))).
 1326
 1327report_fixme :-
 1328    report_fixme(_,_,_).
 1329
 1330report_fixme(TuplesF, TuplesP, TuplesN) :-
 1331    fixme(failed, TuplesF, Failed),
 1332    fixme(passed, TuplesP, Passed),
 1333    fixme(nondet, TuplesN, Nondet),
 1334    print_message(informational, plunit(fixme(Failed, Passed, Nondet))).
 1335
 1336
 1337fixme(How, Tuples, Count) :-
 1338    findall(fixme(Unit, Name, Line, Reason, How),
 1339            fixme(Unit, Name, Line, Reason, How), Tuples),
 1340    length(Tuples, Count).
 1341
 1342
 1343report_failure(_, _, _, assertion, _) :-
 1344    !,
 1345    put_char(user_error, 'A').
 1346report_failure(Unit, Name, Line, Error, _Options) :-
 1347    print_message(error, plunit(failed(Unit, Name, Line, Error))).
 1348
 1349
 1350%!  test_report(What) is det.
 1351%
 1352%   Produce reports on test results after the run.
 1353
 1354test_report(fixme) :-
 1355    !,
 1356    report_fixme(TuplesF, TuplesP, TuplesN),
 1357    append([TuplesF, TuplesP, TuplesN], Tuples),
 1358    print_message(informational, plunit(fixme(Tuples))).
 1359test_report(What) :-
 1360    throw_error(domain_error(report_class, What), _).
 1361
 1362
 1363                 /*******************************
 1364                 *             INFO             *
 1365                 *******************************/
 1366
 1367%!  current_test_set(?Unit) is nondet.
 1368%
 1369%   True if Unit is a currently loaded test-set.
 1370
 1371current_test_set(Unit) :-
 1372    current_unit(Unit, _Module, _Context, _Options).
 1373
 1374%!  unit_file(+Unit, -File) is det.
 1375%!  unit_file(-Unit, +File) is nondet.
 1376
 1377unit_file(Unit, File) :-
 1378    current_unit(Unit, Module, _Context, _Options),
 1379    current_module(Module, File).
 1380unit_file(Unit, PlFile) :-
 1381    nonvar(PlFile),
 1382    test_file_for(TestFile, PlFile),
 1383    current_module(Module, TestFile),
 1384    current_unit(Unit, Module, _Context, _Options).
 1385
 1386
 1387                 /*******************************
 1388                 *             FILES            *
 1389                 *******************************/
 1390
 1391%!  load_test_files(+Options) is det.
 1392%
 1393%   Load .plt test-files related to loaded source-files.
 1394
 1395load_test_files(_Options) :-
 1396    (   source_file(File),
 1397        file_name_extension(Base, Old, File),
 1398        Old \== plt,
 1399        file_name_extension(Base, plt, TestFile),
 1400        exists_file(TestFile),
 1401        (   test_file_for(TestFile, File)
 1402        ->  true
 1403        ;   load_files(TestFile,
 1404                       [ if(changed),
 1405                         imports([])
 1406                       ]),
 1407            asserta(test_file_for(TestFile, File))
 1408        ),
 1409        fail ; true
 1410    ).
 1411
 1412
 1413
 1414                 /*******************************
 1415                 *           MESSAGES           *
 1416                 *******************************/
 1417
 1418%!  info(+Term)
 1419%
 1420%   Runs print_message(Level, Term), where Level  is one of =silent=
 1421%   or =informational= (default).
 1422
 1423info(Term) :-
 1424    message_level(Level),
 1425    print_message(Level, Term).
 1426
 1427message_level(Level) :-
 1428    current_test_flag(test_options, Options),
 1429    option(silent(Silent), Options, false),
 1430    (   Silent == false
 1431    ->  Level = informational
 1432    ;   Level = silent
 1433    ).
 1434
 1435locationprefix(File:Line) -->
 1436    !,
 1437    [ '~w:~d:\n\t'-[File,Line]].
 1438locationprefix(test(Unit,_Test,Line)) -->
 1439    !,
 1440    { unit_file(Unit, File) },
 1441    locationprefix(File:Line).
 1442locationprefix(unit(Unit)) -->
 1443    !,
 1444    [ 'PL-Unit: unit ~w: '-[Unit] ].
 1445locationprefix(FileLine) -->
 1446    { throw_error(type_error(locationprefix,FileLine), _) }.
 1447
 1448:- discontiguous
 1449    message//1. 1450
 1451message(error(context_error(plunit_close(Name, -)), _)) -->
 1452    [ 'PL-Unit: cannot close unit ~w: no open unit'-[Name] ].
 1453message(error(context_error(plunit_close(Name, Start)), _)) -->
 1454    [ 'PL-Unit: cannot close unit ~w: current unit is ~w'-[Name, Start] ].
 1455message(plunit(nondet(File, Line, Name))) -->
 1456    locationprefix(File:Line),
 1457    [ 'PL-Unit: Test ~w: Test succeeded with choicepoint'- [Name] ].
 1458message(error(plunit(incompatible_options, Tests), _)) -->
 1459    [ 'PL-Unit: incompatible test-options: ~p'-[Tests] ].
 1460
 1461                                        % Unit start/end
 1462:- if(swi). 1463message(plunit(begin(Unit))) -->
 1464    [ 'PL-Unit: ~w '-[Unit], flush ].
 1465message(plunit(end(_Unit))) -->
 1466    [ at_same_line, ' done' ].
 1467:- else. 1468message(plunit(begin(Unit))) -->
 1469    [ 'PL-Unit: ~w '-[Unit]/*, flush-[]*/ ].
 1470message(plunit(end(_Unit))) -->
 1471    [ ' done'-[] ].
 1472:- endif. 1473message(plunit(blocked(unit(Unit, Reason)))) -->
 1474    [ 'PL-Unit: ~w blocked: ~w'-[Unit, Reason] ].
 1475message(plunit(running([]))) -->
 1476    !,
 1477    [ 'PL-Unit: no tests running' ].
 1478message(plunit(running([One]))) -->
 1479    !,
 1480    [ 'PL-Unit: running ' ],
 1481    running(One).
 1482message(plunit(running(More))) -->
 1483    !,
 1484    [ 'PL-Unit: running tests:', nl ],
 1485    running(More).
 1486message(plunit(fixme([]))) --> !.
 1487message(plunit(fixme(Tuples))) -->
 1488    !,
 1489    fixme_message(Tuples).
 1490
 1491                                        % Blocked tests
 1492message(plunit(blocked(1))) -->
 1493    !,
 1494    [ 'one test is blocked:'-[] ].
 1495message(plunit(blocked(N))) -->
 1496    [ '~D tests are blocked:'-[N] ].
 1497message(plunit(blocked(Pos, Name, Reason))) -->
 1498    locationprefix(Pos),
 1499    test_name(Name),
 1500    [ ': ~w'-[Reason] ].
 1501
 1502                                        % fail/success
 1503message(plunit(no_tests)) -->
 1504    !,
 1505    [ 'No tests to run' ].
 1506message(plunit(all_passed(1))) -->
 1507    !,
 1508    [ 'test passed' ].
 1509message(plunit(all_passed(Count))) -->
 1510    !,
 1511    [ 'All ~D tests passed'-[Count] ].
 1512message(plunit(passed(Count))) -->
 1513    !,
 1514    [ '~D tests passed'-[Count] ].
 1515message(plunit(failed(0))) -->
 1516    !,
 1517    [].
 1518message(plunit(failed(1))) -->
 1519    !,
 1520    [ '1 test failed'-[] ].
 1521message(plunit(failed(N))) -->
 1522    [ '~D tests failed'-[N] ].
 1523message(plunit(failed_assertions(0))) -->
 1524    !,
 1525    [].
 1526message(plunit(failed_assertions(1))) -->
 1527    !,
 1528    [ '1 assertion failed'-[] ].
 1529message(plunit(failed_assertions(N))) -->
 1530    [ '~D assertions failed'-[N] ].
 1531message(plunit(sto(0))) -->
 1532    !,
 1533    [].
 1534message(plunit(sto(N))) -->
 1535    [ '~D test results depend on unification mode'-[N] ].
 1536message(plunit(fixme(0,0,0))) -->
 1537    [].
 1538message(plunit(fixme(Failed,0,0))) -->
 1539    !,
 1540    [ 'all ~D tests flagged FIXME failed'-[Failed] ].
 1541message(plunit(fixme(Failed,Passed,0))) -->
 1542    [ 'FIXME: ~D failed; ~D passed'-[Failed, Passed] ].
 1543message(plunit(fixme(Failed,Passed,Nondet))) -->
 1544    { TotalPassed is Passed+Nondet },
 1545    [ 'FIXME: ~D failed; ~D passed; (~D nondet)'-
 1546      [Failed, TotalPassed, Nondet] ].
 1547message(plunit(failed(Unit, Name, Line, Failure))) -->
 1548    { unit_file(Unit, File) },
 1549    locationprefix(File:Line),
 1550    test_name(Name),
 1551    [': '-[] ],
 1552    failure(Failure).
 1553:- if(swi). 1554message(plunit(failed_assertion(Unit, Name, Line, AssertLoc,
 1555                                _STO, Reason, Goal))) -->
 1556    { unit_file(Unit, File) },
 1557    locationprefix(File:Line),
 1558    test_name(Name),
 1559    [ ': assertion'-[] ],
 1560    assertion_location(AssertLoc, File),
 1561    assertion_reason(Reason), ['\n\t'],
 1562    assertion_goal(Unit, Goal).
 1563
 1564assertion_location(File:Line, File) -->
 1565    [ ' at line ~w'-[Line] ].
 1566assertion_location(File:Line, _) -->
 1567    [ ' at ~w:~w'-[File, Line] ].
 1568assertion_location(unknown, _) -->
 1569    [].
 1570
 1571assertion_reason(fail) -->
 1572    !,
 1573    [ ' failed'-[] ].
 1574assertion_reason(Error) -->
 1575    { message_to_string(Error, String) },
 1576    [ ' raised "~w"'-[String] ].
 1577
 1578assertion_goal(Unit, Goal) -->
 1579    { unit_module(Unit, Module),
 1580      unqualify(Goal, Module, Plain)
 1581    },
 1582    [ 'Assertion: ~p'-[Plain] ].
 1583
 1584unqualify(Var, _, Var) :-
 1585    var(Var),
 1586    !.
 1587unqualify(M:Goal, Unit, Goal) :-
 1588    nonvar(M),
 1589    unit_module(Unit, M),
 1590    !.
 1591unqualify(M:Goal, _, Goal) :-
 1592    callable(Goal),
 1593    predicate_property(M:Goal, imported_from(system)),
 1594    !.
 1595unqualify(Goal, _, Goal).
 1596
 1597:- endif. 1598                                        % Setup/condition errors
 1599message(plunit(error(Where, Context, Exception))) -->
 1600    locationprefix(Context),
 1601    { message_to_string(Exception, String) },
 1602    [ 'error in ~w: ~w'-[Where, String] ].
 1603
 1604                                        % STO messages
 1605message(plunit(sto(Unit, Name, Line))) -->
 1606    { unit_file(Unit, File) },
 1607       locationprefix(File:Line),
 1608       test_name(Name),
 1609       [' is subject to occurs check (STO): '-[] ].
 1610message(plunit(sto(Type, Result))) -->
 1611    sto_type(Type),
 1612    sto_result(Result).
 1613
 1614                                        % Interrupts (SWI)
 1615:- if(swi). 1616message(interrupt(begin)) -->
 1617    { thread_self(Me),
 1618      running(Unit, Test, Line, STO, Me),
 1619      !,
 1620      unit_file(Unit, File)
 1621    },
 1622    [ 'Interrupted test '-[] ],
 1623    running(running(Unit:Test, File:Line, STO, Me)),
 1624    [nl],
 1625    '$messages':prolog_message(interrupt(begin)).
 1626message(interrupt(begin)) -->
 1627    '$messages':prolog_message(interrupt(begin)).
 1628:- endif. 1629
 1630test_name(@(Name,Bindings)) -->
 1631    !,
 1632    [ 'test ~w (forall bindings = ~p)'-[Name, Bindings] ].
 1633test_name(Name) -->
 1634    !,
 1635    [ 'test ~w'-[Name] ].
 1636
 1637sto_type(sto_error_incomplete) -->
 1638    [ 'Finite trees (error checking): ' ].
 1639sto_type(rational_trees) -->
 1640    [ 'Rational trees: ' ].
 1641sto_type(finite_trees) -->
 1642    [ 'Finite trees: ' ].
 1643
 1644sto_result(success(_Unit, _Name, _Line, Det, Time)) -->
 1645    det(Det),
 1646    [ ' success in ~2f seconds'-[Time] ].
 1647sto_result(failure(_Unit, _Name, _Line, How)) -->
 1648    failure(How).
 1649
 1650det(true) -->
 1651    [ 'deterministic' ].
 1652det(false) -->
 1653    [ 'non-deterministic' ].
 1654
 1655running(running(Unit:Test, File:Line, STO, Thread)) -->
 1656    thread(Thread),
 1657    [ '~q:~q at ~w:~d'-[Unit, Test, File, Line] ],
 1658    current_sto(STO).
 1659running([H|T]) -->
 1660    ['\t'], running(H),
 1661    (   {T == []}
 1662    ->  []
 1663    ;   [nl], running(T)
 1664    ).
 1665
 1666thread(main) --> !.
 1667thread(Other) -->
 1668    [' [~w] '-[Other] ].
 1669
 1670current_sto(sto_error_incomplete) -->
 1671    [ ' (STO: error checking)' ].
 1672current_sto(rational_trees) -->
 1673    [].
 1674current_sto(finite_trees) -->
 1675    [ ' (STO: occurs check enabled)' ].
 1676
 1677:- if(swi). 1678write_term(T, OPS) -->
 1679    ['~@'-[write_term(T,OPS)]].
 1680:- else. 1681write_term(T, _OPS) -->
 1682    ['~q'-[T]].
 1683:- endif. 1684
 1685expected_got_ops_(Ex, E, OPS, Goals) -->
 1686    ['    Expected: '-[]], write_term(Ex, OPS), [nl],
 1687    ['    Got:      '-[]], write_term(E,  OPS), [nl],
 1688    ( { Goals = [] } -> []
 1689    ; ['       with: '-[]], write_term(Goals, OPS), [nl]
 1690    ).
 1691
 1692
 1693failure(Var) -->
 1694    { var(Var) },
 1695    !,
 1696    [ 'Unknown failure?' ].
 1697failure(succeeded(Time)) -->
 1698    !,
 1699    [ 'must fail but succeeded in ~2f seconds~n'-[Time] ].
 1700failure(wrong_error(Expected, Error)) -->
 1701    !,
 1702    { copy_term(Expected-Error, Ex-E, Goals),
 1703      numbervars(Ex-E-Goals, 0, _),
 1704      write_options(OPS)
 1705    },
 1706    [ 'wrong error'-[], nl ],
 1707    expected_got_ops_(Ex, E, OPS, Goals).
 1708failure(wrong_answer(Cmp)) -->
 1709    { Cmp =.. [Op,Answer,Expected],
 1710      !,
 1711      copy_term(Expected-Answer, Ex-A, Goals),
 1712      numbervars(Ex-A-Goals, 0, _),
 1713      write_options(OPS)
 1714    },
 1715    [ 'wrong answer (compared using ~w)'-[Op], nl ],
 1716    expected_got_ops_(Ex, A, OPS, Goals).
 1717failure(wrong_answer(CmpExpected, Bindings)) -->
 1718    { (   CmpExpected = all(Cmp)
 1719      ->  Cmp =.. [_Op1,_,Expected],
 1720          Got = Bindings,
 1721          Type = all
 1722      ;   CmpExpected = set(Cmp),
 1723          Cmp =.. [_Op2,_,Expected0],
 1724          sort(Expected0, Expected),
 1725          sort(Bindings, Got),
 1726          Type = set
 1727      )
 1728    },
 1729    [ 'wrong "~w" answer:'-[Type] ],
 1730    [ nl, '    Expected: ~q'-[Expected] ],
 1731    [ nl, '       Found: ~q'-[Got] ].
 1732:- if(swi). 1733failure(cmp_error(_Cmp, Error)) -->
 1734    { message_to_string(Error, Message) },
 1735    [ 'Comparison error: ~w'-[Message] ].
 1736failure(Error) -->
 1737    { Error = error(_,_),
 1738      !,
 1739      message_to_string(Error, Message)
 1740    },
 1741    [ 'received error: ~w'-[Message] ].
 1742:- endif. 1743failure(Why) -->
 1744    [ '~p~n'-[Why] ].
 1745
 1746fixme_message([]) --> [].
 1747fixme_message([fixme(Unit, _Name, Line, Reason, How)|T]) -->
 1748    { unit_file(Unit, File) },
 1749    fixme_message(File:Line, Reason, How),
 1750    (   {T == []}
 1751    ->  []
 1752    ;   [nl],
 1753        fixme_message(T)
 1754    ).
 1755
 1756fixme_message(Location, Reason, failed) -->
 1757    [ 'FIXME: ~w: ~w'-[Location, Reason] ].
 1758fixme_message(Location, Reason, passed) -->
 1759    [ 'FIXME: ~w: passed ~w'-[Location, Reason] ].
 1760fixme_message(Location, Reason, nondet) -->
 1761    [ 'FIXME: ~w: passed (nondet) ~w'-[Location, Reason] ].
 1762
 1763
 1764write_options([ numbervars(true),
 1765                quoted(true),
 1766                portray(true),
 1767                max_depth(100),
 1768                attributes(portray)
 1769              ]).
 1770
 1771:- if(swi). 1772
 1773:- multifile
 1774    prolog:message/3,
 1775    user:message_hook/3. 1776
 1777prolog:message(Term) -->
 1778    message(Term).
 1779
 1780%       user:message_hook(+Term, +Kind, +Lines)
 1781
 1782user:message_hook(make(done(Files)), _, _) :-
 1783    make_run_tests(Files),
 1784    fail.                           % give other hooks a chance
 1785
 1786:- endif. 1787
 1788:- if(sicstus). 1789
 1790user:generate_message_hook(Message) -->
 1791    message(Message),
 1792    [nl].                           % SICStus requires nl at the end
 1793
 1794%!  user:message_hook(+Severity, +Message, +Lines) is semidet.
 1795%
 1796%   Redefine printing some messages. It appears   SICStus has no way
 1797%   to get multiple messages at the same   line, so we roll our own.
 1798%   As there is a lot pre-wired and   checked in the SICStus message
 1799%   handling we cannot reuse the lines. Unless I miss something ...
 1800
 1801user:message_hook(informational, plunit(begin(Unit)), _Lines) :-
 1802    format(user_error, '% PL-Unit: ~w ', [Unit]),
 1803    flush_output(user_error).
 1804user:message_hook(informational, plunit(end(_Unit)), _Lines) :-
 1805    format(user, ' done~n', []).
 1806
 1807:- endif.