------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- Cheddar is a GNU GPL real-time scheduling analysis tool. -- This program provides services to automatically check schedulability and -- other performance criteria of real-time architecture models. -- -- Copyright (C) 2002-2020, Frank Singhoff, Alain Plantec, Jerome Legrand, -- Hai Nam Tran, Stephane Rubini -- -- The Cheddar project was started in 2002 by -- Frank Singhoff, Lab-STICC UMR 6285, Université de Bretagne Occidentale -- -- Cheddar has been published in the "Agence de Protection des Programmes/France" in 2008. -- Since 2008, Ellidiss technologies also contributes to the development of -- Cheddar and provides industrial support. -- -- The full list of contributors and sponsors can be found in AUTHORS.txt and SPONSORS.txt -- -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This program 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 -- along with this program; if not, write to the Free Software -- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -- -- -- Contact : cheddar@listes.univ-brest.fr -- ------------------------------------------------------------------------------ -- Last update : -- $Rev$ -- $Date$ -- $Author: singhoff $ ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ with translate; use translate; with unbounded_strings; use unbounded_strings; with Ada.Exceptions; use Ada.Exceptions; with processors; use processors; with core_units; use core_units; use core_units.core_units_table_package; with objects; use objects; use objects.generic_object_set_package; with objects.extended; use objects.extended; with Text_IO; use Text_IO; with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; with unbounded_strings; use unbounded_strings; use unbounded_strings.strings_table_package; use unbounded_strings.unbounded_string_list_package; with initialize_framework; use initialize_framework; package body deployment_set is procedure check_deployment (my_deployments : in deployments_set; name : in Unbounded_String; resource_entities : in generic_objects_set; consumer_entities : in generic_objects_set; allocation_file : in Unbounded_String; capacity : in Integer; period : in Integer; priority : in Integer; is_preemptive : in preemptives_type; quantum : in Integer; file_name : in Unbounded_String; a_scheduler : in schedulers_type; automaton_name : in Unbounded_String) is begin if name = "" then Raise_Exception (invalid_parameter'identity, To_String (lb_deployment_name (current_language) & lb_mandatory (current_language))); end if; if not is_a_valid_identifier (name) then Raise_Exception (invalid_parameter'identity, To_String (lb_deployment (current_language) & " " & name & " : " & lb_deployment_name (current_language) & lb_colon & lb_invalid_identifier (current_language))); end if; if not is_a_valid_identifier (allocation_file) then Raise_Exception (invalid_parameter'identity, To_String (lb_deployment (current_language) & " " & name & " : allocation file " & lb_colon & lb_invalid_identifier (current_language))); end if; if not is_a_valid_identifier (file_name) then Raise_Exception (invalid_parameter'identity, To_String (lb_deployment (current_language) & " " & name & " : " & lb_file_name (current_language) & lb_colon & lb_invalid_identifier (current_language))); end if; if (allocation_file = empty_string) then if (a_scheduler = pipeline_user_defined_protocol) and (file_name = "") then Raise_Exception (invalid_parameter'identity, To_String (lb_deployment (current_language) & name & " : " & lb_file_name (current_language) & lb_mandatory (current_language))); end if; if (file_name /= "") and (a_scheduler /= pipeline_user_defined_protocol) and (a_scheduler /= automata_user_defined_protocol) then Raise_Exception (invalid_parameter'identity, To_String (lb_deployment (current_language) & name & " : " & lb_file_name_control (current_language))); end if; if period < 0 then Raise_Exception (invalid_parameter'identity, To_String (lb_deployment (current_language) & " " & name & " : " & lb_period (current_language) & lb_must_be (current_language) & lb_greater_or_equal_than (current_language) & To_Unbounded_String ("0"))); end if; if capacity < 0 then Raise_Exception (invalid_parameter'identity, To_String (lb_deployment (current_language) & " " & name & " : " & lb_capacity (current_language) & lb_must_be (current_language) & lb_greater_or_equal_than (current_language) & To_Unbounded_String ("0"))); end if; if (priority < Integer (priority_range'first)) or (priority > Integer (priority_range'last)) then Raise_Exception (invalid_parameter'identity, To_String (lb_deployment (current_language) & " " & name & " : " & lb_invalid_priority (current_language))); end if; if (quantum /= 0) and (a_scheduler /= posix_1003_highest_priority_first_protocol) and (a_scheduler /= round_robin_protocol) and (a_scheduler /= hierarchical_round_robin_protocol) and (a_scheduler /= hierarchical_cyclic_protocol) then Raise_Exception (invalid_parameter'identity, To_String (lb_deployment (current_language) & name & " : " & lb_quantum_control (current_language))); end if; if (quantum < 0) then Raise_Exception (invalid_parameter'identity, To_String (lb_deployment (current_language) & name & " : " & "Quantum" & lb_must_be (current_language) & lb_greater_or_equal_than (current_language) & To_Unbounded_String ("0"))); end if; if (a_scheduler = no_scheduling_protocol) then Raise_Exception (invalid_parameter'identity, To_String (lb_deployment (current_language) & " " & name & " : " & lb_invalid_scheduler (current_language))); end if; end if; if (get_number_of_elements (consumer_entities) = 0) then Raise_Exception (invalid_parameter'identity, To_String (lb_deployment (current_language) & " " & name & " : " & lb_source_set (current_language) & lb_can_not_be_empty (current_language))); end if; if (get_number_of_elements (resource_entities) = 0) then Raise_Exception (invalid_parameter'identity, To_String (lb_deployment (current_language) & " " & name & " : " & lb_sink_set (current_language) & lb_can_not_be_empty (current_language))); end if; end check_deployment; procedure add_deployment (my_deployments : in out deployments_set; name : in Unbounded_String; resource_entities : in generic_objects_set; consumer_entities : in generic_objects_set; allocation_description : in Unbounded_String; capacity : in Integer := 0; period : in Integer := 0; priority : in Integer := 0; is_preemptive : in preemptives_type := preemptive; quantum : in Integer := 0; file_name : in Unbounded_String := empty_string; a_scheduler : in schedulers_type := no_scheduling_protocol; automaton_name : in Unbounded_String := empty_string) is dummy : generic_deployment_ptr; begin add_deployment (my_deployments, dummy, name, resource_entities, consumer_entities, allocation_description, capacity, period, priority, is_preemptive, quantum, file_name, a_scheduler, automaton_name); end add_deployment; procedure add_deployment (my_deployments : in out deployments_set; a_deployment : in out generic_deployment_ptr; name : in Unbounded_String; resource_entities : in generic_objects_set; consumer_entities : in generic_objects_set; allocation_description : in Unbounded_String; capacity : in Integer := 0; period : in Integer := 0; priority : in Integer := 0; is_preemptive : in preemptives_type := preemptive; quantum : in Integer := 0; file_name : in Unbounded_String := empty_string; a_scheduler : in schedulers_type := no_scheduling_protocol; automaton_name : in Unbounded_String := empty_string) is my_iterator : deployments_iterator; begin check_initialize; check_deployment (my_deployments, name, resource_entities, consumer_entities, allocation_description, capacity, period, priority, is_preemptive, quantum, file_name, a_scheduler, automaton_name); if (get_number_of_elements (my_deployments) > 0) then reset_iterator (my_deployments, my_iterator); loop current_element (my_deployments, a_deployment, my_iterator); if (name = a_deployment.name) then Raise_Exception (invalid_parameter'identity, To_String (lb_deployment (current_language) & " " & name & " : " & lb_deployment_name (current_language) & lb_already_defined (current_language))); end if; exit when is_last_element (my_deployments, my_iterator); next_element (my_deployments, my_iterator); end loop; end if; if allocation_description /= empty_string then a_deployment := new static_deployment; a_deployment.deployment_type := static_deployment_type; static_deployment_ptr (a_deployment).allocation_description := allocation_description; else a_deployment := new dynamic_deployment; a_deployment.deployment_type := dynamic_deployment_type; dynamic_deployment_ptr (a_deployment).allocation_parameters .scheduler_type := a_scheduler; dynamic_deployment_ptr (a_deployment).allocation_parameters .capacity := capacity; dynamic_deployment_ptr (a_deployment).allocation_parameters.period := period; dynamic_deployment_ptr (a_deployment).allocation_parameters .priority := priority_range (priority); dynamic_deployment_ptr (a_deployment).allocation_parameters.quantum := quantum; dynamic_deployment_ptr (a_deployment).allocation_parameters .preemptive_type := is_preemptive; dynamic_deployment_ptr (a_deployment).allocation_parameters .automaton_name := automaton_name; dynamic_deployment_ptr (a_deployment).allocation_parameters .user_defined_scheduler_source_file_name := file_name; end if; a_deployment.name := name; a_deployment.consumer_entities := consumer_entities; a_deployment.resource_entities := resource_entities; add (my_deployments, a_deployment); exception when generic_deployment_set.full_set => Raise_Exception (invalid_parameter'identity, To_String (lb_can_not_define_more_deployments (current_language))); end add_deployment; function search_deployment (my_deployments : in deployments_set; name : in Unbounded_String) return generic_deployment_ptr is my_iterator : deployments_iterator; a_deployment : generic_deployment_ptr; result : generic_deployment_ptr; found : Boolean := False; begin if not is_empty (my_deployments) then reset_iterator (my_deployments, my_iterator); loop current_element (my_deployments, a_deployment, my_iterator); if (a_deployment.name = name) then found := True; result := a_deployment; end if; exit when is_last_element (my_deployments, my_iterator); next_element (my_deployments, my_iterator); end loop; end if; if not found then Raise_Exception (deployment_not_found'identity, To_String (lb_deployment_name (current_language) & "=" & name)); end if; return result; end search_deployment; function search_deployment_by_processor_name (my_deployments : in deployments_set; name : in Unbounded_String) return generic_deployment_ptr is my_iterator : deployments_iterator; a_deployment : generic_deployment_ptr; result : generic_deployment_ptr; resource_iterator : generic_object_set_package.iterator; resource_object : generic_object_ptr; found : Boolean := False; begin if not is_empty (my_deployments) then reset_iterator (my_deployments, my_iterator); loop current_element (my_deployments, a_deployment, my_iterator); reset_iterator (a_deployment.resource_entities, resource_iterator); loop current_element (a_deployment.resource_entities, resource_object, resource_iterator); if (resource_object.object_type = processor_object_type) and (named_object_ptr (resource_object).name = name) then found := True; result := a_deployment; end if; exit when is_last_element (a_deployment.resource_entities, resource_iterator); next_element (a_deployment.resource_entities, resource_iterator); end loop; exit when is_last_element (my_deployments, my_iterator); next_element (my_deployments, my_iterator); end loop; end if; if not found then Raise_Exception (deployment_not_found'identity, To_String (lb_deployment_name (current_language) & "=" & name)); end if; return result; end search_deployment_by_processor_name; function search_deployment_by_resource_task_name (my_deployments : in deployments_set; name : in Unbounded_String) return generic_deployment_ptr is my_iterator : deployments_iterator; a_deployment : generic_deployment_ptr; result : generic_deployment_ptr; resource_iterator : generic_object_set_package.iterator; resource_object : generic_object_ptr; found : Boolean := False; begin if not is_empty (my_deployments) then reset_iterator (my_deployments, my_iterator); loop current_element (my_deployments, a_deployment, my_iterator); reset_iterator (a_deployment.resource_entities, resource_iterator); loop current_element (a_deployment.resource_entities, resource_object, resource_iterator); if (resource_object.object_type = task_object_type) and (named_object_ptr (resource_object).name = name) then found := True; result := a_deployment; end if; exit when is_last_element (a_deployment.resource_entities, resource_iterator); next_element (a_deployment.resource_entities, resource_iterator); end loop; exit when is_last_element (my_deployments, my_iterator); next_element (my_deployments, my_iterator); end loop; end if; if not found then Raise_Exception (deployment_not_found'identity, To_String (lb_deployment_name (current_language) & "=" & name)); end if; return result; end search_deployment_by_resource_task_name; function search_deployment_by_consumer_task_name (my_deployments : in deployments_set; name : in Unbounded_String) return generic_deployment_ptr is my_iterator : deployments_iterator; a_deployment : generic_deployment_ptr; result : generic_deployment_ptr; consumer_iterator : generic_object_set_package.iterator; consumer_object : generic_object_ptr; found : Boolean := False; begin if not is_empty (my_deployments) then reset_iterator (my_deployments, my_iterator); loop current_element (my_deployments, a_deployment, my_iterator); reset_iterator (a_deployment.consumer_entities, consumer_iterator); loop current_element (a_deployment.consumer_entities, consumer_object, consumer_iterator); if (consumer_object.object_type = task_object_type) and (named_object_ptr (consumer_object).name = name) then found := True; result := a_deployment; end if; exit when is_last_element (a_deployment.consumer_entities, consumer_iterator); next_element (a_deployment.consumer_entities, consumer_iterator); end loop; exit when is_last_element (my_deployments, my_iterator); next_element (my_deployments, my_iterator); end loop; end if; if not found then Raise_Exception (deployment_not_found'identity, To_String (lb_deployment_name (current_language) & "=" & name)); end if; return result; end search_deployment_by_consumer_task_name; procedure delete_deployment (my_deployments : in out deployments_set; name : in Unbounded_String) is the_deployment : generic_deployment_ptr; begin the_deployment := search_deployment (my_deployments, name); delete (my_deployments, the_deployment); end delete_deployment; end deployment_set;