----------------------------------------- --------------------------------------- -- -- -- 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;