[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
This commit is contained in:
Arnaud Charlet
parent
45ec05e18a
commit
1ebc2612da
@ -1,3 +1,36 @@
|
||||
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.
|
||||
|
||||
@ -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);
|
||||
|
||||
@ -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;
|
||||
|
||||
|
||||
@ -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 --
|
||||
----------------------
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -2845,20 +2845,42 @@ package body Prj.Proc is
|
||||
return;
|
||||
end if;
|
||||
|
||||
Project :=
|
||||
new Project_Data'
|
||||
(Empty_Project
|
||||
(Project_Qualifier_Of
|
||||
(From_Project_Node, From_Project_Node_Tree)));
|
||||
-- Check if the project is already in the tree
|
||||
|
||||
-- Note that at this point we do not know yet if the project has
|
||||
-- been withed from an encapsulated library or not.
|
||||
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);
|
||||
|
||||
In_Tree.Projects :=
|
||||
new Project_List_Element'
|
||||
(Project => Project,
|
||||
From_Encapsulated_Lib => False,
|
||||
Next => In_Tree.Projects);
|
||||
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.
|
||||
|
||||
In_Tree.Projects :=
|
||||
new Project_List_Element'
|
||||
(Project => Project,
|
||||
From_Encapsulated_Lib => False,
|
||||
Next => In_Tree.Projects);
|
||||
end if;
|
||||
|
||||
-- Keep track of this point
|
||||
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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,6 +485,260 @@ package body Set_Targ is
|
||||
end if;
|
||||
end Write_Target_Dependent_Values;
|
||||
|
||||
----------------------------------
|
||||
-- Read_Target_Dependent_Values --
|
||||
----------------------------------
|
||||
|
||||
procedure Read_Target_Dependent_Values (File_Name : String) is
|
||||
File_Desc : File_Descriptor;
|
||||
N : Natural;
|
||||
|
||||
type ANat is access all Natural;
|
||||
-- Pointer to Nat or Pos value (it is harmless to treat Pos values
|
||||
-- as Nat via Unchecked_Conversion).
|
||||
|
||||
function To_ANat is new Unchecked_Conversion (Address, ANat);
|
||||
|
||||
VP : ANat;
|
||||
|
||||
Buffer : String (1 .. 2000);
|
||||
Buflen : Natural;
|
||||
-- File information and length (2000 easily enough)
|
||||
|
||||
Nam_Buf : String (1 .. 40);
|
||||
Nam_Len : Natural;
|
||||
|
||||
procedure Check_Spaces;
|
||||
-- Checks that we have one or more spaces and skips them
|
||||
|
||||
procedure FailN (S : String);
|
||||
-- Calls Fail adding " name in file xxx", where name is the currently
|
||||
-- gathered name in Nam_Buf, surrounded by quotes, and xxx is the
|
||||
-- name of the file.
|
||||
|
||||
procedure Get_Name;
|
||||
-- Scan out name, leaving it in Nam_Buf with Nam_Len set. Calls
|
||||
-- Skip_Spaces to skip any following spaces. Note that the name is
|
||||
-- terminated by a sequence of at least two spaces.
|
||||
|
||||
function Get_Nat return Natural;
|
||||
-- N on entry points to decimal integer, scan out decimal integer
|
||||
-- and return it, leaving N pointing to following space or LF.
|
||||
|
||||
procedure Skip_Spaces;
|
||||
-- Skip past spaces
|
||||
|
||||
------------------
|
||||
-- Check_Spaces --
|
||||
------------------
|
||||
|
||||
procedure Check_Spaces is
|
||||
begin
|
||||
if N > Buflen or else Buffer (N) /= ' ' then
|
||||
FailN ("missing space for");
|
||||
end if;
|
||||
|
||||
Skip_Spaces;
|
||||
return;
|
||||
end Check_Spaces;
|
||||
|
||||
-----------
|
||||
-- FailN --
|
||||
-----------
|
||||
|
||||
procedure FailN (S : String) is
|
||||
begin
|
||||
Fail (S & " """ & Nam_Buf (1 .. Nam_Len) & """ in file "
|
||||
& File_Name);
|
||||
end FailN;
|
||||
|
||||
--------------
|
||||
-- Get_Name --
|
||||
--------------
|
||||
|
||||
procedure Get_Name is
|
||||
begin
|
||||
Nam_Len := 0;
|
||||
|
||||
-- Scan out name and put it in Nam_Buf
|
||||
|
||||
loop
|
||||
if N > Buflen or else Buffer (N) = ASCII.LF then
|
||||
FailN ("incorrectly formatted line for");
|
||||
end if;
|
||||
|
||||
-- Name is terminated by two blanks
|
||||
|
||||
exit when N < Buflen and then Buffer (N .. N + 1) = " ";
|
||||
|
||||
Nam_Len := Nam_Len + 1;
|
||||
|
||||
if Nam_Len > Nam_Buf'Last then
|
||||
Fail ("name too long");
|
||||
end if;
|
||||
|
||||
Nam_Buf (Nam_Len) := Buffer (N);
|
||||
N := N + 1;
|
||||
end loop;
|
||||
|
||||
Check_Spaces;
|
||||
end Get_Name;
|
||||
|
||||
-------------
|
||||
-- Get_Nat --
|
||||
-------------
|
||||
|
||||
function Get_Nat return Natural is
|
||||
Result : Natural := 0;
|
||||
|
||||
begin
|
||||
loop
|
||||
if N > Buflen
|
||||
or else Buffer (N) not in '0' .. '9'
|
||||
or else Result > 999
|
||||
then
|
||||
FailN ("bad value for");
|
||||
end if;
|
||||
|
||||
Result := Result * 10 + (Character'Pos (Buffer (N)) - 48);
|
||||
N := N + 1;
|
||||
|
||||
exit when N <= Buflen
|
||||
and then (Buffer (N) = ASCII.LF or else Buffer (N) = ' ');
|
||||
end loop;
|
||||
|
||||
return Result;
|
||||
end Get_Nat;
|
||||
|
||||
-----------------
|
||||
-- Skip_Spaces --
|
||||
-----------------
|
||||
|
||||
procedure Skip_Spaces is
|
||||
begin
|
||||
while N <= Buflen and Buffer (N) = ' ' loop
|
||||
N := N + 1;
|
||||
end loop;
|
||||
end Skip_Spaces;
|
||||
|
||||
-- Start of processing for Read_Target_Dependent_Values
|
||||
|
||||
begin
|
||||
File_Desc := Open_Read (File_Name, Text);
|
||||
|
||||
if File_Desc = Invalid_FD then
|
||||
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: " & File_Name);
|
||||
end if;
|
||||
|
||||
-- Scan through file for properly formatted entries in first section
|
||||
|
||||
N := 1;
|
||||
while N <= Buflen and then Buffer (N) /= ASCII.LF loop
|
||||
Get_Name;
|
||||
|
||||
-- Validate name and get corresponding value pointer
|
||||
|
||||
VP := null;
|
||||
|
||||
for J in DTN'Range loop
|
||||
if DTN (J).all = Nam_Buf (1 .. Nam_Len) then
|
||||
VP := To_ANat (DTV (J));
|
||||
DTR (J) := True;
|
||||
exit;
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
if VP = null then
|
||||
FailN ("unrecognized name");
|
||||
end if;
|
||||
|
||||
-- Scan out value
|
||||
|
||||
VP.all := Get_Nat;
|
||||
|
||||
if N > Buflen or else Buffer (N) /= ASCII.LF then
|
||||
FailN ("misformatted line for");
|
||||
end if;
|
||||
|
||||
N := N + 1; -- skip LF
|
||||
end loop;
|
||||
|
||||
-- Fall through this loop when all lines in first section read.
|
||||
-- Check that values have been supplied for all entries.
|
||||
|
||||
for J in DTR'Range loop
|
||||
if not DTR (J) then
|
||||
Fail ("missing entry for " & DTN (J).all & " in file "
|
||||
& File_Name);
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
-- Now acquire FPT entries
|
||||
|
||||
if N >= Buflen then
|
||||
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 " & File_Name);
|
||||
end if;
|
||||
|
||||
Num_FPT_Modes := 0;
|
||||
while N <= Buflen loop
|
||||
Get_Name;
|
||||
|
||||
Num_FPT_Modes := Num_FPT_Modes + 1;
|
||||
|
||||
declare
|
||||
E : FPT_Mode_Entry renames FPT_Mode_Table (Num_FPT_Modes);
|
||||
|
||||
begin
|
||||
E.NAME := new String'(Nam_Buf (1 .. Nam_Len));
|
||||
|
||||
E.DIGS := Get_Nat;
|
||||
Check_Spaces;
|
||||
|
||||
case Buffer (N) is
|
||||
when 'I' =>
|
||||
E.FLOAT_REP := IEEE_Binary;
|
||||
when 'V' =>
|
||||
E.FLOAT_REP := VAX_Native;
|
||||
when 'A' =>
|
||||
E.FLOAT_REP := AAMP;
|
||||
when others =>
|
||||
FailN ("bad float rep field for");
|
||||
end case;
|
||||
|
||||
N := N + 1;
|
||||
Check_Spaces;
|
||||
|
||||
E.PRECISION := Get_Nat;
|
||||
Check_Spaces;
|
||||
|
||||
E.ALIGNMENT := Get_Nat;
|
||||
|
||||
if Buffer (N) /= ASCII.LF then
|
||||
FailN ("junk at end of line for");
|
||||
end if;
|
||||
|
||||
-- ??? We do not read E.SIZE, see Write_Target_Dependent_Values
|
||||
|
||||
E.SIZE :=
|
||||
(E.PRECISION + E.ALIGNMENT - 1) / E.ALIGNMENT * E.ALIGNMENT;
|
||||
|
||||
N := N + 1;
|
||||
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.
|
||||
@ -565,40 +823,6 @@ begin
|
||||
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
|
||||
@ -607,257 +831,50 @@ begin
|
||||
-- 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
|
||||
Read_Target_Dependent_Values : declare
|
||||
File_Desc : File_Descriptor;
|
||||
N : Natural;
|
||||
|
||||
type ANat is access all Natural;
|
||||
-- Pointer to Nat or Pos value (it is harmless to treat Pos values
|
||||
-- as Nat via Unchecked_Conversion).
|
||||
|
||||
function To_ANat is new Unchecked_Conversion (Address, ANat);
|
||||
|
||||
VP : ANat;
|
||||
|
||||
Buffer : String (1 .. 2000);
|
||||
Buflen : Natural;
|
||||
-- File information and length (2000 easily enough)
|
||||
|
||||
Nam_Buf : String (1 .. 40);
|
||||
Nam_Len : Natural;
|
||||
|
||||
procedure Check_Spaces;
|
||||
-- Checks that we have one or more spaces and skips them
|
||||
|
||||
procedure FailN (S : String);
|
||||
-- Calls Fail adding " name in file xxx", where name is the currently
|
||||
-- gathered name in Nam_Buf, surrounded by quotes, and xxx is the
|
||||
-- name of the file.
|
||||
|
||||
procedure Get_Name;
|
||||
-- Scan out name, leaving it in Nam_Buf with Nam_Len set. Calls
|
||||
-- Skip_Spaces to skip any following spaces. Note that the name is
|
||||
-- terminated by a sequence of at least two spaces.
|
||||
|
||||
function Get_Nat return Natural;
|
||||
-- N on entry points to decimal integer, scan out decimal integer
|
||||
-- and return it, leaving N pointing to following space or LF.
|
||||
|
||||
procedure Skip_Spaces;
|
||||
-- Skip past spaces
|
||||
|
||||
------------------
|
||||
-- Check_Spaces --
|
||||
------------------
|
||||
|
||||
procedure Check_Spaces is
|
||||
begin
|
||||
if N > Buflen or else Buffer (N) /= ' ' then
|
||||
FailN ("missing space for");
|
||||
end if;
|
||||
|
||||
Skip_Spaces;
|
||||
return;
|
||||
end Check_Spaces;
|
||||
|
||||
-----------
|
||||
-- FailN --
|
||||
-----------
|
||||
|
||||
procedure FailN (S : String) is
|
||||
begin
|
||||
Fail (S & " """ & Nam_Buf (1 .. Nam_Len) & """ in file "
|
||||
& Target_Dependent_Info_Read_Name.all);
|
||||
end FailN;
|
||||
|
||||
--------------
|
||||
-- Get_Name --
|
||||
--------------
|
||||
|
||||
procedure Get_Name is
|
||||
begin
|
||||
Nam_Len := 0;
|
||||
|
||||
-- Scan out name and put it in Nam_Buf
|
||||
|
||||
loop
|
||||
if N > Buflen or else Buffer (N) = ASCII.LF then
|
||||
FailN ("incorrectly formatted line for");
|
||||
end if;
|
||||
|
||||
-- Name is terminated by two blanks
|
||||
|
||||
exit when N < Buflen and then Buffer (N .. N + 1) = " ";
|
||||
|
||||
Nam_Len := Nam_Len + 1;
|
||||
|
||||
if Nam_Len > Nam_Buf'Last then
|
||||
Fail ("name too long");
|
||||
end if;
|
||||
|
||||
Nam_Buf (Nam_Len) := Buffer (N);
|
||||
N := N + 1;
|
||||
end loop;
|
||||
|
||||
Check_Spaces;
|
||||
end Get_Name;
|
||||
|
||||
-------------
|
||||
-- Get_Nat --
|
||||
-------------
|
||||
|
||||
function Get_Nat return Natural is
|
||||
Result : Natural := 0;
|
||||
|
||||
begin
|
||||
loop
|
||||
if N > Buflen
|
||||
or else Buffer (N) not in '0' .. '9'
|
||||
or else Result > 999
|
||||
then
|
||||
FailN ("bad value for");
|
||||
end if;
|
||||
|
||||
Result := Result * 10 + (Character'Pos (Buffer (N)) - 48);
|
||||
N := N + 1;
|
||||
|
||||
exit when N <= Buflen
|
||||
and then (Buffer (N) = ASCII.LF or else Buffer (N) = ' ');
|
||||
end loop;
|
||||
|
||||
return Result;
|
||||
end Get_Nat;
|
||||
|
||||
-----------------
|
||||
-- Skip_Spaces --
|
||||
-----------------
|
||||
|
||||
procedure Skip_Spaces is
|
||||
begin
|
||||
while N <= Buflen and Buffer (N) = ' ' loop
|
||||
N := N + 1;
|
||||
end loop;
|
||||
end Skip_Spaces;
|
||||
|
||||
-- Start of processing for Read_Target_Dependent_Values
|
||||
-- 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
|
||||
File_Desc := Open_Read (Target_Dependent_Info_Read_Name.all, Text);
|
||||
if Back_End_Config_File /= null then
|
||||
Read_Target_Dependent_Values (Back_End_Config_File.all);
|
||||
|
||||
if File_Desc = Invalid_FD then
|
||||
Fail ("cannot read file " & Target_Dependent_Info_Read_Name.all);
|
||||
end if;
|
||||
-- Otherwise we get all values from the back end directly
|
||||
|
||||
Buflen := Read (File_Desc, Buffer'Address, Buffer'Length);
|
||||
|
||||
if Buflen = Buffer'Length then
|
||||
Fail ("file is too long: " & Target_Dependent_Info_Read_Name.all);
|
||||
end if;
|
||||
|
||||
-- Scan through file for properly formatted entries in first section
|
||||
|
||||
N := 1;
|
||||
while N <= Buflen and then Buffer (N) /= ASCII.LF loop
|
||||
Get_Name;
|
||||
|
||||
-- Validate name and get corresponding value pointer
|
||||
|
||||
VP := null;
|
||||
|
||||
for J in DTN'Range loop
|
||||
if DTN (J).all = Nam_Buf (1 .. Nam_Len) then
|
||||
VP := To_ANat (DTV (J));
|
||||
DTR (J) := True;
|
||||
exit;
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
if VP = null then
|
||||
FailN ("unrecognized name");
|
||||
end if;
|
||||
|
||||
-- Scan out value
|
||||
|
||||
VP.all := Get_Nat;
|
||||
|
||||
if N > Buflen or else Buffer (N) /= ASCII.LF then
|
||||
FailN ("misformatted line for");
|
||||
end if;
|
||||
|
||||
N := N + 1; -- skip LF
|
||||
end loop;
|
||||
|
||||
-- Fall through this loop when all lines in first section read.
|
||||
-- Check that values have been supplied for all entries.
|
||||
|
||||
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);
|
||||
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);
|
||||
end if;
|
||||
|
||||
if Buffer (N) = ASCII.LF then
|
||||
N := N + 1;
|
||||
else
|
||||
Fail ("missing blank line in file "
|
||||
& Target_Dependent_Info_Read_Name.all);
|
||||
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;
|
||||
|
||||
Num_FPT_Modes := 0;
|
||||
while N <= Buflen loop
|
||||
Get_Name;
|
||||
|
||||
Num_FPT_Modes := Num_FPT_Modes + 1;
|
||||
|
||||
declare
|
||||
E : FPT_Mode_Entry renames FPT_Mode_Table (Num_FPT_Modes);
|
||||
|
||||
begin
|
||||
E.NAME := new String'(Nam_Buf (1 .. Nam_Len));
|
||||
|
||||
E.DIGS := Get_Nat;
|
||||
Check_Spaces;
|
||||
|
||||
case Buffer (N) is
|
||||
when 'I' =>
|
||||
E.FLOAT_REP := IEEE_Binary;
|
||||
when 'V' =>
|
||||
E.FLOAT_REP := VAX_Native;
|
||||
when 'A' =>
|
||||
E.FLOAT_REP := AAMP;
|
||||
when others =>
|
||||
FailN ("bad float rep field for");
|
||||
end case;
|
||||
|
||||
N := N + 1;
|
||||
Check_Spaces;
|
||||
|
||||
E.PRECISION := Get_Nat;
|
||||
Check_Spaces;
|
||||
|
||||
E.ALIGNMENT := Get_Nat;
|
||||
|
||||
if Buffer (N) /= ASCII.LF then
|
||||
FailN ("junk at end of line for");
|
||||
end if;
|
||||
|
||||
-- ??? We do not read E.SIZE, see Write_Target_Dependent_Values
|
||||
|
||||
E.SIZE :=
|
||||
(E.PRECISION + E.ALIGNMENT - 1) / E.ALIGNMENT * E.ALIGNMENT;
|
||||
|
||||
N := N + 1;
|
||||
end;
|
||||
end loop;
|
||||
end Read_Target_Dependent_Values;
|
||||
end;
|
||||
end if;
|
||||
end Set_Targ;
|
||||
|
||||
Loading…
Reference in New Issue
Block a user