1
------------------------------------------------------------------------------
2
--                                                                          --
3
--                           OCARINA COMPONENTS                             --
4
--                                                                          --
5
--         O C A R I N A . B A C K E N D S . S U B P R O G R A M S          --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--                  Copyright (C) 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 Ocarina.ME_AADL;
34
with Ocarina.ME_AADL.AADL_Instances.Nodes;
35
with Ocarina.ME_AADL.AADL_Instances.Nutils;
36
with Ocarina.ME_AADL.AADL_Instances.Entities;
37

38
with Ocarina.Backends.C_Common.Mapping;
39

40
with Ocarina.Instances.Queries;
41

42
with Ocarina.Instances;
43
with Ocarina.Backends.Expander;
44
with Ocarina.Backends.Messages;
45
with Ocarina.Backends.C_Tree.Nodes;
46
with Ocarina.Backends.C_Tree.Nutils;
47
with Ocarina.Backends.C_Tree.Generator;
48
with Ocarina.Backends.Utils;
49
with Ocarina.Backends.Properties;
50

51
with Ocarina.Namet; use Ocarina.Namet;
52

53 1
package body Ocarina.Backends.Subprograms is
54
   use Ocarina.Instances;
55
   use Ocarina.Backends.Expander;
56
   use Ocarina.Backends.Messages;
57
   use Ocarina.Backends.C_Tree.Nodes;
58
   use Ocarina.Backends.C_Tree.Nutils;
59
   use Ocarina.Backends.Utils;
60
   use Ocarina.Backends.Properties;
61

62
   package AAN renames Ocarina.ME_AADL.AADL_Instances.Nodes;
63
   package CTN renames Ocarina.Backends.C_Tree.Nodes;
64
   package CTU renames Ocarina.Backends.C_Tree.Nutils;
65

66 1
   Source_File : Node_Id;
67 1
   Header_File : Node_Id;
68

69
   procedure Visit_Architecture_Instance (E : Node_Id);
70
   --  Most top level visitor routine. E is the root of the AADL
71
   --  instance tree. The procedure does a traversal for each
72
   --  compilation unit to be generated.
73

74
   package Subprograms_Generation is
75
      procedure Visit (E : Node_Id);
76
   end Subprograms_Generation;
77

78
   package body Subprograms_Generation is
79
      use Ocarina.ME_AADL;
80
      use Ocarina.ME_AADL.AADL_Instances.Nodes;
81
      use Ocarina.ME_AADL.AADL_Instances.Entities;
82
      use Ocarina.Backends.C_Common.Mapping;
83

84
      use Ocarina.Instances.Queries;
85

86
      package AIN renames Ocarina.ME_AADL.AADL_Instances.Nodes;
87
      package AINU renames Ocarina.ME_AADL.AADL_Instances.Nutils;
88
      package CTN renames Ocarina.Backends.C_Tree.Nodes;
89

90
      procedure Visit_Architecture_Instance (E : Node_Id);
91
      procedure Visit_Component_Instance (E : Node_Id);
92
      procedure Visit_System_Instance (E : Node_Id);
93
      procedure Visit_Process_Instance (E : Node_Id);
94
      procedure Visit_Thread_Instance (E : Node_Id);
95
      procedure Visit_Subprogram_Instance (E : Node_Id);
96
      procedure Visit_Device_Instance (E : Node_Id);
97
      procedure Visit_Subcomponents_Of is new Visit_Subcomponents_Of_G (Visit);
98

99
      -------------------------
100
      -- Map_Subprogram_Spec --
101
      -------------------------
102

103 1
      function Map_Subprogram_Spec (S : Node_Id) return Node_Id is
104 1
         Profile : constant List_Id := CTU.New_List (CTN.K_Parameter_Profile);
105 1
         Param   : Node_Id;
106 1
         Mode    : Mode_Id;
107 1
         F       : Node_Id;
108 1
         N       : Node_Id;
109 1
         D       : Node_Id;
110 1
         Field   : Node_Id;
111
      begin
112
         pragma Assert (AINU.Is_Subprogram (S));
113

114
         --  We build the parameter profile of the subprogram instance by
115
         --  adding:
116

117
         --  First, the parameter features mapping
118

119 1
         if not AINU.Is_Empty (Features (S)) then
120 0
            F := AIN.First_Node (Features (S));
121

122 0
            while Present (F) loop
123 0
               if Kind (F) = K_Parameter_Instance then
124 0
                  if Is_In (F) and then Is_Out (F) then
125 0
                     Mode := Mode_Inout;
126 0
                  elsif Is_Out (F) then
127 0
                     Mode := Mode_Out;
128 0
                  elsif Is_In (F) then
129 0
                     Mode := Mode_In;
130
                  else
131 0
                     Display_Located_Error
132 0
                       (AIN.Loc (F),
133
                        "Unspecified parameter mode",
134
                        Fatal => True);
135
                  end if;
136

137 0
                  D := Corresponding_Instance (F);
138

139 0
                  if Mode = Mode_In then
140
                     Param :=
141 0
                       CTU.Make_Parameter_Specification
142 0
                         (Defining_Identifier => Map_C_Defining_Identifier (F),
143 0
                          Parameter_Type => Map_C_Defining_Identifier (D));
144
                  else
145
                     Param :=
146 0
                       CTU.Make_Parameter_Specification
147 0
                         (Defining_Identifier => Map_C_Defining_Identifier (F),
148
                          Parameter_Type      =>
149 0
                            CTU.Make_Pointer_Type
150 0
                              (Map_C_Defining_Identifier (D)));
151
                  end if;
152 0
                  CTU.Append_Node_To_List (Param, Profile);
153
               end if;
154

155 0
               F := AIN.Next_Node (F);
156 0
            end loop;
157
         end if;
158

159
         --  Second, the data access mapping. The data accesses are not
160
         --  mapped in the case of pure call sequence subprogram because
161
         --  they are used only to close the access chain.
162

163 1
         if Get_Subprogram_Kind (S) /= Subprogram_Pure_Call_Sequence then
164

165 1
            if not AINU.Is_Empty (Features (S)) then
166 0
               F := AIN.First_Node (Features (S));
167

168 0
               while Present (F) loop
169 0
                  if Kind (F) = K_Subcomponent_Access_Instance then
170 0
                     case Get_Required_Data_Access (Corresponding_Instance (F))
171
                     is
172 0
                        when Access_Read_Only =>
173 0
                           Mode := Mode_In;
174 0
                        when Access_Write_Only =>
175 0
                           Mode := Mode_Out;
176 0
                        when Access_Read_Write =>
177 0
                           Mode := Mode_Inout;
178 0
                        when Access_None =>
179
                           --  By default, we allow read/write access
180 0
                           Mode := Mode_Inout;
181 0
                        when others =>
182 0
                           Display_Located_Error
183 0
                             (AIN.Loc (F),
184
                              "Unsupported required access",
185
                              Fatal => True);
186 0
                     end case;
187

188 0
                     D := Corresponding_Instance (F);
189

190 0
                     case Get_Data_Representation (D) is
191 0
                        when Data_Integer     |
192
                          Data_Boolean        |
193
                          Data_Float          |
194
                          Data_Fixed          |
195
                          Data_Struct         |
196
                          Data_String         |
197
                          Data_Wide_String    |
198
                          Data_Character      |
199
                          Data_Wide_Character |
200
                          Data_Array          =>
201
                           --  If the data component is a simple data
202
                           --  component (not a structure), we simply add a
203
                           --  parameter with the computed mode and with a
204
                           --  type mapped from the data component.
205

206 0
                           if Mode = Mode_In then
207
                              Param :=
208 0
                                CTU.Make_Parameter_Specification
209
                                  (Defining_Identifier =>
210 0
                                     Map_C_Defining_Identifier (F),
211
                                   Parameter_Type =>
212 0
                                     Map_C_Data_Type_Designator (D));
213
                           else
214
                              Param :=
215 0
                                CTU.Make_Parameter_Specification
216
                                  (Defining_Identifier =>
217 0
                                     Map_C_Defining_Identifier (F),
218
                                   Parameter_Type =>
219 0
                                     CTU.Make_Pointer_Type
220 0
                                       (Map_C_Data_Type_Designator (D)));
221
                           end if;
222

223 0
                           CTU.Append_Node_To_List (Param, Profile);
224

225 0
                        when Data_With_Accessors =>
226
                           --  If the data component is a complex data
227
                           --  component (which has subcomponents), we add a
228
                           --  parameter with the computed mode and with a
229
                           --  type mapped from each subcomponent type.
230

231 0
                           Field := AIN.First_Node (Subcomponents (D));
232

233 0
                           while Present (Field) loop
234 0
                              if Mode = Mode_In then
235
                                 Param :=
236 0
                                   CTU.Make_Parameter_Specification
237
                                     (Defining_Identifier =>
238 0
                                        Map_C_Defining_Identifier (Field),
239
                                      Parameter_Type =>
240 0
                                        Map_C_Data_Type_Designator
241 0
                                          (Corresponding_Instance (Field)));
242
                              else
243
                                 Param :=
244 0
                                   CTU.Make_Parameter_Specification
245
                                     (Defining_Identifier =>
246 0
                                        Map_C_Defining_Identifier (Field),
247
                                      Parameter_Type =>
248 0
                                        Make_Pointer_Type
249 0
                                          (Map_C_Data_Type_Designator
250 0
                                             (Corresponding_Instance
251
                                                (Field))));
252
                              end if;
253 0
                              CTU.Append_Node_To_List (Param, Profile);
254

255 0
                              Field := AIN.Next_Node (Field);
256 0
                           end loop;
257

258 0
                        when others =>
259 0
                           Display_Located_Error
260 0
                             (AIN.Loc (F),
261
                              "Unsupported data type",
262
                              Fatal => True);
263 0
                     end case;
264
                  end if;
265

266 0
                  F := AIN.Next_Node (F);
267 0
               end loop;
268
            end if;
269
         end if;
270

271
         N :=
272 1
           CTU.Make_Function_Specification
273
             (Defining_Identifier =>
274 1
                Make_Defining_Identifier (Get_Source_Name (S)),
275
              Parameters  => Profile,
276 1
              Return_Type => New_Node (CTN.K_Void));
277

278 1
         return N;
279
      end Map_Subprogram_Spec;
280

281
      -----------
282
      -- Visit --
283
      -----------
284

285 1
      procedure Visit (E : Node_Id) is
286
      begin
287
         case AAN.Kind (E) is
288 1
            when K_Architecture_Instance =>
289 1
               Visit_Architecture_Instance (E);
290

291 1
            when K_Component_Instance =>
292 1
               Visit_Component_Instance (E);
293

294 0
            when others =>
295 0
               null;
296
         end case;
297 1
      end Visit;
298

299
      ---------------------------------
300
      -- Visit_Architecture_Instance --
301
      ---------------------------------
302

303 1
      procedure Visit_Architecture_Instance (E : Node_Id) is
304
      begin
305 1
         Visit (Root_System (E));
306 1
      end Visit_Architecture_Instance;
307

308
      ------------------------------
309
      -- Visit_Component_Instance --
310
      ------------------------------
311

312 1
      procedure Visit_Component_Instance (E : Node_Id) is
313
         Category : constant Component_Category :=
314 1
           Get_Category_Of_Component (E);
315
      begin
316
         case Category is
317 1
            when CC_System =>
318 1
               Visit_System_Instance (E);
319

320 1
            when CC_Process =>
321 1
               Visit_Process_Instance (E);
322

323 0
            when CC_Device =>
324 0
               Visit_Device_Instance (E);
325

326 1
            when CC_Thread =>
327 1
               Visit_Thread_Instance (E);
328

329 1
            when CC_Subprogram =>
330 1
               Visit_Subprogram_Instance (E);
331

332 1
            when others =>
333 1
               null;
334
         end case;
335 1
      end Visit_Component_Instance;
336

337
      ---------------------------
338
      -- Visit_Device_Instance --
339
      ---------------------------
340

341 0
      procedure Visit_Device_Instance (E : Node_Id) is
342 0
         Implementation : Node_Id;
343
      begin
344 0
         Implementation := Get_Classifier_Property (E, "implemented_as");
345

346 0
         if Implementation /= No_Node then
347 0
            Visit_Subcomponents_Of (Implementation);
348
         end if;
349 0
      end Visit_Device_Instance;
350

351
      ----------------------------
352
      -- Visit_Process_Instance --
353
      ----------------------------
354

355 1
      procedure Visit_Process_Instance (E : Node_Id) is
356
      begin
357 1
         Visit_Subcomponents_Of (E);
358 1
      end Visit_Process_Instance;
359

360
      -------------------------------
361
      -- Visit_Subprogram_Instance --
362
      -------------------------------
363

364 1
      procedure Visit_Subprogram_Instance (E : Node_Id) is
365 1
         Spec     : Node_Id;
366 1
         Impl     : Node_Id;
367 1
         Call_Seq : Node_Id;
368 1
         Spg_Call : Node_Id;
369
      begin
370 1
         if Get_Source_Name (E) = No_Name then
371 0
            return;
372
         end if;
373

374
         --  We only generate users programs.
375

376 1
         Spec := Map_Subprogram_Spec (E);
377 1
         Append_Node_To_List (Spec, CTN.Declarations (Header_File));
378

379 1
         Impl := Make_Function_Implementation (Spec, No_List, No_List);
380 1
         Append_Node_To_List (Impl, CTN.Declarations (Source_File));
381

382 1
         if not AINU.Is_Empty (Calls (E)) then
383 0
            Call_Seq := AIN.First_Node (Calls (E));
384

385 0
            while Present (Call_Seq) loop
386
               --  For each call sequence visit all the called
387
               --  subprograms.
388

389 0
               if not AINU.Is_Empty (Subprogram_Calls (Call_Seq)) then
390 0
                  Spg_Call := AIN.First_Node (Subprogram_Calls (Call_Seq));
391

392 0
                  while Present (Spg_Call) loop
393 0
                     Visit (Corresponding_Instance (Spg_Call));
394

395 0
                     Spg_Call := AIN.Next_Node (Spg_Call);
396 0
                  end loop;
397
               end if;
398

399 0
               Call_Seq := AIN.Next_Node (Call_Seq);
400 0
            end loop;
401
         end if;
402
      end Visit_Subprogram_Instance;
403

404
      ---------------------------
405
      -- Visit_System_Instance --
406
      ---------------------------
407

408 1
      procedure Visit_System_Instance (E : Node_Id) is
409
      begin
410 1
         Visit_Subcomponents_Of (E);
411 1
      end Visit_System_Instance;
412

413
      ---------------------------
414
      -- Visit_Thread_Instance --
415
      ---------------------------
416

417 1
      procedure Visit_Thread_Instance (E : Node_Id) is
418 1
         Call_Seq : Node_Id;
419 1
         Spg_Call : Node_Id;
420
      begin
421
         --  Visit all the call sequences of the thread
422

423 1
         if not AINU.Is_Empty (Calls (E)) then
424 1
            Call_Seq := AIN.First_Node (Calls (E));
425

426 1
            while Present (Call_Seq) loop
427
               --  For each call sequence visit all the called
428
               --  subprograms.
429

430 1
               if not AINU.Is_Empty (Subprogram_Calls (Call_Seq)) then
431 1
                  Spg_Call := AIN.First_Node (Subprogram_Calls (Call_Seq));
432

433 1
                  while Present (Spg_Call) loop
434 1
                     Visit (Corresponding_Instance (Spg_Call));
435

436 1
                     Spg_Call := AIN.Next_Node (Spg_Call);
437 1
                  end loop;
438
               end if;
439

440 1
               Call_Seq := AIN.Next_Node (Call_Seq);
441 1
            end loop;
442
         end if;
443 1
      end Visit_Thread_Instance;
444

445
   end Subprograms_Generation;
446

447
   --------------
448
   -- Generate --
449
   --------------
450

451 1
   procedure Generate (AADL_Root : Node_Id) is
452 1
      Instance_Root : Node_Id;
453
   begin
454 1
      Instance_Root := Instantiate_Model (AADL_Root);
455

456 1
      Expand (Instance_Root);
457

458 1
      Visit_Architecture_Instance (Instance_Root);
459
      --  Abort if the construction of the C tree failed
460

461 1
      if No (AADL_Root) then
462 0
         Display_Error ("Code generation failed", Fatal => True);
463
      end if;
464

465
      --  Enter the output directory
466

467 1
      Enter_Directory (Generated_Sources_Directory);
468

469 1
      if not Remove_Generated_Sources then
470
         --  Create the source files
471

472 1
         C_Tree.Generator.Generate (C_Root);
473
      end if;
474

475
      --  Leave the output directory
476 1
      Leave_Directory;
477 1
   end Generate;
478

479
   ----------
480
   -- Init --
481
   ----------
482

483 1
   procedure Init is
484
   begin
485 1
      Register_Backend ("Subprograms", Generate'Access, Subprograms_Generator);
486 1
   end Init;
487

488
   -----------
489
   -- Reset --
490
   -----------
491

492 0
   procedure Reset is
493
   begin
494 0
      null;
495 0
   end Reset;
496

497
   ---------------------------------
498
   -- Visit_Architecture_Instance --
499
   ---------------------------------
500

501 1
   procedure Visit_Architecture_Instance (E : Node_Id) is
502 1
      D : constant Node_Id := CTU.New_Node (CTN.K_HI_Distributed_Application);
503 1
      N               : Name_Id;
504 1
      File_Identifier : Node_Id;
505 1
      Unit            : Node_Id;
506 1
      Clause          : Name_Id;
507 1
      Unit_Identifier : Node_Id;
508 1
      Ifdef_Clause    : Node_Id;
509 1
      Header_Name     : Name_Id;
510 1
      Header_Node     : Node_Id;
511
   begin
512 1
      CTN.Set_Units (D, CTU.New_List (CTN.K_List_Id));
513 1
      CTN.Set_HI_Nodes (D, CTU.New_List (CTN.K_List_Id));
514 1
      N := Get_String_Name ("generated-code");
515 1
      CTN.Set_Name (D, N);
516

517 1
      Set_Str_To_Name_Buffer ("subprograms-unit");
518 1
      Unit_Identifier := Make_Defining_Identifier (Name_Find);
519

520
      --  Create a "false" unit to store files.
521 1
      Unit := New_Node (CTN.K_HI_Unit, Unit_Identifier);
522 1
      Append_Node_To_List (Unit, Units (D));
523

524 1
      Set_Str_To_Name_Buffer ("generated-subprograms");
525 1
      File_Identifier := Make_Defining_Identifier (Name_Find);
526

527
      --  Create the Source_File node.
528

529 1
      Source_File := Make_Source_File (File_Identifier);
530 1
      Set_Distributed_Application_Unit (Source_File, D);
531 1
      Append_Node_To_List (Source_File, HI_Nodes (D));
532

533
      --  Create the Header_File node.
534

535 1
      Header_File := Make_Header_File (File_Identifier);
536 1
      Set_Distributed_Application_Unit (Header_File, D);
537 1
      Append_Node_To_List (Header_File, HI_Nodes (D));
538

539
      --  Generate #ifdef __POK_C__ #include <gtypes.h>.
540

541 1
      Set_Str_To_Name_Buffer ("gtypes");
542 1
      Header_Name := Name_Find;
543

544
      Header_Node :=
545 1
        Make_Include_Clause (Make_Defining_Identifier (Header_Name), False);
546

547 1
      Set_Str_To_Name_Buffer ("__POK_C__");
548 1
      Clause := Name_Find;
549

550
      Ifdef_Clause :=
551 1
        Make_Ifdef_Clause
552 1
          (Make_Defining_Identifier (Clause, C_Conversion => False),
553
           False,
554 1
           Make_List_Id (Header_Node),
555
           No_List);
556

557 1
      Append_Node_To_List (Ifdef_Clause, CTN.Declarations (Source_File));
558

559 1
      Append_Node_To_List
560 1
        (Copy_Node (Ifdef_Clause),
561 1
         CTN.Declarations (Header_File));
562

563
      --  Generate #ifdef __PO_HI_C__ #include <gtypes.h>.
564

565 1
      Set_Str_To_Name_Buffer ("types");
566 1
      Header_Name := Name_Find;
567

568
      Header_Node :=
569 1
        Make_Include_Clause (Make_Defining_Identifier (Header_Name), False);
570

571 1
      Set_Str_To_Name_Buffer ("__PO_HI_C__");
572 1
      Clause := Name_Find;
573

574
      Ifdef_Clause :=
575 1
        Make_Ifdef_Clause
576 1
          (Make_Defining_Identifier (Clause, C_Conversion => False),
577
           False,
578 1
           Make_List_Id (Header_Node),
579
           No_List);
580

581 1
      Append_Node_To_List (Ifdef_Clause, CTN.Declarations (Source_File));
582

583 1
      Append_Node_To_List
584 1
        (Copy_Node (Ifdef_Clause),
585 1
         CTN.Declarations (Header_File));
586

587
      --  Generate #ifdef is now finished.
588

589 1
      C_Root := D;
590

591 1
      Subprograms_Generation.Visit (E);
592 1
   end Visit_Architecture_Instance;
593

594 1
end Ocarina.Backends.Subprograms;

Read our documentation on viewing source code .

Loading