--------------------------------------------- ----------------------------------- -- -- -- OCARINA COMPONENTS -- -- -- -- O C A R I N A . G E N E R A T O R S . P R O P E R T I E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 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.Nodes; with Ocarina.Nutils; with Ocarina.Entities.Properties; with Ocarina.AADL_Values; with Ocarina.Analyzer.Queries; with Ocarina.Generators.Utils; with Ocarina.Generators.Messages; package body Ocarina.Generators.Properties is use Ocarina.Nodes; use Ocarina.Nutils; use Ocarina.Entities; use Ocarina.Entities.Properties; use Ocarina.Analyzer.Queries; use Ocarina.Generators.Utils; use Ocarina.Generators.Messages; ---------------------------------- -- Several component properties -- ---------------------------------- ARAO_Priority : constant String := "arao::priority"; -- Thread and Data Compute_Entrypoint : constant String := "compute_entrypoint"; -- Thread and IN [event] [data] ports Source_Language : constant String := "source_language"; Source_Name : constant String := "source_name"; Type_Source_Name : constant String := "type_source_name"; Source_Text : constant String := "source_text"; -- Subprogram, thread, data, port... ------------------------------- -- Data component properties -- ------------------------------- Data_Type : constant String := "arao::data_type"; Data_Max_Length : constant String := "arao::max_length"; Data_Length : constant String := "arao::length"; Data_Required_Access : constant String := "required_access"; Data_Provided_Access : constant String := "provided_access"; Data_Digits : constant String := "arao::data_digits"; Data_Scale : constant String := "arao::data_scale"; Data_Size : constant String := "source_data_size"; Data_Concurrency_Protocol : constant String := "concurrency_control_protocol"; --------------------------------- -- Thread component properties -- --------------------------------- Thread_Period : constant String := "period"; Thread_Dispatch_Protocol : constant String := "dispatch_protocol"; Thread_Cheddar_Priority : constant String := "cheddar_properties::fixed_priority"; Thread_Stack_Size : constant String := "source_stack_size"; ---------------------------------- -- Process component properties -- ---------------------------------- Port_Number : constant String := "arao::port_number"; Process_Id : constant String := "arao::process_id"; Processor_Binding : constant String := "actual_processor_binding"; Process_Channel_Address : constant String := "arao::channel_address"; ------------------------------------ -- Processor component properties -- ------------------------------------ Location : constant String := "arao::location"; Execution_Platform : constant String := "arao::execution_platform"; --------------------------------- -- AADL Connections properties -- --------------------------------- Connection_Binding : constant String := "actual_connection_binding"; ------------------------------- -- Bus components properties -- ------------------------------- Transport_API : constant String := "arao::transport_api"; --------------------- -- Port properties -- --------------------- Queue_Size : constant String := "queue_size"; --------------------------------- -- System component properties -- --------------------------------- Protocol : constant String := "arao::protocol"; -- All the Name_Id's below MUST be initialized in the Init -- procedure. Data_Integer_Name : Name_Id; Data_Boolean_Name : Name_Id; Data_Float_Name : Name_Id; Data_Fixed_Name : Name_Id; Data_String_Name : Name_Id; Data_Wide_String_Name : Name_Id; Data_Character_Name : Name_Id; Data_Wide_Character_Name : Name_Id; Data_None_Name : Name_Id; Access_Read_Only_Name : Name_Id; Access_Write_Only_Name : Name_Id; Access_Read_Write_Name : Name_Id; Access_By_Method_Name : Name_Id; Concurrency_NoneSpecified_Name : Name_Id; Concurrency_Protected_Access_Name : Name_Id; Concurrency_Priority_Ceiling_Name : Name_Id; Language_Ada_95_Name : Name_Id; Language_Ada_Name : Name_Id; Language_Ada_05_Name : Name_Id; Language_C_Name : Name_Id; Language_ASN1_Name : Name_Id; Language_Lustre_Name : Name_Id; Language_Lustre5_Name : Name_Id; Language_Lustre6_Name : Name_Id; Thread_Periodic_Name : Name_Id; Thread_Aperiodic_Name : Name_Id; Thread_Sporadic_Name : Name_Id; Time_Ps_Name : Name_Id; Time_Ns_Name : Name_Id; Time_Us_Name : Name_Id; Time_Ms_Name : Name_Id; Time_Sec_Name : Name_Id; Time_Min_Name : Name_Id; Time_Hr_Name : Name_Id; Size_Bit_Name : Name_Id; Size_Byte_Name : Name_Id; Size_Kilo_Byte_Name : Name_Id; Size_Mega_Byte_Name : Name_Id; Size_Giga_Byte_Name : Name_Id; Platform_Native_Name : Name_Id; Platform_LEON_RTEMS_Name : Name_Id; Platform_LEON_ORK_Name : Name_Id; Platform_ERC32_ORK_Name : Name_Id; Platform_ARM_DSLINUX_Name : Name_Id; Platform_ARM_N770_Name : Name_Id; Transport_BSD_Sockets_Name : Name_Id; Transport_SpaceWire_Name : Name_Id; Protocol_IIOP_Name : Name_Id; Protocol_DIOP_Name : Name_Id; Min_Priority : Unsigned_Long_Long := 0; Max_Priority : Unsigned_Long_Long := 0; -- These variables are updated at the first call to -- Get_Thread_Priority. procedure Raise_Inconsistency_Error (M : String); pragma No_Return (Raise_Inconsistency_Error); pragma Inline (Raise_Inconsistency_Error); -- Raises an error that indicates inconsistency between frontend -- and backend. function Get_Size_Property_Value (C : Node_Id; Property_Name : String) return Size_Type; -- Code factorization between thread and data interrogators function Get_Compute_Entrypoint (E : Node_Id) return Name_Id; -- Code factorization between thread and port interrogators ----------------------------- -- Get_Size_Property_Value -- ----------------------------- function Get_Size_Property_Value (C : Node_Id; Property_Name : String) return Size_Type is V : Node_Id; U : Node_Id; Result : Size_Type; N : Name_Id; begin if Is_Defined_Integer_Property (C, Property_Name) then V := Get_Value_Of_Property_Association (C, Property_Name); if Present (V) and then Present (Unit_Identifier (V)) then U := Unit_Identifier (V); -- Get the size Result.S := Get_Integer_Property (C, Property_Name); -- Convert the value to its unit N := Name (U); if N = Size_Bit_Name then Result.U := Bit; elsif N = Size_Byte_Name then Result.U := Byte; elsif N = Size_Kilo_Byte_Name then Result.U := Kilo_Byte; elsif N = Size_Mega_Byte_Name then Result.U := Mega_Byte; elsif N = Size_Giga_Byte_Name then Result.U := Giga_Byte; else Raise_Inconsistency_Error ("Wrong unit"); end if; return Result; else Raise_Inconsistency_Error ("A size without unit"); end if; else return ((0, Bit)); end if; end Get_Size_Property_Value; ---------------------------- -- Get_Compute_Entrypoint -- ---------------------------- function Get_Compute_Entrypoint (E : Node_Id) return Name_Id is begin if Is_Defined_String_Property (E, Compute_Entrypoint) then return Get_String_Property (E, Compute_Entrypoint); else return No_Name; end if; end Get_Compute_Entrypoint; ------------------------------- -- Raise_Inconsistency_Error -- ------------------------------- procedure Raise_Inconsistency_Error (M : String) is Inconsistency_Error : exception; begin -- If we get to this point, this means that the parser let go a -- wrong enumerator or else that the backend is not -- synchronized with the frontend. raise Inconsistency_Error with M; end Raise_Inconsistency_Error; ------------------- -- Get_Data_Type -- ------------------- function Get_Data_Type (D : Node_Id) return Supported_Data_Type is F : Node_Id; T_Name : Name_Id; begin pragma Assert (Utils.Is_Data (D)); if Is_Defined_Enumeration_Property (D, Data_Type) then T_Name := Get_Enumeration_Property (D, Data_Type); -- Although Name_Id is a scalar type, we cannot use a switch -- case since the XXX_Name global variables are not (and -- cannot be) static. if T_Name = Data_Integer_Name then return Data_Integer; elsif T_Name = Data_Boolean_Name then return Data_Boolean; elsif T_Name = Data_Float_Name then return Data_Float; elsif T_Name = Data_Fixed_Name then return Data_Fixed; elsif T_Name = Data_String_Name then if not Is_Defined_Integer_Property (D, Data_Max_Length) then Display_Located_Error (Loc (D), "String types must have a maximum length", Fatal => True); end if; return Data_String; elsif T_Name = Data_Wide_String_Name then if not Is_Defined_Integer_Property (D, Data_Max_Length) then Display_Located_Error (Loc (D), "Wide string types must have a maximum length", Fatal => True); end if; return Data_Wide_String; elsif T_Name = Data_Character_Name then return Data_Character; elsif T_Name = Data_Wide_Character_Name then return Data_Wide_Character; elsif T_Name = Data_None_Name then return Data_None; else Raise_Inconsistency_Error ("Unknown data type"); end if; elsif not Is_Empty (Features (D)) then -- Check whether it is a protected type F := First_Node (Features (D)); while Present (F) loop if Kind (F) /= K_Subprogram_Spec_Instance then Display_Located_Error (Loc (F), "Unsupported feature kind for data type", Fatal => True); end if; F := Next_Node (F); end loop; if Is_Empty (Subcomponents (D)) then Display_Located_Error (Loc (D), "Data with accessor must have at least one data subcomponent", Fatal => True); end if; return Data_With_Accessors; elsif not Is_Empty (Subcomponents (D)) then -- Check whether it is an array if Is_Defined_Integer_Property (D, Data_Length) then if Length (Subcomponents (D)) /= 1 then Display_Located_Error (Loc (D), "Array type must have exactly one data subcomponent", Fatal => True); end if; return Data_Array; else return Data_Record; end if; else return Data_None; end if; end Get_Data_Type; --------------------- -- Get_Data_Digits -- --------------------- function Get_Data_Digits (D : Node_Id) return Unsigned_Long_Long is begin pragma Assert (Get_Data_Type (D) = Data_Fixed); if Is_Defined_Integer_Property (D, Data_Digits) then return Get_Integer_Property (D, Data_Digits); else return 0; end if; end Get_Data_Digits; -------------------- -- Get_Data_Scale -- -------------------- function Get_Data_Scale (D : Node_Id) return Unsigned_Long_Long is begin pragma Assert (Get_Data_Type (D) = Data_Fixed); if Is_Defined_Integer_Property (D, Data_Scale) then return Get_Integer_Property (D, Data_Scale); else return 0; end if; end Get_Data_Scale; ------------------- -- Get_Data_Size -- ------------------- function Get_Data_Size (D : Node_Id) return Size_Type is begin pragma Assert (Utils.Is_Data (D)); return (Get_Size_Property_Value (D, Data_Size)); end Get_Data_Size; ---------------------------------------- -- Get_Priority_Celing_Of_Data_Access -- ---------------------------------------- function Get_Priority_Celing_Of_Data_Access (D : Node_Id) return Unsigned_Long_Long is begin pragma Assert (Utils.Is_Data (D)); if Is_Defined_Integer_Property (D, ARAO_Priority) then if Get_Concurrency_Protocol (D) /= Concurrency_Priority_Ceiling then Display_Located_Error (Loc (D), "Inconsistent definition of data types: should define " & "Concurrency_Control_Protocol to " & "Concurrency_Priority_Ceiling", Fatal => True); end if; return Get_Integer_Property (D, ARAO_Priority); else return 0; end if; end Get_Priority_Celing_Of_Data_Access; ------------------------------ -- Get_Provided_Data_Access -- ------------------------------ function Get_Provided_Data_Access (D : Node_Id) return Supported_Data_Access is T_Name : Name_Id; begin pragma Assert (Utils.Is_Data (D)); if Is_Defined_Enumeration_Property (D, Data_Provided_Access) then T_Name := Get_Enumeration_Property (D, Data_Provided_Access); if T_Name = Access_Read_Only_Name then return Access_Read_Only; elsif T_Name = Access_Write_Only_Name then return Access_Write_Only; elsif T_Name = Access_Read_Write_Name then return Access_Read_Write; elsif T_Name = Access_By_Method_Name then return Access_By_Method; else Raise_Inconsistency_Error ("Unknown access type"); end if; else return Access_None; end if; end Get_Provided_Data_Access; ------------------------------ -- Get_Required_Data_Access -- ------------------------------ function Get_Required_Data_Access (D : Node_Id) return Supported_Data_Access is T_Name : Name_Id; begin pragma Assert (Utils.Is_Data (D)); if Is_Defined_Enumeration_Property (D, Data_Required_Access) then T_Name := Get_Enumeration_Property (D, Data_Required_Access); if T_Name = Access_Read_Only_Name then return Access_Read_Only; elsif T_Name = Access_Write_Only_Name then return Access_Write_Only; elsif T_Name = Access_Read_Write_Name then return Access_Read_Write; elsif T_Name = Access_By_Method_Name then return Access_By_Method; else Raise_Inconsistency_Error ("Unknown access type"); end if; else return Access_None; end if; end Get_Required_Data_Access; --------------------- -- Get_Data_Length -- --------------------- function Get_Data_Length (D : Node_Id) return Unsigned_Long_Long is begin pragma Assert (Utils.Is_Data (D)); case Get_Data_Type (D) is when Data_String | Data_Wide_String => return Get_Integer_Property (D, Data_Max_Length); when Data_Array => return Get_Integer_Property (D, Data_Length); when others => Display_Located_Error (Loc (D), "This data type does not have a length", Fatal => True); return 0; end case; end Get_Data_Length; ------------------------------ -- Get_Concurrency_Protocol -- ------------------------------ function Get_Concurrency_Protocol (D : Node_Id) return Supported_Concurrency_Control_Protocol is C_Name : Name_Id; begin pragma Assert (Utils.Is_Data (D)); if Is_Defined_Enumeration_Property (D, Data_Concurrency_Protocol) then C_Name := Get_Enumeration_Property (D, Data_Concurrency_Protocol); if C_Name = Concurrency_NoneSpecified_Name then return Concurrency_NoneSpecified; elsif C_Name = Concurrency_Protected_Access_Name then -- Verify that the data is with accessor if Get_Data_Type (D) /= Data_With_Accessors and then Get_Data_Type (D) /= Data_Record then Display_Located_Error (Loc (D), "Concurrency protocol Protected_Access cannot be defined" & " for data type that do not have accessor subprograms and" & " are not data records", Fatal => True); end if; return Concurrency_Protected_Access; elsif C_Name = Concurrency_Priority_Ceiling_Name then -- Verify that the data is with accessor if Get_Data_Type (D) /= Data_With_Accessors then Display_Located_Error (Loc (D), "Concurrency protocol Priority_Ceiling cannot be defined" & " for data type that do not have accessor subprograms.", Fatal => True); end if; return Concurrency_Priority_Ceiling; else Raise_Inconsistency_Error ("Unknown concurrency protocol"); end if; else return Concurrency_NoneSpecified; end if; end Get_Concurrency_Protocol; ------------------------- -- Get_Source_Language -- ------------------------- function Get_Source_Language (E : Node_Id) return Supported_Source_Language is Source_L : Name_Id; begin if Is_Defined_Enumeration_Property (E, Source_Language) then Source_L := Get_Enumeration_Property (E, Source_Language); if Source_L = Language_Ada_95_Name or else Source_L = Language_Ada_Name or else Source_L = Language_Ada_05_Name then -- All instances of Ada are aliased to Ada_95 return Language_Ada_95; elsif Source_L = Language_ASN1_Name then return Language_ASN1; elsif Source_L = Language_Lustre_Name or else Source_L = Language_Lustre5_Name or else Source_L = Language_Lustre6_Name then return Language_Lustre; elsif Source_L = Language_C_Name then return Language_C; else Raise_Inconsistency_Error ("Unknown source language"); end if; else return Language_None; end if; end Get_Source_Language; ------------------------- -- Get_Subprogram_Kind -- ------------------------- function Get_Subprogram_Kind (S : Node_Id) return Supported_Subprogram_Kind is Language : constant Supported_Source_Language := Get_Source_Language (S); Src_Name : constant Name_Id := Get_Source_Name (S); Src_Files : constant Name_Array := Get_Source_Text (S); begin case Language is when Language_Ada_95 => if Src_Name /= No_Name or else Src_Files'Length > 0 then if not Is_Empty (Calls (S)) and then not Is_Empty (Subprogram_Calls (First_Node (Calls (S)))) then -- A subprogram having Ada 95 as implementation -- language, an implementation name and a *non -- null* call sequence list is a hybrid Ada 95 -- subprogram. return Subprogram_Hybrid_Ada_95; else -- A subprogram having Ada 95 as implementation -- language, an implementation name and a *null* -- call sequence list is an opaque Ada 95 -- subprogram. return Subprogram_Opaque_Ada_95; end if; else -- A subprogram having Ada 95 as implementation -- language and a null source name and source text is -- a wrong built subprogram. return Subprogram_Unknown; end if; when Language_Lustre => if not Is_Empty (Calls (S)) and then not Is_Empty (Subprogram_Calls (First_Node (Calls (S)))) then -- A subprogram having Lustre as implementation -- language, an implementation name and a *non -- null* call sequence list is not supported yet. return Subprogram_Unknown; else -- A subprogram having Lustre as implementation -- language, an implementation name and a *null* -- call sequence list is an opaque ASN1 wrapped -- subprogram, per the IST-ASSERT process. return Subprogram_Opaque_ASN1_Wrapped; end if; when Language_ASN1 => -- A subprogram having ASN1 as implementation -- language is not supported. return Subprogram_Unknown; when Language_C => if Src_Name /= No_Name or else Src_Files'Length > 0 then if not Is_Empty (Calls (S)) and then not Is_Empty (Subprogram_Calls (First_Node (Calls (S)))) then -- A subprogram having C as implementation -- language, an implementation name and a *non -- null* call sequence list is not supported yet. return Subprogram_Unknown; else -- A subprogram having C as implementation -- language, an implementation name and a *null* -- call sequence list is an opaque C subprogram. return Subprogram_Opaque_C; end if; else -- A subprogram having C as implementation language -- and a null source name and a null source text is a -- wrong built subprogram. return Subprogram_Unknown; end if; when Language_None => if Src_Name /= No_Name or else Src_Files'Length > 0 then -- A subprogram having no implementation source -- language but a non null source name or an non null -- source text is a wrong built subprogram. return Subprogram_Unknown; else if not Is_Empty (Calls (S)) and then not Is_Empty (Subprogram_Calls (First_Node (Calls (S)))) then -- A subprogram having no implementation language, -- no implementation name and a pure call sequence -- subprogram. However the length of its call -- sequence has to be exactly 1. if Length (Calls (S)) = 1 then return Subprogram_Pure_Call_Sequence; else return Subprogram_Unknown; end if; else -- A subprogram having no implementation language -- and a *null* call sequence list is an empty -- subprogram. return Subprogram_Empty; end if; end if; end case; end Get_Subprogram_Kind; --------------------- -- Get_Source_Name -- --------------------- function Get_Source_Name (E : Node_Id) return Name_Id is begin if Is_Defined_String_Property (E, Source_Name) then return Get_String_Property (E, Source_Name); else return No_Name; end if; end Get_Source_Name; -------------------------- -- Get_Type_Source_Name -- -------------------------- function Get_Type_Source_Name (E : Node_Id) return Name_Id is begin if Is_Defined_String_Property (E, Type_Source_Name) then return Get_String_Property (E, Type_Source_Name); else return No_Name; end if; end Get_Type_Source_Name; --------------------- -- Get_Source_Text -- --------------------- function Get_Source_Text (E : Node_Id) return Name_Array is T_List : List_Id; begin if Is_Defined_List_Property (E, Source_Text) then T_List := Get_List_Property (E, Source_Text); declare use Ocarina.AADL_Values; L : constant Nat := Nat (Length (T_List)); Res : Name_Array (1 .. L); N : Node_Id; begin N := First_Node (T_List); for J in Res'Range loop Res (J) := Value (Value (N)).SVal; N := Next_Node (N); end loop; return Res; end; else return Empty_Array; end if; end Get_Source_Text; ---------------------------------- -- Get_Thread_Dispatch_Protocol -- ---------------------------------- function Get_Thread_Dispatch_Protocol (T : Node_Id) return Supported_Thread_Dispatch_Protocol is P_Name : Name_Id; begin pragma Assert (Is_Thread (T)); if Is_Defined_Enumeration_Property (T, Thread_Dispatch_Protocol) then P_Name := Get_Enumeration_Property (T, Thread_Dispatch_Protocol); -- Although Name_Id is a scalar type, we cannot use a switch -- case since the XXX_Name global variables are not (and -- cannot be) static. if P_Name = Thread_Periodic_Name then if not Is_Defined_Integer_Property (T, Thread_Period) then Display_Located_Error (Loc (T), "Periodic threads must have a period", Fatal => True); end if; return Thread_Periodic; elsif P_Name = Thread_Aperiodic_Name then return Thread_Aperiodic; elsif P_Name = Thread_Sporadic_Name then if not Is_Defined_Integer_Property (T, Thread_Period) then Display_Located_Error (Loc (T), "Sporadic threads must have a period", Fatal => True); end if; return Thread_Sporadic; else Raise_Inconsistency_Error ("Unknown thread dispatch protocol"); end if; else return Thread_None; end if; end Get_Thread_Dispatch_Protocol; ----------------------- -- Get_Thread_Period -- ----------------------- function Get_Thread_Period (T : Node_Id) return Time_Type is Result : Time_Type; V : Node_Id; N : Name_Id; U : Node_Id; begin pragma Assert (Is_Thread (T)); case Get_Thread_Dispatch_Protocol (T) is when Thread_Periodic | Thread_Sporadic => -- We are sure the thread has a period V := Get_Value_Of_Property_Association (T, Thread_Period); if Present (V) and then Present (Unit_Identifier (V)) then U := Unit_Identifier (V); -- Get the period Result.T := Get_Integer_Property (T, Thread_Period); -- Convert the value to its unit N := Name (U); if N = Time_Ps_Name then Result.U := Picosecond; elsif N = Time_Ns_Name then Result.U := Nanosecond; elsif N = Time_Us_Name then Result.U := Microsecond; elsif N = Time_Ms_Name then Result.U := Millisecond; elsif N = Time_Sec_Name then Result.U := Second; elsif N = Time_Min_Name then Result.U := Minute; elsif N = Time_Hr_Name then Result.U := Hour; else Raise_Inconsistency_Error ("Wrong unit"); end if; return Result; else Raise_Inconsistency_Error ("A time without unit"); end if; when others => Display_Located_Error (Loc (T), "This kind of thread does not have a period", Fatal => True); return ((0, Picosecond)); end case; end Get_Thread_Period; ------------------------- -- Get_Thread_Priority -- ------------------------- function Get_Thread_Priority (T : Node_Id) return Unsigned_Long_Long is use Ocarina.AADL_Values; procedure Update_Priority_Bounds (P : String); -- Check that the priority type corresponding to T has explicit -- bounds and updates Max_Priority and Min_Priority -- accordingly. Raise an error if the type is not explicitly -- bounded. ---------------------------- -- Update_Priority_Bounds -- ---------------------------- procedure Update_Priority_Bounds (P : String) is Property : constant Node_Id := Find_Property_Association_From_Name (Nodes.Properties (T), P); Property_Type : constant Node_Id := Expanded_Type_Designator (Property_Name_Type (Entity (Property_Name (Property)))); Prperty_Type_Range : constant Node_Id := Type_Range (Property_Type); begin if No (Prperty_Type_Range) then Display_Located_Error (Loc (Property_Type), "This priority type must have EXPLICIT bounds", Fatal => True); else Min_Priority := Value (Value (Number_Value (Lower_Bound (Prperty_Type_Range)))). IVal; Max_Priority := Value (Value (Number_Value (Upper_Bound (Prperty_Type_Range)))). IVal; end if; end Update_Priority_Bounds; begin pragma Assert (Is_Thread (T)); if Is_Defined_Integer_Property (T, ARAO_Priority) then Update_Priority_Bounds (ARAO_Priority); return Get_Integer_Property (T, ARAO_Priority); elsif Is_Defined_Integer_Property (T, Thread_Cheddar_Priority) then Update_Priority_Bounds (Thread_Cheddar_Priority); return Get_Integer_Property (T, Thread_Cheddar_Priority); else return 0; end if; end Get_Thread_Priority; ---------------------- -- Get_Min_Priority -- ---------------------- function Get_Min_Priority return Unsigned_Long_Long is begin if Min_Priority = 0 and then Max_Priority = 0 then Display_Error ("Get_Min_Priority must be called after" & " Get_Thread_Priority", Fatal => True); end if; return Min_Priority; end Get_Min_Priority; ---------------------- -- Get_Max_Priority -- ---------------------- function Get_Max_Priority return Unsigned_Long_Long is begin if Min_Priority = 0 and then Max_Priority = 0 then Display_Error ("Get_Max_Priority must be called after" & " Get_Thread_Priority", Fatal => True); end if; return Max_Priority; end Get_Max_Priority; --------------------------- -- Get_Thread_Stack_Size -- --------------------------- function Get_Thread_Stack_Size (T : Node_Id) return Size_Type is begin pragma Assert (Is_Thread (T)); return (Get_Size_Property_Value (T, Thread_Stack_Size)); end Get_Thread_Stack_Size; ------------------------------------ -- Get_Thread_Implementation_Kind -- ------------------------------------ function Get_Thread_Implementation_Kind (T : Node_Id) return Supported_Thread_Implementation is begin pragma Assert (Is_Thread (T)); if Is_Empty (Calls (T)) then -- See whether the thread IN ports have their own compute -- entrypoints. if not Is_Empty (Features (T)) and then Has_In_Ports (T) then declare F : Node_Id := First_Node (Features (T)); All_Match : Boolean := True; One_Match : Boolean := False; begin while Present (F) loop if Kind (F) = K_Port_Spec_Instance and then Is_In (F) then One_Match := One_Match or else Is_Defined_String_Property (F, Compute_Entrypoint); All_Match := All_Match and then Is_Defined_String_Property (F, Compute_Entrypoint); elsif Kind (F) = K_Port_Spec_Instance and then Is_Out (F) and then Is_Defined_String_Property (F, Compute_Entrypoint) then Display_Located_Error (Loc (F), "You cannot specify Compute_Entrypoint property" & " for an OUT-only port", Fatal => True); end if; F := Next_Node (F); end loop; if One_Match and then All_Match then return Thread_With_Port_Compute_Entrypoint; elsif One_Match then Display_Located_Error (Loc (T), "You should specify a compute entrypoint for all IN ports" & " or else for NONE of them", Fatal => True); end if; end; end if; -- See whether the thread itself has a compute entrypoint if Is_Defined_String_Property (T, Compute_Entrypoint) then return Thread_With_Compute_Entrypoint; end if; elsif Length (Calls (T)) > 1 and then not Has_Modes (T) then Display_Located_Error (Loc (T), "Multiple call sequences in non-MODE threads are not supported." & " You should encapsulate them in a wrapper subprogram.", Fatal => True); else declare Call_Seq : Node_Id := First_Node (Calls (T)); begin while Present (Call_Seq) loop if Length (Subprogram_Calls (Call_Seq)) > 1 then Display_Located_Error (Loc (Call_Seq), "Multiple subprogram calls in the thread call sequence" & " are not supported. You should encapsulate them in" & " a wrapper subprogram.", Fatal => True); end if; Call_Seq := Next_Node (Call_Seq); end loop; return Thread_With_Call_Sequence; end; end if; return Thread_Unknown; end Get_Thread_Implementation_Kind; ----------------------------------- -- Get_Thread_Compute_Entrypoint -- ----------------------------------- function Get_Thread_Compute_Entrypoint (T : Node_Id) return Name_Id renames Get_Compute_Entrypoint; ---------------------------- -- Get_Processor_Location -- ---------------------------- function Get_Processor_Location (P : Node_Id) return Name_Id is begin pragma Assert (Is_Processor (P)); if not Is_Defined_String_Property (P, Location) then return No_Name; end if; return Get_String_Property (P, Location); end Get_Processor_Location; ----------------------------- -- Get_Process_Port_Number -- ----------------------------- function Get_Process_Port_Number (P : Node_Id) return Value_Id is use Ocarina.AADL_Values; begin pragma Assert (Is_Process (P)); if not Is_Defined_Integer_Property (P, Port_Number) then return No_Value; end if; return New_Integer_Value (Unsigned_Long_Long (Get_Integer_Property (P, Port_Number))); end Get_Process_Port_Number; -------------------- -- Get_Process_Id -- -------------------- function Get_Process_Id (P : Node_Id) return Value_Id is use Ocarina.AADL_Values; begin pragma Assert (Is_Process (P)); if not Is_Defined_Integer_Property (P, Process_Id) then return No_Value; end if; return New_Integer_Value (Unsigned_Long_Long (Get_Integer_Property (P, Process_Id))); end Get_Process_Id; ------------------------- -- Get_Channel_Address -- ------------------------- function Get_Channel_Address (P : Node_Id) return Value_Id is use Ocarina.AADL_Values; begin pragma Assert (Is_Process (P)); if not Is_Defined_Integer_Property (P, Process_Channel_Address) then return No_Value; end if; return New_Integer_Value (Unsigned_Long_Long (Get_Integer_Property (P, Process_Channel_Address))); end Get_Channel_Address; ------------------------- -- Get_Bound_Processor -- ------------------------- function Get_Bound_Processor (P : Node_Id) return Node_Id is begin pragma Assert (Is_Process (P)); if not Is_Defined_Reference_Property (P, Processor_Binding) then Display_Located_Error (Loc (Parent_Subcomponent (P)), "This processor has to be bound to a processor", Fatal => True); end if; return Get_Reference_Property (P, Processor_Binding); end Get_Bound_Processor; ------------------- -- Get_Bound_Bus -- ------------------- function Get_Bound_Bus (C : Node_Id) return Node_Id is Result_List : List_Id; Result : Node_Id; begin pragma Assert (Kind (C) = K_Connection_Instance); -- Checks that the connection C can be bound to a bus if not Is_System (Parent_Component (C)) then Display_Located_Error (Loc (C), "Cannot call Get_Bound_Bus on this connection", Fatal => False); raise Program_Error; end if; if not Is_Defined_List_Property (C, Connection_Binding) then Display_Located_Error (Loc (C), "This connection has to be bound to a bus", Fatal => True); end if; Result_List := Get_List_Property (C, Connection_Binding); if Is_Empty (Result_List) then Display_Located_Error (Loc (C), "This connection is not bound to any bus", Fatal => True); end if; if Length (Result_List) > 1 then Display_Located_Error (Loc (C), "This connection is bound to more than ONE bus", Fatal => True); end if; Result := Get_Referenced_Entity (First_Node (Result_List)); pragma Assert (Is_Bus (Result)); return Result; end Get_Bound_Bus; ---------------------------- -- Get_Execution_Platform -- ---------------------------- function Get_Execution_Platform (P : Node_Id) return Supported_Execution_Platform is P_Name : Name_Id; begin pragma Assert (Is_Processor (P)); if Is_Defined_Enumeration_Property (P, Execution_Platform) then P_Name := Get_Enumeration_Property (P, Execution_Platform); if P_Name = Platform_Native_Name then return Platform_Native; elsif P_Name = Platform_LEON_RTEMS_Name then return Platform_LEON_RTEMS; elsif P_Name = Platform_LEON_ORK_Name then return Platform_LEON_ORK; elsif P_Name = Platform_ERC32_ORK_Name then return Platform_ERC32_ORK; elsif P_Name = Platform_ARM_DSLINUX_Name then return Platform_ARM_DSLINUX; elsif P_Name = Platform_ARM_N770_Name then return Platform_ARM_N770; else Raise_Inconsistency_Error ("Unknown execution platform"); end if; else return Platform_None; end if; end Get_Execution_Platform; ----------------------- -- Get_Transport_API -- ----------------------- function Get_Transport_API (B : Node_Id) return Supported_Transport_APIs is T_Name : Name_Id; begin pragma Assert (Is_Bus (B)); if Is_Defined_Enumeration_Property (B, Transport_API) then T_Name := Get_Enumeration_Property (B, Transport_API); if T_Name = Transport_BSD_Sockets_Name then return Transport_BSD_Sockets; elsif T_Name = Transport_SpaceWire_Name then return Transport_SpaceWire; else Raise_Inconsistency_Error ("Unknown transport layer"); end if; else return Transport_None; end if; end Get_Transport_API; -------------------- -- Get_Queue_Size -- -------------------- function Get_Queue_Size (P : Node_Id) return Long_Long is begin pragma Assert (Kind (P) = K_Port_Spec_Instance and then Is_Event (P)); if Is_Out (P) and then not Is_In (P) then Display_Located_Error (Loc (P), "Non-IN event [data] ports cannot have a queue size", Fatal => True); end if; if Is_Defined_Integer_Property (P, Queue_Size) then return Long_Long (Get_Integer_Property (P, Queue_Size)); else return -1; end if; end Get_Queue_Size; --------------------------------- -- Get_Port_Compute_Entrypoint -- --------------------------------- function Get_Port_Compute_Entrypoint (P : Node_Id) return Name_Id is begin if not Is_In (P) then Display_Located_Error (Loc (P), "Compute entrypoint cannot be specified for OUT-only ports", Fatal => True); end if; return Get_Compute_Entrypoint (P); end Get_Port_Compute_Entrypoint; ------------------ -- Get_Protocol -- ------------------ function Get_Protocol (S : Node_Id) return Protocol_Type is P_Name : Name_Id; begin pragma Assert (Is_System (S)); if Is_Defined_Enumeration_Property (S, Protocol) then P_Name := Get_Enumeration_Property (S, Protocol); if P_Name = Protocol_IIOP_Name then return Protocol_IIOP; elsif P_Name = Protocol_DIOP_Name then return Protocol_DIOP; else Raise_Inconsistency_Error ("Unknown protocol name"); end if; else return Protocol_None; end if; end Get_Protocol; ---------- -- Init -- ---------- procedure Init is begin Data_Integer_Name := Get_String_Name ("integer"); Data_Boolean_Name := Get_String_Name ("boolean"); Data_Float_Name := Get_String_Name ("float"); Data_Fixed_Name := Get_String_Name ("fixed"); Data_String_Name := Get_String_Name ("string"); Data_Wide_String_Name := Get_String_Name ("wide_string"); Data_Character_Name := Get_String_Name ("character"); Data_Wide_Character_Name := Get_String_Name ("wide_characeter"); Data_None_Name := Get_String_Name ("null"); Access_Read_Only_Name := Get_String_Name ("read_only"); Access_Write_Only_Name := Get_String_Name ("write_only"); Access_Read_Write_Name := Get_String_Name ("read_write"); Access_By_Method_Name := Get_String_Name ("by_method"); Concurrency_NoneSpecified_Name := Get_String_Name ("nonespecified"); Concurrency_Protected_Access_Name := Get_String_Name ("protected_access"); Concurrency_Priority_Ceiling_Name := Get_String_Name ("priority_ceiling"); Language_Ada_95_Name := Get_String_Name ("ada95"); Language_Ada_Name := Get_String_Name ("ada"); Language_Ada_05_Name := Get_String_Name ("ada05"); Language_C_Name := Get_String_Name ("c"); Language_ASN1_Name := Get_String_Name ("asn1"); Language_Lustre_Name := Get_String_Name ("lustre"); Language_Lustre_Name := Get_String_Name ("lustre"); Language_Lustre5_Name := Get_String_Name ("lustre5"); Language_Lustre6_Name := Get_String_Name ("lustre6"); Thread_Periodic_Name := Get_String_Name ("periodic"); Thread_Aperiodic_Name := Get_String_Name ("aperiodic"); Thread_Sporadic_Name := Get_String_Name ("sporadic"); Time_Ps_Name := Get_String_Name ("ps"); Time_Ns_Name := Get_String_Name ("ns"); Time_Us_Name := Get_String_Name ("us"); Time_Ms_Name := Get_String_Name ("ms"); Time_Sec_Name := Get_String_Name ("sec"); Time_Min_Name := Get_String_Name ("min"); Time_Hr_Name := Get_String_Name ("hr"); Size_Bit_Name := Get_String_Name ("bits"); Size_Byte_Name := Get_String_Name ("b"); Size_Kilo_Byte_Name := Get_String_Name ("kb"); Size_Mega_Byte_Name := Get_String_Name ("mb"); Size_Giga_Byte_Name := Get_String_Name ("gb"); Platform_Native_Name := Get_String_Name ("native"); Platform_LEON_RTEMS_Name := Get_String_Name ("leon_rtems"); Platform_LEON_ORK_Name := Get_String_Name ("leon_ork"); Platform_ERC32_ORK_Name := Get_String_Name ("erc32_ork"); Platform_ARM_DSLINUX_Name := Get_String_Name ("arm_dslinux"); Platform_ARM_N770_Name := Get_String_Name ("arm_n770"); Transport_BSD_Sockets_Name := Get_String_Name ("bsd_sockets"); Transport_SpaceWire_Name := Get_String_Name ("spacewire"); Protocol_IIOP_Name := Get_String_Name ("iiop"); Protocol_DIOP_Name := Get_String_Name ("diop"); end Init; end Ocarina.Generators.Properties;