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

32
with Ocarina.Namet;
33
with GNAT.Table;
34

35
with Ada.Characters.Handling;
36
with Ada.Long_Long_Float_Text_IO;
37

38
with Charset;
39
with Locations;
40

41
with Ocarina.AADL_Values;
42
with Ocarina.ME_AO4AADL.AO4AADL_Tree.Nutils;
43

44 1
package body Ocarina.AO4AADL_Values is
45

46
   AADL_True  : constant String := "true";
47
   AADL_False : constant String := "false";
48

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

51
   ----------------
52
   -- AADL_Value --
53
   ----------------
54

55 0
   function AADL_Value (V : Value_Id) return Value_Id
56
   is
57
      package OV renames Ocarina.AADL_Values;
58

59 0
      VT : constant OV.Value_Type := OV.Get_Value_Type (V);
60 0
      R  : Value_Id;
61
   begin
62 0
      case VT.T is
63 0
         when OV.LT_Integer =>
64 0
            R := New_Integer_Value (VT.IVal, VT.ISign, VT.IBase, VT.IExp);
65

66 0
         when OV.LT_Real =>
67 0
            R := New_Real_Value (VT.RVal, VT.RSign, VT.RBase, VT.RExp);
68

69 0
         when OV.LT_String =>
70 0
            R := New_String_Value (VT.SVal);
71

72 0
         when OV.LT_Boolean =>
73 0
            R := New_Boolean_Value (VT.BVal);
74

75 0
         when OV.LT_Enumeration =>
76 0
            R := New_Enum_Value (VT.EVal);
77 0
      end case;
78

79 0
      return R;
80 0
   end AADL_Value;
81

82
   -----------
83
   -- Reset --
84
   -----------
85

86 0
   procedure Reset is
87
   begin
88 0
      VT.Init;
89 0
   end Reset;
90

91
   --------------------
92
   -- Get_Value_Type --
93
   --------------------
94

95 0
   function Get_Value_Type (Value : Value_Id) return Value_Type is
96
   begin
97 0
      return VT.Table (Value);
98
   end Get_Value_Type;
99

100
   -----------
101
   -- Image --
102
   -----------
103

104 0
   function Image (Value : Value_Type; Quoted : Boolean := True) return String
105
   is
106
      use Namet;
107

108
   begin
109 0
      Name_Len := 0;
110

111 0
      case Value.T is
112 0
         when LT_Boolean =>
113 0
            if Value.BVal then
114 0
               return AADL_True;
115
            else
116 0
               return AADL_False;
117
            end if;
118

119 0
         when LT_String =>
120 0
            if Value.SVal = No_Name then
121 0
               return """""";    --  null string ' "" '
122
            else
123 0
               if Quoted then
124 0
                  Set_Char_To_Name_Buffer ('"');
125 0
                  Get_Name_String_And_Append (Value.SVal);
126 0
                  Add_Char_To_Name_Buffer ('"');
127
               else
128 0
                  Get_Name_String (Value.SVal);
129
               end if;
130
            end if;
131

132 0
         when LT_Enumeration =>
133 0
            if Value.EVal = No_Name then
134 0
               return "";    --  null string ' "" '
135
            else
136 0
               Get_Name_String (Value.EVal);
137
            end if;
138

139 0
         when LT_Real =>
140 0
            if Value.RSign then
141 0
               Set_Char_To_Name_Buffer ('-');
142
            end if;
143

144 0
            Add_Str_To_Name_Buffer
145 0
              (Image (Value.RVal, Value.RBase, Value.RExp));
146

147 0
         when LT_Integer =>
148 0
            if Value.ISign then
149 0
               Set_Char_To_Name_Buffer ('-');
150
            end if;
151 0
            Add_Str_To_Name_Buffer
152 0
              (Image (Value.IVal, Value.IBase, Value.IExp));
153

154 0
         when LT_List =>
155
            --  XXX FIXME :
156 0
            raise Program_Error with "not implemented yet";
157

158 0
         when LT_Range =>
159 0
            if Value.RSign_Left then
160 0
               Set_Char_To_Name_Buffer ('-');
161
            end if;
162 0
            Add_Str_To_Name_Buffer
163 0
              (Image (Value.RVal_Left, Value.RVBase, Value.RVExp));
164

165 0
            Add_Str_To_Name_Buffer (" - ");
166

167 0
            if Value.RSign_Right then
168 0
               Set_Char_To_Name_Buffer ('-');
169
            end if;
170 0
            Add_Str_To_Name_Buffer
171 0
              (Image (Value.RVal_Right, Value.RVBase, Value.RVExp));
172

173 0
         when LT_Element =>
174
            --  FIXME
175 0
            raise Program_Error;
176

177 0
      end case;
178

179 0
      return Name_Buffer (1 .. Name_Len);
180
   end Image;
181

182
   -----------
183
   -- Image --
184
   -----------
185

186 0
   function Image (Value : Value_Id; Quoted : Boolean := True) return String
187
   is
188
   begin
189 0
      if Value = No_Value then
190 0
         return "NoValue";
191
      else
192 0
         return Image (VT.Table (Value), Quoted);
193
      end if;
194 0
   end Image;
195

196
   --------------------
197
   -- New_List_Value --
198
   --------------------
199

200 0
   function New_List_Value (Value : List_Id) return Value_Id is
201
   begin
202 0
      return New_Value (Value_Type'(LT_List, Value));
203 0
   end New_List_Value;
204

205
   -----------------------
206
   -- New_Boolean_Value --
207
   -----------------------
208

209 0
   function New_Boolean_Value (Value : Boolean) return Value_Id is
210
   begin
211 0
      return New_Value (Value_Type'(LT_Boolean, Value));
212 0
   end New_Boolean_Value;
213

214
   ---------------------
215
   -- New_Range_Value --
216
   ---------------------
217

218 0
   function New_Range_Value
219
     (LValue    : Long_Long_Float;
220
      RValue    : Long_Long_Float;
221
      LNegative : Boolean              := False;
222
      RNegative : Boolean              := False;
223
      Base      : Unsigned_Short_Short := 10;
224
      Exp       : Integer              := 0)
225
     return Value_Id is
226
   begin
227 0
      return New_Value (Value_Type'(LT_Range,
228
                                    LValue,
229 0
                                    LNegative,
230
                                    RValue,
231 0
                                    RNegative,
232
                                    Base, Exp));
233 0
   end New_Range_Value;
234

235
   --------------------
236
   -- New_Real_Value --
237
   --------------------
238

239 0
   function New_Real_Value
240
     (Value    : Long_Long_Float;
241
      Negative : Boolean              := False;
242
      Base     : Unsigned_Short_Short := 10;
243
      Exp      : Integer              := 0)
244
     return Value_Id
245
   is
246
   begin
247 0
      return New_Value (Value_Type'(LT_Real, Value, Negative, Base, Exp));
248 0
   end New_Real_Value;
249

250
   -----------------------
251
   -- New_Integer_Value --
252
   -----------------------
253

254 0
   function New_Integer_Value
255
     (Value    : Unsigned_Long_Long;
256
      Negative : Boolean              := False;
257
      Base     : Unsigned_Short_Short := 10;
258
      Exp      : Integer              := 0)
259
     return Value_Id
260
   is
261
   begin
262 0
      return New_Value (Value_Type'(LT_Integer, Value, Negative, Base, Exp));
263 0
   end New_Integer_Value;
264

265
   ----------------------
266
   -- New_String_Value --
267
   ----------------------
268

269 0
   function New_String_Value (Value : Name_Id) return Value_Id is
270
   begin
271 0
      return New_Value (Value_Type'(LT_String, Value));
272 0
   end New_String_Value;
273

274
   --------------------
275
   -- New_Enum_Value --
276
   --------------------
277

278 0
   function New_Enum_Value (Value : Name_Id) return Value_Id is
279
   begin
280 0
      return New_Value (Value_Type'(LT_Enumeration, Value));
281 0
   end New_Enum_Value;
282

283
   --------------------
284
   -- New_Elem_Value --
285
   --------------------
286

287 0
   function New_Elem_Value (Value : Node_Id) return Value_Id is
288
   begin
289 0
      return New_Value (Value_Type'(LT_Element, Value));
290 0
   end New_Elem_Value;
291

292
   ---------------
293
   -- New_Value --
294
   ---------------
295

296 0
   function New_Value (Value : Value_Type) return Value_Id is
297 0
      V : Value_Id;
298
   begin
299 0
      VT.Increment_Last;
300 0
      V := VT.Last;
301 0
      VT.Table (V) := Value;
302 0
      return V;
303
   end New_Value;
304

305
   ---------------
306
   -- Set_Value --
307
   ---------------
308

309 0
   procedure Set_Value (V : Value_Id; X : Value_Type) is
310
   begin
311 0
      VT.Table (V) := X;
312 0
   end Set_Value;
313

314
   -----------
315
   -- Value --
316
   -----------
317

318 0
   function Value (V : Value_Id) return Value_Type is
319
   begin
320 0
      return VT.Table (V);
321
   end Value;
322

323
   function Image
324
     (V    : Long_Long_Float;
325
      Base : Unsigned_Short_Short)
326
     return String;
327

328
   function Remove_Ending_Zeros (Str : String) return String;
329
   --  Remove ending zeros '0'
330
   --  WARNING: if the result string terminates with an '.', the character
331
   --           which is next to '.' will be rescued
332
   --  Example: Remove_Ending_Zeros ("0.0") = "0.0"
333

334
   function Remove_Leading_Spaces (Str : String) return String;
335
   --  Remove leading spaces
336

337
   Minus_Character     : constant Character := '-';
338
   Base_Separator      : constant Character := '#';
339
   Exp_Separator       : constant Character := 'E';
340
   Real_Separator      : constant Character := '.';
341

342
   Real_Epsilon        : constant Long_Long_Float := 1.0E-10;
343
   Fraction_Max_Digits : constant Integer := 4 * 10;
344
   --  Max digits = digits (Real_Epsilon) in base 2 (not in base 10 !!)
345
   --             = about (4 * digits (Real_Epsilon) in base 10)
346

347
   function Image
348
     (V    : Unsigned_Long_Long;
349
      Base : Unsigned_Short_Short)
350
     return String;
351

352
   -----------
353
   -- Image --
354
   -----------
355

356 0
   function Image (V : Unsigned_Short_Short) return String is
357
   begin
358 0
      return Remove_Leading_Spaces (Unsigned_Short_Short'Image (V));
359 0
   end Image;
360

361
   -----------
362
   -- Image --
363
   -----------
364

365 0
   function Image (V : Integer) return String is
366
   begin
367 0
      return Remove_Leading_Spaces (Integer'Image (V));
368 0
   end Image;
369

370
   -----------
371
   -- Image --
372
   -----------
373

374 0
   function Image (V : Unsigned_Long_Long) return String is
375
   begin
376 0
      return Remove_Leading_Spaces (Unsigned_Long_Long'Image (V));
377 0
   end Image;
378

379
   -----------
380
   -- Image --
381
   -----------
382

383 0
   function Image
384
     (V    : Unsigned_Long_Long;
385
      Base : Unsigned_Short_Short)
386
     return String
387
   is
388 0
      Str     : String (1 .. Unsigned_Long_Long'Size + 4);
389
      --  Max digits = BB # (Max Bits) #
390

391 0
      Str_Pos : Integer := Str'Last;
392 0
      Rest    : Unsigned_Long_Long := V;
393 0
      LBase   : constant Unsigned_Long_Long := Unsigned_Long_Long (Base);
394 0
      Digit   : Unsigned_Short_Short;
395 0
      Ch      : Character;
396

397
   begin
398 0
      if Base < 2 or else Base > 16 then
399 0
         raise Constraint_Error;
400
      end if;
401

402
      loop
403 0
         Digit := Unsigned_Short_Short (Rest mod LBase);
404 0
         if Digit < 10 then
405 0
            Ch := Character'Val (Character'Pos ('0') + Digit);
406
         else
407 0
            Ch := Character'Val (Character'Pos ('A') + Digit - 10);
408
         end if;
409

410 0
         Str (Str_Pos) := Ch;
411 0
         Str_Pos       := Str_Pos - 1;
412

413 0
         Rest := Rest / LBase;
414 0
         exit when Rest = 0;
415 0
      end loop;
416

417 0
      return Str (Str_Pos + 1 .. Str'Last);
418 0
   end Image;
419

420
   -----------
421
   -- Image --
422
   -----------
423

424 0
   function Image
425
     (V    : Unsigned_Long_Long;
426
      Base : Unsigned_Short_Short;
427
      Exp  : Integer)
428
     return String
429
   is
430 0
      New_Value : Unsigned_Long_Long;
431

432
   begin
433 0
      if Exp = 0 then
434 0
         if Base = 10 then
435
            --  decimal integer without exponent
436 0
            return Image (V);
437
         else
438
            --  based integer without exponent
439 0
            return Image (Base) & Base_Separator &
440 0
                   Image (V, Base) & Base_Separator;
441
         end if;
442
      else
443 0
         New_Value := Unsigned_Long_Long (Long_Long_Float (V) /
444 0
                                          Power (Integer (Base), Exp));
445 0
         if Base = 10 then
446
            --  decimal integer with exponent
447 0
            return Image (New_Value) &
448 0
                   Exp_Separator & Image (Exp);
449
         else
450
            --  based intgeger with exponent
451 0
            return Image (Base) & Base_Separator &
452 0
                   Image (New_Value, Base) & Base_Separator &
453 0
                   Exp_Separator & Image (Exp);
454
         end if;
455
      end if;
456 0
   end Image;
457

458
   -----------
459
   -- Image --
460
   -----------
461

462 0
   function Image (V : Long_Long_Float) return String is
463 0
      Str : String (1 .. 2 * Long_Long_Float'Digits + 2);
464
      --  Max digits = [+/-] Fore . Aft
465

466
   begin
467 0
      Ada.Long_Long_Float_Text_IO.Put (Str, V, Long_Long_Float'Digits, 0);
468 0
      return Remove_Ending_Zeros (Remove_Leading_Spaces (Str));
469 0
   end Image;
470

471
   -----------
472
   -- Image --
473
   -----------
474

475 0
   function Image
476
     (V    : Long_Long_Float;
477
      Base : Unsigned_Short_Short)
478
     return String
479
   is
480 0
      Str          : String (1 .. Fraction_Max_Digits);
481 0
      Sign         : Boolean;
482 0
      Integer_Part : Unsigned_Long_Long;
483 0
      Rest         : Long_Long_Float;
484 0
      Fraction     : Long_Long_Float;
485 0
      LBase        : constant Long_Long_Float := Long_Long_Float (Base);
486 0
      Digit        : Unsigned_Short_Short;
487 0
      Str_Len      : Integer := 0;
488 0
      Ch           : Character;
489

490
   begin
491 0
      if V < 0.0 then
492 0
         Sign := True;
493 0
         Rest := -V;
494
      else
495 0
         Sign := False;
496 0
         Rest := V;
497
      end if;
498

499 0
      Integer_Part := Unsigned_Long_Long (Long_Long_Float'Floor (Rest));
500 0
      Rest         := Rest - Long_Long_Float (Integer_Part);
501 0
      Fraction     := 1.0 / LBase;
502

503
      loop
504 0
         Digit := Unsigned_Short_Short
505 0
                     (Long_Long_Float'Truncation (Rest / Fraction));
506 0
         if Digit < 10 then
507 0
            Ch := Character'Val (Character'Pos ('0') + Digit);
508
         else
509 0
            Ch := Character'Val (Character'Pos ('A') + Digit - 10);
510
         end if;
511

512 0
         Str_Len       := Str_Len + 1;
513 0
         Str (Str_Len) := Ch;
514

515 0
         Rest     := Rest - Long_Long_Float (Digit) * Fraction;
516 0
         Fraction := Fraction / LBase;
517 0
         exit when Rest < Real_Epsilon or else Str_Len = Str'Last;
518 0
      end loop;
519

520 0
      if Sign then
521 0
         return Minus_Character & Image (Integer_Part, Base) &
522 0
                Real_Separator & Str (1 .. Str_Len);
523
      else
524 0
         return Image (Integer_Part, Base) &
525 0
                Real_Separator & Str (1 .. Str_Len);
526
      end if;
527 0
   end Image;
528

529
   -----------
530
   -- Image --
531
   -----------
532

533 0
   function Image
534
     (V    : Long_Long_Float;
535
      Base : Unsigned_Short_Short;
536
      Exp  : Integer)
537
     return String
538
   is
539 0
      New_Value : Long_Long_Float;
540

541
   begin
542 0
      if Exp = 0 then
543 0
         if Base = 10 then
544
            --  decimal real without exponent
545 0
            return Image (V);
546
         else
547
            --  based real without exponent
548 0
            return Image (Base) & Base_Separator &
549 0
                   Image (V, Base) & Base_Separator;
550
         end if;
551
      else
552 0
         New_Value := V / Power (Integer (Base), Exp);
553

554 0
         if Base = 10 then
555
            --  decimal real with exponent
556 0
            return Image (New_Value) &
557 0
                   Exp_Separator & Image (Exp);
558
         else
559
            --  based real with exponent
560 0
            return Image (Base) & Base_Separator &
561 0
                   Image (New_Value, Base) & Base_Separator &
562 0
                   Exp_Separator & Image (Exp);
563
         end if;
564
      end if;
565 0
   end Image;
566

567
   -----------
568
   -- Image --
569
   -----------
570

571 0
   function Image (Kind : Node_Kind) return String is
572
      use Charset;
573

574 0
      S       : String := Node_Kind'Image (Kind);
575 0
      Capital : Boolean := False;
576

577
   begin
578 0
      To_Lower (S);
579 0
      for I in S'Range loop
580 0
         if S (I) = '_' then
581 0
            Capital := True;
582
         else
583 0
            if Capital then
584 0
               S (I) := Ada.Characters.Handling.To_Upper (S (I));
585
            end if;
586 0
            Capital := False;
587
         end if;
588 0
      end loop;
589

590 0
      return S (3 .. S'Last);
591 0
   end Image;
592

593
   -----------
594
   -- Power --
595
   -----------
596

597 0
   function Power (Base : Integer; Exp : Integer) return Long_Long_Float is
598 0
      Result : Long_Long_Float := 1.0;
599 0
      LBase  : constant Long_Long_Float := Long_Long_Float (Base);
600 0
      PExp   : Natural;
601

602
   begin
603 0
      PExp := abs Exp;
604 0
      for I in 1 .. PExp loop
605 0
         Result := Result * LBase;
606 0
      end loop;
607

608 0
      if Exp < 0 then
609 0
         return 1.0 / Result;
610
      else
611 0
         return Result;
612
      end if;
613
   end Power;
614

615
   -------------------------
616
   -- Remove_Ending_Zeros --
617
   -------------------------
618

619 0
   function Remove_Ending_Zeros (Str : String) return String is
620 0
      I : Integer;
621

622
   begin
623 0
      I := Str'Last;
624
      loop
625 0
         if Str (I) /= '0' then
626 0
            if Str (I) = '.' and then I < Str'Last then
627 0
               return Str (Str'First .. I + 1);
628
            else
629 0
               return Str (Str'First .. I);
630
            end if;
631
         end if;
632 0
         exit when I = Str'First;
633 0
         I := I - 1;
634 0
      end loop;
635 0
      return Str;
636
   end Remove_Ending_Zeros;
637

638
   ---------------------------
639
   -- Remove_Leading_Spaces --
640
   ---------------------------
641

642 0
   function Remove_Leading_Spaces (Str : String) return String is
643
   begin
644 0
      for I in Str'Range loop
645 0
         if Str (I) /= ' ' then
646 0
            return Str (I .. Str'Last);
647
         end if;
648 0
      end loop;
649 0
      return Str;
650
   end Remove_Leading_Spaces;
651

652
   ---------
653
   -- "*" --
654
   ---------
655

656 0
   function "*" (L : Value_Type; R : Value_Type) return Value_Type is
657
   begin
658 0
      case L.T is
659 0
         when LT_Integer =>
660 0
            case R.T is
661 0
               when LT_Integer =>
662 0
                  declare
663 0
                     Result : Value_Type (LT_Integer);
664
                  begin
665 0
                     Result.IBase := 10;
666 0
                     Result.ISign := Safe_XOR (L.ISign, R.ISign);
667 0
                     Result.IVal := L.IVal * R.IVal;
668 0
                     return Result;
669 0
                  end;
670

671 0
               when LT_Real =>
672 0
                  declare
673 0
                     Result : Value_Type (LT_Real);
674
                  begin
675 0
                     Result.RSign := Safe_XOR (L.ISign, R.RSign);
676 0
                     Result.RExp := 0;
677 0
                     Result.RVal := Long_Long_Float (L.IVal) * R.RVal;
678 0
                     return Result;
679 0
                  end;
680

681 0
               when others =>
682 0
                  raise Constraint_Error;
683

684
            end case;
685

686 0
         when LT_Real =>
687 0
            case R.T is
688 0
               when LT_Integer =>
689 0
                  declare
690 0
                     Result : Value_Type (LT_Real);
691
                  begin
692 0
                     Result.RSign := Safe_XOR (L.RSign, R.ISign);
693 0
                     Result.RExp := 0;
694 0
                     Result.RVal := L.RVal * Long_Long_Float (R.IVal);
695 0
                     return Result;
696 0
                  end;
697

698 0
               when LT_Real =>
699 0
                  declare
700 0
                     Result : Value_Type (LT_Real);
701
                  begin
702 0
                     Result.RSign := Safe_XOR (L.RSign, R.RSign);
703 0
                     Result.RExp := 0;
704 0
                     Result.RVal := L.RVal * R.RVal;
705 0
                     return Result;
706 0
                  end;
707

708 0
               when others =>
709 0
                  raise Constraint_Error;
710
            end case;
711

712 0
         when others =>
713 0
            raise Constraint_Error;
714
      end case;
715
   end "*";
716

717
   ---------
718
   -- "/" --
719
   ---------
720

721 0
   function "/" (L : Value_Type; R : Value_Type) return Value_Type is
722
   begin
723 0
      case L.T is
724 0
         when LT_Integer =>
725 0
            case R.T is
726 0
               when LT_Integer =>
727 0
                  if R.IVal = 0 then
728 0
                     raise Constraint_Error with "Division by zero";
729
                  end if;
730

731 0
                  declare
732 0
                     Result : Value_Type (LT_Real);
733
                  begin
734 0
                     Result.RBase := 10;
735 0
                     Result.RSign := Safe_XOR (L.ISign, R.ISign);
736 0
                     Result.RVal := Long_Long_Float (L.IVal) /
737 0
                       Long_Long_Float (R.IVal);
738 0
                     Result.Rexp := 0;
739 0
                     return Result;
740 0
                  end;
741

742 0
               when LT_Real =>
743 0
                  if R.RVal = 0.0 then
744 0
                     raise Constraint_Error with "Division by zero";
745
                  end if;
746

747 0
                  declare
748 0
                     Result : Value_Type (LT_Real);
749
                  begin
750 0
                     Result.RBase := 10;
751 0
                     Result.RSign := Safe_XOR (L.ISign, R.RSign);
752 0
                     Result.RExp := 0;
753 0
                     Result.RVal := Long_Long_Float (L.IVal) / R.RVal;
754 0
                     return Result;
755 0
                  end;
756

757 0
               when others =>
758 0
                  raise Constraint_Error;
759

760
            end case;
761

762 0
         when LT_Real =>
763 0
            case R.T is
764 0
               when LT_Integer =>
765 0
                  if R.IVal = 0 then
766 0
                     raise Constraint_Error with "Division by zero";
767
                  end if;
768

769 0
                  declare
770 0
                     Result : Value_Type (LT_Real);
771
                  begin
772 0
                     Result.RBase := 10;
773 0
                     Result.RSign := Safe_XOR (L.RSign, R.ISign);
774 0
                     Result.RExp := 0;
775 0
                     Result.RVal := L.RVal / Long_Long_Float (R.IVal);
776 0
                     return Result;
777 0
                  end;
778

779 0
               when LT_Real =>
780 0
                  if R.RVal = 0.0 then
781 0
                     raise Constraint_Error with "Division by zero";
782
                  end if;
783

784 0
                  declare
785 0
                     Result : Value_Type (LT_Real);
786
                  begin
787 0
                     Result.RBase := 10;
788 0
                     Result.RSign := Safe_XOR (L.RSign, R.RSign);
789 0
                     Result.RExp := 0;
790 0
                     Result.RVal := L.RVal / R.RVal;
791 0
                     Result.Rexp := 1;
792 0
                     return Result;
793 0
                  end;
794

795 0
               when others =>
796 0
                  raise Constraint_Error;
797
            end case;
798

799 0
         when others =>
800 0
            raise Constraint_Error;
801
      end case;
802
   end "/";
803

804
   ---------
805
   -- "-" --
806
   ---------
807

808 0
   function "-" (L : Value_Type; R : Value_Type) return Value_Type is
809 0
      T : Value_Type := R;
810
   begin
811 0
      case T.T is
812 0
         when LT_Integer =>
813 0
            T.ISign := not R.ISign;
814

815 0
         when LT_Real =>
816 0
            T.RSign := not R.RSign;
817

818 0
         when others =>
819 0
            raise Constraint_Error;
820 0
      end case;
821

822 0
      return (L + T);
823

824 0
   end "-";
825

826
   ---------
827
   -- "+" --
828
   ---------
829

830 0
   function "+" (L : Value_Type; R : Value_Type) return Value_Type is
831
   begin
832 0
      case L.T is
833 0
         when LT_Integer =>
834 0
            case R.T is
835 0
               when LT_Integer =>
836 0
                  declare
837 0
                     Result : Value_Type (LT_Integer);
838
                  begin
839 0
                     Result.IBase := 10;
840 0
                     Result.IExp := 0;
841

842
                     --  |L| + -|R|
843 0
                     if R.ISign and then not L.ISign then
844

845 0
                        if L.IVal >= R.IVal then
846 0
                           Result.IVal := L.IVal - R.IVal;
847 0
                           Result.ISign := False;
848
                        else
849 0
                           Result.IVal := R.IVal - L.IVal;
850 0
                           Result.ISign := True;
851
                        end if;
852

853
                        --  -|L| + -|R|
854 0
                     elsif R.ISign and then L.ISign then
855 0
                        Result.IVal := R.IVal + L.IVal;
856 0
                        Result.ISign := True;
857

858
                        --  |L| + |R|
859 0
                     elsif not R.ISign and then not L.ISign then
860 0
                        Result.IVal := R.IVal + L.IVal;
861 0
                        Result.ISign := False;
862

863
                        --  -|L| + |R|
864
                     else
865 0
                        if R.IVal >= L.IVal then
866 0
                           Result.IVal := R.IVal - L.IVal;
867 0
                           Result.ISign := False;
868
                        else
869 0
                           Result.IVal := L.IVal - R.IVal;
870 0
                           Result.ISign := True;
871
                        end if;
872
                     end if;
873 0
                     return Result;
874 0
                  end;
875

876 0
               when LT_Real =>
877 0
                  declare
878 0
                     Result : Value_Type (LT_Real);
879
                  begin
880 0
                     Result.RBase := 10;
881 0
                     Result.RExp := 0;
882

883
                     --  |L| + -|R|
884 0
                     if R.RSign and then not L.ISign then
885

886 0
                        if Long_Long_Float (L.IVal) >= R.RVal then
887 0
                           Result.RVal := Long_Long_Float (L.IVal) - R.RVal;
888 0
                           Result.RSign := False;
889
                        else
890 0
                           Result.RVal := R.RVal - Long_Long_Float (L.IVal);
891 0
                           Result.RSign := True;
892
                        end if;
893

894
                        --  -|L| + -|R|
895 0
                     elsif R.RSign and then L.ISign then
896 0
                        Result.RVal := R.RVal + Long_Long_Float (L.IVal);
897 0
                        Result.RSign := True;
898

899
                        --  |L| + |R|
900 0
                     elsif not R.RSign and then not L.ISign then
901 0
                        Result.RVal := R.RVal + Long_Long_Float (L.IVal);
902 0
                        Result.RSign := False;
903

904
                        --  -|L| + |R|
905
                     else
906 0
                        if R.RVal >= Long_Long_Float (L.IVal) then
907 0
                           Result.RVal := R.RVal - Long_Long_Float (L.IVal);
908 0
                           Result.RSign := False;
909
                        else
910 0
                           Result.RVal := Long_Long_Float (L.IVal) - R.RVal;
911 0
                           Result.RSign := True;
912
                        end if;
913
                     end if;
914 0
                     return Result;
915 0
                  end;
916

917 0
               when others =>
918 0
                  raise Constraint_Error;
919

920
            end case;
921

922 0
         when LT_Real =>
923 0
            case R.T is
924 0
               when LT_Integer =>
925 0
                  declare
926 0
                     Result : Value_Type (LT_Real);
927
                  begin
928 0
                     Result.RBase := 10;
929 0
                     Result.RExp := 0;
930

931
                     --  |L| + -|R|
932 0
                     if R.ISign and then not L.RSign then
933

934 0
                        if L.RVal >= Long_Long_Float (R.IVal) then
935 0
                           Result.RVal := L.RVal - Long_Long_Float (R.IVal);
936 0
                           Result.RSign := False;
937
                        else
938 0
                           Result.RVal := Long_Long_Float (R.IVal) - L.RVal;
939 0
                           Result.RSign := True;
940
                        end if;
941

942
                        --  -|L| + -|R|
943 0
                     elsif R.ISign and then L.RSign then
944 0
                        Result.RVal := Long_Long_Float (R.IVal) + L.RVal;
945 0
                        Result.RSign := True;
946

947
                        --  |L| + |R|
948 0
                     elsif not R.ISign and then not L.RSign then
949 0
                        Result.RVal := Long_Long_Float (R.IVal) + L.RVal;
950 0
                        Result.RSign := False;
951

952
                        --  -|L| + |R|
953
                     else
954 0
                        if Long_Long_Float (R.IVal) >= L.RVal then
955 0
                           Result.RVal := Long_Long_Float (R.IVal) - L.RVal;
956 0
                           Result.RSign := False;
957
                        else
958 0
                           Result.RVal := L.RVal - Long_Long_Float (R.IVal);
959 0
                           Result.RSign := True;
960
                        end if;
961
                     end if;
962 0
                     return Result;
963 0
                  end;
964

965 0
               when LT_Real =>
966 0
                  declare
967 0
                     Result : Value_Type (LT_Real);
968
                  begin
969 0
                     Result.RBase := 10;
970 0
                     Result.RExp := 0;
971

972
                     --  |L| + -|R|
973 0
                     if R.RSign and then not L.RSign then
974

975 0
                        if L.RVal >= R.RVal then
976 0
                           Result.RVal := L.RVal - R.RVal;
977 0
                           Result.RSign := False;
978
                        else
979 0
                           Result.RVal := R.RVal - L.RVal;
980 0
                           Result.RSign := True;
981
                        end if;
982

983
                        --  -|L| + -|R|
984 0
                     elsif R.RSign and then L.RSign then
985 0
                        Result.RVal := R.RVal + L.RVal;
986 0
                        Result.RSign := True;
987

988
                        --  |L| + |R|
989 0
                     elsif not R.RSign and then not L.RSign then
990 0
                        Result.RVal := R.RVal + L.RVal;
991 0
                        Result.RSign := False;
992

993
                        --  -|L| + |R|
994
                     else
995 0
                        if R.RVal >= L.RVal then
996 0
                           Result.RVal := R.RVal - L.RVal;
997 0
                           Result.RSign := False;
998
                        else
999 0
                           Result.RVal := L.RVal - R.RVal;
1000 0
                           Result.RSign := True;
1001
                        end if;
1002
                     end if;
1003 0
                     return Result;
1004 0
                  end;
1005

1006 0
               when others =>
1007 0
                  raise Constraint_Error;
1008
            end case;
1009

1010 0
         when LT_List =>
1011 0
            case R.T is
1012
               when LT_List =>
1013 0
                  declare
1014
                     use Locations;
1015
                     use Ocarina.ME_AO4AADL.AO4AADL_Tree.Nutils;
1016

1017 0
                     Result : Value_Type;
1018
                     Lst    : constant List_Id :=
1019 0
                       New_List (K_List_Id, No_Location);
1020
                  begin
1021 0
                     if Is_Empty (L.LVal) then
1022 0
                        Result := Value_Type'(LT_List, R.LVal);
1023 0
                     elsif Is_Empty (R.LVal) then
1024 0
                        Result := Value_Type'(LT_List, L.LVal);
1025
                     else
1026 0
                        Set_First_Node (Lst, First_Node (L.LVal));
1027 0
                        Set_Next_Node (Last_Node (L.LVal),
1028 0
                                       First_Node (R.LVal));
1029 0
                        Set_Last_Node (Lst, Last_Node (R.LVal));
1030 0
                        Result := Value_Type'(LT_List, Lst);
1031
                     end if;
1032 0
                     return Result;
1033 0
                  end;
1034

1035
               when others =>
1036 0
                  raise Constraint_Error;
1037
            end case;
1038

1039 0
         when others =>
1040 0
            raise Constraint_Error;
1041
      end case;
1042
   end "+";
1043

1044
   ---------
1045
   -- "=" --
1046
   ---------
1047

1048 0
   function "=" (L : Value_Type; R : Value_Type) return Boolean is
1049
   begin
1050 0
      case L.T is
1051 0
         when LT_Integer =>
1052 0
            case R.T is
1053 0
               when LT_Integer =>
1054 0
                  return (L.IVal = R.IVal) and then (L.ISign = R.ISign);
1055

1056 0
               when LT_Real =>
1057 0
                  return (Long_Long_Float (L.IVal) = R.RVal)
1058 0
                    and then (L.ISign = R.RSign);
1059

1060 0
               when others =>
1061 0
                  raise Constraint_Error;
1062

1063
            end case;
1064

1065 0
         when LT_Real =>
1066 0
            case R.T is
1067 0
               when LT_Integer =>
1068 0
                  return (L.RVal = Long_Long_Float (R.IVal))
1069 0
                    and then (L.RSign = R.ISign);
1070

1071 0
               when LT_Real =>
1072 0
                  return (L.RVal = R.RVal) and then (L.RSign = R.RSign);
1073

1074 0
               when others =>
1075 0
                  raise Constraint_Error;
1076
            end case;
1077

1078 0
         when others =>
1079 0
            raise Constraint_Error;
1080
      end case;
1081
   end "=";
1082

1083
   ---------
1084
   -- "<" --
1085
   ---------
1086

1087 0
   function "<" (L : Value_Type; R : Value_Type) return Boolean is
1088 0
      Sign_L : Boolean;
1089 0
      Sign_R : Boolean;
1090 0
      Result : Boolean;
1091
   begin
1092
      --  Compare absolute values
1093

1094 0
      case L.T is
1095 0
         when LT_Integer =>
1096 0
            case R.T is
1097 0
               when LT_Integer =>
1098 0
                  Sign_L := L.ISign;
1099 0
                  Sign_R := R.ISign;
1100 0
                  Result := L.IVal < R.IVal;
1101

1102 0
               when LT_Real =>
1103 0
                  Sign_L := L.ISign;
1104 0
                  Sign_R := R.RSign;
1105 0
                  Result := Long_Long_Float (L.IVal) < R.RVal;
1106

1107 0
               when others =>
1108 0
                  raise Constraint_Error;
1109

1110 0
            end case;
1111

1112 0
         when LT_Real =>
1113 0
            case R.T is
1114 0
               when LT_Integer =>
1115 0
                  Sign_L := L.RSign;
1116 0
                  Sign_R := R.ISign;
1117 0
                  Result := L.RVal < Long_Long_Float (R.IVal);
1118

1119 0
               when LT_Real =>
1120 0
                  Sign_L := L.RSign;
1121 0
                  Sign_R := R.RSign;
1122 0
                  Result := L.RVal < R.RVal;
1123

1124 0
               when others =>
1125 0
                  raise Constraint_Error;
1126 0
            end case;
1127

1128 0
         when others =>
1129 0
            raise Constraint_Error;
1130 0
      end case;
1131

1132
      --  Take signs into account
1133

1134 0
      if Sign_L then
1135 0
         if Sign_R then
1136 0
            return not Result;
1137
         else
1138 0
            return True;
1139
         end if;
1140
      else
1141 0
         if Sign_R then
1142 0
            return False;
1143
         else
1144 0
            return Result;
1145
         end if;
1146
      end if;
1147
   end "<";
1148

1149 1
end Ocarina.AO4AADL_Values;

Read our documentation on viewing source code .

Loading