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