Refactor checking for missing subprogram bodies

lib/nvc/polyfill-body.vhd

@@ -39,4 +39,18 @@ package body polyfill is
         end if;
     end function;
 
+    function to_string (value : real; spec : string) return string is
+    begin
+        return "";
+    end function;
+
+    function to_hstring (value : bit_vector) return string is
+    begin
+        return "";
+    end function;
+
+    function to_ostring (value : bit_vector) return string is
+    begin
+        return "";
+    end function;
 end package body;

lib/nvc/text_util-body.vhd

@@ -439,4 +439,8 @@ package body text_util is
         return change_bounds(buf(pos + 1 to buf'right), 1, buf'right - pos);
     end function;
 
+    function real_to_string (x : real) return string is
+    begin
+        assert false severity failure;
+    end function;
 end package body;

lib/nvc/verilog-body.vhd

@@ -409,4 +409,19 @@ package body verilog is
     begin
         return to_logic(time'pos(now), 64);
     end function;
+
+    procedure sys_finish is
+    begin
+        -- Has native implementation
+    end procedure;
+
+    procedure sys_display (format : string) is
+    begin
+        -- Has native implementation
+    end procedure;
+
+    procedure sys_write (format : string) is
+    begin
+        -- Has native implementation
+    end procedure;
 end package body;

lib/std.08/env-body.vhd

@@ -16,7 +16,9 @@
 
 package body env is
 
-    procedure stop_impl(finish, have_status : boolean; status : integer);
+    procedure stop_impl(finish, have_status : boolean; status : integer) is
+    begin
+    end procedure;
 
     attribute foreign of stop_impl : procedure is "GHDL _std_env_stop";
 

lib/std.19/env-body.vhd

@@ -22,7 +22,9 @@ package body env is
     -- Forward slash is a legal separator on both Windows and Unix
     constant DIR_SEPARATOR : string := "/";
 
-    procedure stop_impl(finish, have_status : boolean; status : integer);
+    procedure stop_impl (finish, have_status : boolean; status : integer) is
+    begin
+    end procedure;
 
     attribute foreign of stop_impl : procedure is "GHDL _std_env_stop";
 
@@ -459,7 +461,10 @@ package body env is
         return null;
     end function;
 
-    procedure get_caller_file_name (ptr : out line);
+    procedure get_caller_file_name (ptr : out line) is
+    begin
+    end procedure;
+
     attribute foreign of get_caller_file_name : procedure is "GHDL _std_env_file_name";
 
     impure function file_name return line is
@@ -476,7 +481,10 @@ package body env is
         return result.all;
     end function;
 
-    procedure get_caller_file_path (ptr : out line);
+    procedure get_caller_file_path (ptr : out line) is
+    begin
+    end procedure;
+
     attribute foreign of get_caller_file_path : procedure is "GHDL _std_env_file_path";
 
     impure function file_path return line is
@@ -532,32 +540,63 @@ package body env is
     attribute foreign of GetVhdlAssertCount [severity_level return natural] :
         function is "INTERNAL _std_env_get_vhdl_assert_count";
 
+    impure function GetVhdlAssertCount (level : severity_level) return natural is
+    begin
+    end function;
+
     attribute foreign of ClearVhdlAssert [] :
         procedure is "INTERNAL _std_env_clear_vhdl_assert";
 
+    procedure ClearVhdlAssert is
+    begin
+    end procedure;
+
     procedure SetVhdlAssertEnable (Enable : boolean := true) is
     begin
-        SetVhdlAssertEnable (note,    Enable);
-        SetVhdlAssertEnable (warning, Enable);
-        SetVhdlAssertEnable (error,   Enable);
-        SetVhdlAssertEnable (failure, Enable);
+        for s in note to failure loop
+            SetVhdlAssertEnable(s, Enable);
+        end loop;
     end procedure;
 
     attribute foreign of SetVhdlAssertEnable [severity_level, boolean] :
         procedure is "INTERNAL _std_env_set_vhdl_assert_enable";
 
+    procedure SetVhdlAssertEnable (level : severity_level := note;
+                                   enable : boolean := true) is
+    begin
+    end procedure;
+
     attribute foreign of GetVhdlAssertEnable [severity_level return boolean] :
         function is "INTERNAL _std_env_get_vhdl_assert_enable";
 
+    impure function GetVhdlAssertEnable (level : severity_level := note) return boolean is
+    begin
+    end function;
+
     attribute foreign of SetVhdlAssertFormat [severity_level, string] :
         procedure is "INTERNAL _std_env_set_assert_format";
 
+    procedure SetVhdlAssertFormat (level : severity_level; format: string) is
+    begin
+    end procedure;
+
     attribute foreign of SetVhdlAssertFormat [severity_level, string, boolean] :
         procedure is "INTERNAL _std_env_set_assert_format_valid";
 
+    procedure SetVhdlAssertFormat (level : severity_level;
+                                   format: string;
+                                   valid : out boolean) is
+    begin
+    end procedure;
+
     attribute foreign of GetVhdlAssertFormat [severity_level return string] :
         function is "INTERNAL _std_env_get_assert_format";
 
+    impure function GetVhdlAssertFormat (level : severity_level) return string is
+    begin
+        return "";
+    end function;
+
     type read_severity_pt is protected
         procedure set (level : severity_level);
         impure function get return severity_level;

src/lower.c

@@ -9898,7 +9898,6 @@ static void lower_protected_body(lower_unit_t *lu, object_t *obj)
 
 static void lower_decls(lower_unit_t *lu, tree_t scope)
 {
-   bool has_foreign = false;
    const int ndecls = tree_decls(scope);
    for (int i = 0; i < ndecls; i++) {
       tree_t d = tree_decl(scope, i);
@@ -9908,7 +9907,6 @@ static void lower_decls(lower_unit_t *lu, tree_t scope)
          unit_registry_defer(lu->registry, tree_ident2(tree_ref(d)), lu,
                              emit_function, lower_foreign_stub, NULL,
                              tree_to_object(d));
-         has_foreign = true;
       }
    }
 
@@ -9922,7 +9920,7 @@ static void lower_decls(lower_unit_t *lu, tree_t scope)
       case T_FUNC_BODY:
          {
             ident_t mangled = tree_ident2(d);
-            if (!has_foreign || !unit_registry_query(lu->registry, mangled)) {
+            if (!unit_registry_query(lu->registry, mangled)) {
                unit_registry_defer(lu->registry, mangled, lu,
                                    emit_function, lower_func_body,
                                    lu->cover, tree_to_object(d));
@@ -9944,7 +9942,7 @@ static void lower_decls(lower_unit_t *lu, tree_t scope)
             emit_fn_t emitfn = never_waits ? emit_function : emit_procedure;
             ident_t mangled = tree_ident2(d);
 
-            if (!has_foreign || !unit_registry_query(lu->registry, mangled)) {
+            if (!unit_registry_query(lu->registry, mangled)) {
                unit_registry_defer(lu->registry, tree_ident2(d),
                                    lu, emitfn, lower_proc_body, lu->cover,
                                    tree_to_object(d));

src/names.c

@@ -124,24 +124,32 @@ typedef struct {
    int loop;
 } label_cnts_t;
 
+typedef struct {
+   defer_check_fn_t fn;
+   tree_t           tree;
+} defer_check_t;
+
+typedef A(defer_check_t) defer_checks_t;
+
 struct scope {
-   scope_t       *parent;
-   sym_chunk_t    symbols;
-   sym_chunk_t   *sym_tail;
-   hash_t        *lookup;
-   hash_t        *gmap;
-   spec_t        *specs;
-   overload_t    *overload;
-   formal_kind_t  formal_kind;
-   formal_fn_t    formal_fn;
-   void          *formal_arg;
-   ident_t        prefix;
-   tree_t         container;
-   bool           suppress;
-   lazy_sym_t    *lazy;
-   tree_list_t    imported;
-   label_cnts_t   lbl_cnts;
-   scope_t       *chain;
+   scope_t        *parent;
+   sym_chunk_t     symbols;
+   sym_chunk_t    *sym_tail;
+   hash_t         *lookup;
+   hash_t         *gmap;
+   spec_t         *specs;
+   overload_t     *overload;
+   formal_kind_t   formal_kind;
+   formal_fn_t     formal_fn;
+   void           *formal_arg;
+   ident_t         prefix;
+   tree_t          container;
+   bool            suppress;
+   lazy_sym_t     *lazy;
+   tree_list_t     imported;
+   label_cnts_t    lbl_cnts;
+   scope_t        *chain;
+   defer_checks_t  deferred;
 };
 
 typedef struct _nametab {
@@ -428,6 +436,11 @@ void pop_scope(nametab_t *tab)
    assert(tab->top_scope != NULL);
    scope_t *tmp = tab->top_scope->parent;
 
+   for (int i = 0; i < tab->top_scope->deferred.count; i++) {
+      const defer_check_t *dc = &(tab->top_scope->deferred.items[i]);
+      (*dc->fn)(dc->tree, tab->top_scope->container, tab);
+   }
+
    for (spec_t *it = tab->top_scope->specs, *next; it != NULL; it = next) {
       if (it->kind == SPEC_EXACT && it->matches == 0
           && !tab->top_scope->suppress)
@@ -446,6 +459,12 @@ void suppress_errors(nametab_t *tab)
    tab->top_scope->suppress = true;
 }
 
+void defer_check(nametab_t *tab, defer_check_fn_t fn, tree_t t)
+{
+   defer_check_t dc = { fn, t };
+   APUSH(tab->top_scope->deferred, dc);
+}
+
 void map_generic_type(nametab_t *tab, type_t generic, type_t actual)
 {
    assert(type_kind(generic) == T_GENERIC);
@@ -730,25 +749,6 @@ static name_mask_t name_mask_for(tree_t t)
    }
 }
 
-static bool type_has_error(type_t type)
-{
-   if (type_is_none(type))
-      return true;
-
-   if (type_is_subprogram(type)) {
-      const int nparams = type_params(type);
-      for (int i = 0; i < nparams; i++) {
-         if (type_is_none(type_param(type, i)))
-            return true;
-      }
-
-      if (type_kind(type) == T_FUNC && type_is_none(type_result(type)))
-         return true;
-   }
-
-   return false;
-}
-
 static void add_type_literals(scope_t *s, type_t type, make_visible_t fn)
 {
    switch (type_kind(type)) {

src/names.h

@@ -68,6 +68,9 @@ bool is_enclosing(nametab_t *tab, tree_t container);
 bool is_same_region(nametab_t *tab, tree_t decl);
 void suppress_errors(nametab_t *tab);
 
+typedef void (*defer_check_fn_t)(tree_t, tree_t, nametab_t *);
+void defer_check(nametab_t *tab, defer_check_fn_t fn, tree_t t);
+
 void map_generic_type(nametab_t *tab, type_t generic, type_t actual);
 void map_generic_package(nametab_t *tab, tree_t generic, tree_t actual);
 void map_generic_box(nametab_t *tab, tree_t inst, tree_t g, unsigned pos);

src/parse.c

@@ -7679,8 +7679,6 @@ static tree_t p_protected_type_body(ident_t id)
 
    p_protected_type_body_declarative_part(body);
 
-   pop_scope(nametab);
-
    consume(tEND);
    consume(tPROTECTED);
    consume(tBODY);
@@ -7689,6 +7687,8 @@ static tree_t p_protected_type_body(ident_t id)
 
    tree_set_loc(body, CURRENT_LOC);
    sem_check(body, nametab);
+
+   pop_scope(nametab);
    return body;
 }
 
@@ -8673,8 +8673,11 @@ static tree_t p_package_declaration(tree_t unit)
    consume(tIS);
 
    push_scope(nametab);
+   scope_set_container(nametab, pack);
+
    if (standard() >= STD_08)
       p_package_header(pack);
+
    p_package_declarative_part(pack);
 
    if (bootstrapping)
@@ -12663,6 +12666,7 @@ static void p_architecture_body(tree_t unit)
    insert_name(nametab, unit, NULL);
 
    push_scope(nametab);
+   scope_set_container(nametab, unit);
 
    if (e != NULL) {
       insert_generics(nametab, e);
@@ -12845,6 +12849,7 @@ static tree_t p_package_body(tree_t unit)
    consume(tIS);
 
    push_scope(nametab);
+   scope_set_container(nametab, body);
 
    if (pack != NULL) {
       insert_generics(nametab, pack);
@@ -12856,9 +12861,6 @@ static tree_t p_package_body(tree_t unit)
    if (pack != NULL && (tree_global_flags(pack) & TREE_GF_DEFERRED_INST))
       package_body_deferred_instantiation(pack, body);
 
-   pop_scope(nametab);
-   pop_scope(nametab);
-
    consume(tEND);
 
    if (optional(tPACKAGE))
@@ -12870,6 +12872,9 @@ static tree_t p_package_body(tree_t unit)
    tree_set_loc(body, CURRENT_LOC);
    sem_check(body, nametab);
 
+   pop_scope(nametab);
+   pop_scope(nametab);
+
    return body;
 }