-- --
-- 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 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;
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
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 for& 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);
-- 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));
------------
-- 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 =>
+ when Pragma_Ada_05 => declare
+ E_Id : Node_Id;
+
+ 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
- -- A record type that is the Equivalent_Type for
- -- a remote access-to-subprogram type.
+ 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 (Corresponding_Remote_Type (Nm));
+ N := Declaration_Node (Nm);
+ end if;
if Nkind (N) = N_Full_Type_Declaration
and then Nkind (Type_Definition (N)) =
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));
+ RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm));
end if;
else
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;
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;
-- 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 Present (Prev (N)) then
+ Subp := Prev (N);
- if No (Prev (N))
- or else (Nkind (Prev (N))) /= N_Subprogram_Declaration
+ -- 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 --
----------
end if;
if Present (External) then
+ Check_Arg_Is_External_Name (External);
Check_Too_Long (External);
end if;
Pragma_Obsolescent => 0,
Pragma_Optimize => -1,
Pragma_Optional_Overriding => -1,
- Pragma_Overriding => -1,
Pragma_Pack => 0,
Pragma_Page => -1,
Pragma_Passive => -1,
OSDN Git Service
