Changeset 511


Ignore:
Timestamp:
Jul 27, 2017, 9:37:45 AM (5 years ago)
Author:
Maxim Reznik
Message:

Drop Cursor and Visiter for up interpretation set.

Replace it with Any_Cursor and iterator.

Location:
trunk/ada-2012/src
Files:
10 edited

Legend:

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

    r509 r511  
    196196   --  For interpretation with given persistent Index apply Target visiter
    197197
    198    type Cursor is limited interface;
    199    type Up_Visiter is tagged;
    200 
    201    not overriding function Has_Element
    202      (Self : Cursor) return Boolean is abstract;
    203    --  Check if cursor points to an interpretation
    204 
    205    not overriding procedure Next (Self : in out Cursor) is abstract;
    206    --  Go to next interpretation in set under cursor
    207 
    208    not overriding procedure Visit
    209      (Self   : Cursor;
    210       Target : access Up_Visiter'Class) is abstract;
    211    --  For current interpretation for cursor apply Target visiter
    212 
    213    not overriding function Get_Index
    214      (Self : Cursor) return Gela.Interpretations.Interpretation_Index
    215         is abstract;
    216    --  Request persistent index for current interpretation
    217 
    218    type Up_Visiter is limited interface;
    219 
    220    not overriding procedure On_Defining_Name
    221      (Self   : in out Up_Visiter;
    222       Name   : Gela.Elements.Defining_Names.Defining_Name_Access;
    223       Cursor : Gela.Interpretations.Cursor'Class) is null;
    224    --  Called for each defining name interpretation
    225 
    226    not overriding procedure On_Expression
    227      (Self   : in out Up_Visiter;
    228       Tipe   : Gela.Semantic_Types.Type_Index;
    229       Cursor : Gela.Interpretations.Cursor'Class) is null;
    230    --  Called for each expression interpretation
    231 
    232    not overriding procedure On_Expression_Category
    233      (Self   : in out Up_Visiter;
    234       Match  : not null Gela.Interpretations.Type_Matcher_Access;
    235       Cursor : Gela.Interpretations.Cursor'Class) is null;
    236    --  Called for each category of expression interpretation
    237 
    238    not overriding procedure On_Attr_Function
    239      (Self   : in out Up_Visiter;
    240       Tipe   : Gela.Semantic_Types.Type_Index;
    241       Kind   : Gela.Lexical_Types.Predefined_Symbols.Attribute;
    242       Cursor : Gela.Interpretations.Cursor'Class) is null;
    243    --  Called for each attribute denoting function
    244 
    245    not overriding procedure On_Placeholder
    246      (Self   : in out Up_Visiter;
    247       Kind   : Gela.Interpretations.Placeholder_Kind;
    248       Cursor : Gela.Interpretations.Cursor'Class) is null;
    249    --  Called for each placeholder
    250 
    251    not overriding procedure On_Symbol
    252      (Self   : in out Up_Visiter;
    253       Symbol : Gela.Lexical_Types.Symbol;
    254       Cursor : Gela.Interpretations.Cursor'Class) is null;
    255    --  Called for each symbol
    256 
    257198   not overriding function Get_Tuple
    258199     (Self   : in out Interpretation_Manager;
     
    266207      return Gela.Interpretations.Interpretation_Tuple_Index_Array is abstract;
    267208   --  Get tuple list elements
    268 
    269    not overriding function Get_Cursor
    270      (Self   : in out Interpretation_Manager;
    271       Set    : Gela.Interpretations.Interpretation_Set_Index)
    272       return Gela.Interpretations.Cursor'Class is abstract;
    273    --  Get cursor to iterate over all interpretations in Set
    274209
    275210   not overriding procedure Get_Down_Interpretation
     
    298233     (Self : Abstract_Cursor)
    299234      return Gela.Interpretations.Interpretation_Index is abstract;
     235   --  Request persistent index for current interpretation
    300236
    301237   --  Iterating over symbol interpretation
     
    392328        return Profile_Iterators.Forward_Iterator'Class is abstract;
    393329
     330   --  Iterating over any interpretation
     331   type Any_Cursor is interface and Abstract_Cursor;
     332
     333   function Has_Some
     334     (Self : Any_Cursor'Class) return Boolean is (Self.Has_Element);
     335
     336   not overriding function Is_Symbol
     337     (Self : Any_Cursor) return Boolean is abstract;
     338
     339   not overriding function Is_Defining_Name (Self : Any_Cursor)
     340      return Boolean is abstract;
     341
     342   not overriding function Is_Expression (Self : Any_Cursor)
     343      return Boolean is abstract;
     344
     345   not overriding function Is_Expression_Category (Self : Any_Cursor)
     346      return Boolean is abstract;
     347
     348   not overriding function Is_Profile (Self : Any_Cursor)
     349      return Boolean is abstract;
     350
     351   not overriding function Symbol
     352     (Self : Any_Cursor) return Gela.Lexical_Types.Symbol is abstract;
     353
     354   not overriding function Defining_Name (Self : Any_Cursor)
     355      return Gela.Elements.Defining_Names.Defining_Name_Access is abstract;
     356
     357   not overriding function Expression_Type (Self : Any_Cursor)
     358      return Gela.Semantic_Types.Type_Index is abstract;
     359
     360   not overriding function Matcher (Self : Any_Cursor)
     361        return Gela.Interpretations.Type_Matcher_Access is abstract;
     362
     363   not overriding function Corresponding_Type
     364     (Self : Any_Cursor) return Gela.Semantic_Types.Type_Index is abstract;
     365
     366   not overriding function Attribute_Kind (Self : Any_Cursor)
     367        return Gela.Lexical_Types.Predefined_Symbols.Attribute is abstract;
     368
     369   package Any_Iterators is new Ada.Iterator_Interfaces
     370     (Any_Cursor'Class, Has_Some);
     371
     372   not overriding function Each
     373     (Self   : in out Interpretation_Manager;
     374      Set    : Gela.Interpretations.Interpretation_Set_Index)
     375        return Any_Iterators.Forward_Iterator'Class is abstract;
     376   --  Get cursor to iterate over all interpretations in Set
     377
    394378end Gela.Interpretations;
  • trunk/ada-2012/src/semantic/gela-debug_properties.adb

    r497 r511  
    127127   end Dump_Interpretation;
    128128
    129    package Dump_Up_Interpretation is
    130       type Visiter is new Gela.Interpretations.Up_Visiter with record
    131          Comp : not null Gela.Compilations.Compilation_Access;
    132       end record;
    133 
    134       overriding procedure On_Defining_Name
    135         (Self   : in out Visiter;
    136          Name   : Gela.Elements.Defining_Names.Defining_Name_Access;
    137          Cursor : Gela.Interpretations.Cursor'Class);
    138 
    139       overriding procedure On_Expression
    140         (Self   : in out Visiter;
    141          Tipe   : Gela.Semantic_Types.Type_Index;
    142          Cursor : Gela.Interpretations.Cursor'Class);
    143 
    144       overriding procedure On_Expression_Category
    145         (Self   : in out Visiter;
    146          Match  : not null Gela.Interpretations.Type_Matcher_Access;
    147          Cursor : Gela.Interpretations.Cursor'Class);
    148 
    149       overriding procedure On_Attr_Function
    150         (Self   : in out Visiter;
    151          Tipe   : Gela.Semantic_Types.Type_Index;
    152          Kind   : Gela.Lexical_Types.Predefined_Symbols.Attribute;
    153          Cursor : Gela.Interpretations.Cursor'Class);
    154 
    155       overriding procedure On_Symbol
    156         (Self   : in out Visiter;
    157          Symbol : Gela.Lexical_Types.Symbol;
    158          Cursor : Gela.Interpretations.Cursor'Class);
    159 
    160    end Dump_Up_Interpretation;
    161 
    162129   package body Dump_Property is
    163130      overriding procedure On_Down
     
    253220         IM  : constant Gela.Interpretations.Interpretation_Manager_Access :=
    254221           Comp.Context.Interpretation_Manager;
    255          IV  : aliased Dump_Up_Interpretation.Visiter := (Comp => Comp);
    256          Pos : Gela.Interpretations.Cursor'Class := IM.Get_Cursor (Value);
     222         TM : constant Gela.Type_Managers.Type_Manager_Access :=
     223           Comp.Context.Types;
    257224      begin
    258225         if Self.Flags (Up) = False then
     
    264231              Gela.Interpretations.Interpretation_Set_Index'Image (Value));
    265232
    266          while Pos.Has_Element loop
     233         for J in IM.Each (Value) loop
    267234            Put_Line
    268235              ("   INDEX:" &
    269236                 Gela.Interpretations.Interpretation_Index'Image
    270                    (Pos.Get_Index));
    271             Pos.Visit (IV'Access);
    272             Pos.Next;
     237                   (J.Get_Index));
     238
     239            if J.Is_Defining_Name then
     240               declare
     241                  Name   : constant Gela.Elements.Defining_Names.
     242                    Defining_Name_Access := J.Defining_Name;
     243                  Symbol : constant Gela.Lexical_Types.Symbol :=
     244                    Name.Full_Name;
     245               begin
     246                  Put_Line
     247                    ("   Defining_Name " &
     248                       Comp.Context.Symbols.Image (Symbol).To_UTF_8_String);
     249               end;
     250            elsif J.Is_Expression then
     251               declare
     252                  use type Gela.Semantic_Types.Type_Index;
     253                  use type Gela.Types.Type_View_Access;
     254
     255                  Tipe : constant Gela.Semantic_Types.Type_Index :=
     256                    J.Expression_Type;
     257                  View : Gela.Types.Type_View_Access;
     258                  DT   : Dump_Type.Type_Visitor (Put_Expression'Access);
     259               begin
     260                  if Tipe /= 0 then
     261                     View := TM.Get (Tipe);
     262                  end if;
     263
     264                  if View = null then
     265                     Put_Line ("   Expression NULL");
     266                  else
     267                     View.Visit (DT);
     268                  end if;
     269               end;
     270            elsif J.Is_Expression_Category then
     271               Put_Line ("   Expression_Category: ");
     272            elsif J.Is_Symbol then
     273               Put_Line
     274                 ("   Symbol " &
     275                    Comp.Context.Symbols.Image (J.Symbol).To_UTF_8_String);
     276            elsif J.Is_Profile then
     277               Put_Line
     278                 ("   Attr_Function " &
     279                    Comp.Context.Symbols.Image (J.Attribute_Kind).
     280                      To_UTF_8_String);
     281            end if;
    273282         end loop;
    274283      end On_Up;
     
    370379   end Dump_Interpretation;
    371380
    372    package body Dump_Up_Interpretation is
    373 
    374       overriding procedure On_Defining_Name
    375         (Self   : in out Visiter;
    376          Name   : Gela.Elements.Defining_Names.Defining_Name_Access;
    377          Cursor : Gela.Interpretations.Cursor'Class)
    378       is
    379          pragma Unreferenced (Cursor);
    380          Symbol : constant Gela.Lexical_Types.Symbol := Name.Full_Name;
    381       begin
    382          Put_Line
    383            ("   Defining_Name " &
    384               Self.Comp.Context.Symbols.Image (Symbol).To_UTF_8_String);
    385       end On_Defining_Name;
    386 
    387       overriding procedure On_Expression
    388         (Self   : in out Visiter;
    389          Tipe   : Gela.Semantic_Types.Type_Index;
    390          Cursor : Gela.Interpretations.Cursor'Class)
    391       is
    392          pragma Unreferenced (Cursor);
    393          use type Gela.Semantic_Types.Type_Index;
    394          use type Gela.Types.Type_View_Access;
    395 
    396          TM : constant Gela.Type_Managers.Type_Manager_Access :=
    397            Self.Comp.Context.Types;
    398          View : Gela.Types.Type_View_Access;
    399          DT   : Dump_Type.Type_Visitor (Put_Expression'Access);
    400       begin
    401          if Tipe /= 0 then
    402             View := TM.Get (Tipe);
    403          end if;
    404 
    405          if View = null then
    406             Put_Line ("   Expression NULL");
    407          else
    408             View.Visit (DT);
    409          end if;
    410       end On_Expression;
    411 
    412       overriding procedure On_Expression_Category
    413         (Self   : in out Visiter;
    414          Match  : not null Gela.Interpretations.Type_Matcher_Access;
    415          Cursor : Gela.Interpretations.Cursor'Class)
    416       is
    417          pragma Unreferenced (Self, Cursor, Match);
    418       begin
    419          Put_Line ("   Expression_Category: ");
    420       end On_Expression_Category;
    421 
    422       overriding procedure On_Attr_Function
    423         (Self   : in out Visiter;
    424          Tipe   : Gela.Semantic_Types.Type_Index;
    425          Kind   : Gela.Lexical_Types.Predefined_Symbols.Attribute;
    426          Cursor : Gela.Interpretations.Cursor'Class)
    427       is
    428          pragma Unreferenced (Cursor, Tipe);
    429       begin
    430          Put_Line
    431            ("   Attr_Function " &
    432               Self.Comp.Context.Symbols.Image (Kind).To_UTF_8_String);
    433       end On_Attr_Function;
    434 
    435       overriding procedure On_Symbol
    436         (Self   : in out Visiter;
    437          Symbol : Gela.Lexical_Types.Symbol;
    438          Cursor : Gela.Interpretations.Cursor'Class)
    439       is
    440          pragma Unreferenced (Cursor);
    441       begin
    442          Put_Line
    443            ("   Symbol " &
    444               Self.Comp.Context.Symbols.Image (Symbol).To_UTF_8_String);
    445       end On_Symbol;
    446 
    447 --        overriding procedure On_Tuple
    448 --          (Self  : in out Visiter;
    449 --           Value : Gela.Interpretations.Interpretation_Set_Index_Array)
    450 --        is
    451 --           pragma Unreferenced (Self);
    452 --        begin
    453 --           Put_Line ("   Tuple");
    454 --
    455 --           for J of Value loop
    456 --              Put_Line
    457 --                ("     " &
    458 --                   Gela.Interpretations.Interpretation_Set_Index'Image (J));
    459 --           end loop;
    460 --        end On_Tuple;
    461 
    462    end Dump_Up_Interpretation;
    463381
    464382   package body Dump_Type is
  • trunk/ada-2012/src/semantic/gela-int_sets.ads

    r508 r511  
    1313      Index : Gela.Interpretations.Interpretation_Index)
    1414     return Gela.Int.Interpretation_Access is abstract;
    15 
    16    not overriding function Get_Cursor
    17      (Self  : access Interpretation_Set;
    18       Index : Gela.Interpretations.Interpretation_Set_Index)
    19      return Gela.Interpretations.Cursor'Class is abstract;
    2015
    2116   not overriding function Categories
     
    4944                 .Forward_Iterator'Class is abstract;
    5045
     46   not overriding function Each
     47     (Self   : access Interpretation_Set;
     48      Index  : Gela.Interpretations.Interpretation_Set_Index)
     49        return Gela.Interpretations.Any_Iterators
     50                 .Forward_Iterator'Class is abstract;
     51
    5152   type Index_Provider is limited interface;
    5253
  • trunk/ada-2012/src/semantic/gela-plain_int_sets-cursors.adb

    r509 r511  
    7070   end Attribute_Kind;
    7171
     72   --------------------
     73   -- Attribute_Kind --
     74   --------------------
     75
     76   overriding function Attribute_Kind (Self : Any_Cursor)
     77      return Gela.Lexical_Types.Predefined_Symbols.Attribute
     78   is
     79      Item   : constant Gela.Int.Interpretation_Access :=
     80        Int_Lists.Element (Self.Pos);
     81   begin
     82      return Gela.Int.Attr_Functions.Attr_Function (Item.all).Kind;
     83   end Attribute_Kind;
     84
    7285   ------------------------
    7386   -- Corresponding_Type --
     
    8497   end Corresponding_Type;
    8598
     99   ------------------------
     100   -- Corresponding_Type --
     101   ------------------------
     102
     103   overriding function Corresponding_Type (Self : Any_Cursor)
     104      return Gela.Semantic_Types.Type_Index
     105   is
     106      Item   : constant Gela.Int.Interpretation_Access :=
     107        Int_Lists.Element (Self.Pos);
     108   begin
     109      return Gela.Int.Attr_Functions.Attr_Function (Item.all).Tipe;
     110   end Corresponding_Type;
     111
    86112   -------------------
    87113   -- Defining_Name --
     
    98124   end Defining_Name;
    99125
     126   -------------------
     127   -- Defining_Name --
     128   -------------------
     129
     130   overriding function Defining_Name (Self : Any_Cursor)
     131      return Gela.Elements.Defining_Names.Defining_Name_Access
     132   is
     133      Item   : constant Gela.Int.Interpretation_Access :=
     134        Int_Lists.Element (Self.Pos);
     135   begin
     136      return Gela.Int.Defining_Names.Defining_Name (Item.all).Name;
     137   end Defining_Name;
     138
    100139   ---------------------
    101140   -- Expression_Type --
     
    112151   end Expression_Type;
    113152
     153   ---------------------
     154   -- Expression_Type --
     155   ---------------------
     156
     157   overriding function Expression_Type (Self : Any_Cursor)
     158      return Gela.Semantic_Types.Type_Index
     159   is
     160      Item   : constant Gela.Int.Interpretation_Access :=
     161        Int_Lists.Element (Self.Pos);
     162   begin
     163      return Gela.Int.Expressions.Expression (Item.all).Expression_Type;
     164   end Expression_Type;
     165
    114166   ---------------
    115167   -- Get_Index --
     
    209261   end Initialize;
    210262
     263   ----------------
     264   -- Initialize --
     265   ----------------
     266
     267   not overriding procedure Initialize
     268     (Self  : out Any_Cursor;
     269      Set   : access Interpretation_Set;
     270      Index : Gela.Interpretations.Interpretation_Set_Index) is
     271   begin
     272      Self := (Set, Set.Map (Index).First);
     273   end Initialize;
     274
     275   ----------------------
     276   -- Is_Defining_Name --
     277   ----------------------
     278
     279   overriding function Is_Defining_Name (Self : Any_Cursor) return Boolean is
     280      Item   : constant Gela.Int.Interpretation_Access :=
     281        Int_Lists.Element (Self.Pos);
     282   begin
     283      return Item.all in Gela.Int.Defining_Names.Defining_Name'Class;
     284   end Is_Defining_Name;
     285
     286   -------------------
     287   -- Is_Expression --
     288   -------------------
     289
     290   overriding function Is_Expression (Self : Any_Cursor) return Boolean is
     291      Item   : constant Gela.Int.Interpretation_Access :=
     292        Int_Lists.Element (Self.Pos);
     293   begin
     294      return Item.all in Gela.Int.Expressions.Expression'Class;
     295   end Is_Expression;
     296
     297   ----------------------------
     298   -- Is_Expression_Category --
     299   ----------------------------
     300
     301   overriding function Is_Expression_Category
     302     (Self : Any_Cursor) return Boolean
     303   is
     304      Item   : constant Gela.Int.Interpretation_Access :=
     305        Int_Lists.Element (Self.Pos);
     306   begin
     307      return Item.all in Gela.Int.Categories.Category'Class;
     308   end Is_Expression_Category;
     309
     310   ----------------
     311   -- Is_Profile --
     312   ----------------
     313
     314   overriding function Is_Profile (Self : Any_Cursor) return Boolean is
     315      Item   : constant Gela.Int.Interpretation_Access :=
     316        Int_Lists.Element (Self.Pos);
     317   begin
     318      return Item.all in Gela.Int.Attr_Functions.Attr_Function'Class;
     319   end Is_Profile;
     320
     321   ---------------
     322   -- Is_Symbol --
     323   ---------------
     324
     325   overriding function Is_Symbol (Self : Any_Cursor) return Boolean is
     326      Item   : constant Gela.Int.Interpretation_Access :=
     327        Int_Lists.Element (Self.Pos);
     328   begin
     329      return Item.all in Gela.Int.Symbols.Symbol'Class;
     330   end Is_Symbol;
     331
    211332   -------------
    212333   -- Matcher --
     
    223344   end Matcher;
    224345
     346   -------------
     347   -- Matcher --
     348   -------------
     349
     350   overriding function Matcher (Self : Any_Cursor)
     351      return Gela.Interpretations.Type_Matcher_Access
     352   is
     353      Item   : constant Gela.Int.Interpretation_Access :=
     354        Int_Lists.Element (Self.Pos);
     355   begin
     356      return Gela.Int.Categories.Category (Item.all).Match;
     357   end Matcher;
     358
    225359   ----------
    226360   -- Next --
     
    271405      Int_Lists.Next (Self.Pos);
    272406      Profile_Step (Self);
     407   end Next;
     408
     409   ----------
     410   -- Next --
     411   ----------
     412
     413   overriding procedure Next (Self : in out Any_Cursor) is
     414   begin
     415      Int_Lists.Next (Self.Pos);
    273416   end Next;
    274417
     
    287430   end Symbol;
    288431
     432   ------------
     433   -- Symbol --
     434   ------------
     435
     436   overriding function Symbol
     437     (Self : Any_Cursor) return Gela.Lexical_Types.Symbol
     438   is
     439      Item   : constant Gela.Int.Interpretation_Access :=
     440        Int_Lists.Element (Self.Pos);
     441   begin
     442      return Gela.Int.Symbols.Symbol (Item.all).Get_Symbol;
     443   end Symbol;
     444
    289445end Gela.Plain_Int_Sets.Cursors;
  • trunk/ada-2012/src/semantic/gela-plain_int_sets-cursors.ads

    r509 r511  
    4747   overriding procedure Next (Self : in out Defining_Name_Cursor);
    4848
     49   overriding function Defining_Name
     50     (Self : Defining_Name_Cursor)
     51         return Gela.Elements.Defining_Names.Defining_Name_Access;
     52
    4953   type Expression_Cursor is
    5054     new Gela.Interpretations.Expression_Cursor with private;
     
    5458      Set   : access Interpretation_Set;
    5559      Index : Gela.Interpretations.Interpretation_Set_Index);
     60
     61   overriding function Expression_Type
     62     (Self : Expression_Cursor) return Gela.Semantic_Types.Type_Index;
    5663
    5764   overriding procedure Next (Self : in out Expression_Cursor);
     
    7683
    7784   overriding procedure Next (Self : in out Profile_Cursor);
     85
     86   type Any_Cursor is
     87     new Gela.Interpretations.Any_Cursor with private;
     88
     89   not overriding procedure Initialize
     90     (Self  : out Any_Cursor;
     91      Set   : access Interpretation_Set;
     92      Index : Gela.Interpretations.Interpretation_Set_Index);
     93
     94   overriding procedure Next (Self : in out Any_Cursor);
    7895
    7996private
     
    100117     and Gela.Interpretations.Defining_Name_Cursor with null record;
    101118
    102    overriding function Defining_Name
    103      (Self : Defining_Name_Cursor)
    104          return Gela.Elements.Defining_Names.Defining_Name_Access;
    105 
    106119   type Expression_Cursor is new Base_Cursor
    107120     and Gela.Interpretations.Expression_Cursor with null record;
    108 
    109    overriding function Expression_Type
    110      (Self : Expression_Cursor) return Gela.Semantic_Types.Type_Index;
    111121
    112122   type Symbol_Cursor is new Base_Cursor
     
    126136         return Gela.Lexical_Types.Predefined_Symbols.Attribute;
    127137
     138   type Any_Cursor is new Base_Cursor
     139     and Gela.Interpretations.Any_Cursor with null record;
     140
     141   overriding function Is_Symbol (Self : Any_Cursor) return Boolean;
     142
     143   overriding function Is_Defining_Name (Self : Any_Cursor) return Boolean;
     144
     145   overriding function Is_Expression (Self : Any_Cursor) return Boolean;
     146
     147   overriding function Is_Expression_Category (Self : Any_Cursor)
     148      return Boolean;
     149
     150   overriding function Is_Profile (Self : Any_Cursor) return Boolean;
     151
     152   overriding function Symbol
     153     (Self : Any_Cursor) return Gela.Lexical_Types.Symbol;
     154
     155   overriding function Defining_Name (Self : Any_Cursor)
     156      return Gela.Elements.Defining_Names.Defining_Name_Access;
     157
     158   overriding function Expression_Type (Self : Any_Cursor)
     159      return Gela.Semantic_Types.Type_Index;
     160
     161   overriding function Matcher (Self : Any_Cursor)
     162        return Gela.Interpretations.Type_Matcher_Access;
     163
     164   overriding function Corresponding_Type
     165     (Self : Any_Cursor) return Gela.Semantic_Types.Type_Index;
     166
     167   overriding function Attribute_Kind (Self : Any_Cursor)
     168        return Gela.Lexical_Types.Predefined_Symbols.Attribute;
     169
    128170end Gela.Plain_Int_Sets.Cursors;
  • trunk/ada-2012/src/semantic/gela-plain_int_sets.adb

    r509 r511  
    1 with Gela.Int.Attr_Functions;
    2 with Gela.Int.Categories;
    3 with Gela.Int.Defining_Names;
    4 with Gela.Int.Expressions;
    5 with Gela.Int.Placeholders;
    6 with Gela.Int.Symbols;
    7 with Gela.Int.Tuples;
    8 with Gela.Int.Visiters;
    9 
    101with Gela.Plain_Int_Sets.Cursors;
    112
     
    4132      Some_Cursor    => Cursors.Profile_Cursor,
    4233      Iterators      => Gela.Interpretations.Profile_Iterators);
     34
     35   package Any_Iterators is new Cursors.Generic_Iterators
     36     (Cursor         => Gela.Interpretations.Any_Cursor,
     37      Next           => Gela.Interpretations.Next,
     38      Some_Cursor    => Cursors.Any_Cursor,
     39      Iterators      => Gela.Interpretations.Any_Iterators);
    4340
    4441   ---------
     
    165162   end Element;
    166163
     164   ----------
     165   -- Each --
     166   ----------
     167
     168   overriding function Each
     169     (Self   : access Interpretation_Set;
     170      Index  : Gela.Interpretations.Interpretation_Set_Index)
     171        return Gela.Interpretations.Any_Iterators
     172                 .Forward_Iterator'Class
     173   is
     174      use type Gela.Interpretations.Interpretation_Set_Index;
     175   begin
     176      return Result : Any_Iterators.Iterator do
     177         if Index /= 0 then
     178            Result.Cursor.Initialize (Self, Index);
     179         end if;
     180      end return;
     181   end Each;
     182
    167183   -----------------
    168184   -- Expressions --
     
    184200   end Expressions;
    185201
    186    ----------------
    187    -- Get_Cursor --
    188    ----------------
    189 
    190    overriding function Get_Cursor
    191      (Self  : access Interpretation_Set;
    192       Index : Gela.Interpretations.Interpretation_Set_Index)
    193       return Gela.Interpretations.Cursor'Class
    194    is
    195    begin
    196       return Result : Cursor do
    197 
    198          declare
    199             procedure Get
    200               (Key     : Gela.Interpretations.Interpretation_Set_Index;
    201                Element : Int_Lists.List);
    202 
    203             ---------
    204             -- Get --
    205             ---------
    206 
    207             procedure Get
    208               (Key     : Gela.Interpretations.Interpretation_Set_Index;
    209                Element : Int_Lists.List)
    210             is
    211                pragma Unreferenced (Key);
    212             begin
    213                Result.Pos := Element.First;
    214             end Get;
    215 
    216             use type Gela.Interpretations.Interpretation_Set_Index;
    217          begin
    218             if Index /= 0 then
    219                Int_List_Maps.Query_Element (Self.Map.Find (Index), Get'Access);
    220             end if;
    221 
    222             Result.Set := Self;
    223          end;
    224 
    225       end return;
    226    end Get_Cursor;
    227 
    228    ---------------
    229    -- Get_Index --
    230    ---------------
    231 
    232    overriding function Get_Index
    233      (Self : Cursor)
    234       return Gela.Interpretations.Interpretation_Index
    235    is
    236       use type Gela.Interpretations.Interpretation_Index;
    237 
    238       Item   : constant Gela.Int.Interpretation_Access :=
    239         Int_Lists.Element (Self.Pos);
    240       Result : Gela.Interpretations.Interpretation_Index;
    241    begin
    242       if Item.Index /= 0 then
    243          return Item.Index;
    244       end if;
    245 
    246       Self.Set.Add (Result, Item);
    247 
    248       return Result;
    249    end Get_Index;
    250 
    251    -----------------
    252    -- Has_Element --
    253    -----------------
    254 
    255    overriding function Has_Element (Self : Cursor) return Boolean is
    256    begin
    257       return Int_Lists.Has_Element (Self.Pos);
    258    end Has_Element;
    259 
    260202   ----------
    261203   -- Hash --
     
    299241   end Profiles;
    300242
    301    ----------
    302    -- Next --
    303    ----------
    304 
    305    overriding procedure Next (Self : in out Cursor) is
    306    begin
    307       Int_Lists.Next (Self.Pos);
    308    end Next;
    309 
    310243   -------------
    311244   -- Symbols --
     
    327260   end Symbols;
    328261
    329    -----------
    330    -- Visit --
    331    -----------
    332 
    333    overriding procedure Visit
    334      (Self   : Cursor;
    335       Target : access Gela.Interpretations.Up_Visiter'Class)
    336    is
    337       package Each is
    338          type Visiter is new Gela.Int.Visiters.Visiter with null record;
    339 
    340          overriding procedure Attr_Function
    341            (Self  : access Visiter;
    342             Value : Gela.Int.Attr_Functions.Attr_Function);
    343 
    344          overriding procedure Chosen_Tuple
    345            (Self  : access Visiter;
    346             Value : Gela.Int.Tuples.Chosen_Tuple);
    347 
    348          overriding procedure Defining_Name
    349            (Self  : access Visiter;
    350             Value : Gela.Int.Defining_Names.Defining_Name);
    351 
    352          overriding procedure Expression
    353            (Self  : access Visiter;
    354             Value : Gela.Int.Expressions.Expression);
    355 
    356          overriding procedure Expression_Category
    357            (Self  : access Visiter;
    358             Value : Gela.Int.Categories.Category);
    359 
    360          overriding procedure Placeholder
    361            (Self  : access Visiter;
    362             Value : Gela.Int.Placeholders.Placeholder);
    363 
    364          overriding procedure Symbol
    365            (Self  : access Visiter;
    366             Value : Gela.Int.Symbols.Symbol);
    367 
    368          overriding procedure Tuple
    369            (Self  : access Visiter;
    370             Value : Gela.Int.Tuples.Tuple);
    371 
    372       end Each;
    373 
    374       package body Each is
    375 
    376          overriding procedure Defining_Name
    377            (Self  : access Visiter;
    378             Value : Gela.Int.Defining_Names.Defining_Name)
    379          is
    380             pragma Unreferenced (Self);
    381          begin
    382             Target.On_Defining_Name
    383               (Name   => Value.Name,
    384                Cursor => Visit.Self);
    385          end Defining_Name;
    386 
    387          overriding procedure Expression
    388            (Self  : access Visiter;
    389             Value : Gela.Int.Expressions.Expression)
    390          is
    391             pragma Unreferenced (Self);
    392          begin
    393             Target.On_Expression
    394               (Tipe   => Value.Expression_Type,
    395                Cursor => Visit.Self);
    396          end Expression;
    397 
    398          overriding procedure Expression_Category
    399            (Self  : access Visiter;
    400             Value : Gela.Int.Categories.Category)
    401          is
    402             pragma Unreferenced (Self);
    403          begin
    404             Target.On_Expression_Category
    405               (Match  => Value.Match,
    406                Cursor => Visit.Self);
    407          end Expression_Category;
    408 
    409          overriding procedure Attr_Function
    410            (Self  : access Visiter;
    411             Value : Gela.Int.Attr_Functions.Attr_Function)
    412          is
    413             pragma Unreferenced (Self);
    414          begin
    415             Target.On_Attr_Function
    416               (Kind   => Value.Kind,
    417                Tipe   => Value.Tipe,
    418                Cursor => Visit.Self);
    419          end Attr_Function;
    420 
    421          overriding procedure Placeholder
    422            (Self  : access Visiter;
    423             Value : Gela.Int.Placeholders.Placeholder)
    424          is
    425             pragma Unreferenced (Self);
    426          begin
    427             Target.On_Placeholder
    428               (Kind   => Value.Placeholder_Kind,
    429                Cursor => Visit.Self);
    430          end Placeholder;
    431 
    432          overriding procedure Symbol
    433            (Self  : access Visiter;
    434             Value : Gela.Int.Symbols.Symbol)
    435          is
    436             pragma Unreferenced (Self);
    437          begin
    438             Target.On_Symbol
    439               (Symbol => Value.Get_Symbol,
    440                Cursor => Visit.Self);
    441          end Symbol;
    442 
    443          overriding procedure Tuple
    444            (Self  : access Visiter;
    445             Value : Gela.Int.Tuples.Tuple) is
    446          begin
    447             null;
    448          end Tuple;
    449 
    450          overriding procedure Chosen_Tuple
    451            (Self  : access Visiter;
    452             Value : Gela.Int.Tuples.Chosen_Tuple)
    453          is
    454             pragma Unreferenced (Self, Value);
    455          begin
    456             raise Constraint_Error with "Unexpected down interpretation in up";
    457          end Chosen_Tuple;
    458 
    459       end Each;
    460 
    461       V : aliased Each.Visiter;
    462    begin
    463       Int_Lists.Element (Self.Pos).Visit (V'Access);
    464    end Visit;
    465 
    466262end Gela.Plain_Int_Sets;
  • trunk/ada-2012/src/semantic/gela-plain_int_sets.ads

    r508 r511  
    6666     return Gela.Int.Interpretation_Access;
    6767
    68    overriding function Get_Cursor
    69      (Self  : access Interpretation_Set;
    70       Index : Gela.Interpretations.Interpretation_Set_Index)
    71      return Gela.Interpretations.Cursor'Class;
    72 
    7368   overriding function Symbols
    7469     (Self  : access Interpretation_Set;
     
    10196                 .Forward_Iterator'Class;
    10297
    103    type Cursor is new Gela.Interpretations.Cursor with record
    104       Set : access Interpretation_Set;
    105       Pos : Int_Lists.Cursor := Int_Lists.No_Element;
    106    end record;
    107 
    108    overriding function Has_Element (Self : Cursor) return Boolean;
    109 
    110    overriding procedure Next (Self : in out Cursor);
    111 
    112    overriding procedure Visit
    113      (Self   : Cursor;
    114       Target : access Gela.Interpretations.Up_Visiter'Class);
    115 
    116    overriding function Get_Index
    117      (Self : Cursor) return Gela.Interpretations.Interpretation_Index;
     98   overriding function Each
     99     (Self   : access Interpretation_Set;
     100      Index  : Gela.Interpretations.Interpretation_Set_Index)
     101        return Gela.Interpretations.Any_Iterators
     102                 .Forward_Iterator'Class;
    118103
    119104end Gela.Plain_Int_Sets;
  • trunk/ada-2012/src/semantic/gela-plain_interpretations.adb

    r508 r511  
    1010package body Gela.Plain_Interpretations is
    1111
    12    package Empty_Cursors is
    13       type Cursor is new Gela.Interpretations.Cursor with null record;
    14 
    15       overriding function Has_Element (Self : Cursor) return Boolean;
    16 
    17       overriding procedure Next (Self : in out Cursor) is null;
    18 
    19       overriding procedure Visit
    20         (Self   : Cursor;
    21          Target : access Gela.Interpretations.Up_Visiter'Class) is null;
    22 
    23       overriding function Get_Index
    24         (Self : Cursor) return Gela.Interpretations.Interpretation_Index;
    25 
    26    end Empty_Cursors;
    27 
    28    package body Empty_Cursors is
    29 
    30       overriding function Has_Element (Self : Cursor) return Boolean is
    31          pragma Unreferenced (Self);
    32       begin
    33          return False;
    34       end Has_Element;
    35 
    36       overriding function Get_Index
    37         (Self : Cursor) return Gela.Interpretations.Interpretation_Index
    38       is
    39          pragma Unreferenced (Self);
    40       begin
    41          return 0;
    42       end Get_Index;
    43 
    44    end Empty_Cursors;
    45 
    4612   -----------------------
    4713   -- Add_Attr_Function --
     
    309275   end Defining_Names;
    310276
     277   ----------
     278   -- Each --
     279   ----------
     280
     281   overriding function Each
     282     (Self   : in out Interpretation_Manager;
     283      Set    : Gela.Interpretations.Interpretation_Set_Index)
     284        return Gela.Interpretations.Any_Iterators
     285                 .Forward_Iterator'Class is
     286   begin
     287      return Self.Set_Batches.Element (Set / Batch_Size).Each (Set);
     288   end Each;
     289
    311290   -----------------
    312291   -- Expressions --
     
    321300      return Self.Set_Batches.Element (Set / Batch_Size).Expressions (Set);
    322301   end Expressions;
    323 
    324    ----------------
    325    -- Get_Cursor --
    326    ----------------
    327 
    328    overriding function Get_Cursor
    329      (Self   : in out Interpretation_Manager;
    330       Set    : Gela.Interpretations.Interpretation_Set_Index)
    331       return Gela.Interpretations.Cursor'Class is
    332    begin
    333       if Set = 0 then
    334          return None : Empty_Cursors.Cursor;
    335       else
    336          return Self.Set_Batches.Element (Set / Batch_Size).Get_Cursor (Set);
    337       end if;
    338    end Get_Cursor;
    339302
    340303   -----------------------------
  • trunk/ada-2012/src/semantic/gela-plain_interpretations.ads

    r508 r511  
    130130      return Gela.Interpretations.Interpretation_Tuple_Index_Array;
    131131
    132    overriding function Get_Cursor
    133      (Self   : in out Interpretation_Manager;
    134       Set    : Gela.Interpretations.Interpretation_Set_Index)
    135       return Gela.Interpretations.Cursor'Class;
    136    --  Get cursor to iterate over all interpretations in Set
    137 
    138132   overriding procedure Visit
    139133     (Self   : in out Interpretation_Manager;
     
    196190                 .Forward_Iterator'Class;
    197191
     192   overriding function Each
     193     (Self   : in out Interpretation_Manager;
     194      Set    : Gela.Interpretations.Interpretation_Set_Index)
     195        return Gela.Interpretations.Any_Iterators
     196                 .Forward_Iterator'Class;
     197
    198198end Gela.Plain_Interpretations;
  • trunk/ada-2012/src/semantic/gela-resolve.adb

    r510 r511  
    10321032   end Get_Subtype;
    10331033
     1034   --------------------
     1035   -- Interpretation --
     1036   --------------------
     1037
    10341038   procedure Interpretation
    10351039     (Comp   : Gela.Compilations.Compilation_Access;
     
    10401044      pragma Unreferenced (Env);
    10411045
    1042       package Each is
    1043          type Visiter is new Gela.Interpretations.Up_Visiter with record
    1044             Prev   : Gela.Interpretations.Interpretation_Index := 0;
    1045             Result : Gela.Interpretations.Interpretation_Index := 0;
    1046          end record;
    1047 
    1048          overriding procedure On_Symbol
    1049            (Self   : in out Visiter;
    1050             Symbol : Gela.Lexical_Types.Symbol;
    1051             Cursor : Gela.Interpretations.Cursor'Class);
    1052 
    1053       end Each;
    1054 
    1055       package body Each is
    1056 
    1057          overriding procedure On_Symbol
    1058            (Self   : in out Visiter;
    1059             Symbol : Gela.Lexical_Types.Symbol;
    1060             Cursor : Gela.Interpretations.Cursor'Class)
    1061          is
    1062             pragma Unreferenced (Symbol, Cursor);
    1063          begin
    1064             --  Skip symbols
    1065             Self.Result := Self.Prev;
    1066          end On_Symbol;
    1067 
    1068       end Each;
    1069 
    10701046      IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
    10711047        Comp.Context.Interpretation_Manager;
    1072 
    1073       Cursor : Gela.Interpretations.Cursor'Class :=
    1074         IM.Get_Cursor (Set);
    1075 
    1076       Visiter : aliased Each.Visiter;
    1077    begin
    1078       while Cursor.Has_Element loop
    1079          Visiter.Result := Cursor.Get_Index;
    1080          Cursor.Visit (Visiter'Access);
    1081          Visiter.Prev := Visiter.Result;
    1082          Cursor.Next;
     1048   begin
     1049      Result := 0;
     1050
     1051      for J in IM.Each (Set) loop
     1052         if not J.Is_Symbol then
     1053            Result := J.Get_Index;
     1054         end if;
    10831055      end loop;
    1084 
    1085       Result := Visiter.Result;
    10861056   end Interpretation;
    10871057
     
    18711841      pragma Unreferenced (Env);
    18721842
    1873       package Each is
    1874          type Visiter is new Gela.Interpretations.Up_Visiter with record
    1875             Type_Index : Gela.Semantic_Types.Type_Index;
    1876             Index      : Gela.Interpretations.Interpretation_Index := 0;
    1877          end record;
    1878 
    1879          overriding procedure On_Defining_Name
    1880            (Self   : in out Visiter;
    1881             Name   : Gela.Elements.Defining_Names.Defining_Name_Access;
    1882             Cursor : Gela.Interpretations.Cursor'Class);
    1883 
    1884          overriding procedure On_Expression
    1885            (Self   : in out Visiter;
    1886             Tipe   : Gela.Semantic_Types.Type_Index;
    1887             Cursor : Gela.Interpretations.Cursor'Class);
    1888 
    1889          overriding procedure On_Expression_Category
    1890            (Self   : in out Visiter;
    1891             Match  : not null Gela.Interpretations.Type_Matcher_Access;
    1892             Cursor : Gela.Interpretations.Cursor'Class);
    1893 
    1894       end Each;
    1895 
    18961843      IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
    18971844        Comp.Context.Interpretation_Manager;
     
    19021849      View : constant Gela.Types.Type_View_Access := TM.Get (Type_Up);
    19031850
    1904       ----------
    1905       -- Each --
    1906       ----------
    1907 
    1908       package body Each is
    1909 
    1910          overriding procedure On_Defining_Name
    1911            (Self   : in out Visiter;
    1912             Name   : Gela.Elements.Defining_Names.Defining_Name_Access;
    1913             Cursor : Gela.Interpretations.Cursor'Class)
    1914          is
    1915             pragma Unreferenced (Name);
    1916          begin
    1917             Self.Index := Cursor.Get_Index;
    1918          end On_Defining_Name;
    1919 
    1920          overriding procedure On_Expression
    1921            (Self   : in out Visiter;
    1922             Tipe   : Gela.Semantic_Types.Type_Index;
    1923             Cursor : Gela.Interpretations.Cursor'Class)
    1924          is
    1925             This_Type : constant Gela.Types.Type_View_Access :=
    1926               TM.Get (Tipe);
    1927          begin
    1928             if This_Type.Assigned and then
    1929               This_Type.Is_Expected_Type (View)
    1930             then
    1931                Self.Index := Cursor.Get_Index;
    1932             end if;
    1933          end On_Expression;
    1934 
    1935          overriding procedure On_Expression_Category
    1936            (Self   : in out Visiter;
    1937             Match  : not null Gela.Interpretations.Type_Matcher_Access;
    1938             Cursor : Gela.Interpretations.Cursor'Class)
    1939          is
    1940             pragma Unreferenced (Cursor);
    1941             use type Gela.Interpretations.Interpretation_Index;
    1942          begin
    1943             View.Visit (Match.all);
    1944 
    1945             if Match.Is_Matched and Self.Index = 0 then
    1946                IM.Get_Expression_Index
    1947                  (Tipe   => Self.Type_Index,
    1948                   Result => Self.Index);
    1949             end if;
    1950          end On_Expression_Category;
    1951 
    1952       end Each;
    1953 
    1954       Cursor  : Gela.Interpretations.Cursor'Class := IM.Get_Cursor (Expr_Up);
    1955       Visiter : aliased Each.Visiter;
    1956    begin
    1957       Visiter.Type_Index := Type_Up;
    1958 
    1959       if View.Assigned then
    1960          while Cursor.Has_Element loop
    1961             Cursor.Visit (Visiter'Access);
    1962             Cursor.Next;
    1963          end loop;
     1851   begin
     1852      Result := 0;
     1853
     1854      if not View.Assigned then
     1855         return;
    19641856      end if;
    19651857
    1966       Result := Visiter.Index;
     1858      for J in IM.Each (Expr_Up) loop
     1859         if J.Is_Defining_Name then
     1860            Result := J.Get_Index;  --  ???
     1861         elsif J.Is_Expression then
     1862            declare
     1863               This_Type : constant Gela.Types.Type_View_Access :=
     1864                 TM.Get (J.Expression_Type);
     1865            begin
     1866               if This_Type.Assigned and then
     1867                 This_Type.Is_Expected_Type (View)
     1868               then
     1869                  Result := J.Get_Index;
     1870               end if;
     1871            end;
     1872         elsif J.Is_Expression_Category then
     1873            declare
     1874               use type Gela.Interpretations.Interpretation_Index;
     1875               Match  : constant Gela.Interpretations.Type_Matcher_Access :=
     1876                 J.Matcher;
     1877            begin
     1878               View.Visit (Match.all);
     1879
     1880               if Match.Is_Matched and Result = 0 then
     1881                  IM.Get_Expression_Index
     1882                    (Tipe   => Type_Up,
     1883                     Result => Result);
     1884               end if;
     1885            end;
     1886         end if;
     1887      end loop;
    19671888   end To_Type;
    19681889
Note: See TracChangeset for help on using the changeset viewer.