-------------------------------------------
-------------------------------------
-- --
-- OCARINA COMPONENTS --
-- --
-- O C A R I N A . G E N E R A T O R S . C _ T R E E . N U T I L S --
-- --
-- B o d y --
-- --
-- Copyright (C) 2007, GET-Telecom Paris. --
-- --
-- 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 Ocarina team --
-- (ocarina-users@listes.enst.fr) --
-- --
------------------------------------------------------------------------------
with GNAT.Table;
with GNAT.Case_Util;
with Charset; use Charset;
with Locations; use Locations;
with Namet; use Namet;
with Utils; use Utils;
with Ocarina.Generators.PO_HI_C.Mapping;
with Ocarina.Generators.PO_HI_C.Runtime;
with Ocarina.Generators.Utils;
with Ocarina.Generators.Messages;
with Ocarina.Generators.C_Tree.Nutils;
with Ocarina.Generators.C_Values;
with Ocarina.Generators.Properties;
with Ocarina.Nodes;
with Ocarina.Nutils;
use Ocarina.Nodes;
use Ocarina.Generators.Utils;
use Ocarina.Generators.Messages;
use Ocarina.Generators.Properties;
use Ocarina.Generators.PO_HI_C.Mapping;
use Ocarina.Generators.PO_HI_C.Runtime;
package body Ocarina.Generators.C_Tree.Nutils is
package AAU renames Ocarina.Nutils;
package AAN renames Ocarina.Nodes;
package CV renames Ocarina.Generators.C_Values;
package CTU renames Ocarina.Generators.C_Tree.Nutils;
package CTN renames Ocarina.Generators.C_Tree.Nodes;
Keyword_Suffix : constant String := "%C";
-- Used to mark ada 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 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;
--------------------------
-- Fully_Qualified_Name --
--------------------------
function Fully_Qualified_Name (N : Node_Id) return Name_Id is
Parent_Node : constant Node_Id := No_Node;
Parent_Name : Name_Id := No_Name;
begin
case CTN.Kind (N) is
when K_Defining_Identifier =>
if Present (Parent_Node) then
Parent_Name := Fully_Qualified_Name (Parent_Node);
end if;
Name_Len := 0;
if Present (Parent_Node) then
Get_Name_String (Parent_Name);
Add_Char_To_Name_Buffer ('.');
end if;
Get_Name_String_And_Append (CTN.Name (N));
return Name_Find;
when others =>
raise Program_Error;
end case;
end Fully_Qualified_Name;
-----------
-- 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_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_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_Minus, "-");
New_Operator (Op_Plus, "+");
New_Operator (Op_Asterisk, "*");
New_Operator (Op_Slash, "/");
New_Operator (Op_Less, "<");
New_Operator (Op_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;
for G in Pragma_Id loop
Set_Str_To_Name_Buffer (Pragma_Id'Image (G));
Set_Str_To_Name_Buffer (Name_Buffer (8 .. Name_Len));
GNAT.Case_Util.To_Mixed (Name_Buffer (1 .. Name_Len));
GN (G) := Name_Find;
end loop;
for E in Error_Id loop
Set_Str_To_Name_Buffer (Error_Id'Image (E));
Set_Str_To_Name_Buffer (Name_Buffer (3 .. Name_Len));
GNAT.Case_Util.To_Mixed (Name_Buffer (1 .. Name_Len));
EN (E) := Name_Find;
end loop;
end Initialize;
--------------
-- 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)
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));
else
CTN.Set_Name (N, Name);
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_Defining_Identifier (N, Defining_Identifier);
Set_Corresponding_Node (Defining_Identifier, N);
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_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 package 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, AAN.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, 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) return Name_Id is
First : Natural := 1;
Name : Name_Id;
Test_Name : Name_Id;
V : Types.Byte;
begin
Get_Name_String (Normalize_Name (N));
while First <= Name_Len and then Name_Buffer (First) = '_' loop
First := First + 1;
end loop;
for I in First .. Name_Len loop
if Name_Buffer (I) = '_'
and then I < Name_Len
and then Name_Buffer (I + 1) = '_'
then
Name_Buffer (I + 1) := 'U';
end if;
end loop;
if Name_Buffer (Name_Len) = '_' then
Add_Char_To_Name_Buffer ('U');
end if;
Name := Name_Find;
-- If the identifier collides with an Ada 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;
return To_Lower (Name);
end To_C_Name;
---------------
-- Unit_Name --
---------------
function Unit_Name (N : Name_Id) return Name_Id is
Pos : Natural := 0;
begin
Get_Name_String (N);
for J in reverse 1 .. Name_Len loop
if Name_Buffer (J) = '.' then
Pos := J;
exit;
end if;
end loop;
if Pos = 0 or else Pos = 1 then
Display_Error
("""" &
Get_Name_String (N) &
""" is not an Ada fully qualified entity name",
Fatal => True);
end if;
Set_Str_To_Name_Buffer (Name_Buffer (1 .. Pos - 1));
return Name_Find;
end Unit_Name;
----------------
-- Local_Name --
----------------
function Local_Name (N : Name_Id) return Name_Id is
Pos : Natural := 0;
begin
Get_Name_String (N);
for J in reverse 1 .. Name_Len loop
if Name_Buffer (J) = '.' then
Pos := J;
exit;
end if;
end loop;
if Pos = Name_Len or else Pos = Name_Len - 1 then
Display_Error
("""" &
Get_Name_String (N) &
""" is not an Ada fully qualified entity name",
Fatal => True);
end if;
Set_Str_To_Name_Buffer (Name_Buffer (Pos + 1 .. Name_Len));
return Name_Find;
end Local_Name;
----------------------------
-- Conventional_Base_Name --
----------------------------
function Conventional_Base_Name (N : Name_Id) return Name_Id is
begin
Get_Name_String (N);
-- Lower and replace all '.' by '-'
for Index in 1 .. Name_Len loop
if Name_Buffer (Index) = '.' then
Name_Buffer (Index) := '_';
else
Name_Buffer (Index) := To_Lower (Name_Buffer (Index));
end if;
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));
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));
return File;
end Make_Header_File;
-----------------
-- Add_Include --
-----------------
procedure Add_Include (E : Node_Id) 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 (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 (E));
Get_Name_String_And_Append
(CTN.Name
(CTN.Entity (Distributed_Application_Unit (Current_File))));
N := To_Lower (Name_Find);
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 (E));
M := Name_Find;
W := Make_Defining_Identifier (M);
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_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)
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;
Owner : Node_Id;
Declaration : Node_Id;
Hybrid : constant Boolean :=
Is_Subprogram (Caller)
and then Properties.Get_Subprogram_Kind (Caller) =
Properties.Subprogram_Hybrid_Ada_95;
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 AAU.Is_Empty (AAN.Subprogram_Calls (Call_Seq)) then
Display_Located_Error
(AAN.Loc (Call_Seq),
"Empty call sequence",
Fatal => False,
Warning => True);
return;
end if;
Spg_Call := AAN.First_Node (AAN.Subprogram_Calls (Call_Seq));
while Present (Spg_Call) loop
Spg := AAN.Corresponding_Instance (Spg_Call);
Call_Profile := New_List (CTN.K_List_Id);
if not AAU.Is_Empty (AAN.Features (Spg)) then
F := AAN.First_Node (AAN.Features (Spg));
while Present (F) loop
if AAN.Kind (F) = AAN.K_Parameter_Instance
and then AAN.Is_Out (F)
then
-- Raise an error if the parameter is not connected
-- to any source.
if AAU.Length (AAN.Destinations (F)) = 0 then
Display_Located_Error
(AAN.Loc (F),
"This OUT parameter is not connected to" &
" any destination",
Fatal => True);
elsif AAU.Length (AAN.Destinations (F)) > 1 then
Display_Located_Error
(AAN.Loc (F),
"This IN 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 :=
AAN.Item (AAN.First_Node (AAN.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 Utils.Is_Thread (Caller)
or else AAN.Parent_Component (Destination_F) /= Caller
then
-- 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.
Declaration :=
Make_Variable_Declaration
(Defining_Identifier =>
Make_Defining_Identifier
(Map_C_Variable_Name
(F,
Request_Variable => True)),
Used_Type =>
Map_C_Data_Type_Designator
(Corresponding_Instance (F)));
Append_Node_To_List (Declaration, Declarations);
Param_Value :=
Make_Variable_Address
(Make_Defining_Identifier
(Map_C_Variable_Name
(F,
Request_Variable => True)));
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
(AAN.Display_Name (AAN.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 paremeter of the calleR.
Param_Value :=
Make_Defining_Identifier
(To_C_Name
(AAN.Display_Name
(AAN.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 AAN.Kind (F) = AAN.K_Parameter_Instance
and then AAN.Is_In (F)
then
-- Raise an error if the parameter is not connected
-- to any source.
if AAU.Length (AAN.Sources (F)) = 0 then
Display_Located_Error
(AAN.Loc (F),
"This IN parameter is not connected to" &
" any source",
Fatal => True);
elsif AAU.Length (AAN.Sources (F)) > 1 then
Display_Located_Error
(AAN.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 := AAN.Item (AAN.First_Node (AAN.Sources (F)));
-- Get the source feature parent
Source_Parent := AAN.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 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.
-- Param_Value :=
--Make_Member_Designator
-- (Make_Defining_Identifier
-- (Map_C_Full_Parameter_Name
-- (Spg, F, 'C')),
-- Make_Member_Designator
-- (Make_Defining_Identifier
-- (Map_C_Enumerator_Name
--(Spg)),
-- Make_Member_Designator
-- (Make_Defining_Identifier
-- (MN (M_Vars)),
-- Make_Defining_Identifier
-- (Req_Name))));
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)));
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_Full_Parameter_Name
(AAN.Parent_Subcomponent (Source_Parent),
Source_F));
elsif Hybrid then
-- (3) If the calleD parameter is connected to
-- the calleR parameter and then then calleR
-- IS hybrid, the we use the 'Status' record
-- field corresponding to the calleR
-- parameter.
Param_Value :=
Make_Member_Designator
(Make_Defining_Identifier
(To_C_Name
(AAN.Display_Name
(AAN.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
(AAN.Display_Name (AAN.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 := AAN.Next_Node (F);
end loop;
end if;
if not AAU.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);
N := Map_C_Defining_Identifier (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.
Add_Include (RH (RH_Subprograms));
N := Message_Comment ("Call implementation");
CTU.Append_Node_To_List (N, Statements);
N := New_Node (K_Defining_Identifier);
CTN.Set_Name (N, AAN.Name (AAN.Identifier (Spg)));
N := Map_C_Defining_Identifier (Spg);
N := Make_Call_Profile (N, Call_Profile);
CTU.Append_Node_To_List (N, Statements);
end if;
Spg_Call := AAN.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_Type : Supported_Data_Type;
Result : Node_Id;
begin
pragma Assert (Utils.Is_Data (D));
Data_Type := Get_Data_Type (D);
case Data_Type 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
(AAN.Loc (D),
"Bounded strings default values not supported yet!",
Fatal => True);
when Data_Wide_String =>
Display_Located_Error
(AAN.Loc (D),
"Bounded wide strings default values not supported yet!",
Fatal => True);
when Data_Array =>
Display_Located_Error
(AAN.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;
end Ocarina.Generators.C_Tree.Nutils;