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

33
with Ocarina.Namet; use Ocarina.Namet;
34

35
with Ocarina.AADL_Values;
36

37
with GNAT.Table;
38

39 1
package body Ocarina.Backends.C_Values is
40

41
   package OV renames Ocarina.AADL_Values;
42

43
   package VT is new GNAT.Table (Value_Type, Value_Id, No_Value + 1, 10, 10);
44

45
   ---------
46
   -- "*" --
47
   ---------
48

49 0
   function "*" (L, R : Value_Type) return Value_Type is
50 0
      V : Value_Type := L;
51
   begin
52 0
      case V.K is
53 0
         when K_Int =>
54 0
            if L.Base = R.Base then
55 0
               V.Base := 10;
56
            end if;
57 0
            V.Sign := L.Sign * R.Sign;
58 0
            V.IVal := L.IVal * R.IVal;
59

60 0
         when K_Float =>
61 0
            V.FVal := L.FVal * R.FVal;
62

63 0
         when others =>
64 0
            return Bad_Value;
65 0
      end case;
66 0
      return V;
67 0
   end "*";
68

69
   ---------
70
   -- "+" --
71
   ---------
72

73 0
   function "+" (L, R : Value_Type) return Value_Type is
74 0
      V : Value_Type := R;
75
   begin
76 0
      case R.K is
77 0
         when K_Int =>
78 0
            if L.Base /= R.Base then
79 0
               V.Base := 10;
80
            end if;
81 0
            if L.Sign = R.Sign then
82 0
               V.IVal := L.IVal + R.IVal;
83 0
            elsif R.IVal <= L.IVal then
84 0
               V.Sign := L.Sign;
85 0
               V.IVal := L.IVal - R.IVal;
86
            else
87 0
               V.Sign := -L.Sign;
88 0
               V.IVal := R.IVal - L.IVal;
89
            end if;
90

91 0
         when K_Float =>
92 0
            V.FVal := L.FVal + R.FVal;
93

94 0
         when others =>
95 0
            return Bad_Value;
96

97 0
      end case;
98 0
      return V;
99 0
   end "+";
100

101
   ---------
102
   -- "-" --
103
   ---------
104

105 0
   function "-" (R : Value_Type) return Value_Type is
106 0
      V : Value_Type := R;
107
   begin
108 0
      case R.K is
109 0
         when K_Int =>
110 0
            V.Sign := -V.Sign;
111

112 0
         when K_Float =>
113 0
            V.FVal := -V.FVal;
114

115 0
         when others =>
116 0
            return Bad_Value;
117

118 0
      end case;
119 0
      return V;
120 0
   end "-";
121

122
   ---------
123
   -- "-" --
124
   ---------
125

126 0
   function "-" (L, R : Value_Type) return Value_Type is
127 0
      V : Value_Type := R;
128
   begin
129 0
      case R.K is
130 0
         when K_Int =>
131 0
            V.Sign := -V.Sign;
132

133 0
         when K_Float =>
134 0
            V.FVal := -V.FVal;
135

136 0
         when others =>
137 0
            return Bad_Value;
138

139 0
      end case;
140 0
      return L + V;
141 0
   end "-";
142

143
   ---------
144
   -- "/" --
145
   ---------
146

147 0
   function "/" (L, R : Value_Type) return Value_Type is
148 0
      V : Value_Type := L;
149
   begin
150 0
      case V.K is
151 0
         when K_Int =>
152 0
            if L.Base = R.Base then
153 0
               V.Base := 10;
154
            end if;
155 0
            V.Sign := L.Sign * R.Sign;
156 0
            V.IVal := L.IVal / R.IVal;
157

158 0
         when K_Float =>
159 0
            V.FVal := L.FVal / R.FVal;
160

161 0
         when others =>
162 0
            return Bad_Value;
163 0
      end case;
164 0
      return V;
165 0
   end "/";
166

167
   ---------
168
   -- "<" --
169
   ---------
170

171 0
   function "<" (L, R : Value_Type) return Boolean is
172
   begin
173 0
      case R.K is
174 0
         when K_Int =>
175 0
            if L.Sign > 0 then
176 0
               if R.Sign > 0 then
177 0
                  return L.IVal < R.IVal;
178
               else
179 0
                  return False;
180
               end if;
181 0
            elsif R.Sign > 0 then
182 0
               return True;
183
            else
184 0
               return L.IVal > R.IVal;
185
            end if;
186

187 0
         when K_Float =>
188 0
            return L.FVal < R.FVal;
189

190 0
         when others =>
191 0
            return False;
192

193
      end case;
194
   end "<";
195

196
   -----------
197
   -- "and" --
198
   -----------
199

200 0
   function "and" (L, R : Value_Type) return Value_Type is
201 0
      LV : Value_Type := L;
202 0
      RV : Value_Type := R;
203
   begin
204 0
      case L.K is
205
         when K_Int =>
206 0
            if LV.Base /= RV.Base then
207 0
               LV.Base := 10;
208
            end if;
209 0
            if LV.Sign < 0 then
210 0
               LV.IVal := LULL - LV.IVal;
211
            end if;
212 0
            if RV.Sign < 0 then
213 0
               RV.IVal := LULL - RV.IVal;
214
            end if;
215 0
            LV.IVal := LV.IVal and RV.IVal;
216 0
            LV.Sign := 1;
217

218
         when others =>
219 0
            return Bad_Value;
220
      end case;
221 0
      return LV;
222 0
   end "and";
223

224
   -----------
225
   -- "mod" --
226
   -----------
227

228 0
   function "mod" (L, R : Value_Type) return Value_Type is
229 0
      V : Value_Type := L;
230
   begin
231 0
      case L.K is
232
         when K_Int =>
233 0
            if L.Base /= R.Base then
234 0
               V.Base := 10;
235
            end if;
236 0
            V.Sign := L.Sign * R.Sign;
237 0
            V.IVal := L.IVal mod R.IVal;
238

239
         when others =>
240 0
            return Bad_Value;
241
      end case;
242 0
      return V;
243 0
   end "mod";
244

245
   -----------
246
   -- "not" --
247
   -----------
248

249 0
   function "not" (R : Value_Type) return Value_Type is
250 0
      V : Value_Type := R;
251
   begin
252 0
      case V.K is
253
         when K_Int =>
254 0
            V.IVal := Unsigned_Long_Long (not Unsigned_Long (V.IVal));
255

256
         when others =>
257 0
            return Bad_Value;
258
      end case;
259 0
      return V;
260 0
   end "not";
261

262
   ----------
263
   -- "or" --
264
   ----------
265

266 0
   function "or" (L, R : Value_Type) return Value_Type is
267 0
      LV : Value_Type := L;
268 0
      RV : Value_Type := R;
269
   begin
270 0
      case L.K is
271
         when K_Int =>
272 0
            if LV.Base /= RV.Base then
273 0
               LV.Base := 10;
274
            end if;
275 0
            if LV.Sign < 0 then
276 0
               LV.IVal := LULL - LV.IVal;
277
            end if;
278 0
            if RV.Sign < 0 then
279 0
               RV.IVal := LULL - RV.IVal;
280
            end if;
281 0
            LV.IVal := LV.IVal or RV.IVal;
282 0
            LV.Sign := 1;
283

284
         when others =>
285 0
            return Bad_Value;
286
      end case;
287 0
      return LV;
288 0
   end "or";
289

290
   -----------
291
   -- "xor" --
292
   -----------
293

294 0
   function "xor" (L, R : Value_Type) return Value_Type is
295 0
      LV : Value_Type := L;
296 0
      RV : Value_Type := R;
297
   begin
298 0
      case LV.K is
299
         when K_Int =>
300 0
            if LV.Base /= RV.Base then
301 0
               LV.Base := 10;
302
            end if;
303 0
            if LV.Sign < 0 then
304 0
               LV.IVal := LULL - LV.IVal;
305
            end if;
306 0
            if RV.Sign < 0 then
307 0
               RV.IVal := LULL - RV.IVal;
308
            end if;
309 0
            LV.IVal := LV.IVal xor RV.IVal;
310 0
            LV.Sign := 1;
311

312
         when others =>
313 0
            return Bad_Value;
314
      end case;
315 0
      return LV;
316 0
   end "xor";
317

318
   -----------
319
   -- Image --
320
   -----------
321

322 1
   function Image (Value : Value_Id) return String is
323 1
      V : Value_Type;
324
   begin
325 1
      if Value = No_Value then
326 0
         return "<>";
327
      end if;
328 1
      V        := VT.Table (Value);
329 1
      Name_Len := 0;
330 1
      case V.K is
331

332 1
         when K_Int =>
333 1
            if V.Sign < 0 then
334 1
               Add_Char_To_Name_Buffer ('-');
335 1
            elsif V.Base = 16 then
336 0
               Add_Str_To_Name_Buffer ("0x");
337 1
            elsif V.Base = 8 then
338 0
               Add_Str_To_Name_Buffer ("0");
339
            end if;
340

341 1
            Add_ULL_To_Name_Buffer (V.IVal, ULL (V.Base));
342

343 0
         when K_Float =>
344 0
            Add_Str_To_Name_Buffer (Long_Double'Image (V.FVal));
345
            declare
346 0
               Index : Natural := Name_Len;
347

348
            begin
349

350
               --  Find exponent if any
351

352 0
               while Index > 0 and then Name_Buffer (Index) /= 'E' loop
353 0
                  Index := Index - 1;
354 0
               end loop;
355

356
               --  Remove leading zero in exponent part.
357

358 0
               if Index > 0 then
359 0
                  Index := Index + 2;
360 0
                  while Index <= Name_Len and then Name_Buffer (Index) = '0'
361
                  loop
362 0
                     Name_Buffer (Index .. Name_Len - 1) :=
363 0
                       Name_Buffer (Index + 1 .. Name_Len);
364 0
                     Name_Len := Name_Len - 1;
365 0
                  end loop;
366

367
                  --  Remove exponent
368

369 0
                  if Index > Name_Len then
370 0
                     Name_Len := Name_Len - 2;
371 0
                     Index    := Name_Len;
372

373
                  else
374 0
                     Index := Name_Len;
375 0
                     while Name_Buffer (Index) /= 'E' loop
376 0
                        Index := Index - 1;
377 0
                     end loop;
378 0
                     Index := Index - 1;
379
                  end if;
380

381
               end if;
382

383
               --  Remove trailing zero in fraction part.
384

385 0
               while Name_Buffer (Index) = '0' loop
386 0
                  exit when Name_Buffer (Index - 1) = '.';
387 0
                  Name_Buffer (Index .. Name_Len - 1) :=
388 0
                    Name_Buffer (Index + 1 .. Name_Len);
389 0
                  Name_Len := Name_Len - 1;
390 0
                  Index    := Index - 1;
391 0
               end loop;
392
            end;
393

394 0
         when K_Char =>
395 0
            if V.CVal <= 127 then
396
               declare
397 0
                  C : constant Character := Character'Val (Natural (V.CVal));
398
               begin
399 0
                  if C in '!' .. '~' then
400 0
                     Add_Char_To_Name_Buffer (''');
401 0
                     Add_Char_To_Name_Buffer (C);
402 0
                     Add_Char_To_Name_Buffer (''');
403
                  else
404 0
                     Add_Str_To_Name_Buffer ("Character'Val (");
405 0
                     Add_ULL_To_Name_Buffer (ULL (V.CVal), 10);
406 0
                     Add_Char_To_Name_Buffer (')');
407
                  end if;
408
               end;
409
            else
410 0
               Add_Str_To_Name_Buffer ("Wide_Character'Val (");
411 0
               Add_ULL_To_Name_Buffer (ULL (V.CVal), 10);
412 0
               Add_Char_To_Name_Buffer (')');
413
            end if;
414

415 1
         when K_Pointed_Char =>
416 1
            if V.PCVal = No_Name then
417 0
               return '"' & '"';
418
            end if;
419 1
            Add_Char_To_Name_Buffer ('"'); -- "
420 1
            Get_Name_String_And_Append (V.PCVal);
421 1
            Add_Char_To_Name_Buffer ('"'); -- "
422

423 0
         when others =>
424 0
            raise Program_Error;
425 1
      end case;
426

427 1
      return Name_Buffer (1 .. Name_Len);
428 1
   end Image;
429

430
   ----------------
431
   -- To_C_Value --
432
   ----------------
433

434 1
   function To_C_Value (V : Value_Id) return Value_Id is
435 1
      VT     : constant OV.Value_Type := OV.Value (V);
436 1
      Result : Value_Id;
437
   begin
438 1
      case VT.T is
439 1
         when OV.LT_Integer =>
440 1
            if VT.ISign then
441 0
               Result := New_Int_Value (VT.IVal, -1, VT.IBase);
442
            else
443 1
               Result := New_Int_Value (VT.IVal, 1, VT.IBase);
444
            end if;
445 0
         when OV.LT_Real =>
446 0
            Result := New_Floating_Point_Value (Long_Double (VT.RVal));
447 0
         when OV.LT_String =>
448 0
            Result := New_Pointed_Char_Value (VT.SVal);
449 0
         when OV.LT_Boolean =>
450 0
            raise Constraint_Error;
451 0
         when others =>
452 0
            raise Constraint_Error;
453 1
      end case;
454

455 1
      return Result;
456 1
   end To_C_Value;
457

458
   ------------------------------
459
   -- New_Floating_Point_Value --
460
   ------------------------------
461

462 0
   function New_Floating_Point_Value (Value : Long_Double) return Value_Id is
463
   begin
464 0
      return New_Value (Value_Type'(K_Float, Value));
465 0
   end New_Floating_Point_Value;
466

467
   -------------------
468
   -- New_Int_Value --
469
   -------------------
470

471 1
   function New_Int_Value
472
     (Value : Unsigned_Long_Long;
473
      Sign  : Short_Short;
474
      Base  : Unsigned_Short_Short) return Value_Id
475
   is
476
   begin
477 1
      return New_Value (Value_Type'(K_Int, Value, Sign, Base));
478 1
   end New_Int_Value;
479

480
   -------------------------
481
   -- New_Character_Value --
482
   -------------------------
483

484 0
   function New_Char_Value (Value : Unsigned_Short) return Value_Id is
485
   begin
486 0
      return New_Value (Value_Type'(K_Char, Value));
487 0
   end New_Char_Value;
488

489
   ---------------
490
   -- New_Value --
491
   ---------------
492

493 1
   function New_Value (Value : Value_Type) return Value_Id is
494 1
      V : Value_Id;
495
   begin
496 1
      VT.Increment_Last;
497 1
      V            := VT.Last;
498 1
      VT.Table (V) := Value;
499 1
      return V;
500
   end New_Value;
501

502
   ---------------
503
   -- Set_Value --
504
   ---------------
505

506 0
   procedure Set_Value (V : Value_Id; X : Value_Type) is
507
   begin
508 0
      VT.Table (V) := X;
509 0
   end Set_Value;
510

511
   ----------------
512
   -- Shift_Left --
513
   ----------------
514

515 0
   function Shift_Left (L, R : Value_Type) return Value_Type is
516 0
      LV : Value_Type := L;
517 0
      RV : Value_Type := R;
518
   begin
519 0
      case RV.K is
520
         when K_Int =>
521 0
            if RV.Sign < 0 then
522 0
               RV.Sign := 1;
523 0
               return Shift_Right (LV, RV);
524
            end if;
525

526
            --  Keep working with left operand base
527

528 0
            LV.IVal := Shift_Left (LV.IVal, Natural (RV.IVal));
529 0
            return LV;
530

531
         when others =>
532 0
            return Bad_Value;
533
      end case;
534 0
   end Shift_Left;
535

536
   -----------------
537
   -- Shift_Right --
538
   -----------------
539

540 0
   function Shift_Right (L, R : Value_Type) return Value_Type is
541 0
      LV : Value_Type := L;
542 0
      RV : Value_Type := R;
543
   begin
544 0
      case RV.K is
545
         when K_Int =>
546 0
            if RV.Sign < 0 then
547 0
               RV.Sign := 1;
548 0
               return Shift_Left (LV, RV);
549
            end if;
550

551
            --  Keep working with left operand base
552

553 0
            LV.IVal := Shift_Right (LV.IVal, Natural (RV.IVal));
554 0
            return LV;
555

556
         when others =>
557 0
            return Bad_Value;
558
      end case;
559 0
   end Shift_Right;
560

561
   ----------------------------
562
   -- New_Pointed_Char_Value --
563
   ----------------------------
564

565 1
   function New_Pointed_Char_Value (Value : Name_Id) return Value_Id is
566
   begin
567 1
      return New_Value (Value_Type'(K_Pointed_Char, Value));
568 1
   end New_Pointed_Char_Value;
569

570
   -----------
571
   -- Value --
572
   -----------
573

574 0
   function Value (V : Value_Id) return Value_Type is
575
   begin
576 0
      return VT.Table (V);
577
   end Value;
578

579
   -----------
580
   -- Reset --
581
   -----------
582

583 1
   procedure Reset is
584
   begin
585 1
      VT.Init;
586 1
   end Reset;
587

588 1
end Ocarina.Backends.C_Values;

Read our documentation on viewing source code .

Loading