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

Subversion Repositories openrisc

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

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

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT RUN-TIME COMPONENTS                         --
4
--                                                                          --
5
--                       S Y S T E M . I M G _ B I U                        --
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.Unsigned_Types; use System.Unsigned_Types;
33
 
34
package body System.Img_BIU is
35
 
36
   -----------------------------
37
   -- Set_Image_Based_Integer --
38
   -----------------------------
39
 
40
   procedure Set_Image_Based_Integer
41
     (V : Integer;
42
      B : Natural;
43
      W : Integer;
44
      S : out String;
45
      P : in out Natural)
46
   is
47
      Start : Natural;
48
 
49
   begin
50
      --  Positive case can just use the unsigned circuit directly
51
 
52
      if V >= 0 then
53
         Set_Image_Based_Unsigned (Unsigned (V), B, W, S, P);
54
 
55
      --  Negative case has to set a minus sign. Note also that we have to be
56
      --  careful not to generate overflow with the largest negative number.
57
 
58
      else
59
         P := P + 1;
60
         S (P) := ' ';
61
         Start := P;
62
 
63
         declare
64
            pragma Suppress (Overflow_Check);
65
            pragma Suppress (Range_Check);
66
         begin
67
            Set_Image_Based_Unsigned (Unsigned (-V), B, W - 1, S, P);
68
         end;
69
 
70
         --  Set minus sign in last leading blank location. Because of the
71
         --  code above, there must be at least one such location.
72
 
73
         while S (Start + 1) = ' ' loop
74
            Start := Start + 1;
75
         end loop;
76
 
77
         S (Start) := '-';
78
      end if;
79
 
80
   end Set_Image_Based_Integer;
81
 
82
   ------------------------------
83
   -- Set_Image_Based_Unsigned --
84
   ------------------------------
85
 
86
   procedure Set_Image_Based_Unsigned
87
     (V : Unsigned;
88
      B : Natural;
89
      W : Integer;
90
      S : out String;
91
      P : in out Natural)
92
   is
93
      Start : constant Natural := P;
94
      F, T  : Natural;
95
      BU    : constant Unsigned := Unsigned (B);
96
      Hex   : constant array
97
                (Unsigned range 0 .. 15) of Character := "0123456789ABCDEF";
98
 
99
      procedure Set_Digits (T : Unsigned);
100
      --  Set digits of absolute value of T
101
 
102
      procedure Set_Digits (T : Unsigned) is
103
      begin
104
         if T >= BU then
105
            Set_Digits (T / BU);
106
            P := P + 1;
107
            S (P) := Hex (T mod BU);
108
         else
109
            P := P + 1;
110
            S (P) := Hex (T);
111
         end if;
112
      end Set_Digits;
113
 
114
   --  Start of processing for Set_Image_Based_Unsigned
115
 
116
   begin
117
 
118
      if B >= 10 then
119
         P := P + 1;
120
         S (P) := '1';
121
      end if;
122
 
123
      P := P + 1;
124
      S (P) := Character'Val (Character'Pos ('0') + B mod 10);
125
 
126
      P := P + 1;
127
      S (P) := '#';
128
 
129
      Set_Digits (V);
130
 
131
      P := P + 1;
132
      S (P) := '#';
133
 
134
      --  Add leading spaces if required by width parameter
135
 
136
      if P - Start < W then
137
         F := P;
138
         P := Start + W;
139
         T := P;
140
 
141
         while F > Start loop
142
            S (T) := S (F);
143
            T := T - 1;
144
            F := F - 1;
145
         end loop;
146
 
147
         for J in Start + 1 .. T loop
148
            S (J) := ' ';
149
         end loop;
150
      end if;
151
 
152
   end Set_Image_Based_Unsigned;
153
 
154
end System.Img_BIU;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.