Add hppa-openbsd target
[official-gcc.git] / gcc / ada / memroot.adb
blob1fa7211e7673d9d2e819477fd9c1ab3599865f76
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- M E M R O O T --
6 -- --
7 -- B o d y --
8 -- --
9 -- --
10 -- Copyright (C) 1997-2002 Ada Core Technologies, Inc. --
11 -- --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
22 -- --
23 -- GNAT was originally developed by the GNAT team at New York University. --
24 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
25 -- --
26 ------------------------------------------------------------------------------
28 with GNAT.Table;
29 with GNAT.HTable; use GNAT.HTable;
30 with Ada.Text_IO; use Ada.Text_IO;
32 package body Memroot is
34 -------------
35 -- Name_Id --
36 -------------
38 package Chars is new GNAT.Table (
39 Table_Component_Type => Character,
40 Table_Index_Type => Integer,
41 Table_Low_Bound => 1,
42 Table_Initial => 10_000,
43 Table_Increment => 100);
44 -- The actual character container for names
46 type Name is record
47 First, Last : Integer;
48 end record;
50 package Names is new GNAT.Table (
51 Table_Component_Type => Name,
52 Table_Index_Type => Name_Id,
53 Table_Low_Bound => 0,
54 Table_Initial => 400,
55 Table_Increment => 100);
57 type Name_Range is range 1 .. 1023;
59 function Name_Eq (N1, N2 : Name) return Boolean;
60 -- compare 2 names
62 function H (N : Name) return Name_Range;
64 package Name_HTable is new GNAT.HTable.Simple_HTable (
65 Header_Num => Name_Range,
66 Element => Name_Id,
67 No_Element => No_Name_Id,
68 Key => Name,
69 Hash => H,
70 Equal => Name_Eq);
72 --------------
73 -- Frame_Id --
74 --------------
76 type Frame is record
77 Name, File, Line : Name_Id;
78 end record;
80 function Image
81 (F : Frame_Id;
82 Max_Fil : Integer;
83 Max_Lin : Integer)
84 return String;
85 -- Returns an image for F containing the file name, the Line number,
86 -- and the subprogram name. When possible, spaces are inserted between
87 -- the line number and the subprogram name in order to align images of the
88 -- same frame. Alignement is cimputed with Max_Fil & Max_Lin representing
89 -- the max number of character in a filename or length in a given frame.
91 package Frames is new GNAT.Table (
92 Table_Component_Type => Frame,
93 Table_Index_Type => Frame_Id,
94 Table_Low_Bound => 1,
95 Table_Initial => 400,
96 Table_Increment => 100);
98 type Frame_Range is range 1 .. 513;
99 function H (N : Frame) return Frame_Range;
101 package Frame_HTable is new GNAT.HTable.Simple_HTable (
102 Header_Num => Frame_Range,
103 Element => Frame_Id,
104 No_Element => No_Frame_Id,
105 Key => Frame,
106 Hash => H,
107 Equal => "=");
109 -------------
110 -- Root_Id --
111 -------------
113 type Root is record
114 First, Last : Integer;
115 Nb_Alloc : Integer;
116 Alloc_Size : Storage_Count;
117 High_Water_Mark : Storage_Count;
118 end record;
120 package Frames_In_Root is new GNAT.Table (
121 Table_Component_Type => Frame_Id,
122 Table_Index_Type => Integer,
123 Table_Low_Bound => 1,
124 Table_Initial => 400,
125 Table_Increment => 100);
127 package Roots is new GNAT.Table (
128 Table_Component_Type => Root,
129 Table_Index_Type => Root_Id,
130 Table_Low_Bound => 1,
131 Table_Initial => 200,
132 Table_Increment => 100);
133 type Root_Range is range 1 .. 513;
135 function Root_Eq (N1, N2 : Root) return Boolean;
136 function H (B : Root) return Root_Range;
138 package Root_HTable is new GNAT.HTable.Simple_HTable (
139 Header_Num => Root_Range,
140 Element => Root_Id,
141 No_Element => No_Root_Id,
142 Key => Root,
143 Hash => H,
144 Equal => Root_Eq);
146 ----------------
147 -- Alloc_Size --
148 ----------------
150 function Alloc_Size (B : Root_Id) return Storage_Count is
151 begin
152 return Roots.Table (B).Alloc_Size;
153 end Alloc_Size;
155 -----------------
156 -- Enter_Frame --
157 -----------------
159 function Enter_Frame (Name, File, Line : Name_Id) return Frame_Id is
160 Res : Frame_Id;
162 begin
163 Frames.Increment_Last;
164 Frames.Table (Frames.Last) := Frame'(Name, File, Line);
165 Res := Frame_HTable.Get (Frames.Table (Frames.Last));
167 if Res /= No_Frame_Id then
168 Frames.Decrement_Last;
169 return Res;
171 else
172 Frame_HTable.Set (Frames.Table (Frames.Last), Frames.Last);
173 return Frames.Last;
174 end if;
175 end Enter_Frame;
177 ----------------
178 -- Enter_Name --
179 ----------------
181 function Enter_Name (S : String) return Name_Id is
182 Old_L : constant Integer := Chars.Last;
183 Len : constant Integer := S'Length;
184 F : constant Integer := Chars.Allocate (Len);
185 Res : Name_Id;
187 begin
188 Chars.Table (F .. F + Len - 1) := Chars.Table_Type (S);
189 Names.Increment_Last;
190 Names.Table (Names.Last) := Name'(F, F + Len - 1);
191 Res := Name_HTable.Get (Names.Table (Names.Last));
193 if Res /= No_Name_Id then
194 Names.Decrement_Last;
195 Chars.Set_Last (Old_L);
196 return Res;
198 else
199 Name_HTable.Set (Names.Table (Names.Last), Names.Last);
200 return Names.Last;
201 end if;
202 end Enter_Name;
204 ----------------
205 -- Enter_Root --
206 ----------------
208 function Enter_Root (Fr : Frame_Array) return Root_Id is
209 Old_L : constant Integer := Frames_In_Root.Last;
210 Len : constant Integer := Fr'Length;
211 F : constant Integer := Frames_In_Root.Allocate (Len);
212 Res : Root_Id;
214 begin
215 Frames_In_Root.Table (F .. F + Len - 1) :=
216 Frames_In_Root.Table_Type (Fr);
217 Roots.Increment_Last;
218 Roots.Table (Roots.Last) := Root'(F, F + Len - 1, 0, 0, 0);
219 Res := Root_HTable.Get (Roots.Table (Roots.Last));
221 if Res /= No_Root_Id then
222 Frames_In_Root.Set_Last (Old_L);
223 Roots.Decrement_Last;
224 return Res;
226 else
227 Root_HTable.Set (Roots.Table (Roots.Last), Roots.Last);
228 return Roots.Last;
229 end if;
230 end Enter_Root;
232 ---------------
233 -- Frames_Of --
234 ---------------
236 function Frames_Of (B : Root_Id) return Frame_Array is
237 begin
238 return Frame_Array (
239 Frames_In_Root.Table (Roots.Table (B).First .. Roots.Table (B).Last));
240 end Frames_Of;
242 ---------------
243 -- Get_First --
244 ---------------
246 function Get_First return Root_Id is
247 begin
248 return Root_HTable.Get_First;
249 end Get_First;
251 --------------
252 -- Get_Next --
253 --------------
255 function Get_Next return Root_Id is
256 begin
257 return Root_HTable.Get_Next;
258 end Get_Next;
260 -------
261 -- H --
262 -------
264 function H (B : Root) return Root_Range is
266 type Uns is mod 2 ** 32;
268 function Rotate_Left (Value : Uns; Amount : Natural) return Uns;
269 pragma Import (Intrinsic, Rotate_Left);
271 Tmp : Uns := 0;
273 begin
274 for J in B.First .. B.Last loop
275 Tmp := Rotate_Left (Tmp, 1) + Uns (Frames_In_Root.Table (J));
276 end loop;
278 return Root_Range'First
279 + Root_Range'Base (Tmp mod Root_Range'Range_Length);
280 end H;
282 function H (N : Name) return Name_Range is
283 function H is new Hash (Name_Range);
285 begin
286 return H (String (Chars.Table (N.First .. N.Last)));
287 end H;
289 function H (N : Frame) return Frame_Range is
290 begin
291 return Frame_Range (1 + (7 * N.Name + 13 * N.File + 17 * N.Line)
292 mod Frame_Range'Range_Length);
293 end H;
295 ---------------------
296 -- High_Water_Mark --
297 ---------------------
299 function High_Water_Mark (B : Root_Id) return Storage_Count is
300 begin
301 return Roots.Table (B).High_Water_Mark;
302 end High_Water_Mark;
304 -----------
305 -- Image --
306 -----------
308 function Image (N : Name_Id) return String is
309 Nam : Name renames Names.Table (N);
311 begin
312 return String (Chars.Table (Nam.First .. Nam.Last));
313 end Image;
315 function Image
316 (F : Frame_Id;
317 Max_Fil : Integer;
318 Max_Lin : Integer)
319 return String is
321 Fram : Frame renames Frames.Table (F);
322 Fil : Name renames Names.Table (Fram.File);
323 Lin : Name renames Names.Table (Fram.Line);
324 Nam : Name renames Names.Table (Fram.Name);
326 Fil_Len : constant Integer := Fil.Last - Fil.First + 1;
327 Lin_Len : constant Integer := Lin.Last - Lin.First + 1;
329 use type Chars.Table_Type;
331 Spaces : constant String (1 .. 80) := (1 .. 80 => ' ');
333 begin
334 return String (Chars.Table (Fil.First .. Fil.Last))
335 & ':'
336 & String (Chars.Table (Lin.First .. Lin.Last))
337 & Spaces (1 .. 1 + Max_Fil - Fil_Len + Max_Lin - Lin_Len)
338 & String (Chars.Table (Nam.First .. Nam.Last));
339 end Image;
341 -------------
342 -- Name_Eq --
343 -------------
345 function Name_Eq (N1, N2 : Name) return Boolean is
346 use type Chars.Table_Type;
347 begin
348 return
349 Chars.Table (N1.First .. N1.Last) = Chars.Table (N2.First .. N2.Last);
350 end Name_Eq;
352 --------------
353 -- Nb_Alloc --
354 --------------
356 function Nb_Alloc (B : Root_Id) return Integer is
357 begin
358 return Roots.Table (B).Nb_Alloc;
359 end Nb_Alloc;
361 --------------
362 -- Print_BT --
363 --------------
365 procedure Print_BT (B : Root_Id) is
366 Max_Col_Width : constant := 35;
367 -- Largest filename length for which backtraces will be
368 -- properly aligned. Frames containing longer names won't be
369 -- truncated but they won't be properly aligned either.
371 F : constant Frame_Array := Frames_Of (B);
373 Max_Fil : Integer;
374 Max_Lin : Integer;
376 begin
377 Max_Fil := 0;
378 Max_Lin := 0;
380 for J in F'Range loop
381 declare
382 Fram : Frame renames Frames.Table (F (J));
383 Fil : Name renames Names.Table (Fram.File);
384 Lin : Name renames Names.Table (Fram.Line);
386 begin
387 Max_Fil := Integer'Max (Max_Fil, Fil.Last - Fil.First + 1);
388 Max_Lin := Integer'Max (Max_Lin, Lin.Last - Lin.First + 1);
389 end;
390 end loop;
392 Max_Fil := Integer'Min (Max_Fil, Max_Col_Width);
394 for J in F'Range loop
395 Put (" ");
396 Put_Line (Image (F (J), Max_Fil, Max_Lin));
397 end loop;
398 end Print_BT;
400 -------------
401 -- Read_BT --
402 -------------
404 function Read_BT (BT_Depth : Integer; FT : File_Type) return Root_Id is
405 Max_Line : constant Integer := 500;
406 Curs1 : Integer;
407 Curs2 : Integer;
408 Line : String (1 .. Max_Line);
409 Last : Integer := 0;
410 Frames : Frame_Array (1 .. BT_Depth);
411 F : Integer := Frames'First;
412 Nam : Name_Id;
413 Fil : Name_Id;
414 Lin : Name_Id;
416 No_File : Boolean := False;
417 Main_Found : Boolean := False;
419 procedure Find_File;
420 -- Position Curs1 and Curs2 so that Line (Curs1 .. Curs2) contains
421 -- the file name. The file name may not be on the current line since
422 -- a frame may be printed on more than one line when there is a lot
423 -- of parameters or names are long, so this subprogram can read new
424 -- lines of input.
426 procedure Find_Line;
427 -- Position Curs1 and Curs2 so that Line (Curs1 .. Curs2) contains
428 -- the line number.
430 procedure Find_Name;
431 -- Position Curs1 and Curs2 so that Line (Curs1 .. Curs2) contains
432 -- the subprogram name.
434 procedure Gmem_Read_BT_Frame (Buf : out String; Last : out Natural);
435 -- GMEM functionality binding
437 ---------------
438 -- Find_File --
439 ---------------
441 procedure Find_File is
442 Match_Parent : Integer;
444 begin
445 -- Skip parameters
447 Curs1 := Curs2 + 3;
448 Match_Parent := 1;
449 while Curs1 <= Last loop
450 if Line (Curs1) = '(' then
451 Match_Parent := Match_Parent + 1;
452 elsif Line (Curs1) = ')' then
453 Match_Parent := Match_Parent - 1;
454 exit when Match_Parent = 0;
455 end if;
457 Curs1 := Curs1 + 1;
458 end loop;
460 -- Skip " at "
462 Curs1 := Curs1 + 5;
464 if Curs1 >= Last then
466 -- Maybe the file reference is on one of the next lines
468 Read : loop
469 Get_Line (FT, Line, Last);
471 -- If we have another Frame or if the backtrace is finished
472 -- the file reference was just missing
474 if Last <= 1 or else Line (1) = '#' then
475 No_File := True;
476 Curs2 := Curs1 - 1;
477 return;
479 else
480 Curs1 := 1;
481 while Curs1 <= Last - 2 loop
482 if Line (Curs1) = '(' then
483 Match_Parent := Match_Parent + 1;
484 elsif Line (Curs1) = ')' then
485 Match_Parent := Match_Parent - 1;
486 end if;
488 if Match_Parent = 0
489 and then Line (Curs1 .. Curs1 + 1) = "at"
490 then
491 Curs1 := Curs1 + 3;
492 exit Read;
493 end if;
495 Curs1 := Curs1 + 1;
496 end loop;
497 end if;
498 end loop Read;
499 end if;
501 -- Let's assume that the filename length is greater than 1
502 -- it simplifies dealing with the potential drive ':' on
503 -- windows systems
505 Curs2 := Curs1 + 1;
506 while Line (Curs2 + 1) /= ':' loop Curs2 := Curs2 + 1; end loop;
507 end Find_File;
509 ---------------
510 -- Find_Line --
511 ---------------
513 procedure Find_Line is
514 begin
515 Curs1 := Curs2 + 2;
516 Curs2 := Last;
517 if Curs2 - Curs1 > 5 then
518 raise Constraint_Error;
519 end if;
520 end Find_Line;
522 ---------------
523 -- Find_Name --
524 ---------------
526 procedure Find_Name is
527 begin
528 Curs1 := 3;
530 -- Skip Frame #
532 while Line (Curs1) /= ' ' loop Curs1 := Curs1 + 1; end loop;
534 -- Skip spaces
536 while Line (Curs1) = ' ' loop Curs1 := Curs1 + 1; end loop;
538 Curs2 := Curs1;
539 while Line (Curs2 + 1) /= ' ' loop Curs2 := Curs2 + 1; end loop;
540 end Find_Name;
542 ------------------------
543 -- Gmem_Read_BT_Frame --
544 ------------------------
546 procedure Gmem_Read_BT_Frame (Buf : out String; Last : out Natural) is
547 procedure Read_BT_Frame (buf : System.Address);
548 pragma Import (C, Read_BT_Frame, "__gnat_gmem_read_bt_frame");
550 function Strlen (chars : System.Address) return Natural;
551 pragma Import (C, Strlen, "strlen");
553 S : String (1 .. 1000);
554 begin
555 Read_BT_Frame (S'Address);
556 Last := Strlen (S'Address);
557 Buf (1 .. Last) := S (1 .. Last);
558 end Gmem_Read_BT_Frame;
560 -- Start of processing for Read_BT
562 begin
564 if Gmem_Mode then
565 Gmem_Read_BT_Frame (Line, Last);
566 else
567 Line (1) := ' ';
568 while Line (1) /= '#' loop
569 Get_Line (FT, Line, Last);
570 end loop;
571 end if;
573 while Last >= 1 and then Line (1) = '#' and then not Main_Found loop
574 if F <= BT_Depth then
575 Find_Name;
576 -- Skip the __gnat_malloc frame itself
577 if Line (Curs1 .. Curs2) /= "<__gnat_malloc>" then
578 Nam := Enter_Name (Line (Curs1 .. Curs2));
579 Main_Found := Line (Curs1 .. Curs2) = "main";
581 Find_File;
583 if No_File then
584 Fil := No_Name_Id;
585 Lin := No_Name_Id;
586 else
587 Fil := Enter_Name (Line (Curs1 .. Curs2));
589 Find_Line;
590 Lin := Enter_Name (Line (Curs1 .. Curs2));
591 end if;
593 Frames (F) := Enter_Frame (Nam, Fil, Lin);
594 F := F + 1;
595 end if;
596 end if;
598 if No_File then
600 -- If no file reference was found, the next line has already
601 -- been read because, it may sometimes be found on the next
602 -- line
604 No_File := False;
606 else
607 if Gmem_Mode then
608 Gmem_Read_BT_Frame (Line, Last);
609 else
610 Get_Line (FT, Line, Last);
611 exit when End_Of_File (FT);
612 end if;
613 end if;
615 end loop;
617 return Enter_Root (Frames (1 .. F - 1));
618 end Read_BT;
620 -------------
621 -- Root_Eq --
622 -------------
624 function Root_Eq (N1, N2 : Root) return Boolean is
625 use type Frames_In_Root.Table_Type;
627 begin
628 return
629 Frames_In_Root.Table (N1.First .. N1.Last)
630 = Frames_In_Root.Table (N2.First .. N2.Last);
631 end Root_Eq;
633 --------------------
634 -- Set_Alloc_Size --
635 --------------------
637 procedure Set_Alloc_Size (B : Root_Id; V : Storage_Count) is
638 begin
639 Roots.Table (B).Alloc_Size := V;
640 end Set_Alloc_Size;
642 -------------------------
643 -- Set_High_Water_Mark --
644 -------------------------
646 procedure Set_High_Water_Mark (B : Root_Id; V : Storage_Count) is
647 begin
648 Roots.Table (B).High_Water_Mark := V;
649 end Set_High_Water_Mark;
651 ------------------
652 -- Set_Nb_Alloc --
653 ------------------
655 procedure Set_Nb_Alloc (B : Root_Id; V : Integer) is
656 begin
657 Roots.Table (B).Nb_Alloc := V;
658 end Set_Nb_Alloc;
660 begin
661 -- Initialize name for No_Name_ID
663 Names.Increment_Last;
664 Names.Table (Names.Last) := Name'(1, 0);
665 end Memroot;