From 89e8d4526dfd6b86ba2bee8225e9b9649ac7abf0 Mon Sep 17 00:00:00 2001
From: Nick Gasson <nick@nickg.me.uk>
Date: Thu, 19 Sep 2024 22:42:49 +0100
Subject: [PATCH] Check function specification and body return types exactly
 match

Fixes #980
---
 src/sem.c             | 21 +++++++++++++++++++++
 test/sem/issue980.vhd | 17 +++++++++++++++++
 test/test_sem.c       | 21 +++++++++++++++++++++
 3 files changed, 59 insertions(+)
 create mode 100644 test/sem/issue980.vhd

diff --git a/src/sem.c b/src/sem.c
index 5e18b8d88..c34927907 100644
--- a/src/sem.c
+++ b/src/sem.c
@@ -1993,6 +1993,27 @@ static bool sem_check_conforming(tree_t decl, tree_t body)
          ok &= sem_compare_interfaces(decl, body, i, tree_generic, "generic");
    }
 
+   type_t dtype = tree_type(decl);
+   type_t btype = tree_type(body);
+
+   if (type_has_result(dtype) && type_has_result(btype)) {
+      type_t dresult = type_result(dtype);
+      type_t bresult = type_result(btype);
+
+      if (!type_strict_eq(dresult, bresult)) {
+         diag_t *d = diag_new(DIAG_ERROR, tree_loc(body));
+         diag_printf(d, "return type of function body %s does not match type "
+                     "%s in specification", istr(tree_ident(body)),
+                     type_pp(dresult));
+         diag_hint(d, tree_loc(decl), "specification has return type %s",
+                   type_pp(dresult));
+         diag_hint(d, tree_loc(body), "body has return type %s ",
+                   type_pp(bresult));
+         diag_emit(d);
+         ok = false;
+      }
+   }
+
    return ok;
 }
 
diff --git a/test/sem/issue980.vhd b/test/sem/issue980.vhd
new file mode 100644
index 000000000..953411a82
--- /dev/null
+++ b/test/sem/issue980.vhd
@@ -0,0 +1,17 @@
+package issue980 is
+    type t_enum is (a, b, c);
+    subtype t_sub is t_enum range a to b;
+
+    function foo return t_sub;
+    procedure bar (x : t_sub);
+end package;
+
+package body issue980 is
+    function foo return t_enum is       -- Error
+    begin
+    end function;
+
+    procedure bar (x : t_enum) is       -- Error
+    begin
+    end procedure;
+end package body;
diff --git a/test/test_sem.c b/test/test_sem.c
index 1238ea055..ac5b5d64e 100644
--- a/test/test_sem.c
+++ b/test/test_sem.c
@@ -3750,6 +3750,26 @@ START_TEST(test_lcs2016_49)
 }
 END_TEST
 
+START_TEST(test_issue980)
+{
+   input_from_file(TESTDIR "/sem/issue980.vhd");
+
+   const error_t expect[] = {
+      { 10, "return type of function body FOO does not match type T_SUB in "
+        "specification" },
+      {  0, "body has return type T_ENUM" },
+      {  0, "specification has return type T_SUB" },
+      { 14, "subtype of parameter X does not match type T_SUB" },
+      { -1, NULL }
+   };
+   expect_errors(expect);
+
+   parse_and_check(T_PACKAGE, T_PACK_BODY);
+
+   check_expected_errors();
+}
+END_TEST
+
 Suite *get_sem_tests(void)
 {
    Suite *s = suite_create("sem");
@@ -3922,6 +3942,7 @@ Suite *get_sem_tests(void)
    tcase_add_test(tc_core, test_issue958);
    tcase_add_test(tc_core, test_issue965);
    tcase_add_test(tc_core, test_lcs2016_49);
+   tcase_add_test(tc_core, test_issue980);
    suite_add_tcase(s, tc_core);
 
    return s;