diff options
Diffstat (limited to 'translate/grt/grt-values.adb')
| -rw-r--r-- | translate/grt/grt-values.adb | 215 |
1 files changed, 215 insertions, 0 deletions
diff --git a/translate/grt/grt-values.adb b/translate/grt/grt-values.adb new file mode 100644 index 0000000..404a2a4 --- /dev/null +++ b/translate/grt/grt-values.adb @@ -0,0 +1,215 @@ +-- GHDL Run Time (GRT) - 'value subprograms. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL 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 +-- along with GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Grt.Errors; use Grt.Errors; + +package body Grt.Values is + + NBSP : constant Character := Character'Val (160); + HT : constant Character := Character'Val (9); + + function Ghdl_Value_I32 (Str : Std_String_Ptr) return Ghdl_I32 + is + S : constant Std_String_Basep := Str.Base; + Len : constant Ghdl_Index_Type := Str.Bounds.Dim_1.Length; + Pos : Ghdl_Index_Type := 0; + C : Character; + Sep : Character; + Val, D, Base : Ghdl_I32; + Exp : Integer; + begin + -- LRM 14.1 + -- Leading [and trailing] whitespace is allowed and ignored. + -- + -- GHDL: allow several leading whitespace. + while Pos < Len loop + case S (Pos) is + when ' ' + | NBSP + | HT => + Pos := Pos + 1; + when others => + exit; + end case; + end loop; + + if Pos = Len then + Error_E ("'value: empty string"); + end if; + C := S (Pos); + + -- Be user friendly. + if C = '-' or C = '+' then + Error_E ("'value: leading sign +/- not allowed"); + end if; + + Val := 0; + loop + if C in '0' .. '9' then + Val := Val * 10 + Character'Pos (C) - Character'Pos ('0'); + Pos := Pos + 1; + exit when Pos >= Len; + C := S (Pos); + else + Error_E ("'value: decimal digit expected"); + end if; + case C is + when '_' => + Pos := Pos + 1; + if Pos >= Len then + Error_E ("'value: trailing underscore"); + end if; + C := S (Pos); + when '#' + | ':' + | 'E' + | 'e' => + exit; + when ' ' + | NBSP + | HT => + Pos := Pos + 1; + exit; + when others => + null; + end case; + end loop; + + if Pos >= Len then + return Val; + end if; + + if C = '#' or C = ':' then + Base := Val; + Val := 0; + Sep := C; + Pos := Pos + 1; + if Base < 2 or Base > 16 then + Error_E ("'value: bad base"); + end if; + if Pos >= Len then + Error_E ("'value: missing based integer"); + end if; + C := S (Pos); + loop + case C is + when '0' .. '9' => + D := Character'Pos (C) - Character'Pos ('0'); + when 'a' .. 'f' => + D := Character'Pos (C) - Character'Pos ('a') + 10; + when 'A' .. 'F' => + D := Character'Pos (C) - Character'Pos ('A') + 10; + when others => + Error_E ("'value: digit expected"); + end case; + if D > Base then + Error_E ("'value: digit greather than base"); + end if; + Val := Val * Base + D; + Pos := Pos + 1; + if Pos >= Len then + Error_E ("'value: missing end sign number"); + end if; + C := S (Pos); + if C = '#' or C = ':' then + if C /= Sep then + Error_E ("'value: sign number mismatch"); + end if; + Pos := Pos + 1; + exit; + elsif C = '_' then + Pos := Pos + 1; + if Pos >= Len then + Error_E ("'value: no character after underscore"); + end if; + C := S (Pos); + end if; + end loop; + else + Base := 10; + end if; + + -- Handle exponent. + if C = 'e' or C = 'E' then + Pos := Pos + 1; + if Pos >= Len then + Error_E ("'value: no character after exponent"); + end if; + C := S (Pos); + if C = '+' then + Pos := Pos + 1; + if Pos >= Len then + Error_E ("'value: no character after sign"); + end if; + C := S (Pos); + elsif C = '-' then + Error_E ("'value: negativ exponent not allowed"); + end if; + Exp := 0; + loop + if C in '0' .. '9' then + Exp := Exp * 10 + Character'Pos (C) - Character'Pos ('0'); + Pos := Pos + 1; + exit when Pos >= Len; + C := S (Pos); + else + Error_E ("'value: decimal digit expected"); + end if; + case C is + when '_' => + Pos := Pos + 1; + if Pos >= Len then + Error_E ("'value: trailing underscore"); + end if; + C := S (Pos); + when ' ' + | NBSP + | HT => + Pos := Pos + 1; + exit; + when others => + null; + end case; + end loop; + while Exp > 0 loop + if Exp mod 2 = 1 then + Val := Val * Base; + end if; + Exp := Exp / 2; + Base := Base * Base; + end loop; + end if; + + -- LRM 14.1 + -- [Leading] and trailing whitespace is allowed and ignored. + -- + -- GHDL: allow several leading whitespace. + while Pos < Len loop + case S (Pos) is + when ' ' + | NBSP + | HT => + Pos := Pos + 1; + when others => + Error_E ("'value: trailing characters after blank"); + end case; + end loop; + + return Val; + end Ghdl_Value_I32; + +end Grt.Values; |