├── support ├── exclude.txt └── aunit.xml ├── version_information ├── .gitignore ├── doc ├── share │ ├── favicon.ico │ ├── adacore-logo-white.png │ ├── latex_elements.py │ └── conf.py ├── aunit_cb │ ├── gps_support.rst │ └── introduction.rst ├── aunit_cb.rst └── Makefile ├── test ├── zfp.adc ├── src │ ├── aunit_suite.ads │ ├── aunit-test_suites-tests-suite.ads │ ├── aunit-test_cases-tests-suite.ads │ ├── aunit-test_fixtures-tests-suite.ads │ ├── aunit-test_cases-tests.ads │ ├── aunit_suite.adb │ ├── aunit-test_suites-tests.ads │ ├── aunit-test_fixtures-tests.ads │ ├── aunit-test_fixtures-tests_fixtures.ads │ ├── aunit_harness.adb │ ├── aunit-test_cases-tests-suite.adb │ ├── aunit-test_fixtures-tests-suite.adb │ ├── aunit-test_cases-tests_fixtures.ads │ ├── aunit-test_suites-tests-suite.adb │ ├── aunit-test_fixtures-tests_fixtures.adb │ ├── aunit-test_suites-tests_fixtures.ads │ ├── aunit-test_cases-tests.adb │ ├── aunit-test_suites-tests_fixtures.adb │ └── aunit-test_cases-tests_fixtures.adb ├── expected.out ├── support │ └── run-ppc-elf ├── aunit_tests.gpr └── Makefile ├── examples ├── test_caller │ ├── Makefile │ ├── harness │ │ ├── src │ │ │ ├── math_suite.ads │ │ │ ├── math-test.ads │ │ │ ├── test_math.adb │ │ │ ├── math_suite.adb │ │ │ └── math-test.adb │ │ └── harness.gpr │ └── tested_lib │ │ ├── src │ │ ├── math.ads │ │ └── math.adb │ │ └── testlib.gpr ├── liskov │ ├── Makefile │ ├── tests │ │ ├── my_suite.ads │ │ ├── square-tests-suite.ads │ │ ├── rectangle-tests-suite.ads │ │ ├── square-tests-suite_liskov.ads │ │ ├── rectangle-tests.ads │ │ ├── square-tests.ads │ │ ├── test_liskov.adb │ │ ├── shape-tests.ads │ │ ├── my_suite.adb │ │ ├── rectangle-tests.adb │ │ ├── square-tests.adb │ │ ├── shape-tests.adb │ │ ├── square-tests-suite.adb │ │ ├── rectangle-tests-suite.adb │ │ └── square-tests-suite_liskov.adb │ ├── tested_lib │ │ ├── src │ │ │ ├── rectangle.adb │ │ │ ├── rectangle.ads │ │ │ ├── square.adb │ │ │ ├── shape.adb │ │ │ ├── square.ads │ │ │ └── shape.ads │ │ └── testlib.gpr │ └── harness.gpr ├── failures │ ├── Makefile │ ├── tests │ │ ├── math_suite.ads │ │ ├── test_math.adb │ │ ├── math-test.ads │ │ ├── math_suite.adb │ │ └── math-test.adb │ ├── tested_lib │ │ ├── src │ │ │ ├── math.ads │ │ │ └── math.adb │ │ └── testlib.gpr │ └── harness.gpr ├── simple_test │ ├── Makefile │ ├── tests │ │ ├── math_suite.ads │ │ ├── test_math.adb │ │ ├── math-test.ads │ │ ├── math_suite.adb │ │ └── math-test.adb │ ├── tested_lib │ │ ├── src │ │ │ ├── math.ads │ │ │ └── math.adb │ │ └── testlib.gpr │ └── harness.gpr ├── test_fixture │ ├── Makefile │ ├── tests │ │ ├── math_suite.ads │ │ ├── test_math.adb │ │ ├── math-test.ads │ │ ├── math_suite.adb │ │ └── math-test.adb │ ├── tested_lib │ │ ├── src │ │ │ ├── math.ads │ │ │ └── math.adb │ │ └── testlib.gpr │ └── harness.gpr ├── calculator │ ├── fixture │ │ ├── main_suite.ads │ │ ├── operations-addition-test-suite.ads │ │ ├── stack-test-suite.ads │ │ ├── operations-subtraction-test-suite.ads │ │ ├── operands-ints-test-suite.ads │ │ ├── test_calculator.adb │ │ ├── main_suite.adb │ │ ├── operations-binary-gen_test-gen_suite.adb │ │ ├── operations-binary-gen_test-gen_suite.ads │ │ ├── operands-ints-test-suite.adb │ │ └── stack-test-suite.adb │ ├── tests │ │ ├── operations-addition-test.ads │ │ ├── operations-subtraction-test.ads │ │ ├── operands-ints-test.ads │ │ ├── operations-addition_test_fixture.ads │ │ ├── operations-subtraction_test_fixture.ads │ │ ├── operations-addition_test_fixture.adb │ │ ├── operations-subtraction_test_fixture.adb │ │ ├── stack-test.ads │ │ ├── operations-binary-gen_test.ads │ │ ├── operands-ints-test.adb │ │ └── operations-binary-gen_test.adb │ ├── tested_lib │ │ ├── src │ │ │ ├── operations-ints.ads │ │ │ ├── operands.ads │ │ │ ├── operations-addition.ads │ │ │ ├── operations-subtraction.ads │ │ │ ├── operands-ints.ads │ │ │ ├── operations-ints.adb │ │ │ ├── operations.ads │ │ │ ├── operands-ints.adb │ │ │ ├── operations-binary.adb │ │ │ ├── stack.ads │ │ │ ├── operations-binary.ads │ │ │ └── stack.adb │ │ └── testlib.gpr │ ├── Makefile │ └── harness.gpr └── Makefile ├── template ├── sample_suite.ads ├── harness.adb ├── sample_suite.adb ├── pr_xxxx_xxx.ads ├── sample.gpr └── pr_xxxx_xxx.adb ├── internal └── README.gpl ├── include └── aunit │ ├── containers │ └── ada_containers.ads │ ├── framework │ ├── aunit-reporter.adb │ ├── nodealloc │ │ ├── aunit-memory-utils.adb │ │ └── aunit-memory.adb │ ├── nativememory │ │ ├── aunit-memory-utils.adb │ │ └── aunit-memory.adb │ ├── aunit-tests.ads │ ├── aunit-memory-utils.ads │ ├── aunit.ads │ ├── aunit-test_fixtures.adb │ ├── certexception │ │ ├── aunit-assertions-assert_exception.adb │ │ └── aunit-test_cases-call_set_up_case.adb │ ├── fullexception │ │ ├── aunit-assertions-assert_exception.adb │ │ └── aunit-test_cases-call_set_up_case.adb │ ├── aunit-options.ads │ ├── aunit-memory.ads │ ├── nofileio │ │ ├── aunit-io.ads │ │ └── aunit-io.adb │ ├── staticmemory │ │ └── aunit-memory-utils.adb │ ├── zfpexception │ │ ├── aunit-assertions-assert_exception.adb │ │ ├── aunit-last_chance_handler.ads │ │ └── aunit-test_cases-call_set_up_case.adb │ ├── aunit-reporter.ads │ ├── aunit-test_cases-registration.adb │ ├── fileio │ │ └── aunit-io.ads │ └── nocalendar │ │ └── aunit-time_measure.ads │ └── reporters │ ├── aunit-reporter-xml.ads │ ├── aunit-reporter-junit.ads │ └── aunit-reporter-gnattest.ads ├── README ├── Makefile ├── lib └── gnat │ ├── aunit_shared.gpr │ └── aunit.gpr └── COPYING.RUNTIME /support/exclude.txt: -------------------------------------------------------------------------------- 1 | .svn 2 | -------------------------------------------------------------------------------- /version_information: -------------------------------------------------------------------------------- 1 | 0.0 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | *.ali 3 | lib/aunit* 4 | -------------------------------------------------------------------------------- /doc/share/favicon.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/AdaCore/aunit/HEAD/doc/share/favicon.ico -------------------------------------------------------------------------------- /doc/share/adacore-logo-white.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/AdaCore/aunit/HEAD/doc/share/adacore-logo-white.png -------------------------------------------------------------------------------- /test/zfp.adc: -------------------------------------------------------------------------------- 1 | pragma Restrictions (No_Fixed_Point); 2 | pragma Restrictions (No_Implementation_Attributes); 3 | -------------------------------------------------------------------------------- /examples/test_caller/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | gprbuild -p -Pharness/harness 3 | clean: 4 | gprclean -Pharness/harness 5 | gprclean -Ptested_lib/testlib 6 | -------------------------------------------------------------------------------- /examples/liskov/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | gprbuild -p -Pharness 3 | clean: 4 | -gprclean -Pharness 5 | -gprclean -Ptested_lib/testlib 6 | rm -rf obj tested_lib/obj 7 | -------------------------------------------------------------------------------- /examples/failures/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | gprbuild -p -Pharness 3 | clean: 4 | -gprclean -Pharness 5 | -gprclean -Ptested_lib/testlib 6 | rm -rf obj tested_lib/obj 7 | -------------------------------------------------------------------------------- /examples/simple_test/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | gprbuild -p -Pharness 3 | clean: 4 | -gprclean -Pharness 5 | -gprclean -Ptested_lib/testlib 6 | rm -rf obj tested_lib/obj 7 | -------------------------------------------------------------------------------- /examples/test_fixture/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | gprbuild -p -Pharness 3 | clean: 4 | -gprclean -Pharness 5 | -gprclean -Ptested_lib/testlib 6 | rm -rf obj tested_lib/obj 7 | -------------------------------------------------------------------------------- /template/sample_suite.ads: -------------------------------------------------------------------------------- 1 | with AUnit.Test_Suites; use AUnit.Test_Suites; 2 | 3 | package Sample_Suite is 4 | function Suite return Access_Test_Suite; 5 | end Sample_Suite; 6 | -------------------------------------------------------------------------------- /test/src/aunit_suite.ads: -------------------------------------------------------------------------------- 1 | with AUnit; use AUnit; 2 | with AUnit.Test_Suites; 3 | package AUnit_Suite is 4 | function Suite return Test_Suites.Access_Test_Suite; 5 | end AUnit_Suite; 6 | -------------------------------------------------------------------------------- /test/expected.out: -------------------------------------------------------------------------------- 1 | Total Tests Run: 15 2 | Successful Tests: 15 3 | Failed Assertions: 0 4 | Unexpected Errors: 0 5 | Total Tests Run: 1 6 | Successful Tests: 1 7 | Failed Assertions: 0 8 | Unexpected Errors: 0 9 | -------------------------------------------------------------------------------- /examples/liskov/tests/my_suite.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with AUnit.Test_Suites; 5 | 6 | package My_Suite is 7 | 8 | function Suite return AUnit.Test_Suites.Access_Test_Suite; 9 | 10 | end My_Suite; 11 | -------------------------------------------------------------------------------- /examples/calculator/fixture/main_suite.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with AUnit.Test_Suites; use AUnit.Test_Suites; 5 | 6 | package Main_Suite is 7 | 8 | function Suite return Access_Test_Suite; 9 | 10 | end Main_Suite; 11 | -------------------------------------------------------------------------------- /examples/failures/tests/math_suite.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with AUnit.Test_Suites; use AUnit.Test_Suites; 5 | 6 | package Math_Suite is 7 | 8 | function Suite return Access_Test_Suite; 9 | 10 | end Math_Suite; 11 | -------------------------------------------------------------------------------- /examples/simple_test/tests/math_suite.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with AUnit.Test_Suites; use AUnit.Test_Suites; 5 | 6 | package Math_Suite is 7 | 8 | function Suite return Access_Test_Suite; 9 | 10 | end Math_Suite; 11 | -------------------------------------------------------------------------------- /examples/test_fixture/tests/math_suite.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with AUnit.Test_Suites; use AUnit.Test_Suites; 5 | 6 | package Math_Suite is 7 | 8 | function Suite return Access_Test_Suite; 9 | 10 | end Math_Suite; 11 | -------------------------------------------------------------------------------- /examples/test_caller/harness/src/math_suite.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with AUnit.Test_Suites; use AUnit.Test_Suites; 5 | 6 | package Math_Suite is 7 | 8 | function Suite return Access_Test_Suite; 9 | 10 | end Math_Suite; 11 | -------------------------------------------------------------------------------- /examples/calculator/fixture/operations-addition-test-suite.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2021, AdaCore 3 | -- 4 | with Operations.Binary.Gen_Test.Gen_Suite; 5 | package Operations.Addition.Test.Suite is new 6 | Operations.Addition.Test.Gen_Suite ("Operations.Addition"); 7 | -------------------------------------------------------------------------------- /test/src/aunit-test_suites-tests-suite.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2009-2010, AdaCore 3 | -- 4 | 5 | package AUnit.Test_Suites.Tests.Suite is 6 | 7 | function Test_Suite return AUnit.Test_Suites.Access_Test_Suite; 8 | 9 | end AUnit.Test_Suites.Tests.Suite; 10 | -------------------------------------------------------------------------------- /examples/calculator/fixture/stack-test-suite.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with AUnit.Test_Suites; use AUnit.Test_Suites; 5 | 6 | package Stack.Test.Suite is 7 | 8 | function Suite return Access_Test_Suite; 9 | 10 | end Stack.Test.Suite; 11 | -------------------------------------------------------------------------------- /examples/liskov/tests/square-tests-suite.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | 5 | with AUnit.Test_Suites; 6 | 7 | package Square.Tests.Suite is 8 | 9 | function Suite return AUnit.Test_Suites.Access_Test_Suite; 10 | 11 | end Square.Tests.Suite; 12 | -------------------------------------------------------------------------------- /examples/calculator/fixture/operations-subtraction-test-suite.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with Operations.Binary.Gen_Test.Gen_Suite; 5 | package Operations.Subtraction.Test.Suite is new 6 | Operations.Subtraction.Test.Gen_Suite ("Operations.Subtraction"); 7 | -------------------------------------------------------------------------------- /examples/failures/tested_lib/src/math.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | package Math is 5 | 6 | type Int is new Integer; 7 | 8 | function "+" (I1, I2 : Int) return Int; 9 | 10 | function "-" (I1, I2 : Int) return Int; 11 | 12 | end Math; 13 | -------------------------------------------------------------------------------- /examples/simple_test/tested_lib/src/math.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | package Math is 5 | 6 | type Int is new Integer; 7 | 8 | function "+" (I1, I2 : Int) return Int; 9 | 10 | function "-" (I1, I2 : Int) return Int; 11 | 12 | end Math; 13 | -------------------------------------------------------------------------------- /examples/test_caller/tested_lib/src/math.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | package Math is 5 | 6 | type Int is new Integer; 7 | 8 | function "+" (I1, I2 : Int) return Int; 9 | 10 | function "-" (I1, I2 : Int) return Int; 11 | 12 | end Math; 13 | -------------------------------------------------------------------------------- /examples/test_fixture/tested_lib/src/math.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | package Math is 5 | 6 | type Int is new Integer; 7 | 8 | function "+" (I1, I2 : Int) return Int; 9 | 10 | function "-" (I1, I2 : Int) return Int; 11 | 12 | end Math; 13 | -------------------------------------------------------------------------------- /examples/liskov/tests/rectangle-tests-suite.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | 5 | with AUnit.Test_Suites; 6 | 7 | package Rectangle.Tests.Suite is 8 | 9 | function Suite return AUnit.Test_Suites.Access_Test_Suite; 10 | 11 | end Rectangle.Tests.Suite; 12 | -------------------------------------------------------------------------------- /examples/liskov/tested_lib/src/rectangle.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | package body Rectangle is 5 | 6 | function Area (Obj : Rectangle_Type) return Natural is 7 | begin 8 | return Obj.Width * Obj.Height; 9 | end Area; 10 | 11 | end Rectangle; 12 | -------------------------------------------------------------------------------- /examples/liskov/tests/square-tests-suite_liskov.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | 5 | with AUnit.Test_Suites; 6 | 7 | package Square.Tests.Suite_Liskov is 8 | 9 | function Suite return AUnit.Test_Suites.Access_Test_Suite; 10 | 11 | end Square.Tests.Suite_Liskov; 12 | -------------------------------------------------------------------------------- /examples/Makefile: -------------------------------------------------------------------------------- 1 | ALL_TARGETS = calculator failures liskov simple_test test_caller test_fixture 2 | 3 | all: $(ALL_TARGETS) 4 | 5 | $(ALL_TARGETS): 6 | make -C $@ 7 | 8 | clean: 9 | $(foreach DIR,$(ALL_TARGETS), make -C $(DIR) clean &&) echo end 10 | 11 | .PHONY: $(ALL_TARGETS) clean 12 | -------------------------------------------------------------------------------- /examples/calculator/fixture/operands-ints-test-suite.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with AUnit.Test_Suites; use AUnit.Test_Suites; 5 | 6 | package Operands.Ints.Test.Suite is 7 | 8 | function Suite return Access_Test_Suite; 9 | 10 | end Operands.Ints.Test.Suite; 11 | -------------------------------------------------------------------------------- /examples/calculator/tests/operations-addition-test.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2021, AdaCore 3 | -- 4 | with Operations.Binary.Gen_Test; 5 | with Operations.Addition_Test_Fixture; use Operations.Addition_Test_Fixture; 6 | package Operations.Addition.Test is new Operations.Addition.Gen_Test 7 | (Set_Up); 8 | -------------------------------------------------------------------------------- /test/src/aunit-test_cases-tests-suite.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2009-2010, AdaCore 3 | -- 4 | 5 | with AUnit.Test_Suites; 6 | 7 | package AUnit.Test_Cases.Tests.Suite is 8 | 9 | function Test_Suite return AUnit.Test_Suites.Access_Test_Suite; 10 | 11 | end AUnit.Test_Cases.Tests.Suite; 12 | -------------------------------------------------------------------------------- /test/src/aunit-test_fixtures-tests-suite.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2009-2010, AdaCore 3 | -- 4 | 5 | with AUnit.Test_Suites; 6 | 7 | package AUnit.Test_Fixtures.Tests.Suite is 8 | 9 | function Test_Suite return AUnit.Test_Suites.Access_Test_Suite; 10 | 11 | end AUnit.Test_Fixtures.Tests.Suite; 12 | -------------------------------------------------------------------------------- /internal/README.gpl: -------------------------------------------------------------------------------- 1 | AUnit README 2 | 3 | This is the GNAT GPL release of the Ada unit test framework AUnit, derived 4 | from the JUnit/CPPUnit frameworks for Java/C++. Read the AUnit Cookbook, 5 | available in doc/ in a number of formats, for installation and usage. 6 | 7 | Maintainer: AdaCore (sales@adacore.com) 8 | -------------------------------------------------------------------------------- /examples/calculator/tests/operations-subtraction-test.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2021, AdaCore 3 | -- 4 | with Operations.Binary.Gen_Test; 5 | with Operations.Subtraction_Test_Fixture; 6 | use Operations.Subtraction_Test_Fixture; 7 | package Operations.Subtraction.Test is new Operations.Subtraction.Gen_Test 8 | (Set_Up); 9 | -------------------------------------------------------------------------------- /examples/calculator/tested_lib/src/operations-ints.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with Operands.Ints; use Operands.Ints; 5 | 6 | package Operations.Ints is 7 | 8 | function "+" (Op1, Op2 : Int) return Int; 9 | 10 | function "-" (Op1, Op2 : Int) return Int; 11 | 12 | end Operations.Ints; 13 | -------------------------------------------------------------------------------- /examples/calculator/tested_lib/src/operands.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | package Operands is 5 | 6 | type Operand is abstract tagged null record; 7 | type Operand_Access is access all Operand'Class; 8 | 9 | function Image (Opnd : Operand) return String is abstract; 10 | 11 | end Operands; 12 | -------------------------------------------------------------------------------- /examples/calculator/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | gprbuild -p -f -Pharness 3 | 4 | coverage: 5 | gprbuild -p -f -Pharness -XCOVERAGE=yes 6 | ./test_calculator 7 | cd obj; gcov ../../tested_lib/obj/*.gcda 8 | 9 | clean: 10 | gprclean -Pharness 11 | gprclean -Ptested_lib/testlib 12 | -rm -rf obj 13 | -rm -rf tested_lib/obj 14 | -rm -rf tested_lib/lib 15 | -------------------------------------------------------------------------------- /examples/liskov/tests/rectangle-tests.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with Shape.Tests; 5 | 6 | package Rectangle.Tests is 7 | 8 | type Test is new Shape.Tests.Test with null record; 9 | 10 | procedure Set_Up (T : in out Test); 11 | 12 | procedure Test_Get_Area (T : in out Test); 13 | 14 | end Rectangle.Tests; 15 | -------------------------------------------------------------------------------- /template/harness.adb: -------------------------------------------------------------------------------- 1 | with AUnit.Reporter.Text; 2 | with AUnit.Run; 3 | 4 | -- Suite for this level of tests: 5 | with Sample_Suite; 6 | 7 | procedure Harness is 8 | 9 | procedure Run is new AUnit.Run.Test_Runner (Sample_Suite.Suite); 10 | Reporter : AUnit.Reporter.Text.Text_Reporter; 11 | 12 | begin 13 | Run (Reporter); 14 | end Harness; 15 | -------------------------------------------------------------------------------- /examples/calculator/tested_lib/src/operations-addition.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with Operands.Ints; 5 | with Operations.Binary; 6 | with Operations.Ints; 7 | 8 | package Operations.Addition is new Operations.Binary 9 | (T => Operands.Ints.Int, 10 | T_Ret => Operands.Ints.Int, 11 | The_Operation => Operations.Ints."+"); 12 | -------------------------------------------------------------------------------- /examples/liskov/tests/square-tests.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with Rectangle.Tests; 5 | 6 | package Square.Tests is 7 | 8 | type Test is new Rectangle.Tests.Test with 9 | null record; 10 | 11 | procedure Set_Up (T : in out Test); 12 | 13 | procedure Test_Get_Area (T : in out Test); 14 | 15 | end Square.Tests; 16 | -------------------------------------------------------------------------------- /examples/calculator/tested_lib/src/operations-subtraction.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with Operands.Ints; 5 | with Operations.Binary; 6 | with Operations.Ints; 7 | 8 | package Operations.Subtraction is new Operations.Binary 9 | (T => Operands.Ints.Int, 10 | T_Ret => Operands.Ints.Int, 11 | The_Operation => Operations.Ints."-"); 12 | -------------------------------------------------------------------------------- /examples/failures/tests/test_math.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with AUnit.Reporter.Text; 5 | with AUnit.Run; 6 | with Math_Suite; use Math_Suite; 7 | 8 | procedure Test_Math is 9 | procedure Runner is new AUnit.Run.Test_Runner (Suite); 10 | Reporter : AUnit.Reporter.Text.Text_Reporter; 11 | begin 12 | Runner (Reporter); 13 | end Test_Math; 14 | -------------------------------------------------------------------------------- /examples/liskov/tests/test_liskov.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with AUnit.Reporter.Text; 5 | with AUnit.Run; 6 | with My_Suite; use My_Suite; 7 | 8 | procedure Test_Liskov is 9 | procedure Runner is new AUnit.Run.Test_Runner (Suite); 10 | Reporter : AUnit.Reporter.Text.Text_Reporter; 11 | begin 12 | Runner (Reporter); 13 | end Test_Liskov; 14 | -------------------------------------------------------------------------------- /examples/simple_test/tests/test_math.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with AUnit.Reporter.Text; 5 | with AUnit.Run; 6 | with Math_Suite; use Math_Suite; 7 | 8 | procedure Test_Math is 9 | procedure Runner is new AUnit.Run.Test_Runner (Suite); 10 | Reporter : AUnit.Reporter.Text.Text_Reporter; 11 | begin 12 | Runner (Reporter); 13 | end Test_Math; 14 | -------------------------------------------------------------------------------- /examples/test_fixture/tests/test_math.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with AUnit.Reporter.Text; 5 | with AUnit.Run; 6 | with Math_Suite; use Math_Suite; 7 | 8 | procedure Test_Math is 9 | procedure Runner is new AUnit.Run.Test_Runner (Suite); 10 | Reporter : AUnit.Reporter.Text.Text_Reporter; 11 | begin 12 | Runner (Reporter); 13 | end Test_Math; 14 | -------------------------------------------------------------------------------- /template/sample_suite.adb: -------------------------------------------------------------------------------- 1 | with PR_XXXX_XXX; 2 | 3 | package body Sample_Suite is 4 | 5 | Result : aliased Test_Suite; 6 | 7 | Test_Case : aliased PR_XXXX_XXX.Test_Case; 8 | 9 | function Suite return Access_Test_Suite is 10 | begin 11 | Add_Test (Result'Access, Test_Case'Access); 12 | return Result'Access; 13 | end Suite; 14 | 15 | end Sample_Suite; 16 | -------------------------------------------------------------------------------- /examples/test_caller/harness/src/math-test.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with AUnit; 5 | with AUnit.Test_Fixtures; 6 | 7 | package Math.Test is 8 | 9 | type Test is new AUnit.Test_Fixtures.Test_Fixture with null record; 10 | 11 | procedure Test_Addition (T : in out Test); 12 | procedure Test_Subtraction (T : in out Test); 13 | 14 | end Math.Test; 15 | -------------------------------------------------------------------------------- /examples/test_caller/harness/src/test_math.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with AUnit.Reporter.Text; 5 | with AUnit.Run; 6 | with Math_Suite; use Math_Suite; 7 | 8 | procedure Test_Math is 9 | procedure Runner is new AUnit.Run.Test_Runner (Suite); 10 | Reporter : AUnit.Reporter.Text.Text_Reporter; 11 | begin 12 | Runner (Reporter); 13 | end Test_Math; 14 | -------------------------------------------------------------------------------- /examples/simple_test/tests/math-test.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with AUnit; 5 | with AUnit.Simple_Test_Cases; 6 | 7 | package Math.Test is 8 | 9 | type Test is new AUnit.Simple_Test_Cases.Test_Case with null record; 10 | 11 | function Name (T : Test) return AUnit.Message_String; 12 | 13 | procedure Run_Test (T : in out Test); 14 | 15 | end Math.Test; 16 | -------------------------------------------------------------------------------- /examples/calculator/fixture/test_calculator.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with AUnit.Reporter.Text; 5 | with AUnit.Run; 6 | with Main_Suite; use Main_Suite; 7 | 8 | procedure Test_Calculator is 9 | procedure Runner is new AUnit.Run.Test_Runner (Suite); 10 | Reporter : AUnit.Reporter.Text.Text_Reporter; 11 | begin 12 | Runner (Reporter); 13 | end Test_Calculator; 14 | -------------------------------------------------------------------------------- /examples/failures/tested_lib/src/math.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | package body Math is 5 | 6 | function "+" (I1, I2 : Int) return Int is 7 | begin 8 | return Int (Integer (I1) + Integer (I2)); 9 | end "+"; 10 | 11 | function "-" (I1, I2 : Int) return Int is 12 | begin 13 | return Int (Integer (I1) - Integer (I2)); 14 | end "-"; 15 | 16 | end Math; 17 | -------------------------------------------------------------------------------- /examples/simple_test/tested_lib/src/math.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | package body Math is 5 | 6 | function "+" (I1, I2 : Int) return Int is 7 | begin 8 | return Int (Integer (I1) + Integer (I2)); 9 | end "+"; 10 | 11 | function "-" (I1, I2 : Int) return Int is 12 | begin 13 | return Int (Integer (I1) - Integer (I2)); 14 | end "-"; 15 | 16 | end Math; 17 | -------------------------------------------------------------------------------- /examples/test_caller/tested_lib/src/math.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | package body Math is 5 | 6 | function "+" (I1, I2 : Int) return Int is 7 | begin 8 | return Int (Integer (I1) + Integer (I2)); 9 | end "+"; 10 | 11 | function "-" (I1, I2 : Int) return Int is 12 | begin 13 | return Int (Integer (I1) - Integer (I2)); 14 | end "-"; 15 | 16 | end Math; 17 | -------------------------------------------------------------------------------- /examples/test_fixture/tested_lib/src/math.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | package body Math is 5 | 6 | function "+" (I1, I2 : Int) return Int is 7 | begin 8 | return Int (Integer (I1) + Integer (I2)); 9 | end "+"; 10 | 11 | function "-" (I1, I2 : Int) return Int is 12 | begin 13 | return Int (Integer (I1) - Integer (I2)); 14 | end "-"; 15 | 16 | end Math; 17 | -------------------------------------------------------------------------------- /test/support/run-ppc-elf: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | if [ $# -ne 1 ]; then 4 | echo "Usage: $0 obj" 5 | exit 2 6 | fi 7 | 8 | obj=$1 9 | 10 | # Generate the simple script 11 | cat > gdb.run << EOF 12 | # Load binary 13 | target sim -e bug -r 0x400000 14 | load $obj 15 | set confirm off 16 | run 17 | quit 18 | EOF 19 | 20 | # Run gdb on it 21 | powerpc-elf-gdb -n --batch --command=gdb.run $obj 22 | rm -f gdb.run 23 | 24 | -------------------------------------------------------------------------------- /examples/calculator/tests/operands-ints-test.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with AUnit.Test_Fixtures; 5 | 6 | package Operands.Ints.Test is 7 | 8 | type Test is new AUnit.Test_Fixtures.Test_Fixture with null record; 9 | 10 | procedure Test_Image (T : in out Test); 11 | 12 | procedure Test_Value (T : in out Test); 13 | 14 | procedure Test_Set (T : in out Test); 15 | 16 | end Operands.Ints.Test; 17 | -------------------------------------------------------------------------------- /support/aunit.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | share/doc/aunit 4 | 5 | 6 | /Help/AUnit 7 | 8 | 9 | 10 | aunit.html 11 | AUnit User's Guide 12 | AUnit 13 | /Help/AUnit/AUnit User's Guide 14 | 15 | 16 | -------------------------------------------------------------------------------- /examples/calculator/tests/operations-addition_test_fixture.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with Operands.Ints; use Operands.Ints; 5 | with Operations.Addition; 6 | 7 | package Operations.Addition_Test_Fixture is 8 | 9 | procedure Set_Up 10 | (Op : out Operations.Addition.Binary_Operation; 11 | Test_Op1 : out Int; 12 | Test_Op2 : out Int; 13 | Exp_Res : out Int); 14 | 15 | end Operations.Addition_Test_Fixture; 16 | -------------------------------------------------------------------------------- /examples/simple_test/tests/math_suite.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with AUnit.Simple_Test_Cases; use AUnit.Simple_Test_Cases; 5 | with Math.Test; 6 | 7 | package body Math_Suite is 8 | 9 | function Suite return Access_Test_Suite is 10 | Ret : constant Access_Test_Suite := new Test_Suite; 11 | begin 12 | Ret.Add_Test (Test_Case_Access'(new Math.Test.Test)); 13 | return Ret; 14 | end Suite; 15 | 16 | end Math_Suite; 17 | -------------------------------------------------------------------------------- /examples/calculator/tests/operations-subtraction_test_fixture.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with Operands.Ints; use Operands.Ints; 5 | with Operations.Subtraction; 6 | package Operations.Subtraction_Test_Fixture is 7 | 8 | procedure Set_Up 9 | (Op : out Operations.Subtraction.Binary_Operation; 10 | Test_Op1 : out Int; 11 | Test_Op2 : out Int; 12 | Exp_Res : out Int); 13 | 14 | end Operations.Subtraction_Test_Fixture; 15 | -------------------------------------------------------------------------------- /examples/liskov/tested_lib/src/rectangle.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | 5 | with Shape; 6 | 7 | package Rectangle is 8 | 9 | type Rectangle_Type is new Shape.Shape_Type with private; 10 | 11 | function Area (Obj : Rectangle_Type) return Natural; 12 | -- pragma Postcondition (Area'Result = Width (Obj) * Height (Obj)); 13 | 14 | private 15 | 16 | type Rectangle_Type is new Shape.Shape_Type with null record; 17 | 18 | end Rectangle; 19 | -------------------------------------------------------------------------------- /examples/liskov/tested_lib/src/square.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with Rectangle; use Rectangle; 5 | package body Square is 6 | 7 | procedure Set_Width (Obj : in out Square_Type; W : Natural) is 8 | begin 9 | Rectangle_Type (Obj).Set_Width (W); 10 | Rectangle_Type (Obj).Set_Height (W); 11 | end Set_Width; 12 | 13 | procedure Set_Height (Obj : in out Square_Type; H : Natural) 14 | renames Set_Width; 15 | 16 | end Square; 17 | -------------------------------------------------------------------------------- /examples/test_fixture/tests/math-test.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with AUnit; 5 | with AUnit.Test_Fixtures; 6 | 7 | package Math.Test is 8 | 9 | type Test is new AUnit.Test_Fixtures.Test_Fixture with record 10 | I1 : Int; 11 | I2 : Int; 12 | end record; 13 | 14 | procedure Set_Up (T : in out Test); 15 | 16 | procedure Test_Addition (T : in out Test); 17 | procedure Test_Subtraction (T : in out Test); 18 | 19 | end Math.Test; 20 | -------------------------------------------------------------------------------- /doc/aunit_cb/gps_support.rst: -------------------------------------------------------------------------------- 1 | ******************* 2 | GNAT Studio Support 3 | ******************* 4 | 5 | .. index:: GNAT Studio support 6 | 7 | The GNAT Studio IDE relies on the `gnattest` tool that creates unit-test 8 | skeletons as well as a test driver infrastructure (harness). A harness can be 9 | generated for a project hierarchy, a single project or a package. 10 | The generation process can be launched from the `Analyze` -> `GNATtest` menu 11 | or from a contextual menu. 12 | 13 | -------------------------------------------------------------------------------- /examples/liskov/tests/shape-tests.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with AUnit.Test_Fixtures; 5 | 6 | package Shape.Tests is 7 | 8 | type Test is abstract new AUnit.Test_Fixtures.Test_Fixture 9 | with record 10 | The_Shape : Shape_Access; 11 | end record; 12 | 13 | procedure Test_Set_Width (T : in out Test); 14 | procedure Test_Set_Height (T : in out Test); 15 | procedure Test_Get_Area (T : in out Test) is abstract; 16 | 17 | end Shape.Tests; 18 | -------------------------------------------------------------------------------- /examples/calculator/tested_lib/src/operands-ints.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | package Operands.Ints is 5 | 6 | type Int is new Operand with private; 7 | 8 | function Image (Opnd : Int) return String; 9 | 10 | function Value (Opnd : Int) return Integer; 11 | 12 | procedure Set (Opnd : in out Int; Value : Integer); 13 | 14 | private 15 | 16 | type Int is new Operand with record 17 | Value : Integer; 18 | end record; 19 | 20 | end Operands.Ints; 21 | -------------------------------------------------------------------------------- /examples/liskov/tested_lib/testlib.gpr: -------------------------------------------------------------------------------- 1 | project TestLib is 2 | 3 | for Source_Dirs use ("src"); 4 | 5 | for Languages use ("Ada"); 6 | for Object_Dir use "obj"; 7 | for Library_Dir use "lib"; 8 | for Library_Name use "testlib"; 9 | for Library_Kind use "static"; 10 | 11 | package Compiler is 12 | for Default_Switches ("ada") use 13 | ("-g", "-O1", "-gnatwa.Xe", "-gnaty", "-gnata", "-gnatf"); 14 | end Compiler; 15 | 16 | end TestLib; 17 | 18 | -------------------------------------------------------------------------------- /examples/failures/tested_lib/testlib.gpr: -------------------------------------------------------------------------------- 1 | project TestLib is 2 | 3 | for Source_Dirs use ("src"); 4 | 5 | for Languages use ("Ada"); 6 | for Object_Dir use "obj"; 7 | for Library_Dir use "lib"; 8 | for Library_Name use "testlib"; 9 | for Library_Kind use "static"; 10 | 11 | package Compiler is 12 | for Default_Switches ("ada") use 13 | ("-g", "-O1", "-gnatwa.Xe", "-gnaty", "-gnato", "-gnatf"); 14 | end Compiler; 15 | 16 | end TestLib; 17 | 18 | -------------------------------------------------------------------------------- /examples/simple_test/tested_lib/testlib.gpr: -------------------------------------------------------------------------------- 1 | project TestLib is 2 | 3 | for Source_Dirs use ("src"); 4 | 5 | for Languages use ("Ada"); 6 | for Object_Dir use "obj"; 7 | for Library_Dir use "lib"; 8 | for Library_Name use "testlib"; 9 | for Library_Kind use "static"; 10 | 11 | package Compiler is 12 | for Default_Switches ("ada") use 13 | ("-g", "-O1", "-gnatwa.Xe", "-gnaty", "-gnata", "-gnatf"); 14 | end Compiler; 15 | 16 | end TestLib; 17 | 18 | -------------------------------------------------------------------------------- /examples/test_caller/tested_lib/testlib.gpr: -------------------------------------------------------------------------------- 1 | project TestLib is 2 | 3 | for Source_Dirs use ("src"); 4 | 5 | for Languages use ("Ada"); 6 | for Object_Dir use "obj"; 7 | for Library_Dir use "lib"; 8 | for Library_Name use "testlib"; 9 | for Library_Kind use "static"; 10 | 11 | package Compiler is 12 | for Default_Switches ("ada") use 13 | ("-g", "-O1", "-gnatwa.Xe", "-gnaty", "-gnata", "-gnatf"); 14 | end Compiler; 15 | 16 | end TestLib; 17 | 18 | -------------------------------------------------------------------------------- /examples/test_fixture/tested_lib/testlib.gpr: -------------------------------------------------------------------------------- 1 | project TestLib is 2 | 3 | for Source_Dirs use ("src"); 4 | 5 | for Languages use ("Ada"); 6 | for Object_Dir use "obj"; 7 | for Library_Dir use "lib"; 8 | for Library_Name use "testlib"; 9 | for Library_Kind use "static"; 10 | 11 | package Compiler is 12 | for Default_Switches ("ada") use 13 | ("-g", "-O1", "-gnatwa.Xe", "-gnaty", "-gnata", "-gnatf"); 14 | end Compiler; 15 | 16 | end TestLib; 17 | 18 | -------------------------------------------------------------------------------- /examples/calculator/tested_lib/src/operations-ints.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | package body Operations.Ints is 5 | 6 | function "+" (Op1, Op2 : Int) return Int is 7 | Ret : Int; 8 | begin 9 | Ret.Set (Op1.Value + Op2.Value); 10 | return Ret; 11 | end "+"; 12 | 13 | function "-" (Op1, Op2 : Int) return Int is 14 | Ret : Int; 15 | begin 16 | Ret.Set (Op1.Value - Op2.Value); 17 | return Ret; 18 | end "-"; 19 | 20 | end Operations.Ints; 21 | -------------------------------------------------------------------------------- /examples/calculator/tested_lib/src/operations.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | package Operations is 5 | 6 | type Operation is abstract tagged null record; 7 | 8 | procedure Pop (Op : in out Operation) is abstract; 9 | -- Pops the operands from the stack 10 | 11 | procedure Push (Op : in out Operation) is abstract; 12 | -- Pushes the operands in the stack 13 | 14 | procedure Execute (Op : in out Operation) is abstract; 15 | -- Execute the operation 16 | 17 | end Operations; 18 | -------------------------------------------------------------------------------- /examples/calculator/tested_lib/src/operands-ints.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | package body Operands.Ints is 5 | 6 | function Image (Opnd : Int) return String is 7 | begin 8 | return Integer'Image (Opnd.Value); 9 | end Image; 10 | 11 | function Value (Opnd : Int) return Integer is 12 | begin 13 | return Opnd.Value; 14 | end Value; 15 | 16 | procedure Set (Opnd : in out Int; Value : Integer) is 17 | begin 18 | Opnd.Value := Value; 19 | end Set; 20 | 21 | end Operands.Ints; 22 | -------------------------------------------------------------------------------- /examples/calculator/tests/operations-addition_test_fixture.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | package body Operations.Addition_Test_Fixture is 5 | 6 | procedure Set_Up 7 | (Op : out Operations.Addition.Binary_Operation; 8 | Test_Op1 : out Int; 9 | Test_Op2 : out Int; 10 | Exp_Res : out Int) 11 | is 12 | pragma Unreferenced (Op); 13 | begin 14 | Test_Op1.Set (4); 15 | Test_Op2.Set (6); 16 | Exp_Res.Set (10); 17 | end Set_Up; 18 | 19 | end Operations.Addition_Test_Fixture; 20 | -------------------------------------------------------------------------------- /examples/calculator/tests/operations-subtraction_test_fixture.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | package body Operations.Subtraction_Test_Fixture is 5 | 6 | procedure Set_Up 7 | (Op : out Operations.Subtraction.Binary_Operation; 8 | Test_Op1 : out Int; 9 | Test_Op2 : out Int; 10 | Exp_Res : out Int) 11 | is 12 | pragma Unreferenced (Op); 13 | begin 14 | Test_Op1.Set (4); 15 | Test_Op2.Set (6); 16 | Exp_Res.Set (-2); 17 | end Set_Up; 18 | 19 | end Operations.Subtraction_Test_Fixture; 20 | -------------------------------------------------------------------------------- /examples/failures/tests/math-test.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with AUnit; 5 | with AUnit.Test_Fixtures; 6 | 7 | package Math.Test is 8 | 9 | type Test is new AUnit.Test_Fixtures.Test_Fixture with null record; 10 | 11 | procedure Test_Addition (T : in out Test); 12 | procedure Test_Subtraction (T : in out Test); 13 | 14 | procedure Test_Addition_Failure (T : in out Test); 15 | -- This test will do a failed assertion 16 | 17 | procedure Test_Addition_Error (T : in out Test); 18 | -- This test will raise an exception 19 | 20 | end Math.Test; 21 | -------------------------------------------------------------------------------- /test/src/aunit-test_cases-tests.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2009-2010, AdaCore 3 | -- 4 | 5 | with AUnit.Test_Fixtures; 6 | with AUnit.Test_Cases.Tests_Fixtures; use AUnit.Test_Cases.Tests_Fixtures; 7 | 8 | package AUnit.Test_Cases.Tests is 9 | 10 | type Fixture is new AUnit.Test_Fixtures.Test_Fixture with record 11 | TC : aliased The_Test_Case; 12 | end record; 13 | 14 | procedure Test_Register_Tests (T : in out Fixture); 15 | procedure Test_Set_Up (T : in out Fixture); 16 | procedure Test_Torn_Down (T : in out Fixture); 17 | procedure Test_Run (T : in out Fixture); 18 | 19 | end AUnit.Test_Cases.Tests; 20 | -------------------------------------------------------------------------------- /examples/liskov/tests/my_suite.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | -- with AUnit.Test_Caller; 5 | 6 | with Rectangle.Tests.Suite; 7 | with Square.Tests.Suite; 8 | with Square.Tests.Suite_Liskov; 9 | 10 | package body My_Suite is 11 | 12 | Result : aliased AUnit.Test_Suites.Test_Suite; 13 | 14 | function Suite return AUnit.Test_Suites.Access_Test_Suite is 15 | begin 16 | Result.Add_Test (Rectangle.Tests.Suite.Suite); 17 | Result.Add_Test (Square.Tests.Suite.Suite); 18 | Result.Add_Test (Square.Tests.Suite_Liskov.Suite); 19 | return Result'Access; 20 | end Suite; 21 | 22 | end My_Suite; 23 | -------------------------------------------------------------------------------- /examples/test_fixture/tests/math_suite.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with Math.Test; use Math.Test; 5 | with AUnit.Test_Caller; 6 | 7 | package body Math_Suite is 8 | 9 | package Caller is new AUnit.Test_Caller (Math.Test.Test); 10 | 11 | function Suite return Access_Test_Suite is 12 | Ret : constant Access_Test_Suite := new Test_Suite; 13 | begin 14 | Ret.Add_Test 15 | (Caller.Create ("Test addition", Test_Addition'Access)); 16 | Ret.Add_Test 17 | (Caller.Create ("Test subtraction", Test_Subtraction'Access)); 18 | return Ret; 19 | end Suite; 20 | 21 | end Math_Suite; 22 | -------------------------------------------------------------------------------- /examples/liskov/tested_lib/src/shape.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | package body Shape is 5 | 6 | procedure Set_Width (Obj : in out Shape_Type; W : Natural) is 7 | begin 8 | Obj.Width := W; 9 | end Set_Width; 10 | 11 | procedure Set_Height (Obj : in out Shape_Type; H : Natural) is 12 | begin 13 | Obj.Height := H; 14 | end Set_Height; 15 | 16 | function Width (Obj : in Shape_Type) return Natural is 17 | begin 18 | return Obj.Width; 19 | end Width; 20 | 21 | function Height (Obj : in Shape_Type) return Natural is 22 | begin 23 | return Obj.Height; 24 | end Height; 25 | 26 | end Shape; 27 | -------------------------------------------------------------------------------- /examples/test_fixture/tests/math-test.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with AUnit.Assertions; use AUnit.Assertions; 5 | 6 | package body Math.Test is 7 | 8 | procedure Set_Up (T : in out Test) is 9 | begin 10 | T.I1 := 5; 11 | T.I2 := 3; 12 | end Set_Up; 13 | 14 | procedure Test_Addition (T : in out Test) is 15 | begin 16 | Assert (T.I1 + T.I2 = 8, "Incorrect result after addition"); 17 | end Test_Addition; 18 | 19 | procedure Test_Subtraction (T : in out Test) is 20 | begin 21 | Assert (T.I1 - T.I2 = 2, "Incorrect result after subtraction"); 22 | end Test_Subtraction; 23 | 24 | end Math.Test; 25 | -------------------------------------------------------------------------------- /examples/test_caller/harness/src/math_suite.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with Math.Test; use Math.Test; 5 | with AUnit.Test_Caller; 6 | 7 | package body Math_Suite is 8 | 9 | package Caller is new AUnit.Test_Caller (Math.Test.Test); 10 | 11 | function Suite return Access_Test_Suite is 12 | Ret : constant Access_Test_Suite := AUnit.Test_Suites.New_Suite; 13 | begin 14 | Ret.Add_Test 15 | (Caller.Create ("Test addition", Test_Addition'Access)); 16 | Ret.Add_Test 17 | (Caller.Create ("Test subtraction", Test_Subtraction'Access)); 18 | return Ret; 19 | end Suite; 20 | 21 | end Math_Suite; 22 | -------------------------------------------------------------------------------- /test/aunit_tests.gpr: -------------------------------------------------------------------------------- 1 | with "aunit"; 2 | 3 | project Aunit_Tests is 4 | 5 | for Languages use ("Ada"); 6 | for Main use ("aunit_harness.adb"); 7 | for Source_Dirs use ("src"); 8 | for Exec_Dir use "exe"; 9 | for Object_Dir use "obj"; 10 | 11 | package Linker is 12 | for Default_Switches ("ada") use ("-g"); 13 | end Linker; 14 | 15 | package Binder is 16 | for Default_Switches ("ada") use ("-E", "-static"); 17 | end Binder; 18 | 19 | package Compiler is 20 | for Default_Switches ("ada") use 21 | ("-g", "-gnatQ", "-O1", "-gnatf", "-gnato", "-gnatwa.Xe", "-gnaty"); 22 | end Compiler; 23 | 24 | end Aunit_Tests; 25 | 26 | -------------------------------------------------------------------------------- /examples/calculator/fixture/main_suite.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with Stack.Test.Suite; 5 | with Operations.Addition.Test.Suite; 6 | with Operations.Subtraction.Test.Suite; 7 | with Operands.Ints.Test.Suite; 8 | 9 | package body Main_Suite is 10 | 11 | function Suite return Access_Test_Suite is 12 | Ret : constant Access_Test_Suite := new Test_Suite; 13 | begin 14 | Ret.Add_Test (Stack.Test.Suite.Suite); 15 | Ret.Add_Test (Operations.Addition.Test.Suite.Suite); 16 | Ret.Add_Test (Operations.Subtraction.Test.Suite.Suite); 17 | Ret.Add_Test (Operands.Ints.Test.Suite.Suite); 18 | return Ret; 19 | end Suite; 20 | 21 | end Main_Suite; 22 | -------------------------------------------------------------------------------- /examples/simple_test/tests/math-test.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with AUnit.Assertions; use AUnit.Assertions; 5 | 6 | package body Math.Test is 7 | 8 | function Name (T : Test) return AUnit.Message_String is 9 | pragma Unreferenced (T); 10 | begin 11 | return AUnit.Format ("Test Math package"); 12 | end Name; 13 | 14 | procedure Run_Test (T : in out Test) is 15 | pragma Unreferenced (T); 16 | I1 : constant Int := 5; 17 | I2 : constant Int := 3; 18 | begin 19 | Assert (I1 + I2 = 8, "Incorrect result after addition"); 20 | Assert (I1 - I2 = 2, "Incorrect result after subtraction"); 21 | end Run_Test; 22 | 23 | end Math.Test; 24 | -------------------------------------------------------------------------------- /examples/failures/harness.gpr: -------------------------------------------------------------------------------- 1 | with "aunit"; 2 | with "tested_lib/testlib"; 3 | 4 | project Harness is 5 | 6 | for Languages use ("Ada"); 7 | for Main use ("test_math.adb"); 8 | for Source_Dirs use ("tests"); 9 | for Exec_Dir use "."; 10 | for Object_Dir use "obj"; 11 | 12 | package Linker is 13 | for Default_Switches ("ada") use ("-g"); 14 | end Linker; 15 | 16 | package Binder is 17 | for Default_Switches ("ada") use ("-E", "-static"); 18 | end Binder; 19 | 20 | package Compiler is 21 | for Default_Switches ("ada") use 22 | ("-g", "-gnatQ", "-O1", "-gnatf", "-gnato", 23 | "-gnatwa.Xe", "-gnaty"); 24 | end Compiler; 25 | 26 | end Harness; 27 | 28 | -------------------------------------------------------------------------------- /examples/liskov/harness.gpr: -------------------------------------------------------------------------------- 1 | with "aunit"; 2 | with "tested_lib/testlib"; 3 | 4 | project Harness is 5 | 6 | for Languages use ("Ada"); 7 | for Main use ("test_liskov.adb"); 8 | for Source_Dirs use ("tests"); 9 | for Exec_Dir use "."; 10 | for Object_Dir use "obj"; 11 | 12 | package Linker is 13 | for Default_Switches ("ada") use ("-g"); 14 | end Linker; 15 | 16 | package Binder is 17 | for Default_Switches ("ada") use ("-E", "-static"); 18 | end Binder; 19 | 20 | package Compiler is 21 | for Default_Switches ("ada") use 22 | ("-g", "-gnatQ", "-O1", "-gnatf", "-gnato", 23 | "-gnatwa.Xe", "-gnaty"); 24 | end Compiler; 25 | 26 | end Harness; 27 | 28 | -------------------------------------------------------------------------------- /examples/simple_test/harness.gpr: -------------------------------------------------------------------------------- 1 | with "aunit"; 2 | with "tested_lib/testlib"; 3 | 4 | project Harness is 5 | 6 | for Languages use ("Ada"); 7 | for Main use ("test_math.adb"); 8 | for Source_Dirs use ("tests"); 9 | for Exec_Dir use "."; 10 | for Object_Dir use "obj"; 11 | 12 | package Linker is 13 | for Default_Switches ("ada") use ("-g"); 14 | end Linker; 15 | 16 | package Binder is 17 | for Default_Switches ("ada") use ("-E", "-static"); 18 | end Binder; 19 | 20 | package Compiler is 21 | for Default_Switches ("ada") use 22 | ("-g", "-gnatQ", "-O1", "-gnatf", "-gnato", 23 | "-gnatwa.Xe", "-gnaty"); 24 | end Compiler; 25 | 26 | end Harness; 27 | 28 | -------------------------------------------------------------------------------- /examples/test_fixture/harness.gpr: -------------------------------------------------------------------------------- 1 | with "aunit"; 2 | with "tested_lib/testlib"; 3 | 4 | project Harness is 5 | 6 | for Languages use ("Ada"); 7 | for Main use ("test_math.adb"); 8 | for Source_Dirs use ("tests"); 9 | for Exec_Dir use "."; 10 | for Object_Dir use "obj"; 11 | 12 | package Linker is 13 | for Default_Switches ("ada") use ("-g"); 14 | end Linker; 15 | 16 | package Binder is 17 | for Default_Switches ("ada") use ("-E", "-static"); 18 | end Binder; 19 | 20 | package Compiler is 21 | for Default_Switches ("ada") use 22 | ("-g", "-gnatQ", "-O1", "-gnatf", "-gnato", 23 | "-gnatwa.Xe", "-gnaty"); 24 | end Compiler; 25 | 26 | end Harness; 27 | 28 | -------------------------------------------------------------------------------- /examples/calculator/fixture/operations-binary-gen_test-gen_suite.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | package body Operations.Binary.Gen_Test.Gen_Suite is 5 | 6 | function Suite return Access_Test_Suite is 7 | Ret : constant Access_Test_Suite := new Test_Suite; 8 | begin 9 | Ret.Add_Test 10 | (Caller.Create ("Test " & Instance_Name & ".Pop", Test_Pop_Access)); 11 | Ret.Add_Test 12 | (Caller.Create ("Test " & Instance_Name & ".Push", Test_Push_Access)); 13 | Ret.Add_Test 14 | (Caller.Create 15 | ("Test " & Instance_Name & ".Execute", Test_Execute_Access)); 16 | return Ret; 17 | end Suite; 18 | 19 | end Operations.Binary.Gen_Test.Gen_Suite; 20 | -------------------------------------------------------------------------------- /examples/test_caller/harness/harness.gpr: -------------------------------------------------------------------------------- 1 | with "aunit"; 2 | with "../tested_lib/testlib"; 3 | 4 | project Harness is 5 | 6 | for Languages use ("Ada"); 7 | for Main use ("test_math.adb"); 8 | for Source_Dirs use ("src"); 9 | for Exec_Dir use ".."; 10 | for Object_Dir use "obj"; 11 | 12 | package Linker is 13 | for Default_Switches ("ada") use ("-g"); 14 | end Linker; 15 | 16 | package Binder is 17 | for Default_Switches ("ada") use ("-E", "-static"); 18 | end Binder; 19 | 20 | package Compiler is 21 | for Default_Switches ("ada") use 22 | ("-g", "-gnatQ", "-O1", "-gnatf", "-gnato", 23 | "-gnatwa.Xe", "-gnaty"); 24 | end Compiler; 25 | 26 | end Harness; 27 | 28 | -------------------------------------------------------------------------------- /examples/calculator/fixture/operations-binary-gen_test-gen_suite.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with AUnit.Test_Suites; use AUnit.Test_Suites; 5 | with AUnit.Test_Caller; 6 | 7 | generic 8 | Instance_Name : String; 9 | package Operations.Binary.Gen_Test.Gen_Suite is 10 | 11 | function Suite return Access_Test_Suite; 12 | 13 | private 14 | 15 | package Caller is new AUnit.Test_Caller (Operations.Binary.Gen_Test.Test); 16 | Test_Pop_Access : constant Caller.Test_Method := Test_Pop'Access; 17 | Test_Push_Access : constant Caller.Test_Method := Test_Push'Access; 18 | Test_Execute_Access : constant Caller.Test_Method := Test_Execute'Access; 19 | 20 | end Operations.Binary.Gen_Test.Gen_Suite; 21 | -------------------------------------------------------------------------------- /examples/calculator/tests/stack-test.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with AUnit.Test_Fixtures; 5 | 6 | package Stack.Test is 7 | 8 | type Test is new AUnit.Test_Fixtures.Test_Fixture with null record; 9 | 10 | procedure Tear_Down (T : in out Test); 11 | 12 | procedure Test_Push (T : in out Test); 13 | -- Test for Stack.Push 14 | 15 | procedure Test_Pop (T : in out Test); 16 | -- Test for Stack.Pop 17 | 18 | procedure Test_Length (T : in out Test); 19 | -- Test for Stack.Length 20 | 21 | procedure Test_Top (T : in out Test); 22 | -- Test for Stack.Top 23 | 24 | procedure Test_Next_To_Top (T : in out Test); 25 | -- Test for Stack.Next_To_Top 26 | 27 | end Stack.Test; 28 | -------------------------------------------------------------------------------- /template/pr_xxxx_xxx.ads: -------------------------------------------------------------------------------- 1 | with AUnit; use AUnit; 2 | with AUnit.Test_Cases; 3 | 4 | package PR_XXXX_XXX is 5 | type Test_Case is new AUnit.Test_Cases.Test_Case with null record; 6 | 7 | -- Override: 8 | 9 | -- Register routines to be run: 10 | procedure Register_Tests (T : in out Test_Case); 11 | 12 | -- Provide name identifying the test case: 13 | function Name (T : Test_Case) return Message_String; 14 | 15 | -- Override if needed. Default empty implementations provided: 16 | 17 | -- Preparation performed before each routine: 18 | procedure Set_Up (T : in out Test_Case); 19 | 20 | -- Cleanup performed after each routine: 21 | procedure Tear_Down (T : in out Test_Case); 22 | 23 | end PR_XXXX_XXX; 24 | -------------------------------------------------------------------------------- /examples/test_caller/harness/src/math-test.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with AUnit.Assertions; use AUnit.Assertions; 5 | 6 | package body Math.Test is 7 | 8 | procedure Test_Addition (T : in out Test) is 9 | pragma Unreferenced (T); 10 | I1 : constant Int := 5; 11 | I2 : constant Int := 3; 12 | begin 13 | Assert (I1 + I2 = 8, "Incorrect result after addition"); 14 | end Test_Addition; 15 | 16 | procedure Test_Subtraction (T : in out Test) is 17 | pragma Unreferenced (T); 18 | I1 : constant Int := 5; 19 | I2 : constant Int := 3; 20 | begin 21 | Assert (I1 - I2 = 2, "Incorrect result after subtraction"); 22 | end Test_Subtraction; 23 | 24 | end Math.Test; 25 | -------------------------------------------------------------------------------- /test/src/aunit_suite.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008-2010, AdaCore 3 | -- 4 | 5 | with AUnit.Test_Suites.Tests.Suite; 6 | with AUnit.Test_Cases.Tests.Suite; 7 | with AUnit.Test_Fixtures.Tests.Suite; 8 | 9 | package body AUnit_Suite is 10 | use Test_Suites; 11 | 12 | function Suite return Access_Test_Suite is 13 | S : constant AUnit.Test_Suites.Access_Test_Suite := 14 | AUnit.Test_Suites.New_Suite; 15 | begin 16 | Add_Test 17 | (S, AUnit.Test_Suites.Tests.Suite.Test_Suite); 18 | Add_Test 19 | (S, AUnit.Test_Cases.Tests.Suite.Test_Suite); 20 | Add_Test 21 | (S, AUnit.Test_Fixtures.Tests.Suite.Test_Suite); 22 | 23 | return S; 24 | end Suite; 25 | 26 | end AUnit_Suite; 27 | -------------------------------------------------------------------------------- /examples/calculator/fixture/operands-ints-test-suite.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with AUnit.Test_Caller; 5 | 6 | package body Operands.Ints.Test.Suite is 7 | 8 | package Caller is new AUnit.Test_Caller (Operands.Ints.Test.Test); 9 | 10 | function Suite return Access_Test_Suite is 11 | Ret : constant Access_Test_Suite := new Test_Suite; 12 | begin 13 | Ret.Add_Test 14 | (Caller.Create ("Test Operands.Ints.Image", Test_Image'Access)); 15 | Ret.Add_Test 16 | (Caller.Create ("Test Operands.Ints.Value", Test_Value'Access)); 17 | Ret.Add_Test 18 | (Caller.Create ("Test Operands.Ints.Set", Test_Set'Access)); 19 | return Ret; 20 | end Suite; 21 | 22 | end Operands.Ints.Test.Suite; 23 | -------------------------------------------------------------------------------- /template/sample.gpr: -------------------------------------------------------------------------------- 1 | with "aunit.gpr"; 2 | 3 | project Sample is 4 | 5 | for Languages use ("Ada"); 6 | for Source_Dirs use ("./"); 7 | for Object_Dir use "./"; 8 | for Exec_Dir use "./"; 9 | for Main use ("harness.adb"); 10 | 11 | package Builder is 12 | for Default_Switches ("ada") use ("-g", "-gnatQ"); 13 | for Executable ("harness.adb") use "harness"; 14 | end Builder; 15 | 16 | package Linker is 17 | for Default_Switches ("ada") use ("-g"); 18 | end Linker; 19 | 20 | package Compiler is 21 | for Default_Switches ("ada") use ("-gnatf", "-g"); 22 | end Compiler; 23 | 24 | package Binder is 25 | for Default_Switches ("ada") use ("-E", "-static"); 26 | end Binder; 27 | 28 | end Sample; 29 | 30 | -------------------------------------------------------------------------------- /examples/calculator/tested_lib/src/operations-binary.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | package body Operations.Binary is 5 | 6 | --------- 7 | -- Pop -- 8 | --------- 9 | 10 | procedure Pop (Op : in out Binary_Operation) is 11 | begin 12 | Op.Op2 := T (Stack.Pop); 13 | Op.Op1 := T (Stack.Pop); 14 | end Pop; 15 | 16 | ---------- 17 | -- Push -- 18 | ---------- 19 | 20 | procedure Push (Op : in out Binary_Operation) is 21 | begin 22 | Stack.Push (Op.Res); 23 | end Push; 24 | 25 | ------------- 26 | -- Execute -- 27 | ------------- 28 | 29 | procedure Execute (Op : in out Binary_Operation) is 30 | begin 31 | Op.Res := The_Operation (Op.Op1, Op.Op2); 32 | end Execute; 33 | 34 | end Operations.Binary; 35 | -------------------------------------------------------------------------------- /examples/liskov/tested_lib/src/square.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | 5 | with Rectangle; 6 | 7 | package Square is 8 | 9 | type Square_Type is new Rectangle.Rectangle_Type with private; 10 | -- class invariant 11 | -- for all Obj : Eight (Obj) = Width (Obj) 12 | 13 | procedure Set_Width (Obj : in out Square_Type; W : Natural); 14 | -- pragma Postcondition 15 | -- (Height (Obj) = Width (Obj) -- this is the class invariant 16 | -- ); 17 | 18 | procedure Set_Height (Obj : in out Square_Type; H : Natural); 19 | -- pragma Postcondition 20 | -- (Height (Obj) = Width (Obj) -- this is the class invariant 21 | -- ); 22 | 23 | private 24 | 25 | type Square_Type is new Rectangle.Rectangle_Type with null record; 26 | 27 | end Square; 28 | -------------------------------------------------------------------------------- /examples/calculator/tested_lib/testlib.gpr: -------------------------------------------------------------------------------- 1 | project TestLib is 2 | 3 | type Yes_No is ("yes", "no"); 4 | Coverage : Yes_No := External ("COVERAGE", "no"); 5 | 6 | for Source_Dirs use ("src"); 7 | 8 | for Languages use ("Ada"); 9 | for Object_Dir use "obj"; 10 | for Library_Dir use "lib"; 11 | for Library_Name use "testlib"; 12 | for Library_Kind use "static"; 13 | 14 | package Compiler is 15 | for Default_Switches ("ada") use 16 | ("-g", "-O0", "-gnatwae", "-gnaty", "-gnata"); 17 | case Coverage is 18 | when "yes" => 19 | for Default_Switches ("ada") use Compiler'Default_Switches ("ada") & 20 | ("-fprofile-arcs", "-ftest-coverage"); 21 | when others => 22 | end case; 23 | end Compiler; 24 | 25 | end TestLib; 26 | 27 | -------------------------------------------------------------------------------- /examples/liskov/tests/rectangle-tests.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with AUnit.Assertions; use AUnit.Assertions; 5 | 6 | with Shape; 7 | 8 | package body Rectangle.Tests is 9 | 10 | ----------------- 11 | -- Set_Up_Case -- 12 | ----------------- 13 | 14 | Local_Rectangle : aliased Rectangle_Type; 15 | procedure Set_Up (T : in out Test) is 16 | begin 17 | T.The_Shape := Local_Rectangle'Access; 18 | end Set_Up; 19 | 20 | ------------------- 21 | -- Test_Get_Area -- 22 | ------------------- 23 | 24 | procedure Test_Get_Area (T : in out Test) is 25 | begin 26 | Shape.Set_Width (T.The_Shape.all, 3); 27 | Shape.Set_Height (T.The_Shape.all, 5); 28 | Assert (Shape.Area (T.The_Shape.all) = 15, 29 | "Wrong area returned for object rectangle"); 30 | end Test_Get_Area; 31 | 32 | end Rectangle.Tests; 33 | -------------------------------------------------------------------------------- /examples/calculator/fixture/stack-test-suite.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with AUnit.Test_Caller; 5 | 6 | package body Stack.Test.Suite is 7 | 8 | package Caller is new AUnit.Test_Caller (Stack.Test.Test); 9 | 10 | function Suite return Access_Test_Suite is 11 | Ret : constant Access_Test_Suite := new Test_Suite; 12 | begin 13 | Ret.Add_Test 14 | (Caller.Create ("Test Stack.Push", Test_Push'Access)); 15 | Ret.Add_Test 16 | (Caller.Create ("Test Stack.Pop", Test_Pop'Access)); 17 | Ret.Add_Test 18 | (Caller.Create ("Test Stack.Length", Test_Length'Access)); 19 | Ret.Add_Test 20 | (Caller.Create ("Test Stack.Top", Test_Top'Access)); 21 | Ret.Add_Test 22 | (Caller.Create ("Test Stack.Next_To_Top", Test_Next_To_Top'Access)); 23 | return Ret; 24 | end Suite; 25 | 26 | end Stack.Test.Suite; 27 | -------------------------------------------------------------------------------- /examples/liskov/tests/square-tests.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with AUnit.Assertions; use AUnit.Assertions; 5 | 6 | package body Square.Tests is 7 | 8 | ----------------- 9 | -- Set_Up_Case -- 10 | ----------------- 11 | 12 | Local_Square : aliased Square_Type; 13 | 14 | procedure Set_Up (T : in out Test) is 15 | begin 16 | T.The_Shape := Local_Square'Access; 17 | end Set_Up; 18 | 19 | ------------------- 20 | -- Test_Get_Area -- 21 | ------------------- 22 | 23 | procedure Test_Get_Area (T : in out Test) is 24 | begin 25 | T.The_Shape.Set_Width (3); 26 | Assert (T.The_Shape.Area = 9, 27 | "Wrong area returned for object square"); 28 | T.The_Shape.Set_Height (5); 29 | Assert (T.The_Shape.Area = 25, 30 | "Wrong area returned for object square"); 31 | end Test_Get_Area; 32 | 33 | end Square.Tests; 34 | -------------------------------------------------------------------------------- /examples/failures/tests/math_suite.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with Math.Test; use Math.Test; 5 | with AUnit.Test_Caller; 6 | 7 | package body Math_Suite is 8 | 9 | package Caller is new AUnit.Test_Caller (Math.Test.Test); 10 | 11 | function Suite return Access_Test_Suite is 12 | Ret : constant Access_Test_Suite := new Test_Suite; 13 | begin 14 | Ret.Add_Test 15 | (Caller.Create ("Test addition", Test_Addition'Access)); 16 | Ret.Add_Test 17 | (Caller.Create ("Test subtraction", Test_Subtraction'Access)); 18 | Ret.Add_Test 19 | (Caller.Create 20 | ("Test addition (failure expected)", 21 | Test_Addition_Failure'Access)); 22 | Ret.Add_Test 23 | (Caller.Create 24 | ("Test addition (error expected)", 25 | Test_Addition_Error'Access)); 26 | return Ret; 27 | end Suite; 28 | 29 | end Math_Suite; 30 | -------------------------------------------------------------------------------- /test/src/aunit-test_suites-tests.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2009-2021, AdaCore 3 | -- 4 | 5 | with AUnit.Test_Fixtures; 6 | with AUnit.Test_Results; 7 | 8 | package AUnit.Test_Suites.Tests is 9 | 10 | type Fixture is new AUnit.Test_Fixtures.Test_Fixture with record 11 | Suite : AUnit.Test_Suites.Access_Test_Suite; 12 | Res : AUnit.Test_Results.Result; 13 | end record; 14 | 15 | procedure Set_Up (Test : in out Fixture); 16 | procedure Tear_Down (Test : in out Fixture); 17 | 18 | procedure Test_Add_Test_Case (T : in out Fixture); 19 | procedure Test_Run_Empty (T : in out Fixture); 20 | procedure Test_Run_With_Success (T : in out Fixture); 21 | procedure Test_Run_With_Failure (T : in out Fixture); 22 | procedure Test_Run_With_Exception (T : in out Fixture); 23 | procedure Test_Run_With_All (T : in out Fixture); 24 | procedure Test_Run_With_Setup (T : in out Fixture); 25 | 26 | end AUnit.Test_Suites.Tests; 27 | -------------------------------------------------------------------------------- /examples/calculator/harness.gpr: -------------------------------------------------------------------------------- 1 | with "aunit"; 2 | with "tested_lib/testlib"; 3 | 4 | project Harness is 5 | 6 | for Languages use ("Ada"); 7 | for Main use ("test_calculator.adb"); 8 | for Source_Dirs use ("fixture", "tests"); 9 | for Exec_Dir use "."; 10 | for Object_Dir use "obj"; 11 | 12 | package Linker is 13 | for Default_Switches ("ada") use ("-g"); 14 | case TestLib.Coverage is 15 | when "yes" => 16 | for Default_Switches ("ada") use Linker'Default_Switches("ada") & 17 | "-fprofile-arcs"; 18 | when others => 19 | end case; 20 | end Linker; 21 | 22 | package Binder is 23 | for Default_Switches ("ada") use ("-E", "-static"); 24 | end Binder; 25 | 26 | package Compiler is 27 | for Default_Switches ("ada") use 28 | ("-g", "-gnatQ", "-O1", "-gnatf", "-gnato", 29 | "-gnatwa.Xe", "-gnaty"); 30 | end Compiler; 31 | 32 | end Harness; 33 | 34 | -------------------------------------------------------------------------------- /examples/calculator/tests/operations-binary-gen_test.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with AUnit.Test_Fixtures; 5 | 6 | generic 7 | 8 | with procedure Set_Up 9 | (The_Op : out Binary_Operation; 10 | Test_Op1 : out T; 11 | Test_Op2 : out T; 12 | Exp_Res : out T_Ret); 13 | 14 | package Operations.Binary.Gen_Test is 15 | 16 | type Test is new AUnit.Test_Fixtures.Test_Fixture with private; 17 | 18 | procedure Set_Up (T : in out Test); 19 | procedure Tear_Down (T : in out Test); 20 | 21 | procedure Test_Pop (T : in out Test); 22 | procedure Test_Push (T : in out Test); 23 | procedure Test_Execute (T : in out Test); 24 | 25 | private 26 | 27 | type Test is new AUnit.Test_Fixtures.Test_Fixture with record 28 | Op : Operations.Binary.Binary_Operation; 29 | Test_Op1 : T; 30 | Test_Op2 : T; 31 | Exp_Res : T_Ret; 32 | end record; 33 | 34 | end Operations.Binary.Gen_Test; 35 | -------------------------------------------------------------------------------- /examples/calculator/tests/operands-ints-test.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with AUnit.Assertions; use AUnit.Assertions; 5 | 6 | package body Operands.Ints.Test is 7 | 8 | procedure Test_Image (T : in out Test) is 9 | pragma Unreferenced (T); 10 | I : Int; 11 | begin 12 | I.Value := 0; 13 | Assert (I.Image = " 0", "Wrong image for 0"); 14 | I.Value := 9657; 15 | Assert (I.Image = " 9657", "Wrong image for 9657"); 16 | I.Value := -45879876; 17 | Assert (I.Image = "-45879876", "Wrong image for -45879876"); 18 | end Test_Image; 19 | 20 | procedure Test_Value (T : in out Test) is 21 | pragma Unreferenced (T); 22 | begin 23 | Assert (False, "test not implemented"); 24 | end Test_Value; 25 | 26 | procedure Test_Set (T : in out Test) is 27 | pragma Unreferenced (T); 28 | begin 29 | Assert (False, "test not implemented"); 30 | end Test_Set; 31 | 32 | end Operands.Ints.Test; 33 | -------------------------------------------------------------------------------- /test/src/aunit-test_fixtures-tests.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2009-2010, AdaCore 3 | -- 4 | 5 | package AUnit.Test_Fixtures.Tests is 6 | 7 | type Fixture is new AUnit.Test_Fixtures.Test_Fixture with null record; 8 | 9 | procedure Test_Set_Up (T : in out Fixture); 10 | -- Test that Set_Up is correctly called when running a test, and that the 11 | -- same fixture object is used for different tests. 12 | 13 | procedure Test_Tear_Down_Success (T : in out Fixture); 14 | -- Test that Tear_Down is correctly called when running a test that 15 | -- succeeds, and that test result is correct. 16 | 17 | procedure Test_Tear_Down_Failure (T : in out Fixture); 18 | -- Test that Tear_Down is correctly called when running a test that 19 | -- fails, and that test result is correct. 20 | 21 | procedure Test_Tear_Down_Error (T : in out Fixture); 22 | -- Test that Tear_Down is correctly called when running a test with 23 | -- an error, and that test result is correct. 24 | 25 | end AUnit.Test_Fixtures.Tests; 26 | -------------------------------------------------------------------------------- /doc/aunit_cb.rst: -------------------------------------------------------------------------------- 1 | AUnit Cookbook 2 | ============== 3 | 4 | *Ada Unit Testing Framework* 5 | 6 | | Version |version| 7 | | Date: |today| 8 | 9 | 10 | AdaCore 11 | 12 | Permission is granted to copy, distribute and/or modify this document under the 13 | terms of the GNU Free Documentation License, Version 1.3 or any later version 14 | published by the Free Software Foundation; with no Invariant Sections, no 15 | Front-Cover Texts, and no Back-Cover Texts. A copy of the license is included 16 | in the section entitled :ref:`gnu_fdl`. 17 | 18 | .. toctree:: 19 | :numbered: 20 | :maxdepth: 3 21 | 22 | aunit_cb/introduction 23 | aunit_cb/overview 24 | aunit_cb/test_case 25 | aunit_cb/fixture 26 | aunit_cb/suite 27 | aunit_cb/reporting 28 | aunit_cb/test_organization 29 | aunit_cb/restricted_runtimes 30 | aunit_cb/installation_and_use 31 | aunit_cb/gps_support 32 | 33 | .. raw:: latex 34 | 35 | \appendix 36 | 37 | .. toctree:: 38 | :maxdepth: 3 39 | 40 | share/gnu_free_documentation_license 41 | -------------------------------------------------------------------------------- /examples/liskov/tests/shape-tests.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with AUnit.Assertions; use AUnit.Assertions; 5 | 6 | package body Shape.Tests is 7 | 8 | -------------------- 9 | -- Test_Set_Width -- 10 | -------------------- 11 | 12 | procedure Test_Set_Width (T : in out Test) is 13 | begin 14 | T.The_Shape.Set_Width (3); 15 | Assert 16 | (T.The_Shape.Width = 3, 17 | "Width did not return the correct value after a Set_Width"); 18 | 19 | T.The_Shape.Set_Width (7); 20 | Assert 21 | (T.The_Shape.Width = 7, 22 | "Width did not return the correct value after a 2nd Set_Width"); 23 | end Test_Set_Width; 24 | 25 | procedure Test_Set_Height (T : in out Test) is 26 | begin 27 | T.The_Shape.Set_Height (3); 28 | Assert 29 | (T.The_Shape.Height = 3, 30 | "Height did not return the correct value after a Set_Height"); 31 | 32 | T.The_Shape.Set_Height (7); 33 | Assert 34 | (T.The_Shape.Height = 7, 35 | "Height did not return the correct value after a 2nd Set_Height"); 36 | end Test_Set_Height; 37 | 38 | end Shape.Tests; 39 | -------------------------------------------------------------------------------- /examples/liskov/tests/square-tests-suite.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | 5 | with AUnit.Test_Caller; 6 | 7 | package body Square.Tests.Suite is 8 | 9 | package Runner is new AUnit.Test_Caller 10 | (Square.Tests.Test); 11 | 12 | Result : aliased AUnit.Test_Suites.Test_Suite; 13 | 14 | Test_Width : aliased Runner.Test_Case; 15 | Test_Height : aliased Runner.Test_Case; 16 | Test_Area : aliased Runner.Test_Case; 17 | 18 | function Suite return AUnit.Test_Suites.Access_Test_Suite is 19 | begin 20 | Runner.Create (Test_Width, 21 | "Square : Test width", 22 | Test_Set_Width'Access); 23 | Runner.Create (Test_Height, 24 | "Square : Test height", 25 | Test_Set_Height'Access); 26 | Runner.Create (Test_Area, 27 | "Square : Test area", 28 | Test_Get_Area'Access); 29 | Result.Add_Test (Test_Width'Access); 30 | Result.Add_Test (Test_Height'Access); 31 | Result.Add_Test (Test_Area'Access); 32 | 33 | return Result'Access; 34 | end Suite; 35 | 36 | end Square.Tests.Suite; 37 | -------------------------------------------------------------------------------- /test/src/aunit-test_fixtures-tests_fixtures.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2009-2010, AdaCore 3 | -- 4 | 5 | with AUnit.Test_Caller; 6 | 7 | package AUnit.Test_Fixtures.Tests_Fixtures is 8 | 9 | type Fix is new AUnit.Test_Fixtures.Test_Fixture with record 10 | Set_Up_Called : Natural := 0; 11 | Tear_Down_Called : Natural := 0; 12 | end record; 13 | 14 | procedure Set_Up (T : in out Fix); 15 | procedure Tear_Down (T : in out Fix); 16 | 17 | procedure Test_Success (T : in out Fix); 18 | procedure Test_Failure (T : in out Fix); 19 | procedure Test_Error (T : in out Fix); 20 | 21 | package Caller is new AUnit.Test_Caller (Fix); 22 | 23 | TC_Success : constant Caller.Test_Case_Access := 24 | Caller.Create ("Test Success", Test_Success'Access); 25 | TC_Failure : constant Caller.Test_Case_Access := 26 | Caller.Create ("Test Failure", Test_Failure'Access); 27 | TC_Error : constant Caller.Test_Case_Access := 28 | Caller.Create ("Test Error", Test_Error'Access); 29 | 30 | function Get_Nb_Set_Up_Called return Natural; 31 | function Get_Nb_Tear_Down_Called return Natural; 32 | 33 | end AUnit.Test_Fixtures.Tests_Fixtures; 34 | -------------------------------------------------------------------------------- /test/src/aunit_harness.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2009-2013, AdaCore 3 | -- 4 | 5 | with AUnit.Options; 6 | with AUnit.Reporter.Text; 7 | with AUnit.Run; 8 | with AUnit.Test_Filters; use AUnit.Test_Filters; 9 | 10 | with AUnit_Suite; use AUnit_Suite; 11 | 12 | procedure AUnit_Harness is 13 | 14 | procedure Harness is new AUnit.Run.Test_Runner (Suite); 15 | -- The full test harness 16 | 17 | Reporter : AUnit.Reporter.Text.Text_Reporter; 18 | Filter : aliased AUnit.Test_Filters.Name_Filter; 19 | Options : AUnit.Options.AUnit_Options := 20 | (Global_Timer => False, 21 | Test_Case_Timer => True, 22 | Report_Successes => True, 23 | Filter => null); 24 | begin 25 | AUnit.Reporter.Text.Set_Use_ANSI_Colors (Reporter, True); 26 | Harness (Reporter, Options); 27 | 28 | -- Test the filter 29 | -- This filter should be initialized from the command line arguments. In 30 | -- this example, we don't do it to support limited runtimes with no support 31 | -- for Ada.Command_Line 32 | 33 | Options.Filter := Filter'Unchecked_Access; 34 | Set_Name (Filter, "(test_case) Test routines registration"); 35 | Harness (Reporter, Options); 36 | 37 | end AUnit_Harness; 38 | -------------------------------------------------------------------------------- /test/src/aunit-test_cases-tests-suite.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2009-2010, AdaCore 3 | -- 4 | 5 | with AUnit.Test_Caller; 6 | 7 | package body AUnit.Test_Cases.Tests.Suite is 8 | 9 | package Caller is new AUnit.Test_Caller 10 | (AUnit.Test_Cases.Tests.Fixture); 11 | 12 | function Test_Suite return AUnit.Test_Suites.Access_Test_Suite is 13 | S : constant AUnit.Test_Suites.Access_Test_Suite := 14 | AUnit.Test_Suites.New_Suite; 15 | begin 16 | AUnit.Test_Suites.Add_Test 17 | (S, 18 | Caller.Create 19 | ("(test_case) Test routines registration", 20 | Test_Register_Tests'Access)); 21 | AUnit.Test_Suites.Add_Test 22 | (S, 23 | Caller.Create 24 | ("(test_case) Test set_up phase", 25 | Test_Set_Up'Access)); 26 | AUnit.Test_Suites.Add_Test 27 | (S, 28 | Caller.Create 29 | ("(test_case) Test tear_down phase", 30 | Test_Torn_Down'Access)); 31 | AUnit.Test_Suites.Add_Test 32 | (S, 33 | Caller.Create 34 | ("(test_case) Test run phase", 35 | Test_Run'Access)); 36 | return S; 37 | end Test_Suite; 38 | 39 | end AUnit.Test_Cases.Tests.Suite; 40 | -------------------------------------------------------------------------------- /examples/liskov/tests/rectangle-tests-suite.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | 5 | with AUnit.Test_Caller; 6 | 7 | package body Rectangle.Tests.Suite is 8 | 9 | package Runner is new AUnit.Test_Caller 10 | (Rectangle.Tests.Test); 11 | 12 | Result : aliased AUnit.Test_Suites.Test_Suite; 13 | 14 | Test_Width : aliased Runner.Test_Case; 15 | Test_Height : aliased Runner.Test_Case; 16 | Test_Area : aliased Runner.Test_Case; 17 | 18 | ----------- 19 | -- Suite -- 20 | ----------- 21 | 22 | function Suite return AUnit.Test_Suites.Access_Test_Suite 23 | is 24 | begin 25 | Runner.Create (Test_Width, 26 | "Rectangle : Test width", 27 | Test_Set_Width'Access); 28 | Runner.Create (Test_Height, 29 | "Rectangle : Test height", 30 | Test_Set_Height'Access); 31 | Runner.Create (Test_Area, 32 | "Rectangle : Test area", 33 | Test_Get_Area'Access); 34 | Result.Add_Test (Test_Width'Access); 35 | Result.Add_Test (Test_Height'Access); 36 | Result.Add_Test (Test_Area'Access); 37 | 38 | return Result'Access; 39 | end Suite; 40 | 41 | end Rectangle.Tests.Suite; 42 | -------------------------------------------------------------------------------- /test/Makefile: -------------------------------------------------------------------------------- 1 | GPRBUILD = gprbuild 2 | GPRCLEAN = gprclean 3 | 4 | .PHONY: all test force 5 | 6 | all: test 7 | 8 | RTS = 9 | TARGET = 10 | PROJECT_PATH_ARG = 11 | 12 | ifeq ($(RTS),) 13 | RTS = full 14 | RTS_CONF = 15 | else 16 | RTS_CONF = --RTS=$(RTS) 17 | endif 18 | 19 | ifeq ($(TARGET),) 20 | TARGET = native 21 | TARGET_CONF = 22 | else 23 | TARGET_CONF = --target=$(TARGET) 24 | endif 25 | 26 | CONF_ARGS = $(TARGET_CONF) $(RTS_CONF) 27 | 28 | ifeq ($(OS),Windows_NT) 29 | ifeq ($(TARGET),native) 30 | exeext=.exe 31 | endif 32 | endif 33 | 34 | ifeq ($(findstring vxworks,$(TARGET)),vxworks) 35 | exeext=.out 36 | endif 37 | 38 | RUN= 39 | ifeq ($(TARGET),powerpc-elf) 40 | RUN=./support/run-ppc-elf 41 | endif 42 | 43 | build: 44 | $(PROJECT_PATH_ARG) $(GPRBUILD) -p -Paunit_tests $(CONF_ARGS) $(LARGS) 45 | 46 | run: build 47 | -$(RUN) ./exe/$(TARGET)-$(RTS)/aunit_harness$(exeext) 48 | 49 | test: build 50 | -$(RUN) ./exe/aunit_harness$(exeext) > test.out.full 2>&1 51 | egrep "^Total|^Success|^Fail|^Unexp" test.out.full > test.out 52 | diff -b test.out expected.out 53 | @echo 54 | @echo "[OK] AUNIT TEST IS SUCCESSFUL" 55 | 56 | clean: 57 | $(RM) -rf obj exe support/obj support/lib *.cgpr test.out 58 | 59 | RMDIR = rmdir 60 | MKDIR = mkdir -p 61 | RM = rm 62 | CP = cp -p 63 | -------------------------------------------------------------------------------- /examples/failures/tests/math-test.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with AUnit.Assertions; use AUnit.Assertions; 5 | 6 | package body Math.Test is 7 | 8 | procedure Test_Addition (T : in out Test) is 9 | pragma Unreferenced (T); 10 | I1 : constant Int := 5; 11 | I2 : constant Int := 3; 12 | begin 13 | Assert (I1 + I2 = 8, "Incorrect result after addition"); 14 | end Test_Addition; 15 | 16 | procedure Test_Subtraction (T : in out Test) is 17 | pragma Unreferenced (T); 18 | I1 : constant Int := 5; 19 | I2 : constant Int := 3; 20 | begin 21 | Assert (I1 - I2 = 2, "Incorrect result after subtraction"); 22 | end Test_Subtraction; 23 | 24 | procedure Test_Addition_Failure (T : in out Test) is 25 | pragma Unreferenced (T); 26 | I1 : constant Int := 5; 27 | I2 : constant Int := 3; 28 | begin 29 | Assert (I1 + I2 = 9, "Test should fail this assertion, as 5+3 /= 9"); 30 | end Test_Addition_Failure; 31 | 32 | procedure Test_Addition_Error (T : in out Test) is 33 | pragma Unreferenced (T); 34 | I1 : constant Int := Int'Last; 35 | I2 : constant Int := Int'Last; 36 | begin 37 | Assert (I1 + I2 = I1, "This raises a constraint error"); 38 | end Test_Addition_Error; 39 | 40 | end Math.Test; 41 | -------------------------------------------------------------------------------- /include/aunit/containers/ada_containers.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- -- 3 | -- GNAT LIBRARY COMPONENTS -- 4 | -- -- 5 | -- A D A . C O N T A I N E R S -- 6 | -- -- 7 | -- S p e c -- 8 | -- -- 9 | -- This specification is adapted from the Ada Reference Manual for use with -- 10 | -- GNAT. In accordance with the copyright of that document, you can freely -- 11 | -- copy and modify this specification, provided that if you redistribute a -- 12 | -- modified version, any changes that you have made are clearly indicated. -- 13 | -- -- 14 | ------------------------------------------------------------------------------ 15 | 16 | package Ada_Containers is 17 | pragma Pure; 18 | 19 | type Hash_Type is mod 2**32; 20 | type Count_Type is range 0 .. 2**31 - 1; 21 | 22 | end Ada_Containers; 23 | -------------------------------------------------------------------------------- /test/src/aunit-test_fixtures-tests-suite.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2009-2010, AdaCore 3 | -- 4 | 5 | with AUnit.Test_Caller; 6 | 7 | package body AUnit.Test_Fixtures.Tests.Suite is 8 | 9 | package Caller is new AUnit.Test_Caller 10 | (AUnit.Test_Fixtures.Tests.Fixture); 11 | 12 | function Test_Suite return AUnit.Test_Suites.Access_Test_Suite is 13 | S : constant AUnit.Test_Suites.Access_Test_Suite := 14 | AUnit.Test_Suites.New_Suite; 15 | begin 16 | AUnit.Test_Suites.Add_Test 17 | (S, 18 | Caller.Create 19 | ("(test_fixture) Test Set_Up call", 20 | Test_Set_Up'Access)); 21 | AUnit.Test_Suites.Add_Test 22 | (S, 23 | Caller.Create 24 | ("(test_fixture) Test Tear_Down call (the called test is success)", 25 | Test_Tear_Down_Success'Access)); 26 | AUnit.Test_Suites.Add_Test 27 | (S, 28 | Caller.Create 29 | ("(test_fixture) Test Tear_Down call (the called test is failure)", 30 | Test_Tear_Down_Failure'Access)); 31 | AUnit.Test_Suites.Add_Test 32 | (S, 33 | Caller.Create 34 | ("(test_fixture) Test Tear_Down call (the called test is error)", 35 | Test_Tear_Down_Error'Access)); 36 | return S; 37 | end Test_Suite; 38 | 39 | end AUnit.Test_Fixtures.Tests.Suite; 40 | -------------------------------------------------------------------------------- /examples/calculator/tested_lib/src/stack.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with Ada.Unchecked_Deallocation; 5 | with Operands; use Operands; 6 | 7 | package Stack is 8 | 9 | Stack_Overflow : exception; 10 | Stack_Empty : exception; 11 | 12 | Max_Stack_Size : constant Natural := 128; 13 | 14 | procedure Push (Op : Operands.Operand'Class); 15 | -- Push an operand on the stack 16 | -- Raises Stack_Overflow if the stack is full 17 | 18 | function Pop return Operands.Operand'Class; 19 | -- Pop an operand from the stack 20 | -- Raises Stack_Empty if the stack is empty 21 | 22 | function Length return Natural; 23 | -- Return the number of objects in the stack 24 | 25 | function Top return Operands.Operand'Class; 26 | -- Return the operand on the top of the stack without removing it from the 27 | -- stack. 28 | 29 | function Next_To_Top return Operands.Operand'Class; 30 | -- Return he operand on the next to top of the stack without removing it 31 | -- from the stack 32 | 33 | private 34 | 35 | type Stack_Index is new Natural range 0 .. Max_Stack_Size; 36 | Empty_Stack : constant Stack_Index := 0; 37 | 38 | The_Stack : array (Stack_Index range 1 .. Stack_Index'Last) 39 | of Operand_Access; 40 | The_Stack_Index : Stack_Index := Empty_Stack; 41 | 42 | procedure Free is new Ada.Unchecked_Deallocation 43 | (Operands.Operand'Class, Operand_Access); 44 | 45 | end Stack; 46 | -------------------------------------------------------------------------------- /examples/calculator/tested_lib/src/operations-binary.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with Operands; use Operands; 5 | with Stack; 6 | 7 | generic 8 | type T is new Operands.Operand with private; 9 | type T_Ret is new Operands.Operand with private; 10 | with function The_Operation (T1, T2 : T) return T_Ret; 11 | package Operations.Binary is 12 | 13 | type Binary_Operation is new Operation with private; 14 | 15 | procedure Pop (Op : in out Binary_Operation); 16 | pragma Precondition 17 | (Stack.Length >= 2 18 | and then Stack.Top in T'Class 19 | and then Stack.Next_To_Top in T'Class, 20 | "precondition for Operations.Binary.Pop"); 21 | pragma Postcondition 22 | (Stack.Length = Stack.Length'Old - 2, 23 | "postcondition for Operations.Binary.Pop"); 24 | -- Pops the operands from the stack 25 | 26 | procedure Push (Op : in out Binary_Operation); 27 | pragma Precondition 28 | (Stack.Length < Stack.Max_Stack_Size, 29 | "precondition for Operations.Binary.Push"); 30 | pragma Postcondition 31 | (Stack.Length = Stack.Length'Old + 1, 32 | "postcondition for Operations.Binary.Push"); 33 | -- Pushes the operands in the stack 34 | 35 | procedure Execute (Op : in out Binary_Operation); 36 | -- Execute the operation 37 | 38 | private 39 | 40 | type Binary_Operation is new Operation with record 41 | Op1 : T; 42 | Op2 : T; 43 | Res : T_Ret; 44 | end record; 45 | 46 | end Operations.Binary; 47 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | AUnit README 2 | 3 | This is the Ada unit test framework AUnit, derived 4 | from the JUnit/CPPUnit frameworks for Java/C++. Read the AUnit Cookbook, 5 | available in doc/ in a number of formats, for installation and usage. 6 | 7 | AUnit is maintained by AdaCore. Please report problems at support@adacore.com 8 | 9 | NOTE FOR CONTRIBUTORS 10 | --------------------- 11 | 12 | AUnit is intended to be used on bareboard targets that have a very 13 | limited runtime library, so many things like containers, finalization, 14 | exception propagation and so on cannot be used in the main framework 15 | unconditionally. For full list of restrictions see following parts of 16 | GNAT User’s Guide Supplement for Cross Platforms: 17 | 18 | * [4.2.2. Ada Restrictions in the Zero Footprint Profile](http://docs.adacore.com/live/wave/gnat_ugx/html/gnat_ugx/gnat_ugx/the_predefined_profiles.html#ada-restrictions-in-the-zero-footprint-profile) 19 | 20 | * [4.2.3. Predefined Packages in the Zero Footprint Profile](http://docs.adacore.com/live/wave/gnat_ugx/html/gnat_ugx/gnat_ugx/the_predefined_profiles.html#predefined-packages-in-the-zero-footprint-profile) 21 | 22 | Other language features and predefined packages may be used in conditional 23 | way, by either providing the same API across different scenarios or adding 24 | new units for full runtime scenario only. An example of such conditional usage 25 | is FileIO variable from lib/gnat/aunit_shared.gpr that selects between 26 | include/aunit/framework/fileio and include/aunit/framework/nofileio. 27 | -------------------------------------------------------------------------------- /test/src/aunit-test_cases-tests_fixtures.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2009-2010, AdaCore 3 | -- 4 | 5 | package AUnit.Test_Cases.Tests_Fixtures is 6 | 7 | type The_Test_Case is new Test_Cases.Test_Case with record 8 | Is_Set_Up, 9 | Is_Torn_Down : Boolean := False; 10 | end record; 11 | type The_Test_Case_Access is access all The_Test_Case'Class; 12 | 13 | procedure Register_Tests (T : in out The_Test_Case); 14 | -- Register routines to be run 15 | 16 | function Name (T : The_Test_Case) return Test_String; 17 | -- Provide name identifying the test case 18 | 19 | procedure Set_Up (T : in out The_Test_Case); 20 | -- Preparation performed before each routine 21 | 22 | procedure Tear_Down (T : in out The_Test_Case); 23 | -- Cleanup performed after each routine 24 | 25 | function Is_Set_Up (T : The_Test_Case) return Boolean; 26 | -- Set up? 27 | 28 | function Is_Torn_Down (T : The_Test_Case) return Boolean; 29 | -- Torn down? 30 | 31 | -------------------- 32 | -- Test Routines -- 33 | -------------------- 34 | 35 | procedure Fail (T : in out Test_Cases.Test_Case'Class); 36 | -- This routine produces a failure 37 | 38 | procedure Succeed (T : in out Test_Cases.Test_Case'Class); 39 | -- This routine does nothing, so succeeds 40 | 41 | procedure Double_Failure (T : in out The_Test_Case); 42 | -- This routine produces two failrues 43 | 44 | procedure Except (T : in out Test_Cases.Test_Case'Class); 45 | -- This routine raises an exception 46 | 47 | end AUnit.Test_Cases.Tests_Fixtures; 48 | -------------------------------------------------------------------------------- /examples/liskov/tested_lib/src/shape.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | 5 | package Shape is 6 | 7 | type Shape_Type is abstract tagged private; 8 | type Shape_Access is access all Shape_Type'Class; 9 | 10 | -- Additional functional API for expressing pre/postconditions 11 | -- & invariants: 12 | -- function New_Shape (W, H : Natural) return Shape; 13 | -- function Set_Width (S : Shape; W : Natural) return Shape; 14 | -- function Set_Height (S : Shape; H : Natural) return Shape; 15 | -- 16 | -- Class invariants: 17 | -- for_all W, H in Natural: 18 | -- Set_Width (New_Shape (W, H), X) = New_Shape (X, H)) 19 | -- Set_Height (New_Shape (W, H), X) = New_Shape (W, X)) 20 | 21 | function Width (Obj : Shape_Type) return Natural; 22 | function Height (Obj : Shape_Type) return Natural; 23 | 24 | procedure Set_Width (Obj : in out Shape_Type; W : Natural); 25 | -- pragma Postcondition 26 | -- (Width (Obj) = W -- expected result 27 | -- and Height (Obj) = Height (Obj'Old) -- independence 28 | -- ); 29 | 30 | procedure Set_Height (Obj : in out Shape_Type; H : Natural); 31 | -- pragma Postcondition 32 | -- (Height (Obj) = H -- expected result 33 | -- and Width (Obj) = Width (Obj'Old) -- independence 34 | -- ); 35 | 36 | function Area (Obj : Shape_Type) return Natural is abstract; 37 | 38 | private 39 | type Shape_Type is abstract tagged record 40 | Width : Natural; 41 | Height : Natural; 42 | end record; 43 | end Shape; 44 | -------------------------------------------------------------------------------- /examples/liskov/tests/square-tests-suite_liskov.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with Ada.Unchecked_Conversion; 5 | with AUnit.Test_Caller; 6 | with Rectangle.Tests; 7 | 8 | package body Square.Tests.Suite_Liskov is 9 | 10 | package Runner is new AUnit.Test_Caller 11 | (Square.Tests.Test); 12 | package Rectangle_Runner is new AUnit.Test_Caller 13 | (Rectangle.Tests.Test); 14 | 15 | Result : aliased AUnit.Test_Suites.Test_Suite; 16 | 17 | Test_Width : aliased Runner.Test_Case; 18 | Test_Height : aliased Runner.Test_Case; 19 | Test_Area : aliased Runner.Test_Case; 20 | 21 | function Suite return AUnit.Test_Suites.Access_Test_Suite is 22 | function Convert is new Ada.Unchecked_Conversion 23 | (Rectangle_Runner.Test_Method, Runner.Test_Method); 24 | begin 25 | Runner.Create 26 | (Test_Width, 27 | "Square as Rectangle (liskov) : Test width", 28 | Convert 29 | (Rectangle_Runner.Test_Method' 30 | (Rectangle.Tests.Test_Set_Width'Access))); 31 | Runner.Create 32 | (Test_Height, 33 | "Square as Rectangle (liskov) : Test height", 34 | Convert 35 | (Rectangle_Runner.Test_Method' 36 | (Rectangle.Tests.Test_Set_Height'Access))); 37 | Runner.Create 38 | (Test_Area, 39 | "Square as Rectangle (liskov) : Test area", 40 | Convert 41 | (Rectangle_Runner.Test_Method' 42 | (Rectangle.Tests.Test_Get_Area'Access))); 43 | Result.Add_Test (Test_Width'Access); 44 | Result.Add_Test (Test_Height'Access); 45 | Result.Add_Test (Test_Area'Access); 46 | 47 | return Result'Access; 48 | end Suite; 49 | 50 | end Square.Tests.Suite_Liskov; 51 | -------------------------------------------------------------------------------- /template/pr_xxxx_xxx.adb: -------------------------------------------------------------------------------- 1 | with AUnit.Assertions; use AUnit.Assertions; 2 | 3 | -- Template for test case body. 4 | package body PR_XXXX_XXX is 5 | 6 | -- Example test routine. Provide as many as are needed: 7 | procedure Test1 (R : in out AUnit.Test_Cases.Test_Case'Class); 8 | 9 | procedure Set_Up (T : in out Test_Case) is 10 | begin 11 | -- Do any necessary set ups. If there are none, 12 | -- omit from both spec and body, as a default 13 | -- version is provided in Test_Cases. 14 | null; 15 | end Set_Up; 16 | 17 | procedure Tear_Down (T : in out Test_Case) is 18 | begin 19 | -- Do any necessary cleanups, so the next test 20 | -- has a clean environment. If there is no 21 | -- cleanup, omit spec and body, as default is 22 | -- provided in Test_Cases. 23 | null; 24 | end Tear_Down; 25 | 26 | 27 | -- Example test routine. Provide as many as are needed: 28 | procedure Test1 (R : in out AUnit.Test_Cases.Test_Case'Class) is 29 | begin 30 | -- Do something: 31 | null; 32 | 33 | -- Test for expected conditions. Multiple assertions 34 | -- and actions are ok: 35 | Assert (True, "Indication of what failed"); 36 | end Test1; 37 | 38 | 39 | -- Register test routines to call: 40 | procedure Register_Tests (T : in out Test_Case) is 41 | use Test_Cases, Test_Cases.Registration; 42 | begin 43 | -- Repeat for each test routine. 44 | Register_Routine (T, Test1'Access, "Description of test routine"); 45 | end Register_Tests; 46 | 47 | -- Identifier of test case: 48 | function Name (T : Test_Case) return Message_String is 49 | begin 50 | return Format ("Test case name"); 51 | end Name; 52 | 53 | end PR_XXXX_XXX; 54 | -------------------------------------------------------------------------------- /test/src/aunit-test_suites-tests-suite.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2009-2010, AdaCore 3 | -- 4 | 5 | with AUnit.Test_Caller; 6 | 7 | package body AUnit.Test_Suites.Tests.Suite is 8 | 9 | package Caller is new AUnit.Test_Caller 10 | (AUnit.Test_Suites.Tests.Fixture); 11 | 12 | function Test_Suite return AUnit.Test_Suites.Access_Test_Suite is 13 | S : constant AUnit.Test_Suites.Access_Test_Suite := 14 | AUnit.Test_Suites.New_Suite; 15 | begin 16 | AUnit.Test_Suites.Add_Test 17 | (S, 18 | Caller.Create 19 | ("(suite) Add test case", 20 | Test_Add_Test_Case'Access)); 21 | AUnit.Test_Suites.Add_Test 22 | (S, 23 | Caller.Create 24 | ("(suite) Run empty suite", 25 | Test_Run_Empty'Access)); 26 | AUnit.Test_Suites.Add_Test 27 | (S, 28 | Caller.Create 29 | ("(suite) Run suite with a successful test", 30 | Test_Run_With_Success'Access)); 31 | AUnit.Test_Suites.Add_Test 32 | (S, 33 | Caller.Create 34 | ("(suite) Run suite with a failing test", 35 | Test_Run_With_Failure'Access)); 36 | AUnit.Test_Suites.Add_Test 37 | (S, 38 | Caller.Create 39 | ("(suite) Run suite with a test raising an exception", 40 | Test_Run_With_Exception'Access)); 41 | AUnit.Test_Suites.Add_Test 42 | (S, 43 | Caller.Create 44 | ("(suite) Run suite with various tests", 45 | Test_Run_With_All'Access)); 46 | AUnit.Test_Suites.Add_Test 47 | (S, 48 | Caller.Create 49 | ("(suite) Verify Set_Up/Tear_Down are called", 50 | Test_Run_With_Setup'Access)); 51 | return S; 52 | end Test_Suite; 53 | 54 | end AUnit.Test_Suites.Tests.Suite; 55 | -------------------------------------------------------------------------------- /examples/calculator/tested_lib/src/stack.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | package body Stack is 5 | 6 | ---------- 7 | -- Push -- 8 | ---------- 9 | 10 | procedure Push (Op : Operands.Operand'Class) is 11 | begin 12 | if The_Stack_Index = Stack_Index'Last then 13 | raise Stack_Overflow; 14 | end if; 15 | 16 | The_Stack_Index := The_Stack_Index + 1; 17 | The_Stack (The_Stack_Index) := new Operands.Operand'Class'(Op); 18 | end Push; 19 | 20 | --------- 21 | -- Pop -- 22 | --------- 23 | 24 | function Pop return Operands.Operand'Class is 25 | begin 26 | if The_Stack_Index = Empty_Stack then 27 | raise Stack_Empty; 28 | end if; 29 | 30 | declare 31 | Op : constant Operands.Operand'Class := 32 | The_Stack (The_Stack_Index).all; 33 | begin 34 | Free (The_Stack (The_Stack_Index)); 35 | The_Stack_Index := The_Stack_Index - 1; 36 | return Op; 37 | end; 38 | end Pop; 39 | 40 | ------------ 41 | -- Length -- 42 | ------------ 43 | 44 | function Length return Natural is 45 | begin 46 | return Natural (The_Stack_Index); 47 | end Length; 48 | 49 | -------------- 50 | -- Top_Type -- 51 | -------------- 52 | 53 | function Top return Operands.Operand'Class is 54 | begin 55 | if The_Stack_Index = 0 then 56 | raise Stack_Empty; 57 | end if; 58 | 59 | return The_Stack (The_Stack_Index).all; 60 | end Top; 61 | 62 | ---------------------- 63 | -- Next_To_Top_Type -- 64 | ---------------------- 65 | 66 | function Next_To_Top return Operands.Operand'Class is 67 | begin 68 | if The_Stack_Index < 2 then 69 | raise Stack_Empty; 70 | end if; 71 | 72 | return The_Stack (The_Stack_Index - 1).all; 73 | end Next_To_Top; 74 | 75 | end Stack; 76 | -------------------------------------------------------------------------------- /doc/share/latex_elements.py: -------------------------------------------------------------------------------- 1 | # define some latex elements to be used for PDF output 2 | 3 | PAGE_BLANK = r''' 4 | \makeatletter 5 | \def\cleartooddpage{%% 6 | \cleardoublepage%% 7 | } 8 | \def\cleardoublepage{%% 9 | \clearpage%% 10 | \if@twoside%% 11 | \ifodd\c@page%% 12 | %% nothing to do 13 | \else%% 14 | \hbox{}%% 15 | \thispagestyle{plain}%% 16 | \vspace*{\fill}%% 17 | \begin{center}%% 18 | \textbf{\em This page is intentionally left blank.}%% 19 | \end{center}%% 20 | \vspace{\fill}%% 21 | \newpage%% 22 | \if@twocolumn%% 23 | \hbox{}%% 24 | \newpage%% 25 | \fi%% 26 | \fi%% 27 | \fi%% 28 | } 29 | \makeatother 30 | ''' 31 | 32 | TOC_DEPTH = r''' 33 | \pagenumbering{arabic} 34 | \setcounter{tocdepth}{3} 35 | ''' 36 | 37 | TOC_CMD = r''' 38 | \makeatletter 39 | \def\tableofcontents{%% 40 | \pagestyle{plain}%% 41 | \chapter*{\contentsname}%% 42 | \@mkboth{\MakeUppercase{\contentsname}}%% 43 | {\MakeUppercase{\contentsname}}%% 44 | \@starttoc{toc}%% 45 | } 46 | \makeatother 47 | ''' 48 | 49 | TOC = r''' 50 | \cleardoublepage 51 | \tableofcontents 52 | \cleardoublepage\pagestyle{plain} 53 | ''' 54 | 55 | LATEX_HYPHEN = r''' 56 | \hyphenpenalty=5000 57 | \tolerance=1000 58 | ''' 59 | 60 | FOOTER = r""" 61 | \usepackage{titleref} 62 | 63 | \makeatletter 64 | \@ifundefined{fancyhf}{}{ 65 | \fancypagestyle{normal}{ 66 | \fancyhf{} 67 | % Define footers 68 | \fancyfoot[LE,RO]{{\py@HeaderFamily\thepage}} 69 | \fancyfoot[LO,RE]{\TR@currentTitle} 70 | } 71 | \fancypagestyle{plain}{ 72 | \fancyhf{} 73 | % Define footers 74 | \fancyfoot[LE,RO]{{\py@HeaderFamily\thepage}} 75 | \fancyfoot[LO,RE]{\TR@currentTitle} 76 | } 77 | } 78 | \makeatother 79 | """ 80 | 81 | 82 | def doc_settings(full_document_name, version): 83 | return '\n'.join([ 84 | r'\newcommand*{\GNATFullDocumentName}[0]{' + full_document_name + r'}', 85 | r'\newcommand*{\GNATVersion}[0]{' + version + r'}']) 86 | -------------------------------------------------------------------------------- /test/src/aunit-test_fixtures-tests_fixtures.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2009-2010, AdaCore 3 | -- 4 | 5 | with AUnit.Assertions; use AUnit.Assertions; 6 | 7 | package body AUnit.Test_Fixtures.Tests_Fixtures is 8 | 9 | Nb_Set_Up_Called : Natural := 0; 10 | Nb_Tear_Down_Called : Natural := 0; 11 | 12 | ------------ 13 | -- Set_Up -- 14 | ------------ 15 | 16 | procedure Set_Up (T : in out Fix) is 17 | begin 18 | T.Set_Up_Called := T.Set_Up_Called + 1; 19 | Nb_Set_Up_Called := T.Set_Up_Called; 20 | end Set_Up; 21 | 22 | --------------- 23 | -- Tear_Down -- 24 | --------------- 25 | 26 | procedure Tear_Down (T : in out Fix) is 27 | begin 28 | T.Tear_Down_Called := T.Tear_Down_Called + 1; 29 | Nb_Tear_Down_Called := T.Tear_Down_Called; 30 | end Tear_Down; 31 | 32 | ------------------ 33 | -- Test_Success -- 34 | ------------------ 35 | 36 | procedure Test_Success (T : in out Fix) is 37 | pragma Unreferenced (T); 38 | begin 39 | null; 40 | end Test_Success; 41 | 42 | ------------------ 43 | -- Test_Failure -- 44 | ------------------ 45 | 46 | procedure Test_Failure (T : in out Fix) is 47 | pragma Unreferenced (T); 48 | begin 49 | Assert (False, "Failure"); 50 | end Test_Failure; 51 | 52 | ---------------- 53 | -- Test_Error -- 54 | ---------------- 55 | 56 | procedure Test_Error (T : in out Fix) is 57 | pragma Unreferenced (T); 58 | begin 59 | raise Constraint_Error; 60 | end Test_Error; 61 | 62 | -------------------------- 63 | -- Get_Nb_Set_Up_Called -- 64 | -------------------------- 65 | 66 | function Get_Nb_Set_Up_Called return Natural is 67 | begin 68 | return Nb_Set_Up_Called; 69 | end Get_Nb_Set_Up_Called; 70 | 71 | ----------------------------- 72 | -- Get_Nb_Tear_Down_Called -- 73 | ----------------------------- 74 | 75 | function Get_Nb_Tear_Down_Called return Natural is 76 | begin 77 | return Nb_Tear_Down_Called; 78 | end Get_Nb_Tear_Down_Called; 79 | 80 | end AUnit.Test_Fixtures.Tests_Fixtures; 81 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | RTS = 2 | TARGET = 3 | GPRBUILD = gprbuild 4 | GPRCLEAN = gprclean 5 | GPRINSTALL = gprinstall 6 | 7 | INSTALL:=$(shell exec=`which gprbuild`;if [ ! -x "$$exec" ]; then unset exec;fi;echo $$exec | sed -e 's/\/bin\/$(GPRBUILD).*//') 8 | 9 | ifeq ($(RTS),) 10 | RTS=full 11 | RTS_CONF = 12 | else 13 | RTS_CONF = --RTS=$(RTS) 14 | endif 15 | 16 | ifeq ($(TARGET),) 17 | TARGET=native 18 | TARGET_CONF = 19 | else 20 | TARGET_CONF = --target=$(TARGET) 21 | endif 22 | 23 | MODE = Install 24 | 25 | CONF_ARGS = $(TARGET_CONF) $(RTS_CONF) 26 | 27 | GPROPTS = $(CONF_ARGS) -XAUNIT_BUILD_MODE=$(MODE) -XAUNIT_RUNTIME=$(RTS) \ 28 | -XAUNIT_PLATFORM=$(TARGET) 29 | 30 | # For the 64 bits architectures, the large code model has to be used. 31 | # with rtp-large, gprconfig ensures that -mcmodel=large is used, 32 | # but it is managed here for the default (kernel). 33 | GPROPTS_EXTRA= 34 | ifneq ($(strip $(filter aarch64-wrs-vxworks7r2 powerpc64-wrs-vxworks7r2 x86_64-wrs-vxworks7r2,$(TARGET))),) 35 | ifeq (${RTS_CONF},) 36 | # This covers the kernel RTS because for rtp, the RTS_OPT variable is defined to --RTS=rtp. 37 | # kernel is the default and the RTS_OPT is not set in that case. 38 | GPROPTS_EXTRA+=-cargs -mcmodel=large -largs -mcmodel=large 39 | endif 40 | endif 41 | 42 | .PHONY: all clean targets install_clean install 43 | 44 | all: 45 | $(GPRBUILD) -p $(GPROPTS) lib/gnat/aunit.gpr ${GPROPTS_EXTRA} 46 | 47 | clean-lib: 48 | $(RM) -fr lib/aunit lib/aunit-obj 49 | 50 | clean: clean-lib 51 | -${MAKE} -C doc clean 52 | 53 | install-clean-legacy: 54 | ifneq (,$(wildcard $(INSTALL)/lib/gnat/manifests/aunit)) 55 | -$(GPRINSTALL) $(GPROPTS) --uninstall --prefix=$(INSTALL) \ 56 | --project-subdir=lib/gnat aunit 57 | endif 58 | 59 | install-clean: install-clean-legacy 60 | ifneq (,$(wildcard $(INSTALL)/share/gpr/manifests/aunit)) 61 | -$(GPRINSTALL) $(GPROPTS) --uninstall --prefix=$(INSTALL) aunit 62 | endif 63 | 64 | install: install-clean 65 | $(GPRINSTALL) $(GPROPTS) -p -f --prefix=$(INSTALL) \ 66 | --no-build-var lib/gnat/aunit.gpr 67 | 68 | .PHONY: doc 69 | doc: 70 | ${MAKE} -C doc 71 | 72 | RM = rm 73 | -------------------------------------------------------------------------------- /test/src/aunit-test_suites-tests_fixtures.ads: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2009-2010, AdaCore 3 | -- 4 | 5 | with AUnit.Simple_Test_Cases; 6 | 7 | package AUnit.Test_Suites.Tests_Fixtures is 8 | 9 | -- A very simple minded test case 10 | type Simple_Test_Case is new AUnit.Simple_Test_Cases.Test_Case with 11 | null record; 12 | function Name (Test : Simple_Test_Case) return Message_String; 13 | procedure Run_Test (Test : in out Simple_Test_Case); 14 | 15 | A_Simple_Test_Case : aliased Simple_Test_Case; 16 | 17 | -- A test case raising a failure 18 | type TC_With_Failure is new AUnit.Simple_Test_Cases.Test_Case with 19 | null record; 20 | function Name (Test : TC_With_Failure) return Message_String; 21 | procedure Run_Test (Test : in out TC_With_Failure); 22 | 23 | A_TC_With_Failure : aliased TC_With_Failure; 24 | 25 | -- A test case raising two failures 26 | type TC_With_Two_Failures is new AUnit.Simple_Test_Cases.Test_Case with 27 | null record; 28 | function Name (Test : TC_With_Two_Failures) return Message_String; 29 | procedure Run_Test (Test : in out TC_With_Two_Failures); 30 | 31 | A_TC_With_Two_Failures : aliased TC_With_Two_Failures; 32 | 33 | -- A test case raising an exception 34 | type TC_With_Exception is new AUnit.Simple_Test_Cases.Test_Case with 35 | null record; 36 | function Name (Test : TC_With_Exception) return Message_String; 37 | procedure Run_Test (Test : in out TC_With_Exception); 38 | 39 | A_TC_With_Exception : aliased TC_With_Exception; 40 | 41 | -- A test case using set_up and tear_down 42 | type TC_With_Setup is new AUnit.Simple_Test_Cases.Test_Case with record 43 | Setup : Boolean := False; 44 | Error : Boolean := False; 45 | end record; 46 | function Name (Test : TC_With_Setup) return Message_String; 47 | procedure Set_Up (Test : in out TC_With_Setup); 48 | procedure Tear_Down (Test : in out TC_With_Setup); 49 | procedure Run_Test (Test : in out TC_With_Setup); 50 | A_TC_With_Setup : aliased TC_With_Setup; 51 | 52 | My_Exception : exception; 53 | 54 | end AUnit.Test_Suites.Tests_Fixtures; 55 | -------------------------------------------------------------------------------- /lib/gnat/aunit_shared.gpr: -------------------------------------------------------------------------------- 1 | project AUnit_Shared is 2 | 3 | Target := external ("AUNIT_PLATFORM", "native"); 4 | 5 | type Runtime_Type is 6 | ( 7 | "full", -- used for all full capability runtimes 8 | "zfp", -- used for typical zfp/sfp/minimal runtimes 9 | "zfp-cross", -- used for zfp runtimes on some cross ports 10 | "ravenscar", -- used for full ravenscar runtimes 11 | "ravenscar-cert", -- used for ravenscar-cert runtimes 12 | "cert" -- used for cert runtimes 13 | ); 14 | 15 | Runtime : Runtime_Type := external ("AUNIT_RUNTIME", "full"); 16 | 17 | Library_Dir := external ("AUNIT_LIBDIR", "../aunit/" & Target & "-" & Runtime); 18 | 19 | for Source_Dirs use (); 20 | 21 | type Exception_Type is ("fullexception", "certexception", "zfpexception"); 22 | type Calendar_Type is ("calendar", "nocalendar"); 23 | type Memory_type is ("nativememory", "nodealloc", "staticmemory"); 24 | type FileIO_Type is ("fileio", "nofileio"); 25 | 26 | Except : Exception_Type := "fullexception"; 27 | Calend : Calendar_Type := "calendar"; 28 | Memory : Memory_Type := "nativememory"; 29 | FileIO : FileIO_Type := "fileio"; 30 | 31 | case Runtime is 32 | when "zfp" => 33 | Except := "zfpexception"; 34 | Calend := "nocalendar"; 35 | Memory := "nodealloc"; 36 | FileIO := "nofileio"; 37 | when "zfp-cross" => 38 | Except := "zfpexception"; 39 | Calend := "nocalendar"; 40 | Memory := "staticmemory"; 41 | FileIO := "nofileio"; 42 | when "ravenscar" => 43 | Except := "certexception"; 44 | Calend := "nocalendar"; 45 | FileIO := "nofileio"; 46 | when "ravenscar-cert" => 47 | Except := "certexception"; 48 | Calend := "calendar"; 49 | Memory := "staticmemory"; 50 | FileIO := "nofileio"; 51 | when "cert" => 52 | Except := "certexception"; 53 | Calend := "calendar"; 54 | Memory := "staticmemory"; 55 | FileIO := "nofileio"; 56 | when others => 57 | end case; 58 | 59 | end AUnit_Shared; 60 | -------------------------------------------------------------------------------- /lib/gnat/aunit.gpr: -------------------------------------------------------------------------------- 1 | 2 | with "aunit_shared"; 3 | 4 | project AUnit is 5 | 6 | type Compilation_Mode_Type is ("Devel", "Install"); 7 | Mode : Compilation_Mode_Type := external ("AUNIT_BUILD_MODE", "Install"); 8 | 9 | for Source_Dirs use 10 | ("../../include/aunit/framework", 11 | "../../include/aunit/containers", 12 | "../../include/aunit/reporters", 13 | "../../include/aunit/framework/" & AUnit_Shared.Except, 14 | "../../include/aunit/framework/" & AUnit_Shared.Calend, 15 | "../../include/aunit/framework/" & AUnit_Shared.Memory, 16 | "../../include/aunit/framework/" & AUnit_Shared.FileIO); 17 | 18 | for Library_Dir use AUnit_Shared.Library_Dir; 19 | 20 | Obj_Dir := external ("AUNIT_OBJDIR", "../aunit-obj/" 21 | & AUnit_Shared.Target & "-" & AUnit_Shared.Runtime); 22 | for Object_Dir use Obj_Dir; 23 | 24 | for Library_Name use "aunit"; 25 | for Library_Kind use "static"; 26 | 27 | -------------- 28 | -- Compiler -- 29 | -------------- 30 | 31 | package Compiler is 32 | case Mode is 33 | when "Devel" => 34 | for Default_Switches ("ada") use 35 | ("-g", "-gnatQ", "-O1", "-gnatf", "-gnato", 36 | "-gnatwa.Xe", "-gnaty"); 37 | 38 | when "Install" => 39 | for Default_Switches ("ada") use 40 | ("-O2", "-gnatp", "-gnatn", "-gnatwa.X"); 41 | end case; 42 | 43 | for Switches ("aunit.adb") use 44 | Compiler'Default_Switches ("ada") & ("-fno-strict-aliasing"); 45 | end Compiler; 46 | 47 | ------------- 48 | -- Install -- 49 | ------------- 50 | 51 | package Install is 52 | for Artifacts ("share/doc/aunit/pdf") 53 | use ("../../doc/pdf/**"); 54 | for Artifacts ("share/doc/aunit/txt") 55 | use ("../../doc/txt/**"); 56 | for Artifacts ("share/doc/aunit/info") 57 | use ("../../doc/info/**"); 58 | for Artifacts ("share/doc/aunit/html") 59 | use ("../../doc/html/**"); 60 | 61 | for Artifacts ("share/gps/plug-ins") use ("../../support/aunit.xml"); 62 | for Artifacts ("share/examples/aunit") use ("../../examples/*"); 63 | end Install; 64 | 65 | end AUnit; 66 | -------------------------------------------------------------------------------- /include/aunit/framework/aunit-reporter.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- -- 3 | -- GNAT COMPILER COMPONENTS -- 4 | -- -- 5 | -- A U N I T . R E P O R T E R -- 6 | -- -- 7 | -- B o d y -- 8 | -- -- 9 | -- -- 10 | -- Copyright (C) 2019, AdaCore -- 11 | -- -- 12 | -- GNAT is free software; you can redistribute it and/or modify it under -- 13 | -- terms of the GNU General Public License as published by the Free Soft- -- 14 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 15 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 16 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 17 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- 18 | -- -- 19 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 20 | -- additional permissions described in the GCC Runtime Library Exception, -- 21 | -- version 3.1, as published by the Free Software Foundation. -- 22 | -- -- 23 | -- You should have received a copy of the GNU General Public License and -- 24 | -- a copy of the GCC Runtime Library Exception along with this program; -- 25 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 26 | -- . -- 27 | -- -- 28 | -- GNAT is maintained by AdaCore (http://www.adacore.com) -- 29 | -- -- 30 | ------------------------------------------------------------------------------ 31 | 32 | package body AUnit.Reporter is 33 | 34 | procedure Set_File 35 | (Engine : in out Reporter; 36 | Value : AUnit.IO.File_Access) is 37 | begin 38 | Engine.File := Value; 39 | end Set_File; 40 | 41 | end AUnit.Reporter; 42 | -------------------------------------------------------------------------------- /include/aunit/framework/nodealloc/aunit-memory-utils.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- -- 3 | -- GNAT COMPILER COMPONENTS -- 4 | -- -- 5 | -- A U N I T . M E M O R Y . U T I L S -- 6 | -- -- 7 | -- B o d y -- 8 | -- -- 9 | -- -- 10 | -- Copyright (C) 2008-2012, AdaCore -- 11 | -- -- 12 | -- GNAT is free software; you can redistribute it and/or modify it under -- 13 | -- terms of the GNU General Public License as published by the Free Soft- -- 14 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 15 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 16 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 17 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- 18 | -- -- 19 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 20 | -- additional permissions described in the GCC Runtime Library Exception, -- 21 | -- version 3.1, as published by the Free Software Foundation. -- 22 | -- -- 23 | -- You should have received a copy of the GNU General Public License and -- 24 | -- a copy of the GCC Runtime Library Exception along with this program; -- 25 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 26 | -- . -- 27 | -- -- 28 | -- GNAT is maintained by AdaCore (http://www.adacore.com) -- 29 | -- -- 30 | ------------------------------------------------------------------------------ 31 | 32 | package body AUnit.Memory.Utils is 33 | 34 | --------------- 35 | -- Gen_Alloc -- 36 | --------------- 37 | 38 | function Gen_Alloc return Name is 39 | begin 40 | return new Object; 41 | end Gen_Alloc; 42 | 43 | end AUnit.Memory.Utils; 44 | -------------------------------------------------------------------------------- /include/aunit/framework/nativememory/aunit-memory-utils.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- -- 3 | -- GNAT COMPILER COMPONENTS -- 4 | -- -- 5 | -- A U N I T . M E M O R Y . U T I L S -- 6 | -- -- 7 | -- B o d y -- 8 | -- -- 9 | -- -- 10 | -- Copyright (C) 2008-2012, AdaCore -- 11 | -- -- 12 | -- GNAT is free software; you can redistribute it and/or modify it under -- 13 | -- terms of the GNU General Public License as published by the Free Soft- -- 14 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 15 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 16 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 17 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- 18 | -- -- 19 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 20 | -- additional permissions described in the GCC Runtime Library Exception, -- 21 | -- version 3.1, as published by the Free Software Foundation. -- 22 | -- -- 23 | -- You should have received a copy of the GNU General Public License and -- 24 | -- a copy of the GCC Runtime Library Exception along with this program; -- 25 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 26 | -- . -- 27 | -- -- 28 | -- GNAT is maintained by AdaCore (http://www.adacore.com) -- 29 | -- -- 30 | ------------------------------------------------------------------------------ 31 | 32 | package body AUnit.Memory.Utils is 33 | 34 | --------------- 35 | -- Gen_Alloc -- 36 | --------------- 37 | 38 | function Gen_Alloc return Name is 39 | begin 40 | return new Object; 41 | end Gen_Alloc; 42 | 43 | end AUnit.Memory.Utils; 44 | -------------------------------------------------------------------------------- /include/aunit/framework/aunit-tests.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- -- 3 | -- GNAT COMPILER COMPONENTS -- 4 | -- -- 5 | -- A U N I T . T E S T S -- 6 | -- -- 7 | -- S p e c -- 8 | -- -- 9 | -- Copyright (C) 2000-2011, AdaCore -- 10 | -- -- 11 | -- GNAT is free software; you can redistribute it and/or modify it under -- 12 | -- terms of the GNU General Public License as published by the Free Soft- -- 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 14 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- 17 | -- -- 18 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 19 | -- additional permissions described in the GCC Runtime Library Exception, -- 20 | -- version 3.1, as published by the Free Software Foundation. -- 21 | -- -- 22 | -- You should have received a copy of the GNU General Public License and -- 23 | -- a copy of the GCC Runtime Library Exception along with this program; -- 24 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25 | -- . -- 26 | -- -- 27 | -- GNAT is maintained by AdaCore (http://www.adacore.com). -- 28 | -- -- 29 | ------------------------------------------------------------------------------ 30 | 31 | -- Base Test Case or Test Suite 32 | -- 33 | -- This base type allows composition of both test cases and sub-suites into a 34 | -- test suite (Composite pattern) 35 | 36 | package AUnit.Tests is 37 | 38 | type Test is abstract tagged limited private; 39 | type Test_Access is access all Test'Class; 40 | 41 | private 42 | 43 | type Test is abstract tagged limited null record; 44 | 45 | end AUnit.Tests; 46 | -------------------------------------------------------------------------------- /include/aunit/framework/aunit-memory-utils.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- -- 3 | -- GNAT COMPILER COMPONENTS -- 4 | -- -- 5 | -- A U N I T . M E M O R Y . U T I L S -- 6 | -- -- 7 | -- S p e c -- 8 | -- -- 9 | -- -- 10 | -- Copyright (C) 2008-2011, AdaCore -- 11 | -- -- 12 | -- GNAT is free software; you can redistribute it and/or modify it under -- 13 | -- terms of the GNU General Public License as published by the Free Soft- -- 14 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 15 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 16 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 17 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- 18 | -- -- 19 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 20 | -- additional permissions described in the GCC Runtime Library Exception, -- 21 | -- version 3.1, as published by the Free Software Foundation. -- 22 | -- -- 23 | -- You should have received a copy of the GNU General Public License and -- 24 | -- a copy of the GCC Runtime Library Exception along with this program; -- 25 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 26 | -- . -- 27 | -- -- 28 | -- GNAT is maintained by AdaCore (http://www.adacore.com) -- 29 | -- -- 30 | ------------------------------------------------------------------------------ 31 | 32 | -- Provides Gen_Alloc, easing the allocation of objects within AUnit. 33 | 34 | package AUnit.Memory.Utils is 35 | 36 | generic 37 | type Object is limited private; 38 | type Name is access Object; 39 | pragma No_Strict_Aliasing (Name); 40 | function Gen_Alloc return Name; 41 | 42 | end AUnit.Memory.Utils; 43 | -------------------------------------------------------------------------------- /include/aunit/reporters/aunit-reporter-xml.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- -- 3 | -- GNAT COMPILER COMPONENTS -- 4 | -- -- 5 | -- A U N I T . R E P O R T E R . X M L -- 6 | -- -- 7 | -- S p e c -- 8 | -- -- 9 | -- -- 10 | -- Copyright (C) 2000-2013, AdaCore -- 11 | -- -- 12 | -- GNAT is free software; you can redistribute it and/or modify it under -- 13 | -- terms of the GNU General Public License as published by the Free Soft- -- 14 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 15 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 16 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 17 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- 18 | -- -- 19 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 20 | -- additional permissions described in the GCC Runtime Library Exception, -- 21 | -- version 3.1, as published by the Free Software Foundation. -- 22 | -- -- 23 | -- You should have received a copy of the GNU General Public License and -- 24 | -- a copy of the GCC Runtime Library Exception along with this program; -- 25 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 26 | -- . -- 27 | -- -- 28 | -- GNAT is maintained by AdaCore (http://www.adacore.com) -- 29 | -- -- 30 | ------------------------------------------------------------------------------ 31 | 32 | -- Very simple reporter to console 33 | package AUnit.Reporter.XML is 34 | 35 | type XML_Reporter is new Reporter with null record; 36 | 37 | procedure Report (Engine : XML_Reporter; 38 | R : in out Result'Class; 39 | Options : AUnit_Options := Default_Options); 40 | end AUnit.Reporter.XML; 41 | -------------------------------------------------------------------------------- /test/src/aunit-test_cases-tests.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2009-2010, AdaCore 3 | -- 4 | 5 | with AUnit.Assertions; use AUnit.Assertions; 6 | 7 | package body AUnit.Test_Cases.Tests is 8 | 9 | ------------------------- 10 | -- Test_Register_Tests -- 11 | ------------------------- 12 | 13 | procedure Test_Register_Tests (T : in out Fixture) 14 | is 15 | Old_Count : constant Count_Type := 16 | Registration.Routine_Count (T.TC); 17 | Routines_In_Simple : constant := 4; 18 | begin 19 | Register_Tests (T.TC); 20 | 21 | Assert 22 | (Test_Cases.Registration.Routine_Count (T.TC) = 23 | Old_Count + Routines_In_Simple, 24 | "Routine not properly registered"); 25 | end Test_Register_Tests; 26 | 27 | ----------------- 28 | -- Test_Set_Up -- 29 | ----------------- 30 | 31 | procedure Test_Set_Up (T : in out Fixture) is 32 | Was_Reset : constant Boolean := not Is_Set_Up (T.TC); 33 | begin 34 | Set_Up (T.TC); 35 | 36 | Assert 37 | (Was_Reset and Is_Set_Up (T.TC), 38 | "Not set up correctly"); 39 | end Test_Set_Up; 40 | 41 | -------------------- 42 | -- Test_Torn_Down -- 43 | -------------------- 44 | 45 | procedure Test_Torn_Down (T : in out Fixture) is 46 | Was_Reset : constant Boolean := not Is_Torn_Down (T.TC); 47 | begin 48 | Tear_Down (T.TC); 49 | 50 | Assert 51 | (Was_Reset and Is_Torn_Down (T.TC), 52 | "Not torn down correctly"); 53 | end Test_Torn_Down; 54 | 55 | -------------- 56 | -- Test_Run -- 57 | -------------- 58 | 59 | procedure Test_Run (T : in out Fixture) is 60 | Count : constant Count_Type := 61 | Test_Cases.Registration.Routine_Count (T.TC); 62 | Outcome : AUnit.Status; 63 | R : Result; 64 | 65 | begin 66 | Run (T.TC'Access, AUnit.Options.Default_Options, R, Outcome); 67 | 68 | Assert 69 | (Count = 4, 70 | "Not enough routines in simple test case"); 71 | 72 | Assert 73 | (Test_Count (R) = Count, 74 | "Not all requested routines were run"); 75 | 76 | -- There are supposed to be two failed assertions for one routine 77 | -- in R, so we expect Count + Old_Count + 1: 78 | Assert 79 | (Success_Count (R) + Failure_Count (R) + Error_Count (R) 80 | = Count + 1, 81 | "Not all requested routines are recorded"); 82 | 83 | Assert (Is_Torn_Down (T.TC), "Not torn down correctly"); 84 | Assert (Success_Count (R) = 1, "Wrong success count"); 85 | Assert (Failure_Count (R) = 3, "Wrong failures count"); 86 | Assert (Error_Count (R) = 1, "Wrong errors count"); 87 | Assert (Outcome = Failure, "Result flag incorrect"); 88 | end Test_Run; 89 | 90 | end AUnit.Test_Cases.Tests; 91 | -------------------------------------------------------------------------------- /include/aunit/reporters/aunit-reporter-junit.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- -- 3 | -- GNAT COMPILER COMPONENTS -- 4 | -- -- 5 | -- A U N I T . R E P O R T E R . J U N I T -- 6 | -- -- 7 | -- S p e c -- 8 | -- -- 9 | -- -- 10 | -- Copyright (C) 2020, AdaCore -- 11 | -- -- 12 | -- GNAT is free software; you can redistribute it and/or modify it under -- 13 | -- terms of the GNU General Public License as published by the Free Soft- -- 14 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 15 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 16 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 17 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- 18 | -- -- 19 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 20 | -- additional permissions described in the GCC Runtime Library Exception, -- 21 | -- version 3.1, as published by the Free Software Foundation. -- 22 | -- -- 23 | -- You should have received a copy of the GNU General Public License and -- 24 | -- a copy of the GCC Runtime Library Exception along with this program; -- 25 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 26 | -- . -- 27 | -- -- 28 | -- GNAT is maintained by AdaCore (http://www.adacore.com) -- 29 | -- -- 30 | ------------------------------------------------------------------------------ 31 | 32 | -- jenkins-junit.xsd compatible reporter to file. 33 | package AUnit.Reporter.JUnit is 34 | 35 | type JUnit_Reporter is new Reporter with null record; 36 | 37 | procedure Report (Engine : JUnit_Reporter; 38 | R : in out Result'Class; 39 | Options : AUnit_Options := Default_Options); 40 | 41 | end AUnit.Reporter.JUnit; 42 | -------------------------------------------------------------------------------- /include/aunit/reporters/aunit-reporter-gnattest.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- -- 3 | -- GNAT COMPILER COMPONENTS -- 4 | -- -- 5 | -- A U N I T . R E P O R T E R . G N A T T E S T -- 6 | -- -- 7 | -- S p e c -- 8 | -- -- 9 | -- -- 10 | -- Copyright (C) 2012-2013, AdaCore -- 11 | -- -- 12 | -- GNAT is free software; you can redistribute it and/or modify it under -- 13 | -- terms of the GNU General Public License as published by the Free Soft- -- 14 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 15 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 16 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 17 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- 18 | -- -- 19 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 20 | -- additional permissions described in the GCC Runtime Library Exception, -- 21 | -- version 3.1, as published by the Free Software Foundation. -- 22 | -- -- 23 | -- You should have received a copy of the GNU General Public License and -- 24 | -- a copy of the GCC Runtime Library Exception along with this program; -- 25 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 26 | -- . -- 27 | -- -- 28 | -- GNAT is maintained by AdaCore (http://www.adacore.com) -- 29 | -- -- 30 | ------------------------------------------------------------------------------ 31 | 32 | -- Reporter intended to be used by test drivers generated by gnattest. 33 | 34 | package AUnit.Reporter.GNATtest is 35 | 36 | type GNATtest_Reporter is new Reporter with null record; 37 | 38 | procedure Report (Engine : GNATtest_Reporter; 39 | R : in out Result'Class; 40 | Options : AUnit_Options := Default_Options); 41 | end AUnit.Reporter.GNATtest; 42 | -------------------------------------------------------------------------------- /doc/Makefile: -------------------------------------------------------------------------------- 1 | # Makefile for Sphinx documentation 2 | 3 | # You can set these variables from the command line. 4 | SPHINXOPTS = 5 | SPHINXBUILD = DOC_NAME=$* sphinx-build 6 | PAPER = 7 | BUILDDIR = build 8 | SOURCEDIR = . 9 | 10 | # Internal variables. 11 | PAPEROPT_a4 = -D latex_paper_size=a4 12 | PAPEROPT_letter = -D latex_paper_size=letter 13 | ALLSPHINXOPTS = $(PAPEROPT_$(PAPER)) $(SPHINXOPTS) \ 14 | -c $(SOURCEDIR)/share \ 15 | -d $(BUILDDIR)/$*/doctrees \ 16 | $(SOURCEDIR) 17 | DOC_LIST=aunit_cb 18 | FMT_LIST=html pdf txt info 19 | 20 | .PHONY: all help clean 21 | 22 | all: $(foreach doc, $(DOC_LIST), $(doc).all) 23 | 24 | help: 25 | @echo "Please use \`make ' where is one of" 26 | @echo " DOC_NAME.html to make standalone HTML files" 27 | @echo " DOC_NAME.pdf to make LaTeX files and run them through pdflatex" 28 | @echo " DOC_NAME.txt to make text files" 29 | @echo " DOC_NAME.texinfo to make Texinfo files" 30 | @echo " DOC_NAME.info to make info files" 31 | @echo " DOC_NAME.all to build DOC_NAME for all previous formats" 32 | @echo " all to build all documentations in all formats" 33 | @echo " html-all same as previous rule but only for HTML format" 34 | @echo " pdf-all same as previous rule but only for PDF format" 35 | @echo " txt-all same as previous rule but only for text format" 36 | @echo " texinfo-all same as previous rule but only for texinfo format" 37 | @echo " info-all same as previous rule but only for info format" 38 | @echo "" 39 | @echo "DOC_NAME should be a documentation name in the following list:" 40 | @echo " $(DOC_LIST)" 41 | @echo "" 42 | @echo "source and location can be overriden using SOURCEDIR and BUILDDIR variables" 43 | 44 | clean: 45 | -rm -rf $(BUILDDIR)/*/html \ 46 | $(BUILDDIR)/*/pdf \ 47 | $(BUILDDIR)/*/txt \ 48 | $(BUILDDIR)/*/info \ 49 | $(BUILDDIR)/*/doctrees \ 50 | share/__pycache__ 51 | 52 | %.html: 53 | $(SPHINXBUILD) -b html $(ALLSPHINXOPTS) $(BUILDDIR)/$*/html 54 | 55 | %.pdf: 56 | $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/$*/pdf 57 | $(MAKE) -C $(BUILDDIR)/$*/pdf all-pdf LATEXOPTS="-interaction=nonstopmode" 58 | 59 | %.txt: 60 | $(SPHINXBUILD) -b texinfo $(ALLSPHINXOPTS) $(BUILDDIR)/$*/txt 61 | $(MAKE) -C $(BUILDDIR)/$*/txt plaintext 62 | 63 | %.info: 64 | $(SPHINXBUILD) -b texinfo $(ALLSPHINXOPTS) $(BUILDDIR)/$*/info 65 | $(MAKE) -C $(BUILDDIR)/$*/info info 66 | 67 | %.texinfo: 68 | $(SPHINXBUILD) -b texinfo $(ALLSPHINXOPTS) $(BUILDDIR)/$*/texinfo 69 | 70 | html-all: $(foreach doc, $(DOC_LIST), $(doc).html) 71 | 72 | pdf-all: $(foreach doc, $(DOC_LIST), $(doc).pdf) 73 | 74 | txt-all: $(foreach doc, $(DOC_LIST), $(doc).txt) 75 | 76 | texinfo-all: $(foreach doc, $(DOC_LIST), $(doc).texinfo) 77 | 78 | %.all: 79 | $(MAKE) $(foreach fmt, $(FMT_LIST), $*.$(fmt)) 80 | -------------------------------------------------------------------------------- /include/aunit/framework/aunit.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- -- 3 | -- GNAT COMPILER COMPONENTS -- 4 | -- -- 5 | -- A U N I T -- 6 | -- -- 7 | -- S p e c -- 8 | -- -- 9 | -- -- 10 | -- Copyright (C) 2006-2011, AdaCore -- 11 | -- -- 12 | -- GNAT is free software; you can redistribute it and/or modify it under -- 13 | -- terms of the GNU General Public License as published by the Free Soft- -- 14 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 15 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 16 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 17 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- 18 | -- -- 19 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 20 | -- additional permissions described in the GCC Runtime Library Exception, -- 21 | -- version 3.1, as published by the Free Software Foundation. -- 22 | -- -- 23 | -- You should have received a copy of the GNU General Public License and -- 24 | -- a copy of the GCC Runtime Library Exception along with this program; -- 25 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 26 | -- . -- 27 | -- -- 28 | -- GNAT is maintained by AdaCore (http://www.adacore.com) -- 29 | -- -- 30 | ------------------------------------------------------------------------------ 31 | 32 | -- Test Suite Framework 33 | 34 | package AUnit is 35 | 36 | type Message_String is access String; 37 | 38 | subtype Test_String is Message_String; 39 | 40 | type Status is (Success, Failure); 41 | 42 | -- String manipulation functions. 43 | 44 | function Format (S : String) return Message_String; 45 | function Message_Alloc (Length : Natural) return Message_String; 46 | procedure Message_Free (Msg : in out Message_String); 47 | 48 | end AUnit; 49 | -------------------------------------------------------------------------------- /include/aunit/framework/aunit-test_fixtures.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- -- 3 | -- GNAT COMPILER COMPONENTS -- 4 | -- -- 5 | -- A U N I T . T E S T _ F I X T U R E S -- 6 | -- -- 7 | -- B o d y -- 8 | -- -- 9 | -- -- 10 | -- Copyright (C) 2008-2011, AdaCore -- 11 | -- -- 12 | -- GNAT is free software; you can redistribute it and/or modify it under -- 13 | -- terms of the GNU General Public License as published by the Free Soft- -- 14 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 15 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 16 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 17 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- 18 | -- -- 19 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 20 | -- additional permissions described in the GCC Runtime Library Exception, -- 21 | -- version 3.1, as published by the Free Software Foundation. -- 22 | -- -- 23 | -- You should have received a copy of the GNU General Public License and -- 24 | -- a copy of the GCC Runtime Library Exception along with this program; -- 25 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 26 | -- . -- 27 | -- -- 28 | -- GNAT is maintained by AdaCore (http://www.adacore.com) -- 29 | -- -- 30 | ------------------------------------------------------------------------------ 31 | 32 | package body AUnit.Test_Fixtures is 33 | 34 | ------------ 35 | -- Set_Up -- 36 | ------------ 37 | 38 | procedure Set_Up (Test : in out Test_Fixture) is 39 | pragma Unreferenced (Test); 40 | begin 41 | null; 42 | end Set_Up; 43 | 44 | --------------- 45 | -- Tear_Down -- 46 | --------------- 47 | 48 | procedure Tear_Down (Test : in out Test_Fixture) is 49 | pragma Unreferenced (Test); 50 | begin 51 | null; 52 | end Tear_Down; 53 | 54 | end AUnit.Test_Fixtures; 55 | -------------------------------------------------------------------------------- /include/aunit/framework/certexception/aunit-assertions-assert_exception.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- -- 3 | -- GNAT COMPILER COMPONENTS -- 4 | -- -- 5 | -- A U N I T . A S S E R T I O N S -- 6 | -- -- 7 | -- B o d y -- 8 | -- -- 9 | -- -- 10 | -- Copyright (C) 2000-2011, AdaCore -- 11 | -- -- 12 | -- GNAT is free software; you can redistribute it and/or modify it under -- 13 | -- terms of the GNU General Public License as published by the Free Soft- -- 14 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 15 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 16 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 17 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- 18 | -- -- 19 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 20 | -- additional permissions described in the GCC Runtime Library Exception, -- 21 | -- version 3.1, as published by the Free Software Foundation. -- 22 | -- -- 23 | -- You should have received a copy of the GNU General Public License and -- 24 | -- a copy of the GCC Runtime Library Exception along with this program; -- 25 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 26 | -- . -- 27 | -- -- 28 | -- GNAT is maintained by AdaCore (http://www.adacore.com) -- 29 | -- -- 30 | ------------------------------------------------------------------------------ 31 | 32 | -- Version for cert run-time libraries that support exception handling 33 | separate (AUnit.Assertions) 34 | procedure Assert_Exception 35 | (Proc : Throwing_Exception_Proc; 36 | Message : String; 37 | Source : String := GNAT.Source_Info.File; 38 | Line : Natural := GNAT.Source_Info.Line) 39 | is 40 | begin 41 | Proc.all; 42 | -- No exception raised: register the failure message 43 | Assert (False, Message, Source, Line); 44 | 45 | exception 46 | when others => 47 | null; 48 | end Assert_Exception; 49 | -------------------------------------------------------------------------------- /include/aunit/framework/fullexception/aunit-assertions-assert_exception.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- -- 3 | -- GNAT COMPILER COMPONENTS -- 4 | -- -- 5 | -- A U N I T . A S S E R T I O N S -- 6 | -- -- 7 | -- B o d y -- 8 | -- -- 9 | -- -- 10 | -- Copyright (C) 2000-2011, AdaCore -- 11 | -- -- 12 | -- GNAT is free software; you can redistribute it and/or modify it under -- 13 | -- terms of the GNU General Public License as published by the Free Soft- -- 14 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 15 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 16 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 17 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- 18 | -- -- 19 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 20 | -- additional permissions described in the GCC Runtime Library Exception, -- 21 | -- version 3.1, as published by the Free Software Foundation. -- 22 | -- -- 23 | -- You should have received a copy of the GNU General Public License and -- 24 | -- a copy of the GCC Runtime Library Exception along with this program; -- 25 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 26 | -- . -- 27 | -- -- 28 | -- GNAT is maintained by AdaCore (http://www.adacore.com) -- 29 | -- -- 30 | ------------------------------------------------------------------------------ 31 | 32 | -- Version for run-time libraries that support exception handling 33 | 34 | separate (AUnit.Assertions) 35 | procedure Assert_Exception 36 | (Proc : Throwing_Exception_Proc; 37 | Message : String; 38 | Source : String := GNAT.Source_Info.File; 39 | Line : Natural := GNAT.Source_Info.Line) 40 | is 41 | begin 42 | begin 43 | Proc.all; 44 | exception 45 | when others => 46 | return; 47 | end; 48 | 49 | -- No exception raised: register the failure message 50 | Assert (False, Message, Source, Line); 51 | 52 | end Assert_Exception; 53 | -------------------------------------------------------------------------------- /include/aunit/framework/aunit-options.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- -- 3 | -- GNAT COMPILER COMPONENTS -- 4 | -- -- 5 | -- A U N I T . O P T I O N S -- 6 | -- -- 7 | -- S p e c -- 8 | -- -- 9 | -- -- 10 | -- Copyright (C) 2009-2013, AdaCore -- 11 | -- -- 12 | -- GNAT is free software; you can redistribute it and/or modify it under -- 13 | -- terms of the GNU General Public License as published by the Free Soft- -- 14 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 15 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 16 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 17 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- 18 | -- -- 19 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 20 | -- additional permissions described in the GCC Runtime Library Exception, -- 21 | -- version 3.1, as published by the Free Software Foundation. -- 22 | -- -- 23 | -- You should have received a copy of the GNU General Public License and -- 24 | -- a copy of the GCC Runtime Library Exception along with this program; -- 25 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 26 | -- . -- 27 | -- -- 28 | -- GNAT is maintained by AdaCore (http://www.adacore.com) -- 29 | -- -- 30 | ------------------------------------------------------------------------------ 31 | 32 | with AUnit.Test_Filters; 33 | 34 | package AUnit.Options is 35 | 36 | type AUnit_Options is record 37 | Global_Timer : Boolean := False; 38 | Test_Case_Timer : Boolean := False; 39 | Report_Successes : Boolean := True; 40 | Filter : AUnit.Test_Filters.Test_Filter_Access := null; 41 | end record; 42 | -- Options used to determine how a test should be run. 43 | 44 | Default_Options : constant AUnit_Options := 45 | (Global_Timer => False, 46 | Test_Case_Timer => False, 47 | Report_Successes => True, 48 | Filter => null); 49 | 50 | end AUnit.Options; 51 | -------------------------------------------------------------------------------- /include/aunit/framework/aunit-memory.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- -- 3 | -- GNAT COMPILER COMPONENTS -- 4 | -- -- 5 | -- A U N I T . M E M O R Y -- 6 | -- -- 7 | -- S p e c -- 8 | -- -- 9 | -- -- 10 | -- Copyright (C) 2008-2011, AdaCore -- 11 | -- -- 12 | -- GNAT is free software; you can redistribute it and/or modify it under -- 13 | -- terms of the GNU General Public License as published by the Free Soft- -- 14 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 15 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 16 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 17 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- 18 | -- -- 19 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 20 | -- additional permissions described in the GCC Runtime Library Exception, -- 21 | -- version 3.1, as published by the Free Software Foundation. -- 22 | -- -- 23 | -- You should have received a copy of the GNU General Public License and -- 24 | -- a copy of the GCC Runtime Library Exception along with this program; -- 25 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 26 | -- . -- 27 | -- -- 28 | -- GNAT is maintained by AdaCore (http://www.adacore.com) -- 29 | -- -- 30 | ------------------------------------------------------------------------------ 31 | 32 | -- Provides the memory handling mechanism used by AUnit. This allows in 33 | -- particular AUnit to use dynamic allocation even on limited run-times that 34 | -- do not provide memory management. 35 | -- See also AUnit.Memory.Utils that provides an easy to use allocator for 36 | -- complex objects. 37 | 38 | with System; 39 | 40 | package AUnit.Memory is 41 | 42 | type size_t is mod 2 ** Standard'Address_Size; 43 | 44 | function AUnit_Alloc (Size : size_t) return System.Address; 45 | 46 | procedure AUnit_Free (Obj : System.Address); 47 | 48 | private 49 | 50 | pragma Inline (AUnit_Alloc); 51 | pragma Inline (AUnit_Free); 52 | 53 | end AUnit.Memory; 54 | -------------------------------------------------------------------------------- /include/aunit/framework/nofileio/aunit-io.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- -- 3 | -- GNAT COMPILER COMPONENTS -- 4 | -- -- 5 | -- A U N I T . R E P O R T E R -- 6 | -- -- 7 | -- S p e c -- 8 | -- -- 9 | -- -- 10 | -- Copyright (C) 2019, AdaCore -- 11 | -- -- 12 | -- GNAT is free software; you can redistribute it and/or modify it under -- 13 | -- terms of the GNU General Public License as published by the Free Soft- -- 14 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 15 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 16 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 17 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- 18 | -- -- 19 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 20 | -- additional permissions described in the GCC Runtime Library Exception, -- 21 | -- version 3.1, as published by the Free Software Foundation. -- 22 | -- -- 23 | -- You should have received a copy of the GNU General Public License and -- 24 | -- a copy of the GCC Runtime Library Exception along with this program; -- 25 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 26 | -- . -- 27 | -- -- 28 | -- GNAT is maintained by AdaCore (http://www.adacore.com) -- 29 | -- -- 30 | ------------------------------------------------------------------------------ 31 | 32 | package AUnit.IO is 33 | 34 | type File_Type is new Integer; 35 | 36 | type File_Access is access constant File_Type; 37 | 38 | function Standard_Output 39 | return File_Access; 40 | 41 | procedure Put (File : File_Type; 42 | Item : Integer; 43 | Width : Integer := 0; 44 | Base : Integer := 0); 45 | 46 | procedure Put (File : File_Type; 47 | Item : String); 48 | 49 | procedure Put_Line (File : File_Type; 50 | Item : String); 51 | 52 | procedure New_Line (File : File_Type; 53 | Spacing : Positive := 1); 54 | 55 | end AUnit.IO; 56 | -------------------------------------------------------------------------------- /include/aunit/framework/staticmemory/aunit-memory-utils.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- -- 3 | -- GNAT COMPILER COMPONENTS -- 4 | -- -- 5 | -- A U N I T . M E M O R Y . U T I L S -- 6 | -- -- 7 | -- B o d y -- 8 | -- -- 9 | -- -- 10 | -- Copyright (C) 2008-2012, AdaCore -- 11 | -- -- 12 | -- GNAT is free software; you can redistribute it and/or modify it under -- 13 | -- terms of the GNU General Public License as published by the Free Soft- -- 14 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 15 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 16 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 17 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- 18 | -- -- 19 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 20 | -- additional permissions described in the GCC Runtime Library Exception, -- 21 | -- version 3.1, as published by the Free Software Foundation. -- 22 | -- -- 23 | -- You should have received a copy of the GNU General Public License and -- 24 | -- a copy of the GCC Runtime Library Exception along with this program; -- 25 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 26 | -- . -- 27 | -- -- 28 | -- GNAT is maintained by AdaCore (http://www.adacore.com) -- 29 | -- -- 30 | ------------------------------------------------------------------------------ 31 | 32 | with Ada.Unchecked_Conversion; 33 | 34 | package body AUnit.Memory.Utils is 35 | 36 | --------------- 37 | -- Gen_Alloc -- 38 | --------------- 39 | 40 | function Gen_Alloc return Name is 41 | function To_Name is new Ada.Unchecked_Conversion (System.Address, Name); 42 | Ret : constant System.Address := AUnit_Alloc (Object'Object_Size / 8); 43 | -- Declare an actual object at Ret Address so that the default 44 | -- initialisation is performed. 45 | Obj : Object; 46 | for Obj'Address use Ret; 47 | pragma Warnings (Off, Obj); 48 | begin 49 | return To_Name (Ret); 50 | end Gen_Alloc; 51 | 52 | end AUnit.Memory.Utils; 53 | -------------------------------------------------------------------------------- /include/aunit/framework/certexception/aunit-test_cases-call_set_up_case.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- -- 3 | -- GNAT COMPILER COMPONENTS -- 4 | -- -- 5 | -- A U N I T . T E S T _ C A S E S -- 6 | -- -- 7 | -- B o d y -- 8 | -- -- 9 | -- -- 10 | -- Copyright (C) 2000-2019, AdaCore -- 11 | -- -- 12 | -- GNAT is free software; you can redistribute it and/or modify it under -- 13 | -- terms of the GNU General Public License as published by the Free Soft- -- 14 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 15 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 16 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 17 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- 18 | -- -- 19 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 20 | -- additional permissions described in the GCC Runtime Library Exception, -- 21 | -- version 3.1, as published by the Free Software Foundation. -- 22 | -- -- 23 | -- You should have received a copy of the GNU General Public License and -- 24 | -- a copy of the GCC Runtime Library Exception along with this program; -- 25 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 26 | -- . -- 27 | -- -- 28 | -- GNAT is maintained by AdaCore (http://www.adacore.com) -- 29 | -- -- 30 | ------------------------------------------------------------------------------ 31 | 32 | with Ada.Exceptions; use Ada.Exceptions; 33 | with AUnit.Memory.Utils; use AUnit.Memory.Utils; 34 | 35 | separate (AUnit.Test_Cases) 36 | function Call_Set_Up_Case 37 | (Test : in out Test_Case'Class) return Test_Error_Access is 38 | function Alloc_Error is new Gen_Alloc (Test_Error, Test_Error_Access); 39 | begin 40 | Set_Up_Case (Test); 41 | return null; 42 | exception when E : others => 43 | return Error : constant Test_Error_Access := Alloc_Error do 44 | Error.Exception_Name := Format (Exception_Name (E)); 45 | Error.Exception_Message := null; 46 | Error.Traceback := null; 47 | end return; 48 | end Call_Set_Up_Case; 49 | -------------------------------------------------------------------------------- /include/aunit/framework/nodealloc/aunit-memory.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- -- 3 | -- GNAT RUN-TIME COMPONENTS -- 4 | -- -- 5 | -- A U N I T . M E M O R Y -- 6 | -- -- 7 | -- B o d y -- 8 | -- -- 9 | -- Copyright (C) 2001-2003 Free Software Foundation, Inc. -- 10 | -- Copyright (C) 2008-2018, AdaCore -- 11 | -- -- 12 | -- GNAT is free software; you can redistribute it and/or modify it under -- 13 | -- terms of the GNU General Public License as published by the Free Soft- -- 14 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 15 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 16 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 17 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- 18 | -- -- 19 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 20 | -- additional permissions described in the GCC Runtime Library Exception, -- 21 | -- version 3.1, as published by the Free Software Foundation. -- 22 | -- -- 23 | -- You should have received a copy of the GNU General Public License and -- 24 | -- a copy of the GCC Runtime Library Exception along with this program; -- 25 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 26 | -- . -- 27 | -- -- 28 | -- GNAT is maintained by AdaCore (http://www.adacore.com) -- 29 | -- -- 30 | ------------------------------------------------------------------------------ 31 | 32 | -- Memory allocation implementation using the gnat runtime methods with 33 | -- no support for deallocation. 34 | 35 | package body AUnit.Memory is 36 | 37 | ----------- 38 | -- Alloc -- 39 | ----------- 40 | 41 | function AUnit_Alloc (Size : size_t) return System.Address is 42 | function RT_Malloc (Size : size_t) return System.Address; 43 | pragma Import (C, RT_Malloc, "__gnat_malloc"); 44 | begin 45 | return RT_Malloc (Size); 46 | end AUnit_Alloc; 47 | 48 | ---------- 49 | -- Free -- 50 | ---------- 51 | 52 | procedure AUnit_Free (Obj : System.Address) is 53 | pragma Unreferenced (Obj); 54 | begin 55 | null; 56 | end AUnit_Free; 57 | 58 | end AUnit.Memory; 59 | -------------------------------------------------------------------------------- /include/aunit/framework/nativememory/aunit-memory.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- -- 3 | -- GNAT RUN-TIME COMPONENTS -- 4 | -- -- 5 | -- A U N I T . M E M O R Y -- 6 | -- -- 7 | -- B o d y -- 8 | -- -- 9 | -- Copyright (C) 2001-2003 Free Software Foundation, Inc. -- 10 | -- Copyright (C) 2008-2011, AdaCore -- 11 | -- -- 12 | -- GNAT is free software; you can redistribute it and/or modify it under -- 13 | -- terms of the GNU General Public License as published by the Free Soft- -- 14 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 15 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 16 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 17 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- 18 | -- -- 19 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 20 | -- additional permissions described in the GCC Runtime Library Exception, -- 21 | -- version 3.1, as published by the Free Software Foundation. -- 22 | -- -- 23 | -- You should have received a copy of the GNU General Public License and -- 24 | -- a copy of the GCC Runtime Library Exception along with this program; -- 25 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 26 | -- . -- 27 | -- -- 28 | -- GNAT is maintained by AdaCore (http://www.adacore.com) -- 29 | -- -- 30 | ------------------------------------------------------------------------------ 31 | 32 | -- Memory allocation implementation using the gnat runtime methods. 33 | 34 | package body AUnit.Memory is 35 | 36 | ----------- 37 | -- Alloc -- 38 | ----------- 39 | 40 | function AUnit_Alloc (Size : size_t) return System.Address is 41 | function RT_Malloc (Size : size_t) return System.Address; 42 | pragma Import (C, RT_Malloc, "__gnat_malloc"); 43 | begin 44 | return RT_Malloc (Size); 45 | end AUnit_Alloc; 46 | 47 | ---------- 48 | -- Free -- 49 | ---------- 50 | 51 | procedure AUnit_Free (Obj : System.Address) is 52 | procedure RT_Free (Obj : System.Address); 53 | pragma Import (C, RT_Free, "__gnat_free"); 54 | begin 55 | RT_Free (Obj); 56 | end AUnit_Free; 57 | 58 | end AUnit.Memory; 59 | -------------------------------------------------------------------------------- /examples/calculator/tests/operations-binary-gen_test.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2008, AdaCore 3 | -- 4 | with Ada.Exceptions; 5 | with System.Assertions; 6 | with AUnit.Assertions; use AUnit.Assertions; 7 | with Stack; use Stack; 8 | package body Operations.Binary.Gen_Test is 9 | 10 | ------------ 11 | -- Set_Up -- 12 | ------------ 13 | 14 | procedure Set_Up (T : in out Test) is 15 | begin 16 | Set_Up (T.Op, T.Test_Op1, T.Test_Op2, T.Exp_Res); 17 | end Set_Up; 18 | 19 | --------------- 20 | -- Tear_Down -- 21 | --------------- 22 | 23 | procedure Tear_Down (T : in out Test) is 24 | pragma Unreferenced (T); 25 | begin 26 | -- Make sure the stack is empty after each test. 27 | while Stack.Length > 0 loop 28 | declare 29 | Op : constant Operands.Operand'Class := Stack.Pop; 30 | pragma Unreferenced (Op); 31 | begin 32 | null; 33 | end; 34 | end loop; 35 | end Tear_Down; 36 | 37 | -------------- 38 | -- Test_Pop -- 39 | -------------- 40 | 41 | procedure Test_Pop (T : in out Test) is 42 | begin 43 | begin 44 | Pop (T.Op); 45 | Assert (False, "stack is empty, it should have raised an exception"); 46 | exception 47 | when System.Assertions.Assert_Failure => 48 | -- Precondition failed. OK 49 | null; 50 | when E : others => 51 | Assert (False, "Wrong exception raised: " & 52 | Ada.Exceptions.Exception_Name (E)); 53 | end; 54 | 55 | Stack.Push (T.Test_Op1); 56 | Stack.Push (T.Test_Op2); 57 | Pop (T.Op); 58 | Assert (Stack.Length = 0, "Wrong pop operation"); 59 | Assert (T.Op.Op1 = T.Test_Op1, "Wrong first value poped"); 60 | Assert (T.Op.Op2 = T.Test_Op2, "Wrong 2nd value poped"); 61 | end Test_Pop; 62 | 63 | --------------- 64 | -- Test_Push -- 65 | --------------- 66 | 67 | procedure Test_Push (T : in out Test) is 68 | begin 69 | T.Op.Res := T.Exp_Res; 70 | T.Op.Push; 71 | Assert (Stack.Length = 1, "Wrong push on stack"); 72 | Assert (Stack.Top = Operands.Operand'Class (T.Exp_Res), 73 | "Wrong value pushed"); 74 | for J in 2 .. Stack.Max_Stack_Size loop 75 | Stack.Push (T.Test_Op1); 76 | end loop; 77 | 78 | begin 79 | T.Op.Push; 80 | Assert (False, "stack is full, it should have raised an exception"); 81 | exception 82 | when System.Assertions.Assert_Failure => 83 | null; -- Expected 84 | when E : others => 85 | Assert (False, "Wrong exception raised: " & 86 | Ada.Exceptions.Exception_Name (E)); 87 | end; 88 | end Test_Push; 89 | 90 | ------------------ 91 | -- Test_Execute -- 92 | ------------------ 93 | 94 | procedure Test_Execute (T : in out Test) is 95 | begin 96 | T.Op.Op1 := T.Test_Op1; 97 | T.Op.Op2 := T.Test_Op2; 98 | T.Op.Execute; 99 | Assert (T.Op.Res = T.Exp_Res, "Incorrect result set after Execute"); 100 | end Test_Execute; 101 | 102 | end Operations.Binary.Gen_Test; 103 | -------------------------------------------------------------------------------- /doc/share/conf.py: -------------------------------------------------------------------------------- 1 | # -*- coding: utf-8 -*- 2 | # 3 | # GNAT build configuration file 4 | 5 | import sys 6 | import os 7 | import time 8 | import re 9 | 10 | sys.path.append('.') 11 | 12 | import ada_pygments 13 | import latex_elements 14 | 15 | # Some configuration values for the various documentation handled by 16 | # this conf.py 17 | 18 | DOCS = { 19 | 'aunit_cb': { 20 | 'title': u'AUnit Cookbook'}} 21 | 22 | # Then retrieve the source directory 23 | root_source_dir = os.path.dirname(os.path.dirname(os.path.abspath(__file__))) 24 | texi_fsf = True # Set to False when FSF doc is switched to sphinx by default 25 | 26 | 27 | def get_copyright(): 28 | return u'2008-%s, AdaCore' % time.strftime('%Y') 29 | 30 | 31 | def get_version(): 32 | # Assumes that version number is defined in file version_information 33 | # two directory levels up, as the first line in this file 34 | try: 35 | with open('../../version_information') as vinfo: 36 | line = (vinfo.readline()).strip() 37 | return line 38 | except: 39 | print('Error opening or reading version_information file') 40 | sys.exit(1) 41 | 42 | # First retrieve the name of the documentation we are building 43 | doc_name = os.environ.get('DOC_NAME', None) 44 | if doc_name is None: 45 | print('DOC_NAME environment variable should be set') 46 | sys.exit(1) 47 | 48 | if doc_name not in DOCS: 49 | print('%s is not a valid documentation name' % doc_name) 50 | sys.exit(1) 51 | 52 | # Exclude sources that are not part of the current documentation 53 | exclude_patterns = [] 54 | for d in os.listdir(root_source_dir): 55 | if d not in ('share', doc_name, doc_name + '.rst'): 56 | exclude_patterns.append(d) 57 | print('ignoring %s' % d) 58 | 59 | extensions = ['sphinx_rtd_theme'] 60 | templates_path = ['_templates'] 61 | source_suffix = '.rst' 62 | master_doc = doc_name 63 | 64 | # General information about the project. 65 | project = DOCS[doc_name]['title'] 66 | 67 | copyright = get_copyright() 68 | 69 | version = get_version() 70 | release = get_version() 71 | 72 | pygments_style = None 73 | html_theme = 'sphinx_rtd_theme' 74 | html_theme_options = { 75 | "style_nav_header_background": "#12284c", 76 | } 77 | if os.path.isfile('adacore-logo-white.png'): 78 | html_logo = 'adacore-logo-white.png' 79 | if os.path.isfile('favicon.ico'): 80 | html_favicon = 'favicon.ico' 81 | 82 | latex_elements = { 83 | 'preamble': latex_elements.TOC_DEPTH + 84 | latex_elements.PAGE_BLANK + 85 | latex_elements.TOC_CMD + 86 | latex_elements.LATEX_HYPHEN + 87 | latex_elements.doc_settings(DOCS[doc_name]['title'], get_version()) + 88 | latex_elements.FOOTER, 89 | 'tableofcontents': latex_elements.TOC 90 | } 91 | 92 | latex_table_style = ["standard", "colorrows"] 93 | 94 | latex_documents = [ 95 | (master_doc, '%s.tex' % doc_name, project, u'AdaCore', 'manual')] 96 | 97 | texinfo_documents = [ 98 | (master_doc, doc_name, project, 99 | u'AdaCore', doc_name, doc_name, '')] 100 | 101 | 102 | def setup(app): 103 | app.add_lexer('ada', ada_pygments.AdaLexer) 104 | app.add_lexer('gpr', ada_pygments.GNATProjectLexer) 105 | -------------------------------------------------------------------------------- /include/aunit/framework/zfpexception/aunit-assertions-assert_exception.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- -- 3 | -- GNAT COMPILER COMPONENTS -- 4 | -- -- 5 | -- A U N I T . A S S E R T I O N S -- 6 | -- -- 7 | -- B o d y -- 8 | -- -- 9 | -- -- 10 | -- Copyright (C) 2000-2011, AdaCore -- 11 | -- -- 12 | -- GNAT is free software; you can redistribute it and/or modify it under -- 13 | -- terms of the GNU General Public License as published by the Free Soft- -- 14 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 15 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 16 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 17 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- 18 | -- -- 19 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 20 | -- additional permissions described in the GCC Runtime Library Exception, -- 21 | -- version 3.1, as published by the Free Software Foundation. -- 22 | -- -- 23 | -- You should have received a copy of the GNU General Public License and -- 24 | -- a copy of the GCC Runtime Library Exception along with this program; -- 25 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 26 | -- . -- 27 | -- -- 28 | -- GNAT is maintained by AdaCore (http://www.adacore.com) -- 29 | -- -- 30 | ------------------------------------------------------------------------------ 31 | 32 | -- Version for run-time libraries that support exception handling via 33 | -- gcc builtin setjmp/longjmp 34 | 35 | with AUnit.Last_Chance_Handler; 36 | 37 | separate (AUnit.Assertions) 38 | procedure Assert_Exception 39 | (Proc : Throwing_Exception_Proc; 40 | Message : String; 41 | Source : String := GNAT.Source_Info.File; 42 | Line : Natural := GNAT.Source_Info.Line) 43 | is 44 | procedure Exec; 45 | 46 | procedure Exec is 47 | begin 48 | Proc.all; 49 | end Exec; 50 | 51 | function My_Setjmp is new AUnit.Last_Chance_Handler.Gen_Setjmp (Exec); 52 | begin 53 | if My_Setjmp = 0 then 54 | -- Result is 0 when no exception has been raised. 55 | Assert (False, Message, Source, Line); 56 | end if; 57 | end Assert_Exception; 58 | -------------------------------------------------------------------------------- /include/aunit/framework/fullexception/aunit-test_cases-call_set_up_case.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- -- 3 | -- GNAT COMPILER COMPONENTS -- 4 | -- -- 5 | -- A U N I T . T E S T _ C A S E S -- 6 | -- -- 7 | -- B o d y -- 8 | -- -- 9 | -- -- 10 | -- Copyright (C) 2000-2019, AdaCore -- 11 | -- -- 12 | -- GNAT is free software; you can redistribute it and/or modify it under -- 13 | -- terms of the GNU General Public License as published by the Free Soft- -- 14 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 15 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 16 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 17 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- 18 | -- -- 19 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 20 | -- additional permissions described in the GCC Runtime Library Exception, -- 21 | -- version 3.1, as published by the Free Software Foundation. -- 22 | -- -- 23 | -- You should have received a copy of the GNU General Public License and -- 24 | -- a copy of the GCC Runtime Library Exception along with this program; -- 25 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 26 | -- . -- 27 | -- -- 28 | -- GNAT is maintained by AdaCore (http://www.adacore.com) -- 29 | -- -- 30 | ------------------------------------------------------------------------------ 31 | 32 | with Ada.Exceptions; use Ada.Exceptions; 33 | with GNAT.Traceback.Symbolic; use GNAT.Traceback.Symbolic; 34 | with AUnit.Memory.Utils; use AUnit.Memory.Utils; 35 | 36 | separate (AUnit.Test_Cases) 37 | function Call_Set_Up_Case 38 | (Test : in out Test_Case'Class) return Test_Error_Access is 39 | function Alloc_Error is new Gen_Alloc (Test_Error, Test_Error_Access); 40 | begin 41 | Set_Up_Case (Test); 42 | return null; 43 | exception when E : others => 44 | return Error : constant Test_Error_Access := Alloc_Error do 45 | Error.Exception_Name := Format (Exception_Name (E)); 46 | Error.Exception_Message := Format (Exception_Message (E)); 47 | Error.Traceback := Format (Symbolic_Traceback (E)); 48 | end return; 49 | end Call_Set_Up_Case; 50 | -------------------------------------------------------------------------------- /include/aunit/framework/aunit-reporter.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- -- 3 | -- GNAT COMPILER COMPONENTS -- 4 | -- -- 5 | -- A U N I T . R E P O R T E R -- 6 | -- -- 7 | -- S p e c -- 8 | -- -- 9 | -- -- 10 | -- Copyright (C) 2008-2019, AdaCore -- 11 | -- -- 12 | -- GNAT is free software; you can redistribute it and/or modify it under -- 13 | -- terms of the GNU General Public License as published by the Free Soft- -- 14 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 15 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 16 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 17 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- 18 | -- -- 19 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 20 | -- additional permissions described in the GCC Runtime Library Exception, -- 21 | -- version 3.1, as published by the Free Software Foundation. -- 22 | -- -- 23 | -- You should have received a copy of the GNU General Public License and -- 24 | -- a copy of the GCC Runtime Library Exception along with this program; -- 25 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 26 | -- . -- 27 | -- -- 28 | -- GNAT is maintained by AdaCore (http://www.adacore.com) -- 29 | -- -- 30 | ------------------------------------------------------------------------------ 31 | 32 | with AUnit.IO; 33 | with AUnit.Options; use AUnit.Options; 34 | with AUnit.Test_Results; use AUnit.Test_Results; 35 | 36 | package AUnit.Reporter is 37 | 38 | type Reporter is abstract tagged private; 39 | 40 | procedure Set_File 41 | (Engine : in out Reporter; 42 | Value : AUnit.IO.File_Access); 43 | 44 | procedure Report 45 | (Engine : Reporter; 46 | R : in out Result'Class; 47 | Options : AUnit_Options := Default_Options) is abstract; 48 | -- This procedure is called by AUnit.Run to report the result after running 49 | -- the whole testsuite (or the selected subset of tests). 50 | 51 | private 52 | 53 | type Reporter is abstract tagged 54 | record 55 | File : AUnit.IO.File_Access := AUnit.IO.Standard_Output; 56 | end record; 57 | 58 | end AUnit.Reporter; 59 | -------------------------------------------------------------------------------- /include/aunit/framework/zfpexception/aunit-last_chance_handler.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- -- 3 | -- GNAT COMPILER COMPONENTS -- 4 | -- -- 5 | -- L A S T _ C H A N C E _ H A N D L E R -- 6 | -- -- 7 | -- S p e c -- 8 | -- -- 9 | -- -- 10 | -- Copyright (C) 2008-2011, AdaCore -- 11 | -- -- 12 | -- GNAT is free software; you can redistribute it and/or modify it under -- 13 | -- terms of the GNU General Public License as published by the Free Soft- -- 14 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 15 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 16 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 17 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- 18 | -- -- 19 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 20 | -- additional permissions described in the GCC Runtime Library Exception, -- 21 | -- version 3.1, as published by the Free Software Foundation. -- 22 | -- -- 23 | -- You should have received a copy of the GNU General Public License and -- 24 | -- a copy of the GCC Runtime Library Exception along with this program; -- 25 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 26 | -- . -- 27 | -- -- 28 | -- GNAT is maintained by AdaCore (http://www.adacore.com) -- 29 | -- -- 30 | ------------------------------------------------------------------------------ 31 | 32 | -- This last chance handler implementation performs a longjmp using gcc 33 | -- builtin to allow exception simulation on platforms where the run-time does 34 | -- not allow exception propagation. 35 | 36 | with System; 37 | 38 | package AUnit.Last_Chance_Handler is 39 | 40 | function Get_Exception_Name return Message_String; 41 | function Get_Exception_Message return Message_String; 42 | -- Return the last exception message 43 | 44 | generic 45 | with procedure Proc; 46 | function Gen_Setjmp return Integer; 47 | -- Setjmp: init the handler, and call Proc. 48 | 49 | procedure Last_Chance_Handler (Msg : System.Address; Line : Integer); 50 | pragma Export (C, Last_Chance_Handler, "__gnat_last_chance_handler"); 51 | pragma No_Return (Last_Chance_Handler); 52 | 53 | end AUnit.Last_Chance_Handler; 54 | -------------------------------------------------------------------------------- /include/aunit/framework/aunit-test_cases-registration.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- -- 3 | -- GNAT COMPILER COMPONENTS -- 4 | -- -- 5 | -- A U N I T . T E S T _ C A S E S . R E G I S T R A T I O N -- 6 | -- -- 7 | -- B o d y -- 8 | -- -- 9 | -- -- 10 | -- Copyright (C) 2000-2017, AdaCore -- 11 | -- -- 12 | -- GNAT is free software; you can redistribute it and/or modify it under -- 13 | -- terms of the GNU General Public License as published by the Free Soft- -- 14 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 15 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 16 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 17 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- 18 | -- -- 19 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 20 | -- additional permissions described in the GCC Runtime Library Exception, -- 21 | -- version 3.1, as published by the Free Software Foundation. -- 22 | -- -- 23 | -- You should have received a copy of the GNU General Public License and -- 24 | -- a copy of the GCC Runtime Library Exception along with this program; -- 25 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 26 | -- . -- 27 | -- -- 28 | -- GNAT is maintained by AdaCore (http://www.adacore.com) -- 29 | -- -- 30 | ------------------------------------------------------------------------------ 31 | 32 | -- Test routine registration 33 | 34 | separate (AUnit.Test_Cases) 35 | package body Registration is 36 | 37 | ---------------------- 38 | -- Register_Routine -- 39 | ---------------------- 40 | 41 | procedure Register_Routine 42 | (Test : in out Test_Case'Class; 43 | Routine : Test_Routine; 44 | Name : String) is 45 | 46 | Formatted_Name : constant Message_String := Format (Name); 47 | Val : Routine_Spec; 48 | 49 | begin 50 | Val := (Routine, Formatted_Name); 51 | Add_Routine (Test, Val); 52 | end Register_Routine; 53 | 54 | ------------------- 55 | -- Routine_Count -- 56 | ------------------- 57 | 58 | function Routine_Count (Test : Test_Case'Class) return Count_Type is 59 | begin 60 | return Routine_Lists.Length (Test.Routines); 61 | end Routine_Count; 62 | 63 | end Registration; 64 | -------------------------------------------------------------------------------- /include/aunit/framework/zfpexception/aunit-test_cases-call_set_up_case.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- -- 3 | -- GNAT COMPILER COMPONENTS -- 4 | -- -- 5 | -- A U N I T . T E S T _ C A S E S -- 6 | -- -- 7 | -- B o d y -- 8 | -- -- 9 | -- -- 10 | -- Copyright (C) 2000-2019, AdaCore -- 11 | -- -- 12 | -- GNAT is free software; you can redistribute it and/or modify it under -- 13 | -- terms of the GNU General Public License as published by the Free Soft- -- 14 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 15 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 16 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 17 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- 18 | -- -- 19 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 20 | -- additional permissions described in the GCC Runtime Library Exception, -- 21 | -- version 3.1, as published by the Free Software Foundation. -- 22 | -- -- 23 | -- You should have received a copy of the GNU General Public License and -- 24 | -- a copy of the GCC Runtime Library Exception along with this program; -- 25 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 26 | -- . -- 27 | -- -- 28 | -- GNAT is maintained by AdaCore (http://www.adacore.com) -- 29 | -- -- 30 | ------------------------------------------------------------------------------ 31 | 32 | with AUnit.Last_Chance_Handler; use AUnit.Last_Chance_Handler; 33 | with AUnit.Memory.Utils; use AUnit.Memory.Utils; 34 | 35 | separate (AUnit.Test_Cases) 36 | function Call_Set_Up_Case 37 | (Test : in out Test_Case'Class) return Test_Error_Access is 38 | function Alloc_Error is new Gen_Alloc (Test_Error, Test_Error_Access); 39 | 40 | procedure Internal_Set_Up_Case is 41 | begin 42 | Set_Up_Case (Test); 43 | end Internal_Set_Up_Case; 44 | 45 | function Internal_Setjmp is new Gen_Setjmp (Internal_Set_Up_Case); 46 | 47 | Error : Test_Error_Access := null; 48 | begin 49 | if Internal_Setjmp /= 0 then 50 | Error := Alloc_Error; 51 | Error.Exception_Name := Get_Exception_Name; 52 | Error.Exception_Message := Get_Exception_Message; 53 | Error.Traceback := null; 54 | end if; 55 | return Error; 56 | end Call_Set_Up_Case; 57 | -------------------------------------------------------------------------------- /include/aunit/framework/fileio/aunit-io.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- -- 3 | -- GNAT COMPILER COMPONENTS -- 4 | -- -- 5 | -- A U N I T . R E P O R T E R -- 6 | -- -- 7 | -- S p e c -- 8 | -- -- 9 | -- -- 10 | -- Copyright (C) 2019, AdaCore -- 11 | -- -- 12 | -- GNAT is free software; you can redistribute it and/or modify it under -- 13 | -- terms of the GNU General Public License as published by the Free Soft- -- 14 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 15 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 16 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 17 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- 18 | -- -- 19 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 20 | -- additional permissions described in the GCC Runtime Library Exception, -- 21 | -- version 3.1, as published by the Free Software Foundation. -- 22 | -- -- 23 | -- You should have received a copy of the GNU General Public License and -- 24 | -- a copy of the GCC Runtime Library Exception along with this program; -- 25 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 26 | -- . -- 27 | -- -- 28 | -- GNAT is maintained by AdaCore (http://www.adacore.com) -- 29 | -- -- 30 | ------------------------------------------------------------------------------ 31 | 32 | with Ada.Text_IO; 33 | with Ada.Integer_Text_IO; 34 | 35 | package AUnit.IO is 36 | 37 | subtype File_Type is Ada.Text_IO.File_Type; 38 | 39 | subtype File_Access is Ada.Text_IO.File_Access; 40 | 41 | function Standard_Output 42 | return File_Access renames Ada.Text_IO.Standard_Output; 43 | 44 | procedure Put (File : File_Type; 45 | Item : Integer; 46 | Width : Ada.Text_IO.Field := Ada.Integer_Text_IO.Default_Width; 47 | Base : Ada.Text_IO.Number_Base := Ada.Integer_Text_IO.Default_Base) 48 | renames Ada.Integer_Text_IO.Put; 49 | 50 | procedure Put (File : File_Type; 51 | Item : String) renames Ada.Text_IO.Put; 52 | 53 | procedure Put_Line (File : File_Type; 54 | Item : String) renames Ada.Text_IO.Put_Line; 55 | 56 | procedure New_Line (File : File_Type; 57 | Spacing : Ada.Text_IO.Positive_Count := 1) renames Ada.Text_IO.New_Line; 58 | 59 | end AUnit.IO; 60 | -------------------------------------------------------------------------------- /include/aunit/framework/nocalendar/aunit-time_measure.ads: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- -- 3 | -- GNAT COMPILER COMPONENTS -- 4 | -- -- 5 | -- A U N I T . T I M E _ M E A S U R E -- 6 | -- -- 7 | -- S p e c -- 8 | -- -- 9 | -- -- 10 | -- Copyright (C) 2006-2019, AdaCore -- 11 | -- -- 12 | -- GNAT is free software; you can redistribute it and/or modify it under -- 13 | -- terms of the GNU General Public License as published by the Free Soft- -- 14 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 15 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 16 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 17 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- 18 | -- -- 19 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 20 | -- additional permissions described in the GCC Runtime Library Exception, -- 21 | -- version 3.1, as published by the Free Software Foundation. -- 22 | -- -- 23 | -- You should have received a copy of the GNU General Public License and -- 24 | -- a copy of the GCC Runtime Library Exception along with this program; -- 25 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 26 | -- . -- 27 | -- -- 28 | -- GNAT is maintained by AdaCore (http://www.adacore.com) -- 29 | -- -- 30 | ------------------------------------------------------------------------------ 31 | 32 | -- Dummy package when Ada.Calendar is not supported 33 | with AUnit.IO; 34 | 35 | package AUnit.Time_Measure is 36 | 37 | type Time is null record; 38 | 39 | type AUnit_Duration is private; 40 | 41 | Null_Time : Time; 42 | 43 | procedure Start_Measure (T : in out Time); 44 | -- Start a new measure 45 | 46 | procedure Stop_Measure (T : in out Time); 47 | -- Stop the measure 48 | 49 | function Get_Measure (T : Time) return AUnit_Duration; 50 | -- Get the measure 51 | 52 | generic 53 | procedure Gen_Put_Measure (File : AUnit.IO.File_Type; 54 | Measure : AUnit_Duration); 55 | -- Put the image of the measure 56 | 57 | generic 58 | procedure Gen_Put_Measure_In_Seconds (File : AUnit.IO.File_Type; 59 | Measure : AUnit_Duration); 60 | -- Unlike Gen_Put_Measure, puts the measure in seconds only, also puts 61 | -- 9 digits after decimal point. 62 | 63 | private 64 | 65 | type AUnit_Duration is new Integer; 66 | 67 | end AUnit.Time_Measure; 68 | -------------------------------------------------------------------------------- /COPYING.RUNTIME: -------------------------------------------------------------------------------- 1 | GCC RUNTIME LIBRARY EXCEPTION 2 | 3 | Version 3.1, 31 March 2009 4 | 5 | Copyright (C) 2009 Free Software Foundation, Inc. 6 | 7 | Everyone is permitted to copy and distribute verbatim copies of this 8 | license document, but changing it is not allowed. 9 | 10 | This GCC Runtime Library Exception ("Exception") is an additional 11 | permission under section 7 of the GNU General Public License, version 12 | 3 ("GPLv3"). It applies to a given file (the "Runtime Library") that 13 | bears a notice placed by the copyright holder of the file stating that 14 | the file is governed by GPLv3 along with this Exception. 15 | 16 | When you use GCC to compile a program, GCC may combine portions of 17 | certain GCC header files and runtime libraries with the compiled 18 | program. The purpose of this Exception is to allow compilation of 19 | non-GPL (including proprietary) programs to use, in this way, the 20 | header files and runtime libraries covered by this Exception. 21 | 22 | 0. Definitions. 23 | 24 | A file is an "Independent Module" if it either requires the Runtime 25 | Library for execution after a Compilation Process, or makes use of an 26 | interface provided by the Runtime Library, but is not otherwise based 27 | on the Runtime Library. 28 | 29 | "GCC" means a version of the GNU Compiler Collection, with or without 30 | modifications, governed by version 3 (or a specified later version) of 31 | the GNU General Public License (GPL) with the option of using any 32 | subsequent versions published by the FSF. 33 | 34 | "GPL-compatible Software" is software whose conditions of propagation, 35 | modification and use would permit combination with GCC in accord with 36 | the license of GCC. 37 | 38 | "Target Code" refers to output from any compiler for a real or virtual 39 | target processor architecture, in executable form or suitable for 40 | input to an assembler, loader, linker and/or execution 41 | phase. Notwithstanding that, Target Code does not include data in any 42 | format that is used as a compiler intermediate representation, or used 43 | for producing a compiler intermediate representation. 44 | 45 | The "Compilation Process" transforms code entirely represented in 46 | non-intermediate languages designed for human-written code, and/or in 47 | Java Virtual Machine byte code, into Target Code. Thus, for example, 48 | use of source code generators and preprocessors need not be considered 49 | part of the Compilation Process, since the Compilation Process can be 50 | understood as starting with the output of the generators or 51 | preprocessors. 52 | 53 | A Compilation Process is "Eligible" if it is done using GCC, alone or 54 | with other GPL-compatible software, or if it is done without using any 55 | work based on GCC. For example, using non-GPL-compatible Software to 56 | optimize any GCC intermediate representations would not qualify as an 57 | Eligible Compilation Process. 58 | 59 | 1. Grant of Additional Permission. 60 | 61 | You have permission to propagate a work of Target Code formed by 62 | combining the Runtime Library with Independent Modules, even if such 63 | propagation would otherwise violate the terms of GPLv3, provided that 64 | all Target Code was generated by Eligible Compilation Processes. You 65 | may then convey such a combination under terms of your choice, 66 | consistent with the licensing of the Independent Modules. 67 | 68 | 2. No Weakening of GCC Copyleft. 69 | 70 | The availability of this Exception does not imply any general 71 | presumption that third-party software is unaffected by the copyleft 72 | requirements of the license of GCC. 73 | 74 | -------------------------------------------------------------------------------- /include/aunit/framework/nofileio/aunit-io.adb: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- -- 3 | -- GNAT COMPILER COMPONENTS -- 4 | -- -- 5 | -- A U N I T . I O -- 6 | -- -- 7 | -- B o d y -- 8 | -- -- 9 | -- -- 10 | -- Copyright (C) 2019, AdaCore -- 11 | -- -- 12 | -- GNAT is free software; you can redistribute it and/or modify it under -- 13 | -- terms of the GNU General Public License as published by the Free Soft- -- 14 | -- ware Foundation; either version 3, or (at your option) any later ver- -- 15 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 16 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 17 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- 18 | -- -- 19 | -- As a special exception under Section 7 of GPL version 3, you are granted -- 20 | -- additional permissions described in the GCC Runtime Library Exception, -- 21 | -- version 3.1, as published by the Free Software Foundation. -- 22 | -- -- 23 | -- You should have received a copy of the GNU General Public License and -- 24 | -- a copy of the GCC Runtime Library Exception along with this program; -- 25 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 26 | -- . -- 27 | -- -- 28 | -- GNAT is maintained by AdaCore (http://www.adacore.com) -- 29 | -- -- 30 | ------------------------------------------------------------------------------ 31 | 32 | with GNAT.IO; use GNAT.IO; 33 | 34 | package body AUnit.IO is 35 | 36 | Standard_Out : aliased constant File_Type := 1; 37 | 38 | function Standard_Output 39 | return File_Access is 40 | (Standard_Out'Access); 41 | 42 | procedure Put (File : File_Type; 43 | Item : Integer; 44 | Width : Integer := 0; 45 | Base : Integer := 0) is 46 | pragma Unreferenced (File, Width, Base); 47 | begin 48 | Put (Item); 49 | end Put; 50 | 51 | procedure Put (File : File_Type; 52 | Item : String) is 53 | pragma Unreferenced (File); 54 | begin 55 | Put (Item); 56 | end Put; 57 | 58 | procedure Put_Line (File : File_Type; 59 | Item : String) is 60 | pragma Unreferenced (File); 61 | begin 62 | Put_Line (Item); 63 | end Put_Line; 64 | 65 | procedure New_Line (File : File_Type; 66 | Spacing : Positive := 1) is 67 | pragma Unreferenced (File); 68 | begin 69 | New_Line (Spacing); 70 | end New_Line; 71 | 72 | end AUnit.IO; 73 | -------------------------------------------------------------------------------- /doc/aunit_cb/introduction.rst: -------------------------------------------------------------------------------- 1 | .. _Introduction: 2 | 3 | ************ 4 | Introduction 5 | ************ 6 | 7 | This is a short guide for using the AUnit test framework. 8 | AUnit is an adaptation of the Java :index:`JUnit` (Kent Beck, Erich Gamma) and C++ 9 | :index:`CppUnit` (M. Feathers, J. Lacoste, E. Sommerlade, B. Lepilleur, B. Bakker, 10 | S. Robbins) unit test frameworks for Ada code. 11 | 12 | 13 | What's new in AUnit 3 14 | ===================== 15 | 16 | AUnit 3 brings several enhancements over AUnit 2 and AUnit 1: 17 | 18 | 19 | * Removal of the genericity of the AUnit framework, making the AUnit 3 20 | API as close as possible to AUnit 1. 21 | 22 | * Emulates dynamic memory management for limited run-time profiles. 23 | 24 | * Provides a new XML reporter, and changes harness invocation to support 25 | easy switching among text, XML and customized reporters. 26 | 27 | * Provides new tagged types ``Simple_Test_Case``, ``Test_Fixture`` and ``Test_Caller`` 28 | that correspond to CppUnit's ``TestCase``, ``TestFixture`` and ``TestCaller`` classes. 29 | 30 | .. index:: ZFP profile 31 | 32 | .. index:: setjmp/longjmp 33 | 34 | * Emulates exception propagation for restricted run-time profiles 35 | (e.g. ZFP), by using the gcc builtin `setjmp` / `longjmp` mechanism. 36 | 37 | * Reports the source location of an error when possible. 38 | 39 | 40 | Typographic conventions 41 | ======================= 42 | 43 | .. index:: notational convention 44 | 45 | For notational convenience, `` will be used throughout 46 | this document to stand for the AUnit product version number. 47 | For example, aunit-**-src expands to aunit-|version|-src. 48 | 49 | 50 | Examples 51 | ======== 52 | 53 | With this version, we have provided new examples illustrating the enhanced 54 | features of the framework. These examples are in the AUnit 55 | installation directory: 56 | :file:`/share/examples/aunit`, and are also available in the source 57 | distribution :samp:`aunit-{}-src/examples`. 58 | 59 | The following examples are provided: 60 | 61 | * simple_test: shows use of AUnit.Simple_Test_Cases 62 | (see :ref:`AUnit.Simple_Test_Cases`). 63 | * test_caller: shows use of AUnit.Test_Caller (see :ref:`AUnit.Test_Caller`). 64 | * test_fixture: example of a test fixture (see :ref:`Fixture`). 65 | * liskov: This suite tests conformance to the Liskov Substitution Principle 66 | of a pair of simple tagged types. (see :ref:`OOP_considerations`) 67 | * failures: example of handling and reporting failed tests 68 | (see :ref:`Reporting`). 69 | * calculator: a full example of test suite organization. 70 | 71 | Note about limited run-time libraries 72 | ===================================== 73 | 74 | AUnit allows a great deal of flexibility for the structure of test cases, 75 | suites and harnesses. The templates and examples given in this document 76 | illustrate how to use AUnit while staying within the constraints of the 77 | GNAT Pro restricted and Zero Footprint (ZFP) run-time libraries. Therefore, 78 | they avoid the use of dynamic allocation and some other features that would 79 | be outside of the profiles corresponding to these libraries. Tests targeted 80 | to the full Ada run-time library need not comply with these constraints. 81 | 82 | Thanks 83 | ====== 84 | 85 | This document is adapted from the JUnit and CppUnit Cookbooks documents 86 | contained in their respective release packages. 87 | 88 | .. |c-cedilla-lc| unicode:: 0xE7 89 | :trim: 90 | 91 | Special thanks to Fran |c-cedilla-lc| ois Brun of Thales Avionics for his ideas about 92 | support for OOP testing. 93 | 94 | -------------------------------------------------------------------------------- /test/src/aunit-test_suites-tests_fixtures.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2009-2010, AdaCore 3 | -- 4 | 5 | with Ada.Exceptions; 6 | with AUnit.Assertions; use AUnit.Assertions; 7 | 8 | package body AUnit.Test_Suites.Tests_Fixtures is 9 | 10 | ---------- 11 | -- Name -- 12 | ---------- 13 | 14 | function Name (Test : Simple_Test_Case) return Message_String is 15 | pragma Unreferenced (Test); 16 | begin 17 | return AUnit.Format ("Simple test case"); 18 | end Name; 19 | 20 | -------------- 21 | -- Run_Test -- 22 | -------------- 23 | 24 | procedure Run_Test (Test : in out Simple_Test_Case) is 25 | pragma Unreferenced (Test); 26 | begin 27 | null; 28 | end Run_Test; 29 | 30 | function Name (Test : TC_With_Failure) return Message_String is 31 | pragma Unreferenced (Test); 32 | begin 33 | return AUnit.Format ("Test case with failure"); 34 | end Name; 35 | 36 | -------------- 37 | -- Run_Test -- 38 | -------------- 39 | 40 | procedure Run_Test (Test : in out TC_With_Failure) is 41 | pragma Unreferenced (Test); 42 | begin 43 | Assert (False, "A failed assertion"); 44 | end Run_Test; 45 | 46 | ---------- 47 | -- Name -- 48 | ---------- 49 | 50 | function Name (Test : TC_With_Two_Failures) return Message_String is 51 | pragma Unreferenced (Test); 52 | begin 53 | return AUnit.Format ("Test case with 2 failures"); 54 | end Name; 55 | 56 | -------------- 57 | -- Run_Test -- 58 | -------------- 59 | 60 | procedure Run_Test (Test : in out TC_With_Two_Failures) is 61 | pragma Unreferenced (Test); 62 | begin 63 | if not Assert (False, "A first failure") then 64 | Assert (False, "A second failure"); 65 | Assert (False, "Third failure, should not appear"); 66 | end if; 67 | end Run_Test; 68 | 69 | ---------- 70 | -- Name -- 71 | ---------- 72 | 73 | function Name (Test : TC_With_Exception) return Message_String is 74 | pragma Unreferenced (Test); 75 | begin 76 | return AUnit.Format ("Test case with exception"); 77 | end Name; 78 | 79 | -------------- 80 | -- Run_Test -- 81 | -------------- 82 | 83 | procedure Run_Test (Test : in out TC_With_Exception) is 84 | pragma Unreferenced (Test); 85 | begin 86 | Ada.Exceptions.Raise_Exception 87 | (My_Exception'Identity, "A message"); 88 | end Run_Test; 89 | 90 | ---------- 91 | -- Name -- 92 | ---------- 93 | 94 | function Name (Test : TC_With_Setup) return Message_String is 95 | pragma Unreferenced (Test); 96 | begin 97 | return AUnit.Format ("Test case with set_up/tear_down defined)"); 98 | end Name; 99 | 100 | ------------ 101 | -- Set_Up -- 102 | ------------ 103 | 104 | procedure Set_Up (Test : in out TC_With_Setup) is 105 | begin 106 | if Test.Setup then 107 | Test.Error := True; 108 | end if; 109 | 110 | Test.Setup := True; 111 | end Set_Up; 112 | 113 | --------------- 114 | -- Tear_Down -- 115 | --------------- 116 | 117 | procedure Tear_Down (Test : in out TC_With_Setup) is 118 | begin 119 | if not Test.Setup then 120 | Test.Error := True; 121 | end if; 122 | 123 | Test.Setup := False; 124 | end Tear_Down; 125 | 126 | -------------- 127 | -- Run_Test -- 128 | -------------- 129 | 130 | procedure Run_Test (Test : in out TC_With_Setup) is 131 | begin 132 | Assert (Test.Setup, "Set up not done correctly"); 133 | end Run_Test; 134 | 135 | end AUnit.Test_Suites.Tests_Fixtures; 136 | -------------------------------------------------------------------------------- /test/src/aunit-test_cases-tests_fixtures.adb: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright (C) 2009-2010, AdaCore 3 | -- 4 | 5 | with AUnit.Assertions; use AUnit.Assertions; 6 | 7 | package body AUnit.Test_Cases.Tests_Fixtures is 8 | 9 | procedure Double_Failure_Wrapper (T : in out The_Test_Case'Class); 10 | 11 | use AUnit.Test_Cases.Registration; 12 | 13 | ------------ 14 | -- Set_Up -- 15 | ------------ 16 | 17 | procedure Set_Up (T : in out The_Test_Case) is 18 | begin 19 | T.Is_Set_Up := True; 20 | end Set_Up; 21 | 22 | --------------- 23 | -- Tear_Down -- 24 | --------------- 25 | 26 | procedure Tear_Down (T : in out The_Test_Case) is 27 | begin 28 | T.Is_Torn_Down := True; 29 | end Tear_Down; 30 | 31 | ------------- 32 | -- Succeed -- 33 | ------------- 34 | 35 | procedure Succeed (T : in out Test_Cases.Test_Case'Class) is 36 | pragma Unreferenced (T); 37 | begin 38 | null; 39 | end Succeed; 40 | 41 | ---------- 42 | -- Fail -- 43 | ---------- 44 | 45 | procedure Fail (T : in out Test_Cases.Test_Case'Class) is 46 | pragma Unreferenced (T); 47 | begin 48 | Assert (False, "Failure test failed"); 49 | end Fail; 50 | 51 | ---------------------------- 52 | -- Double_Failure_Wrapper -- 53 | ---------------------------- 54 | 55 | procedure Double_Failure_Wrapper (T : in out The_Test_Case'Class) is 56 | begin 57 | Double_Failure (T); 58 | end Double_Failure_Wrapper; 59 | 60 | -------------------- 61 | -- Double_Failure -- 62 | -------------------- 63 | 64 | procedure Double_Failure (T : in out The_Test_Case) is 65 | Dummy : Boolean; 66 | pragma Unreferenced (T, Dummy); 67 | begin 68 | -- Fail two assertions. Will be checked in Test_Test_Case.Test_Run 69 | Dummy := Assert (False, "first failure"); 70 | Assert (False, "second failure"); 71 | end Double_Failure; 72 | 73 | ------------ 74 | -- Except -- 75 | ------------ 76 | 77 | procedure Except (T : in out Test_Cases.Test_Case'Class) is 78 | pragma Unreferenced (T); 79 | begin 80 | raise Constraint_Error; 81 | end Except; 82 | 83 | -------------------- 84 | -- Register_Tests -- 85 | -------------------- 86 | 87 | procedure Register_Tests (T : in out The_Test_Case) is 88 | package Register_Specific is 89 | new AUnit.Test_Cases.Specific_Test_Case_Registration 90 | (The_Test_Case); 91 | use Register_Specific; 92 | begin 93 | 94 | Register_Routine 95 | (T, Succeed'Access, "Success Test"); 96 | 97 | Register_Routine 98 | (T, Fail'Access, "Failure Test"); 99 | 100 | Register_Wrapper 101 | (T, 102 | Double_Failure_Wrapper'Access, 103 | "Multiple assertion failures"); 104 | 105 | Register_Routine 106 | (T, Except'Access, "Exception Test"); 107 | end Register_Tests; 108 | 109 | ---------- 110 | -- Name -- 111 | ---------- 112 | 113 | function Name (T : The_Test_Case) return Test_String is 114 | pragma Unreferenced (T); 115 | begin 116 | return Format ("Dummy Test Case"); 117 | end Name; 118 | 119 | --------------- 120 | -- Is_Set_Up -- 121 | --------------- 122 | 123 | function Is_Set_Up (T : The_Test_Case) return Boolean is 124 | begin 125 | return T.Is_Set_Up; 126 | end Is_Set_Up; 127 | 128 | ------------------ 129 | -- Is_Torn_Down -- 130 | ------------------ 131 | 132 | function Is_Torn_Down (T : The_Test_Case) return Boolean is 133 | begin 134 | return T.Is_Torn_Down; 135 | end Is_Torn_Down; 136 | 137 | end AUnit.Test_Cases.Tests_Fixtures; 138 | --------------------------------------------------------------------------------