--------------------------------------------- ----------------------------------- -- -- -- 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 -- -- -- -- S p e c -- -- -- -- 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 Ocarina.Generators.Ada_Tree.Nodes; use Ocarina.Generators.Ada_Tree.Nodes; package Ocarina.Generators.Ada_Tree.Nutils is Int0_Val : value_id; Int1_Val : value_id; Output_Tree_Warnings : Boolean := False; Output_Unit_Withing : Boolean := False; -- Control flags type token_type is ( -- Token name Token type -- Keywords tok_mod, -- MOD **** First Keyword tok_rem, -- REM tok_new, -- NEW tok_abs, -- ABS tok_others, -- OTHERS tok_null, -- NULL tok_delta, -- DELTA tok_digits, -- DIGITS tok_range, -- RANGE tok_and, -- AND tok_or, -- OR tok_xor, -- XOR tok_in, -- IN tok_not, -- NOT tok_abstract, -- ABSTRACT tok_access, -- ACCESS tok_aliased, -- ALIASED tok_all, -- ALL tok_array, -- ARRAY tok_at, -- AT tok_body, -- BODY tok_constant, -- CONSTANT tok_do, -- DO tok_is, -- IS tok_limited, -- LIMITED tok_of, -- OF tok_out, -- OUT tok_record, -- RECORD tok_renames, -- RENAMES tok_reverse, -- REVERSE tok_tagged, -- TAGGED tok_then, -- THEN tok_abort, -- ABORT tok_accept, -- ACCEPT tok_case, -- CASE tok_delay, -- DELAY tok_else, -- ELSE tok_elsif, -- ELSIF tok_end, -- END tok_exception, -- EXCEPTION tok_exit, -- EXIT tok_goto, -- GOTO tok_if, -- IF tok_pragma, -- PRAGMA tok_raise, -- RAISE tok_requeue, -- REQUEUE tok_return, -- RETURN tok_select, -- SELECT tok_terminate, -- TERMINATE tok_until, -- UNTIL tok_when, -- WHEN tok_begin, -- BEGIN tok_declare, -- DECLARE tok_for, -- FOR tok_loop, -- LOOP tok_while, -- WHILE tok_entry, -- ENTRY tok_protected, -- PROTECTED tok_task, -- TASK tok_type, -- TYPE tok_subtype, -- SUBTYPE tok_use, -- USE tok_function, -- FUNCTION tok_generic, -- GENERIC tok_package, -- PACKAGE tok_procedure, -- PROCEDURE tok_private, -- PRIVATE tok_with, -- WITH tok_separate, -- SEPARATE **** Last Keyword -- Graphic Characters tok_double_asterisk, -- ** tok_ampersand, -- & tok_minus, -- - tok_plus, -- + tok_asterisk, -- * tok_slash, -- / tok_dot, -- . tok_apostrophe, -- ' tok_left_paren, -- ( tok_right_paren, -- ) tok_comma, -- , tok_less, -- < tok_equal, -- = tok_greater, -- > tok_not_equal, -- /= tok_greater_equal, -- >= tok_less_equal, -- <= tok_box, -- <> tok_colon_equal, -- := tok_colon, -- : tok_greater_greater, -- >> tok_less_less, -- << tok_semicolon, -- ; tok_arrow, -- => tok_vertical_bar, -- | tok_dot_dot, -- .. tok_minus_minus); -- -- Token_Image : array (token_type) of name_id; subtype keyword_type is token_type range tok_mod .. tok_separate; type operator_type is (op_not, -- not op_and, -- and op_in, -- in op_and_then, -- and then op_or, -- or op_or_else, -- or else op_and_symbol, -- & op_double_asterisk, -- ** op_minus, -- - op_plus, -- + op_asterisk, -- * op_slash, -- / op_less, -- < op_equal, -- = op_greater, -- > op_not_equal, -- /= op_greater_equal, -- >= op_less_equal, -- <= op_box, -- <> op_colon_equal, -- := op_colon, -- : op_greater_greater, -- >> op_less_less, -- << op_semicolon, -- ; op_arrow, -- => op_vertical_bar, -- | op_none); -- No operation Operator_Image : array (operator_type'pos (op_and) .. operator_type'pos (op_vertical_bar)) of name_id; subtype keyword_operator is operator_type range operator_type'first .. op_or_else; type parameter_id is (p_arg_list, p_argument, p_c, p_conflicts, p_current_entity, p_data, p_depends, p_destinations, p_dispatcher, p_e_req, p_entity, p_entity_table, p_error, p_from, p_global_data_queue_size, p_got_data, p_id, p_implicit, p_incoming_message, p_init, p_index, p_item, p_job, p_key, p_lane_r, p_may_poll, p_message, p_msg, p_my_node, p_n_destinations, p_name, p_naming_table, p_next_start, p_obj, p_operation, p_period, p_port, p_port_table, p_portname, p_provides, p_priority, p_priority_manager, p_ref, p_req, p_result, p_self, p_server_entity_table, p_spg_interface, p_task_period, p_task_priority, p_task_stack_size, p_thread_fifo_sizes, p_thread_fifo_offsets, p_thread_interface, p_the_partition_source, p_to, p_tp, p_type_code, p_size, p_store, p_source, p_section, p_shutdown, p_storage_size, p_stack_size, p_status, p_system_start_time, p_valid, p_value); PN : array (parameter_id) of name_id; type variable_id is (v_argument, v_id, v_index, v_invalid_server, v_mutex, v_name, v_present, v_temp, v_req, v_args, v_status, v_result, v_thread_interface, v_threads_array, v_threads_access, v_error); VN : array (variable_id) of name_id; type subprogram_id is (s_build, s_catch, s_deferred_initialization, s_deliver, s_emit_message, s_execute_servant, s_found, s_from_any, s_get_count, s_get_next_event, s_get_value, s_initialize, s_marshall, s_next_value, s_receive_input, s_send_output, s_put_value, s_store_received_message, s_to_any, s_to_bounded_string, s_to_bounded_wide_string, s_to_string, s_to_wide_string, s_unmarshall, s_wait_for_incoming_events, s_controller, s_get_conf, s_process_request, s_register_source, s_init_lane, s_create); SN : array (subprogram_id) of name_id; type component_id is (c_address, c_from, c_los, c_name, c_pid, c_port, c_proc_id, c_switch, c_conf_table, c_operation); CN : array (component_id) of name_id; type attribute_id is (a_access, a_address, a_class, a_first, a_pos, a_range, a_size, a_val, a_identity, a_last); AN : array (attribute_id) of name_id; type type_id is (t_bounded_string, t_bounded_wide_string, t_entity_type, t_address_array, t_integer_array, t_node_type, t_object, t_operations, t_ref, t_request, t_server_entity_type, t_table, t_thread_interface_type, t_partition_source, t_parameter_entry, t_port_type); TN : array (type_id) of name_id; type pragma_id is (pragma_elaborate_body, pragma_import, pragma_export, pragma_inline, pragma_no_return, pragma_preelaborate, pragma_priority, pragma_style_checks, pragma_unreferenced, pragma_warnings); GN : array (pragma_id) of name_id; type error_id is (e_program_error, e_constraint_error, e_nyi); EN : array (error_id) of name_id; function Add_Prefix_To_Name (Prefix : String; Name : name_id) return name_id; function Add_Suffix_To_Name (Suffix : String; Name : name_id) return name_id; function Remove_Suffix_From_Name (Suffix : String; Name : name_id) return name_id; -- This function returns a new name without the suffix. If the -- suffix does not exist, the returned name is equal to the given -- name. procedure Add_With_Package (E : node_id; Used : Boolean := False; Warnings_Off : Boolean := False; Elaborated : Boolean := False); procedure Append_Node_To_List (E : node_id; L : list_id); procedure Insert_After_Node (E : node_id; N : node_id); procedure Insert_Before_Node (E : node_id; N : node_id; L : list_id); procedure Push_Entity (E : node_id); procedure Pop_Entity; function Current_Entity return node_id; function Current_Package return node_id; function Copy_Node (N : node_id) return node_id; function New_Node (Kind : node_kind; From : node_id := No_Node) return node_id; function New_List (Kind : node_kind; From : node_id := No_Node) return list_id; function Image (T : token_type) return String; function Image (O : operator_type) return String; procedure Initialize; procedure Reset; procedure New_Token (T : token_type; I : String := ""); function Length (L : list_id) return Natural; procedure Remove_Node_From_List (E : node_id; L : list_id); -- Remove node N to list L. function Is_Empty (L : list_id) return Boolean; pragma inline (Is_Empty); -- Return True when L is empty function Copy_Designator (Designator : node_id; Withed : Boolean := True) return node_id; function Defining_Identifier_To_Designator (N : node_id; Copy : Boolean := False; Keep_Parent : Boolean := True; Keep_Corresponding_Node : Boolean := True) return node_id; 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; function Make_Ada_Comment (N : name_id; Has_Header_Spaces : Boolean := True) return node_id; -- This function does only the fllowing thing: it creates a node -- whose name is the full text of the comment. It does not split -- the comment into many lines. This is done in the code -- generation phase function Make_Array_Aggregate (Elements : list_id) return node_id; function Make_Array_Type_Definition (Range_Constraints : list_id; Component_Definition : node_id; Aliased_Present : Boolean := False) return node_id; -- Usually used with Make_Full_Type_Declaration function Make_Assignment_Statement (Variable_Identifier : node_id; Expression : node_id) return node_id; function Make_Attribute_Definition_Clause (Defining_Identifier : node_id; Attribute_Designator : attribute_id; Expression : node_id) return node_id; function Make_Attribute_Designator (Prefix : node_id; Attribute : attribute_id) return node_id; 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; function Make_Case_Label (Value : value_id) return node_id; function Make_Case_Statement (Expression : node_id; Case_Statement_Alternatives : list_id) return node_id; function Make_Case_Statement_Alternative (Discret_Choice_List : list_id; Statements : list_id) return node_id; function Make_Component_Association (Selector_Name : node_id; Expression : node_id) return node_id; function Make_Component_Declaration (Defining_Identifier : node_id; Subtype_Indication : node_id; Expression : node_id := No_Node; Aliased_Present : Boolean := False) return node_id; function Make_Decimal_Type_Definition (D_Digits : unsigned_long_long; D_Scale : unsigned_long_long) return node_id; function Make_Defining_Identifier (Name : name_id) return node_id; function Make_Delay_Statement (Expression : node_id; Is_Until : Boolean := False) return node_id; 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; function Make_Designator (Designator : name_id; Parent : name_id := No_Name; Is_All : Boolean := False) return node_id; function Make_Elsif_Statement (Condition : node_id; Then_Statements : list_id) return node_id; function Make_Element_Association (Index : node_id; Expression : node_id) return node_id; -- If 'Index' is No_Node, then 'others => ' will be -- generated function Make_Enumeration_Type_Definition (Enumeration_Literals : list_id) return node_id; function Make_Enumeration_Representation_Clause (Defining_Identifier : node_id; Array_Aggregate : node_id) return node_id; function Make_Exception_Declaration (Defining_Identifier : node_id; Renamed_Exception : node_id := No_Node) return node_id; function Make_Explicit_Dereference (Prefix : node_id) return node_id; function Make_Expression (Left_Expr : node_id; Operator : operator_type := op_none; Right_Expr : node_id := No_Node) return node_id; function Make_For_Statement (Defining_Identifier : node_id; Range_Constraint : node_id; Statements : list_id) return node_id; function Make_Loop_Statement (Statements : list_id) return node_id; 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; -- No_Node as Type_Definition made type declaration without actual -- definition (eg. "type X;"). 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; function Make_List_Id (N1 : node_id; N2 : node_id := No_Node; N3 : node_id := No_Node) return list_id; function Make_Literal (Value : value_id; Parent_Designator : node_id := No_Node) return node_id; function Make_Main_Subprogram_Implementation (Identifier : node_id; Build_Spec : Boolean := False; Build_Body : Boolean := True) return node_id; -- If Build_Body is false generate only the spec of a main -- subprogram function Make_Null_Statement return node_id; 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; function Make_Object_Instantiation (Qualified_Expression : node_id) return node_id; function Make_Package_Declaration (Identifier : node_id) return node_id; function Make_Package_Instantiation (Defining_Identifier : node_id; Generic_Package : node_id; Parameter_List : list_id := No_List) return node_id; function Make_Private_Type_Definition return node_id; function Make_Parameter_Association (Selector_Name : node_id; Actual_Parameter : node_id) return node_id; 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; function Make_Pragma_Statement (The_Pragma : pragma_id; Argument_List : list_id := No_List) return node_id; 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; function Make_Protected_Object_Body (Defining_Identifier : node_id; Statements : list_id) return node_id; function Make_Qualified_Expression (Subtype_Mark : node_id; Aggregate : node_id) return node_id; function Make_Raise_Statement (Raised_Error : node_id := No_Node) return node_id; function Make_Range_Constraint (First : node_id; Last : node_id; Index_Type : node_id := No_Node) return node_id; function Make_Record_Aggregate (L : list_id) return node_id; function Make_Record_Definition (Component_List : list_id) return node_id; 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; function Make_Return_Statement (Expression : node_id) return node_id; function Make_Subprogram_Call (Defining_Identifier : node_id; Actual_Parameter_Part : list_id := No_List) return node_id; function Make_Selected_Component (Prefix : node_id; Selector_Name : node_id) return node_id; function Make_Subprogram_Implementation (Specification : node_id; Declarations : list_id; Statements : list_id) return node_id; 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; function Make_Type_Attribute (Designator : node_id; Attribute : attribute_id) return node_id; function Make_Type_Conversion (Subtype_Mark : node_id; Expression : node_id) return node_id; function Make_Withed_Package (Defining_Identifier : node_id; Used : Boolean := False; Warnings_Off : Boolean := False; Elaborated : Boolean := False) return node_id; function Make_Used_Package (The_Used_Package : node_id) return node_id; function Make_Used_Type (The_Used_Type : node_id) return node_id; function Make_Variant_Part (Discriminant : node_id; Variant_List : list_id) return node_id; procedure Make_Comment_Header (Package_Header : list_id); -- This procedure generates a comment header for the generated -- packages. function Next_N_Node (N : node_id; Num : Natural) return node_id; -- This function executes Next_Node Num times function Message_Comment (M : name_id) return node_id; function Message_Comment (M : String) return node_id; -- Return a comment message. Used by all the tree -- converters function Qualified_Designator (P : node_id) return node_id; procedure Set_Homogeneous_Parent_Unit_Name (Child : node_id; Parent : node_id); -- This procedure sets correctly the parent unit name of a node -- depending on its kind : -- * K_Defining_Identifier : the parent unit name is also a -- K_Defining_Identifier -- * K_Designator : The parent unit name is a K_Designator and the -- parent unit name of its defining identifier is also set up. -- Units setters for the PolyORB-QoS Module procedure Set_Main_Body (N : node_id := No_Node); procedure Set_Helpers_Body (N : node_id := No_Node); procedure Set_Helpers_Spec (N : node_id := No_Node); procedure Set_Servants_Body (N : node_id := No_Node); procedure Set_Servants_Spec (N : node_id := No_Node); procedure Set_Parameters_Body (N : node_id := No_Node); procedure Set_Parameters_Spec (N : node_id := No_Node); procedure Set_Setup_Body (N : node_id := No_Node); procedure Set_Setup_Spec (N : node_id := No_Node); procedure Set_Namespaces_Body (N : node_id := No_Node); procedure Set_Namespaces_Spec (N : node_id := No_Node); procedure Set_Obj_Adapters_Spec (N : node_id := No_Node); -- Units Setters for the PolyORB-HI module procedure Set_Main_Spec (N : node_id := No_Node); procedure Set_Marshallers_Spec (N : node_id := No_Node); procedure Set_Marshallers_Body (N : node_id := No_Node); procedure Set_Activity_Spec (N : node_id := No_Node); procedure Set_Activity_Body (N : node_id := No_Node); procedure Set_Types_Spec (N : node_id := No_Node); procedure Set_Types_Body (N : node_id := No_Node); procedure Set_Subprograms_Spec (N : node_id := No_Node); procedure Set_Subprograms_Body (N : node_id := No_Node); procedure Set_Deployment_Spec (N : node_id := No_Node); procedure Set_Naming_Spec (N : node_id := No_Node); function To_Ada_Name (N : name_id) return name_id; -- Convert N to a valid Ada identifier (no clashing with keywords, -- no consecutive '_', no heading '_'...). function Unit_Name (N : name_id) return name_id; -- Given an ENTITY fully qualified name A.B.C.D, returns A.B.C -- Raises an arror if the name does not contains any dot. function Local_Name (N : name_id) return name_id; -- Given an ENTITY fully qualified name A.B.C.D, returns D function Conventional_Base_Name (N : name_id) return name_id; -- Given a UNIT fully qualified name A.D.C, returns a-b-c function Fully_Qualified_Name (N : node_id) return name_id; function Extract_Designator (N : node_id; Add_With_Clause : Boolean := True) return node_id; -- Extracts the designator of the *Ada* entity N and return a copy -- of it after adding the proper 'with' clause to the current -- package if 'Add_With_Clause' is True. N may be: -- * a type declaration -- * a subprogram specification -- * an object declaration -- * a package specification -- * a package declaration end Ocarina.Generators.Ada_Tree.Nutils;