OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR ada/11978 (ada compiler crashes in a-tags.adb) 

PR ada/11978:
	* exp_ch13.adb (Expand_N_Freeze_Entity): Do not consider inherited
	External_Tag attribute definition clauses.

	PR ada/7613:
	* exp_dbug.adb (Debug_Renaming_Declaration): For the renaming of a
	child unit, generate a fully qualified name to avoid spurious errors
	when the context contains renamings of different child units with
	the same simple name.

	* exp_dbug.ads: Add documentation on name qualification for renamings
	of child units.

	* g-regpat.ads, g-regpat.adb: Minor reformatting

	* Makefile.in: Use the file 1atags.ads with the ZFP and cert run-times.

	* trans.c: (tree_transform, case N_Real_Literal): Add extra arg to
	Machine call.

	* urealp.h: (Machine): Update to proper definition.

From-SVN: r72843
This commit is contained in:
Arnaud Charlet 2003-10-23 13:57:52 +02:00
parent 6d244bbea8
commit 9d7d51be97
9 changed files with 104 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
gcc/ada/ChangeLog
View File

@ -1,3 +1,35 @@
2003-10-23 Thomas Quinot <quinot@act-europe.fr>
PR ada/11978:
* exp_ch13.adb (Expand_N_Freeze_Entity): Do not consider inherited
External_Tag attribute definition clauses.
2003-10-23 Ed Schonberg <schonberg@gnat.com>
PR ada/7613:
* exp_dbug.adb (Debug_Renaming_Declaration): For the renaming of a
child unit, generate a fully qualified name to avoid spurious errors
when the context contains renamings of different child units with
the same simple name.
* exp_dbug.ads: Add documentation on name qualification for renamings
of child units.
2003-10-23 Robert Dewar <dewar@gnat.com>
* g-regpat.ads, g-regpat.adb: Minor reformatting
2003-10-23 Jose Ruiz <ruiz@act-europe.fr>
* Makefile.in: Use the file 1atags.ads with the ZFP and cert run-times.
2003-10-23 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* trans.c: (tree_transform, case N_Real_Literal): Add extra arg to
Machine call.
* urealp.h: (Machine): Update to proper definition.
2003-10-23 Arnaud Charlet <charlet@act-europe.fr>
* init.c, adaint.c: Minor reformatting.

3
gcc/ada/Makefile.in
View File

@ -600,6 +600,7 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks,$(targ))),)
a-taside.adb<1ataside.adb \
CERT_LEVEL_B_TARGET_PAIRS=\
a-tags.ads<1atags.ads \
a-tags.adb<1atags.adb \
a-except.adb<2aexcept.adb \
a-except.ads<2aexcept.ads \
@ -694,6 +695,7 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworksae,$(targ))),)
a-taside.adb<1ataside.adb \
CERT_LEVEL_B_TARGET_PAIRS=\
a-tags.ads<1atags.ads \
a-tags.adb<1atags.adb \
a-except.adb<2aexcept.adb \
a-except.ads<2aexcept.ads \
@ -1969,6 +1971,7 @@ gnatlib: ../stamp-gnatlib1 ../stamp-gnatlib2
HIE_NONE_TARGET_PAIRS=\
a-except.ads<1aexcept.ads \
a-except.adb<1aexcept.adb \
a-tags.ads<1atags.ads \
a-tags.adb<1atags.adb \
s-secsta.ads<1ssecsta.ads \
s-secsta.adb<1ssecsta.adb \

6
gcc/ada/exp_ch13.adb
View File

@ -329,7 +329,9 @@ package body Exp_Ch13 is
and then Is_First_Subtype (E)
then
-- Check for a definition of External_Tag, whose expansion must
-- be delayed until the dispatch table is built.
-- be delayed until the dispatch table is built. The clause
-- is considered only if it applies to this specific tagged
-- type, as opposed to one of its ancestors.
declare
Def : constant Node_Id :=
@ -337,7 +339,7 @@ package body Exp_Ch13 is
(E, Attribute_External_Tag);
begin
if Present (Def) then
if Present (Def) and then Entity (Name (Def)) = E then
Expand_External_Tag_Definition (Def);
end if;
end;

10
gcc/ada/exp_dbug.adb
View File

@ -358,6 +358,16 @@ package body Exp_Dbug is
when N_Package_Renaming_Declaration =>
Add_Str_To_Name_Buffer ("___XRP");
-- If it is a child unit create a fully qualified name,
-- to disambiguate multiple child units with the same
-- name and different parents.
if Is_Child_Unit (Ent) then
Prepend_String_To_Buffer ("__");
Prepend_String_To_Buffer
(Get_Name_String (Chars (Scope (Ent))));
end if;
when others =>
return Empty;
end case;

7
gcc/ada/exp_dbug.ads
View File

@ -951,7 +951,10 @@ package Exp_Dbug is
-- x___XRP for a package renaming
-- The name is fully qualified in the usual manner, i.e. qualified in
-- the same manner as the entity x would be.
-- the same manner as the entity x would be. In the case of a package
-- renaming where x is a child unit, the qualification includes the
-- name of the parent unit, to disambiguate child units with the same
-- simple name and (of necessity) different parents.
-- Note: subprogram renamings are not encoded at the present time.
@ -1036,7 +1039,7 @@ package Exp_Dbug is
-- type p__z___XR is
-- (p__g___XEXS1XS5XRmXL2XS3);
-- p__q___XE--------------------outer entity is g
-- p__g___XE--------------------outer entity is g
-- XS1-----------------first subscript for g
-- XS5--------------second subscript for g
-- XRm-----------select field m

87
gcc/ada/g-regpat.adb
View File

@ -237,8 +237,7 @@ package body GNAT.Regpat is
function Get_From_Class
(Bitmap : Character_Class;
C : Character)
return Boolean;
C : Character) return Boolean;
-- Return True if the entry is set for C in the class Bitmap.
procedure Reset_Class (Bitmap : out Character_Class);
@ -268,8 +267,7 @@ package body GNAT.Regpat is
function String_Length
(Program : Program_Data;
P : Pointer)
return Program_Size;
P : Pointer) return Program_Size;
-- Return the length of the string argument of the node at P
function String_Operand (P : Pointer) return Pointer;
@ -283,14 +281,12 @@ package body GNAT.Regpat is
function Get_Next_Offset
(Program : Program_Data;
IP : Pointer)
return Pointer;
IP : Pointer) return Pointer;
-- Get the offset field of a node. Used by Get_Next.
function Get_Next
(Program : Program_Data;
IP : Pointer)
return Pointer;
IP : Pointer) return Pointer;
-- Dig the next instruction pointer out of a node
procedure Optimize (Self : in out Pattern_Matcher);
@ -298,8 +294,7 @@ package body GNAT.Regpat is
function Read_Natural
(Program : Program_Data;
IP : Pointer)
return Natural;
IP : Pointer) return Natural;
-- Return the 2-byte natural coded at position IP.
-- All of the subprograms above are tiny and should be inlined
@ -2052,8 +2047,7 @@ package body GNAT.Regpat is
function Compile
(Expression : String;
Flags : Regexp_Flags := No_Flags)
return Pattern_Matcher
Flags : Regexp_Flags := No_Flags) return Pattern_Matcher
is
Size : Program_Size;
Dummy : Pattern_Matcher (0);
@ -2296,8 +2290,7 @@ package body GNAT.Regpat is
function Get_From_Class
(Bitmap : Character_Class;
C : Character)
return Boolean
C : Character) return Boolean
is
Value : constant Class_Byte := Character'Pos (C);
@ -2327,8 +2320,7 @@ package body GNAT.Regpat is
function Get_Next_Offset
(Program : Program_Data;
IP : Pointer)
return Pointer
IP : Pointer) return Pointer
is
begin
return Pointer (Read_Natural (Program, IP + 1));
@ -2432,9 +2424,8 @@ package body GNAT.Regpat is
-- Find character C in Data starting at Start and return position
function Repeat
(IP : Pointer;
Max : Natural := Natural'Last)
return Natural;
(IP : Pointer;
Max : Natural := Natural'Last) return Natural;
-- Repeatedly match something simple, report how many
-- It only matches on things of length 1.
-- Starting from Input_Pos, it matches at most Max CURLY.
@ -2468,8 +2459,7 @@ package body GNAT.Regpat is
(Op : Opcode;
Scan : Pointer;
Next : Pointer;
Greedy : Boolean)
return Boolean;
Greedy : Boolean) return Boolean;
-- Return True it the simple operator (possibly non-greedy) matches
pragma Inline (Index);
@ -2484,11 +2474,7 @@ package body GNAT.Regpat is
-- Index --
-----------
function Index
(Start : Positive;
C : Character)
return Natural
is
function Index (Start : Positive; C : Character) return Natural is
begin
for J in Start .. Last_In_Data loop
if Data (J) = C then
@ -2529,7 +2515,7 @@ package body GNAT.Regpat is
-- Match --
-----------
function Match (IP : Pointer) return Boolean is
function Match (IP : Pointer) return Boolean is
Scan : Pointer := IP;
Next : Pointer;
Op : Opcode;
@ -2835,8 +2821,7 @@ package body GNAT.Regpat is
(Op : Opcode;
Scan : Pointer;
Next : Pointer;
Greedy : Boolean)
return Boolean
Greedy : Boolean) return Boolean
is
Next_Char : Character := ASCII.Nul;
Next_Char_Known : Boolean := False;
@ -3137,9 +3122,8 @@ package body GNAT.Regpat is
------------
function Repeat
(IP : Pointer;
Max : Natural := Natural'Last)
return Natural
(IP : Pointer;
Max : Natural := Natural'Last) return Natural
is
Scan : Natural := Input_Pos;
Last : Natural;
@ -3384,12 +3368,15 @@ package body GNAT.Regpat is
return;
end Match;
function Match
(Self : Pattern_Matcher;
Data : String;
-----------
-- Match --
-----------
function Match
(Self : Pattern_Matcher;
Data : String;
Data_First : Integer := -1;
Data_Last : Positive := Positive'Last)
return Natural
Data_Last : Positive := Positive'Last) return Natural
is
Matches : Match_Array (0 .. 0);
@ -3402,12 +3389,11 @@ package body GNAT.Regpat is
end if;
end Match;
function Match
function Match
(Self : Pattern_Matcher;
Data : String;
Data_First : Integer := -1;
Data_Last : Positive := Positive'Last)
return Boolean
Data_Last : Positive := Positive'Last) return Boolean
is
Matches : Match_Array (0 .. 0);
@ -3436,13 +3422,16 @@ package body GNAT.Regpat is
end if;
end Match;
-----------
-- Match --
-----------
function Match
(Expression : String;
Data : String;
Size : Program_Size := 0;
Data_First : Integer := -1;
Data_Last : Positive := Positive'Last)
return Natural
Data_Last : Positive := Positive'Last) return Natural
is
PM : Pattern_Matcher (Size);
Final_Size : Program_Size; -- unused
@ -3456,13 +3445,16 @@ package body GNAT.Regpat is
end if;
end Match;
-----------
-- Match --
-----------
function Match
(Expression : String;
Data : String;
Size : Program_Size := 0;
Data_First : Integer := -1;
Data_Last : Positive := Positive'Last)
return Boolean
Data_Last : Positive := Positive'Last) return Boolean
is
Matches : Match_Array (0 .. 0);
PM : Pattern_Matcher (Size);
@ -3592,8 +3584,7 @@ package body GNAT.Regpat is
function Read_Natural
(Program : Program_Data;
IP : Pointer)
return Natural
IP : Pointer) return Natural
is
begin
return Character'Pos (Program (IP)) +
@ -3618,7 +3609,6 @@ package body GNAT.Regpat is
C : Character)
is
Value : constant Class_Byte := Character'Pos (C);
begin
Bitmap (Value / 8) := Bitmap (Value / 8)
or Bit_Conversion (Value mod 8);
@ -3630,8 +3620,7 @@ package body GNAT.Regpat is
function String_Length
(Program : Program_Data;
P : Pointer)
return Program_Size
P : Pointer) return Program_Size
is
begin
pragma Assert (Program (P) = EXACT or else Program (P) = EXACTF);

21
gcc/ada/g-regpat.ads
View File

@ -301,7 +301,7 @@ pragma Preelaborate (Regpat);
-- byte-compiled version of regular expressions.
Max_Program_Size : constant := 2**15 - 1;
-- Maximum size that can be allocated for a program.
-- Maximum size that can be allocated for a program
Max_Curly_Repeat : constant := 32767;
-- Maximum number of repetition for the curly operator.
@ -380,8 +380,7 @@ pragma Preelaborate (Regpat);
function Compile
(Expression : String;
Flags : Regexp_Flags := No_Flags)
return Pattern_Matcher;
Flags : Regexp_Flags := No_Flags) return Pattern_Matcher;
-- Compile a regular expression into internal code.
-- Raises Expression_Error if Expression is not a legal regular expression.
-- The appropriate size is calculated automatically, but this means that
@ -476,8 +475,7 @@ pragma Preelaborate (Regpat);
Data : String;
Size : Program_Size := 0;
Data_First : Integer := -1;
Data_Last : Positive := Positive'Last)
return Natural;
Data_Last : Positive := Positive'Last) return Natural;
-- Return the position where Data matches, or (Data'First - 1) if
-- there is no match.
--
@ -493,8 +491,7 @@ pragma Preelaborate (Regpat);
Data : String;
Size : Program_Size := 0;
Data_First : Integer := -1;
Data_Last : Positive := Positive'Last)
return Boolean;
Data_Last : Positive := Positive'Last) return Boolean;
-- Return True if Data matches Expression. Match raises Storage_Error
-- if Size is too small for Expression, or Expression_Error if Expression
-- is not a legal regular expression.
@ -516,8 +513,7 @@ pragma Preelaborate (Regpat);
(Self : Pattern_Matcher;
Data : String;
Data_First : Integer := -1;
Data_Last : Positive := Positive'Last)
return Natural;
Data_Last : Positive := Positive'Last) return Natural;
-- Match Data using the given pattern matcher.
-- Return the position where Data matches, or (Data'First - 1) if there is
-- no match.
@ -528,14 +524,13 @@ pragma Preelaborate (Regpat);
(Self : Pattern_Matcher;
Data : String;
Data_First : Integer := -1;
Data_Last : Positive := Positive'Last)
return Boolean;
Data_Last : Positive := Positive'Last) return Boolean;
-- Return True if Data matches using the given pattern matcher.
--
-- See description of Data_First and Data_Last above.
pragma Inline (Match);
-- All except the last one below.
-- All except the last one below
procedure Match
(Self : Pattern_Matcher;
@ -555,7 +550,7 @@ pragma Preelaborate (Regpat);
-----------
procedure Dump (Self : Pattern_Matcher);
-- Dump the compiled version of the regular expression matched by Self.
-- Dump the compiled version of the regular expression matched by Self
--------------------------
-- Private Declarations --

2
gcc/ada/trans.c
View File

@ -564,7 +564,7 @@ tree_transform (gnat_node)
if (! Is_Machine_Number (gnat_node))
ur_realval
= Machine (Base_Type (Underlying_Type (Etype (gnat_node))),
ur_realval, Round_Even);
ur_realval, Round_Even, gnat_node);
gnu_result
= UI_To_gnu (Numerator (ur_realval), gnu_result_type);

5
gcc/ada/urealp.h
View File

@ -6,7 +6,7 @@
* *
* C Header File *
* *
* Copyright (C) 1992-2002 Free Software Foundation, Inc. *
* Copyright (C) 1992-2003 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- *
@ -47,4 +47,5 @@ extern Boolean UR_Is_Zero (Ureal);
enum Rounding_Mode {Floor = 0, Ceiling = 1, Round = 2, Round_Even = 3};
#define Machine eval_fat__machine
extern Ureal Machine (Entity_Id, Ureal, enum Rounding_Mode);
extern Ureal Machine (Entity_Id, Ureal, enum Rounding_Mode,
Node_Id);