ocarina-backends-properties-utils.adb 15.4 KB
Newer Older
1 2 3 4 5 6 7 8
------------------------------------------------------------------------------
--                                                                          --
--                           OCARINA COMPONENTS                             --
--                                                                          --
--    O C A R I N A . B A C K E N D S . P R O P E R T I E S . U T I L S     --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25
--                   Copyright (C) 2014-2015 ESA & ISAE.                    --
--                                                                          --
-- Ocarina  is free software; you can redistribute it and/or modify under   --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion. 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.                     --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
26 27 28 29 30 31
--                                                                          --
--                 Ocarina is maintained by the TASTE project               --
--                      (taste-users@lists.tuxfamily.org)                   --
--                                                                          --
------------------------------------------------------------------------------

yoogx's avatar
yoogx committed
32
with Ocarina.Backends.Messages;
33
with Ocarina.Instances.Queries;
yoogx's avatar
yoogx committed
34 35
with Ocarina.ME_AADL.AADL_Instances.Nodes;
with Ocarina.Namet;
36
with Charset; use Charset;
37 38
with Utils;
with Ocarina.ME_AADL.AADL_Tree.Nodes;
yoogx's avatar
yoogx committed
39
with Ocarina.ME_AADL.AADL_Tree.Nutils;
40 41

package body Ocarina.Backends.Properties.Utils is
yoogx's avatar
yoogx committed
42 43

   use Ocarina.Backends.Messages;
44
   use Ocarina.Instances.Queries;
yoogx's avatar
yoogx committed
45 46
   use Ocarina.ME_AADL.AADL_Instances.Nodes;
   use Ocarina.Namet;
47 48 49
   use Standard.Utils;

   package ATN renames Ocarina.ME_AADL.AADL_Tree.Nodes;
50
   package AIN renames Ocarina.ME_AADL.AADL_Instances.Nodes;
yoogx's avatar
yoogx committed
51
   package ATNU renames Ocarina.ME_AADL.AADL_Tree.Nutils;
52 53 54 55 56 57 58 59 60
   use type ATN.Node_Kind;

   function SA (S : String) return String_Access is (new String'(S));

   -----------------------------------------
   -- Print_Value_Of_Property_Association --
   -----------------------------------------

   function Print_Value_Of_Property_Association
yoogx's avatar
yoogx committed
61
     (AADL_Property_Value : Node_Id) return String;
62 63

   function Print_Value_Of_Property_Association
yoogx's avatar
yoogx committed
64 65
     (AADL_Property_Value : Node_Id) return String
   is
66 67 68 69 70
   begin
      if Present (AADL_Property_Value)
        and then ATN.Kind (AADL_Property_Value) = ATN.K_Signed_AADLNumber
      then
         return Ocarina.AADL_Values.Image
yoogx's avatar
yoogx committed
71 72 73 74 75 76 77 78
             (ATN.Value (ATN.Number_Value (AADL_Property_Value))) &
           " " &
           (if
              Present (ATN.Unit_Identifier (AADL_Property_Value))
            then
              Get_Name_String
                (ATN.Display_Name (ATN.Unit_Identifier (AADL_Property_Value)))
            else "");
79 80 81 82 83 84 85

      elsif Present (AADL_Property_Value)
        and then ATN.Kind (AADL_Property_Value) = ATN.K_Literal
      then
         --  This property value denotes a literal

         return Ocarina.AADL_Values.Image
yoogx's avatar
yoogx committed
86 87
             (ATN.Value (AADL_Property_Value),
              Quoted => False);
88 89 90 91 92 93

      elsif Present (AADL_Property_Value)
        and then ATN.Kind (AADL_Property_Value) = ATN.K_Reference_Term
      then
         --  This property value denotes a reference term

yoogx's avatar
yoogx committed
94 95 96 97 98
         return Get_Name_String
             (ATN.Display_Name
                (ATN.First_Node --  XXX must iterate
                   (ATN.List_Items
                      (ATN.Reference_Term (AADL_Property_Value)))));
99 100 101 102

      elsif Present (AADL_Property_Value)
        and then ATN.Kind (AADL_Property_Value) = ATN.K_Enumeration_Term
      then
yoogx's avatar
yoogx committed
103
         --  This property value denotes an enumeration term
104

yoogx's avatar
yoogx committed
105 106
         return Get_Name_String
             (ATN.Display_Name (ATN.Identifier (AADL_Property_Value)));
107 108 109 110 111 112 113

      elsif Present (AADL_Property_Value)
        and then ATN.Kind (AADL_Property_Value) = ATN.K_Number_Range_Term
      then
         --  This property value denotes a number range term

         return Ocarina.AADL_Values.Image
yoogx's avatar
yoogx committed
114 115 116 117 118 119 120 121 122
             (ATN.Value
                (ATN.Number_Value (ATN.Lower_Bound (AADL_Property_Value)))) &
           (if
              Present
                (ATN.Unit_Identifier (ATN.Lower_Bound (AADL_Property_Value)))
            then
              " " &
              Get_Name_String
                (ATN.Display_Name
123
                   (ATN.Unit_Identifier
yoogx's avatar
yoogx committed
124 125 126 127 128 129 130 131 132 133 134 135
                      (ATN.Lower_Bound (AADL_Property_Value))))
            else "") &
           " .. " &
           Ocarina.AADL_Values.Image
             (ATN.Value
                (ATN.Number_Value (ATN.Upper_Bound (AADL_Property_Value)))) &
           (if
              Present
                (ATN.Unit_Identifier (ATN.Upper_Bound (AADL_Property_Value)))
            then
              " " &
              Get_Name_String
136 137
                (ATN.Display_Name
                   (ATN.Unit_Identifier
yoogx's avatar
yoogx committed
138 139
                      (ATN.Upper_Bound (AADL_Property_Value))))
            else "");
140 141 142 143
      end if;

      raise Program_Error;
   end Print_Value_Of_Property_Association;
144 145 146 147 148

   ----------------------------
   -- Check_And_Get_Property --
   ----------------------------

149
   function Check_And_Get_Property
yoogx's avatar
yoogx committed
150 151
     (E        : Node_Id;
      Property : Node_Id) return String_List
152
   is
yoogx's avatar
yoogx committed
153 154
      Prop_Name : constant Name_Id :=
        Standard.Utils.To_Lower (Display_Name (Identifier (Property)));
155 156 157 158 159
   begin
      return Check_And_Get_Property (E, Prop_Name);
   end Check_And_Get_Property;

   function Check_And_Get_Property
yoogx's avatar
yoogx committed
160 161
     (E         : Node_Id;
      Prop_Name : Name_Id) return String_List
162
   is
yoogx's avatar
yoogx committed
163
      A : constant String_Access := new String'(Get_Name_String (Prop_Name));
164 165 166 167
      AADL_Property_Value : Node_Id;

   begin
      if Is_Defined_String_Property (E, Prop_Name) then
yoogx's avatar
yoogx committed
168
         return A & SA (Get_Name_String (Get_String_Property (E, Prop_Name)));
169

yoogx's avatar
yoogx committed
170 171 172
      elsif
        (Is_Defined_Integer_Property (E, Prop_Name)
         or else Is_Defined_Float_Property (E, Prop_Name))
173 174 175
      then
         AADL_Property_Value :=
           Get_Value_Of_Property_Association (E, Prop_Name);
yoogx's avatar
yoogx committed
176 177
         return A &
           SA (Print_Value_Of_Property_Association (AADL_Property_Value));
178 179

      elsif Is_Defined_Boolean_Property (E, Prop_Name) then
yoogx's avatar
yoogx committed
180
         return A & SA (Boolean'Image (Get_Boolean_Property (E, Prop_Name)));
181 182 183 184 185 186 187 188 189

      elsif Is_Defined_Reference_Property (E, Prop_Name) then
         return A & SA (Get_Reference_Property (E, Prop_Name)'Img);

      elsif Is_Defined_Classifier_Property (E, Prop_Name) then
         return A & SA (Get_Classifier_Property (E, Prop_Name)'Img);

      elsif Is_Defined_Range_Property (E, Prop_Name) then
         AADL_Property_Value := Get_Range_Property (E, Prop_Name);
yoogx's avatar
yoogx committed
190 191
         return A &
           SA (Print_Value_Of_Property_Association (AADL_Property_Value));
192 193 194

      elsif Is_Defined_List_Property (E, Prop_Name) then
         declare
yoogx's avatar
yoogx committed
195 196 197
            It : Node_Id := ATN.First_Node (Get_List_Property (E, Prop_Name));
            B  : String_List
            (1 .. ATNU.Length (Get_List_Property (E, Prop_Name)));
198 199 200 201
            J : Integer := B'First;
         begin
            while Present (It) loop
               B (J) := new String'(Print_Value_Of_Property_Association (It));
yoogx's avatar
yoogx committed
202 203
               J     := J + 1;
               It    := ATN.Next_Node (It);
204 205 206 207 208
            end loop;
            return A & B;
         end;

      elsif Is_Defined_Enumeration_Property (E, Prop_Name) then
yoogx's avatar
yoogx committed
209 210
         return A &
           SA (Get_Name_String (Get_Enumeration_Property (E, Prop_Name)));
211 212 213 214 215
      end if;

      return A & SA (" KO");
   end Check_And_Get_Property;

216
   function Check_And_Get_Property
yoogx's avatar
yoogx committed
217
     (E             : Node_Id;
218
      Property_Name : Name_Id;
yoogx's avatar
yoogx committed
219 220
      Default_Value : Unsigned_Long_Long := 0) return Unsigned_Long_Long
   is
221 222 223 224 225 226 227 228
   begin
      if Is_Defined_Integer_Property (E, Property_Name) then
         return Get_Integer_Property (E, Property_Name);
      else
         return Default_Value;
      end if;
   end Check_And_Get_Property;

yoogx's avatar
yoogx committed
229
   function Check_And_Get_Property
yoogx's avatar
yoogx committed
230
     (E             : Node_Id;
yoogx's avatar
yoogx committed
231
      Property_Name : Name_Id;
yoogx's avatar
yoogx committed
232 233
      Default_Value : Name_Id := No_Name) return Name_Id
   is
yoogx's avatar
yoogx committed
234 235 236 237 238 239 240 241 242
   begin
      if Is_Defined_String_Property (E, Property_Name) then
         return Get_String_Property (E, Property_Name);
      else
         return Default_Value;
      end if;
   end Check_And_Get_Property;

   function Check_And_Get_Property
yoogx's avatar
yoogx committed
243
     (E             : Node_Id;
yoogx's avatar
yoogx committed
244
      Property_Name : Name_Id;
yoogx's avatar
yoogx committed
245 246
      Default_Value : Node_Id := No_Node) return Node_Id
   is
yoogx's avatar
yoogx committed
247 248 249 250 251 252 253 254
   begin
      if Is_Defined_Property (E, Property_Name) then
         return Get_Classifier_Property (E, Property_Name);
      else
         return Default_Value;
      end if;
   end Check_And_Get_Property;

yoogx's avatar
yoogx committed
255
   function Check_And_Get_Property
yoogx's avatar
yoogx committed
256
     (E             : Node_Id;
yoogx's avatar
yoogx committed
257
      Property_Name : Name_Id;
yoogx's avatar
yoogx committed
258 259
      Default_Value : List_Id := No_List) return List_Id
   is
yoogx's avatar
yoogx committed
260 261 262 263 264 265 266 267
   begin
      if Is_Defined_List_Property (E, Property_Name) then
         return Get_List_Property (E, Property_Name);
      else
         return Default_Value;
      end if;
   end Check_And_Get_Property;

yoogx's avatar
yoogx committed
268
   function Check_And_Get_Property
yoogx's avatar
yoogx committed
269
     (E             : Node_Id;
yoogx's avatar
yoogx committed
270
      Property_Name : Name_Id;
yoogx's avatar
yoogx committed
271 272
      Default_Value : Boolean := False) return Boolean
   is
yoogx's avatar
yoogx committed
273 274 275 276 277 278 279 280
   begin
      if Is_Defined_Boolean_Property (E, Property_Name) then
         return Get_Boolean_Property (E, Property_Name);
      else
         return Default_Value;
      end if;
   end Check_And_Get_Property;

yoogx's avatar
yoogx committed
281
   function Check_And_Get_Property
yoogx's avatar
yoogx committed
282
     (E             : Node_Id;
yoogx's avatar
yoogx committed
283
      Property_Name : Name_Id;
yoogx's avatar
yoogx committed
284 285
      Names         : Name_Array;
      Default_Value : Int := Int'First) return Int
yoogx's avatar
yoogx committed
286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306
   is
      P_Name : Name_Id;
   begin
      if not Is_Defined_Enumeration_Property (E, Property_Name) then
         return Default_Value;
      end if;

      P_Name := Get_Enumeration_Property (E, Property_Name);
      for J in Names'Range loop
         if P_Name = Names (J) then
            return J;
         end if;
      end loop;

      Display_Located_Error
        (Loc (E),
         "Unknown enumerator " & Get_Name_String (P_Name),
         Fatal => True);
      return Default_Value;
   end Check_And_Get_Property;

307
   function Check_And_Get_Property_Enumerator
yoogx's avatar
yoogx committed
308 309
     (E             : Node_Id;
      Property_Name : Name_Id) return T
310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336
   is
      Enumerator : Name_Id;
   begin
      if not Is_Defined_Enumeration_Property (E, Property_Name) then
         Display_Located_Error
           (AIN.Loc (E),
            "Property " & Get_Name_String (Property_Name) & " not defined",
            Fatal => True);
         raise Program_Error;
      end if;

      Enumerator := Get_Enumeration_Property (E, Property_Name);
      for Elt in T'Range loop
         if To_Upper (Get_Name_String (Enumerator)) = Elt'Img then
            return Elt;
         end if;
      end loop;

      Display_Located_Error
        (AIN.Loc (E),
         "Enumerator """ & Get_Name_String (Enumerator) & """ not supported",
         Fatal => True);

      raise Program_Error;
   end Check_And_Get_Property_Enumerator;

   function Check_And_Get_Property_Enumerator_With_Default
yoogx's avatar
yoogx committed
337 338
     (E             : Node_Id;
      Property_Name : Name_Id) return T
339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366
   is
      Enumerator : Name_Id;
   begin
      if not Is_Defined_Enumeration_Property (E, Property_Name) then
         return Default_Value;
      end if;

      Enumerator := Get_Enumeration_Property (E, Property_Name);
      declare
         Enumerator_String : constant String :=
           To_Upper (Get_Name_String (Enumerator));
      begin
         for Elt in T'Range loop
            if Enumerator_String = Elt'Img then
               return Elt;
            end if;
         end loop;
      end;

      Display_Located_Error
        (AIN.Loc (E),
         "Enumerator " & Get_Name_String (Enumerator) & " not supported",
         Fatal => True);

      raise Program_Error;
   end Check_And_Get_Property_Enumerator_With_Default;

   function Check_And_Get_Property
yoogx's avatar
yoogx committed
367 368
     (E             : Node_Id;
      Property_Name : Name_Id) return Name_Array
369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394
   is
      N_List : List_Id;
   begin
      if Is_Defined_List_Property (E, Property_Name) then
         N_List := Get_List_Property (E, Property_Name);

         declare
            L   : constant Nat := Nat (ATNU.Length (N_List));
            Res : Name_Array (1 .. L);
            N   : Node_Id;
         begin
            N := ATN.First_Node (N_List);

            for Elt of Res loop
               Elt := Value (ATN.Value (N)).SVal;
               N   := ATN.Next_Node (N);
            end loop;

            return Res;
         end;
      else
         return Empty_Name_Array;
      end if;
   end Check_And_Get_Property;

   function Check_And_Get_Property_Generic
yoogx's avatar
yoogx committed
395 396
     (E             : Node_Id;
      Property_Name : Name_Id) return Elt_Array
397 398 399 400 401 402 403 404 405 406 407 408 409 410
   is
      D_List : List_Id;
   begin
      if Is_Defined_List_Property (E, Property_Name) then
         D_List := Get_List_Property (E, Property_Name);

         declare
            L   : constant Nat := Nat (ATNU.Length (D_List));
            Res : Elt_Array (1 .. L);
            N   : Node_Id;
         begin
            N := ATN.First_Node (D_List);

            for J in Res'Range loop
yoogx's avatar
yoogx committed
411 412
               Res (J) :=
                 Extract_Value (Value (ATN.Value (ATN.Number_Value (N))));
413

yoogx's avatar
yoogx committed
414
               N := ATN.Next_Node (N);
415 416 417 418 419 420 421 422 423
            end loop;

            return Res;
         end;
      else
         return Default_Value;
      end if;
   end Check_And_Get_Property_Generic;

yoogx's avatar
yoogx committed
424 425 426
   function Check_And_Get_Property_ULL is new Check_And_Get_Property_Generic
     (Elt_Type      => Unsigned_Long_Long,
      Elt_Array     => ULL_Array,
427 428 429 430
      Extract_Value => Extract_Value,
      Default_Value => Empty_ULL_Array);

   function Check_And_Get_Property
yoogx's avatar
yoogx committed
431 432 433 434 435 436 437
     (E             : Node_Id;
      Property_Name : Name_Id) return ULL_Array renames
     Check_And_Get_Property_ULL;

   function Check_And_Get_Property_LL is new Check_And_Get_Property_Generic
     (Elt_Type      => Long_Long,
      Elt_Array     => LL_Array,
438 439 440 441
      Extract_Value => Extract_Value,
      Default_Value => Empty_LL_Array);

   function Check_And_Get_Property
yoogx's avatar
yoogx committed
442 443 444 445 446 447 448
     (E             : Node_Id;
      Property_Name : Name_Id) return LL_Array renames
     Check_And_Get_Property_LL;

   function Check_And_Get_Property_LD is new Check_And_Get_Property_Generic
     (Elt_Type      => Long_Double,
      Elt_Array     => LD_Array,
449 450 451 452
      Extract_Value => Extract_Value,
      Default_Value => Empty_LD_Array);

   function Check_And_Get_Property
yoogx's avatar
yoogx committed
453 454 455
     (E             : Node_Id;
      Property_Name : Name_Id) return LD_Array renames
     Check_And_Get_Property_LD;
456

457
end Ocarina.Backends.Properties.Utils;