-- 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.
+ -- 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
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
Skip_Space;
- if Nextc = '<' then
- P := P + 1;
- N := Get_Nat;
+ 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;
- 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;
+ -- 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
- XE.Ptype_File_Num := Current_File_Num;
+ 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;
- XE.Ptype_Line := N;
- XE.Ptype_Type := Getc;
- XE.Ptype_Col := Get_Nat;
+ P := P + 1; -- skip closing bracket
+
+ -- No typeref entry present
else
- XE.Ptype_File_Num := No_Sdep_Id;
- XE.Ptype_Line := 0;
- XE.Ptype_Type := ' ';
- XE.Ptype_Col := 0;
+ 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;
-- --
-- S p e c --
-- --
--- $Revision: 1.71 $
+-- $Revision$
-- --
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
-- --
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
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
+ 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.
- Ptype_Col : Nat;
- -- Set to zero if no ptype (parent type) entry, otherwise this is
+ 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
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;
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 --
-------------------------------------
-- --
-- B o d y --
-- --
--- $Revision: 1.88 $
+-- $Revision$
-- --
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
-- --
-- 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
+ -- 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
-- 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
-- other basic tree operations also cause a line of output to be
-- 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
-- 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;
-- --
-- B o d y --
-- --
--- $Revision: 1.125 $
+-- $Revision$
-- --
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
-- --
-- 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
-- Acquire proper Set entity. We use the aligned or unaligned
-- case as appropriate.
- if Must_Be_Aligned (Obj) then
+ if Known_Aligned_Enough (Obj, Csiz) then
Set_nn := RTE (Set_Id (Csiz));
else
Set_nn := RTE (SetU_Id (Csiz));
-- Acquire proper Get entity. We use the aligned or unaligned
-- case as appropriate.
- if Must_Be_Aligned (Obj) then
+ if Known_Aligned_Enough (Obj, Csiz) then
Get_nn := RTE (Get_Id (Csiz));
else
Get_nn := RTE (GetU_Id (Csiz));
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.
+
+ --------------------------------
+ -- In_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 --
---------------------
-- 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.
-- --
-- B o d y --
-- --
--- $Revision: 1.56 $
+-- $Revision$
-- --
-- Copyright (C) 1998-2001, Free Software Foundation, Inc. --
-- --
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;
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 --
-------------------------
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 --
-----------------------
Ctyp : Character;
-- Entity type character
- Parent_Entry : Int;
- -- entry for parent of derived type.
+ 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
- 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;
+ -----------------
+ -- Name_Change --
+ -----------------
function Name_Change (X : Entity_Id) return Boolean is
begin
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;
end loop;
end if;
- -- Output derived entity name if it is available
+ -- 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 := '>';
- Parent_Entry := Get_Parent_Entry (XE.Ent);
+ -- If non-derived ptr, get designated type
- if Parent_Entry /= 0 then
- declare
- XD : Xref_Entry renames Xrefs.Table (Parent_Entry);
+ elsif Is_Access_Type (Tref) then
+ Tref := Designated_Type (Tref);
+ Left := '(';
+ Right := ')';
- begin
- Write_Info_Char ('<');
+ -- For other non-derived base types, nothing
- -- Write unit number only if different from the
- -- current one.
+ else
+ exit;
+ end if;
- if XE.Eun /= XD.Eun then
- Write_Info_Nat (Dependency_Num (XD.Eun));
+ -- 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 (XD.Def)));
+ (Int (Get_Logical_Line_Number (Sloc (Tref))));
Write_Info_Char
- (Xref_Entity_Letters (Ekind (XD.Ent)));
- Write_Info_Nat (Int (Get_Column_Number (XD.Def)));
+ (Xref_Entity_Letters (Ekind (Tref)));
+ Write_Info_Nat
+ (Int (Get_Column_Number (Sloc (Tref))));
+ Write_Info_Char (Right);
+ exit;
- Write_Info_Char ('>');
- end;
- end if;
+ -- If non-standard, non-source entity, keep looking
+
+ else
+ null;
+ end if;
+ end loop;
Curru := Curxu;
Crloc := No_Location;
-- --
-- S p e c --
-- --
--- $Revision: 1.31 $
+-- $Revision$
-- --
-- Copyright (C) 1998-2001, Free Software Foundation, Inc. --
-- --
--
-- The lines following the header look like
--
- -- line type col level entity ptype ref ref ref
+ -- line type col level entity typeref ref ref ref
--
-- line is the line number of the referenced entity. It starts
-- in column one.
-- 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.
+ -- 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
--
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)));
+ Make_Raise_Program_Error (Loc));
Error_Msg_N ("potentially blocking operation, " &
" Program Error will be raised at run time?", N);
projects / gcc.git / commitdiff