This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[Ada] Reflect ACT changes of 2001-10-28
- From: Geert Bosch <bosch at darwin dot gnat dot com>
- To: gcc-patches at gcc dot gnu dot org
- Date: Tue, 11 Dec 2001 17:12:30 -0500 (EST)
- Subject: [Ada] Reflect ACT changes of 2001-10-28
2001-12-11 Robert Dewar <dewar@gnat.com>
* einfo.ads: Minor reformatting
* exp_ch5.adb: Add comment for previous.change
* ali.adb: New interface for extended typeref stuff.
* ali.ads: New interface for typeref stuff.
* checks.adb (Apply_Alignment_Check): New procedure.
* debug.adb: Add -gnatdM for modified ALI output
* exp_pakd.adb (Known_Aligned_Enough): Replaces Known_Aligned_Enough.
* lib-xref.adb: Extend generation of <..> notation to cover
subtype/object types. Note that this is a complete rewrite,
getting rid of the very nasty quadratic algorithm previously
used for derived type output.
* lib-xref.ads: Extend description of <..> notation to cover
subtype/object types. Uses {..} for these other cases.
Also use (..) for pointer types.
* sem_util.adb (Check_Potentially_Blocking_Operation): Slight cleanup.
* exp_pakd.adb: Minor reformatting. Note that prevous RH should say:
(Known_Aligned_Enough): Replaces Must_Be_Aligned.
*** einfo.ads 2001/10/21 10:17:52 1.644
--- einfo.ads 2001/10/28 11:30:45 1.645
***************
*** 302,307 ****
--- 302,308 ----
-- only if the actual subtype differs from the nominal subtype. If the
-- actual and nominal subtypes are the same, then the Actual_Subtype
-- field is Empty, and Etype indicates both types.
+ --
-- For objects, the Actual_Subtype is set only if this is a discriminated
-- type. For arrays, the bounds of the expression are obtained and the
-- Etype of the object is directly the constrained subtype. This is
*** exp_ch5.adb 2001/10/26 23:19:15 1.217
--- exp_ch5.adb 2001/10/28 11:31:27 1.218
***************
*** 1895,1900 ****
--- 1895,1905 ----
-- the Then statements
else
+ -- We do not delete the condition if constant condition
+ -- warnings are enabled, since otherwise we end up deleting
+ -- the desired warning. Of course the backend will get rid
+ -- of this True/False test anyway, so nothing is lost here.
+
if not Constant_Condition_Warnings then
Kill_Dead_Code (Condition (N));
end if;
*** ali.adb 2001/10/03 17:30:20 1.127
--- ali.adb 2001/10/28 15:03:10 1.128
***************
*** 133,139 ****
-- If Lower is set to true then the Name_Buffer will be converted to
-- all lower case. This only happends for systems where file names are
-- not case sensitive, and ensures that gnatbind works correctly on
! -- such systems, regardless of the case of the file name.
function Get_Nat return Nat;
-- Skip blanks, then scan out an unsigned integer value in Nat range
--- 133,140 ----
-- If Lower is set to true then the Name_Buffer will be converted to
-- all lower case. This only happends for systems where file names are
-- not case sensitive, and ensures that gnatbind works correctly on
! -- such systems, regardless of the case of the file name. Note that
! -- a name can be terminated by a right typeref bracket.
function Get_Nat return Nat;
-- Skip blanks, then scan out an unsigned integer value in Nat range
***************
*** 305,310 ****
--- 306,312 ----
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := Getc;
exit when At_End_Of_Field;
+ exit when Nextc = ')' or else Nextc = '}' or else Nextc = '>';
end loop;
-- Convert file name to all lower case if file names are not case
***************
*** 1253,1282 ****
Skip_Space;
! if Nextc = '<' then
! P := P + 1;
! N := Get_Nat;
! if Nextc = '|' then
! XE.Ptype_File_Num :=
! Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
! Current_File_Num := XE.Ptype_File_Num;
! P := P + 1;
N := Get_Nat;
! else
! XE.Ptype_File_Num := Current_File_Num;
end if;
! XE.Ptype_Line := N;
! XE.Ptype_Type := Getc;
! XE.Ptype_Col := Get_Nat;
else
! XE.Ptype_File_Num := No_Sdep_Id;
! XE.Ptype_Line := 0;
! XE.Ptype_Type := ' ';
! XE.Ptype_Col := 0;
end if;
XE.First_Xref := Xref.Last + 1;
--- 1255,1309 ----
Skip_Space;
! case Nextc is
! when '<' => XE.Tref := Tref_Derived;
! when '(' => XE.Tref := Tref_Access;
! when '{' => XE.Tref := Tref_Type;
! when others => XE.Tref := Tref_None;
! end case;
!
! -- Case of typeref field present
!
! if XE.Tref /= Tref_None then
! P := P + 1; -- skip opening bracket
!
! if Nextc in 'a' .. 'z' then
! XE.Tref_File_Num := No_Sdep_Id;
! XE.Tref_Line := 0;
! XE.Tref_Type := ' ';
! XE.Tref_Col := 0;
! XE.Tref_Standard_Entity := Get_Name;
! else
N := Get_Nat;
! if Nextc = '|' then
! XE.Tref_File_Num :=
! Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
! Current_File_Num := XE.Tref_File_Num;
! P := P + 1;
! N := Get_Nat;
!
! else
! XE.Tref_File_Num := Current_File_Num;
! end if;
!
! XE.Tref_Line := N;
! XE.Tref_Type := Getc;
! XE.Tref_Col := Get_Nat;
! XE.Tref_Standard_Entity := No_Name;
end if;
+
+ P := P + 1; -- skip closing bracket
! -- No typeref entry present
else
! XE.Tref_File_Num := No_Sdep_Id;
! XE.Tref_Line := 0;
! XE.Tref_Type := ' ';
! XE.Tref_Col := 0;
! XE.Tref_Standard_Entity := No_Name;
end if;
XE.First_Xref := Xref.Last + 1;
*** ali.ads 2001/09/29 03:24:33 1.73
--- ali.ads 2001/10/28 15:03:16 1.74
***************
*** 588,593 ****
--- 588,602 ----
Table_Increment => 300,
Table_Name => "Xref_Section");
+ -- The following is used to indicate whether a typeref field is present
+ -- for the entity, and if so what kind of typeref field.
+
+ type Tref_Kind is (
+ Tref_None, -- No typeref present
+ Tref_Access, -- Access type typeref (points to designated type)
+ Tref_Derived, -- Derived type typeref (points to parent type)
+ Tref_Type); -- All other cases
+
-- The following table records entities for which xrefs are recorded
type Xref_Entity_Record is record
***************
*** 607,629 ****
Entity : Name_Id;
-- Name of entity
! Ptype_File_Num : Sdep_Id;
! -- This field is set to No_Sdep_Id if no ptype (parent type) entry
! -- is present, otherwise it is the file dependency reference for
! -- the parent type declaration.
!
! Ptype_Line : Nat;
! -- Set to zero if no ptype (parent type) entry, otherwise this is
! -- the line number of the declaration of the parent type.
!
! Ptype_Type : Character;
! -- Set to blank if no ptype (parent type) entry, otherwise this is
! -- the identification character for the parent type. See section
-- "Cross-Reference Entity Indentifiers in lib-xref.ads for details.
! Ptype_Col : Nat;
! -- Set to zero if no ptype (parent type) entry, otherwise this is
-- the column number of the declaration of the parent type.
First_Xref : Nat;
-- Index into Xref table of first cross-reference
--- 616,653 ----
Entity : Name_Id;
-- Name of entity
! Tref : Tref_Kind;
! -- Indicates if a typeref is present, and if so what kind. Set to
! -- Tref_None if no typeref field is present.
!
! Tref_File_Num : Sdep_Id;
! -- This field is set to No_Sdep_Id if no typeref is present, or
! -- if the typeref refers to an entity in standard. Otherwise it
! -- it is the dependency reference for the file containing the
! -- declaration of the typeref entity.
!
! Tref_Line : Nat;
! -- This field is set to zero if no typeref is present, or if the
! -- typeref refers to an entity in standard. Otherwise it contains
! -- the line number of the declaration of the typeref entity.
!
! Tref_Type : Character;
! -- This field is set to blank if no typeref is present, or if the
! -- typeref refers to an entity in standard. Otherwise it contains
! -- the identification character for the typeref entity. See section
-- "Cross-Reference Entity Indentifiers in lib-xref.ads for details.
! Tref_Col : Nat;
! -- This field is set to zero if no typeref is present, or if the
! -- typeref refers to an entity in standard. Otherwise it contains
-- the column number of the declaration of the parent type.
+
+ Tref_Standard_Entity : Name_Id;
+ -- This field is set to No_Name if no typeref is present or if the
+ -- typeref refers to a declared entity rather than an entity in
+ -- package Standard. If there is a typeref that references an
+ -- entity in package Standard, then this field is a Name_Id
+ -- reference for the entity name.
First_Xref : Nat;
-- Index into Xref table of first cross-reference
*** checks.adb 2001/10/25 01:16:17 1.208
--- checks.adb 2001/10/28 15:12:48 1.209
***************
*** 37,42 ****
--- 37,43 ----
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
+ with Restrict; use Restrict;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Eval; use Sem_Eval;
***************
*** 276,281 ****
--- 277,355 ----
Analyze_And_Resolve (N);
end if;
end Apply_Accessibility_Check;
+
+ ---------------------------
+ -- Apply_Alignment_Check --
+ ---------------------------
+
+ procedure Apply_Alignment_Check (E : Entity_Id; N : Node_Id) is
+ AC : constant Node_Id := Address_Clause (E);
+ Expr : Node_Id;
+ Loc : Source_Ptr;
+
+ begin
+ if No (AC) or else Range_Checks_Suppressed (E) then
+ return;
+ end if;
+
+ Loc := Sloc (AC);
+ Expr := Expression (AC);
+
+ if Nkind (Expr) = N_Unchecked_Type_Conversion then
+ Expr := Expression (Expr);
+
+ elsif Nkind (Expr) = N_Function_Call
+ and then Is_RTE (Entity (Name (Expr)), RE_To_Address)
+ then
+ Expr := First (Parameter_Associations (Expr));
+
+ if Nkind (Expr) = N_Parameter_Association then
+ Expr := Explicit_Actual_Parameter (Expr);
+ end if;
+ end if;
+
+ -- Here Expr is the address value. See if we know that the
+ -- value is unacceptable at compile time.
+
+ if Compile_Time_Known_Value (Expr)
+ and then Known_Alignment (E)
+ then
+ if Expr_Value (Expr) mod Alignment (E) /= 0 then
+ Insert_Action (N,
+ Make_Raise_Program_Error (Loc));
+ Error_Msg_NE
+ ("?specified address for& not " &
+ "consistent with alignment", Expr, E);
+ end if;
+
+ -- Here we do not know if the value is acceptable, generate
+ -- code to raise PE if alignment is inappropriate.
+
+ else
+ -- Skip generation of this code if we don't want elab code
+
+ if not Restrictions (No_Elaboration_Code) then
+ Insert_After_And_Analyze (N,
+ Make_Raise_Program_Error (Loc,
+ Condition =>
+ Make_Op_Ne (Loc,
+ Left_Opnd =>
+ Make_Op_Mod (Loc,
+ Left_Opnd =>
+ Unchecked_Convert_To
+ (RTE (RE_Integer_Address),
+ Duplicate_Subexpr (Expr)),
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (E, Loc),
+ Attribute_Name => Name_Alignment)),
+ Right_Opnd => Make_Integer_Literal (Loc, Uint_0))),
+ Suppress => All_Checks);
+ end if;
+ end if;
+
+ return;
+ end Apply_Alignment_Check;
-------------------------------------
-- Apply_Arithmetic_Overflow_Check --
*** debug.adb 2001/09/08 16:05:45 1.88
--- debug.adb 2001/10/28 15:13:13 1.89
***************
*** 80,86 ****
-- dJ Output debugging trace info for JGNAT (Java VM version of GNAT)
-- dK Kill all error messages
-- dL Output trace information on elaboration checking
! -- dM
-- dN Do not generate file/line exception messages
-- dO Output immediate error messages
-- dP Do not check for controlled objects in preelaborable packages
--- 80,86 ----
-- dJ Output debugging trace info for JGNAT (Java VM version of GNAT)
-- dK Kill all error messages
-- dL Output trace information on elaboration checking
! -- dM Modified ali file output
-- dN Do not generate file/line exception messages
-- dO Output immediate error messages
-- dP Do not check for controlled objects in preelaborable packages
***************
*** 283,288 ****
--- 283,293 ----
-- Of course they may not have any useful effect, and in particular
-- attempting to generate code with this flag set may blow up.
-- The flag also forces the use of 64-bits for Long_Integer.
+
+ -- dM Generate modified ALI output. Several ALI extensions are being
+ -- developed for version 3.15w, and this switch is used to enable
+ -- these extensions. This switch will disappear when this work is
+ -- completed.
-- dn Generate messages for node/list allocation. Each time a node or
-- list header is allocated, a line of output is generated. Certain
*** exp_pakd.adb 2001/03/18 08:49:51 1.125
--- exp_pakd.adb 2001/10/28 15:13:38 1.126
***************
*** 453,458 ****
--- 453,468 ----
-- expression whose type is the implementation type used to represent
-- the packed array. Aexp is analyzed and resolved on entry and on exit.
+ function Known_Aligned_Enough (Obj : Node_Id; Csiz : Nat) return Boolean;
+ -- There are two versions of the Set routines, the ones used when the
+ -- object is known to be sufficiently well aligned given the number of
+ -- bits, and the ones used when the object is not known to be aligned.
+ -- This routine is used to determine which set to use. Obj is a reference
+ -- to the object, and Csiz is the component size of the packed array.
+ -- True is returned if the alignment of object is known to be sufficient,
+ -- defined as 1 for odd bit sizes, 4 for bit sizes divisible by 4, and
+ -- 2 otherwise.
+
function Make_Shift_Left (N : Node_Id; S : Node_Id) return Node_Id;
-- Build a left shift node, checking for the case of a shift count of zero
***************
*** 1426,1432 ****
-- Acquire proper Set entity. We use the aligned or unaligned
-- case as appropriate.
! if Must_Be_Aligned (Obj) then
Set_nn := RTE (Set_Id (Csiz));
else
Set_nn := RTE (SetU_Id (Csiz));
--- 1436,1442 ----
-- Acquire proper Set entity. We use the aligned or unaligned
-- case as appropriate.
! if Known_Aligned_Enough (Obj, Csiz) then
Set_nn := RTE (Set_Id (Csiz));
else
Set_nn := RTE (SetU_Id (Csiz));
***************
*** 1816,1822 ****
-- Acquire proper Get entity. We use the aligned or unaligned
-- case as appropriate.
! if Must_Be_Aligned (Obj) then
Get_nn := RTE (Get_Id (Csiz));
else
Get_nn := RTE (GetU_Id (Csiz));
--- 1826,1832 ----
-- Acquire proper Get entity. We use the aligned or unaligned
-- case as appropriate.
! if Known_Aligned_Enough (Obj, Csiz) then
Get_nn := RTE (Get_Id (Csiz));
else
Get_nn := RTE (GetU_Id (Csiz));
***************
*** 2087,2092 ****
--- 2097,2218 ----
return False;
end if;
end Involves_Packed_Array_Reference;
+
+ --------------------------
+ -- Known_Aligned_Enough --
+ --------------------------
+
+ function Known_Aligned_Enough (Obj : Node_Id; Csiz : Nat) return Boolean is
+ Typ : constant Entity_Id := Etype (Obj);
+
+ function In_Partially_Packed_Record (Comp : Entity_Id) return Boolean;
+ -- If the component is in a record that contains previous packed
+ -- components, consider it unaligned because the back-end might
+ -- choose to pack the rest of the record. Lead to less efficient code,
+ -- but safer vis-a-vis of back-end choices.
+
+ -----------------------------
+ -- Partially_Packed_Record --
+ -----------------------------
+
+ function In_Partially_Packed_Record (Comp : Entity_Id) return Boolean is
+ Rec_Type : constant Entity_Id := Scope (Comp);
+ Prev_Comp : Entity_Id;
+
+ begin
+ Prev_Comp := First_Entity (Rec_Type);
+ while Present (Prev_Comp) loop
+ if Is_Packed (Etype (Prev_Comp)) then
+ return True;
+
+ elsif Prev_Comp = Comp then
+ return False;
+ end if;
+
+ Next_Entity (Prev_Comp);
+ end loop;
+
+ return False;
+ end In_Partially_Packed_Record;
+
+ -- Start of processing for Known_Aligned_Enough
+
+ begin
+ -- Odd bit sizes don't need alignment anyway
+
+ if Csiz mod 2 = 1 then
+ return True;
+
+ -- If we have a specified alignment, see if it is sufficient, if not
+ -- then we can't possibly be aligned enough in any case.
+
+ elsif Is_Entity_Name (Obj)
+ and then Known_Alignment (Entity (Obj))
+ then
+ -- Alignment required is 4 if size is a multiple of 4, and
+ -- 2 otherwise (e.g. 12 bits requires 4, 10 bits requires 2)
+
+ if Alignment (Entity (Obj)) < 4 - (Csiz mod 4) then
+ return False;
+ end if;
+ end if;
+
+ -- OK, alignment should be sufficient, if object is aligned
+
+ -- If object is strictly aligned, then it is definitely aligned
+
+ if Strict_Alignment (Typ) then
+ return True;
+
+ -- Case of subscripted array reference
+
+ elsif Nkind (Obj) = N_Indexed_Component then
+
+ -- If we have a pointer to an array, then this is definitely
+ -- aligned, because pointers always point to aligned versions.
+
+ if Is_Access_Type (Etype (Prefix (Obj))) then
+ return True;
+
+ -- Otherwise, go look at the prefix
+
+ else
+ return Known_Aligned_Enough (Prefix (Obj), Csiz);
+ end if;
+
+ -- Case of record field
+
+ elsif Nkind (Obj) = N_Selected_Component then
+
+ -- What is significant here is whether the record type is packed
+
+ if Is_Record_Type (Etype (Prefix (Obj)))
+ and then Is_Packed (Etype (Prefix (Obj)))
+ then
+ return False;
+
+ -- Or the component has a component clause which might cause
+ -- the component to become unaligned (we can't tell if the
+ -- backend is doing alignment computations).
+
+ elsif Present (Component_Clause (Entity (Selector_Name (Obj)))) then
+ return False;
+
+ elsif In_Partially_Packed_Record (Entity (Selector_Name (Obj))) then
+ return False;
+
+ -- In all other cases, go look at prefix
+
+ else
+ return Known_Aligned_Enough (Prefix (Obj), Csiz);
+ end if;
+
+ -- If not selected or indexed component, must be aligned
+
+ else
+ return True;
+ end if;
+ end Known_Aligned_Enough;
---------------------
-- Make_Shift_Left --
*** lib-xref.adb 2001/07/24 19:35:38 1.56
--- lib-xref.adb 2001/10/28 15:14:16 1.57
***************
*** 28,33 ****
--- 28,34 ----
with Atree; use Atree;
with Csets; use Csets;
+ with Debug; use Debug;
with Lib.Util; use Lib.Util;
with Namet; use Namet;
with Opt; use Opt;
***************
*** 84,93 ****
Table_Increment => Alloc.Xrefs_Increment,
Table_Name => "Xrefs");
- function Get_Xref_Index (E : Entity_Id) return Xref_Entry_Number;
- -- Returns the Xref entry table index for entity E.
- -- So : Xrefs.Table (Get_Xref_Index (E)).Ent = E
-
-------------------------
-- Generate_Definition --
-------------------------
--- 85,90 ----
***************
*** 328,350 ****
end if;
end Generate_Reference;
- --------------------
- -- Get_Xref_Index --
- --------------------
-
- function Get_Xref_Index (E : Entity_Id) return Xref_Entry_Number is
- begin
- for K in 1 .. Xrefs.Last loop
- if Xrefs.Table (K).Ent = E then
- return K;
- end if;
- end loop;
-
- -- not found, this happend if the entity is not in the compiled unit.
-
- return 0;
- end Get_Xref_Index;
-
-----------------------
-- Output_References --
-----------------------
--- 325,330 ----
***************
*** 465,500 ****
Ctyp : Character;
-- Entity type character
! Parent_Entry : Int;
! -- entry for parent of derived type.
function Name_Change (X : Entity_Id) return Boolean;
-- Determines if entity X has a different simple name from Curent
-
- function Get_Parent_Entry (X : Entity_Id) return Int;
- -- For a derived type, locate entry of parent type, if defined in
- -- in the current unit.
-
- function Get_Parent_Entry (X : Entity_Id) return Int is
- Parent_Type : Entity_Id;
-
- begin
- if not Is_Type (X)
- or else not Is_Derived_Type (X)
- then
- return 0;
- else
- Parent_Type := First_Subtype (Etype (Base_Type (X)));
-
- if Comes_From_Source (Parent_Type) then
- return Get_Xref_Index (Parent_Type);
! else
! return 0;
! end if;
! end if;
! end Get_Parent_Entry;
function Name_Change (X : Entity_Id) return Boolean is
begin
--- 445,463 ----
Ctyp : Character;
-- Entity type character
+
+ Tref : Entity_Id;
+ -- Type reference
! Trunit : Unit_Number_Type;
! -- Unit number for type reference
function Name_Change (X : Entity_Id) return Boolean;
-- Determines if entity X has a different simple name from Curent
! -----------------
! -- Name_Change --
! -----------------
function Name_Change (X : Entity_Id) return Boolean is
begin
***************
*** 529,535 ****
--- 492,503 ----
WC : Char_Code;
Err : Boolean;
Ent : Entity_Id;
+ Sav : Entity_Id;
+ Left : Character;
+ Right : Character;
+ -- Used for {} or <> for type reference
+
begin
Ent := XE.Ent;
Ctyp := Xref_Entity_Letters (Ekind (Ent));
***************
*** 708,742 ****
Write_Info_Char (Cursrc (J));
end loop;
end if;
! -- Output derived entity name if it is available
! Parent_Entry := Get_Parent_Entry (XE.Ent);
! if Parent_Entry /= 0 then
! declare
! XD : Xref_Entry renames Xrefs.Table (Parent_Entry);
! begin
! Write_Info_Char ('<');
! -- Write unit number only if different from the
! -- current one.
! if XE.Eun /= XD.Eun then
! Write_Info_Nat (Dependency_Num (XD.Eun));
Write_Info_Char ('|');
end if;
Write_Info_Nat
! (Int (Get_Logical_Line_Number (XD.Def)));
Write_Info_Char
! (Xref_Entity_Letters (Ekind (XD.Ent)));
! Write_Info_Nat (Int (Get_Column_Number (XD.Def)));
!
! Write_Info_Char ('>');
! end;
! end if;
Curru := Curxu;
Crloc := No_Location;
--- 676,799 ----
Write_Info_Char (Cursrc (J));
end loop;
end if;
+
+ -- Output type reference if any
+
+ Tref := XE.Ent;
+ Left := '{';
+ Right := '}';
+
+ loop
+ Sav := Tref;
+
+ -- Processing for types
+
+ if Is_Type (Tref) then
+
+ -- Case of base type
+
+ if Base_Type (Tref) = Tref then
+
+ -- If derived, then get first subtype
! if Tref /= Etype (Tref) then
! Tref := First_Subtype (Etype (Tref));
! Left := '<';
! Right := '>';
! -- If non-derived ptr, get designated type
! elsif Is_Access_Type (Tref) then
! Tref := Designated_Type (Tref);
! Left := '(';
! Right := ')';
! -- For other non-derived base types, nothing
! else
! exit;
! end if;
! -- For a subtype, go to ancestor subtype
!
! else
! Tref := Ancestor_Subtype (Tref);
!
! -- If no ancestor subtype, go to base type
!
! if No (Tref) then
! Tref := Base_Type (Sav);
! end if;
! end if;
!
! -- For objects, functions, enum literals,
! -- just get type from Etype field.
!
! elsif Is_Object (Tref)
! or else Ekind (Tref) = E_Enumeration_Literal
! or else Ekind (Tref) = E_Function
! or else Ekind (Tref) = E_Operator
! then
! Tref := Etype (Tref);
!
! -- For anything else, exit
!
! else
! exit;
! end if;
!
! -- Exit if no type reference, or we are stuck in
! -- some loop trying to find the type reference.
!
! exit when No (Tref) or else Tref = Sav;
!
! -- Case of standard entity, output name
!
! if Sloc (Tref) = Standard_Location then
!
! -- For now, output only if speial -gnatdM flag set
!
! exit when not Debug_Flag_MM;
!
! Write_Info_Char (Left);
! Write_Info_Name (Chars (Tref));
! Write_Info_Char (Right);
! exit;
!
! -- Case of source entity, output location
!
! elsif Comes_From_Source (Tref) then
!
! -- For now, output only derived type entries
! -- unless we have special debug flag -gnatdM
!
! exit when not (Debug_Flag_MM or else Left = '<');
!
! -- Output the reference
!
! Write_Info_Char (Left);
! Trunit := Get_Source_Unit (Sloc (Tref));
!
! if Trunit /= Curxu then
! Write_Info_Nat (Dependency_Num (Trunit));
Write_Info_Char ('|');
end if;
Write_Info_Nat
! (Int (Get_Logical_Line_Number (Sloc (Tref))));
Write_Info_Char
! (Xref_Entity_Letters (Ekind (Tref)));
! Write_Info_Nat
! (Int (Get_Column_Number (Sloc (Tref))));
! Write_Info_Char (Right);
! exit;
!
! -- If non-standard, non-source entity, keep looking
!
! else
! null;
! end if;
! end loop;
Curru := Curxu;
Crloc := No_Location;
*** lib-xref.ads 2001/07/24 19:35:07 1.31
--- lib-xref.ads 2001/10/28 15:14:22 1.32
***************
*** 56,62 ****
--
-- The lines following the header look like
--
! -- line type col level entity ptype ref ref ref
--
-- line is the line number of the referenced entity. It starts
-- in column one.
--- 56,62 ----
--
-- The lines following the header look like
--
! -- line type col level entity typeref ref ref ref
--
-- line is the line number of the referenced entity. It starts
-- in column one.
***************
*** 74,90 ****
-- entity is the name of the referenced entity, with casing in
-- the canical casing for the source file where it is defined.
--
! -- ptype is the parent's entity reference. This part is optional (it
! -- is only set for derived types) and has the following format:
--
! -- < file | line type col >
! --
! -- file is the dependency number of the file containing the
! -- declaration of the parent type. This number and the following
! -- vertical bar are omitted if the parent type is defined in the
! -- same file as the derived type. The line, type, col are defined
! -- as previously described, and give the location of the parent
! -- type declaration in the referenced file.
--
-- There may be zero or more ref entries on each line
--
--- 74,103 ----
-- entity is the name of the referenced entity, with casing in
-- the canical casing for the source file where it is defined.
--
! -- typeref is the reference for the type. This part is optional.
! -- It is present for the following cases:
--
! -- derived types (points to the parent type) LR=<>
! -- access types (points to designated type) LR=()
! -- subtypes (points to ancestor type) LR={}
! -- functions (points to result type) LR={}
! -- enumeration literals (points to enum type) LR={}
! -- objects and components (points to type) LR={}
! --
! -- In the above list LR shows the brackets used in the output,
! -- which has one of the two following forms:
! --
! -- L file | line type col R user entity
! -- L name-in-lower-case R standard entity
! --
! -- For the form for a user entity, file is the dependency number
! -- of the file containing the declaration of the parent type. This
! -- number and the following vertical bar are omitted if the relevant
! -- type is defined in the same file as the current entity. The line,
! -- type, col are defined as previously described, and specify the
! -- location of the relevant type declaration in the referenced file.
! -- For the standard entity form, the name between the brackets is
! -- the normal name of the entity in lower case letters.
--
-- There may be zero or more ref entries on each line
--
*** sem_util.adb 2001/10/11 16:16:38 1.545
--- sem_util.adb 2001/10/28 15:14:54 1.546
***************
*** 720,727 ****
if Is_Protected_Type (S) then
if Restricted_Profile then
Insert_Before (N,
! Make_Raise_Statement (Loc,
! Name => New_Occurrence_Of (Standard_Program_Error, Loc)));
Error_Msg_N ("potentially blocking operation, " &
" Program Error will be raised at run time?", N);
--- 720,726 ----
if Is_Protected_Type (S) then
if Restricted_Profile then
Insert_Before (N,
! Make_Raise_Program_Error (Loc));
Error_Msg_N ("potentially blocking operation, " &
" Program Error will be raised at run time?", N);
*** exp_pakd.adb 2001/10/28 15:13:38 1.126
--- exp_pakd.adb 2001/10/28 15:40:30 1.127
***************
*** 2111,2119 ****
-- choose to pack the rest of the record. Lead to less efficient code,
-- but safer vis-a-vis of back-end choices.
! -----------------------------
! -- Partially_Packed_Record --
! -----------------------------
function In_Partially_Packed_Record (Comp : Entity_Id) return Boolean is
Rec_Type : constant Entity_Id := Scope (Comp);
--- 2111,2119 ----
-- choose to pack the rest of the record. Lead to less efficient code,
-- but safer vis-a-vis of back-end choices.
! --------------------------------
! -- In_Partially_Packed_Record --
! --------------------------------
function In_Partially_Packed_Record (Comp : Entity_Id) return Boolean is
Rec_Type : constant Entity_Id := Scope (Comp);
***************
*** 2310,2315 ****
--- 2310,2316 ----
-- All we have to do here is to find the subscripts that correspond
-- to the index positions that have non-standard enumeration types
-- and insert a Pos attribute to get the proper subscript value.
+
-- Finally the prefix must be uncheck converted to the corresponding
-- packed array type.