taste-semantic_check.adb 7.96 KB
Newer Older
1
with Ada.Strings.Unbounded,
2
     Ada.Containers,
3
     --  Ocarina.Backends.Properties,
4
     TASTE.Deployment_View,
Maxime Perrotin's avatar
Maxime Perrotin committed
5
     TASTE.Interface_View,
6 7 8
     TASTE.Parser_Utils;

use Ada.Strings.Unbounded,
9
    Ada.Containers,
10
    --  Ocarina.Backends.Properties,
11
    TASTE.Deployment_View,
Maxime Perrotin's avatar
Maxime Perrotin committed
12
    TASTE.Interface_View,
13
    TASTE.Interface_View.Interfaces_Maps,
14 15 16
    TASTE.Parser_Utils;

package body TASTE.Semantic_Check is
17
   --  use String_Vectors;
18 19
   procedure Check_Model (Model : TASTE_Model) is
      use Option_Partition;
20
      Opt_Part     : Option_Partition.Option;
21 22 23
   begin
      if Model.Configuration.Glue then
         for Each of Model.Interface_View.Flat_Functions loop
24
            Opt_Part  := Model.Find_Binding (Each.Name);
25
            --  Check that each function is placed on a partition
26
            if not Each.Is_Type and then not Opt_Part.Has_Value then
27 28 29 30
               raise Semantic_Error with
                "In the deployment view, the function " & To_String (Each.Name)
                & " is not bound to any partition!";
            end if;
31 32 33

            --  Check that functions have at least one PI
            --  with the exception of GUIs and Blackbox devices
34 35
            if Each.Language /= "gui"
               and then Each.Language /= "blackbox_device"
36 37 38 39 40 41 42
               and then Each.Provided.Length = 0
            then
               raise Semantic_Error with
                  "Function " & To_String (Each.Name) & " has no provided "
                  & "interfaces, and dead code is not allowed";
            end if;

43
            --  Check that Simulink functions have exactly one PI and no RI
44 45 46 47 48
            if (Each.Language    = "simulink"
                or Each.Language = "qgenada"
                or Each.Language = "qgenc")
                and then (Each.Provided.Length /= 1
                          or Each.Required.Length /= 0)
49 50
            then
               raise Semantic_Error with
Maxime Perrotin's avatar
Maxime Perrotin committed
51 52 53 54 55
                  "Function " & To_String (Each.Name) & " must contain only "
                  & "one Provided Interface and no Required Interfaces";
            end if;

            --  Check that Simulink/QGen functions's PI is synchronous
56 57 58
            if Each.Language    = "simulink"
               or Each.Language = "qgenada"
               or Each.Language = "qgenc"
Maxime Perrotin's avatar
Maxime Perrotin committed
59 60 61 62 63 64 65 66 67 68
            then
               for PI of Each.Provided loop
                  if PI.RCM /= Unprotected_Operation
                     and PI.RCM /= Protected_Operation
                  then
                     raise Semantic_Error with "The provided interface of "
                     & "function " & To_String (Each.Name) & " must be either"
                     & " protected or unprotected, but not sporadic or cyclic";
                  end if;
               end loop;
69 70
            end if;

71 72
            --  GUI checks:
            --  1) interfaces must all have a parameter
73
            --  2) interfaces must all be sporadic (TODO)
74
            if Each.Language = "gui" and then
Maxime Perrotin's avatar
Maxime Perrotin committed
75 76 77 78
               ((Each.Provided.Length > 0 and then
                   (for all I of Each.Provided => I.Params.Length /= 1))
               or else (Each.Required.Length > 0 and then
                   (for all I of Each.Required  => I.Params.Length /= 1)))
79
            then
Maxime Perrotin's avatar
Maxime Perrotin committed
80 81 82 83 84 85 86 87
               for I of Each.Provided loop
                  Put_Error ("PI " & To_String (I.Name) & " has "
                             & I.Params.Length'Img & " parameters");
               end loop;
               for I of Each.Required loop
                  Put_Error ("RI " & To_String (I.Name) & " has "
                             & I.Params.Length'Img & " parameters");
               end loop;
88 89 90 91
               raise Semantic_Error with
                     "Function " & To_String (Each.Name) & "'s interfaces"
                     & " must all have exactly one parameter";
            end if;
92 93

            for PI of Each.Provided loop
94 95
               --  Check that functions including at least one (un)protected
               --  interface are located on the same partition as their callers
96 97 98 99
               if not Each.Is_Type and then (PI.RCM = Protected_Operation
                                          or PI.RCM = Unprotected_Operation)
               then
                  for Remote of PI.Remote_Interfaces loop
100 101
                     if not Opt_Part.Unsafe_Just.Bound_Functions.Contains
                       (To_String (Remote.Function_Name))
102 103 104 105 106 107 108 109 110
                     then
                        raise Semantic_Error with "Function "
                        & To_String (Each.Name) & " and function "
                        & To_String (Remote.Function_Name) & " must be located"
                        & " on the same partition in the deployment view, "
                        & "because they share a synchronous interface";
                     end if;
                  end loop;
               end if;
111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129

               --  Check that Cyclic PIs are not connected and that they have
               --  no parameters.
               if PI.RCM = Cyclic_Operation and then
                  (PI.Remote_Interfaces.Length > 0 or PI.Params.Length > 0)
               then
                  raise Semantic_Error with "Interface " & To_String (PI.Name)
                  & " in function " & To_String (Each.Name) & " is incorrect: "
                  & "it shall have no parameters and shall not be connected";

                  --  Check that sporadic PIs have at most one IN pararmeter
               elsif PI.RCM = Sporadic_Operation and then
                  (PI.Params.Length > 1 or (PI.Params.Length = 1 and
                  (for all Param of PI.Params => Param.Direction /= param_in)))
               then
                  raise Semantic_Error with "Interface " & To_String (PI.Name)
                  & " in function " & To_String (Each.Name) & " is incorrect: "
                  & "it shall have at most one IN parameter (no OUT param)";
               end if;
130 131
            end loop;

Maxime Perrotin's avatar
Maxime Perrotin committed
132
            --  Component type/instance checks
133 134 135 136
            if Each.Is_Type
               and Each.Language /= "ada"
               and Each.Language /= "sdl"
               and Each.Language /= "cpp"
Maxime Perrotin's avatar
Maxime Perrotin committed
137 138
            then
               raise Semantic_Error with "Function " & To_String (Each.Name)
139 140
               & " can be a type only if it is implemented in Ada, C++ or SDL"
               & " (not " & To_String (Each.Language) & ")";
Maxime Perrotin's avatar
Maxime Perrotin committed
141 142 143 144 145 146 147 148 149 150 151 152 153 154 155
            end if;

            if Each.Instance_Of.Has_Value then
               begin
                  declare
                     Corresponding_Type : constant Taste_Terminal_Function :=
                        Model.Interface_View.Flat_Functions.Element
                           (To_String (Each.Instance_Of.Unsafe_Just));
                  begin
                     if not Corresponding_Type.Is_Type then
                        raise Semantic_Error with "Function "
                        & To_String (Each.Name) & " is an instance of "
                        & To_String (Corresponding_Type.Name) & " which is NOT"
                        & " a type";
                     end if;
156 157 158 159 160 161 162 163 164 165 166 167 168

                     --  Much check that PIs and RIs of type and instance match
                     for PI of Each.Provided loop
                        null;
                     end loop;

                     for RI of Each.Required loop
                        null;
                     end loop;

--                      raise Semantic_Error with "Interface mismatch between "
--                      & "functions " & To_String (Corresponding_Type.Name) &
--                      " (type) and " & To_String (Each.Name) & " (instance)";
Maxime Perrotin's avatar
Maxime Perrotin committed
169 170 171 172 173 174 175 176 177
                  end;
               exception
                  when Constraint_Error =>
                     --  if call to Element did not return anything
                     raise Semantic_Error with "Function not found : "
                     & To_String (Each.Instance_Of.Unsafe_Just) & " (specified"
                     & " as type of function " & To_String (Each.Name) & ")";
               end;
            end if;
178 179 180 181 182
         end loop;
      end if;
   end Check_Model;

end TASTE.Semantic_Check;