-- Vax_Float Flag151
-- Entry_Accepted Flag152
- -- Is_Psected Flag153
-- Has_Per_Object_Constraint Flag154
-- Has_Private_Declaration Flag155
-- Referenced Flag156
-- Has_Xref_Entry Flag182
-- Must_Be_On_Byte_Boundary Flag183
- -- Note: there are no unused flags currently!
+ -- (unused) Flag153
--------------------------------
-- Attribute Access Functions --
return Flag53 (Id);
end Is_Private_Descendant;
- function Is_Psected (Id : E) return B is
- begin
- return Flag153 (Id);
- end Is_Psected;
-
function Is_Public (Id : E) return B is
begin
pragma Assert (Nkind (Id) in N_Entity);
Set_Flag53 (Id, V);
end Set_Is_Private_Descendant;
- procedure Set_Is_Psected (Id : E; V : B := True) is
- begin
- Set_Flag153 (Id, V);
- end Set_Is_Psected;
-
procedure Set_Is_Public (Id : E; V : B := True) is
begin
pragma Assert (Nkind (Id) in N_Entity);
-- Scans the Discriminants to see whether any are Completely_Hidden
-- (the mechanism for describing non-specified stored discriminants)
+ ----------------------------------------
+ -- Has_Completely_Hidden_Discriminant --
+ ----------------------------------------
+
function Has_Completely_Hidden_Discriminant (Id : E) return Boolean is
Ent : Entity_Id := Id;
pragma Assert (Ekind (Id) = E_Discriminant);
while Present (Ent) and then Ekind (Ent) = E_Discriminant loop
-
if Is_Completely_Hidden (Ent) then
return True;
end if;
-------------------------------------
function Get_Attribute_Definition_Clause
- (E : Entity_Id;
- Id : Attribute_Id)
- return Node_Id
+ (E : Entity_Id;
+ Id : Attribute_Id) return Node_Id
is
N : Node_Id;
--------------------
function Get_Rep_Pragma (E : Entity_Id; Nam : Name_Id) return Node_Id is
- N : Node_Id;
- Typ : Entity_Id;
+ N : Node_Id;
begin
N := First_Rep_Item (E);
-
while Present (N) loop
if Nkind (N) = N_Pragma and then Chars (N) = Nam then
-
- if Nam = Name_Stream_Convert then
-
- -- For tagged types this pragma is not inherited, so we
- -- must verify that it is defined for the given type and
- -- not an ancestor.
-
- Typ := Entity (Expression
- (First (Pragma_Argument_Associations (N))));
-
- if not Is_Tagged_Type (E)
- or else E = Typ
- or else (Is_Private_Type (Typ)
- and then E = Full_View (Typ))
- then
- return N;
- else
- Next_Rep_Item (N);
- end if;
-
- else
- return N;
- end if;
- else
- Next_Rep_Item (N);
+ return N;
end if;
+
+ Next_Rep_Item (N);
end loop;
return Empty;
return False;
end Has_Attach_Handler;
+ -------------------------------------
+ -- Has_Attribute_Definition_Clause --
+ -------------------------------------
+
+ function Has_Attribute_Definition_Clause
+ (E : Entity_Id;
+ Id : Attribute_Id) return Boolean
+ is
+ begin
+ return Present (Get_Attribute_Definition_Clause (E, Id));
+ end Has_Attribute_Definition_Clause;
+
-----------------
-- Has_Entries --
-----------------
begin
pragma Assert (Is_Concurrent_Type (Id));
- Ent := First_Entity (Id);
+ Ent := First_Entity (Id);
while Present (Ent) loop
if Is_Entry (Ent) then
Result := True;
end loop;
end Has_Private_Ancestor;
+ --------------------
+ -- Has_Rep_Pragma --
+ --------------------
+
+ function Has_Rep_Pragma (E : Entity_Id; Nam : Name_Id) return Boolean is
+ begin
+ return Present (Get_Rep_Pragma (E, Nam));
+ end Has_Rep_Pragma;
+
------------------------------
-- Implementation_Base_Type --
------------------------------
begin
Item := First_Rep_Item (Id);
-
while Present (Item) loop
if Nkind (Item) = N_Pragma
and then Get_Pragma_Id (Chars (Item)) = Pragma_Inline_Always
else
declare
- C : Entity_Id := First_Component (Btype);
+ C : Entity_Id;
begin
+ C := First_Component (Btype);
while Present (C) loop
if Is_By_Reference_Type (Etype (C))
or else Is_Volatile (Etype (C))
else
declare
- C : E := First_Component (Btype);
+ C : E;
begin
+ C := First_Component (Btype);
while Present (C) loop
if Is_Limited_Type (Etype (C)) then
return True;
else
declare
- C : Entity_Id := First_Component (Btype);
+ C : Entity_Id;
begin
+ C := First_Component (Btype);
while Present (C) loop
if Is_Return_By_Reference_Type (Etype (C)) then
return True;
begin
Comp_Id := Next_Entity (Id);
-
while Present (Comp_Id) loop
exit when Ekind (Comp_Id) = E_Component;
Comp_Id := Next_Entity (Comp_Id);
else
N := 0;
T := First_Index (Id);
-
while Present (T) loop
N := N + 1;
T := Next (T);
begin
N := 0;
Discr := First_Discriminant (Id);
-
while Present (Discr) loop
N := N + 1;
Discr := Next_Discriminant (Discr);
begin
pragma Assert (Is_Concurrent_Type (Id));
+
N := 0;
Ent := First_Entity (Id);
-
while Present (Ent) loop
if Is_Entry (Ent) then
N := N + 1;
begin
N := 0;
Formal := First_Formal (Id);
-
while Present (Formal) loop
N := N + 1;
Formal := Next_Formal (Formal);
return Ekind (Id);
end Parameter_Mode;
+ ---------------------
+ -- Record_Rep_Item --
+ ---------------------
+
+ procedure Record_Rep_Item (E : Entity_Id; N : Node_Id) is
+ begin
+ Set_Next_Rep_Item (N, First_Rep_Item (E));
+ Set_First_Rep_Item (E, N);
+ end Record_Rep_Item;
+
---------------
-- Root_Type --
---------------
-----------------
function Scope_Depth (Id : E) return Uint is
- Scop : Entity_Id := Id;
+ Scop : Entity_Id;
begin
+ Scop := Id;
while Is_Record_Type (Scop) loop
Scop := Scope (Scop);
end loop;
W ("Is_Preelaborated", Flag59 (Id));
W ("Is_Private_Composite", Flag107 (Id));
W ("Is_Private_Descendant", Flag53 (Id));
- W ("Is_Psected", Flag153 (Id));
W ("Is_Public", Flag10 (Id));
W ("Is_Pure", Flag44 (Id));
W ("Is_Remote_Call_Interface", Flag62 (Id));
Index : E;
begin
- Write_Attribute (" Component Type ",
- Component_Type (Id));
+ Write_Attribute
+ (" Component Type ", Component_Type (Id));
Write_Eol;
Write_Str (Prefix);
Write_Str (" Indices ");
Index := First_Index (Id);
-
while Present (Index) loop
Write_Attribute (" ", Etype (Index));
Index := Next_Index (Index);
-- Is_Protected_Type (synthesized)
-- Applies to all entities, true for protected types and subtypes
--- Is_Psected (Flag153)
--- Present in entities for objects, true if a valid Psect_Object
--- pragma applies to the object. Used to detect duplicate pragmas.
-
-- Is_Public (Flag10)
-- Present in all entities. Set to indicate that an entity defined in
-- one compilation unit can be referenced from other compilation units.
-- Has_Volatile_Components (Flag87)
-- Is_Atomic (Flag85)
-- Is_Eliminated (Flag124)
- -- Is_Psected (Flag153)
-- Is_True_Constant (Flag163)
-- Is_Volatile (Flag16)
-- Never_Set_In_Source (Flag115)
-- Has_Volatile_Components (Flag87)
-- Is_Atomic (Flag85)
-- Is_Eliminated (Flag124)
- -- Is_Psected (Flag153)
-- Is_Shared_Passive (Flag60)
-- Is_True_Constant (Flag163)
-- Is_Volatile (Flag16)
function Is_Preelaborated (Id : E) return B;
function Is_Private_Composite (Id : E) return B;
function Is_Private_Descendant (Id : E) return B;
- function Is_Psected (Id : E) return B;
function Is_Public (Id : E) return B;
function Is_Pure (Id : E) return B;
function Is_Remote_Call_Interface (Id : E) return B;
procedure Set_Is_Preelaborated (Id : E; V : B := True);
procedure Set_Is_Private_Composite (Id : E; V : B := True);
procedure Set_Is_Private_Descendant (Id : E; V : B := True);
- procedure Set_Is_Psected (Id : E; V : B := True);
procedure Set_Is_Public (Id : E; V : B := True);
procedure Set_Is_Pure (Id : E; V : B := True);
procedure Set_Is_Remote_Call_Interface (Id : E; V : B := True);
procedure Next_Stored_Discriminant (N : in out Node_Id)
renames Proc_Next_Stored_Discriminant;
- -------------------------------
- -- Miscellaneous Subprograms --
- -------------------------------
+ ----------------------------------------------
+ -- Subprograms for Accessing Rep Item Chain --
+ ----------------------------------------------
- procedure Append_Entity (Id : Entity_Id; V : Entity_Id);
- -- Add an entity to the list of entities declared in the scope V
+ -- The First_Rep_Item field of every entity points to a linked list
+ -- (linked through Next_Rep_Item) of representation pragmas and
+ -- attribute definition clauses that apply to the item. Note that
+ -- in the case of types, it is assumed that any such rep items for
+ -- a base type also apply to all subtypes. This is implemented by
+ -- having the chain for subtypes link onto the chain for the base
+ -- type, so that any new entries for the subtype are added at the
+ -- start of the chain.
+
+ function Get_Attribute_Definition_Clause
+ (E : Entity_Id;
+ Id : Attribute_Id) return Node_Id;
+ -- Searches the Rep_Item chain for a given entity E, for an instance
+ -- of an attribute definition clause with the given attibute Id Id. If
+ -- found, the value returned is the N_Attribute_Definition_Clause node,
+ -- otherwise Empty is returned.
function Get_Rep_Pragma (E : Entity_Id; Nam : Name_Id) return Node_Id;
-- Searches the Rep_Item chain for the given entity E, for an instance
-- of a representation pragma with the given name Nam. If found then
-- the value returned is the N_Pragma node, otherwise Empty is returned.
- function Get_Attribute_Definition_Clause
- (E : Entity_Id;
- Id : Attribute_Id)
- return Node_Id;
+ function Has_Rep_Pragma (E : Entity_Id; Nam : Name_Id) return Boolean;
+ -- Searches the Rep_Item chain for the given entity E, for an instance
+ -- of representation pragma with the given name Nam. If found then True
+ -- is returned, otherwise False indicates that no matching entry was found.
+
+ function Has_Attribute_Definition_Clause
+ (E : Entity_Id;
+ Id : Attribute_Id) return Boolean;
-- Searches the Rep_Item chain for a given entity E, for an instance
-- of an attribute definition clause with the given attibute Id Id. If
- -- found, the value returned is the N_Attribute_Definition_Clause node,
- -- otherwise Empty is returned.
+ -- found, True is returned, otherwise False indicates that no matching
+ -- entry was found.
+
+ procedure Record_Rep_Item (E : Entity_Id; N : Node_Id);
+ -- N is the node for either a representation pragma or an attribute
+ -- definition clause that applies to entity E. This procedure links
+ -- the node N onto the Rep_Item chain for entity E.
+
+ -------------------------------
+ -- Miscellaneous Subprograms --
+ -------------------------------
+
+ procedure Append_Entity (Id : Entity_Id; V : Entity_Id);
+ -- Add an entity to the list of entities declared in the scope V
function Is_Entity_Name (N : Node_Id) return Boolean;
-- Test if the node N is the name of an entity (i.e. is an identifier,
pragma Inline (Is_Private_Descendant);
pragma Inline (Is_Private_Type);
pragma Inline (Is_Protected_Type);
- pragma Inline (Is_Psected);
pragma Inline (Is_Public);
pragma Inline (Is_Pure);
pragma Inline (Is_Real_Type);
pragma Inline (Set_Is_Preelaborated);
pragma Inline (Set_Is_Private_Composite);
pragma Inline (Set_Is_Private_Descendant);
- pragma Inline (Set_Is_Psected);
pragma Inline (Set_Is_Public);
pragma Inline (Set_Is_Pure);
pragma Inline (Set_Is_Remote_Call_Interface);
-- defining it, is returned. In both cases, inheritance of representation
-- aspects is thus taken into account.
+ function Get_Stream_Convert_Pragma (T : Entity_Id) return Node_Id;
+ -- Given a type, find a corresponding stream convert pragma that applies to
+ -- the implementation base type of this type (Typ). If found, return the
+ -- pragma node, otherwise return Empty if no pragma is found.
+
function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean;
-- Utility for array attributes, returns true on packed constrained
-- arrays, and on access to same.
-- The generated call is given the provided set of parameters, and then
-- wrapped in a conversion which converts the result to the target type
+ -- We use the base type as the target because a range check may be
+ -- required.
Rewrite (N,
- Unchecked_Convert_To (Etype (N),
+ Unchecked_Convert_To (Base_Type (Etype (N)),
Make_Function_Call (Loc,
Name => Fnm,
Parameter_Associations => Args)));
if Pent = Standard_Standard
or else Pent = Standard_ASCII
then
- Name_Buffer (1 .. Verbose_Library_Version'Length) :=
- Verbose_Library_Version;
- Name_Len := Verbose_Library_Version'Length;
Rewrite (N,
Make_String_Literal (Loc,
- Strval => String_From_Name_Buffer));
+ Strval => Verbose_Library_Version));
-- All other cases
-- from which it is derived. The extra conversion is required
-- for the derived case.
- Prag :=
- Get_Rep_Pragma
- (Implementation_Base_Type (P_Type), Name_Stream_Convert);
+ Prag := Get_Stream_Convert_Pragma (P_Type);
if Present (Prag) then
Arg2 := Next (First (Pragma_Argument_Associations (Prag)));
-- it is derived to type strmtyp. The conversion to acttyp is
-- required for the derived case.
- Prag :=
- Get_Rep_Pragma
- (Implementation_Base_Type (P_Type), Name_Stream_Convert);
+ Prag := Get_Stream_Convert_Pragma (P_Type);
if Present (Prag) then
Arg3 :=
-- where Itemx is the expression of the type conversion (i.e.
-- the actual object), and typex is the type of Itemx.
- Prag :=
- Get_Rep_Pragma
- (Implementation_Base_Type (P_Type), Name_Stream_Convert);
+ Prag := Get_Stream_Convert_Pragma (P_Type);
if Present (Prag) then
Arg2 := Next (First (Pragma_Argument_Associations (Prag)));
-- it is derived to type strmtyp. The conversion to acttyp is
-- required for the derived case.
- Prag :=
- Get_Rep_Pragma
- (Implementation_Base_Type (P_Type), Name_Stream_Convert);
+ Prag := Get_Stream_Convert_Pragma (P_Type);
if Present (Prag) then
Arg3 :=
return Etype (Indx);
end Get_Index_Subtype;
+ -------------------------------
+ -- Get_Stream_Convert_Pragma --
+ -------------------------------
+
+ function Get_Stream_Convert_Pragma (T : Entity_Id) return Node_Id is
+ Typ : Entity_Id;
+ N : Node_Id;
+
+ begin
+ -- Note: we cannot use Get_Rep_Pragma here because of the peculiarity
+ -- that a stream convert pragma for a tagged type is not inherited from
+ -- its parent. Probably what is wrong here is that it is basically
+ -- incorrect to consider a stream convert pragma to be a representation
+ -- pragma at all ???
+
+ N := First_Rep_Item (Implementation_Base_Type (T));
+ while Present (N) loop
+ if Nkind (N) = N_Pragma and then Chars (N) = Name_Stream_Convert then
+
+ -- For tagged types this pragma is not inherited, so we
+ -- must verify that it is defined for the given type and
+ -- not an ancestor.
+
+ Typ :=
+ Entity (Expression (First (Pragma_Argument_Associations (N))));
+
+ if not Is_Tagged_Type (T)
+ or else T = Typ
+ or else (Is_Private_Type (Typ) and then T = Full_View (Typ))
+ then
+ return N;
+ end if;
+ end if;
+
+ Next_Rep_Item (N);
+ end loop;
+
+ return Empty;
+ end Get_Stream_Convert_Pragma;
+
---------------------------------
-- Is_Constrained_Packed_Array --
---------------------------------
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Stand; use Stand;
-with Stringt; use Stringt;
with Snames; use Snames;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
-- This is just a workaround that must be improved later???
if With_Default_Init then
- declare
- S : String_Id;
- Null_String : Node_Id;
- begin
- Start_String;
- S := End_String;
- Null_String := Make_String_Literal (Loc, Strval => S);
- Append_To (Args, Null_String);
- end;
+ Append_To (Args,
+ Make_String_Literal (Loc,
+ Strval => ""));
+
else
Decls := Build_Task_Image_Decls (Loc, Id_Ref, Enclos_Type);
Decl := Last (Decls);
Loc : constant Source_Ptr := Sloc (N);
P : Node_Id;
E : Entity_Id;
- S : String_Id;
begin
-- Climb up parents to see if we are in exception handler
P := Parent (N);
loop
- -- Case of not in exception handler
+ -- Case of not in exception handler, replace by null string
if No (P) then
- Start_String;
- S := End_String;
Rewrite (N,
Make_String_Literal (Loc,
- Strval => S));
+ Strval => ""));
exit;
-- Case of in exception handler
function Arg1 (N : Node_Id) return Node_Id;
function Arg2 (N : Node_Id) return Node_Id;
- -- Obtain specified Pragma_Argument_Association
+ -- Obtain specified pragma argument expression
procedure Expand_Pragma_Abort_Defer (N : Node_Id);
procedure Expand_Pragma_Assert (N : Node_Id);
+ procedure Expand_Pragma_Common_Object (N : Node_Id);
procedure Expand_Pragma_Import (N : Node_Id);
procedure Expand_Pragma_Import_Export_Exception (N : Node_Id);
procedure Expand_Pragma_Inspection_Point (N : Node_Id);
procedure Expand_Pragma_Interrupt_Priority (N : Node_Id);
+ procedure Expand_Pragma_Psect_Object (N : Node_Id);
----------
-- Arg1 --
----------
function Arg1 (N : Node_Id) return Node_Id is
+ Arg : constant Node_Id := First (Pragma_Argument_Associations (N));
begin
- return First (Pragma_Argument_Associations (N));
+ if Present (Arg)
+ and then Nkind (Arg) = N_Pragma_Argument_Association
+ then
+ return Expression (Arg);
+ else
+ return Arg;
+ end if;
end Arg1;
----------
----------
function Arg2 (N : Node_Id) return Node_Id is
+ Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
begin
- return Next (Arg1 (N));
+ if No (Arg1) then
+ return Empty;
+ else
+ declare
+ Arg : constant Node_Id := Next (Arg1);
+ begin
+ if Present (Arg)
+ and then Nkind (Arg) = N_Pragma_Argument_Association
+ then
+ return Expression (Arg);
+ else
+ return Arg;
+ end if;
+ end;
+ end if;
end Arg2;
---------------------
when Pragma_Assert =>
Expand_Pragma_Assert (N);
+ when Pragma_Common_Object =>
+ Expand_Pragma_Common_Object (N);
+
when Pragma_Export_Exception =>
Expand_Pragma_Import_Export_Exception (N);
when Pragma_Interrupt_Priority =>
Expand_Pragma_Interrupt_Priority (N);
+ when Pragma_Psect_Object =>
+ Expand_Pragma_Psect_Object (N);
+
-- All other pragmas need no expander action
when others => null;
procedure Expand_Pragma_Assert (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Cond : constant Node_Id := Expression (Arg1 (N));
+ Cond : constant Node_Id := Arg1 (N);
Msg : String_Id;
begin
-- First, we need to prepare the character literal
if Present (Arg2 (N)) then
- Msg := Strval (Expr_Value_S (Expression (Arg2 (N))));
+ Msg := Strval (Expr_Value_S (Arg2 (N)));
else
Build_Location_String (Loc);
Msg := String_From_Name_Buffer;
end if;
end Expand_Pragma_Assert;
+ ---------------------------------
+ -- Expand_Pragma_Common_Object --
+ ---------------------------------
+
+ -- Add series of pragmas to replicate semantic effect in DEC Ada
+
+ -- pragma Linker_Section (internal_name, external_name);
+ -- pragma Machine_Attribute (internal_name, "overlaid");
+ -- pragma Machine_Attribute (internal_name, "global");
+ -- pragma Machine_Attribute (internal_name, "initialize");
+
+ -- For now we do nothing with the size attribute ???
+
+ -- Really this expansion would be much better in the back end. The
+ -- front end should not need to know about target dependent, back end
+ -- dependent semantics ???
+
+ procedure Expand_Pragma_Common_Object (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+
+ Internal : constant Node_Id := Arg1 (N);
+ External : constant Node_Id := Arg2 (N);
+
+ Psect : Node_Id;
+ -- Psect value upper cased as string literal
+
+ Iloc : constant Source_Ptr := Sloc (Internal);
+ Eloc : constant Source_Ptr := Sloc (External);
+ Ploc : Source_Ptr;
+
+ begin
+ -- Acquire Psect value and fold to upper case
+
+ if Present (External) then
+ if Nkind (External) = N_String_Literal then
+ String_To_Name_Buffer (Strval (External));
+ else
+ Get_Name_String (Chars (External));
+ end if;
+
+ Set_All_Upper_Case;
+
+ Psect :=
+ Make_String_Literal (Eloc,
+ Strval => String_From_Name_Buffer);
+
+ else
+ Get_Name_String (Chars (Internal));
+ Set_All_Upper_Case;
+ Psect :=
+ Make_String_Literal (Iloc,
+ Strval => String_From_Name_Buffer);
+ end if;
+
+ Ploc := Sloc (Psect);
+
+ -- Insert pragmas
+
+ Insert_List_After_And_Analyze (N, New_List (
+
+ -- The Linker_Section pragma ensures the correct section
+
+ Make_Pragma (Loc,
+ Chars => Name_Linker_Section,
+ Pragma_Argument_Associations => New_List (
+ Make_Pragma_Argument_Association (Iloc,
+ Expression => New_Copy_Tree (Internal)),
+ Make_Pragma_Argument_Association (Ploc,
+ Expression => New_Copy_Tree (Psect)))),
+
+ -- Machine_Attribute "overlaid" ensures that this section
+ -- overlays any other sections of the same name.
+
+ Make_Pragma (Loc,
+ Chars => Name_Machine_Attribute,
+ Pragma_Argument_Associations => New_List (
+ Make_Pragma_Argument_Association (Iloc,
+ Expression => New_Copy_Tree (Internal)),
+ Make_Pragma_Argument_Association (Eloc,
+ Expression =>
+ Make_String_Literal (Sloc => Ploc,
+ Strval => "overlaid")))),
+
+ -- Machine_Attribute "global" ensures that section is visible
+
+ Make_Pragma (Loc,
+ Chars => Name_Machine_Attribute,
+ Pragma_Argument_Associations => New_List (
+ Make_Pragma_Argument_Association (Iloc,
+ Expression => New_Copy_Tree (Internal)),
+ Make_Pragma_Argument_Association (Eloc,
+ Expression =>
+ Make_String_Literal (Sloc => Ploc,
+ Strval => "global")))),
+
+ -- Machine_Attribute "initialize" ensures section is demand zeroed
+
+ Make_Pragma (Loc,
+ Chars => Name_Machine_Attribute,
+ Pragma_Argument_Associations => New_List (
+ Make_Pragma_Argument_Association (Iloc,
+ Expression => New_Copy_Tree (Internal)),
+ Make_Pragma_Argument_Association (Eloc,
+ Expression =>
+ Make_String_Literal (Sloc => Ploc,
+ Strval => "initialize"))))));
+ end Expand_Pragma_Common_Object;
+
--------------------------
-- Expand_Pragma_Import --
--------------------------
-- seen (i.e. this elaboration cannot be deferred to the freeze point).
procedure Expand_Pragma_Import (N : Node_Id) is
- Def_Id : constant Entity_Id := Entity (Expression (Arg2 (N)));
+ Def_Id : constant Entity_Id := Entity (Arg2 (N));
Typ : Entity_Id;
Init_Call : Node_Id;
end if;
declare
- Id : constant Entity_Id := Entity (Expression (Arg1 (N)));
+ Id : constant Entity_Id := Entity (Arg1 (N));
Call : constant Node_Id := Register_Exception_Call (Id);
Loc : constant Source_Ptr := Sloc (N);
end if;
end Expand_Pragma_Interrupt_Priority;
+ --------------------------------
+ -- Expand_Pragma_Psect_Object --
+ --------------------------------
+
+ -- Convert to Common_Object, and expand the resulting pragma
+
+ procedure Expand_Pragma_Psect_Object (N : Node_Id) is
+ begin
+ Set_Chars (N, Name_Common_Object);
+ Expand_Pragma_Common_Object (N);
+ end Expand_Pragma_Psect_Object;
+
end Exp_Prag;
-- inherited the indication from elsewhere (e.g. an address
-- clause, which is not good enough in RM terms!)
- if Present (Get_Rep_Pragma (E, Name_Atomic))
+ if Has_Rep_Pragma (E, Name_Atomic)
or else
- Present (Get_Rep_Pragma (E, Name_Atomic_Components))
+ Has_Rep_Pragma (E, Name_Atomic_Components)
then
Error_Msg_N
("stand alone atomic constant must be " &
"imported ('R'M 'C.6(13))", E);
- elsif Present (Get_Rep_Pragma (E, Name_Volatile))
+ elsif Has_Rep_Pragma (E, Name_Volatile)
or else
- Present (Get_Rep_Pragma (E, Name_Volatile_Components))
+ Has_Rep_Pragma (E, Name_Volatile_Components)
then
Error_Msg_N
("stand alone volatile constant must be " &
if Is_Limited_Type (P_Type)
and then Comes_From_Source (N)
and then not Present (TSS (Btyp, Nam))
- and then No (Get_Rep_Pragma (Btyp, Name_Stream_Convert))
+ and then not Has_Rep_Pragma (Btyp, Name_Stream_Convert)
then
Error_Msg_Name_1 := Aname;
Error_Msg_NE
when Attribute_Target_Name => Target_Name : declare
TN : constant String := Sdefault.Target_Name.all;
- TL : Integer := TN'Last;
+ TL : Natural;
begin
Check_Standard_Prefix;
Check_E0;
- Start_String;
+
+ TL := TN'Last;
if TN (TL) = '/' or else TN (TL) = '\' then
TL := TL - 1;
end if;
- Store_String_Chars (TN (TN'First .. TL));
-
Rewrite (N,
Make_String_Literal (Loc,
- Strval => End_String));
+ Strval => TN (TN'First .. TL)));
Analyze_And_Resolve (N, Standard_String);
end Target_Name;
end if;
end New_Stream_Procedure;
- ---------------------
- -- Record_Rep_Item --
- ---------------------
-
- procedure Record_Rep_Item (T : Entity_Id; N : Node_Id) is
- begin
- Set_Next_Rep_Item (N, First_Rep_Item (T));
- Set_First_Rep_Item (T, N);
- end Record_Rep_Item;
-
------------------------
-- Rep_Item_Too_Early --
------------------------
-- If the size is too small, and an error message is given, then both
-- Esize and RM_Size are reset to the allowed minimum value in T.
- procedure Record_Rep_Item (T : Entity_Id; N : Node_Id);
- -- N is the node for either a representation pragma or an attribute
- -- definition clause that applies to type T. This procedure links
- -- the node N onto the Rep_Item chain for the type T.
-
function Rep_Item_Too_Early (T : Entity_Id; N : Node_Id) return Boolean;
-- Called at the start of processing a representation clause or a
-- representation pragma. Used to check that the representation item
procedure Check_Arg_Is_String_Literal (Arg : Node_Id) is
Argx : constant Node_Id := Get_Pragma_Arg (Arg);
-
begin
if Nkind (Argx) /= N_String_Literal then
Error_Pragma_Arg
("argument for pragma% must be string literal", Argx);
end if;
-
end Check_Arg_Is_String_Literal;
------------------------------------------
procedure Check_At_Most_N_Arguments (N : Nat) is
Arg : Node_Id;
-
begin
if Arg_Count > N then
Arg := Arg1;
procedure Check_First_Subtype (Arg : Node_Id) is
Argx : constant Node_Id := Get_Pragma_Arg (Arg);
-
begin
if not Is_First_Subtype (Entity (Argx)) then
Error_Pragma_Arg
procedure Check_No_Identifiers is
Arg_Node : Node_Id;
-
begin
if Arg_Count > 0 then
Arg_Node := Arg1;
-
while Present (Arg_Node) loop
Check_No_Identifier (Arg_Node);
Next (Arg_Node);
when N_Index_Or_Discriminant_Constraint =>
declare
- IDC : Entity_Id := First (Constraints (Constr));
+ IDC : Entity_Id;
begin
+ IDC := First (Constraints (Constr));
while Present (IDC) loop
Check_Static_Constraint (IDC);
Next (IDC);
Comp := First (Component_Items (Clist));
while Present (Comp) loop
-
Check_Component (Comp);
Next (Comp);
-
end loop;
end Check_Variant;
("pragma% must designate an object", Arg_Internal);
end if;
- if Is_Psected (Def_Id) then
+ if Has_Rep_Pragma (Def_Id, Name_Common_Object)
+ or else
+ Has_Rep_Pragma (Def_Id, Name_Psect_Object)
+ then
Error_Pragma_Arg
- ("previous Psect_Object applies, pragma % not permitted",
+ ("previous Common/Psect_Object applies, pragma % not permitted",
Arg_Internal);
end if;
begin
Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
- Hom_Id := Entity (Arg_Internal);
Ent := Empty;
Ambiguous := False;
- -- Loop through homonyms (overloadings) of Hom_Id
+ -- Loop through homonyms (overloadings) of the entity
+ Hom_Id := Entity (Arg_Internal);
while Present (Hom_Id) loop
Def_Id := Get_Base_Subprogram (Hom_Id);
else
Bad_Class;
end if;
-
end Set_Mechanism_Value;
---------------------------
External : Node_Id renames Args (2);
Size : Node_Id renames Args (3);
- R_Internal : Node_Id;
- R_External : Node_Id;
-
- MA : Node_Id;
- Str : String_Id;
-
- Def_Id : Entity_Id;
+ Def_Id : Entity_Id;
procedure Check_Too_Long (Arg : Node_Id);
-- Posts message if the argument is an identifier with more
Gather_Associations (Names, Args);
Process_Extended_Import_Export_Internal_Arg (Internal);
- R_Internal := Relocate_Node (Internal);
-
- Def_Id := Entity (R_Internal);
+ Def_Id := Entity (Internal);
if Ekind (Def_Id) /= E_Constant
and then Ekind (Def_Id) /= E_Variable
("pragma% must designate an object", Internal);
end if;
- Check_Too_Long (R_Internal);
+ Check_Too_Long (Internal);
if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
Error_Pragma_Arg
("cannot use pragma% for imported/exported object",
- R_Internal);
+ Internal);
end if;
- if Is_Concurrent_Type (Etype (R_Internal)) then
+ if Is_Concurrent_Type (Etype (Internal)) then
Error_Pragma_Arg
("cannot specify pragma % for task/protected object",
- R_Internal);
+ Internal);
end if;
- if Is_Psected (Def_Id) then
- Error_Msg_N ("?duplicate Psect_Object pragma", N);
- else
- Set_Is_Psected (Def_Id);
+ if Has_Rep_Pragma (Def_Id, Name_Common_Object)
+ or else
+ Has_Rep_Pragma (Def_Id, Name_Psect_Object)
+ then
+ Error_Msg_N ("?duplicate Common/Psect_Object pragma", N);
end if;
if Ekind (Def_Id) = E_Constant then
Error_Pragma_Arg
- ("cannot specify pragma % for a constant", R_Internal);
+ ("cannot specify pragma % for a constant", Internal);
end if;
- if Is_Record_Type (Etype (R_Internal)) then
+ if Is_Record_Type (Etype (Internal)) then
declare
Ent : Entity_Id;
Decl : Entity_Id;
begin
- Ent := First_Entity (Etype (R_Internal));
+ Ent := First_Entity (Etype (Internal));
while Present (Ent) loop
Decl := Declaration_Node (Ent);
and then Warn_On_Export_Import
then
Error_Msg_N
- ("?object for pragma % has defaults", R_Internal);
+ ("?object for pragma % has defaults", Internal);
exit;
else
Check_Too_Long (Size);
end if;
- -- Make Psect case-insensitive.
-
if Present (External) then
Check_Too_Long (External);
-
- if Nkind (External) = N_String_Literal then
- String_To_Name_Buffer (Strval (External));
- else
- Get_Name_String (Chars (External));
- end if;
-
- Set_All_Upper_Case;
- Start_String;
- Store_String_Chars (Name_Buffer (1 .. Name_Len));
- Str := End_String;
- R_External := Make_String_Literal
- (Sloc => Sloc (External), Strval => Str);
- else
- Get_Name_String (Chars (Internal));
- Set_All_Upper_Case;
- Start_String;
- Store_String_Chars (Name_Buffer (1 .. Name_Len));
- Str := End_String;
- R_External := Make_String_Literal
- (Sloc => Sloc (Internal), Strval => Str);
end if;
- -- Transform into pragma Linker_Section, add attributes to
- -- match what DEC Ada does. Ignore size for now?
-
- Rewrite (N,
- Make_Pragma
- (Sloc (N),
- Name_Linker_Section,
- New_List
- (Make_Pragma_Argument_Association
- (Sloc => Sloc (R_Internal),
- Expression => R_Internal),
- Make_Pragma_Argument_Association
- (Sloc => Sloc (R_External),
- Expression => R_External))));
-
- Analyze (N);
-
- -- Add Machine_Attribute of "overlaid", so the section overlays
- -- other sections of the same name.
-
- Start_String;
- Store_String_Chars ("overlaid");
- Str := End_String;
-
- MA :=
- Make_Pragma
- (Sloc (N),
- Name_Machine_Attribute,
- New_List
- (Make_Pragma_Argument_Association
- (Sloc => Sloc (R_Internal),
- Expression => R_Internal),
- Make_Pragma_Argument_Association
- (Sloc => Sloc (R_External),
- Expression =>
- Make_String_Literal
- (Sloc => Sloc (R_External),
- Strval => Str))));
- Analyze (MA);
-
- -- Add Machine_Attribute of "global", so the section is visible
- -- everywhere
-
- Start_String;
- Store_String_Chars ("global");
- Str := End_String;
-
- MA :=
- Make_Pragma
- (Sloc (N),
- Name_Machine_Attribute,
- New_List
- (Make_Pragma_Argument_Association
- (Sloc => Sloc (R_Internal),
- Expression => R_Internal),
-
- Make_Pragma_Argument_Association
- (Sloc => Sloc (R_External),
- Expression =>
- Make_String_Literal
- (Sloc => Sloc (R_External),
- Strval => Str))));
- Analyze (MA);
-
- -- Add Machine_Attribute of "initialize", so the section is
- -- demand zeroed.
-
- Start_String;
- Store_String_Chars ("initialize");
- Str := End_String;
-
- MA :=
- Make_Pragma
- (Sloc (N),
- Name_Machine_Attribute,
- New_List
- (Make_Pragma_Argument_Association
- (Sloc => Sloc (R_Internal),
- Expression => R_Internal),
+ -- If all error tests pass, link pragma on to the rep item chain
- Make_Pragma_Argument_Association
- (Sloc => Sloc (R_External),
- Expression =>
- Make_String_Literal
- (Sloc => Sloc (R_External),
- Strval => Str))));
- Analyze (MA);
+ Record_Rep_Item (Def_Id, N);
end Psect_Object;
----------
end if;
Vpart := Variant_Part (Clist);
+
Variant := First (Variants (Vpart));
while Present (Variant) loop
-
Check_Variant (Variant);
Next (Variant);
-
end loop;
end if;
Check_At_Least_N_Arguments (1);
Arg_Node := Arg1;
-
while Present (Arg_Node) loop
Check_No_Identifier (Arg_Node);
if Is_Enumeration_Type (E) then
declare
- Lit : Entity_Id := First_Literal (E);
-
+ Lit : Entity_Id;
begin
+ Lit := First_Literal (E);
while Present (Lit) loop
Set_Warnings_Off (Lit);
Next_Literal (Lit);
Result : Entity_Id;
begin
- Result := Def_Id;
-
-- Follow subprogram renaming chain
+ Result := Def_Id;
while Is_Subprogram (Result)
and then
(Is_Generic_Instance (Result)
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
+with Stringt; use Stringt;
with Uintp; use Uintp;
package body Tbuild is
UI_From_Int (RT_Exception_Code'Pos (Reason)));
end Make_Raise_Storage_Error;
+ -------------------------
+ -- Make_String_Literal --
+ -------------------------
+
+ function Make_String_Literal
+ (Sloc : Source_Ptr;
+ Strval : String) return Node_Id
+ is
+ begin
+ Start_String;
+ Store_String_Chars (Strval);
+ return
+ Make_String_Literal (Sloc,
+ Strval => End_String);
+ end Make_String_Literal;
+
---------------------------
-- Make_Unsuppress_Block --
---------------------------
-- A convenient form of Make_Raise_Storage_Error where the Reason
-- is given simply as an enumeration value, rather than a Uint code.
+ function Make_String_Literal
+ (Sloc : Source_Ptr;
+ Strval : String) return Node_Id;
+ -- A convenient form of Make_String_Literal, where the string value
+ -- is given as a normal string instead of a String_Id value.
+
function Make_Unsuppress_Block
(Loc : Source_Ptr;
Check : Name_Id;
projects / gcc.git / commitdiff