From 238fc3252faec6f3f32d7f9fbc7e956beb166798 Mon Sep 17 00:00:00 2001 From: Fedor Rybin Date: Thu, 29 Feb 2024 10:50:10 +0300 Subject: [PATCH] Fix cascade IO crashes after unexpected error If output file is open when an unexpected error happens, close it. fixes eng/ide/libadalang-tools#148 --- src/test-common.adb | 4 +++- src/test-skeleton.adb | 2 ++ src/test-stub.adb | 2 ++ testsuite/tests/test/error_recovery/importing.ads | 6 ++++++ testsuite/tests/test/error_recovery/p.gpr | 2 ++ testsuite/tests/test/error_recovery/right.adb | 6 ++++++ testsuite/tests/test/error_recovery/right.ads | 3 +++ testsuite/tests/test/error_recovery/test.out | 4 ++++ testsuite/tests/test/error_recovery/test.sh | 3 +++ testsuite/tests/test/error_recovery/test.yaml | 5 +++++ testsuite/tests/test/error_recovery/wrong_1.adb | 6 ++++++ testsuite/tests/test/error_recovery/wrong_1.ads | 4 ++++ testsuite/tests/test/error_recovery/wrong_2.adb | 6 ++++++ testsuite/tests/test/error_recovery/wrong_2.ads | 4 ++++ 14 files changed, 56 insertions(+), 1 deletion(-) create mode 100644 testsuite/tests/test/error_recovery/importing.ads create mode 100644 testsuite/tests/test/error_recovery/p.gpr create mode 100644 testsuite/tests/test/error_recovery/right.adb create mode 100644 testsuite/tests/test/error_recovery/right.ads create mode 100644 testsuite/tests/test/error_recovery/test.out create mode 100644 testsuite/tests/test/error_recovery/test.sh create mode 100644 testsuite/tests/test/error_recovery/test.yaml create mode 100644 testsuite/tests/test/error_recovery/wrong_1.adb create mode 100644 testsuite/tests/test/error_recovery/wrong_1.ads create mode 100644 testsuite/tests/test/error_recovery/wrong_2.adb create mode 100644 testsuite/tests/test/error_recovery/wrong_2.ads diff --git a/src/test-common.adb b/src/test-common.adb index c3f2273f..d939caea 100755 --- a/src/test-common.adb +++ b/src/test-common.adb @@ -861,7 +861,9 @@ package body Test.Common is procedure Close_File is begin - Char_Sequential_IO.Close (Output_File); + if Char_Sequential_IO.Is_Open (Output_File) then + Char_Sequential_IO.Close (Output_File); + end if; end Close_File; ------------------ diff --git a/src/test-skeleton.adb b/src/test-skeleton.adb index 612bf851..be322595 100755 --- a/src/test-skeleton.adb +++ b/src/test-skeleton.adb @@ -578,6 +578,8 @@ package body Test.Skeleton is Suite_Data.TR_List.Clear; Suite_Data.ITR_List.Clear; Suite_Data.LTR_List.Clear; + + Close_File; end Cleanup; ---------------------------- diff --git a/src/test-stub.adb b/src/test-stub.adb index 9e2d3123..7f1b9c44 100755 --- a/src/test-stub.adb +++ b/src/test-stub.adb @@ -369,6 +369,8 @@ package body Test.Stub is Data.Elem_Tree.Clear; Data.Flat_List.Clear; Data.Limited_Withed_Units.Clear; + + Close_File; end Cleanup; ------------------------ diff --git a/testsuite/tests/test/error_recovery/importing.ads b/testsuite/tests/test/error_recovery/importing.ads new file mode 100644 index 00000000..85dd7c27 --- /dev/null +++ b/testsuite/tests/test/error_recovery/importing.ads @@ -0,0 +1,6 @@ +with Wrong_1; +with Wrong_2; +with Right; +package Importing is + function F return Integer is (1); +end importing; diff --git a/testsuite/tests/test/error_recovery/p.gpr b/testsuite/tests/test/error_recovery/p.gpr new file mode 100644 index 00000000..17b1a7d2 --- /dev/null +++ b/testsuite/tests/test/error_recovery/p.gpr @@ -0,0 +1,2 @@ +project p is +end p; diff --git a/testsuite/tests/test/error_recovery/right.adb b/testsuite/tests/test/error_recovery/right.adb new file mode 100644 index 00000000..c0c58386 --- /dev/null +++ b/testsuite/tests/test/error_recovery/right.adb @@ -0,0 +1,6 @@ +package body Right is + function F return String is + begin + return "foo"; + end F; +end Right; diff --git a/testsuite/tests/test/error_recovery/right.ads b/testsuite/tests/test/error_recovery/right.ads new file mode 100644 index 00000000..8e84ddfc --- /dev/null +++ b/testsuite/tests/test/error_recovery/right.ads @@ -0,0 +1,3 @@ +package Right is + function F return String; +end Right; diff --git a/testsuite/tests/test/error_recovery/test.out b/testsuite/tests/test/error_recovery/test.out new file mode 100644 index 00000000..c1d016f8 --- /dev/null +++ b/testsuite/tests/test/error_recovery/test.out @@ -0,0 +1,4 @@ +gnattest: name resolution error for +gnattest: unexpected error while creating stub for wrong_1.ads +gnattest: name resolution error for +gnattest: unexpected error while creating stub for wrong_2.ads diff --git a/testsuite/tests/test/error_recovery/test.sh b/testsuite/tests/test/error_recovery/test.sh new file mode 100644 index 00000000..6bf72e57 --- /dev/null +++ b/testsuite/tests/test/error_recovery/test.sh @@ -0,0 +1,3 @@ +#!/bin/bash + +GNATTEST_STRICT=False gnattest -P p --stub importing.ads -q diff --git a/testsuite/tests/test/error_recovery/test.yaml b/testsuite/tests/test/error_recovery/test.yaml new file mode 100644 index 00000000..3ea1cf6f --- /dev/null +++ b/testsuite/tests/test/error_recovery/test.yaml @@ -0,0 +1,5 @@ +description: + Test error recovery + +driver: shell_script + diff --git a/testsuite/tests/test/error_recovery/wrong_1.adb b/testsuite/tests/test/error_recovery/wrong_1.adb new file mode 100644 index 00000000..49b008cb --- /dev/null +++ b/testsuite/tests/test/error_recovery/wrong_1.adb @@ -0,0 +1,6 @@ +package body Wrong_1 is + procedure Cannot_Stub (X : in out Missing.Something.Some_Type) is + begin + null; + end Cannot_Stub; +end Wrong_1; diff --git a/testsuite/tests/test/error_recovery/wrong_1.ads b/testsuite/tests/test/error_recovery/wrong_1.ads new file mode 100644 index 00000000..23c12a0f --- /dev/null +++ b/testsuite/tests/test/error_recovery/wrong_1.ads @@ -0,0 +1,4 @@ +with Missing.Something; +package Wrong_1 is + procedure Cannot_Stub (X : in out Missing.Something.Some_Type); +end Wrong_1; diff --git a/testsuite/tests/test/error_recovery/wrong_2.adb b/testsuite/tests/test/error_recovery/wrong_2.adb new file mode 100644 index 00000000..3a6ac02a --- /dev/null +++ b/testsuite/tests/test/error_recovery/wrong_2.adb @@ -0,0 +1,6 @@ +package body Wrong_2 is + procedure Cannot_Stub (X : in out Missing.Some_Type) is + begin + null; + end Cannot_Stub; +end Wrong_2; diff --git a/testsuite/tests/test/error_recovery/wrong_2.ads b/testsuite/tests/test/error_recovery/wrong_2.ads new file mode 100644 index 00000000..5f4b4c75 --- /dev/null +++ b/testsuite/tests/test/error_recovery/wrong_2.ads @@ -0,0 +1,4 @@ +with Missing; +package Wrong_2 is + procedure Cannot_Stub (X : in out Missing.Some_Type); +end Wrong_2;