------------------------------------------------------------------------------
-- --
-- OCARINA COMPONENTS --
-- --
-- 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 --
-- --
-- B o d y --
-- --
-- Copyright (C) 2008-2009 Telecom ParisTech, 2010-2014 ESA & ISAE. --
-- --
-- Ocarina is free software; you can redistribute it and/or modify --
-- it under terms of the GNU General Public License as published by the --
-- Free Software Foundation; either version 2, or (at your option) any --
-- later version. Ocarina is distributed in the hope that it will be --
-- useful, but WITHOUT ANY WARRANTY; without even the implied warranty of --
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General --
-- Public License for more details. You should have received a copy of the --
-- GNU General Public License distributed with Ocarina; see file COPYING. --
-- If not, write to the Free Software Foundation, 51 Franklin Street, Fifth --
-- Floor, Boston, MA 02111-1301, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- Ocarina is maintained by the TASTE project --
-- (taste-users@lists.tuxfamily.org) --
-- --
------------------------------------------------------------------------------
with GNAT.Table;
with GNAT.Case_Util;
with Charset; use Charset;
with Locations; use Locations;
with Ocarina.Namet; use Ocarina.Namet;
with Utils; use Utils;
with Ocarina.Backends;
with Ocarina.Backends.C_Common.Mapping;
with Ocarina.Backends.PO_HI_C.Runtime;
with Ocarina.Backends.POK_C;
with Ocarina.Backends.POK_C.Runtime;
with Ocarina.Backends.Utils;
with Ocarina.Backends.Messages;
with Ocarina.Backends.C_Tree.Nutils;
with Ocarina.Backends.C_Values;
with Ocarina.Backends.Properties;
with Ocarina.ME_AADL.AADL_Instances.Nodes;
with Ocarina.ME_AADL.AADL_Tree.Nodes;
with Ocarina.ME_AADL.AADL_Instances.Nutils;
with Ocarina.Instances.Queries;
use Ocarina.ME_AADL.AADL_Instances.Nodes;
use Ocarina.Backends;
use Ocarina.Backends.Utils;
use Ocarina.Backends.Messages;
use Ocarina.Backends.Properties;
use Ocarina.Backends.C_Common.Mapping;
use Ocarina.Backends.C_Values;
use Ocarina.Instances.Queries;
package body Ocarina.Backends.C_Tree.Nutils is
package AINU renames Ocarina.ME_AADL.AADL_Instances.Nutils;
package AIN renames Ocarina.ME_AADL.AADL_Instances.Nodes;
package ATN renames Ocarina.ME_AADL.AADL_Tree.Nodes;
package CV renames Ocarina.Backends.C_Values;
package CTU renames Ocarina.Backends.C_Tree.Nutils;
package CTN renames Ocarina.Backends.C_Tree.Nodes;
package PHCR renames Ocarina.Backends.PO_HI_C.Runtime;
package PKR renames Ocarina.Backends.POK_C.Runtime;
Keyword_Suffix : constant String := "%C";
-- Used to mark C keywords and avoid collision with other languages
type Entity_Stack_Entry is record
Current_File : Node_Id;
Current_Entity : Node_Id;
end record;
No_Depth : constant Int := -1;
package Entity_Stack is
new GNAT.Table (Entity_Stack_Entry, Int, No_Depth + 1, 10, 10);
use Entity_Stack;
procedure New_Operator
(O : Operator_Type;
I : String := "");
------------------------
-- Add_Prefix_To_Name --
------------------------
function Add_Prefix_To_Name
(Prefix : String;
Name : Name_Id)
return Name_Id
is
begin
Set_Str_To_Name_Buffer (Prefix);
Get_Name_String_And_Append (Name);
return Name_Find;
end Add_Prefix_To_Name;
------------------------
-- Add_Suffix_To_Name --
------------------------
function Add_Suffix_To_Name
(Suffix : String;
Name : Name_Id)
return Name_Id
is
begin
Get_Name_String (Name);
Add_Str_To_Name_Buffer (Suffix);
return Name_Find;
end Add_Suffix_To_Name;
-----------------------------
-- Remove_Suffix_From_Name --
-----------------------------
function Remove_Suffix_From_Name
(Suffix : String;
Name : Name_Id)
return Name_Id
is
Length : Natural;
Temp_Str : String (1 .. Suffix'Length);
begin
Set_Str_To_Name_Buffer (Suffix);
Length := Name_Len;
Get_Name_String (Name);
if Name_Len > Length then
Temp_Str := Name_Buffer (Name_Len - Length + 1 .. Name_Len);
if Suffix = Temp_Str then
Set_Str_To_Name_Buffer (Name_Buffer (1 .. Name_Len - Length));
return Name_Find;
end if;
end if;
return Name;
end Remove_Suffix_From_Name;
-------------------------
-- Append_Node_To_List --
-------------------------
procedure Append_Node_To_List (E : Node_Id; L : List_Id) is
Last : Node_Id;
begin
Last := CTN.Last_Node (L);
if No (Last) then
CTN.Set_First_Node (L, E);
else
CTN.Set_Next_Node (Last, E);
end if;
Last := E;
while Present (Last) loop
CTN.Set_Last_Node (L, Last);
Last := CTN.Next_Node (Last);
end loop;
end Append_Node_To_List;
-----------------------
-- Insert_After_Node --
-----------------------
procedure Insert_After_Node (E : Node_Id; N : Node_Id) is
Next : constant Node_Id := CTN.Next_Node (N);
begin
CTN.Set_Next_Node (N, E);
CTN.Set_Next_Node (E, Next);
end Insert_After_Node;
------------------------
-- Insert_Before_Node --
------------------------
procedure Insert_Before_Node (E : Node_Id; N : Node_Id; L : List_Id) is
Entity : Node_Id;
begin
Entity := CTN.First_Node (L);
if Entity = N then
CTN.Set_Next_Node (E, Entity);
CTN.Set_First_Node (L, E);
else
while Present (Entity) loop
exit when CTN.Next_Node (Entity) = N;
Entity := CTN.Next_Node (Entity);
end loop;
Insert_After_Node (E, Entity);
end if;
end Insert_Before_Node;
---------------
-- Copy_Node --
---------------
function Copy_Node (N : Node_Id) return Node_Id is
C : Node_Id;
begin
case CTN.Kind (N) is
when K_Defining_Identifier =>
C := New_Node (K_Defining_Identifier);
CTN.Set_Name (C, CTN.Name (N));
CTN.Set_Corresponding_Node (C, CTN.Corresponding_Node (N));
when K_Function_Specification =>
C := New_Node (K_Function_Specification);
CTN.Set_Defining_Identifier
(C, CTU.Copy_Node (Defining_Identifier (N)));
CTN.Set_Parameters (C, CTN.Parameters (N));
CTN.Set_Return_Type (C, CTN.Return_Type (N));
when K_Include_Clause =>
C := New_Node (K_Include_Clause);
CTN.Set_Header_Name
(C, CTU.Copy_Node (Header_Name (N)));
CTN.Set_Is_Local (C, CTN.Is_Local (N));
when K_Literal =>
C := New_Node (K_Literal);
CTN.Set_Value (C, CTN.Value (N));
when K_Ifdef_Clause =>
C := New_Node (K_Ifdef_Clause);
CTN.Set_Negation (C, Negation (N));
CTN.Set_Then_Statements (C, Then_Statements (N));
CTN.Set_Else_Statements (C, Else_Statements (N));
CTN.Set_Clause (C, Copy_Node (Clause (N)));
when others =>
raise Program_Error;
end case;
return C;
end Copy_Node;
---------------------
-- Message_Comment --
---------------------
function Message_Comment (M : Name_Id) return Node_Id is
C : Node_Id;
begin
C := Make_C_Comment (M);
return C;
end Message_Comment;
---------------------
-- Message_Comment --
---------------------
function Message_Comment (M : String) return Node_Id is
C : Node_Id;
begin
Set_Str_To_Name_Buffer (M);
C := Make_C_Comment (Name_Find);
return C;
end Message_Comment;
-----------
-- Image --
-----------
function Image (T : Token_Type) return String is
S : String := Token_Type'Image (T);
begin
To_Lower (S);
return S (5 .. S'Last);
end Image;
-----------
-- Image --
-----------
function Image (O : Operator_Type) return String is
S : String := Operator_Type'Image (O);
begin
To_Lower (S);
for I in S'First .. S'Last loop
if S (I) = '_' then
S (I) := ' ';
end if;
end loop;
return S (4 .. S'Last);
end Image;
----------------
-- Initialize --
----------------
procedure Initialize is
begin
-- Initialize Nutils only once
if Initialized then
return;
end if;
Initialized := True;
-- Keywords.
for I in Keyword_Type loop
New_Token (I);
end loop;
-- Graphic Characters
New_Token (Tok_And, "&&");
New_Token (Tok_Xor, "^");
New_Token (Tok_Sharp, "#");
New_Token (Tok_Or, "||");
New_Token (Tok_Left_Brace, "{");
New_Token (Tok_Right_Brace, "}");
New_Token (Tok_Mod, "%");
New_Token (Tok_Not, "!");
New_Token (Tok_Ampersand, "&");
New_Token (Tok_Minus, "-");
New_Token (Tok_Underscore, "_");
New_Token (Tok_Plus, "+");
New_Token (Tok_Asterisk, "*");
New_Token (Tok_Slash, "/");
New_Token (Tok_Dot, ".");
New_Token (Tok_Apostrophe, "'");
New_Token (Tok_Left_Paren, "(");
New_Token (Tok_Right_Paren, ")");
New_Token (Tok_Left_Hook, "[");
New_Token (Tok_Right_Hook, "]");
New_Token (Tok_Comma, ",");
New_Token (Tok_Less, "<");
New_Token (Tok_Equal, "=");
New_Token (Tok_Equal_Equal, "==");
New_Token (Tok_Greater, ">");
New_Token (Tok_Not_Equal, "!=");
New_Token (Tok_Greater_Equal, ">=");
New_Token (Tok_Less_Equal, "<=");
New_Token (Tok_Colon, ":");
New_Token (Tok_Greater_Greater, ">>");
New_Token (Tok_Less_Less, "<<");
New_Token (Tok_Quote, """");
New_Token (Tok_Semicolon, ";");
New_Token (Tok_Arrow, "->");
New_Token (Tok_Vertical_Bar, "|");
for O in Op_And .. Op_Or_Else loop
New_Operator (O);
end loop;
New_Operator (Op_And_Symbol, "&");
New_Operator (Op_Double_Asterisk, "**");
New_Operator (Op_Asterisk, "**");
New_Operator (Op_Minus, "-");
New_Operator (Op_Plus, "+");
New_Operator (Op_Asterisk, "*");
New_Operator (Op_Slash, "/");
New_Operator (Op_Less, "<");
New_Operator (Op_Equal, "=");
New_Operator (Op_Equal_Equal, "==");
New_Operator (Op_Greater, ">");
New_Operator (Op_Not_Equal, "!=");
New_Operator (Op_Greater_Equal, ">=");
New_Operator (Op_Less_Equal, "<=");
New_Operator (Op_Greater_Greater, ">>");
New_Operator (Op_Less_Less, "<<");
New_Operator (Op_Semicolon, ";");
New_Operator (Op_Arrow, "=>");
New_Operator (Op_Vertical_Bar, "|");
for A in Attribute_Id loop
Set_Str_To_Name_Buffer (Attribute_Id'Image (A));
Set_Str_To_Name_Buffer (Name_Buffer (3 .. Name_Len));
GNAT.Case_Util.To_Mixed (Name_Buffer (1 .. Name_Len));
AN (A) := Name_Find;
end loop;
for C in Constant_Id loop
Set_Str_To_Name_Buffer (Constant_Id'Image (C));
Set_Str_To_Name_Buffer (Name_Buffer (3 .. Name_Len));
CONST (C) := To_Upper (Name_Find);
end loop;
for P in Parameter_Id loop
Set_Str_To_Name_Buffer (Parameter_Id'Image (P));
Set_Str_To_Name_Buffer (Name_Buffer (3 .. Name_Len));
GNAT.Case_Util.To_Mixed (Name_Buffer (1 .. Name_Len));
PN (P) := Name_Find;
end loop;
for F in Function_Id loop
Set_Str_To_Name_Buffer (Function_Id'Image (F));
Set_Str_To_Name_Buffer (Name_Buffer (3 .. Name_Len));
FN (F) := To_Lower (Name_Find);
end loop;
for T in Type_Id loop
Set_Str_To_Name_Buffer (Type_Id'Image (T));
Set_Str_To_Name_Buffer (Name_Buffer (3 .. Name_Len));
TN (T) := To_Lower (Name_Find);
end loop;
for V in Variable_Id loop
Set_Str_To_Name_Buffer (Variable_Id'Image (V));
Set_Str_To_Name_Buffer (Name_Buffer (3 .. Name_Len));
VN (V) := To_Lower (Name_Find);
end loop;
for V in Member_Id loop
Set_Str_To_Name_Buffer (Member_Id'Image (V));
Set_Str_To_Name_Buffer (Name_Buffer (3 .. Name_Len));
MN (V) := To_Lower (Name_Find);
end loop;
end Initialize;
-----------
-- Reset --
-----------
procedure Reset is
begin
Entity_Stack.Init;
Initialized := False;
end Reset;
--------------
-- Is_Empty --
--------------
function Is_Empty (L : List_Id) return Boolean is
begin
return L = No_List or else No (CTN.First_Node (L));
end Is_Empty;
------------
-- Length --
------------
function Length (L : List_Id) return Natural is
N : Node_Id;
C : Natural := 0;
begin
if not Is_Empty (L) then
N := CTN.First_Node (L);
while Present (N) loop
C := C + 1;
N := CTN.Next_Node (N);
end loop;
end if;
return C;
end Length;
--------------------
-- Make_C_Comment --
--------------------
function Make_C_Comment
(N : Name_Id;
Has_Header_Spaces : Boolean := True)
return Node_Id
is
C : Node_Id;
begin
C := New_Node (K_C_Comment);
Set_Defining_Identifier (C, New_Node (K_Defining_Identifier));
CTN.Set_Name (Defining_Identifier (C), N);
CTN.Set_Has_Header_Spaces (C, Has_Header_Spaces);
return C;
end Make_C_Comment;
-------------------------------
-- Make_Assignment_Statement --
-------------------------------
function Make_Assignment_Statement
(Variable_Identifier : Node_Id;
Expression : Node_Id)
return Node_Id
is
N : Node_Id;
begin
N := New_Node (K_Assignment_Statement);
Set_Defining_Identifier (N, Variable_Identifier);
Set_Expression (N, Expression);
return N;
end Make_Assignment_Statement;
------------------------------
-- Make_Defining_Identifier --
------------------------------
function Make_Defining_Identifier
(Name : Name_Id;
C_Conversion : Boolean := True;
Ada_Conversion : Boolean := False;
Pointer : Boolean := False)
return Node_Id
is
N : Node_Id;
begin
N := New_Node (K_Defining_Identifier);
if C_Conversion then
CTN.Set_Name (N, To_C_Name (Name, Ada_Conversion));
else
CTN.Set_Name (N, Name);
end if;
if Pointer then
CTN.Set_Is_Pointer (N, True);
end if;
return N;
end Make_Defining_Identifier;
---------------------
-- Make_Expression --
---------------------
function Make_Expression
(Left_Expr : Node_Id;
Operator : Operator_Type := Op_None;
Right_Expr : Node_Id := No_Node)
return Node_Id
is
N : Node_Id;
begin
N := New_Node (K_Expression);
Set_Left_Expression (N, Left_Expr);
Set_Operator (N, Operator_Type'Pos (Operator));
Set_Right_Expression (N, Right_Expr);
return N;
end Make_Expression;
------------------------
-- Make_For_Statement --
------------------------
function Make_For_Statement
(Defining_Identifier : Node_Id;
Pre_Cond : Node_Id;
Condition : Node_Id;
Post_Cond : Node_Id;
Statements : List_Id)
return Node_Id
is
N : Node_Id;
begin
N := New_Node (K_For_Statement);
Set_Defining_Identifier (N, Defining_Identifier);
Set_Pre_Cond (N, Pre_Cond);
Set_Condition (N, Condition);
Set_Post_Cond (N, Post_Cond);
Set_Statements (N, Statements);
return N;
end Make_For_Statement;
------------------
-- Make_Literal --
------------------
function Make_Literal (Value : Value_Id) return Node_Id is
N : Node_Id;
begin
N := New_Node (K_Literal);
CTN.Set_Value (N, Value);
return N;
end Make_Literal;
-------------------------
-- Make_Loop_Statement --
-------------------------
function Make_While_Statement
(Condition : Node_Id;
Statements : List_Id)
return Node_Id
is
N : Node_Id;
begin
N := New_Node (K_While_Statement);
Set_Condition (N, Condition);
Set_Statements (N, Statements);
return N;
end Make_While_Statement;
--------------------------------
-- Make_Full_Type_Declaration --
--------------------------------
function Make_Full_Type_Declaration
(Defining_Identifier : Node_Id;
Type_Definition : Node_Id)
return Node_Id
is
N : Node_Id;
begin
N := New_Node (K_Full_Type_Declaration);
Set_Type_Name (N, Defining_Identifier);
Set_Type_Definition (N, Type_Definition);
return N;
end Make_Full_Type_Declaration;
-----------------------
-- Make_If_Statement --
-----------------------
function Make_If_Statement
(Condition : Node_Id;
Statements : List_Id;
Else_Statements : List_Id := No_List)
return Node_Id
is
N : Node_Id;
begin
N := New_Node (K_If_Statement);
Set_Condition (N, Condition);
Set_Statements (N, Statements);
Set_Else_Statements (N, Else_Statements);
return N;
end Make_If_Statement;
------------------
-- Make_List_Id --
------------------
function Make_List_Id
(N1 : Node_Id;
N2 : Node_Id := No_Node;
N3 : Node_Id := No_Node)
return List_Id
is
L : List_Id;
begin
L := New_List (K_List_Id);
Append_Node_To_List (N1, L);
if Present (N2) then
Append_Node_To_List (N2, L);
if Present (N3) then
Append_Node_To_List (N3, L);
end if;
end if;
return L;
end Make_List_Id;
----------------------------------
-- Make_Parameter_Specification --
----------------------------------
function Make_Parameter_Specification
(Defining_Identifier : Node_Id;
Parameter_Type : Node_Id := No_Node)
return Node_Id
is
P : Node_Id;
begin
P := New_Node (K_Parameter_Specification);
Set_Defining_Identifier (P, Defining_Identifier);
Set_Parameter_Type (P, Parameter_Type);
return P;
end Make_Parameter_Specification;
---------------------------
-- Make_Return_Statement --
---------------------------
function Make_Return_Statement
(Expression : Node_Id := No_Node)
return Node_Id
is
N : Node_Id;
begin
N := New_Node (K_Return_Statement);
if Expression /= No_Node then
Set_Expression (N, Expression);
end if;
return N;
end Make_Return_Statement;
---------------------------------
-- Make_Function_Specification --
---------------------------------
function Make_Function_Specification
(Defining_Identifier : Node_Id;
Parameters : List_Id := No_List;
Return_Type : Node_Id := No_Node)
return Node_Id
is
N : Node_Id;
begin
N := New_Node (K_Function_Specification);
Set_Parameters (N, Parameters);
Set_Defining_Identifier (N, Defining_Identifier);
Set_Return_Type (N, Return_Type);
return N;
end Make_Function_Specification;
----------------------------------
-- Make_Function_Implementation --
----------------------------------
function Make_Function_Implementation
(Specification : Node_Id;
Declarations : List_Id;
Statements : List_Id)
return Node_Id
is
N : Node_Id;
begin
N := New_Node (K_Function_Implementation);
Set_Specification (N, Specification);
CTN.Set_Declarations (N, Declarations);
Set_Statements (N, Statements);
return N;
end Make_Function_Implementation;
-----------------------------
-- Make_Member_Declaration --
-----------------------------
function Make_Member_Declaration
(Defining_Identifier : Node_Id;
Used_Type : Node_Id)
return Node_Id
is
P : Node_Id;
begin
P := New_Node (K_Member_Declaration);
Set_Defining_Identifier (P, Defining_Identifier);
Set_Used_Type (P, Used_Type);
return P;
end Make_Member_Declaration;
-------------------------------
-- Make_Variable_Declaration --
-------------------------------
function Make_Variable_Declaration
(Defining_Identifier : Node_Id;
Used_Type : Node_Id)
return Node_Id
is
P : Node_Id;
begin
P := New_Node (K_Variable_Declaration);
Set_Defining_Identifier (P, Defining_Identifier);
Set_Used_Type (P, Used_Type);
return P;
end Make_Variable_Declaration;
---------------------------
-- Make_Variable_Address --
---------------------------
function Make_Variable_Address
(Expression : Node_Id)
return Node_Id
is
P : Node_Id;
begin
P := New_Node (K_Variable_Address);
Set_Expression (P, Expression);
return P;
end Make_Variable_Address;
------------------------------------
-- Make_Extern_Entity_Declaration --
------------------------------------
function Make_Extern_Entity_Declaration
(Entity : Node_Id)
return Node_Id
is
P : Node_Id;
begin
P := New_Node (K_Extern_Entity_Declaration);
CTN.Set_Entity (P, Entity);
return P;
end Make_Extern_Entity_Declaration;
---------------------------
-- Make_Struct_Aggregate --
---------------------------
function Make_Struct_Aggregate
(Defining_Identifier : Node_Id := No_Node;
Members : List_Id)
return Node_Id
is
N : Node_Id;
begin
N := New_Node (K_Struct_Aggregate);
if Defining_Identifier /= No_Node then
Set_Defining_Identifier (N, Defining_Identifier);
end if;
Set_Struct_Members (N, Members);
return N;
end Make_Struct_Aggregate;
--------------------------
-- Make_Union_Aggregate --
--------------------------
function Make_Union_Aggregate
(Defining_Identifier : Node_Id := No_Node;
Members : List_Id)
return Node_Id
is
N : Node_Id;
begin
N := New_Node (K_Union_Aggregate);
if Defining_Identifier /= No_Node then
Set_Defining_Identifier (N, Defining_Identifier);
end if;
Set_Union_Members (N, Members);
return N;
end Make_Union_Aggregate;
-------------------------
-- Make_Enum_Aggregate --
-------------------------
function Make_Enum_Aggregate
(Members : List_Id)
return Node_Id
is
N : Node_Id;
begin
N := New_Node (K_Enum_Aggregate);
Set_Enum_Members (N, Members);
return N;
end Make_Enum_Aggregate;
-----------------------
-- Make_Call_Profile --
-----------------------
function Make_Call_Profile
(Defining_Identifier : Node_Id;
Parameters : List_Id := No_List)
return Node_Id
is
N : Node_Id;
begin
N := New_Node (K_Call_Profile);
Set_Defining_Identifier (N, Defining_Identifier);
Set_Parameters (N, Parameters);
return N;
end Make_Call_Profile;
---------------------
-- Make_Macro_Call --
---------------------
function Make_Macro_Call
(Defining_Identifier : Node_Id;
Parameters : List_Id := No_List)
return Node_Id
is
N : Node_Id;
begin
N := New_Node (K_Macro_Call);
Set_Defining_Identifier (N, Defining_Identifier);
Set_Parameters (N, Parameters);
return N;
end Make_Macro_Call;
-------------------------
-- Make_Type_Attribute --
-------------------------
function Make_Type_Attribute
(Designator : Node_Id;
Attribute : Attribute_Id)
return Node_Id
is
procedure Get_Scoped_Name_String (S : Node_Id);
----------------------------
-- Get_Scoped_Name_String --
----------------------------
procedure Get_Scoped_Name_String (S : Node_Id) is
begin
Get_Name_String_And_Append (CTN.Name (Defining_Identifier (S)));
end Get_Scoped_Name_String;
begin
Name_Len := 0;
Get_Scoped_Name_String (Designator);
Add_Char_To_Name_Buffer (''');
Get_Name_String_And_Append (AN (Attribute));
return Make_Defining_Identifier (Name_Find);
end Make_Type_Attribute;
--------------------------
-- Make_Type_Conversion --
--------------------------
function Make_Type_Conversion
(Subtype_Mark : Node_Id;
Expression : Node_Id)
return Node_Id
is
N : Node_Id;
begin
N := New_Node (K_Type_Conversion);
Set_Subtype_Mark (N, Subtype_Mark);
Set_Expression (N, Expression);
return N;
end Make_Type_Conversion;
-------------------------
-- Make_Comment_Header --
-------------------------
procedure Make_Comment_Header (Header : List_Id) is
N : Node_Id;
begin
-- Appending the comment header lines to the file header
Set_Str_To_Name_Buffer
("***************************************************");
N := Make_C_Comment (Name_Find, False);
Append_Node_To_List (N, Header);
Set_Str_To_Name_Buffer
("This file was automatically generated by Ocarina ");
N := Make_C_Comment (Name_Find);
Append_Node_To_List (N, Header);
Set_Str_To_Name_Buffer
("Do NOT hand-modify this file, as your ");
N := Make_C_Comment (Name_Find);
Append_Node_To_List (N, Header);
Set_Str_To_Name_Buffer
("changes will be lost when you re-run Ocarina ");
N := Make_C_Comment (Name_Find);
Append_Node_To_List (N, Header);
Set_Str_To_Name_Buffer
("***************************************************");
N := Make_C_Comment (Name_Find, False);
Append_Node_To_List (N, Header);
end Make_Comment_Header;
-----------------
-- Next_N_Node --
-----------------
function Next_N_Node (N : Node_Id; Num : Natural) return Node_Id is
Result : Node_Id := N;
begin
for I in 1 .. Num loop
Result := CTN.Next_Node (Result);
end loop;
return Result;
end Next_N_Node;
--------------
-- New_List --
--------------
function New_List
(Kind : CTN.Node_Kind;
From : Node_Id := No_Node)
return List_Id is
N : Node_Id;
begin
CTN.Entries.Increment_Last;
N := CTN.Entries.Last;
CTN.Entries.Table (N) := CTN.Default_Node;
Set_Kind (N, Kind);
if Present (From) then
CTN.Set_Loc (N, CTN.Loc (From));
else
CTN.Set_Loc (N, No_Location);
end if;
return List_Id (N);
end New_List;
--------------
-- New_Node --
--------------
function New_Node
(Kind : CTN.Node_Kind;
From : Node_Id := No_Node)
return Node_Id
is
N : Node_Id;
begin
CTN.Entries.Increment_Last;
N := CTN.Entries.Last;
CTN.Entries.Table (N) := CTN.Default_Node;
CTN.Set_Kind (N, Kind);
if Present (From) then
CTN.Set_Loc (N, AIN.Loc (From));
else
CTN.Set_Loc (N, No_Location);
end if;
return N;
end New_Node;
---------------
-- New_Token --
---------------
procedure New_Token
(T : Token_Type;
I : String := "")
is
Name : Name_Id;
begin
if T in Keyword_Type then
-- Marking the token image as a keyword for fas searching
-- purpose, we add the prefix to avoir collision with other
-- languages keywords
Set_Str_To_Name_Buffer (Image (T));
Name := Name_Find;
Name := Add_Suffix_To_Name (Keyword_Suffix, Name);
Set_Name_Table_Byte (Name, Ocarina.Types.Byte (Token_Type'Pos (T) + 1));
Set_Str_To_Name_Buffer (Image (T));
else
Set_Str_To_Name_Buffer (I);
end if;
Token_Image (T) := Name_Find;
end New_Token;
------------------
-- New_Operator --
------------------
procedure New_Operator
(O : Operator_Type;
I : String := "") is
begin
if O in Keyword_Operator then
Set_Str_To_Name_Buffer (Image (O));
else
Set_Str_To_Name_Buffer (I);
end if;
Operator_Image (Operator_Type'Pos (O)) := Name_Find;
end New_Operator;
----------------
-- Pop_Entity --
----------------
procedure Pop_Entity is
begin
if Last > No_Depth then
Decrement_Last;
end if;
end Pop_Entity;
-----------------
-- Push_Entity --
-----------------
procedure Push_Entity (E : Node_Id) is
begin
Increment_Last;
Table (Last).Current_Entity := E;
end Push_Entity;
---------------------------
-- Remove_Node_From_List --
---------------------------
procedure Remove_Node_From_List (E : Node_Id; L : List_Id) is
C : Node_Id;
begin
C := CTN.First_Node (L);
if C = E then
CTN.Set_First_Node (L, CTN.Next_Node (E));
if CTN.Last_Node (L) = E then
CTN.Set_Last_Node (L, No_Node);
end if;
else
while Present (C) loop
if CTN.Next_Node (C) = E then
CTN.Set_Next_Node (C, CTN.Next_Node (E));
if CTN.Last_Node (L) = E then
CTN.Set_Last_Node (L, C);
end if;
exit;
end if;
C := CTN.Next_Node (C);
end loop;
end if;
end Remove_Node_From_List;
---------------------
-- Set_Main_Source --
---------------------
procedure Set_Main_Source (N : Node_Id := No_Node) is
X : Node_Id := N;
begin
if No (X) then
X := Table (Last).Current_Entity;
end if;
Table (Last).Current_File := Main_Source (X);
end Set_Main_Source;
---------------------
-- Set_Main_Header --
---------------------
procedure Set_Main_Header (N : Node_Id := No_Node) is
X : Node_Id := N;
begin
if No (X) then
X := Table (Last).Current_Entity;
end if;
Table (Last).Current_File := Main_Header (X);
end Set_Main_Header;
---------------
-- To_C_Name --
---------------
function To_C_Name
(N : Name_Id;
Ada_Style : Boolean := False;
Keyword_Check : Boolean := True)
return Name_Id
is
Name : Name_Id;
Test_Name : Name_Id;
V : Ocarina.Types.Byte;
begin
Get_Name_String (Normalize_Name (N, Ada_Style));
Name := Name_Find;
if Keyword_Check then
-- If the identifier collides with a C reserved word insert
-- "AADL_" string before the identifier.
Test_Name := Add_Suffix_To_Name (Keyword_Suffix, Name);
V := Get_Name_Table_Byte (Test_Name);
if V > 0 then
Set_Str_To_Name_Buffer ("AADL_");
Get_Name_String_And_Append (Name);
Name := Name_Find;
end if;
end if;
return To_Lower (Name);
end To_C_Name;
----------------------------
-- Conventional_Base_Name --
----------------------------
function Conventional_Base_Name (N : Name_Id) return Name_Id is
begin
Get_Name_String (N);
for Index in 1 .. Name_Len loop
Name_Buffer (Index) := To_Lower (Name_Buffer (Index));
end loop;
return Name_Find;
end Conventional_Base_Name;
-------------------------
-- Set_Activity_Source --
-------------------------
procedure Set_Activity_Source (N : Node_Id := No_Node) is
X : Node_Id := N;
begin
if No (X) then
X := Table (Last).Current_Entity;
end if;
Table (Last).Current_File := Activity_Source (X);
end Set_Activity_Source;
---------------------------
-- Set_Deployment_Header --
---------------------------
procedure Set_Deployment_Header (N : Node_Id := No_Node) is
X : Node_Id := N;
begin
if No (X) then
X := Table (Last).Current_Entity;
end if;
Table (Last).Current_File := Deployment_Header (X);
end Set_Deployment_Header;
---------------------------
-- Set_Deployment_Source --
---------------------------
procedure Set_Deployment_Source (N : Node_Id := No_Node) is
X : Node_Id := N;
begin
if No (X) then
X := Table (Last).Current_Entity;
end if;
Table (Last).Current_File := Deployment_Source (X);
end Set_Deployment_Source;
-------------------------
-- Set_Activity_Header --
-------------------------
procedure Set_Activity_Header (N : Node_Id := No_Node) is
X : Node_Id := N;
begin
if No (X) then
X := Table (Last).Current_Entity;
end if;
Table (Last).Current_File := Activity_Header (X);
end Set_Activity_Header;
------------------------
-- Set_Request_Header --
------------------------
procedure Set_Request_Header (N : Node_Id := No_Node) is
X : Node_Id := N;
begin
if No (X) then
X := Table (Last).Current_Entity;
end if;
Table (Last).Current_File := Request_Header (X);
end Set_Request_Header;
------------------------
-- Set_Request_Source --
------------------------
procedure Set_Request_Source (N : Node_Id := No_Node) is
X : Node_Id := N;
begin
if No (X) then
X := Table (Last).Current_Entity;
end if;
Table (Last).Current_File := Request_Source (X);
end Set_Request_Source;
----------------------------
-- Set_Marshallers_Source --
----------------------------
procedure Set_Marshallers_Source (N : Node_Id := No_Node) is
X : Node_Id := N;
begin
if No (X) then
X := Table (Last).Current_Entity;
end if;
Table (Last).Current_File := Marshallers_Source (X);
end Set_Marshallers_Source;
----------------------
-- Set_Types_Header --
----------------------
procedure Set_Types_Header (N : Node_Id := No_Node) is
X : Node_Id := N;
begin
if No (X) then
X := Table (Last).Current_Entity;
end if;
Table (Last).Current_File := Types_Header (X);
end Set_Types_Header;
----------------------------
-- Set_Marshallers_Header --
----------------------------
procedure Set_Marshallers_Header (N : Node_Id := No_Node) is
X : Node_Id := N;
begin
if No (X) then
X := Table (Last).Current_Entity;
end if;
Table (Last).Current_File := Marshallers_Header (X);
end Set_Marshallers_Header;
----------------------------
-- Set_Subprograms_Header --
----------------------------
procedure Set_Subprograms_Header (N : Node_Id := No_Node) is
X : Node_Id := N;
begin
if No (X) then
X := Table (Last).Current_Entity;
end if;
Table (Last).Current_File := Subprograms_Header (X);
end Set_Subprograms_Header;
-----------------------
-- Set_Naming_Header --
-----------------------
procedure Set_Naming_Header (N : Node_Id := No_Node) is
X : Node_Id := N;
begin
if No (X) then
X := Table (Last).Current_Entity;
end if;
Table (Last).Current_File := Naming_Header (X);
end Set_Naming_Header;
-----------------------
-- Set_Naming_Source --
-----------------------
procedure Set_Naming_Source (N : Node_Id := No_Node) is
X : Node_Id := N;
begin
if No (X) then
X := Table (Last).Current_Entity;
end if;
Table (Last).Current_File := Naming_Source (X);
end Set_Naming_Source;
----------------------------
-- Set_Subprograms_Source --
----------------------------
procedure Set_Subprograms_Source (N : Node_Id := No_Node) is
X : Node_Id := N;
begin
if No (X) then
X := Table (Last).Current_Entity;
end if;
Table (Last).Current_File := Subprograms_Source (X);
end Set_Subprograms_Source;
----------------------
-- Set_Types_Source --
----------------------
procedure Set_Types_Source (N : Node_Id := No_Node) is
X : Node_Id := N;
begin
if No (X) then
X := Table (Last).Current_Entity;
end if;
Table (Last).Current_File := Types_Source (X);
end Set_Types_Source;
--------------------
-- Current_Entity --
--------------------
function Current_Entity return Node_Id is
begin
if Last = No_Depth then
return No_Node;
else
return Table (Last).Current_Entity;
end if;
end Current_Entity;
------------------
-- Current_File --
------------------
function Current_File return Node_Id is
begin
if Last = No_Depth then
return No_Node;
else
return Table (Last).Current_File;
end if;
end Current_File;
----------------------
-- Make_Source_File --
----------------------
function Make_Source_File (Identifier : Node_Id) return Node_Id is
File : Node_Id;
begin
File := New_Node (K_Source_File);
Set_Defining_Identifier (File, Identifier);
Set_Corresponding_Node (Identifier, File);
CTN.Set_Included_Headers (File, New_List (K_Header_List));
CTN.Set_Declarations (File, New_List (CTN.K_Declaration_List));
Make_Comment_Header (CTN.Declarations (File));
return File;
end Make_Source_File;
----------------------
-- Make_Header_File --
----------------------
function Make_Header_File (Identifier : Node_Id) return Node_Id is
File : Node_Id;
begin
File := New_Node (K_Header_File);
Set_Defining_Identifier (File, Identifier);
Set_Corresponding_Node (Identifier, File);
CTN.Set_Included_Headers (File, New_List (K_Header_List));
CTN.Set_Declarations (File, New_List (CTN.K_Declaration_List));
Make_Comment_Header (CTN.Declarations (File));
return File;
end Make_Header_File;
-----------------
-- Add_Include --
-----------------
procedure Add_Include (E : Node_Id; Preserve_Case : Boolean := False)
is
W : Node_Id;
N : Name_Id;
M : Name_Id;
Existing_Include : Node_Id;
begin
-- Get the info associated to the obtained name in the hash
-- table and check whether it is already set to a value
-- different from 0 (No_Node) which means that the withed
-- entity is already in the withed package list. In this case
-- try to enrich the exisiting with clause with eventual 'use',
-- 'elaborate' or warning disabling clauses.
Get_Name_String (CTN.Name (Defining_Identifier (Current_File)));
if Kind (Current_File) = K_Header_File then
-- If the included file is the file in which we add the
-- include, we return immediatly, because a file don't
-- include itself
if To_Lower (CTN.Name (CTN.Header_Name (E)))
= To_Lower (CTN.Name (Defining_Identifier (Current_File))) then
return;
end if;
Set_Str_To_Name_Buffer (Name_Buffer (1 .. Name_Len) & ".h");
else
Set_Str_To_Name_Buffer (Name_Buffer (1 .. Name_Len) & ".c");
end if;
Get_Name_String_And_Append (CTN.Name (CTN.Header_Name (E)));
Get_Name_String_And_Append (CTN.Name
(CTN.Entity (Distributed_Application_Unit (Current_File))));
if Distributed_Application
(Entity
(Distributed_Application_Unit (Current_File))) /= No_Node then
Get_Name_String_And_Append
(CTN.Name
(Distributed_Application
(Entity
(Distributed_Application_Unit (Current_File)))));
end if;
if Preserve_Case then
N := Name_Find;
else
N := To_Lower (Name_Find);
end if;
Existing_Include := Node_Id (Get_Name_Table_Info (N));
-- If the file was already included, we return immediatly
if Present (Existing_Include) then
return;
end if;
-- Else, we add the corresponding header file to included files
Get_Name_String (CTN.Name (Header_Name ((E))));
M := Name_Find;
W := Make_Include_Clause
(Make_Defining_Identifier (M, not Preserve_Case),
Is_Local (E));
Set_Name_Table_Info (N, Int (W));
Append_Node_To_List (W, Included_Headers (Current_File));
end Add_Include;
---------------------------
-- Make_Define_Statement --
---------------------------
function Make_Define_Statement (Defining_Identifier : Node_Id;
Value : Node_Id) return Node_Id is
N : Node_Id;
begin
N := New_Node (K_Define_Statement);
Set_Defining_Identifier (N, Defining_Identifier);
Set_Defined_Value (N, Value);
return N;
end Make_Define_Statement;
-----------------------
-- Make_Pointer_Type --
-----------------------
function Make_Pointer_Type (Used_Type : Node_Id) return Node_Id is
N : Node_Id;
begin
N := New_Node (K_Pointer_Type);
Set_Used_Type (N, Used_Type);
return (N);
end Make_Pointer_Type;
------------------------
-- Make_Constant_Type --
------------------------
function Make_Constant_Type (Used_Type : Node_Id) return Node_Id is
N : Node_Id;
begin
N := New_Node (K_Constant_Type);
Set_Used_Type (N, Used_Type);
return (N);
end Make_Constant_Type;
----------------------------
-- Make_Member_Designator --
----------------------------
function Make_Member_Designator
(Defining_Identifier : Node_Id;
Aggregate_Name : Node_Id;
Is_Pointer : Boolean := False)
return Node_Id is
N : Node_Id;
begin
N := New_Node (K_Member_Designator);
Set_Defining_Identifier (N, Defining_Identifier);
Set_Is_Pointer (N, Is_Pointer);
Set_Aggregate_Name (N, Aggregate_Name);
return (N);
end Make_Member_Designator;
----------------------------
-- Make_Array_Declaration --
----------------------------
function Make_Array_Declaration
(Defining_Identifier : Node_Id;
Array_Size : Node_Id) return Node_Id is
N : Node_Id;
begin
N := New_Node (K_Array_Declaration);
Set_Defining_Identifier (N, Defining_Identifier);
Set_Array_Size (N, Array_Size);
return (N);
end Make_Array_Declaration;
-----------------------
-- Make_Array_Values --
-----------------------
function Make_Array_Values
(Values : List_Id := No_List) return Node_Id is
L : List_Id;
N : Node_Id;
begin
N := New_Node (K_Array_Values);
if not Present (Values) then
L := New_List (CTN.K_Enumeration_Literals);
Set_Values (N, L);
else
Set_Values (N, Values);
end if;
return (N);
end Make_Array_Values;
----------------------
-- Make_Array_Value --
----------------------
function Make_Array_Value (Array_Name : Node_Id; Array_Item : Node_Id)
return Node_Id is
N : Node_Id;
begin
N := New_Node (K_Array_Value);
Set_Defining_Identifier (N, Array_Name);
Set_Array_Item (N, Array_Item);
return (N);
end Make_Array_Value;
---------------------------
-- Make_Switch_Statement --
---------------------------
function Make_Switch_Statement
(Expression : Node_Id;
Alternatives : List_Id)
return Node_Id is
N : Node_Id;
begin
N := New_Node (K_Switch_Statement);
Set_Expression (N, Expression);
Set_Alternatives (N, Alternatives);
return (N);
end Make_Switch_Statement;
-----------------------------
-- Make_Switch_Alternative --
-----------------------------
function Make_Switch_Alternative
(Labels : List_Id;
Statements : List_Id) return Node_Id is
N : Node_Id;
begin
N := New_Node (K_Switch_Alternative);
Set_Labels (N, Labels);
Set_Statements (N, Statements);
return (N);
end Make_Switch_Alternative;
--------------------------
-- Handle_Call_Sequence --
--------------------------
procedure Handle_Call_Sequence
(Caller : Node_Id;
Call_Seq : Node_Id;
Declarations : List_Id;
Statements : List_Id;
Containing_Device : Node_Id := No_Node)
is
Destination_F : Node_Id;
Source_F : Node_Id;
Source_Parent : Node_Id;
Param_Value : Node_Id;
Call_Profile : List_Id;
Spg : Node_Id;
Spg_Call : Node_Id;
N : Node_Id;
F : Node_Id;
M : Node_Id;
Owner : Node_Id;
Declaration : Node_Id;
Hybrid : constant Boolean :=
AINU.Is_Subprogram (Caller) and then
Properties.Get_Subprogram_Kind (Caller) =
Properties.Subprogram_Hybrid_Ada_95; -- XXX why Ada ?
begin
-- The lists have to be created
if Declarations = No_List or else Statements = No_List then
raise Program_Error with "Lists have to be created before any call "
& "to Handle_Call_Sequence";
end if;
-- The call sequence generally contains at least one call to a
-- subprogram.
if AINU.Is_Empty (AIN.Subprogram_Calls (Call_Seq)) then
Display_Located_Error
(AIN.Loc (Call_Seq),
"Empty call sequence",
Fatal => False,
Warning => True);
return;
end if;
Spg_Call := AIN.First_Node (AIN.Subprogram_Calls (Call_Seq));
while Present (Spg_Call) loop
Spg := AIN.Corresponding_Instance (Spg_Call);
Call_Profile := New_List (CTN.K_List_Id);
if not AINU.Is_Empty (AIN.Features (Spg)) then
F := AIN.First_Node (AIN.Features (Spg));
while Present (F) loop
if Kind (F) = K_Subcomponent_Access_Instance
and then Get_Current_Backend_Kind = PolyORB_Kernel_C
then
-- This case is specific to POK since we don't
-- handle the shared data with the same patterns as
-- in PolyORB-HI-C. This could be updated later.
Param_Value := Make_Variable_Address
(Map_C_Defining_Identifier
(Get_Accessed_Data (F)));
Append_Node_To_List (Param_Value, Call_Profile);
elsif AIN.Kind (F) = AIN.K_Parameter_Instance
and then AIN.Is_Out (F)
then
-- Raise an error if the parameter is not connected
-- to any source.
if AINU.Length (AIN.Destinations (F)) = 0 then
Display_Located_Error
(AIN.Loc (F),
"This OUT parameter is not connected to"
& " any destination",
Fatal => True);
elsif AINU.Length (AIN.Destinations (F)) > 1 then
Display_Located_Error
(AIN.Loc (F),
"This OUT parameter has too many destinations",
Fatal => True);
end if;
-- At this point, we have a subprogram call
-- parameter that has exactly one destination.
Destination_F := AIN.Item
(AIN.First_Node (AIN.Destinations (F)));
-- For each OUT parameter, we declare a local
-- variable if the OUT parameter is connected to
-- another subprogram call or if the caller is a
-- thread. Otherwise, we use the corresponding
-- caller subprogram parameter.
-- The parameter association value takes 3 possible
-- values (see the (1), (2) and (3) comments below.
if AINU.Is_Thread (Caller)
or else AIN.Parent_Component (Destination_F) /= Caller
then
-- (1) Here, we map the variable name from the
-- subprogram *call* name and the feature
-- name. This avoids name clashing when a thread
-- calls twice the same subprogram.
if Get_Current_Backend_Kind = PolyORB_HI_C then
M := Map_C_Data_Type_Designator
(Corresponding_Instance (F));
Declaration :=
Make_Variable_Declaration
(Defining_Identifier =>
Make_Defining_Identifier
(Map_C_Variable_Name
(F, Request_Variable => True)),
Used_Type => M);
Append_Node_To_List
(Declaration, Declarations);
M := Make_Defining_Identifier
(Map_C_Variable_Name
(F, Request_Variable => True));
elsif Get_Current_Backend_Kind = PolyORB_Kernel_C then
M := Map_C_Data_Type_Designator
(Corresponding_Instance (F));
Declaration :=
Make_Variable_Declaration
(Defining_Identifier =>
Make_Defining_Identifier
(Map_Port_Data (Destination_F)),
Used_Type => M);
Append_Node_To_List (Declaration, Declarations);
M := Make_Defining_Identifier
(Map_Port_Data (Destination_F));
end if;
Param_Value := Make_Variable_Address (M);
elsif Hybrid then
-- (2) If the calleD parameter is connected to
-- the calleR parameter and then the calleR
-- IS hybrid, then we use the 'Status'
-- record field corresponding to the calleR
-- parameter.
Param_Value := Make_Member_Designator
(Make_Defining_Identifier
(To_C_Name (AIN.Display_Name (AIN.Identifier (F)))),
Make_Defining_Identifier (PN (P_Status)));
else
-- (3) If the calleD parameter is connected to
-- the calleR parameter and then then calleR
-- is NOT hybrid, then we use simply the
-- corresponding parameter of the calleR.
Param_Value := Make_Defining_Identifier
(To_C_Name
(AIN.Display_Name
(AIN.Identifier
(Destination_F))));
end if;
-- For each OUT parameter we build a parameter
-- association of the actual profile of the
-- implmentaion subprogram call =>
-- .
CTU.Append_Node_To_List (Param_Value, Call_Profile);
elsif AIN.Kind (F) = AIN.K_Parameter_Instance
and then AIN.Is_In (F)
then
-- Raise an error if the parameter is not connected
-- to any source.
if AINU.Length (AIN.Sources (F)) = 0 then
Display_Located_Error
(AIN.Loc (F),
"This IN parameter is not connected to"
& " any source",
Fatal => True);
elsif AINU.Length (AIN.Sources (F)) > 1 then
Display_Located_Error
(AIN.Loc (F),
"This IN parameter has too many sources",
Fatal => True);
end if;
-- Here we have an IN parameter with exactly one
-- source.
Source_F := AIN.Item (AIN.First_Node (AIN.Sources (F)));
-- Get the source feature parent
Source_Parent := AIN.Parent_Component (Source_F);
-- The parameter value of the built parameter
-- association can take 4 different values. (see
-- comments (1), (2), (3) and (4) above).
if AINU.Is_Thread (Source_Parent) then
-- (1) If the Parent of 'Source_F' is a thread,
-- then we use the '_Job_Req' record
-- field corresponding to F.
if Get_Current_Backend_Kind = PolyORB_HI_C then
Param_Value :=
Make_Member_Designator
(Defining_Identifier =>
Make_Member_Designator
(Defining_Identifier =>
Make_Member_Designator
(Defining_Identifier =>
Make_Defining_Identifier
(Map_C_Enumerator_Name
(Source_F)),
Aggregate_Name =>
Make_Defining_Identifier
(Map_C_Enumerator_Name
(Source_F))),
Aggregate_Name =>
Make_Defining_Identifier (MN (M_Vars))),
Aggregate_Name =>
Make_Defining_Identifier
(Map_C_Variable_Name
(Source_F, Port_Request => True)));
else
M := Map_C_Data_Type_Designator
(Corresponding_Instance (F));
Declaration :=
Make_Variable_Declaration
(Defining_Identifier =>
Make_Defining_Identifier
(Map_Port_Data (Source_F)),
Used_Type => M);
Append_Node_To_List (Declaration, Declarations);
Param_Value := Make_Defining_Identifier
(Map_Port_Data (Source_F));
end if;
elsif Source_Parent /= Caller then
-- (2) If the the source call is different from
-- the englobing subprogram, we use the
-- formerly declared variable.
Param_Value := Make_Defining_Identifier
(Map_C_Variable_Name
(Source_F, Request_Variable => True));
elsif Hybrid then
-- (3) If the calleD parameter is connected to
-- the calleR parameter then calleR IS
-- hybrid, then we use the 'Status' record field
-- corresponding to the calleR parameter.
Param_Value := Make_Member_Designator
(Make_Defining_Identifier
(To_C_Name
(AIN.Display_Name
(AIN.Identifier (Source_F)))),
Make_Defining_Identifier
(PN (P_Status)));
else
-- (4) If the calleD parameter is connected to
-- the calleR parameter and then then calleR
-- is NOT hybrid, then we use simply the
-- corresponding paremeter of the calleR.
Param_Value := Make_Defining_Identifier
(To_C_Name (AIN.Display_Name
(AIN.Identifier (Source_F))));
end if;
-- For each IN parameter we build a parameter
-- association association of the actual profile of
-- the implmentaion subprogram call =>
-- .
CTU.Append_Node_To_List (Param_Value, Call_Profile);
end if;
F := AIN.Next_Node (F);
end loop;
end if;
if not AINU.Is_Empty (Path (Spg_Call)) then
-- If this is a feature subprogram call, generate a call
-- to the corresponding method. For this moment, we
-- simply handle protected objects
N := Message_Comment ("Invoking method");
CTU.Append_Node_To_List (N, Statements);
Owner := Get_Actual_Owner (Spg_Call);
N := Make_Variable_Address
(CTN.Defining_Identifier
(CTN.Object_Node (Backend_Node (Identifier (Owner)))));
Append_Node_To_List (N, Call_Profile);
-- The name of the called subprogram is deduced from the
-- corresponding subprogram spec instance (last element
-- of the 'Path' list) and from the actual data component
-- instance the call is connected to.
N := Map_C_Feature_Subprogram
(Item (AIN.Last_Node (Path (Spg_Call))),
Corresponding_Instance (Get_Actual_Owner (Spg_Call)));
N := Make_Call_Profile (N, Call_Profile);
CTU.Append_Node_To_List (N, Statements);
else
-- If this is a classic subprogram, call its
-- implementation.
if Get_Current_Backend_Kind = PolyORB_HI_C then
Add_Include (PHCR.RH (PHCR.RH_Subprograms));
elsif Get_Current_Backend_Kind = PolyORB_Kernel_C then
Add_Include (PKR.RH (PKR.RH_Subprograms));
end if;
N := Message_Comment ("Call implementation");
CTU.Append_Node_To_List (N, Statements);
if Get_Current_Backend_Kind = PolyORB_HI_C then
N := Map_C_Defining_Identifier (Spg);
if Containing_Device /= No_Node then
CTU.Append_Node_To_List
(Make_Defining_Identifier
(Map_C_Enumerator_Name (Containing_Device)),
Call_Profile);
end if;
elsif Get_Current_Backend_Kind = PolyORB_Kernel_C then
N := Map_C_Defining_Identifier (Spg);
end if;
N := Make_Call_Profile (N, Call_Profile);
CTU.Append_Node_To_List (N, Statements);
end if;
Spg_Call := AIN.Next_Node (Spg_Call);
end loop;
end Handle_Call_Sequence;
-------------------------
-- Get_C_Default_Value --
-------------------------
function Get_C_Default_Value (D : Node_Id) return Node_Id is
Data_Representation : Supported_Data_Representation;
Result : Node_Id;
begin
pragma Assert (AINU.Is_Data (D));
Data_Representation := Get_Data_Representation (D);
case Data_Representation is
when Data_Integer =>
-- For integers, default value is 0
Result := CTU.Make_Literal
(CV.New_Int_Value (0, 1, 10));
when Data_Float | Data_Fixed =>
-- For reals, the default value is 0.0
Result := CTU.Make_Literal
(CV.New_Floating_Point_Value (0.0));
when Data_Boolean =>
-- For booleans, the default value is FALSE
Result := CTU.Make_Literal
(CV.New_Int_Value (0, 1, 10));
when Data_Character =>
-- For characters, the default value is the space ' '
Result := CTU.Make_Literal
(CV.New_Char_Value (Character'Pos (' ')));
when Data_Wide_Character =>
-- For wide characters, the default value is the wide
-- space ' '.
Result := CTU.Make_Literal
(CV.New_Char_Value (Character'Pos (' ')));
when Data_String =>
Display_Located_Error
(AIN.Loc (D),
"Bounded strings default values not supported yet!",
Fatal => True);
when Data_Wide_String =>
Display_Located_Error
(AIN.Loc (D),
"Bounded wide strings default values not supported yet!",
Fatal => True);
when Data_Array =>
Display_Located_Error
(AIN.Loc (D),
"Bounded arrays default values not supported yet!",
Fatal => True);
when Data_With_Accessors =>
-- This is definitely a code generation error
raise Program_Error with "Data types with accessors should"
& " not have default values";
when others =>
raise Program_Error with "Unsupported data type default value!";
end case;
return Result;
end Get_C_Default_Value;
-------------------------
-- Make_Include_Clause --
-------------------------
function Make_Include_Clause
(Header_Name : Node_Id;
Local : Boolean := False)
return Node_Id
is
N : Node_Id;
begin
N := New_Node (K_Include_Clause);
Set_Header_Name (N, Header_Name);
Set_Is_Local (N, Local);
return N;
end Make_Include_Clause;
---------------------------
-- Add_Define_Deployment --
---------------------------
procedure Add_Define_Deployment (E : Node_Id)
is
W : Node_Id;
N : Name_Id;
F : Node_Id;
Existing_Def : Node_Id;
begin
Set_Str_To_Name_Buffer ("deployment");
Get_Name_String_And_Append (CTN.Name (E));
Get_Name_String_And_Append
(CTN.Name (CTN.Entity (Table (Last).Current_Entity)));
N := Name_Find;
Existing_Def := Node_Id (Get_Name_Table_Info (N));
-- If the file was already included, we return immediatly
if Present (Existing_Def) then
return;
end if;
-- Else, we add the corresponding header file to included files
W := CTU.Make_Define_Statement
(Defining_Identifier => Copy_Node (E),
Value => CTU.Make_Literal
(CV.New_Int_Value (1, 1, 10)));
Set_Name_Table_Info (N, Int (W));
F := Table (Last).Current_File;
Table (Last).Current_File := Deployment_Header
(Table (Last).Current_Entity);
Append_Node_To_List (W, CTN.Declarations (Current_File));
Table (Last).Current_File := F;
end Add_Define_Deployment;
--------------------------
-- Add_Return_Assertion --
--------------------------
procedure POK_Add_Return_Assertion
(Statements : List_Id;
Exception_Error : Node_Id := No_Node)
is
begin
if not POK_C.Add_Assertions then
return;
end if;
if Exception_Error = No_Node then
Append_Node_To_List
(Make_Macro_Call
(PKR.RE (PKR.RE_Assert_Ret),
Make_List_Id (Make_Defining_Identifier (VN (V_Ret)))),
Statements);
else
Append_Node_To_List
(Make_Macro_Call
(PKR.RE (PKR.RE_Assert_Ret_With_Exception),
Make_List_Id
(Make_Defining_Identifier (VN (V_Ret)),
Exception_Error)),
Statements);
end if;
end POK_Add_Return_Assertion;
----------------------------------------
-- POK_Make_Function_Call_With_Assert --
----------------------------------------
function POK_Make_Function_Call_With_Assert
(Function_Name : Node_Id; Parameters : List_Id)
return Node_Id
is
use Ocarina.Backends.POK_C;
Function_Call : Node_Id;
begin
Function_Call := Make_Call_Profile (Function_Name, Parameters);
if POK_C.Add_Assertions
and then POK_Flavor = POK then
return Make_Expression
(Make_Defining_Identifier (VN (V_Ret)),
Op_Equal,
Function_Call);
else
return Function_Call;
end if;
end POK_Make_Function_Call_With_Assert;
-------------------
-- Get_Data_Size --
-------------------
function Get_Data_Size (Data : Node_Id) return Node_Id is
Data_Representation : Supported_Data_Representation;
Value_UUL : Unsigned_Long_Long;
Value_Node : Node_Id := No_Node;
Dimension : constant ULL_Array := Get_Dimension (Data);
Type_Size : Size_Type;
begin
pragma Assert (AINU.Is_Data (Data));
Data_Representation := Get_Data_Representation (Data);
Type_Size := Get_Data_Size (Data);
if Get_Data_Size (Data) /= Null_Size then
Value_UUL := To_Bytes (Type_Size);
return (Make_Literal (New_Int_Value (Value_UUL, 1, 10)));
end if;
if Is_Defined_Property (Data, "type_source_name") then
return Make_Call_Profile
(Make_Defining_Identifier (FN (F_Sizeof)),
Make_List_Id
(Make_Defining_Identifier
(To_C_Name
(Get_String_Property
(Data, "type_source_name")))));
end if;
case Data_Representation is
when Data_Integer | Data_Boolean =>
Value_Node := Make_Call_Profile
(Make_Defining_Identifier (FN (F_Sizeof)),
Make_List_Id (Make_Defining_Identifier (TN (T_Int))));
when Data_Float =>
Value_Node := Make_Call_Profile
(Make_Defining_Identifier (FN (F_Sizeof)),
Make_List_Id (Make_Defining_Identifier (TN (T_Float))));
when Data_String | Data_Wide_String =>
Value_UUL := Dimension (1);
when Data_Array =>
Value_Node := Make_Expression
(Left_Expr =>
Make_Literal (New_Int_Value (Dimension (1), 1, 10)),
Operator => Op_Asterisk,
Right_Expr => Get_Data_Size
(ATN.Entity (ATN.First_Node (Get_Base_Type (Data)))));
when Data_None =>
Value_Node := Make_Call_Profile
(Make_Defining_Identifier (FN (F_Sizeof)),
Make_List_Id (Map_C_Defining_Identifier (Data)));
when others =>
Value_Node := Make_Call_Profile
(Make_Defining_Identifier (FN (F_Sizeof)),
Make_List_Id (Map_C_Defining_Identifier (Data)));
end case;
if Value_Node /= No_Node then
return Value_Node;
else
raise Program_Error with
"Impossible to get the data size of this data";
end if;
end Get_Data_Size;
---------------------------------
-- Add_Return_Variable_In_List --
---------------------------------
procedure Add_Return_Variable_In_Parameters (Parameters : List_Id) is
begin
Append_Node_To_List
(Make_Variable_Address (Make_Defining_Identifier (VN (V_Ret))),
Parameters);
end Add_Return_Variable_In_Parameters;
-----------------------------------------------------
-- Declare_Return_Variable_In_Function_Declaration --
-----------------------------------------------------
procedure POK_Declare_Return_Variable
(Declarations : List_Id) is
use Ocarina.Backends.POK_C;
use Ocarina.Backends.POK_C.Runtime;
N : Node_Id;
begin
if POK_C.Add_Assertions and then POK_Flavor = POK then
N := Make_Variable_Declaration
(Defining_Identifier => Make_Defining_Identifier (VN (V_Ret)),
Used_Type => RE (RE_Pok_Ret_T));
Append_Node_To_List (N, Declarations);
elsif POK_Flavor = ARINC653 then
N := Make_Variable_Declaration
(Defining_Identifier => Make_Defining_Identifier (VN (V_Ret)),
Used_Type => RE (RE_Return_Code_Type));
Append_Node_To_List (N, Declarations);
end if;
end POK_Declare_Return_Variable;
-------------------------
-- Make_Ifdef_Clause --
-------------------------
function Make_Ifdef_Clause
(Clause : Node_Id;
Negation : Boolean := False;
Then_Statements : List_Id;
Else_Statements : List_Id) return Node_Id is
N : Node_Id;
begin
N := New_Node (K_Ifdef_Clause);
CTN.Set_Negation (N, Negation);
CTN.Set_Clause (N, Clause);
CTN.Set_Then_Statements (N, Then_Statements);
CTN.Set_Else_Statements (N, Else_Statements);
return N;
end Make_Ifdef_Clause;
-------------------------------------
-- Get_Inter_Partition_Port_Size --
-------------------------------------
function Get_Inter_Partition_Port_Size (Port : Node_Id) return Node_Id is
Type_Found : Node_Id;
function Get_Inter_Partition_Port_Size_Rec (Port : Node_Id;
Method : Browsing_Kind)
return Node_Id is
Source_Port : Node_Id;
Destination_Port : Node_Id;
Tmp : Node_Id;
Associated_Type : Node_Id;
begin
Associated_Type := Get_Instance_Type_Associated_With_Virtual_Bus
(Port);
if Associated_Type /= No_Node then
return CTU.Get_Data_Size (Associated_Type);
end if;
if AINU.Is_Thread (Parent_Component (Port)) then
return Get_Data_Size (Corresponding_Instance (Port));
end if;
-- We are at the thread level so we are in the applicative domain.
-- no virtual bus was found so we fallback to the thread application
-- data.
if Method = By_Source and then
not AINU.Is_Empty (AIN.Sources (Port)) then
Tmp := AIN.First_Node (AIN.Sources (Port));
while Present (Tmp) loop
Source_Port := AIN.Item (Tmp);
Associated_Type := Get_Inter_Partition_Port_Size_Rec
(Source_Port, Method);
if Associated_Type /= No_Node then
return Associated_Type;
end if;
Tmp := AIN.Next_Node (Tmp);
end loop;
end if;
if Method = By_Destination and then
not AINU.Is_Empty (AIN.Destinations (Port)) then
Tmp := AIN.First_Node (AIN.Destinations (Port));
while Present (Tmp) loop
Destination_Port := AIN.Item (Tmp);
Associated_Type := Get_Inter_Partition_Port_Size_Rec
(Destination_Port, Method);
if Associated_Type /= No_Node then
return Associated_Type;
end if;
Tmp := AIN.Next_Node (Tmp);
end loop;
end if;
return No_Node;
end Get_Inter_Partition_Port_Size_Rec;
begin
if not AIN.Is_Data (Port) then
raise Program_Error with
"Call to Get_Inter_Partition_Port_Size with non DATA port";
end if;
if AIN.Is_In (Port) then
Type_Found := Get_Inter_Partition_Port_Size_Rec (Port, By_Source);
else
Type_Found := Get_Inter_Partition_Port_Size_Rec
(Port, By_Destination);
end if;
if Type_Found = No_Node then
return Get_Data_Size (Corresponding_Instance (Port));
end if;
return Type_Found;
end Get_Inter_Partition_Port_Size;
-------------------------------------
-- Get_Inter_Partition_Port_Type --
-------------------------------------
function Get_Inter_Partition_Port_Type (Port : Node_Id)
return Node_Id is
Type_Found : Node_Id;
function Get_Inter_Partition_Port_Type_Rec (Port : Node_Id;
Method : Browsing_Kind)
return Node_Id is
Source_Port : Node_Id;
Destination_Port : Node_Id;
Tmp : Node_Id;
Associated_Type : Node_Id;
begin
Associated_Type := Get_Instance_Type_Associated_With_Virtual_Bus
(Port);
if Associated_Type /= No_Node then
if Is_Defined_Property (Associated_Type, "type_source_name") then
return Make_Defining_Identifier
(To_C_Name
(Get_String_Property
(Associated_Type, "type_source_name")));
else
return Map_C_Data_Type_Designator (Associated_Type);
end if;
end if;
if AINU.Is_Thread (Parent_Component (Port)) then
return No_Node;
end if;
-- We are at the thread level so we are in the applicative domain.
-- no virtual bus was found so we fallback to the thread application
-- data.
if Method = By_Source and then
not AINU.Is_Empty (AIN.Sources (Port)) then
Tmp := AIN.First_Node (AIN.Sources (Port));
while Present (Tmp) loop
Source_Port := AIN.Item (Tmp);
Associated_Type := Get_Inter_Partition_Port_Type_Rec
(Source_Port, Method);
if Associated_Type /= No_Node then
return Associated_Type;
end if;
Tmp := AIN.Next_Node (Tmp);
end loop;
end if;
if Method = By_Destination and then
not AINU.Is_Empty (AIN.Destinations (Port)) then
Tmp := AIN.First_Node (AIN.Destinations (Port));
while Present (Tmp) loop
Destination_Port := AIN.Item (Tmp);
Associated_Type := Get_Inter_Partition_Port_Type_Rec
(Destination_Port, Method);
if Associated_Type /= No_Node then
return Associated_Type;
end if;
Tmp := AIN.Next_Node (Tmp);
end loop;
end if;
return No_Node;
end Get_Inter_Partition_Port_Type_Rec;
begin
if not AIN.Is_Data (Port) then
raise Program_Error with
"Call to Get_Inter_Partition_Port_Type with non DATA port";
end if;
Type_Found := Get_Inter_Partition_Port_Type_Rec (Port, By_Source);
if Type_Found /= No_Node then
return Type_Found;
end if;
Type_Found := Get_Inter_Partition_Port_Type_Rec (Port, By_Destination);
if Type_Found /= No_Node then
return Type_Found;
end if;
return Map_C_Data_Type_Designator (Corresponding_Instance (Port));
end Get_Inter_Partition_Port_Type;
----------------------------
-- Make_Doxygen_C_Comment --
----------------------------
function Make_Doxygen_C_Comment
(Desc : String;
Brief : String := "";
Element_Name : String := "";
Is_Struct : Boolean := False;
Is_Union : Boolean := False;
Is_Enum : Boolean := False;
Is_Function : Boolean := False;
Is_Variable : Boolean := False;
Is_Define : Boolean := False;
Is_Typedef : Boolean := False;
Is_File : Boolean := False;
Is_Namespace : Boolean := False;
Is_Package : Boolean := False;
Is_Interface : Boolean := False;
Has_Header_Spaces : Boolean := True)
return Node_Id
is
C : Node_Id;
begin
C := New_Node (K_Doxygen_C_Comment);
CTN.Set_Summary (C, No_Node);
CTN.Set_Element (C, No_Node);
CTN.Set_Description (C, No_Node);
CTN.Set_For_Struct (C, False);
CTN.Set_For_Union (C, False);
CTN.Set_For_Enum (C, False);
CTN.Set_For_Function (C, False);
CTN.Set_For_Variable (C, False);
CTN.Set_For_Define (C, False);
CTN.Set_For_Typedef (C, False);
CTN.Set_For_File (C, False);
CTN.Set_For_Namespace (C, False);
CTN.Set_For_Package (C, False);
CTN.Set_For_Interface (C, False);
CTN.Set_Has_Header_Spaces (C, Has_Header_Spaces);
if Desc /= "" then
Set_Description
(C, New_Node (K_Defining_Identifier));
CTN.Set_Name
(Description (C), Get_String_Name (Desc));
end if;
if Element_Name /= "" then
Set_Element
(C, New_Node (K_Defining_Identifier));
CTN.Set_Name
(Element (C), Get_String_Name (Element_Name));
end if;
if Brief /= "" then
Set_Summary
(C, New_Node (K_Defining_Identifier));
CTN.Set_Name
(Summary (C), Get_String_Name (Brief));
end if;
CTN.Set_For_Struct (C, Is_Struct);
CTN.Set_For_Union (C, Is_Union);
CTN.Set_For_Enum (C, Is_Enum);
CTN.Set_For_Function (C, Is_Function);
CTN.Set_For_Variable (C, Is_Variable);
CTN.Set_For_Define (C, Is_Define);
CTN.Set_For_Typedef (C, Is_Typedef);
CTN.Set_For_File (C, Is_File);
CTN.Set_For_Namespace (C, Is_Namespace);
CTN.Set_For_Package (C, Is_Package);
CTN.Set_For_Interface (C, Is_Interface);
return C;
end Make_Doxygen_C_Comment;
end Ocarina.Backends.C_Tree.Nutils;