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

33
with GNAT.Table;
34

35
with Ocarina.Namet; use Ocarina.Namet;
36

37 1
package body Ocarina.Annotations is
38

39
   Prefix : constant String := "annotation";
40

41
   type Annotation_Record is record
42
      Node : Node_Id;
43
      Name : Name_Id;
44
      Info : Node_Id;
45
      Next : Annotation_Id;
46
   end record;
47

48
   package Annotation_Table is new GNAT.Table
49
     (Annotation_Record,
50
      Annotation_Id,
51
      1,
52
      10,
53
      10);
54
   use Annotation_Table;
55

56
   function Internal_Name (N : Node_Id) return Name_Id;
57
   --  Use name table to get a unique name id for N
58

59
   procedure Append_To (N : Node_Id; A : Annotation_Record);
60
   --  Get to the end of the annotation list and add A. Create this
61
   --  list when none already exists.
62

63
   -------------------
64
   -- Internal_Name --
65
   -------------------
66

67 1
   function Internal_Name (N : Node_Id) return Name_Id is
68
   begin
69 1
      Set_Str_To_Name_Buffer (Prefix);
70 1
      Add_Str_To_Name_Buffer (N'Img);
71 1
      return Name_Find;
72
   end Internal_Name;
73

74
   ---------------
75
   -- Append_To --
76
   ---------------
77

78 1
   procedure Append_To (N : Node_Id; A : Annotation_Record) is
79 1
      Index : Annotation_Id := First_Annotation (N);
80

81
   begin
82 1
      Increment_Last;
83
      Table (Last) := A;
84

85
      --  No list available
86

87 1
      if Index = 0 then
88 1
         Set_Name_Table_Info (Internal_Name (N), Int (Last));
89

90
      else
91
         --  Reach end of list then append
92

93
         while Table (Index).Next /= 0 loop
94
            Index := Table (Index).Next;
95 1
         end loop;
96
         Table (Index).Next := Last;
97
      end if;
98 1
   end Append_To;
99

100
   ----------------------
101
   -- First_Annotation --
102
   ----------------------
103

104 1
   function First_Annotation (N : Node_Id) return Annotation_Id is
105
   begin
106
      return Annotation_Id (Get_Name_Table_Info (Internal_Name (N)));
107
   end First_Annotation;
108

109
   ----------------------
110
   -- Annotation_Index --
111
   ----------------------
112

113 1
   function Annotation_Index (N : Node_Id; A : Node_Id) return Annotation_Id is
114 1
      Index : Annotation_Id := First_Annotation (N);
115

116
   begin
117 1
      while Index /= 0 loop
118
         exit when Table (Index).Node = A;
119
         Index := Table (Index).Next;
120 1
      end loop;
121

122 1
      return Index;
123
   end Annotation_Index;
124

125
   ----------------------
126
   -- Annotation_Index --
127
   ----------------------
128

129 0
   function Annotation_Index (N : Node_Id; A : Name_Id) return Annotation_Id is
130 0
      Index : Annotation_Id := First_Annotation (N);
131

132
   begin
133 0
      while Index /= 0 loop
134 0
         exit when Table (Index).Name = A;
135 0
         Index := Table (Index).Next;
136 0
      end loop;
137

138 0
      return Index;
139
   end Annotation_Index;
140

141
   --------------
142
   -- Annotate --
143
   --------------
144

145 1
   procedure Annotate (N : Node_Id; A : Node_Id; I : Node_Id := No_Node) is
146 1
      Index : constant Annotation_Id := Annotation_Index (N, A);
147

148
   begin
149 1
      if Index /= 0 then
150
         Table (Index).Info := I;
151

152
      else
153 1
         Append_To (N, (Node => A, Name => No_Name, Info => I, Next => 0));
154
      end if;
155 1
   end Annotate;
156

157
   --------------
158
   -- Annotate --
159
   --------------
160

161 0
   procedure Annotate (N : Node_Id; A : Name_Id; I : Node_Id := No_Node) is
162 0
      Index : constant Annotation_Id := Annotation_Index (N, A);
163

164
   begin
165 0
      if Index /= 0 then
166 0
         Table (Index).Info := I;
167

168
      else
169 0
         Append_To (N, (Node => No_Node, Name => A, Info => I, Next => 0));
170
      end if;
171 0
   end Annotate;
172

173
   ---------------------
174
   -- Annotation_Info --
175
   ---------------------
176

177 0
   function Annotation_Info (N : Node_Id; A : Node_Id) return Node_Id is
178 0
      Index : constant Annotation_Id := Annotation_Index (N, A);
179

180
   begin
181 0
      if Index = 0 then
182 0
         raise Program_Error with "Annotation item not found";
183
      end if;
184

185 0
      return Table (Index).Info;
186
   end Annotation_Info;
187

188
   ---------------------
189
   -- Annotation_Info --
190
   ---------------------
191

192 0
   function Annotation_Info (N : Node_Id; A : Name_Id) return Node_Id is
193 0
      Index : constant Annotation_Id := Annotation_Index (N, A);
194

195
   begin
196 0
      if Index = 0 then
197 0
         raise Program_Error with "Annotation item not found";
198
      end if;
199

200 0
      return Table (Index).Info;
201
   end Annotation_Info;
202

203
   ---------------------
204
   -- Annotation_Node --
205
   ---------------------
206

207 1
   function Annotation_Node (I : Annotation_Id) return Node_Id is
208
   begin
209
      return Table (I).Node;
210
   end Annotation_Node;
211

212
   ---------------------
213
   -- Annotation_Name --
214
   ---------------------
215

216 0
   function Annotation_Name (I : Annotation_Id) return Name_Id is
217
   begin
218 0
      return Table (I).Name;
219
   end Annotation_Name;
220

221
   ---------------------
222
   -- Next_Annotation --
223
   ---------------------
224

225 1
   function Next_Annotation (I : Annotation_Id) return Annotation_Id is
226
   begin
227
      return Table (I).Next;
228
   end Next_Annotation;
229

230 1
end Ocarina.Annotations;

Read our documentation on viewing source code .

Loading