hac_0.26.0_19beb1f4/src/compile/hac_sys-parser-type_def.adb

-------------------------------------------------------------------------------------
--
--  HAC - HAC Ada Compiler
--
--  A compiler in Ada for an Ada subset
--
--  Copyright, license, etc. : see top package.
--
-------------------------------------------------------------------------------------
--

with HAC_Sys.Parser.Enter_Def,
     HAC_Sys.Parser.Helpers,
     HAC_Sys.Parser.Ranges,
     HAC_Sys.Scanner,
     HAC_Sys.Errors;

with Ada.Characters.Handling;

package body HAC_Sys.Parser.Type_Def is

  use Co_Defs, Defs, Enter_Def, Helpers, Errors;
  use type HAC_Integer;

  procedure Type_or_Subtype_Declaration
    (CD         : in out Co_Defs.Compiler_Data;
     Level      : in     Defs.Nesting_Level;
     FSys_NTD   : in     Defs.Symset)
  is
    T1 : Integer;
    forward_id_idx : Natural;
    is_subtype : constant Boolean := CD.Sy = SUBTYPE_Symbol;
  begin
    Scanner.InSymbol (CD);  --  Consume TYPE or SUBTYPE symbol.
    Test (CD, IDent_Set, Semicolon_Set, err_identifier_missing);
    Enter_Prefixed (CD, Level, CD.Id, CD.Id_with_case, TypeMark, forward_id_idx);
    T1 := CD.Id_Count;
    Scanner.InSymbol (CD);
    Need (CD, IS_Symbol, err_IS_missing);
    declare
      New_T : IdTabEntry renames CD.IdTab (T1);
    begin
      if is_subtype then
        Subtype_Indication
          (CD, Level,
           FSys_TD => Comma_IDent_Semicolon + FSys_NTD,
           xTP     => New_T.xtyp,
           Size    => Integer (New_T.adr_or_sz));
      else
        Type_Definition
          (CD, Level,
           FSys_TD => Comma_IDent_Semicolon + FSys_NTD,
           xTP     => New_T.xtyp,
           Size    => Integer (New_T.adr_or_sz));
      end if;
    end;
    --
    Need_Semicolon_after_Declaration (CD, FSys_NTD);
  end Type_or_Subtype_Declaration;

  --  constrained_array_definition 3.6 (5) : "array (1 .. 2, 3 .. 4) of Integer;"
  --  index_constraint 3.6.1 (2)           : "Matrix (1 .. 2, 3 .. 4);"
  --
  procedure Array_Typ
    (CD            : in out Co_Defs.Compiler_Data;
     Level : in     Defs.Nesting_Level;
     FSys_TD       : in     Defs.Symset;
     arr_tab_ref, arr_size, arr_dimensions : out Integer;
     string_constrained_subtype            :     Boolean)
  is
    Element_Exact_Subtyp, Index_Exact_Subtyp : Exact_Subtyp;
    Element_Size                             : Integer;
    recursive_dimensions                     : Natural := 0;
    Lower_Bound, Higher_Bound                : Constant_Rec;
    use Ranges;
  begin
    Static_Range (CD, Level, FSys_TD, err_illegal_array_bounds, Lower_Bound, Higher_Bound);
    Index_Exact_Subtyp := Lower_Bound.TP;
    Index_Exact_Subtyp.Discrete_First := Lower_Bound.I;
    Index_Exact_Subtyp.Discrete_Last  := Higher_Bound.I;
    Enter_Array (CD, Index_Exact_Subtyp);
    arr_tab_ref := CD.Arrays_Count;
    if string_constrained_subtype then
      --  We define String (L .. H) exactly as an "array (L .. H) of Character".
      Construct_Root (Element_Exact_Subtyp, Chars);
      Element_Exact_Subtyp.Discrete_First := 0;
      Element_Exact_Subtyp.Discrete_Last  := 255;
      Element_Size := 1;
      Need (CD, RParent, err_closing_parenthesis_missing, Forgive => RBrack);
    elsif CD.Sy = Comma then
      --  Multidimensional array is equivalant to:  array (range_1) of array (range_2,...).
      Scanner.InSymbol (CD);  --  Consume ',' symbol.
      Construct_Root (Element_Exact_Subtyp, Arrays);  --  Recursion for next array dimension.
      Array_Typ (CD, Level, FSys_TD, Element_Exact_Subtyp.Ref, Element_Size, recursive_dimensions, False);
    else
      Need (CD, RParent, err_closing_parenthesis_missing, Forgive => RBrack);
      Need (CD, OF_Symbol, err_missing_OF);         --  "of"  in  "array (...) of Some_Type"
      if Type_Begin_Symbol (CD.Sy) then
        Error (CD, err_general_error, "anonymous definition not permitted here");
        --  Recovery:
        Type_Definition (CD, Level, FSys_TD, Element_Exact_Subtyp, Element_Size);
      else
        --  RM 3.6 (2)
        --  Here is a component_definition, which is a
        --  subtype indication (possibly aliased).
        Subtype_Indication (CD, Level, FSys_TD, Element_Exact_Subtyp, Element_Size);
      end if;
    end if;
    arr_size := (Integer (Higher_Bound.I) - Integer (Lower_Bound.I) + 1) * Element_Size;
    arr_dimensions := 1 + recursive_dimensions;
    declare
      New_A : ATabEntry renames CD.Arrays_Table (arr_tab_ref);
    begin
      --  New_A.Index_xTyp already set by Enter_Array.
      New_A.Array_Size   := arr_size;
      New_A.Element_xTyp := Element_Exact_Subtyp;
      New_A.Element_Size := Element_Size;
      New_A.dimensions   := arr_dimensions;
    end;
  end Array_Typ;

  procedure Type_Definition
    (CD            : in out Co_Defs.Compiler_Data;
     Initial_Level : in     Defs.Nesting_Level;
     FSys_TD       : in     Defs.Symset;
     xTP           :    out Co_Defs.Exact_Subtyp;
     Size          :    out Integer)
  is
    Level : Nesting_Level := Initial_Level;
    procedure InSymbol is begin Scanner.InSymbol (CD); end InSymbol;

    procedure Enumeration_Typ is  --  RM 3.5.1 Enumeration Types
      enum_count : Natural := 0;
      forward_id_idx : Natural;
    begin
      xTP.Construct_Root (Enums);
      xTP.Ref := CD.Id_Count;
      loop
        InSymbol;  --  Consume '(' symbol.
        if CD.Sy = IDent then
          enum_count := enum_count + 1;
          Enter_Prefixed (CD, Level, CD.Id, CD.Id_with_case, Declared_Number_or_Enum_Item, forward_id_idx);
          declare
            New_Enum_Item : IdTabEntry renames CD.IdTab (CD.Id_Count);
          begin
            New_Enum_Item.read_only := True;
            New_Enum_Item.xtyp      := xTP;
            New_Enum_Item.adr_or_sz := HAC_Integer (enum_count - 1);  --  RM 3.5.1 (7): position begins with 0.
          end;
        else
          Error (CD, err_identifier_missing);
        end if;
        InSymbol;
        exit when CD.Sy /= Comma;
      end loop;
      Size  := 1;
      xTP.Discrete_First := 0;
      xTP.Discrete_Last  := HAC_Integer (enum_count - 1);
      Need (CD, RParent, err_closing_parenthesis_missing);
    end Enumeration_Typ;

    procedure Record_Typ is  --  RM 3.8
      Field_Exact_Subtyp : Exact_Subtyp;
      Field_Size, Offset, T0, T1 : Integer;
    begin
      InSymbol;  --  Consume RECORD symbol.
      Enter_Block (CD, CD.Id_Count);
      Construct_Root (xTP, Records);
      xTP.Ref := CD.Blocks_Count;
      if Level = nesting_level_max then
        Fatal (LEVELS);  --  Exception is raised there.
      end if;
      Level              := Level + 1;
      CD.Display (Level) := CD.Blocks_Count;
      Offset             := 0;
      --
      loop
        if CD.Sy = IDent then
          --  RM 3.8: Record component declaration
          T0 := CD.Id_Count;
          Enter_Variables (CD, Level, False);
          Need (CD, Colon, err_colon_missing);  --  ':'  in  "a, b, c : Integer;"
          T1 := CD.Id_Count;
          if Type_Begin_Symbol (CD.Sy) then
            Error (CD, err_general_error, "anonymous definition not permitted here");
            --  Recovery:
            Type_Definition
              (CD, Level, FSys_TD + Comma_END_IDent_Semicolon,
               Field_Exact_Subtyp, Field_Size);
          else
            --  RM 3.6 (2)
            --  Here is a component_definition, which is a
            --  subtype indication (possibly aliased).
            Subtype_Indication
              (CD, Level, FSys_TD + Comma_END_IDent_Semicolon,
               Field_Exact_Subtyp, Field_Size);
          end if;
          while T0 < T1 loop
            T0                      := T0 + 1;
            CD.IdTab (T0).xtyp      := Field_Exact_Subtyp;
            CD.IdTab (T0).adr_or_sz := HAC_Integer (Offset);
            Offset                  := Offset + Field_Size;
          end loop;
        else
          Error (CD, err_identifier_missing, severity => major);
        end if;
        Need_Semicolon (CD);
        exit when CD.Sy = END_Symbol;
      end loop;
      --
      CD.Blocks_Table (xTP.Ref).VSize := Offset;
      Size                            := Offset;
      CD.Blocks_Table (xTP.Ref).PSize := 0;
      InSymbol;
      Need (CD, RECORD_Symbol, err_RECORD_missing);  --  (END) RECORD
      Level := Level - 1;
    end Record_Typ;

    dummy_dims : Natural;
  begin
    xTP  := Undefined;
    Size := 0;
    if CD.Sy in
      ABSTRACT_Symbol | ACCESS_Symbol |
      DIGITS_Symbol | DELTA_Symbol |
      INTERFACE_Symbol | LIMITED_Symbol |
      NOT_Symbol | NEW_Symbol |
      PRIVATE_Symbol | PROTECTED_Symbol |
      RANGE_Keyword_Symbol | SYNCHRONIZED_Symbol |
      TASK_Symbol | TAGGED_Symbol
    then
      Error
        (CD, err_not_yet_implemented,
         ": type definitions starting with """ &
         Ada.Characters.Handling.To_Lower (A2S (CD.Id)) & '"',
         severity => major);
    end if;
    Test (CD, Type_Begin_Symbol, FSys_TD, err_missing_type_begin_symbol);
    if Type_Begin_Symbol (CD.Sy) then
      case CD.Sy is
        when ARRAY_Symbol =>
          InSymbol;
          Need (CD, LParent, err_missing_an_opening_parenthesis, Forgive => LBrack);
          Construct_Root (xTP, Arrays);
          Array_Typ (CD, Level, FSys_TD, xTP.Ref, Size, dummy_dims, string_constrained_subtype => False);
        when RECORD_Symbol =>
          Record_Typ;
        when LParent =>
          Enumeration_Typ;
        when others =>
          null;
      end case;
      Test (CD, FSys_TD, empty_symset, err_incorrectly_used_symbol);
    end if;
    if CD.error_count = 0 then
      pragma Assert (Level = Initial_Level);
    end if;
  end Type_Definition;

  procedure Subtype_Indication
    (CD      : in out Co_Defs.Compiler_Data;
     Level   : in     Defs.Nesting_Level;
     FSys_TD : in     Defs.Symset;
     xTP     :    out Co_Defs.Exact_Subtyp;
     Size    :    out Integer)
  is
    procedure InSymbol is begin Scanner.InSymbol (CD); end InSymbol;

    dummy_dims : Natural;

    procedure String_Sub_Typ is
      --  Prototype of constraining an array type: String -> String (1 .. 26)
      --  We need to implement general constraints one day...
    begin
      InSymbol;
      Need (CD, LParent, err_missing_an_opening_parenthesis, Forgive => LBrack);
      Construct_Root (xTP, Arrays);
      Array_Typ (CD, Level, FSys_TD, xTP.Ref, Size, dummy_dims, string_constrained_subtype => True);
    end String_Sub_Typ;

    Ident_Index : Integer;

    --  Here we are sitting, say, on `Character` in `subtype My_Chars is Character` [range 'a' .. 'z']
    --
    procedure Sub_Typ is
      Low, High : Constant_Rec;
    begin
      if Ident_Index = No_Id then
        return;  --  Error already issued due to undefined identifier
      end if;
      declare
        Id_T : IdTabEntry renames CD.IdTab (Ident_Index);
      begin
        if Id_T.entity = TypeMark then
          xTP   := Id_T.xtyp;
          Size  := Integer (Id_T.adr_or_sz);
          if xTP.TYP = NOTYP then
            Error (CD, err_undefined_type);
          end if;
        else
          Error (CD, err_missing_a_type_identifier);
        end if;
      end;
      InSymbol;
      if CD.Sy = RANGE_Keyword_Symbol then
        --  Here comes the optional `  range 'a' .. 'z'  ` constraint.
        InSymbol;
        Ranges.Explicit_Static_Range (CD, Level, FSys_TD, err_range_constraint_error, Low, High);
        if Exact_Typ (Low.TP) /= Exact_Typ (xTP) then
          Error
            (CD, err_range_constraint_error,
             "type of bounds don't match with the parent type", severity => major);
        elsif Low.I not in xTP.Discrete_First .. xTP.Discrete_Last then
          Error
            (CD,
             err_range_constraint_error,
             "lower bound, " & Discrete_Image (CD, Low.I, xTP.TYP, xTP.Ref) &
             ", is out of parent type's range, " &
             Discrete_Range_Image (CD, xTP.Discrete_First, xTP.Discrete_Last, xTP.TYP, xTP.Ref),
             severity => major);
        elsif High.I not in xTP.Discrete_First .. xTP.Discrete_Last then
          Error
            (CD,
             err_range_constraint_error,
             "higher bound, " & Discrete_Image (CD, High.I, xTP.TYP, xTP.Ref) &
             ", is out of parent type's range, " &
             Discrete_Range_Image (CD, xTP.Discrete_First, xTP.Discrete_Last, xTP.TYP, xTP.Ref),
             severity => major);
        else
          xTP.Discrete_First := Low.I;
          xTP.Discrete_Last  := High.I;
        end if;
      end if;
    end Sub_Typ;

  begin
    xTP  := Undefined;
    Size := 0;
    if CD.Sy = NOT_Symbol then
      Error
        (CD, err_not_yet_implemented,
         ": subtype indications starting with """ &
         Ada.Characters.Handling.To_Lower (A2S (CD.Id)) & '"',
         severity => major);
    end if;
    Test (CD, Subtype_Begin_Symbol, FSys_TD, err_identifier_missing);
    if CD.Sy /= IDent then
      --  Normally this case should have been filtered out before.
      Error (CD, err_general_error, severity => major);
    end if;
    Ident_Index := Locate_CD_Id (CD, Level);
    if Ident_Index = CD.String_Id_Index then
      String_Sub_Typ;
    else
      Sub_Typ;
    end if;
    Test (CD, FSys_TD, empty_symset, err_incorrectly_used_symbol);
  end Subtype_Indication;

end HAC_Sys.Parser.Type_Def;