OpenAADL / ocarina
1
------------------------------------------------------------------------------
2
--                                                                          --
3
--                           OCARINA COMPONENTS                             --
4
--                                                                          --
5
--         O C A R I N A . B A C K E N D S . A S N 1 _ V A L U E S          --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--         Copyright (C) 2012-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; use Ocarina.Namet;
33

34
with Ocarina.AADL_Values;
35

36
with GNAT.Table;
37

38 1
package body Ocarina.Backends.ASN1_Values is
39

40
   package OV renames Ocarina.AADL_Values;
41

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

44
   ---------
45
   -- "*" --
46
   ---------
47

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

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

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

68
   ---------
69
   -- "+" --
70
   ---------
71

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

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

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

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

100
   ---------
101
   -- "-" --
102
   ---------
103

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

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

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

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

121
   ---------
122
   -- "-" --
123
   ---------
124

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

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

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

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

142
   ---------
143
   -- "/" --
144
   ---------
145

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

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

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

166
   ---------
167
   -- "<" --
168
   ---------
169

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

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

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

192
      end case;
193
   end "<";
194

195
   -----------
196
   -- "and" --
197
   -----------
198

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

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

223
   -----------
224
   -- "mod" --
225
   -----------
226

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

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

244
   -----------
245
   -- "not" --
246
   -----------
247

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

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

261
   ----------
262
   -- "or" --
263
   ----------
264

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

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

289
   -----------
290
   -- "xor" --
291
   -----------
292

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

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

317
   -----------
318
   -- Image --
319
   -----------
320

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

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

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

342 1
            if V.Base = 16 or else V.Base = 8 then
343 0
               Add_Char_To_Name_Buffer ('#');
344
            end if;
345

346 0
         when K_Float =>
347 0
            Add_Str_To_Name_Buffer (Long_Double'Image (V.FVal));
348
            declare
349 0
               Index : Natural := Name_Len;
350

351
            begin
352

353
               --  Find exponent if any
354

355 0
               while Index > 0 and then Name_Buffer (Index) /= 'E' loop
356 0
                  Index := Index - 1;
357 0
               end loop;
358

359
               --  Remove leading zero in exponent part.
360

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

370
                  --  Remove exponent
371

372 0
                  if Index > Name_Len then
373 0
                     Name_Len := Name_Len - 2;
374 0
                     Index    := Name_Len;
375

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

384
               end if;
385

386
               --  Remove trailing zero in fraction part.
387

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

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

418 0
         when K_String =>
419 0
            if V.PCVal = No_Name then
420 0
               return '"' & '"';
421
            end if;
422 0
            Add_Char_To_Name_Buffer ('"'); -- "
423 0
            Get_Name_String_And_Append (V.PCVal);
424 0
            Add_Char_To_Name_Buffer ('"'); -- "
425

426 0
         when others =>
427 0
            raise Program_Error;
428 1
      end case;
429

430 1
      return Name_Buffer (1 .. Name_Len);
431 1
   end Image;
432

433
   ------------------------------
434
   -- New_Floating_Point_Value --
435
   ------------------------------
436

437 0
   function New_Floating_Point_Value (Value : Long_Double) return Value_Id is
438
   begin
439 0
      return New_Value (Value_Type'(K_Float, Value));
440 0
   end New_Floating_Point_Value;
441

442
   -------------------
443
   -- New_Int_Value --
444
   -------------------
445

446 1
   function New_Int_Value
447
     (Value : Unsigned_Long_Long;
448
      Sign  : Short_Short;
449
      Base  : Unsigned_Short_Short) return Value_Id
450
   is
451
   begin
452 1
      return New_Value (Value_Type'(K_Int, Value, Sign, Base));
453 1
   end New_Int_Value;
454

455
   -------------------------
456
   -- New_Character_Value --
457
   -------------------------
458

459 0
   function New_Char_Value (Value : Unsigned_Short) return Value_Id is
460
   begin
461 0
      return New_Value (Value_Type'(K_Char, Value));
462 0
   end New_Char_Value;
463

464
   ---------------
465
   -- New_Value --
466
   ---------------
467

468 1
   function New_Value (Value : Value_Type) return Value_Id is
469 1
      V : Value_Id;
470
   begin
471 1
      VT.Increment_Last;
472 1
      V            := VT.Last;
473 1
      VT.Table (V) := Value;
474 1
      return V;
475
   end New_Value;
476

477
   ---------------
478
   -- Set_Value --
479
   ---------------
480

481 0
   procedure Set_Value (V : Value_Id; X : Value_Type) is
482
   begin
483 0
      VT.Table (V) := X;
484 0
   end Set_Value;
485

486
   ----------------
487
   -- Shift_Left --
488
   ----------------
489

490 0
   function Shift_Left (L, R : Value_Type) return Value_Type is
491 0
      LV : Value_Type := L;
492 0
      RV : Value_Type := R;
493
   begin
494 0
      case RV.K is
495
         when K_Int =>
496 0
            if RV.Sign < 0 then
497 0
               RV.Sign := 1;
498 0
               return Shift_Right (LV, RV);
499
            end if;
500

501
            --  Keep working with left operand base
502

503 0
            LV.IVal := Shift_Left (LV.IVal, Natural (RV.IVal));
504 0
            return LV;
505

506
         when others =>
507 0
            return Bad_Value;
508
      end case;
509 0
   end Shift_Left;
510

511
   -----------------
512
   -- Shift_Right --
513
   -----------------
514

515 0
   function Shift_Right (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_Left (LV, RV);
524
            end if;
525

526
            --  Keep working with left operand base
527

528 0
            LV.IVal := Shift_Right (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_Right;
535

536
   ----------------------
537
   -- New_String_Value --
538
   ----------------------
539

540 0
   function New_String_Value (Value : Name_Id) return Value_Id is
541
   begin
542 0
      return New_Value (Value_Type'(K_String, Value));
543 0
   end New_String_Value;
544

545
   -----------
546
   -- Value --
547
   -----------
548

549 0
   function Value (V : Value_Id) return Value_Type is
550
   begin
551 0
      return VT.Table (V);
552
   end Value;
553

554
   -----------
555
   -- Reset --
556
   -----------
557

558 1
   procedure Reset is
559
   begin
560 1
      VT.Init;
561 1
   end Reset;
562

563
   -------------------
564
   -- To_ASN1_Value --
565
   -------------------
566

567 0
   function To_ASN1_Value (V : Value_Id) return Value_Id is
568 0
      VT     : constant OV.Value_Type := OV.Value (V);
569 0
      Result : Value_Id;
570
   begin
571 0
      case VT.T is
572 0
         when OV.LT_Integer =>
573 0
            if VT.ISign then
574 0
               Result := New_Int_Value (VT.IVal, -1, VT.IBase);
575
            else
576 0
               Result := New_Int_Value (VT.IVal, 1, VT.IBase);
577
            end if;
578 0
         when OV.LT_Real =>
579 0
            Result := New_Floating_Point_Value (Long_Double (VT.RVal));
580 0
         when OV.LT_String =>
581 0
            Result := New_String_Value (VT.SVal);
582 0
         when OV.LT_Boolean =>
583 0
            raise Constraint_Error;
584 0
         when others =>
585 0
            raise Constraint_Error;
586 0
      end case;
587

588 0
      return Result;
589 0
   end To_ASN1_Value;
590

591 1
end Ocarina.Backends.ASN1_Values;

Read our documentation on viewing source code .

Loading