Wrong name mangling with nested function inside unlabelled process

Issue #751

NEWS.md

@@ -1,4 +1,6 @@
 ## Unreleased changes
+- Fixed memory corruption in rare circumstances with functions declared
+  in process declarative regions (#751).
 
 ## Version 1.10.2 - 2023-08-20
 - Fixed a crash due to an array bounds check being incorrectly optimised

src/parse.c

@@ -7991,7 +7991,7 @@ static tree_t p_process_statement(ident_t label)
 
    push_scope(nametab);
    scope_set_container(nametab, t);
-   scope_set_prefix(nametab, label);
+   scope_set_prefix(nametab, tree_ident(t));
 
    p_process_declarative_part(t);
 
@@ -8003,7 +8003,9 @@ static tree_t p_process_statement(ident_t label)
    if (postponed)
       optional(tPOSTPONED);
    consume(tPROCESS);
+
    p_trailing_label(label);
+
    consume(tSEMI);
 
    pop_scope(nametab);

test/parse/issue751.vhd

@@ -0,0 +1,22 @@
+entity issue751 is
+end entity;
+
+architecture test of issue751 is
+begin
+
+    -- No Label on this process
+    process is                          -- _P0
+        function outer return integer is  -- WORK.ISSUE751-TEST._P0.OUTER
+            function inner return integer is  -- WORK.ISSUE751-TEST._P0.OUTER.INNER
+            begin
+                return 42;
+            end function;
+        begin
+            return inner;
+        end function;
+        type abc is (A, B, C);   -- WORK.ISSUE751-TEST._P0.ABC
+    begin
+        wait;
+    end process;
+
+end architecture;

test/regress/issue751.vhd

@@ -0,0 +1,31 @@
+entity issue751 is
+end entity;
+
+architecture test of issue751 is
+    type t_rec is record
+        x : integer;
+        y : string(1 to 5);
+    end record;
+
+    impure function get_rec return t_rec is
+    begin
+        return (1, "hello");
+    end function;
+
+    constant k : t_rec := get_rec;
+begin
+
+    -- This process has no label
+    process is
+        function get_x return integer is
+        begin
+            return k.x + 1;
+        end function;
+
+        constant c : integer := get_x;
+    begin
+        assert c = 2;
+        wait;
+    end process;
+
+end architecture;

test/regress/testlist.txt

@@ -826,3 +826,4 @@ issue744        normal,vhpi
 issue747        fail,gold,gL=10
 vhpi9           normal,vhpi
 func25          normal
+issue751        normal

test/test_parse.c

@@ -5627,6 +5627,44 @@ START_TEST(test_visibility8)
 }
 END_TEST
 
+START_TEST(test_issue751)
+{
+   input_from_file(TESTDIR "/parse/issue751.vhd");
+
+   tree_t e = parse();
+   fail_if(e == NULL);
+   fail_unless(tree_kind(e) == T_ENTITY);
+   lib_put(lib_work(), e);
+
+   tree_t a = parse();
+   fail_if(a == NULL);
+   fail_unless(tree_kind(a) == T_ARCH);
+
+   tree_t p0 = tree_stmt(a, 0);
+   fail_unless(tree_ident(p0) == ident_new("_P0"));
+   fail_unless(tree_flags(p0) & TREE_F_SYNTHETIC_NAME);
+
+   tree_t outer = tree_decl(p0, 0);
+   fail_unless(tree_kind(outer) == T_FUNC_BODY);
+   fail_unless(tree_ident2(outer) == ident_new(
+                  "WORK.ISSUE751-TEST._P0.OUTER()I"));
+
+   tree_t inner = tree_decl(outer, 0);
+   fail_unless(tree_kind(inner) == T_FUNC_BODY);
+   fail_unless(tree_ident2(inner) == ident_new(
+                  "WORK.ISSUE751-TEST._P0.OUTER()I.INNER()I"));
+
+   tree_t abc = tree_decl(p0, 1);
+   fail_unless(tree_kind(abc) == T_TYPE_DECL);
+   fail_unless(type_ident(tree_type(abc)) == ident_new(
+                  "WORK.ISSUE751-TEST._P0.ABC"));
+
+   fail_unless(parse() == NULL);
+
+   fail_if_errors();
+}
+END_TEST
+
 Suite *get_parse_tests(void)
 {
    Suite *s = suite_create("parse");
@@ -5745,6 +5783,7 @@ Suite *get_parse_tests(void)
    tcase_add_test(tc_core, test_issue708);
    tcase_add_test(tc_core, test_issue727);
    tcase_add_test(tc_core, test_visibility8);
+   tcase_add_test(tc_core, test_issue751);
    suite_add_tcase(s, tc_core);
 
    return s;