1
------------------------------------------------------------------------------
2
--                                                                          --
3
--                           OCARINA COMPONENTS                             --
4
--                                                                          --
5
--                 OCARINA.ANALYZER.AADL_EMA.NAMING_RULES                   --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--         Copyright (C) 2016-2019 ESA & ISAE, 2019-2020 OpenAADL           --
10
--                                                                          --
11
-- Ocarina  is free software; you can redistribute it and/or modify under   --
12
-- terms of the  GNU General Public License as published  by the Free Soft- --
13
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14
-- sion. Ocarina is distributed in the hope that it will be useful, but     --
15
-- WITHOUT ANY WARRANTY; without even the implied warranty of               --
16
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                     --
17
--                                                                          --
18
-- As a special exception under Section 7 of GPL version 3, you are granted --
19
-- additional permissions described in the GCC Runtime Library Exception,   --
20
-- version 3.1, as published by the Free Software Foundation.               --
21
--                                                                          --
22
-- You should have received a copy of the GNU General Public License and    --
23
-- a copy of the GCC Runtime Library Exception along with this program;     --
24
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
25
-- <http://www.gnu.org/licenses/>.                                          --
26
--                                                                          --
27
--                    Ocarina is maintained by OpenAADL team                --
28
--                              (info@openaadl.org)                         --
29
--                                                                          --
30
------------------------------------------------------------------------------
31

32
with Ocarina.Namet;   use Ocarina.Namet;
33
with Ada.Text_IO;     use Ada.Text_IO;
34

35
with Ocarina.ME_AADL_EMA.EMA_Tree.Nodes;
36
with Ocarina.ME_AADL_EMA.EMA_Tree.Nutils;
37
with Ocarina.ME_AADL.AADL_Tree.Nutils;
38
with Ocarina.Analyzer.AADL_EMA.Finder;
39
with Ocarina.Analyzer.AADL_EMA.Links;
40
with Ocarina.ME_AADL.AADL_Tree.Nodes;
41

42
package body Ocarina.Analyzer.AADL_EMA.Naming_Rules is
43

44
   use Ocarina.ME_AADL_EMA.EMA_Tree.Nodes;
45
   use Ocarina.ME_AADL_EMA.EMA_Tree.Nutils;
46
   use Ocarina.Analyzer.AADL_EMA.Finder;
47
   use Ocarina.Analyzer.AADL_EMA.Links;
48

49
   package EMATN renames Ocarina.ME_AADL_EMA.EMA_Tree.Nodes;
50
   package ATN renames Ocarina.ME_AADL.AADL_Tree.Nodes;
51

52
   function Check_All_Error_Type_Library_List
53
     (Root : Node_Id;
54
      EMA_Root : Node_Id;
55
      Package_Spec : Node_Id := No_Node)
56
     return Boolean;
57
   function Check_Error_Type_Library_Extended
58
      (AADL_Root           : Node_Id;
59
       EMA_Root            : Node_Id;
60
       Error_Type_Local_Id : Node_Id)
61
     return Boolean;
62
   function Check_Conflict_Local_Identifiers_Extends_Clause
63
     (AADL_Root           : Node_Id;
64
      List_Extended       : List_Id;
65
      Error_Type_Local_Id : Node_Id)
66
     return Boolean;
67
   procedure Check_Error_Type_Library_List
68
     (Error_Type_Library_List   : List_Id;
69
      Root                      : Node_Id;
70
      Package_Spec              : Node_Id;
71
      Test_Renamed_Package      : Boolean := False;
72
      Package_Renamed_First     : in out Node_Id;
73
      Package_Renamed_Last      : in out Node_Id;
74
      Package_Spec_First        : in out Node_Id;
75
      Package_Spec_Last         : in out Node_Id;
76
      Check_Renamed_Package     : Boolean := False;
77
      Test_Exist_Error_Type_Lib : Boolean;
78
      Final_Result              : out Boolean);
79
   function Test_Extended_Library_Redundancy
80
      (Error_Model           : Node_Id;
81
       Package_Spec_First    : Node_Id;
82
       Package_Renamed_First : Node_Id)
83
      return Boolean;
84
   function Exist_Of_Error_Type_Library
85
      (Root         : Node_Id;
86
       Package_Spec : Node_Id)
87
     return Boolean;
88
   function Check_Identifiers_Error_Type_Library_List
89
        (List_Used     : List_Id;
90
         List_Extended : List_Id) return Boolean;
91
   procedure Affiche (Pckg_Name : Node_Id;
92
                      Is_AADL   : Boolean);
93
   procedure Check_Unique_Identifier_Error_Type_Library_Element
94
      (EMA_Root      : Node_Id;
95
       Id_First_Node : in out Node_Id;
96
       Id_Last_Node  : in out Node_Id;
97
       Success       : out Boolean);
98
   function Check_Unique_Identifier
99
      (First_Node_List : Node_Id)
100
      return Boolean;
101
   function Check_All_Error_Type_Reference
102
      (AADL_Root    : Node_Id;
103
       EMA_Root     : Node_Id;
104
       Package_Spec : Node_Id)
105
      return Boolean;
106
   function Check_Error_Type_Reference_Of_Error_Type_Library
107
      (AADL_Root     : Node_Id;
108
       EMA_Root      : Node_Id;
109
       Package_Spec  : Node_Id)
110
      return Boolean;
111
   function Check_Error_Type_Set_Reference_Of_Error_Type_Library
112
      (AADL_Root     : Node_Id;
113
       EMA_Root      : Node_Id;
114
       Package_Spec  : Node_Id)
115
      return Boolean;
116
   function Check_Referenced_Error_Type_Common_Function
117
      (AADL_Root          : Node_Id;
118
       EMA_Root           : Node_Id;
119
       Parent_Nodes_First : Node_Id;
120
       Package_Spec       : Node_Id;
121
       Is_Set             : Boolean)
122
      return Boolean;
123
   function Check_Error_Type_Reference
124
       (AADL_Root               : Node_Id;
125
        Package_Container       : Node_Id := No_Node;
126
        Parent_Node             : Node_Id;
127
        List_Used               : List_Id;
128
        Is_Set                  : Boolean;
129
        Error_Type_Library_Node : Node_Id := No_Node)
130
       return Boolean;
131
   function Test_Local_Reference_Error_Type_Library
132
       (Error_Type_Library_Node : Node_Id;
133
        Parent_Node             : Node_Id;
134
        Reference_Identifier    : Node_Id;
135
        Is_Set                  : Boolean)
136
      return Boolean;
137
   function Compare_Reference_With_Local
138
      (Parent_Node_References : Node_Id;
139
       Id                     : Node_Id;
140
       Parent_Node            : Node_Id;
141
       Reference_Identifier   : Node_Id)
142
     return Boolean;
143
   function Check_All_Error_Type_Set_Reference
144
      (AADL_Root    : Node_Id;
145
       EMA_Root     : Node_Id;
146
       Package_Spec : Node_Id)
147
      return Boolean;
148
   procedure Search_Reference_In_List
149
     (Id              : Node_Id;
150
      List_First_Node : Node_Id;
151
      Node_Referenced : out Node_Id);
152
   function Check_Referenced_Error_Type_In_Package
153
         (AADL_Root     : Node_Id;
154
          Pckg_Spec     : Node_Id;
155
          Error_Type_Id : Node_Id;
156
          Is_Set        : Boolean)
157
      return Boolean;
158
   function Search_Reference_In_List_Node
159
     (Id              : Node_Id;
160
      List_First_Node : Node_Id)
161
     return Boolean;
162

163
   ---------------------------------------
164
   -- Check_All_Error_Type_Library_List --
165
   ---------------------------------------
166

167
   --  In error_model_library :
168
   --  the node error_type_library cannot use or extend
169
   --  the same package
170
   --  but other nodes in error_model_library can use types in the
171
   --  same_package
172

173 0
   function Check_All_Error_Type_Library_List
174
     (Root : Node_Id;
175
      EMA_Root : Node_Id;
176
      Package_Spec : Node_Id := No_Node)
177
     return Boolean
178
   is
179
      pragma Assert
180 0
        (Kind (EMA_Root) = K_Annex_Library
181 0
         or else Kind (EMA_Root) = K_Annex_Subclause);
182

183 0
      Parent : Node_Id;
184 0
      List : List_Id;
185 0
      List_Used : List_Id;
186 0
      List_Extended : List_Id;
187 0
      Success : Boolean := True;
188

189 0
      Sub_Node : Node_Id := No_Node;
190 0
      Sub_List : List_Id := No_List;
191 0
      Use_Error_Types_Node : Node_Id;
192

193 0
      Package_Renamed_First : Node_Id := No_Node;
194 0
      Package_Renamed_Last : Node_Id := No_Node;
195 0
      Package_Spec_First : Node_Id := No_Node;
196 0
      Package_Spec_Last : Node_Id := No_Node;
197 0
      Final_Result : Boolean;
198 0
      Check_Renamed_Package : Boolean := False;
199 0
      Test_Renamed_Package : Boolean := False;
200 0
      Test_Exist_Error_Type_Lib : Boolean := True;
201
   begin
202 0
      case Kind (EMA_Root) is
203

204
         when K_Annex_Library =>
205
            --  K_Annex_Library
206
            --     Check if packages are correct
207 0
            Parent := Error_Type_Library (EMA_Root);
208

209 0
            if Present (Parent) then
210 0
               List_Used := Error_Type_Library_List_Used (Parent);
211 0
               List_Extended := Error_Type_Library_List_Extended (Parent);
212

213 0
               if not Is_Empty (List_Used) and then
214 0
                  not Is_Empty (List_Extended)
215
               then
216 0
                  Test_Renamed_Package := True;
217
               end if;
218

219 0
               Check_Error_Type_Library_List
220
               (List_Used, Root, Package_Spec,
221
                Test_Renamed_Package,
222
                Package_Renamed_First,
223
                Package_Renamed_Last,
224
                Package_Spec_First,
225
                Package_Spec_Last,
226
                False,
227
                True,
228
                Final_Result);
229 0
               Success := Final_Result;
230

231 0
               if Test_Renamed_Package then
232 0
                  Check_Renamed_Package := True;
233
               else
234 0
                  Check_Renamed_Package := False;
235
               end if;
236

237 0
               Test_Exist_Error_Type_Lib := False;
238

239 0
               Check_Error_Type_Library_List
240
               (List_Extended, Root, Package_Spec,
241
                Test_Renamed_Package,
242
                Package_Renamed_First,
243
                Package_Renamed_Last,
244
                Package_Spec_First,
245
                Package_Spec_Last,
246
                Check_Renamed_Package,
247
                Test_Exist_Error_Type_Lib,
248
                Final_Result);
249 0
               Success := Success and then Final_Result;
250

251
               --     Check redundant packages
252 0
               Success := Success and then
253 0
                          Check_Identifiers_Error_Type_Library_List
254
                          (List_Used, List_Extended);
255

256
            end if;
257

258
            --  Initialize variables
259 0
            Test_Renamed_Package := False;
260 0
            Check_Renamed_Package := False;
261 0
            Test_Exist_Error_Type_Lib := True;
262

263
            --  K_Error_Behavior_State_Machine
264 0
            Sub_List := Error_Behavior_State_Machine_List (EMA_Root);
265 0
            if not Is_Empty (Sub_List) then
266 0
               Sub_Node := First_Node (Sub_List);
267
            end if;
268

269 0
            while Present (Sub_Node) loop
270 0
               List := Error_Type_Library_List (Sub_Node);
271 0
               Check_Error_Type_Library_List
272
               (List, Root, No_Node,
273
                Test_Renamed_Package,
274
                Package_Renamed_First,
275
                Package_Renamed_Last,
276
                Package_Spec_First,
277
                Package_Spec_Last,
278
                Check_Renamed_Package,
279
                Test_Exist_Error_Type_Lib,
280
                Final_Result);
281 0
               Success := Success and then Final_Result;
282 0
               Sub_Node := Next_Node (Sub_Node);
283 0
            end loop;
284

285
            --  K_Error_Type_Mappings
286 0
            Sub_List := Error_Type_Mappings_List (EMA_Root);
287 0
            if not Is_Empty (Sub_List) then
288 0
               Sub_Node := First_Node (Sub_List);
289
            end if;
290

291 0
            while Present (Sub_Node) loop
292 0
               List := Error_Type_Library_List (Sub_Node);
293 0
               Check_Error_Type_Library_List
294
               (List, Root, No_Node,
295
                Test_Renamed_Package,
296
                Package_Renamed_First,
297
                Package_Renamed_Last,
298
                Package_Spec_First,
299
                Package_Spec_Last,
300
                Check_Renamed_Package,
301
                Test_Exist_Error_Type_Lib,
302
                Final_Result);
303 0
               Success := Success and then Final_Result;
304 0
               Sub_Node := Next_Node (Sub_Node);
305 0
            end loop;
306

307
            --  K_Use_Error_Types
308 0
            Sub_List := Error_Type_Transformations_List (EMA_Root);
309 0
            if not Is_Empty (Sub_List) then
310 0
               Sub_Node := First_Node (Sub_List);
311
            end if;
312

313 0
            while Present (Sub_Node) loop
314 0
               Use_Error_Types_Node := Use_Error_Types (Sub_Node);
315 0
               if Present (Use_Error_Types_Node) then
316 0
                  List := Error_Type_Library_List (Use_Error_Types_Node);
317 0
                  Check_Error_Type_Library_List
318
                  (List, Root, No_Node,
319
                   Test_Renamed_Package,
320
                   Package_Renamed_First,
321
                   Package_Renamed_Last,
322
                   Package_Spec_First,
323
                   Package_Spec_Last,
324
                   Check_Renamed_Package,
325
                   Test_Exist_Error_Type_Lib,
326
                   Final_Result);
327 0
                  Success := Success and then Final_Result;
328
               end if;
329 0
               Sub_Node := Next_Node (Sub_Node);
330 0
            end loop;
331

332
         when others =>
333
            --  K_Annex_Subclause
334 0
            List := Error_Type_Library_List (EMA_Root);
335 0
            Check_Error_Type_Library_List
336
            (List, Root, No_Node,
337
             Test_Renamed_Package,
338
             Package_Renamed_First,
339
             Package_Renamed_Last,
340
             Package_Spec_First,
341
             Package_Spec_Last,
342
             Check_Renamed_Package,
343
             Test_Exist_Error_Type_Lib,
344
             Final_Result);
345 0
            Success := Success and then Final_Result;
346
      end case;
347

348 0
      return Success;
349
   end Check_All_Error_Type_Library_List;
350

351
   ---------------------------------------
352
   -- Check_Error_Type_Library_Extended --
353
   ---------------------------------------
354

355 0
   function Check_Error_Type_Library_Extended
356
      (AADL_Root           : Node_Id;
357
       EMA_Root            : Node_Id;
358
       Error_Type_Local_Id : Node_Id)
359
     return Boolean
360
   is
361
      pragma Assert
362 0
        (Kind (EMA_Root) = K_Annex_Library);
363

364 0
      List_Extended : List_Id;
365 0
      Parent : Node_Id;
366 0
      Error_Model : Node_Id;
367 0
      Package_Spec : Node_Id;
368 0
      Error_Type_Library_Node : Node_Id;
369 0
      Error_Type_Extends_Id : Node_List;
370

371 0
      Success : Boolean := True;
372
   begin
373 0
      Parent := Error_Type_Library (EMA_Root);
374

375 0
      if Present (Parent) then
376 0
         List_Extended := Error_Type_Library_List_Extended (Parent);
377

378 0
         if Is_Empty (List_Extended) then
379 0
            return True;
380
         else
381
            if not
382 0
            Is_Empty (Error_Type_Library_Element_List (Parent))
383
            then
384
               --  Check if there is a conflict of identifiers
385
               --  with the new error_type declared and others in
386
               --  the package mentioned in extends
387 0
               Success := Check_Conflict_Local_Identifiers_Extends_Clause
388
                  (AADL_Root, List_Extended, Error_Type_Local_Id);
389
               --  it is useless to link the packages with the new
390
               --  error_types defined because there are never referenced
391
               --  with that package
392
            else
393 0
               Success := True;
394
            end if;
395

396
            --  The occurrence of each identifier in each package
397
            --  of List_Extended must be : one
398 0
            Error_Model := First_Node (List_Extended);
399 0
            while Present (Error_Model) loop
400 0
               Package_Spec := AADL_Package_Reference (Error_Model);
401 0
               Error_Type_Library_Node := Search_Package_Annex_Root
402
               (AADL_Root, Package_Spec);
403

404 0
               if No (Error_Type_Library_Node) or else
405 0
                  Is_Empty (Error_Type_Library_Element_List
406
                  (Error_Type_Library_Node))
407
               then
408 0
                  Success := Success and then True;
409
               else
410 0
                  Find_Error_Type_Library_Element
411
                   (Error_Type_Library_Node,
412
                    Error_Type_Extends_Id.First,
413
                    Error_Type_Extends_Id.Last);
414
               end if;
415

416 0
               Error_Model := Next_Node (Error_Model);
417 0
            end loop;
418

419 0
            if Present (Error_Type_Extends_Id.First) then
420 0
               Success := Success and then Check_Unique_Identifier
421
                          (Error_Type_Extends_Id.First);
422
            end if;
423

424
         end if;
425

426
      end if;
427

428 0
      return Success;
429 0
   end Check_Error_Type_Library_Extended;
430

431
   -----------------------------------------------------
432
   -- Check_Conflict_Local_Identifiers_Extends_Clause --
433
   -----------------------------------------------------
434

435
   --  Test if there is any conflict with local error_types identifiers
436

437 0
   function Check_Conflict_Local_Identifiers_Extends_Clause
438
     (AADL_Root           : Node_Id;
439
      List_Extended       : List_Id;
440
      Error_Type_Local_Id : Node_Id)
441
     return Boolean
442
   is
443 0
      Element_Id : Node_Id;
444 0
      Error_Model : Node_Id;
445 0
      Local_Error_Type_Extends : Node_List;
446 0
      Error_Type_Library_Node : Node_Id;
447 0
      Id : Node_Id;
448 0
      Node : Node_Id;
449 0
      Package_Spec : Node_Id;
450

451 0
      Success : Boolean := True;
452
   begin
453 0
      Element_Id := Error_Type_Local_Id;
454 0
      Error_Model := First_Node (List_Extended);
455 0
      while Present (Error_Model) loop
456
         --  Search local identifiers for the package referenced in
457
         --  error_model_library
458 0
         Package_Spec := AADL_Package_Reference (Error_Model);
459 0
         Error_Type_Library_Node := Search_Package_Annex_Root
460
           (AADL_Root, Package_Spec);
461

462 0
         if No (Error_Type_Library_Node) or else
463 0
            Is_Empty (Error_Type_Library_Element_List
464
            (Error_Type_Library_Node))
465
         then
466 0
            return True;
467
         end if;
468

469 0
         Find_Error_Type_Library_Element
470
             (Error_Type_Library_Node,
471
              Local_Error_Type_Extends.First,
472
              Local_Error_Type_Extends.Last);
473

474 0
         Id := Local_Error_Type_Extends.First;
475 0
         Node := Id;
476

477
         --  Compare identifiers to verify conflicts
478 0
         while Present (Element_Id) loop
479

480 0
            Id := Node;
481

482 0
            while Present (Id) loop
483 0
               if Get_Name_String (Name (Id)) =
484 0
                  Get_Name_String (Name (Element_Id))
485
               then
486 0
                  Put ("Conflict error_type with local error_type (" &
487 0
                  Get_Name_String (Name (Id)) &
488
                  ") in ");
489 0
                  Affiche (Package_Spec, True);
490 0
                  Success := False;
491
               end if;
492 0
               Id := Next_Node (Id);
493 0
            end loop;
494

495 0
            Element_Id := Next_Node (Element_Id);
496 0
         end loop;
497

498 0
         Error_Model := Next_Node (Error_Model);
499 0
      end loop;
500

501 0
      return Success;
502 0
   end Check_Conflict_Local_Identifiers_Extends_Clause;
503

504
   -------------
505
   -- Affiche --
506
   -------------
507

508 0
   procedure Affiche (Pckg_Name : Node_Id;
509
                      Is_AADL   : Boolean)
510
   is
511 0
      Identifier_Node : Node_Id;
512 0
      Pckg : Node_Id;
513
   begin
514 0
      if Is_AADL then
515 0
         Pckg := ATN.Package_Name (Pckg_Name);
516 0
         Identifier_Node := ATN.First_Node
517 0
                  (ATN.Identifiers (Pckg));
518 0
         while Present (Identifier_Node) loop
519 0
            Put (Get_Name_String (ATN.Name (Identifier_Node)));
520 0
            Identifier_Node := ATN.Next_Node
521
                  (Identifier_Node);
522 0
            if Present (Identifier_Node) then
523 0
               Put ("::");
524
            else
525 0
               Put (" ");
526
            end if;
527 0
         end loop;
528 0
         New_Line;
529
      else
530 0
         Identifier_Node := EMATN.First_Node
531 0
                  (EMATN.Identifiers (Pckg_Name));
532 0
         while Present (Identifier_Node) loop
533 0
            Put (Get_Name_String (EMATN.Name (Identifier_Node)));
534 0
            Identifier_Node := EMATN.Next_Node
535
                  (Identifier_Node);
536 0
            if Present (Identifier_Node) then
537 0
               Put ("::");
538
            else
539 0
               Put (" ");
540
            end if;
541 0
         end loop;
542
      end if;
543 0
   end Affiche;
544

545
   -----------------------------------
546
   -- Check_Error_Type_Library_List --
547
   -----------------------------------
548

549 0
   procedure Check_Error_Type_Library_List
550
     (Error_Type_Library_List   : List_Id;
551
      Root                      : Node_Id;
552
      Package_Spec              : Node_Id;
553
      Test_Renamed_Package      : Boolean := False;
554
      Package_Renamed_First     : in out Node_Id;
555
      Package_Renamed_Last      : in out Node_Id;
556
      Package_Spec_First        : in out Node_Id;
557
      Package_Spec_Last         : in out Node_Id;
558
      Check_Renamed_Package     : Boolean := False;
559
      Test_Exist_Error_Type_Lib : Boolean;
560
      Final_Result              : out Boolean)
561
   is
562

563 0
      Success : Boolean := False;
564 0
      EMLR : Node_List;
565 0
      Error_Model : Node_Id;
566 0
      AADL_Package_Referenced : Node_Id;
567

568 0
      Identifier_Node : Node_Id;
569 0
      Pckg_Originale_Name : Node_Id;
570

571 0
      Test_Error_Type_Library : Boolean;
572 0
      Test : Boolean := True;
573

574 0
      Not_Allowed_Reference_Itself : Boolean;
575
   begin
576 0
      Final_Result := True;
577 0
      if Is_Empty (Error_Type_Library_List) then
578 0
         return;
579
      end if;
580

581 0
      Select_Nodes (Error_Type_Library_List,
582
                    (1 => K_Error_Model_Library_Reference),
583
                     EMLR.First,
584
                     EMLR.Last);
585 0
      Error_Model := EMLR.First;
586

587 0
      while Present (Error_Model) loop
588 0
         Test_With_Package_Name_Alias
589
            (Root, Error_Model, Package_Spec,
590
             Success, AADL_Package_Referenced,
591
             Identifier_Node, Pckg_Originale_Name,
592
             Not_Allowed_Reference_Itself);
593 0
         if not Success then
594 0
            if Not_Allowed_Reference_Itself then
595 0
               Put_Line ("Cannot use types or extend the package itself in" &
596
                 " error_type_library");
597
            else
598 0
               Affiche (Error_Model, False);
599 0
               Put ("is not a package or alias or does not contain" &
600
                 " error_model_library");
601 0
               if Present (Package_Spec) then
602 0
                  Put (" in ");
603 0
                  Affiche (Package_Spec, True);
604
               else
605 0
                  New_Line;
606
               end if;
607
            end if;
608 0
            Final_Result := False;
609
         else
610
            --  Test if the referenced package contains error_type_library
611 0
            if Test_Exist_Error_Type_Lib then
612
               Test_Error_Type_Library :=
613 0
                   Exist_Of_Error_Type_Library (Root, AADL_Package_Referenced);
614 0
               if not Test_Error_Type_Library then
615 0
                  Final_Result := False;
616
               end if;
617
            end if;
618

619
            --  Link between the package and error_model_library_reference
620 0
            Link_Error_Type_Library_List
621
                (AADL_Package_Referenced, Error_Model);
622

623
            --  FIXME : if use types clause call the same package
624
            --  with the renamed package and the original name
625
            --  it is accepted (without warning)
626 0
            if Test_Renamed_Package then
627 0
               if Present (Identifier_Node) and then
628 0
                  Present (Pckg_Originale_Name)
629
               then
630

631
                  --  Preseve in 2 list_node : package_renamed
632
                  --  and package original name
633 0
                  Package_Spec_First := No_Node;
634 0
                  Package_Renamed_First := No_Node;
635 0
                  Ocarina.Analyzer.AADL_EMA.Finder.Put_In_A_List_Node
636
                  (Package_Renamed_First,
637
                   Package_Renamed_Last,
638
                   Identifier_Node);
639 0
                  Ocarina.Analyzer.AADL_EMA.Finder.Put_In_A_List_Node
640
                  (Package_Spec_First,
641
                   Package_Spec_Last,
642
                   AADL_Package_Referenced);
643

644
               end if;
645
            end if;
646

647
            --  Test the library error_type_library extended
648 0
            if Check_Renamed_Package then
649

650 0
               Test := Test_Extended_Library_Redundancy
651
                       (Error_Model,
652
                        Package_Spec_First,
653
                        Package_Renamed_First);
654 0
               if Test then
655 0
                  Final_Result := False;
656
               end if;
657
            end if;
658

659
         end if;
660

661 0
         Error_Model := EMATN.Next_Node (Error_Model);
662 0
      end loop;
663

664 0
   end Check_Error_Type_Library_List;
665

666
   --------------------------------------
667
   -- Test_Extended_Library_Redundancy --
668
   --------------------------------------
669

670 0
   function Test_Extended_Library_Redundancy
671
      (Error_Model           : Node_Id;
672
       Package_Spec_First    : Node_Id;
673
       Package_Renamed_First : Node_Id)
674
      return Boolean
675
   is
676 0
      Package_Spec : Node_Id;
677 0
      Pckg_Name : Node_Id;
678 0
      Id : Node_Id;
679 0
      Id_Spec : Node_Id;
680 0
      Package_Renamed : Node_Id;
681

682 0
      Redundant : Boolean := False;
683
   begin
684 0
      if No (Package_Spec_First) or else No (Package_Renamed_First)
685
      then
686 0
         return False;
687
      end if;
688

689
      --  Test if we are using the renamed package
690 0
      Package_Renamed := Package_Renamed_First;
691 0
      while Present (Package_Renamed) loop
692 0
         Id := EMATN.First_Node (EMATN.Identifiers (Error_Model));
693 0
         if Get_Name_String (ATN.Name (Package_Renamed)) =
694 0
            Get_Name_String (EMATN.Name (Id)) and then
695 0
            No (EMATN.Next_Node (Id))
696
         then
697 0
            Put_Line ("Conflict with packages in use types" &
698
            " and extends clause : use of the new name of the package" &
699
            " and the original name of the package");
700

701 0
            return True;
702
         end if;
703 0
         Package_Renamed := ATN.Next_Node (Package_Renamed);
704 0
      end loop;
705

706
      --  Test if we are using the original name of the package
707 0
      Package_Spec := Package_Spec_First;
708 0
      while Present (Package_Spec) loop
709 0
         Pckg_Name := ATN.Package_Name (Package_Spec);
710

711 0
         Redundant := False;
712

713
         --  Test the length of both lists of identifiers
714 0
         if Ocarina.ME_AADL.AADL_Tree.Nutils.Length
715 0
            (ATN.Identifiers (Pckg_Name)) =
716 0
            Ocarina.ME_AADL_EMA.EMA_Tree.Nutils.Length
717 0
            (EMATN.Identifiers (Error_Model))
718
         then
719 0
            Id_Spec := ATN.First_Node (ATN.Identifiers (Pckg_Name));
720 0
            Id := EMATN.First_Node (EMATN.Identifiers (Error_Model));
721

722 0
            while Present (Id_Spec) and then
723 0
                  Present (Id)
724
            loop
725 0
               if Get_Name_String (ATN.Name (Id_Spec)) /=
726 0
                  Get_Name_String (EMATN.Name (Id))
727
               then
728 0
                  exit;
729
               end if;
730

731 0
               Id_Spec := ATN.Next_Node (Id_Spec);
732 0
               Id := EMATN.Next_Node (Id);
733

734 0
               if No (Id) and then No (Id_Spec)
735
               then
736 0
                  Redundant := True;
737 0
                  Put_Line ("Conflict with packages in use types" &
738
                  " and extends clause :");
739 0
                  Put_Line ("use of the new name of the package" &
740
                  " and the original name of the package");
741
               end if;
742 0
            end loop;
743

744
         end if;
745

746 0
         exit when Redundant;
747 0
         Package_Spec := ATN.Next_Node (Package_Spec);
748 0
      end loop;
749

750 0
      return Redundant;
751
   end Test_Extended_Library_Redundancy;
752

753
   ---------------------------------
754
   -- Exist_Of_Error_Type_Library --
755
   ---------------------------------
756

757 0
   function Exist_Of_Error_Type_Library
758
      (Root         : Node_Id;
759
       Package_Spec : Node_Id)
760
     return Boolean
761
   is
762 0
      Error_Type_Library_Node : Node_Id;
763 0
      Success : Boolean := True;
764
   begin
765 0
      Error_Type_Library_Node := Search_Package_Annex_Root
766
                                 (Root, Package_Spec);
767 0
      if No (Error_Type_Library_Node) then
768 0
         Success := False;
769 0
         Put ("Useless use of: ");
770 0
         Affiche (Package_Spec, True);
771 0
         Put_Line (" the package does not contain error_type_library");
772
      end if;
773

774 0
      return Success;
775
   end Exist_Of_Error_Type_Library;
776

777
   -----------------------------------------------
778
   -- Check_Identifiers_Error_Type_Library_List --
779
   -----------------------------------------------
780

781 0
   function Check_Identifiers_Error_Type_Library_List
782
        (List_Used     : List_Id;
783
         List_Extended : List_Id) return Boolean
784
   is
785 0
      Node_Used : Node_Id;
786 0
      Identifier_Used : Node_Id;
787

788 0
      Node_Extended : Node_Id;
789 0
      Identifier_Extended : Node_Id;
790

791 0
      Are_Identical : Boolean := False;
792 0
      Success : Boolean := True;
793
   begin
794 0
      if Is_Empty (List_Used) or else Is_Empty (List_Extended)
795
      then
796 0
         return True;
797
      end if;
798

799 0
      Node_Used := First_Node (List_Used);
800 0
      Node_Extended := First_Node (List_Extended);
801 0
      while Present (Node_Used) loop
802

803 0
         Are_Identical := False;
804

805 0
         while Present (Node_Extended) loop
806
            --  Test the length of both lists of identifiers
807 0
            if Length (Identifiers (Node_Used)) =
808 0
               Length (Identifiers (Node_Extended))
809
            then
810 0
               Identifier_Used := First_Node (Identifiers (Node_Used));
811 0
               Identifier_Extended := First_Node (Identifiers (Node_Extended));
812

813 0
               while Present (Identifier_Used) and then
814 0
                     Present (Identifier_Extended)
815
                  loop
816 0
                     if Get_Name_String (Name (Identifier_Used)) /=
817 0
                        Get_Name_String (Name (Identifier_Extended))
818
                     then
819 0
                        exit;
820
                     end if;
821

822 0
                     Identifier_Used := Next_Node (Identifier_Used);
823 0
                     Identifier_Extended := Next_Node (Identifier_Extended);
824

825 0
                     if No (Identifier_Used) and then No (Identifier_Extended)
826
                     then
827 0
                        Are_Identical := True;
828 0
                        Put_Line ("Erreur : Conflict with packages in use " &
829
                             "types and extends clause");
830 0
                        Success := False;
831
                     end if;
832 0
               end loop;
833

834
            end if;
835

836 0
            exit when Are_Identical;
837 0
            Node_Extended := Next_Node (Node_Extended);
838 0
         end loop;
839

840 0
         Node_Used := Next_Node (Node_Used);
841 0
      end loop;
842

843 0
      return Success;
844
   end Check_Identifiers_Error_Type_Library_List;
845

846
   --------------------------------------------------------
847
   -- Check_Unique_Identifier_Error_Type_Library_Element --
848
   --------------------------------------------------------
849

850
   --  Id_First_Node and Id_Last_Node are used for ulterior motive :
851
   --  compare these identifiers with others from extended
852
   --  packages
853

854 0
   procedure Check_Unique_Identifier_Error_Type_Library_Element
855
      (EMA_Root      : Node_Id;
856
       Id_First_Node : in out Node_Id;
857
       Id_Last_Node  : in out Node_Id;
858
       Success       : out Boolean)
859
   is
860 0
      Error_Type_Library_Node : Node_Id;
861

862 0
      Element_List : List_Id;
863 0
      Element_Node : Node_Id;
864

865 0
      ET_Definition : Node_Id;
866 0
      ET_Alias : Node_Id;
867 0
      ET_Set_Definition : Node_Id;
868 0
      ET_Set_Alias : Node_Id;
869

870 0
      Id_First_Node_1 : Node_Id := No_Node;
871 0
      Id_Last_Node_1  : Node_Id := No_Node;
872 0
      Id_First_Node_2 : Node_Id := No_Node;
873 0
      Id_Last_Node_2  : Node_Id := No_Node;
874 0
      Id_First_Node_3 : Node_Id := No_Node;
875 0
      Id_Last_Node_3  : Node_Id := No_Node;
876 0
      Id_First_Node_4 : Node_Id := No_Node;
877 0
      Id_Last_Node_4  : Node_Id := No_Node;
878
   begin
879 0
      Error_Type_Library_Node := Error_Type_Library (EMA_Root);
880 0
      if No (Error_Type_Library_Node) then
881 0
         Success := True;
882 0
         return;
883
      end if;
884

885 0
      Element_List := Error_Type_Library_Element_List
886
                      (Error_Type_Library_Node);
887 0
      if Is_Empty (Element_List) then
888 0
         Success := True;
889 0
         return;
890
      else
891 0
         Element_Node := First_Node (Element_List);
892 0
         while Present (Element_Node) loop
893

894
            --  Test identifiers of Error_Type_Definition
895 0
            ET_Definition := Error_Type_Definition (Element_Node);
896 0
            Put_In_A_List_Node (Id_First_Node_1,
897
                                Id_Last_Node_1,
898
                                ET_Definition,
899
                                True);
900 0
            Put_In_A_List_Node (Id_First_Node,
901
                                Id_Last_Node,
902
                                ET_Definition,
903
                                True);
904

905
            --  Test identifiers of Error_Type_Alias
906 0
            ET_Alias := Error_Type_Alias (Element_Node);
907 0
            Put_In_A_List_Node (Id_First_Node_2,
908
                                Id_Last_Node_2,
909
                                ET_Alias,
910
                                True);
911 0
            Put_In_A_List_Node (Id_First_Node,
912
                                Id_Last_Node,
913
                                ET_Alias,
914
                                True);
915

916
            --  Test identifiers of Error_Type_Set_Definition
917 0
            ET_Set_Definition := Error_Type_Set_Definition (Element_Node);
918 0
            Put_In_A_List_Node (Id_First_Node_3,
919
                                Id_Last_Node_3,
920
                                ET_Set_Definition,
921
                                True);
922 0
            Put_In_A_List_Node (Id_First_Node,
923
                                Id_Last_Node,
924
                                ET_Set_Definition,
925
                                True);
926

927
            --  Test identifiers of Error_Type_Set_Alias
928 0
            ET_Set_Alias := Error_Type_Set_Alias (Element_Node);
929 0
            Put_In_A_List_Node (Id_First_Node_4,
930
                                Id_Last_Node_4,
931
                                ET_Set_Alias,
932
                                True);
933 0
            Put_In_A_List_Node (Id_First_Node,
934
                                Id_Last_Node,
935
                                ET_Set_Alias,
936
                                True);
937

938 0
            Element_Node := Next_Node (Element_Node);
939 0
         end loop;
940
      end if;
941

942 0
      Success := Check_Unique_Identifier
943
                    (Id_First_Node_1);
944 0
      Success := Success and then Check_Unique_Identifier
945
                    (Id_First_Node_2);
946 0
      Success := Success and then Check_Unique_Identifier
947
                    (Id_First_Node_3);
948 0
      Success := Success and then Check_Unique_Identifier
949
                    (Id_First_Node_4);
950

951 0
      if not Success then
952 0
         Id_First_Node := No_Node;
953 0
         Id_Last_Node := No_Node;
954
      end if;
955

956 0
   end Check_Unique_Identifier_Error_Type_Library_Element;
957

958
   ------------------------
959
   -- Put_In_A_List_Node --
960
   ------------------------
961

962 0
   procedure Put_In_A_List_Node
963
      (Id_First_Node : in out Node_Id;
964
       Id_Last_Node  : in out Node_Id;
965
       Parent_Node   : Node_Id;
966
       Is_Identifier : Boolean := False)
967
   is
968 0
      Node : Node_Id;
969
   begin
970 0
      if Present (Parent_Node) then
971

972 0
         if Is_Identifier then
973 0
            Node := Identifier (Parent_Node);
974
         else
975 0
            Node := Parent_Node;
976
         end if;
977

978 0
         if No (Id_First_Node) then
979 0
            Id_First_Node := Node;
980 0
            Id_Last_Node := Node;
981
         else
982 0
            Set_Next_Node (Id_Last_Node, Node);
983 0
            Set_Next_Node (Node, No_Node);
984 0
            Id_Last_Node := Node;
985
         end if;
986

987
      end if;
988 0
   end Put_In_A_List_Node;
989

990
   -----------------------------
991
   -- Check_Unique_Identifier --
992
   -----------------------------
993

994 0
   function Check_Unique_Identifier
995
      (First_Node_List : Node_Id)
996
      return Boolean
997
   is
998
      --  Id is the identifier that we compare with
999 0
      Id : Node_Id;
1000
      --  Next is the rest of identifiers in the node list
1001 0
      Next : Node_Id;
1002

1003 0
      Success : Boolean := True;
1004
   begin
1005 0
      if Present (First_Node_List) then
1006

1007 0
         Id := First_Node_List;
1008 0
         while Present (Id) loop
1009 0
            Next := Next_Node (Id);
1010 0
            while Present (Next) loop
1011 0
               if Get_Name_String (Name (Id)) =
1012 0
                  Get_Name_String (Name (Next))
1013
               then
1014 0
                  Put_Line ("Duplicate identifier : " &
1015 0
                            Get_Name_String (Name (Id)));
1016 0
                  Success := False;
1017 0
                  exit;
1018
               end if;
1019 0
               Next := Next_Node (Next);
1020 0
            end loop;
1021 0
            Id := Next_Node (Id);
1022 0
         end loop;
1023

1024
      else
1025 0
         return True;
1026
      end if;
1027

1028 0
      return Success;
1029
   end Check_Unique_Identifier;
1030

1031
   ------------------------------------
1032
   -- Check_All_Error_Type_Reference --
1033
   ------------------------------------
1034

1035 0
   function Check_All_Error_Type_Reference
1036
      (AADL_Root    : Node_Id;
1037
       EMA_Root     : Node_Id;
1038
       Package_Spec : Node_Id)
1039
      return Boolean
1040
   is
1041 0
      Success : Boolean;
1042
   begin
1043 0
      Success := Check_Error_Type_Reference_Of_Error_Type_Library
1044
                 (AADL_Root, EMA_Root, Package_Spec);
1045

1046
      --  add other nodes test's about Error_Type_Reference
1047
      --  it is exactly the same as Error_Type_Library
1048

1049 0
      return Success;
1050
   end Check_All_Error_Type_Reference;
1051

1052
   ------------------------------------------------------
1053
   -- Check_Error_Type_Reference_Of_Error_Type_Library --
1054
   ------------------------------------------------------
1055

1056 0
   function Check_Error_Type_Reference_Of_Error_Type_Library
1057
      (AADL_Root     : Node_Id;
1058
       EMA_Root      : Node_Id;
1059
       Package_Spec  : Node_Id)
1060
      return Boolean
1061
   is
1062 0
      Parent_Nodes : Node_List;
1063 0
      Success : Boolean;
1064
   begin
1065 0
      Get_Error_Type_Reference_Of_Error_Type_Library
1066
         (EMA_Root, Parent_Nodes.First, Parent_Nodes.Last);
1067

1068 0
      Success := Check_Referenced_Error_Type_Common_Function
1069
        (AADL_Root, EMA_Root, Parent_Nodes.First, Package_Spec,
1070
         False);
1071

1072 0
      return Success;
1073

1074 0
   end Check_Error_Type_Reference_Of_Error_Type_Library;
1075

1076
   ----------------------------------------------------------
1077
   -- Check_Error_Type_Set_Reference_Of_Error_Type_Library --
1078
   ----------------------------------------------------------
1079

1080 0
   function Check_Error_Type_Set_Reference_Of_Error_Type_Library
1081
      (AADL_Root     : Node_Id;
1082
       EMA_Root      : Node_Id;
1083
       Package_Spec  : Node_Id)
1084
      return Boolean
1085
   is
1086 0
      Parent_Nodes : Node_List;
1087 0
      Success : Boolean;
1088
   begin
1089 0
      Get_Error_Type_Set_Reference_Of_Error_Type_Library
1090
         (EMA_Root, Parent_Nodes.First, Parent_Nodes.Last);
1091

1092 0
      Success := Check_Referenced_Error_Type_Common_Function
1093
        (AADL_Root, EMA_Root, Parent_Nodes.First, Package_Spec,
1094
         True);
1095

1096 0
      return Success;
1097 0
   end Check_Error_Type_Set_Reference_Of_Error_Type_Library;
1098

1099
   -------------------------------------------------
1100
   -- Check_Referenced_Error_Type_Common_Function --
1101
   -------------------------------------------------
1102

1103 0
   function Check_Referenced_Error_Type_Common_Function
1104
      (AADL_Root          : Node_Id;
1105
       EMA_Root           : Node_Id;
1106
       Parent_Nodes_First : Node_Id;
1107
       Package_Spec       : Node_Id;
1108
       Is_Set             : Boolean)
1109
      return Boolean
1110
   is
1111 0
      Success : Boolean := True;
1112

1113 0
      Parent_Node : Node_Id;
1114

1115 0
      Error_Type_Library_Node : Node_Id;
1116 0
      List_Used : List_Id;
1117
   begin
1118
      --  Search for List_Used
1119 0
      Error_Type_Library_Node := Error_Type_Library (EMA_Root);
1120 0
      if No (Error_Type_Library_Node) then
1121 0
         return True;
1122
      end if;
1123

1124 0
      List_Used := Error_Type_Library_List_Used
1125
                   (Error_Type_Library_Node);
1126

1127 0
      Parent_Node := Parent_Nodes_First;
1128
      --  initialize Success
1129 0
      Success := Check_Error_Type_Reference
1130
                 (AADL_Root, Package_Spec,
1131
                  Parent_Node, List_Used,
1132
                  Is_Set,
1133
                  Error_Type_Library_Node);
1134 0
      if Present (Parent_Node) then
1135 0
         Parent_Node := EMATN.Next_Node (Parent_Node);
1136 0
         while Present (Parent_Node) loop
1137 0
            Success := Success and then
1138 0
                Check_Error_Type_Reference
1139
                (AADL_Root, Package_Spec,
1140
                 Parent_Node, List_Used,
1141
                 Is_Set,
1142
                 Error_Type_Library_Node);
1143 0
            Parent_Node := EMATN.Next_Node (Parent_Node);
1144 0
         end loop;
1145
      end if;
1146

1147 0
      return Success;
1148

1149
   end Check_Referenced_Error_Type_Common_Function;
1150

1151
   --------------------------------
1152
   -- Check_Error_Type_Reference --
1153
   --------------------------------
1154

1155
   --  Package referenced exists in use types clause only
1156

1157
   --  error_types , alias ... in extends clause become accessible
1158
   --  without the package name : as local identifiers
1159
   --  ( wich explains : no conflict with other extended libraries and
1160
   --    local identifiers)
1161

1162
   --  In error_type_library we have to check if the new error_type_identifier
1163
   --  or the new error_type_set_identifier is not the same referenced
1164
   --  at the same time
1165

1166
   --  à revoir ce cas
1167
   --  Error_Type_Product is List_Id others are Node_Id
1168

1169
   --  Is_Set : we are using the same function to check Error_Type_Reference
1170
   --  and Error_Type_Set_Reference (same treatments are done for both with
1171
   --  little differences)
1172
   --  Is_Set = True => Error_Type_Set_Reference
1173

1174
   --  If we are testing the references in Error_Type_Library then
1175
   --  Error_Type_Library_Node <> No_Node
1176

1177 0
   function Check_Error_Type_Reference
1178
       (AADL_Root               : Node_Id;
1179
        Package_Container       : Node_Id := No_Node;
1180
        Parent_Node             : Node_Id;
1181
        List_Used               : List_Id;
1182
        Is_Set                  : Boolean;
1183
        Error_Type_Library_Node : Node_Id := No_Node)
1184
       return Boolean
1185
   is
1186 0
      ETL_Ref : Node_Id;
1187 0
      Error_Model_Library_Ref : Node_Id;
1188 0
      Error_Type_Id : Node_Id;
1189

1190 0
      Exist_Package_Ref : Boolean := True;
1191

1192 0
      Not_Allowed_Reference : Boolean;
1193

1194 0
      Success : Boolean := True;
1195

1196 0
      Node_Referenced : Node_Id;
1197

1198 0
      Local_Identifiers : Node_List;
1199 0
      Local_Id : Node_Id;
1200 0
      Library_Used : Node_Id;
1201 0
      Exist_Error_Type : Boolean := False;
1202

1203 0
      Choose_Node : Boolean := False;
1204
   begin
1205 0
      if No (Parent_Node) then
1206 0
         return True;
1207
      end if;
1208

1209 0
      if not Is_Set then
1210 0
         if Kind (Parent_Node) = K_Error_Type_Reference then
1211 0
            ETL_Ref := Parent_Node;
1212
         else
1213 0
            ETL_Ref := Error_Type_Reference (Parent_Node);
1214 0
            if No (ETL_Ref) then
1215 0
               return True;
1216
            end if;
1217
         end if;
1218
      else
1219 0
         ETL_Ref := Error_Type_Set_Reference (Parent_Node);
1220 0
         if No (ETL_Ref) then
1221 0
            return True;
1222
         end if;
1223
      end if;
1224

1225
      --  The parser does not do the difference between
1226
      --  error_type_set_reference and error_type_reference in this node
1227 0
      if Kind (Parent_Node) = K_Error_Type_Or_Set_Reference then
1228 0
         Choose_Node := True;
1229
      end if;
1230

1231
      --  Check existance of referenced element
1232 0
      Error_Model_Library_Ref := Error_Model_Library_Reference (ETL_Ref);
1233 0
      Error_Type_Id := Identifier (ETL_Ref);
1234

1235
      -----------------------------------
1236
      --  A REVOIR : supprimer ce message
1237 0
      New_Line;
1238 0
      if Present (Error_Model_Library_Ref) then
1239 0
         Put_Line ("1111111111 : " & Get_Name_String (Name
1240 0
         (First_Node (Identifiers (Error_Model_Library_Ref)))));
1241
      end if;
1242 0
      Put_Line ("222222222 : " & Get_Name_String (Name (Error_Type_Id)));
1243 0
      New_Line;
1244
      -----------------------------------
1245

1246 0
      if Present (Error_Model_Library_Ref) then
1247

1248
         --  Check if the error_model_library_reference exists
1249
         --  in use types clause
1250 0
         if Is_Empty (List_Used) then
1251 0
            Put_Line ("There is no package mentioned in use types clause");
1252 0
            return False;
1253
         end if;
1254 0
         if not Is_Empty (List_Used) then
1255 0
            Search_Reference_In_List (Error_Model_Library_Ref,
1256 0
            First_Node (List_Used), Node_Referenced);
1257
         end if;
1258

1259 0
         if No (Node_Referenced) then
1260 0
            Put ("Error : The package ");
1261 0
            Affiche (Error_Model_Library_Ref, False);
1262 0
            Put_Line ("does not exist in use types or extends clause");
1263 0
            return False;
1264
         else
1265
            --  Link the package found with the other one
1266 0
            Link_Error_Type_Reference
1267
              (Error_Model_Library_Ref, Node_Referenced);
1268

1269
            --  Check if the identifier is defined in the referenced
1270
            --  package
1271
            -------------------------------------
1272
            --  à revoir : à éliminer ce message
1273 0
            New_Line;
1274 0
            Put_Line (" ~~~ " &
1275
            "The package found is linked with aadl package ~~~");
1276 0
            Put (Get_Name_String (ATN.Name (ATN.First_Node
1277 0
            (ATN.Identifiers (ATN.Package_Name (AADL_Package_Reference
1278
            (Node_Referenced)))))));
1279 0
            Put_Line (" is the referenced package");
1280 0
            Put_Line ("~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~");
1281 0
            New_Line;
1282
            -------------------------------------
1283 0
            Success := Check_Referenced_Error_Type_In_Package
1284
                       (AADL_Root,
1285 0
                        AADL_Package_Reference (Node_Referenced),
1286
                        Error_Type_Id,
1287
                        Is_Set);
1288 0
            if not Success then
1289 0
               Put_Line ("The error type : " & Get_Name_String
1290 0
               (Name (Error_Type_Id)) & " is not mentioned in the "
1291 0
               & " package " & Get_Name_String (Name (First_Node
1292 0
               (Identifiers (Node_Referenced)))));
1293 0
               return False;
1294
            end if;
1295
         end if;
1296

1297
      else
1298 0
         Exist_Package_Ref := False;
1299
      end if;
1300

1301
      --  Check if the error type is local error_type
1302
      --  (error_type_library_element / extended library)
1303
      --  or is mentioned in the package of use types clause
1304 0
      if not Exist_Package_Ref then
1305
         --  Local identifiers
1306 0
         Get_Error_Type_Id
1307
         (AADL_Root,
1308
          Package_Container,
1309
          Local_Identifiers.First,
1310
          Local_Identifiers.Last,
1311
          Is_Set);
1312 0
         Local_Id := Local_Identifiers.First;
1313
         --  Search if the error_type is a local error_type
1314 0
         if Present (Local_Id) then
1315 0
            Exist_Error_Type := Search_Reference_In_List_Node
1316
                  (Error_Type_Id, Local_Id);
1317

1318
            --  Test if the error_type or error_type_set referenced
1319
            --  is the same as the new one defined : this test is only
1320
            --  for error_type_library
1321 0
            if Exist_Error_Type and then
1322 0
               Present (Error_Type_Library_Node)
1323
            then
1324

1325 0
               Not_Allowed_Reference := Test_Local_Reference_Error_Type_Library
1326
                   (Error_Type_Library_Node, Parent_Node,
1327
                    Error_Type_Id, Is_Set);
1328

1329 0
               if Not_Allowed_Reference then
1330 0
                  Put_Line (Get_Name_String (Name (Error_Type_Id)) &
1331
                  " cannot reference itself");
1332 0
                  return False;
1333
               end if;
1334

1335
            end if;
1336
         end if;
1337

1338
         --  identifiers in use types
1339 0
         if not Exist_Error_Type and then
1340 0
            not Is_Empty (List_Used)
1341
         then
1342 0
            Local_Identifiers.First := No_Node;
1343 0
            Library_Used := First_Node (List_Used);
1344 0
            while Present (Library_Used) loop
1345 0
               Get_Error_Type_Id
1346
               (AADL_Root,
1347 0
                AADL_Package_Reference (Library_Used),
1348
                Local_Identifiers.First,
1349
                Local_Identifiers.Last,
1350
                Is_Set);
1351 0
               Library_Used := Next_Node (Library_Used);
1352 0
            end loop;
1353 0
            Local_Id := Local_Identifiers.First;
1354
            --  Search if the error_type is in a used type package
1355 0
            if Present (Local_Id) then
1356 0
               Exist_Error_Type := Search_Reference_In_List_Node
1357
                  (Error_Type_Id, Local_Id);
1358
            end if;
1359
         end if;
1360

1361 0
         Success := Exist_Error_Type;
1362 0
         if not Success then
1363 0
            if Choose_Node then
1364 0
               if not Is_Set then
1365
                  --  Unset the node from error_type_reference
1366 0
                  Set_Error_Type_Reference (Parent_Node, No_Node);
1367 0
                  Success := True;
1368
               else
1369
                  --  Unset the node from error_type_set_reference
1370 0
                  Set_Error_Type_Set_Reference (Parent_Node, No_Node);
1371
                  --  Test if it is error_type_reference
1372 0
                  if No (Error_Type_Reference (Parent_Node)) then
1373 0
                     Put_Line (Get_Name_String (Name (Error_Type_Id)) &
1374 0
                     " is nor error_type_set_reference neither " &
1375
                     "error_type_reference");
1376 0
                     Success := False;
1377
                  else
1378 0
                     Success := True;
1379
                  end if;
1380
               end if;
1381

1382 0
               return Success;
1383
            end if;
1384

1385 0
            if Is_Set then
1386 0
               Put_Line ("The error_type_set_reference ( " &
1387 0
               Get_Name_String (Name (Error_Type_Id)) & " ) does not exist");
1388
            else
1389 0
               Put_Line ("The error_type_reference ( " & Get_Name_String
1390 0
               (Name (Error_Type_Id)) & " ) does not exist");
1391
            end if;
1392
         else
1393
            ----------------------------
1394
            --  à revoir : à éliminer ce message
1395 0
            if Is_Set then
1396 0
               Put_Line (Get_Name_String
1397 0
               (Name (Error_Type_Id)) & " (error_type_Set) is found");
1398
            else
1399 0
               Put_Line (Get_Name_String
1400 0
               (Name (Error_Type_Id)) & " (error_type) is found");
1401
            end if;
1402
            --------------------------
1403
         end if;
1404

1405
      end if;
1406

1407 0
      return Success;
1408 0
   end Check_Error_Type_Reference;
1409

1410
   ---------------------------------------------
1411
   -- Test_Local_Reference_Error_Type_Library --
1412
   ---------------------------------------------
1413

1414
   --  This Test is only used if we are testing references
1415
   --  in error_type_library
1416

1417 0
   function Test_Local_Reference_Error_Type_Library
1418
       (Error_Type_Library_Node : Node_Id;
1419
        Parent_Node             : Node_Id;
1420
        Reference_Identifier    : Node_Id;
1421
        Is_Set                  : Boolean)
1422
      return Boolean
1423
   is
1424 0
      Defined_Parent_Node : Node_Id;
1425 0
      New_Parents : Node_List;
1426 0
      Parent_Node_References : Node_Id;
1427 0
      Id : Node_Id;
1428

1429 0
      Error_Type_Set_List : List_Id;
1430 0
      Type_Set_Elt : Node_Id;
1431 0
      Parent_List : List_Id;
1432

1433 0
      Not_Allowed : Boolean;
1434
   begin
1435 0
      Find_Error_Type_Library_Element
1436
       (Error_Type_Library_Node,
1437
        New_Parents.First, New_Parents.Last,
1438
        False);
1439

1440 0
      Defined_Parent_Node := New_Parents.First;
1441

1442 0
      while Present (Defined_Parent_Node) loop
1443
         --  Search the identifier
1444 0
         Id := Identifier (Defined_Parent_Node);
1445
         --  Search the parent_node of the referenced error_type
1446 0
         if Kind (Defined_Parent_Node) = K_Error_Type_Set_Definition then
1447 0
            if Is_Set then
1448
               ------
1449 0
               Error_Type_Set_List := Error_Type_Set (Defined_Parent_Node);
1450 0
               if not Is_Empty (Error_Type_Set_List) then
1451 0
                  Type_Set_Elt := First_Node (Error_Type_Set_List);
1452 0
                  while Present (Type_Set_Elt) loop
1453
                     Parent_Node_References :=
1454 0
                        Error_Type_Or_Set_Reference (Type_Set_Elt);
1455

1456 0
                     Not_Allowed := Compare_Reference_With_Local
1457
                         (Parent_Node_References, Id,
1458
                          Parent_Node, Reference_Identifier);
1459

1460 0
                     if Not_Allowed then
1461 0
                        return True;
1462
                     end if;
1463

1464 0
                     Type_Set_Elt := Next_Node (Type_Set_Elt);
1465 0
                  end loop;
1466
               end if;
1467
               --------
1468
            else
1469
               ----
1470 0
               Error_Type_Set_List := Error_Type_Set (Defined_Parent_Node);
1471 0
               if not Is_Empty (Error_Type_Set_List) then
1472 0
                  Type_Set_Elt := First_Node (Error_Type_Set_List);
1473 0
                  while Present (Type_Set_Elt) loop
1474 0
                     Parent_Node_References := Error_Type_Or_Set_Reference
1475
                                               (Type_Set_Elt);
1476

1477 0
                     Not_Allowed := Compare_Reference_With_Local
1478
                         (Parent_Node_References, Id,
1479
                          Parent_Node, Reference_Identifier);
1480

1481 0
                     if Not_Allowed then
1482 0
                        return True;
1483
                     end if;
1484

1485
                     --  error_type_product
1486 0
                     Parent_List := Error_Type_Product (Type_Set_Elt);
1487 0
                     if not Is_Empty (Parent_List) then
1488 0
                        Parent_Node_References := First_Node (Parent_List);
1489 0
                        while Present (Parent_Node_References) loop
1490 0
                           Not_Allowed := Compare_Reference_With_Local
1491
                             (Parent_Node_References, Id,
1492
                              Parent_Node, Reference_Identifier);
1493

1494 0
                           if Not_Allowed then
1495 0
                              return True;
1496
                           end if;
1497 0
                           Parent_Node_References := Next_Node
1498
                              (Parent_Node_References);
1499 0
                        end loop;
1500
                     end if;
1501

1502 0
                     Type_Set_Elt := Next_Node (Type_Set_Elt);
1503 0
                  end loop;
1504
               end if;
1505
               ----
1506
            end if;
1507
         else
1508 0
            Parent_Node_References := Defined_Parent_Node;
1509 0
            Not_Allowed := Compare_Reference_With_Local
1510
                (Parent_Node_References, Id,
1511
                 Parent_Node, Reference_Identifier);
1512
         end if;
1513

1514 0
         exit when Not_Allowed;
1515 0
         Defined_Parent_Node := Next_Node (Defined_Parent_Node);
1516

1517 0
      end loop;
1518

1519 0
      return Not_Allowed;
1520 0
   end Test_Local_Reference_Error_Type_Library;
1521

1522
   ----------------------------------
1523
   -- Compare_Reference_With_Local --
1524
   ----------------------------------
1525

1526 0
   function Compare_Reference_With_Local
1527
      (Parent_Node_References : Node_Id;
1528
       Id                     : Node_Id;
1529
       Parent_Node            : Node_Id;
1530
       Reference_Identifier   : Node_Id)
1531
     return Boolean
1532
   is
1533 0
      Not_Allowed : Boolean := False;
1534
   begin
1535 0
      if No (Parent_Node_References) then
1536 0
         return False;
1537
      end if;
1538

1539 0
      if Parent_Node = Parent_Node_References and then
1540 0
         Get_Name_String (Name (Id)) =
1541 0
         Get_Name_String (Name (Reference_Identifier))
1542
      then
1543 0
         Not_Allowed := True;
1544
      end if;
1545

1546 0
      return Not_Allowed;
1547
   end Compare_Reference_With_Local;
1548

1549
   ----------------------------------------
1550
   -- Check_All_Error_Type_Set_Reference --
1551
   ----------------------------------------
1552

1553 0
   function Check_All_Error_Type_Set_Reference
1554
      (AADL_Root    : Node_Id;
1555
       EMA_Root     : Node_Id;
1556
       Package_Spec : Node_Id)
1557
      return Boolean
1558
   is
1559 0
      Success : Boolean;
1560
   begin
1561 0
      Success := Check_Error_Type_Set_Reference_Of_Error_Type_Library
1562
                 (AADL_Root, EMA_Root, Package_Spec);
1563

1564
      --  add other nodes test's about Error_Type_Reference
1565
      --  it is exactly the same as Error_Type_Library
1566

1567 0
      return Success;
1568
   end Check_All_Error_Type_Set_Reference;
1569

1570
   --------------------------------------------
1571
   -- Check_Referenced_Error_Type_In_Package --
1572
   --------------------------------------------
1573

1574
   --  search in local error_type_identifiers of the package
1575
   --  and extended error_type_identifiers
1576

1577 0
   function Check_Referenced_Error_Type_In_Package
1578
         (AADL_Root     : Node_Id;
1579
          Pckg_Spec     : Node_Id;
1580
          Error_Type_Id : Node_Id;
1581
          Is_Set        : Boolean)
1582
      return Boolean
1583
   is
1584 0
      Identifiers_List : Node_List;
1585 0
      Identifier_Node : Node_Id;
1586
   begin
1587 0
      Get_Error_Type_Id
1588
           (AADL_Root, Pckg_Spec,
1589
            Identifiers_List.First, Identifiers_List.Last,
1590
            Is_Set);
1591

1592
      --  Compare error_type identifiers found with
1593
      --  the error_type referenced
1594 0
      Identifier_Node := Identifiers_List.First;
1595 0
      while Present (Identifier_Node) loop
1596 0
         if Get_Name_String (Name (Identifier_Node)) =
1597 0
            Get_Name_String (Name (Error_Type_Id))
1598
         then
1599 0
            return True;
1600
         end if;
1601

1602 0
         Identifier_Node := Next_Node (Identifier_Node);
1603 0
      end loop;
1604

1605 0
      return False;
1606 0
   end Check_Referenced_Error_Type_In_Package;
1607

1608
   ------------------------------
1609
   -- Search_Reference_In_List --
1610
   ------------------------------
1611

1612 0
   procedure Search_Reference_In_List
1613
     (Id              : Node_Id;
1614
      List_First_Node : Node_Id;
1615
      Node_Referenced : out Node_Id)
1616
   is
1617 0
      Node : Node_Id;
1618 0
      Identifier_Node_List : Node_Id;
1619 0
      Identifier_Searched : Node_Id;
1620

1621 0
      Are_Identical : Boolean := False;
1622
   begin
1623 0
      Node_Referenced := No_Node;
1624

1625 0
      Node := List_First_Node;
1626 0
      while Present (Node) loop
1627

1628 0
         Are_Identical := False;
1629 0
         Node_Referenced := No_Node;
1630

1631
         --  Test the length of both lists of identifiers
1632 0
         if Length (Identifiers (Node)) =
1633 0
            Length (Identifiers (Id))
1634
         then
1635 0
            Identifier_Node_List := First_Node (Identifiers (Node));
1636 0
            Identifier_Searched := First_Node (Identifiers (Id));
1637

1638 0
            while Present (Identifier_Node_List) and then
1639 0
                  Present (Identifier_Searched)
1640
            loop
1641 0
               if Get_Name_String (Name (Identifier_Node_List)) /=
1642 0
                  Get_Name_String (Name (Identifier_Searched))
1643
               then
1644 0
                  Node_Referenced := No_Node;
1645 0
                  exit;
1646
               else
1647 0
                  Node_Referenced := Node;
1648
               end if;
1649

1650 0
               Identifier_Node_List := Next_Node (Identifier_Node_List);
1651 0
               Identifier_Searched := Next_Node (Identifier_Searched);
1652

1653 0
               if No (Identifier_Node_List) and then No (Identifier_Searched)
1654
               then
1655 0
                  Are_Identical := True;
1656
               end if;
1657 0
            end loop;
1658

1659
         end if;
1660

1661 0
         exit when Are_Identical;
1662

1663 0
         Node := Next_Node (Node);
1664 0
      end loop;
1665

1666 0
   end Search_Reference_In_List;
1667

1668
   -----------------------------------
1669
   -- Search_Reference_In_List_Node --
1670
   -----------------------------------
1671

1672 0
   function Search_Reference_In_List_Node
1673
     (Id              : Node_Id;
1674
      List_First_Node : Node_Id)
1675
     return Boolean
1676
   is
1677 0
      Node : Node_Id;
1678

1679 0
      Are_Identical : Boolean := False;
1680
   begin
1681 0
      Node := List_First_Node;
1682

1683 0
      while Present (Node) loop
1684

1685 0
         if Get_Name_String (Name (Id)) =
1686 0
            Get_Name_String (Name (Node))
1687
         then
1688 0
            Are_Identical := True;
1689 0
            exit;
1690
         end if;
1691

1692 0
         Node := Next_Node (Node);
1693 0
      end loop;
1694

1695 0
      return Are_Identical;
1696
   end Search_Reference_In_List_Node;
1697

1698
   ----------------------------
1699
   -- Check_Names_In_Library --
1700
   ----------------------------
1701

1702 0
   function Check_Names_In_Library
1703
     (Root : Node_Id;
1704
      EMA_Root : Node_Id;
1705
      Package_Spec : Node_Id)
1706
     return Boolean is
1707

1708
      pragma Assert
1709 0
             (Kind (EMA_Root) = K_Annex_Library);
1710

1711 0
      Success : Boolean := True;
1712 0
      Test : Boolean;
1713 0
      Id_Node : Node_List;
1714

1715 0
      EMA_Pckg_Container : Node_Id;
1716
   begin
1717 0
      Success := Check_All_Error_Type_Library_List
1718
                 (Root, EMA_Root, Package_Spec);
1719

1720 0
      Check_Unique_Identifier_Error_Type_Library_Element
1721
         (EMA_Root, Id_Node.First, Id_Node.Last, Test);
1722 0
      Success := Success and then Test;
1723

1724 0
      Success := Success and then
1725 0
                 Check_Error_Type_Library_Extended
1726
                 (Root, EMA_Root, Id_Node.First);
1727

1728
      --  Search the pakage container of the annex
1729 0
      EMA_Pckg_Container := Find_Package_Annex_Library
1730
                 (Root, EMA_Root);
1731

1732 0
      Success := Success and then
1733 0
         Check_All_Error_Type_Reference
1734
         (Root, EMA_Root, EMA_Pckg_Container);
1735

1736 0
      Success := Success and then
1737 0
         Check_All_Error_Type_Set_Reference
1738
         (Root, EMA_Root, EMA_Pckg_Container);
1739

1740 0
      return Success;
1741 0
   end Check_Names_In_Library;
1742

1743
   ------------------------------
1744
   -- Check_Names_In_Subclause --
1745
   ------------------------------
1746

1747 0
   function Check_Names_In_Subclause
1748
     (Root : Node_Id;
1749
      EMA_Root : Node_Id;
1750
      Package_Spec : Node_Id)
1751
     return Boolean is
1752

1753
      pragma Assert
1754 0
             (Kind (EMA_Root) = K_Annex_Subclause);
1755
   begin
1756 0
      return Check_All_Error_Type_Library_List (Root, EMA_Root, Package_Spec);
1757
   end Check_Names_In_Subclause;
1758

1759
end Ocarina.Analyzer.AADL_EMA.Naming_Rules;

Read our documentation on viewing source code .

Loading