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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-stable/] [gcc-4.5.1/] [gcc/] [ada/] [a-exstat.adb] - Blame information for rev 859

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

Line No. Rev Author Line
1 281 jeremybenn 
------------------------------------------------------------------------------
2 
--                                                                          --
3 
--                         GNAT COMPILER COMPONENTS                         --
4 
--                                                                          --
5 
--                     ADA.EXCEPTIONS.STREAM_ATTRIBUTES                     --
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 
pragma Warnings (Off);
33 
--  Allow withing of non-Preelaborated units in Ada 2005 mode where this
34 
--  package will be categorized as Preelaborate. See AI-362 for details.
35 
--  It is safe in the context of the run-time to violate the rules!
36 
 
37 
with System.Exception_Table;  use System.Exception_Table;
38 
with System.Storage_Elements; use System.Storage_Elements;
39 
 
40 
pragma Warnings (On);
41 
 
42 
separate (Ada.Exceptions)
43 
package body Stream_Attributes is
44 
 
45 
   -------------------
46 
   -- EId_To_String --
47 
   -------------------
48 
 
49 
   function EId_To_String (X : Exception_Id) return String is
50 
   begin
51 
      if X = Null_Id then
52 
         return "";
53 
      else
54 
         return Exception_Name (X);
55 
      end if;
56 
   end EId_To_String;
57 
 
58 
   ------------------
59 
   -- EO_To_String --
60 
   ------------------
61 
 
62 
   --  We use the null string to represent the null occurrence, otherwise
63 
   --  we output the Exception_Information string for the occurrence.
64 
 
65 
   function EO_To_String (X : Exception_Occurrence) return String is
66 
   begin
67 
      if X.Id = Null_Id then
68 
         return "";
69 
      else
70 
         return Exception_Information (X);
71 
      end if;
72 
   end EO_To_String;
73 
 
74 
   -------------------
75 
   -- String_To_EId --
76 
   -------------------
77 
 
78 
   function String_To_EId (S : String) return Exception_Id is
79 
   begin
80 
      if S = "" then
81 
         return Null_Id;
82 
      else
83 
         return Exception_Id (Internal_Exception (S));
84 
      end if;
85 
   end String_To_EId;
86 
 
87 
   ------------------
88 
   -- String_To_EO --
89 
   ------------------
90 
 
91 
   function String_To_EO (S : String) return Exception_Occurrence is
92 
      From : Natural;
93 
      To   : Integer;
94 
 
95 
      X    : aliased Exception_Occurrence;
96 
      --  This is the exception occurrence we will create
97 
 
98 
      procedure Bad_EO;
99 
      pragma No_Return (Bad_EO);
100 
      --  Signal bad exception occurrence string
101 
 
102 
      procedure Next_String;
103 
      --  On entry, To points to last character of previous line of the
104 
      --  message, terminated by LF. On return, From .. To are set to
105 
      --  specify the next string, or From > To if there are no more lines.
106 
 
107 
      procedure Bad_EO is
108 
      begin
109 
         Raise_Exception
110 
           (Program_Error'Identity,
111 
            "bad exception occurrence in stream input");
112 
 
113 
         --  The following junk raise of Program_Error is required because
114 
         --  this is a No_Return function, and unfortunately Raise_Exception
115 
         --  can return (this particular call can't, but the back end is not
116 
         --  clever enough to know that).
117 
 
118 
         raise Program_Error;
119 
      end Bad_EO;
120 
 
121 
      procedure Next_String is
122 
      begin
123 
         From := To + 2;
124 
 
125 
         if From < S'Last then
126 
            To := From + 1;
127 
 
128 
            while To < S'Last - 1 loop
129 
               if To >= S'Last then
130 
                  Bad_EO;
131 
               elsif S (To + 1) = ASCII.LF then
132 
                  exit;
133 
               else
134 
                  To := To + 1;
135 
               end if;
136 
            end loop;
137 
         end if;
138 
      end Next_String;
139 
 
140 
   --  Start of processing for String_To_EO
141 
 
142 
   begin
143 
      if S = "" then
144 
         return Null_Occurrence;
145 
 
146 
      else
147 
         X.Cleanup_Flag := False;
148 
 
149 
         To := S'First - 2;
150 
         Next_String;
151 
 
152 
         if S (From .. From + 15) /= "Exception name: " then
153 
            Bad_EO;
154 
         end if;
155 
 
156 
         X.Id := Exception_Id (Internal_Exception (S (From + 16 .. To)));
157 
 
158 
         Next_String;
159 
 
160 
         if From <= To and then S (From) = 'M' then
161 
            if S (From .. From + 8) /= "Message: " then
162 
               Bad_EO;
163 
            end if;
164 
 
165 
            X.Msg_Length := To - From - 8;
166 
            X.Msg (1 .. X.Msg_Length) := S (From + 9 .. To);
167 
            Next_String;
168 
 
169 
         else
170 
            X.Msg_Length := 0;
171 
         end if;
172 
 
173 
         X.Pid := 0;
174 
 
175 
         if From <= To and then S (From) = 'P' then
176 
            if S (From .. From + 3) /= "PID:" then
177 
               Bad_EO;
178 
            end if;
179 
 
180 
            From := From + 5; -- skip past PID: space
181 
 
182 
            while From <= To loop
183 
               X.Pid := X.Pid * 10 +
184 
                          (Character'Pos (S (From)) - Character'Pos ('0'));
185 
               From := From + 1;
186 
            end loop;
187 
 
188 
            Next_String;
189 
         end if;
190 
 
191 
         X.Num_Tracebacks := 0;
192 
 
193 
         if From <= To then
194 
            if S (From .. To) /= "Call stack traceback locations:" then
195 
               Bad_EO;
196 
            end if;
197 
 
198 
            Next_String;
199 
            loop
200 
               exit when From > To;
201 
 
202 
               declare
203 
                  Ch : Character;
204 
                  C  : Integer_Address;
205 
                  N  : Integer_Address;
206 
 
207 
               begin
208 
                  if S (From) /= '0'
209 
                    or else S (From + 1) /= 'x'
210 
                  then
211 
                     Bad_EO;
212 
                  else
213 
                     From := From + 2;
214 
                  end if;
215 
 
216 
                  C := 0;
217 
                  while From <= To loop
218 
                     Ch := S (From);
219 
 
220 
                     if Ch in '0' .. '9' then
221 
                        N :=
222 
                          Character'Pos (S (From)) - Character'Pos ('0');
223 
 
224 
                     elsif Ch in 'a' .. 'f' then
225 
                        N :=
226 
                          Character'Pos (S (From)) - Character'Pos ('a') + 10;
227 
 
228 
                     elsif Ch = ' ' then
229 
                        From := From + 1;
230 
                        exit;
231 
 
232 
                     else
233 
                        Bad_EO;
234 
                     end if;
235 
 
236 
                     C := C * 16 + N;
237 
 
238 
                     From := From + 1;
239 
                  end loop;
240 
 
241 
                  if X.Num_Tracebacks = Max_Tracebacks then
242 
                     Bad_EO;
243 
                  end if;
244 
 
245 
                  X.Num_Tracebacks := X.Num_Tracebacks + 1;
246 
                  X.Tracebacks (X.Num_Tracebacks) :=
247 
                    TBE.TB_Entry_For (To_Address (C));
248 
               end;
249 
            end loop;
250 
         end if;
251 
 
252 
         --  If an exception was converted to a string, it must have
253 
         --  already been raised, so flag it accordingly and we are done.
254 
 
255 
         X.Exception_Raised := True;
256 
         return X;
257 
      end if;
258 
   end String_To_EO;
259 
 
260 
end Stream_Attributes;

powered by: WebSVN 2.1.0

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