Semantic checking for allocator expressions

src/sem.c

@@ -1100,7 +1100,8 @@ static bool sem_check_context(tree_t t)
 static bool sem_check_constrained(tree_t t, type_t type)
 {
    type_set_push();
-   type_set_add(type);
+   if (type != NULL)
+      type_set_add(type);
    bool ok = sem_check(t);
    type_set_pop();
    return ok;
@@ -2172,6 +2173,7 @@ static tree_t sem_check_lvalue(tree_t t)
    case T_ARRAY_REF:
    case T_ALIAS:
    case T_RECORD_REF:
+   case T_ALL:
       return sem_check_lvalue(tree_value(t));
    case T_VAR_DECL:
    case T_SIGNAL_DECL:
@@ -4218,6 +4220,58 @@ static bool sem_check_file_decl(tree_t t)
    return true;
 }
 
+static bool sem_check_new(tree_t t)
+{
+   // Rules for allocators are in LRM 93 section 7.3.6
+
+   tree_t value = tree_value(t);
+
+   if (!sem_check_constrained(value, NULL))
+      return false;
+
+   switch (tree_kind(value)) {
+   case T_REF:
+      {
+         tree_t decl = tree_ref(value);
+         if (tree_kind(decl) != T_TYPE_DECL)
+            sem_error(value, "%s does not name a type",
+                      istr(tree_ident(value)));
+      }
+      break;
+
+   case T_QUALIFIED:
+      break;
+
+   case T_ARRAY_SLICE:
+      sem_error(t, "sorry, this form of allocator expression is not "
+                "supported yet");
+
+   default:
+      sem_error(t, "invalid allocator expression");
+   }
+
+   type_t type = type_new(T_ACCESS);
+   type_set_access(type, tree_type(value));
+
+   tree_set_type(t, type);
+   return true;
+}
+
+static bool sem_check_all(tree_t t)
+{
+   tree_t value = tree_value(t);
+   if (!sem_check_constrained(value, NULL))
+      return false;
+
+   type_t value_type = tree_type(value);
+
+   if (type_kind(value_type) != T_ACCESS)
+      sem_error(value, "expression must have access type");
+
+   tree_set_type(t, type_access(value_type));
+   return true;
+}
+
 static void sem_intern_strings(void)
 {
    // Intern some commonly used strings
@@ -4329,6 +4383,10 @@ bool sem_check(tree_t t)
       return sem_check_field_decl(t);
    case T_FILE_DECL:
       return sem_check_file_decl(t);
+   case T_NEW:
+      return sem_check_new(t);
+   case T_ALL:
+      return sem_check_all(t);
    default:
       sem_error(t, "cannot check %s", tree_kind_str(tree_kind(t)));
    }

src/tree.c

@@ -266,7 +266,7 @@ static const imask_t has_map[T_LAST_TREE_KIND] = {
    (I_IDENT | I_VALUE | I_TYPE),
 
    // T_ALL
-   (I_VALUE),
+   (I_VALUE | I_TYPE),
 
    // T_NEW
    (I_VALUE | I_TYPE),

src/type.c

@@ -247,39 +247,46 @@ bool type_eq(type_t a, type_t b)
    assert(a != NULL);
    assert(b != NULL);
 
-   assert(type_kind(a) != T_UNRESOLVED);
-   assert(type_kind(b) != T_UNRESOLVED);
+   type_kind_t kind_a = type_kind(a);
+   type_kind_t kind_b = type_kind(b);
+
+   if ((kind_a == T_UNRESOLVED) || (kind_b == T_UNRESOLVED))
+      return false;
 
    if (a == b)
       return true;
 
    // Subtypes are convertible to the base type
-   while (type_kind(a) == T_SUBTYPE)
+   while ((kind_a = type_kind(a)) == T_SUBTYPE)
       a = type_base(a);
-   while (type_kind(b) == T_SUBTYPE)
+   while ((kind_b = type_kind(b)) == T_SUBTYPE)
       b = type_base(b);
 
    const bool compare_c_u_arrays =
-      (type_kind(a) == T_CARRAY && type_kind(b) == T_UARRAY)
-      || (type_kind(a) == T_UARRAY && type_kind(b) == T_CARRAY);
+      (kind_a == T_CARRAY && kind_b == T_UARRAY)
+      || (kind_a == T_UARRAY && kind_b == T_CARRAY);
 
-   if ((type_kind(a) != type_kind(b)) && !compare_c_u_arrays)
+   if ((kind_a != kind_b) && !compare_c_u_arrays)
       return false;
 
    // Universal integer type is equal to any other integer type
    type_t universal_int = type_universal_int();
    ident_t uint_i = type_ident(universal_int);
-   if (type_kind(a) == T_INTEGER
+   if (kind_a == T_INTEGER
        && (type_ident(a) == uint_i || type_ident(b) == uint_i))
       return true;
 
    // Universal real type is equal to any other real type
    type_t universal_real = type_universal_real();
    ident_t ureal_i = type_ident(universal_real);
-   if (type_kind(a) == T_REAL
+   if (kind_a == T_REAL
        && (type_ident(a) == ureal_i || type_ident(b) == ureal_i))
       return true;
 
+   // Access types are equal if the pointed to type is the same
+   if (kind_a == T_ACCESS)
+      return type_eq(type_access(a), type_access(b));
+
    // XXX: this is not quite right as structurally equivalent types
    // may be declared in different scopes with the same name but
    // shouldn't compare equal
@@ -319,16 +326,27 @@ ident_t type_ident(type_t t)
 {
    assert(t != NULL);
 
-   if (t->ident == NULL && t->kind == T_SUBTYPE) {
+   if (t->ident == NULL) {
       char buf[128];
-      snprintf(buf, sizeof(buf), "anonymous subtype of %s",
-               istr(type_ident(type_base(t))));
+      switch (t->kind) {
+      case T_SUBTYPE:
+         snprintf(buf, sizeof(buf), "anonymous subtype of %s",
+                  istr(type_ident(type_base(t))));
+         break;
+
+      case T_ACCESS:
+         snprintf(buf, sizeof(buf), "access to %s",
+                  istr(type_ident(type_access(t))));
+         break;
+
+      default:
+         assert(false);
+      }
+
       return ident_new(buf);
    }
-   else {
-      assert(t->ident != NULL);
+   else
       return t->ident;
-   }
 }
 
 void type_set_ident(type_t t, ident_t id)

test/sem/access.vhd

@@ -15,6 +15,13 @@ package body p is
         v := null;                      -- OK
         i := null;                      -- Error
         deallocate(v);                  -- OK
+        v := new integer;               -- OK
+        v := new integer'(5);           -- OK
+        v := new 5;                     -- Error
+        v := new i;                     -- Error
+        v.all := 5;                     -- OK
+        v := 5;                         -- Error
+        i := v.all + 5;                 -- OK
     end procedure;
 
 end package body;

test/test_sem.c

@@ -951,6 +951,9 @@ START_TEST(test_access)
    const error_t expect[] = {
       {  5, "type FOO is not defined" },
       { 16, "NULL expression must have access type" },
+      { 20, "invalid allocator expression" },
+      { 21, "I does not name a type" },
+      { 23, "does not match type of target WORK.P.INT_PTR" },
       { -1, NULL }
    };
    expect_errors(expect);