-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
-with Expander; use Expander;
with Exp_Dist; use Exp_Dist;
-with Fname; use Fname;
with Hostparm; use Hostparm;
with Lib; use Lib;
with Lib.Writ; use Lib.Writ;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch13; use Sem_Ch13;
with Sem_Disp; use Sem_Disp;
+with Sem_Dist; use Sem_Dist;
with Sem_Elim; use Sem_Elim;
with Sem_Eval; use Sem_Eval;
with Sem_Intr; use Sem_Intr;
procedure Check_At_Most_N_Arguments (N : Nat);
-- Check there are no more than N arguments present
+ procedure Check_Component (Comp : Node_Id);
+ -- Examine Unchecked_Union component for correct use of per-object
+ -- constrained subtypes.
+
procedure Check_Duplicated_Export_Name (Nam : Node_Id);
-- Nam is an N_String_Literal node containing the external name set
-- by an Import or Export pragma (or extended Import or Export pragma).
-- and to library level instantiations), and they are simply ignored,
-- which is implemented by rewriting them as null statements.
+ procedure Check_Variant (Variant : Node_Id);
+ -- Check Unchecked_Union variant for lack of nested variants and
+ -- presence of at least one component.
+
procedure Error_Pragma (Msg : String);
pragma No_Return (Error_Pragma);
-- Outputs error message for current pragma. The message contains an %
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;
-
for J in 1 .. N loop
Next (Arg);
Error_Pragma_Arg ("too many arguments for pragma%", Arg);
end if;
end Check_At_Most_N_Arguments;
+ ---------------------
+ -- Check_Component --
+ ---------------------
+
+ procedure Check_Component (Comp : Node_Id) is
+ begin
+ if Nkind (Comp) = N_Component_Declaration then
+ declare
+ Sindic : constant Node_Id :=
+ Subtype_Indication (Component_Definition (Comp));
+
+ begin
+ if Nkind (Sindic) = N_Subtype_Indication then
+
+ -- Ada 2005 (AI-216): If a component subtype is subject to
+ -- a per-object constraint, then the component type shall
+ -- be an Unchecked_Union.
+
+ if Has_Per_Object_Constraint (Defining_Identifier (Comp))
+ and then
+ not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
+ then
+ Error_Msg_N ("component subtype subject to per-object" &
+ " constraint must be an Unchecked_Union", Comp);
+ end if;
+ end if;
+ end;
+ end if;
+ end Check_Component;
+
----------------------------------
-- Check_Duplicated_Export_Name --
----------------------------------
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);
end if;
end Check_Valid_Library_Unit_Pragma;
+ -------------------
+ -- Check_Variant --
+ -------------------
+
+ procedure Check_Variant (Variant : Node_Id) is
+ Clist : constant Node_Id := Component_List (Variant);
+ Comp : Node_Id;
+
+ begin
+ if Present (Variant_Part (Clist)) then
+ Error_Msg_N
+ ("Unchecked_Union may not have nested variants",
+ Variant_Part (Clist));
+ end if;
+
+ if not Is_Non_Empty_List (Component_Items (Clist)) then
+ Error_Msg_N
+ ("Unchecked_Union may not have empty component list",
+ Variant);
+ return;
+ end if;
+
+ Comp := First (Component_Items (Clist));
+ while Present (Comp) loop
+ Check_Component (Comp);
+ Next (Comp);
+ end loop;
+ end Check_Variant;
+
------------------
-- Error_Pragma --
------------------
-- Otherwise first deal with any positional parameters present
Arg := First (Pragma_Argument_Associations (N));
-
for Index in Args'Range loop
exit when No (Arg) or else Chars (Arg) /= No_Name;
Args (Index) := Expression (Arg);
-- Go to renamed subprogram if present, since convention applies
-- to the actual renamed entity, not to the renaming entity.
+ -- If subprogram is inherited, go to parent subprogram.
if Is_Subprogram (E)
and then Present (Alias (E))
- and then Nkind (Parent (Declaration_Node (E))) =
- N_Subprogram_Renaming_Declaration
then
- E := Alias (E);
+ if Nkind (Parent (Declaration_Node (E)))
+ = N_Subprogram_Renaming_Declaration
+ then
+ E := Alias (E);
+
+ elsif Nkind (Parent (E)) = N_Full_Type_Declaration
+ and then Scope (E) = Scope (Alias (E))
+ then
+ E := Alias (E);
+ end if;
end if;
- -- Check that we not applying this to a specless body
+ -- Check that we are not applying this to a specless body
if Is_Subprogram (E)
and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
("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);
-- Deal with positional ones first
Formal := First_Formal (Ent);
+
if Present (Expressions (Arg_Mechanism)) then
Mname := First (Expressions (Arg_Mechanism));
else
Set_Imported (Def_Id);
- Set_Is_Public (Def_Id);
Process_Interface_Name (Def_Id, Arg3, Arg4);
+ -- Note that we do not set Is_Public here. That's because we
+ -- only want to set if if there is no address clause, and we
+ -- don't know that yet, so we delay that processing till
+ -- freeze time.
+
-- pragma Import completes deferred constants
if Ekind (Def_Id) = E_Constant then
-- denoted entities in the same declarative part.
Hom_Id := Def_Id;
-
while Present (Hom_Id) loop
Def_Id := Get_Base_Subprogram (Hom_Id);
else
Set_Imported (Def_Id);
- -- If Import intrinsic, set intrinsic flag
- -- and verify that it is known as such.
+ -- Special processing for Convention_Intrinsic
if C = Convention_Intrinsic then
+
+ -- Link_Name argument not allowed for intrinsic
+
+ if Present (Arg3)
+ and then Chars (Arg3) = Name_Link_Name
+ then
+ Arg4 := Arg3;
+ end if;
+
+ if Present (Arg4) then
+ Error_Pragma_Arg
+ ("Link_Name argument not allowed for " &
+ "Import Intrinsic",
+ Arg4);
+ end if;
+
Set_Is_Intrinsic_Subprogram (Def_Id);
- Check_Intrinsic_Subprogram
- (Def_Id, Expression (Arg2));
+
+ -- If no external name is present, then check that
+ -- this is a valid intrinsic subprogram. If an external
+ -- name is present, then this is handled by the back end.
+
+ if No (Arg3) then
+ Check_Intrinsic_Subprogram (Def_Id, Expression (Arg2));
+ end if;
end if;
- -- All interfaced procedures need an external
- -- symbol created for them since they are
- -- always referenced from another object file.
+ -- All interfaced procedures need an external symbol
+ -- created for them since they are always referenced
+ -- from another object file.
Set_Is_Public (Def_Id);
procedure Set_Inline_Flags (Subp : Entity_Id);
-- Sets Is_Inlined and Has_Pragma_Inline flags for Subp
- function Cannot_Inline (Subp : Entity_Id) return Boolean;
- -- Do not set the inline flag if body is available and contains
- -- exception handlers, to prevent undefined symbols at link time.
- -- Emit warning if front-end inlining is enabled and the pragma
- -- appears too late.
+ function Inlining_Not_Possible (Subp : Entity_Id) return Boolean;
+ -- Returns True if it can be determined at this stage that inlining
+ -- is not possible, for examle if the body is available and contains
+ -- exception handlers, we prevent inlining, since otherwise we can
+ -- get undefined symbols at link time. This function also emits a
+ -- warning if front-end inlining is enabled and the pragma appears
+ -- too late.
+ -- ??? is business with link symbols still valid, or does it relate
+ -- to front end ZCX which is being phased out ???
- -------------------
- -- Cannot_Inline --
- -------------------
+ ---------------------------
+ -- Inlining_Not_Possible --
+ ---------------------------
- function Cannot_Inline (Subp : Entity_Id) return Boolean is
- Decl : constant Node_Id := Unit_Declaration_Node (Subp);
+ function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is
+ Decl : constant Node_Id := Unit_Declaration_Node (Subp);
+ Stats : Node_Id;
begin
if Nkind (Decl) = N_Subprogram_Body then
- return
- Present
- (Exception_Handlers (Handled_Statement_Sequence (Decl)));
+ Stats := Handled_Statement_Sequence (Decl);
+ return Present (Exception_Handlers (Stats))
+ or else Present (At_End_Proc (Stats));
elsif Nkind (Decl) = N_Subprogram_Declaration
and then Present (Corresponding_Body (Decl))
return False;
else
+ Stats :=
+ Handled_Statement_Sequence
+ (Unit_Declaration_Node (Corresponding_Body (Decl)));
+
return
- Present (Exception_Handlers
- (Handled_Statement_Sequence
- (Unit_Declaration_Node (Corresponding_Body (Decl)))));
+ Present (Exception_Handlers (Stats))
+ or else Present (At_End_Proc (Stats));
end if;
+
else
-- If body is not available, assume the best, the check is
-- performed again when compiling enclosing package bodies.
return False;
end if;
- end Cannot_Inline;
+ end Inlining_Not_Possible;
-----------------
-- Make_Inline --
if Etype (Subp) = Any_Type then
return;
- elsif Cannot_Inline (Subp) then
- Applies := True; -- Do not treat as an error.
+ -- If inlining is not possible, for now do not treat as an error
+
+ elsif Inlining_Not_Possible (Subp) then
+ Applies := True;
return;
-- Here we have a candidate for inlining, but we must exclude
elsif not Effective
and then Warn_On_Redundant_Constructs
then
- Error_Msg_NE ("pragma inline on& is redundant?",
- N, Entity (Subp_Id));
+ if Inlining_Not_Possible (Subp) then
+ Error_Msg_NE
+ ("pragma Inline for& is ignored?", N, Entity (Subp_Id));
+ else
+ Error_Msg_NE
+ ("pragma Inline for& is redundant?", N, Entity (Subp_Id));
+ end if;
end if;
Next (Assoc);
-- particular that no spaces or other obviously incorrect characters
-- appear. This is only a warning, since any characters are allowed.
+ ----------------------------------
+ -- Check_Form_Of_Interface_Name --
+ ----------------------------------
+
procedure Check_Form_Of_Interface_Name (SN : Node_Id) is
S : constant String_Id := Strval (Expr_Value_S (SN));
SL : constant Nat := String_Length (S);
-- Process_Restrictions_Or_Restriction_Warnings --
--------------------------------------------------
+ -- Note: some of the simple identifier cases were handled in par-prag,
+ -- but it is harmless (and more straightforward) to simply handle all
+ -- cases here, even if it means we repeat a bit of work in some cases.
+
procedure Process_Restrictions_Or_Restriction_Warnings is
Arg : Node_Id;
R_Id : Restriction_Id;
Expr : Node_Id;
Val : Uint;
+ procedure Check_Unit_Name (N : Node_Id);
+ -- Checks unit name parameter for No_Dependence. Returns if it has
+ -- an appropriate form, otherwise raises pragma argument error.
+
procedure Set_Warning (R : All_Restrictions);
-- If this is a Restriction_Warnings pragma, set warning flag,
-- otherwise reset the flag.
+ ---------------------
+ -- Check_Unit_Name --
+ ---------------------
+
+ procedure Check_Unit_Name (N : Node_Id) is
+ begin
+ if Nkind (N) = N_Selected_Component then
+ Check_Unit_Name (Prefix (N));
+ Check_Unit_Name (Selector_Name (N));
+
+ elsif Nkind (N) = N_Identifier then
+ return;
+
+ else
+ Error_Pragma_Arg
+ ("wrong form for unit name for No_Dependence", N);
+ end if;
+ end Check_Unit_Name;
+
-----------------
-- Set_Warning --
-----------------
Scope_Suppress := (others => True);
end if;
- -- Case of restriction identifier present
+ -- Case of No_Dependence => unit-name. Note that the parser
+ -- already made the necessary entry in the No_Dependence table.
+
+ elsif Id = Name_No_Dependence then
+ Check_Unit_Name (Expr);
+
+ -- All other cases of restriction identifier present
else
R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg));
-- Import or Export pragma), then the external names must match
if Present (Interface_Name (Internal_Ent)) then
- declare
+ Check_Matching_Internal_Names : declare
S1 : constant String_Id := Strval (Old_Name);
S2 : constant String_Id := Strval (New_Name);
procedure Mismatch;
-- Called if names do not match
+ --------------
+ -- Mismatch --
+ --------------
+
procedure Mismatch is
begin
Error_Msg_Sloc := Sloc (Old_Name);
Arg_External);
end Mismatch;
+ -- Start of processing for Check_Matching_Internal_Names
+
begin
if String_Length (S1) /= String_Length (S2) then
Mismatch;
end if;
end loop;
end if;
- end;
+ end Check_Matching_Internal_Names;
-- Otherwise set the given name
procedure Bad_Mechanism;
-- Signal bad mechanism name
+ ---------------
+ -- Bad_Class --
+ ---------------
+
procedure Bad_Class is
begin
Error_Pragma_Arg ("unrecognized descriptor class name", Class);
end Bad_Class;
+ -------------------------
+ -- Bad_Mechanism_Value --
+ -------------------------
+
procedure Bad_Mechanism is
begin
Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name);
else
Bad_Class;
end if;
-
end Set_Mechanism_Value;
---------------------------
------------
-- pragma Ada_05;
+ -- pragma Ada_05 (LOCAL_NAME);
-- Note: this pragma also has some specific processing in Par.Prag
- -- because we want to set the Ada 83 version mode during parsing.
+ -- because we want to set the Ada 2005 version mode during parsing.
+
+ when Pragma_Ada_05 => declare
+ E_Id : Node_Id;
- when Pragma_Ada_05 =>
+ begin
GNAT_Pragma;
- Ada_Version := Ada_05;
- Check_Arg_Count (0);
+
+ if Arg_Count = 1 then
+ Check_Arg_Is_Local_Name (Arg1);
+ E_Id := Expression (Arg1);
+
+ if Etype (E_Id) = Any_Type then
+ return;
+ end if;
+
+ Set_Is_Ada_2005 (Entity (E_Id));
+
+ else
+ Ada_Version := Ada_05;
+ Check_Arg_Count (0);
+ end if;
+ end;
----------------------
-- All_Calls_Remote --
Error_Pragma_Arg
("pragma% cannot be applied to function", Arg1);
- elsif Ekind (Nm) = E_Record_Type
- and then Present (Corresponding_Remote_Type (Nm))
- then
- N := Declaration_Node (Corresponding_Remote_Type (Nm));
+ elsif Is_Remote_Access_To_Subprogram_Type (Nm) then
+
+ if Is_Record_Type (Nm) then
+ -- A record type that is the Equivalent_Type for
+ -- a remote access-to-subprogram type.
+
+ N := Declaration_Node (Corresponding_Remote_Type (Nm));
+
+ else
+ -- A non-expanded RAS type (case where distribution is
+ -- not enabled).
+
+ N := Declaration_Node (Nm);
+ end if;
if Nkind (N) = N_Full_Type_Declaration
and then Nkind (Type_Definition (N)) =
L := Parameter_Specifications (Type_Definition (N));
Process_Async_Pragma;
+ if Is_Asynchronous (Nm)
+ and then Expander_Active
+ and then Get_PCS_Name /= Name_No_DSA
+ then
+ RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm));
+ end if;
+
else
Error_Pragma_Arg
("pragma% cannot reference access-to-function type",
if Expander_Active and then Typ = Root_Type (Typ) then
- Tag_C := Tag_Component (Typ);
+ Tag_C := First_Tag_Component (Typ);
C := First_Entity (Typ);
if C = Tag_C then
-- . DT_Position will be set at the freezing point
if Arg_Count = 1 then
- Set_DTC_Entity (Subp, Tag_Component (Typ));
+ Set_DTC_Entity (Subp, First_Tag_Component (Typ));
return;
end if;
-- If it is the first pragma Vtable, This becomes the default tag
elsif (not Is_Tag (DTC))
- and then DT_Entry_Count (Tag_Component (Typ)) = No_Uint
+ and then DT_Entry_Count (First_Tag_Component (Typ)) = No_Uint
then
- Set_Is_Tag (Tag_Component (Typ), False);
+ Set_Is_Tag (First_Tag_Component (Typ), False);
Set_Is_Tag (DTC, True);
Set_DT_Entry_Count (DTC, No_Uint);
end if;
when Pragma_Debug => Debug : begin
GNAT_Pragma;
- -- If assertions are enabled, and we are expanding code, then
- -- we rewrite the pragma with its corresponding procedure call
- -- and then analyze the call.
+ -- Rewrite into a conditional with a static condition
- if Assertions_Enabled and Expander_Active then
- Rewrite (N, Relocate_Node (Debug_Statement (N)));
- Analyze (N);
-
- -- Otherwise we work a bit to get a tree that makes sense
- -- for ASIS purposes, namely a pragma with an analyzed
- -- argument that looks like a procedure call.
-
- else
- Expander_Mode_Save_And_Set (False);
- Rewrite (N, Relocate_Node (Debug_Statement (N)));
- Analyze (N);
- Rewrite (N,
- Make_Pragma (Loc,
- Chars => Name_Debug,
- Pragma_Argument_Associations =>
- New_List (Relocate_Node (N))));
- Expander_Mode_Restore;
- end if;
+ Rewrite (N, Make_Implicit_If_Statement (N,
+ Condition => New_Occurrence_Of (Boolean_Literals (
+ Assertions_Enabled and Expander_Active), Loc),
+ Then_Statements => New_List (
+ Relocate_Node (Debug_Statement (N)))));
+ Analyze (N);
end Debug;
---------------------
then
Set_Elaborate_Present (Citem, True);
Set_Unit_Name (Expression (Arg), Name (Citem));
- Set_Suppress_Elaboration_Warnings (Entity (Name (Citem)));
+
+ -- With the pragma present, elaboration calls on
+ -- subprograms from the named unit need no further
+ -- checks, as long as the pragma appears in the current
+ -- compilation unit. If the pragma appears in some unit
+ -- in the context, there might still be a need for an
+ -- Elaborate_All_Desirable from the current compilation
+ -- to the the named unit, so we keep the check enabled.
+
+ if In_Extended_Main_Source_Unit (N) then
+ Set_Suppress_Elaboration_Warnings
+ (Entity (Name (Citem)));
+ end if;
exit Inner;
end if;
then
Set_Elaborate_All_Present (Citem, True);
Set_Unit_Name (Expression (Arg), Name (Citem));
- Set_Suppress_Elaboration_Warnings (Entity (Name (Citem)));
+
+ -- Suppress warnings and elaboration checks on the named
+ -- unit if the pragma is in the current compilation, as
+ -- for pragma Elaborate.
+
+ if In_Extended_Main_Source_Unit (N) then
+ Set_Suppress_Elaboration_Warnings
+ (Entity (Name (Citem)));
+ end if;
exit Innr;
end if;
-- UPPERCASE | LOWERCASE
-- [, AS_IS | UPPERCASE | LOWERCASE]);
- when Pragma_External_Name_Casing =>
-
- External_Name_Casing : declare
+ when Pragma_External_Name_Casing => External_Name_Casing : declare
begin
GNAT_Pragma;
Check_No_Identifiers;
-- Pragma is active if inlining option is active
- if Inline_Active then
- Process_Inline (True);
-
- -- Pragma is active in a predefined file in config run time mode
-
- elsif Configurable_Run_Time_Mode
- and then
- Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit))
- then
- Process_Inline (True);
-
- -- Otherwise inlining is not active
-
- else
- Process_Inline (False);
- end if;
+ Process_Inline (Inline_Active);
-------------------
-- Inline_Always --
-- pragma Obsolescent [(static_string_EXPRESSION)];
when Pragma_Obsolescent => Obsolescent : declare
+ Subp : Node_Or_Entity_Id;
+ S : String_Id;
+
begin
GNAT_Pragma;
Check_At_Most_N_Arguments (1);
Check_No_Identifiers;
- if Arg_Count = 1 then
- Check_Arg_Is_Static_Expression (Arg1, Standard_String);
- end if;
+ -- Check OK placement
+
+ -- First possibility is within a declarative region, where the
+ -- pragma immediately follows a subprogram declaration.
- if No (Prev (N))
- or else (Nkind (Prev (N))) /= N_Subprogram_Declaration
+ if Present (Prev (N)) then
+ Subp := Prev (N);
+
+ -- Second possibility, stand alone subprogram declaration with the
+ -- pragma immediately following the declaration.
+
+ elsif No (Prev (N))
+ and then Nkind (Parent (N)) = N_Compilation_Unit_Aux
then
+ Subp := Unit (Parent (Parent (N)));
+
+ -- Any other possibility is a misplacement
+
+ else
+ Subp := Empty;
+ end if;
+
+ -- Check correct placement
+
+ if Nkind (Subp) /= N_Subprogram_Declaration then
Error_Pragma
("pragma% misplaced, must immediately " &
"follow subprogram spec");
+
+ -- If OK placement, set flag and acquire argument
+
+ else
+ Subp := Defining_Entity (Subp);
+ Set_Is_Obsolescent (Subp);
+
+ if Arg_Count = 1 then
+ Check_Arg_Is_Static_Expression (Arg1, Standard_String);
+ S := Strval (Expression (Arg1));
+
+ for J in 1 .. String_Length (S) loop
+ if not In_Character_Range (Get_String_Char (S, J)) then
+ Error_Pragma_Arg
+ ("pragma% argument does not allow wide characters",
+ Arg1);
+ end if;
+ end loop;
+
+ Set_Obsolescent_Warning (Subp, Expression (Arg1));
+ end if;
end if;
end Obsolescent;
when Pragma_Optional_Overriding =>
Error_Msg_N ("pragma must appear immediately after subprogram", N);
- ----------------
- -- Overriding --
- ----------------
-
- when Pragma_Overriding =>
- Error_Msg_N ("pragma must appear immediately after subprogram", N);
-
----------
-- Pack --
----------
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_Arg_Is_External_Name (External);
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;
+ -- If all error tests pass, link pragma on to the rep item chain
- 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),
-
- 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;
----------
Tdef := Type_Definition (Declaration_Node (Typ));
Clist := Component_List (Tdef);
+ Comp := First (Component_Items (Clist));
+ while Present (Comp) loop
+
+ Check_Component (Comp);
+ Next (Comp);
+
+ end loop;
+
if No (Clist) or else No (Variant_Part (Clist)) then
Error_Msg_N
("Unchecked_Union must have variant part",
Vpart := Variant_Part (Clist);
- if Is_Non_Empty_List (Component_Items (Clist)) then
- Error_Msg_N
- ("components before variant not allowed " &
- "in Unchecked_Union",
- First (Component_Items (Clist)));
- end if;
-
Variant := First (Variants (Vpart));
while Present (Variant) loop
- Clist := Component_List (Variant);
-
- if Present (Variant_Part (Clist)) then
- Error_Msg_N
- ("Unchecked_Union may not have nested variants",
- Variant_Part (Clist));
- end if;
-
- if not Is_Non_Empty_List (Component_Items (Clist)) then
- Error_Msg_N
- ("Unchecked_Union may not have empty component list",
- Variant);
- return;
- end if;
-
- Comp := First (Component_Items (Clist));
-
- if Nkind (Comp) = N_Component_Declaration then
-
- if Present (Expression (Comp)) then
- Error_Msg_N
- ("default initialization not allowed " &
- "in Unchecked_Union",
- Expression (Comp));
- end if;
-
- declare
- Sindic : constant Node_Id :=
- Subtype_Indication (Component_Definition (Comp));
-
- begin
- if Nkind (Sindic) = N_Subtype_Indication then
- Check_Static_Constraint (Constraint (Sindic));
- end if;
- end;
- end if;
-
- if Present (Next (Comp)) then
- Error_Msg_N
- ("Unchecked_Union variant can have only one component",
- Next (Comp));
- end if;
-
+ 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)
Pragma_Obsolescent => 0,
Pragma_Optimize => -1,
Pragma_Optional_Overriding => -1,
- Pragma_Overriding => -1,
Pragma_Pack => 0,
Pragma_Page => -1,
Pragma_Passive => -1,
-- Stores encoded value of character code CC. The encoding we
-- use an underscore followed by four lower case hex digits.
+ ------------
+ -- Encode --
+ ------------
+
procedure Encode is
begin
Store_String_Char (Get_Char_Code ('_'));
Pref := Prefix (N);
Scop := Scope (Entity (N));
-
while Nkind (Pref) = N_Selected_Component loop
Change_Selected_Component_To_Expanded_Name (Pref);
Set_Entity (Selector_Name (Pref), Scop);
Set_Entity (Pref, Scop);
end if;
end Set_Unit_Name;
-
end Sem_Prag;
OSDN Git Service
