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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [a-exstat.adb] - Blame information for rev 839

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

Line No. Rev Author Line
1 706 jeremybenn 
------------------------------------------------------------------------------
2 
--                                                                          --
3 
--                         GNAT COMPILER COMPONENTS                         --
4 
--                                                                          --
5 
--                     ADA.EXCEPTIONS.STREAM_ATTRIBUTES                     --
6 
--                                                                          --
7 
--                                 B o d y                                  --
8 
--                                                                          --
9 
--          Copyright (C) 1992-2011, 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 
         To := S'First - 2;
148 
         Next_String;
149 
 
150 
         if S (From .. From + 15) /= "Exception name: " then
151 
            Bad_EO;
152 
         end if;
153 
 
154 
         X.Id := Exception_Id (Internal_Exception (S (From + 16 .. To)));
155 
 
156 
         Next_String;
157 
 
158 
         if From <= To and then S (From) = 'M' then
159 
            if S (From .. From + 8) /= "Message: " then
160 
               Bad_EO;
161 
            end if;
162 
 
163 
            X.Msg_Length := To - From - 8;
164 
            X.Msg (1 .. X.Msg_Length) := S (From + 9 .. To);
165 
            Next_String;
166 
 
167 
         else
168 
            X.Msg_Length := 0;
169 
         end if;
170 
 
171 
         X.Pid := 0;
172 
 
173 
         if From <= To and then S (From) = 'P' then
174 
            if S (From .. From + 3) /= "PID:" then
175 
               Bad_EO;
176 
            end if;
177 
 
178 
            From := From + 5; -- skip past PID: space
179 
 
180 
            while From <= To loop
181 
               X.Pid := X.Pid * 10 +
182 
                          (Character'Pos (S (From)) - Character'Pos ('0'));
183 
               From := From + 1;
184 
            end loop;
185 
 
186 
            Next_String;
187 
         end if;
188 
 
189 
         X.Num_Tracebacks := 0;
190 
 
191 
         if From <= To then
192 
            if S (From .. To) /= "Call stack traceback locations:" then
193 
               Bad_EO;
194 
            end if;
195 
 
196 
            Next_String;
197 
            loop
198 
               exit when From > To;
199 
 
200 
               declare
201 
                  Ch : Character;
202 
                  C  : Integer_Address;
203 
                  N  : Integer_Address;
204 
 
205 
               begin
206 
                  if S (From) /= '0'
207 
                    or else S (From + 1) /= 'x'
208 
                  then
209 
                     Bad_EO;
210 
                  else
211 
                     From := From + 2;
212 
                  end if;
213 
 
214 
                  C := 0;
215 
                  while From <= To loop
216 
                     Ch := S (From);
217 
 
218 
                     if Ch in '0' .. '9' then
219 
                        N :=
220 
                          Character'Pos (S (From)) - Character'Pos ('0');
221 
 
222 
                     elsif Ch in 'a' .. 'f' then
223 
                        N :=
224 
                          Character'Pos (S (From)) - Character'Pos ('a') + 10;
225 
 
226 
                     elsif Ch = ' ' then
227 
                        From := From + 1;
228 
                        exit;
229 
 
230 
                     else
231 
                        Bad_EO;
232 
                     end if;
233 
 
234 
                     C := C * 16 + N;
235 
 
236 
                     From := From + 1;
237 
                  end loop;
238 
 
239 
                  if X.Num_Tracebacks = Max_Tracebacks then
240 
                     Bad_EO;
241 
                  end if;
242 
 
243 
                  X.Num_Tracebacks := X.Num_Tracebacks + 1;
244 
                  X.Tracebacks (X.Num_Tracebacks) :=
245 
                    TBE.TB_Entry_For (To_Address (C));
246 
               end;
247 
            end loop;
248 
         end if;
249 
 
250 
         --  If an exception was converted to a string, it must have
251 
         --  already been raised, so flag it accordingly and we are done.
252 
 
253 
         X.Exception_Raised := True;
254 
         return X;
255 
      end if;
256 
   end String_To_EO;
257 
 
258 
end Stream_Attributes;

powered by: WebSVN 2.1.0

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