-- is posted (with the same effect as Error_Msg_N (Msg, N) if and only
-- if Eflag is True and if the node N is within the main extended source
-- unit and comes from source. Typically this is a warning mode flag.
+ -- This routine can only be called during semantic analysis. It may not
+ -- be called during parsing.
procedure Change_Error_Text (Error_Id : Error_Msg_Id; New_Msg : String);
-- The error message text of the message identified by Id is replaced by
Nod := N;
Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
- -- Construct argument list for the initialization routine call.
- -- The CPP constructor needs the address directly
+ -- Construct argument list for the initialization routine call
- if Is_CPP_Class (T) then
- Arg1 := New_Reference_To (Temp, Loc);
- Temp_Type := T;
+ Arg1 :=
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Reference_To (Temp, Loc));
+ Set_Assignment_OK (Arg1);
+ Temp_Type := PtrT;
- else
- Arg1 := Make_Explicit_Dereference (Loc,
- Prefix => New_Reference_To (Temp, Loc));
- Set_Assignment_OK (Arg1);
- Temp_Type := PtrT;
-
- -- The initialization procedure expects a specific type. if
- -- the context is access to class wide, indicate that the
- -- object being allocated has the right specific type.
+ -- The initialization procedure expects a specific type. if the
+ -- context is access to class wide, indicate that the object being
+ -- allocated has the right specific type.
- if Is_Class_Wide_Type (Dtyp) then
- Arg1 := Unchecked_Convert_To (T, Arg1);
- end if;
+ if Is_Class_Wide_Type (Dtyp) then
+ Arg1 := Unchecked_Convert_To (T, Arg1);
end if;
-- If designated type is a concurrent type or if it is private
Expression => Nod);
Set_Assignment_OK (Temp_Decl);
-
- if Is_CPP_Class (T) then
- Set_Aliased_Present (Temp_Decl);
- end if;
-
Insert_Action (N, Temp_Decl, Suppress => All_Checks);
-- If the designated type is a task type or contains tasks,
end if;
end if;
- if Is_CPP_Class (T) then
- Rewrite (N,
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Temp, Loc),
- Attribute_Name => Name_Unchecked_Access));
- else
- Rewrite (N, New_Reference_To (Temp, Loc));
- end if;
-
+ Rewrite (N, New_Reference_To (Temp, Loc));
Analyze_And_Resolve (N, PtrT);
end if;
end;
elsif Is_Array_Type (Typl) then
- -- If we are doing full validity checking, then expand out array
- -- comparisons to make sure that we check the array elements.
+ -- If we are doing full validity checking, and it is possible for the
+ -- array elements to be invalid then expand out array comparisons to
+ -- make sure that we check the array elements.
- if Validity_Check_Operands then
+ if Validity_Check_Operands
+ and then not Is_Known_Valid (Component_Type (Typl))
+ then
declare
Save_Force_Validity_Checks : constant Boolean :=
Force_Validity_Checks;
Rhi : Uint;
ROK : Boolean;
+ pragma Warnings (Off, Lhi);
+
begin
Binary_Op_Validity_Checks (N);
Rhi : Uint;
ROK : Boolean;
+ pragma Warnings (Off, Lhi);
+
begin
Binary_Op_Validity_Checks (N);
Expanded : Boolean)
is
begin
+ if Cmd.Expanded = null then
+ Iter.List := null;
+ return;
+ end if;
+
-- Coalesce the switches as much as possible
if not Expanded
procedure Delete_Temp_Config_Files is
Success : Boolean;
+ pragma Warnings (Off, Success);
begin
if not Keep_Temporary_Files then
for J in 1 .. First_Switches.Last loop
if First_Switches.Table (J).all = "-cargs" then
- for K in J + 1 .. First_Switches.Last loop
- Add_To_Carg_Switches (First_Switches.Table (K));
- end loop;
- First_Switches.Set_Last (J - 1);
+ declare
+ K : Positive;
+ Last : Natural;
+
+ begin
+ -- Move the switches that are before -rules when the
+ -- command is CHECK.
+
+ K := J + 1;
+ while K <= First_Switches.Last
+ and then
+ (The_Command /= Check
+ or else First_Switches.Table (K).all /= "-rules")
+ loop
+ Add_To_Carg_Switches (First_Switches.Table (K));
+ K := K + 1;
+ end loop;
+
+ if K > First_Switches.Last then
+ First_Switches.Set_Last (J - 1);
+
+ else
+ Last := J - 1;
+ while K <= First_Switches.Last loop
+ Last := Last + 1;
+ First_Switches.Table (Last) :=
+ First_Switches.Table (K);
+ K := K + 1;
+ end loop;
+
+ First_Switches.Set_Last (Last);
+ end if;
+ end;
+
exit;
end if;
end loop;
for J in 1 .. Last_Switches.Last loop
if Last_Switches.Table (J).all = "-cargs" then
- for K in J + 1 .. Last_Switches.Last loop
- Add_To_Carg_Switches (Last_Switches.Table (K));
- end loop;
- Last_Switches.Set_Last (J - 1);
+ declare
+ K : Positive;
+ Last : Natural;
+
+ begin
+ -- Move the switches that are before -rules when the
+ -- command is CHECK.
+
+ K := J + 1;
+ while K <= Last_Switches.Last
+ and then
+ (The_Command /= Check
+ or else
+ Last_Switches.Table (K).all /= "-rules")
+ loop
+ Add_To_Carg_Switches (Last_Switches.Table (K));
+ K := K + 1;
+ end loop;
+
+ if K > Last_Switches.Last then
+ Last_Switches.Set_Last (J - 1);
+
+ else
+ Last := J - 1;
+ while K <= Last_Switches.Last loop
+ Last := Last + 1;
+ Last_Switches.Table (Last) :=
+ Last_Switches.Table (K);
+ K := K + 1;
+ end loop;
+
+ Last_Switches.Set_Last (Last);
+ end if;
+ end;
+
exit;
end if;
end loop;
elsif The_Command = Stub then
declare
- Data : constant Prj.Project_Data :=
- Project_Tree.Projects.Table (Project);
+ Data : constant Prj.Project_Data :=
+ Project_Tree.Projects.Table (Project);
File_Index : Integer := 0;
Dir_Index : Integer := 0;
Last : constant Integer := Last_Switches.Last;
if Spec'Length > Name_Len
and then Spec (Last - Name_Len + 1 .. Last) =
- Name_Buffer (1 .. Name_Len)
+ Name_Buffer (1 .. Name_Len)
then
Last := Last - Name_Len;
Get_Name_String
if File_Index /= 0 then
for Index in File_Index + 1 .. Last loop
if Last_Switches.Table (Index)
- (Last_Switches.Table (Index)'First) /= '-'
+ (Last_Switches.Table (Index)'First) /= '-'
then
Dir_Index := Index;
exit;
if The_Command = Check then
declare
- New_Last : Natural;
+ New_Last : Natural;
-- Set to rank of options preceding "-rules"
In_Rules_Switches : Boolean;
break;
}
- Raise_From_Signal_Handler (exception, msg);
+ Raise_From_Signal_Handler (exception, msg);
}
long
-- Same function as above but argument is a source pointer
function Earlier_In_Extended_Unit (S1, S2 : Source_Ptr) return Boolean;
- -- Given two Sloc values for which In_Same_Extended_Unit is true,
- -- determine if S1 appears before S2. Returns True if S1 appears before
- -- S2, and False otherwise. The result is undefined if S1 and S2 are
- -- not in the same extended unit.
+ -- Given two Sloc values for which In_Same_Extended_Unit is true, determine
+ -- if S1 appears before S2. Returns True if S1 appears before S2, and False
+ -- otherwise. The result is undefined if S1 and S2 are not in the same
+ -- extended unit. Note: this routine will not give reliable results if
+ -- called after Sprint has been called with -gnatD set.
function Compilation_Switches_Last return Nat;
-- Return the count of stored compilation switches
-- buffers etc from writes by Write_Binder_Info.
procedure Set_Current_File_Name_Index (To : Int);
- -- Set the value of Current_File_Name_Index (in the private part of Osint)
- -- to To.
+ -- Set value of Current_File_Name_Index (in private part of Osint) to To
end Osint.B;
Process_Partition_Id (N);
return;
+ ------------------
+ -- Pool_Address --
+ ------------------
+
when Attribute_Pool_Address =>
Resolve (P);
Generate_Reference (Entry_Id, Entry_Name);
if Present (First_Formal (Entry_Id)) then
- if VM_Target = JVM_Target then
+ if VM_Target = JVM_Target and then not Inspector_Mode then
Error_Msg_N
("arguments unsupported in requeue statement",
First_Formal (Entry_Id));
OSDN Git Service
