procedure Process_Compile_Time_Warning_Or_Error;
-- Common processing for Compile_Time_Error and Compile_Time_Warning
- procedure Process_Convention (C : out Convention_Id; E : out Entity_Id);
+ procedure Process_Convention
+ (C : out Convention_Id;
+ Ent : out Entity_Id);
-- Common processing for Convention, Interface, Import and Export.
-- Checks first two arguments of pragma, and sets the appropriate
-- convention value in the specified entity or entities. On return
- -- C is the convention, E is the referenced entity.
+ -- C is the convention, Ent is the referenced entity.
procedure Process_Extended_Import_Export_Exception_Pragma
(Arg_Internal : Node_Id;
String_Val : constant String_Id := Strval (Nam);
begin
+ -- We allow duplicated export names in CIL, as they are always
+ -- enclosed in a namespace that differentiates them, and overloaded
+ -- entities are supported by the VM.
+
+ if VM_Target = CLI_Target then
+ return;
+ end if;
+
-- We are only interested in the export case, and in the case of
-- generics, it is the instance, not the template, that is the
-- problem (the template will generate a warning in any case).
-- Record whether pragma is enabled
- Set_PPC_Enabled (N, Check_Enabled (Pname));
+ Set_Pragma_Enabled (N, Check_Enabled (Pname));
-- If we are within an inlined body, the legality of the pragma
-- has been checked already.
------------------------
procedure Process_Convention
- (C : out Convention_Id;
- E : out Entity_Id)
+ (C : out Convention_Id;
+ Ent : out Entity_Id)
is
Id : Node_Id;
+ E : Entity_Id;
E1 : Entity_Id;
Cname : Name_Id;
Comp_Unit : Unit_Number_Type;
E := Entity (Id);
+ -- Set entity to return
+
+ Ent := E;
+
-- Go to renamed subprogram if present, since convention applies to
-- the actual renamed entity, not to the renaming entity. If the
-- subprogram is inherited, go to parent subprogram.
and then Scope (E) = Scope (Alias (E))
then
E := Alias (E);
+
+ -- Return the parent subprogram the entity was inherited from
+
+ Ent := E;
end if;
end if;
Generate_Reference (E, Id, 'b');
end if;
- E1 := E;
+ -- Loop through the homonyms of the pragma argument's entity
+
+ E1 := Ent;
loop
E1 := Homonym (E1);
exit when No (E1) or else Scope (E1) /= Current_Scope;
Set_Convention_From_Pragma (E1);
if Prag_Id = Pragma_Import then
- Generate_Reference (E, Id, 'b');
+ Generate_Reference (E1, Id, 'b');
end if;
end if;
end loop;
else
Set_Imported (Def_Id);
+ -- Reject an Import applied to an abstract subprogram
+
+ if Is_Subprogram (Def_Id)
+ and then Is_Abstract_Subprogram (Def_Id)
+ then
+ Error_Msg_Sloc := Sloc (Def_Id);
+ Error_Msg_NE
+ ("cannot import abstract subprogram& declared#",
+ Arg2, Def_Id);
+ end if;
+
-- Special processing for Convention_Intrinsic
if C = Convention_Intrinsic then
-- Annotate --
--------------
- -- pragma Annotate (IDENTIFIER {, ARG});
+ -- pragma Annotate (IDENTIFIER [, IDENTIFIER {, ARG}]);
-- ARG ::= NAME | EXPRESSION
+ -- The first two arguments are by convention intended to refer to an
+ -- external tool and a tool-specific function. These arguments are
+ -- not analyzed.
+
when Pragma_Annotate => Annotate : begin
GNAT_Pragma;
Check_At_Least_N_Arguments (1);
Exp : Node_Id;
begin
- Arg := Arg2;
- while Present (Arg) loop
- Exp := Expression (Arg);
- Analyze (Exp);
+ -- Second unanalyzed parameter is optional
- if Is_Entity_Name (Exp) then
- null;
+ if No (Arg2) then
+ null;
+ else
+ Arg := Next (Arg2);
+ while Present (Arg) loop
+ Exp := Expression (Arg);
+ Analyze (Exp);
- elsif Nkind (Exp) = N_String_Literal then
- Resolve (Exp, Standard_String);
+ if Is_Entity_Name (Exp) then
+ null;
- elsif Is_Overloaded (Exp) then
- Error_Pragma_Arg ("ambiguous argument for pragma%", Exp);
+ -- For string literals, we assume Standard_String as the
+ -- type, unless the string contains wide or wide_wide
+ -- characters.
- else
- Resolve (Exp);
- end if;
+ elsif Nkind (Exp) = N_String_Literal then
+ if Has_Wide_Wide_Character (Exp) then
+ Resolve (Exp, Standard_Wide_Wide_String);
+ elsif Has_Wide_Character (Exp) then
+ Resolve (Exp, Standard_Wide_String);
+ else
+ Resolve (Exp, Standard_String);
+ end if;
- Next (Arg);
- end loop;
+ elsif Is_Overloaded (Exp) then
+ Error_Pragma_Arg
+ ("ambiguous argument for pragma%", Exp);
+
+ else
+ Resolve (Exp);
+ end if;
+
+ Next (Arg);
+ end loop;
+ end if;
end;
end Annotate;
Check_Arg_Is_Identifier (Arg1);
Check_On := Check_Enabled (Chars (Get_Pragma_Arg (Arg1)));
+ Set_Pragma_Enabled (N, Check_On);
-- If expansion is active and the check is not enabled then we
-- rewrite the Check as:
when Pragma_Reviewable =>
Check_Ada_83_Warning;
Check_Arg_Count (0);
+
+ -- Call dummy debugging function rv. This is done to assist front
+ -- end debugging. By placing a Reviewable pragma in the source
+ -- program, a breakpoint on rv catches this place in the source,
+ -- allowing convenient stepping to the point of interest.
+
rv;
+ --------------------------
+ -- Short_Circuit_And_Or --
+ --------------------------
+
+ when Pragma_Short_Circuit_And_Or =>
+ GNAT_Pragma;
+ Check_Arg_Count (0);
+ Check_Valid_Configuration_Pragma;
+ Short_Circuit_And_Or := True;
+
-------------------
-- Share_Generic --
-------------------
Check_At_Least_N_Arguments (1);
Check_No_Identifiers;
+ -- If debug flag -gnatd.i is set, pragma is ignored
+
+ if Debug_Flag_Dot_I then
+ return;
+ end if;
+
+ -- Process various forms of the pragma
+
declare
Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
Pragma_Restriction_Warnings => -1,
Pragma_Restrictions => -1,
Pragma_Reviewable => -1,
+ Pragma_Short_Circuit_And_Or => -1,
Pragma_Share_Generic => -1,
Pragma_Shared => -1,
Pragma_Shared_Passive => -1,
OSDN Git Service
