Skip to content

R
riscv-gcc-1
Commit 1ebc2612 by Arnaud Charlet
Options

[multiple changes] 

2014-07-30  Arnaud Charlet  <charlet@adacore.com>

	* set_targ.adb (Read_Target_Dependent_Values): New subprogram.
	(elab body): Add provision for default target config file.
	* get_targ.ads, get_targ.adb (Get_Back_End_Config_File): New subprogram.

2014-07-30  Ed Schonberg  <schonberg@adacore.com>

	* a-cbhase.adb (Delete): Raise Constraint_Error, not Program_Error,
	when attempting to remove an element not in the set. This is
	the given semantics for all set containers.
	* a-cborse.adb (Delete): Attempt removal first, to check for
	tampering, before checking whether this is an attempt to
	delete a  non-existing element, and in fthe latter case raise
	Constraint_Error.

2014-07-30  Vincent Celier  <celier@adacore.com>

	* prj-proc.adb (Recursive_Process): Do not create a new
	Project_Id if the project is already in the list of projects of
	the tree.

2014-07-30  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch6.adb (Analyze_Function_Return): Reject a return expression
	whose type is an incomplete formal type.
	(Analyze_Return_Type): Reject a return type that is an untagged
	imcomplete formal type.
	(Process_Formals): Reject a formal parameter whose type is an
	untagged formal incomplete type.
	* sem_res.adb (Resolve_Actuals): Reject an actual whose type is
	an untagged formal incomplete type.

From-SVN: r213299
parent 45ec05e1
Showing with 277 additions and 144 deletions
gcc/ada/ChangeLog
2014-07-30 Arnaud Charlet <charlet@adacore.com>
* set_targ.adb (Read_Target_Dependent_Values): New subprogram.
(elab body): Add provision for default target config file.
* get_targ.ads, get_targ.adb (Get_Back_End_Config_File): New subprogram.
2014-07-30 Ed Schonberg <schonberg@adacore.com>
* a-cbhase.adb (Delete): Raise Constraint_Error, not Program_Error,
when attempting to remove an element not in the set. This is
the given semantics for all set containers.
* a-cborse.adb (Delete): Attempt removal first, to check for
tampering, before checking whether this is an attempt to
delete a non-existing element, and in fthe latter case raise
Constraint_Error.
2014-07-30 Vincent Celier <celier@adacore.com>
* prj-proc.adb (Recursive_Process): Do not create a new
Project_Id if the project is already in the list of projects of
the tree.
2014-07-30 Ed Schonberg <schonberg@adacore.com>
* sem_ch6.adb (Analyze_Function_Return): Reject a return expression
whose type is an incomplete formal type.
(Analyze_Return_Type): Reject a return type that is an untagged
imcomplete formal type.
(Process_Formals): Reject a formal parameter whose type is an
untagged formal incomplete type.
* sem_res.adb (Resolve_Actuals): Reject an actual whose type is
an untagged formal incomplete type.
2014-07-30 Robert Dewar <dewar@adacore.com>
* gnat_ugn.texi: Minor spelling correction.
......
gcc/ada/a-cbhase.adb
......@@ -313,7 +313,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is
Element_Keys.Delete_Key_Sans_Free (Container, Item, X);
if X = 0 then
raise Program_Error with "attempt to delete element not in set";
raise Constraint_Error with "attempt to delete element not in set";
end if;
HT_Ops.Free (Container, X);
......
gcc/ada/a-cborse.adb
......@@ -500,11 +500,12 @@ package body Ada.Containers.Bounded_Ordered_Sets is
X : constant Count_Type := Element_Keys.Find (Container, Item);
begin
Tree_Operations.Delete_Node_Sans_Free (Container, X);
if X = 0 then
raise Program_Error with "attempt to delete element not in set";
raise Constraint_Error with "attempt to delete element not in set";
end if;
Tree_Operations.Delete_Node_Sans_Free (Container, X);
Tree_Operations.Free (Container, X);
end Delete;
......
gcc/ada/get_targ.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2014, 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- --
......@@ -293,6 +293,15 @@ package body Get_Targ is
return C_Get_Double_Scalar_Alignment;
end Get_Double_Scalar_Alignment;
------------------------------
-- Get_Back_End_Config_File --
------------------------------
function Get_Back_End_Config_File return String_Ptr is
begin
return null;
end Get_Back_End_Config_File;
----------------------
-- Digits_From_Size --
----------------------
......
gcc/ada/get_targ.ads
......@@ -145,4 +145,9 @@ package Get_Targ is
procedure Register_Back_End_Types (Call_Back : Register_Type_Proc);
-- Calls the Call_Back function with information for each supported type
function Get_Back_End_Config_File return String_Ptr;
-- Return the back end configuration file, or null if none.
-- If non null, this file should be used instead of calling the various
-- Get_xxx functions in this package.
end Get_Targ;
gcc/ada/prj-proc.adb
......@@ -2845,20 +2845,42 @@ package body Prj.Proc is
return;
end if;
-- Check if the project is already in the tree
Project := No_Project;
declare
List : Project_List := In_Tree.Projects;
Path : constant Path_Name_Type :=
Path_Name_Of (From_Project_Node,
From_Project_Node_Tree);
begin
while List /= null loop
if List.Project.Path.Display_Name = Path then
Project := List.Project;
exit;
end if;
List := List.Next;
end loop;
end;
if Project = No_Project then
Project :=
new Project_Data'
(Empty_Project
(Project_Qualifier_Of
(From_Project_Node, From_Project_Node_Tree)));
-- Note that at this point we do not know yet if the project has
-- been withed from an encapsulated library or not.
-- Note that at this point we do not know yet if the project
-- has been withed from an encapsulated library or not.
In_Tree.Projects :=
new Project_List_Element'
(Project => Project,
From_Encapsulated_Lib => False,
Next => In_Tree.Projects);
end if;
-- Keep track of this point
......
gcc/ada/sem_ch6.adb
......@@ -981,6 +981,14 @@ package body Sem_Ch6 is
then
Error_Msg_N ("cannot return local access to subprogram", N);
end if;
-- The expression cannot be of a formal incomplete type
elsif Ekind (Etype (Expr)) = E_Incomplete_Type
and then Is_Generic_Type (Etype (Expr))
then
Error_Msg_N
("cannot return expression of a formal incomplete type", N);
end if;
-- If the result type is class-wide, then check that the return
......@@ -1953,6 +1961,24 @@ package body Sem_Ch6 is
("invalid use of incomplete type&",
Result_Definition (N), Typ);
-- The return type of a subprogram body cannot be of a
-- formal incomplete type.
elsif Is_Generic_Type (Typ)
and then Nkind (Parent (N)) = N_Subprogram_Body
then
Error_Msg_N
("return type cannot be a formal incomplete type",
Result_Definition (N));
elsif Is_Class_Wide_Type (Typ)
and then Is_Generic_Type (Root_Type (Typ))
and then Nkind (Parent (N)) = N_Subprogram_Body
then
Error_Msg_N
("return type cannot be a formal incomplete type",
Result_Definition (N));
elsif Is_Tagged_Type (Typ) then
null;
......@@ -9827,7 +9853,8 @@ package body Sem_Ch6 is
if Is_Tagged_Type (Formal_Type)
or else (Ada_Version >= Ada_2012
and then not From_Limited_With (Formal_Type))
and then not From_Limited_With (Formal_Type)
and then not Is_Generic_Type (Formal_Type))
then
if Ekind (Scope (Current_Scope)) = E_Package
and then not Is_Generic_Type (Formal_Type)
......@@ -9864,8 +9891,17 @@ package body Sem_Ch6 is
-- in bodies. Limited views of either kind are not allowed
-- if there is no place at which the non-limited view can
-- become available.
-- Incomplete formal untagged types are not allowed in
-- subprogram bodies (but are legal in their declarations).
if Ada_Version >= Ada_2012 then
if Is_Generic_Type (Formal_Type)
and then not Is_Tagged_Type (Formal_Type)
and then Nkind (Parent (Related_Nod)) = N_Subprogram_Body
then
Error_Msg_N
("invalid use of formal incomplete type", Param_Spec);
elsif Ada_Version >= Ada_2012 then
if Is_Tagged_Type (Formal_Type)
and then (not From_Limited_With (Formal_Type)
or else not In_Package_Body)
......
gcc/ada/sem_res.adb
......@@ -3864,6 +3864,16 @@ package body Sem_Res is
A_Typ := Etype (A);
F_Typ := Etype (F);
-- An actual cannot be an untagged formal incomplete type
if Ekind (A_Typ) = E_Incomplete_Type
and then not Is_Tagged_Type (A_Typ)
and then Is_Generic_Type (A_Typ)
then
Error_Msg_N
("invalid use of untagged formal incomplete type", A);
end if;
if Comes_From_Source (Original_Node (N))
and then Nkind_In (Original_Node (N), N_Function_Call,
N_Procedure_Call_Statement)
......
gcc/ada/set_targ.adb
......@@ -130,6 +130,10 @@ package body Set_Targ is
-- Local Subprograms --
-----------------------
procedure Read_Target_Dependent_Values (File_Name : String);
-- Read target dependent values from File_Name, and set the target
-- dependent values (global variables) declared in this package.
procedure Fail (E : String);
pragma No_Return (Fail);
-- Terminate program with fatal error message passed as parameter
......@@ -481,134 +485,11 @@ package body Set_Targ is
end if;
end Write_Target_Dependent_Values;
-- Package Initialization, set target dependent values. This must be done
-- early on, before we start accessing various compiler packages, since
-- these values are used all over the place.
begin
-- First step: see if the -gnateT switch is present. As we have noted,
-- this has to be done very early, so can not depend on the normal circuit
-- for reading switches and setting switches in Opt. The following code
-- will set Opt.Target_Dependent_Info_Read_Name if the switch -gnateT=name
-- is present in the options string.
declare
type Arg_Array is array (Nat) of Big_String_Ptr;
type Arg_Array_Ptr is access Arg_Array;
-- Types to access compiler arguments
save_argc : Nat;
pragma Import (C, save_argc);
-- Saved value of argc (number of arguments), imported from misc.c
save_argv : Arg_Array_Ptr;
pragma Import (C, save_argv);
-- Saved value of argv (argument pointers), imported from misc.c
gnat_argc : Nat;
gnat_argv : Arg_Array_Ptr;
pragma Import (C, gnat_argc);
pragma Import (C, gnat_argv);
-- If save_argv is not set, default to gnat_argc/argv
argc : Nat;
argv : Arg_Array_Ptr;
function Len_Arg (Arg : Big_String_Ptr) return Nat;
-- Determine length of argument Arg (a nul terminated C string).
-------------
-- Len_Arg --
-------------
function Len_Arg (Arg : Big_String_Ptr) return Nat is
begin
for J in 1 .. Nat'Last loop
if Arg (Natural (J)) = ASCII.NUL then
return J - 1;
end if;
end loop;
raise Program_Error;
end Len_Arg;
begin
if save_argv /= null then
argv := save_argv;
argc := save_argc;
else
-- Case of a non gcc compiler, e.g. gnat2why or gnat2scil
argv := gnat_argv;
argc := gnat_argc;
end if;
-- Loop through arguments looking for -gnateT, also look for -gnatd.b
----------------------------------
-- Read_Target_Dependent_Values --
----------------------------------
for Arg in 1 .. argc - 1 loop
declare
Argv_Ptr : constant Big_String_Ptr := argv (Arg);
Argv_Len : constant Nat := Len_Arg (Argv_Ptr);
begin
if Argv_Len > 8
and then Argv_Ptr (1 .. 8) = "-gnateT="
then
Opt.Target_Dependent_Info_Read_Name :=
new String'(Argv_Ptr (9 .. Natural (Argv_Len)));
elsif Argv_Len >= 8
and then Argv_Ptr (1 .. 8) = "-gnatd.b"
then
Debug_Flag_Dot_B := True;
end if;
end;
end loop;
end;
-- If the switch is not set, we get all values from the back end
if Opt.Target_Dependent_Info_Read_Name = null then
-- Set values by direct calls to the back end
Bits_BE := Get_Bits_BE;
Bits_Per_Unit := Get_Bits_Per_Unit;
Bits_Per_Word := Get_Bits_Per_Word;
Bytes_BE := Get_Bytes_BE;
Char_Size := Get_Char_Size;
Double_Float_Alignment := Get_Double_Float_Alignment;
Double_Scalar_Alignment := Get_Double_Scalar_Alignment;
Double_Size := Get_Double_Size;
Float_Size := Get_Float_Size;
Float_Words_BE := Get_Float_Words_BE;
Int_Size := Get_Int_Size;
Long_Double_Size := Get_Long_Double_Size;
Long_Long_Size := Get_Long_Long_Size;
Long_Size := Get_Long_Size;
Maximum_Alignment := Get_Maximum_Alignment;
Max_Unaligned_Field := Get_Max_Unaligned_Field;
Pointer_Size := Get_Pointer_Size;
Short_Enums := Get_Short_Enums;
Short_Size := Get_Short_Size;
Strict_Alignment := Get_Strict_Alignment;
System_Allocator_Alignment := Get_System_Allocator_Alignment;
Wchar_T_Size := Get_Wchar_T_Size;
Words_BE := Get_Words_BE;
-- Register floating-point types from the back end
Register_Back_End_Types (Register_Float_Type'Access);
-- Case of reading the target dependent values from file
-- This is bit more complex than might be expected, because it has to be
-- done very early. All kinds of packages depend on these values, and we
-- can't wait till the normal processing of reading command line switches
-- etc to read the file. We do this at the System.OS_Lib level since it is
-- too early to be using Osint directly.
else
Read_Target_Dependent_Values : declare
procedure Read_Target_Dependent_Values (File_Name : String) is
File_Desc : File_Descriptor;
N : Natural;
......@@ -668,7 +549,7 @@ begin
procedure FailN (S : String) is
begin
Fail (S & " """ & Nam_Buf (1 .. Nam_Len) & """ in file "
& Target_Dependent_Info_Read_Name.all);
& File_Name);
end FailN;
--------------
......@@ -743,16 +624,16 @@ begin
-- Start of processing for Read_Target_Dependent_Values
begin
File_Desc := Open_Read (Target_Dependent_Info_Read_Name.all, Text);
File_Desc := Open_Read (File_Name, Text);
if File_Desc = Invalid_FD then
Fail ("cannot read file " & Target_Dependent_Info_Read_Name.all);
Fail ("cannot read file " & File_Name);
end if;
Buflen := Read (File_Desc, Buffer'Address, Buffer'Length);
if Buflen = Buffer'Length then
Fail ("file is too long: " & Target_Dependent_Info_Read_Name.all);
Fail ("file is too long: " & File_Name);
end if;
-- Scan through file for properly formatted entries in first section
......@@ -794,22 +675,20 @@ begin
for J in DTR'Range loop
if not DTR (J) then
Fail ("missing entry for " & DTN (J).all & " in file "
& Target_Dependent_Info_Read_Name.all);
& File_Name);
end if;
end loop;
-- Now acquire FPT entries
if N >= Buflen then
Fail ("missing entries for FPT modes in file "
& Target_Dependent_Info_Read_Name.all);
Fail ("missing entries for FPT modes in file " & File_Name);
end if;
if Buffer (N) = ASCII.LF then
N := N + 1;
else
Fail ("missing blank line in file "
& Target_Dependent_Info_Read_Name.all);
Fail ("missing blank line in file " & File_Name);
end if;
Num_FPT_Modes := 0;
......@@ -859,5 +738,143 @@ begin
end;
end loop;
end Read_Target_Dependent_Values;
-- Package Initialization, set target dependent values. This must be done
-- early on, before we start accessing various compiler packages, since
-- these values are used all over the place.
begin
-- First step: see if the -gnateT switch is present. As we have noted,
-- this has to be done very early, so can not depend on the normal circuit
-- for reading switches and setting switches in Opt. The following code
-- will set Opt.Target_Dependent_Info_Read_Name if the switch -gnateT=name
-- is present in the options string.
declare
type Arg_Array is array (Nat) of Big_String_Ptr;
type Arg_Array_Ptr is access Arg_Array;
-- Types to access compiler arguments
save_argc : Nat;
pragma Import (C, save_argc);
-- Saved value of argc (number of arguments), imported from misc.c
save_argv : Arg_Array_Ptr;
pragma Import (C, save_argv);
-- Saved value of argv (argument pointers), imported from misc.c
gnat_argc : Nat;
gnat_argv : Arg_Array_Ptr;
pragma Import (C, gnat_argc);
pragma Import (C, gnat_argv);
-- If save_argv is not set, default to gnat_argc/argv
argc : Nat;
argv : Arg_Array_Ptr;
function Len_Arg (Arg : Big_String_Ptr) return Nat;
-- Determine length of argument Arg (a nul terminated C string).
-------------
-- Len_Arg --
-------------
function Len_Arg (Arg : Big_String_Ptr) return Nat is
begin
for J in 1 .. Nat'Last loop
if Arg (Natural (J)) = ASCII.NUL then
return J - 1;
end if;
end loop;
raise Program_Error;
end Len_Arg;
begin
if save_argv /= null then
argv := save_argv;
argc := save_argc;
else
-- Case of a non gcc compiler, e.g. gnat2why or gnat2scil
argv := gnat_argv;
argc := gnat_argc;
end if;
-- Loop through arguments looking for -gnateT, also look for -gnatd.b
for Arg in 1 .. argc - 1 loop
declare
Argv_Ptr : constant Big_String_Ptr := argv (Arg);
Argv_Len : constant Nat := Len_Arg (Argv_Ptr);
begin
if Argv_Len > 8
and then Argv_Ptr (1 .. 8) = "-gnateT="
then
Opt.Target_Dependent_Info_Read_Name :=
new String'(Argv_Ptr (9 .. Natural (Argv_Len)));
elsif Argv_Len >= 8
and then Argv_Ptr (1 .. 8) = "-gnatd.b"
then
Debug_Flag_Dot_B := True;
end if;
end;
end loop;
end;
-- Case of reading the target dependent values from file
-- This is bit more complex than might be expected, because it has to be
-- done very early. All kinds of packages depend on these values, and we
-- can't wait till the normal processing of reading command line switches
-- etc to read the file. We do this at the System.OS_Lib level since it is
-- too early to be using Osint directly.
if Opt.Target_Dependent_Info_Read_Name /= null then
Read_Target_Dependent_Values (Target_Dependent_Info_Read_Name.all);
else
-- If the back-end comes with a target config file, then use it
-- to set the values
declare
Back_End_Config_File : constant String_Ptr :=
Get_Back_End_Config_File;
begin
if Back_End_Config_File /= null then
Read_Target_Dependent_Values (Back_End_Config_File.all);
-- Otherwise we get all values from the back end directly
else
Bits_BE := Get_Bits_BE;
Bits_Per_Unit := Get_Bits_Per_Unit;
Bits_Per_Word := Get_Bits_Per_Word;
Bytes_BE := Get_Bytes_BE;
Char_Size := Get_Char_Size;
Double_Float_Alignment := Get_Double_Float_Alignment;
Double_Scalar_Alignment := Get_Double_Scalar_Alignment;
Double_Size := Get_Double_Size;
Float_Size := Get_Float_Size;
Float_Words_BE := Get_Float_Words_BE;
Int_Size := Get_Int_Size;
Long_Double_Size := Get_Long_Double_Size;
Long_Long_Size := Get_Long_Long_Size;
Long_Size := Get_Long_Size;
Maximum_Alignment := Get_Maximum_Alignment;
Max_Unaligned_Field := Get_Max_Unaligned_Field;
Pointer_Size := Get_Pointer_Size;
Short_Enums := Get_Short_Enums;
Short_Size := Get_Short_Size;
Strict_Alignment := Get_Strict_Alignment;
System_Allocator_Alignment := Get_System_Allocator_Alignment;
Wchar_T_Size := Get_Wchar_T_Size;
Words_BE := Get_Words_BE;
-- Register floating-point types from the back end
Register_Back_End_Types (Register_Float_Type'Access);
end if;
end;
end if;
end Set_Targ;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment