Changeset 407


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

Add type for represent subprogram profile

Location:
trunk/ada-2012
Files:
3 added
11 edited

Legend:

Unmodified
Added
Removed
  • trunk/ada-2012/gnat/gela_build.gpr

    r380 r407  
    1616   package Compiler is
    1717      for Default_Switches ("ada") use Check_Ada_Switches;
     18--      for Local_Configuration_Pragmas use "./gnat.adc";
    1819   end Compiler;
    1920
  • trunk/ada-2012/src/ag/down.ag

    r405 r407  
    993993Rules for decimal_fixed_point_definition. :
    994994(.
    995       ${Real_Range_Constraint.Down} := 0;  --  FIXME
     995      Gela.Pass_Utils.Resolve.Real_Type
     996        (Self.Compilation,
     997         ${Real_Range_Constraint.Up},
     998         ${Real_Range_Constraint.Down});
    996999.)
    9971000
    9981001Rules for floating_point_definition. :
    9991002(.
    1000       ${Real_Range_Constraint.Down} := 0;  --  FIXME
     1003      Gela.Pass_Utils.Resolve.Real_Type
     1004        (Self.Compilation,
     1005         ${Real_Range_Constraint.Up:0},
     1006         ${Real_Range_Constraint.Down});
    10011007.)
    10021008
    10031009Rules for ordinary_fixed_point_definition. :
    10041010(.
    1005       ${Real_Range_Constraint.Down} := 0;  --  FIXME
     1011      Gela.Pass_Utils.Resolve.Real_Type
     1012        (Self.Compilation,
     1013         ${Real_Range_Constraint.Up},
     1014         ${Real_Range_Constraint.Down});
    10061015.)
    10071016
  • trunk/ada-2012/src/ag/errors.ag

    r394 r407  
    232232Rules for object_declaration. :
    233233(.
    234       ${object_declaration.Errors} := ${Initialization_Expression.Errors};
     234      ${object_declaration.Errors} := ${Initialization_Expression.Errors:0};
    235235      --  ${Object_Declaration_Subtype.Errors};
    236236.)
  • trunk/ada-2012/src/api/gela-type_managers.ads

    r395 r407  
    44with Gela.Semantic_Types;
    55with Gela.Elements.Defining_Names;
    6 with Gela.Elements.Subtype_Marks;
     6with Gela.Elements.Subtype_Mark_Or_Access_Definitions;
     7with Gela.Profiles;
    78
    89package Gela.Type_Managers is
     
    3435   not overriding function Type_From_Subtype_Mark
    3536     (Self  : access Type_Manager;
    36       Node  : Gela.Elements.Subtype_Marks.Subtype_Mark_Access)
     37      Node  : access Gela.Elements.Subtype_Mark_Or_Access_Definitions.
     38                Subtype_Mark_Or_Access_Definition'Class)
    3739      return Gela.Semantic_Types.Type_Index is abstract;
    3840   --  Get type view from given subtype mark
     
    5961   --  Get type view of predefined universal_access
    6062
     63   not overriding function Get_Profile
     64     (Self  : access Type_Manager;
     65      Name  : Gela.Elements.Defining_Names.Defining_Name_Access)
     66      return Gela.Profiles.Profile_Access is abstract;
     67   --  If Name if callable entity return corresponding profile
     68
    6169end Gela.Type_Managers;
  • trunk/ada-2012/src/api/gela-type_views.ads

    r405 r407  
    4343   type Category_Kind_Set is array (Category_Kinds) of Boolean with Pack;
    4444
    45    subtype An_Integer is Category_Kinds
     45   subtype Any_Integer_Type is Category_Kinds
    4646     range An_Universal_Integer .. A_Modular_Integer;
     47
     48   subtype Any_Real_Type is Category_Kinds
     49     range An_Universal_Real .. A_Decimal_Fixed_Point;
    4750
    4851   not overriding function Category
  • trunk/ada-2012/src/semantic/gela-debug_properties.adb

    r405 r407  
    99with Gela.Semantic_Types;
    1010with Gela.Type_Views;
     11with Gela.Type_Managers;
    1112
    1213package body Gela.Debug_Properties is
     
    6566        (Self   : in out Visiter;
    6667         Tipe   : Gela.Semantic_Types.Type_Index;
     68         Down   : Gela.Interpretations.Interpretation_Index_Array);
     69
     70      overriding procedure On_Expression_Category
     71        (Self   : in out Visiter;
     72         Kinds  : Gela.Type_Views.Category_Kind_Set;
    6773         Down   : Gela.Interpretations.Interpretation_Index_Array);
    6874
     
    255261         Down   : Gela.Interpretations.Interpretation_Index_Array)
    256262      is
    257          pragma Unreferenced (Self, Tipe);
    258       begin
    259          Put_Line
    260            ("   Expression ");
     263         use type Gela.Semantic_Types.Type_Index;
     264         use type Gela.Type_Views.Type_View_Access;
     265
     266         TM : constant Gela.Type_Managers.Type_Manager_Access :=
     267           Self.Comp.Context.Types;
     268         View : Gela.Type_Views.Type_View_Access;
     269      begin
     270         if Tipe /= 0 then
     271            View := TM.Get (Tipe);
     272         end if;
     273
     274         if View = null then
     275            Put_Line ("   Expression NULL");
     276         else
     277            Put_Line
     278              ("   Expression " &
     279                 Gela.Type_Views.Category_Kinds'Image (View.Category));
     280         end if;
    261281
    262282         for J of Down loop
     
    266286         end loop;
    267287      end On_Expression;
     288
     289      overriding procedure On_Expression_Category
     290        (Self   : in out Visiter;
     291         Kinds  : Gela.Type_Views.Category_Kind_Set;
     292         Down   : Gela.Interpretations.Interpretation_Index_Array)
     293      is
     294         pragma Unreferenced (Self);
     295      begin
     296         Put_Line ("   Expression_Category: ");
     297
     298         for J in Kinds'Range loop
     299            if Kinds (J) then
     300               Put_Line ("      " & Gela.Type_Views.Category_Kinds'Image (J));
     301            end if;
     302         end loop;
     303
     304         for J of Down loop
     305            Put_Line
     306              ("     DOWN" &
     307                 Gela.Interpretations.Interpretation_Index'Image (J));
     308         end loop;
     309      end On_Expression_Category;
    268310
    269311      overriding procedure On_Attr_Function
     
    309351         Cursor : Gela.Interpretations.Cursor'Class)
    310352      is
    311          pragma Unreferenced (Self, Tipe, Cursor);
    312       begin
    313          Put_Line ("   Expression ");
     353         pragma Unreferenced (Cursor);
     354         use type Gela.Semantic_Types.Type_Index;
     355         use type Gela.Type_Views.Type_View_Access;
     356
     357         TM : constant Gela.Type_Managers.Type_Manager_Access :=
     358           Self.Comp.Context.Types;
     359         View : Gela.Type_Views.Type_View_Access;
     360      begin
     361         if Tipe /= 0 then
     362            View := TM.Get (Tipe);
     363         end if;
     364
     365         if View = null then
     366            Put_Line ("   Expression NULL");
     367         else
     368            Put_Line
     369              ("   Expression " &
     370                 Gela.Type_Views.Category_Kinds'Image (View.Category));
     371         end if;
    314372      end On_Expression;
    315373
     
    322380      begin
    323381         Put_Line ("   Expression_Category: ");
     382
    324383         for J in Kinds'Range loop
    325384            if Kinds (J) then
  • trunk/ada-2012/src/semantic/gela-pass_utils.adb

    r398 r407  
    581581      function Create_Operator
    582582        (Operator_Symbol : Gela.Lexical_Types.Symbol;
    583          Type_Symbol     : Gela.Lexical_Types.Symbol)
     583         Type_Symbol     : Gela.Lexical_Types.Symbol;
     584         Arity           : Positive := 2)
    584585         return Gela.Elements.Function_Declarations.
    585586                  Function_Declaration_Access;
     
    609610      function Create_Operator
    610611        (Operator_Symbol : Gela.Lexical_Types.Symbol;
    611          Type_Symbol     : Gela.Lexical_Types.Symbol)
     612         Type_Symbol     : Gela.Lexical_Types.Symbol;
     613         Arity           : Positive := 2)
    612614         return Gela.Elements.Function_Declarations.
    613615                  Function_Declaration_Access
     
    638640           (Oper);
    639641
    640          for J in 1 .. 2 loop
     642         for J in 1 .. Arity loop
    641643            Mark := Create_Subtype (Type_Symbol);
    642644
     
    759761        (Operator_Symbol => Gela.Lexical_Types.Operators.Ampersand_Operator,
    760762         Type_Symbol     => Gela.Lexical_Types.Predefined_Symbols.String);
     763
     764      FD := Create_Operator
     765        (Operator_Symbol => Gela.Lexical_Types.Operators.Hyphen_Operator,
     766         Type_Symbol     => Gela.Lexical_Types.Predefined_Symbols.Float,
     767         Arity           => 1);
    761768   end Postprocess_Standard;
    762769
  • 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;
  • trunk/ada-2012/src/semantic/gela-plain_type_managers.ads

    r395 r407  
    77with Gela.Elements.Defining_Names;
    88with Gela.Elements.Full_Type_Declarations;
    9 with Gela.Elements.Subtype_Marks;
     9with Gela.Elements.Subtype_Mark_Or_Access_Definitions;
     10with Gela.Profiles;
    1011with Gela.Semantic_Types;
    1112with Gela.Type_Managers;
     
    4748      "="             => Gela.Semantic_Types."=");
    4849
     50   function Hash
     51     (Self : Gela.Elements.Defining_Names.Defining_Name_Access)
     52      return Ada.Containers.Hash_Type;
     53
     54   type Profile_Access is access all Gela.Profiles.Profile'Class;
     55
     56   package Profile_Maps is new Ada.Containers.Hashed_Maps
     57     (Key_Type        => Gela.Elements.Defining_Names.Defining_Name_Access,
     58      Element_Type    => Profile_Access,
     59      Hash            => Hash,
     60      Equivalent_Keys => Gela.Elements.Defining_Names."=");
     61
    4962   type Type_Manager (Context : Gela.Contexts.Context_Access) is
    5063     new Gela.Type_Managers.Type_Manager with
    5164   record
    52        Map  : Type_View_Maps.Map;
    53        Back : Back_Maps.Map;
     65       Map      : Type_View_Maps.Map;
     66       Back     : Back_Maps.Map;
     67       Profiles : Profile_Maps.Map;
    5468   end record;
    5569
     
    7892   overriding function Type_From_Subtype_Mark
    7993     (Self  : access Type_Manager;
    80       Node  : Gela.Elements.Subtype_Marks.Subtype_Mark_Access)
     94      Node  : access Gela.Elements.Subtype_Mark_Or_Access_Definitions.
     95                Subtype_Mark_Or_Access_Definition'Class)
    8196      return Gela.Semantic_Types.Type_Index;
    8297
     
    95110     (Self  : access Type_Manager) return Gela.Semantic_Types.Type_Index;
    96111
     112   overriding function Get_Profile
     113     (Self  : access Type_Manager;
     114      Name  : Gela.Elements.Defining_Names.Defining_Name_Access)
     115      return Gela.Profiles.Profile_Access;
     116
    97117end Gela.Plain_Type_Managers;
  • trunk/ada-2012/src/semantic/gela-resolve.adb

    r405 r407  
    66with Gela.Elements.Simple_Expression_Ranges;
    77with Gela.Environments;
     8with Gela.Profiles;
    89with Gela.Type_Managers;
    9 with Gela.Type_Views;
    1010
    1111package body Gela.Resolve is
     
    660660      use type Gela.Interpretations.Interpretation_Index_Array;
    661661
    662       No_Args_Allowed : constant Boolean := True;
    663       --  FIXME Replace with actual check
    664 
    665662      package Each_Prefix is
    666663         type Visiter is new Gela.Interpretations.Up_Visiter with null record;
     
    675672      package Each_Arg is
    676673         type Visiter is new Gela.Interpretations.Up_Visiter with record
    677             Index  : Gela.Interpretations.Interpretation_Index := 0;
     674            Index   : Gela.Interpretations.Interpretation_Index := 0;
     675            Profile : Gela.Profiles.Profile_Access;
    678676         end record;
    679677
     
    686684      package Each_Association is
    687685         type Visiter is new Gela.Interpretations.Up_Visiter with record
    688             Index  : aliased Gela.Interpretations.Interpretation_Index := 0;
     686            Index   : aliased Gela.Interpretations.Interpretation_Index := 0;
     687            Profile : Gela.Profiles.Profile_Access;
     688            Count   : Natural := 0;
    689689         end record;
    690690
     
    698698        Comp.Context.Interpretation_Manager;
    699699
     700      TM : constant Gela.Type_Managers.Type_Manager_Access :=
     701        Comp.Context.Types;
     702
    700703      package body Each_Arg is
    701704         overriding procedure On_Tuple
     
    703706            Value : Gela.Interpretations.Interpretation_Set_Index_Array)
    704707         is
    705 
    706             V      : aliased Each_Association.Visiter;
     708            use type Gela.Interpretations.Interpretation_Index;
     709
     710            V      : aliased Each_Association.Visiter :=
     711              (Index   => 0,
     712               Profile => Self.Profile,
     713               Count   => 0);
    707714            Chosen : Gela.Interpretations.Interpretation_Index;
    708715         begin
     
    714721               Chosen => Chosen);
    715722
    716             Comp.Context.Interpretation_Manager.Add_Expression
    717               (Tipe   => Comp.Context.Types.Universal_Integer,
    718                Down   => Self.Index & Chosen,
    719                Result => Set);
     723            if Chosen /= 0 then
     724               Comp.Context.Interpretation_Manager.Add_Expression
     725                 (Tipe   => V.Profile.Return_Type,
     726                  Down   => Self.Index & Chosen,
     727                  Result => Set);
     728            end if;
    720729         end On_Tuple;
    721730      end Each_Arg;
     
    728737         is
    729738
     739            Tipe   : Gela.Semantic_Types.Type_Index;
    730740            Chosen : Gela.Interpretations.Interpretation_Index;
    731741            List   : Gela.Interpretations.Interpretation_Index_Array
    732742              (Value'Range);
    733743         begin
    734             for J in Value'Range loop
    735                Interpretation
    736                  (Comp   => Comp,
    737                   Env    => Env,
    738                   Set    => Value (J),
    739                   Result => List (J));
    740             end loop;
     744            if Value'Length = 1 then
     745               if Self.Count < Self.Profile.Length then
     746                  Self.Count := Self.Count + 1;
     747                  Tipe := Self.Profile.Get_Type (Self.Count);
     748                  To_Type (Comp, Tipe, Value (Value'First), List (List'First));
     749               else
     750                  Self.Index := 0;
     751                  return;
     752               end if;
     753            else
     754               for J in Value'Range loop
     755                  Interpretation
     756                    (Comp   => Comp,
     757                     Env    => Env,
     758                     Set    => Value (J),
     759                     Result => List (J));
     760               end loop;
     761            end if;
    741762
    742763            Chosen := 0;
     
    758779            Cursor : Gela.Interpretations.Cursor'Class)
    759780         is
    760             pragma Unreferenced (Name, Self);
    761             Visiter : aliased Each_Arg.Visiter := (Index => Cursor.Get_Index);
    762             Arg     : Gela.Interpretations.Cursor'Class :=
    763               IM.Get_Cursor (Args);
    764          begin
     781            pragma Unreferenced (Self);
     782            Visiter : aliased Each_Arg.Visiter :=
     783              (Index   => Cursor.Get_Index,
     784               Profile => TM.Get_Profile (Name));
     785            Arg : Gela.Interpretations.Cursor'Class := IM.Get_Cursor (Args);
     786         begin
     787            if not Visiter.Profile.Assigned then
     788               return;
     789            end if;
     790
    765791            if Arg.Has_Element then
    766792               while Arg.Has_Element loop
     
    768794                  Arg.Next;
    769795               end loop;
    770             elsif No_Args_Allowed then
     796            elsif Visiter.Profile.Allow_Empty_Argument_List then
    771797               Comp.Context.Interpretation_Manager.Add_Expression
    772                  (Tipe   => Comp.Context.Types.Universal_Integer,
     798                 (Tipe   => Visiter.Profile.Return_Type,
    773799                  Down   => Visiter.Index & 0,
    774800                  Result => Set);
     
    951977      return Result;
    952978   end Placeholder;
     979
     980   ---------------
     981   -- Real_Type --
     982   ---------------
     983
     984   procedure Real_Type
     985     (Comp     : Gela.Compilations.Compilation_Access;
     986      Up       : Gela.Interpretations.Interpretation_Set_Index;
     987      Result   : out Gela.Interpretations.Interpretation_Index) is
     988   begin
     989      To_Type_Category (Comp, Up, Gela.Type_Views.A_Float_Point, Result);
     990   end Real_Type;
    953991
    954992   ------------------------
     
    10441082     (Comp     : Gela.Compilations.Compilation_Access;
    10451083      Up       : Gela.Interpretations.Interpretation_Set_Index;
    1046       Result   : out Gela.Interpretations.Interpretation_Index)
    1047    is
    1048 
    1049       package Each is
    1050          type Visiter is new Gela.Interpretations.Up_Visiter with null record;
    1051 
    1052          overriding procedure On_Expression_Category
    1053            (Self   : in out Visiter;
    1054             Kinds  : Gela.Type_Views.Category_Kind_Set;
    1055             Cursor : Gela.Interpretations.Cursor'Class);
    1056 
    1057       end Each;
    1058 
    1059       ----------
    1060       -- Each --
    1061       ----------
    1062 
    1063       package body Each is
    1064 
    1065          overriding procedure On_Expression_Category
    1066            (Self   : in out Visiter;
    1067             Kinds  : Gela.Type_Views.Category_Kind_Set;
    1068             Cursor : Gela.Interpretations.Cursor'Class)
    1069          is
    1070             pragma Unreferenced (Self);
    1071          begin
    1072             if Kinds (Gela.Type_Views.A_Signed_Integer) then
    1073                Result := Cursor.Get_Index;
    1074             end if;
    1075          end On_Expression_Category;
    1076 
    1077       end Each;
    1078 
    1079       IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
    1080         Comp.Context.Interpretation_Manager;
    1081 
    1082       Cursor  : Gela.Interpretations.Cursor'Class := IM.Get_Cursor (Up);
    1083       Visiter : aliased Each.Visiter;
    1084    begin
    1085       Result := 0;
    1086 
    1087       while Cursor.Has_Element loop
    1088          Cursor.Visit (Visiter'Access);
    1089          Cursor.Next;
    1090       end loop;
     1084      Result   : out Gela.Interpretations.Interpretation_Index) is
     1085   begin
     1086      To_Type_Category (Comp, Up, Gela.Type_Views.A_Signed_Integer, Result);
    10911087   end Signed_Integer_Type;
    10921088
     
    11041100      pragma Unreferenced (Env);
    11051101
     1102      type Counter is record
     1103         Count : Natural := 0;
     1104         Index : Gela.Interpretations.Interpretation_Index;
     1105      end record;
     1106
     1107      type Type_Kind is (Integer, Float);
     1108      type Counter_By_Type is array (Type_Kind) of Counter;
     1109      type Side is (Left_Side, Right_Side);
     1110      type Counter_Array is array (Side) of Counter_By_Type;
     1111
     1112      procedure Increment
     1113        (Value    : in out Counter_By_Type;
     1114         Index    : Gela.Interpretations.Interpretation_Index;
     1115         Tipe     : Type_Kind);
     1116
     1117      procedure Increment
     1118        (Value    : in out Counter_Array;
     1119         Index    : Gela.Interpretations.Interpretation_Index;
     1120         Count    : Counter_By_Type;
     1121         Tipe     : Type_Kind);
     1122
    11061123      package Each_Left is
    11071124         type Visiter is new Gela.Interpretations.Up_Visiter with record
    1108             Left_Int_Index  : Gela.Interpretations.Interpretation_Index;
    1109             Left_Int_Count  : Natural := 0;
    1110             Right_Int_Index : Gela.Interpretations.Interpretation_Index;
    1111             Right_Int_Count : Natural := 0;
     1125            Counters : Counter_Array;
    11121126         end record;
    11131127
     
    11351149               type Visiter is new Gela.Interpretations.Up_Visiter with record
    11361150                  Tipe      : Gela.Semantic_Types.Type_Index;
    1137                   Int_Index : Gela.Interpretations.Interpretation_Index;
    1138                   Int_Count : Natural := 0;
     1151                  Counters  : Counter_By_Type;
    11391152               end record;
    11401153
     
    11561169                    TM.Get (Tipe);
    11571170               begin
    1158                   if Type_View.Assigned and then
    1159                     Type_View.Category in Gela.Type_Views.An_Integer
     1171                  if not Type_View.Assigned then
     1172                     null;
     1173                  elsif Type_View.Category in
     1174                    Gela.Type_Views.Any_Integer_Type
    11601175                  then
    1161                      Self.Int_Index := Cursor.Get_Index;
    1162                      Self.Int_Count := Self.Int_Count + 1;
     1176                     Increment (Self.Counters, Cursor.Get_Index, Integer);
     1177                  elsif Type_View.Category in
     1178                    Gela.Type_Views.Any_Real_Type
     1179                  then
     1180                     Increment (Self.Counters, Cursor.Get_Index, Float);
    11631181                  else  --  FIXME Drop after implementation of types
    1164                      Self.Int_Index := Cursor.Get_Index;
    1165                      Self.Int_Count := Self.Int_Count + 1;
     1182                     null;
    11661183                  end if;
    11671184
     
    11851202               Target => Visiter_Right);
    11861203
    1187             if Type_View.Assigned and then
    1188               Type_View.Category in Gela.Type_Views.An_Integer
    1189             then
    1190                Self.Left_Int_Index := Cursor.Get_Index;
    1191                Self.Left_Int_Count := Self.Left_Int_Count + 1;
    1192                Self.Right_Int_Index := Visiter_Right.Int_Index;
    1193                Self.Right_Int_Count := Visiter_Right.Int_Count;
     1204            if not Type_View.Assigned then
     1205               null;
     1206            elsif Type_View.Category in Gela.Type_Views.Any_Integer_Type then
     1207               Increment
     1208                 (Self.Counters,
     1209                  Cursor.Get_Index,
     1210                  Visiter_Right.Counters,
     1211                  Integer);
     1212            elsif Type_View.Category in Gela.Type_Views.Any_Real_Type then
     1213               Increment
     1214                 (Self.Counters,
     1215                  Cursor.Get_Index,
     1216                  Visiter_Right.Counters,
     1217                  Float);
    11941218            else  --  FIXME Drop after implementation of types
    1195                Self.Left_Int_Index := Cursor.Get_Index;
    1196                Self.Left_Int_Count := Self.Left_Int_Count + 1;
    1197                Self.Right_Int_Index := Visiter_Right.Int_Index;
    1198                Self.Right_Int_Count := Visiter_Right.Int_Count;
     1219               null;
    11991220            end if;
    12001221         end On_Expression;
     
    12021223      end Each_Left;
    12031224
     1225      ---------------
     1226      -- Increment --
     1227      ---------------
     1228
     1229      procedure Increment
     1230        (Value    : in out Counter_By_Type;
     1231         Index    : Gela.Interpretations.Interpretation_Index;
     1232         Tipe     : Type_Kind) is
     1233      begin
     1234         Value (Tipe).Count := Value (Tipe).Count + 1;
     1235         Value (Tipe).Index := Index;
     1236      end Increment;
     1237
     1238      ---------------
     1239      -- Increment --
     1240      ---------------
     1241
     1242      procedure Increment
     1243        (Value    : in out Counter_Array;
     1244         Index    : Gela.Interpretations.Interpretation_Index;
     1245         Count    : Counter_By_Type;
     1246         Tipe     : Type_Kind)
     1247      is
     1248         L_Val : Counter_By_Type renames Value (Left_Side);
     1249         R_Val : Counter_By_Type renames Value (Right_Side);
     1250      begin
     1251         Increment (L_Val, Index, Tipe);
     1252         R_Val (Tipe) := Count (Tipe);
     1253      end Increment;
     1254
    12041255      Visiter : aliased Each_Left.Visiter;
     1256      L_Val : Counter_By_Type renames Visiter.Counters (Left_Side);
     1257      R_Val : Counter_By_Type renames Visiter.Counters (Right_Side);
    12051258   begin
    12061259      Set := 0;
     
    12101263         Target => Visiter);
    12111264
    1212       if Visiter.Left_Int_Count = 1 and Visiter.Right_Int_Count = 1 then
     1265      if L_Val (Integer).Count = 1 and R_Val (Integer).Count = 1 then
    12131266         Comp.Context.Interpretation_Manager.Add_Expression_Category
    12141267           (Kinds  =>
    12151268              (Gela.Type_Views.A_Signed_Integer => True, others => False),
    1216             Down   => (Visiter.Left_Int_Index, Visiter.Right_Int_Index),
     1269            Down   => (L_Val (Integer).Index, R_Val (Integer).Index),
     1270            Result => Set);
     1271      end if;
     1272
     1273      if L_Val (Float).Count = 1 and R_Val (Float).Count = 1 then
     1274         Comp.Context.Interpretation_Manager.Add_Expression_Category
     1275           (Kinds  =>
     1276              (Gela.Type_Views.A_Float_Point => True, others => False),
     1277            Down   => (L_Val (Float).Index, R_Val (Float).Index),
    12171278            Result => Set);
    12181279      end if;
     
    14301491         is
    14311492
    1432             V      : aliased Each_Symbol.Visiter;
     1493            V      : aliased Each_Symbol.Visiter := (0, 0);
    14331494            Expr   : Gela.Interpretations.Interpretation_Index;
    14341495            Chosen : Gela.Interpretations.Interpretation_Index;
     
    14921553      Result := Visiter.Index;
    14931554   end To_Type;
     1555
     1556   ----------------------
     1557   -- To_Type_Category --
     1558   ----------------------
     1559
     1560   procedure To_Type_Category
     1561     (Comp     : Gela.Compilations.Compilation_Access;
     1562      Up       : Gela.Interpretations.Interpretation_Set_Index;
     1563      Category : Gela.Type_Views.Category_Kinds;
     1564      Result   : out Gela.Interpretations.Interpretation_Index)
     1565   is
     1566
     1567      package Each is
     1568         type Visiter is new Gela.Interpretations.Up_Visiter with null record;
     1569
     1570         overriding procedure On_Expression_Category
     1571           (Self   : in out Visiter;
     1572            Kinds  : Gela.Type_Views.Category_Kind_Set;
     1573            Cursor : Gela.Interpretations.Cursor'Class);
     1574
     1575      end Each;
     1576
     1577      ----------
     1578      -- Each --
     1579      ----------
     1580
     1581      package body Each is
     1582
     1583         overriding procedure On_Expression_Category
     1584           (Self   : in out Visiter;
     1585            Kinds  : Gela.Type_Views.Category_Kind_Set;
     1586            Cursor : Gela.Interpretations.Cursor'Class)
     1587         is
     1588            pragma Unreferenced (Self);
     1589         begin
     1590            if Kinds (Category) then
     1591               Result := Cursor.Get_Index;
     1592            end if;
     1593         end On_Expression_Category;
     1594
     1595      end Each;
     1596
     1597      IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
     1598        Comp.Context.Interpretation_Manager;
     1599
     1600      Cursor  : Gela.Interpretations.Cursor'Class := IM.Get_Cursor (Up);
     1601      Visiter : aliased Each.Visiter;
     1602   begin
     1603      Result := 0;
     1604
     1605      while Cursor.Has_Element loop
     1606         Cursor.Visit (Visiter'Access);
     1607         Cursor.Next;
     1608      end loop;
     1609   end To_Type_Category;
    14941610
    14951611   ------------------------------
  • trunk/ada-2012/src/semantic/gela-resolve.ads

    r405 r407  
    44with Gela.Lexical_Types;
    55with Gela.Semantic_Types;
     6with Gela.Type_Views;
    67
    78package Gela.Resolve is
     
    132133      Result   : out Gela.Interpretations.Interpretation_Index);
    133134
     135   procedure Real_Type
     136     (Comp     : Gela.Compilations.Compilation_Access;
     137      Up       : Gela.Interpretations.Interpretation_Set_Index;
     138      Result   : out Gela.Interpretations.Interpretation_Index);
     139
     140   procedure To_Type_Category
     141     (Comp     : Gela.Compilations.Compilation_Access;
     142      Up       : Gela.Interpretations.Interpretation_Set_Index;
     143      Category : Gela.Type_Views.Category_Kinds;
     144      Result   : out Gela.Interpretations.Interpretation_Index);
     145
    134146end Gela.Resolve;
Note: See TracChangeset for help on using the changeset viewer.