Start adding records.

lexer.mll

@@ -30,6 +30,10 @@ let keywords = create_hashtable 10 [
    "False",       FALSE;
    "in",          IN;
    "out",         OUT;
+   "case",        CASE;
+   "when",        WHEN;
+   "others",      OTHERS;
+   "record",      RECORD;
    "Inspect_Type", INSPECT_TYPE;
    "Static_Assert", STATIC_ASSERT;
 ]
@@ -60,6 +64,7 @@ rule scan = parse
    | ';'  { SEMICOLON }
    | '.'  { DOT }
    | ','  { COMMA }
+   | '|'  { MID }
    | ":=" { ASSIGN }
    | ".." { DOTDOT }
    | "=>" { RARROW }

parse_tree.mli

@@ -43,6 +43,21 @@ and package =
 
 and declaration =
    | Subprogram of subprogram
+   | Type_decl of loc * string * type_decl
+
+and type_decl =
+   | Record_type_decl of record_field list
+
+and record_field =
+   | Record_constraint of expr
+   | Record_field of loc * string * ttype
+   | Variant_record of loc * expr * (discrete_choice list * record_field list) list
+
+and discrete_choice =
+   | Expr_choice of expr
+   | Range_choice of expr * expr
+   | Subtype_choice of ttype
+   | Others_choice
 
 and ttype =
    | Named_type of loc * dotted_name

parser.mly

@@ -24,13 +24,13 @@ let check_end (pos1, name1) (pos2, name2) =
 
 /* Keywords */
 %token PACKAGE PROCEDURE NULL END AND OR VAR IS IF THEN ELSE ELSIF
-%token WHILE LOOP TYPE RANGE GIVEN TRUE FALSE
-%token INSPECT_TYPE STATIC_ASSERT IN OUT
+%token WHILE LOOP TYPE RANGE GIVEN TRUE FALSE CASE WHEN OTHERS
+%token INSPECT_TYPE STATIC_ASSERT IN OUT RECORD
 
 /* Punctuation */
 %token COLON SEMICOLON DOT DOTDOT COMMA ASSIGN RARROW
 %token LPAREN RPAREN LBRACKET RBRACKET LBRACE RBRACE
-%token EQ NE LT LE GT GE
+%token EQ NE LT LE GT GE MID
 
 /* Other */
 %token EOF
@@ -72,6 +72,7 @@ declarations:
 
 declaration:
    | subprogram { Subprogram $1 }
+   | TYPE IDENT IS type_decl SEMICOLON { Type_decl(rhs_start_pos 4, $2, $4) }
 
 subprogram:
    | PROCEDURE dotted_name opt_parameters IS
@@ -143,6 +144,43 @@ konstraint:
          }
       }
 
+type_decl:
+   | NULL RECORD { Record_type_decl([]) }
+   | RECORD record_fields END RECORD { Record_type_decl($2) }
+
+record_fields:
+   | NULL SEMICOLON { [] }
+   | ne_record_fields { $1 }
+
+ne_record_fields:
+   | record_field { [$1] }
+   | record_field ne_record_fields { $1::$2 }
+
+record_field:
+   | expr SEMICOLON
+      { Record_constraint($1) }
+   | IDENT COLON ttype SEMICOLON
+      { Record_field(pos(), $1, $3) }
+   | CASE expr IS variant_cases END CASE SEMICOLON
+      { Variant_record(pos(), $2, $4) }
+
+variant_cases:
+   | variant_case { [$1] }
+   | variant_case variant_cases { $1::$2 }
+
+variant_case:
+   | WHEN discrete_choices RARROW record_fields { ($2, $4) }
+
+discrete_choices:
+   | discrete_choice { [$1] }
+   | discrete_choice MID discrete_choices { $1::$3 }
+
+discrete_choice:
+   | expr { Expr_choice($1) }
+   | expr DOTDOT expr { Range_choice($1,$3) }
+   | IN ttype { Subtype_choice($2) }
+   | OTHERS { Others_choice }
+
 ne_statements:
    | NULL SEMICOLON
       { Null_statement(pos ()) }

symbols.ml

@@ -55,6 +55,7 @@ and symbol_info =
    | Subprogram_sym of subprogram_info
    | Variable_sym
    | Parameter_sym of param_mode * ttype
+   | Record_sym
 
 and subprogram_info = {
    mutable sub_parameters    : symbol list;

symbols.mli

@@ -74,6 +74,7 @@ and symbol_info =
    | Subprogram_sym of subprogram_info
    | Variable_sym
    | Parameter_sym of param_mode * ttype
+   | Record_sym
 
 and subprogram_info = {
    mutable sub_parameters    : symbol list;

translation.ml

@@ -403,12 +403,25 @@ let translate_subprogram_body compiler state subprogram_sym sub =
    Backend_c.translate compiler subprogram_sym entry_point state.st_blocks;
    state.st_blocks <- []
 
+let translate_type_declaration state scope loc name decl =
+   begin match find scope name with
+      | [] -> ()
+      | sym::_ ->
+         already_declared_error sym loc;
+         raise Bail_out
+   end;
+   let type_sym = new_symbol scope name (Some loc) Record_sym in
+   (* TODO *)
+   ()
+
 let translate_declarations state scope declarations =
    List.iter (fun declaration ->
       try
          match declaration with
             | Parse_tree.Subprogram(sub) ->
                translate_subprogram_prototype state scope sub
+            | Parse_tree.Type_decl(loc, name, decl) ->
+               translate_type_declaration state scope loc name decl
       with Bail_out -> ()
    ) declarations