----------------------------------------- --------------------------------------- -- -- -- OCARINA COMPONENTS -- -- -- -- O C A R I N A . G E N E R A T O R S . A D A _ T R E E . N U T I L S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-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 GNAT.Table; with GNAT.Case_Util; with Charset; use Charset; with Locations; use Locations; with Namet; use Namet; with Output; use Output; with Utils; use Utils; with Ocarina.Generators.Ada_Values; use Ocarina.Generators.Ada_Values; with Ocarina.Generators.Utils; use Ocarina.Generators.Utils; with Ocarina.Generators.Messages; use Ocarina.Generators.Messages; with Ocarina.Nodes; package body Ocarina.Generators.Ada_Tree.Nutils is package ADN renames Ocarina.Generators.Ada_Tree.Nodes; package AAN renames Ocarina.Nodes; Var_Suffix : constant String := "_Ü"; Initialized : Boolean := False; Keyword_Suffix : constant String := "%Ada"; -- Used to mark ada keywords and avoid collision with other -- languages type Entity_Stack_Entry is record Current_Package : Node_Id; Current_Entity : Node_Id; end record; No_Depth : constant Int := -1; package Entity_Stack is new GNAT.Table ( Entity_Stack_Entry, Int, No_Depth + 1, 10, 10); use Entity_Stack; function Get_Style_State return Value_Id; -- This function returns a string literal which is the value given -- to the pragma style_checks. The 'Off' value is does not ignore -- line length. procedure New_Operator (O : Operator_Type; I : String := ""); ------------------------ -- Add_Prefix_To_Name -- ------------------------ function Add_Prefix_To_Name (Prefix : String; Name : Name_Id) return Name_Id is begin Set_Str_To_Name_Buffer (Prefix); Get_Name_String_And_Append (Name); return Name_Find; end Add_Prefix_To_Name; ------------------------ -- Add_Suffix_To_Name -- ------------------------ function Add_Suffix_To_Name (Suffix : String; Name : Name_Id) return Name_Id is begin Get_Name_String (Name); Add_Str_To_Name_Buffer (Suffix); return Name_Find; end Add_Suffix_To_Name; ----------------------------- -- Remove_Suffix_From_Name -- ----------------------------- function Remove_Suffix_From_Name (Suffix : String; Name : Name_Id) return Name_Id is Length : Natural; Temp_Str : String (1 .. Suffix'Length); begin Set_Str_To_Name_Buffer (Suffix); Length := Name_Len; Get_Name_String (Name); if Name_Len > Length then Temp_Str := Name_Buffer (Name_Len - Length + 1 .. Name_Len); if Suffix = Temp_Str then Set_Str_To_Name_Buffer (Name_Buffer (1 .. Name_Len - Length)); return Name_Find; end if; end if; return Name; end Remove_Suffix_From_Name; ---------------------- -- Add_With_Package -- ---------------------- procedure Add_With_Package (E : Node_Id; Used : Boolean := False; Warnings_Off : Boolean := False; Elaborated : Boolean := False) is function To_Library_Unit (E : Node_Id) return Node_Id; -- Return the library unit which E belongs to in order to with -- it. As a special rule, package Standard returns No_Node. --------------------- -- To_Library_Unit -- --------------------- function To_Library_Unit (E : Node_Id) return Node_Id is U : Node_Id; begin pragma Assert (Kind (E) = K_Designator); U := Corresponding_Node (Defining_Identifier (E)); -- This node is not properly built as the corresponding node -- is not set. if No (U) then if Output_Tree_Warnings then Write_Str ("WARNING: node "); Write_Name (Name (Defining_Identifier (E))); Write_Line (" has a null corresponding node"); end if; return E; end if; if ADN.Kind (U) = K_Package_Declaration then U := Package_Specification (U); end if; pragma Assert (Kind (U) = K_Package_Specification or else Kind (U) = K_Package_Instantiation); -- This is a subunit and we do not need to add a with for -- this unit but for one of its parents. If the kind of the -- parent unit name is a K_Package_Instantiation, we -- consider it as a subunit. if Kind (U) = K_Package_Instantiation or else Is_Subunit_Package (U) then U := Parent_Unit_Name (E); -- This is a special case to handle package Standard if No (U) then return No_Node; end if; return To_Library_Unit (U); end if; return E; end To_Library_Unit; P : constant Node_Id := To_Library_Unit (E); W : Node_Id; N : Name_Id; I : Node_Id; Existing_With : Node_Id; begin if No (P) then return; end if; -- Build a string "%[s,b] " that -- is the current entity name, a character 's' (resp 'b') to -- indicate whether we consider the spec (resp. body) of the -- current entity and the withed entity name. -- To avoid that a package "with"es itself if Kind (Current_Package) /= K_Subprogram_Implementation and then Kind (Current_Package) /= K_Subprogram_Specification then -- and then Corresponding_Node (Defining_Identifier (P)) -- = Package_Declaration (Current_Package) if To_Lower (Fully_Qualified_Name (P)) = To_Lower (Fully_Qualified_Name (Defining_Identifier (Package_Declaration (Current_Package)))) then return; end if; end if; -- Routine that check wether the package P has already been -- added to the withed packages of the current package. When we -- add a 'with' clause to a package specification, we check -- only if this clause has been added to the current -- spec. However, when we add a 'with' clause to a package -- body, we check that the clause has been added in both the -- spec and the body. -- IMPORTANT: Provided that all specs are generated before all -- bodies, this behaviour is automatically applied. We just -- need to encode the package name *without* precising whether -- it is a spec or a body -- Encoding the withed package and the current entity N := Fully_Qualified_Name (P); if Kind (Current_Package) /= K_Subprogram_Implementation and then Kind (Current_Package) /= K_Subprogram_Specification then I := Defining_Identifier (Package_Declaration (Current_Package)); Get_Name_String (Fully_Qualified_Name (I)); case Current_Generator_Kind is when PolyORB_HI_Ada | PolyORB_QoS_Ada => -- In the PolyORB-HI and PolyORB-QoS generators some -- packages that are generated for different nodes -- have exactly the same name. We must encode the node -- name to differenciate them. This happens only when -- we deal with a package generated for a root node if Present (Main_Subprogram (Distributed_Application_Unit (Package_Declaration (Current_Package)))) then Add_Char_To_Name_Buffer (' '); Get_Name_String_And_Append (ADN.Name (Defining_Identifier (Main_Subprogram (Distributed_Application_Unit (Package_Declaration (Current_Package)))))) ; end if; when others => raise Program_Error with "Invalid Generator"; end case; elsif Kind (Current_Package) /= K_Subprogram_Specification then I := Defining_Identifier (Specification (Current_Package)); Get_Name_String (Fully_Qualified_Name (I)); else I := Defining_Identifier (Current_Package); Get_Name_String (Fully_Qualified_Name (I)); end if; Add_Char_To_Name_Buffer (' '); Get_Name_String_And_Append (N); N := To_Lower (Name_Find); -- Get the info associated to the obtained name in the hash -- table and check whether it is already set to a value -- different from 0 (No_Node) which means that the withed -- entity is already in the withed package list. In this case -- try to enrich the exisiting with clause with eventual 'use', -- 'elaborate' or warning disabling clauses. Existing_With := Node_Id (Get_Name_Table_Info (N)); if Present (Existing_With) then Set_Used (Existing_With, ADN.Used (Existing_With) or else Used); Set_Warnings_Off (Existing_With, ADN.Warnings_Off (Existing_With) or else Warnings_Off); Set_Elaborated (Existing_With, ADN.Elaborated (Existing_With) or else Elaborated); return; end if; -- Debug message (if wanted by the user) if Output_Unit_Withing then Write_Name (N); Write_Eol; end if; -- Add entity to the withed packages list of the current -- package W := Make_Withed_Package (P, Used, Warnings_Off, Elaborated); -- Mark the 'with' clause as being added to the current package Set_Name_Table_Info (N, Int (W)); Append_Node_To_List (W, Withed_Packages (Current_Package)); end Add_With_Package; ------------------------- -- Append_Node_To_List -- ------------------------- procedure Append_Node_To_List (E : Node_Id; L : List_Id) is Last : Node_Id; begin Last := Last_Node (L); if No (Last) then Set_First_Node (L, E); else Set_Next_Node (Last, E); end if; Last := E; while Present (Last) loop Set_Last_Node (L, Last); Last := Next_Node (Last); end loop; end Append_Node_To_List; ----------------------- -- Insert_After_Node -- ----------------------- procedure Insert_After_Node (E : Node_Id; N : Node_Id) is Next : constant Node_Id := Next_Node (N); begin Set_Next_Node (N, E); Set_Next_Node (E, Next); end Insert_After_Node; ------------------------ -- Insert_Before_Node -- ------------------------ procedure Insert_Before_Node (E : Node_Id; N : Node_Id; L : List_Id) is Entity : Node_Id; begin Entity := First_Node (L); if Entity = N then Set_Next_Node (E, Entity); Set_First_Node (L, E); else while Present (Entity) loop exit when Next_Node (Entity) = N; Entity := Next_Node (Entity); end loop; Insert_After_Node (E, Entity); end if; end Insert_Before_Node; --------------------- -- Copy_Designator -- --------------------- function Copy_Designator (Designator : Node_Id; Withed : Boolean := True) return Node_Id is D : Node_Id; P : Node_Id := Parent_Unit_Name (Designator); begin D := Copy_Node (Designator); if Kind (Designator) = K_Designator or else Kind (Designator) = K_Defining_Identifier then P := Parent_Unit_Name (Designator); elsif Kind (Designator) = K_Attribute_Designator then P := Parent_Unit_Name (Prefix (Designator)); end if; if Present (P) then P := Copy_Designator (P, False); if Withed then Add_With_Package (P); end if; end if; return D; end Copy_Designator; --------------- -- Copy_Node -- --------------- function Copy_Node (N : Node_Id) return Node_Id is C : Node_Id; begin case Kind (N) is when K_Designator => C := New_Node (K_Designator); Set_Defining_Identifier (C, Defining_Identifier (N)); Set_Frontend_Node (C, Frontend_Node (N)); Set_Homogeneous_Parent_Unit_Name (C, Parent_Unit_Name (N)); when K_Defining_Identifier => C := New_Node (K_Defining_Identifier); Set_Name (C, Name (N)); Set_Homogeneous_Parent_Unit_Name (C, Parent_Unit_Name (N)); Set_Corresponding_Node (C, Corresponding_Node (N)); when K_Attribute_Designator => C := New_Node (K_Attribute_Designator); Set_Name (C, Name (N)); Set_Prefix (C, Copy_Node (Prefix (N))); when others => raise Program_Error; end case; return C; end Copy_Node; -------------------- -- Current_Entity -- -------------------- function Current_Entity return Node_Id is begin if Last = No_Depth then return No_Node; else return Table (Last).Current_Entity; end if; end Current_Entity; --------------------- -- Current_Package -- --------------------- function Current_Package return Node_Id is begin if Last = No_Depth then return No_Node; else return Table (Last).Current_Package; end if; end Current_Package; --------------------------------------- -- Defining_Identifier_To_Designator -- --------------------------------------- function Defining_Identifier_To_Designator (N : Node_Id; Copy : Boolean := False; Keep_Parent : Boolean := True; Keep_Corresponding_Node : Boolean := True) return Node_Id is P : Node_Id; Def_Id : Node_Id := N; begin pragma Assert (ADN.Kind (N) = K_Defining_Identifier); if Copy then Def_Id := Copy_Node (N); end if; if not Keep_Parent then Def_Id := Make_Defining_Identifier (ADN.Name (N)); end if; if Keep_Corresponding_Node then Set_Corresponding_Node (Def_Id, Corresponding_Node (N)); end if; P := New_Node (K_Designator); Set_Defining_Identifier (P, Def_Id); if Keep_Parent then Set_Homogeneous_Parent_Unit_Name (P, Parent_Unit_Name (N)); end if; return P; end Defining_Identifier_To_Designator; --------------------- -- Message_Comment -- --------------------- function Message_Comment (M : Name_Id) return Node_Id is C : Node_Id; begin C := Make_Ada_Comment (M); return C; end Message_Comment; --------------------- -- Message_Comment -- --------------------- function Message_Comment (M : String) return Node_Id is C : Node_Id; begin Set_Str_To_Name_Buffer (M); C := Make_Ada_Comment (Name_Find); return C; end Message_Comment; -------------------------- -- Fully_Qualified_Name -- -------------------------- function Fully_Qualified_Name (N : Node_Id) return Name_Id is Parent_Node : Node_Id := No_Node; Parent_Name : Name_Id := No_Name; begin case Kind (N) is when K_Designator => Parent_Node := Parent_Unit_Name (N); if not Present (Parent_Node) then Parent_Node := Parent_Unit_Name (Defining_Identifier (N)); end if; if Present (Parent_Node) then Parent_Name := Fully_Qualified_Name (Parent_Node); end if; Name_Len := 0; if Present (Parent_Node) then Get_Name_String (Parent_Name); Add_Char_To_Name_Buffer ('.'); end if; Get_Name_String_And_Append (Name (Defining_Identifier (N))); return Name_Find; when K_Defining_Identifier => Parent_Node := Parent_Unit_Name (N); if Present (Parent_Node) then Parent_Name := Fully_Qualified_Name (Parent_Node); end if; Name_Len := 0; if Present (Parent_Node) then Get_Name_String (Parent_Name); Add_Char_To_Name_Buffer ('.'); end if; Get_Name_String_And_Append (Name (N)); return Name_Find; when K_Attribute_Designator => Get_Name_String (Fully_Qualified_Name (Prefix (N))); Add_Char_To_Name_Buffer ('''); Get_Name_String_And_Append (Name (N)); return Name_Find; when others => raise Program_Error; end case; end Fully_Qualified_Name; --------------------- -- Get_Style_State -- --------------------- function Get_Style_State return Value_Id is -- The maximum line length allowed by GNAT is 32766 Max_Line_Length : constant Int := 32766; Result : Value_Id; begin Set_Str_To_Name_Buffer ("NM"); Add_Nat_To_Name_Buffer (Max_Line_Length); Result := New_String_Value (Name_Find); return Result; end Get_Style_State; ----------- -- Image -- ----------- function Image (T : Token_Type) return String is S : String := Token_Type'Image (T); begin To_Lower (S); return S (5 .. S'Last); end Image; ----------- -- Image -- ----------- function Image (O : Operator_Type) return String is S : String := Operator_Type'Image (O); begin To_Lower (S); for I in S'First .. S'Last loop if S (I) = '_' then S (I) := ' '; end if; end loop; return S (4 .. S'Last); end Image; ---------------- -- Initialize -- ---------------- procedure Initialize is begin -- Initialize Nutils only once if Initialized then return; end if; Initialized := True; -- Keywords. for I in Keyword_Type loop New_Token (I); end loop; -- Graphic Characters New_Token (Tok_Double_Asterisk, "**"); New_Token (Tok_Ampersand, "&"); New_Token (Tok_Minus, "-"); New_Token (Tok_Plus, "+"); New_Token (Tok_Asterisk, "*"); New_Token (Tok_Slash, "/"); New_Token (Tok_Dot, "."); New_Token (Tok_Apostrophe, "'"); New_Token (Tok_Left_Paren, "("); New_Token (Tok_Right_Paren, ")"); New_Token (Tok_Comma, ","); New_Token (Tok_Less, "<"); New_Token (Tok_Equal, "="); New_Token (Tok_Greater, ">"); New_Token (Tok_Not_Equal, "/="); New_Token (Tok_Greater_Equal, ">="); New_Token (Tok_Less_Equal, "<="); New_Token (Tok_Box, "<>"); New_Token (Tok_Colon_Equal, ":="); New_Token (Tok_Colon, ":"); New_Token (Tok_Greater_Greater, ">>"); New_Token (Tok_Less_Less, "<<"); New_Token (Tok_Semicolon, ";"); New_Token (Tok_Arrow, "=>"); New_Token (Tok_Vertical_Bar, "|"); New_Token (Tok_Dot_Dot, ".."); New_Token (Tok_Minus_Minus, "--"); for O in Op_And .. Op_Or_Else loop New_Operator (O); end loop; New_Operator (Op_And_Symbol, "&"); New_Operator (Op_Double_Asterisk, "**"); New_Operator (Op_Minus, "-"); New_Operator (Op_Plus, "+"); New_Operator (Op_Asterisk, "*"); New_Operator (Op_Slash, "/"); New_Operator (Op_Less, "<"); New_Operator (Op_Equal, "="); New_Operator (Op_Greater, ">"); New_Operator (Op_Not_Equal, "/="); New_Operator (Op_Greater_Equal, ">="); New_Operator (Op_Less_Equal, "<="); New_Operator (Op_Box, "<>"); New_Operator (Op_Colon_Equal, ":="); New_Operator (Op_Colon, "--"); New_Operator (Op_Greater_Greater, ">>"); New_Operator (Op_Less_Less, "<<"); New_Operator (Op_Semicolon, ";"); New_Operator (Op_Arrow, "=>"); New_Operator (Op_Vertical_Bar, "|"); for A in Attribute_Id loop Set_Str_To_Name_Buffer (Attribute_Id'Image (A)); Set_Str_To_Name_Buffer (Name_Buffer (3 .. Name_Len)); GNAT.Case_Util.To_Mixed (Name_Buffer (1 .. Name_Len)); AN (A) := Name_Find; end loop; for C in Component_Id loop Set_Str_To_Name_Buffer (Component_Id'Image (C)); Set_Str_To_Name_Buffer (Name_Buffer (3 .. Name_Len)); GNAT.Case_Util.To_Mixed (Name_Buffer (1 .. Name_Len)); CN (C) := Name_Find; end loop; for P in Parameter_Id loop Set_Str_To_Name_Buffer (Parameter_Id'Image (P)); Set_Str_To_Name_Buffer (Name_Buffer (3 .. Name_Len)); GNAT.Case_Util.To_Mixed (Name_Buffer (1 .. Name_Len)); PN (P) := Name_Find; end loop; for S in Subprogram_Id loop Set_Str_To_Name_Buffer (Subprogram_Id'Image (S)); Set_Str_To_Name_Buffer (Name_Buffer (3 .. Name_Len)); GNAT.Case_Util.To_Mixed (Name_Buffer (1 .. Name_Len)); SN (S) := Name_Find; end loop; for T in Type_Id loop Set_Str_To_Name_Buffer (Type_Id'Image (T)); Set_Str_To_Name_Buffer (Name_Buffer (3 .. Name_Len)); GNAT.Case_Util.To_Mixed (Name_Buffer (1 .. Name_Len)); TN (T) := Name_Find; end loop; for V in Variable_Id loop Set_Str_To_Name_Buffer (Variable_Id'Image (V)); Set_Str_To_Name_Buffer (Name_Buffer (3 .. Name_Len)); Add_Str_To_Name_Buffer (Var_Suffix); GNAT.Case_Util.To_Mixed (Name_Buffer (1 .. Name_Len)); VN (V) := Name_Find; end loop; for G in Pragma_Id loop Set_Str_To_Name_Buffer (Pragma_Id'Image (G)); Set_Str_To_Name_Buffer (Name_Buffer (8 .. Name_Len)); GNAT.Case_Util.To_Mixed (Name_Buffer (1 .. Name_Len)); GN (G) := Name_Find; end loop; for E in Error_Id loop Set_Str_To_Name_Buffer (Error_Id'Image (E)); Set_Str_To_Name_Buffer (Name_Buffer (3 .. Name_Len)); GNAT.Case_Util.To_Mixed (Name_Buffer (1 .. Name_Len)); EN (E) := Name_Find; end loop; end Initialize; procedure Reset is begin Entity_Stack.Init; Initialized := False; end Reset; -------------- -- Is_Empty -- -------------- function Is_Empty (L : List_Id) return Boolean is begin return L = No_List or else No (First_Node (L)); end Is_Empty; ------------ -- Length -- ------------ function Length (L : List_Id) return Natural is N : Node_Id; C : Natural := 0; begin if not Is_Empty (L) then N := First_Node (L); while Present (N) loop C := C + 1; N := Next_Node (N); end loop; end if; return C; end Length; --------------------------------- -- Make_Access_Type_Definition -- --------------------------------- function Make_Access_Type_Definition (Subtype_Indication : Node_Id; Is_All : Boolean := False; Is_Constant : Boolean := False; Is_Not_Null : Boolean := False) return Node_Id is N : Node_Id; begin N := New_Node (K_Access_Type_Definition); Set_Subtype_Indication (N, Subtype_Indication); Set_Is_All (N, Is_All); Set_Is_Constant (N, Is_Constant); Set_Is_Not_Null (N, Is_Not_Null); return N; end Make_Access_Type_Definition; ---------------------- -- Make_Ada_Comment -- ---------------------- function Make_Ada_Comment (N : Name_Id; Has_Header_Spaces : Boolean := True) return Node_Id is C : Node_Id; begin C := New_Node (K_Ada_Comment); Set_Defining_Identifier (C, New_Node (K_Defining_Identifier)); Set_Name (Defining_Identifier (C), N); Set_Has_Header_Spaces (C, Has_Header_Spaces); return C; end Make_Ada_Comment; -------------------------- -- Make_Array_Aggregate -- -------------------------- function Make_Array_Aggregate (Elements : List_Id) return Node_Id is pragma Assert (not Is_Empty (Elements)); N : Node_Id; begin N := New_Node (K_Array_Aggregate); Set_Elements (N, Elements); return N; end Make_Array_Aggregate; -------------------------------- -- Make_Array_Type_Definition -- -------------------------------- function Make_Array_Type_Definition (Range_Constraints : List_Id; Component_Definition : Node_Id; Aliased_Present : Boolean := False) return Node_Id is N : Node_Id; begin N := New_Node (ADN.K_Array_Type_Definition); Set_Range_Constraints (N, Range_Constraints); Set_Component_Definition (N, Component_Definition); Set_Aliased_Present (N, Aliased_Present); return N; end Make_Array_Type_Definition; ------------------------------- -- Make_Assignment_Statement -- ------------------------------- function Make_Assignment_Statement (Variable_Identifier : Node_Id; Expression : Node_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Assignment_Statement); Set_Defining_Identifier (N, Variable_Identifier); Set_Expression (N, Expression); return N; end Make_Assignment_Statement; -------------------------------------- -- Make_Attribute_Definition_Clause -- -------------------------------------- function Make_Attribute_Definition_Clause (Defining_Identifier : Node_Id; Attribute_Designator : Attribute_Id; Expression : Node_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Attribute_Definition_Clause); Set_Defining_Identifier (N, Defining_Identifier); Set_Attribute_Designator (N, AN (Attribute_Designator)); Set_Expression (N, Expression); return N; end Make_Attribute_Definition_Clause; ------------------------------- -- Make_Attribute_Designator -- ------------------------------- function Make_Attribute_Designator (Prefix : Node_Id; Attribute : Attribute_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Attribute_Designator); Set_Prefix (N, Prefix); Set_Name (N, AN (Attribute)); return N; end Make_Attribute_Designator; -------------------------- -- Make_Block_Statement -- -------------------------- function Make_Block_Statement (Statement_Identifier : Node_Id := No_Node; Declarative_Part : List_Id; Statements : List_Id; Exception_Handler : List_Id := No_List) return Node_Id is N : Node_Id; begin N := New_Node (K_Block_Statement); Set_Defining_Identifier (N, Statement_Identifier); if Present (Statement_Identifier) then Set_Corresponding_Node (Statement_Identifier, N); end if; Set_Declarative_Part (N, Declarative_Part); Set_Statements (N, Statements); if not Is_Empty (Exception_Handler) then Set_Exception_Handler (N, Exception_Handler); end if; return N; end Make_Block_Statement; --------------------- -- Make_Case_Label -- --------------------- function Make_Case_Label (Value : Value_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Case_Label); Set_Value (N, Value); return N; end Make_Case_Label; ------------------------- -- Make_Case_Statement -- ------------------------- function Make_Case_Statement (Expression : Node_Id; Case_Statement_Alternatives : List_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Case_Statement); Set_Expression (N, Expression); Set_Case_Statement_Alternatives (N, Case_Statement_Alternatives); return N; end Make_Case_Statement; ------------------------------------- -- Make_Case_Statement_Alternative -- ------------------------------------- function Make_Case_Statement_Alternative (Discret_Choice_List : List_Id; Statements : List_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Case_Statement_Alternative); Set_Discret_Choice_List (N, Discret_Choice_List); Set_Statements (N, Statements); return N; end Make_Case_Statement_Alternative; -------------------------------- -- Make_Component_Association -- -------------------------------- function Make_Component_Association (Selector_Name : Node_Id; Expression : Node_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Component_Association); Set_Defining_Identifier (N, Selector_Name); Set_Expression (N, Expression); return N; end Make_Component_Association; -------------------------------- -- Make_Component_Declaration -- -------------------------------- function Make_Component_Declaration (Defining_Identifier : Node_Id; Subtype_Indication : Node_Id; Expression : Node_Id := No_Node; Aliased_Present : Boolean := False) return Node_Id is N : Node_Id; begin N := New_Node (K_Component_Declaration); Set_Defining_Identifier (N, Defining_Identifier); Set_Subtype_Indication (N, Subtype_Indication); Set_Expression (N, Expression); Set_Aliased_Present (N, Aliased_Present); return N; end Make_Component_Declaration; ---------------------------------- -- Make_Decimal_Type_Definition -- ---------------------------------- function Make_Decimal_Type_Definition (D_Digits : Unsigned_Long_Long; D_Scale : Unsigned_Long_Long) return Node_Id is N : Node_Id; V : Value_Id; begin N := New_Node (K_Decimal_Type_Definition); V := New_Floating_Point_Value (Long_Double (1.0 / (10 ** (Integer (D_Scale))))); Set_Scale (N, Make_Literal (V)); V := New_Integer_Value (D_Digits, 1, 10); Set_Total (N, V); return N; end Make_Decimal_Type_Definition; ------------------------------ -- Make_Defining_Identifier -- ------------------------------ function Make_Defining_Identifier (Name : Name_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Defining_Identifier); Set_Name (N, To_Ada_Name (Name)); return N; end Make_Defining_Identifier; -------------------------- -- Make_Delay_Statement -- -------------------------- function Make_Delay_Statement (Expression : Node_Id; Is_Until : Boolean := False) return Node_Id is N : Node_Id; begin N := New_Node (K_Delay_Statement); Set_Expression (N, Expression); Set_Is_Until (N, Is_Until); return N; end Make_Delay_Statement; ---------------------------------- -- Make_Derived_Type_Definition -- ---------------------------------- function Make_Derived_Type_Definition (Subtype_Indication : Node_Id; Record_Extension_Part : Node_Id := No_Node; Is_Abstract_Type : Boolean := False; Is_Private_Extention : Boolean := False; Is_Subtype : Boolean := False) return Node_Id is N : Node_Id; begin N := New_Node (K_Derived_Type_Definition); Set_Is_Abstract_Type (N, Is_Abstract_Type); Set_Is_Private_Extention (N, Is_Private_Extention); Set_Subtype_Indication (N, Subtype_Indication); Set_Record_Extension_Part (N, Record_Extension_Part); Set_Is_Subtype (N, Is_Subtype); return N; end Make_Derived_Type_Definition; --------------------- -- Make_Designator -- --------------------- function Make_Designator (Designator : Name_Id; Parent : Name_Id := No_Name; Is_All : Boolean := False) return Node_Id is N : Node_Id; P : Node_Id; begin N := New_Node (K_Designator); Set_Defining_Identifier (N, Make_Defining_Identifier (Designator)); Set_Is_All (N, Is_All); if Parent /= No_Name then P := New_Node (K_Designator); Set_Defining_Identifier (P, Make_Defining_Identifier (Parent)); Set_Homogeneous_Parent_Unit_Name (N, P); end if; return N; end Make_Designator; ------------------------------ -- Make_Element_Association -- ------------------------------ function Make_Element_Association (Index : Node_Id; Expression : Node_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Element_Association); Set_Index (N, Index); Set_Expression (N, Expression); return N; end Make_Element_Association; -------------------------- -- Make_Elsif_Statement -- -------------------------- function Make_Elsif_Statement (Condition : Node_Id; Then_Statements : List_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Elsif_Statement); Set_Condition (N, Condition); Set_Then_Statements (N, Then_Statements); return N; end Make_Elsif_Statement; -------------------------------------- -- Make_Enumeration_Type_Definition -- -------------------------------------- function Make_Enumeration_Type_Definition (Enumeration_Literals : List_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Enumeration_Type_Definition); Set_Enumeration_Literals (N, Enumeration_Literals); return N; end Make_Enumeration_Type_Definition; -------------------------------------------- -- Make_Enumeration_Representation_Clause -- -------------------------------------------- function Make_Enumeration_Representation_Clause (Defining_Identifier : Node_Id; Array_Aggregate : Node_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Enumeration_Representation_Clause); Set_Defining_Identifier (N, Defining_Identifier); Set_Array_Aggregate (N, Array_Aggregate); return N; end Make_Enumeration_Representation_Clause; ------------------------------- -- Make_Explicit_Dereference -- ------------------------------- function Make_Explicit_Dereference (Prefix : Node_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Explicit_Dereference); Set_Prefix (N, Prefix); return N; end Make_Explicit_Dereference; -------------------------------- -- Make_Exception_Declaration -- -------------------------------- function Make_Exception_Declaration (Defining_Identifier : Node_Id; Renamed_Exception : Node_Id := No_Node) return Node_Id is N : Node_Id; begin N := New_Node (K_Exception_Declaration); Set_Defining_Identifier (N, Defining_Identifier); Set_Renamed_Entity (N, Renamed_Exception); Set_Corresponding_Node (Defining_Identifier, N); Set_Parent (N, Current_Package); return N; end Make_Exception_Declaration; --------------------- -- Make_Expression -- --------------------- function Make_Expression (Left_Expr : Node_Id; Operator : Operator_Type := Op_None; Right_Expr : Node_Id := No_Node) return Node_Id is N : Node_Id; begin N := New_Node (K_Expression); Set_Left_Expr (N, Left_Expr); Set_Operator (N, Operator_Type'Pos (Operator)); Set_Right_Expr (N, Right_Expr); return N; end Make_Expression; ------------------------ -- Make_For_Statement -- ------------------------ function Make_For_Statement (Defining_Identifier : Node_Id; Range_Constraint : Node_Id; Statements : List_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_For_Statement); Set_Defining_Identifier (N, Defining_Identifier); Set_Range_Constraint (N, Range_Constraint); Set_Statements (N, Statements); return N; end Make_For_Statement; ------------------------- -- Make_Loop_Statement -- ------------------------- function Make_Loop_Statement (Statements : List_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Loop_Statement); Set_Statements (N, Statements); return N; end Make_Loop_Statement; -------------------------------- -- Make_Full_Type_Declaration -- -------------------------------- function Make_Full_Type_Declaration (Defining_Identifier : Node_Id; Type_Definition : Node_Id; Discriminant_Spec : Node_Id := No_Node; Parent : Node_Id := No_Node; Is_Subtype : Boolean := False) return Node_Id is N : Node_Id; begin N := New_Node (K_Full_Type_Declaration); Set_Defining_Identifier (N, Defining_Identifier); Set_Corresponding_Node (Defining_Identifier, N); Set_Type_Definition (N, Type_Definition); Set_Discriminant_Spec (N, Discriminant_Spec); if Present (Parent) then Set_Parent (N, Parent); else Set_Parent (N, Current_Package); end if; Set_Is_Subtype (N, Is_Subtype); return N; end Make_Full_Type_Declaration; ----------------------- -- Make_If_Statement -- ----------------------- function Make_If_Statement (Condition : Node_Id; Then_Statements : List_Id; Elsif_Statements : List_Id := No_List; Else_Statements : List_Id := No_List) return Node_Id is N : Node_Id; begin N := New_Node (K_If_Statement); Set_Condition (N, Condition); Set_Then_Statements (N, Then_Statements); Set_Elsif_Statements (N, Elsif_Statements); Set_Else_Statements (N, Else_Statements); return N; end Make_If_Statement; ------------------ -- Make_List_Id -- ------------------ function Make_List_Id (N1 : Node_Id; N2 : Node_Id := No_Node; N3 : Node_Id := No_Node) return List_Id is L : List_Id; begin L := New_List (K_List_Id); Append_Node_To_List (N1, L); if Present (N2) then Append_Node_To_List (N2, L); if Present (N3) then Append_Node_To_List (N3, L); end if; end if; return L; end Make_List_Id; ------------------ -- Make_Literal -- ------------------ function Make_Literal (Value : Value_Id; Parent_Designator : Node_Id := No_Node) return Node_Id is N : Node_Id; begin N := New_Node (K_Literal); Set_Value (N, Value); Set_Parent_Designator (N, Parent_Designator); return N; end Make_Literal; ----------------------------------------- -- Make_Main_Subprogram_Implementation -- ----------------------------------------- function Make_Main_Subprogram_Implementation (Identifier : Node_Id; Build_Spec : Boolean := False; Build_Body : Boolean := True) return Node_Id is Unit : Node_Id; Spg : Node_Id; N : Node_Id; Style_State : constant Value_Id := Get_Style_State; begin Unit := New_Node (K_Main_Subprogram_Implementation); Set_Defining_Identifier (Unit, Identifier); Set_Corresponding_Node (Identifier, Unit); ---------- -- Spec -- ---------- Spg := Make_Subprogram_Specification (Defining_Identifier => Copy_Node (Identifier), Parameter_Profile => No_List, Return_Type => No_Node, Parent => No_Node, Renamed_Subprogram => No_Node); if Build_Spec then Set_Withed_Packages (Spg, New_List (K_Withed_Packages)); -- Adding a comment header Make_Comment_Header (Withed_Packages (Spg)); -- Disabling style checks N := Make_Pragma_Statement (Pragma_Style_Checks, Make_List_Id (Make_Literal (Style_State))); Append_Node_To_List (N, Withed_Packages (Spg)); -- Binding Set_Main_Subprogram_Unit (Spg, Unit); Set_Subprogram_Specification (Unit, Spg); end if; if Build_Body then ---------- -- Body -- ---------- Spg := Make_Subprogram_Implementation (Specification => Spg, Declarations => New_List (K_Declaration_List), Statements => New_List (K_Statement_List)); Set_Withed_Packages (Spg, New_List (K_Withed_Packages)); -- Adding a comment header Make_Comment_Header (Withed_Packages (Spg)); -- Disabling style checks N := Make_Pragma_Statement (Pragma_Style_Checks, Make_List_Id (Make_Literal (Style_State))); Append_Node_To_List (N, Withed_Packages (Spg)); -- Binding Set_Main_Subprogram_Unit (Spg, Unit); Set_Subprogram_Implementation (Unit, Spg); end if; return Unit; end Make_Main_Subprogram_Implementation; ------------------------- -- Make_Null_Statement -- ------------------------- function Make_Null_Statement return Node_Id is N : Node_Id; begin N := New_Node (K_Null_Statement); return N; end Make_Null_Statement; ----------------------------- -- Make_Object_Declaration -- ----------------------------- function Make_Object_Declaration (Defining_Identifier : Node_Id; Constant_Present : Boolean := False; Object_Definition : Node_Id; Expression : Node_Id := No_Node; Parent : Node_Id := No_Node; Renamed_Object : Node_Id := No_Node; Aliased_Present : Boolean := False; Discriminant_Spec : Node_Id := No_Node) return Node_Id is N : Node_Id; begin N := New_Node (K_Object_Declaration); Set_Defining_Identifier (N, Defining_Identifier); Set_Corresponding_Node (Defining_Identifier, N); Set_Constant_Present (N, Constant_Present); Set_Aliased_Present (N, Aliased_Present); Set_Object_Definition (N, Object_Definition); Set_Expression (N, Expression); Set_Renamed_Entity (N, Renamed_Object); Set_Discriminant_Spec (N, Discriminant_Spec); if No (Parent) then Set_Parent (N, Current_Package); else Set_Parent (N, Parent); end if; return N; end Make_Object_Declaration; ------------------------------- -- Make_Object_Instantiation -- ------------------------------- function Make_Object_Instantiation (Qualified_Expression : Node_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Object_Instantiation); Set_Qualified_Expression (N, Qualified_Expression); return N; end Make_Object_Instantiation; ------------------------------ -- Make_Package_Declaration -- ------------------------------ function Make_Package_Declaration (Identifier : Node_Id) return Node_Id is Pkg : Node_Id; Unit : Node_Id; N : Node_Id; Style_State : constant Value_Id := Get_Style_State; begin Unit := New_Node (K_Package_Declaration); Set_Defining_Identifier (Unit, Identifier); Set_Corresponding_Node (Identifier, Unit); -- FIXME : Set the correct parent! ---------- -- Spec -- ---------- Pkg := New_Node (K_Package_Specification); Set_Withed_Packages (Pkg, New_List (K_Withed_Packages)); -- Adding a comment header Make_Comment_Header (Withed_Packages (Pkg)); -- Disabling style checks N := Make_Pragma_Statement (Pragma_Style_Checks, Make_List_Id (Make_Literal (Style_State))); Append_Node_To_List (N, Withed_Packages (Pkg)); Set_Visible_Part (Pkg, New_List (K_Declaration_List)); Set_Private_Part (Pkg, New_List (K_Declaration_List)); Set_Package_Declaration (Pkg, Unit); Set_Package_Specification (Unit, Pkg); ---------- -- Body -- ---------- Pkg := New_Node (K_Package_Implementation); Set_Withed_Packages (Pkg, New_List (K_Withed_Packages)); -- Adding a comment header Make_Comment_Header (Withed_Packages (Pkg)); -- Disabling style checks N := Make_Pragma_Statement (Pragma_Style_Checks, Make_List_Id (Make_Literal (Style_State))); Append_Node_To_List (N, Withed_Packages (Pkg)); Set_Declarations (Pkg, New_List (K_Declaration_List)); Set_Statements (Pkg, New_List (K_Statement_List)); Set_Package_Declaration (Pkg, Unit); Set_Package_Implementation (Unit, Pkg); return Unit; end Make_Package_Declaration; -------------------------------- -- Make_Package_Instantiation -- -------------------------------- function Make_Package_Instantiation (Defining_Identifier : Node_Id; Generic_Package : Node_Id; Parameter_List : List_Id := No_List) return Node_Id is N : Node_Id; begin N := New_Node (K_Package_Instantiation); Set_Defining_Identifier (N, Defining_Identifier); Set_Corresponding_Node (Defining_Identifier, N); Set_Generic_Package (N, Generic_Package); Set_Parameter_List (N, Parameter_List); return N; end Make_Package_Instantiation; ---------------------------------- -- Make_Private_Type_Definition -- ---------------------------------- function Make_Private_Type_Definition return Node_Id is begin return New_Node (K_Private_Type_Definition); end Make_Private_Type_Definition; -------------------------------- -- Make_Parameter_Association -- -------------------------------- function Make_Parameter_Association (Selector_Name : Node_Id; Actual_Parameter : Node_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Parameter_Association); Set_Selector_Name (N, Selector_Name); Set_Actual_Parameter (N, Actual_Parameter); return N; end Make_Parameter_Association; ---------------------------------- -- Make_Parameter_Specification -- ---------------------------------- function Make_Parameter_Specification (Defining_Identifier : Node_Id; Subtype_Mark : Node_Id; Parameter_Mode : Mode_Id := Mode_In; Expression : Node_Id := No_Node) return Node_Id is P : Node_Id; begin P := New_Node (K_Parameter_Specification); Set_Defining_Identifier (P, Defining_Identifier); Set_Parameter_Type (P, Subtype_Mark); Set_Parameter_Mode (P, Parameter_Mode); Set_Expression (P, Expression); return P; end Make_Parameter_Specification; --------------------------- -- Make_Pragma_Statement -- --------------------------- function Make_Pragma_Statement (The_Pragma : Pragma_Id; Argument_List : List_Id := No_List) return Node_Id is N : Node_Id; begin N := New_Node (K_Pragma_Statement); Set_Defining_Identifier (N, Make_Defining_Identifier (GN (The_Pragma))); Set_Argument_List (N, Argument_List); return N; end Make_Pragma_Statement; -------------------------------- -- Make_Protected_Object_Spec -- -------------------------------- function Make_Protected_Object_Spec (Defining_Identifier : Node_Id; Visible_Part : List_Id; Private_Part : List_Id; Parent : Node_Id := Current_Package; Is_Type : Boolean := False) return Node_Id is N : Node_Id; begin N := New_Node (K_Protected_Object_Spec); Set_Defining_Identifier (N, Defining_Identifier); Set_Visible_Part (N, Visible_Part); Set_Private_Part (N, Private_Part); Set_Parent (N, Parent); Set_Is_Type (N, Is_Type); return N; end Make_Protected_Object_Spec; -------------------------------- -- Make_Protected_Object_Body -- -------------------------------- function Make_Protected_Object_Body (Defining_Identifier : Node_Id; Statements : List_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Protected_Object_Body); Set_Defining_Identifier (N, Defining_Identifier); Set_Statements (N, Statements); return N; end Make_Protected_Object_Body; ------------------------------- -- Make_Qualified_Expression -- ------------------------------- function Make_Qualified_Expression (Subtype_Mark : Node_Id; Aggregate : Node_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Qualified_Expression); Set_Subtype_Mark (N, Subtype_Mark); Set_Aggregate (N, Aggregate); return N; end Make_Qualified_Expression; -------------------------- -- Make_Raise_Statement -- -------------------------- function Make_Raise_Statement (Raised_Error : Node_Id := No_Node) return Node_Id is N : Node_Id; begin N := New_Node (K_Raise_Statement); Set_Raised_Error (N, Raised_Error); return N; end Make_Raise_Statement; --------------------------- -- Make_Range_Constraint -- --------------------------- function Make_Range_Constraint (First : Node_Id; Last : Node_Id; Index_Type : Node_Id := No_Node) return Node_Id is N : Node_Id; begin N := New_Node (K_Range_Constraint); Set_First (N, First); Set_Last (N, Last); Set_Index_Type (N, Index_Type); return N; end Make_Range_Constraint; --------------------------- -- Make_Record_Aggregate -- --------------------------- function Make_Record_Aggregate (L : List_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Record_Aggregate); Set_Component_Association_List (N, L); return N; end Make_Record_Aggregate; ---------------------------- -- Make_Record_Definition -- ---------------------------- function Make_Record_Definition (Component_List : List_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Record_Definition); Set_Component_List (N, Component_List); return N; end Make_Record_Definition; --------------------------------- -- Make_Record_Type_Definition -- --------------------------------- function Make_Record_Type_Definition (Record_Definition : Node_Id; Is_Abstract_Type : Boolean := False; Is_Tagged_Type : Boolean := False; Is_Limited_Type : Boolean := False) return Node_Id is N : Node_Id; begin N := New_Node (K_Record_Type_Definition); Set_Is_Abstract_Type (N, Is_Abstract_Type); Set_Is_Tagged_Type (N, Is_Tagged_Type); Set_Is_Limited_Type (N, Is_Limited_Type); Set_Record_Definition (N, Record_Definition); return N; end Make_Record_Type_Definition; --------------------------- -- Make_Return_Statement -- --------------------------- function Make_Return_Statement (Expression : Node_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Return_Statement); Set_Expression (N, Expression); return N; end Make_Return_Statement; ----------------------------- -- Make_Selected_Component -- ----------------------------- function Make_Selected_Component (Prefix : Node_Id; Selector_Name : Node_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Selected_Component); Set_Prefix (N, Prefix); Set_Selector_Name (N, Selector_Name); return N; end Make_Selected_Component; -------------------------- -- Make_Subprogram_Call -- -------------------------- function Make_Subprogram_Call (Defining_Identifier : Node_Id; Actual_Parameter_Part : List_Id := No_List) return Node_Id is N : Node_Id; begin N := New_Node (K_Subprogram_Call); Set_Defining_Identifier (N, Defining_Identifier); Set_Actual_Parameter_Part (N, Actual_Parameter_Part); return N; end Make_Subprogram_Call; ------------------------------------ -- Make_Subprogram_Implementation -- ------------------------------------ function Make_Subprogram_Implementation (Specification : Node_Id; Declarations : List_Id; Statements : List_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Subprogram_Implementation); Set_Specification (N, Specification); Set_Declarations (N, Declarations); Set_Statements (N, Statements); return N; end Make_Subprogram_Implementation; ----------------------------------- -- Make_Subprogram_Specification -- ----------------------------------- function Make_Subprogram_Specification (Defining_Identifier : Node_Id; Parameter_Profile : List_Id; Return_Type : Node_Id := No_Node; Parent : Node_Id := Current_Package; Renamed_Subprogram : Node_Id := No_Node; Instantiated_Subprogram : Node_Id := No_Node) return Node_Id is N : Node_Id; begin N := New_Node (K_Subprogram_Specification); Set_Defining_Identifier (N, Defining_Identifier); Set_Parameter_Profile (N, Parameter_Profile); Set_Return_Type (N, Return_Type); Set_Parent (N, Parent); Set_Renamed_Entity (N, Renamed_Subprogram); Set_Instantiated_Entity (N, Instantiated_Subprogram); return N; end Make_Subprogram_Specification; ------------------------- -- Make_Type_Attribute -- ------------------------- function Make_Type_Attribute (Designator : Node_Id; Attribute : Attribute_Id) return Node_Id is procedure Get_Scoped_Name_String (S : Node_Id); ---------------------------- -- Get_Scoped_Name_String -- ---------------------------- procedure Get_Scoped_Name_String (S : Node_Id) is P : Node_Id; begin P := Parent_Unit_Name (S); if Present (P) then Get_Scoped_Name_String (P); Add_Char_To_Name_Buffer ('.'); end if; Get_Name_String_And_Append (Name (Defining_Identifier (S))); end Get_Scoped_Name_String; begin Name_Len := 0; Get_Scoped_Name_String (Designator); Add_Char_To_Name_Buffer ('''); Get_Name_String_And_Append (AN (Attribute)); return Make_Defining_Identifier (Name_Find); end Make_Type_Attribute; -------------------------- -- Make_Type_Conversion -- -------------------------- function Make_Type_Conversion (Subtype_Mark : Node_Id; Expression : Node_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Type_Conversion); Set_Subtype_Mark (N, Subtype_Mark); Set_Expression (N, Expression); return N; end Make_Type_Conversion; -------------------- -- Make_Used_Type -- -------------------- function Make_Used_Type (The_Used_Type : Node_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Used_Type); Set_The_Used_Entity (N, The_Used_Type); return N; end Make_Used_Type; ------------------------- -- Make_Withed_Package -- ------------------------- function Make_Withed_Package (Defining_Identifier : Node_Id; Used : Boolean := False; Warnings_Off : Boolean := False; Elaborated : Boolean := False) return Node_Id is N : Node_Id; begin N := New_Node (K_Withed_Package); Set_Defining_Identifier (N, Defining_Identifier); Set_Used (N, Used); Set_Warnings_Off (N, Warnings_Off); Set_Elaborated (N, Elaborated); return N; end Make_Withed_Package; ----------------------- -- Make_Used_Package -- ----------------------- function Make_Used_Package (The_Used_Package : Node_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Used_Package); Set_The_Used_Entity (N, The_Used_Package); return N; end Make_Used_Package; ----------------------- -- Make_Variant_Part -- ----------------------- function Make_Variant_Part (Discriminant : Node_Id; Variant_List : List_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Variant_Part); Set_Variants (N, Variant_List); Set_Discriminant (N, Discriminant); return N; end Make_Variant_Part; ------------------------- -- Make_Comment_Header -- ------------------------- procedure Make_Comment_Header (Package_Header : List_Id) is N : Node_Id; begin -- Appending the comment header lines to the package header Set_Str_To_Name_Buffer ("------------------------------------------------------"); N := Make_Ada_Comment (Name_Find, False); Append_Node_To_List (N, Package_Header); Set_Str_To_Name_Buffer ("This file was automatically generated by Ocarina --"); N := Make_Ada_Comment (Name_Find); Append_Node_To_List (N, Package_Header); Set_Str_To_Name_Buffer ("Do NOT hand-modify this file, as your --"); N := Make_Ada_Comment (Name_Find); Append_Node_To_List (N, Package_Header); Set_Str_To_Name_Buffer ("changes will be lost when you re-run Ocarina --"); N := Make_Ada_Comment (Name_Find); Append_Node_To_List (N, Package_Header); Set_Str_To_Name_Buffer ("------------------------------------------------------"); N := Make_Ada_Comment (Name_Find, False); Append_Node_To_List (N, Package_Header); end Make_Comment_Header; ----------------- -- Next_N_Node -- ----------------- function Next_N_Node (N : Node_Id; Num : Natural) return Node_Id is Result : Node_Id := N; begin for I in 1 .. Num loop Result := Next_Node (Result); end loop; return Result; end Next_N_Node; -------------- -- New_List -- -------------- function New_List (Kind : Node_Kind; From : Node_Id := No_Node) return List_Id is N : Node_Id; begin Entries.Increment_Last; N := Entries.Last; Entries.Table (N) := Default_Node; Set_Kind (N, Kind); if Present (From) then Set_Loc (N, Loc (From)); else Set_Loc (N, No_Location); end if; return List_Id (N); end New_List; -------------- -- New_Node -- -------------- function New_Node (Kind : Node_Kind; From : Node_Id := No_Node) return Node_Id is N : Node_Id; begin Entries.Increment_Last; N := Entries.Last; Entries.Table (N) := Default_Node; Set_Kind (N, Kind); if Present (From) then Set_Loc (N, AAN.Loc (From)); else Set_Loc (N, No_Location); end if; return N; end New_Node; --------------- -- New_Token -- --------------- procedure New_Token (T : Token_Type; I : String := "") is Name : Name_Id; begin if T in Keyword_Type then -- Marking the token image as a keyword for fas searching -- purpose, we add the prefix to avoir collision with other -- languages keywords Set_Str_To_Name_Buffer (Image (T)); Name := Name_Find; Name := Add_Suffix_To_Name (Keyword_Suffix, Name); Set_Name_Table_Byte (Name, Byte (Token_Type'Pos (T) + 1)); Set_Str_To_Name_Buffer (Image (T)); else Set_Str_To_Name_Buffer (I); end if; Token_Image (T) := Name_Find; end New_Token; ------------------ -- New_Operator -- ------------------ procedure New_Operator (O : Operator_Type; I : String := "") is begin if O in Keyword_Operator then Set_Str_To_Name_Buffer (Image (O)); else Set_Str_To_Name_Buffer (I); end if; Operator_Image (Operator_Type'Pos (O)) := Name_Find; end New_Operator; ---------------- -- Pop_Entity -- ---------------- procedure Pop_Entity is begin if Last > No_Depth then Decrement_Last; end if; end Pop_Entity; ----------------- -- Push_Entity -- ----------------- procedure Push_Entity (E : Node_Id) is begin Increment_Last; Table (Last).Current_Entity := E; end Push_Entity; -------------------------- -- Qualified_Designator -- -------------------------- function Qualified_Designator (P : Node_Id) return Node_Id is N : Node_Id; begin N := New_Node (K_Designator); Set_Defining_Identifier (N, Make_Defining_Identifier (Name (P))); if Present (Parent_Unit_Name (P)) then Set_Homogeneous_Parent_Unit_Name (N, Qualified_Designator (Parent_Unit_Name (P))); else Set_Homogeneous_Parent_Unit_Name (N, No_Node); end if; return N; end Qualified_Designator; --------------------------- -- Remove_Node_From_List -- --------------------------- procedure Remove_Node_From_List (E : Node_Id; L : List_Id) is C : Node_Id; begin C := First_Node (L); if C = E then Set_First_Node (L, Next_Node (E)); if Last_Node (L) = E then Set_Last_Node (L, No_Node); end if; else while Present (C) loop if Next_Node (C) = E then Set_Next_Node (C, Next_Node (E)); if Last_Node (L) = E then Set_Last_Node (L, C); end if; exit; end if; C := Next_Node (C); end loop; end if; end Remove_Node_From_List; -------------------------------------- -- Set_Homogeneous_Parent_Unit_Name -- -------------------------------------- procedure Set_Homogeneous_Parent_Unit_Name (Child : Node_Id; Parent : Node_Id) is begin pragma Assert (ADN.Kind (Child) = K_Defining_Identifier or else ADN.Kind (Child) = K_Designator); pragma Assert (Parent = No_Node or else ADN.Kind (Parent) = K_Defining_Identifier or else ADN.Kind (Parent) = K_Designator); case ADN.Kind (Child) is when K_Defining_Identifier => if Parent = No_Node then Set_Parent_Unit_Name (Child, Parent); elsif ADN.Kind (Parent) = K_Defining_Identifier then Set_Parent_Unit_Name (Child, Parent); elsif ADN.Kind (Parent) = K_Designator then Set_Parent_Unit_Name (Child, Defining_Identifier (Parent)); else raise Program_Error; end if; when K_Designator => if Parent = No_Node then Set_Parent_Unit_Name (Child, Parent); if Present (Defining_Identifier (Child)) then Set_Parent_Unit_Name (Defining_Identifier (Child), Parent); end if; elsif ADN.Kind (Parent) = K_Defining_Identifier then Set_Parent_Unit_Name (Child, Defining_Identifier_To_Designator (Parent)); if Present (Defining_Identifier (Child)) then Set_Parent_Unit_Name (Defining_Identifier (Child), Parent); end if; elsif ADN.Kind (Parent) = K_Designator then Set_Parent_Unit_Name (Child, Parent); if Present (Defining_Identifier (Child)) then Set_Parent_Unit_Name (Defining_Identifier (Child), Defining_Identifier (Parent)); end if; else raise Program_Error; end if; when others => raise Program_Error; end case; end Set_Homogeneous_Parent_Unit_Name; ---------------------- -- Set_Helpers_Body -- ---------------------- procedure Set_Helpers_Body (N : Node_Id := No_Node) is X : Node_Id := N; begin if No (X) then X := Table (Last).Current_Entity; end if; Table (Last).Current_Package := Package_Implementation (Helpers_Package (X)); end Set_Helpers_Body; ---------------------- -- Set_Helpers_Spec -- ---------------------- procedure Set_Helpers_Spec (N : Node_Id := No_Node) is X : Node_Id := N; begin if No (X) then X := Table (Last).Current_Entity; end if; Table (Last).Current_Package := Package_Specification (Helpers_Package (X)); end Set_Helpers_Spec; ----------------------- -- Set_Servants_Body -- ----------------------- procedure Set_Servants_Body (N : Node_Id := No_Node) is X : Node_Id := N; begin if No (X) then X := Table (Last).Current_Entity; end if; Table (Last).Current_Package := Package_Implementation (Servants_Package (X)); end Set_Servants_Body; ----------------------- -- Set_Servants_Spec -- ----------------------- procedure Set_Servants_Spec (N : Node_Id := No_Node) is X : Node_Id := N; begin if No (X) then X := Table (Last).Current_Entity; end if; Table (Last).Current_Package := Package_Specification (Servants_Package (X)); end Set_Servants_Spec; -------------------- -- Set_Setup_Spec -- -------------------- procedure Set_Setup_Spec (N : Node_Id := No_Node) is X : Node_Id := N; begin if No (X) then X := Table (Last).Current_Entity; end if; Table (Last).Current_Package := Package_Specification (Setup_Package (X)); end Set_Setup_Spec; -------------------- -- Set_Setup_Body -- -------------------- procedure Set_Setup_Body (N : Node_Id := No_Node) is X : Node_Id := N; begin if No (X) then X := Table (Last).Current_Entity; end if; Table (Last).Current_Package := Package_Implementation (Setup_Package (X)); end Set_Setup_Body; ------------------------- -- Set_Namespaces_Spec -- ------------------------- procedure Set_Namespaces_Spec (N : Node_Id := No_Node) is X : Node_Id := N; begin if No (X) then X := Table (Last).Current_Entity; end if; Table (Last).Current_Package := Package_Specification (Namespaces_Package (X)); end Set_Namespaces_Spec; ------------------------- -- Set_Namespaces_Body -- ------------------------- procedure Set_Namespaces_Body (N : Node_Id := No_Node) is X : Node_Id := N; begin if No (X) then X := Table (Last).Current_Entity; end if; Table (Last).Current_Package := Package_Implementation (Namespaces_Package (X)); end Set_Namespaces_Body; ------------------------- -- Set_Parameters_Body -- ------------------------- procedure Set_Parameters_Body (N : Node_Id := No_Node) is X : Node_Id := N; begin if No (X) then X := Table (Last).Current_Entity; end if; Table (Last).Current_Package := Package_Implementation (Parameters_Package (X)); end Set_Parameters_Body; ------------------------- -- Set_Parameters_Spec -- ------------------------- procedure Set_Parameters_Spec (N : Node_Id := No_Node) is X : Node_Id := N; begin if No (X) then X := Table (Last).Current_Entity; end if; Table (Last).Current_Package := Package_Specification (Parameters_Package (X)); end Set_Parameters_Spec; --------------------------- -- Set_Obj_Adapters_Spec -- --------------------------- procedure Set_Obj_Adapters_Spec (N : Node_Id := No_Node) is X : Node_Id := N; begin if No (X) then X := Table (Last).Current_Entity; end if; Table (Last).Current_Package := Package_Specification (Obj_Adapters_Package (X)); end Set_Obj_Adapters_Spec; ------------------- -- Set_Main_Body -- ------------------- procedure Set_Main_Body (N : Node_Id := No_Node) is X : Node_Id := N; begin if No (X) then X := Table (Last).Current_Entity; end if; Table (Last).Current_Package := Subprogram_Implementation (Main_Subprogram (X)); end Set_Main_Body; ------------------- -- Set_Main_Spec -- ------------------- procedure Set_Main_Spec (N : Node_Id := No_Node) is X : Node_Id := N; begin if No (X) then X := Table (Last).Current_Entity; end if; Table (Last).Current_Package := Subprogram_Specification (Main_Subprogram (X)); end Set_Main_Spec; -------------------------- -- Set_Marshallers_Spec -- -------------------------- procedure Set_Marshallers_Spec (N : Node_Id := No_Node) is X : Node_Id := N; begin if No (X) then X := Table (Last).Current_Entity; end if; Table (Last).Current_Package := Package_Specification (Marshallers_Package (X)); end Set_Marshallers_Spec; -------------------------- -- Set_Marshallers_Body -- -------------------------- procedure Set_Marshallers_Body (N : Node_Id := No_Node) is X : Node_Id := N; begin if No (X) then X := Table (Last).Current_Entity; end if; Table (Last).Current_Package := Package_Implementation (Marshallers_Package (X)); end Set_Marshallers_Body; ----------------------- -- Set_Activity_Body -- ----------------------- procedure Set_Activity_Body (N : Node_Id := No_Node) is X : Node_Id := N; begin if No (X) then X := Table (Last).Current_Entity; end if; Table (Last).Current_Package := Package_Implementation (Activity_Package (X)); end Set_Activity_Body; ----------------------- -- Set_Activity_Spec -- ----------------------- procedure Set_Activity_Spec (N : Node_Id := No_Node) is X : Node_Id := N; begin if No (X) then X := Table (Last).Current_Entity; end if; Table (Last).Current_Package := Package_Specification (Activity_Package (X)); end Set_Activity_Spec; -------------------- -- Set_Types_Body -- -------------------- procedure Set_Types_Body (N : Node_Id := No_Node) is X : Node_Id := N; begin if No (X) then X := Table (Last).Current_Entity; end if; Table (Last).Current_Package := Package_Implementation (Types_Package (X)); end Set_Types_Body; -------------------- -- Set_Types_Spec -- -------------------- procedure Set_Types_Spec (N : Node_Id := No_Node) is X : Node_Id := N; begin if No (X) then X := Table (Last).Current_Entity; end if; Table (Last).Current_Package := Package_Specification (Types_Package (X)); end Set_Types_Spec; -------------------------- -- Set_Subprograms_Body -- -------------------------- procedure Set_Subprograms_Body (N : Node_Id := No_Node) is X : Node_Id := N; begin if No (X) then X := Table (Last).Current_Entity; end if; Table (Last).Current_Package := Package_Implementation (Subprograms_Package (X)); end Set_Subprograms_Body; -------------------------- -- Set_Subprograms_Spec -- -------------------------- procedure Set_Subprograms_Spec (N : Node_Id := No_Node) is X : Node_Id := N; begin if No (X) then X := Table (Last).Current_Entity; end if; Table (Last).Current_Package := Package_Specification (Subprograms_Package (X)); end Set_Subprograms_Spec; ------------------------- -- Set_Deployment_Spec -- ------------------------- procedure Set_Deployment_Spec (N : Node_Id := No_Node) is X : Node_Id := N; begin if No (X) then X := Table (Last).Current_Entity; end if; Table (Last).Current_Package := Package_Specification (Deployment_Package (X)); end Set_Deployment_Spec; --------------------- -- Set_Naming_Spec -- --------------------- procedure Set_Naming_Spec (N : Node_Id := No_Node) is X : Node_Id := N; begin if No (X) then X := Table (Last).Current_Entity; end if; Table (Last).Current_Package := Package_Specification (Naming_Package (X)); end Set_Naming_Spec; ----------------- -- To_Ada_Name -- ----------------- function To_Ada_Name (N : Name_Id) return Name_Id is First : Natural := 1; Name : Name_Id; Test_Name : Name_Id; V : Byte; begin Get_Name_String (Normalize_Name (N)); while First <= Name_Len and then Name_Buffer (First) = '_' loop First := First + 1; end loop; for I in First .. Name_Len loop if Name_Buffer (I) = '_' and then I < Name_Len and then Name_Buffer (I + 1) = '_' then Name_Buffer (I + 1) := 'U'; end if; end loop; if Name_Buffer (Name_Len) = '_' then Add_Char_To_Name_Buffer ('U'); end if; Name := Name_Find; -- If the identifier collides with an Ada reserved word insert -- "AADL_" string before the identifier. Test_Name := Add_Suffix_To_Name (Keyword_Suffix, Name); V := Get_Name_Table_Byte (Test_Name); if V > 0 then Set_Str_To_Name_Buffer ("AADL_"); Get_Name_String_And_Append (Name); Name := Name_Find; end if; return Name; end To_Ada_Name; ------------------------ -- Extract_Designator -- ------------------------ function Extract_Designator (N : Node_Id; Add_With_Clause : Boolean := True) return Node_Id is P : Node_Id; D : Node_Id := No_Node; X : Node_Id := N; FE : Node_Id; begin case Kind (N) is when K_Full_Type_Declaration | K_Subprogram_Specification => P := Parent (X); FE := Frontend_Node (X); when K_Object_Declaration | K_Exception_Declaration => P := Parent (X); FE := Frontend_Node (X); when K_Package_Specification => X := Package_Declaration (N); P := Parent (X); FE := Frontend_Node (Distributed_Application_Unit (X)); when K_Package_Declaration => P := Parent (N); FE := Frontend_Node (Distributed_Application_Unit (X)); when K_Designator => return Copy_Designator (N); when K_Protected_Object_Spec => P := Parent (N); when K_Package_Instantiation => P := Parent (X); when others => raise Program_Error; end case; D := Defining_Identifier_To_Designator (N => Defining_Identifier (X), Keep_Parent => False); Set_Frontend_Node (D, FE); if No (P) then return D; end if; -- This handles the particular case of package instanciations if Kind (N) = K_Full_Type_Declaration and then Present (Parent_Unit_Name (Defining_Identifier (N))) and then Kind (Corresponding_Node (Parent_Unit_Name (Defining_Identifier (N)))) = K_Package_Instantiation then Set_Homogeneous_Parent_Unit_Name (D, Parent_Unit_Name (Defining_Identifier (N))); P := Extract_Designator (P); else Set_Homogeneous_Parent_Unit_Name (D, Extract_Designator (P, False)); P := Parent_Unit_Name (D); end if; -- Adding the with clause in the case the parent is a package if Add_With_Clause and then Present (P) and then Kind (Parent (N)) /= K_Protected_Object_Spec then Add_With_Package (P); end if; return D; end Extract_Designator; --------------- -- Unit_Name -- --------------- function Unit_Name (N : Name_Id) return Name_Id is Pos : Natural := 0; begin Get_Name_String (N); for J in reverse 1 .. Name_Len loop if Name_Buffer (J) = '.' then Pos := J; exit; end if; end loop; if Pos = 0 or else Pos = 1 then Display_Error ("""" & Get_Name_String (N) & """ is not an Ada fully qualified entity name", Fatal => True); end if; Set_Str_To_Name_Buffer (Name_Buffer (1 .. Pos - 1)); return Name_Find; end Unit_Name; ---------------- -- Local_Name -- ---------------- function Local_Name (N : Name_Id) return Name_Id is Pos : Natural := 0; begin Get_Name_String (N); for J in reverse 1 .. Name_Len loop if Name_Buffer (J) = '.' then Pos := J; exit; end if; end loop; if Pos = Name_Len or else Pos = Name_Len - 1 then Display_Error ("""" & Get_Name_String (N) & """ is not an Ada fully qualified entity name", Fatal => True); end if; Set_Str_To_Name_Buffer (Name_Buffer (Pos + 1 .. Name_Len)); return Name_Find; end Local_Name; ---------------------------- -- Conventional_Base_Name -- ---------------------------- function Conventional_Base_Name (N : Name_Id) return Name_Id is begin Get_Name_String (N); -- Lower and replace all '.' by '-' for Index in 1 .. Name_Len loop if Name_Buffer (Index) = '.' then Name_Buffer (Index) := '-'; else Name_Buffer (Index) := To_Lower (Name_Buffer (Index)); end if; end loop; return Name_Find; end Conventional_Base_Name; end Ocarina.Generators.Ada_Tree.Nutils;