Changeset 405


Ignore:
Timestamp:
Feb 28, 2015, 7:17:02 AM (5 years ago)
Author:
Maxim Reznik
Message:

Add interpretation for signed integer types

Location:
trunk/ada-2012
Files:
9 edited

Legend:

Unmodified
Added
Removed
  • trunk/ada-2012/src/ag/down.ag

    r397 r405  
    10081008Rules for signed_integer_type_definition. :
    10091009(.
    1010       ${Integer_Constraint.Down} := 0;  --  FIXME
     1010      Gela.Pass_Utils.Resolve.Signed_Integer_Type
     1011        (Self.Compilation,
     1012         ${Integer_Constraint.Up},
     1013         ${Integer_Constraint.Down});
    10111014.)
    10121015
  • trunk/ada-2012/src/api/gela-interpretations.ads

    r404 r405  
    110110      Down   : Gela.Interpretations.Interpretation_Index_Array) is null;
    111111   --  Called for each expression interpretation
     112
     113   not overriding procedure On_Expression_Category
     114     (Self   : in out Down_Visiter;
     115      Kinds  : Gela.Type_Views.Category_Kind_Set;
     116      Down   : Gela.Interpretations.Interpretation_Index_Array) is null;
     117   --  Called for each category of expression interpretation
    112118
    113119   not overriding procedure On_Attr_Function
  • trunk/ada-2012/src/api/gela-type_views.ads

    r403 r405  
    1010   type Type_View_Access is access all Type_View'Class;
    1111   for Type_View_Access'Storage_Size use 0;
     12
     13   function Assigned (Self : access Type_View'Class) return Boolean
     14     is (Self /= null);
    1215
    1316   type Category_Kinds is
     
    3841      An_Incomplete);
    3942
    40    type Category_Kind_Set is array (Category_Kinds) of Boolean;
     43   type Category_Kind_Set is array (Category_Kinds) of Boolean with Pack;
     44
     45   subtype An_Integer is Category_Kinds
     46     range An_Universal_Integer .. A_Modular_Integer;
    4147
    4248   not overriding function Category
  • trunk/ada-2012/src/semantic/gela-debug_properties.adb

    r404 r405  
    88with Gela.Property_Visiters;
    99with Gela.Semantic_Types;
     10with Gela.Type_Views;
    1011
    1112package body Gela.Debug_Properties is
     
    9091        (Self   : in out Visiter;
    9192         Tipe   : Gela.Semantic_Types.Type_Index;
     93         Cursor : Gela.Interpretations.Cursor'Class);
     94
     95      overriding procedure On_Expression_Category
     96        (Self   : in out Visiter;
     97         Kinds  : Gela.Type_Views.Category_Kind_Set;
    9298         Cursor : Gela.Interpretations.Cursor'Class);
    9399
     
    307313         Put_Line ("   Expression ");
    308314      end On_Expression;
     315
     316      overriding procedure On_Expression_Category
     317        (Self   : in out Visiter;
     318         Kinds  : Gela.Type_Views.Category_Kind_Set;
     319         Cursor : Gela.Interpretations.Cursor'Class)
     320      is
     321         pragma Unreferenced (Self, Cursor);
     322      begin
     323         Put_Line ("   Expression_Category: ");
     324         for J in Kinds'Range loop
     325            if Kinds (J) then
     326               Put_Line ("      " & Gela.Type_Views.Category_Kinds'Image (J));
     327            end if;
     328         end loop;
     329      end On_Expression_Category;
    309330
    310331      overriding procedure On_Attr_Function
  • trunk/ada-2012/src/semantic/gela-plain_interpretations.adb

    r404 r405  
    476476            pragma Unreferenced (Self);
    477477         begin
    478             raise Program_Error with "Unexpected up interpretation in down";
     478            Target.On_Expression_Category
     479              (Kinds => Value.Kinds,
     480               Down  => Value.Down);
    479481         end Expression_Category;
    480482
  • trunk/ada-2012/src/semantic/gela-resolve.adb

    r404 r405  
    10371037   end Shall_Be_Subtype;
    10381038
     1039   -------------------------
     1040   -- Signed_Integer_Type --
     1041   -------------------------
     1042
     1043   procedure Signed_Integer_Type
     1044     (Comp     : Gela.Compilations.Compilation_Access;
     1045      Up       : Gela.Interpretations.Interpretation_Set_Index;
     1046      Result   : out Gela.Interpretations.Interpretation_Index)
     1047   is
     1048
     1049      package Each is
     1050         type Visiter is new Gela.Interpretations.Up_Visiter with null record;
     1051
     1052         overriding procedure On_Expression_Category
     1053           (Self   : in out Visiter;
     1054            Kinds  : Gela.Type_Views.Category_Kind_Set;
     1055            Cursor : Gela.Interpretations.Cursor'Class);
     1056
     1057      end Each;
     1058
     1059      ----------
     1060      -- Each --
     1061      ----------
     1062
     1063      package body Each is
     1064
     1065         overriding procedure On_Expression_Category
     1066           (Self   : in out Visiter;
     1067            Kinds  : Gela.Type_Views.Category_Kind_Set;
     1068            Cursor : Gela.Interpretations.Cursor'Class)
     1069         is
     1070            pragma Unreferenced (Self);
     1071         begin
     1072            if Kinds (Gela.Type_Views.A_Signed_Integer) then
     1073               Result := Cursor.Get_Index;
     1074            end if;
     1075         end On_Expression_Category;
     1076
     1077      end Each;
     1078
     1079      IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
     1080        Comp.Context.Interpretation_Manager;
     1081
     1082      Cursor  : Gela.Interpretations.Cursor'Class := IM.Get_Cursor (Up);
     1083      Visiter : aliased Each.Visiter;
     1084   begin
     1085      Result := 0;
     1086
     1087      while Cursor.Has_Element loop
     1088         Cursor.Visit (Visiter'Access);
     1089         Cursor.Next;
     1090      end loop;
     1091   end Signed_Integer_Type;
     1092
    10391093   -----------------------------
    10401094   -- Simple_Expression_Range --
     
    10491103   is
    10501104      pragma Unreferenced (Env);
    1051       IM : constant Gela.Interpretations.Interpretation_Manager_Access :=
    1052         Comp.Context.Interpretation_Manager;
    1053 
    1054       Cursor_Left  : Gela.Interpretations.Cursor'Class := IM.Get_Cursor (Left);
    1055       Cursor_Right : Gela.Interpretations.Cursor'Class :=
    1056         IM.Get_Cursor (Right);
    1057 
     1105
     1106      package Each_Left is
     1107         type Visiter is new Gela.Interpretations.Up_Visiter with record
     1108            Left_Int_Index  : Gela.Interpretations.Interpretation_Index;
     1109            Left_Int_Count  : Natural := 0;
     1110            Right_Int_Index : Gela.Interpretations.Interpretation_Index;
     1111            Right_Int_Count : Natural := 0;
     1112         end record;
     1113
     1114         overriding procedure On_Expression
     1115           (Self   : in out Visiter;
     1116            Tipe   : Gela.Semantic_Types.Type_Index;
     1117            Cursor : Gela.Interpretations.Cursor'Class);
     1118
     1119      end Each_Left;
     1120
     1121      TM : constant Gela.Type_Managers.Type_Manager_Access :=
     1122        Comp.Context.Types;
     1123
     1124      package body Each_Left is
     1125
     1126         overriding procedure On_Expression
     1127           (Self   : in out Visiter;
     1128            Tipe   : Gela.Semantic_Types.Type_Index;
     1129            Cursor : Gela.Interpretations.Cursor'Class)
     1130         is
     1131
     1132            Left_Cursor : Gela.Interpretations.Cursor'Class renames Cursor;
     1133
     1134            package Each_Right is
     1135               type Visiter is new Gela.Interpretations.Up_Visiter with record
     1136                  Tipe      : Gela.Semantic_Types.Type_Index;
     1137                  Int_Index : Gela.Interpretations.Interpretation_Index;
     1138                  Int_Count : Natural := 0;
     1139               end record;
     1140
     1141               overriding procedure On_Expression
     1142                 (Self   : in out Visiter;
     1143                  Tipe   : Gela.Semantic_Types.Type_Index;
     1144                  Cursor : Gela.Interpretations.Cursor'Class);
     1145
     1146            end Each_Right;
     1147
     1148            package body Each_Right is
     1149
     1150               overriding procedure On_Expression
     1151                 (Self   : in out Visiter;
     1152                  Tipe   : Gela.Semantic_Types.Type_Index;
     1153                  Cursor : Gela.Interpretations.Cursor'Class)
     1154               is
     1155                  Type_View : constant Gela.Type_Views.Type_View_Access :=
     1156                    TM.Get (Tipe);
     1157               begin
     1158                  if Type_View.Assigned and then
     1159                    Type_View.Category in Gela.Type_Views.An_Integer
     1160                  then
     1161                     Self.Int_Index := Cursor.Get_Index;
     1162                     Self.Int_Count := Self.Int_Count + 1;
     1163                  else  --  FIXME Drop after implementation of types
     1164                     Self.Int_Index := Cursor.Get_Index;
     1165                     Self.Int_Count := Self.Int_Count + 1;
     1166                  end if;
     1167
     1168                  Comp.Context.Interpretation_Manager.Add_Expression
     1169                    (Tipe   => Tipe,
     1170                     Down   => (Left_Cursor.Get_Index, Cursor.Get_Index),
     1171                     Result => Set);
     1172               end On_Expression;
     1173
     1174            end Each_Right;
     1175
     1176            Type_View : constant Gela.Type_Views.Type_View_Access :=
     1177              TM.Get (Tipe);
     1178
     1179            Visiter_Right : aliased Each_Right.Visiter :=
     1180              (Tipe => Tipe, others => <>);
     1181         begin
     1182            Each_Expression
     1183              (Comp   => Comp,
     1184               Set    => Right,
     1185               Target => Visiter_Right);
     1186
     1187            if Type_View.Assigned and then
     1188              Type_View.Category in Gela.Type_Views.An_Integer
     1189            then
     1190               Self.Left_Int_Index := Cursor.Get_Index;
     1191               Self.Left_Int_Count := Self.Left_Int_Count + 1;
     1192               Self.Right_Int_Index := Visiter_Right.Int_Index;
     1193               Self.Right_Int_Count := Visiter_Right.Int_Count;
     1194            else  --  FIXME Drop after implementation of types
     1195               Self.Left_Int_Index := Cursor.Get_Index;
     1196               Self.Left_Int_Count := Self.Left_Int_Count + 1;
     1197               Self.Right_Int_Index := Visiter_Right.Int_Index;
     1198               Self.Right_Int_Count := Visiter_Right.Int_Count;
     1199            end if;
     1200         end On_Expression;
     1201
     1202      end Each_Left;
     1203
     1204      Visiter : aliased Each_Left.Visiter;
    10581205   begin
    10591206      Set := 0;
    1060       while Cursor_Left.Has_Element loop
    1061          while Cursor_Right.Has_Element loop
    1062             --  FIX ME: compare types of left and right interpretation
    1063             Comp.Context.Interpretation_Manager.Add_Expression
    1064               (Tipe   => 0,
    1065                Down   => (Cursor_Left.Get_Index,
    1066                           Cursor_Right.Get_Index),
    1067                Result => Set);
    1068 
    1069             Cursor_Right.Next;
    1070          end loop;
    1071 
    1072          Cursor_Left.Next;
    1073       end loop;
     1207      Each_Expression
     1208        (Comp   => Comp,
     1209         Set    => Left,
     1210         Target => Visiter);
     1211
     1212      if Visiter.Left_Int_Count = 1 and Visiter.Right_Int_Count = 1 then
     1213         Comp.Context.Interpretation_Manager.Add_Expression_Category
     1214           (Kinds  =>
     1215              (Gela.Type_Views.A_Signed_Integer => True, others => False),
     1216            Down   => (Visiter.Left_Int_Index, Visiter.Right_Int_Index),
     1217            Result => Set);
     1218      end if;
    10741219   end Simple_Expression_Range;
    10751220
  • trunk/ada-2012/src/semantic/gela-resolve.ads

    r395 r405  
    122122   procedure Assignment_Right
    123123     (Comp     : Gela.Compilations.Compilation_Access;
    124       Env        : Gela.Semantic_Types.Env_Index;
     124      Env      : Gela.Semantic_Types.Env_Index;
    125125      Left     : Gela.Interpretations.Interpretation_Set_Index;
    126126      Right    : Gela.Interpretations.Interpretation_Set_Index;
    127127      Result   : out Gela.Interpretations.Interpretation_Index);
    128128
     129   procedure Signed_Integer_Type
     130     (Comp     : Gela.Compilations.Compilation_Access;
     131      Up       : Gela.Interpretations.Interpretation_Set_Index;
     132      Result   : out Gela.Interpretations.Interpretation_Index);
     133
    129134end Gela.Resolve;
  • trunk/ada-2012/tests/asis/asis2xml.gpl/list.txt

    r402 r405  
    99./A/A34017C.ADA 3218990317
    1010./A/A35101B.ADA 3952123876
     11./A/A35402A.ADA 847347084
  • trunk/ada-2012/tests/asis/def_name/list.txt

    r402 r405  
    99./A/A34017C.ADA +1820504207
    1010./A/A35101B.ADA +3960786450
    11 ./A/A35402A.ADA 4131699407
     11./A/A35402A.ADA +3341560208
    1212./A/A35801F.ADA 4055769666
    1313./A/A35902C.ADA 540739767
Note: See TracChangeset for help on using the changeset viewer.