- -----------------------
- -- Create_Gdb_Script --
- -----------------------
-
- procedure Create_Gdb_Script is
- FD : File_Type;
-
- begin
- begin
- Create (FD, Out_File, Gnatmem_Tmp);
- exception
- when others =>
- Put_Line ("Cannot create temporary file : " & Gnatmem_Tmp);
- GNAT.OS_Lib.OS_Exit (1);
- end;
-
- declare
- TTY : constant String := Get_Current_TTY;
- begin
- if TTY'Length > 0 then
- Put_Line (FD, "tty " & TTY);
- end if;
- end;
-
- if Cross_Case then
- Put (FD, "target ");
- Put (FD, Target_Protocol (1 .. Target_Protocol_Len));
- Put (FD, " ");
- Put (FD, Argument (Target_Pos));
- New_Line (FD);
- Put (FD, "load ");
- Put_Line (FD, Argument (Exec_Pos));
-
- else
- -- In the native case, run the program before setting the
- -- breakpoints so that gnatmem will also work with shared
- -- libraries.
-
- Put_Line (FD, "set lang c");
- Put_Line (FD, "break main");
- Put_Line (FD, "set lang auto");
- Put (FD, "run");
- for J in Exec_Pos + 1 .. Argc loop
- Put (FD, " ");
- Put (FD, Argument (J));
- end loop;
- New_Line (FD);
-
- -- At this point, gdb knows about __gnat_malloc and __gnat_free
- end if;
-
- -- Make sure that outputing long backtraces do not pause
-
- Put_Line (FD, "set height 0");
- Put_Line (FD, "set width 0");
-
- if Quiet_Mode then
- Put_Line (FD, "break __gnat_malloc");
- Put_Line (FD, "command");
- Put_Line (FD, " silent");
- Put_Line (FD, " set lang c");
- Put_Line (FD, " set print address on");
- Put_Line (FD, " finish");
- Put_Line (FD, " set $gm_addr = $");
- Put_Line (FD, " printf ""\n\n""");
- Put_Line (FD, " printf ""ALLOC^0x%x^\n"", $gm_addr");
- Put_Line (FD, " set print address off");
- Put_Line (FD, " set lang auto");
- else
- Put_Line (FD, "break __gnat_malloc");
- Put_Line (FD, "command");
- Put_Line (FD, " silent");
- Put_Line (FD, " set lang c");
- Put_Line (FD, " set $gm_size = size");
- Put_Line (FD, " set print address on");
- Put_Line (FD, " finish");
- Put_Line (FD, " set $gm_addr = $");
- Put_Line (FD, " printf ""\n\n""");
- Put_Line (FD, " printf ""ALLOC^%d^0x%x^\n"", $gm_size, $gm_addr");
- Put_Line (FD, " set print address off");
- Put_Line (FD, " set lang auto");
- end if;
-
- Put (FD, " backtrace");
-
- if BT_Depth /= 0 then
- Put (FD, Integer'Image (BT_Depth));
- end if;
-
- New_Line (FD);
-
- Put_Line (FD, " printf ""\n\n""");
- Put_Line (FD, " continue");
- Put_Line (FD, "end");
- Put_Line (FD, "#");
- Put_Line (FD, "#");
- Put_Line (FD, "break __gnat_free");
- Put_Line (FD, "command");
- Put_Line (FD, " silent");
- Put_Line (FD, " set print address on");
- Put_Line (FD, " printf ""\n\n""");
- Put_Line (FD, " printf ""DEALL^0x%x^\n"", ptr");
- Put_Line (FD, " set print address off");
- Put_Line (FD, " finish");
-
- Put (FD, " backtrace");
-
- if BT_Depth /= 0 then
- Put (FD, Integer'Image (BT_Depth));
- end if;
-
- New_Line (FD);
-
- Put_Line (FD, " printf ""\n\n""");
- Put_Line (FD, " continue");
- Put_Line (FD, "end");
- Put_Line (FD, "#");
- Put_Line (FD, "#");
- Put_Line (FD, "#");
-
- if Cross_Case then
- Put (FD, "run ");
- Put_Line (FD, Argument (Exec_Pos));
-
- if Target_Protocol (1 .. Target_Protocol_Len) = "wtx" then
- Put (FD, "unload ");
- Put_Line (FD, Argument (Exec_Pos));
- end if;
- else
- Put_Line (FD, "continue");
- end if;
-
- Close (FD);
- end Create_Gdb_Script;
-