Changeset 423


Ignore:
Timestamp:
Oct 29, 2015, 10:48:36 AM (7 years ago)
Author:
Maxim Reznik
Message:

Remove Type_Category from type API

Location:
trunk/ada-2012/src
Files:
2 added
16 edited

Legend:

Unmodified
Added
Removed
  • trunk/ada-2012/src/api/gela-interpretations.ads

    r421 r423  
    33with Gela.Lexical_Types;
    44with Gela.Semantic_Types;
    5 with Gela.Types;
     5with Gela.Types.Visitors;
    66
    77package Gela.Interpretations is
     
    2626   for Interpretation_Manager_Access'Storage_Size use 0;
    2727
     28   type Type_Matcher is limited interface and Gela.Types.Visitors.Type_Visitor;
     29   type Type_Matcher_Access is access all Type_Matcher'Class;
     30   for Type_Matcher_Access'Storage_Size use 0;
     31
     32   not overriding function Is_Matched
     33     (Self : Type_Matcher) return Boolean is abstract;
     34
    2835   not overriding procedure Add_Symbol
    2936     (Self   : in out Interpretation_Manager;
     
    5158   not overriding procedure Add_Expression_Category
    5259     (Self   : in out Interpretation_Manager;
    53       Kinds  : Gela.Types.Category_Kind_Set;
     60      Match  : not null Gela.Interpretations.Type_Matcher_Access;
    5461      Down   : Gela.Interpretations.Interpretation_Index_Array;
    5562      Result : in out Gela.Interpretations.Interpretation_Set_Index)
     
    113120   not overriding procedure On_Expression_Category
    114121     (Self   : in out Down_Visiter;
    115       Kinds  : Gela.Types.Category_Kind_Set;
     122      Match  : not null Gela.Interpretations.Type_Matcher_Access;
    116123      Down   : Gela.Interpretations.Interpretation_Index_Array) is null;
    117124   --  Called for each category of expression interpretation
     
    176183   not overriding procedure On_Expression_Category
    177184     (Self   : in out Up_Visiter;
    178       Kinds  : Gela.Types.Category_Kind_Set;
     185      Match  : not null Gela.Interpretations.Type_Matcher_Access;
    179186      Cursor : Gela.Interpretations.Cursor'Class) is null;
    180187   --  Called for each category of expression interpretation
  • trunk/ada-2012/src/api/gela-types.ads

    r421 r423  
    1515   function Assigned (Self : access Type_View'Class) return Boolean
    1616     is (Self /= null);
    17 
    18    type Category_Kinds is
    19      (A_Character,
    20       A_Boolean,
    21       An_Other_Enum,
    22       An_Universal_Integer,
    23       A_Signed_Integer,
    24       A_Modular_Integer,
    25       An_Universal_Real,
    26       A_Float_Point,
    27       An_Universal_Fixed,
    28       A_Ordinary_Fixed_Point,
    29       A_Decimal_Fixed_Point,
    30       A_Constant_Access,
    31       A_Variable_Access,
    32       A_Pool_Access,
    33       A_Procedure_Access,
    34       A_Function_Access,
    35       An_Universal_Access,
    36       A_String,
    37       An_Other_Array,
    38       A_Untagged_Record,
    39       A_Tagged,
    40       A_Task,
    41       A_Protected,
    42       A_Private,
    43       An_Incomplete);
    44 
    45    type Category_Kind_Set is array (Category_Kinds) of Boolean with Pack;
    46 
    47    subtype Any_Integer_Type is Category_Kinds
    48      range An_Universal_Integer .. A_Modular_Integer;
    49 
    50    subtype Any_Real_Type is Category_Kinds
    51      range An_Universal_Real .. A_Decimal_Fixed_Point;
    52 
    53    not overriding function Category
    54      (Self : Type_View) return Category_Kinds is abstract;
    5517
    5618   not overriding function Get_Discriminant
     
    7941--     function Is_Discrete             (Self : Abstract_Type) return Boolean;
    8042--     function Is_Enumeration          (Self : Abstract_Type) return Boolean;
    81 --     function Is_Character            (Self : Abstract_Type) return Boolean;
    8243--     function Is_Boolean              (Self : Abstract_Type) return Boolean;
    83 --     function Is_Signed_Integer       (Self : Abstract_Type) return Boolean;
    84 --     function Is_Modular_Integer      (Self : Abstract_Type) return Boolean;
    85 --     function Is_Float_Point          (Self : Abstract_Type) return Boolean;
    8644--     function Is_Ordinary_Fixed_Point (Self : Abstract_Type) return Boolean;
    8745--     function Is_Decimal_Fixed_Point  (Self : Abstract_Type) return Boolean;
     
    9452--     function Is_Subprogram_Access    (Self : Abstract_Type) return Boolean;
    9553--     function Is_String               (Self : Abstract_Type) return Boolean;
    96 --     function Is_Array                (Self : Abstract_Type) return Boolean;
    9754--     function Is_Untagged_Record      (Self : Abstract_Type) return Boolean;
    9855--     function Is_Tagged               (Self : Abstract_Type) return Boolean;
    9956--     function Is_Task                 (Self : Abstract_Type) return Boolean;
    10057--     function Is_Protected            (Self : Abstract_Type) return Boolean;
    101 --     function Is_Integer              (Self : Abstract_Type) return Boolean;
    102 --     function Is_Real                 (Self : Abstract_Type) return Boolean;
    103 --     function Is_Fixed_Point          (Self : Abstract_Type) return Boolean;
    104 --     function Is_Numeric              (Self : Abstract_Type) return Boolean;
    10558--     function Is_Access               (Self : Abstract_Type) return Boolean;
    10659--     function Is_Composite            (Self : Abstract_Type) return Boolean;
    107 --     function Is_Universal            (Self : Abstract_Type) return Boolean;
    10860--     function Is_Incomplete           (Self : Abstract_Type) return Boolean;
    10961--
     
    11264--        Length : Positive) return Boolean;
    11365
     66
    11467   not overriding function Is_Array (Self : Type_View) return Boolean
    11568     is abstract;
     69
     70   not overriding function Is_Character (Self : Type_View) return Boolean
     71     is abstract;
     72
     73   not overriding function Is_Floating_Point (Self : Type_View) return Boolean
     74     is abstract;
     75
     76   not overriding function Is_Modular_Integer (Self : Type_View) return Boolean
     77     is abstract;
     78
     79   not overriding function Is_Object_Access (Self : Type_View) return Boolean
     80     is abstract;
     81
     82   not overriding function Is_Record (Self : Type_View) return Boolean
     83     is abstract;
     84
     85   not overriding function Is_Signed_Integer (Self : Type_View) return Boolean
     86     is abstract;
     87
     88   not overriding function Is_Universal (Self : Type_View) return Boolean
     89     is abstract;
     90
     91   function Is_Integer (Self : Type_View'Class) return Boolean;
     92   function Is_Real    (Self : Type_View'Class) return Boolean;
     93   function Is_Numeric (Self : Type_View'Class) return Boolean;
    11694
    11795   not overriding procedure Visit
  • trunk/ada-2012/src/semantic/gela-debug_properties.adb

    r421 r423  
    1010with Gela.Types;
    1111with Gela.Type_Managers;
     12with Gela.Types.Visitors;
     13with Gela.Types.Simple;
     14with Gela.Types.Arrays;
     15with Gela.Types.Untagged_Records;
    1216
    1317package body Gela.Debug_Properties is
    1418
    1519   procedure Put_Line (Text : String);
     20
     21   procedure Put_Expression (Text : String);
     22
     23   package Dump_Type is
     24      type Type_Visitor (Put_Line : access procedure (Text : String)) is
     25        new Gela.Types.Visitors.Type_Visitor with null record;
     26
     27      overriding procedure Enumeration_Type
     28        (Self  : in out Type_Visitor;
     29         Value : not null Gela.Types.Simple.Enumeration_Type_Access);
     30
     31      overriding procedure Signed_Integer_Type
     32        (Self  : in out Type_Visitor;
     33         Value : not null Gela.Types.Simple.Signed_Integer_Type_Access);
     34
     35      overriding procedure Floating_Point_Type
     36        (Self  : in out Type_Visitor;
     37         Value : not null Gela.Types.Simple.Floating_Point_Type_Access);
     38
     39      overriding procedure Array_Type
     40        (Self  : in out Type_Visitor;
     41         Value : not null Gela.Types.Arrays.Array_Type_Access);
     42
     43      overriding procedure Untagged_Record
     44        (Self  : in out Type_Visitor;
     45         Value : not null Gela.Types.Untagged_Records
     46         .Untagged_Record_Type_Access);
     47
     48      overriding procedure Object_Access_Type
     49        (Self  : in out Type_Visitor;
     50         Value : not null Gela.Types.Simple.Object_Access_Type_Access);
     51
     52      overriding procedure Subprogram_Access_Type
     53        (Self  : in out Type_Visitor;
     54         Value : not null Gela.Types.Simple.Subprogram_Access_Type_Access);
     55
     56   end Dump_Type;
    1657
    1758   package Dump_Property is
     
    70111      overriding procedure On_Expression_Category
    71112        (Self   : in out Visiter;
    72          Kinds  : Gela.Types.Category_Kind_Set;
     113         Match  : not null Gela.Interpretations.Type_Matcher_Access;
    73114         Down   : Gela.Interpretations.Interpretation_Index_Array);
    74115
     
    101142      overriding procedure On_Expression_Category
    102143        (Self   : in out Visiter;
    103          Kinds  : Gela.Types.Category_Kind_Set;
     144         Match  : not null Gela.Interpretations.Type_Matcher_Access;
    104145         Cursor : Gela.Interpretations.Cursor'Class);
    105146
     
    267308           Self.Comp.Context.Types;
    268309         View : Gela.Types.Type_View_Access;
     310         DT   : Dump_Type.Type_Visitor (Put_Expression'Access);
    269311      begin
    270312         if Tipe /= 0 then
     
    275317            Put_Line ("   Expression NULL");
    276318         else
    277             Put_Line
    278               ("   Expression " &
    279                  Gela.Types.Category_Kinds'Image (View.Category));
     319            View.Visit (DT);
    280320         end if;
    281321
     
    289329      overriding procedure On_Expression_Category
    290330        (Self   : in out Visiter;
    291          Kinds  : Gela.Types.Category_Kind_Set;
     331         Match  : not null Gela.Interpretations.Type_Matcher_Access;
    292332         Down   : Gela.Interpretations.Interpretation_Index_Array)
    293333      is
    294          pragma Unreferenced (Self);
     334         pragma Unreferenced (Self, Match);
    295335      begin
    296336         Put_Line ("   Expression_Category: ");
    297 
    298          for J in Kinds'Range loop
    299             if Kinds (J) then
    300                Put_Line ("      " & Gela.Types.Category_Kinds'Image (J));
    301             end if;
    302          end loop;
    303337
    304338         for J of Down loop
     
    358392           Self.Comp.Context.Types;
    359393         View : Gela.Types.Type_View_Access;
     394         DT   : Dump_Type.Type_Visitor (Put_Expression'Access);
    360395      begin
    361396         if Tipe /= 0 then
     
    366401            Put_Line ("   Expression NULL");
    367402         else
    368             Put_Line
    369               ("   Expression " &
    370                  Gela.Types.Category_Kinds'Image (View.Category));
     403            View.Visit (DT);
    371404         end if;
    372405      end On_Expression;
     
    374407      overriding procedure On_Expression_Category
    375408        (Self   : in out Visiter;
    376          Kinds  : Gela.Types.Category_Kind_Set;
     409         Match  : not null Gela.Interpretations.Type_Matcher_Access;
    377410         Cursor : Gela.Interpretations.Cursor'Class)
    378411      is
    379          pragma Unreferenced (Self, Cursor);
     412         pragma Unreferenced (Self, Cursor, Match);
    380413      begin
    381414         Put_Line ("   Expression_Category: ");
    382 
    383          for J in Kinds'Range loop
    384             if Kinds (J) then
    385                Put_Line ("      " & Gela.Types.Category_Kinds'Image (J));
    386             end if;
    387          end loop;
    388415      end On_Expression_Category;
    389416
     
    426453
    427454   end Dump_Up_Interpretation;
     455
     456   package body Dump_Type is
     457
     458      overriding procedure Enumeration_Type
     459        (Self  : in out Type_Visitor;
     460         Value : not null Gela.Types.Simple.Enumeration_Type_Access)
     461      is
     462      begin
     463         if Value.Is_Character then
     464            Self.Put_Line ("Character");
     465         else
     466            Self.Put_Line ("Enumeration");
     467         end if;
     468      end Enumeration_Type;
     469
     470      overriding procedure Signed_Integer_Type
     471        (Self  : in out Type_Visitor;
     472         Value : not null Gela.Types.Simple.Signed_Integer_Type_Access) is
     473      begin
     474         if Value.Is_Universal then
     475            Self.Put_Line ("Universal_Integer");
     476         else
     477            Self.Put_Line ("Signed_Integer");
     478         end if;
     479      end Signed_Integer_Type;
     480
     481      overriding procedure Floating_Point_Type
     482        (Self  : in out Type_Visitor;
     483         Value : not null Gela.Types.Simple.Floating_Point_Type_Access) is
     484      begin
     485         if Value.Is_Universal then
     486            Self.Put_Line ("Universal_Real");
     487         else
     488            Self.Put_Line ("Floating_Point");
     489         end if;
     490      end Floating_Point_Type;
     491
     492      overriding procedure Array_Type
     493        (Self  : in out Type_Visitor;
     494         Value : not null Gela.Types.Arrays.Array_Type_Access)
     495      is
     496         pragma Unreferenced (Value);
     497      begin
     498         Self.Put_Line ("Array");
     499      end Array_Type;
     500
     501      overriding procedure Untagged_Record
     502        (Self  : in out Type_Visitor;
     503         Value : not null Gela.Types.Untagged_Records
     504         .Untagged_Record_Type_Access)
     505      is
     506         pragma Unreferenced (Value);
     507      begin
     508         Self.Put_Line ("Untagged_Record");
     509      end Untagged_Record;
     510
     511      overriding procedure Object_Access_Type
     512        (Self  : in out Type_Visitor;
     513         Value : not null Gela.Types.Simple.Object_Access_Type_Access)
     514      is
     515         pragma Unreferenced (Value);
     516      begin
     517         Self.Put_Line ("Object_Access");
     518      end Object_Access_Type;
     519
     520      overriding procedure Subprogram_Access_Type
     521        (Self  : in out Type_Visitor;
     522         Value : not null Gela.Types.Simple.Subprogram_Access_Type_Access)
     523      is
     524         pragma Unreferenced (Value);
     525      begin
     526         Self.Put_Line ("Subprogram_Access");
     527      end Subprogram_Access_Type;
     528
     529   end Dump_Type;
    428530
    429531
     
    493595   end Dump;
    494596
     597   --------------------
     598   -- Put_Expression --
     599   --------------------
     600
     601   procedure Put_Expression (Text : String) is
     602   begin
     603      Put_Line ("   Expression " & Text);
     604   end Put_Expression;
     605
    495606   --------------
    496607   -- Put_Line --
  • trunk/ada-2012/src/semantic/gela-derived_type_views.adb

    r421 r423  
    66
    77   function Create_Derived_Type
    8      (Parent   : not null Gela.Types.Type_View_Access;
     8     (Parent   : not null Gela.Type_Categories.Type_View_Access;
    99      Decl     : Gela.Elements.Full_Type_Declarations
    1010                   .Full_Type_Declaration_Access)
    11       return Gela.Types.Type_View_Access
     11      return Gela.Type_Categories.Type_View_Access
    1212   is
    1313      Value : constant Type_View_Access := new Type_View'(Parent, Decl);
    1414   begin
    15       return Gela.Types.Type_View_Access (Value);
     15      return Gela.Type_Categories.Type_View_Access (Value);
    1616   end Create_Derived_Type;
    1717
     
    2121
    2222   overriding function Category
    23      (Self : Type_View) return Gela.Types.Category_Kinds is
     23     (Self : Type_View) return Gela.Type_Categories.Category_Kinds is
    2424   begin
    2525      return Self.Parent.Category;
     
    7272   end Is_Array;
    7373
     74   ------------------
     75   -- Is_Character --
     76   ------------------
     77
     78   overriding function Is_Character (Self : Type_View) return Boolean is
     79   begin
     80      return Self.Parent.Is_Character;
     81   end Is_Character;
     82
    7483   ----------------------
    7584   -- Is_Expected_Type --
     
    8493        .Full_Type_Declaration_Access;
    8594
    86       Expected_Category : constant Gela.Types.Category_Kinds :=
    87         Expected.Category;
    88 
    8995   begin
    9096      if Expected.all in Type_View and then
     
    94100      end if;
    95101
    96       case Expected_Category is
    97          when Gela.Types.An_Universal_Integer =>
    98             return Self.Category in Gela.Types.Any_Integer_Type;
    99          when Gela.Types.An_Universal_Real =>
    100             return Self.Category in Gela.Types.Any_Real_Type;
    101          when others =>
    102             null;
    103       end case;
     102      if Expected.Is_Universal then
     103         if Expected.Is_Integer then
     104            return Self.Category in Gela.Type_Categories.Any_Integer_Type;
     105         elsif Expected.Is_Real then
     106            return Self.Category in Gela.Type_Categories.Any_Real_Type;
     107         end if;
     108      end if;
    104109
    105110      return False;
    106111   end Is_Expected_Type;
     112
     113   -----------------------
     114   -- Is_Floating_Point --
     115   -----------------------
     116
     117   overriding function Is_Floating_Point (Self : Type_View) return Boolean is
     118   begin
     119      return Self.Parent.Is_Floating_Point;
     120   end Is_Floating_Point;
     121
     122   ------------------------
     123   -- Is_Modular_Integer --
     124   ------------------------
     125
     126   overriding function Is_Modular_Integer (Self : Type_View) return Boolean is
     127   begin
     128      return Self.Parent.Is_Modular_Integer;
     129   end Is_Modular_Integer;
     130
     131   ----------------------
     132   -- Is_Object_Access --
     133   ----------------------
     134
     135   overriding function Is_Object_Access (Self : Type_View) return Boolean is
     136   begin
     137      return Self.Parent.Is_Modular_Integer;
     138   end Is_Object_Access;
     139
     140   ---------------
     141   -- Is_Record --
     142   ---------------
     143
     144   overriding function Is_Record (Self : Type_View) return Boolean is
     145   begin
     146      return Self.Parent.Is_Record;
     147   end Is_Record;
     148
     149   -----------------------
     150   -- Is_Signed_Integer --
     151   -----------------------
     152
     153   overriding function Is_Signed_Integer (Self : Type_View) return Boolean is
     154   begin
     155      return Self.Parent.Is_Signed_Integer;
     156   end Is_Signed_Integer;
     157
     158   ------------------
     159   -- Is_Universal --
     160   ------------------
     161
     162   overriding function Is_Universal (Self : Type_View) return Boolean is
     163      pragma Unreferenced (Self);
     164   begin
     165      return False;
     166   end Is_Universal;
    107167
    108168   -----------
  • trunk/ada-2012/src/semantic/gela-derived_type_views.ads

    r422 r423  
    77with Gela.Types.Untagged_Records;
    88with Gela.Types.Visitors;
     9with Gela.Type_Categories;
    910
    1011package Gela.Derived_Type_Views is
    1112   pragma Preelaborate;
    1213
    13    type Type_View is new Gela.Types.Type_View
     14   type Type_View is new Gela.Type_Categories.Type_View
    1415     and Gela.Types.Simple.Enumeration_Type
    1516     and Gela.Types.Simple.Signed_Integer_Type
     
    2324
    2425   function Create_Derived_Type
    25      (Parent   : not null Gela.Types.Type_View_Access;
     26     (Parent   : not null Gela.Type_Categories.Type_View_Access;
    2627      Decl     : Gela.Elements.Full_Type_Declarations
    2728                   .Full_Type_Declaration_Access)
    28       return Gela.Types.Type_View_Access;
     29      return Gela.Type_Categories.Type_View_Access;
    2930
    3031private
    3132
    32    type Type_View is new Gela.Types.Type_View
     33   type Type_View is new Gela.Type_Categories.Type_View
    3334     and Gela.Types.Simple.Enumeration_Type
    3435     and Gela.Types.Simple.Signed_Integer_Type
     
    3940     and Gela.Types.Arrays.Array_Type with
    4041   record
    41       Parent   : not null Gela.Types.Type_View_Access;
     42      Parent   : not null Gela.Type_Categories.Type_View_Access;
    4243      Decl     : Gela.Elements.Full_Type_Declarations
    4344        .Full_Type_Declaration_Access;
     
    4546
    4647   overriding function Category
    47      (Self : Type_View) return Gela.Types.Category_Kinds;
     48     (Self : Type_View) return Gela.Type_Categories.Category_Kinds;
    4849
    4950   overriding function Get_Discriminant
     
    7172   overriding function Is_Array (Self : Type_View) return Boolean;
    7273
     74   overriding function Is_Character (Self : Type_View) return Boolean;
     75
     76   overriding function Is_Floating_Point (Self : Type_View) return Boolean;
     77
     78   overriding function Is_Modular_Integer (Self : Type_View) return Boolean;
     79
     80   overriding function Is_Object_Access (Self : Type_View) return Boolean;
     81
     82   overriding function Is_Record (Self : Type_View) return Boolean;
     83
     84   overriding function Is_Signed_Integer (Self : Type_View) return Boolean;
     85
     86   overriding function Is_Universal (Self : Type_View) return Boolean;
     87
    7388end Gela.Derived_Type_Views;
  • trunk/ada-2012/src/semantic/gela-int-categories.adb

    r421 r423  
    99   function Create
    1010     (Down  : Gela.Interpretations.Interpretation_Index_Array;
    11       Kinds : Gela.Types.Category_Kind_Set)
     11      Match  : not null Gela.Interpretations.Type_Matcher_Access)
    1212      return Category is
    1313   begin
    1414      return (Index  => 0,
    1515              Length => Down'Length,
    16               Kinds  => Kinds,
     16              Match  => Match,
    1717              Down   => Down);
    1818   end Create;
    1919
    2020   -----------
    21    -- Kinds --
     21   -- Match --
    2222   -----------
    2323
    24    function Kinds
     24   function Match
    2525     (Self : Category)
    26       return Gela.Types.Category_Kind_Set is
     26      return not null Gela.Interpretations.Type_Matcher_Access is
    2727   begin
    28       return Self.Kinds;
    29    end Kinds;
     28      return Self.Match;
     29   end Match;
    3030
    3131   -----------
  • trunk/ada-2012/src/semantic/gela-int-categories.ads

    r421 r423  
    1 with Gela.Types;
    2 
    31package Gela.Int.Categories is
    42   pragma Preelaborate;
     
    86   function Create
    97     (Down  : Gela.Interpretations.Interpretation_Index_Array;
    10       Kinds : Gela.Types.Category_Kind_Set)
     8      Match  : not null Gela.Interpretations.Type_Matcher_Access)
    119      return Category;
    1210
    13    function Kinds
     11   function Match
    1412     (Self : Category)
    15       return Gela.Types.Category_Kind_Set;
     13      return not null Gela.Interpretations.Type_Matcher_Access;
    1614
    1715private
    1816
    1917   type Category is new Interpretation with record
    20       Kinds : Gela.Types.Category_Kind_Set;
     18      Match  : not null Gela.Interpretations.Type_Matcher_Access;
    2119   end record;
    2220
  • trunk/ada-2012/src/semantic/gela-plain_interpretations.adb

    r421 r423  
    107107   overriding procedure Add_Expression_Category
    108108     (Self   : in out Interpretation_Manager;
    109       Kinds  : Gela.Types.Category_Kind_Set;
     109      Match  : not null Gela.Interpretations.Type_Matcher_Access;
    110110      Down   : Gela.Interpretations.Interpretation_Index_Array;
    111111      Result : in out Gela.Interpretations.Interpretation_Set_Index)
     
    115115          (Gela.Int.Categories.Create
    116116             (Down  => Down,
    117               Kinds => Kinds));
     117              Match => Match));
    118118   begin
    119119      Self.Plian_Int_Set.Add (Result, Item);
     
    477477         begin
    478478            Target.On_Expression_Category
    479               (Kinds => Value.Kinds,
     479              (Match => Value.Match,
    480480               Down  => Value.Down);
    481481         end Expression_Category;
  • trunk/ada-2012/src/semantic/gela-plain_interpretations.ads

    r421 r423  
    1010with Gela.Plian_Int_Sets;
    1111with Gela.Semantic_Types;
    12 with Gela.Types;
    1312
    1413package Gela.Plain_Interpretations is
     
    7069   overriding procedure Add_Expression_Category
    7170     (Self   : in out Interpretation_Manager;
    72       Kinds  : Gela.Types.Category_Kind_Set;
     71      Match  : not null Gela.Interpretations.Type_Matcher_Access;
    7372      Down   : Gela.Interpretations.Interpretation_Index_Array;
    7473      Result : in out Gela.Interpretations.Interpretation_Set_Index);
  • trunk/ada-2012/src/semantic/gela-plain_type_managers.adb

    r421 r423  
    4444   not overriding function Get
    4545     (Self     : access Type_Manager;
    46       Category : Gela.Types.Category_Kinds;
     46      Category : Gela.Type_Categories.Category_Kinds;
    4747      Decl     : Gela.Elements.Full_Type_Declarations
    4848      .Full_Type_Declaration_Access)
     
    8383         return null;
    8484      else
    85          return Self.Map.Element (Index);
     85         return Gela.Types.Type_View_Access (Self.Map.Element (Index));
    8686      end if;
    8787   end Get;
     
    9393   not overriding function Get_Derived
    9494     (Self     : access Type_Manager;
    95       Parent   : Gela.Types.Type_View_Access;
     95      Parent   : Gela.Type_Categories.Type_View_Access;
    9696      Decl     : Gela.Elements.Full_Type_Declarations
    9797      .Full_Type_Declaration_Access)
     
    150150      use type Ada.Containers.Hash_Type;
    151151   begin
    152       return Key.Decl.Hash + Gela.Types.Category_Kinds'Pos (Key.Category);
     152      return Key.Decl.Hash
     153        + Gela.Type_Categories.Category_Kinds'Pos (Key.Category);
    153154   end Hash;
    154155
     
    185186   is
    186187      procedure Create
    187         (Category : Gela.Types.Category_Kinds;
     188        (Category : Gela.Type_Categories.Category_Kinds;
    188189         Index    : Gela.Semantic_Types.Type_Index);
    189190
     
    194195
    195196      procedure Create
    196         (Category : Gela.Types.Category_Kinds;
     197        (Category : Gela.Type_Categories.Category_Kinds;
    197198         Index    : Gela.Semantic_Types.Type_Index)
    198199      is
     
    223224      end Create;
    224225
    225    begin
    226       Create (Gela.Types.An_Universal_Access, Universal_Access_Index);
    227       Create (Gela.Types.An_Universal_Integer, Universal_Integer_Index);
    228       Create (Gela.Types.An_Universal_Real, Universal_Real_Index);
     226      use Gela.Type_Categories;
     227   begin
     228      Create (An_Universal_Access, Universal_Access_Index);
     229      Create (An_Universal_Integer, Universal_Integer_Index);
     230      Create (An_Universal_Real, Universal_Real_Index);
    229231   end Initialize;
    230232
     
    365367         begin
    366368            Self.Result := Type_From_Declaration.Self.Get
    367               (Category => Gela.Types.A_Variable_Access,
     369              (Category => Gela.Type_Categories.A_Variable_Access,
    368370               Decl     => Gela.Elements.Full_Type_Declarations.
    369371                 Full_Type_Declaration_Access (Node.Enclosing_Element));
     
    384386              Type_From_Declaration.Self.Type_From_Subtype_Mark
    385387                (Env, Subtype_Mark);
    386             Type_View : Gela.Types.Type_View_Access;
     388            Type_View : Gela.Type_Categories.Type_View_Access;
    387389         begin
    388390            if Tipe /= 0 then
    389                Type_View := Type_From_Declaration.Self.Get (Tipe);
     391               Type_View := Gela.Type_Categories.Type_View_Access
     392                 (Type_From_Declaration.Self.Get (Tipe));
    390393
    391394               Self.Result := Type_From_Declaration.Self.Get_Derived
     
    421424            if V.Found then
    422425               Self.Result := Type_From_Declaration.Self.Get
    423                  (Category => Gela.Types.A_Character,
     426                 (Category => Gela.Type_Categories.A_Character,
    424427                  Decl     => Gela.Elements.Full_Type_Declarations.
    425428                    Full_Type_Declaration_Access (Node.Enclosing_Element));
    426429            else
    427430               Self.Result := Type_From_Declaration.Self.Get
    428                  (Category => Gela.Types.An_Other_Enum,
     431                 (Category => Gela.Type_Categories.An_Other_Enum,
    429432                  Decl     => Gela.Elements.Full_Type_Declarations.
    430433                    Full_Type_Declaration_Access (Node.Enclosing_Element));
     
    438441         begin
    439442            Self.Result := Type_From_Declaration.Self.Get
    440               (Category => Gela.Types.A_Float_Point,
     443              (Category => Gela.Type_Categories.A_Float_Point,
    441444               Decl     => Gela.Elements.Full_Type_Declarations.
    442445                 Full_Type_Declaration_Access (Node.Enclosing_Element));
     
    468471         begin
    469472            Self.Result := Type_From_Declaration.Self.Get
    470               (Category => Gela.Types.A_Untagged_Record,
     473              (Category => Gela.Type_Categories.A_Untagged_Record,
    471474               Decl     => Gela.Elements.Full_Type_Declarations.
    472475                 Full_Type_Declaration_Access (Node.Enclosing_Element));
     
    491494         begin
    492495            Self.Result := Type_From_Declaration.Self.Get
    493               (Category => Gela.Types.A_Signed_Integer,
     496              (Category => Gela.Type_Categories.A_Signed_Integer,
    494497               Decl     => Gela.Elements.Full_Type_Declarations.
    495498                 Full_Type_Declaration_Access (Node.Enclosing_Element));
     
    515518              Unconstrained_Array_Definition_Access)
    516519         is
    517             use type Gela.Types.Category_Kinds;
     520            use type Gela.Type_Categories.Category_Kinds;
    518521
    519522            Component : constant Gela.Elements.Component_Definitions.
     
    528531         begin
    529532            if Component_Type_View.Assigned and then
    530               Component_Type_View.Category = Gela.Types.A_Character
     533              Component_Type_View.Is_Character
    531534            then
    532535               Self.Result := Type_From_Declaration.Self.Get
    533                  (Category => Gela.Types.A_String,
     536                 (Category => Gela.Type_Categories.A_String,
    534537                  Decl     => Gela.Elements.Full_Type_Declarations.
    535538                    Full_Type_Declaration_Access (Node.Enclosing_Element));
    536539            else
    537540               Self.Result := Type_From_Declaration.Self.Get
    538                  (Category => Gela.Types.An_Other_Array,
     541                 (Category => Gela.Type_Categories.An_Other_Array,
    539542                  Decl     => Gela.Elements.Full_Type_Declarations.
    540543                    Full_Type_Declaration_Access (Node.Enclosing_Element));
  • trunk/ada-2012/src/semantic/gela-plain_type_managers.ads

    r421 r423  
    1313with Gela.Type_Managers;
    1414with Gela.Types;
     15with Gela.Type_Categories;
    1516
    1617package Gela.Plain_Type_Managers is
     
    3031   package Type_View_Maps is new Ada.Containers.Ordered_Maps
    3132        (Key_Type     => Gela.Semantic_Types.Type_Index,
    32          Element_Type => Gela.Types.Type_View_Access,
     33         Element_Type => Gela.Type_Categories.Type_View_Access,
    3334         "<"          => Gela.Semantic_Types."<",
    34          "="          => Gela.Types."=");
     35         "="          => Gela.Type_Categories."=");
    3536
    3637   type Back_Key is record
    37       Category : Gela.Types.Category_Kinds;
     38      Category : Gela.Type_Categories.Category_Kinds;
    3839      Decl     : Gela.Elements.Full_Type_Declarations
    3940        .Full_Type_Declaration_Access;
     
    8586   not overriding function Get
    8687     (Self     : access Type_Manager;
    87       Category : Gela.Types.Category_Kinds;
     88      Category : Gela.Type_Categories.Category_Kinds;
    8889      Decl     : Gela.Elements.Full_Type_Declarations
    8990      .Full_Type_Declaration_Access)
     
    9293   not overriding function Get_Derived
    9394     (Self     : access Type_Manager;
    94       Parent   : Gela.Types.Type_View_Access;
     95      Parent   : Gela.Type_Categories.Type_View_Access;
    9596      Decl     : Gela.Elements.Full_Type_Declarations
    9697      .Full_Type_Declaration_Access)
    97         return Gela.Semantic_Types.Type_Index;
     98      return Gela.Semantic_Types.Type_Index;
    9899
    99100   overriding function Get
  • trunk/ada-2012/src/semantic/gela-plain_type_views.adb

    r422 r423  
    2121
    2222   overriding function Category
    23      (Self : Type_View)
    24       return Gela.Types.Category_Kinds
     23     (Self : Type_View) return Gela.Type_Categories.Category_Kinds
    2524   is
    2625   begin
     
    3332
    3433   function Create_Full_Type
    35      (Category : Gela.Types.Category_Kinds;
     34     (Category : Gela.Type_Categories.Category_Kinds;
    3635      Decl     : Gela.Elements.Full_Type_Declarations
    37       .Full_Type_Declaration_Access)
    38       return Gela.Types.Type_View_Access
     36                   .Full_Type_Declaration_Access)
     37      return Gela.Type_Categories.Type_View_Access
    3938   is
    4039      Value : constant Type_View_Access :=
    4140        new Type_View'(Category => Category, Decl => Decl);
    4241   begin
    43       return Gela.Types.Type_View_Access (Value);
     42      return Gela.Type_Categories.Type_View_Access (Value);
    4443   end Create_Full_Type;
    4544
     
    297296   overriding function Is_Array (Self : Type_View) return Boolean is
    298297   begin
    299       return Self.Category in Gela.Types.A_String | Gela.Types.An_Other_Array;
     298      return Self.Category in Gela.Type_Categories.A_String
     299        | Gela.Type_Categories.An_Other_Array;
    300300   end Is_Array;
     301
     302   ------------------
     303   -- Is_Character --
     304   ------------------
     305
     306   overriding function Is_Character (Self : Type_View) return Boolean is
     307   begin
     308      return Self.Category in Gela.Type_Categories.A_Character;
     309   end Is_Character;
    301310
    302311   ----------------------
     
    311320        .Full_Type_Declaration_Access;
    312321
    313       Expected_Category : constant Gela.Types.Category_Kinds :=
    314         Expected.Category;
     322      package Visitors is
     323         type Type_Visitor is new Gela.Types.Visitors.Type_Visitor with record
     324            Match_Integer : Boolean := False;
     325            Match_Real    : Boolean := False;
     326         end record;
     327
     328         overriding procedure Signed_Integer_Type
     329           (Self  : in out Type_Visitor;
     330            Value : not null Gela.Types.Simple.Signed_Integer_Type_Access);
     331
     332         overriding procedure Floating_Point_Type
     333           (Self  : in out Type_Visitor;
     334            Value : not null Gela.Types.Simple.Floating_Point_Type_Access);
     335
     336      end Visitors;
     337
     338      package body Visitors is
     339
     340         overriding procedure Signed_Integer_Type
     341           (Self  : in out Type_Visitor;
     342            Value : not null Gela.Types.Simple.Signed_Integer_Type_Access)
     343         is
     344            pragma Unreferenced (Value);
     345         begin
     346            Self.Match_Integer := True;
     347         end Signed_Integer_Type;
     348
     349         overriding procedure Floating_Point_Type
     350           (Self  : in out Type_Visitor;
     351            Value : not null Gela.Types.Simple.Floating_Point_Type_Access)
     352         is
     353            pragma Unreferenced (Value);
     354         begin
     355            Self.Match_Real := True;
     356         end Floating_Point_Type;
     357
     358      end Visitors;
     359
     360      Matcher : Visitors.Type_Visitor;
    315361   begin
    316362      if Expected.all in Type_View and then
     
    320366      end if;
    321367
    322       case Expected_Category is
    323          when Gela.Types.An_Universal_Integer =>
    324             return Self.Category in Gela.Types.Any_Integer_Type;
    325          when Gela.Types.An_Universal_Real =>
    326             return Self.Category in Gela.Types.Any_Real_Type;
     368      if Expected.Is_Universal then
     369         Expected.Visit (Matcher);
     370
     371         if Matcher.Match_Integer then
     372            return Self.Category in Gela.Type_Categories.Any_Integer_Type;
     373         elsif Matcher.Match_Real then
     374            return Self.Category in Gela.Type_Categories.Any_Real_Type;
     375         end if;
     376      end if;
     377
     378      case Self.Category is
     379         when Gela.Type_Categories.An_Universal_Integer =>
     380            Expected.Visit (Matcher);
     381            return Matcher.Match_Integer;
     382         when Gela.Type_Categories.An_Universal_Real =>
     383            Expected.Visit (Matcher);
     384            return Matcher.Match_Real;
    327385         when others =>
    328386            null;
    329387      end case;
    330388
    331       case Self.Category is
    332          when Gela.Types.An_Universal_Integer =>
    333             return Expected_Category in Gela.Types.Any_Integer_Type;
    334          when Gela.Types.An_Universal_Real =>
    335             return Expected_Category in Gela.Types.Any_Real_Type;
    336          when others =>
    337             null;
    338       end case;
    339 
    340389      return False;
    341390   end Is_Expected_Type;
     391
     392   -----------------------
     393   -- Is_Floating_Point --
     394   -----------------------
     395
     396   overriding function Is_Floating_Point (Self : Type_View) return Boolean is
     397   begin
     398      return Self.Category in Gela.Type_Categories.A_Float_Point
     399        | Gela.Type_Categories.An_Universal_Real;
     400   end Is_Floating_Point;
     401
     402   ------------------------
     403   -- Is_Modular_Integer --
     404   ------------------------
     405
     406   overriding function Is_Modular_Integer (Self : Type_View) return Boolean is
     407   begin
     408      return Self.Category in Gela.Type_Categories.A_Modular_Integer
     409        | Gela.Type_Categories.An_Universal_Integer;
     410   end Is_Modular_Integer;
     411
     412   ----------------------
     413   -- Is_Object_Access --
     414   ----------------------
     415
     416   overriding function Is_Object_Access (Self : Type_View) return Boolean is
     417   begin
     418      return Self.Category in Gela.Type_Categories.A_Constant_Access
     419        | Gela.Type_Categories.A_Variable_Access;
     420   end Is_Object_Access;
     421
     422   ---------------
     423   -- Is_Record --
     424   ---------------
     425
     426   overriding function Is_Record (Self : Type_View) return Boolean is
     427   begin
     428      return Self.Category in Gela.Type_Categories.A_Untagged_Record
     429       | Gela.Type_Categories.A_Tagged;
     430   end Is_Record;
     431
     432   -----------------------
     433   -- Is_Signed_Integer --
     434   -----------------------
     435
     436   overriding function Is_Signed_Integer (Self : Type_View) return Boolean is
     437   begin
     438      return Self.Category in Gela.Type_Categories.A_Signed_Integer
     439        | Gela.Type_Categories.An_Universal_Integer;
     440   end Is_Signed_Integer;
     441
     442   ------------------
     443   -- Is_Universal --
     444   ------------------
     445
     446   overriding function Is_Universal (Self : Type_View) return Boolean is
     447   begin
     448      return Self.Category in Gela.Type_Categories.An_Universal_Integer
     449        | Gela.Type_Categories.An_Universal_Real
     450        | Gela.Type_Categories.An_Universal_Fixed
     451        | Gela.Type_Categories.An_Universal_Access;
     452   end Is_Universal;
    342453
    343454   -----------
     
    350461   begin
    351462      case Self.Category is
    352          when Gela.Types.A_Character |
    353               Gela.Types.A_Boolean |
    354               Gela.Types.An_Other_Enum =>
     463         when Gela.Type_Categories.A_Character |
     464              Gela.Type_Categories.A_Boolean |
     465              Gela.Type_Categories.An_Other_Enum =>
    355466
    356467            Visiter.Enumeration_Type
    357468              (Gela.Types.Simple.Enumeration_Type_Access (Self));
    358          when Gela.Types.A_Signed_Integer =>
     469         when Gela.Type_Categories.A_Signed_Integer |
     470              Gela.Type_Categories.An_Universal_Integer =>
    359471            Visiter.Signed_Integer_Type
    360472              (Gela.Types.Simple.Signed_Integer_Type_Access (Self));
    361          when Gela.Types.A_Float_Point =>
     473         when Gela.Type_Categories.A_Float_Point |
     474              Gela.Type_Categories.An_Universal_Real =>
    362475            Visiter.Floating_Point_Type
    363476              (Gela.Types.Simple.Floating_Point_Type_Access (Self));
    364          when Gela.Types.A_String | Gela.Types.An_Other_Array =>
     477         when Gela.Type_Categories.A_String |
     478              Gela.Type_Categories.An_Other_Array =>
    365479            Visiter.Array_Type
    366480              (Gela.Types.Arrays.Array_Type_Access (Self));
    367          when Gela.Types.A_Untagged_Record =>
     481         when Gela.Type_Categories.A_Untagged_Record =>
    368482            Visiter.Untagged_Record
    369483              (Gela.Types.Untagged_Records.Untagged_Record_Type_Access (Self));
    370          when Gela.Types.A_Constant_Access |
    371               Gela.Types.A_Variable_Access =>
     484         when Gela.Type_Categories.A_Constant_Access |
     485              Gela.Type_Categories.A_Variable_Access =>
    372486            Visiter.Object_Access_Type
    373487              (Gela.Types.Simple.Object_Access_Type_Access (Self));
  • trunk/ada-2012/src/semantic/gela-plain_type_views.ads

    r422 r423  
    77with Gela.Types.Untagged_Records;
    88with Gela.Types.Visitors;
     9with Gela.Type_Categories;
    910
    1011package Gela.Plain_Type_Views is
    1112   pragma Preelaborate;
    1213
    13    type Type_View is new Gela.Types.Type_View
     14   type Type_View is new Gela.Type_Categories.Type_View
    1415     and Gela.Types.Simple.Enumeration_Type
    1516     and Gela.Types.Simple.Signed_Integer_Type
     
    2324
    2425   function Create_Full_Type
    25      (Category : Gela.Types.Category_Kinds;
     26     (Category : Gela.Type_Categories.Category_Kinds;
    2627      Decl     : Gela.Elements.Full_Type_Declarations
    2728                   .Full_Type_Declaration_Access)
    28       return Gela.Types.Type_View_Access;
     29      return Gela.Type_Categories.Type_View_Access;
    2930
    3031private
    3132
    32    type Type_View is new Gela.Types.Type_View
     33   type Type_View is new Gela.Type_Categories.Type_View
    3334     and Gela.Types.Simple.Enumeration_Type
    3435     and Gela.Types.Simple.Signed_Integer_Type
     
    3940     and Gela.Types.Arrays.Array_Type with
    4041   record
    41       Category : Gela.Types.Category_Kinds;
     42      Category : Gela.Type_Categories.Category_Kinds;
    4243      Decl     : Gela.Elements.Full_Type_Declarations
    4344        .Full_Type_Declaration_Access;
     
    4546
    4647   overriding function Category
    47      (Self : Type_View) return Gela.Types.Category_Kinds;
     48     (Self : Type_View) return Gela.Type_Categories.Category_Kinds;
    4849
    4950   overriding function Get_Discriminant
     
    7172   overriding function Is_Array (Self : Type_View) return Boolean;
    7273
     74   overriding function Is_Character (Self : Type_View) return Boolean;
     75
     76   overriding function Is_Floating_Point (Self : Type_View) return Boolean;
     77
     78   overriding function Is_Modular_Integer (Self : Type_View) return Boolean;
     79
     80   overriding function Is_Object_Access (Self : Type_View) return Boolean;
     81
     82   overriding function Is_Record (Self : Type_View) return Boolean;
     83
     84   overriding function Is_Signed_Integer (Self : Type_View) return Boolean;
     85
     86   overriding function Is_Universal (Self : Type_View) return Boolean;
     87
    7388end Gela.Plain_Type_Views;
  • trunk/ada-2012/src/semantic/gela-plian_int_sets.adb

    r415 r423  
    277277         begin
    278278            Target.On_Expression_Category
    279               (Kinds  => Value.Kinds,
     279              (Match  => Value.Match,
    280280               Cursor => Visit.Self);
    281281         end Expression_Category;
  • trunk/ada-2012/src/semantic/gela-resolve.adb

    r421 r423  
    99with Gela.Profiles;
    1010with Gela.Type_Managers;
     11with Gela.Types.Arrays;
     12with Gela.Types.Simple;
    1113
    1214package body Gela.Resolve is
     15
     16   procedure To_Type_Category
     17     (Comp     : Gela.Compilations.Compilation_Access;
     18      Up       : Gela.Interpretations.Interpretation_Set_Index;
     19      Tipe     : Gela.Semantic_Types.Type_Index;
     20      Result   : out Gela.Interpretations.Interpretation_Index);
     21   --  Fetch Type_Category interpretation from Up that match given Tipe.
    1322
    1423   procedure Get_Subtype
     
    5261   --  resolve. Read resolved value from Found. Wrap each resolved value in
    5362   --  down interpretation, then return its index as Chosen
     63
     64   package String_Type_Matcher is
     65      type Type_Matcher is new Gela.Interpretations.Type_Matcher with record
     66         Match : Boolean := False;
     67      end record;
     68
     69      type Type_Matcher_Access is access all Type_Matcher'Class;
     70
     71      overriding procedure Array_Type
     72        (Self  : in out Type_Matcher;
     73         Value : not null Gela.Types.Arrays.Array_Type_Access);
     74
     75      overriding function Is_Matched
     76        (Self : Type_Matcher) return Boolean;
     77   end String_Type_Matcher;
     78
     79   package body String_Type_Matcher is
     80
     81      overriding procedure Array_Type
     82        (Self  : in out Type_Matcher;
     83         Value : not null Gela.Types.Arrays.Array_Type_Access)
     84      is
     85         pragma Unreferenced (Value);
     86      begin
     87         Self.Match := True;  --  Value.Is_String;  FIXME
     88      end Array_Type;
     89
     90      overriding function Is_Matched
     91        (Self : Type_Matcher) return Boolean is
     92      begin
     93         return Self.Match;
     94      end Is_Matched;
     95
     96   end String_Type_Matcher;
     97
     98   package Integer_Type_Matcher is
     99      type Type_Matcher is new Gela.Interpretations.Type_Matcher with record
     100         Match : Boolean := False;
     101      end record;
     102
     103      type Type_Matcher_Access is access all Type_Matcher'Class;
     104
     105      overriding procedure Signed_Integer_Type
     106        (Self  : in out Type_Matcher;
     107         Value : not null Gela.Types.Simple.Signed_Integer_Type_Access);
     108
     109      overriding function Is_Matched
     110        (Self : Type_Matcher) return Boolean;
     111   end Integer_Type_Matcher;
     112
     113   package body Integer_Type_Matcher is
     114
     115      overriding procedure Signed_Integer_Type
     116        (Self  : in out Type_Matcher;
     117         Value : not null Gela.Types.Simple.Signed_Integer_Type_Access)
     118      is
     119         pragma Unreferenced (Value);
     120      begin
     121         Self.Match := True;
     122      end Signed_Integer_Type;
     123
     124      overriding function Is_Matched
     125        (Self : Type_Matcher) return Boolean is
     126      begin
     127         return Self.Match;
     128      end Is_Matched;
     129
     130   end Integer_Type_Matcher;
     131
     132   package Float_Type_Matcher is
     133      type Type_Matcher is new Gela.Interpretations.Type_Matcher with record
     134         Match : Boolean := False;
     135      end record;
     136
     137      type Type_Matcher_Access is access all Type_Matcher'Class;
     138
     139      overriding procedure Floating_Point_Type
     140        (Self  : in out Type_Matcher;
     141         Value : not null Gela.Types.Simple.Floating_Point_Type_Access);
     142
     143      overriding function Is_Matched
     144        (Self : Type_Matcher) return Boolean;
     145   end Float_Type_Matcher;
     146
     147   package body Float_Type_Matcher is
     148
     149      overriding procedure Floating_Point_Type
     150        (Self  : in out Type_Matcher;
     151         Value : not null Gela.Types.Simple.Floating_Point_Type_Access)
     152      is
     153         pragma Unreferenced (Value);
     154      begin
     155         Self.Match := True;
     156      end Floating_Point_Type;
     157
     158      overriding function Is_Matched
     159        (Self : Type_Matcher) return Boolean is
     160      begin
     161         return Self.Match;
     162      end Is_Matched;
     163
     164   end Float_Type_Matcher;
     165
    54166
    55167   ----------------------
     
    706818            Target.On_Expression (Tipe, Cursor);
    707819
    708             if View.Assigned and then View.Category in
    709                 Gela.Types.A_Variable_Access |
    710                 Gela.Types.A_Constant_Access
    711             then
     820            if View.Assigned and then View.Is_Object_Access then
    712821               declare
    713822                  SI : constant Gela.Elements.Subtype_Indications
     
    10771186     (Comp     : Gela.Compilations.Compilation_Access;
    10781187      Up       : Gela.Interpretations.Interpretation_Set_Index;
    1079       Result   : out Gela.Interpretations.Interpretation_Index) is
    1080    begin
    1081       To_Type_Category (Comp, Up, Gela.Types.A_Float_Point, Result);
     1188      Result   : out Gela.Interpretations.Interpretation_Index)
     1189   is
     1190      TM : constant Gela.Type_Managers.Type_Manager_Access :=
     1191        Comp.Context.Types;
     1192   begin
     1193      To_Type_Category (Comp, Up, TM.Universal_Real, Result);
    10821194   end Real_Type;
    10831195
     
    12301342     (Comp     : Gela.Compilations.Compilation_Access;
    12311343      Up       : Gela.Interpretations.Interpretation_Set_Index;
    1232       Result   : out Gela.Interpretations.Interpretation_Index) is
    1233    begin
    1234       To_Type_Category (Comp, Up, Gela.Types.A_Signed_Integer, Result);
     1344      Result   : out Gela.Interpretations.Interpretation_Index)
     1345   is
     1346      TM : constant Gela.Type_Managers.Type_Manager_Access :=
     1347        Comp.Context.Types;
     1348   begin
     1349      To_Type_Category (Comp, Up, TM.Universal_Integer, Result);
    12351350   end Signed_Integer_Type;
    12361351
     
    13201435                  if not Type_View.Assigned then
    13211436                     return;
    1322                   elsif Type_View.Category in
    1323                     Gela.Types.Any_Integer_Type
    1324                   then
     1437                  elsif Type_View.Is_Integer then
    13251438                     Increment (Self.Counters, Cursor.Get_Index, Integer);
    1326                   elsif Type_View.Category in
    1327                     Gela.Types.Any_Real_Type
    1328                   then
     1439                  elsif Type_View.Is_Real then
    13291440                     Increment (Self.Counters, Cursor.Get_Index, Float);
    13301441                  else  --  FIXME Return after implementation of types
     
    13331444
    13341445                  if Type_View.Is_Expected_Type (Self.Type_View) then
    1335                      if Type_View.Category in
    1336                            Gela.Types.An_Universal_Integer |
    1337                            Gela.Types.An_Universal_Real |
    1338                            Gela.Types.An_Universal_Fixed
     1446                     if Type_View.Is_Universal
     1447                       and then Type_View.Is_Numeric
    13391448                     then
    13401449                        Chosen := Self.Tipe;
     
    13651474               Target => Visiter_Right);
    13661475
    1367             if Visiter_Right.Type_View.Category in
    1368                  Gela.Types.Any_Integer_Type
    1369             then
     1476            if Visiter_Right.Type_View.Is_Integer then
    13701477               Increment
    13711478                 (Self.Counters,
     
    13731480                  Visiter_Right.Counters,
    13741481                  Integer);
    1375             elsif Visiter_Right.Type_View.Category in
    1376               Gela.Types.Any_Real_Type
    1377             then
     1482            elsif Visiter_Right.Type_View.Is_Real then
    13781483               Increment
    13791484                 (Self.Counters,
     
    14211526      L_Val : Counter_By_Type renames Visiter.Counters (Left_Side);
    14221527      R_Val : Counter_By_Type renames Visiter.Counters (Right_Side);
     1528
     1529      Int_Matcher   : Integer_Type_Matcher.Type_Matcher_Access;
     1530      Float_Matcher : Float_Type_Matcher.Type_Matcher_Access;
    14231531   begin
    14241532      Set := 0;
     
    14301538
    14311539      if L_Val (Integer).Count = 1 and R_Val (Integer).Count = 1 then
     1540         Int_Matcher := new Integer_Type_Matcher.Type_Matcher;
     1541
    14321542         Comp.Context.Interpretation_Manager.Add_Expression_Category
    1433            (Kinds  =>
    1434               (Gela.Types.A_Signed_Integer => True, others => False),
     1543           (Match  => Gela.Interpretations.Type_Matcher_Access (Int_Matcher),
    14351544            Down   => (L_Val (Integer).Index, R_Val (Integer).Index),
    14361545            Result => Set);
     
    14381547
    14391548      if L_Val (Float).Count = 1 and R_Val (Float).Count = 1 then
     1549         Float_Matcher := new Float_Type_Matcher.Type_Matcher;
     1550
    14401551         Comp.Context.Interpretation_Manager.Add_Expression_Category
    1441            (Kinds  =>
    1442               (Gela.Types.A_Float_Point => True, others => False),
     1552           (Match  => Gela.Interpretations.Type_Matcher_Access (Float_Matcher),
    14431553            Down   => (L_Val (Float).Index, R_Val (Float).Index),
    14441554            Result => Set);
     
    14561566   is
    14571567      pragma Unreferenced (Token);
     1568      Matcher : constant String_Type_Matcher.Type_Matcher_Access :=
     1569        new String_Type_Matcher.Type_Matcher;
    14581570   begin
    14591571      Result := 0;
    14601572
    14611573      Comp.Context.Interpretation_Manager.Add_Expression_Category
    1462         (Kinds  =>
    1463            (Gela.Types.A_String => True, others => False),
     1574        (Match => Gela.Interpretations.Type_Matcher_Access (Matcher),
    14641575         Down   => (1 .. 0 => 0),
    14651576         Result => Result);
     
    15831694         overriding procedure On_Expression_Category
    15841695           (Self   : in out Visiter;
    1585             Kinds  : Gela.Types.Category_Kind_Set;
     1696            Match  : not null Gela.Interpretations.Type_Matcher_Access;
    15861697            Cursor : Gela.Interpretations.Cursor'Class);
    15871698
     
    16621773         overriding procedure On_Expression_Category
    16631774           (Self   : in out Visiter;
    1664             Kinds  : Gela.Types.Category_Kind_Set;
     1775            Match  : not null Gela.Interpretations.Type_Matcher_Access;
    16651776            Cursor : Gela.Interpretations.Cursor'Class) is
    16661777         begin
    1667             if Kinds (View.Category) then
     1778            View.Visit (Match.all);
     1779
     1780            if Match.Is_Matched then
    16681781               Self.Index := Cursor.Get_Index;
    16691782            end if;
     
    16791792            Chosen : Gela.Interpretations.Interpretation_Index;
    16801793         begin
    1681             if View /= null and then
    1682               View.Category in Gela.Types.A_Untagged_Record
    1683             then
     1794            if View /= null and then View.Is_Record then
    16841795               Wrap_Tuple
    16851796                 (Self   => V'Access,
     
    17731884     (Comp     : Gela.Compilations.Compilation_Access;
    17741885      Up       : Gela.Interpretations.Interpretation_Set_Index;
    1775       Category : Gela.Types.Category_Kinds;
     1886      Tipe     : Gela.Semantic_Types.Type_Index;
    17761887      Result   : out Gela.Interpretations.Interpretation_Index)
    17771888   is
     
    17821893         overriding procedure On_Expression_Category
    17831894           (Self   : in out Visiter;
    1784             Kinds  : Gela.Types.Category_Kind_Set;
     1895            Match  : not null Gela.Interpretations.Type_Matcher_Access;
    17851896            Cursor : Gela.Interpretations.Cursor'Class);
    17861897
    17871898      end Each;
     1899
     1900      TM : constant Gela.Type_Managers.Type_Manager_Access :=
     1901        Comp.Context.Types;
     1902
     1903      View : constant Gela.Types.Type_View_Access := TM.Get (Tipe);
    17881904
    17891905      ----------
     
    17951911         overriding procedure On_Expression_Category
    17961912           (Self   : in out Visiter;
    1797             Kinds  : Gela.Types.Category_Kind_Set;
     1913            Match  : not null Gela.Interpretations.Type_Matcher_Access;
    17981914            Cursor : Gela.Interpretations.Cursor'Class)
    17991915         is
    18001916            pragma Unreferenced (Self);
    18011917         begin
    1802             if Kinds (Category) then
     1918            View.Visit (Match.all);
     1919
     1920            if Match.Is_Matched then
    18031921               Result := Cursor.Get_Index;
    18041922            end if;
  • trunk/ada-2012/src/semantic/gela-resolve.ads

    r421 r423  
    44with Gela.Lexical_Types;
    55with Gela.Semantic_Types;
    6 with Gela.Types;
    76
    87package Gela.Resolve is
     
    144143      Result   : out Gela.Interpretations.Interpretation_Index);
    145144
    146    procedure To_Type_Category
    147      (Comp     : Gela.Compilations.Compilation_Access;
    148       Up       : Gela.Interpretations.Interpretation_Set_Index;
    149       Category : Gela.Types.Category_Kinds;
    150       Result   : out Gela.Interpretations.Interpretation_Index);
    151 
    152145end Gela.Resolve;
Note: See TracChangeset for help on using the changeset viewer.