mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-03-25 12:41:01 +08:00
Code Issues Packages Projects Releases Wiki Activity

sinput.ads, [...] (Unlock): New procedure.

Browse Source 
2007-04-20  Robert Dewar  <dewar@adacore.com>

	* sinput.ads, sinput.adb, uintp.ads, urealp.adb, stringt.adb,
	sem_elim.adb, prj-strt.adb, repinfo.ads, repinfo.adb, namet.ads,
	elists.ads, elists.adb, lib.ads, lib.adb (Unlock): New procedure.
	Fix lower bound of tables.
	Add rep clauses.

	* nlists.adb: Ditto.
	(Prev_Node, Next_Node): Change index type to Int so that it properly
	covers the range First_Node_Id - 1 up.

From-SVN: r125391
This commit is contained in:
Robert Dewar 2007-06-06 12:23:26 +02:00 committed by Arnaud Charlet
parent 0a36105d56
commit 1c28fe3afe
15 changed files with 341 additions and 86 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
gcc/ada/elists.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2007, 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- --
@ -90,7 +90,7 @@ package body Elists is
package Elists is new Table.Table (
Table_Component_Type => Elist_Header,
Table_Index_Type => Elist_Id,
Table_Index_Type => Elist_Id'Base,
Table_Low_Bound => First_Elist_Id,
Table_Initial => Alloc.Elists_Initial,
Table_Increment => Alloc.Elists_Increment,
@ -103,7 +103,7 @@ package body Elists is
package Elmts is new Table.Table (
Table_Component_Type => Elmt_Item,
Table_Index_Type => Elmt_Id,
Table_Index_Type => Elmt_Id'Base,
Table_Low_Bound => First_Elmt_Id,
Table_Initial => Alloc.Elmts_Initial,
Table_Increment => Alloc.Elmts_Increment,
@ -482,4 +482,14 @@ package body Elists is
Elmts.Tree_Write;
end Tree_Write;
------------
-- Unlock --
------------
procedure Unlock is
begin
Elists.Locked := False;
Elmts.Locked := False;
end Unlock;
end Elists;

5
gcc/ada/elists.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2007, 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- --
@ -62,6 +62,9 @@ package Elists is
procedure Lock;
-- Lock tables used for element lists before calling backend
procedure Unlock;
-- Unlock list tables, in cases where the back end needs to modify them
procedure Tree_Read;
-- Initializes internal tables from current tree file using the relevant
-- Table.Tree_Read routines. Note that Initialize should not be called if

14
gcc/ada/lib.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2007, 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- --
@ -38,7 +38,6 @@ pragma Style_Checks (All_Checks);
with Atree; use Atree;
with Einfo; use Einfo;
with Fname; use Fname;
with Namet; use Namet;
with Output; use Output;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
@ -1027,6 +1026,17 @@ package body Lib is
end loop;
end Tree_Write;
------------
-- Unlock --
------------
procedure Unlock is
begin
Linker_Option_Lines.Locked := False;
Load_Stack.Locked := False;
Units.Locked := False;
end Unlock;
-----------------
-- Version_Get --
-----------------

48
gcc/ada/lib.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2007, 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- --
@ -35,8 +35,9 @@
-- information. It contains the routine to load subsidiary units.
with Alloc;
with Namet; use Namet;
with Table;
with Types; use Types;
with Types; use Types;
package Lib is
@ -562,6 +563,9 @@ package Lib is
procedure Lock;
-- Lock internal tables before calling back end
procedure Unlock;
-- Unlock internal tables, in cases where the back end needs to modify them
procedure Tree_Read;
-- Initializes internal tables from current tree file using the relevant
-- Table.Tree_Read routines.
@ -658,18 +662,46 @@ private
Cunit : Node_Id;
Cunit_Entity : Entity_Id;
Dependency_Num : Int;
Fatal_Error : Boolean;
Generate_Code : Boolean;
Has_RACW : Boolean;
Ident_String : Node_Id;
Loading : Boolean;
Main_Priority : Int;
Serial_Number : Nat;
Version : Word;
Dynamic_Elab : Boolean;
Error_Location : Source_Ptr;
Fatal_Error : Boolean;
Generate_Code : Boolean;
Has_RACW : Boolean;
Dynamic_Elab : Boolean;
Loading : Boolean;
end record;
-- The following representation clause ensures that the above record
-- has no holes. We do this so that when instances of this record are
-- written by Tree_Gen, we do not write uninitialized values to the file.
for Unit_Record use record
Unit_File_Name at 0 range 0 .. 31;
Unit_Name at 4 range 0 .. 31;
Munit_Index at 8 range 0 .. 31;
Expected_Unit at 12 range 0 .. 31;
Source_Index at 16 range 0 .. 31;
Cunit at 20 range 0 .. 31;
Cunit_Entity at 24 range 0 .. 31;
Dependency_Num at 28 range 0 .. 31;
Ident_String at 32 range 0 .. 31;
Main_Priority at 36 range 0 .. 31;
Serial_Number at 40 range 0 .. 31;
Version at 44 range 0 .. 31;
Error_Location at 48 range 0 .. 31;
Fatal_Error at 52 range 0 .. 7;
Generate_Code at 53 range 0 .. 7;
Has_RACW at 54 range 0 .. 7;
Dynamic_Elab at 55 range 0 .. 7;
Loading at 56 range 0 .. 31;
end record;
for Unit_Record'Size use 60 * 8;
-- This ensures that we did not leave out any fields
package Units is new Table.Table (
Table_Component_Type => Unit_Record,
Table_Index_Type => Unit_Number_Type,
@ -740,7 +772,7 @@ private
package Load_Stack is new Table.Table (
Table_Component_Type => Load_Stack_Entry,
Table_Index_Type => Nat,
Table_Index_Type => Int,
Table_Low_Bound => 0,
Table_Initial => Alloc.Load_Stack_Initial,
Table_Increment => Alloc.Load_Stack_Increment,

110
gcc/ada/namet.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2007, 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- --
@ -136,6 +136,37 @@ package Namet is
-- Length of name stored in Name_Buffer. Used as an input parameter for
-- Name_Find, and as an output value by Get_Name_String, or Write_Name.
-----------------------------
-- Types for Namet Package --
-----------------------------
-- Name_Id values are used to identify entries in the names table. Except
-- for the special values No_Name, and Error_Name, they are subscript
-- values for the Names table defined in package Namet.
-- Note that with only a few exceptions, which are clearly documented, the
-- type Name_Id should be regarded as a private type. In particular it is
-- never appropriate to perform arithmetic operations using this type.
type Name_Id is range Names_Low_Bound .. Names_High_Bound;
for Name_Id'Size use 32;
-- Type used to identify entries in the names table
No_Name : constant Name_Id := Names_Low_Bound;
-- The special Name_Id value No_Name is used in the parser to indicate
-- a situation where no name is present (e.g. on a loop or block).
Error_Name : constant Name_Id := Names_Low_Bound + 1;
-- The special Name_Id value Error_Name is used in the parser to
-- indicate that some kind of error was encountered in scanning out
-- the relevant name, so it does not have a representable label.
subtype Error_Name_Or_No_Name is Name_Id range No_Name .. Error_Name;
-- Used to test for either error name or no name
First_Name_Id : constant Name_Id := Names_Low_Bound + 2;
-- Subscript of first entry in names table
-----------------
-- Subprograms --
-----------------
@ -153,7 +184,7 @@ package Namet is
function Get_Name_String (Id : Name_Id) return String;
-- This functional form returns the result as a string without affecting
-- the contents of either Name_Buffer or Name_Len.
-- the contents of either Name_Buffer or Name_Len. The lower bound is 1.
procedure Get_Unqualified_Name_String (Id : Name_Id);
-- Similar to the above except that qualification (as defined in unit
@ -215,13 +246,12 @@ package Namet is
-- that Initialize must not be called if Tree_Read is used.
procedure Lock;
-- Lock name table before calling back end. Space for up to 10 extra
-- names and 1000 extra characters is reserved before the table is locked.
-- Lock name tables before calling back end. We reserve some extra space
-- before locking to avoid unnecessary inefficiencies when we unlock.
procedure Unlock;
-- Unlocks the name table to allow use of the 10 extra names and 1000
-- extra characters reserved by the Lock call. See gnat1drv for details of
-- the need for this.
-- Unlocks the name table to allow use of the extra space reserved by the
-- call to Lock. See gnat1drv for details of the need for this.
function Length_Of_Name (Id : Name_Id) return Nat;
pragma Inline (Length_Of_Name);
@ -367,6 +397,58 @@ package Namet is
-- described for Get_Decoded_Name_String, and the resulting value stored
-- in Name_Len and Name_Buffer is the decoded name.
------------------------------
-- File and Unit Name Types --
------------------------------
-- These are defined here in Namet rather than Fname and Uname to avoid
-- problems with dependencies, and to avoid dragging in Fname and Uname
-- into many more files, but it would be cleaner to move to Fname/Uname.
type File_Name_Type is new Name_Id;
-- File names are stored in the names table and this type is used to
-- indicate that a Name_Id value is being used to hold a simple file name
-- (which does not include any directory information).
No_File : constant File_Name_Type := File_Name_Type (No_Name);
-- Constant used to indicate no file is present (this is used for example
-- when a search for a file indicates that no file of the name exists).
Error_File_Name : constant File_Name_Type := File_Name_Type (Error_Name);
-- The special File_Name_Type value Error_File_Name is used to indicate
-- a unit name where some previous processing has found an error.
subtype Error_File_Name_Or_No_File is
File_Name_Type range No_File .. Error_File_Name;
-- Used to test for either error file name or no file
type Path_Name_Type is new Name_Id;
-- Path names are stored in the names table and this type is used to
-- indicate that a Name_Id value is being used to hold a path name (that
-- may contain directory information).
No_Path : constant Path_Name_Type := Path_Name_Type (No_Name);
-- Constant used to indicate no path name is present
type Unit_Name_Type is new Name_Id;
-- Unit names are stored in the names table and this type is used to
-- indicate that a Name_Id value is being used to hold a unit name, which
-- terminates in %b for a body or %s for a spec.
No_Unit_Name : constant Unit_Name_Type := Unit_Name_Type (No_Name);
-- Constant used to indicate no file name present
Error_Unit_Name : constant Unit_Name_Type := Unit_Name_Type (Error_Name);
-- The special Unit_Name_Type value Error_Unit_Name is used to indicate
-- a unit name where some previous processing has found an error.
subtype Error_Unit_Name_Or_No_Unit_Name is
Unit_Name_Type range No_Unit_Name .. Error_Unit_Name;
------------------------
-- Debugging Routines --
------------------------
procedure wn (Id : Name_Id);
pragma Export (Ada, wn);
-- This routine is intended for debugging use only (i.e. it is intended to
@ -427,12 +509,24 @@ private
-- Int Value associated with this name
end record;
for Name_Entry use record
Name_Chars_Index at 0 range 0 .. 31;
Name_Len at 4 range 0 .. 15;
Byte_Info at 6 range 0 .. 7;
Name_Has_No_Encodings at 7 range 0 .. 7;
Hash_Link at 8 range 0 .. 31;
Int_Info at 12 range 0 .. 31;
end record;
for Name_Entry'Size use 16 * 8;
-- This ensures that we did not leave out any fields
-- This is the table that is referenced by Name_Id entries.
-- It contains one entry for each unique name in the table.
package Name_Entries is new Table.Table (
Table_Component_Type => Name_Entry,
Table_Index_Type => Name_Id,
Table_Index_Type => Name_Id'Base,
Table_Low_Bound => First_Name_Id,
Table_Initial => Alloc.Names_Initial,
Table_Increment => Alloc.Names_Increment,

30
gcc/ada/nlists.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2007, 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- --
@ -68,7 +68,7 @@ package body Nlists is
package Lists is new Table.Table (
Table_Component_Type => List_Header,
Table_Index_Type => List_Id,
Table_Index_Type => List_Id'Base,
Table_Low_Bound => First_List_Id,
Table_Initial => Alloc.Lists_Initial,
Table_Increment => Alloc.Lists_Increment,
@ -88,7 +88,7 @@ package body Nlists is
package Next_Node is new Table.Table (
Table_Component_Type => Node_Id,
Table_Index_Type => Node_Id,
Table_Index_Type => Node_Id'Base,
Table_Low_Bound => First_Node_Id,
Table_Initial => Alloc.Orig_Nodes_Initial,
Table_Increment => Alloc.Orig_Nodes_Increment,
@ -96,7 +96,7 @@ package body Nlists is
package Prev_Node is new Table.Table (
Table_Component_Type => Node_Id,
Table_Index_Type => Node_Id,
Table_Index_Type => Node_Id'Base,
Table_Low_Bound => First_Node_Id,
Table_Initial => Alloc.Orig_Nodes_Initial,
Table_Increment => Alloc.Orig_Nodes_Increment,
@ -131,9 +131,20 @@ package body Nlists is
--------------------------
procedure Allocate_List_Tables (N : Node_Id) is
Old_Last : constant Node_Id'Base := Next_Node.Last;
begin
pragma Assert (N >= Old_Last);
Next_Node.Set_Last (N);
Prev_Node.Set_Last (N);
-- Make sure we have no uninitialized junk in any new entires added.
-- This ensures that Tree_Gen will not write out any unitialized junk.
for J in Old_Last + 1 .. N loop
Next_Node.Table (J) := Empty;
Prev_Node.Table (J) := Empty;
end loop;
end Allocate_List_Tables;
------------
@ -1379,4 +1390,15 @@ package body Nlists is
Prev_Node.Tree_Write;
end Tree_Write;
------------
-- Unlock --
------------
procedure Unlock is
begin
Lists.Locked := False;
Prev_Node.Locked := False;
Next_Node.Locked := False;
end Unlock;
end Nlists;

54
gcc/ada/prj-strt.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2006, Free Software Foundation, Inc. --
-- Copyright (C) 2001-2007, 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- --
@ -25,7 +25,6 @@
------------------------------------------------------------------------------
with Err_Vars; use Err_Vars;
with Namet; use Namet;
with Prj.Attr; use Prj.Attr;
with Prj.Err; use Prj.Err;
with Snames;
@ -58,21 +57,23 @@ package body Prj.Strt is
Choice_Node_Low_Bound;
package Choices is
new Table.Table (Table_Component_Type => Choice_String,
Table_Index_Type => Choice_Node_Id,
Table_Low_Bound => First_Choice_Node_Id,
Table_Initial => Choices_Initial,
Table_Increment => Choices_Increment,
Table_Name => "Prj.Strt.Choices");
new Table.Table
(Table_Component_Type => Choice_String,
Table_Index_Type => Choice_Node_Id'Base,
Table_Low_Bound => First_Choice_Node_Id,
Table_Initial => Choices_Initial,
Table_Increment => Choices_Increment,
Table_Name => "Prj.Strt.Choices");
-- Used to store the case labels and check that there is no duplicate
package Choice_Lasts is
new Table.Table (Table_Component_Type => Choice_Node_Id,
Table_Index_Type => Nat,
Table_Low_Bound => 1,
Table_Initial => 10,
Table_Increment => 100,
Table_Name => "Prj.Strt.Choice_Lasts");
new Table.Table
(Table_Component_Type => Choice_Node_Id,
Table_Index_Type => Nat,
Table_Low_Bound => 1,
Table_Initial => 10,
Table_Increment => 100,
Table_Name => "Prj.Strt.Choice_Lasts");
-- Used to store the indices of the choices in table Choices,
-- to distinguish nested case constructions.
@ -87,12 +88,13 @@ package body Prj.Strt is
-- Store the identifier and the location of a simple name
package Names is
new Table.Table (Table_Component_Type => Name_Location,
Table_Index_Type => Nat,
Table_Low_Bound => 1,
Table_Initial => 10,
Table_Increment => 100,
Table_Name => "Prj.Strt.Names");
new Table.Table
(Table_Component_Type => Name_Location,
Table_Index_Type => Nat,
Table_Low_Bound => 1,
Table_Initial => 10,
Table_Increment => 100,
Table_Name => "Prj.Strt.Names");
-- Used to accumulate the single names of a name
procedure Add (This_String : Name_Id);
@ -193,7 +195,7 @@ package body Prj.Strt is
if Current_Attribute = Empty_Attribute then
Error_Msg_Name_1 := Token_Name;
Error_Msg ("unknown attribute %", Token_Ptr);
Error_Msg ("unknown attribute %%", Token_Ptr);
Reference := Empty_Node;
-- Scan past the attribute name
@ -293,7 +295,7 @@ package body Prj.Strt is
if Non_Used = 1 then
Error_Msg_Name_1 := Choices.Table (First_Non_Used).The_String;
Error_Msg ("?value { is not used as label", Case_Location);
Error_Msg ("?value %% is not used as label", Case_Location);
-- If several are not used, report a warning for each one of them
@ -305,7 +307,7 @@ package body Prj.Strt is
for Choice in First_Non_Used .. Choices.Last loop
if not Choices.Table (Choice).Already_Used then
Error_Msg_Name_1 := Choices.Table (Choice).The_String;
Error_Msg ("\?{", Case_Location);
Error_Msg ("\?%%", Case_Location);
end if;
end loop;
end if;
@ -484,7 +486,7 @@ package body Prj.Strt is
-- case construction; report an error.
Error_Msg_Name_1 := Choice_String;
Error_Msg ("duplicate case label {", Token_Ptr);
Error_Msg ("duplicate case label %%", Token_Ptr);
else
Choices.Table (Choice).Already_Used := True;
end if;
@ -497,7 +499,7 @@ package body Prj.Strt is
if not Found then
Error_Msg_Name_1 := Choice_String;
Error_Msg ("illegal case label {", Token_Ptr);
Error_Msg ("illegal case label %%", Token_Ptr);
end if;
-- Scan past the label
@ -607,7 +609,7 @@ package body Prj.Strt is
-- This is a repetition, report an error
Error_Msg_Name_1 := String_Value;
Error_Msg ("duplicate value { in type", Token_Ptr);
Error_Msg ("duplicate value %% in type", Token_Ptr);
exit;
end if;

26
gcc/ada/repinfo.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1999-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1999-2007, 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- --
@ -63,9 +63,8 @@ package body Repinfo is
-- Representation of gcc Expressions --
---------------------------------------
-- This table is used only if Frontend_Layout_On_Target is False, so that
-- gigi lays out dynamic size/offset fields using encoded gcc
-- expressions.
-- This table is used only if Frontend_Layout_On_Target is False, so gigi
-- lays out dynamic size/offset fields using encoded gcc expressions.
-- A table internal to this unit is used to hold the values of back
-- annotated expressions. This table is written out by -gnatt and read
@ -81,6 +80,20 @@ package body Repinfo is
Op3 : Node_Ref_Or_Val;
end record;
-- The following representation clause ensures that the above record
-- has no holes. We do this so that when instances of this record are
-- written by Tree_Gen, we do not write uninitialized values to the file.
for Exp_Node use record
Expr at 0 range 0 .. 31;
Op1 at 4 range 0 .. 31;
Op2 at 8 range 0 .. 31;
Op3 at 12 range 0 .. 31;
end record;
for Exp_Node'Size use 16 * 8;
-- This ensures that we did not leave out any fields
package Rep_Table is new Table.Table (
Table_Component_Type => Exp_Node,
Table_Index_Type => Nat,
@ -672,6 +685,7 @@ package body Repinfo is
when Convention_Protected => Write_Line ("Protected");
when Convention_Assembler => Write_Line ("Assembler");
when Convention_C => Write_Line ("C");
when Convention_CIL => Write_Line ("CIL");
when Convention_COBOL => Write_Line ("COBOL");
when Convention_CPP => Write_Line ("C++");
when Convention_Fortran => Write_Line ("Fortran");
@ -782,7 +796,7 @@ package body Repinfo is
-- length, for the purpose of lining things up nicely.
Max_Name_Length := 0;
Max_Suni_Length := 0;
Max_Suni_Length := 0;
Comp := First_Component_Or_Discriminant (Ent);
while Present (Comp) loop
@ -983,7 +997,7 @@ package body Repinfo is
else
Create_Repinfo_File_Access.all
(File_Name (Source_Index (U)));
(Get_Name_String (File_Name (Source_Index (U))));
Set_Special_Output (Write_Info_Line'Access);
List_Entities (Cunit_Entity (U));
Set_Special_Output (null);

10
gcc/ada/repinfo.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1999-2005, Free Software Foundation, Inc. --
-- Copyright (C) 1999-2007, 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- --
@ -182,10 +182,10 @@ package Repinfo is
Op1 : Node_Ref_Or_Val;
Op2 : Node_Ref_Or_Val := No_Uint;
Op3 : Node_Ref_Or_Val := No_Uint) return Node_Ref;
-- Creates a node with using the tree code defined by Expr and from
-- 1-3 operands as required (unused operands set as shown to No_Uint)
-- Note that this call can be used to create a discriminant reference
-- by using (Expr => Discrim_Val, Op1 => discriminant_number).
-- Creates a node using the tree code defined by Expr and from one to three
-- operands as required (unused operands set as shown to No_Uint) Note that
-- this call can be used to create a discriminant reference by using (Expr
-- => Discrim_Val, Op1 => discriminant_number).
function Create_Discrim_Ref (Discr : Entity_Id) return Node_Ref;
-- Creates a refrerence to the discriminant whose entity is Discr

4
gcc/ada/sem_elim.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1997-2004 Free Software Foundation, Inc. --
-- Copyright (C) 1997-2007, 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- --
@ -218,7 +218,7 @@ package body Sem_Elim is
package Elim_Entities is new Table.Table (
Table_Component_Type => Elim_Entity_Entry,
Table_Index_Type => Name_Id,
Table_Index_Type => Name_Id'Base,
Table_Low_Bound => First_Name_Id,
Table_Initial => 50,
Table_Increment => 200,

19
gcc/ada/sinput.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2007, 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- --
@ -35,7 +35,6 @@ pragma Style_Checks (All_Checks);
-- Subprograms not all in alpha order
with Debug; use Debug;
with Namet; use Namet;
with Opt; use Opt;
with Output; use Output;
with Tree_IO; use Tree_IO;
@ -575,8 +574,8 @@ package body Sinput is
--------------------------------
procedure Register_Source_Ref_Pragma
(File_Name : Name_Id;
Stripped_File_Name : Name_Id;
(File_Name : File_Name_Type;
Stripped_File_Name : File_Name_Type;
Mapped_Line : Nat;
Line_After_Pragma : Physical_Line_Number)
is
@ -587,7 +586,7 @@ package body Sinput is
ML : Logical_Line_Number;
begin
if File_Name /= No_Name then
if File_Name /= No_File then
SFR.Reference_Name := Stripped_File_Name;
SFR.Full_Ref_Name := File_Name;
@ -1202,6 +1201,16 @@ package body Sinput is
Source_File.Table (S).Lines_Table_Max := Physical_Line_Number (Max);
end Trim_Lines_Table;
------------
-- Unlock --
------------
procedure Unlock is
begin
Source_File.Locked := False;
Source_File.Release;
end Unlock;
--------
-- wl --
--------

65
gcc/ada/sinput.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2007, 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- --
@ -66,6 +66,7 @@
with Alloc;
with Casing; use Casing;
with Namet; use Namet;
with Table;
with Types; use Types;
@ -323,6 +324,9 @@ package Sinput is
procedure Lock;
-- Lock internal tables
procedure Unlock;
-- Unlock internal tables
Main_Source_File : Source_File_Index := No_Source_File;
-- This is set to the source file index of the main unit
@ -517,8 +521,8 @@ package Sinput is
-- physical line number.
procedure Register_Source_Ref_Pragma
(File_Name : Name_Id;
Stripped_File_Name : Name_Id;
(File_Name : File_Name_Type;
Stripped_File_Name : File_Name_Type;
Mapped_Line : Nat;
Line_After_Pragma : Physical_Line_Number);
-- Register a source reference pragma, the parameter File_Name is the
@ -670,29 +674,28 @@ private
-- See earlier descriptions for meanings of public fields
type Source_File_Record is record
File_Name : File_Name_Type;
File_Type : Type_Of_File;
Reference_Name : File_Name_Type;
Debug_Source_Name : File_Name_Type;
Full_Debug_Name : File_Name_Type;
Full_File_Name : File_Name_Type;
Full_Ref_Name : File_Name_Type;
Inlined_Body : Boolean;
License : License_Type;
Num_SRef_Pragmas : Nat;
First_Mapped_Line : Logical_Line_Number;
Source_Text : Source_Buffer_Ptr;
Source_First : Source_Ptr;
Source_Last : Source_Ptr;
Time_Stamp : Time_Stamp_Type;
Source_Checksum : Word;
Last_Source_Line : Physical_Line_Number;
Keyword_Casing : Casing_Type;
Identifier_Casing : Casing_Type;
Instantiation : Source_Ptr;
Template : Source_File_Index;
Unit : Unit_Number_Type;
Time_Stamp : Time_Stamp_Type;
File_Type : Type_Of_File;
Inlined_Body : Boolean;
License : License_Type;
Keyword_Casing : Casing_Type;
Identifier_Casing : Casing_Type;
-- The following fields are for internal use only (i.e. only in the
-- body of Sinput or its children, with no direct access by clients).
@ -722,6 +725,48 @@ private
end record;
-- The following representation clause ensures that the above record
-- has no holes. We do this so that when instances of this record are
-- written by Tree_Gen, we do not write uninitialized values to the file.
AS : constant Pos := Standard'Address_Size;
for Source_File_Record use record
File_Name at 0 range 0 .. 31;
Reference_Name at 4 range 0 .. 31;
Debug_Source_Name at 8 range 0 .. 31;
Full_Debug_Name at 12 range 0 .. 31;
Full_File_Name at 16 range 0 .. 31;
Full_Ref_Name at 20 range 0 .. 31;
Num_SRef_Pragmas at 24 range 0 .. 31;
First_Mapped_Line at 28 range 0 .. 31;
Source_First at 32 range 0 .. 31;
Source_Last at 36 range 0 .. 31;
Source_Checksum at 40 range 0 .. 31;
Last_Source_Line at 44 range 0 .. 31;
Instantiation at 48 range 0 .. 31;
Template at 52 range 0 .. 31;
Unit at 56 range 0 .. 31;
Time_Stamp at 60 range 0 .. 8 * Time_Stamp_Length - 1;
File_Type at 74 range 0 .. 7;
Inlined_Body at 75 range 0 .. 7;
License at 76 range 0 .. 7;
Keyword_Casing at 77 range 0 .. 7;
Identifier_Casing at 78 range 0 .. 15;
Sloc_Adjust at 80 range 0 .. 31;
Lines_Table_Max at 84 range 0 .. 31;
-- The following fields are pointers, so we have to specialize their
-- lengths using pointer size, obtained above as Standard'Address_Size.
Source_Text at 88 range 0 .. AS - 1;
Lines_Table at 88 range AS .. AS * 2 - 1;
Logical_Lines_Table at 88 range AS * 2 .. AS * 3 - 1;
end record;
for Source_File_Record'Size use 88 * 8 + AS * 3;
-- This ensures that we did not leave out any fields
package Source_File is new Table.Table (
Table_Component_Type => Source_File_Record,
Table_Index_Type => Source_File_Index,

4
gcc/ada/stringt.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2007, 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- --
@ -61,7 +61,7 @@ package body Stringt is
package Strings is new Table.Table (
Table_Component_Type => String_Entry,
Table_Index_Type => String_Id,
Table_Index_Type => String_Id'Base,
Table_Low_Bound => First_String_Id,
Table_Initial => Alloc.Strings_Initial,
Table_Increment => Alloc.Strings_Increment,

4
gcc/ada/uintp.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2007, 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- --
@ -518,7 +518,7 @@ private
package Uints is new Table.Table (
Table_Component_Type => Uint_Entry,
Table_Index_Type => Uint,
Table_Index_Type => Uint'Base,
Table_Low_Bound => Uint_First_Entry,
Table_Initial => Alloc.Uints_Initial,
Table_Increment => Alloc.Uints_Increment,

18
gcc/ada/urealp.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2007, 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- --
@ -57,9 +57,23 @@ package body Urealp is
-- Flag set if value is negative
end record;
-- The following representation clause ensures that the above record
-- has no holes. We do this so that when instances of this record are
-- written by Tree_Gen, we do not write uninitialized values to the file.
for Ureal_Entry use record
Num at 0 range 0 .. 31;
Den at 4 range 0 .. 31;
Rbase at 8 range 0 .. 31;
Negative at 12 range 0 .. 31;
end record;
for Ureal_Entry'Size use 16 * 8;
-- This ensures that we did not leave out any fields
package Ureals is new Table.Table (
Table_Component_Type => Ureal_Entry,
Table_Index_Type => Ureal,
Table_Index_Type => Ureal'Base,
Table_Low_Bound => Ureal_First_Entry,
Table_Initial => Alloc.Ureals_Initial,
Table_Increment => Alloc.Ureals_Increment,