diff options
| -rw-r--r-- | gcc/ada/atree.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/atree.ads | 4 | ||||
| -rw-r--r-- | gcc/ada/gen_il-gen.adb | 44 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 6 |
4 files changed, 40 insertions, 20 deletions
diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index 608819b..541655c 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -139,10 +139,6 @@ package body Atree is -- Local Subprograms -- ----------------------- - function Is_Entity (N : Node_Or_Entity_Id) return Boolean; - pragma Inline (Is_Entity); - -- Returns True if N is an entity - function Allocate_New_Node (Kind : Node_Kind) return Node_Id; pragma Inline (Allocate_New_Node); -- Allocate a new node or first part of a node extension. Initialize the @@ -1435,7 +1431,7 @@ package body Atree is -- Is_Entity -- --------------- - function Is_Entity (N : Node_Id) return Boolean is + function Is_Entity (N : Node_Or_Entity_Id) return Boolean is begin return Nkind (N) in N_Entity; end Is_Entity; diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index e2d3492..c814c80 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -222,6 +222,10 @@ package Atree is -- Called to unlock node modifications when assertions are enabled; if -- assertions are not enabled calling this subprogram has no effect. + function Is_Entity (N : Node_Or_Entity_Id) return Boolean; + pragma Inline (Is_Entity); + -- Returns True if N is an entity + function New_Node (New_Node_Kind : Node_Kind; New_Sloc : Source_Ptr) return Node_Id; diff --git a/gcc/ada/gen_il-gen.adb b/gcc/ada/gen_il-gen.adb index 5b2a17b..7055729 100644 --- a/gcc/ada/gen_il-gen.adb +++ b/gcc/ada/gen_il-gen.adb @@ -1508,20 +1508,31 @@ package body Gen_IL.Gen is end Put_Getter_Decl; procedure Put_Getter_Body (S : in out Sink'Class; F : Field_Enum) is + Rec : Field_Info renames Field_Table (F).all; begin + -- Note that we store the result in a local constant below, so that + -- the "Pre => ..." can refer to it. The constant is called Val so + -- that it has the same name as the formal of the setter, so the + -- "Pre => ..." can refer to it by the same name in both getter + -- and setter. + Put_Getter_Spec (S, F); Put (S, " is\n"); + Indent (S, 3); + Put (S, "Val : constant \1 := \2 (\3, \4);\n", + Get_Set_Id_Image (Rec.Field_Type), + Low_Level_Getter (Rec.Field_Type), + Node_To_Fetch_From (F), + Image (Rec.Offset)); + Outdent (S, 3); Put (S, "begin\n"); Indent (S, 3); - if Field_Table (F).Pre.all /= "" then - Put (S, "pragma Assert (\1);\n", Field_Table (F).Pre.all); + if Rec.Pre.all /= "" then + Put (S, "pragma Assert (\1);\n", Rec.Pre.all); end if; - Put (S, "return \1 (\2, \3);\n", - Low_Level_Getter (Field_Table (F).Field_Type), - Node_To_Fetch_From (F), - Image (Field_Table (F).Offset)); + Put (S, "return Val;\n"); Outdent (S, 3); Put (S, "end \1;\n\n", Image (F)); end Put_Getter_Body; @@ -1529,7 +1540,7 @@ package body Gen_IL.Gen is procedure Put_Setter_Spec (S : in out Sink'Class; F : Field_Enum) is Rec : Field_Info renames Field_Table (F).all; Default : constant String := - (if Field_Table (F).Field_Type = Flag then " := True" else ""); + (if Rec.Field_Type = Flag then " := True" else ""); begin Put (S, "procedure Set_\1\n", Image (F)); Indent (S, 2); @@ -1550,11 +1561,13 @@ package body Gen_IL.Gen is end Put_Setter_Decl; procedure Put_Setter_Body (S : in out Sink'Class; F : Field_Enum) is + Rec : Field_Info renames Field_Table (F).all; + -- If Type_Only was specified in the call to Create_Semantic_Field, -- then we assert that the node is a base (etc) type. Type_Only_Assertion : constant String := - (case Field_Table (F).Type_Only is + (case Rec.Type_Only is when No_Type_Only => "", when Base_Type_Only => "Is_Base_Type (N)", -- ????It seems like we should call Is_Implementation_Base_Type or @@ -1570,8 +1583,8 @@ package body Gen_IL.Gen is Put (S, "begin\n"); Indent (S, 3); - if Field_Table (F).Pre.all /= "" then - Put (S, "pragma Assert (\1);\n", Field_Table (F).Pre.all); + if Rec.Pre.all /= "" then + Put (S, "pragma Assert (\1);\n", Rec.Pre.all); end if; if Type_Only_Assertion /= "" then @@ -1580,7 +1593,7 @@ package body Gen_IL.Gen is Put (S, "\1 (N, \2, Val);\n", Low_Level_Setter (F), - Image (Field_Table (F).Offset)); + Image (Rec.Offset)); Outdent (S, 3); Put (S, "end Set_\1;\n\n", Image (F)); end Put_Setter_Body; @@ -2034,9 +2047,11 @@ package body Gen_IL.Gen is begin Put (S, "with Seinfo; use Seinfo;\n"); - Put (S, "pragma Warnings (Off); -- ????\n"); + Put (S, "pragma Warnings (Off);\n"); + -- With's included in case they are needed; so we don't have to keep + -- switching back and forth. Put (S, "with Output; use Output;\n"); - Put (S, "pragma Warnings (On); -- ????\n"); + Put (S, "pragma Warnings (On);\n"); Put (S, "\npackage Sinfo.Nodes is\n\n"); Indent (S, 3); @@ -2061,6 +2076,9 @@ package body Gen_IL.Gen is Put (B, "with Atree; use Atree; use Atree.Atree_Private_Part;\n"); Put (B, "with Nlists; use Nlists;\n"); + Put (B, "pragma Warnings (Off);\n"); + Put (B, "with Einfo.Utils; use Einfo.Utils;\n"); + Put (B, "pragma Warnings (On);\n"); Put (B, "\npackage body Sinfo.Nodes is\n\n"); Indent (B, 3); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 73a7bd1..01690f3 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -26215,7 +26215,9 @@ package body Sem_Util is Part_IP := Partial_Invariant_Procedure (From_Typ); -- The setting of the attributes is intentionally conservative. This - -- prevents accidental clobbering of enabled attributes. + -- prevents accidental clobbering of enabled attributes. We need to + -- call Base_Type twice, because it is sometimes not set to an actual + -- base type. if Has_Inheritable_Invariants (From_Typ) then Set_Has_Inheritable_Invariants (Typ); @@ -26226,7 +26228,7 @@ package body Sem_Util is end if; if Has_Own_Invariants (From_Typ) then - Set_Has_Own_Invariants (Base_Type (Typ)); + Set_Has_Own_Invariants (Base_Type (Base_Type (Typ))); end if; if Present (Full_IP) and then No (Invariant_Procedure (Typ)) then |