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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [g-trasym-vms-alpha.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT RUN-TIME COMPONENTS                         --
4
--                                                                          --
5
--             G N A T . T R A C E B A C K . S Y M B O L I C                --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--           Copyright (C) 1999-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
--  Run-time symbolic traceback support for Alpha/VMS
33
 
34
with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback;
35
with Interfaces.C;
36
with System;
37
with System.Aux_DEC;
38
with System.Soft_Links;
39
with System.Traceback_Entries;
40
 
41
package body GNAT.Traceback.Symbolic is
42
 
43
   pragma Warnings (Off); --  Needs comment ???
44
   pragma Linker_Options ("--for-linker=sys$library:trace.exe");
45
 
46
   use Interfaces.C;
47
   use System;
48
   use System.Aux_DEC;
49
   use System.Traceback_Entries;
50
 
51
   subtype User_Arg_Type is Unsigned_Longword;
52
   subtype Cond_Value_Type is Unsigned_Longword;
53
 
54
   type ASCIC is record
55
      Count : unsigned_char;
56
      Data  : char_array (1 .. 255);
57
   end record;
58
   pragma Convention (C, ASCIC);
59
 
60
   for ASCIC use record
61
      Count at 0 range 0 .. 7;
62
      Data  at 1 range 0 .. 8 * 255 - 1;
63
   end record;
64
   for ASCIC'Size use 8 * 256;
65
 
66
   function Fetch_ASCIC is new Fetch_From_Address (ASCIC);
67
 
68
   -----------------------
69
   -- Local Subprograms --
70
   -----------------------
71
 
72
   function Dummy_User_Act_Proc
73
     (Msgvec : Address       := Null_Address;
74
      Actrtn : Address       := Null_Address;
75
      Facnam : Address       := Null_Address;
76
      Actprm : User_Arg_Type := 0) return Cond_Value_Type;
77
   --  Dummy routine with SYS$PUTMSG signature
78
 
79
   procedure Symbolize
80
     (Status         : out Cond_Value_Type;
81
      Current_PC     : Address;
82
      Adjusted_PC    : Address;
83
      Current_FP     : Address;
84
      Current_R26    : Address;
85
      Image_Name     : out Address;
86
      Module_Name    : out Address;
87
      Routine_Name   : out Address;
88
      Line_Number    : out Integer;
89
      Relative_PC    : out Address;
90
      Absolute_PC    : out Address;
91
      PC_Is_Valid    : out Long_Integer;
92
      User_Act_Proc  : Address           := Dummy_User_Act_Proc'Address;
93
      User_Arg_Value : User_Arg_Type     := 0);
94
   --  Comment on above procedure required ???
95
 
96
   pragma Interface (External, Symbolize);
97
 
98
   pragma Import_Valued_Procedure
99
     (Symbolize, "TBK$SYMBOLIZE",
100
      (Cond_Value_Type, Address, Address, Address, Address,
101
       Address, Address, Address, Integer,
102
       Address, Address, Long_Integer,
103
       Address, User_Arg_Type),
104
      (Value, Value, Value, Value, Value,
105
       Reference, Reference, Reference, Reference,
106
       Reference, Reference, Reference,
107
       Value, Value));
108
 
109
   function Decode_Ada_Name (Encoded_Name : String) return String;
110
   --  Decodes an Ada identifier name. Removes leading "_ada_" and trailing
111
   --  __{DIGIT}+ or ${DIGIT}+, converts other "__" to '.'
112
 
113
   ---------------------
114
   -- Decode_Ada_Name --
115
   ---------------------
116
 
117
   function Decode_Ada_Name (Encoded_Name : String) return String is
118
      Decoded_Name : String (1 .. Encoded_Name'Length);
119
      Pos          : Integer := Encoded_Name'First;
120
      Last         : Integer := Encoded_Name'Last;
121
      DPos         : Integer := 1;
122
 
123
   begin
124
      if Pos > Last then
125
         return "";
126
      end if;
127
 
128
      --  Skip leading _ada_
129
 
130
      if Encoded_Name'Length > 4
131
        and then Encoded_Name (Pos .. Pos + 4) = "_ada_"
132
      then
133
         Pos := Pos + 5;
134
      end if;
135
 
136
      --  Skip trailing __{DIGIT}+ or ${DIGIT}+
137
 
138
      if Encoded_Name (Last) in '0' .. '9' then
139
         for J in reverse Pos + 2 .. Last - 1 loop
140
            case Encoded_Name (J) is
141
               when '0' .. '9' =>
142
                  null;
143
               when '$' =>
144
                  Last := J - 1;
145
                  exit;
146
               when '_' =>
147
                  if Encoded_Name (J - 1) = '_' then
148
                     Last := J - 2;
149
                  end if;
150
                  exit;
151
               when others =>
152
                  exit;
153
            end case;
154
         end loop;
155
      end if;
156
 
157
      --  Now just copy encoded name to decoded name, converting "__" to '.'
158
 
159
      while Pos <= Last loop
160
         if Encoded_Name (Pos) = '_' and then Encoded_Name (Pos + 1) = '_'
161
           and then Pos /= Encoded_Name'First
162
         then
163
            Decoded_Name (DPos) := '.';
164
            Pos := Pos + 2;
165
 
166
         else
167
            Decoded_Name (DPos) := Encoded_Name (Pos);
168
            Pos := Pos + 1;
169
         end if;
170
 
171
         DPos := DPos + 1;
172
      end loop;
173
 
174
      return Decoded_Name (1 .. DPos - 1);
175
   end Decode_Ada_Name;
176
 
177
   -------------------------
178
   -- Dummy_User_Act_Proc --
179
   -------------------------
180
 
181
   function Dummy_User_Act_Proc
182
     (Msgvec : Address       := Null_Address;
183
      Actrtn : Address       := Null_Address;
184
      Facnam : Address       := Null_Address;
185
      Actprm : User_Arg_Type := 0) return Cond_Value_Type
186
   is
187
   begin
188
      return 0;
189
   end Dummy_User_Act_Proc;
190
 
191
   ------------------------
192
   -- Symbolic_Traceback --
193
   ------------------------
194
 
195
   function Symbolic_Traceback (Traceback : Tracebacks_Array) return String is
196
      Status            : Cond_Value_Type;
197
      Image_Name        : ASCIC;
198
      Image_Name_Addr   : Address;
199
      Module_Name       : ASCIC;
200
      Module_Name_Addr  : Address;
201
      Routine_Name      : ASCIC;
202
      Routine_Name_Addr : Address;
203
      Line_Number       : Integer;
204
      Relative_PC       : Address;
205
      Absolute_PC       : Address;
206
      PC_Is_Valid       : Long_Integer;
207
      Return_Address    : Address;
208
      Res               : String (1 .. 256 * Traceback'Length);
209
      Len               : Integer;
210
 
211
   begin
212
      if Traceback'Length > 0 then
213
         Len := 0;
214
 
215
         --  Since image computation is not thread-safe we need task lockout
216
 
217
         System.Soft_Links.Lock_Task.all;
218
 
219
         for J in Traceback'Range loop
220
            Return_Address :=
221
              (if J = Traceback'Last then Address_Zero
222
                                     else PC_For (Traceback (J + 1)));
223
 
224
            Symbolize
225
              (Status,
226
               PC_For (Traceback (J)),
227
               PC_For (Traceback (J)),
228
               PV_For (Traceback (J)),
229
               Return_Address,
230
               Image_Name_Addr,
231
               Module_Name_Addr,
232
               Routine_Name_Addr,
233
               Line_Number,
234
               Relative_PC,
235
               Absolute_PC,
236
               PC_Is_Valid);
237
 
238
            Image_Name   := Fetch_ASCIC (Image_Name_Addr);
239
            Module_Name  := Fetch_ASCIC (Module_Name_Addr);
240
            Routine_Name := Fetch_ASCIC (Routine_Name_Addr);
241
 
242
            declare
243
               First : Integer := Len + 1;
244
               Last  : Integer := First + 80 - 1;
245
               Pos   : Integer;
246
               Routine_Name_D : String := Decode_Ada_Name
247
                 (To_Ada
248
                    (Routine_Name.Data (1 .. size_t (Routine_Name.Count)),
249
                     False));
250
 
251
            begin
252
               Res (First .. Last) := (others => ' ');
253
 
254
               Res (First .. First + Integer (Image_Name.Count) - 1) :=
255
                 To_Ada
256
                  (Image_Name.Data (1 .. size_t (Image_Name.Count)),
257
                   False);
258
 
259
               Res (First + 10 ..
260
                    First + 10 + Integer (Module_Name.Count) - 1) :=
261
                 To_Ada
262
                  (Module_Name.Data (1 .. size_t (Module_Name.Count)),
263
                   False);
264
 
265
               Res (First + 30 ..
266
                    First + 30 + Routine_Name_D'Length - 1) :=
267
                 Routine_Name_D;
268
 
269
               --  If routine name doesn't fit 20 characters, output
270
               --  the line number on next line at 50th position
271
 
272
               if Routine_Name_D'Length > 20 then
273
                  Pos := First + 30 + Routine_Name_D'Length;
274
                  Res (Pos) := ASCII.LF;
275
                  Last := Pos + 80;
276
                  Res (Pos + 1 .. Last) := (others => ' ');
277
                  Pos := Pos + 51;
278
               else
279
                  Pos := First + 50;
280
               end if;
281
 
282
               Res (Pos .. Pos + Integer'Image (Line_Number)'Length - 1) :=
283
                 Integer'Image (Line_Number);
284
 
285
               Res (Last) := ASCII.LF;
286
               Len := Last;
287
            end;
288
         end loop;
289
 
290
         System.Soft_Links.Unlock_Task.all;
291
         return Res (1 .. Len);
292
 
293
      else
294
         return "";
295
      end if;
296
   end Symbolic_Traceback;
297
 
298
   function Symbolic_Traceback (E : Exception_Occurrence) return String is
299
   begin
300
      return Symbolic_Traceback (Tracebacks (E));
301
   end Symbolic_Traceback;
302
 
303
end GNAT.Traceback.Symbolic;

powered by: WebSVN 2.1.0

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