ocarina-me_real-real_tree-utils.adb 14 KB
Newer Older
1
2
3
4
5
6
7
8
------------------------------------------------------------------------------
--                                                                          --
--                           OCARINA COMPONENTS                             --
--                                                                          --
--      O C A R I N A . M E _ R E A L . R E A L _ T R E E . U T I L S       --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
jhugues's avatar
jhugues committed
9
--       Copyright (C) 2009 Telecom ParisTech, 2010-2012 ESA & ISAE.        --
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
--                                                                          --
-- 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.                                       --
--                                                                          --
jhugues's avatar
jhugues committed
29
30
--                 Ocarina is maintained by the TASTE project               --
--                      (taste-users@lists.tuxfamily.org)                   --
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
--                                                                          --
------------------------------------------------------------------------------

with Charset;   use Charset;
with Errors;    use Errors;
with Namet;     use Namet;

package body Ocarina.ME_REAL.REAL_Tree.Utils is

   Up_To_Low : constant := Character'Pos ('A') - Character'Pos ('a');

   --------------
   -- To_Lower --
   --------------

   function To_Lower (Str : Name_Id) return Name_Id
   is
      N : constant String := To_Lower (Get_Name_String (Str));
   begin
      return Get_String_Name (N);
   end To_Lower;

   ----------------
   -- Capitalize --
   ----------------

   procedure Capitalize (S : in out String) is
      Up : Boolean := True;
   begin
      for I in S'Range loop
         if Up then
            Up := False;
            if S (I) in 'a' .. 'z' then
               S (I) := Character'Val (Character'Pos (S (I)) + Up_To_Low);
            end if;
         else
            if S (I) in 'A' .. 'Z' then
               S (I) := Character'Val (Character'Pos (S (I)) - Up_To_Low);
            end if;
         end if;
         if S (I) = '_' then
            Up := True;
         end if;
      end loop;
   end Capitalize;

   ------------
   -- Quoted --
   ------------

   function Quoted (S : String; D : Character := '"') return String is
   begin
      return (1 => D) & S & (1 => D);
   end Quoted;

   ------------
   -- Quoted --
   ------------

   function Quoted (S : String; D : Character := '"') return Name_Id is
   begin
      Set_Char_To_Name_Buffer (D);
      Add_Str_To_Name_Buffer (S);
      Add_Char_To_Name_Buffer (D);
      return Name_Find;
   end Quoted;

   ------------
   -- Quoted --
   ------------

   function Quoted (N : Name_Id; D : Character := '"') return String is
   begin
      return Quoted (Get_Name_String (N), D);
   end Quoted;

   ------------
   -- Quoted --
   ------------

   function Quoted (N : Name_Id; D : Character := '"') return Name_Id is
   begin
      return Quoted (Get_Name_String (N), D);
   end Quoted;

   function Remove_Prefix (N : Name_Id) return Name_Id is
      M : constant Natural := Name_Len;
      S : constant String := Get_Name_String (N);
      P : Boolean := False;
      L : Natural := 0;
   begin
      --  Search the last occurence of "::"

      for I in 1 .. M loop
         if S (I) = ':' then
            if P then
               L := I;
               P := False;
            else
               P := True;
            end if;
         else
            P := False;
         end if;
      end loop;

      Set_Str_To_Name_Buffer (S (L + 1 .. M));

      return To_Lower (Name_Find);
   end Remove_Prefix;

   -------------------------------
   -- Translate_Predefined_Sets --
   -------------------------------

146
   function Translate_Predefined_Sets (T : Token_Type) return Value_Id is
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
   begin
      case T is
         when T_Processor_Set =>
            return SV_Processor_Set;
         when T_Virtual_Processor_Set =>
            return SV_Virtual_Processor_Set;
         when T_Process_Set =>
            return SV_Process_Set;
         when T_Thread_Set =>
            return SV_Thread_Set;
         when T_Threadgroup_Set =>
            return SV_Threadgroup_Set;
         when T_Subprogram_Call_Set =>
            return SV_Subprogram_Call_Set;
         when T_Sequence_Call_Set =>
            return SV_Sequence_Call_Set;
         when T_Subprogram_Set =>
            return SV_Subprogram_Set;
         when T_Data_Set =>
            return SV_Data_Set;
         when T_Memory_Set =>
            return SV_Memory_Set;
         when T_Bus_Set =>
            return SV_Bus_Set;
         when T_Virtual_Bus_Set =>
            return SV_Virtual_Bus_Set;
         when T_Connection_Set =>
            return SV_Connection_Set;
         when T_Device_Set =>
            return SV_Device_Set;
         when T_System_Set =>
            return SV_System_Set;
179
180
         when T_Abstract_Set =>
            return SV_Abstract_Set;
181
182
         when T_Root_System_Set =>
            return SV_Root_System_Set;
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
         when T_End_To_End_Flows_Set =>
            return SV_End_To_End_Flows_Set;
         when T_Local_Set =>
            return SV_Local_Set;
         when T_Unknown_Set =>
            return SV_No_Type;
         when others =>
            DE ("Unknown REAL predefined set");
            return SV_No_Type;
      end case;
   end Translate_Predefined_Sets;

   -------------------------------
   -- Translate_Predefined_Sets --
   -------------------------------

199
   function Translate_Predefined_Sets (T : Value_Id) return Token_Type is
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
   begin
      case T is
         when SV_Processor_Set =>
            return T_Processor_Set;
         when SV_Virtual_Processor_Set =>
            return T_Virtual_Processor_Set;
         when SV_Process_Set =>
            return T_Process_Set;
         when SV_Thread_Set =>
            return T_Thread_Set;
         when SV_Threadgroup_Set =>
            return T_Threadgroup_Set;
         when SV_Subprogram_Call_Set =>
            return T_Subprogram_Call_Set;
         when SV_Sequence_Call_Set =>
            return T_Sequence_Call_Set;
         when SV_Subprogram_Set =>
            return T_Subprogram_Set;
         when SV_Data_Set =>
            return T_Data_Set;
         when SV_Memory_Set =>
            return T_Memory_Set;
         when SV_Bus_Set =>
            return T_Bus_Set;
         when SV_Virtual_Bus_Set =>
            return T_Virtual_Bus_Set;
         when SV_Connection_Set =>
            return T_Connection_Set;
         when SV_Device_Set =>
            return T_Device_Set;
         when SV_System_Set =>
            return T_System_Set;
232
233
         when SV_Abstract_Set =>
            return T_Abstract_Set;
234
235
         when SV_Root_System_Set =>
            return T_Root_System_Set;
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
         when SV_End_To_End_Flows_Set =>
            return T_End_To_End_Flows_Set;
         when SV_Local_Set =>
            return T_Local_Set;
         when SV_No_Type =>
            return T_Unknown_Set;
         when others =>
            DE ("Unknown REAL predefined set");
            return T_Unknown_Set;
      end case;
   end Translate_Predefined_Sets;

   -----------------------------
   -- Translate_Function_Code --
   -----------------------------

252
   function Translate_Function_Code (T : Token_Type) return Value_Id is
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
   begin
      case T is
         when T_Is_Subcomponent_Of =>
            return FC_Is_Subcomponent_Of;
         when T_Is_Bound_To =>
            return FC_Is_Bound_To;
         when T_Is_Provided_Class =>
            return FC_Is_Provided_Class;
         when T_Is_Predecessor_Of =>
            return FC_Is_Predecessor_Of;
         when T_Is_Connected_To =>
            return FC_Is_Connected_To;
         when T_Is_Connecting_To =>
            return FC_Is_Connecting_To;
         when T_Get_System_Property_Value =>
            return FC_Get_System_Property_Value;
         when T_Is_Called_By =>
            return FC_Is_Called_By;
         when T_Is_Calling =>
            return FC_Is_Calling;
         when T_Is_Accessed_By =>
            return FC_Is_Accessed_By;
         when T_Is_Accessing_To =>
            return FC_Is_Accessing_To;
         when T_Get_Property_Value =>
            return FC_Get_Property_Value;
         when T_Property_Exists =>
            return FC_Property_Exists;
         when T_Cardinal =>
            return FC_Cardinal;
         when T_Is_Passing_Through =>
            return FC_Is_Passing_Through;
         when T_Is_In =>
            return FC_Is_In;
         when T_GCD =>
            return FC_GCD;
         when T_LCM =>
            return FC_LCM;
         when T_Non_Null =>
            return FC_Non_Null;
         when T_Size =>
            return FC_Size;
         when T_Max =>
            return FC_Max;
         when T_Min =>
            return FC_Min;
         when T_All_Equals =>
            return FC_All_Equals;
         when T_List =>
            return FC_List;
         when T_Integer =>
            return FC_Int;
305
306
307
308
         when T_Ceil =>
            return FC_Ceil;
         when T_Floor =>
            return FC_Floor;
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
         when T_Float =>
            return FC_Float;
         when T_Sum =>
            return FC_Sum;
         when T_Product =>
            return FC_Product;
         when T_Expr =>
            return FC_Expr;
         when T_First =>
            return FC_First;
         when T_Last =>
            return FC_Last;
         when T_MMax =>
            return FC_MMax;
         when T_MMin =>
            return FC_MMin;
         when T_MAll_Equals =>
            return FC_MAll_Equals;
         when T_MProduct =>
            return FC_MProduct;
         when T_MSum =>
            return FC_MSum;
         when T_Head =>
            return FC_Head;
         when T_Queue =>
            return FC_Queue;
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
         when T_Cos =>
            return FC_Cos;
         when T_Sin =>
            return FC_Sin;
         when T_Tan =>
            return FC_Tan;
         when T_Cosh =>
            return FC_Cosh;
         when T_Sinh =>
            return FC_Sinh;
         when T_Tanh =>
            return FC_Tanh;
         when T_Ln =>
            return FC_Ln;
         when T_Exp =>
            return FC_Exp;
         when T_Sqrt =>
            return FC_Sqrt;
353
354
355
356
357
358
359
360
361
362
363
         when others =>
            DE ("Unknown REAL function");
            return FC_Unknown;
      end case;

   end Translate_Function_Code;

   -----------------------
   -- Get_Returned_Type --
   -----------------------

364
   function Get_Returned_Type (T : Value_Id) return Return_Type is
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
   begin
      case T is
         when FC_Is_Subcomponent_Of =>
            return RT_Boolean;
         when FC_Is_Bound_To =>
            return RT_Boolean;
         when FC_Is_Connected_To =>
            return RT_Boolean;
         when FC_Is_Connecting_To =>
            return RT_Boolean;
         when FC_Get_System_Property_Value =>
            return RT_Unknown;
         when FC_Is_Called_By =>
            return RT_Boolean;
         when FC_Is_Provided_Class =>
            return RT_Boolean;
         when FC_Is_Predecessor_Of =>
            return RT_Boolean;
         when FC_Is_Calling =>
            return RT_Boolean;
         when FC_Is_Accessed_By =>
            return RT_Boolean;
         when FC_Is_Accessing_To =>
            return RT_Boolean;
         when FC_Is_Passing_Through =>
            return RT_Boolean;
         when FC_Get_Property_Value =>
            return RT_Unknown;
         when FC_Property_Exists =>
            return RT_Boolean;
         when FC_Cardinal =>
            return RT_Integer;
         when FC_Size =>
            return RT_Integer;
         when FC_All_Equals =>
            return RT_Boolean;
         when FC_Min =>      --  Result is casted to float
            return RT_Float;
         when FC_Max =>      --  Result is casted to float
            return RT_Float;
         when FC_Product =>  --  Result is casted to float
            return RT_Float;
         when FC_Expr =>     --  Result is casted to float
            return RT_Float_List;
         when FC_Sum =>      --  Result is casted to float
            return RT_Float;
         when FC_Is_In =>
            return RT_Boolean;
         when FC_LCM =>
            return RT_Integer;
         when FC_GCD =>
            return RT_Integer;
         when FC_Non_Null =>
            return RT_Integer;
         when FC_First | FC_Last =>  --  Result is casted to float
            return RT_Float;
         when FC_List =>
            return RT_Unknown;
         when FC_Head =>
            return RT_Unknown;
         when FC_Queue =>
            return RT_Unknown;
427
         when FC_Cos | FC_Sin | FC_Tan | FC_Ceil | FC_Floor =>
428
            return RT_Float;
429
430
431
432
433
434
435
         when others =>
            DE ("Unable to determine REAL function returning type");
            return RT_Error;
      end case;
   end Get_Returned_Type;

end Ocarina.ME_REAL.REAL_Tree.Utils;