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

33
with GNAT.Table;
34
with GNAT.Case_Util;
35

36
with Charset;       use Charset;
37
with Locations;     use Locations;
38
with Ocarina.Namet; use Ocarina.Namet;
39
with Utils;         use Utils;
40

41
with Ocarina.Backends;
42
with Ocarina.Backends.C_Common.Mapping;
43
with Ocarina.Backends.PO_HI_C.Runtime;
44
with Ocarina.Backends.POK_C;
45
with Ocarina.Backends.POK_C.Runtime;
46
with Ocarina.Backends.Utils;
47
with Ocarina.Backends.Messages;
48
with Ocarina.Backends.C_Tree.Nutils;
49
with Ocarina.Backends.C_Values;
50
with Ocarina.Backends.Properties;
51

52
with Ocarina.ME_AADL.AADL_Instances.Nodes;
53
with Ocarina.ME_AADL.AADL_Tree.Nodes;
54
with Ocarina.ME_AADL.AADL_Instances.Nutils;
55
with Ocarina.Instances.Queries;
56

57
use Ocarina.ME_AADL.AADL_Instances.Nodes;
58
use Ocarina.Backends;
59
use Ocarina.Backends.Utils;
60
use Ocarina.Backends.Messages;
61
use Ocarina.Backends.Properties;
62
use Ocarina.Backends.C_Common.Mapping;
63
use Ocarina.Backends.C_Values;
64

65
use Ocarina.Instances.Queries;
66

67 1
package body Ocarina.Backends.C_Tree.Nutils is
68

69
   package AINU renames Ocarina.ME_AADL.AADL_Instances.Nutils;
70
   package AIN renames Ocarina.ME_AADL.AADL_Instances.Nodes;
71
   package ATN renames Ocarina.ME_AADL.AADL_Tree.Nodes;
72
   package CV renames Ocarina.Backends.C_Values;
73
   package CTU renames Ocarina.Backends.C_Tree.Nutils;
74
   package CTN renames Ocarina.Backends.C_Tree.Nodes;
75
   package PHCR renames Ocarina.Backends.PO_HI_C.Runtime;
76
   package PKR renames Ocarina.Backends.POK_C.Runtime;
77

78
   Keyword_Suffix : constant String := "%C";
79
   --  Used to mark C keywords and avoid collision with other languages
80

81
   type Entity_Stack_Entry is record
82
      Current_File   : Node_Id;
83
      Current_Entity : Node_Id;
84
   end record;
85

86
   No_Depth : constant Int := -1;
87
   package Entity_Stack is new GNAT.Table
88
     (Entity_Stack_Entry,
89
      Int,
90
      No_Depth + 1,
91
      10,
92
      10);
93

94
   use Entity_Stack;
95

96
   procedure New_Operator (O : Operator_Type; I : String := "");
97

98
   ------------------------
99
   -- Add_Prefix_To_Name --
100
   ------------------------
101

102 0
   function Add_Prefix_To_Name
103
     (Prefix : String;
104
      Name   : Name_Id) return Name_Id
105
   is
106
   begin
107 0
      Set_Str_To_Name_Buffer (Prefix);
108 0
      Get_Name_String_And_Append (Name);
109 0
      return Name_Find;
110
   end Add_Prefix_To_Name;
111

112
   ------------------------
113
   -- Add_Suffix_To_Name --
114
   ------------------------
115

116
   function Add_Suffix_To_Name
117
     (Suffix : String;
118
      Name   : Name_Id) return Name_Id
119
   is
120
   begin
121 1
      Get_Name_String (Name);
122 1
      Add_Str_To_Name_Buffer (Suffix);
123 1
      return Name_Find;
124
   end Add_Suffix_To_Name;
125

126
   -----------------------------
127
   -- Remove_Suffix_From_Name --
128
   -----------------------------
129

130 0
   function Remove_Suffix_From_Name
131
     (Suffix : String;
132
      Name   : Name_Id) return Name_Id
133
   is
134 0
      Length   : Natural;
135 0
      Temp_Str : String (1 .. Suffix'Length);
136
   begin
137 0
      Set_Str_To_Name_Buffer (Suffix);
138 0
      Length := Name_Len;
139 0
      Get_Name_String (Name);
140 0
      if Name_Len > Length then
141 0
         Temp_Str := Name_Buffer (Name_Len - Length + 1 .. Name_Len);
142 0
         if Suffix = Temp_Str then
143 0
            Set_Str_To_Name_Buffer (Name_Buffer (1 .. Name_Len - Length));
144 0
            return Name_Find;
145
         end if;
146
      end if;
147 0
      return Name;
148
   end Remove_Suffix_From_Name;
149

150
   -------------------------
151
   -- Append_Node_To_List --
152
   -------------------------
153

154 1
   procedure Append_Node_To_List (E : Node_Id; L : List_Id) is
155 1
      Last : Node_Id;
156

157
   begin
158 1
      Last := CTN.Last_Node (L);
159 1
      if No (Last) then
160 1
         CTN.Set_First_Node (L, E);
161
      else
162 1
         CTN.Set_Next_Node (Last, E);
163
      end if;
164 1
      Last := E;
165 1
      while Present (Last) loop
166 1
         CTN.Set_Last_Node (L, Last);
167 1
         Last := CTN.Next_Node (Last);
168 1
      end loop;
169 1
   end Append_Node_To_List;
170

171
   -----------------------
172
   -- Insert_After_Node --
173
   -----------------------
174

175 0
   procedure Insert_After_Node (E : Node_Id; N : Node_Id) is
176 0
      Next : constant Node_Id := CTN.Next_Node (N);
177
   begin
178 0
      CTN.Set_Next_Node (N, E);
179 0
      CTN.Set_Next_Node (E, Next);
180 0
   end Insert_After_Node;
181

182
   ------------------------
183
   -- Insert_Before_Node --
184
   ------------------------
185

186 0
   procedure Insert_Before_Node (E : Node_Id; N : Node_Id; L : List_Id) is
187 0
      Entity : Node_Id;
188
   begin
189 0
      Entity := CTN.First_Node (L);
190 0
      if Entity = N then
191 0
         CTN.Set_Next_Node (E, Entity);
192 0
         CTN.Set_First_Node (L, E);
193
      else
194 0
         while Present (Entity) loop
195 0
            exit when CTN.Next_Node (Entity) = N;
196 0
            Entity := CTN.Next_Node (Entity);
197 0
         end loop;
198

199 0
         Insert_After_Node (E, Entity);
200
      end if;
201 0
   end Insert_Before_Node;
202

203
   ---------------
204
   -- Copy_Node --
205
   ---------------
206

207 1
   function Copy_Node (N : Node_Id) return Node_Id is
208 1
      C : Node_Id;
209
   begin
210
      case CTN.Kind (N) is
211 1
         when K_Defining_Identifier =>
212 1
            C := New_Node (K_Defining_Identifier);
213 1
            CTN.Set_Name (C, CTN.Name (N));
214 1
            CTN.Set_Corresponding_Node (C, CTN.Corresponding_Node (N));
215

216 0
         when K_Function_Specification =>
217 0
            C := New_Node (K_Function_Specification);
218 0
            CTN.Set_Defining_Identifier
219
              (C,
220 0
               CTU.Copy_Node (Defining_Identifier (N)));
221 0
            CTN.Set_Parameters (C, CTN.Parameters (N));
222 0
            CTN.Set_Return_Type (C, CTN.Return_Type (N));
223

224 1
         when K_Include_Clause =>
225 1
            C := New_Node (K_Include_Clause);
226 1
            CTN.Set_Header_Name (C, CTU.Copy_Node (Header_Name (N)));
227 1
            CTN.Set_Is_Local (C, CTN.Is_Local (N));
228

229 1
         when K_Literal =>
230 1
            C := New_Node (K_Literal);
231 1
            CTN.Set_Value (C, CTN.Value (N));
232

233 1
         when K_Ifdef_Clause =>
234 1
            C := New_Node (K_Ifdef_Clause);
235 1
            CTN.Set_Negation (C, Negation (N));
236 1
            CTN.Set_Then_Statements (C, Then_Statements (N));
237 1
            CTN.Set_Else_Statements (C, Else_Statements (N));
238 1
            CTN.Set_Clause (C, Copy_Node (Clause (N)));
239

240 0
         when others =>
241 0
            raise Program_Error;
242
      end case;
243 1
      return C;
244
   end Copy_Node;
245

246
   ---------------------
247
   -- Message_Comment --
248
   ---------------------
249

250 0
   function Message_Comment (M : Name_Id) return Node_Id is
251 0
      C : Node_Id;
252
   begin
253 0
      C := Make_C_Comment (M);
254 0
      return C;
255
   end Message_Comment;
256

257
   ---------------------
258
   -- Message_Comment --
259
   ---------------------
260

261
   function Message_Comment (M : String) return Node_Id is
262 1
      C : Node_Id;
263
   begin
264 1
      Set_Str_To_Name_Buffer (M);
265 1
      C := Make_C_Comment (Name_Find);
266 1
      return C;
267
   end Message_Comment;
268

269
   -----------
270
   -- Image --
271
   -----------
272

273 1
   function Image (T : Token_Type) return String is
274
      S : String := Token_Type'Image (T);
275
   begin
276 1
      To_Lower (S);
277 1
      return S (5 .. S'Last);
278
   end Image;
279

280
   -----------
281
   -- Image --
282
   -----------
283

284 0
   function Image (O : Operator_Type) return String is
285 0
      S : String := Operator_Type'Image (O);
286
   begin
287 0
      To_Lower (S);
288 0
      for I in S'First .. S'Last loop
289 0
         if S (I) = '_' then
290 0
            S (I) := ' ';
291
         end if;
292 0
      end loop;
293 0
      return S (4 .. S'Last);
294 0
   end Image;
295

296
   ----------------
297
   -- Initialize --
298
   ----------------
299

300 1
   procedure Initialize is
301
   begin
302
      --  Initialize Nutils only once
303

304 1
      if Initialized then
305 0
         return;
306
      end if;
307

308 1
      Initialized := True;
309

310
      --  Keywords.
311 1
      for I in Keyword_Type loop
312 1
         New_Token (I);
313 1
      end loop;
314

315
      --  Graphic Characters
316 1
      New_Token (Tok_And, "&&");
317 1
      New_Token (Tok_Xor, "^");
318 1
      New_Token (Tok_Sharp, "#");
319 1
      New_Token (Tok_Or, "||");
320 1
      New_Token (Tok_Left_Brace, "{");
321 1
      New_Token (Tok_Right_Brace, "}");
322 1
      New_Token (Tok_Mod, "%");
323 1
      New_Token (Tok_Not, "!");
324 1
      New_Token (Tok_Ampersand, "&");
325 1
      New_Token (Tok_Minus, "-");
326 1
      New_Token (Tok_Underscore, "_");
327 1
      New_Token (Tok_Plus, "+");
328 1
      New_Token (Tok_Plus_Plus, "++");
329 1
      New_Token (Tok_Asterisk, "*");
330 1
      New_Token (Tok_Slash, "/");
331 1
      New_Token (Tok_Dot, ".");
332 1
      New_Token (Tok_Apostrophe, "'");
333 1
      New_Token (Tok_Left_Paren, "(");
334 1
      New_Token (Tok_Right_Paren, ")");
335 1
      New_Token (Tok_Left_Hook, "[");
336 1
      New_Token (Tok_Right_Hook, "]");
337 1
      New_Token (Tok_Comma, ",");
338 1
      New_Token (Tok_Less, "<");
339 1
      New_Token (Tok_Equal, "=");
340 1
      New_Token (Tok_Equal_Equal, "==");
341 1
      New_Token (Tok_Greater, ">");
342 1
      New_Token (Tok_Not_Equal, "!=");
343 1
      New_Token (Tok_Greater_Equal, ">=");
344 1
      New_Token (Tok_Less_Equal, "<=");
345 1
      New_Token (Tok_Colon, ":");
346 1
      New_Token (Tok_Greater_Greater, ">>");
347 1
      New_Token (Tok_Less_Less, "<<");
348 1
      New_Token (Tok_Quote, """");
349 1
      New_Token (Tok_Semicolon, ";");
350 1
      New_Token (Tok_Arrow, "->");
351 1
      New_Token (Tok_Vertical_Bar, "|");
352

353 1
      New_Operator (Op_Not, "!");
354 1
      New_Operator (Op_And, "&&");
355 1
      New_Operator (Op_Or, "||");
356 1
      New_Operator (Op_And_Symbol, "&");
357 1
      New_Operator (Op_Double_Asterisk, "**");
358 1
      New_Operator (Op_Asterisk, "**");
359 1
      New_Operator (Op_Minus, "-");
360 1
      New_Operator (Op_Plus, "+");
361 1
      New_Operator (Op_Plus_Plus, "++");
362 1
      New_Operator (Op_Asterisk, "*");
363 1
      New_Operator (Op_Slash, "/");
364 1
      New_Operator (Op_Less, "<");
365 1
      New_Operator (Op_Equal, "=");
366 1
      New_Operator (Op_Equal_Equal, "==");
367 1
      New_Operator (Op_Greater, ">");
368 1
      New_Operator (Op_Not_Equal, "!=");
369 1
      New_Operator (Op_Greater_Equal, ">=");
370 1
      New_Operator (Op_Less_Equal, "<=");
371 1
      New_Operator (Op_Greater_Greater, ">>");
372 1
      New_Operator (Op_Less_Less, "<<");
373 1
      New_Operator (Op_Semicolon, ";");
374 1
      New_Operator (Op_Arrow, "=>");
375 1
      New_Operator (Op_Modulo, "%");
376 1
      New_Operator (Op_Vertical_Bar, "|");
377

378 1
      for A in Attribute_Id loop
379 1
         Set_Str_To_Name_Buffer (Attribute_Id'Image (A));
380
         Set_Str_To_Name_Buffer (Name_Buffer (3 .. Name_Len));
381
         GNAT.Case_Util.To_Mixed (Name_Buffer (1 .. Name_Len));
382 1
         AN (A) := Name_Find;
383 1
      end loop;
384

385
      for C in Constant_Id loop
386 1
         Set_Str_To_Name_Buffer (Constant_Id'Image (C));
387
         Set_Str_To_Name_Buffer (Name_Buffer (3 .. Name_Len));
388 1
         CONST (C) := To_Upper (Name_Find);
389 0
      end loop;
390

391 1
      for P in Parameter_Id loop
392 1
         Set_Str_To_Name_Buffer (Parameter_Id'Image (P));
393
         Set_Str_To_Name_Buffer (Name_Buffer (3 .. Name_Len));
394
         GNAT.Case_Util.To_Mixed (Name_Buffer (1 .. Name_Len));
395 1
         PN (P) := Name_Find;
396 1
      end loop;
397

398 1
      for F in Function_Id loop
399 1
         Set_Str_To_Name_Buffer (Function_Id'Image (F));
400
         Set_Str_To_Name_Buffer (Name_Buffer (3 .. Name_Len));
401 1
         FN (F) := To_Lower (Name_Find);
402 1
      end loop;
403

404 1
      for T in Type_Id loop
405 1
         Set_Str_To_Name_Buffer (Type_Id'Image (T));
406
         Set_Str_To_Name_Buffer (Name_Buffer (3 .. Name_Len));
407 1
         TN (T) := To_Lower (Name_Find);
408 1
      end loop;
409

410 1
      for V in Variable_Id loop
411 1
         Set_Str_To_Name_Buffer (Variable_Id'Image (V));
412
         Set_Str_To_Name_Buffer (Name_Buffer (3 .. Name_Len));
413 1
         VN (V) := To_Lower (Name_Find);
414 1
      end loop;
415

416 1
      for V in Member_Id loop
417 1
         Set_Str_To_Name_Buffer (Member_Id'Image (V));
418
         Set_Str_To_Name_Buffer (Name_Buffer (3 .. Name_Len));
419

420 1
         MN (V) := To_Lower (Name_Find);
421 1
      end loop;
422
   end Initialize;
423

424
   -----------
425
   -- Reset --
426
   -----------
427

428 1
   procedure Reset is
429
   begin
430 1
      Entity_Stack.Init;
431

432 1
      Initialized := False;
433 1
   end Reset;
434

435
   --------------
436
   -- Is_Empty --
437
   --------------
438

439 1
   function Is_Empty (L : List_Id) return Boolean is
440
   begin
441 1
      return L = No_List or else No (CTN.First_Node (L));
442
   end Is_Empty;
443

444
   ------------
445
   -- Length --
446
   ------------
447

448 0
   function Length (L : List_Id) return Natural is
449 0
      N : Node_Id;
450 0
      C : Natural := 0;
451
   begin
452 0
      if not Is_Empty (L) then
453 0
         N := CTN.First_Node (L);
454

455 0
         while Present (N) loop
456 0
            C := C + 1;
457 0
            N := CTN.Next_Node (N);
458 0
         end loop;
459
      end if;
460

461 0
      return C;
462
   end Length;
463

464
   --------------------
465
   -- Make_C_Comment --
466
   --------------------
467

468 1
   function Make_C_Comment
469
     (N                 : Name_Id;
470
      Has_Header_Spaces : Boolean := True) return Node_Id
471
   is
472 1
      C : Node_Id;
473
   begin
474 1
      C := New_Node (K_C_Comment);
475 1
      Set_Defining_Identifier (C, New_Node (K_Defining_Identifier));
476 1
      CTN.Set_Name (Defining_Identifier (C), N);
477 1
      CTN.Set_Has_Header_Spaces (C, Has_Header_Spaces);
478 1
      return C;
479
   end Make_C_Comment;
480

481
   -------------------------------
482
   -- Make_Assignment_Statement --
483
   -------------------------------
484

485 1
   function Make_Assignment_Statement
486
     (Variable_Identifier : Node_Id;
487
      Expression          : Node_Id) return Node_Id
488
   is
489 1
      N : Node_Id;
490
   begin
491 1
      N := New_Node (K_Assignment_Statement);
492 1
      Set_Defining_Identifier (N, Variable_Identifier);
493 1
      Set_Expression (N, Expression);
494 1
      return N;
495
   end Make_Assignment_Statement;
496

497
   ------------------------------
498
   -- Make_Defining_Identifier --
499
   ------------------------------
500

501 1
   function Make_Defining_Identifier
502
     (Name             : Name_Id;
503
      C_Conversion     : Boolean := True;
504
      Ada_Conversion   : Boolean := False;
505
      Pointer          : Boolean := False;
506
      Variable_Address : Boolean := False) return Node_Id
507
   is
508 1
      N : Node_Id;
509

510
   begin
511 1
      N := New_Node (K_Defining_Identifier);
512 1
      if C_Conversion then
513 1
         CTN.Set_Name (N, To_C_Name (Name, Ada_Conversion));
514
      else
515 1
         CTN.Set_Name (N, Name);
516
      end if;
517

518 1
      if Pointer then
519 1
         CTN.Set_Is_Pointer (N, True);
520
      end if;
521

522 1
      if Variable_Address then
523 1
         CTN.Set_Is_Variable_Address (N, True);
524
      end if;
525

526 1
      return N;
527
   end Make_Defining_Identifier;
528

529
   ---------------------
530
   -- Make_Expression --
531
   ---------------------
532

533 1
   function Make_Expression
534
     (Left_Expr  : Node_Id;
535
      Operator   : Operator_Type := Op_None;
536
      Right_Expr : Node_Id       := No_Node) return Node_Id
537
   is
538 1
      N : Node_Id;
539
   begin
540 1
      N := New_Node (K_Expression);
541 1
      Set_Left_Expression (N, Left_Expr);
542 1
      Set_Operator (N, Operator_Type'Pos (Operator));
543 1
      Set_Right_Expression (N, Right_Expr);
544 1
      return N;
545
   end Make_Expression;
546

547
   ------------------------
548
   -- Make_For_Statement --
549
   ------------------------
550

551 1
   function Make_For_Statement
552
     (Pre_Cond            : Node_Id;
553
      Condition           : Node_Id;
554
      Post_Cond           : Node_Id;
555
      Statements          : List_Id) return Node_Id
556
   is
557 1
      N : Node_Id;
558
   begin
559 1
      N := New_Node (K_For_Statement);
560 1
      Set_Pre_Cond (N, Pre_Cond);
561 1
      Set_Condition (N, Condition);
562 1
      Set_Post_Cond (N, Post_Cond);
563 1
      Set_Statements (N, Statements);
564 1
      return N;
565
   end Make_For_Statement;
566

567
   ------------------
568
   -- Make_Literal --
569
   ------------------
570

571 1
   function Make_Literal (Value : Value_Id) return Node_Id is
572 1
      N : Node_Id;
573
   begin
574 1
      N := New_Node (K_Literal);
575 1
      CTN.Set_Value (N, Value);
576 1
      return N;
577
   end Make_Literal;
578

579
   -------------------------
580
   -- Make_Loop_Statement --
581
   -------------------------
582

583 1
   function Make_While_Statement
584
     (Condition  : Node_Id;
585
      Statements : List_Id) return Node_Id
586
   is
587 1
      N : Node_Id;
588
   begin
589 1
      N := New_Node (K_While_Statement);
590 1
      Set_Condition (N, Condition);
591 1
      Set_Statements (N, Statements);
592 1
      return N;
593
   end Make_While_Statement;
594

595
   --------------------------------
596
   -- Make_Full_Type_Declaration --
597
   --------------------------------
598

599 1
   function Make_Full_Type_Declaration
600
     (Defining_Identifier : Node_Id;
601
      Type_Definition     : Node_Id) return Node_Id
602
   is
603 1
      N : Node_Id;
604

605
   begin
606 1
      N := New_Node (K_Full_Type_Declaration);
607 1
      Set_Type_Name (N, Defining_Identifier);
608 1
      Set_Type_Definition (N, Type_Definition);
609 1
      return N;
610
   end Make_Full_Type_Declaration;
611

612
   -----------------------
613
   -- Make_If_Statement --
614
   -----------------------
615

616 1
   function Make_If_Statement
617
     (Condition       : Node_Id;
618
      Statements      : List_Id;
619
      Else_Statements : List_Id := No_List) return Node_Id
620
   is
621 1
      N : Node_Id;
622
   begin
623 1
      N := New_Node (K_If_Statement);
624 1
      Set_Condition (N, Condition);
625 1
      Set_Statements (N, Statements);
626 1
      Set_Else_Statements (N, Else_Statements);
627 1
      return N;
628
   end Make_If_Statement;
629

630
   ------------------
631
   -- Make_List_Id --
632
   ------------------
633

634 1
   function Make_List_Id
635
     (N1 : Node_Id;
636
      N2 : Node_Id := No_Node;
637
      N3 : Node_Id := No_Node) return List_Id
638
   is
639 1
      L : List_Id;
640
   begin
641 1
      L := New_List (K_List_Id);
642 1
      Append_Node_To_List (N1, L);
643 1
      if Present (N2) then
644 1
         Append_Node_To_List (N2, L);
645

646 1
         if Present (N3) then
647 0
            Append_Node_To_List (N3, L);
648
         end if;
649
      end if;
650 1
      return L;
651
   end Make_List_Id;
652

653
   ----------------------------------
654
   -- Make_Parameter_Specification --
655
   ----------------------------------
656

657 1
   function Make_Parameter_Specification
658
     (Defining_Identifier : Node_Id;
659
      Parameter_Type      : Node_Id := No_Node) return Node_Id
660
   is
661 1
      P : Node_Id;
662

663
   begin
664 1
      P := New_Node (K_Parameter_Specification);
665 1
      Set_Defining_Identifier (P, Defining_Identifier);
666 1
      Set_Parameter_Type (P, Parameter_Type);
667 1
      return P;
668
   end Make_Parameter_Specification;
669

670
   ---------------------------
671
   -- Make_Return_Statement --
672
   ---------------------------
673

674 1
   function Make_Return_Statement
675
     (Expression : Node_Id := No_Node) return Node_Id
676
   is
677 1
      N : Node_Id;
678
   begin
679 1
      N := New_Node (K_Return_Statement);
680 1
      if Expression /= No_Node then
681 1
         Set_Expression (N, Expression);
682
      end if;
683 1
      return N;
684
   end Make_Return_Statement;
685

686
   ---------------------------------
687
   -- Make_Function_Specification --
688
   ---------------------------------
689

690 1
   function Make_Function_Specification
691
     (Defining_Identifier : Node_Id;
692
      Parameters          : List_Id := No_List;
693
      Return_Type         : Node_Id := No_Node) return Node_Id
694
   is
695 1
      N : Node_Id;
696
   begin
697 1
      N := New_Node (K_Function_Specification);
698 1
      Set_Parameters (N, Parameters);
699 1
      Set_Defining_Identifier (N, Defining_Identifier);
700 1
      Set_Return_Type (N, Return_Type);
701 1
      return N;
702
   end Make_Function_Specification;
703

704
   ----------------------------------
705
   -- Make_Function_Implementation --
706
   ----------------------------------
707

708 1
   function Make_Function_Implementation
709
     (Specification : Node_Id;
710
      Declarations  : List_Id;
711
      Statements    : List_Id) return Node_Id
712
   is
713 1
      N : Node_Id;
714

715
   begin
716 1
      N := New_Node (K_Function_Implementation);
717 1
      Set_Specification (N, Specification);
718 1
      CTN.Set_Declarations (N, Declarations);
719 1
      Set_Statements (N, Statements);
720 1
      return N;
721
   end Make_Function_Implementation;
722

723
   -----------------------------
724
   -- Make_Member_Declaration --
725
   -----------------------------
726

727 1
   function Make_Member_Declaration
728
     (Defining_Identifier : Node_Id;
729
      Used_Type           : Node_Id) return Node_Id
730
   is
731 1
      P : Node_Id;
732
   begin
733 1
      P := New_Node (K_Member_Declaration);
734 1
      Set_Defining_Identifier (P, Defining_Identifier);
735 1
      Set_Used_Type (P, Used_Type);
736 1
      return P;
737
   end Make_Member_Declaration;
738

739
   -------------------------------
740
   -- Make_Variable_Declaration --
741
   -------------------------------
742

743 1
   function Make_Variable_Declaration
744
     (Defining_Identifier : Node_Id;
745
      Used_Type           : Node_Id;
746
      Is_Static           : Boolean := False;
747
      Value               : Node_Id := No_Node) return Node_Id
748
   is
749 1
      P : Node_Id;
750
   begin
751 1
      P := New_Node (K_Variable_Declaration);
752 1
      Set_Defining_Identifier (P, Defining_Identifier);
753 1
      Set_Used_Type (P, Used_Type);
754 1
      Set_Is_Static (P, Is_Static);
755 1
      Set_Initialization_Value (P, Value);
756 1
      return P;
757
   end Make_Variable_Declaration;
758

759
   ---------------------------
760
   -- Make_Variable_Address --
761
   ---------------------------
762

763 1
   function Make_Variable_Address (Expression : Node_Id) return Node_Id is
764 1
      P : Node_Id;
765
   begin
766 1
      P := New_Node (K_Variable_Address);
767 1
      Set_Expression (P, Expression);
768 1
      return P;
769
   end Make_Variable_Address;
770

771
   ------------------------------------
772
   -- Make_Extern_Entity_Declaration --
773
   ------------------------------------
774

775 1
   function Make_Extern_Entity_Declaration (Entity : Node_Id) return Node_Id is
776 1
      P : Node_Id;
777
   begin
778 1
      P := New_Node (K_Extern_Entity_Declaration);
779 1
      CTN.Set_Entity (P, Entity);
780 1
      return P;
781
   end Make_Extern_Entity_Declaration;
782

783
   ---------------------------
784
   -- Make_Struct_Aggregate --
785
   ---------------------------
786

787 1
   function Make_Struct_Aggregate
788
     (Defining_Identifier : Node_Id := No_Node;
789
      Members             : List_Id) return Node_Id
790
   is
791 1
      N : Node_Id;
792
   begin
793 1
      N := New_Node (K_Struct_Aggregate);
794 1
      if Defining_Identifier /= No_Node then
795 0
         Set_Defining_Identifier (N, Defining_Identifier);
796
      end if;
797 1
      Set_Struct_Members (N, Members);
798 1
      return N;
799
   end Make_Struct_Aggregate;
800

801
   --------------------------
802
   -- Make_Union_Aggregate --
803
   --------------------------
804

805 1
   function Make_Union_Aggregate
806
     (Defining_Identifier : Node_Id := No_Node;
807
      Members             : List_Id) return Node_Id
808
   is
809 1
      N : Node_Id;
810
   begin
811 1
      N := New_Node (K_Union_Aggregate);
812 1
      if Defining_Identifier /= No_Node then
813 0
         Set_Defining_Identifier (N, Defining_Identifier);
814
      end if;
815 1
      Set_Union_Members (N, Members);
816 1
      return N;
817
   end Make_Union_Aggregate;
818

819
   -------------------------
820
   -- Make_Enum_Aggregate --
821
   -------------------------
822

823 1
   function Make_Enum_Aggregate (Members : List_Id) return Node_Id is
824 1
      N : Node_Id;
825
   begin
826 1
      N := New_Node (K_Enum_Aggregate);
827 1
      Set_Enum_Members (N, Members);
828 1
      return N;
829
   end Make_Enum_Aggregate;
830

831
   -----------------------
832
   -- Make_Call_Profile --
833
   -----------------------
834

835 1
   function Make_Call_Profile
836
     (Defining_Identifier : Node_Id;
837
      Parameters          : List_Id := No_List) return Node_Id
838
   is
839 1
      N : Node_Id;
840
   begin
841 1
      N := New_Node (K_Call_Profile);
842 1
      Set_Defining_Identifier (N, Defining_Identifier);
843 1
      Set_Parameters (N, Parameters);
844 1
      return N;
845
   end Make_Call_Profile;
846

847
   ---------------------
848
   -- Make_Macro_Call --
849
   ---------------------
850

851 1
   function Make_Macro_Call
852
     (Defining_Identifier : Node_Id;
853
      Parameters          : List_Id := No_List) return Node_Id
854
   is
855 1
      N : Node_Id;
856
   begin
857 1
      N := New_Node (K_Macro_Call);
858 1
      Set_Defining_Identifier (N, Defining_Identifier);
859 1
      Set_Parameters (N, Parameters);
860 1
      return N;
861
   end Make_Macro_Call;
862

863
   -------------------------
864
   -- Make_Type_Attribute --
865
   -------------------------
866

867 0
   function Make_Type_Attribute
868
     (Designator : Node_Id;
869
      Attribute  : Attribute_Id) return Node_Id
870
   is
871
      procedure Get_Scoped_Name_String (S : Node_Id);
872

873
      ----------------------------
874
      -- Get_Scoped_Name_String --
875
      ----------------------------
876

877 0
      procedure Get_Scoped_Name_String (S : Node_Id) is
878
      begin
879 0
         Get_Name_String_And_Append (CTN.Name (Defining_Identifier (S)));
880 0
      end Get_Scoped_Name_String;
881

882
   begin
883 0
      Name_Len := 0;
884 0
      Get_Scoped_Name_String (Designator);
885 0
      Add_Char_To_Name_Buffer (''');
886 0
      Get_Name_String_And_Append (AN (Attribute));
887 0
      return Make_Defining_Identifier (Name_Find);
888
   end Make_Type_Attribute;
889

890
   --------------------------
891
   -- Make_Type_Conversion --
892
   --------------------------
893

894 1
   function Make_Type_Conversion
895
     (Subtype_Mark : Node_Id;
896
      Expression   : Node_Id) return Node_Id
897
   is
898 1
      N : Node_Id;
899
   begin
900 1
      N := New_Node (K_Type_Conversion);
901 1
      Set_Subtype_Mark (N, Subtype_Mark);
902 1
      Set_Expression (N, Expression);
903 1
      return N;
904
   end Make_Type_Conversion;
905

906
   -------------------------
907
   -- Make_Comment_Header --
908
   -------------------------
909

910 1
   procedure Make_Comment_Header (Header : List_Id) is
911 1
      N : Node_Id;
912
   begin
913
      --  Appending the comment header lines to the file header
914

915 1
      Set_Str_To_Name_Buffer
916
        ("***************************************************");
917 1
      N := Make_C_Comment (Name_Find, False);
918 1
      Append_Node_To_List (N, Header);
919

920 1
      Set_Str_To_Name_Buffer
921
        ("This file was automatically generated by Ocarina ");
922 1
      N := Make_C_Comment (Name_Find);
923 1
      Append_Node_To_List (N, Header);
924

925 1
      Set_Str_To_Name_Buffer
926
        (SCM_Version.all);
927 1
      N := Make_C_Comment (Name_Find);
928 1
      Append_Node_To_List (N, Header);
929

930 1
      Set_Str_To_Name_Buffer
931
        ("Do NOT hand-modify this file, as your            ");
932 1
      N := Make_C_Comment (Name_Find);
933 1
      Append_Node_To_List (N, Header);
934

935 1
      Set_Str_To_Name_Buffer
936
        ("changes will be lost when you re-run Ocarina     ");
937 1
      N := Make_C_Comment (Name_Find);
938 1
      Append_Node_To_List (N, Header);
939

940 1
      Set_Str_To_Name_Buffer
941
        ("***************************************************");
942 1
      N := Make_C_Comment (Name_Find, False);
943 1
      Append_Node_To_List (N, Header);
944

945 1
   end Make_Comment_Header;
946

947
   -----------------
948
   -- Next_N_Node --
949
   -----------------
950

951 0
   function Next_N_Node (N : Node_Id; Num : Natural) return Node_Id is
952 0
      Result : Node_Id := N;
953
   begin
954 0
      for I in 1 .. Num loop
955 0
         Result := CTN.Next_Node (Result);
956 0
      end loop;
957

958 0
      return Result;
959
   end Next_N_Node;
960

961
   --------------
962
   -- New_List --
963
   --------------
964

965 1
   function New_List
966
     (Kind : CTN.Node_Kind;
967
      From : Node_Id := No_Node) return List_Id
968
   is
969 1
      N : Node_Id;
970

971
   begin
972 1
      CTN.Entries.Increment_Last;
973 1
      N                     := CTN.Entries.Last;
974
      CTN.Entries.Table (N) := CTN.Default_Node;
975 1
      Set_Kind (N, Kind);
976 1
      if Present (From) then
977 0
         CTN.Set_Loc (N, CTN.Loc (From));
978
      else
979 1
         CTN.Set_Loc (N, No_Location);
980
      end if;
981 1
      return List_Id (N);
982
   end New_List;
983

984
   --------------
985
   -- New_Node --
986
   --------------
987

988 1
   function New_Node
989
     (Kind : CTN.Node_Kind;
990
      From : Node_Id := No_Node) return Node_Id
991
   is
992 1
      N : Node_Id;
993
   begin
994 1
      CTN.Entries.Increment_Last;
995 1
      N                     := CTN.Entries.Last;
996
      CTN.Entries.Table (N) := CTN.Default_Node;
997 1
      CTN.Set_Kind (N, Kind);
998

999 1
      if Present (From) then
1000 1
         CTN.Set_Loc (N, AIN.Loc (From));
1001
      else
1002 1
         CTN.Set_Loc (N, No_Location);
1003
      end if;
1004

1005 1
      return N;
1006
   end New_Node;
1007

1008
   ---------------
1009
   -- New_Token --
1010
   ---------------
1011

1012 1
   procedure New_Token (T : Token_Type; I : String := "") is
1013 1
      Name : Name_Id;
1014
   begin
1015 1
      if T in Keyword_Type then
1016
         --  Marking the token image as a keyword for fas searching
1017
         --  purpose, we add the prefix to avoir collision with other
1018
         --  languages keywords
1019

1020 1
         Set_Str_To_Name_Buffer (Image (T));
1021 1
         Name := Name_Find;
1022 1
         Name := Add_Suffix_To_Name (Keyword_Suffix, Name);
1023
         Set_Name_Table_Byte
1024
           (Name,
1025 1
            Ocarina.Types.Byte (Token_Type'Pos (T) + 1));
1026

1027 1
         Set_Str_To_Name_Buffer (Image (T));
1028
      else
1029 1
         Set_Str_To_Name_Buffer (I);
1030
      end if;
1031
      Token_Image (T) := Name_Find;
1032 1
   end New_Token;
1033

1034
   ------------------
1035
   -- New_Operator --
1036
   ------------------
1037

1038
   procedure New_Operator (O : Operator_Type; I : String := "") is
1039
   begin
1040

1041 1
      Set_Str_To_Name_Buffer (I);
1042
      Operator_Image (Operator_Type'Pos (O)) := Name_Find;
1043 1
   end New_Operator;
1044

1045
   ----------------
1046
   -- Pop_Entity --
1047
   ----------------
1048

1049 1
   procedure Pop_Entity is
1050
   begin
1051 1
      if Last > No_Depth then
1052 1
         Decrement_Last;
1053
      end if;
1054 1
   end Pop_Entity;
1055

1056
   -----------------
1057
   -- Push_Entity --
1058
   -----------------
1059

1060 1
   procedure Push_Entity (E : Node_Id) is
1061
   begin
1062 1
      Increment_Last;
1063
      Table (Last).Current_Entity := E;
1064 1
   end Push_Entity;
1065

1066
   ---------------------------
1067
   -- Remove_Node_From_List --
1068
   ---------------------------
1069

1070 0
   procedure Remove_Node_From_List (E : Node_Id; L : List_Id) is
1071 0
      C : Node_Id;
1072

1073
   begin
1074 0
      C := CTN.First_Node (L);
1075 0
      if C = E then
1076 0
         CTN.Set_First_Node (L, CTN.Next_Node (E));
1077 0
         if CTN.Last_Node (L) = E then
1078 0
            CTN.Set_Last_Node (L, No_Node);
1079
         end if;
1080
      else
1081 0
         while Present (C) loop
1082 0
            if CTN.Next_Node (C) = E then
1083 0
               CTN.Set_Next_Node (C, CTN.Next_Node (E));
1084 0
               if CTN.Last_Node (L) = E then
1085 0
                  CTN.Set_Last_Node (L, C);
1086
               end if;
1087 0
               exit;
1088
            end if;
1089 0
            C := CTN.Next_Node (C);
1090 0
         end loop;
1091
      end if;
1092 0
   end Remove_Node_From_List;
1093

1094
   ---------------------
1095
   -- Set_Main_Source --
1096
   ---------------------
1097

1098 1
   procedure Set_Main_Source (N : Node_Id := No_Node) is
1099 1
      X : Node_Id := N;
1100
   begin
1101 1
      if No (X) then
1102
         X := Table (Last).Current_Entity;
1103
      end if;
1104
      Table (Last).Current_File := Main_Source (X);
1105 1
   end Set_Main_Source;
1106

1107
   ---------------------
1108
   -- Set_Main_Header --
1109
   ---------------------
1110

1111 0
   procedure Set_Main_Header (N : Node_Id := No_Node) is
1112 0
      X : Node_Id := N;
1113
   begin
1114 0
      if No (X) then
1115 0
         X := Table (Last).Current_Entity;
1116
      end if;
1117 0
      Table (Last).Current_File := Main_Header (X);
1118 0
   end Set_Main_Header;
1119

1120
   ---------------
1121
   -- To_C_Name --
1122
   ---------------
1123

1124 1
   function To_C_Name
1125
     (N             : Name_Id;
1126
      Ada_Style     : Boolean := False;
1127
      Keyword_Check : Boolean := True) return Name_Id
1128
   is
1129 1
      Name      : Name_Id;
1130 1
      Test_Name : Name_Id;
1131 1
      V         : Ocarina.Types.Byte;
1132
   begin
1133 1
      Get_Name_String (Normalize_Name (N, Ada_Style));
1134 1
      Name := Name_Find;
1135

1136 1
      if Keyword_Check then
1137

1138
         --  If the identifier collides with a C reserved word insert
1139
         --  "AADL_" string before the identifier.
1140

1141 1
         Test_Name := Add_Suffix_To_Name (Keyword_Suffix, Name);
1142 1
         V         := Get_Name_Table_Byte (Test_Name);
1143 1
         if V > 0 then
1144 0
            Set_Str_To_Name_Buffer ("AADL_");
1145 0
            Get_Name_String_And_Append (Name);
1146 0
            Name := Name_Find;
1147
         end if;
1148
      end if;
1149 1
      return To_Lower (Name);
1150
   end To_C_Name;
1151

1152
   ----------------------------
1153
   -- Conventional_Base_Name --
1154
   ----------------------------
1155

1156 1
   function Conventional_Base_Name (N : Name_Id) return Name_Id is
1157
   begin
1158 1
      Get_Name_String (N);
1159

1160 1
      for Index in 1 .. Name_Len loop
1161
         Name_Buffer (Index) := To_Lower (Name_Buffer (Index));
1162 1
      end loop;
1163

1164 1
      return Name_Find;
1165
   end Conventional_Base_Name;
1166

1167
   -------------------------
1168
   -- Set_Activity_Source --
1169
   -------------------------
1170

1171 1
   procedure Set_Activity_Source (N : Node_Id := No_Node) is
1172 1
      X : Node_Id := N;
1173
   begin
1174 1
      if No (X) then
1175
         X := Table (Last).Current_Entity;
1176
      end if;
1177
      Table (Last).Current_File := Activity_Source (X);
1178 1
   end Set_Activity_Source;
1179

1180
   ---------------------------
1181
   -- Set_Deployment_Header --
1182
   ---------------------------
1183

1184 1
   procedure Set_Deployment_Header (N : Node_Id := No_Node) is
1185 1
      X : Node_Id := N;
1186
   begin
1187 1
      if No (X) then
1188
         X := Table (Last).Current_Entity;
1189
      end if;
1190
      Table (Last).Current_File := Deployment_Header (X);
1191 1
   end Set_Deployment_Header;
1192

1193
   ---------------------------
1194
   -- Set_Deployment_Source --
1195
   ---------------------------
1196

1197 1
   procedure Set_Deployment_Source (N : Node_Id := No_Node) is
1198 1
      X : Node_Id := N;
1199
   begin
1200 1
      if No (X) then
1201
         X := Table (Last).Current_Entity;
1202
      end if;
1203
      Table (Last).Current_File := Deployment_Source (X);
1204 1
   end Set_Deployment_Source;
1205

1206
   -------------------------
1207
   -- Set_Activity_Header --
1208
   -------------------------
1209

1210 1
   procedure Set_Activity_Header (N : Node_Id := No_Node) is
1211 1
      X : Node_Id := N;
1212
   begin
1213 1
      if No (X) then
1214
         X := Table (Last).Current_Entity;
1215
      end if;
1216
      Table (Last).Current_File := Activity_Header (X);
1217 1
   end Set_Activity_Header;
1218

1219
   ------------------------
1220
   -- Set_Request_Header --
1221
   ------------------------
1222

1223 1
   procedure Set_Request_Header (N : Node_Id := No_Node) is
1224 1
      X : Node_Id := N;
1225
   begin
1226 1
      if No (X) then
1227
         X := Table (Last).Current_Entity;
1228
      end if;
1229
      Table (Last).Current_File := Request_Header (X);
1230 1
   end Set_Request_Header;
1231

1232
   ------------------------
1233
   -- Set_Request_Source --
1234
   ------------------------
1235

1236 1
   procedure Set_Request_Source (N : Node_Id := No_Node) is
1237 1
      X : Node_Id := N;
1238
   begin
1239 1
      if No (X) then
1240
         X := Table (Last).Current_Entity;
1241
      end if;
1242
      Table (Last).Current_File := Request_Source (X);
1243 1
   end Set_Request_Source;
1244

1245
   ----------------------------
1246
   -- Set_Marshallers_Source --
1247
   ----------------------------
1248 1
   procedure Set_Marshallers_Source (N : Node_Id := No_Node) is
1249 1
      X : Node_Id := N;
1250
   begin
1251 1
      if No (X) then
1252
         X := Table (Last).Current_Entity;
1253
      end if;
1254
      Table (Last).Current_File := Marshallers_Source (X);
1255 1
   end Set_Marshallers_Source;
1256

1257
   ----------------------
1258
   -- Set_Types_Header --
1259
   ----------------------
1260

1261 1
   procedure Set_Types_Header (N : Node_Id := No_Node) is
1262 1
      X : Node_Id := N;
1263
   begin
1264 1
      if No (X) then
1265
         X := Table (Last).Current_Entity;
1266
      end if;
1267
      Table (Last).Current_File := Types_Header (X);
1268 1
   end Set_Types_Header;
1269

1270
   ----------------------------
1271
   -- Set_Marshallers_Header --
1272
   ----------------------------
1273

1274 1
   procedure Set_Marshallers_Header (N : Node_Id := No_Node) is
1275 1
      X : Node_Id := N;
1276
   begin
1277 1
      if No (X) then
1278
         X := Table (Last).Current_Entity;
1279
      end if;
1280
      Table (Last).Current_File := Marshallers_Header (X);
1281 1
   end Set_Marshallers_Header;
1282

1283
   ----------------------------
1284
   -- Set_Subprograms_Header --
1285
   ----------------------------
1286

1287 1
   procedure Set_Subprograms_Header (N : Node_Id := No_Node) is
1288 1
      X : Node_Id := N;
1289
   begin
1290 1
      if No (X) then
1291
         X := Table (Last).Current_Entity;
1292
      end if;
1293
      Table (Last).Current_File := Subprograms_Header (X);
1294 1
   end Set_Subprograms_Header;
1295

1296
   -----------------------
1297
   -- Set_Naming_Header --
1298
   -----------------------
1299

1300 1
   procedure Set_Naming_Header (N : Node_Id := No_Node) is
1301 1
      X : Node_Id := N;
1302
   begin
1303 1
      if No (X) then
1304 0
         X := Table (Last).Current_Entity;
1305
      end if;
1306
      Table (Last).Current_File := Naming_Header (X);
1307 1
   end Set_Naming_Header;
1308

1309
   -----------------------
1310
   -- Set_Naming_Source --
1311
   -----------------------
1312

1313 1
   procedure Set_Naming_Source (N : Node_Id := No_Node) is
1314 1
      X : Node_Id := N;
1315
   begin
1316 1
      if No (X) then
1317
         X := Table (Last).Current_Entity;
1318
      end if;
1319
      Table (Last).Current_File := Naming_Source (X);
1320 1
   end Set_Naming_Source;
1321

1322
   ----------------------------
1323
   -- Set_Subprograms_Source --
1324
   ----------------------------
1325

1326 1
   procedure Set_Subprograms_Source (N : Node_Id := No_Node) is
1327 1
      X : Node_Id := N;
1328
   begin
1329 1
      if No (X) then
1330
         X := Table (Last).Current_Entity;
1331
      end if;
1332
      Table (Last).Current_File := Subprograms_Source (X);
1333 1
   end Set_Subprograms_Source;
1334

1335
   ----------------------
1336
   -- Set_Types_Source --
1337
   ----------------------
1338

1339 1
   procedure Set_Types_Source (N : Node_Id := No_Node) is
1340 1
      X : Node_Id := N;
1341
   begin
1342 1
      if No (X) then
1343
         X := Table (Last).Current_Entity;
1344
      end if;
1345
      Table (Last).Current_File := Types_Source (X);
1346 1
   end Set_Types_Source;
1347

1348
   --------------------
1349
   -- Current_Entity --
1350
   --------------------
1351

1352 1
   function Current_Entity return Node_Id is
1353
   begin
1354 1
      if Last = No_Depth then
1355 0
         return No_Node;
1356
      else
1357
         return Table (Last).Current_Entity;
1358
      end if;
1359
   end Current_Entity;
1360

1361
   ------------------
1362
   -- Current_File --
1363
   ------------------
1364

1365 1
   function Current_File return Node_Id is
1366
   begin
1367 1
      if Last = No_Depth then
1368 0
         return No_Node;
1369
      else
1370
         return Table (Last).Current_File;
1371
      end if;
1372
   end Current_File;
1373

1374
   ----------------------
1375
   -- Make_Source_File --
1376
   ----------------------
1377

1378 1
   function Make_Source_File (Identifier : Node_Id) return Node_Id is
1379 1
      File : Node_Id;
1380
   begin
1381 1
      File := New_Node (K_Source_File);
1382 1
      Set_Defining_Identifier (File, Identifier);
1383 1
      Set_Corresponding_Node (Identifier, File);
1384

1385 1
      CTN.Set_Included_Headers (File, New_List (K_Header_List));
1386 1
      CTN.Set_Declarations (File, New_List (CTN.K_Declaration_List));
1387 1
      Make_Comment_Header (CTN.Declarations (File));
1388

1389 1
      return File;
1390
   end Make_Source_File;
1391

1392
   ----------------------
1393
   -- Make_Header_File --
1394
   ----------------------
1395

1396 1
   function Make_Header_File (Identifier : Node_Id) return Node_Id is
1397 1
      File : Node_Id;
1398
   begin
1399 1
      File := New_Node (K_Header_File);
1400 1
      Set_Defining_Identifier (File, Identifier);
1401 1
      Set_Corresponding_Node (Identifier, File);
1402

1403 1
      CTN.Set_Included_Headers (File, New_List (K_Header_List));
1404 1
      CTN.Set_Declarations (File, New_List (CTN.K_Declaration_List));
1405 1
      Make_Comment_Header (CTN.Declarations (File));
1406

1407 1
      return File;
1408
   end Make_Header_File;
1409

1410
   -----------------
1411
   -- Add_Include --
1412
   -----------------
1413

1414 1
   procedure Add_Include (E : Node_Id; Preserve_Case : Boolean := False) is
1415 1
      W                : Node_Id;
1416 1
      N                : Name_Id;
1417 1
      M                : Name_Id;
1418 1
      Existing_Include : Node_Id;
1419
   begin
1420
      --  Get the info associated to the obtained name in the hash
1421
      --  table and check whether it is already set to a value
1422
      --  different from 0 (No_Node) which means that the withed
1423
      --  entity is already in the withed package list. In this case
1424
      --  try to enrich the exisiting with clause with eventual 'use',
1425
      --  'elaborate' or warning disabling clauses.
1426 1
      Get_Name_String (CTN.Name (Defining_Identifier (Current_File)));
1427

1428 1
      if Kind (Current_File) = K_Header_File then
1429
         --  If the included file is the file in which we add the
1430
         --  include, we return immediatly, because a file don't
1431
         --  include itself
1432 1
         if To_Lower (CTN.Name (CTN.Header_Name (E))) =
1433 1
           To_Lower (CTN.Name (Defining_Identifier (Current_File)))
1434
         then
1435 1
            return;
1436
         end if;
1437

1438
         Set_Str_To_Name_Buffer (Name_Buffer (1 .. Name_Len) & ".h");
1439
      else
1440
         Set_Str_To_Name_Buffer (Name_Buffer (1 .. Name_Len) & ".c");
1441
      end if;
1442

1443 1
      Get_Name_String_And_Append (CTN.Name (CTN.Header_Name (E)));
1444 1
      Get_Name_String_And_Append
1445 1
        (CTN.Name (CTN.Entity (Distributed_Application_Unit (Current_File))));
1446

1447 1
      if Distributed_Application
1448 1
          (Entity (Distributed_Application_Unit (Current_File))) /=
1449
        No_Node
1450
      then
1451 1
         Get_Name_String_And_Append
1452 1
           (CTN.Name
1453 1
              (Distributed_Application
1454 1
                 (Entity (Distributed_Application_Unit (Current_File)))));
1455
      end if;
1456

1457 1
      if Preserve_Case then
1458 1
         N := Name_Find;
1459
      else
1460 1
         N := To_Lower (Name_Find);
1461
      end if;
1462

1463 1
      Existing_Include := Node_Id (Get_Name_Table_Info (N));
1464

1465
      --  If the file was already included, we return immediatly
1466 1
      if Present (Existing_Include) then
1467 1
         return;
1468
      end if;
1469

1470
      --  Else, we add the corresponding header file to included files
1471 1
      Get_Name_String (CTN.Name (Header_Name ((E))));
1472

1473 1
      M := Name_Find;
1474
      W :=
1475 1
        Make_Include_Clause
1476 1
          (Make_Defining_Identifier (M, not Preserve_Case),
1477 1
           Is_Local (E));
1478 1
      Set_Name_Table_Info (N, Int (W));
1479

1480 1
      Append_Node_To_List (W, Included_Headers (Current_File));
1481
   end Add_Include;
1482

1483
   ---------------------------
1484
   -- Make_Define_Statement --
1485
   ---------------------------
1486

1487 1
   function Make_Define_Statement
1488
     (Defining_Identifier : Node_Id;
1489
      Value               : Node_Id) return Node_Id
1490
   is
1491 1
      N : Node_Id;
1492
   begin
1493 1
      N := New_Node (K_Define_Statement);
1494 1
      Set_Defining_Identifier (N, Defining_Identifier);
1495 1
      Set_Defined_Value (N, Value);
1496 1
      return N;
1497
   end Make_Define_Statement;
1498

1499
   -----------------------
1500
   -- Make_Pointer_Type --
1501
   -----------------------
1502

1503 1
   function Make_Pointer_Type (Used_Type : Node_Id) return Node_Id is
1504 1
      N : Node_Id;
1505
   begin
1506 1
      N := New_Node (K_Pointer_Type);
1507 1
      Set_Used_Type (N, Used_Type);
1508 1
      return (N);
1509
   end Make_Pointer_Type;
1510

1511
   ------------------------
1512
   -- Make_Constant_Type --
1513
   ------------------------
1514

1515 1
   function Make_Constant_Type (Used_Type : Node_Id) return Node_Id is
1516 1
      N : Node_Id;
1517
   begin
1518 1
      N := New_Node (K_Constant_Type);
1519 1
      Set_Used_Type (N, Used_Type);
1520 1
      return (N);
1521
   end Make_Constant_Type;
1522

1523
   ----------------------------
1524
   -- Make_Member_Designator --
1525
   ----------------------------
1526

1527 1
   function Make_Member_Designator
1528
     (Defining_Identifier : Node_Id;
1529
      Aggregate_Name      : Node_Id;
1530
      Is_Pointer          : Boolean := False) return Node_Id
1531
   is
1532 1
      N : Node_Id;
1533
   begin
1534 1
      N := New_Node (K_Member_Designator);
1535 1
      Set_Defining_Identifier (N, Defining_Identifier);
1536 1
      Set_Is_Pointer (N, Is_Pointer);
1537 1
      Set_Aggregate_Name (N, Aggregate_Name);
1538 1
      return (N);
1539
   end Make_Member_Designator;
1540

1541
   ----------------------------
1542
   -- Make_Array_Declaration --
1543
   ----------------------------
1544

1545 1
   function Make_Array_Declaration
1546
     (Defining_Identifier : Node_Id;
1547
      Array_Size          : Node_Id) return Node_Id
1548
   is
1549 1
      N : Node_Id;
1550
   begin
1551 1
      N := New_Node (K_Array_Declaration);
1552 1
      Set_Defining_Identifier (N, Defining_Identifier);
1553 1
      Set_Array_Size (N, Array_Size);
1554 1
      return (N);
1555
   end Make_Array_Declaration;
1556

1557
   -----------------------
1558
   -- Make_Array_Values --
1559
   -----------------------
1560

1561 1
   function Make_Array_Values (Values : List_Id := No_List) return Node_Id is
1562 1
      L : List_Id;
1563 1
      N : Node_Id;
1564
   begin
1565 1
      N := New_Node (K_Array_Values);
1566 1
      if not Present (Values) then
1567 1
         L := New_List (CTN.K_Enumeration_Literals);
1568 1
         Set_Values (N, L);
1569
      else
1570 0
         Set_Values (N, Values);
1571
      end if;
1572 1
      return (N);
1573
   end Make_Array_Values;
1574

1575
   ----------------------
1576
   -- Make_Array_Value --
1577
   ----------------------
1578

1579 1
   function Make_Array_Value
1580
     (Array_Name : Node_Id;
1581
      Array_Item : Node_Id) return Node_Id
1582
   is
1583 1
      N : Node_Id;
1584
   begin
1585 1
      N := New_Node (K_Array_Value);
1586 1
      Set_Defining_Identifier (N, Array_Name);
1587 1
      Set_Array_Item (N, Array_Item);
1588 1
      return (N);
1589
   end Make_Array_Value;
1590

1591
   ---------------------------
1592
   -- Make_Switch_Statement --
1593
   ---------------------------
1594

1595 1
   function Make_Switch_Statement
1596
     (Expression   : Node_Id;
1597
      Alternatives : List_Id) return Node_Id
1598
   is
1599 1
      N : Node_Id;
1600
   begin
1601 1
      N := New_Node (K_Switch_Statement);
1602 1
      Set_Expression (N, Expression);
1603 1
      Set_Alternatives (N, Alternatives);
1604 1
      return (N);
1605
   end Make_Switch_Statement;
1606

1607
   -----------------------------
1608
   -- Make_Switch_Alternative --
1609
   -----------------------------
1610

1611 1
   function Make_Switch_Alternative
1612
     (Labels     : List_Id;
1613
      Statements : List_Id) return Node_Id
1614
   is
1615 1
      N : Node_Id;
1616
   begin
1617 1
      N := New_Node (K_Switch_Alternative);
1618 1
      Set_Labels (N, Labels);
1619 1
      Set_Statements (N, Statements);
1620 1
      return (N);
1621
   end Make_Switch_Alternative;
1622

1623
   --------------------------
1624
   -- Handle_Call_Sequence --
1625
   --------------------------
1626

1627 1
   procedure Handle_Call_Sequence
1628
     (Caller            : Node_Id;
1629
      Call_Seq          : Node_Id;
1630
      Declarations      : List_Id;
1631
      Statements        : List_Id;
1632
      Containing_Device : Node_Id := No_Node)
1633
   is
1634 1
      Destination_F : Node_Id;
1635 1
      Source_F      : Node_Id;
1636 1
      Source_Parent : Node_Id;
1637 1
      Param_Value   : Node_Id;
1638 1
      Call_Profile  : List_Id;
1639 1
      Spg           : Node_Id;
1640 1
      Spg_Call      : Node_Id;
1641 1
      N             : Node_Id;
1642 1
      F             : Node_Id;
1643 1
      M             : Node_Id;
1644 1
      Declaration   : Node_Id;
1645 1
      Data_Accessed : Node_Id;
1646 1
      Hybrid        : constant Boolean :=
1647 1
        AINU.Is_Subprogram (Caller)
1648
        and then
1649 1
          Properties.Get_Subprogram_Kind (Caller) =
1650
          Properties.Subprogram_Hybrid_Ada_95; --  XXX why Ada ?
1651
   begin
1652
      --  The lists have to be created
1653

1654 1
      if Declarations = No_List or else Statements = No_List then
1655 0
         raise Program_Error
1656
           with "Lists have to be created before any call " &
1657
           "to Handle_Call_Sequence";
1658
      end if;
1659

1660
      --  The call sequence generally contains at least one call to a
1661
      --  subprogram.
1662

1663 1
      if AINU.Is_Empty (AIN.Subprogram_Calls (Call_Seq)) then
1664 0
         Display_Located_Error
1665 0
           (AIN.Loc (Call_Seq),
1666
            "Empty call sequence",
1667
            Fatal   => False,
1668
            Warning => True);
1669 0
         return;
1670
      end if;
1671 1
      Spg_Call := AIN.First_Node (AIN.Subprogram_Calls (Call_Seq));
1672

1673 1
      while Present (Spg_Call) loop
1674 1
         Spg          := AIN.Corresponding_Instance (Spg_Call);
1675 1
         Call_Profile := New_List (CTN.K_List_Id);
1676

1677 1
         if not AINU.Is_Empty (AIN.Features (Spg)) then
1678 1
            F := AIN.First_Node (AIN.Features (Spg));
1679 1
            while Present (F) loop
1680 1
               if Kind (F) = K_Subcomponent_Access_Instance then
1681
                  --  This case is specific to POK since we don't
1682
                  --  handle the shared data with the same patterns as
1683
                  --  in PolyORB-HI-C. This could be updated later.
1684 1
                  Data_Accessed := Get_Accessed_Data (F);
1685

1686 1
                  if Data_Accessed = No_Node then
1687 0
                     Display_Located_Error
1688 0
                       (AIN.Loc (F),
1689
                        "is not properly conected to" & " any source",
1690
                        Fatal => True);
1691
                  end if;
1692

1693
                  Param_Value :=
1694 1
                    Make_Variable_Address
1695 1
                      (Map_C_Defining_Identifier (Data_Accessed));
1696

1697 1
                  Append_Node_To_List (Param_Value, Call_Profile);
1698

1699 1
               elsif AIN.Kind (F) = AIN.K_Parameter_Instance
1700 1
                 and then AIN.Is_Out (F)
1701
               then
1702
                  --  Raise an error if the parameter is not connected
1703
                  --  to any source.
1704

1705 1
                  if AINU.Length (AIN.Destinations (F)) = 0 then
1706 0
                     Display_Located_Error
1707 0
                       (AIN.Loc (F),
1708
                        "This OUT parameter is not connected to" &
1709
                        " any destination",
1710
                        Fatal => True);
1711 1
                  elsif AINU.Length (AIN.Destinations (F)) > 1 then
1712 0
                     Display_Located_Error
1713 0
                       (AIN.Loc (F),
1714
                        "This OUT parameter has too many destinations",
1715
                        Fatal => True);
1716
                  end if;
1717

1718
                  --  At this point, we have a subprogram call
1719
                  --  parameter that has exactly one destination.
1720

1721
                  Destination_F :=
1722 1
                    AIN.Item (AIN.First_Node (AIN.Destinations (F)));
1723

1724
                  --  For each OUT parameter, we declare a local
1725
                  --  variable if the OUT parameter is connected to
1726
                  --  another subprogram call or if the caller is a
1727
                  --  thread. Otherwise, we use the corresponding
1728
                  --  caller subprogram parameter.
1729

1730
                  --  The parameter association value takes 3 possible
1731
                  --  values (see the (1), (2) and (3) comments below.
1732

1733 1
                  if AINU.Is_Thread (Caller)
1734 1
                    or else AIN.Parent_Component (Destination_F) /= Caller
1735
                  then
1736
                     --  (1) Here, we map the variable name from the
1737
                     --  subprogram *call* name and the feature
1738
                     --  name. This avoids name clashing when a thread
1739
                     --  calls twice the same subprogram.
1740

1741 1
                     if Get_Current_Backend_Kind = PolyORB_HI_C then
1742
                        M :=
1743 1
                          Map_C_Data_Type_Designator
1744 1
                            (Corresponding_Instance (F));
1745
                        Declaration :=
1746 1
                          Make_Variable_Declaration
1747
                            (Defining_Identifier =>
1748 1
                               Make_Defining_Identifier
1749 1
                                 (Map_C_Variable_Name
1750
                                    (F,
1751
                                     Request_Variable => True)),
1752
                             Used_Type => M,
1753
                             Is_Static => True);
1754

1755 1
                        Append_Node_To_List (Declaration, Declarations);
1756

1757
                        M :=
1758 1
                          Make_Defining_Identifier
1759 1
                            (Map_C_Variable_Name
1760
                               (F,
1761
                                Request_Variable => True));
1762

1763 1
                     elsif Get_Current_Backend_Kind = PolyORB_Kernel_C then
1764
                        M :=
1765 1
                          Map_C_Data_Type_Designator
1766 1
                            (Corresponding_Instance (F));
1767

1768
                        Declaration :=
1769 1
                          Make_Variable_Declaration
1770
                            (Defining_Identifier =>
1771 1
                               Make_Defining_Identifier
1772 1
                                 (Map_Port_Data (Destination_F)),
1773
                             Used_Type => M);
1774

1775 1
                        Append_Node_To_List (Declaration, Declarations);
1776

1777
                        M :=
1778 1
                          Make_Defining_Identifier
1779 1
                            (Map_Port_Data (Destination_F));
1780
                     end if;
1781

1782 1
                     Param_Value := Make_Variable_Address (M);
1783

1784 1
                  elsif Hybrid then
1785
                     --  (2) If the calleD parameter is connected to
1786
                     --      the calleR parameter and then the calleR
1787
                     --      IS hybrid, then we use the 'Status'
1788
                     --      record field corresponding to the calleR
1789
                     --      parameter.
1790

1791
                     Param_Value :=
1792 0
                       Make_Member_Designator
1793 0
                         (Make_Defining_Identifier
1794 0
                            (To_C_Name
1795 0
                               (AIN.Display_Name (AIN.Identifier (F)))),
1796 0
                          Make_Defining_Identifier (PN (P_Status)));
1797

1798
                  else
1799
                     --  (3) If the calleD parameter is connected to
1800
                     --      the calleR parameter and then then calleR
1801
                     --      is NOT hybrid, then we use simply the
1802
                     --      corresponding parameter of the calleR.
1803

1804
                     Param_Value :=
1805 1
                       Make_Defining_Identifier
1806 1
                         (To_C_Name
1807 1
                            (AIN.Display_Name
1808 1
                               (AIN.Identifier (Destination_F))));
1809
                  end if;
1810

1811
                  --  For each OUT parameter we build a parameter
1812
                  --  association of the actual profile of the
1813
                  --  implmentaion subprogram call <Param> =>
1814
                  --  <Param_Value>.
1815

1816 1
                  CTU.Append_Node_To_List (Param_Value, Call_Profile);
1817

1818 1
               elsif AIN.Kind (F) = AIN.K_Parameter_Instance
1819 1
                 and then AIN.Is_In (F)
1820
               then
1821
                  --  Raise an error if the parameter is not connected
1822
                  --  to any source.
1823

1824 1
                  if AINU.Length (AIN.Sources (F)) = 0 then
1825 0
                     Display_Located_Error
1826 0
                       (AIN.Loc (F),
1827
                        "This IN parameter is not connected to" &
1828
                        " any source",
1829
                        Fatal => True);
1830 1
                  elsif AINU.Length (AIN.Sources (F)) > 1 then
1831 0
                     Display_Located_Error
1832 0
                       (AIN.Loc (F),
1833
                        "This IN parameter has too many sources",
1834
                        Fatal => True);
1835
                  end if;
1836

1837
                  --  Here we have an IN parameter with exactly one
1838
                  --  source.
1839

1840 1
                  Source_F := AIN.Item (AIN.First_Node (AIN.Sources (F)));
1841

1842
                  --  Get the source feature parent
1843

1844 1
                  Source_Parent := AIN.Parent_Component (Source_F);
1845

1846
                  --  The parameter value of the built parameter
1847
                  --  association can take 4 different values. (see
1848
                  --  comments (1), (2), (3) and (4) above).
1849

1850 1
                  if AINU.Is_Thread (Source_Parent) then
1851
                     --  (1) If the Parent of 'Source_F' is a thread,
1852
                     --  then we use the '<Thread>_Job_Req' record
1853
                     --  field corresponding to F.
1854

1855 1
                     if Get_Current_Backend_Kind = PolyORB_HI_C then
1856
                        Param_Value :=
1857 1
                          Make_Member_Designator
1858
                            (Defining_Identifier =>
1859 1
                               Make_Member_Designator
1860
                                 (Defining_Identifier =>
1861 1
                                    Make_Member_Designator
1862
                                      (Defining_Identifier =>
1863 1
                                         Make_Defining_Identifier
1864 1
                                           (Map_C_Enumerator_Name (Source_F)),
1865
                                       Aggregate_Name =>
1866 1
                                         Make_Defining_Identifier
1867 1
                                           (Map_C_Enumerator_Name (Source_F))),
1868
                                  Aggregate_Name =>
1869 1
                                    Make_Defining_Identifier (MN (M_Vars))),
1870
                             Aggregate_Name =>
1871 1
                               Make_Defining_Identifier
1872 1
                                 (Map_C_Variable_Name
1873
                                    (Source_F,
1874
                                     Port_Request => True)));
1875
                     else
1876
                        M :=
1877 1
                          Map_C_Data_Type_Designator
1878 1
                            (Corresponding_Instance (F));
1879

1880
                        Declaration :=
1881 1
                          Make_Variable_Declaration
1882
                            (Defining_Identifier =>
1883 1
                               Make_Defining_Identifier
1884 1
                                 (Map_Port_Data (Source_F)),
1885
                             Used_Type => M);
1886

1887 1
                        Append_Node_To_List (Declaration, Declarations);
1888

1889
                        Param_Value :=
1890 1
                          Make_Defining_Identifier (Map_Port_Data (Source_F));
1891
                     end if;
1892

1893 1
                  elsif Source_Parent /= Caller then
1894
                     --  (2) If the the source call is different from
1895
                     --      the englobing subprogram, we use the
1896
                     --      formerly declared variable.
1897

1898
                     Param_Value :=
1899 0
                       Make_Defining_Identifier
1900 0
                         (Map_C_Variable_Name
1901
                            (Source_F,
1902
                             Request_Variable => True));
1903

1904 1
                  elsif Hybrid then
1905
                     --  (3) If the calleD parameter is connected to
1906
                     --      the calleR parameter then calleR IS
1907
                     --      hybrid, then we use the 'Status' record field
1908
                     --      corresponding to the calleR parameter.
1909

1910
                     Param_Value :=
1911 0
                       Make_Member_Designator
1912 0
                         (Make_Defining_Identifier
1913 0
                            (To_C_Name
1914 0
                               (AIN.Display_Name (AIN.Identifier (Source_F)))),
1915 0
                          Make_Defining_Identifier (PN (P_Status)));
1916
                  else
1917
                     --  (4) If the calleD parameter is connected to
1918
                     --      the calleR parameter and then then calleR
1919
                     --      is NOT hybrid, then we use simply the
1920
                     --      corresponding paremeter of the calleR.
1921

1922
                     Param_Value :=
1923 1
                       Make_Defining_Identifier
1924 1
                         (To_C_Name
1925 1
                            (AIN.Display_Name (AIN.Identifier (Source_F))));
1926
                  end if;
1927

1928
                  --  For each IN parameter we build a parameter
1929
                  --  association association of the actual profile of
1930
                  --  the implmentaion subprogram call <Param> =>
1931
                  --  <Param_Value>.
1932

1933 1
                  CTU.Append_Node_To_List (Param_Value, Call_Profile);
1934
               end if;
1935

1936 1
               F := AIN.Next_Node (F);
1937 1
            end loop;
1938

1939
         end if;
1940

1941 1
         if not AINU.Is_Empty (Path (Spg_Call)) then
1942
            --  If this is a feature subprogram call, generate a call
1943
            --  to the corresponding method.  For this moment, we
1944
            --  simply handle protected objects
1945

1946 1
            N := Message_Comment ("Invoking method");
1947 1
            CTU.Append_Node_To_List (N, Statements);
1948
            --  The name of the called subprogram is deduced from the
1949
            --  corresponding subprogram spec instance (last element
1950
            --  of the 'Path' list) and from the actual data component
1951
            --  instance the call is connected to.
1952

1953
            N :=
1954 1
              Map_C_Feature_Subprogram
1955 1
                (Item (AIN.Last_Node (Path (Spg_Call))),
1956 1
                 Corresponding_Instance (Get_Actual_Owner (Spg_Call)));
1957

1958 1
            N := Make_Call_Profile (N, Call_Profile);
1959 1
            CTU.Append_Node_To_List (N, Statements);
1960

1961
         else
1962
            --  If this is a classic subprogram, call its
1963
            --  implementation.
1964

1965 1
            if Get_Current_Backend_Kind = PolyORB_HI_C then
1966 1
               Add_Include (PHCR.RH (PHCR.RH_Subprograms));
1967 1
            elsif Get_Current_Backend_Kind = PolyORB_Kernel_C then
1968 1
               Add_Include (PKR.RH (PKR.RH_Subprograms));
1969
            end if;
1970

1971 1
            N := Message_Comment ("Call implementation");
1972 1
            CTU.Append_Node_To_List (N, Statements);
1973

1974 1
            if Get_Current_Backend_Kind = PolyORB_HI_C then
1975 1
               N := Map_C_Defining_Identifier (Spg);
1976 1
               if Containing_Device /= No_Node then
1977 0
                  CTU.Append_Node_To_List
1978 0
                    (Make_Defining_Identifier
1979 0
                       (Map_C_Enumerator_Name (Containing_Device)),
1980
                     Call_Profile);
1981
               end if;
1982 1
            elsif Get_Current_Backend_Kind = PolyORB_Kernel_C then
1983 1
               N := Map_C_Defining_Identifier (Spg);
1984
            end if;
1985 1
            N := Make_Call_Profile (N, Call_Profile);
1986 1
            CTU.Append_Node_To_List (N, Statements);
1987
         end if;
1988

1989 1
         Spg_Call := AIN.Next_Node (Spg_Call);
1990 1
      end loop;
1991
   end Handle_Call_Sequence;
1992

1993
   -------------------------
1994
   -- Get_C_Default_Value --
1995
   -------------------------
1996

1997 0
   function Get_C_Default_Value (D : Node_Id) return Node_Id is
1998 0
      Data_Representation : Supported_Data_Representation;
1999 0
      Result              : Node_Id;
2000
   begin
2001 0
      pragma Assert (AINU.Is_Data (D));
2002

2003 0
      Data_Representation := Get_Data_Representation (D);
2004

2005 0
      case Data_Representation is
2006 0
         when Data_Integer =>
2007
            --  For integers, default value is 0
2008

2009 0
            Result := CTU.Make_Literal (CV.New_Int_Value (0, 1, 10));
2010

2011 0
         when Data_Float | Data_Fixed =>
2012
            --  For reals, the default value is 0.0
2013

2014 0
            Result := CTU.Make_Literal (CV.New_Floating_Point_Value (0.0));
2015

2016 0
         when Data_Boolean =>
2017
            --  For booleans, the default value is FALSE
2018

2019 0
            Result := CTU.Make_Literal (CV.New_Int_Value (0, 1, 10));
2020

2021 0
         when Data_Character =>
2022
            --  For characters, the default value is the space ' '
2023

2024
            Result :=
2025 0
              CTU.Make_Literal (CV.New_Char_Value (Character'Pos (' ')));
2026

2027 0
         when Data_Wide_Character =>
2028
            --  For wide characters, the default value is the wide
2029
            --  space ' '.
2030

2031
            Result :=
2032 0
              CTU.Make_Literal (CV.New_Char_Value (Character'Pos (' ')));
2033

2034 0
         when Data_String =>
2035 0
            Display_Located_Error
2036 0
              (AIN.Loc (D),
2037
               "Bounded strings default values not supported yet!",
2038
               Fatal => True);
2039

2040 0
         when Data_Wide_String =>
2041 0
            Display_Located_Error
2042 0
              (AIN.Loc (D),
2043
               "Bounded wide strings default values not supported yet!",
2044
               Fatal => True);
2045

2046 0
         when Data_Array =>
2047 0
            Display_Located_Error
2048 0
              (AIN.Loc (D),
2049
               "Bounded arrays default values not supported yet!",
2050
               Fatal => True);
2051

2052 0
         when Data_With_Accessors =>
2053
            --  This is definitely a code generation error
2054

2055 0
            raise Program_Error
2056
              with "Data types with accessors should" &
2057
              " not have default values";
2058

2059 0
         when others =>
2060 0
            raise Program_Error with "Unsupported data type default value!";
2061

2062 0
      end case;
2063

2064 0
      return Result;
2065
   end Get_C_Default_Value;
2066

2067
   -------------------------
2068
   -- Make_Include_Clause --
2069
   -------------------------
2070

2071 1
   function Make_Include_Clause
2072
     (Header_Name : Node_Id;
2073
      Local       : Boolean := False) return Node_Id
2074
   is
2075 1
      N : Node_Id;
2076
   begin
2077 1
      N := New_Node (K_Include_Clause);
2078 1
      Set_Header_Name (N, Header_Name);
2079 1
      Set_Is_Local (N, Local);
2080

2081 1
      return N;
2082
   end Make_Include_Clause;
2083

2084
   ---------------------------
2085
   -- Add_Define_Deployment --
2086
   ---------------------------
2087

2088 1
   procedure Add_Define_Deployment (E : Node_Id) is
2089 1
      W            : Node_Id;
2090 1
      N            : Name_Id;
2091 1
      F            : Node_Id;
2092 1
      Existing_Def : Node_Id;
2093
   begin
2094 1
      Set_Str_To_Name_Buffer ("deployment");
2095 1
      Get_Name_String_And_Append (CTN.Name (E));
2096

2097 1
      Get_Name_String_And_Append
2098
        (CTN.Name (CTN.Entity (Table (Last).Current_Entity)));
2099 1
      N := Name_Find;
2100

2101 1
      Existing_Def := Node_Id (Get_Name_Table_Info (N));
2102

2103
      --  If the file was already included, we return immediatly
2104 1
      if Present (Existing_Def) then
2105 1
         return;
2106
      end if;
2107

2108
      --  Else, we add the corresponding header file to included files
2109
      W :=
2110 1
        CTU.Make_Define_Statement
2111 1
          (Defining_Identifier => Copy_Node (E),
2112 1
           Value => CTU.Make_Literal (CV.New_Int_Value (1, 1, 10)));
2113

2114 1
      Set_Name_Table_Info (N, Int (W));
2115

2116
      F                         := Table (Last).Current_File;
2117
      Table (Last).Current_File :=
2118
        Deployment_Header (Table (Last).Current_Entity);
2119 1
      Append_Node_To_List (W, CTN.Declarations (Current_File));
2120
      Table (Last).Current_File := F;
2121
   end Add_Define_Deployment;
2122

2123
   --------------------------
2124
   -- Add_Return_Assertion --
2125
   --------------------------
2126

2127 1
   procedure POK_Add_Return_Assertion
2128
     (Statements      : List_Id;
2129
      Exception_Error : Node_Id := No_Node)
2130
   is
2131
   begin
2132 1
      if not POK_C.Add_Assertions then
2133 0
         return;
2134
      end if;
2135

2136 1
      if Exception_Error = No_Node then
2137 1
         Append_Node_To_List
2138 1
           (Make_Macro_Call
2139 1
              (PKR.RE (PKR.RE_Assert_Ret),
2140 1
               Make_List_Id (Make_Defining_Identifier (VN (V_Ret)))),
2141
            Statements);
2142
      else
2143 1
         Append_Node_To_List
2144 1
           (Make_Macro_Call
2145 1
              (PKR.RE (PKR.RE_Assert_Ret_With_Exception),
2146 1
               Make_List_Id
2147 1
                 (Make_Defining_Identifier (VN (V_Ret)),
2148
                  Exception_Error)),
2149
            Statements);
2150
      end if;
2151
   end POK_Add_Return_Assertion;
2152

2153
   ----------------------------------------
2154
   -- POK_Make_Function_Call_With_Assert --
2155
   ----------------------------------------
2156

2157 1
   function POK_Make_Function_Call_With_Assert
2158
     (Function_Name : Node_Id;
2159
      Parameters    : List_Id) return Node_Id
2160
   is
2161
      use Ocarina.Backends.POK_C;
2162 1
      Function_Call : Node_Id;
2163
   begin
2164 1
      Function_Call := Make_Call_Profile (Function_Name, Parameters);
2165 1
      if POK_C.Add_Assertions and then POK_Flavor = POK then
2166 0
         return Make_Expression
2167 0
             (Make_Defining_Identifier (VN (V_Ret)),
2168
              Op_Equal,
2169
              Function_Call);
2170
      else
2171 1
         return Function_Call;
2172
      end if;
2173
   end POK_Make_Function_Call_With_Assert;
2174

2175
   -------------------
2176
   -- Get_Data_Size --
2177
   -------------------
2178

2179 1
   function Get_Data_Size (Data : Node_Id;
2180
                           Is_Pointer : Boolean := False;
2181
                           Maximum_Size : Boolean := False)
2182
                          return Node_Id
2183
   is
2184 1
      Data_Representation : Supported_Data_Representation;
2185 1
      Value_UUL           : Unsigned_Long_Long;
2186 1
      Value_Node          : Node_Id            := No_Node;
2187
      Dimension           : constant ULL_Array := Get_Dimension (Data);
2188 1
      Type_Size           : Size_Type;
2189
   begin
2190
      pragma Assert (AINU.Is_Data (Data));
2191

2192 1
      Data_Representation := Get_Data_Representation (Data);
2193 1
      Type_Size           := Get_Data_Size (Data);
2194

2195 1
      if Get_Data_Size (Data) /= Null_Size then
2196 1
         Value_UUL := To_Bytes (Type_Size);
2197 1
         return (Make_Literal (New_Int_Value (Value_UUL, 1, 10)));
2198
      end if;
2199

2200 1
      if Is_Defined_Property (Data, "type_source_name") then
2201 1
         return Make_Call_Profile
2202 1
             (Make_Defining_Identifier (FN (F_Sizeof)),
2203 1
              Make_List_Id
2204 1
                (Make_Defining_Identifier
2205 1
                   (To_C_Name
2206 1
                      (Get_String_Property (Data, "type_source_name")))));
2207
      end if;
2208

2209
      case Data_Representation is
2210 1
         when Data_Integer | Data_Boolean =>
2211
            Value_Node :=
2212 1
              Make_Call_Profile
2213 1
                (Make_Defining_Identifier (FN (F_Sizeof)),
2214 1
                 Make_List_Id (Make_Defining_Identifier (TN (T_Int))));
2215

2216 1
         when Data_Float =>
2217
            Value_Node :=
2218 1
              Make_Call_Profile
2219 1
                (Make_Defining_Identifier (FN (F_Sizeof)),
2220 1
                 Make_List_Id (Make_Defining_Identifier (TN (T_Float))));
2221

2222 0
         when Data_String | Data_Wide_String =>
2223 0
            Value_UUL := Dimension (1);
2224

2225 1
         when Data_Array =>
2226
            Value_Node :=
2227 1
              Make_Expression
2228
                (Left_Expr =>
2229
                   Make_Literal (New_Int_Value (Dimension (1), 1, 10)),
2230
                 Operator   => Op_Asterisk,
2231
                 Right_Expr =>
2232 1
                   Get_Data_Size
2233 1
                     (ATN.Entity (ATN.First_Node (Get_Base_Type (Data)))));
2234

2235 1
         when Data_Bounded_Array =>
2236 1
            if Maximum_Size then
2237
               Value_Node :=
2238 1
                 Make_Expression
2239
                 (Left_Expr =>
2240
                    Make_Literal (New_Int_Value (Dimension (1), 1, 10)),
2241
                  Operator   => Op_Asterisk,
2242
                  Right_Expr =>
2243 1
                    Get_Data_Size
2244 1
                    (ATN.Entity (ATN.First_Node (Get_Base_Type (Data)))));
2245

2246
            else
2247
               Value_Node :=
2248 1
                 Make_Expression
2249
                 (Left_Expr =>
2250 1
                    Make_Member_Designator
2251
                    (Defining_Identifier =>
2252 1
                       Make_Defining_Identifier (MN (M_length)),
2253
                     Aggregate_Name =>
2254 1
                       Make_Defining_Identifier (PN (P_Value)),
2255
                     Is_Pointer => Is_Pointer),
2256
                  Operator   => Op_Asterisk,
2257
                  Right_Expr =>
2258 1
                    Get_Data_Size
2259 1
                    (ATN.Entity (ATN.First_Node (Get_Base_Type (Data)))));
2260
            end if;
2261

2262 0
         when Data_None =>
2263
            Value_Node :=
2264 0
              Make_Call_Profile
2265 0
                (Make_Defining_Identifier (FN (F_Sizeof)),
2266 0
                 Make_List_Id (Map_C_Defining_Identifier (Data)));
2267

2268 1
         when others =>
2269
            Value_Node :=
2270 1
              Make_Call_Profile
2271 1
                (Make_Defining_Identifier (FN (F_Sizeof)),
2272 1
                 Make_List_Id (Map_C_Defining_Identifier (Data)));
2273
      end case;
2274

2275 1
      if Value_Node /= No_Node then
2276 1
         return Value_Node;
2277
      else
2278 0
         raise Program_Error
2279
           with "Impossible to get the data size of this data";
2280
      end if;
2281 1
   end Get_Data_Size;
2282

2283
   ---------------------------------
2284
   -- Add_Return_Variable_In_List --
2285
   ---------------------------------
2286

2287 1
   procedure Add_Return_Variable_In_Parameters (Parameters : List_Id) is
2288
   begin
2289 1
      Append_Node_To_List
2290 1
        (Make_Variable_Address (Make_Defining_Identifier (VN (V_Ret))),
2291
         Parameters);
2292 1
   end Add_Return_Variable_In_Parameters;
2293

2294
   -----------------------------------------------------
2295
   -- Declare_Return_Variable_In_Function_Declaration --
2296
   -----------------------------------------------------
2297

2298 1
   procedure POK_Declare_Return_Variable (Declarations : List_Id) is
2299
      use Ocarina.Backends.POK_C;
2300
      use Ocarina.Backends.POK_C.Runtime;
2301 1
      N : Node_Id;
2302
   begin
2303 1
      if POK_C.Add_Assertions and then POK_Flavor = POK then
2304
         N :=
2305 0
           Make_Variable_Declaration
2306 0
             (Defining_Identifier => Make_Defining_Identifier (VN (V_Ret)),
2307 0
              Used_Type           => RE (RE_Pok_Ret_T));
2308 0
         Append_Node_To_List (N, Declarations);
2309 1
      elsif Use_ARINC653_API then
2310
         N :=
2311 1
           Make_Variable_Declaration
2312 1
             (Defining_Identifier => Make_Defining_Identifier (VN (V_Ret)),
2313 1
              Used_Type           => RE (RE_Return_Code_Type));
2314 1
         Append_Node_To_List (N, Declarations);
2315
      end if;
2316 1
   end POK_Declare_Return_Variable;
2317

2318
   -------------------------
2319
   --  Make_Ifdef_Clause  --
2320
   -------------------------
2321

2322 1
   function Make_Ifdef_Clause
2323
     (Clause          : Node_Id;
2324
      Negation        : Boolean := False;
2325
      Then_Statements : List_Id;
2326
      Else_Statements : List_Id) return Node_Id
2327
   is
2328 1
      N : Node_Id;
2329
   begin
2330 1
      N := New_Node (K_Ifdef_Clause);
2331 1
      CTN.Set_Negation (N, Negation);
2332 1
      CTN.Set_Clause (N, Clause);
2333 1
      CTN.Set_Then_Statements (N, Then_Statements);
2334 1
      CTN.Set_Else_Statements (N, Else_Statements);
2335 1
      return N;
2336
   end Make_Ifdef_Clause;
2337

2338
   -------------------------------------
2339
   --  Get_Inter_Partition_Port_Size  --
2340
   -------------------------------------
2341

2342 1
   function Get_Inter_Partition_Port_Size (Port : Node_Id) return Node_Id is
2343

2344 1
      Type_Found : Node_Id;
2345

2346 1
      function Get_Inter_Partition_Port_Size_Rec
2347
        (Port   : Node_Id;
2348
         Method : Browsing_Kind) return Node_Id
2349
      is
2350 1
         Source_Port      : Node_Id;
2351 1
         Destination_Port : Node_Id;
2352 1
         Tmp              : Node_Id;
2353 1
         Associated_Type  : Node_Id;
2354
      begin
2355

2356
         Associated_Type :=
2357 1
           Get_Instance_Type_Associated_With_Virtual_Bus (Port);
2358

2359 1
         if Associated_Type /= No_Node then
2360 0
            return CTU.Get_Data_Size (Associated_Type);
2361
         end if;
2362

2363 1
         if AINU.Is_Thread (Parent_Component (Port)) then
2364 1
            return Get_Data_Size (Corresponding_Instance (Port));
2365
         end if;
2366

2367
         --  We are at the thread level so we are in the applicative domain.
2368
         --  no virtual bus was found so we fallback to the thread application
2369
         --  data.
2370

2371 1
         if Method = By_Source
2372 1
           and then not AINU.Is_Empty (AIN.Sources (Port))
2373
         then
2374 1
            Tmp := AIN.First_Node (AIN.Sources (Port));
2375

2376 1
            while Present (Tmp) loop
2377 1
               Source_Port := AIN.Item (Tmp);
2378

2379
               Associated_Type :=
2380 1
                 Get_Inter_Partition_Port_Size_Rec (Source_Port, Method);
2381

2382 1
               if Associated_Type /= No_Node then
2383 1
                  return Associated_Type;
2384
               end if;
2385

2386 0
               Tmp := AIN.Next_Node (Tmp);
2387

2388 0
            end loop;
2389
         end if;
2390

2391 1
         if Method = By_Destination
2392 1
           and then not AINU.Is_Empty (AIN.Destinations (Port))
2393
         then
2394 1
            Tmp := AIN.First_Node (AIN.Destinations (Port));
2395

2396 1
            while Present (Tmp) loop
2397 1
               Destination_Port := AIN.Item (Tmp);
2398

2399
               Associated_Type :=
2400 1
                 Get_Inter_Partition_Port_Size_Rec (Destination_Port, Method);
2401

2402 1
               if Associated_Type /= No_Node then
2403 1
                  return Associated_Type;
2404
               end if;
2405

2406 0
               Tmp := AIN.Next_Node (Tmp);
2407

2408 0
            end loop;
2409
         end if;
2410

2411 0
         return No_Node;
2412

2413
      end Get_Inter_Partition_Port_Size_Rec;
2414

2415
   begin
2416 1
      if not AIN.Is_Data (Port) then
2417 0
         raise Program_Error
2418
           with "Call to Get_Inter_Partition_Port_Size with non DATA port";
2419
      end if;
2420

2421 1
      if AIN.Is_In (Port) then
2422 1
         Type_Found := Get_Inter_Partition_Port_Size_Rec (Port, By_Source);
2423
      else
2424
         Type_Found :=
2425 1
           Get_Inter_Partition_Port_Size_Rec (Port, By_Destination);
2426
      end if;
2427

2428 1
      if Type_Found = No_Node then
2429 0
         return Get_Data_Size (Corresponding_Instance (Port));
2430
      end if;
2431

2432 1
      return Type_Found;
2433
   end Get_Inter_Partition_Port_Size;
2434

2435
   -------------------------------------
2436
   --  Get_Inter_Partition_Port_Type  --
2437
   -------------------------------------
2438

2439 0
   function Get_Inter_Partition_Port_Type (Port : Node_Id) return Node_Id is
2440

2441 0
      Type_Found : Node_Id;
2442

2443 0
      function Get_Inter_Partition_Port_Type_Rec
2444
        (Port   : Node_Id;
2445
         Method : Browsing_Kind) return Node_Id
2446
      is
2447 0
         Source_Port      : Node_Id;
2448 0
         Destination_Port : Node_Id;
2449 0
         Tmp              : Node_Id;
2450 0
         Associated_Type  : Node_Id;
2451
      begin
2452

2453
         Associated_Type :=
2454 0
           Get_Instance_Type_Associated_With_Virtual_Bus (Port);
2455

2456 0
         if Associated_Type /= No_Node then
2457 0
            if Is_Defined_Property (Associated_Type, "type_source_name") then
2458 0
               return Make_Defining_Identifier
2459 0
                   (To_C_Name
2460 0
                      (Get_String_Property
2461
                         (Associated_Type,
2462
                          "type_source_name")));
2463
            else
2464 0
               return Map_C_Data_Type_Designator (Associated_Type);
2465
            end if;
2466
         end if;
2467

2468 0
         if AINU.Is_Thread (Parent_Component (Port)) then
2469 0
            return No_Node;
2470
         end if;
2471

2472
         --  We are at the thread level so we are in the applicative domain.
2473
         --  no virtual bus was found so we fallback to the thread application
2474
         --  data.
2475

2476 0
         if Method = By_Source
2477 0
           and then not AINU.Is_Empty (AIN.Sources (Port))
2478
         then
2479 0
            Tmp := AIN.First_Node (AIN.Sources (Port));
2480

2481 0
            while Present (Tmp) loop
2482 0
               Source_Port := AIN.Item (Tmp);
2483

2484
               Associated_Type :=
2485 0
                 Get_Inter_Partition_Port_Type_Rec (Source_Port, Method);
2486

2487 0
               if Associated_Type /= No_Node then
2488 0
                  return Associated_Type;
2489
               end if;
2490

2491 0
               Tmp := AIN.Next_Node (Tmp);
2492

2493 0
            end loop;
2494
         end if;
2495

2496 0
         if Method = By_Destination
2497 0
           and then not AINU.Is_Empty (AIN.Destinations (Port))
2498
         then
2499 0
            Tmp := AIN.First_Node (AIN.Destinations (Port));
2500

2501 0
            while Present (Tmp) loop
2502 0
               Destination_Port := AIN.Item (Tmp);
2503

2504
               Associated_Type :=
2505 0
                 Get_Inter_Partition_Port_Type_Rec (Destination_Port, Method);
2506

2507 0
               if Associated_Type /= No_Node then
2508 0
                  return Associated_Type;
2509
               end if;
2510

2511 0
               Tmp := AIN.Next_Node (Tmp);
2512

2513 0
            end loop;
2514
         end if;
2515

2516 0
         return No_Node;
2517

2518
      end Get_Inter_Partition_Port_Type_Rec;
2519

2520
   begin
2521 0
      if not AIN.Is_Data (Port) then
2522 0
         raise Program_Error
2523
           with "Call to Get_Inter_Partition_Port_Type with non DATA port";
2524
      end if;
2525

2526 0
      Type_Found := Get_Inter_Partition_Port_Type_Rec (Port, By_Source);
2527

2528 0
      if Type_Found /= No_Node then
2529 0
         return Type_Found;
2530
      end if;
2531

2532 0
      Type_Found := Get_Inter_Partition_Port_Type_Rec (Port, By_Destination);
2533

2534 0
      if Type_Found /= No_Node then
2535 0
         return Type_Found;
2536
      end if;
2537

2538 0
      return Map_C_Data_Type_Designator (Corresponding_Instance (Port));
2539
   end Get_Inter_Partition_Port_Type;
2540

2541
   ----------------------------
2542
   -- Make_Doxygen_C_Comment --
2543
   ----------------------------
2544

2545
   function Make_Doxygen_C_Comment
2546
     (Desc              : String;
2547
      Brief             : String  := "";
2548
      Element_Name      : String  := "";
2549
      Is_Struct         : Boolean := False;
2550
      Is_Union          : Boolean := False;
2551
      Is_Enum           : Boolean := False;
2552
      Is_Function       : Boolean := False;
2553
      Is_Variable       : Boolean := False;
2554
      Is_Define         : Boolean := False;
2555
      Is_Typedef        : Boolean := False;
2556
      Is_File           : Boolean := False;
2557
      Is_Namespace      : Boolean := False;
2558
      Is_Package        : Boolean := False;
2559
      Is_Interface      : Boolean := False;
2560
      Has_Header_Spaces : Boolean := True) return Node_Id
2561
   is
2562 1
      C : Node_Id;
2563
   begin
2564 1
      C := New_Node (K_Doxygen_C_Comment);
2565 1
      CTN.Set_Summary (C, No_Node);
2566 1
      CTN.Set_Element (C, No_Node);
2567 1
      CTN.Set_Description (C, No_Node);
2568

2569 1
      CTN.Set_For_Struct (C, False);
2570 1
      CTN.Set_For_Union (C, False);
2571 1
      CTN.Set_For_Enum (C, False);
2572 1
      CTN.Set_For_Function (C, False);
2573 1
      CTN.Set_For_Variable (C, False);
2574 1
      CTN.Set_For_Define (C, False);
2575 1
      CTN.Set_For_Typedef (C, False);
2576 1
      CTN.Set_For_File (C, False);
2577 1
      CTN.Set_For_Namespace (C, False);
2578 1
      CTN.Set_For_Package (C, False);
2579 1
      CTN.Set_For_Interface (C, False);
2580 1
      CTN.Set_Has_Header_Spaces (C, Has_Header_Spaces);
2581

2582 1
      if Desc /= "" then
2583 1
         Set_Description (C, New_Node (K_Defining_Identifier));
2584 1
         CTN.Set_Name (Description (C), Get_String_Name (Desc));
2585
      end if;
2586

2587 1
      if Element_Name /= "" then
2588 1
         Set_Element (C, New_Node (K_Defining_Identifier));
2589 1
         CTN.Set_Name (Element (C), Get_String_Name (Element_Name));
2590
      end if;
2591

2592 1
      if Brief /= "" then
2593 1
         Set_Summary (C, New_Node (K_Defining_Identifier));
2594 1
         CTN.Set_Name (Summary (C), Get_String_Name (Brief));
2595
      end if;
2596

2597 1
      CTN.Set_For_Struct (C, Is_Struct);
2598 1
      CTN.Set_For_Union (C, Is_Union);
2599 1
      CTN.Set_For_Enum (C, Is_Enum);
2600 1
      CTN.Set_For_Function (C, Is_Function);
2601 1
      CTN.Set_For_Variable (C, Is_Variable);
2602 1
      CTN.Set_For_Define (C, Is_Define);
2603 1
      CTN.Set_For_Typedef (C, Is_Typedef);
2604 1
      CTN.Set_For_File (C, Is_File);
2605 1
      CTN.Set_For_Namespace (C, Is_Namespace);
2606 1
      CTN.Set_For_Package (C, Is_Package);
2607 1
      CTN.Set_For_Interface (C, Is_Interface);
2608

2609 1
      return C;
2610
   end Make_Doxygen_C_Comment;
2611

2612 1
end Ocarina.Backends.C_Tree.Nutils;

Read our documentation on viewing source code .

Loading