From 862a8f12cb946ac4a41fb3c5ee81c0764e1c36cd Mon Sep 17 00:00:00 2001
From: Nick Gasson <nick@nickg.me.uk>
Date: Mon, 12 Feb 2024 21:29:02 +0000
Subject: [PATCH] Missing error impure function called indirectly via procedure

Issue #848
---
 src/sem.c               | 29 +++++++++++-----------
 test/parse/issue848.vhd | 54 +++++++++++++++++++++++++++++++++++++++++
 test/test_parse.c       | 32 ++++++++++++++++++++++++
 3 files changed, 100 insertions(+), 15 deletions(-)
 create mode 100644 test/parse/issue848.vhd

diff --git a/src/sem.c b/src/sem.c
index f1f82b33..85f324ce 100644
--- a/src/sem.c
+++ b/src/sem.c
@@ -3120,23 +3120,22 @@ static bool sem_check_fcall(tree_t t, nametab_t *tab)
          return false;
    }
 
-   tree_t decl = tree_ref(t);
-
-   // Pure function may not call an impure function
-   tree_t sub = find_enclosing(tab, S_SUBPROGRAM);
-
-   const bool pure_call_to_impure =
-      sub != NULL && tree_kind(sub) == T_FUNC_BODY
-      && !(tree_flags(sub) & TREE_F_IMPURE)
-      && (tree_flags(decl) & TREE_F_IMPURE);
+   tree_t decl = tree_ref(t), sub;
+   const tree_flags_t flags = tree_flags(decl);
 
-   if (pure_call_to_impure) {
-      diag_t *d = pedantic_diag(t);
-      if (d != NULL) {
-         diag_printf(d, "pure function %s cannot call impure function %s",
-                     istr(tree_ident(sub)), istr(tree_ident(decl)));
-         diag_emit(d);
+   if ((flags & TREE_F_IMPURE) && (sub = find_enclosing(tab, S_SUBPROGRAM))) {
+      // Pure function may not call an impure function
+      if (tree_kind(sub) == T_FUNC_BODY && !(tree_flags(sub) & TREE_F_IMPURE)) {
+         diag_t *d = pedantic_diag(t);
+         if (d != NULL) {
+            diag_printf(d, "pure function %s cannot call impure function %s",
+                        istr(tree_ident(sub)), istr(tree_ident(decl)));
+            diag_emit(d);
+         }
       }
+
+      // Propagate impurity flags
+      tree_set_flag(sub, flags & (TREE_F_IMPURE_FILE | TREE_F_IMPURE_SHARED));
    }
 
    if (!sem_check_call_args(t, decl, tab))
diff --git a/test/parse/issue848.vhd b/test/parse/issue848.vhd
new file mode 100644
index 00000000..08504ec7
--- /dev/null
+++ b/test/parse/issue848.vhd
@@ -0,0 +1,54 @@
+package test_pkg is
+  shared variable v_test : natural;
+  impure function func return natural;
+  procedure proc(var : out natural);
+  pure function test return natural;
+  procedure proc2(var : out natural);
+  pure function test2 return natural;
+  procedure proc3(var : out natural);
+  pure function test3 return natural;
+
+end package test_pkg;
+
+package body test_pkg is
+  impure function func return natural is
+  begin
+    return v_test;
+  end function;
+
+  procedure proc(var : out natural) is
+  begin
+    var := func;
+  end procedure;
+
+  procedure proc2(var : out natural) is
+  begin
+    var := v_test;
+  end procedure;
+
+  procedure proc3(var : out natural) is
+  begin
+    proc2(var);
+  end procedure;
+
+  pure function test return natural is
+    variable v_var : natural;
+  begin
+    proc(v_var);
+    return v_var;
+  end function;
+
+  pure function test2 return natural is
+    variable v_var : natural;
+  begin
+    proc2(v_var);
+    return v_var;
+  end function;
+
+  pure function test3 return natural is
+    variable v_var : natural;
+  begin
+    proc3(v_var);
+    return v_var;
+  end function;
+end package body;
diff --git a/test/test_parse.c b/test/test_parse.c
index 73cf99c1..57e12cbb 100644
--- a/test/test_parse.c
+++ b/test/test_parse.c
@@ -6133,6 +6133,37 @@ START_TEST(test_issue845)
 }
 END_TEST
 
+START_TEST(test_issue848)
+{
+   input_from_file(TESTDIR "/parse/issue848.vhd");
+
+   const error_t expect[] = {
+      { 37, "pure function TEST cannot call procedure PROC which references "
+        "a shared variable" },
+      { 44, "pure function TEST2 cannot call procedure PROC2 which references "
+        "a shared variable" },
+      { 51, "pure function TEST3 cannot call procedure PROC3 which references "
+        "a shared variable" },
+      { -1, NULL }
+   };
+   expect_errors(expect);
+
+   tree_t p = parse();
+   fail_if(p == NULL);
+   fail_unless(tree_kind(p) == T_PACKAGE);
+   lib_put(lib_work(), p);
+
+   tree_t b = parse();
+   fail_if(b == NULL);
+   fail_unless(tree_kind(b) == T_PACK_BODY);
+   lib_put(lib_work(), b);
+
+   fail_unless(parse() == NULL);
+
+   check_expected_errors();
+}
+END_TEST
+
 Suite *get_parse_tests(void)
 {
    Suite *s = suite_create("parse");
@@ -6269,6 +6300,7 @@ Suite *get_parse_tests(void)
    tcase_add_test(tc_core, test_visibility11);
    tcase_add_test(tc_core, test_issue837);
    tcase_add_test(tc_core, test_issue845);
+   tcase_add_test(tc_core, test_issue848);
    suite_add_tcase(s, tc_core);
 
    return s;
-- 
2.39.2