Semantic checking for access types

src/parse.y

@@ -163,6 +163,7 @@
 %type <t> comp_instance_stmt conc_stmt_without_label elsif_list
 %type <t> delay_mechanism bit_string_literal block_stmt expr_or_open
 %type <t> conc_select_assign_stmt generate_stmt condition_clause
+%type <t> null_literal
 %type <i> id opt_id selected_id func_name
 %type <l> interface_object_decl interface_list
 %type <l> port_clause generic_clause interface_decl signal_decl
@@ -242,7 +243,6 @@ context_item : library_clause { $$ = NULL; } | use_clause ;
 library_clause
 : tLIBRARY id_list tSEMI
   {
-     // TODO: foreach(id_list) { load_library(..); }
      list_free($2);
   }
 ;
@@ -1492,7 +1492,6 @@ waveform_element
      tree_set_value($$, $1);
      tree_set_delay($$, $3);
   }
-| tNULL { $$ = NULL; }
 ;
 
 condition_clause
@@ -1980,8 +1979,17 @@ literal
 : numeric_literal
 | string_literal
 | bit_string_literal
-/*   | null
- */
+| null_literal
+;
+
+null_literal
+: tNULL
+  {
+     $$ = tree_new(T_LITERAL);
+     tree_set_loc($$, &@$);
+     literal_t l = { .kind = L_NULL };
+     tree_set_literal($$, l);
+  }
 ;
 
 string_literal

src/sem.c

@@ -826,6 +826,16 @@ static void sem_declare_predefined_ops(tree_t decl)
       }
       break;
 
+   case T_ACCESS:
+      {
+         ident_t deallocate_i = ident_new("DEALLOCATE");
+
+         tree_t deallocate = sem_builtin_proc(deallocate_i, "deallocate");
+         sem_add_port(deallocate, t, PORT_INOUT, NULL);
+         scope_insert(deallocate);
+      }
+      break;
+
    default:
       break;
    }
@@ -1413,6 +1423,18 @@ static bool sem_check_type_decl(tree_t t)
          return true;
       }
 
+   case T_ACCESS:
+      // Rules for access types are in LRM 93 section 3.3
+      {
+         type_t a = type_access(base);
+
+         if (!sem_check_type(t, &a))
+            return false;
+         type_set_access(base, a);
+
+         return true;
+      }
+
    default:
       return true;
    }
@@ -1551,6 +1573,15 @@ static tree_t sem_default_value(type_t type)
          return def;
       }
 
+   case T_ACCESS:
+      {
+         tree_t null = tree_new(T_LITERAL);
+         literal_t l = { .kind = L_NULL };
+         tree_set_literal(null, l);
+         tree_set_type(null, type);
+         return null;
+      }
+
    default:
       assert(false);
    }
@@ -3146,9 +3177,24 @@ static bool sem_check_literal(tree_t t)
    case L_INT:
       tree_set_type(t, type_universal_int());
       break;
+
    case L_REAL:
       tree_set_type(t, type_universal_real());
       break;
+
+   case L_NULL:
+      {
+         type_t access_type;
+         if (!type_set_uniq(&access_type))
+            sem_error(t, "invalid use of NULL expression");
+
+         if (type_kind(access_type) != T_ACCESS)
+            sem_error(t, "NULL expression must have access type");
+
+         tree_set_type(t, access_type);
+      }
+      break;
+
    default:
       assert(false);
    }

src/tree.h

@@ -110,7 +110,7 @@ typedef struct literal {
       int64_t i;
       double  r;
    };
-   enum { L_INT, L_REAL } kind;
+   enum { L_INT, L_REAL, L_NULL } kind;
 } literal_t;
 
 typedef struct assoc {

test/parse/literal.vhd

@@ -11,6 +11,7 @@ architecture a of e is
     constant h : real := 235.1e-2;
     constant i : integer := 1_2_3_4;
     constant j : real := 5_6_7.12_3;
+    constant k : ptr := null;
 begin
 
 end architecture;

test/sem/access.vhd

@@ -0,0 +1,20 @@
+package p is
+
+    type int_ptr is access integer;     -- OK
+
+    type bad1 is access foo;            -- Error
+
+end package;
+
+package body p is
+
+    procedure test is
+        variable v : int_ptr;
+        variable i : integer;
+    begin
+        v := null;                      -- OK
+        i := null;                      -- Error
+        deallocate(v);                  -- OK
+    end procedure;
+
+end package body;

test/test_parse.c

@@ -689,7 +689,7 @@ START_TEST(test_literal)
    a = parse();
    fail_if(a == NULL);
    fail_unless(tree_kind(a) == T_ARCH);
-   fail_unless(tree_decls(a) == 12);
+   fail_unless(tree_decls(a) == 13);
 
    d = tree_decl(a, 0);
    fail_unless(tree_ident(d) == ident_new("POS"));
@@ -786,6 +786,13 @@ START_TEST(test_literal)
    fail_unless(l.kind == L_REAL);
    fail_unless(l.r == 567.123);
 
+   d = tree_decl(a, 12);
+   fail_unless(tree_ident(d) == ident_new("K"));
+   v = tree_value(d);
+   fail_unless(tree_kind(v) == T_LITERAL);
+   l = tree_literal(v);
+   fail_unless(l.kind == L_NULL);
+
    a = parse();
    fail_unless(a == NULL);
 

test/test_sem.c

@@ -941,6 +941,37 @@ START_TEST(test_file)
 }
 END_TEST
 
+START_TEST(test_access)
+{
+   tree_t p, d;
+   type_t t;
+
+   fail_unless(input_from_file(TESTDIR "/sem/access.vhd"));
+
+   const error_t expect[] = {
+      {  5, "type FOO is not defined" },
+      { 16, "NULL expression must have access type" },
+      { -1, NULL }
+   };
+   expect_errors(expect);
+
+   p = parse();
+   fail_if(p == NULL);
+   fail_unless(tree_kind(p) == T_PACKAGE);
+   sem_check(p);
+
+   p = parse();
+   fail_if(p == NULL);
+   fail_unless(tree_kind(p) == T_PACK_BODY);
+   sem_check(p);
+
+   fail_unless(parse() == NULL);
+   fail_unless(parse_errors() == 0);
+
+   fail_unless(sem_errors() == (sizeof(expect) / sizeof(error_t)) - 1);
+}
+END_TEST
+
 int main(void)
 {
    register_trace_signal_handlers();
@@ -971,6 +1002,7 @@ int main(void)
    tcase_add_test(tc_core, test_generate);
    tcase_add_test(tc_core, test_record);
    tcase_add_test(tc_core, test_file);
+   tcase_add_test(tc_core, test_access);
    suite_add_tcase(s, tc_core);
 
    SRunner *sr = srunner_create(s);