diff --git a/.gitmodules b/.gitmodules index 57cbc0f88..f4839bef8 100644 --- a/.gitmodules +++ b/.gitmodules @@ -25,3 +25,6 @@ [submodule "packages/semweb"] path = packages/semweb url = ssh://vsc@yap.git.sourceforge.net/gitroot/yap/semweb +[submodule "packages/plunit"] + path = packages/plunit + url = ssh://vsc@yap.git.sourceforge.net/gitroot/yap/plunit diff --git a/C/c_interface.c b/C/c_interface.c index 39d16a286..0718bdc91 100755 --- a/C/c_interface.c +++ b/C/c_interface.c @@ -1427,105 +1427,106 @@ execute_cargs_back(PredEntry *pe, CPredicate exec_code, struct foreign_context * case 1: { CBPredicate1 code1 = (CBPredicate1)exec_code; - return ((code1)(Yap_InitSlot(Deref(ARG1) PASS_REGS), + return ((code1)(&B->cp_a1-LCL0, ctx)); } case 2: { CBPredicate2 code2 = (CBPredicate2)exec_code; - return ((code2)(Yap_InitSlot(Deref(ARG1) PASS_REGS), - Yap_InitSlot(Deref(ARG2) PASS_REGS), + return ((code2)(&B->cp_a1-LCL0, + &B->cp_a2-LCL0, ctx)); } case 3: { CBPredicate3 code3 = (CBPredicate3)exec_code; - return ((code3)(Yap_InitSlot(Deref(ARG1) PASS_REGS), - Yap_InitSlot(Deref(ARG2) PASS_REGS), - Yap_InitSlot(Deref(ARG3) PASS_REGS), + return ((code3)(&B->cp_a1-LCL0, + &B->cp_a2-LCL0, + &B->cp_a3-LCL0, ctx)); } case 4: { CBPredicate4 code4 = (CBPredicate4)exec_code; - return ((code4)(Yap_InitSlot(Deref(ARG1) PASS_REGS), - Yap_InitSlot(Deref(ARG2) PASS_REGS), - Yap_InitSlot(Deref(ARG3) PASS_REGS), - Yap_InitSlot(Deref(ARG4) PASS_REGS), + return ((code4)(&B->cp_a1-LCL0, + &B->cp_a2-LCL0, + &B->cp_a3-LCL0, + &B->cp_a4-LCL0, ctx)); } case 5: { CBPredicate5 code5 = (CBPredicate5)exec_code; - return ((code5)(Yap_InitSlot(Deref(ARG1) PASS_REGS), - Yap_InitSlot(Deref(ARG2) PASS_REGS), - Yap_InitSlot(Deref(ARG3) PASS_REGS), - Yap_InitSlot(Deref(ARG4) PASS_REGS), - Yap_InitSlot(Deref(ARG5) PASS_REGS), ctx)); + return ((code5)(&B->cp_a1-LCL0, + &B->cp_a2-LCL0, + &B->cp_a3-LCL0, + &B->cp_a4-LCL0, + &B->cp_a5-LCL0, + ctx)); } case 6: { CBPredicate6 code6 = (CBPredicate6)exec_code; - return ((code6)(Yap_InitSlot(Deref(ARG1) PASS_REGS), - Yap_InitSlot(Deref(ARG2) PASS_REGS), - Yap_InitSlot(Deref(ARG3) PASS_REGS), - Yap_InitSlot(Deref(ARG4) PASS_REGS), - Yap_InitSlot(Deref(ARG5) PASS_REGS), - Yap_InitSlot(Deref(ARG6) PASS_REGS), + return ((code6)(&B->cp_a1-LCL0, + &B->cp_a2-LCL0, + &B->cp_a3-LCL0, + &B->cp_a4-LCL0, + &B->cp_a5-LCL0, + &B->cp_a6-LCL0, ctx)); } case 7: { CBPredicate7 code7 = (CBPredicate7)exec_code; - return ((code7)(Yap_InitSlot(Deref(ARG1) PASS_REGS), - Yap_InitSlot(Deref(ARG2) PASS_REGS), - Yap_InitSlot(Deref(ARG3) PASS_REGS), - Yap_InitSlot(Deref(ARG4) PASS_REGS), - Yap_InitSlot(Deref(ARG5) PASS_REGS), - Yap_InitSlot(Deref(ARG6) PASS_REGS), - Yap_InitSlot(Deref(ARG7) PASS_REGS), + return ((code7)(&B->cp_a1-LCL0, + &B->cp_a2-LCL0, + &B->cp_a3-LCL0, + &B->cp_a4-LCL0, + &B->cp_a5-LCL0, + &B->cp_a6-LCL0, + &B->cp_a7-LCL0, ctx)); } case 8: { CBPredicate8 code8 = (CBPredicate8)exec_code; - return ((code8)(Yap_InitSlot(Deref(ARG1) PASS_REGS), - Yap_InitSlot(Deref(ARG2) PASS_REGS), - Yap_InitSlot(Deref(ARG3) PASS_REGS), - Yap_InitSlot(Deref(ARG4) PASS_REGS), - Yap_InitSlot(Deref(ARG5) PASS_REGS), - Yap_InitSlot(Deref(ARG6) PASS_REGS), - Yap_InitSlot(Deref(ARG7) PASS_REGS), - Yap_InitSlot(Deref(ARG8) PASS_REGS), + return ((code8)(&B->cp_a1-LCL0, + &B->cp_a2-LCL0, + &B->cp_a3-LCL0, + &B->cp_a4-LCL0, + &B->cp_a5-LCL0, + &B->cp_a6-LCL0, + &B->cp_a7-LCL0, + &B->cp_a8-LCL0, ctx)); } case 9: { CBPredicate9 code9 = (CBPredicate9)exec_code; - return ((code9)(Yap_InitSlot(Deref(ARG1) PASS_REGS), - Yap_InitSlot(Deref(ARG2) PASS_REGS), - Yap_InitSlot(Deref(ARG3) PASS_REGS), - Yap_InitSlot(Deref(ARG4) PASS_REGS), - Yap_InitSlot(Deref(ARG5) PASS_REGS), - Yap_InitSlot(Deref(ARG6) PASS_REGS), - Yap_InitSlot(Deref(ARG7) PASS_REGS), - Yap_InitSlot(Deref(ARG8) PASS_REGS), - Yap_InitSlot(Deref(ARG9) PASS_REGS), + return ((code9)(&B->cp_a1-LCL0, + &B->cp_a2-LCL0, + &B->cp_a3-LCL0, + &B->cp_a4-LCL0, + &B->cp_a5-LCL0, + &B->cp_a6-LCL0, + &B->cp_a7-LCL0, + &B->cp_a8-LCL0, + &B->cp_a9-LCL0, ctx)); } case 10: { CBPredicate10 code10 = (CBPredicate10)exec_code; - return ((code10)(Yap_InitSlot(Deref(ARG1) PASS_REGS), - Yap_InitSlot(Deref(ARG2) PASS_REGS), - Yap_InitSlot(Deref(ARG3) PASS_REGS), - Yap_InitSlot(Deref(ARG4) PASS_REGS), - Yap_InitSlot(Deref(ARG5) PASS_REGS), - Yap_InitSlot(Deref(ARG6) PASS_REGS), - Yap_InitSlot(Deref(ARG7) PASS_REGS), - Yap_InitSlot(Deref(ARG8) PASS_REGS), - Yap_InitSlot(Deref(ARG9) PASS_REGS), - Yap_InitSlot(Deref(ARG10) PASS_REGS), + return ((code10)(&B->cp_a1-LCL0, + &B->cp_a2-LCL0, + &B->cp_a3-LCL0, + &B->cp_a4-LCL0, + &B->cp_a5-LCL0, + &B->cp_a6-LCL0, + &B->cp_a7-LCL0, + &B->cp_a8-LCL0, + &B->cp_a9-LCL0, + &B->cp_a10-LCL0, ctx)); } default: @@ -1595,7 +1596,7 @@ YAP_ExecuteFirst(PredEntry *pe, CPredicate exec_code) if (pe->PredFlags & CArgsPredFlag) { val = execute_cargs_back(pe, exec_code, ctx PASS_REGS); } else { - val = ((codev)((&ARG1)-LCL0,0,ctx)); + val = ((codev)(B->cp_args-LCL0,0,ctx)); } /* make sure we clean up the frames left by the user */ while (execution != oexec) @@ -1710,7 +1711,7 @@ YAP_ExecuteNext(PredEntry *pe, CPredicate exec_code) if (pe->PredFlags & CArgsPredFlag) { val = execute_cargs_back(pe, exec_code, ctx PASS_REGS); } else { - val = ((codev)((&ARG1)-LCL0,0,ctx)); + val = ((codev)(B->cp_args-LCL0,0,ctx)); } /* make sure we clean up the frames left by the user */ while (execution != oexec) @@ -1732,12 +1733,10 @@ YAP_ExecuteNext(PredEntry *pe, CPredicate exec_code) } else if (val == 1) { /* TRUE */ cut_succeed(); } else { - /* - if ((val & REDO_PTR) == REDO_PTR) + if ((val & REDO_PTR) == REDO_PTR) ctx->context = (int *)(val & ~REDO_PTR); - else + else ctx->context = (int *)((val & ~REDO_PTR)>>FRG_REDO_BITS); - */ } return TRUE; } else { diff --git a/H/amidefs.h b/H/amidefs.h index bb889fd3a..8f467e1dc 100644 --- a/H/amidefs.h +++ b/H/amidefs.h @@ -952,6 +952,8 @@ typedef struct choicept { #define cp_a6 cp_args[5] #define cp_a7 cp_args[6] #define cp_a8 cp_args[7] +#define cp_a9 cp_args[8] +#define cp_a10 cp_args[9] #define EXTRA_CBACK_ARG(Arity,Offset) B->cp_args[(Arity)+(Offset)-1] #else /* Otherwise, we need a very dirty trick to access the arguments */ diff --git a/library/dialect/swi.yap b/library/dialect/swi.yap index 19ad38b4e..5f3c0055f 100755 --- a/library/dialect/swi.yap +++ b/library/dialect/swi.yap @@ -5,7 +5,6 @@ :- module(system, [concat_atom/2, concat_atom/3, - setenv/2, read_clause/1, string/1, chdir/1, @@ -154,8 +153,6 @@ concat_atom(List, New) :- atomic_concat(List, New). -setenv(X,Y) :- unix(putenv(X,Y)). - read_clause(X,Y) :- read_term(X,Y,[singetons(warning)]). diff --git a/library/dialect/swi/fli/swi.c b/library/dialect/swi/fli/swi.c index e1451eedb..f112beffa 100755 --- a/library/dialect/swi/fli/swi.c +++ b/library/dialect/swi/fli/swi.c @@ -2621,25 +2621,15 @@ PL_eval_expression_to_int64_ex(term_t t, int64_t *val) } foreign_t -_PL_retry(intptr_t n) +_PL_retry(intptr_t v) { - CACHE_REGS - /* first we need to get the pointer to the predicate */ - PredEntry *pe = B->cp_ap->u.OtapFs.p; - struct foreign_context *ctx = (struct foreign_context *)(&EXTRA_CBACK_ARG(pe->ArityOfPE,1)); - ctx->context = n; - return LCL0-(CELL *)ctx; + return (((uintptr_t)(v)<cp_ap->u.OtapFs.p; - struct foreign_context *ctx = (struct foreign_context *)(&EXTRA_CBACK_ARG(pe->ArityOfPE,1)); - ctx->context = (intptr_t)addr; - return LCL0-(CELL *)ctx; + return (((uintptr_t)(addr))|REDO_PTR); } diff --git a/packages/RDF b/packages/RDF index 613a7199e..220431a82 160000 --- a/packages/RDF +++ b/packages/RDF @@ -1 +1 @@ -Subproject commit 613a7199e420a734717f2887c17b4fc3ef30f67e +Subproject commit 220431a82d88734dfcde0201655e9f67adfdd4a1 diff --git a/packages/clib b/packages/clib index b9631d198..449c7a945 160000 --- a/packages/clib +++ b/packages/clib @@ -1 +1 @@ -Subproject commit b9631d198164fbeebda627ed440ce2a36be84914 +Subproject commit 449c7a945cba6452634222592eef25f845d3e677 diff --git a/packages/plunit b/packages/plunit new file mode 160000 index 000000000..52469bccc --- /dev/null +++ b/packages/plunit @@ -0,0 +1 @@ +Subproject commit 52469bccc1cc81d06e47a3a781128689f4658542 diff --git a/packages/plunit/ChangeLog b/packages/plunit/ChangeLog deleted file mode 100644 index f83fb0297..000000000 --- a/packages/plunit/ChangeLog +++ /dev/null @@ -1,172 +0,0 @@ -[Jul 29 2009] - - * ENHANCED: System and library modules now use =system= as their parent module rather than =user=. -[Jun 15 2009] - - * DOC: Item#483: Broken link in PlUnit. Ulrich Neumerkel. - -[May 14 2009] - - * DOC: module specifier, typos - -[Mar 19 2009] - - * CLEANUP: Removed all trailing whitespace from all source-files. This avoids many GIT (merge) warnings. -[Mar 12 2009] - - * MODIFIED: Renamed concat_atom/2,3 into atomic_list_concat/2,3 for compatibility. Moved the old predicates into library(backcomp). It is adviced to update your code, but 99% of the code will remain working because the old definitions are autoloaded. -[Feb 11 2009] - - * CLEANUP: Module declaration code -[Sep 11 2008] - - * PORT: Add AC_PREREQ to configure.h for systems that auto-select autoconf - versions. After tip by Ulrich Neumerkel. - -[Aug 11 2008] - - * INSTALL: Remove all configure files from the git repository - -[Jul 10 2008] - - * FIXED: PlUnit: Perform goal_expansion/2 on setup, condition and cleanup options. - Ivo Swartjes. - -[Jun 26 2008] - - * ADDED: forall option to unit tests that allows running the same test on - different data sets. - - * FIXED: wrong handling of gloabl option sto(false) -[May 31 2008] - - * FIXED: Properly support tests with condition and setup - -[May 14 2008] - - * ENHANCED: PlUnit: Test options in set_test_options/1; fix documentation. - -[May 9 2008] - - * ADDED: Allow specifying sto mode for an entire test set - -[May 1 2008] - - * DOC: plunit and non termination - -[Apr 28 2008] - - * ADDED: flag tests using `fixme'. Suggested under the name `desired' by - Ulrich Neumerkel. Let us see how this works out in practice! - -[Apr 24 2008] - - * ENHANCED: When interrupting a thread, indicate which one. - - * ADDED: PlUnit: running_tests/0 to find what test is running. - - * FIXED: wrong dynamic declaration in plunit.pl - -[Mar 11 2008] - - * ENHANCED: Provide file/line info for errors in setup and condition - -[Feb 4 2008] - - * FIXED: STO independent of timings, Item#316 - -[Jan 31 2008] - - * DOC: formatting - -[Jan 30 2008] - - * ENHANCED: PlUnit: run_tests(Unit) raise error on non-existing unit. - Item#305, Ulrich Neumerkel. - - * ENHANCED: PlUnit: reporting STO and setting STO checking options - -[Jan 29 2008] - - * CLEANUP: PlUnit: some reorganisation of the test loop, preparing for further - enhancements. - -[Jan 28 2008] - - * ADDED: subsumes/2 and subsumes_chk/2 as built-in predicates. - - * ENHANCED: Really load no tests if not asked to do and provide better feedback - if no tests where loaded or all tests passed. - - * FIXED: DCG: cut transparency, output unification, preserve erroneous non-terminals - * ENHANCED: DCG: more tests - * FIXED: PlUnit version confusion - -[2008-01-26] - - * FIXED: portability for SICStus 3.12 - * ENHANCED: new option sto - -[Jan 14 2008] - - * FIXED: Non-determinism in run_tests/0 if there are blocked tests. - -[Dec 21 2007] - - * FIXED: PlUnit printing of wrong answers if there are attributes. Ulrich - Neumerkel, item#242 -Oct 30, 2007 - -* ENHANCED: Report error or failure in cleanup handler (Mark van Assem) -* ENHANCED: Do not report '% All tests passed' if no tests are - executed after a make/0. - -Sep 21, 2007 - -* ENHANCED: Verify test-set and test options. - -* ADDED: Allow for Var == Value as shorthand for true(Var == Value). - -Sep 20, 2007 - -* ENHANCED: Message on wrong error - -* DOCS: Fixed typos. Ulrich Neumerkel. - -* FIXED: avoid a loop if a test throws an error holding a cyclic term. - -* MODIFIED: errors are now verified using subsumes_chk/2 instead of =@=. - -* PORT: =@= is now correctly bound to variant/2 for SICStus. - -Aug 1, 2007 - -* FIXED: Ran failing tests twice due to unwanted choicepoint. - -Jul 30, 2007 - -* ADDED: allow for error(Error) as alias for throws(error(Error, _)). - -Mar 28, 2007 - -* ADDED: option silent(Bool) to force completely silent operation. - -Mar 6, 2007 - -* Allow for single option without list - -Nov 23, 2006 - -* Force start of line after .... - -Oct 22, 2006 - -* Allow tracing body of tests. Suggested by Lukas Degener. - -Oct 17, 2006 - -* Portability with SICStus 3.12. - -Oct 13, 2006 - -* Better message for tests that succeeded but should have failed diff --git a/packages/plunit/Makefile.in b/packages/plunit/Makefile.in deleted file mode 100755 index 95aae4d3e..000000000 --- a/packages/plunit/Makefile.in +++ /dev/null @@ -1,137 +0,0 @@ -################################################################ -# SWI-Prolog `PlDoc' package -# Author: Jan Wielemaker. wielemak@science.uva.nl -# Copyright: GPL (see COPYING or www.gnu.org -################################################################ - -.SUFFIXES: .tex .dvi .doc .pl - -SHELL=@SHELL@ - -ifeq (@PROLOG_SYSTEM@,yap) - -prefix = @prefix@ -exec_prefix = @exec_prefix@ -ROOTDIR = $(prefix) -EROOTDIR = @exec_prefix@ - -srcdir=@srcdir@ - -BINDIR = $(EROOTDIR)/bin -LIBDIR=@libdir@ -YAPLIBDIR=@libdir@/Yap -SHAREDIR=$(EROOTDIR)/share/Yap - -PL=@INSTALL_ENV@ $(DESTDIR)$(BINDIR)/yap $(DESTDIR)$(YAPLIBDIR)/startup.yss -LN_S=@LN_S@ -EXDIR=$(LIBDIR)/examples/plunit - -INSTALLDIR=$(SHAREDIR) - -else # SWI - -srcdir=. - -PLBASE=@PLBASE@ -PLARCH=@PLARCH@ -PL=@PL@ -XPCEBASE=$(PLBASE)/xpce -PKGDOC=$(PLBASE)/doc/packages -PCEHOME=../xpce -LIBDIR=$(PLBASE)/library -EXDIR=$(PKGDOC)/examples/plunit - -INSTALLDIR=$(LIBDIR) - -endif - -DESTDIR= - -DOCTOTEX=$(PCEHOME)/bin/doc2tex -PLTOTEX=$(PCEHOME)/bin/pl2tex -vLATEX=latex -DOC=plunit -TEX=$(DOC).tex -DVI=$(DOC).dvi -PDF=$(DOC).pdf -HTML=$(DOC).html - -INSTALL=@INSTALL@ -INSTALL_PROGRAM=@INSTALL_PROGRAM@ -INSTALL_DATA=@INSTALL_DATA@ - -LIBPL= $(srcdir)/plunit.pl $(srcdir)/test_wizard.pl $(srcdir)/test_cover.pl -LIBALL= $(LIBPL) $(SUPPORT) -EXAMPLES= $(srcdir)/read.pl $(srcdir)/simple.pl - -all: - @echo "Nothing to do for this package" - -install: $(LIBPL) - mkdir -p $(DESTDIR)$(INSTALLDIR) - $(INSTALL_DATA) $(LIBALL) $(DESTDIR)$(INSTALLDIR) - $(PL) -f none -g make -t halt - -ln-install: $(LIBPL) - mkdir -p $(DESTDIR)$(INSTALLDIR) - for f in $(LIBALL); do \ - rm -f $(DESTDIR)$(INSTALLDIR)/$$f; \ - ln -s `pwd`/$$f $(DESTDIR)$(INSTALLDIR); \ - done - $(PL) -f none -g make -t halt - -rpm-install: install - -pdf-install: install-examples - $(INSTALL_DATA) $(DOC).pdf $(DESTDIR)$(PKGDOC) - -html-install: install-examples - $(INSTALL_DATA) $(DOC).html $(DESTDIR)$(PKGDOC) - -install-examples:: - mkdir -p $(DESTDIR)$(EXDIR) - (cd examples && $(INSTALL_DATA) $(EXAMPLES) $(DESTDIR)$(EXDIR)) - -uninstall:: - rm -f $(DESTDIR)$(INSTALLDIR)/plunit.pl - $(PL) -f none -g make -t halt - -check:: - true - -################################################################ -# Documentation -################################################################ - -doc: $(PDF) $(HTML) -pdf: $(PDF) -html: $(HTML) - -$(HTML): $(TEX) - latex2html $(DOC) - mv html/index.html $@ - rmdir html - -$(PDF): $(TEX) - ../../man/runtex --pdf $(DOC) - -$(TEX): $(DOCTOTEX) - -.doc.tex: - $(DOCTOTEX) $*.doc > $*.tex -.pl.tex: - $(PLTOTEX) $*.pl > $*.tex - -################################################################ -# Clean -################################################################ - -clean: - rm -f *~ *% config.log - -# rm -f $(TEX) -# ../../man/runtex --clean $(DOC) -# rm -rf html - -distclean: clean - rm -f $(TARGETS) config.cache config.status Makefile diff --git a/packages/plunit/README b/packages/plunit/README deleted file mode 100644 index d8f2b4a08..000000000 --- a/packages/plunit/README +++ /dev/null @@ -1,46 +0,0 @@ -Prolog Unit Tests -================= - - ----++ TBD - - * Add options to test units - - Condition, setup, cleanup, blocked [OK] - * Run the tests on make, etc. [OK] - * Report generation options - ----++ What to do with loaded tests? - - * Keep them around - * Remove them - * Flag module as `volatile', so it is not saved. - ----++ Distinguish user/system/library tests - ----++ Deal with seperate test-files: - - * load_test_files(+Options) - ----++ Volatile modules? - ----++ Conversion of system tests: - - - test.pl internals [OK] - - scripts called from test.pl [OK] - - tests for packages - ----++ Run tests concurrently? - - + Tests applications for concurrent execution - + Saves time, notably on tests doing networking, timeout, etc. - - Might be more complicated to understand - ----++ Test wizard - - * Write tests to .plt files - * Merge with existing content of .plt files - - Read with comments and write back? - ----++ Coverage analysis - - * See cover.pl diff --git a/packages/plunit/examples/read.pl b/packages/plunit/examples/read.pl deleted file mode 100644 index a3ab885a0..000000000 --- a/packages/plunit/examples/read.pl +++ /dev/null @@ -1,27 +0,0 @@ - -:- use_module(library(plunit)). - -:- begin_tests(read). - -:- use_module(library(system)). - -:- use_module(library(readutil)). - -create_file(Tmp) :- - tmp_file(plunit, Tmp), - open(Tmp, write, Out), - write(Out, 'hello(World).\n'), - close(Out). - -test(read, [ setup(create_file(Tmp)), - cleanup(delete_file(Tmp)) - ]) :- - read_file_to_terms(Tmp, Terms, []), - Terms =@= [hello(_)]. - -:- end_tests(read). - -:- trace,run_tests. - - - diff --git a/packages/plunit/examples/simple.pl b/packages/plunit/examples/simple.pl deleted file mode 100644 index 688a6ca94..000000000 --- a/packages/plunit/examples/simple.pl +++ /dev/null @@ -1,37 +0,0 @@ -:- module(ex_simple, []). - -:- use_module(library(plunit)). - -:- begin_tests(lists). - -test(true) :- - true. - -test(fail) :- - \+ fail. - -test(fail, [fail]) :- - fail. - -test(member) :- - member(a, [a]), !. - -test(member, [nondet]) :- - member(_, [a]). - -test(member, [true(X == a)]) :- - member(X, [a]), !. - -test(member, [all(V == [a,b,c])]) :- - member(V, [a,b,c]). - -test(append) :- - append("aap", "noot", X), - X == "aapnoot". - -:- end_tests(lists). - -:- run_tests. - -:- run_tests(lists:member). - diff --git a/packages/plunit/plunit.doc b/packages/plunit/plunit.doc deleted file mode 100644 index f08c3c618..000000000 --- a/packages/plunit/plunit.doc +++ /dev/null @@ -1,671 +0,0 @@ -\documentclass[11pt]{article} -\usepackage{times} -\usepackage{pl} -\usepackage{html} -\usepackage{plpage} -\sloppy -\makeindex - -\onefile -\htmloutput{html} % Output directory -\htmlmainfile{index} % Main document file -\bodycolor{white} % Page colour - -\renewcommand{\runningtitle}{Prolog Unit Tests} - -\begin{document} - -\title{Prolog Unit Tests} -\author{Jan Wielemaker \\ - HCS, \\ - University of Amsterdam \\ - The Netherlands \\ - E-mail: \email{wielemak@science.uva.nl}} - -\maketitle - -\begin{abstract} -This document describes a Prolog unit-test framework. This framework was -initially developed for \url[SWI-Prolog]{http://www.swi-prolog.org}. The -current version also runs on \url[SICStus -Prolog]{http://www.sics.se/sicstus/}, providing a portable testing -framework. See \secref{sicstus}. -\end{abstract} - -\pagebreak -\tableofcontents - -\vfill -\vfill - -\newpage - -\section{Introduction} -\label{sec:intro} - -There is really no excuse not to write tests! - -Automatic testing of software during development is probably the most -important Quality Assurance measure. Tests can validate the final -system, which is nice for your users. However, most (Prolog) developers -forget that it is not just a burden during development. - -\begin{itemize} - \item Tests document how the code is supposed to be used. - \item Tests can validate claims you make on the Prolog - implementation. Writing a test makes the claim - explicit. - \item Tests avoid big applications saying `No' after - modifications. This saves time during development, - and it saves \emph{a lot} of time if you must return - to the application a few years later or you must - modify and debug someone else's application. -\end{itemize} - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{A Unit Test box} -\label{sec:unitbox} - -Tests are written in pure Prolog and enclosed within the directives -begin_tests/1,2 and end_tests/1. They can be embedded inside a normal -source module, or be placed in a separate test-file that loads the files -to be tested. Code inside a test box is normal Prolog code. The -entry points are defined by rules using the head \term{test}{Name} or -\term{test}{Name, Options}, where \arg{Name} is a ground term and -\arg{Options} is a list describing additional properties of the test. -Here is a very simple example: - -\begin{code} -:- begin_tests(lists). -:- use_module(library(lists)). - -test(reverse) :- - reverse([a,b], [b,a]). - -:- end_tests(lists). -\end{code} - -The optional second argument of the test-head defines additional processing -options. Defined options are: - -\begin{description} - \termitem{blocked}{+Reason:atom} -The test is currently disabled. Tests are flagged as blocked if they -cannot be run for some reason. E.g.\ they crash Prolog, they rely on -some service that is not available, they take too much resources, etc. -Tests that fail but do not crash, etc.\ should be flagged using -\term{fixme}{Fixme}. - - \termitem{fixme}{+Reason:atom} -Similar to \term{blocked}{Reason}, but the test it executed anyway. If -it fails, a \const{-} is printed instead of the \const{.} character. If -it passes a \const{+} and if it passes with a choicepoint, \const{!}. -A summary is printed at the end of the test run and the goal -\term{test_report}{fixme} can be used to get details. - - \termitem{condition}{:Goal} -Pre-condition for running the test. If the condition fails -the test is skipped. The condition can be used as an alternative -to the \const{setup} option. The only difference is that failure -of a condition skips the test and is considered an error when using -the \const{setup} option. - - \termitem{cleanup}{:Goal} -\arg{Goal} is always called after completion of the test-body, -regardless of whether it fails, succeeds or throws an exception. This -option or call_cleanup/2 must be used by tests that require side-effects -that must be reverted after the test completes. \arg{Goal} may share -variables with the test body. - -\begin{code} -create_file(Tmp) :- - tmp_file(plunit, Tmp), - open(Tmp, write, Out), - write(Out, 'hello(World).\n'), - close(Out). - -test(read, [ setup(create_file(Tmp)), - cleanup(delete_file(Tmp)) - ]) :- - read_file_to_terms(Tmp, Terms, []), - Term = hello(_). -\end{code} - - \termitem{setup}{:Goal} -\arg{Goal} is run before the test-body. Typically used together with -the \const{cleanup} option to create and destroy the required execution -environment. - - \termitem{forall}{:Generator} -Run the same test for each solution of \arg{Generator}. Each run invokes -the setup and cleanup handlers. This can be used to run the same test -with different inputs. If an error occurs, the test is reported as -\mbox{\texttt{name (forall bindings = } \texttt{)}}, where - indicates the bindings of variables in \arg{Generator}. - - \termitem{true}{AnswerTerm Cmp Value} -Body must succeed deterministically. AnswerTerm is compared to Value -using the comparison operator \arg{Cmp}. \arg{Cmp} is typically one of -=/2, ==/2, =:=/2 or =@=/2,% - \footnote{The =@= predicate (denoted \emph{structural equivalence}) - is the same as variant/2 in SICStus.} -but any test can be used. This is the same as inserting the test at the -end of the conjunction, but it allows the test engine to distinguish -between failure of copy_term/2 and producing the wrong value. Multiple -variables must be combined in an arbitrary compound term. E.g.\ -\verb$A1-A2 == v1-v2$ - -\begin{code} -test(copy, [ true(Copy =@= hello(X,X)) - ]) :- - copy_term(hello(Y,Y), Copy). -\end{code} - - \termitem{AnswerTerm Cmp Value} -Equivalent to \term{true}{AnswerTerm Cmp Value} if \arg{Cmp} is one -of the comparison operators given above. - - \termitem{fail}{} -Body must fail. - - \termitem{throws}{Error} -Body must throw \arg{Error}. The error is verified using -\term{subsumes_chk}{Error, Generated}. I.e.\ the generated error -must be more specific than the specified \arg{Error}. - - \termitem{error}{Error} -Body must throw \term{error}{Error, _Context}. See \const{throws} -for details. - - \termitem{all}{AnswerTerm Cmp Instances} -Similar to \term{true}{AnswerTerm Cmp Values}, but used for non-deterministic -predicates. Each element is compared using \arg{Cmp}. Order matters. For -example: - -\begin{code} -test(or, all(X == [1,2])) :- - ( X = 1 ; X = 2 ). -\end{code} - - \termitem{set}{AnswerTerm Cmp Instances} -Similar to \term{all}{AnswerTerm Cmp Instances}, but ignores order and -duplicates with respect to \arg{Cmp} in the comparison. Each element is -compared using \arg{Cmp}. - - \termitem{nondet}{} -If this keyword appears in the option list, non-deterministic success -of the body is not considered an error. - - \termitem{sto}{Terms} -Declares that executing body is subject to occurs-check (STO). The -test is executed with \arg{Terms}. \arg{Terms} is either -\const{rational_trees} or \const{finite_trees}. STO programs are not -portable between different kinds of terms. Only programs \emph{not} -subject to occurs-check (NSTO) are portable\footnote{See 7.3.3 of -ISO/IEC 13211-1 PROLOG: Part 1 - General Core, for a detailed -discussion of STO and NSTO}. Fortunately, most practical programs are -NSTO. Writing tests that are STO is still useful to ensure the -robustness of a predicate. In case sto4 and sto5 below, an infinite -list (a rational tree) is created prior to calling the actual -predicate. Ideally, such cases produce a type error or fail silently. - -\begin{code} -test(sto1, [sto(rational_trees)]) :- - X=s(X). -test(sto2, [sto(finite_trees),fail]) :- - X=s(X). -test(sto3, [sto(rational_trees), fail]) :- - X=s(X), fail. -test(sto4, [sto(rational_trees),error(type_error(list,L))]) :- - L = [_|L], length(L,_). -test(sto5, [sto(rational_trees),fail]) :- - L = [_|L], length(L,3). -\end{code} - -Programs that depend on STO cases tend to be inefficient, even -incorrect, are hard to understand and debug, and terminate poorly. It -is therefore advisable to avoid STO programs whenever possible. - -SWI's Prolog flag \prologflag{occurs_check} must not be modified -within plunit tests. - -\end{description} - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\subsection{Test Unit options} -\label{sec:unitoptions} - -\begin{description} - \predicate{begin_tests}{1}{+Name} -Start named test-unit. Same as \verb$begin_tests(Name, [])$. - - \predicate{begin_tests}{2}{+Name, +Options} -Start named test-unit with options. Options provide conditional -processing, setup and cleanup similar to individual tests (second -argument of test/2 rules). - -Defined options are: - \begin{description} - \termitem{blocked}{+Reason} -Test-unit has been blocked for the given \arg{Reason}. - - \termitem{condition}{:Goal} -Executed before executing any of the tests. If \arg{Goal} fails, -the test of this unit is skipped. - - \termitem{setup}{:Goal} -Executed before executing any of the tests. - - \termitem{cleanup}{:Goal} -Executed after completion of all tests in the unit. - - \termitem{sto}{+Terms} -Specify default for subject-to-occurs-check mode. See \secref{unitbox} -for details on the sto option. - \end{description} -\end{description} - - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\subsection{Writing the test body} -\label{sec:testbody} - -The test-body is ordinary Prolog code. Without any options, the body -must be designed to succeed \emph{deterministically}. Any other result -is considered a failure. One of the options \const{fail}, \const{true}, -\const{throws}, \const{all} or \const{set} can be used to specify a -different expected result. See \secref{unitbox} for details. In this -section we illustrate typical test-scenarios by testing SWI-Prolog -built-in and library predicates. - -\subsubsection{Testing deterministic predicates} -\label{sec:testdet} - -Deterministic predicates are predicates that must succeed exactly once -and, for well behaved predicates, leave no choicepoints. Typically they -have zero or more input- and zero or more output arguments. The test -goal supplies proper values for the input arguments and verifies the -output arguments. Verification can use test-options or be explicit in -the body. The tests in the example below are equivalent. - -\begin{code} -test(add) :- - A is 1 + 2, - A =:= 3. - -test(add, [true(A =:= 3)]) :- - A is 1 + 2. -\end{code} - -The test engine verifies that the test-body does not leave a -choicepoint. We illustrate that using the test below: - -\begin{code} -test(member) :- - member(b, [a,b,c]). -\end{code} - -Although this test succeeds, member/2 leaves a choicepoint which is -reported by the test subsystem. To make the test silent, use one of -the alternatives below. - -\begin{code} -test(member) :- - member(b, [a,b,c]), !. - -test(member, [nondet]) :- - member(b, [a,b,c]). -\end{code} - -\subsubsection{Testing semi-deterministic predicates} -\label{sec:testsemidet} - -Semi-deterministic predicates are predicates that either fail or succeed -exactly once and, for well behaved predicates, leave no choicepoints. -Testing such predicates is the same as testing deterministic -predicates. Negative tests must be specified using the option -\const{fail} or by negating the body using \verb$\+/1$. - -\begin{code} -test(is_set) :- - \+ is_set([a,a]). - -test(is_set, [fail]) :- - is_set([a,a]). -\end{code} - - -\subsubsection{Testing non-deterministic predicates} -\label{sec:testnondet} - -Non-deterministic predicates succeed zero or more times. Their results -are tested either using findall/3 or setof/3 followed by a value-check -or using the \const{all} or \const{set} options. The following are -equivalent tests: - -\begin{code} -test(member) :- - findall(X, member(X, [a,b,c]), Xs), - Xs == [a,b,c]. - -test(member, all(X == [a,b,c])) :- - member(X, [a,b,c]). -\end{code} - -\subsubsection{Testing error conditions} -\label{sec:testerror} - -Error-conditions are tested using the option \term{throws}{Error} or -by wrapping the test in a catch/3. The following tests are equivalent: - -\begin{code} -test(div0) :- - catch(A is 1/0, error(E, _), true), - E =@= evaluation_error(zero_divisor). - -test(div0, [error(evaluation_error(zero_divisor))]) :- - A is 1/0. -\end{code} - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{Using separate test files} -\label{sec:testfiles} - -Test-units can be embedded in normal Prolog source-files. Alternatively, -tests for a source-file can be placed in another file alongside the file -to be tested. Test files use the extension \fileext{plt}. The predicate -load_test_files/1 can load all files that are related to source-files -loaded into the current project. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{Running the test-suite} -\label{sec:running} - -At any time, the tests can be executed by loading the program and -running run_tests/0 or run_tests(+Unit). - -\begin{description} - \predicate{run_tests}{0}{} -Run all test-units. - - \predicate{run_tests}{1}{+Spec} -Run only the specified tests. \arg{Spec} can be a list to run multiple -tests. A single specification is either the name of a test unit or -a term :, running only the specified test. is -either the name of a test or a list of names. Running particular -tests is particularly useful for tracing a test:% -\footnote{Unfortunately the body of the test is called through -meta-calling, so it cannot be traced. The called user-code can be traced -normally though.} - -\begin{code} -?- gtrace, run_tests(lists:member). -\end{code} -\end{description} - -To identify nonterminating tests, interrupt the looping process with -\emph{Control-C}. The test name and location will be displayed. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{Tests and production systems} -\label{sec:state} - -Most applications do not want the test-suite to end up in the -final application. There are several ways to achieve this. One -is to place all tests in separate files and not to load the tests -when creating the production environment. Alternatively, use the -directive below before loading the application. - -\begin{code} -:- set_test_options([load(never)]). -\end{code} - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{Controlling the test suite} -\label{sec:options} - -\begin{description} - \predicate{set_test_options}{1}{+Options} -Defined options are: - -\begin{description} - \termitem{load}{+Load} -Determines whether or not tests are loaded. When \const{never}, -everything between begin_tests/1 and end_tests/1 is simply ignored. -When \const{always}, tests are always loaded. Finally, when using -the default value \const{normal}, tests are loaded if the code is -not compiled with optimisation turned on. - - \termitem{run}{+Run} -Specifies when tests are run. Using \const{manual}, tests can only be -run using run_tests/0 or run_tests/1. Using \const{make}, tests will be -run for reloaded files, but not for files loaded the first time. Using -\const{make(all)} make/0 will run all test-suites, not only those that -belong to files that are reloaded. - - \termitem{silent}{+Bool} -When \const{true} (default is \const{false}), send informational -messages using the `silent' level. In practice this means there -is no output except for errors. - - \termitem{sto}{+Bool} -When \const{true} (default \const{false}), assume tests are not subject -to occurs check (non-STO) and verify this if the Prolog implementation -supports testing this. -\end{description} - - \predicate{load_test_files}{1}{+Options} -Load \fileext{plt} test-files that belong to the currently loaded -sources. - - \predicate{running_tests}{0}{} -Print all currently running tests to the terminal. It can be used -to find running thread in multi-threaded test operation or find the -currently running test if a test appears to be blocking. - - \predicate{test_report}{1}{+What} -Print report on the executed tests. \arg{What} defines the type -of report. Currently this only supports \const{fixme}, providing -details on how the fixme-flagged tests proceeded. -\end{description} - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{Auto-generating tests} -\label{sec:wizard} - -Prolog is an interactive environment. Where users of non-interactive -systems tend to write tests as code, Prolog developers tend to run -queries interactively during development. This interactive testing is -generally faster, but the disadvantage is that the tests are lost at the -end of the session. The test-wizard tries to combine the advantages. It -collects toplevel queries and saves them to a specified file. Later, -it extracts these queries from the file and locates the predicates that -are tested by the queries. It runs the query and creates a test clause -from the query. - -Auto-generating test cases is experimentally supported through the -library \pllib{test_wizard}. We briefly introduce the functionality -using examples. First step is to log the queries into a file. This is -accomplished with the commands below. \file{Queries.pl} is the name in -which to store all queries. The user can choose any filename for this -purpose. Multiple Prolog instances can share the same name, as data -is appended to this file and write is properly locked to avoid file -corruption. - -\begin{code} -:- use_module(library(test_wizard)). -:- set_prolog_flag(log_query_file, 'Queries.pl'). -\end{code} - -Next, we will illustrate using the library by testing the predicates -from library \pllib{lists}. To generate test cases we just make calls -on the terminal. Note that all queries are recorded and the system will -select the appropriate ones when generating the test unit for a -particular module. - -\begin{code} -?- member(b, [a,b]). -Yes -?- reverse([a,b], [b|A]). -A = [a] ; -No -\end{code} - -Now we can generate the test-cases for the module list using -make_tests/3: - -\begin{code} -?- make_tests(lists, 'Queries.pl', current_output). -:- begin_tests(lists). - -test(member, [nondet]) :- - member(b, [a, b]). -test(reverse, [true(A==[a])]) :- - reverse([a, b], [b|A]). - -:- end_tests(lists). -\end{code} - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{Coverage analysis} -\label{sec:cover} - -An important aspect of tests is to know which parts of program -is used (\emph{covered}) by the tests. An experimental analysis -is provided by the library \pllib{test_cover}. - -\begin{description} - \predicate{show_coverage}{1}{:Goal} -Run \arg{Goal} and write a report on which percentage of the clauses in -each file are used by the program and which percentage of the clauses -always fail. -\end{description} - -We illustrate this here using CHAT, a natural language question and -answer application by David H.D. Warren and Fernando C.N. Pereira. - -\begin{code} -1 ?- show_coverage(test_chat). -Chat Natural Language Question Answering Test -... - -================================================================== - Coverage by File -================================================================== -File Clauses %Cov %Fail -================================================================== -/staff/jan/lib/prolog/chat/xgrun.pl 5 100.0 0.0 -/staff/jan/lib/prolog/chat/newg.pl 186 89.2 18.3 -/staff/jan/lib/prolog/chat/clotab.pl 28 89.3 0.0 -/staff/jan/lib/prolog/chat/newdic.pl 275 35.6 0.0 -/staff/jan/lib/prolog/chat/slots.pl 128 74.2 1.6 -/staff/jan/lib/prolog/chat/scopes.pl 132 70.5 3.0 -/staff/jan/lib/prolog/chat/templa.pl 67 55.2 1.5 -/staff/jan/lib/prolog/chat/qplan.pl 106 75.5 0.9 -/staff/jan/lib/prolog/chat/talkr.pl 60 20.0 1.7 -/staff/jan/lib/prolog/chat/ndtabl.pl 42 59.5 0.0 -/staff/jan/lib/prolog/chat/aggreg.pl 47 48.9 2.1 -/staff/jan/lib/prolog/chat/world0.pl 131 71.8 1.5 -/staff/jan/lib/prolog/chat/rivers.pl 41 100.0 0.0 -/staff/jan/lib/prolog/chat/cities.pl 76 43.4 0.0 -/staff/jan/lib/prolog/chat/countr.pl 156 100.0 0.0 -/staff/jan/lib/prolog/chat/contai.pl 334 100.0 0.0 -/staff/jan/lib/prolog/chat/border.pl 857 98.6 0.0 -/staff/jan/lib/prolog/chat/chattop.pl 139 43.9 0.7 -================================================================== -\end{code} - -Using \verb$?- show_coverage(run_tests).$, this library currently only -shows some rough quality measure for test-suite. Later versions should -provide a report to the developer identifying which clauses are covered, -not covered and always failed. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{Portability of the test-suite} -\label{sec:porting} - -One of the reasons to have tests is to simplify migrating code between -Prolog implementations. Unfortunately creating a portable test-suite -implies a poor integration into the development environment. Luckily, -the specification of the test-system proposed here can be ported quite -easily to most Prolog systems sufficiently compatible to SWI-Prolog to -consider porting your application. Most important is to have support for -term_expansion/2. - -In the current system, test units are compiled into sub-modules of the -module in which they appear. Few Prolog systems allow for sub-modules -and therefore ports may have to fall-back to inject the code in the -surrounding module. This implies that support predicates used inside -the test unit should not conflict with predicates of the module being -tested. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\subsection{PlUnit on SICStus} -\label{sec:sicstus} - -The directory of \file{plunit.pl} and \file{swi.pl} must be in the -\const{library} search-path. With PLUNITDIR replaced accordingly, -add the following into your \file{.sicstusrc} or \file{sicstus.ini}. - -\begin{code} -:- set_prolog_flag(language, iso). % for maximal compatibility -library_directory('PLUNITDIR'). -\end{code} - -The current version runs under SICStus 3. Open issues: - -\begin{itemize} - - \item Some messages are unformatted because SICStus 3 reports - all ISO errors as instantiation errors. - - \item Only \file{plunit.pl}. Both coverage analysis and the test - generation wizard currently require SWI-Prolog. - - \item The \const{load} option \const{normal} is the same as \const{always}. - Use \exam{set_test_options(load, never)} to avoid loading the - test suites. - - \item The \const{run} option is not supported. - - \item Tests are loaded into the enclosing module instead of a separate - test module. This means that predicates in the test module must - not conflict with the enclosing module, nor with other test - modules loaded into the same module. -\end{itemize} - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{Motivation of choices} -\label{sec:motivation} - -\subsection*{Easy to understand and flexible} - -There are two approaches for testing. In one extreme the tests are -written using declarations dealing with setup, cleanup, running and -testing the result. In the other extreme a test is simply a Prolog goal -that is supposed to succeed. We have chosen to allow for any mixture of -these approaches. Written down as test/1 we opt for the simple -succeeding goal approach. Using options to the test the user can choose -for a more declarative specification. The user can mix both approaches. - -The body of the test appears at the position of a clause-body. This -simplifies identification of the test body and ensures proper layout and -colouring support from the editor without the need for explicit support -of the unit test module. Only clauses of test/1 and test/2 may be marked -as non-called in environments that perform cross-referencing. - -%\subsection*{Well integrated} - -\printindex - -\end{document} - diff --git a/packages/plunit/plunit.pl b/packages/plunit/plunit.pl deleted file mode 100644 index 84fdf6762..000000000 --- a/packages/plunit/plunit.pl +++ /dev/null @@ -1,1506 +0,0 @@ -/* $Id$ - - Part of SWI-Prolog - - Author: Jan Wielemaker - E-mail: wielemak@science.uva.nl - WWW: http://www.swi-prolog.org - Copyright (C): 2006-2008, University of Amsterdam - - This file is covered by the `The Artistic License', also in use by - Perl. See http://www.perl.com/pub/a/language/misc/Artistic.html -*/ - -:- module(plunit, - [ set_test_options/1, % +Options - begin_tests/1, % +Name - begin_tests/2, % +Name, +Options - end_tests/1, % +Name - run_tests/0, % Run all tests - run_tests/1, % Run named test-set - load_test_files/1, % +Options - running_tests/0, % Prints currently running test - test_report/1 % +What - ]). - -/** Unit Testing - -Unit testing environment for SWI-Prolog and SICStus Prolog. For usage, -please visit http://www.swi-prolog.org/pldoc/package/plunit.html. - -@author Jan Wielemaker -@license artistic -*/ - - /******************************* - * CONDITIONAL COMPILATION * - *******************************/ - -:- discontiguous - user:term_expansion/2. - -:- dynamic - include_code/1. - -:- expects_dialect(swi). - -including :- - include_code(X), !, - X == true. -including. - -if_expansion((:- if(G)), []) :- - ( including - -> ( catch(G, E, (print_message(error, E), fail)) - -> asserta(include_code(true)) - ; asserta(include_code(false)) - ) - ; asserta(include_code(else_false)) - ). -if_expansion((:- else), []) :- - ( retract(include_code(X)) - -> ( X == true - -> X2 = false - ; X == false - -> X2 = true - ; X2 = X - ), - asserta(include_code(X2)) - ; throw_error(context_error(no_if),_) - ). -if_expansion((:- endif), []) :- - retract(include_code(_)), !. - -if_expansion(_, []) :- - \+ including. - -user:term_expansion(In, Out) :- - prolog_load_context(module, plunit), - if_expansion(In, Out). - -swi :- catch(current_prolog_flag(dialect, swi), _, fail), !. -swi :- catch(current_prolog_flag(dialect, yap), _, fail). -sicstus :- catch(current_prolog_flag(system_type, _), _, fail). - - -:- if(swi). - -throw_error(Error_term,Impldef) :- - throw(error(Error_term,Impldef)). - -:- set_prolog_flag(generate_debug_info, false). -:- use_module(library(option)). -:- use_module(library(pairs)). - -:- endif. - -:- if(sicstus). -throw_error(Error_term,Impldef) :- - throw(error(Error_term,i(Impldef))). % SICStus 3 work around - -:- if(current_prolog_flag(dialect, sicstus)). -:- use_module(swi). % SWI-Compatibility -:- endif. -:- use_module(library(terms)). -:- op(700, xfx, =@=). - -'$set_source_module'(_, _). - -:- op(1150, fx, thread_local). - -user:term_expansion((:- thread_local(PI)), (:- dynamic(PI))) :- - prolog_load_context(module, plunit). - -:- endif. - -%% current_test_flag(?Name, ?Value) is nondet. -% -% Query flags that control the testing process. Emulates -% SWI-Prologs flags. - -:- dynamic test_flag/2. % Name, Val - -current_test_flag(optimise, Val) :- - current_prolog_flag(compiling, Compiling), - ( Compiling == debugcode ; true % TBD: Proper test - -> Val = false - ; Val = true - ). -current_test_flag(Name, Val) :- - test_flag(Name, Val). - - -%% set_test_flag(+Name, +Value) is det. - -set_test_flag(Name, Val) :- - var(Name), !, - throw_error(instantiation_error, set_test_flag(Name,Val)). -set_test_flag( Name, Val ) :- - retractall(test_flag(Name,_)), - asserta(test_flag(Name, Val)). - - - /******************************* - * IMPORTS * - *******************************/ - -:- use_module(library(lists)). - -:- initialization - ( current_test_flag(test_options, _) - -> true - ; set_test_flag(test_options, - [ run(make), % run tests on make/0 - sto(false) - ]) - ). - -%% set_test_options(+Options) -% -% Specifies how to deal with test suites. Defined options are: -% -% * load(+Load) -% Whether or not the tests must be loaded. Values are -% =never=, =always=, =normal= (only if not optimised) -% -% * run(+When) -% When the tests are run. Values are =manual=, =make= -% or make(all). -% -% * silent(+Bool) -% If =true= (default =false=), report successful tests -% using message level =silent=, only printing errors and -% warnings. -% -% * sto(+Bool) -% How to test whether code is subject to occurs check -% (STO). If =false= (default), STO is not considered. -% If =true= and supported by the hosting Prolog, code -% is run in all supported unification mode and reported -% if the results are inconsistent. - -set_test_options(Options) :- - valid_options(Options, global_test_option), - set_test_flag(test_options, Options). - -global_test_option(load(Load)) :- - must_be(oneof([never,always,normal]), Load). -global_test_option(run(When)) :- - must_be(oneof([manual,make,all]), When). -global_test_option(silent(Bool)) :- - must_be(boolean, Bool). -global_test_option(sto(Bool)) :- - must_be(boolean, Bool). - - -%% loading_tests -% -% True if tests must be loaded. - -loading_tests :- - current_test_flag(test_options, Options), - option(load(Load), Options, normal), - ( Load == always - -> true - ; Load == normal, - \+ current_test_flag(optimise, true) - ). - - /******************************* - * MODULE * - *******************************/ - -:- dynamic - loading_unit/4, % Unit, Module, File, OldSource - current_unit/4, % Unit, Module, Context, Options - test_file_for/2. % ?TestFile, ?PrologFile - -%% begin_tests(+UnitName:atom) is det. -%% begin_tests(+UnitName:atom, Options) is det. -% -% Start a test-unit. UnitName is the name of the test set. the -% unit is ended by :- end_tests(UnitName). - -begin_tests(Unit) :- - begin_tests(Unit, []). - -begin_tests(Unit, Options) :- - valid_options(Options, test_set_option), - make_unit_module(Unit, Name), - source_location(File, Line), - begin_tests(Unit, Name, File:Line, Options). - -:- if(swi). -begin_tests(Unit, Name, File:Line, Options) :- - loading_tests, !, - '$set_source_module'(Context, Context), - ( current_unit(Unit, Name, Context, Options) - -> true - ; retractall(current_unit(Unit, Name, _, _)), - assert(current_unit(Unit, Name, Context, Options)) - ), - '$set_source_module'(Old, Name), - '$declare_module'(Name, Context, File, Line, false), - discontiguous(Name:'unit test'/4), - '$set_predicate_attribute'(Name:'unit test'/4, trace, 0), - discontiguous(Name:'unit body'/2), - asserta(loading_unit(Unit, Name, File, Old)). -begin_tests(Unit, Name, File:_Line, _Options) :- - '$set_source_module'(Old, Old), - asserta(loading_unit(Unit, Name, File, Old)). - -set_import_modules(Module, Imports) :- - findall(I, import_module(Module, I), IL), - forall(member(I, IL), delete_import_module(Module, I)), - forall(member(I, Imports), add_import_module(Module, I, end)). - -:- else. - -% we cannot use discontiguous as a goal in SICStus Prolog. - -user:term_expansion((:- begin_tests(Set)), - [ (:- begin_tests(Set)), - (:- discontiguous(test/2)), - (:- discontiguous('unit body'/2)), - (:- discontiguous('unit test'/4)) - ]). - -begin_tests(Unit, Name, File:_Line, Options) :- - loading_tests, !, - ( current_unit(Unit, Name, _, Options) - -> true - ; retractall(current_unit(Unit, Name, _, _)), - assert(current_unit(Unit, Name, -, Options)) - ), - asserta(loading_unit(Unit, Name, File, -)). -begin_tests(Unit, Name, File:_Line, _Options) :- - asserta(loading_unit(Unit, Name, File, -)). - -:- endif. - -%% end_tests(+Name) is det. -% -% Close a unit-test module. -% -% @tbd Run tests/clean module? -% @tbd End of file? - -end_tests(Unit) :- - loading_unit(StartUnit, _, _, _), !, - ( Unit == StartUnit - -> once(retract(loading_unit(StartUnit, _, _, Old))), - '$set_source_module'(_, Old) - ; throw_error(context_error(plunit_close(Unit, StartUnit)), _) - ). -end_tests(Unit) :- - throw_error(context_error(plunit_close(Unit, -)), _). - -%% make_unit_module(+Name, -ModuleName) is det. -%% unit_module(+Name, -ModuleName) is det. - -:- if(swi). - -unit_module(Unit, Module) :- - atom_concat('plunit_', Unit, Module). - -make_unit_module(Unit, Module) :- - unit_module(Unit, Module), - ( current_module(Module), - \+ current_unit(_, Module, _, _) - -> throw_error(permission_error(create, plunit, Unit), - 'Existing module') - ; true - ). - -:- else. - -:- dynamic - unit_module_store/2. - -unit_module(Unit, Module) :- - unit_module_store(Unit, Module), !. - -make_unit_module(Unit, Module) :- - prolog_load_context(module, Module), - assert(unit_module_store(Unit, Module)). - -:- endif. - - /******************************* - * EXPANSION * - *******************************/ - -%% expand_test(+Name, +Options, +Body, -Clause) is det. -% -% Expand test(Name, Options) :- Body into a clause for -% 'unit test'/4 and 'unit body'/2. - -expand_test(Name, Options0, Body, - [ 'unit test'(Name, Line, Options, Module:'unit body'(Id, Vars)), - ('unit body'(Id, Vars) :- !, Body) - ]) :- - source_location(_File, Line), - prolog_load_context(module, Module), - atomic_list_concat([Name, '@line ', Line], Id), - term_variables(Body, VarList), - Vars =.. [vars|VarList], - ( is_list(Options0) % allow for single option without list - -> Options1 = Options0 - ; Options1 = [Options0] - ), - maplist(expand_option, Options1, Options), - valid_options(Options, test_option). - -expand_option(Var, _) :- - var(Var), !, - throw_error(instantiation_error,_). -expand_option(A == B, true(A==B)) :- !. -expand_option(A = B, true(A=B)) :- !. -expand_option(A =@= B, true(A=@=B)) :- !. -expand_option(A =:= B, true(A=:=B)) :- !. -expand_option(O, O). - - -%% expand(+Term, -Clauses) is semidet. - -expand(end_of_file, _) :- - loading_unit(Unit, _, _, _), !, - end_tests(Unit), % warn? - fail. -expand(_Term, []) :- - \+ loading_tests. -expand((test(Name) :- Body), Clauses) :- !, - expand_test(Name, [], Body, Clauses). -expand((test(Name, Options) :- Body), Clauses) :- !, - expand_test(Name, Options, Body, Clauses). -expand(test(Name), _) :- !, - throw_error(existence_error(body, test(Name)), _). -expand(test(Name, _Options), _) :- !, - throw_error(existence_error(body, test(Name)), _). - -:- if(swi). -:- multifile - user:term_expansion/2. -:- endif. - -user:term_expansion(Term, Expanded) :- - ( loading_unit(_, _, File, _) - -> source_location(File, _), - expand(Term, Expanded) - ). - - - /******************************* - * OPTIONS * - *******************************/ - -:- if(swi). -:- use_module(library(error)). -:- else. -must_be(list, X) :- !, - ( is_list(X) - -> true - ; is_not(list, X) - ). -must_be(Type, X) :- - ( call(Type, X) - -> true - ; is_not(Type, X) - ). - -is_not(Type, X) :- - ( ground(X) - -> throw_error(type_error(Type, X), _) - ; throw_error(instantiation_error, _) - ). -:- endif. - -%% valid_options(+Options, :Pred) is det. -% -% Verify Options to be a list of valid options according to -% Pred. -% -% @throws =type_error= or =instantiation_error=. - -valid_options(Options, Pred) :- - must_be(list, Options), - verify_options(Options, Pred). - -verify_options([], _). -verify_options([H|T], Pred) :- - ( call(Pred, H) - -> verify_options(T, Pred) - ; throw_error(domain_error(Pred, H), _) - ). - - -%% test_option(+Option) is semidet. -% -% True if Option is a valid option for test(Name, Options). - -test_option(Option) :- - test_set_option(Option), !. -test_option(true(_)). -test_option(fail). -test_option(true). -test_option(throws(_)). -test_option(error(_)). -test_option(all(_)). -test_option(set(_)). -test_option(nondet). -test_option(fixme(_)). -test_option(forall(X)) :- - must_be(callable, X). - -%% test_option(+Option) is semidet. -% -% True if Option is a valid option for :- begin_tests(Name, -% Options). - -test_set_option(blocked(X)) :- - must_be(ground, X). -test_set_option(condition(X)) :- - must_be(callable, X). -test_set_option(setup(X)) :- - must_be(callable, X). -test_set_option(cleanup(X)) :- - must_be(callable, X). -test_set_option(sto(V)) :- - nonvar(V), member(V, [finite_trees, rational_trees]). - - - /******************************* - * RUNNING TOPLEVEL * - *******************************/ - -:- thread_local - passed/5, % Unit, Test, Line, Det, Time - failed/4, % Unit, Test, Line, Reason - blocked/4, % Unit, Test, Line, Reason - sto/4, % Unit, Test, Line, Results - fixme/5. % Unit, Test, Line, Reason, Status - -:- dynamic - running/5. % Unit, Test, Line, STO, Thread - -%% run_tests is semidet. -%% run_tests(+TestSet) is semidet. - -run_tests :- - cleanup, - forall(current_test_set(Set), - run_unit(Set)), - report. - -run_tests(Set) :- - cleanup, - run_unit(Set), - report. - -run_unit([]) :- !. -run_unit([H|T]) :- !, - run_unit(H), - run_unit(T). -run_unit(Spec) :- - unit_from_spec(Spec, Unit, Tests, Module, UnitOptions), - ( option(blocked(Reason), UnitOptions) - -> info(plunit(blocked(unit(Unit, Reason)))) - ; setup(Module, unit(Unit), UnitOptions) - -> info(plunit(begin(Spec))), - forall((Module:'unit test'(Name, Line, Options, Body), - matching_test(Name, Tests)), - run_test(Unit, Name, Line, Options, Body)), - info(plunit(end(Spec))), - ( message_level(silent) - -> true - ; format(user_error, '~N', []) - ), - cleanup(Module, UnitOptions) - ; true - ). - -unit_from_spec(Unit, Unit, _, Module, Options) :- - atom(Unit), !, - ( current_unit(Unit, Module, _Supers, Options) - -> true - ; throw_error(existence_error(unit_test, Unit), _) - ). -unit_from_spec(Unit:Tests, Unit, Tests, Module, Options) :- - atom(Unit), !, - ( current_unit(Unit, Module, _Supers, Options) - -> true - ; throw_error(existence_error(unit_test, Unit), _) - ). - - -matching_test(X, X) :- !. -matching_test(Name, Set) :- - is_list(Set), - memberchk(Name, Set). - -cleanup :- - thread_self(Me), - retractall(passed(_, _, _, _, _)), - retractall(failed(_, _, _, _)), - retractall(blocked(_, _, _, _)), - retractall(sto(_, _, _, _)), - retractall(fixme(_, _, _, _, _)), - retractall(running(_,_,_,_,Me)). - - -%% run_tests_in_files(+Files:list) is det. -% -% Run all test-units that appear in the given Files. - -run_tests_in_files(Files) :- - findall(Unit, unit_in_files(Files, Unit), Units), - ( Units == [] - -> true - ; run_tests(Units) - ). - -unit_in_files(Files, Unit) :- - is_list(Files), !, - member(F, Files), - absolute_file_name(F, Source, - [ file_type(prolog), - access(read), - file_errors(fail) - ]), - unit_file(Unit, Source). - - - /******************************* - * HOOKING MAKE/0 * - *******************************/ - -%% make_run_tests(+Files) -% -% Called indirectly from make/0 after Files have been reloaded. - -make_run_tests(Files) :- - current_test_flag(test_options, Options), - option(run(When), Options, manual), - ( When == make - -> run_tests_in_files(Files) - ; When == make(all) - -> run_tests - ; true - ). - -:- if(swi). - -unification_capability(sto_error_incomplete). -% can detect some (almost all) STO runs -unification_capability(rational_trees). -unification_capability(finite_trees). - -set_unification_capability(Cap) :- - cap_to_flag(Cap, Flag), - set_prolog_flag(occurs_check, Flag). - -current_unification_capability(Cap) :- - current_prolog_flag(occurs_check, Flag), - cap_to_flag(Cap, Flag), !. - -cap_to_flag(sto_error_incomplete, error). -cap_to_flag(rational_trees, false). -cap_to_flag(finite_trees, true). - -:- else. -:- if(sicstus). - -unification_capability(rational_trees). -set_unification_capability(rational_trees). -current_unification_capability(rational_trees). - -:- else. - -unification_capability(_) :- - fail. - -:- endif. -:- endif. - - - /******************************* - * RUNNING A TEST * - *******************************/ - -%% run_test(+Unit, +Name, +Line, +Options, +Body) is det. -% -% Run a single test. - -run_test(Unit, Name, Line, Options, Body) :- - option(forall(Generator), Options), !, - unit_module(Unit, Module), - term_variables(Generator, Vars), - forall(Module:Generator, - run_test_once(Unit, @(Name,Vars), Line, Options, Body)). -run_test(Unit, Name, Line, Options, Body) :- - run_test_once(Unit, Name, Line, Options, Body). - -run_test_once(Unit, Name, Line, Options, Body) :- - current_test_flag(test_options, GlobalOptions), - option(sto(false), GlobalOptions, false), !, - run_test_6(Unit, Name, Line, Options, Body, Result), - report_result(Result, Options). -run_test_once(Unit, Name, Line, Options, Body) :- - current_unit(Unit, _Module, _Supers, UnitOptions), - option(sto(Type), UnitOptions), - \+ option(sto(_), Options), !, - current_unification_capability(Cap0), - call_cleanup(run_test_cap(Unit, Name, Line, [sto(Type)|Options], Body), - set_unification_capability(Cap0)). -run_test_once(Unit, Name, Line, Options, Body) :- - current_unification_capability(Cap0), - call_cleanup(run_test_cap(Unit, Name, Line, Options, Body), - set_unification_capability(Cap0)). - -run_test_cap(Unit, Name, Line, Options, Body) :- - ( option(sto(Type), Options) - -> unification_capability(Type), - set_unification_capability(Type), - run_test_6(Unit, Name, Line, Options, Body, Result), - report_result(Result, Options) - ; findall(Key-(Type+Result), - test_caps(Type, Unit, Name, Line, Options, Body, Result, Key), - Pairs), - group_pairs_by_key(Pairs, Keyed), - ( Keyed == [] - -> true - ; Keyed = [_-Results] - -> Results = [_Type+Result|_], - report_result(Result, Options) % consistent results - ; pairs_values(Pairs, ResultByType), - report_result(sto(Unit, Name, Line, ResultByType), Options) - ) - ). - -%% test_caps(-Type, +Unit, +Name, +Line, +Options, +Body, -Result, -Key) is nondet. - -test_caps(Type, Unit, Name, Line, Options, Body, Result, Key) :- - unification_capability(Type), - set_unification_capability(Type), - begin_test(Unit, Name, Line, Type), - run_test_6(Unit, Name, Line, Options, Body, Result), - end_test(Unit, Name, Line, Type), - result_to_key(Result, Key), - Key \== setup_failed. - -result_to_key(blocked(_, _, _, _), blocked). -result_to_key(failure(_, _, _, How0), failure(How1)) :- - ( How0 = succeeded(_T) -> How1 = succeeded ; How0 = How1 ). -result_to_key(success(_, _, _, Determinism, _), success(Determinism)). -result_to_key(setup_failed(_,_,_), setup_failed). - -report_result(blocked(Unit, Name, Line, Reason), _) :- !, - assert(blocked(Unit, Name, Line, Reason)). -report_result(failure(Unit, Name, Line, How), Options) :- !, - failure(Unit, Name, Line, How, Options). -report_result(success(Unit, Name, Line, Determinism, Time), Options) :- !, - success(Unit, Name, Line, Determinism, Time, Options). -report_result(setup_failed(_Unit, _Name, _Line), _Options). -report_result(sto(Unit, Name, Line, ResultByType), Options) :- - assert(sto(Unit, Name, Line, ResultByType)), - print_message(error, plunit(sto(Unit, Name, Line))), - report_sto_results(ResultByType, Options). - -report_sto_results([], _). -report_sto_results([Type+Result|T], Options) :- - print_message(error, plunit(sto(Type, Result))), - report_sto_results(T, Options). - - -%% run_test_6(+Unit, +Name, +Line, +Options, :Body, -Result) is det. -% -% Result is one of: -% -% * blocked(Unit, Name, Line, Reason) -% * failure(Unit, Name, Line, How) -% * success(Unit, Name, Line, Determinism, Time) -% * setup_failed(Unit, Name, Line) - -run_test_6(Unit, Name, Line, Options, _Body, - blocked(Unit, Name, Line, Reason)) :- - option(blocked(Reason), Options), !. -run_test_6(Unit, Name, Line, Options, Body, Result) :- - option(all(Answer), Options), !, % all(Bindings) - nondet_test(all(Answer), Unit, Name, Line, Options, Body, Result). -run_test_6(Unit, Name, Line, Options, Body, Result) :- - option(set(Answer), Options), !, % set(Bindings) - nondet_test(set(Answer), Unit, Name, Line, Options, Body, Result). -run_test_6(Unit, Name, Line, Options, Body, Result) :- - option(fail, Options), !, % fail - unit_module(Unit, Module), - ( setup(Module, test(Unit,Name,Line), Options) - -> statistics(runtime, [T0,_]), - ( catch(Module:Body, E, true) - -> ( var(E) - -> statistics(runtime, [T1,_]), - Time is (T1 - T0)/1000.0, - Result = failure(Unit, Name, Line, succeeded(Time)), - cleanup(Module, Options) - ; Result = failure(Unit, Name, Line, E), - cleanup(Module, Options) - ) - ; statistics(runtime, [T1,_]), - Time is (T1 - T0)/1000.0, - Result = success(Unit, Name, Line, true, Time), - cleanup(Module, Options) - ) - ; Result = setup_failed(Unit, Name, Line) - ). -run_test_6(Unit, Name, Line, Options, Body, Result) :- - option(true(Cmp), Options), !, - unit_module(Unit, Module), - ( setup(Module, test(Unit,Name,Line), Options) % true(Binding) - -> statistics(runtime, [T0,_]), - ( catch(call_det(Module:Body, Det), E, true) - -> ( var(E) - -> statistics(runtime, [T1,_]), - Time is (T1 - T0)/1000.0, - ( catch(Cmp, _, fail) % tbd: error - -> Result = success(Unit, Name, Line, Det, Time) - ; Result = failure(Unit, Name, Line, wrong_answer(Cmp)) - ), - cleanup(Module, Options) - ; Result = failure(Unit, Name, Line, E), - cleanup(Module, Options) - ) - ; Result = failure(Unit, Name, Line, failed), - cleanup(Module, Options) - ) - ; Result = setup_failed(Unit, Name, Line) - ). -run_test_6(Unit, Name, Line, Options, Body, Result) :- - ( option(throws(Expect), Options) - -> true - ; option(error(ErrorExpect), Options) - -> Expect = error(ErrorExpect, _) - ), !, - unit_module(Unit, Module), - ( setup(Module, test(Unit,Name,Line), Options) - -> statistics(runtime, [T0,_]), - ( catch(Module:Body, E, true) - -> ( var(E) - -> Result = failure(Unit, Name, Line, no_exception), - cleanup(Module, Options) - ; statistics(runtime, [T1,_]), - Time is (T1 - T0)/1000.0, - ( match_error(Expect, E) - -> Result = success(Unit, Name, Line, true, Time) - ; Result = failure(Unit, Name, Line, wrong_error(Expect, E)) - ), - cleanup(Module, Options) - ) - ; Result = failure(Unit, Name, Line, failed), - cleanup(Module, Options) - ) - ; Result = setup_failed(Unit, Name, Line) - ). -run_test_6(Unit, Name, Line, Options, Body, Result) :- - unit_module(Unit, Module), - ( setup(Module, test(Unit,Name,Line), Options) - -> statistics(runtime, [T0,_]), - ( catch(call_det(Module:Body, Det), E, true) - -> ( var(E) - -> statistics(runtime, [T1,_]), - Time is (T1 - T0)/1000.0, - Result = success(Unit, Name, Line, Det, Time), - cleanup(Module, Options) - ; Result = failure(Unit, Name, Line, E), - cleanup(Module, Options) - ) - ; Result = failure(Unit, Name, Line, failed), - cleanup(Module, Options) - ) - ; Result = setup_failed(Unit, Name, Line) - ). - - -%% non_det_test(+Expected, +Unit, +Name, +Line, +Options, +Body, -Result) -% -% Run tests on non-deterministic predicates. - -nondet_test(Expected, Unit, Name, Line, Options, Body, Result) :- - unit_module(Unit, Module), - result_vars(Expected, Vars), - statistics(runtime, [T0,_]), - ( setup(Module, test(Unit,Name,Line), Options) - -> ( catch(findall(Vars, Module:Body, Bindings), E, true) - -> ( var(E) - -> statistics(runtime, [T1,_]), - Time is (T1 - T0)/1000.0, - ( nondet_compare(Expected, Bindings, Unit, Name, Line) - -> Result = success(Unit, Name, Line, true, Time) - ; Result = failure(Unit, Name, Line, wrong_answer) - ), - cleanup(Module, Options) - ; Result = failure(Unit, Name, Line, E), - cleanup(Module, Options) - ) - ) - ; Result = setup_failed(Unit, Name, Line) - ). - - -%% result_vars(+Expected, -Vars) is det. -% -% Create a term v(V1, ...) containing all variables at the left -% side of the comparison operator on Expected. - -result_vars(Expected, Vars) :- - arg(1, Expected, CmpOp), - arg(1, CmpOp, Vars). - -%% nondet_compare(+Expected, +Bindings, +Unit, +Name, +Line) is semidet. -% -% Compare list/set results for non-deterministic predicates. -% -% @tbd Properly report errors -% @bug Sort should deal with equivalence on the comparison -% operator. - -nondet_compare(all(Cmp), Bindings, _Unit, _Name, _Line) :- - cmp(Cmp, _Vars, Op, Values), - cmp_list(Values, Bindings, Op). -nondet_compare(set(Cmp), Bindings0, _Unit, _Name, _Line) :- - cmp(Cmp, _Vars, Op, Values0), - sort(Bindings0, Bindings), - sort(Values0, Values), - cmp_list(Values, Bindings, Op). - -cmp_list([], [], _Op). -cmp_list([E0|ET], [V0|VT], Op) :- - call(Op, E0, V0), - cmp_list(ET, VT, Op). - -%% cmp(+CmpTerm, -Left, -Op, -Right) is det. - -cmp(Var == Value, Var, ==, Value). -cmp(Var =:= Value, Var, =:=, Value). -cmp(Var = Value, Var, =, Value). -:- if(swi). -cmp(Var =@= Value, Var, =@=, Value). -:- else. -:- if(sicstus). -cmp(Var =@= Value, Var, variant, Value). % variant/2 is the same =@= -:- endif. -:- endif. - - -%% call_det(:Goal, -Det) is nondet. -% -% True if Goal succeeded. Det is unified to =true= if Goal left -% no choicepoints and =false= otherwise. - -:- if((swi|sicstus)). -call_det(Goal, Det) :- - call_cleanup(Goal,Det0=true), - ( var(Det0) -> Det = false ; Det = true ). -:- else. -call_det(Goal, true) :- - call(Goal). -:- endif. - -%% match_error(+Expected, +Received) is semidet. -% -% True if the Received errors matches the expected error. Matching -% is based on subsumes_chk/2. - -match_error(Expect, Rec) :- - subsumes_chk(Expect, Rec). - -%% setup(+Module, +Context, +Options) is semidet. -% -% Call the setup handler and fail if it cannot run for some -% reason. The condition handler is similar, but failing is not -% considered an error. Context is one of -% -% * unit(Unit) -% If it is the setup handler for a unit -% * test(Unit,Name,Line) -% If it is the setup handler for a test - -setup(Module, Context, Options) :- - option(condition(Condition), Options), - option(setup(Setup), Options), !, - setup(Module, Context, [condition(Condition)]), - setup(Module, Context, [setup(Setup)]). -setup(Module, Context, Options) :- - option(setup(Setup), Options), !, - ( catch(call_ex(Module, Setup), E, true) - -> ( var(E) - -> true - ; print_message(error, plunit(error(setup, Context, E))), - fail - ) - ; print_message(error, error(goal_failed(Setup), _)), - fail - ). -setup(Module, Context, Options) :- - option(condition(Setup), Options), !, - ( catch(call_ex(Module, Setup), E, true) - -> ( var(E) - -> true - ; print_message(error, plunit(error(condition, Context, E))), - fail - ) - ; fail - ). -setup(_,_,_). - -%% call_ex(+Module, +Goal) -% -% Call Goal in Module after applying goal expansion. - -call_ex(Module, Goal) :- - Module:(expand_goal(Goal, GoalEx), - GoalEx). - -%% cleanup(+Module, +Options) is det. -% -% Call the cleanup handler and succeed. Failure or error of the -% cleanup handler is reported, but tests continue normally. - -cleanup(Module, Options) :- - option(cleanup(Cleanup), Options, true), - ( catch(call_ex(Module, Cleanup), E, true) - -> ( var(E) - -> true - ; print_message(warning, E) - ) - ; print_message(warning, goal_failed(Cleanup, '(cleanup handler)')) - ). - -success(Unit, Name, Line, Det, _Time, Options) :- - memberchk(fixme(Reason), Options), !, - ( ( Det == true - ; memberchk(nondet, Options) - ) - -> put_char(user_error, +), - Ok = passed - ; put_char(user_error, !), - Ok = nondet - ), - flush_output(user_error), - assert(fixme(Unit, Name, Line, Reason, Ok)). -success(Unit, Name, Line, Det, Time, Options) :- - assert(passed(Unit, Name, Line, Det, Time)), - ( ( Det == true - ; memberchk(nondet, Options) - ) - -> put_char(user_error, .) - ; unit_file(Unit, File), - print_message(warning, plunit(nondet(File, Line, Name))) - ), - flush_output(user_error). - -failure(Unit, Name, Line, _, Options) :- - memberchk(fixme(Reason), Options), !, - put_char(user_error, -), - flush_output(user_error), - assert(fixme(Unit, Name, Line, Reason, failed)). -failure(Unit, Name, Line, E, Options) :- - report_failure(Unit, Name, Line, E, Options), - assert_cyclic(failed(Unit, Name, Line, E)). - -%% assert_cyclic(+Term) is det. -% -% Assert a possibly cyclic unit clause. Current SWI-Prolog -% assert/1 does not handle cyclic terms, so we emulate this using -% the recorded database. -% -% @tbd Implement cycle-safe assert and remove this. - -:- if(swi). -assert_cyclic(Term) :- - acyclic_term(Term), !, - assert(Term). -assert_cyclic(Term) :- - Term =.. [Functor|Args], - recorda(cyclic, Args, Id), - functor(Term, _, Arity), - length(NewArgs, Arity), - Head =.. [Functor|NewArgs], - assert((Head :- recorded(_, Var, Id), Var = NewArgs)). -:- else. -:- if(sicstus). -:- endif. -assert_cyclic(Term) :- - assert(Term). -:- endif. - - - /******************************* - * REPORTING * - *******************************/ - -%% begin_test(Unit, Test, Line, STO) is det. -%% end_test(Unit, Test, Line, STO) is det. -% -% Maintain running/5 and report a test has started/is ended using -% a =silent= message: -% -% * plunit(begin(Unit:Test, File:Line, STO)) -% * plunit(end(Unit:Test, File:Line, STO)) -% -% @see message_hook/3 for intercepting these messages - -begin_test(Unit, Test, Line, STO) :- - thread_self(Me), - assert(running(Unit, Test, Line, STO, Me)), - unit_file(Unit, File), - print_message(silent, plunit(begin(Unit:Test, File:Line, STO))). - -end_test(Unit, Test, Line, STO) :- - thread_self(Me), - retractall(running(_,_,_,_,Me)), - unit_file(Unit, File), - print_message(silent, plunit(end(Unit:Test, File:Line, STO))). - -%% running_tests is det. -% -% Print the currently running test. - -running_tests :- - running_tests(Running), - print_message(informational, plunit(running(Running))). - -running_tests(Running) :- - findall(running(Unit:Test, File:Line, STO, Thread), - ( running(Unit, Test, Line, STO, Thread), - unit_file(Unit, File) - ), Running). - - -%% report is semidet. -% -% True if there are no errors. If errors were encountered, report -% them to current output and fail. - -report :- - number_of_clauses(passed/5, Passed), - number_of_clauses(failed/4, Failed), - number_of_clauses(blocked/4, Blocked), - number_of_clauses(sto/4, STO), - ( Passed+Failed+Blocked+STO =:= 0 - -> info(plunit(no_tests)) - ; Failed+Blocked+STO =:= 0 - -> report_fixme, - info(plunit(all_passed(Passed))) - ; report_blocked, - report_fixme, - report_failed, - report_sto - ). - -number_of_clauses(F/A,N) :- - ( current_predicate(F/A) - -> functor(G,F,A), - findall(t, G, Ts), - length(Ts, N) - ; N = 0 - ). - -report_blocked :- - number_of_clauses(blocked/4,N), - N > 0, !, - info(plunit(blocked(N))), - ( blocked(Unit, Name, Line, Reason), - unit_file(Unit, File), - print_message(informational, - plunit(blocked(File:Line, Name, Reason))), - fail ; true - ). -report_blocked. - -report_failed :- - number_of_clauses(failed/4, N), - N > 0, !, - info(plunit(failed(N))), - fail. -report_failed :- - info(plunit(failed(0))). - -report_sto :- - number_of_clauses(sto/4, N), - N > 0, !, - info(plunit(sto(N))), - fail. -report_sto :- - info(plunit(sto(0))). - -report_fixme :- - report_fixme(_,_,_). - -report_fixme(TuplesF, TuplesP, TuplesN) :- - fixme(failed, TuplesF, Failed), - fixme(passed, TuplesP, Passed), - fixme(nondet, TuplesN, Nondet), - print_message(informational, plunit(fixme(Failed, Passed, Nondet))). - - -fixme(How, Tuples, Count) :- - findall(fixme(Unit, Name, Line, Reason, How), - fixme(Unit, Name, Line, Reason, How), Tuples), - length(Tuples, Count). - - -report_failure(Unit, Name, Line, Error, _Options) :- - print_message(error, plunit(failed(Unit, Name, Line, Error))). - - -%% test_report(What) is det. -% -% Produce reports on test results after the run. - -test_report(fixme) :- !, - report_fixme(TuplesF, TuplesP, TuplesN), - append([TuplesF, TuplesP, TuplesN], Tuples), - print_message(informational, plunit(fixme(Tuples))). -test_report(What) :- - throw_error(domain_error(report_class, What), _). - - - /******************************* - * INFO * - *******************************/ - -%% current_test_set(?Unit) is nondet. -% -% True if Unit is a currently loaded test-set. - -current_test_set(Unit) :- - current_unit(Unit, _Module, _Context, _Options). - -%% unit_file(+Unit, -File) is det. -%% unit_file(-Unit, +File) is nondet. - -unit_file(Unit, File) :- - current_unit(Unit, Module, _Context, _Options), - current_module(Module, File). -unit_file(Unit, PlFile) :- - nonvar(PlFile), - test_file_for(TestFile, PlFile), - current_module(Module, TestFile), - current_unit(Unit, Module, _Context, _Options). - - - /******************************* - * FILES * - *******************************/ - -%% load_test_files(+Options) is det. -% -% Load .plt test-files related to loaded source-files. - -load_test_files(_Options) :- - ( source_file(File), - file_name_extension(Base, Old, File), - Old \== plt, - file_name_extension(Base, plt, TestFile), - exists_file(TestFile), - ( test_file_for(TestFile, File) - -> true - ; load_files(TestFile, - [ if(changed), - imports([]) - ]), - asserta(test_file_for(TestFile, File)) - ), - fail ; true - ). - - - - /******************************* - * MESSAGES * - *******************************/ - -%% info(+Term) -% -% Runs print_message(Level, Term), where Level is one of =silent= -% or =informational= (default). - -info(Term) :- - message_level(Level), - print_message(Level, Term). - -message_level(Level) :- - current_test_flag(test_options, Options), - option(silent(Silent), Options, false), - ( Silent == false - -> Level = informational - ; Level = silent - ). - -locationprefix(File:Line) --> !, - [ '~w:~d:\n\t'-[File,Line]]. -locationprefix(test(Unit,_Test,Line)) --> !, - { unit_file(Unit, File) }, - locationprefix(File:Line). -locationprefix(unit(Unit)) --> !, - [ 'PL-Unit: unit ~w: '-[Unit] ]. -locationprefix(FileLine) --> - { throw_error(type_error(locationprefix,FileLine), _) }. - -message(error(context_error(plunit_close(Name, -)), _)) --> - [ 'PL-Unit: cannot close unit ~w: no open unit'-[Name] ]. -message(error(context_error(plunit_close(Name, Start)), _)) --> - [ 'PL-Unit: cannot close unit ~w: current unit is ~w'-[Name, Start] ]. -message(plunit(nondet(File, Line, Name))) --> - locationprefix(File:Line), - [ 'PL-Unit: Test ~w: Test succeeded with choicepoint'- [Name] ]. - % Unit start/end -:- if(swi). -message(plunit(begin(Unit))) --> - [ 'PL-Unit: ~w '-[Unit], flush ]. -message(plunit(end(_Unit))) --> - [ at_same_line, ' done' ]. -:- else. -message(plunit(begin(Unit))) --> - [ 'PL-Unit: ~w '-[Unit]/*, flush-[]*/ ]. -message(plunit(end(_Unit))) --> - [ ' done'-[] ]. -:- endif. -message(plunit(blocked(unit(Unit, Reason)))) --> - [ 'PL-Unit: ~w blocked: ~w'-[Unit, Reason] ]. -message(plunit(running([]))) --> !, - [ 'PL-Unit: no tests running' ]. -message(plunit(running([One]))) --> !, - [ 'PL-Unit: running ' ], - running(One). -message(plunit(running(More))) --> !, - [ 'PL-Unit: running tests:', nl ], - running(More). -message(plunit(fixme([]))) --> !. -message(plunit(fixme(Tuples))) --> !, - fixme_message(Tuples). - - % Blocked tests -message(plunit(blocked(1))) --> !, - [ 'one test is blocked:'-[] ]. -message(plunit(blocked(N))) --> - [ '~D tests are blocked:'-[N] ]. -message(plunit(blocked(Pos, Name, Reason))) --> - locationprefix(Pos), - test_name(Name), - [ ': ~w'-[Reason] ]. - - % fail/success -message(plunit(no_tests)) --> !, - [ 'No tests to run' ]. -message(plunit(all_passed(Count))) --> !, - [ 'All ~D tests passed'-[Count] ]. -message(plunit(failed(0))) --> !, - []. -message(plunit(failed(1))) --> !, - [ '1 test failed'-[] ]. -message(plunit(failed(N))) --> - [ '~D tests failed'-[N] ]. -message(plunit(sto(0))) --> !, - []. -message(plunit(sto(N))) --> - [ '~D test results depend on unification mode'-[N] ]. -message(plunit(fixme(0,0,0))) --> - []. -message(plunit(fixme(Failed,0,0))) --> !, - [ 'all ~D tests flagged FIXME failed'-[Failed] ]. -message(plunit(fixme(Failed,Passed,0))) --> - [ 'FIXME: ~D failed; ~D passed'-[Failed, Passed] ]. -message(plunit(fixme(Failed,Passed,Nondet))) --> - { TotalPassed is Passed+Nondet }, - [ 'FIXME: ~D failed; ~D passed; (~D nondet)'-[Failed, TotalPassed, Nondet] ]. -message(plunit(failed(Unit, Name, Line, Failure))) --> - { unit_file(Unit, File) }, - locationprefix(File:Line), - test_name(Name), - [': '-[] ], - failure(Failure). - % Setup/condition errors -message(plunit(error(Where, Context, Exception))) --> - locationprefix(Context), - { message_to_string(Exception, String) }, - [ 'error in ~w: ~w'-[Where, String] ]. - - % STO messages -message(plunit(sto(Unit, Name, Line))) --> - { unit_file(Unit, File) }, - locationprefix(File:Line), - test_name(Name), - [' is subject to occurs check (STO): '-[] ]. -message(plunit(sto(Type, Result))) --> - sto_type(Type), - sto_result(Result). - - % Interrupts (SWI) -:- if(swi). -message(interrupt(begin)) --> - { thread_self(Me), - running(Unit, Test, Line, STO, Me), !, - unit_file(Unit, File) - }, - [ 'Interrupted test '-[] ], - running(running(Unit:Test, File:Line, STO, Me)), - [nl], - '$messages':prolog_message(interrupt(begin)). -message(interrupt(begin)) --> - '$messages':prolog_message(interrupt(begin)). -:- endif. - -test_name(@(Name,Bindings)) --> !, - [ 'test ~w (forall bindings = ~p)'-[Name, Bindings] ]. -test_name(Name) --> !, - [ 'test ~w'-[Name] ]. - -sto_type(sto_error_incomplete) --> - [ 'Finite trees (error checking): ' ]. -sto_type(rational_trees) --> - [ 'Rational trees: ' ]. -sto_type(finite_trees) --> - [ 'Finite trees: ' ]. - -sto_result(success(_Unit, _Name, _Line, Det, Time)) --> - det(Det), - [ ' success in ~2f seconds'-[Time] ]. -sto_result(failure(_Unit, _Name, _Line, How)) --> - failure(How). - -det(true) --> - [ 'deterministic' ]. -det(false) --> - [ 'non-deterministic' ]. - -running(running(Unit:Test, File:Line, STO, Thread)) --> - thread(Thread), - [ '~q:~q at ~w:~d'-[Unit, Test, File, Line] ], - current_sto(STO). -running([H|T]) --> - ['\t'], running(H), - ( {T == []} - -> [] - ; [nl], running(T) - ). - -thread(main) --> !. -thread(Other) --> - [' [~w] '-[Other] ]. - -current_sto(sto_error_incomplete) --> - [ ' (STO: error checking)' ]. -current_sto(rational_trees) --> - []. -current_sto(finite_trees) --> - [ ' (STO: occurs check enabled)' ]. - -:- if(swi). -write_term(T, OPS) --> - ['~@'-[write_term(T,OPS)]]. -:- else. -write_term(T, _OPS) --> - ['~q'-[T]]. -:- endif. - -expected_got_ops_(Ex, E, OPS, Goals) --> - [' Expected: '-[]], write_term(Ex, OPS), [nl], - [' Got: '-[]], write_term(E, OPS), [nl], - ( { Goals = [] } -> [] - ; [' with: '-[]], write_term(Goals, OPS), [nl] - ). - - -failure(Var) --> - { var(Var) }, !, - [ 'Unknown failure?' ]. -failure(succeeded(Time)) --> !, - [ 'must fail but succeeded in ~2f seconds~n'-[Time] ]. -failure(wrong_error(Expected, Error)) --> !, - { copy_term(Expected-Error, Ex-E, Goals), - numbervars(Ex-E-Goals, 0, _), - write_options(OPS) - }, - [ 'wrong error'-[], nl ], - expected_got_ops_(Ex, E, OPS, Goals). -failure(wrong_answer(Cmp)) --> - { Cmp =.. [Op,Answer,Expected], !, - copy_term(Expected-Answer, Ex-A, Goals), - numbervars(Ex-A-Goals, 0, _), - write_options(OPS) - }, - [ 'wrong answer (compared using ~w)'-[Op], nl ], - expected_got_ops_(Ex, A, OPS, Goals). -:- if(swi). -failure(Error) --> - { Error = error(_,_), !, - message_to_string(Error, Message) - }, - [ 'received error: ~w'-[Message] ]. -:- endif. -failure(Why) --> - [ '~p~n'-[Why] ]. - -fixme_message([]) --> []. -fixme_message([fixme(Unit, _Name, Line, Reason, How)|T]) --> - { unit_file(Unit, File) }, - fixme_message(File:Line, Reason, How), - ( {T == []} - -> [] - ; [nl], - fixme_message(T) - ). - -fixme_message(Location, Reason, failed) --> - [ 'FIXME: ~w: ~w'-[Location, Reason] ]. -fixme_message(Location, Reason, passed) --> - [ 'FIXME: ~w: passed ~w'-[Location, Reason] ]. -fixme_message(Location, Reason, nondet) --> - [ 'FIXME: ~w: passed (nondet) ~w'-[Location, Reason] ]. - - -write_options([ numbervars(true), - quoted(true), - portray(true), - max_depth(10), - attributes(portray) - ]). - -:- if(swi). - -:- multifile - prolog:message/3, - user:message_hook/3. - -prolog:message(Term) --> - message(Term). - -% user:message_hook(+Term, +Kind, +Lines) - -user:message_hook(make(done(Files)), _, _) :- - make_run_tests(Files), - fail. % give other hooks a chance - -:- endif. - -:- if(sicstus). - -user:generate_message_hook(Message) --> - message(Message), - [nl]. % SICStus requires nl at the end - -% user:message_hook(+Severity, +Message, +Lines) is semidet. -% -% Redefine printing some messages. It appears SICStus has no way -% to get multiple messages at the same line, so we roll our own. -% As there is a lot pre-wired and checked in the SICStus message -% handling we cannot reuse the lines. Unless I miss something ... - -user:message_hook(informational, plunit(begin(Unit)), _Lines) :- - format(user_error, '% PL-Unit: ~w ', [Unit]), - flush_output(user_error). -user:message_hook(informational, plunit(end(_Unit)), _Lines) :- - format(user, ' done~n', []). - -:- endif. - diff --git a/packages/plunit/test_cover.pl b/packages/plunit/test_cover.pl deleted file mode 100644 index 4435d1177..000000000 --- a/packages/plunit/test_cover.pl +++ /dev/null @@ -1,251 +0,0 @@ -/* $Id$ - - Part of SWI-Prolog - - Author: Jan Wielemaker - E-mail: wielemak@science.uva.nl - WWW: http://www.swi-prolog.org - Copyright (C): 1985-2006, University of Amsterdam - - This program is free software; you can redistribute it and/or - modify it under the terms of the GNU General Public License - as published by the Free Software Foundation; either version 2 - of the License, or (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - - As a special exception, if you link this library with other files, - compiled with a Free Software compiler, to produce an executable, this - library does not by itself cause the resulting executable to be covered - by the GNU General Public License. This exception does not however - invalidate any other reasons why the executable file might be covered by - the GNU General Public License. -*/ - -:- module(prolog_cover, - [ show_coverage/1, % :Goal - covered_clauses/4 % +Goal, -Result, -Succeeded, -Failed - ]). -:- use_module(library(ordsets)). - -:- set_prolog_flag(generate_debug_info, false). - -/** Clause cover analysis - -The purpose of this module is to find which part of the program has been -use by a certain goal. Usage is defined in terms of clauses that have -fired, seperated in clauses that succeeded at least once and clauses -that failed on each occasion. - -This module relies on the SWI-Prolog tracer hooks. It modifies these -hooks and collects the results, after which it restores the debugging -environment. This has some limitations: - - * The performance degrades significantly (about 10 times) - * It is not possible to use the debugger using coverage analysis - * The cover analysis tool is currently not thread-safe. - -The result is represented as a list of clause-references. As the -references to clauses of dynamic predicates cannot be guaranteed, these -are omitted from the result. - -@bug Relies heavily on SWI-Prolog internals. We have considered using - a meta-interpreter for this purpose, but it is nearly impossible - to do 100% complete meta-interpretation of Prolog. Example - problem areas include handling cuts in control-structures - and calls from non-interpreted meta-predicates. -*/ - - -:- dynamic - entered/1, % clauses entered - exited/1. % clauses completed - -:- module_transparent - covering/1, - covering/4. - -%% show_coverage(Goal) -% -% Report on coverage by Goal - -show_coverage(Goal) :- - covered_clauses(Goal, Result, Succeeded, Failed), - file_coverage(Succeeded, Failed), - return(Result). - -return(true). -return(fail) :- !, fail. -return(error(E)) :- - throw(E). - -%% covered_clauses(:Goal, -Result, -Succeeded, -Failed) is det. -% -% Run Goal as once/1. Unify Result with one of =true=, =fail= or -% error(Error). -% -% @param Succeeded Ordered set of succeeded clauses -% @param Failed Ordered set of clauses that are entered but -% never succeeded. - -covered_clauses(Goal, Result, Succeeded, Failed) :- - asserta(user:prolog_trace_interception(Port, Frame, _, continue) :- - prolog_cover:assert_cover(Port, Frame), Ref), - port_mask([unify,exit], Mask), - '$visible'(V, Mask), - '$leash'(L, Mask), - trace, - call_with_result(Goal, Result), - set_prolog_flag(debug, false), - covered(Ref, V, L, Succeeded, Failed). - -%% call_with_result(:Goal, -Result) is det. -% -% Run Goal as once/1. Unify Result with one of =true=, =fail= or -% error(Error). - -call_with_result(Goal, Result) :- - ( catch(Goal, E, true) - -> ( var(E) - -> Result = true - ; Result = error(E) - ) - ; Result = false - ). - -port_mask([], 0). -port_mask([H|T], Mask) :- - port_mask(T, M0), - '$syspreds':'$port_bit'(H, Bit), % Private stuff - Mask is M0 \/ Bit. - -%% assert_cover(+Port, +Frame) is det. -% -% Assert coverage of the current clause. We monitor two ports: the -% _unify_ port to see which clauses we entered, and the _exit_ -% port to see which completed successfully. - -assert_cover(unify, Frame) :- - running_static_pred(Frame), - prolog_frame_attribute(Frame, clause, Cl), !, - assert_entered(Cl). -assert_cover(exit, Frame) :- - running_static_pred(Frame), - prolog_frame_attribute(Frame, clause, Cl), !, - assert_exited(Cl). -assert_cover(_, _). - -%% running_static_pred(+Frame) is semidet. -% -% True if Frame is not running a dynamic predicate. - -running_static_pred(Frame) :- - prolog_frame_attribute(Frame, goal, Goal), - \+ predicate_property(Goal, dynamic). - -%% assert_entered(+Ref) is det. -%% assert_exited(+Ref) is det. -% -% Add Ref to the set of entered or exited clauses. - -assert_entered(Cl) :- - entered(Cl), !. -assert_entered(Cl) :- - assert(entered(Cl)). - -assert_exited(Cl) :- - exited(Cl), !. -assert_exited(Cl) :- - assert(exited(Cl)). - -%% covered(+Ref, +VisibleMask, +LeashMask, -Succeeded, -Failed) is det. -% -% Restore state and collect failed and succeeded clauses. - -covered(Ref, V, L, Succeeded, Failed) :- - '$visible'(_, V), - '$leash'(_, L), - erase(Ref), - findall(Cl, (entered(Cl), \+exited(Cl)), Failed0), - findall(Cl, retract(exited(Cl)), Succeeded0), - retractall(entered(Cl)), - sort(Failed0, Failed), - sort(Succeeded0, Succeeded). - - - /******************************* - * REPORTING * - *******************************/ - -%% file_coverage(+Succeeded, +Failed) is det. -% -% Write a report on the clauses covered organised by file to -% current output. - -file_coverage(Succeeded, Failed) :- - format('~N~n~`=t~78|~n'), - format('~tCoverage by File~t~78|~n'), - format('~`=t~78|~n'), - format('~w~t~w~64|~t~w~72|~t~w~78|~n', - ['File', 'Clauses', '%Cov', '%Fail']), - format('~`=t~78|~n'), - forall(source_file(File), - file_coverage(File, Succeeded, Failed)), - format('~`=t~78|~n'). - -file_coverage(File, Succeeded, Failed) :- - findall(Cl, clause_source(Cl, File, _), Clauses), - sort(Clauses, All), - ( ord_intersect(All, Succeeded) - -> true - ; ord_intersect(All, Failed) - ), !, - ord_intersection(All, Failed, FailedInFile), - ord_intersection(All, Succeeded, SucceededInFile), - ord_subtract(All, SucceededInFile, UnCov1), - ord_subtract(UnCov1, FailedInFile, Uncovered), - length(All, AC), - length(Uncovered, UC), - length(FailedInFile, FC), - CP is 100-100*UC/AC, - FCP is 100*FC/AC, - summary(File, 56, SFile), - format('~w~t ~D~64| ~t~1f~72| ~t~1f~78|~n', [SFile, AC, CP, FCP]). -file_coverage(_,_,_). - - -summary(Atom, MaxLen, Summary) :- - atom_length(Atom, Len), - ( Len < MaxLen - -> Summary = Atom - ; SLen is MaxLen - 5, - sub_atom(Atom, _, SLen, 0, End), - atom_concat('...', End, Summary) - ). - - -%% clause_source(+Clause, -File, -Line) is det. -%% clause_source(-Clause, +File, -Line) is det. - -clause_source(Clause, File, Line) :- - nonvar(Clause), !, - clause_property(Clause, file(File)), - clause_property(Clause, line_count(Line)). -clause_source(Clause, File, Line) :- - source_file(Pred, File), - \+ predicate_property(Pred, multifile), - nth_clause(Pred, _Index, Clause), - clause_property(Clause, line_count(Line)). -clause_source(Clause, File, Line) :- - Pred = _:_, - predicate_property(Pred, multifile), - nth_clause(Pred, _Index, Clause), - clause_property(Clause, file(File)), - clause_property(Clause, line_count(Line)). diff --git a/packages/plunit/test_wizard.pl b/packages/plunit/test_wizard.pl deleted file mode 100644 index 7775277e3..000000000 --- a/packages/plunit/test_wizard.pl +++ /dev/null @@ -1,211 +0,0 @@ -:- module(test_wizard, - [ make_tests/3, % +Module, +File, +Out - make_test/3 % +Callable, -Module, -Test - ]). -:- use_module(library(time)). -:- use_module(library(lists)). -:- use_module(library(listing)). -:- use_module(library(readutil)). - -/** Test Generation Wizard - -Tasks - - * Accumulate user queries - * Suggest tests from user queries -*/ - -setting(max_time(5)). - - - /******************************* - * UNIT GENERATION * - *******************************/ - -%% make_tests(+Module, +File, +Out) is det. -% -% Create tests from queries stored in File and write the tests for -% Module to the stream Out. - -make_tests(Module, File, Out) :- - read_file_to_terms(File, Queries, []), - findall(Test, ( member(Q, Queries), - make_test(Q, Module, Test)), Tests), - ( Tests == [] - -> true - ; format(Out, ':- begin_tests(~q).~n~n', [Module]), - maplist(portray_clause(Out), Tests), - format(Out, '~n:- end_tests(~q).~n', [Module]) - ). - - - /******************************* - * TEST GENERATION * - *******************************/ - -%% make_test(+Query:callable, -Module, -Test:term) is det. -% -% Generate a test from a query. Test is returned as a clause of -% test/1 or test/2 to be inserted between begin_tests and -% end_tests. - -make_test(Query0, Module, (test(Name, Options) :- Query)) :- - find_test_module(Query0, Module, Query), - pred_name(Query, Name), - setting(max_time(Max)), - test_result(Module:Query, Max, Options). - -%% find_test_module(+QuerySpec, ?Module, -Query). -% -% Find module to test from a query. Note that it is very common -% for toplevel usage to rely on SWI-Prolog's DWIM. -% -% @tbd What if multiple modules match? We can select the -% local one or ask the user. - -find_test_module(Var, _, _) :- - var(Var), !, fail. -find_test_module(M:Query, M0, Query) :- !, - M0 = M. -find_test_module(Query, M, Query) :- - current_predicate(_, M:Query), - \+ predicate_property(M:Query, imported_from(_M2)). - -%% pred_name(+Callable, -Name) is det. -% -% Suggest a name for the test. In the plunit framework the name -% needs not be unique, so we simply take the predicate name. - -pred_name(Callable, Name) :- - strip_module(Callable, _, Term), - functor(Term, Name, _Arity). - -%% test_result(+Callable, +Maxtime, -Result) is det. -% -% Try running goal and get meaningful results. Results are: -% -% * true(Templ == Var) -% * fail -% * all(Templ == Bindings) -% * throws(Error) -% * timeout - -test_result(Callable, Maxtime, Result) :- - term_variables(Callable, Vars), - make_template(Vars, Templ), - catch(call_with_time_limit(Maxtime, - findall(Templ-Det, - call_test(Callable, Det), - Bindings)), - E, true), - ( var(E) - -> success(Bindings, Templ, Result) - ; error(E, Result) - ). - -%% success(+Bindings, +Templ, -Result) is det. -% -% Create test-results from non-error cases. - -success([], _, [fail]) :- !. -success([[]-true], _, []) :- !. -success([S1-true], Templ, [ true(Templ == S1) ]) :- !. -success([[]-false], _, [ nondet ]) :- !. -success([S1-false], Templ, [ true(Templ == S1), nondet ]) :- !. -success(ListDet, Templ, [all(Templ == List)]) :- - strip_det(ListDet, List). - -strip_det([], []). -strip_det([H-_|T0], [H|T]) :- - strip_det(T0, T). - -%% error(+ErrorTerm, -Result) - -error(Error0, [throws(Error)]) :- - generalise_error(Error0, Error). - - -generalise_error(error(Formal, _), error(Formal, _)) :- !. -generalise_error(Term, Term). - - -%% make_template(+Vars, -Template) is det. -% -% Make a nice looking template - -make_template([], []) :- !. -make_template([One], One) :- !. -make_template([One, Two], One-Two) :- !. -make_template(List, Vars) :- - Vars =.. [v|List]. - -%% call_test(:Goal, -Det) is nondet. -% -% True if Goal succeeded. Det is unified to =true= if Goal left -% no choicepoints and =false= otherwise. - -call_test(Goal, Det) :- - Goal, - deterministic(Det). - - - /******************************* - * COLLECT * - *******************************/ - -/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -Collect toplevel queries if the Prolog flag log_query_file points to the -name of a writeable file. The file is opened in append-mode for -exclusive write to allow for concurrent operation from multiple Prolog -systems using the same logfile. - -The file is written in UTF-8 encoding and using ignore_ops(true) to -ensure it can be read. -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ - -:- multifile - user:message_hook/3. - -user:message_hook(toplevel_goal(Goal0, Bindings), _Level, _Lines) :- - open_query_log(Out), - bind_vars(Bindings), - clean_goal(Goal0, Goal), - call_cleanup(format(Out, '~W.~n', [Goal, [ numbervars(true), - quoted(true), - ignore_ops(true) - ]]), close(Out)), - fail. - -clean_goal(Var, _) :- - var(Var), !, fail. -clean_goal(user:Goal, Goal) :- !. -clean_goal(Goal, Goal). - -bind_vars([]). -bind_vars([Name=Var|T]) :- - Var = '$VAR'(Name), - bind_vars(T). - -open_query_log(Out) :- - current_prolog_flag(log_query_file, File), - exists_file(File), !, - open(File, append, Out, - [ encoding(utf8), - lock(write) - ]). -open_query_log(Out) :- - current_prolog_flag(log_query_file, File), - access_file(File, write), !, - open(File, write, Out, - [ encoding(utf8), - lock(write), - bom(true) - ]), - format(Out, - '/* SWI-Prolog query log. This file contains all syntactically\n \ - correct queries issued in this directory. It is used by the\n \ - test wizard to generate unit tests.\n\ - */~n~n', []). - - - diff --git a/packages/semweb b/packages/semweb index 4ce1e49b4..82c003105 160000 --- a/packages/semweb +++ b/packages/semweb @@ -1 +1 @@ -Subproject commit 4ce1e49b493a8571a2159660195adcf5f353af79 +Subproject commit 82c00310523e08d1bd314374aed335e4b511c823 diff --git a/packages/sgml b/packages/sgml index 3a23a5129..28338edf6 160000 --- a/packages/sgml +++ b/packages/sgml @@ -1 +1 @@ -Subproject commit 3a23a5129738fa08327922bda35bb5458191aaa5 +Subproject commit 28338edf66fc4618518fa4be9bf6e28bc81a7aaf diff --git a/pl/consult.yap b/pl/consult.yap index 275e1ed7f..072b1892d 100755 --- a/pl/consult.yap +++ b/pl/consult.yap @@ -1045,3 +1045,4 @@ make. '$fetch_stream_alias'(OldStream,Alias) :- stream_property(OldStream, alias(Alias)), !. +'$require'(_Ps, _M). \ No newline at end of file diff --git a/pl/directives.yap b/pl/directives.yap index 84265e5fd..eb0b1fa9d 100644 --- a/pl/directives.yap +++ b/pl/directives.yap @@ -48,6 +48,7 @@ '$directive'(parallel). '$directive'(public(_)). '$directive'(op(_,_,_)). +'$directive'(require(_)). '$directive'(set_prolog_flag(_,_)). '$directive'(reconsult(_)). '$directive'(reexport(_)). @@ -104,6 +105,8 @@ '$module_transparent'(P, M). '$exec_directive'(noprofile(P), _, M) :- '$noprofile'(P, M). +'$exec_directive'(require(Ps), _, M) :- + '$require'(Ps, M). '$exec_directive'(dynamic(P), _, M) :- '$dynamic'(P, M). '$exec_directive'(thread_local(P), _, M) :- diff --git a/pl/utils.yap b/pl/utils.yap index 3c45c2b9f..5ea3410f2 100644 --- a/pl/utils.yap +++ b/pl/utils.yap @@ -301,6 +301,9 @@ putenv(Na,Val) :- getenv(Na,Val) :- '$getenv'(Na,Val). +setenv(Na,Val) :- + '$putenv'(Na,Val). + %%% Saving and restoring a computation save(A) :- save(A,_).