Ignore:
Timestamp:
Mar 6, 2015, 8:03:57 AM (5 years ago)
Author:
Maxim Reznik
Message:

Add type for represent subprogram profile

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/ada-2012/src/semantic/gela-plain_type_managers.adb

    r399 r407  
    55with Gela.Elements.Component_Definitions;
    66with Gela.Elements.Defining_Identifiers;
     7with Gela.Elements.Derived_Type_Definitions;
    78with Gela.Elements.Discriminant_Specifications;
     9with Gela.Elements.Floating_Point_Definitions;
    810with Gela.Elements.Identifiers;
    911with Gela.Elements.Object_Declarations;
    1012with Gela.Elements.Object_Definitions;
     13with Gela.Elements.Parameter_Specifications;
    1114with Gela.Elements.Record_Type_Definitions;
    1215with Gela.Elements.Root_Type_Definitions;
     16with Gela.Elements.Signed_Integer_Type_Definitions;
    1317with Gela.Elements.Subtype_Indication_Or_Access_Definitions;
    1418with Gela.Elements.Subtype_Indications;
    15 with Gela.Elements.Subtype_Mark_Or_Access_Definitions;
     19with Gela.Elements.Subtype_Marks;
    1620with Gela.Elements.Type_Definitions;
    1721with Gela.Elements.Unconstrained_Array_Definitions;
    1822with Gela.Plain_Type_Views;
     23with Gela.Profiles.Names;
    1924
    2025package body Gela.Plain_Type_Managers is
     
    7378   end Get;
    7479
     80   -----------------
     81   -- Get_Profile --
     82   -----------------
     83
     84   overriding function Get_Profile
     85     (Self  : access Type_Manager;
     86      Name  : Gela.Elements.Defining_Names.Defining_Name_Access)
     87      return Gela.Profiles.Profile_Access
     88   is
     89      Result : Profile_Access;
     90      Cursor : constant Profile_Maps.Cursor := Self.Profiles.Find (Name);
     91   begin
     92      if Profile_Maps.Has_Element (Cursor) then
     93         Result := Profile_Maps.Element (Cursor);
     94      else
     95         Result := new Gela.Profiles.Profile'Class'
     96           (Gela.Profiles.Names.Create (Name));
     97         Self.Profiles.Insert (Name, Result);
     98      end if;
     99
     100      return Gela.Profiles.Profile_Access (Result);
     101   end Get_Profile;
     102
    75103   ----------
    76104   -- Hash --
     
    81109   begin
    82110      return Key.Decl.Hash + Gela.Type_Views.Category_Kinds'Pos (Key.Category);
     111   end Hash;
     112
     113   ----------
     114   -- Hash --
     115   ----------
     116
     117   function Hash
     118     (Self : Gela.Elements.Defining_Names.Defining_Name_Access)
     119      return Ada.Containers.Hash_Type is
     120   begin
     121      return Self.Hash;
    83122   end Hash;
    84123
     
    165204         end record;
    166205
     206         overriding procedure Derived_Type_Definition
     207           (Self : in out Visiter;
     208            Node : not null Gela.Elements.Derived_Type_Definitions.
     209              Derived_Type_Definition_Access);
     210
     211         overriding procedure Floating_Point_Definition
     212           (Self : in out Visiter;
     213            Node : not null Gela.Elements.Floating_Point_Definitions.
     214              Floating_Point_Definition_Access);
     215
    167216         overriding procedure Full_Type_Declaration
    168217           (Self : in out Visiter;
     
    179228            Node : not null Gela.Elements.Root_Type_Definitions.
    180229              Root_Type_Definition_Access);
     230
     231         overriding procedure Signed_Integer_Type_Definition
     232           (Self : in out Visiter;
     233            Node : not null Gela.Elements.Signed_Integer_Type_Definitions.
     234              Signed_Integer_Type_Definition_Access);
    181235
    182236         overriding procedure Unconstrained_Array_Definition
     
    192246
    193247      package body Visiters is
     248
     249         overriding procedure Derived_Type_Definition
     250           (Self : in out Visiter;
     251            Node : not null Gela.Elements.Derived_Type_Definitions.
     252              Derived_Type_Definition_Access)
     253         is
     254            use type Gela.Semantic_Types.Type_Index;
     255
     256            Parent : constant Gela.Elements.Subtype_Indications.
     257              Subtype_Indication_Access := Node.Parent_Subtype_Indication;
     258            Subtype_Mark : constant Gela.Elements.Subtype_Marks
     259              .Subtype_Mark_Access  := Parent.Subtype_Mark;
     260            Tipe : constant Gela.Semantic_Types.Type_Index :=
     261              Type_From_Declaration.Self.Type_From_Subtype_Mark (Subtype_Mark);
     262            Type_View : Gela.Type_Views.Type_View_Access;
     263         begin
     264            if Tipe /= 0 then
     265               Type_View := Type_From_Declaration.Self.Get (Tipe);
     266
     267               Self.Result := Type_From_Declaration.Self.Get
     268                 (Category => Type_View.Category,
     269                  Decl     => Gela.Elements.Full_Type_Declarations.
     270                    Full_Type_Declaration_Access (Node.Enclosing_Element));
     271            end if;
     272         end Derived_Type_Definition;
     273
     274         overriding procedure Floating_Point_Definition
     275           (Self : in out Visiter;
     276            Node : not null Gela.Elements.Floating_Point_Definitions.
     277              Floating_Point_Definition_Access) is
     278         begin
     279            Self.Result := Type_From_Declaration.Self.Get
     280              (Category => Gela.Type_Views.A_Float_Point,
     281               Decl     => Gela.Elements.Full_Type_Declarations.
     282                 Full_Type_Declaration_Access (Node.Enclosing_Element));
     283         end Floating_Point_Definition;
    194284
    195285         ---------------------------
     
    235325         end Root_Type_Definition;
    236326
     327         overriding procedure Signed_Integer_Type_Definition
     328           (Self : in out Visiter;
     329            Node : not null Gela.Elements.Signed_Integer_Type_Definitions.
     330              Signed_Integer_Type_Definition_Access) is
     331         begin
     332            Self.Result := Type_From_Declaration.Self.Get
     333              (Category => Gela.Type_Views.A_Signed_Integer,
     334               Decl     => Gela.Elements.Full_Type_Declarations.
     335                 Full_Type_Declaration_Access (Node.Enclosing_Element));
     336         end Signed_Integer_Type_Definition;
     337
    237338         overriding procedure Unconstrained_Array_Definition
    238339           (Self : in out Visiter;
     
    261362   overriding function Type_From_Subtype_Mark
    262363     (Self  : access Type_Manager;
    263       Node  : Gela.Elements.Subtype_Marks.Subtype_Mark_Access)
     364      Node  : access Gela.Elements.Subtype_Mark_Or_Access_Definitions.
     365                Subtype_Mark_Or_Access_Definition'Class)
    264366      return Gela.Semantic_Types.Type_Index
    265367   is
     
    334436              Object_Declaration_Access);
    335437
     438         overriding procedure Parameter_Specification
     439           (Self : in out Visiter;
     440            Node : not null Gela.Elements.Parameter_Specifications.
     441              Parameter_Specification_Access);
     442
    336443         overriding procedure Subtype_Indication
    337444           (Self : in out Visiter;
     
    376483                Node.Object_Declaration_Subtype;
    377484         begin
    378             X.Visit (Self);
     485            Self.Result :=
     486              Type_Of_Object_Declaration.Self.Type_From_Subtype_Mark (X);
    379487         end Discriminant_Specification;
    380488
     
    390498         end Object_Declaration;
    391499
     500         overriding procedure Parameter_Specification
     501           (Self : in out Visiter;
     502            Node : not null Gela.Elements.Parameter_Specifications.
     503              Parameter_Specification_Access)
     504         is
     505            X : constant Gela.Elements.Subtype_Mark_Or_Access_Definitions.
     506              Subtype_Mark_Or_Access_Definition_Access :=
     507                Node.Object_Declaration_Subtype;
     508         begin
     509            Self.Result :=
     510              Type_Of_Object_Declaration.Self.Type_From_Subtype_Mark (X);
     511         end Parameter_Specification;
     512
    392513         overriding procedure Subtype_Indication
    393514           (Self : in out Visiter;
    394515            Node : not null Gela.Elements.Subtype_Indications.
    395               Subtype_Indication_Access) is
     516              Subtype_Indication_Access)
     517         is
     518            X : constant Gela.Elements.Subtype_Marks.Subtype_Mark_Access  :=
     519              Node.Subtype_Mark;
    396520         begin
    397521            Self.Result :=
    398               Type_Of_Object_Declaration.Self.Type_From_Subtype_Mark
    399                 (Node.Subtype_Mark);
     522              Type_Of_Object_Declaration.Self.Type_From_Subtype_Mark (X);
    400523         end Subtype_Indication;
    401524      end Visiters;
Note: See TracChangeset for help on using the changeset viewer.