home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / gnat-2.06-src.tgz / tar.out / fsf / gnat / ada / comperr.adb < prev    next >
Text File  |  1996-09-28  |  7KB  |  201 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --                              C O M P E R R                               --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.36 $                             --
  10. --                                                                          --
  11. --           Copyright (c) 1992,1993,1994 NYU, All Rights Reserved          --
  12. --                                                                          --
  13. -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14. -- terms of the  GNU General Public License as published  by the Free Soft- --
  15. -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16. -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17. -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18. -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19. -- for  more details.  You should have  received  a copy of the GNU General --
  20. -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21. -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. --
  22. --                                                                          --
  23. ------------------------------------------------------------------------------
  24.  
  25. --  This package contains routines called when a fatal internal compiler
  26. --  error is detected. Calls to these routines cause termination of the
  27. --  current compilation with appropriate error output.
  28.  
  29. with Atree;    use Atree;
  30. with Debug;    use Debug;
  31. with Errout;   use Errout;
  32. with Gnatvsn;
  33. with Osint;    use Osint;
  34. with Output;   use Output;
  35. with Sinput;   use Sinput;
  36. with Sprint;   use Sprint;
  37. with Sdefault; use Sdefault;
  38. with Treepr;   use Treepr;
  39.  
  40. with System.Assertions; use System.Assertions;
  41.  
  42. package body Comperr is
  43.  
  44.    -----------------------
  45.    -- Local Subprograms --
  46.    -----------------------
  47.  
  48.    procedure Repeat_Char (Char : Character; Col : Nat; After : Character);
  49.    --  Output Char until current column is at or past Col, and then output
  50.    --  the character given by After (if column is already past Col on entry,
  51.    --  then the effect is simply to output the After character).
  52.  
  53.    --------------------
  54.    -- Compiler_Abort --
  55.    --------------------
  56.  
  57.    procedure Compiler_Abort (X : String; Code : Integer := 0) is
  58.  
  59.       procedure End_Line;
  60.       --  Add blanks up to column 76, and then a final vertical bar
  61.  
  62.       procedure End_Line is
  63.       begin
  64.          Repeat_Char (' ', 76, '|');
  65.          Write_Eol;
  66.       end End_Line;
  67.  
  68.    --  Start of processing for Compiler_Abort
  69.  
  70.    begin
  71.       --  If errors have already occured, then we guess that the abort may
  72.       --  well be caused by previous errors, and we don't make too much fuss
  73.       --  about it, since we want to let the programmer fix the errors first.
  74.  
  75.       --  Debug flag K disables this behavior (useful for debugging)
  76.  
  77.       if Errors_Detected /= 0 and then not Debug_Flag_K then
  78.          raise Unrecoverable_Error;
  79.  
  80.       --  Otherwise give message with details of the abort'
  81.  
  82.       else
  83.          Set_Standard_Error;
  84.          Write_Char ('+');
  85.          Repeat_Char ('=', 29, 'G');
  86.          Write_Str ("NAT BUG DETECTED");
  87.          Repeat_Char ('=', 76, '+');
  88.          Write_Eol;
  89.  
  90.          if Sloc (Fatal_Error_Node) <= Standard_Location
  91.            or else Sloc (Fatal_Error_Node) = No_Location
  92.          then
  93.             Write_Str ("| No source file position information available");
  94.             End_Line;
  95.          else
  96.             Write_Str ("| Error detected at ");
  97.             Write_Location (Sloc (Fatal_Error_Node));
  98.             End_Line;
  99.          end if;
  100.  
  101.          Write_Str
  102.            ("| Please submit bug report by email to gnat-report@cs.nyu.edu");
  103.          End_Line;
  104.  
  105.          Write_Str
  106.            ("| Use a subject line meaningful to you and us to track the bug");
  107.          End_Line;
  108.  
  109.          Write_Str
  110.            ("| Include full sources in ASCII in a format " &
  111.             "compatible with gnatchop");
  112.          End_Line;
  113.  
  114.          Write_Str
  115.            ("| First line of sources must be marked by an Ada " &
  116.             "-- comment line");
  117.          End_Line;
  118.  
  119.          Write_Str
  120.            ("| Last line of sources must be last line of " &
  121.             "email message (no signature!)");
  122.          End_Line;
  123.  
  124.          Write_Str
  125.            ("| See gnatinfo.txt file for more info on procedure " &
  126.             "for submitting bugs");
  127.          End_Line;
  128.  
  129.          Write_Str ("| GNAT V");
  130.          Write_Str (Gnatvsn.GNAT_Version_String);
  131.          Write_Str (" (");
  132.  
  133.          --  Output target name, deleting junk final reverse slash
  134.  
  135.          if Target_Name.all (Target_Name.all'Last) = '\'
  136.            or else Target_Name.all (Target_Name.all'Last) = '/'
  137.          then
  138.             Write_Str (Target_Name.all (1 .. Target_Name.all'Last - 1));
  139.          else
  140.             Write_Str (Target_Name.all);
  141.          end if;
  142.  
  143.          Write_Str (") ");
  144.  
  145.          Write_Str (X);
  146.  
  147.          if Code /= 0 then
  148.             Write_Str (", Code=");
  149.             Write_Int (Int (Code));
  150.          end if;
  151.  
  152.          if Assert_Msg_Length /= 0 then
  153.             Write_Str (" at ");
  154.  
  155.             if Assert_Msg (Assert_Msg_Length) = Ascii.NUL then
  156.                Assert_Msg_Length := Assert_Msg_Length - 1;
  157.             end if;
  158.  
  159.             Write_Str (Assert_Msg (1 .. Assert_Msg_Length));
  160.          end if;
  161.  
  162.          End_Line;
  163.  
  164.          Write_Char ('+');
  165.          Repeat_Char ('=', 76, '+');
  166.          Write_Eol;
  167.  
  168.          --  Otherwise output additional diagnostic information and terminate
  169.          --  with a compilation abandoned message, but don't abort, instead
  170.          --  raise Unrecoverable_Error to generate compilation abandoned msg.
  171.  
  172.          if Debug_Flag_3 then
  173.             Write_Eol;
  174.             Write_Eol;
  175.             Print_Tree_Node (Fatal_Error_Node);
  176.             Write_Eol;
  177.          end if;
  178.  
  179.          Set_Standard_Output;
  180.          Tree_Dump;
  181.          Source_Dump;
  182.          raise Unrecoverable_Error;
  183.       end if;
  184.  
  185.    end Compiler_Abort;
  186.  
  187.    -----------------
  188.    -- Repeat_Char --
  189.    -----------------
  190.  
  191.    procedure Repeat_Char (Char : Character; Col : Nat; After : Character) is
  192.    begin
  193.       while Column < Col loop
  194.          Write_Char (Char);
  195.       end loop;
  196.  
  197.       Write_Char (After);
  198.    end Repeat_Char;
  199.  
  200. end Comperr;
  201.