URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [s-valuti.adb] - Blame information for rev 801

Go to most recent revision | Details | Compare with Previous | View Log


------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                      S Y S T E M . V A L _ U T I L                       --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------
 
with System.Case_Util; use System.Case_Util;
 
package body System.Val_Util is
 
   ----------------------
   -- Normalize_String --
   ----------------------
 
   procedure Normalize_String
     (S    : in out String;
      F, L : out Integer)
   is
   begin
      F := S'First;
      L := S'Last;
 
      --  Scan for leading spaces
 
      while F <= L and then S (F) = ' ' loop
         F := F + 1;
      end loop;
 
      --  Check for case when the string contained no characters
 
      if F > L then
         raise Constraint_Error;
      end if;
 
      --  Scan for trailing spaces
 
      while S (L) = ' ' loop
         L := L - 1;
      end loop;
 
      --  Except in the case of a character literal, convert to upper case
 
      if S (F) /= ''' then
         for J in F .. L loop
            S (J) := To_Upper (S (J));
         end loop;
      end if;
   end Normalize_String;
 
   -------------------
   -- Scan_Exponent --
   -------------------
 
   function Scan_Exponent
     (Str  : String;
      Ptr  : not null access Integer;
      Max  : Integer;
      Real : Boolean := False) return Integer
   is
      P : Natural := Ptr.all;
      M : Boolean;
      X : Integer;
 
   begin
      if P >= Max
        or else (Str (P) /= 'E' and then Str (P) /= 'e')
      then
         return 0;
      end if;
 
      --  We have an E/e, see if sign follows
 
      P := P + 1;
 
      if Str (P) = '+' then
         P := P + 1;
 
         if P > Max then
            return 0;
         else
            M := False;
         end if;
 
      elsif Str (P) = '-' then
         P := P + 1;
 
         if P > Max or else not Real then
            return 0;
         else
            M := True;
         end if;
 
      else
         M := False;
      end if;
 
      if Str (P) not in '0' .. '9' then
         return 0;
      end if;
 
      --  Scan out the exponent value as an unsigned integer. Values larger
      --  than (Integer'Last / 10) are simply considered large enough here.
      --  This assumption is correct for all machines we know of (e.g. in
      --  the case of 16 bit integers it allows exponents up to 3276, which
      --  is large enough for the largest floating types in base 2.)
 
      X := 0;
 
      loop
         if X < (Integer'Last / 10) then
            X := X * 10 + (Character'Pos (Str (P)) - Character'Pos ('0'));
         end if;
 
         P := P + 1;
 
         exit when P > Max;
 
         if Str (P) = '_' then
            Scan_Underscore (Str, P, Ptr, Max, False);
         else
            exit when Str (P) not in '0' .. '9';
         end if;
      end loop;
 
      if M then
         X := -X;
      end if;
 
      Ptr.all := P;
      return X;
   end Scan_Exponent;
 
   --------------------
   -- Scan_Plus_Sign --
   --------------------
 
   procedure Scan_Plus_Sign
     (Str   : String;
      Ptr   : not null access Integer;
      Max   : Integer;
      Start : out Positive)
   is
      P : Natural := Ptr.all;
 
   begin
      if P > Max then
         raise Constraint_Error;
      end if;
 
      --  Scan past initial blanks
 
      while Str (P) = ' ' loop
         P := P + 1;
 
         if P > Max then
            Ptr.all := P;
            raise Constraint_Error;
         end if;
      end loop;
 
      Start := P;
 
      --  Skip past an initial plus sign
 
      if Str (P) = '+' then
         P := P + 1;
 
         if P > Max then
            Ptr.all := Start;
            raise Constraint_Error;
         end if;
      end if;
 
      Ptr.all := P;
   end Scan_Plus_Sign;
 
   ---------------
   -- Scan_Sign --
   ---------------
 
   procedure Scan_Sign
     (Str   : String;
      Ptr   : not null access Integer;
      Max   : Integer;
      Minus : out Boolean;
      Start : out Positive)
   is
      P : Natural := Ptr.all;
 
   begin
      --  Deal with case of null string (all blanks!). As per spec, we
      --  raise constraint error, with Ptr unchanged, and thus > Max.
 
      if P > Max then
         raise Constraint_Error;
      end if;
 
      --  Scan past initial blanks
 
      while Str (P) = ' ' loop
         P := P + 1;
 
         if P > Max then
            Ptr.all := P;
            raise Constraint_Error;
         end if;
      end loop;
 
      Start := P;
 
      --  Remember an initial minus sign
 
      if Str (P) = '-' then
         Minus := True;
         P := P + 1;
 
         if P > Max then
            Ptr.all := Start;
            raise Constraint_Error;
         end if;
 
      --  Skip past an initial plus sign
 
      elsif Str (P) = '+' then
         Minus := False;
         P := P + 1;
 
         if P > Max then
            Ptr.all := Start;
            raise Constraint_Error;
         end if;
 
      else
         Minus := False;
      end if;
 
      Ptr.all := P;
   end Scan_Sign;
 
   --------------------------
   -- Scan_Trailing_Blanks --
   --------------------------
 
   procedure Scan_Trailing_Blanks (Str : String; P : Positive) is
   begin
      for J in P .. Str'Last loop
         if Str (J) /= ' ' then
            raise Constraint_Error;
         end if;
      end loop;
   end Scan_Trailing_Blanks;
 
   ---------------------
   -- Scan_Underscore --
   ---------------------
 
   procedure Scan_Underscore
     (Str : String;
      P   : in out Natural;
      Ptr : not null access Integer;
      Max : Integer;
      Ext : Boolean)
   is
      C : Character;
 
   begin
      P := P + 1;
 
      --  If underscore is at the end of string, then this is an error and
      --  we raise Constraint_Error, leaving the pointer past the underscore.
      --  This seems a bit strange. It means e.g. that if the field is:
 
      --    345_
 
      --  that Constraint_Error is raised. You might think that the RM in
      --  this case would scan out the 345 as a valid integer, leaving the
      --  pointer at the underscore, but the ACVC suite clearly requires
      --  an error in this situation (see for example CE3704M).
 
      if P > Max then
         Ptr.all := P;
         raise Constraint_Error;
      end if;
 
      --  Similarly, if no digit follows the underscore raise an error. This
      --  also catches the case of double underscore which is also an error.
 
      C := Str (P);
 
      if C in '0' .. '9'
        or else
          (Ext and then (C in 'A' .. 'F' or else C in 'a' .. 'f'))
      then
         return;
      else
         Ptr.all := P;
         raise Constraint_Error;
      end if;
   end Scan_Underscore;
 
end System.Val_Util;

Browse

Tools

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [s-valuti.adb] - Blame information for rev 801

Line No.	Rev	Author	Line
1	706	jeremybenn	`------------------------------------------------------------------------------`
2			`-- --`
3			`-- GNAT COMPILER COMPONENTS --`
4			`-- --`
5			`-- S Y S T E M . V A L _ U T I L --`
6			`-- --`
7			`-- B o d y --`
8			`-- --`
9			`-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --`
10			`-- --`
11			`-- GNAT is free software; you can redistribute it and/or modify it 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. GNAT is distributed in the hope that it will be useful, but WITH- --`
15			`-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --`
16			`-- 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			`-- GNAT was originally developed by the GNAT team at New York University. --`
28			`-- Extensive contributions were provided by Ada Core Technologies Inc. --`
29			`-- --`
30			`------------------------------------------------------------------------------`
31
32			`with System.Case_Util; use System.Case_Util;`
33
34			`package body System.Val_Util is`
35
36			`----------------------`
37			`-- Normalize_String --`
38			`----------------------`
39
40			`procedure Normalize_String`
41			`(S : in out String;`
42			`F, L : out Integer)`
43			`is`
44			`begin`
45			`F := S'First;`
46			`L := S'Last;`
47
48			`-- Scan for leading spaces`
49
50			`while F <= L and then S (F) = ' ' loop`
51			`F := F + 1;`
52			`end loop;`
53
54			`-- Check for case when the string contained no characters`
55
56			`if F > L then`
57			`raise Constraint_Error;`
58			`end if;`
59
60			`-- Scan for trailing spaces`
61
62			`while S (L) = ' ' loop`
63			`L := L - 1;`
64			`end loop;`
65
66			`-- Except in the case of a character literal, convert to upper case`
67
68			`if S (F) /= ''' then`
69			`for J in F .. L loop`
70			`S (J) := To_Upper (S (J));`
71			`end loop;`
72			`end if;`
73			`end Normalize_String;`
74
75			`-------------------`
76			`-- Scan_Exponent --`
77			`-------------------`
78
79			`function Scan_Exponent`
80			`(Str : String;`
81			`Ptr : not null access Integer;`
82			`Max : Integer;`
83			`Real : Boolean := False) return Integer`
84			`is`
85			`P : Natural := Ptr.all;`
86			`M : Boolean;`
87			`X : Integer;`
88
89			`begin`
90			`if P >= Max`
91			`or else (Str (P) /= 'E' and then Str (P) /= 'e')`
92			`then`
93			`return 0;`
94			`end if;`
95
96			`-- We have an E/e, see if sign follows`
97
98			`P := P + 1;`
99
100			`if Str (P) = '+' then`
101			`P := P + 1;`
102
103			`if P > Max then`
104			`return 0;`
105			`else`
106			`M := False;`
107			`end if;`
108
109			`elsif Str (P) = '-' then`
110			`P := P + 1;`
111
112			`if P > Max or else not Real then`
113			`return 0;`
114			`else`
115			`M := True;`
116			`end if;`
117
118			`else`
119			`M := False;`
120			`end if;`
121
122			`if Str (P) not in '0' .. '9' then`
123			`return 0;`
124			`end if;`
125
126			`-- Scan out the exponent value as an unsigned integer. Values larger`
127			`-- than (Integer'Last / 10) are simply considered large enough here.`
128			`-- This assumption is correct for all machines we know of (e.g. in`
129			`-- the case of 16 bit integers it allows exponents up to 3276, which`
130			`-- is large enough for the largest floating types in base 2.)`
131
132			`X := 0;`
133
134			`loop`
135			`if X < (Integer'Last / 10) then`
136			`X := X * 10 + (Character'Pos (Str (P)) - Character'Pos ('0'));`
137			`end if;`
138
139			`P := P + 1;`
140
141			`exit when P > Max;`
142
143			`if Str (P) = '_' then`
144			`Scan_Underscore (Str, P, Ptr, Max, False);`
145			`else`
146			`exit when Str (P) not in '0' .. '9';`
147			`end if;`
148			`end loop;`
149
150			`if M then`
151			`X := -X;`
152			`end if;`
153
154			`Ptr.all := P;`
155			`return X;`
156			`end Scan_Exponent;`
157
158			`--------------------`
159			`-- Scan_Plus_Sign --`
160			`--------------------`
161
162			`procedure Scan_Plus_Sign`
163			`(Str : String;`
164			`Ptr : not null access Integer;`
165			`Max : Integer;`
166			`Start : out Positive)`
167			`is`
168			`P : Natural := Ptr.all;`
169
170			`begin`
171			`if P > Max then`
172			`raise Constraint_Error;`
173			`end if;`
174
175			`-- Scan past initial blanks`
176
177			`while Str (P) = ' ' loop`
178			`P := P + 1;`
179
180			`if P > Max then`
181			`Ptr.all := P;`
182			`raise Constraint_Error;`
183			`end if;`
184			`end loop;`
185
186			`Start := P;`
187
188			`-- Skip past an initial plus sign`
189
190			`if Str (P) = '+' then`
191			`P := P + 1;`
192
193			`if P > Max then`
194			`Ptr.all := Start;`
195			`raise Constraint_Error;`
196			`end if;`
197			`end if;`
198
199			`Ptr.all := P;`
200			`end Scan_Plus_Sign;`
201
202			`---------------`
203			`-- Scan_Sign --`
204			`---------------`
205
206			`procedure Scan_Sign`
207			`(Str : String;`
208			`Ptr : not null access Integer;`
209			`Max : Integer;`
210			`Minus : out Boolean;`
211			`Start : out Positive)`
212			`is`
213			`P : Natural := Ptr.all;`
214
215			`begin`
216			`-- Deal with case of null string (all blanks!). As per spec, we`
217			`-- raise constraint error, with Ptr unchanged, and thus > Max.`
218
219			`if P > Max then`
220			`raise Constraint_Error;`
221			`end if;`
222
223			`-- Scan past initial blanks`
224
225			`while Str (P) = ' ' loop`
226			`P := P + 1;`
227
228			`if P > Max then`
229			`Ptr.all := P;`
230			`raise Constraint_Error;`
231			`end if;`
232			`end loop;`
233
234			`Start := P;`
235
236			`-- Remember an initial minus sign`
237
238			`if Str (P) = '-' then`
239			`Minus := True;`
240			`P := P + 1;`
241
242			`if P > Max then`
243			`Ptr.all := Start;`
244			`raise Constraint_Error;`
245			`end if;`
246
247			`-- Skip past an initial plus sign`
248
249			`elsif Str (P) = '+' then`
250			`Minus := False;`
251			`P := P + 1;`
252
253			`if P > Max then`
254			`Ptr.all := Start;`
255			`raise Constraint_Error;`
256			`end if;`
257
258			`else`
259			`Minus := False;`
260			`end if;`
261
262			`Ptr.all := P;`
263			`end Scan_Sign;`
264
265			`--------------------------`
266			`-- Scan_Trailing_Blanks --`
267			`--------------------------`
268
269			`procedure Scan_Trailing_Blanks (Str : String; P : Positive) is`
270			`begin`
271			`for J in P .. Str'Last loop`
272			`if Str (J) /= ' ' then`
273			`raise Constraint_Error;`
274			`end if;`
275			`end loop;`
276			`end Scan_Trailing_Blanks;`
277
278			`---------------------`
279			`-- Scan_Underscore --`
280			`---------------------`
281
282			`procedure Scan_Underscore`
283			`(Str : String;`
284			`P : in out Natural;`
285			`Ptr : not null access Integer;`
286			`Max : Integer;`
287			`Ext : Boolean)`
288			`is`
289			`C : Character;`
290
291			`begin`
292			`P := P + 1;`
293
294			`-- If underscore is at the end of string, then this is an error and`
295			`-- we raise Constraint_Error, leaving the pointer past the underscore.`
296			`-- This seems a bit strange. It means e.g. that if the field is:`
297
298			`-- 345_`
299
300			`-- that Constraint_Error is raised. You might think that the RM in`
301			`-- this case would scan out the 345 as a valid integer, leaving the`
302			`-- pointer at the underscore, but the ACVC suite clearly requires`
303			`-- an error in this situation (see for example CE3704M).`
304
305			`if P > Max then`
306			`Ptr.all := P;`
307			`raise Constraint_Error;`
308			`end if;`
309
310			`-- Similarly, if no digit follows the underscore raise an error. This`
311			`-- also catches the case of double underscore which is also an error.`
312
313			`C := Str (P);`
314
315			`if C in '0' .. '9'`
316			`or else`
317			`(Ext and then (C in 'A' .. 'F' or else C in 'a' .. 'f'))`
318			`then`
319			`return;`
320			`else`
321			`Ptr.all := P;`
322			`raise Constraint_Error;`
323			`end if;`
324			`end Scan_Underscore;`
325
326			`end System.Val_Util;`