1------------------------------------------------------------------------------
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-2012, 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
34with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback;
35with Interfaces.C;
36with System;
37with System.Aux_DEC;
38with System.Soft_Links;
39with System.Traceback_Entries;
40
41package 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 Import (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
303end GNAT.Traceback.Symbolic;
304