---------------------------------------------------- ---------------------------- -- -- -- OCARINA COMPONENTS -- -- -- -- O C A R I N A . A N A L Y Z E R . N A M I N G _ R U L E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2007, GET-Telecom Paris. -- -- -- -- Ocarina is free software; you can redistribute it and/or modify -- -- it under terms of the GNU General Public License as published by the -- -- Free Software Foundation; either version 2, or (at your option) any -- -- later version. Ocarina is distributed in the hope that it will be -- -- useful, but WITHOUT 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 Ocarina; see file COPYING. -- -- If not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- -- Floor, Boston, MA 02111-1301, USA. -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- -- Ocarina is maintained by the Ocarina team -- -- (ocarina-users@listes.enst.fr) -- -- -- ------------------------------------------------------------------------------ with Errors; with Ocarina.Nodes; with Ocarina.Nutils; with Ocarina.Analyzer.Messages; with Ocarina.Entities; package body Ocarina.Analyzer.Naming_Rules is use Errors; use Ocarina.Nodes; use Ocarina.Nutils; use Ocarina.Analyzer.Messages; use Ocarina.Entities; use Scope_Stack; type Entity_Conflict_Status is (Replacement, Conflict, No_Conflict); -- used for Resolve_Conflict function Merge_Packages (Pack1 : Node_Id; Pack2 : Node_Id) return Node_Id; -- Integrate Pack2 into Pack1 and return Pack1 function Have_Common_Statements (Node_1 : Node_Id; Node_2 : Node_Id) return Boolean; -- Return True if the two property association declarations have -- statements (in modes or in bindings) in common, else -- False function Have_Common_Applies_To (Applies_To_1 : List_Id; Applies_To_2 : List_Id) return Boolean; -- Return True if the two property association declarations apply -- to the same thing. This means that the two lists contain the -- same identifiers. function Resolve_Conflict (Entity : Node_Id; Former_Entity : Node_Id) return Entity_Conflict_Status; -- Resolve name conflicts if Entity and Former_Entity have the -- same name, Entity being added in a scope that already contains -- Former_Entity. procedure Remove_From_Scope (Identifier : Node_Id; Scope : Node_Id); -- Remove from Scope the first entity in Homonym chain procedure Display_Conflict (N : Node_Id; C : Node_Id); -- Output that N conflicts with C function Is_Inherited (E : Node_Id) return Boolean; pragma Unreferenced (Is_Inherited); -- To introduce an inherited entity in the scope of an -- interface, we introduce an identifier corresponding to this -- entity. However, the identifier of this entity is different -- from this new identifier. In particular, the original -- identifier refers to the original scope in which the entity -- was defined. To decide whether an entity is inherited or -- not, we check that the scope of the original identifier is -- not null (otherwise, it is a newly-added entity) and that -- this scope is different from the current scope. ---------------------- -- Display_Conflict -- ---------------------- procedure Display_Conflict (N : Node_Id; C : Node_Id) is begin Error_Loc (1) := Loc (N); Error_Loc (2) := Loc (C); Error_Name (1) := Display_Name (N); if Kind (C) = K_Scoped_Name then DE ("#conflicts with scoped name!"); else DE ("#conflicts with declaration!"); end if; end Display_Conflict; ------------------ -- Is_Inherited -- ------------------ function Is_Inherited (E : Node_Id) return Boolean is S : constant Node_Id := Scope_Entity (Identifier (E)); begin return Present (S) and then S /= Current_Scope; end Is_Inherited; ------------------- -- Current_Scope -- ------------------- function Current_Scope return Node_Id is begin if Last = No_Scope_Depth then return No_Node; else return Table (Last).Node; end if; end Current_Scope; ------------------------- -- Enter_Name_In_Scope -- ------------------------- function Enter_Name_In_Scope (Identifier : Node_Id) return Boolean is begin return Present (Enter_Name_In_Scope (Identifier)); end Enter_Name_In_Scope; ------------------------- -- Enter_Name_In_Scope -- ------------------------- function Enter_Name_In_Scope (Identifier : Node_Id) return Node_Id is pragma Assert (Kind (Identifier) = K_Identifier); Entity : constant Node_Id := Corresponding_Entity (Identifier); Local_Scope : constant Node_Id := Current_Scope; Former_Entity : constant Node_Id := Node_In_Scope (Identifier, Local_Scope); Kind_Of_Former_Entity : Node_Kind; Kind_Of_Entity : constant Node_Kind := Kind (Entity); Entity_Identifier : Node_Id; begin if Present (Former_Entity) then Kind_Of_Former_Entity := Kind (Former_Entity); Entity_Identifier := Ocarina.Nodes.Identifier (Former_Entity); -- This same entity is already in the scope -- The Node_In_Scope functions returns only on node. We -- must check all the homonyms of this node while Present (Entity_Identifier) loop if Corresponding_Entity (Entity_Identifier) = Entity then return Entity; end if; Entity_Identifier := Homonym (Entity_Identifier); end loop; -- This entity is a package. Reload the previous scope. if Kind_Of_Former_Entity = K_Package_Specification and then Kind_Of_Entity = K_Package_Specification then declare Global_Package : constant Node_Id := Merge_Packages (Former_Entity, Entity); begin -- We keep the previous scope entry. There is -- nothing to do. if No (Global_Package) then Display_Conflict (Identifier, Former_Entity); end if; return Global_Package; end; else declare Conflict_Status : constant Entity_Conflict_Status := Resolve_Conflict (Entity => Entity, Former_Entity => Former_Entity); begin if Conflict_Status = Replacement then Remove_From_Scope (Ocarina.Nodes.Identifier (Former_Entity), Current_Scope); elsif Conflict_Status = Conflict then Display_Conflict (Identifier, Former_Entity); return No_Node; end if; end; end if; elsif Is_A_Refinement (Entity) then DAE (Node1 => Identifier, Message1 => "does not refines anything"); return No_Node; end if; Set_Scope_Entity (Identifier, Local_Scope); Set_Visible (Identifier, True); Set_Next_Node (Identifier, Scoped_Identifiers (Local_Scope)); Set_Scoped_Identifiers (Local_Scope, Identifier); return Entity; end Enter_Name_In_Scope; ---------------- -- Initialize -- ---------------- procedure Initialize is begin Init; Increment_Last; end Initialize; ------------------------------ -- Node_Explicitly_In_Scope -- ------------------------------ function Node_Explicitly_In_Scope (Identifier : Node_Id; Scope : Node_Id) return Node_Id is pragma Assert (Kind (Identifier) = K_Identifier); begin return Node_In_Scope (Name (Identifier), Scope); end Node_Explicitly_In_Scope; ------------------------------ -- Node_Explicitly_In_Scope -- ------------------------------ function Node_Explicitly_In_Scope (Name_Of_Identifier : Name_Id; Scope : Node_Id) return Node_Id is pragma Assert (Name_Of_Identifier /= No_Name); pragma Assert (No (Scope) or else Kind (Scope) = K_Scope_Definition); Scoped_Identifier : Node_Id; begin if Present (Scope) then Scoped_Identifier := Scoped_Identifiers (Scope); else return No_Node; end if; while Present (Scoped_Identifier) loop if Name (Scoped_Identifier) = Name_Of_Identifier then return Corresponding_Entity (Scoped_Identifier); end if; Scoped_Identifier := Next_Node (Scoped_Identifier); end loop; return No_Node; end Node_Explicitly_In_Scope; ------------------- -- Node_In_Scope -- ------------------- function Node_In_Scope (Identifier : Node_Id; Scope : Node_Id) return Node_Id is pragma Assert (Kind (Identifier) = K_Identifier); begin return Node_In_Scope (Name (Identifier), Scope); end Node_In_Scope; ------------------- -- Node_In_Scope -- ------------------- function Node_In_Scope (Name_Of_Identifier : Name_Id; Scope : Node_Id) return Node_Id is pragma Assert (Name_Of_Identifier /= No_Name); pragma Assert (No (Scope) or else (Kind (Scope) = K_Scope_Definition and then Present (Corresponding_Entity (Scope)))); First_Node : Node_Id := No_Node; Homonym_Node : Node_Id := No_Node; Previous_Homonym_Node : Node_Id := No_Node; procedure Recursive_Node_In_Scope (The_Scope : Node_Id); -- Fetch the Name_Of_Identifier in the given scope AND the -- scope of its paren (if any) AND the scope of its -- corresponding cooomponent type (if any). ----------------------------- -- Recursive_Node_In_Scope -- ----------------------------- procedure Recursive_Node_In_Scope (The_Scope : Node_Id) is Scoped_Identifier : Node_Id; Entity : Node_Id; begin if No (The_Scope) or else No (Corresponding_Entity (The_Scope)) then return; end if; -- Start with the given scope Scoped_Identifier := Scoped_Identifiers (The_Scope); while Present (Scoped_Identifier) loop if Name (Scoped_Identifier) = Name_Of_Identifier then if No (First_Node) then First_Node := Corresponding_Entity (Scoped_Identifier); else Homonym_Node := Ocarina.Nodes.Identifier (First_Node); Previous_Homonym_Node := No_Node; while Present (Homonym_Node) loop Previous_Homonym_Node := Homonym_Node; Homonym_Node := Homonym (Homonym_Node); end loop; Set_Homonym (Previous_Homonym_Node, Scoped_Identifier); end if; Set_Homonym (Scoped_Identifier, No_Node); end if; Scoped_Identifier := Next_Node (Scoped_Identifier); end loop; Entity := Corresponding_Entity (The_Scope); -- Fetch the scope of corresponding type and then the parent case Kind (Entity) is when K_Component_Implementation => -- We only fetch the parent components for the -- entities. Properties can override other ones, so -- there is no point in seeking further if The_Scope = Entity_Scope (Entity) then -- Fetch recursively the scope of the corresponding -- type. if Present (Component_Type_Identifier (Entity)) then Recursive_Node_In_Scope (Entity_Scope (Corresponding_Entity (Component_Type_Identifier (Entity)))); end if; -- Fetch recursively the scope of the parent if Present (Parent (Entity)) then Recursive_Node_In_Scope (Entity_Scope (Get_Referenced_Entity (Parent (Entity)))); end if; end if; when K_Component_Type | K_Port_Group_Type => if Scope = Entity_Scope (Entity) and then Parent (Entity) /= No_Node then Recursive_Node_In_Scope (Entity_Scope (Get_Referenced_Entity (Parent (Entity)))); end if; when others => null; end case; end Recursive_Node_In_Scope; begin Recursive_Node_In_Scope (Scope); return First_Node; end Node_In_Scope; --------------- -- Pop_Scope -- --------------- procedure Pop_Scope is begin -- Pop scope Decrement_Last; end Pop_Scope; ---------------- -- Push_Scope -- ---------------- procedure Push_Scope (Scope : Node_Id) is pragma Assert (Kind (Scope) = K_Scope_Definition); begin Increment_Last; Table (Last).Node := Scope; end Push_Scope; ----------------------- -- Remove_From_Scope -- ----------------------- procedure Remove_From_Scope (Identifier : Node_Id; Scope : Node_Id) is pragma Assert (Kind (Identifier) = K_Identifier); pragma Assert (Kind (Scope) = K_Scope_Definition); Scope_Identifier : Node_Id := Scoped_Identifiers (Scope); Parent : Node_Id := No_Node; Entity : constant Node_Id := Corresponding_Entity (Identifier); begin while Present (Scope_Identifier) loop exit when Entity = Corresponding_Entity (Scope_Identifier); Parent := Scope_Identifier; Scope_Identifier := Next_Node (Scope_Identifier); end loop; if Present (Scope_Identifier) then if Present (Parent) then Set_Next_Node (Parent, Next_Node (Scope_Identifier)); else Set_Scoped_Identifiers (Scope, Next_Node (Scope_Identifier)); end if; else return; end if; Set_Next_Node (Identifier, No_Node); Set_Visible (Identifier, False); end Remove_From_Scope; -------------------- -- Merge_Packages -- -------------------- function Merge_Packages (Pack1 : Node_Id; Pack2 : Node_Id) return Node_Id is pragma Assert (Kind (Pack1) = K_Package_Specification); pragma Assert (Kind (Pack2) = K_Package_Specification); pragma Assert (Name (Identifier (Pack1)) = Name (Identifier (Pack2))); Declaration_List : List_Id; Property_List : List_Id; begin if Has_Public_Part (Pack1) = Has_Public_Part (Pack2) or else Has_Private_Part (Pack1) = Has_Private_Part (Pack2) then -- We can only merge a public part and a private part. Both -- packages cannot have a public or a private part. return No_Node; end if; Set_Has_Public_Part (Pack1, True); Set_Has_Private_Part (Pack1, True); Declaration_List := Declarations (Pack1); Property_List := Properties (Pack1); Append_List_To_List (Declarations (Pack2), Declaration_List); Append_List_To_List (Properties (Pack2), Property_List); Set_Declarations (Pack1, Declaration_List); Set_Properties (Pack1, Property_List); return Pack1; end Merge_Packages; -------------------------- -- Remove_From_Homonyms -- -------------------------- function Remove_From_Homonyms (First_Homonym : Node_Id; Homonym_To_Remove : Node_Id) return Node_Id is pragma Assert (Kind (First_Homonym) = K_Identifier); pragma Assert (Kind (Homonym_To_Remove) = K_Identifier); List_Homonym : Node_Id := First_Homonym; Previous_List_Homonym : Node_Id := First_Homonym; begin while Present (List_Homonym) and then List_Homonym /= Homonym_To_Remove loop Previous_List_Homonym := List_Homonym; List_Homonym := Homonym (List_Homonym); end loop; if No (List_Homonym) then return First_Homonym; elsif List_Homonym = First_Homonym then Set_Homonym (First_Homonym, No_Node); return Homonym (List_Homonym); else Set_Homonym (Previous_List_Homonym, Homonym (List_Homonym)); Set_Homonym (List_Homonym, No_Node); return Homonym (Previous_List_Homonym); end if; end Remove_From_Homonyms; ---------------------------- -- Have_Common_Statements -- ---------------------------- function Have_Common_Statements (Node_1 : Node_Id; Node_2 : Node_Id) return Boolean is List_1 : List_Id; List_2 : List_Id; List_Item_1 : Node_Id; List_Item_2 : Node_Id; Name_Id_1 : Name_Id; Name_Id_2 : Name_Id; begin -- If a property association is not associated with a statement -- (in modes, applies to, in bindings), then we consider that -- this association is a default one. if No (Node_1) and then No (Node_2) then return True; elsif Safe_XOR (No (Node_1), No (Node_2)) then return False; -- FIXME is this right? end if; case Kind (Node_1) is when K_In_Modes => List_1 := Modes (Node_1); when K_In_Binding => List_1 := Binding (Node_1); when others => raise Program_Error; end case; case Kind (Node_2) is when K_In_Modes => List_2 := Modes (Node_2); when K_In_Binding => List_2 := Binding (Node_2); when others => raise Program_Error; end case; if Is_Empty (List_1) and then Is_Empty (List_2) then return True; elsif Safe_XOR (Is_Empty (List_1), Is_Empty (List_2)) then return False; -- FIXME is this right? else List_Item_1 := First_Node (List_1); List_Item_2 := First_Node (List_2); while Present (List_Item_1) loop List_Item_2 := First_Node (List_2); while Present (List_Item_2) loop if Kind (List_Item_1) = Kind (List_Item_2) then if Kind (List_Item_1) = K_Entity_Reference then Name_Id_1 := Get_Name_Of_Entity_Reference (List_Item_1); Name_Id_2 := Get_Name_Of_Entity_Reference (List_Item_2); if Name_Id_1 = Name_Id_2 then return True; -- XXX We only consider identifers or modes, -- not classifier references, etc. Hence this -- test is incomplete. The tree structure -- should be modified to avoid so that we can -- use the same accessor for all the node -- kinds end if; end if; end if; List_Item_2 := Next_Node (List_Item_2); end loop; List_Item_1 := Next_Node (List_Item_1); end loop; return False; end if; end Have_Common_Statements; ---------------------------- -- Have_Common_Applies_To -- ---------------------------- function Have_Common_Applies_To (Applies_To_1 : List_Id; Applies_To_2 : List_Id) return Boolean is List_Item_1 : Node_Id; List_Item_2 : Node_Id; begin if Is_Empty (Applies_To_1) and then Is_Empty (Applies_To_2) then return True; elsif Safe_XOR (Is_Empty (Applies_To_1), Is_Empty (Applies_To_2)) then return False; else List_Item_1 := First_Node (Applies_To_1); List_Item_2 := First_Node (Applies_To_2); while Present (List_Item_1) loop pragma Assert (Kind (List_Item_1) = K_Identifier); pragma Assert (No (List_Item_2) or else Kind (List_Item_2) = K_Identifier); if No (List_Item_2) then return False; elsif Name (List_Item_1) /= Name (List_Item_2) then return False; end if; List_Item_1 := Next_Node (List_Item_1); List_Item_2 := Next_Node (List_Item_2); end loop; if Present (List_Item_2) then return False; end if; return True; end if; end Have_Common_Applies_To; ---------------------- -- Resolve_Conflict -- ---------------------- function Resolve_Conflict (Entity : Node_Id; Former_Entity : Node_Id) return Entity_Conflict_Status is pragma Assert (Present (Former_Entity)); Category_Of_Entity : constant Entity_Category := Get_Entity_Category (Entity); Category_Of_Former_Entity : Entity_Category; Homonym_Of_Former_Entity : Node_Id := Identifier (Former_Entity); Current_Former_Entity : Node_Id; Result : Entity_Conflict_Status := No_Conflict; begin case Kind (Entity) is when K_Property_Association => -- Property associations are different from the other -- declarations: they have additional statements (applies -- to, in binding). In addition, property associations -- declared without 'in mode' statement are considered as -- default properties and thus do not conflict with -- property associations associated with an 'in modes' -- statement. In addition, private and public property -- associations are associated with the declarations of -- their section (public or private) and thus do not -- conflict. while Present (Homonym_Of_Former_Entity) loop Current_Former_Entity := Corresponding_Entity (Homonym_Of_Former_Entity); if Kind (Current_Former_Entity) = K_Property_Association and then Is_Private (Entity) = Is_Private (Current_Former_Entity) and then Have_Common_Statements (In_Modes (Entity), In_Modes (Current_Former_Entity)) and then Have_Common_Applies_To (Applies_To_Prop (Entity), Applies_To_Prop (Current_Former_Entity)) and then Have_Common_Statements (In_Binding (Entity), In_Binding (Current_Former_Entity)) then Result := Conflict; exit; end if; Homonym_Of_Former_Entity := Homonym (Homonym_Of_Former_Entity); end loop; when others => while Present (Homonym_Of_Former_Entity) loop Current_Former_Entity := Corresponding_Entity (Homonym_Of_Former_Entity); Category_Of_Former_Entity := Get_Entity_Category (Corresponding_Entity (Homonym_Of_Former_Entity)); if Category_Of_Entity = Category_Of_Former_Entity and then Have_Modes_In_Common (Entity, Current_Former_Entity) then if Is_A_Refinement (Entity) and then Scope_Entity (Identifier (Current_Former_Entity)) /= Current_Scope then Result := Replacement; -- There is replacement only if the new entity -- is a refinement of the same category as the -- former entity, and the former entity is not -- part of the current scope (we assume that the -- new entity is to be inserted in the current -- scope). else Result := Conflict; exit; end if; end if; Homonym_Of_Former_Entity := Homonym (Homonym_Of_Former_Entity); end loop; end case; return Result; end Resolve_Conflict; end Ocarina.Analyzer.Naming_Rules;