Changeset 542


Ignore:
Timestamp:
Feb 24, 2018, 12:22:02 PM (5 years ago)
Author:
Maxim Reznik
Message:

Implement root_integer and root_real preferences

in interpretation sets of dircrete range and simple expression range.

Location:
trunk/ada-2012
Files:
6 edited

Legend:

Unmodified
Added
Removed
  • trunk/ada-2012/src/adalib/standard.ads

    r540 r542  
    3535   -- corresponding universal type universal_integer are predefined.
    3636
    37 --   type root_integer is range implementation_defined .. implementation_defined;
     37   type root_integer is range implementation_defined .. implementation_defined;
    3838
    3939   type Integer is range implementation_defined .. implementation_defined;
     
    7575   -- corresponding universal type universal_real are predefined.
    7676
    77 --   type root_real is digits implementation_defined;
     77   type root_real is digits implementation_defined;
    7878
    7979   type Float is digits implementation_defined;
  • trunk/ada-2012/src/semantic/gela-plain_type_managers.adb

    r541 r542  
    462462         Gela.Type_Categories.A_Signed_Integer,
    463463         Root_Integer_Index);
     464      Find_Type
     465        (Gela.Lexical_Types.Predefined_Symbols.Root_Real,
     466         Gela.Type_Categories.A_Float_Point,
     467         Root_Real_Index);
    464468   end Initialize;
    465469
  • trunk/ada-2012/src/semantic/gela-resolve-each.adb

    r531 r542  
    6666   procedure Step (Self : in out Prefix_Cursor'Class);
    6767
     68   type Prefer_Root_Cursor is
     69     new Gela.Interpretations.Expression_Cursor with
     70   record
     71      Has_Integer_Root : Boolean := False;
     72      Has_Real_Root    : Boolean := False;
     73      Root_Cursor      : Join_Cursor;
     74      Exp_Cursor       : Join_Cursor;
     75   end record;
     76
     77   procedure Step (Self : in out Prefer_Root_Cursor'Class);
     78
     79   overriding function Has_Element
     80     (Self : Prefer_Root_Cursor) return Boolean;
     81
     82   overriding procedure Next (Self : in out Prefer_Root_Cursor);
     83
     84   overriding function Get_Index
     85     (Self : Prefer_Root_Cursor)
     86       return Gela.Interpretations.Interpretation_Index;
     87
     88   overriding function Expression_Type
     89     (Self : Prefer_Root_Cursor)
     90       return Gela.Semantic_Types.Type_Index;
     91
     92   procedure Initialize
     93     (Self : in out Prefer_Root_Cursor'Class;
     94      IM   : access Gela.Interpretations.Interpretation_Manager'Class;
     95      TM   : Gela.Type_Managers.Type_Manager_Access;
     96      Env  : Gela.Semantic_Types.Env_Index;
     97      Set  : Gela.Interpretations.Interpretation_Set_Index);
     98
    6899   ---------------------
    69100   -- Expression_Type --
     
    117148   end Get_Index;
    118149
     150   ---------------
     151   -- Get_Index --
     152   ---------------
     153
     154   overriding function Get_Index
     155     (Self : Prefer_Root_Cursor)
     156       return Gela.Interpretations.Interpretation_Index is
     157   begin
     158      if Self.Root_Cursor.Has_Element then
     159         return Self.Root_Cursor.Get_Index;
     160      else
     161         return Self.Exp_Cursor.Get_Index;
     162      end if;
     163   end Get_Index;
     164
    119165   -----------------
    120166   -- Has_Element --
     
    134180   begin
    135181      return Self.Name.Has_Element or else Self.Exp.Has_Element;
     182   end Has_Element;
     183
     184   -----------------
     185   -- Has_Element --
     186   -----------------
     187
     188   overriding function Has_Element
     189     (Self : Prefer_Root_Cursor) return Boolean is
     190   begin
     191      return Self.Root_Cursor.Has_Element or else Self.Exp_Cursor.Has_Element;
    136192   end Has_Element;
    137193
     
    155211   end Initialize;
    156212
     213   ----------------
     214   -- Initialize --
     215   ----------------
     216
     217   procedure Initialize
     218     (Self : in out Prefer_Root_Cursor'Class;
     219      IM   : access Gela.Interpretations.Interpretation_Manager'Class;
     220      TM   : Gela.Type_Managers.Type_Manager_Access;
     221      Env  : Gela.Semantic_Types.Env_Index;
     222      Set  : Gela.Interpretations.Interpretation_Set_Index) is
     223   begin
     224      Self.Root_Cursor.Initialize (IM, TM, Env, Set);
     225      Self.Exp_Cursor.Initialize (IM, TM, Env, Set);
     226      Self.Step;
     227   end Initialize;
     228
    157229   ----------
    158230   -- Next --
     
    176248         Self.Exp.Next;
    177249      end if;
     250   end Next;
     251
     252   ----------
     253   -- Next --
     254   ----------
     255
     256   overriding procedure Next (Self : in out Prefer_Root_Cursor) is
     257   begin
     258      if Self.Root_Cursor.Has_Element then
     259         Self.Root_Cursor.Next;
     260      else
     261         Self.Exp_Cursor.Next;
     262      end if;
     263
     264      Self.Step;
    178265   end Next;
    179266
     
    199286      end loop;
    200287   end Step;
     288
     289   ----------
     290   -- Step --
     291   ----------
     292
     293   procedure Step (Self : in out Prefer_Root_Cursor'Class) is
     294      TM         : constant Gela.Type_Managers.Type_Manager_Access :=
     295        Self.Root_Cursor.Name.TM;
     296      Type_Index : Gela.Semantic_Types.Type_Index;
     297      Type_View  : Gela.Types.Type_View_Access;
     298   begin
     299      --   In the first phase look for root types and return them
     300      while Self.Root_Cursor.Has_Element loop
     301         Type_Index := Self.Root_Cursor.Expression_Type;
     302         Type_View := TM.Get (Type_Index);
     303
     304         if Type_View in null then
     305            null;  --  Skip unknown types
     306         elsif Type_View.Is_Root then
     307            if Type_View.Is_Signed_Integer then
     308               Self.Has_Integer_Root := True;
     309            else
     310               Self.Has_Real_Root := True;
     311            end if;
     312
     313            return;
     314         end if;
     315
     316         Self.Root_Cursor.Next;
     317      end loop;
     318
     319      --   In the second phase look for other types, if not hidden by root
     320      while Self.Exp_Cursor.Has_Element loop
     321         Type_Index := Self.Exp_Cursor.Expression_Type;
     322         Type_View := TM.Get (Type_Index);
     323
     324         if Type_View in null then
     325            null;  --  Skip unknown types
     326         elsif Type_View.Is_Root then
     327            null;  --  Skip root types
     328         elsif Self.Has_Integer_Root and then Type_View.Is_Signed_Integer then
     329            null;  --  Skip any integer type if we have integer_root
     330         elsif Self.Has_Real_Root and then Type_View.Is_Real then
     331            null;  --  Skip any real type if we have real_root
     332         else
     333            --  Found other expression type, return it
     334            return;
     335         end if;
     336
     337         Self.Exp_Cursor.Next;
     338      end loop;
     339   end Step;
     340
     341   ----------
     342   -- Step --
     343   ----------
    201344
    202345   procedure Step (Self : in out Prefix_Cursor'Class) is
     
    264407   end Expression_Type;
    265408
     409   ---------------------
     410   -- Expression_Type --
     411   ---------------------
     412
     413   overriding function Expression_Type
     414     (Self : Prefer_Root_Cursor)
     415       return Gela.Semantic_Types.Type_Index is
     416   begin
     417      if Self.Root_Cursor.Has_Element then
     418         return Self.Root_Cursor.Expression_Type;
     419      else
     420         return Self.Exp_Cursor.Expression_Type;
     421      end if;
     422   end Expression_Type;
     423
    266424   package Join_Iterators is
    267425     new Gela.Plain_Int_Sets.Cursors.Generic_Iterators
     
    278436      Iterators   => Gela.Interpretations.Expression_Iterators);
    279437
     438   package Prefer_Root_Iterators is
     439     new Gela.Plain_Int_Sets.Cursors.Generic_Iterators
     440     (Cursor      => Gela.Interpretations.Expression_Cursor,
     441      Next        => Gela.Interpretations.Next,
     442      Some_Cursor => Prefer_Root_Cursor,
     443      Iterators   => Gela.Interpretations.Expression_Iterators);
     444
     445   -----------------
     446   -- Prefer_Root --
     447   -----------------
     448
     449   function Prefer_Root
     450     (Self : access Gela.Interpretations.Interpretation_Manager'Class;
     451      TM   : Gela.Type_Managers.Type_Manager_Access;
     452      Env  : Gela.Semantic_Types.Env_Index;
     453      Set  : Gela.Interpretations.Interpretation_Set_Index)
     454      return Gela.Interpretations.Expression_Iterators.Forward_Iterator'Class
     455   is
     456   begin
     457      return Result : Prefer_Root_Iterators.Iterator do
     458         Result.Cursor.Initialize (Self, TM, Env, Set);
     459      end return;
     460   end Prefer_Root;
     461
    280462   ------------
    281463   -- Prefix --
  • trunk/ada-2012/src/semantic/gela-resolve-each.ads

    r510 r542  
    1414   --  expression.
    1515
     16   function Prefer_Root
     17     (Self : access Gela.Interpretations.Interpretation_Manager'Class;
     18      TM   : Gela.Type_Managers.Type_Manager_Access;
     19      Env  : Gela.Semantic_Types.Env_Index;
     20      Set  : Gela.Interpretations.Interpretation_Set_Index)
     21      return Gela.Interpretations.Expression_Iterators.Forward_Iterator'Class;
     22   --  The same as Expression, but prefere root_integer and root_read over
     23   --  other interpretations.
     24
    1625   function Prefix
    1726     (Self : access Gela.Interpretations.Interpretation_Manager'Class;
  • trunk/ada-2012/src/semantic/gela-resolve.adb

    r536 r542  
    16351635            L_Type_View : constant Gela.Types.Type_View_Access :=
    16361636              TM.Get (L_Tipe);
    1637             R_Counters  : Counter_By_Type;
    16381637
    16391638         begin
     
    16501649                  if not Type_View.Assigned then
    16511650                     return;
    1652                   elsif Type_View.Is_Integer then
    1653                      Increment (R_Counters, R.Get_Index, Integer);
    1654                   elsif Type_View.Is_Real then
    1655                      Increment (R_Counters, R.Get_Index, Float);
    16561651                  else  --  FIXME Return after implementation of types
    16571652                     null;
     
    16871682                        Down   => (L.Get_Index, R.Get_Index),
    16881683                        Result => Set);
     1684                  end if;
     1685               end;
     1686            end loop;
     1687         end;
     1688      end loop;
     1689
     1690      for L in IM.Categories (Left) loop
     1691         for R in Each.Expression (IM, TM, Env, Right) loop
     1692            declare
     1693               Match : constant Gela.Interpretations.Type_Matcher_Access :=
     1694                 L.Matcher;
     1695               Type_View : constant Gela.Types.Type_View_Access :=
     1696                 TM.Get (R.Expression_Type);
     1697            begin
     1698               Type_View.Visit (Match.all);
     1699
     1700               if Match.Is_Matched then
     1701                  Comp.Context.Interpretation_Manager.Add_Expression
     1702                    (Tipe   => R.Expression_Type,
     1703                     Down   => (L.Get_Index, R.Get_Index),
     1704                     Result => Set);
     1705               end if;
     1706            end;
     1707         end loop;
     1708      end loop;
     1709
     1710      for L in Each.Prefer_Root (IM, TM, Env, Left) loop
     1711         declare
     1712
     1713            R_Counters  : Counter_By_Type;
     1714            L_Type_View : constant Gela.Types.Type_View_Access :=
     1715              TM.Get (L.Expression_Type);
     1716
     1717         begin
     1718            for R in Each.Prefer_Root (IM, TM, Env, Right) loop
     1719               declare
     1720                  Type_View : constant Gela.Types.Type_View_Access :=
     1721                    TM.Get (R.Expression_Type);
     1722               begin
     1723                  if Type_View.Is_Integer then
     1724                     Increment (R_Counters, R.Get_Index, Integer);
     1725                  elsif Type_View.Is_Real then
     1726                     Increment (R_Counters, R.Get_Index, Float);
     1727                  else  --  FIXME Return after implementation of types
     1728                     null;
    16891729                  end if;
    16901730               end;
     
    17111751      end loop;
    17121752
    1713       for L in IM.Categories (Left) loop
    1714          for R in Each.Expression (IM, TM, Env, Right) loop
    1715             declare
    1716                Match : constant Gela.Interpretations.Type_Matcher_Access :=
    1717                  L.Matcher;
    1718                Type_View : constant Gela.Types.Type_View_Access :=
    1719                  TM.Get (R.Expression_Type);
    1720             begin
    1721                Type_View.Visit (Match.all);
    1722 
    1723                if Match.Is_Matched then
    1724                   Comp.Context.Interpretation_Manager.Add_Expression
    1725                     (Tipe   => R.Expression_Type,
    1726                      Down   => (L.Get_Index, R.Get_Index),
    1727                      Result => Set);
    1728                end if;
    1729             end;
    1730          end loop;
    1731       end loop;
    1732 
    17331753      if L_Val (Integer).Count = 1 and R_Val (Integer).Count = 1 then
    17341754         declare
     
    17781798      L_Count : Natural := 0;
    17791799   begin
    1780       for L in Each.Expression (IM, TM, Env, Left) loop
     1800      for L in Each.Prefer_Root (IM, TM, Env, Left) loop
    17811801         declare
    17821802
     
    17881808         begin
    17891809            if L_Type_View.Assigned and then L_Type_View.Is_Discrete then
    1790                for R in Each.Expression (IM, TM, Env, Right) loop
     1810               for R in Each.Prefer_Root (IM, TM, Env, Right) loop
    17911811                  declare
    17921812                     use type Gela.Semantic_Types.Type_Index;
  • trunk/ada-2012/tests/asis/def_name/list.txt

    r540 r542  
    1010./A/A35101B.ADA +2731034906
    1111./A/A35402A.ADA +1586780575
    12 ./A/A35801F.ADA +876258191
    13 ./A/A35902C.ADA +3466706282
     12./A/A35801F.ADA +3376682458
     13./A/A35902C.ADA +1097459835
    1414./A/A38106D.ADA +270178334
    1515./A/A38106E.ADA +2535167923
    1616./A/A49027A.ADA +3286192145
    1717./A/A49027B.ADA +2282938720
    18 ./A/A49027C.ADA +2949465672
     18./A/A49027C.ADA +1066771995
    1919./A/A54B01A.ADA +3101169469
    2020./A/A54B02A.ADA +3273270317
Note: See TracChangeset for help on using the changeset viewer.