Checking for VHDL-2019 pointers-to-protected-types

src/diag.c

@@ -408,6 +408,7 @@ static const struct {
    { "Entity statement part", { [STD_93] = "1.1.3", [STD_08] = "3.2.4" } },
    { "Qualified expressions", { [STD_08] = "9.3.5" } },
    { "Interface package declarations", { [STD_08] = "6.5.5" } },
+   { "Selected names", { [STD_08] = "8.3", [STD_93] = "6.3" } },
 };
 
 diag_t *diag_new(diag_level_t level, const loc_t *loc)

src/names.c

@@ -25,6 +25,7 @@
 #include "names.h"
 #include "option.h"
 #include "phase.h"
+#include "thread.h"
 #include "type.h"
 
 #include <assert.h>
@@ -129,6 +130,7 @@ struct scope {
    void          *formal_arg;
    ident_t        prefix;
    tree_t         container;
+   type_t         type;
    bool           suppress;
    lazy_sym_t    *lazy;
    tree_list_t    imported;
@@ -960,24 +962,60 @@ static ident_t unit_bare_name(tree_t unit)
    return ident_rfrom(unit_name, '.') ?: unit_name;
 }
 
+static scope_t *scope_for_type(nametab_t *tab, type_t type)
+{
+   static hash_t *cache = NULL;
+   INIT_ONCE(cache = hash_new(128));
+
+   assert(type_is_protected(type));
+
+   const bool cacheable = type_frozen(type);
+   void *key = type;
+
+   scope_t *s = NULL;
+   if (cacheable && (s = hash_get(cache, key)))
+      return s;
+   else {
+      for (scope_t *ss = tab->top_scope; ss; ss = ss->parent) {
+         for (s = ss->chain; s; s = s->chain) {
+            if (s->type == type)
+               return s;
+         }
+      }
+   }
+
+   s = xcalloc(sizeof(scope_t));
+   s->lookup   = hash_new(128);
+   s->sym_tail = &(s->symbols);
+   s->type     = type;
+
+   const int ndecls = type_decls(type);
+   for (int i = 0; i < ndecls; i++) {
+      tree_t d = type_decl(type, i);
+      make_visible_fast(s, tree_ident(d), d);
+   }
+
+   if (cacheable)
+      hash_put(cache, key, s);
+   else {
+      s->chain = tab->top_scope->chain;
+      tab->top_scope->chain = s;
+   }
+
+   return s;
+}
+
 static scope_t *private_scope_for(nametab_t *tab, tree_t unit)
 {
    static hash_t *cache = NULL;
-   if (cache == NULL)
-      cache = hash_new(128);
+   INIT_ONCE(cache = hash_new(128));
 
    const tree_kind_t kind = tree_kind(unit);
 
-   type_t type = NULL;
    bool cacheable = true;
    void *key = unit;
    if (kind == T_LIBRARY)
       key = tree_ident(unit);   // Tree pointer is not stable
-   else if (kind == T_PARAM_DECL || kind == T_VAR_DECL || kind == T_PORT_DECL) {
-      key = type = tree_type(unit);
-      assert(type_is_protected(type));
-      cacheable = type_frozen(type);
-   }
    else {
       assert(is_container(unit));
       cacheable = tree_frozen(unit);
@@ -1002,13 +1040,6 @@ static scope_t *private_scope_for(nametab_t *tab, tree_t unit)
 
    if (kind == T_LIBRARY)
       make_library_visible(s, lib_require(tree_ident(unit)));
-   else if (type != NULL) {
-      const int ndecls = type_decls(type);
-      for (int i = 0; i < ndecls; i++) {
-         tree_t d = type_decl(type, i);
-         make_visible_fast(s, tree_ident(d), d);
-      }
-   }
    else {
       // For package instances do not export the names declared only in
       // the body
@@ -2093,29 +2124,40 @@ static void overload_add_candidate(overload_t *o, tree_t d)
    APUSH(o->candidates, d);
 }
 
-static tree_t get_container(tree_t t)
+static type_t get_protected_type(tree_t t)
 {
    switch (tree_kind(t)) {
+   case T_ALL:
    case T_ALIAS:
-      return get_container(tree_value(t));
+      return get_protected_type(tree_value(t));
    case T_REF:
-      return get_container(tree_ref(t));
+      return get_protected_type(tree_ref(t));
    case T_VAR_DECL:
    case T_PARAM_DECL:
    case T_PORT_DECL:
-      return type_is_protected(tree_type(t)) ? t : NULL;
+      {
+         type_t type = tree_type(t);
+         for (;;) {
+            if (type_is_access(type))
+               type = type_designated(type);
+            else if (type_is_protected(type))
+               return type;
+            else
+               return NULL;
+         }
+      }
    default:
-      return is_container(t) ? t : NULL;
+      return NULL;
    }
 }
 
 static void begin_overload_resolution(overload_t *o)
 {
    const symbol_t *sym = NULL;
    if (o->prefix != NULL) {
-      tree_t container = get_container(o->prefix);
-      if (container != NULL) {
-         scope_t *scope = private_scope_for(o->nametab, container);
+      type_t type = get_protected_type(o->prefix);
+      if (type != NULL) {
+         scope_t *scope = scope_for_type(o->nametab, type);
          sym = symbol_for(scope, o->name);
       }
    }

src/sem.c

@@ -845,13 +845,15 @@ static bool sem_check_type_decl(tree_t t, nametab_t *tab)
          if (!sem_check_subtype(t, designated, tab))
             return false;
 
-         if (type_is_file(designated))
-            sem_error(t, "access type %s cannot designate file type",
-                      istr(tree_ident(t)));
+         if (standard() < STD_19) {
+            if (type_is_file(designated))
+               sem_error(t, "access type %s cannot designate file type",
+                         istr(tree_ident(t)));
 
-         if (type_is_protected(designated))
-            sem_error(t, "access type %s cannot designate protected type",
-                      istr(tree_ident(t)));
+            if (type_is_protected(designated))
+               sem_error(t, "access type %s cannot designate protected type",
+                         istr(tree_ident(t)));
+         }
 
          return true;
       }
@@ -5431,12 +5433,17 @@ static bool sem_check_new(tree_t t, nametab_t *tab)
    if (!sem_check_subtype(value, type, tab))
       return false;
 
-   if (!tree_has_value(value) && type_is_unconstrained(type))
+   const bool has_initial = tree_has_value(value);
+
+   if (!has_initial && type_is_unconstrained(type))
       sem_error(t, "unconstrained array type %s not allowed in allocator "
                 "expression", type_pp(type));
    else if (type_is_incomplete(type))
       sem_error(t, "incomplete type %s found in allocator expression",
                 type_pp(type));
+   else if (has_initial && type_is_protected(type))
+      sem_error(t, "protected type %s cannot have initial value",
+                type_pp(type));
 
    type_t designated = type_designated(access_type);
 
@@ -5458,8 +5465,15 @@ static bool sem_check_all(tree_t t, nametab_t *tab)
    if (type_is_none(value_type))
       return false;
 
-   if (!type_is_access(value_type))
-      sem_error(value, "expression type %s is not access", type_pp(value_type));
+   if (!type_is_access(value_type)) {
+      diag_t *d = diag_new(DIAG_ERROR, tree_loc(value));
+      diag_printf(d, "prefix of a selected name with suffix ALL must "
+                  "have access type");
+      diag_hint(d, tree_loc(value), "prefix has type %s", type_pp(value_type));
+      diag_lrm(d, STD_08, "8.3");
+      diag_emit(d);
+      return false;
+   }
 
    return true;
 }

test/sem/lcs2016_14a.vhd

@@ -0,0 +1,42 @@
+entity lcs2016_014a is
+end entity;
+
+architecture test of lcs2016_014a is
+    type pt is protected
+        procedure proc;
+        function func (x : integer := 2) return integer;
+    end protected;
+
+    type pt is protected body
+        procedure proc is
+        begin
+        end procedure;
+        function func (x : integer := 2) return integer is
+        begin
+            return x;
+        end function;
+    end protected body;
+
+    type ptp is access pt;          -- OK
+    type ft is file of natural;     -- OK
+    type ftp is access ft;          -- OK
+
+    -- TODO: additions re. generic protected types
+begin
+
+    p1: process is
+        variable sv : ptp;              -- OK
+        variable v : pt;
+    begin
+        assert sv = null;               -- OK
+        sv := new pt;                   -- OK
+        sv.all.proc;                    -- OK
+        sv.proc;                        -- OK
+        sv.all.all.proc;                -- Error
+        assert sv.all.func = 2;         -- OK
+        assert sv.func(5) = 2;          -- OK
+        sv := new pt'(sv.all);          -- Error (?)
+        wait;
+    end process;
+
+end architecture;

test/test_sem.c

@@ -880,7 +880,7 @@ START_TEST(test_access)
       { 103, "declaration of variable P hides package P" },
       { 105, "incomplete type A found in allocator expression" },
       { 109, "declaration of variable P hides package P" },
-      { 111, "expression type INT_VEC is not access" },
+      { 111, "prefix of a selected name with suffix ALL must have access " },
       { 125, "access type PTP cannot designate protected type" },
       { 127, "access type FTP cannot designate file type" },
       { -1, NULL }
@@ -3190,6 +3190,25 @@ START_TEST(test_lcs2016_41)
 }
 END_TEST
 
+START_TEST(test_lcs2016_14a)
+{
+   set_standard(STD_19);
+
+   input_from_file(TESTDIR "/sem/lcs2016_14a.vhd");
+
+   const error_t expect[] = {
+      { 35, "prefix of a selected name with suffix ALL must have access type" },
+      { 38, "protected type PT cannot have initial value" },
+      { -1, NULL }
+   };
+   expect_errors(expect);
+
+   parse_and_check(T_ENTITY, T_ARCH);
+
+   check_expected_errors();
+}
+END_TEST
+
 Suite *get_sem_tests(void)
 {
    Suite *s = suite_create("sem");
@@ -3341,6 +3360,7 @@ Suite *get_sem_tests(void)
    tcase_add_test(tc_core, test_lcs2016_18);
    tcase_add_test(tc_core, test_issue713);
    tcase_add_test(tc_core, test_lcs2016_41);
+   tcase_add_test(tc_core, test_lcs2016_14a);
    suite_add_tcase(s, tc_core);
 
    return s;

www/features.html.in

@@ -196,7 +196,7 @@ table below.
     <td><a href="http://www.eda-twiki.org/cgi-bin/view.cgi/P1076/LCS2016_014a">
         LCS2016-014a</td>
     <td>Pointers to composites of protected types</td>
-    <td class="feature-missing"></td>
+    <td class="feature-partial">master</td>
   </tr>
   <tr>
     <td><a href="http://www.eda-twiki.org/cgi-bin/view.cgi/P1076/LCS2016_015">