Geek Gadgets 1

home *** CD-ROM | disk | FTP | other *** search

/ Geek Gadgets 1 / ADE-1.bin / ade-dist / gnat-2.06-src.tgz / tar.out / fsf / gnat / ada / sem_util.adb < prev next >

Wrap

Text File | 1996-09-28 | 61KB | 1,961 lines

------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ U T I L -- -- -- -- B o d y -- -- -- -- $Revision: 1.233 $ -- -- -- -- Copyright (c) 1992,1993,1994,1995 NYU, All Rights Reserved -- -- -- -- 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- -- -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Checks; use Checks; with Debug; use Debug; with Errout; use Errout; with Elists; use Elists; with Exp_Util; use Exp_Util; with Itypes; use Itypes; with Lib; use Lib; with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; with Output; use Output; with Opt; use Opt; with Scans; use Scans; with Scn; use Scn; with Sem; use Sem; with Sem_Ch8; use Sem_Ch8; with Sem_Eval; use Sem_Eval; with Sem_Prag; use Sem_Prag; with Sem_Res; use Sem_Res; with Sem_Type; use Sem_Type; with Sinfo; use Sinfo; with Sinput; use Sinput; with Snames; use Snames; with Stand; use Stand; with Style; with Tbuild; use Tbuild; package body Sem_Util is -------------------------- -- Build_Actual_Subtype -- -------------------------- -- ??? is there something special to do for the explicit deference -- case (e.g. access string) ??? function Build_Actual_Subtype (T : Entity_Id; N : Node_Or_Entity_Id) return Node_Id is Obj : Node_Id; Loc : constant Source_Ptr := Sloc (N); Constraints : List_Id; Decl : Node_Id; Discr : Entity_Id; Formal : Entity_Id; Hi : Node_Id; Lo : Node_Id; Subt : Entity_Id; begin if Nkind (N) = N_Defining_Identifier then Obj := New_Reference_To (N, Loc); else Obj := N; end if; if Is_Array_Type (T) then Constraints := New_List; for J in 1 .. Number_Dimensions (T) loop -- Build an array subtype declaration with the nominal -- subtype and the bounds of the actual. Add the declaration -- in front of the local declarations for the subprogram,for -- analysis before any reference to the formal in the body. Lo := Make_Attribute_Reference (Loc, Prefix => Duplicate_Subexpr (Obj, Name_Req => True), Attribute_Name => Name_First, Expressions => New_List ( Make_Integer_Literal (Loc, UI_From_Int (J)))); Hi := Make_Attribute_Reference (Loc, Prefix => Duplicate_Subexpr (Obj, Name_Req => True), Attribute_Name => Name_Last, Expressions => New_List ( Make_Integer_Literal (Loc, UI_From_Int (J)))); Append (Make_Range (Loc, Lo, Hi), Constraints); end loop; else Constraints := New_List; Discr := First_Discriminant (T); while Present (Discr) loop Append_To (Constraints, Make_Selected_Component (Loc, Prefix => Duplicate_Subexpr (Obj), Selector_Name => New_Occurrence_Of (Discr, Loc))); Discr := Next_Discriminant (Discr); end loop; end if; Subt := Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('S')); Decl := Make_Subtype_Declaration (Loc, Defining_Identifier => Subt, Subtype_Indication => Make_Subtype_Indication (Loc, Subtype_Mark => New_Reference_To (T, Loc), Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => Constraints))); return Decl; end Build_Actual_Subtype; --------------------------------------- -- Build_Actual_Subtype_Of_Component -- --------------------------------------- function Build_Actual_Subtype_Of_Component (T : Entity_Id; N : Node_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (N); P : constant Node_Id := Prefix (N); D : Elmt_Id; Id : Node_Id; Subt : Entity_Id; function Denotes_Discriminant (N : Node_Id) return Boolean; -- Check whether bound or discriminant constraint is a discriminant. function Build_Actual_Array_Constraint return List_Id; -- If one or more of the bounds of the component depends on -- discriminants, build actual constraint using the discriminants -- of the prefix. function Build_Actual_Record_Constraint return List_Id; -- Similar to previous one, for discriminated components constrained -- by the discriminant of the enclosing object. function Denotes_Discriminant (N : Node_Id) return Boolean is begin return Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Discriminant; end Denotes_Discriminant; function Build_Subtype (C : List_Id) return Node_Id; -- Build actual declaration for array or record subtype. function Build_Actual_Array_Constraint return List_Id is Constraints : List_Id := New_List; Indx : Node_Id; Hi : Node_Id; Lo : Node_Id; Old_Hi : Node_Id; Old_Lo : Node_Id; begin Indx := First_Index (T); while Present (Indx) loop Old_Lo := Type_Low_Bound (Etype (Indx)); Old_Hi := Type_High_Bound (Etype (Indx)); if Denotes_Discriminant (Old_Lo) then Lo := Make_Selected_Component (Loc, Prefix => New_Copy_Tree (P), Selector_Name => New_Occurrence_Of (Entity (Old_Lo), Loc)); else Lo := New_Copy_Tree (Old_Lo); end if; if Denotes_Discriminant (Old_Hi) then Hi := Make_Selected_Component (Loc, Prefix => New_Copy_Tree (P), Selector_Name => New_Occurrence_Of (Entity (Old_Hi), Loc)); else Hi := New_Copy_Tree (Old_Hi); end if; Append (Make_Range (Loc, Lo, Hi), Constraints); Indx := Next_Index (Indx); end loop; return Constraints; end Build_Actual_Array_Constraint; function Build_Actual_Record_Constraint return List_Id is Constraints : List_Id := New_List; D : Elmt_Id; D_Val : Node_Id; begin D := First_Elmt (Discriminant_Constraint (T)); while Present (D) loop if Denotes_Discriminant (Node (D)) then D_Val := Make_Selected_Component (Loc, Prefix => New_Copy_Tree (P), Selector_Name => New_Occurrence_Of (Entity (Node (D)), Loc)); else D_Val := New_Copy_Tree (Node (D)); end if; Append (D_Val, Constraints); D := Next_Elmt (D); end loop; return Constraints; end Build_Actual_Record_Constraint; function Build_Subtype (C : List_Id) return Node_Id is Subt : Entity_Id; Decl : Node_Id; begin Subt := Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('S')); Decl := Make_Subtype_Declaration (Loc, Defining_Identifier => Subt, Subtype_Indication => Make_Subtype_Indication (Loc, Subtype_Mark => New_Reference_To (Base_Type (T), Loc), Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => C))); return Decl; end Build_Subtype; -- Start of processing for Build_Actual_Subtype_Of_Component begin if Nkind (N) = N_Explicit_Dereference then if Is_Composite_Type (T) and then not Is_Constrained (T) and then not (Is_Class_Wide_Type (T) and then Is_Constrained (Root_Type (T))) then return Build_Actual_Subtype (T, N); else return Empty; end if; elsif Ekind (T) = E_Array_Subtype then Id := First_Index (T); while Present (Id) loop if Denotes_Discriminant (Type_Low_Bound (Etype (Id))) or else Denotes_Discriminant (Type_High_Bound (Etype (Id))) then return Build_Subtype (Build_Actual_Array_Constraint); end if; Id := Next_Index (Id); end loop; elsif Ekind (T) = E_Record_Subtype and then Has_Discriminants (T) then D := First_Elmt (Discriminant_Constraint (T)); while Present (D) loop if Denotes_Discriminant (Node (D)) then return Build_Subtype (Build_Actual_Record_Constraint); end if; D := Next_Elmt (D); end loop; end if; -- If none of the above, the actual and nominal subtypes are the same. return Empty; end Build_Actual_Subtype_Of_Component; -------------------------- -- Check_Fully_Declared -- -------------------------- procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is begin if Ekind (T) = E_Incomplete_Type then Error_Msg_NE ("premature usage of incomplete}", N, T); elsif Has_Private_Component (T) and then not Is_Generic_Type (Root_Type (T)) then Error_Msg_NE ("premature usage of incomplete}", N, T); end if; end Check_Fully_Declared; ----------------------------------- -- Compile_Time_Constraint_Error -- ----------------------------------- procedure Compile_Time_Constraint_Error (N : Node_Id; Msg : String) is Loc : constant Source_Ptr := Sloc (N); Typ : constant Entity_Id := Etype (N); Stat : constant Boolean := Is_Static_Expression (N); Msgc : String (1 .. Msg'Length + 1); Msgl : Natural; Warn : Boolean; P : Node_Id; Msgs : Boolean; function In_Instance_Body return Boolean; -- A static constraint error in an instance body is not a fatal error. -- we choose to inhibit the error altogether, because there is no -- obvious node (for now) on which to post it. function In_Instance_Body return Boolean is S : Entity_Id := Current_Scope; begin while Present (S) and then S /= Standard_Standard loop if (Ekind (S) = E_Function or else Ekind (S) = E_Procedure) and then Present (Generic_Parent (Specification (Get_Declaration_Node (S)))) then return True; elsif Ekind (S) = E_Package and then In_Package_Body (S) and then Present (Generic_Parent (Specification (Get_Declaration_Node (S)))) then return True; end if; S := Scope (S); end loop; return False; end In_Instance_Body; -- Start of processing for Compile_Time_Constraint_Error begin if In_Instance_Body then return; -- No messages are generated if we already posted an error on this node elsif not Error_Posted (N) then Msgc (1 .. Msg'Length) := Msg; -- Message is a warning, even in Ada 95 case if Msg (Msg'Length) = '?' then Warn := True; Msgl := Msg'Length; -- In Ada 83, all messages are warnings elsif Ada_83 and then Comes_From_Source (N) then Msgl := Msg'Length + 1; Msgc (Msgl) := '?'; Warn := True; -- Otherwise we have a real error message (Ada 95 static case) else Warn := False; Msgl := Msg'Length; end if; -- Should we generate a warning? The answer is not quite yes. The -- very annoying exception occurs in the case of a short circuit -- operator where the left operand is static and decisive. Climb -- parents to see if that is the case we have here. Msgs := True; P := N; loop P := Parent (P); exit when Nkind (P) not in N_Subexpr; if (Nkind (P) = N_And_Then and then Is_OK_Static_Expression (Left_Opnd (P)) and then Is_False (Expr_Value (Left_Opnd (P)))) or else (Nkind (P) = N_Or_Else and then Is_OK_Static_Expression (Left_Opnd (P)) and then Is_True (Expr_Value (Left_Opnd (P)))) then Msgs := False; exit; end if; end loop; if Msgs then Error_Msg_NE (Msgc (1 .. Msgl), N, Typ); if Warn then Error_Msg_NE ("& will be raised at runtime?!", N, Standard_Constraint_Error); else Error_Msg_NE ("static expression raises&!", N, Standard_Constraint_Error); end if; end if; end if; -- Now we replace the node by an N_Raise_Constraint_Error node -- This does not need reanalyzing, so set it as analyzed now. Rewrite_Substitute_Tree (N, Make_Raise_Constraint_Error (Loc)); Set_Analyzed (N, True); Set_Etype (N, Typ); Set_Raises_Constraint_Error (N); -- If the original expression was marked as static, the result is -- still marked as static, but the Raises_Constraint_Error flag is -- set so that further static evaluation is not attempted. if Stat then Set_Is_Static_Expression (N); end if; end Compile_Time_Constraint_Error; -------------------- -- Current_Entity -- -------------------- -- The currently visible definition for a given identifier is the -- one most chained at the start of the visibility chain, i.e. the -- one that is referenced by the Node_Id value of the name of the -- given identifier. function Current_Entity (N : Node_Id) return Entity_Id is begin return Get_Name_Entity_Id (Chars (N)); end Current_Entity; ----------------------------- -- Current_Entity_In_Scope -- ----------------------------- function Current_Entity_In_Scope (N : Node_Id) return Entity_Id is E : Entity_Id; begin E := Get_Name_Entity_Id (Chars (N)); while Present (E) and then Scope (E) /= Current_Scope loop E := Homonym (E); end loop; return E; end Current_Entity_In_Scope; ------------------- -- Current_Scope -- ------------------- function Current_Scope return Entity_Id is C : constant Entity_Id := Scope_Stack.Table (Scope_Stack.last).Entity; begin if Present (C) then return C; else return Standard_Standard; end if; end Current_Scope; ------------------------------- -- Defining_Unit_Simple_Name -- ------------------------------- function Defining_Unit_Simple_Name (N : Node_Id) return Entity_Id is Nam : Node_Id := Defining_Unit_Name (N); begin if Nkind (Nam) in N_Entity then return Nam; else return Defining_Identifier (Nam); end if; end Defining_Unit_Simple_Name; ------------------------- -- Designate_Same_Unit -- ------------------------- function Designate_Same_Unit (Name1 : Node_Id; Name2 : Node_Id) return Boolean is K1 : Node_Kind := Nkind (Name1); K2 : Node_Kind := Nkind (Name2); function Prefix_Node (N : Node_Id) return Node_Id; -- Returns the parent unit name node of a defining program unit name -- or the prefix if N is a selected component or an expanded name. function Select_Node (N : Node_Id) return Node_Id; -- Returns the defining identifier node of a defining program unit -- name or the selector node if N is a selected component or an -- expanded name. function Prefix_Node (N : Node_Id) return Node_Id is begin if Nkind (N) = N_Defining_Program_Unit_Name then return Name (N); else return Prefix (N); end if; end Prefix_Node; function Select_Node (N : Node_Id) return Node_Id is begin if Nkind (N) = N_Defining_Program_Unit_Name then return Defining_Identifier (N); else return Selector_Name (N); end if; end Select_Node; -- Start of processing for Designate_Next_Unit begin if (K1 = N_Identifier or else K1 = N_Defining_Identifier) and then (K2 = N_Identifier or else K2 = N_Defining_Identifier) then return Chars (Name1) = Chars (Name2); elsif (K1 = N_Expanded_Name or else K1 = N_Selected_Component or else K1 = N_Defining_Program_Unit_Name) and then (K2 = N_Expanded_Name or else K2 = N_Selected_Component or else K2 = N_Defining_Program_Unit_Name) then return (Chars (Select_Node (Name1)) = Chars (Select_Node (Name2))) and then Designate_Same_Unit (Prefix_Node (Name1), Prefix_Node (Name2)); else return False; end if; end Designate_Same_Unit; ----------------------------- -- Enclosing_Dynamic_Scope -- ----------------------------- function Enclosing_Dynamic_Scope (E : Entity_Id) return Entity_Id is S : Entity_Id := E; begin -- Chase up the scope links (equivalent to, but faster than moving -- through entries stored on the scope stack, since no indexing). while S /= Standard_Standard and then Ekind (S) /= E_Block and then Ekind (S) /= E_Function and then Ekind (S) /= E_Procedure and then Ekind (S) /= E_Task_Type and then Ekind (S) /= E_Entry loop S := Scope (S); end loop; return S; end Enclosing_Dynamic_Scope; ---------------- -- Enter_Name -- ---------------- procedure Enter_Name (Def_Id : Node_Id) is C : constant Entity_Id := Current_Entity (Def_Id); E : constant Entity_Id := Current_Entity_In_Scope (Def_Id); S : constant Entity_Id := Current_Scope; begin -- Add new name to current scope declarations. Check for duplicate -- declaration, which may or may not be a genuine error. if Present (E) then -- Case of previous entity entered because of a missing declaration -- or else a bad subtype indication. Best is to use the new entity, -- and make the previous one invisible. if Etype (E) = Any_Type then Set_Is_Immediately_Visible (E, False); -- Case of renaming declaration constructed for package instances. -- if there is an explicit declaration with the same identifier, -- the renaming is not immediately visible any longer, but remains -- visible through selected component notation. elsif Nkind (Parent (E)) = N_Package_Renaming_Declaration and then not Comes_From_Source (E) then Set_Is_Immediately_Visible (E, False); -- Case of genuine duplicate declaration else Error_Msg_Sloc := Sloc (E); Error_Msg_N ("& conflicts with declaration#", Def_Id); -- If entity is in standard, then we are in trouble, because -- it means that we have a library package with a duplicated -- name. That's hard to recover from, so abort! if S = Standard_Standard then raise Unrecoverable_Error; -- Otherwise we continue with the declaration. Having two -- identical declarations should not cause us too much trouble! else null; end if; end if; end if; -- If we fall through, declaration is OK , or OK enough to continue -- The kind E_Void insures that premature uses of the entity will be -- detected. Any_Type insures that no cascaded errors will occur. Set_Ekind (Def_Id, E_Void); Set_Etype (Def_Id, Any_Type); Set_Is_Immediately_Visible (Def_Id); Set_Current_Entity (Def_Id); Set_Homonym (Def_Id, C); Append_Entity (Def_Id, S); Set_Public_Status (Def_Id); end Enter_Name; ------------------ -- First_Actual -- ------------------ function First_Actual (Node : Node_Id) return Node_Id is N : Node_Id; begin if No (Parameter_Associations (Node)) then return Empty; end if; N := First (Parameter_Associations (Node)); if Nkind (N) = N_Parameter_Association then return First_Named_Actual (Node); else return N; end if; end First_Actual; -------------------------- -- Get_Declaration_Node -- -------------------------- function Get_Declaration_Node (Unit_Id : Entity_Id) return Node_Id is N : Node_Id := Parent (Unit_Id); begin -- Predefined operators do not have a full function declaration. if Ekind (Unit_Id) = E_Operator then return N; end if; while Nkind (N) /= N_Abstract_Subprogram_Declaration and then Nkind (N) /= N_Formal_Subprogram_Declaration and then Nkind (N) /= N_Generic_Package_Declaration and then Nkind (N) /= N_Generic_Subprogram_Declaration and then Nkind (N) /= N_Package_Declaration and then Nkind (N) /= N_Package_Body and then Nkind (N) /= N_Package_Renaming_Declaration and then Nkind (N) /= N_Subprogram_Declaration and then Nkind (N) /= N_Subprogram_Body and then Nkind (N) /= N_Subprogram_Body_Stub and then Nkind (N) /= N_Subprogram_Renaming_Declaration and then Nkind (N) not in N_Generic_Renaming_Declaration loop N := Parent (N); pragma Assert (Present (N)); end loop; return N; end Get_Declaration_Node; ------------------------ -- Get_Actual_Subtype -- ------------------------ function Get_Actual_Subtype (N : Node_Id) return Entity_Id is Typ : constant Entity_Id := Underlying_Type (Etype (N)); Decl : Node_Id; begin -- For all types other than constrained arrays the actual subtype -- is the nominal subtype, and we return the argument unchanged. if not Is_Array_Type (Typ) or else Ekind (Typ) = E_String_Literal_Subtype or else Is_Constrained (Typ) then return Typ; -- Here for the unconstrained case, we must find actual subtype else -- If what we have is an identifier that references a subprogram -- formal, or a variable or constant object, then we get the actual -- subtype from the referenced entity if one has been built. if Nkind (N) = N_Identifier and then (Ekind (Entity (N)) in Formal_Kind or else Ekind (Entity (N)) = E_Constant or else Ekind (Entity (N)) = E_Variable) and then Present (Actual_Subtype (Entity (N))) then return Actual_Subtype (Entity (N)); -- Here, we have an unconstrained array with no actual subtype in -- sight so we build the actual subtype on the fly. else Decl := Build_Actual_Subtype (Etype (N), N); Insert_Action (N, Decl); return Defining_Identifier (Decl); end if; end if; end Get_Actual_Subtype; ---------------------- -- Get_Index_Bounds -- ---------------------- procedure Get_Index_Bounds (I : Node_Id; L, H : out Node_Id) is Kind : constant Node_Kind := Nkind (I); begin if Kind = N_Range then L := Low_Bound (I); H := High_Bound (I); elsif Kind = N_Subtype_Indication then L := Low_Bound (Range_Expression (Constraint (I))); H := High_Bound (Range_Expression (Constraint (I))); elsif Is_Entity_Name (I) and then Is_Type (Entity (I)) then L := Low_Bound (Scalar_Range (Entity (I))); H := High_Bound (Scalar_Range (Entity (I))); else -- I is an expression, indicating a range with one value. L := I; H := I; end if; -- ??? The bounds are copied around without any checks all over the -- place in the agregate code. This is completely wrong... For now, -- a partial fix (kludge?) is made to avoid to copy unnecessarily -- the expression action that can be generated for 'range. The proper -- fix would be to compute L and H in the following manner -- L --> T'first (where T is Etype (I)) -- H --> T'Last and get rid of the New_Copy from the callers... if Nkind (L) = N_Expression_Actions then L := Expression (L); end if; end Get_Index_Bounds; ------------------------ -- Get_Name_Entity_Id -- ------------------------ function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id is begin return Entity_Id (Get_Name_Table_Info (Id)); end Get_Name_Entity_Id; --------------------------- -- Get_Referenced_Object -- --------------------------- function Get_Referenced_Object (N : Node_Id) return Node_Id is R : Node_Id := N; begin while Is_Entity_Name (R) and then Present (Renamed_Object (Entity (R))) loop R := Renamed_Object (Entity (R)); end loop; return R; end Get_Referenced_Object; --------------------------- -- Has_Private_Component -- --------------------------- function Has_Private_Component (Type_Id : Entity_Id) return Boolean is Btype : Entity_Id := Base_Type (Type_Id); Component : Entity_Id; begin if Is_Class_Wide_Type (Btype) then Btype := Root_Type (Btype); end if; if Is_Private_Type (Btype) then return No (Underlying_Type (Btype)) and then not Is_Generic_Type (Btype) and then not Is_Generic_Type (Root_Type (Btype)); elsif Is_Array_Type (Btype) then return Has_Private_Component (Component_Type (Btype)); elsif Is_Record_Type (Btype) then Component := First_Component (Btype); while Present (Component) loop if Has_Private_Component (Etype (Component)) then return True; end if; Component := Next_Component (Component); end loop; return False; else return False; end if; end Has_Private_Component; -------------------------- -- Has_Tagged_Component -- -------------------------- function Has_Tagged_Component (Typ : Entity_Id) return Boolean is Comp : Entity_Id; begin if Is_Private_Type (Typ) and then Present (Underlying_Type (Typ)) then return Has_Tagged_Component (Underlying_Type (Typ)); elsif Is_Array_Type (Typ) then return Has_Tagged_Component (Component_Type (Typ)); elsif Is_Tagged_Type (Typ) then return True; elsif Is_Record_Type (Typ) then Comp := First_Component (Typ); while Present (Comp) loop if Has_Tagged_Component (Etype (Comp)) then return True; end if; Comp := Next_Component (Typ); end loop; return False; else return False; end if; end Has_Tagged_Component; ---------------------- -- Private_Ancestor -- ---------------------- function Private_Ancestor (Type_Id : Entity_Id) return Entity_Id is Btype : constant Entity_Id := Base_Type (Type_Id); Component : Entity_Id; P : Entity_Id; begin if Is_Private_Type (Btype) and then No (Underlying_Type (Btype)) and then not Is_Generic_Type (Btype) then return Btype; elsif Is_Array_Type (Btype) then return Private_Ancestor (Component_Type (Btype)); elsif Is_Record_Type (Btype) then Component := First_Entity (Btype); while Present (Component) loop P := Private_Ancestor (Etype (Component)); if Present (P) then return P; end if; Component := Next_Entity (Component); end loop; return Empty; else return Empty; end if; end Private_Ancestor; -------------------- -- In_Subrange_Of -- -------------------- function In_Subrange_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is begin if T1 = T2 or else Is_Subtype_Of (T1, T2) then return True; -- For now consider mixed types to be in range so that no range checking -- is done until all the cases are more understood. ??? elsif Ekind (Base_Type (T1)) /= Ekind (Base_Type (T2)) then return True; elsif not Is_OK_Static_Subtype (T1) or else not Is_OK_Static_Subtype (T2) then return False; elsif Is_Discrete_Type (T1) then return Expr_Value (Type_Low_Bound (T2)) <= Expr_Value (Type_Low_Bound (T1)) and then Expr_Value (Type_High_Bound (T2)) >= Expr_Value (Type_High_Bound (T1)); elsif Is_Floating_Point_Type (T1) then return Expr_Value_R (Type_Low_Bound (T2)) <= Expr_Value_R (Type_Low_Bound (T1)) and then Expr_Value_R (Type_High_Bound (T2)) >= Expr_Value_R (Type_High_Bound (T1)); else return False; end if; end In_Subrange_Of; -------------------- -- Is_Entity_Name -- -------------------- function Is_Entity_Name (N : Node_Id) return Boolean is Kind : constant Node_Kind := Nkind (N); begin -- Identifiers and expanded names are always entity names return Kind = N_Identifier or else Kind = N_Expanded_Name -- Attribute references are entity names if they refer to an entity. -- Note that we don't do this by testing for the presence of the -- Entity field in the N_Attribute_Reference node, since it may not -- have been set yet. or else (Kind = N_Attribute_Reference and then Is_Entity_Attribute_Name (Attribute_Name (N))); end Is_Entity_Name; -------------- -- Is_False -- -------------- function Is_False (U : Uint) return Boolean is begin return (U = 0); end Is_False; ----------------------------- -- Is_Library_Level_Entity -- ----------------------------- function Is_Library_Level_Entity (E : Entity_Id) return Boolean is Decl : constant Node_Id := Get_Declaration_Node (E); N : Node_Id; Unum : constant Unit_Number_Type := Get_Sloc_Unit_Number (Sloc (E)); Unit_Node : constant Node_Id := Unit (Cunit (Unum)); begin if E = Cunit_Entity (Unum) then return True; elsif Nkind (Unit_Node) = N_Package_Declaration then N := E; while N /= Unit_Node loop if Nkind (Parent (N)) = N_Package_Specification and then List_Containing (N) = Private_Declarations (Parent (N)) then return False; else N := Parent (N); end if; end loop; return True; else return False; end if; end Is_Library_Level_Entity; ------------------------- -- Is_Object_Reference -- ------------------------- function Is_Object_Reference (N : Node_Id) return Boolean is begin if Is_Entity_Name (N) then return Ekind (Entity (N)) in Object_Kind; else case Nkind (N) is when N_Indexed_Component | N_Slice => return True; when N_Selected_Component => return True; when N_Explicit_Dereference => return True; -- An unchecked type conversion is considered to be an object if -- the operand is an object (this construction arises only as a -- result of expansion activities). when N_Unchecked_Type_Conversion => return True; when others => return False; end case; end if; end Is_Object_Reference; ---------------------- -- Is_Selector_Name -- ---------------------- function Is_Selector_Name (N : Node_Id) return Boolean is begin if not Is_List_Member (N) then declare P : constant Node_Id := Parent (N); K : constant Node_Kind := Nkind (P); begin return (K = N_Expanded_Name or else K = N_Generic_Association or else K = N_Parameter_Association or else K = N_Selected_Component) and then Selector_Name (P) = N; end; else declare L : constant List_Id := List_Containing (N); P : constant Node_Id := Parent (L); begin return (Nkind (P) = N_Discriminant_Association and then Selector_Names (P) = L) or else (Nkind (P) = N_Component_Association and then Choices (P) = L); end; end if; end Is_Selector_Name; ------------- -- Is_True -- ------------- function Is_True (U : Uint) return Boolean is begin return (U /= 0); end Is_True; ----------------- -- Is_Variable -- ----------------- function Is_Variable (N : Node_Id) return Boolean is function Is_Variable_Prefix (N : Node_Id) return Boolean; -- Prefixes can involve implicit dereferences, in which case we -- must test for the case of a reference of a constant access -- type, which can never be a variable. function Is_Variable_Prefix (N : Node_Id) return Boolean is begin if Is_Access_Type (Etype (N)) then return not Is_Access_Constant (Root_Type (Etype (N))); else return Is_Variable (N); end if; end Is_Variable_Prefix; -- Start of processing for Is_Variable begin if Assignment_OK (N) then return True; elsif Is_Entity_Name (N) then declare K : Entity_Kind := Ekind (Entity (N)); begin return K = E_Variable or else K = E_Component or else K = E_Out_Parameter or else K = E_In_Out_Parameter or else K = E_Generic_In_Out_Parameter; end; else case Nkind (N) is when N_Indexed_Component | N_Slice => return Is_Variable_Prefix (Prefix (N)); when N_Selected_Component => return Is_Variable_Prefix (Prefix (N)) and then Is_Variable (Selector_Name (N)); -- For an explicit dereference, we must check whether the type -- is ACCESS CONSTANT, since if it is, then it is not a variable. when N_Explicit_Dereference => return Is_Access_Type (Etype (Prefix (N))) and then not Is_Access_Constant (Root_Type (Etype (Prefix (N)))); -- The type conversion is the case where we do not deal with the -- context dependent special case of an actual parameter. Thus -- the type conversion is only considered a variable for the -- purposes of this routine if the target type is tagged. However, -- a type conversion is considered to be a variable if it does not -- come from source (this deals for example with the conversions -- of expressions to their actual subtypes). when N_Type_Conversion => return Is_Variable (Expression (N)) and then (not Comes_From_Source (N) or else (Is_Tagged_Type (Etype (Subtype_Mark (N))) and then Is_Tagged_Type (Etype (Expression (N))))); -- GNAT allows an unchecked type conversion as a variable. This -- only affects the generation of internal expanded code, since -- calls to instantiations of Unchecked_Conversion are never -- considered variables (since they are function calls). -- This is also true for expression actions. when N_Unchecked_Type_Conversion | N_Expression_Actions => return Is_Variable (Expression (N)); when others => return False; end case; end if; end Is_Variable; ------------------------- -- New_External_Entity -- ------------------------- function New_External_Entity (Kind : Entity_Kind; Scope_Id : Entity_Id; Sloc_Value : Source_Ptr; Related_Id : Entity_Id; Suffix : Character; Suffix_Index : Nat := 0; Prefix : Character := ' ') return Entity_Id is N : constant Entity_Id := Make_Defining_Identifier (Sloc_Value, New_External_Name (Chars (Related_Id), Suffix, Suffix_Index, Prefix)); begin Set_Ekind (N, Kind); Set_Is_Internal (N, True); Append_Entity (N, Scope_Id); Set_Public_Status (N); Set_Current_Entity (N); return N; end New_External_Entity; ------------------------- -- New_Internal_Entity -- ------------------------- function New_Internal_Entity (Kind : Entity_Kind; Scope_Id : Entity_Id; Sloc_Value : Source_Ptr; Id_Char : Character) return Entity_Id is N : constant Entity_Id := Make_Defining_Identifier (Sloc_Value, New_Internal_Name (Id_Char)); begin Set_Ekind (N, Kind); Set_Is_Internal (N, True); Append_Entity (N, Scope_Id); Set_Current_Entity (N); return N; end New_Internal_Entity; ----------------- -- Next_Actual -- ----------------- function Next_Actual (Actual_Id : Node_Id) return Node_Id is N : Node_Id; begin -- If we are pointing at a positional parameter, it is a member of -- a node list (the list of parameters), and the next parameter -- is the next node on the list, unless we hit a parameter -- association, in which case we shift to using the chain whose -- head is the First_Named_Actual in the parent, and then is -- threaded using the Next_Named_Actual of the Parameter_Association. -- All this fiddling is because the original node list is in the -- textual call order, and what we need is the declaration order. if Is_List_Member (Actual_Id) then N := Next (Actual_Id); if Nkind (N) = N_Parameter_Association then return First_Named_Actual (Parent (Actual_Id)); else return N; end if; else return Next_Named_Actual (Parent (Actual_Id)); end if; end Next_Actual; ----------------------- -- Normalize_Actuals -- ----------------------- -- Chain actuals according to formals of subprogram. If there are -- no named associations, the chain is simply the list of Parameter -- Associations, since the order is the same as the declaration order. -- If there are named associations, then the First_Named_Actual field -- in the N_Procedure_Call_Statement node or N_Function_Call node -- points to the Parameter_Association node for the parameter that -- comes first in declaration order. The remaining named parameters -- are then chained in declaration order using Next_Named_Actual. -- This routine also verifies that the number of actuals is compatible -- with the number and default values of formals, but performs no type -- checking (type checking is done by the caller). -- If the matching succeeds, Success is set to True, and the caller -- proceeds with type-checking. If the match is unsuccessful, then -- Success is set to False, and the caller attempts a different -- interpretation, if there is one. -- If the flag Report is on, the call is not overloaded, and a failure -- to match can be reported here, rather than in the caller. procedure Normalize_Actuals (N : Node_Id; S : Entity_Id; Report : Boolean; Success : out Boolean) is Actuals : constant List_Id := Parameter_Associations (N); Actual : Node_Id := Empty; Formal : Entity_Id; Last : Entity_Id := Empty; First_Named : Entity_Id := Empty; Found : Boolean; Formals_To_Match : Integer := 0; Actuals_To_Match : Integer := 0; procedure Chain (A : Node_Id); -- Need some documentation on this spec ??? procedure Chain (A : Node_Id) is begin if No (Last) then -- Call node points to first actual in list. Set_First_Named_Actual (N, Explicit_Actual_Parameter (A)); else Set_Next_Named_Actual (Last, Explicit_Actual_Parameter (A)); end if; Last := A; Set_Next_Named_Actual (Last, Empty); end Chain; -- Start of processing for Normalize_Actuals begin if Is_Access_Type (S) then -- The name in the call is a function call that returns an access -- to subprogram. The designated type has the list of formals. Formal := First_Formal (Designated_Type (S)); else Formal := First_Formal (S); end if; while Present (Formal) loop Formals_To_Match := Formals_To_Match + 1; Formal := Next_Formal (Formal); end loop; -- Find if there is a named association, and verify that no positional -- associations appear after named ones. if Present (Actuals) then Actual := First (Actuals); end if; while Present (Actual) and then Nkind (Actual) /= N_Parameter_Association loop Actuals_To_Match := Actuals_To_Match + 1; Actual := Next (Actual); end loop; if No (Actual) and Actuals_To_Match = Formals_To_Match then -- Most common case: positional notation, no defaults Success := True; return; elsif Actuals_To_Match > Formals_To_Match then -- Too many actuals: will not work. if Report then Error_Msg_N ("too many arguments in call", N); end if; Success := False; return; end if; First_Named := Actual; while Present (Actual) loop if Nkind (Actual) /= N_Parameter_Association then Error_Msg_N ("positional parameters not allowed after named ones", Actual); Success := False; return; else Actuals_To_Match := Actuals_To_Match + 1; end if; Actual := Next (Actual); end loop; if Present (Actuals) then Actual := First (Actuals); end if; Formal := First_Formal (S); while Present (Formal) loop -- Match the formals in order. If the corresponding actual -- is positional, nothing to do. Else scan the list of named -- actuals to find the one with the right name. if Present (Actual) and then Nkind (Actual) /= N_Parameter_Association then Actual := Next (Actual); Actuals_To_Match := Actuals_To_Match - 1; Formals_To_Match := Formals_To_Match - 1; else -- For named parameters, search the list of actuals to find -- one that matches the next formal name. Actual := First_Named; Found := False; while Present (Actual) loop if Chars (Selector_Name (Actual)) = Chars (Formal) then Found := True; Chain (Actual); Actuals_To_Match := Actuals_To_Match - 1; Formals_To_Match := Formals_To_Match - 1; exit; end if; Actual := Next (Actual); end loop; if not Found then if Ekind (Formal) /= E_In_Parameter or else No (Default_Value (Formal)) then if Report then Error_Msg_NE ("missing argument for parameter &", N, Formal); end if; Success := False; return; else Formals_To_Match := Formals_To_Match - 1; end if; end if; end if; Formal := Next_Formal (Formal); end loop; if Formals_To_Match = 0 and then Actuals_To_Match = 0 then Success := True; return; else if Report then Error_Msg_N ("too many arguments in call", N); end if; Success := False; return; end if; end Normalize_Actuals; ------------------------- -- Object_Access_Level -- ------------------------- function Object_Access_Level (Obj : Node_Id) return Uint is E : Entity_Id; -- Returns the static accessibility level of the view denoted -- by Obj. Note that the value returned is the result of a -- call to Scope_Depth. Only scope depths associated with -- dynamic scopes can actually be returned. Since only -- relative levels matter for accessibility checking, the fact -- that the distance between successive levels of accessibility -- is not always one is immaterial (invariant: if level(E2) is -- deeper than level(E1), then Scope_Depth(E1) < Scope_Depth(E2)). begin if Is_Entity_Name (Obj) then E := Entity (Obj); if Present (Renamed_Object (E)) then return Object_Access_Level (Renamed_Object (E)); else return Scope_Depth (Enclosing_Dynamic_Scope (Scope (E))); end if; elsif Nkind (Obj) = N_Selected_Component then if Is_Access_Type (Etype (Prefix (Obj))) then return Type_Access_Level (Etype (Prefix (Obj))); else return Object_Access_Level (Prefix (Obj)); end if; elsif Nkind (Obj) = N_Indexed_Component then if Is_Access_Type (Etype (Prefix (Obj))) then return Type_Access_Level (Etype (Prefix (Obj))); else return Object_Access_Level (Prefix (Obj)); end if; elsif Nkind (Obj) = N_Explicit_Dereference then return Type_Access_Level (Etype (Prefix (Obj))); elsif Nkind (Obj) = N_Type_Conversion then return Object_Access_Level (Expression (Obj)); elsif Nkind (Obj) = N_Expression_Actions then return Object_Access_Level (Expression (Obj)); -- Otherwise return the scope level of Standard. -- (If there are cases that fall through -- to this point they will be treated as -- having global accessibility for now. ???) else return Scope_Depth (Standard_Standard); end if; end Object_Access_Level; ------------------ -- Real_Convert -- ------------------ -- We do the conversion to get the value of the real string by using -- the scanner, see Sinput for details on use of the internal source -- buffer for scanning internal strings. function Real_Convert (S : String) return Node_Id is Negative : Boolean; begin Source := Internal_Source_Ptr; Scan_Ptr := 1; for J in S'Range loop Source (Source_Ptr (J)) := S (J); end loop; Source (S'Length + 1) := EOF; if Source (Scan_Ptr) = '-' then Negative := True; Scan_Ptr := Scan_Ptr + 1; else Negative := False; end if; Scan; if Negative then Set_Realval (Token_Node, UR_Negate (Realval (Token_Node))); end if; return Token_Node; end Real_Convert; --------------- -- Same_Name -- --------------- function Same_Name (N1, N2 : Node_Id) return Boolean is K1 : constant Node_Kind := Nkind (N1); K2 : constant Node_Kind := Nkind (N2); begin if (K1 = N_Identifier or else K1 = N_Defining_Identifier) and then (K2 = N_Identifier or else K2 = N_Defining_Identifier) then return Chars (N1) = Chars (N2); elsif (K1 = N_Selected_Component or else K1 = N_Expanded_Name) and then (K2 = N_Selected_Component or else K2 = N_Expanded_Name) then return Same_Name (Selector_Name (N1), Selector_Name (N2)) and then Same_Name (Prefix (N1), Prefix (N2)); else return False; end if; end Same_Name; ------------------------ -- Set_Current_Entity -- ------------------------ -- The given entity is to be set as the currently visible definition -- of its associated name (i.e. the Node_Id associated with its name). -- All we have to do is to get the name from the identifier, and -- then set the associated Node_Id to point to the given entity. procedure Set_Current_Entity (E : Entity_Id) is begin Set_Name_Entity_Id (Chars (E), E); end Set_Current_Entity; --------------------------------- -- Set_Entity_With_Style_Check -- --------------------------------- procedure Set_Entity_With_Style_Check (N : Node_Id; Val : Entity_Id) is Val_Actual : Entity_Id; begin if Style_Check and then Nkind (N) = N_Identifier then Val_Actual := Val; -- A special situation arises for derived operations, where we want -- to do the check against the parent (since the Sloc of the derived -- operation points to the derived type declaration itself). while not Comes_From_Source (Val_Actual) and then Nkind (Val_Actual) in N_Entity and then (Ekind (Val_Actual) = E_Enumeration_Literal or else Ekind (Val_Actual) = E_Function or else Ekind (Val_Actual) = E_Generic_Function or else Ekind (Val_Actual) = E_Procedure or else Ekind (Val_Actual) = E_Generic_Procedure) and then Present (Alias (Val_Actual)) loop Val_Actual := Alias (Val_Actual); end loop; Style.Check_Identifier (N, Val_Actual); end if; Set_Entity (N, Val); end Set_Entity_With_Style_Check; ------------------------ -- Set_Name_Entity_Id -- ------------------------ procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id) is begin Set_Name_Table_Info (Id, Int (Val)); end Set_Name_Entity_Id; --------------------- -- Set_Next_Actual -- --------------------- procedure Set_Next_Actual (Ass1_Id : Node_Id; Ass2_Id : Node_Id) is begin if Nkind (Parent (Ass1_Id)) = N_Parameter_Association then Set_First_Named_Actual (Parent (Ass1_Id), Ass2_Id); end if; end Set_Next_Actual; ----------------------- -- Set_Public_Status -- ----------------------- procedure Set_Public_Status (Id : Entity_Id) is S : constant Entity_Id := Current_Scope; begin if S = Standard_Standard or else (Is_Public (S) and then (Ekind (S) = E_Package or else Is_Record_Type (S) or else Ekind (S) = E_Void)) then Set_Is_Public (Id); end if; end Set_Public_Status; -------------------- -- Static_Integer -- -------------------- function Static_Integer (N : Node_Id) return Uint is begin Analyze (N); Resolve (N, Any_Integer); if Is_Static_Expression (N) then if not Raises_Constraint_Error (N) then return Expr_Value (N); else return No_Uint; end if; elsif Etype (N) = Any_Type then return No_Uint; else Error_Msg_N ("static integer expression required here", N); return No_Uint; end if; end Static_Integer; -------------------------- -- Statically_Different -- -------------------------- function Statically_Different (E1, E2 : Node_Id) return Boolean is R1 : constant Node_Id := Get_Referenced_Object (E1); R2 : constant Node_Id := Get_Referenced_Object (E2); begin return Is_Entity_Name (R1) and then Is_Entity_Name (R2) and then Entity (R1) /= Entity (R2); end Statically_Different; ----------------------------- -- Subprogram_Access_Level -- ----------------------------- function Subprogram_Access_Level (Subp : Entity_Id) return Uint is begin if Present (Alias (Subp)) then return Subprogram_Access_Level (Alias (Subp)); else return Scope_Depth (Enclosing_Dynamic_Scope (Scope (Subp))); end if; end Subprogram_Access_Level; ----------------- -- Trace_Scope -- ----------------- procedure Trace_Scope (N : Node_Id; E : Entity_Id; Msg : String) is begin if Debug_Flag_W then for J in 0 .. Scope_Stack.Last loop Write_Str (" "); end loop; Write_Str (Msg); Write_Name (Chars (E)); Write_Str (" line "); Write_Int (Int (Get_Line_Number (Sloc (N)))); Write_Eol; end if; end Trace_Scope; ----------------------- -- Transfer_Entities -- ----------------------- procedure Transfer_Entities (From : Entity_Id; To : Entity_Id) is Ent : Entity_Id := First_Entity (From); Next_Ent : Entity_Id; begin if No (Ent) then return; end if; if (Last_Entity (To)) = Empty then Set_First_Entity (To, Ent); else Set_Next_Entity (Last_Entity (To), Ent); end if; Set_Last_Entity (To, Last_Entity (From)); while Present (Ent) loop Set_Scope (Ent, To); Set_Public_Status (Ent); Ent := Next_Entity (Ent); end loop; Set_First_Entity (From, Empty); Set_Last_Entity (From, Empty); end Transfer_Entities; ----------------------- -- Type_Access_Level -- ----------------------- function Type_Access_Level (Typ : Entity_Id) return Uint is Btyp : Entity_Id := Base_Type (Typ); begin -- If the type is an anonymous access type we treat -- it as being declared at the library level to ensure -- that names such as X.all'access don't fail static -- accessibility checks. if Ekind (Btyp) in Access_Kind then if Ekind (Btyp) = E_Anonymous_Access_Type then return Scope_Depth (Standard_Standard); end if; Btyp := Root_Type (Btyp); end if; return Scope_Depth (Enclosing_Dynamic_Scope (Scope (Btyp))); end Type_Access_Level; ------------------- -- Unimplemented -- ------------------- procedure Unimplemented (N : Node_Id; Feature : String) is Msg1 : constant String := " not implemented yet"; Msg2 : String (Feature'First .. Feature'Last + Msg1'Length); begin -- Note that we don't want to use dynamic concatenation in the compiler -- (to limit the number of runtime routines, and hence the possibility -- of bootstrap path problems is reduced). Msg2 (Feature'Range) := Feature; Msg2 (Feature'Last + 1 .. Msg2'Last) := Msg1; Error_Msg_N (Msg2, N); end Unimplemented; ---------------- -- Wrong_Type -- ---------------- procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id) is Found_Type : constant Entity_Id := Etype (Expr); begin -- Don't output message if either type is Any_Type, or if a message -- has already been posted for this node. We need to do the latter -- check explicitly (it is ordinarily done in Errout), because we -- are using ! to force the output of the error messages. if Expected_Type = Any_Type or else Found_Type = Any_Type or else Error_Posted (Expr) then return; end if; -- An interesting special check. If the expression is parenthesized -- and its type corresponds to the type of the sole component of the -- expected record type, or to the component type of the expected one -- dimensional array type, then assume we have a bad aggregate attempt. if Nkind (Expr) in N_Subexpr and then Paren_Count (Expr) /= 0 and then ((Is_Record_Type (Expected_Type) and then not Has_Discriminants (Expected_Type) and then Present (First_Component (Expected_Type)) and then Covers (Etype (First_Component (Expected_Type)), Found_Type) and then No (Next_Component (First_Component (Expected_Type)))) or else (Is_Record_Type (Expected_Type) and then Has_Discriminants (Expected_Type) and then No (First_Component (Expected_Type)) and then Covers (Etype (First_Discriminant (Expected_Type)), Found_Type) and then No (Next_Discriminant (First_Discriminant (Expected_Type)))) or else (Is_Array_Type (Expected_Type) and then Number_Dimensions (Expected_Type) = 1 and then Covers (Etype (Component_Type (Expected_Type)), Found_Type))) then Error_Msg_N ("positional aggregate cannot have one component", Expr); -- Another special check, if we are looking for a pool specific access -- type and we found an anonymous access type, then we probably have -- the case of a 'Access attribute being used in a context which needs -- a pool specific type, which is never allowed. The one extra check -- we make is that the designated types cover. elsif Is_Access_Type (Expected_Type) and then Ekind (Found_Type) = E_Anonymous_Access_Type and then Ekind (Base_Type (Expected_Type)) /= E_General_Access_Type and then Covers (Designated_Type (Expected_Type), Designated_Type (Found_Type)) then Error_Msg_N ("result must be general access type!", Expr); Error_Msg_NE ("add ALL to }!", Expr, Expected_Type); -- Normal case of one type found, some other type expected else Error_Msg_NE ("expected}!", Expr, Expected_Type); Error_Msg_NE ("found}!", Expr, Found_Type); end if; end Wrong_Type; end Sem_Util;