Changeset 391


Ignore:
Timestamp:
Jan 13, 2015, 9:45:32 AM (5 years ago)
Author:
Maxim Reznik
Message:

Resolve selector_name in discriminant constraint

Add Symbol interpretation to pass information about selector_name.
Add Interpretation_Manager.Get_Defining_Name_Index procedure to register
resolved defining name of discriminants.
Add Type_View.Get_Discriminant to retrive discriminant name from type view.
Rewrite Gela.Resolve.Constraints

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

Legend:

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

    r345 r391  
    11--  This package provides Element interface and their methods.
     2
     3with Ada.Containers;
     4
    25with Gela.Lexical_Types;
    36
     
    4750     (Self  : Element) return Gela.Lexical_Types.Token_Count is abstract;
    4851   --  Return last token index of given element.
     52
     53   not overriding function Hash
     54     (Self  : Element) return Ada.Containers.Hash_Type is abstract;
     55   --  Return hash of given element.
    4956
    5057   not overriding procedure Visit
  • trunk/ada-2012/src/api/gela-interpretations.ads

    r367 r391  
    2424     access all Interpretation_Manager'Class;
    2525   for Interpretation_Manager_Access'Storage_Size use 0;
     26
     27   not overriding procedure Add_Symbol
     28     (Self   : in out Interpretation_Manager;
     29      Symbol : Gela.Lexical_Types.Symbol;
     30      Result : in out Gela.Interpretations.Interpretation_Set_Index)
     31        is abstract;
     32   --  Extend Result with new interpretation as symbol
    2633
    2734   not overriding procedure Add_Defining_Name
     
    6269      Left   : Gela.Interpretations.Interpretation_Index;
    6370      Right  : Gela.Interpretations.Interpretation_Index;
    64       Result : out Gela.Interpretations.Interpretation_Index)
    65         is abstract;
     71      Result : out Gela.Interpretations.Interpretation_Index) is abstract;
    6672   --  Register chosen tuple interpretation
     73
     74   not overriding procedure Get_Defining_Name_Index
     75     (Self   : in out Interpretation_Manager;
     76      Name   : Gela.Elements.Defining_Names.Defining_Name_Access;
     77      Result : out Gela.Interpretations.Interpretation_Index) is abstract;
     78   --  Register chosen defining_name interpretation
    6779
    6880   type Placeholder_Kind is (Absent);
     
    101113      Down   : Gela.Interpretations.Interpretation_Index_Array) is null;
    102114   --  Called for each placeholder
     115
     116   not overriding procedure On_Symbol
     117     (Self   : in out Visiter;
     118      Symbol : Gela.Lexical_Types.Symbol;
     119      Down   : Gela.Interpretations.Interpretation_Index_Array) is null;
     120   --  Called for each symbol
    103121
    104122   not overriding procedure On_Tuple
  • trunk/ada-2012/src/api/gela-type_views.ads

    r280 r391  
    11--  This package provides representation of types and their categories.
     2
     3with Gela.Elements.Defining_Names;
     4with Gela.Lexical_Types;
    25
    36package Gela.Type_Views is
     
    3740   not overriding function Category
    3841     (Self : Type_View) return Category_Kinds is abstract;
     42
     43   not overriding function Get_Discriminant
     44     (Self   : Type_View;
     45      Symbol : Gela.Lexical_Types.Symbol)
     46      return Gela.Elements.Defining_Names.Defining_Name_Access is abstract;
    3947
    4048--     function Is_Elementary           (Self : Abstract_Type) return Boolean;
  • trunk/ada-2012/src/asis/asis-elements.adb

    r388 r391  
    1010--  Procedural wrapper over Object-Oriented ASIS implementation
    1111
    12 with System.Storage_Elements;
     12with Ada.Containers;
    1313
    1414with Gela.Compilations;
     
    894894
    895895   function Hash (Element : in Asis.Element) return Asis.ASIS_Integer is
    896       subtype Integer_Address is System.Storage_Elements.Integer_Address;
    897       use type Integer_Address;
    898       X : Integer_Address;
     896      use type Ada.Containers.Hash_Type;
     897
     898      X : Ada.Containers.Hash_Type;
    899899   begin
    900900      if Assigned (Element) then
    901          X := System.Storage_Elements.To_Integer (Element.Data.all'Address);
    902          X := X and Integer_Address (ASIS_Integer'Last);
     901         X := Element.Data.Hash;
     902         X := X and Ada.Containers.Hash_Type (ASIS_Integer'Last);
    903903         return ASIS_Integer (X);
    904904      else
  • trunk/ada-2012/src/asis/asis-extensions-flat_kinds.adb

    r390 r391  
    221221     (Self : in out Visiter;
    222222      Node : not null Gela.Elements.Access_To_Object_Definitions.
    223         Access_To_Object_Definition_Access)
    224    is null;
     223        Access_To_Object_Definition_Access);
    225224
    226225   overriding procedure Access_To_Procedure_Definition
     
    368367     (Self : in out Visiter;
    369368      Node : not null Gela.Elements.Constrained_Array_Definitions.
    370         Constrained_Array_Definition_Access)
    371    is null;
     369        Constrained_Array_Definition_Access);
    372370
    373371   overriding procedure Decimal_Fixed_Point_Definition
     
    401399     (Self : in out Visiter;
    402400      Node : not null Gela.Elements.Defining_Operator_Symbols.
    403         Defining_Operator_Symbol_Access)
    404    is null;
     401        Defining_Operator_Symbol_Access);
    405402
    406403   overriding procedure Delay_Statement
     
    439436     (Self : in out Visiter;
    440437      Node : not null Gela.Elements.Discrete_Simple_Expression_Ranges.
    441         Discrete_Simple_Expression_Range_Access)
    442    is null;
     438        Discrete_Simple_Expression_Range_Access);
    443439
    444440   overriding procedure Discrete_Subtype_Indication
    445441     (Self : in out Visiter;
    446442      Node : not null Gela.Elements.Discrete_Subtype_Indications.
    447         Discrete_Subtype_Indication_Access)
    448    is null;
     443        Discrete_Subtype_Indication_Access);
    449444
    450445   overriding procedure Discrete_Subtype_Indication_Dr
     
    530525     (Self : in out Visiter;
    531526      Node : not null Gela.Elements.Exception_Renaming_Declarations.
    532         Exception_Renaming_Declaration_Access)
    533    is null;
     527        Exception_Renaming_Declaration_Access);
    534528
    535529   overriding procedure Exit_Statement
     
    829823   overriding procedure Null_Component
    830824     (Self : in out Visiter;
    831       Node : not null Gela.Elements.Null_Components.Null_Component_Access)
    832    is null;
     825      Node : not null Gela.Elements.Null_Components.Null_Component_Access);
    833826
    834827   overriding procedure Null_Literal
     
    850843     (Self : in out Visiter;
    851844      Node : not null Gela.Elements.Number_Declarations.
    852         Number_Declaration_Access)
    853    is null;
     845        Number_Declaration_Access);
    854846
    855847   overriding procedure Numeric_Literal
     
    865857     (Self : in out Visiter;
    866858      Node : not null Gela.Elements.Object_Renaming_Declarations.
    867         Object_Renaming_Declaration_Access)
    868    is null;
     859        Object_Renaming_Declaration_Access);
    869860
    870861   overriding procedure Operator_Symbol
     
    905896     (Self : in out Visiter;
    906897      Node : not null Gela.Elements.Package_Renaming_Declarations.
    907         Package_Renaming_Declaration_Access)
    908    is null;
     898        Package_Renaming_Declaration_Access);
    909899
    910900   overriding procedure Parameter_Association
     
    944934     (Self : in out Visiter;
    945935      Node : not null Gela.Elements.Private_Type_Declarations.
    946         Private_Type_Declaration_Access)
    947    is null;
     936        Private_Type_Declaration_Access);
    948937
    949938   overriding procedure Private_Type_Definition
    950939     (Self : in out Visiter;
    951940      Node : not null Gela.Elements.Private_Type_Definitions.
    952         Private_Type_Definition_Access)
    953    is null;
     941        Private_Type_Definition_Access);
    954942
    955943   overriding procedure Procedure_Body
     
    11591147     (Self : in out Visiter;
    11601148      Node : not null Gela.Elements.Unconstrained_Array_Definitions.
    1161         Unconstrained_Array_Definition_Access)
    1162    is null;
     1149        Unconstrained_Array_Definition_Access);
    11631150
    11641151   overriding procedure Unknown_Discriminant_Part
     
    12031190      Self.Result := An_Accept_Statement;
    12041191   end Accept_Statement;
     1192
     1193   overriding procedure Access_To_Object_Definition
     1194     (Self : in out Visiter;
     1195      Node : not null Gela.Elements.Access_To_Object_Definitions.
     1196        Access_To_Object_Definition_Access)
     1197   is
     1198      use type Gela.Lexical_Types.Token_Count;
     1199   begin
     1200      if Node.Constant_Token = 0 then
     1201         Self.Result := An_Anonymous_Access_To_Variable;
     1202      else
     1203         Self.Result := An_Anonymous_Access_To_Constant;
     1204      end if;
     1205   end Access_To_Object_Definition;
    12051206
    12061207   overriding procedure Anonymous_Access_To_Object_Definition
     
    14191420   end Composite_Constraint;
    14201421
     1422   overriding procedure Constrained_Array_Definition
     1423     (Self : in out Visiter;
     1424      Node : not null Gela.Elements.Constrained_Array_Definitions.
     1425        Constrained_Array_Definition_Access)
     1426   is
     1427      pragma Unreferenced (Node);
     1428   begin
     1429      Self.Result := A_Constrained_Array_Definition;
     1430   end Constrained_Array_Definition;
     1431
    14211432   overriding procedure Defining_Enumeration_Literal
    14221433     (Self : in out Visiter;
     
    14481459      Self.Result := A_Defining_Identifier;
    14491460   end Defining_Identifier;
     1461
     1462   overriding procedure Defining_Operator_Symbol
     1463     (Self : in out Visiter;
     1464      Node : not null Gela.Elements.Defining_Operator_Symbols.
     1465        Defining_Operator_Symbol_Access)
     1466   is
     1467      Operator_Map : constant array
     1468        (Gela.Lexical_Types.Symbol range 1 .. 19) of Element_Flat_Kind
     1469        := (A_Defining_Less_Than_Operator,
     1470            A_Defining_Equal_Operator,
     1471            A_Defining_Greater_Than_Operator,
     1472            A_Defining_Minus_Operator,
     1473            A_Defining_Divide_Operator,
     1474            A_Defining_Multiply_Operator,
     1475            A_Defining_Concatenate_Operator,
     1476            A_Defining_Plus_Operator,
     1477            A_Defining_Less_Than_Or_Equal_Operator,
     1478            A_Defining_Greater_Than_Or_Equal_Operator,
     1479            A_Defining_Not_Equal_Operator,
     1480            A_Defining_Exponentiate_Operator,
     1481            A_Defining_Or_Operator,
     1482            A_Defining_And_Operator,
     1483            A_Defining_Xor_Operator,
     1484            A_Defining_Mod_Operator,
     1485            A_Defining_Rem_Operator,
     1486            A_Defining_Abs_Operator,
     1487            A_Defining_Not_Operator);
     1488
     1489      Comp    : constant Gela.Compilations.Compilation_Access :=
     1490        Node.Enclosing_Compilation;
     1491      Token : constant Gela.Lexical_Types.Token :=
     1492        Comp.Get_Token (Node.Operator_Symbol_Token);
     1493   begin
     1494      if Token.Symbol in Operator_Map'Range then
     1495         Self.Result := Operator_Map (Token.Symbol);
     1496      end if;
     1497   end Defining_Operator_Symbol;
    14501498
    14511499   overriding procedure Delay_Statement
     
    14721520   end Derived_Type_Definition;
    14731521
     1522   overriding procedure Discrete_Simple_Expression_Range
     1523     (Self : in out Visiter;
     1524      Node : not null Gela.Elements.Discrete_Simple_Expression_Ranges.
     1525        Discrete_Simple_Expression_Range_Access)
     1526   is
     1527      pragma Unreferenced (Node);
     1528   begin
     1529      Self.Result := A_Discrete_Simple_Expression_Range;
     1530   end Discrete_Simple_Expression_Range;
     1531
     1532   overriding procedure Discrete_Subtype_Indication
     1533     (Self : in out Visiter;
     1534      Node : not null Gela.Elements.Discrete_Subtype_Indications.
     1535        Discrete_Subtype_Indication_Access)
     1536   is
     1537      pragma Unreferenced (Node);
     1538   begin
     1539      Self.Result := A_Discrete_Subtype_Indication;
     1540   end Discrete_Subtype_Indication;
     1541
    14741542   overriding procedure Discriminant_Specification
    14751543     (Self : in out Visiter;
     
    15501618   end Exception_Handler;
    15511619
     1620   overriding procedure Exception_Renaming_Declaration
     1621     (Self : in out Visiter;
     1622      Node : not null Gela.Elements.Exception_Renaming_Declarations.
     1623        Exception_Renaming_Declaration_Access)
     1624   is
     1625      pragma Unreferenced (Node);
     1626   begin
     1627      Self.Result := An_Exception_Renaming_Declaration;
     1628   end Exception_Renaming_Declaration;
     1629
    15521630   overriding procedure Exit_Statement
    15531631     (Self : in out Visiter;
     
    15681646      Self.Result := An_Explicit_Dereference;
    15691647   end Explicit_Dereference;
    1570 
    1571    overriding procedure Formal_Derived_Type_Definition
    1572      (Self : in out Visiter;
    1573       Node : not null Gela.Elements.Formal_Derived_Type_Definitions.
    1574         Formal_Derived_Type_Definition_Access)
    1575    is
    1576       pragma Unreferenced (Node);
    1577    begin
    1578       Self.Result := A_Formal_Derived_Type_Definition;
    1579    end Formal_Derived_Type_Definition;
    1580 
    1581    overriding procedure Formal_Type_Declaration
    1582      (Self : in out Visiter;
    1583       Node : not null Gela.Elements.Formal_Type_Declarations.
    1584         Formal_Type_Declaration_Access)
    1585    is
    1586       pragma Unreferenced (Node);
    1587    begin
    1588       Self.Result := A_Formal_Type_Declaration;
    1589    end Formal_Type_Declaration;
    1590 
    1591    overriding procedure Full_Type_Declaration
    1592      (Self : in out Visiter;
    1593       Node : not null Gela.Elements.Full_Type_Declarations.
    1594         Full_Type_Declaration_Access)
    1595    is
    1596       pragma Unreferenced (Node);
    1597    begin
    1598       Self.Result := An_Ordinary_Type_Declaration;
    1599    end Full_Type_Declaration;
    1600 
    1601    overriding procedure Function_Body
    1602      (Self : in out Visiter;
    1603       Node : not null Gela.Elements.Function_Bodies.Function_Body_Access)
    1604    is
    1605       pragma Unreferenced (Node);
    1606    begin
    1607       Self.Result := A_Function_Body_Declaration;
    1608    end Function_Body;
    1609 
    1610    overriding procedure Function_Declaration
    1611      (Self : in out Visiter;
    1612       Node : not null Gela.Elements.Function_Declarations.
    1613         Function_Declaration_Access)
    1614    is
    1615       pragma Unreferenced (Node);
    1616    begin
    1617       Self.Result := A_Function_Declaration;
    1618    end Function_Declaration;
    1619 
    1620    overriding procedure Generic_Association
    1621      (Self : in out Visiter;
    1622       Node : not null Gela.Elements.Generic_Associations.
    1623         Generic_Association_Access)
    1624    is
    1625       pragma Unreferenced (Node);
    1626    begin
    1627       Self.Result := A_Generic_Association;
    1628    end Generic_Association;
    1629 
    1630    overriding procedure Generic_Package_Declaration
    1631      (Self : in out Visiter;
    1632       Node : not null Gela.Elements.Generic_Package_Declarations.
    1633         Generic_Package_Declaration_Access)
    1634    is
    1635       pragma Unreferenced (Node);
    1636    begin
    1637       Self.Result := A_Generic_Package_Declaration;
    1638    end Generic_Package_Declaration;
    1639 
    1640    overriding procedure Identifier
    1641      (Self : in out Visiter;
    1642       Node : not null Gela.Elements.Identifiers.Identifier_Access)
    1643    is
    1644       pragma Unreferenced (Node);
    1645    begin
    1646       Self.Result := An_Identifier;
    1647    end Identifier;
    1648 
    1649    overriding procedure If_Path
    1650      (Self : in out Visiter;
    1651       Node : not null Gela.Elements.If_Paths.If_Path_Access)
    1652    is
    1653       pragma Unreferenced (Node);
    1654    begin
    1655       Self.Result := An_If_Path;
    1656    end If_Path;
    1657 
    1658    overriding procedure If_Statement
    1659      (Self : in out Visiter;
    1660       Node : not null Gela.Elements.If_Statements.If_Statement_Access)
    1661    is
    1662       pragma Unreferenced (Node);
    1663    begin
    1664       Self.Result := An_If_Statement;
    1665    end If_Statement;
    1666 
    1667    overriding procedure Known_Discriminant_Part
    1668      (Self : in out Visiter;
    1669       Node : not null Gela.Elements.Known_Discriminant_Parts.
    1670         Known_Discriminant_Part_Access)
    1671    is
    1672       pragma Unreferenced (Node);
    1673    begin
    1674       Self.Result := A_Known_Discriminant_Part;
    1675    end Known_Discriminant_Part;
    1676 
    1677    overriding procedure Loop_Statement
    1678      (Self : in out Visiter;
    1679       Node : not null Gela.Elements.Loop_Statements.Loop_Statement_Access)
    1680    is
    1681       pragma Unreferenced (Node);
    1682    begin
    1683       Self.Result := A_Loop_Statement;
    1684    end Loop_Statement;
    16851648
    16861649   ---------------
     
    16971660   end Flat_Kind;
    16981661
     1662   overriding procedure Formal_Derived_Type_Definition
     1663     (Self : in out Visiter;
     1664      Node : not null Gela.Elements.Formal_Derived_Type_Definitions.
     1665        Formal_Derived_Type_Definition_Access)
     1666   is
     1667      pragma Unreferenced (Node);
     1668   begin
     1669      Self.Result := A_Formal_Derived_Type_Definition;
     1670   end Formal_Derived_Type_Definition;
     1671
     1672   overriding procedure Formal_Type_Declaration
     1673     (Self : in out Visiter;
     1674      Node : not null Gela.Elements.Formal_Type_Declarations.
     1675        Formal_Type_Declaration_Access)
     1676   is
     1677      pragma Unreferenced (Node);
     1678   begin
     1679      Self.Result := A_Formal_Type_Declaration;
     1680   end Formal_Type_Declaration;
     1681
     1682   overriding procedure Full_Type_Declaration
     1683     (Self : in out Visiter;
     1684      Node : not null Gela.Elements.Full_Type_Declarations.
     1685        Full_Type_Declaration_Access)
     1686   is
     1687      pragma Unreferenced (Node);
     1688   begin
     1689      Self.Result := An_Ordinary_Type_Declaration;
     1690   end Full_Type_Declaration;
     1691
     1692   overriding procedure Function_Body
     1693     (Self : in out Visiter;
     1694      Node : not null Gela.Elements.Function_Bodies.Function_Body_Access)
     1695   is
     1696      pragma Unreferenced (Node);
     1697   begin
     1698      Self.Result := A_Function_Body_Declaration;
     1699   end Function_Body;
     1700
     1701   overriding procedure Function_Declaration
     1702     (Self : in out Visiter;
     1703      Node : not null Gela.Elements.Function_Declarations.
     1704        Function_Declaration_Access)
     1705   is
     1706      pragma Unreferenced (Node);
     1707   begin
     1708      Self.Result := A_Function_Declaration;
     1709   end Function_Declaration;
     1710
     1711   overriding procedure Generic_Association
     1712     (Self : in out Visiter;
     1713      Node : not null Gela.Elements.Generic_Associations.
     1714        Generic_Association_Access)
     1715   is
     1716      pragma Unreferenced (Node);
     1717   begin
     1718      Self.Result := A_Generic_Association;
     1719   end Generic_Association;
     1720
     1721   overriding procedure Generic_Package_Declaration
     1722     (Self : in out Visiter;
     1723      Node : not null Gela.Elements.Generic_Package_Declarations.
     1724        Generic_Package_Declaration_Access)
     1725   is
     1726      pragma Unreferenced (Node);
     1727   begin
     1728      Self.Result := A_Generic_Package_Declaration;
     1729   end Generic_Package_Declaration;
     1730
     1731   overriding procedure Identifier
     1732     (Self : in out Visiter;
     1733      Node : not null Gela.Elements.Identifiers.Identifier_Access)
     1734   is
     1735      pragma Unreferenced (Node);
     1736   begin
     1737      Self.Result := An_Identifier;
     1738   end Identifier;
     1739
     1740   overriding procedure If_Path
     1741     (Self : in out Visiter;
     1742      Node : not null Gela.Elements.If_Paths.If_Path_Access)
     1743   is
     1744      pragma Unreferenced (Node);
     1745   begin
     1746      Self.Result := An_If_Path;
     1747   end If_Path;
     1748
     1749   overriding procedure If_Statement
     1750     (Self : in out Visiter;
     1751      Node : not null Gela.Elements.If_Statements.If_Statement_Access)
     1752   is
     1753      pragma Unreferenced (Node);
     1754   begin
     1755      Self.Result := An_If_Statement;
     1756   end If_Statement;
     1757
     1758   overriding procedure Known_Discriminant_Part
     1759     (Self : in out Visiter;
     1760      Node : not null Gela.Elements.Known_Discriminant_Parts.
     1761        Known_Discriminant_Part_Access)
     1762   is
     1763      pragma Unreferenced (Node);
     1764   begin
     1765      Self.Result := A_Known_Discriminant_Part;
     1766   end Known_Discriminant_Part;
     1767
     1768   overriding procedure Loop_Statement
     1769     (Self : in out Visiter;
     1770      Node : not null Gela.Elements.Loop_Statements.Loop_Statement_Access)
     1771   is
     1772      pragma Unreferenced (Node);
     1773   begin
     1774      Self.Result := A_Loop_Statement;
     1775   end Loop_Statement;
     1776
     1777   overriding procedure Null_Component
     1778     (Self : in out Visiter;
     1779      Node : not null Gela.Elements.Null_Components.Null_Component_Access)
     1780   is
     1781      pragma Unreferenced (Node);
     1782   begin
     1783      Self.Result := A_Null_Component;
     1784   end Null_Component;
     1785
    16991786   overriding procedure Null_Statement
    17001787     (Self : in out Visiter;
     
    17051792      Self.Result := A_Null_Statement;
    17061793   end Null_Statement;
     1794
     1795   overriding procedure Number_Declaration
     1796     (Self : in out Visiter;
     1797      Node : not null Gela.Elements.Number_Declarations.
     1798        Number_Declaration_Access)
     1799   is
     1800      pragma Unreferenced (Node);
     1801   begin
     1802      Self.Result := An_Integer_Number_Declaration;
     1803   end Number_Declaration;
    17071804
    17081805   overriding procedure Numeric_Literal
     
    17291826   end Object_Declaration;
    17301827
     1828   overriding procedure Object_Renaming_Declaration
     1829     (Self : in out Visiter;
     1830      Node : not null Gela.Elements.Object_Renaming_Declarations.
     1831        Object_Renaming_Declaration_Access)
     1832   is
     1833      pragma Unreferenced (Node);
     1834   begin
     1835      Self.Result := An_Object_Renaming_Declaration;
     1836   end Object_Renaming_Declaration;
     1837
    17311838   overriding procedure Operator_Symbol
    17321839     (Self : in out Visiter;
    17331840      Node : not null Gela.Elements.Operator_Symbols.Operator_Symbol_Access)
    17341841   is
     1842      Operator_Map : constant array
     1843        (Gela.Lexical_Types.Symbol range 1 .. 19) of Element_Flat_Kind
     1844        :=
     1845          (A_Less_Than_Operator, An_Equal_Operator, A_Greater_Than_Operator,
     1846           A_Minus_Operator, A_Divide_Operator, A_Multiply_Operator,
     1847           A_Concatenate_Operator, A_Plus_Operator,
     1848           A_Less_Than_Or_Equal_Operator, A_Greater_Than_Or_Equal_Operator,
     1849           A_Not_Equal_Operator, An_Exponentiate_Operator, An_Or_Operator,
     1850           An_And_Operator, An_Xor_Operator, A_Mod_Operator, A_Rem_Operator,
     1851           An_Abs_Operator, A_Not_Operator);
     1852
    17351853      Comp    : constant Gela.Compilations.Compilation_Access :=
    17361854        Node.Enclosing_Compilation;
    17371855      Token : constant Gela.Lexical_Types.Token :=
    17381856        Comp.Get_Token (Node.Operator_Symbol_Token);
    1739       Map : constant array
    1740         (Gela.Lexical_Types.Symbol range 1 .. 19) of Element_Flat_Kind
    1741         :=
    1742         (A_Less_Than_Operator, An_Equal_Operator, A_Greater_Than_Operator,
    1743          A_Minus_Operator, A_Divide_Operator, A_Multiply_Operator,
    1744          A_Concatenate_Operator, A_Plus_Operator,
    1745          A_Less_Than_Or_Equal_Operator, A_Greater_Than_Or_Equal_Operator,
    1746          A_Not_Equal_Operator, An_Exponentiate_Operator, An_Or_Operator,
    1747          An_And_Operator, An_Xor_Operator, A_Mod_Operator, A_Rem_Operator,
    1748          An_Abs_Operator, A_Not_Operator);
    1749    begin
    1750       if Token.Symbol in Map'Range then
    1751          Self.Result := Map (Token.Symbol);
     1857   begin
     1858      if Token.Symbol in Operator_Map'Range then
     1859         Self.Result := Operator_Map (Token.Symbol);
    17521860      end if;
    17531861   end Operator_Symbol;
     
    17901898      Self.Result := A_Package_Instantiation;
    17911899   end Package_Instantiation;
     1900
     1901   overriding procedure Package_Renaming_Declaration
     1902     (Self : in out Visiter;
     1903      Node : not null Gela.Elements.Package_Renaming_Declarations.
     1904        Package_Renaming_Declaration_Access)
     1905   is
     1906      pragma Unreferenced (Node);
     1907   begin
     1908      Self.Result := A_Package_Renaming_Declaration;
     1909   end Package_Renaming_Declaration;
    17921910
    17931911   overriding procedure Parameter_Specification
     
    18761994   end Pragma_Node;
    18771995
     1996   overriding procedure Private_Type_Declaration
     1997     (Self : in out Visiter;
     1998      Node : not null Gela.Elements.Private_Type_Declarations.
     1999        Private_Type_Declaration_Access)
     2000   is
     2001      pragma Unreferenced (Node);
     2002   begin
     2003      Self.Result := A_Private_Type_Declaration;
     2004   end Private_Type_Declaration;
     2005
     2006   overriding procedure Private_Type_Definition
     2007     (Self : in out Visiter;
     2008      Node : not null Gela.Elements.Private_Type_Definitions.
     2009        Private_Type_Definition_Access)
     2010   is
     2011      pragma Unreferenced (Node);
     2012   begin
     2013      Self.Result := A_Private_Type_Definition;
     2014   end Private_Type_Definition;
     2015
    18782016   --------------------
    18792017   -- Procedure_Body --
     
    21422280   end Terminate_Alternative_Statement;
    21432281
     2282   overriding procedure Unconstrained_Array_Definition
     2283     (Self : in out Visiter;
     2284      Node : not null Gela.Elements.Unconstrained_Array_Definitions.
     2285        Unconstrained_Array_Definition_Access)
     2286   is
     2287      pragma Unreferenced (Node);
     2288   begin
     2289      Self.Result := An_Unconstrained_Array_Definition;
     2290   end Unconstrained_Array_Definition;
     2291
    21442292   ------------------------
    21452293   -- Use_Package_Clause --
  • trunk/ada-2012/src/parser/gela-nodes.adb

    r383 r391  
     1with System.Storage_Elements;
     2
    13package body Gela.Nodes is
    24
     
    9496      return 0;
    9597   end First_Token;
     98
     99   ----------
     100   -- Hash --
     101   ----------
     102
     103   overriding function Hash (Self  : Node) return Ada.Containers.Hash_Type is
     104      subtype Integer_Address is System.Storage_Elements.Integer_Address;
     105      use type Integer_Address;
     106      X : Integer_Address;
     107   begin
     108      X := System.Storage_Elements.To_Integer (Self'Address);
     109      return Ada.Containers.Hash_Type (X mod Ada.Containers.Hash_Type'Modulus);
     110   end Hash;
    96111
    97112   -------------------------
  • trunk/ada-2012/src/parser/gela-nodes.ads

    r383 r391  
    128128      Value : Gela.Elements.Element_Access);
    129129
     130   overriding function Hash (Self  : Node) return Ada.Containers.Hash_Type;
     131
    130132end Gela.Nodes;
  • trunk/ada-2012/src/semantic/gela-debug_properties.adb

    r385 r391  
    6262         Down   : Gela.Interpretations.Interpretation_Index_Array);
    6363
     64      overriding procedure On_Symbol
     65        (Self   : in out Visiter;
     66         Symbol : Gela.Lexical_Types.Symbol;
     67         Down   : Gela.Interpretations.Interpretation_Index_Array);
     68
    6469      overriding procedure On_Tuple
    6570        (Self  : in out Visiter;
     
    187192         Kind   : Gela.Lexical_Types.Predefined_Symbols.Attribute;
    188193         Down   : Gela.Interpretations.Interpretation_Index_Array) is null;
     194
     195      overriding procedure On_Symbol
     196        (Self   : in out Visiter;
     197         Symbol : Gela.Lexical_Types.Symbol;
     198         Down   : Gela.Interpretations.Interpretation_Index_Array)
     199      is
     200         pragma Unreferenced (Down);
     201      begin
     202         Put_Line
     203           ("   Symbol " &
     204              Self.Comp.Context.Symbols.Image (Symbol).To_UTF_8_String);
     205      end On_Symbol;
    189206
    190207      overriding procedure On_Tuple
  • trunk/ada-2012/src/semantic/gela-int-visiters.ads

    r367 r391  
    33with Gela.Int.Expressions;
    44with Gela.Int.Placeholders;
     5with Gela.Int.Symbols;
    56with Gela.Int.Tuples;
    67
     
    3031      Value : Gela.Int.Placeholders.Placeholder) is abstract;
    3132
     33   not overriding procedure Symbol
     34     (Self  : access Visiter;
     35      Value : Gela.Int.Symbols.Symbol) is abstract;
     36
    3237   not overriding procedure Tuple
    3338     (Self  : access Visiter;
  • trunk/ada-2012/src/semantic/gela-plain_interpretations.adb

    r367 r391  
    33with Gela.Int.Expressions;
    44with Gela.Int.Placeholders;
     5with Gela.Int.Symbols;
    56with Gela.Int.Tuples;
    67with Gela.Int.Visiters;
     
    117118   end Add_Placeholder;
    118119
     120   ----------------
     121   -- Add_Symbol --
     122   ----------------
     123
     124   overriding procedure Add_Symbol
     125     (Self   : in out Interpretation_Manager;
     126      Symbol : Gela.Lexical_Types.Symbol;
     127      Result : in out Gela.Interpretations.Interpretation_Set_Index)
     128   is
     129      Item : constant Gela.Int.Interpretation_Access :=
     130        new Gela.Int.Symbols.Symbol'
     131          (Gela.Int.Symbols.Create
     132             (Down  => (1 .. 0 => 0),
     133              Value => Symbol));
     134   begin
     135      Self.Plian_Int_Set.Add (Result, Item);
     136   end Add_Symbol;
     137
    119138   ---------------
    120139   -- Add_Tuple --
     
    264283   end Get_Cursor;
    265284
     285   -----------------------------
     286   -- Get_Defining_Name_Index --
     287   -----------------------------
     288
     289   overriding procedure Get_Defining_Name_Index
     290     (Self   : in out Interpretation_Manager;
     291      Name   : Gela.Elements.Defining_Names.Defining_Name_Access;
     292      Result : out Gela.Interpretations.Interpretation_Index)
     293   is
     294      Item : constant Gela.Int.Interpretation_Access :=
     295        new Gela.Int.Defining_Names.Defining_Name'
     296          (Gela.Int.Defining_Names.Create
     297             (Down => (1 .. 0 => 0), Name => Name));
     298   begin
     299      Self.Plian_Int_Set.Add (Result, Item);
     300   end Get_Defining_Name_Index;
     301
    266302   ---------------------
    267303   -- Get_Tuple_Index --
     
    347383            Value : Gela.Int.Placeholders.Placeholder);
    348384
     385         overriding procedure Symbol
     386           (Self  : access Visiter;
     387            Value : Gela.Int.Symbols.Symbol);
     388
    349389         overriding procedure Tuple
    350390           (Self  : access Visiter;
     
    418458               Down => Value.Down);
    419459         end Placeholder;
     460
     461         ------------
     462         -- Symbol --
     463         ------------
     464
     465         overriding procedure Symbol
     466           (Self  : access Visiter;
     467            Value : Gela.Int.Symbols.Symbol)
     468         is
     469            pragma Unreferenced (Self);
     470         begin
     471            Target.On_Symbol
     472              (Symbol => Value.Get_Symbol,
     473               Down   => Value.Down);
     474         end Symbol;
    420475
    421476         -----------
  • trunk/ada-2012/src/semantic/gela-plain_interpretations.ads

    r367 r391  
    7878      Result : in out Gela.Interpretations.Interpretation_Set_Index);
    7979
     80   overriding procedure Add_Symbol
     81     (Self   : in out Interpretation_Manager;
     82      Symbol : Gela.Lexical_Types.Symbol;
     83      Result : in out Gela.Interpretations.Interpretation_Set_Index);
     84
    8085   overriding procedure Add_Tuple
    8186     (Self   : in out Interpretation_Manager;
     
    8388      Right  : Gela.Interpretations.Interpretation_Set_Index;
    8489      Result : in out Gela.Interpretations.Interpretation_Set_Index);
     90
     91   overriding procedure Get_Defining_Name_Index
     92     (Self   : in out Interpretation_Manager;
     93      Name   : Gela.Elements.Defining_Names.Defining_Name_Access;
     94      Result : out Gela.Interpretations.Interpretation_Index);
    8595
    8696   overriding procedure Get_Tuple_Index
  • trunk/ada-2012/src/semantic/gela-plain_type_managers.adb

    r380 r391  
    33with Gela.Element_Visiters;
    44with Gela.Elements.Defining_Identifiers;
    5 with Gela.Elements.Full_Type_Declarations;
    65with Gela.Elements.Root_Type_Definitions;
    76with Gela.Elements.Type_Definitions;
    87with Gela.Plain_Type_Views;
     8with Gela.Elements.Record_Type_Definitions;
    99
    1010package body Gela.Plain_Type_Managers is
     
    1313   Universal_Integer_Index : constant Gela.Semantic_Types.Type_Index := 2;
    1414   Universal_Real_Index    : constant Gela.Semantic_Types.Type_Index := 3;
     15
     16   ---------
     17   -- Get --
     18   ---------
     19
     20   not overriding function Get
     21     (Self     : access Type_Manager;
     22      Category : Gela.Type_Views.Category_Kinds;
     23      Decl     : Gela.Elements.Full_Type_Declarations
     24      .Full_Type_Declaration_Access)
     25      return Gela.Semantic_Types.Type_Index
     26   is
     27      use type Gela.Semantic_Types.Type_Index;
     28
     29      Key : constant Back_Key := (Category, Decl);
     30      Pos : constant Back_Maps.Cursor := Self.Back.Find (Key);
     31      Result : constant Gela.Semantic_Types.Type_Index :=
     32        Self.Map.Last_Key + 1;
     33   begin
     34      if Back_Maps.Has_Element (Pos) then
     35         return Back_Maps.Element (Pos);
     36      end if;
     37
     38      Self.Map.Insert
     39        (Result,
     40         Gela.Plain_Type_Views.Create_Full_Type (Category, Decl));
     41
     42      Self.Back.Insert (Key, Result);
     43
     44      return Result;
     45   end Get;
    1546
    1647   ---------
     
    3162      end if;
    3263   end Get;
     64
     65   ----------
     66   -- Hash --
     67   ----------
     68
     69   function Hash (Key : Back_Key) return Ada.Containers.Hash_Type is
     70      use type Ada.Containers.Hash_Type;
     71   begin
     72      return Key.Decl.Hash + Gela.Type_Views.Category_Kinds'Pos (Key.Category);
     73   end Hash;
    3374
    3475   ----------------
     
    108149      return Gela.Semantic_Types.Type_Index
    109150   is
    110       pragma Unreferenced (Self);
    111151
    112152      package Visiters is
     
    119159            Node : not null Gela.Elements.Full_Type_Declarations.
    120160              Full_Type_Declaration_Access);
     161
     162         overriding procedure Record_Type_Definition
     163           (Self : in out Visiter;
     164            Node : not null Gela.Elements.Record_Type_Definitions.
     165              Record_Type_Definition_Access);
    121166
    122167         overriding procedure Root_Type_Definition
     
    148193         end Full_Type_Declaration;
    149194
     195         ----------------------------
     196         -- Record_Type_Definition --
     197         ----------------------------
     198
     199         overriding procedure Record_Type_Definition
     200           (Self : in out Visiter;
     201            Node : not null Gela.Elements.Record_Type_Definitions.
     202              Record_Type_Definition_Access) is
     203         begin
     204            Self.Result := Type_From_Declaration.Self.Get
     205              (Category => Gela.Type_Views.A_Untagged_Record,
     206               Decl     => Gela.Elements.Full_Type_Declarations.
     207                 Full_Type_Declaration_Access (Node.Enclosing_Element));
     208         end Record_Type_Definition;
     209
    150210         --------------------------
    151211         -- Root_Type_Definition --
  • trunk/ada-2012/src/semantic/gela-plain_type_managers.ads

    r318 r391  
    22
    33with Ada.Containers.Ordered_Maps;
     4with Ada.Containers.Hashed_Maps;
    45
    56with Gela.Contexts;
    67with Gela.Elements.Defining_Names;
     8with Gela.Elements.Full_Type_Declarations;
    79with Gela.Elements.Subtype_Marks;
    810with Gela.Semantic_Types;
     
    3032         "="          => Gela.Type_Views."=");
    3133
     34   type Back_Key is record
     35      Category : Gela.Type_Views.Category_Kinds;
     36      Decl     : Gela.Elements.Full_Type_Declarations
     37        .Full_Type_Declaration_Access;
     38   end record;
     39
     40   function Hash (Key : Back_Key) return Ada.Containers.Hash_Type;
     41
     42   package Back_Maps is new Ada.Containers.Hashed_Maps
     43     (Key_Type        => Back_Key,
     44      Element_Type    => Gela.Semantic_Types.Type_Index,
     45      Hash            => Hash,
     46      Equivalent_Keys => "=",
     47      "="             => Gela.Semantic_Types."=");
     48
    3249   type Type_Manager (Context : Gela.Contexts.Context_Access) is
    3350     new Gela.Type_Managers.Type_Manager with
    3451   record
    35       Map : Type_View_Maps.Map;
     52       Map  : Type_View_Maps.Map;
     53       Back : Back_Maps.Map;
    3654   end record;
     55
     56   not overriding function Get
     57     (Self     : access Type_Manager;
     58      Category : Gela.Type_Views.Category_Kinds;
     59      Decl     : Gela.Elements.Full_Type_Declarations
     60      .Full_Type_Declaration_Access)
     61        return Gela.Semantic_Types.Type_Index;
    3762
    3863   overriding function Get
  • trunk/ada-2012/src/semantic/gela-plain_type_views.adb

    r282 r391  
     1with Gela.Element_Visiters;
     2with Gela.Elements.Discriminant_Parts;
     3with Gela.Elements.Known_Discriminant_Parts;
     4with Gela.Elements.Discriminant_Specifications;
     5with Gela.Elements.Defining_Identifiers;
     6
    17package body Gela.Plain_Type_Views is
    28
     
    2935   end Create_Full_Type;
    3036
     37   ----------------------
     38   -- Get_Discriminant --
     39   ----------------------
     40
     41   overriding function Get_Discriminant
     42     (Self   : Type_View;
     43      Symbol : Gela.Lexical_Types.Symbol)
     44      return Gela.Elements.Defining_Names.Defining_Name_Access
     45   is
     46      package Get is
     47         type Visiter is new Gela.Element_Visiters.Visiter with record
     48            Result : Gela.Elements.Defining_Identifiers.
     49              Defining_Identifier_Access;
     50         end record;
     51
     52         overriding procedure Known_Discriminant_Part
     53           (Self : in out Visiter;
     54            Node : not null Gela.Elements.Known_Discriminant_Parts.
     55              Known_Discriminant_Part_Access);
     56      end Get;
     57
     58      package body Get is
     59
     60         overriding procedure Known_Discriminant_Part
     61           (Self : in out Visiter;
     62            Node : not null Gela.Elements.Known_Discriminant_Parts.
     63              Known_Discriminant_Part_Access)
     64         is
     65            List : constant Gela.Elements.Discriminant_Specifications.
     66              Discriminant_Specification_Sequence_Access := Node.Discriminants;
     67            Cursor : Gela.Elements.Discriminant_Specifications.
     68              Discriminant_Specification_Sequence_Cursor := List.First;
     69         begin
     70            while Cursor.Has_Element loop
     71               declare
     72                  use type Gela.Lexical_Types.Symbol;
     73                  Names : constant Gela.Elements.Defining_Identifiers.
     74                    Defining_Identifier_Sequence_Access :=
     75                      Cursor.Element.Names;
     76                  Pos : Gela.Elements.Defining_Identifiers.
     77                    Defining_Identifier_Sequence_Cursor := Names.First;
     78               begin
     79                  while Pos.Has_Element loop
     80                     if Pos.Element.Full_Name = Symbol then
     81                        Self.Result := Pos.Element;
     82
     83                        return;
     84                     end if;
     85
     86                     Pos.Next;
     87                  end loop;
     88
     89                  Cursor.Next;
     90               end;
     91            end loop;
     92         end Known_Discriminant_Part;
     93      end Get;
     94
     95      X : constant Gela.Elements.Discriminant_Parts.
     96        Discriminant_Part_Access := Self.Decl.Discriminant_Part;
     97      V : Get.Visiter;
     98   begin
     99      if X.Assigned then
     100         X.Visit (V);
     101         return Gela.Elements.Defining_Names.Defining_Name_Access (V.Result);
     102      else
     103         return null;
     104      end if;
     105   end Get_Discriminant;
     106
    31107end Gela.Plain_Type_Views;
  • trunk/ada-2012/src/semantic/gela-plain_type_views.ads

    r282 r391  
     1with Gela.Elements.Defining_Names;
     2with Gela.Elements.Full_Type_Declarations;
     3with Gela.Lexical_Types;
    14with Gela.Type_Views;
    2 with Gela.Elements.Full_Type_Declarations;
    35
    46package Gela.Plain_Type_Views is
     
    2527     (Self : Type_View) return Gela.Type_Views.Category_Kinds;
    2628
     29   overriding function Get_Discriminant
     30     (Self   : Type_View;
     31      Symbol : Gela.Lexical_Types.Symbol)
     32      return Gela.Elements.Defining_Names.Defining_Name_Access;
     33
    2734end Gela.Plain_Type_Views;
  • trunk/ada-2012/src/semantic/gela-plian_int_sets.adb

    r367 r391  
    33with Gela.Int.Expressions;
    44with Gela.Int.Placeholders;
     5with Gela.Int.Symbols;
    56with Gela.Int.Tuples;
    67with Gela.Int.Visiters;
     
    230231            Value : Gela.Int.Placeholders.Placeholder);
    231232
     233         overriding procedure Symbol
     234           (Self  : access Visiter;
     235            Value : Gela.Int.Symbols.Symbol);
     236
    232237         overriding procedure Tuple
    233238           (Self  : access Visiter;
     
    282287         end Placeholder;
    283288
     289         overriding procedure Symbol
     290           (Self  : access Visiter;
     291            Value : Gela.Int.Symbols.Symbol)
     292         is
     293            pragma Unreferenced (Self);
     294         begin
     295            Target.On_Symbol
     296              (Symbol => Value.Get_Symbol,
     297               Down   => Value.Down);
     298         end Symbol;
     299
    284300         overriding procedure Tuple
    285301           (Self  : access Visiter;
  • trunk/ada-2012/src/semantic/gela-resolve.adb

    r389 r391  
    77with Gela.Environments;
    88with Gela.Type_Managers;
     9with Gela.Type_Views;
    910
    1011package body Gela.Resolve is
     
    134135         type Visiter is new Gela.Interpretations.Visiter with record
    135136            Comp       : Gela.Compilations.Compilation_Access;
     137            IM         : Gela.Interpretations.Interpretation_Manager_Access;
    136138            Level      : Positive;
    137139            Type_Index : Gela.Semantic_Types.Type_Index;
     
    145147            Down  : Gela.Interpretations.Interpretation_Index_Array);
    146148
     149         overriding procedure On_Symbol
     150           (Self   : in out Visiter;
     151            Symbol : Gela.Lexical_Types.Symbol;
     152            Down   : Gela.Interpretations.Interpretation_Index_Array);
     153
    147154      end Each_Tuple;
    148155
     
    160167            Index         : Gela.Interpretations.Interpretation_Index;
    161168            Tuple_Visiter : aliased Each_Tuple.Visiter :=
    162               (Comp => Self.Comp, Level => 1, others => <>);
     169              (Comp => Self.Comp, IM => IM, Level => 1, others => <>);
    163170            Cursor        : Gela.Interpretations.Cursor'Class :=
    164171              IM.Get_Cursor (Constr);
     
    218225
    219226      package body Each_Tuple is
     227
     228         --  Example:                   Level = 2 --+
     229         --           My_Record                     v
     230         --             (Discriminant_1 | Discriminant_2 => 5,  <-- Level = 1
     231         --              Discriminant_3 | Discriminant_4 => 6); <-- Level = 1
     232         --               ^
     233         --               +---- Level = 2
     234
     235         overriding procedure On_Symbol
     236           (Self   : in out Visiter;
     237            Symbol : Gela.Lexical_Types.Symbol;
     238            Down   : Gela.Interpretations.Interpretation_Index_Array)
     239         is
     240            pragma Unreferenced (Down);
     241            TM : constant Gela.Type_Managers.Type_Manager_Access :=
     242              Self.Comp.Context.Types;
     243            Type_View : constant Gela.Type_Views.Type_View_Access :=
     244              TM.Get (Self.Type_Index);
     245            Name : constant Gela.Elements.Defining_Names.Defining_Name_Access
     246              := Type_View.Get_Discriminant (Symbol);
     247         begin
     248            if Name.Assigned then
     249               Self.IM.Get_Defining_Name_Index (Name, Self.Index);
     250            else
     251               Self.Index := 0;
     252            end if;
     253         end On_Symbol;
    220254
    221255         overriding procedure On_Tuple
     
    261295            else
    262296               declare
     297                  use type Gela.Semantic_Types.Type_Index;
     298
    263299                  Chosen : Gela.Interpretations.Interpretation_Index;
    264300                  List   : Gela.Interpretations.Interpretation_Index_Array
     
    272308                        List (J) := 0;
    273309                        while Cursor.Has_Element loop
    274                            List (J) := Cursor.Get_Index;
     310                           if J = Value'First or Self.Type_Index = 0 then
     311                              --  expression of association or
     312                              --  something went wrong
     313                              List (J) := Cursor.Get_Index;
     314                           else
     315                              Cursor.Visit (Self'Access);
     316                              List (J) := Self.Index;
     317                           end if;
     318
    275319                           Cursor.Next;
    276320                        end loop;
     
    327371   begin
    328372      Set := 0;
     373      IM.Add_Symbol (Symbol, Set);
    329374
    330375      while DV.Has_Element loop
     
    414459      Set    : out Gela.Interpretations.Interpretation_Set_Index)
    415460   is
    416       pragma Unreferenced (Env);
    417461
    418462      use type Gela.Interpretations.Interpretation_Index_Array;
     
    420464      No_Args_Allowed : constant Boolean := True;
    421465      --  FIXME Replace with actual check
     466
     467      package Each_Prefix is
     468         type Visiter is new Gela.Interpretations.Visiter with record
     469            Index  : Gela.Interpretations.Interpretation_Index := 0;
     470         end record;
     471
     472         overriding procedure On_Defining_Name
     473           (Self   : in out Visiter;
     474            Name   : Gela.Elements.Defining_Names.Defining_Name_Access;
     475            Down   : Gela.Interpretations.Interpretation_Index_Array);
     476
     477      end Each_Prefix;
    422478
    423479      package Each_Arg is
     
    498554         begin
    499555            for J in Value'Range loop
    500                declare
    501                   Cursor : constant Gela.Interpretations.Cursor'Class :=
    502                     IM.Get_Cursor (Value (J));
    503                begin
    504                   List (J) := Cursor.Get_Index;
    505                end;
     556               Interpretation
     557                 (Comp   => Comp,
     558                  Env    => Env,
     559                  Set    => Value (J),
     560                  Result => List (J));
    506561            end loop;
    507562
     
    517572      end Each_Association;
    518573
    519       Cursor  : Gela.Interpretations.Cursor'Class := IM.Get_Cursor (Prefix);
    520    begin
    521       Set := 0;
    522 
    523       while Cursor.Has_Element loop
    524          declare
    525             Visiter : aliased Each_Arg.Visiter := (Index => Cursor.Get_Index);
     574      package body Each_Prefix is
     575
     576         overriding procedure On_Defining_Name
     577           (Self   : in out Visiter;
     578            Name   : Gela.Elements.Defining_Names.Defining_Name_Access;
     579            Down   : Gela.Interpretations.Interpretation_Index_Array)
     580         is
     581            pragma Unreferenced (Name, Down);
     582            Visiter : aliased Each_Arg.Visiter := (Index => Self.Index);
    526583            Arg     : Gela.Interpretations.Cursor'Class :=
    527584              IM.Get_Cursor (Args);
     
    538595                  Result => Set);
    539596            end if;
    540 
     597         end On_Defining_Name;
     598
     599      end Each_Prefix;
     600
     601      Cursor  : Gela.Interpretations.Cursor'Class := IM.Get_Cursor (Prefix);
     602   begin
     603      Set := 0;
     604
     605      while Cursor.Has_Element loop
     606         declare
     607            Visiter : aliased Each_Prefix.Visiter :=
     608              (Index => Cursor.Get_Index);
     609         begin
     610            Cursor.Visit (Visiter'Access);
    541611            Cursor.Next;
    542612         end;
     
    617687      pragma Unreferenced (Env);
    618688
     689      package Each is
     690         type Visiter is new Gela.Interpretations.Visiter with record
     691            Prev   : Gela.Interpretations.Interpretation_Index := 0;
     692            Result : Gela.Interpretations.Interpretation_Index := 0;
     693         end record;
     694
     695         overriding procedure On_Symbol
     696           (Self   : in out Visiter;
     697            Symbol : Gela.Lexical_Types.Symbol;
     698            Down   : Gela.Interpretations.Interpretation_Index_Array);
     699
     700      end Each;
     701
     702      package body Each is
     703
     704         overriding procedure On_Symbol
     705           (Self   : in out Visiter;
     706            Symbol : Gela.Lexical_Types.Symbol;
     707            Down   : Gela.Interpretations.Interpretation_Index_Array)
     708         is
     709            pragma Unreferenced (Symbol, Down);
     710         begin
     711            --  Skip symbos
     712            Self.Result := Self.Prev;
     713         end On_Symbol;
     714
     715      end Each;
     716
    619717      IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
    620718        Comp.Context.Interpretation_Manager;
    621719
    622       Cursor : constant Gela.Interpretations.Cursor'Class :=
     720      Cursor : Gela.Interpretations.Cursor'Class :=
    623721        IM.Get_Cursor (Set);
    624722
    625    begin
    626       if Cursor.Has_Element then
    627          Result := Cursor.Get_Index;
    628       else
    629          Result := 0;
    630       end if;
     723      Visiter : aliased Each.Visiter;
     724   begin
     725      while Cursor.Has_Element loop
     726         Visiter.Result := Cursor.Get_Index;
     727         Cursor.Visit (Visiter'Access);
     728         Visiter.Prev := Visiter.Result;
     729         Cursor.Next;
     730      end loop;
     731
     732      Result := Visiter.Result;
    631733   end Interpretation;
    632734
Note: See TracChangeset for help on using the changeset viewer.