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 / output.adb < prev    next >
Text File  |  1996-09-28  |  5KB  |  207 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --                               O U T P U T                                --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.27 $                             --
  10. --                                                                          --
  11. --        Copyright (c) 1992,1993,1994,1995 NYU, All Rights Reserved        --
  12. --                                                                          --
  13. -- The GNAT library is free software; you can redistribute it and/or modify --
  14. -- it under terms of the GNU Library General Public License as published by --
  15. -- the Free Software  Foundation; either version 2, or (at your option) any --
  16. -- later version.  The GNAT library is distributed in the hope that it will --
  17. -- be useful, but WITHOUT ANY WARRANTY;  without even  the implied warranty --
  18. -- of MERCHANTABILITY  or  FITNESS FOR  A PARTICULAR PURPOSE.  See the  GNU --
  19. -- Library  General  Public  License for  more  details.  You  should  have --
  20. -- received  a copy of the GNU  Library  General Public License  along with --
  21. -- the GNAT library;  see the file  COPYING.LIB.  If not, write to the Free --
  22. -- Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.        --
  23. --                                                                          --
  24. ------------------------------------------------------------------------------
  25.  
  26. package body Output is
  27.  
  28.    Current_Column : Int := 1;
  29.    --  Current column number
  30.  
  31.    Current_FD : File_Descriptor := Standout;
  32.    --  File descriptor for current output
  33.  
  34.    Saved_FD : File_Descriptor;
  35.  
  36.    -------------
  37.    --  Column --
  38.    -------------
  39.  
  40.    function Column return Int is
  41.    begin
  42.       return Current_Column;
  43.    end Column;
  44.  
  45.    -----------------------
  46.    -- Restore_Output_FD --
  47.    -----------------------
  48.  
  49.    procedure Restore_Output_FD is
  50.    begin
  51.       Current_FD := Saved_FD;
  52.    end Restore_Output_FD;
  53.  
  54.    -------------------
  55.    -- Set_Output_FD --
  56.    -------------------
  57.  
  58.    procedure Set_Output_FD (FD : File_Descriptor) is
  59.    begin
  60.       Saved_FD   := Current_FD;
  61.       Current_FD := FD;
  62.    end Set_Output_FD;
  63.  
  64.    ------------------------
  65.    -- Set_Standard_Error --
  66.    ------------------------
  67.  
  68.    procedure Set_Standard_Error is
  69.    begin
  70.       Current_FD := Standerr;
  71.    end Set_Standard_Error;
  72.  
  73.    -------------------------
  74.    -- Set_Standard_Output --
  75.    -------------------------
  76.  
  77.    procedure Set_Standard_Output is
  78.    begin
  79.       Current_FD := Standout;
  80.    end Set_Standard_Output;
  81.  
  82.    ----------------
  83.    -- Write_Char --
  84.    ----------------
  85.  
  86.    procedure Write_Char (C : Character) is
  87.    begin
  88.       if 1 = Write (Current_FD, C'Address, 1) then
  89.          Current_Column := Current_Column + 1;
  90.  
  91.       else
  92.          Set_Standard_Error;
  93.          Write_Str ("fatal error: disk full");
  94.          OS_Exit (2);
  95.       end if;
  96.    end Write_Char;
  97.  
  98.    ---------------
  99.    -- Write_Eol --
  100.    ---------------
  101.  
  102.    procedure Write_Eol is
  103.    begin
  104.       Write_Char (Ascii.LF);
  105.       Current_Column := 1;
  106.    end Write_Eol;
  107.  
  108.    ---------------
  109.    -- Write_Int --
  110.    ---------------
  111.  
  112.    procedure Write_Int (I : Int) is
  113.    begin
  114.  
  115.       if I < 0 then
  116.          Write_Char ('-');
  117.          Write_Int (-I);
  118.  
  119.       else
  120.          if I > 9 then
  121.             Write_Int (I / 10);
  122.          end if;
  123.  
  124.          Write_Char (Character'Val ((I mod 10) + Character'Pos ('0')));
  125.       end if;
  126.    end Write_Int;
  127.  
  128.    ---------------
  129.    -- Write_Str --
  130.    ---------------
  131.  
  132.    procedure Write_Str (S : String) is
  133.    begin
  134.       if S'Length = Write (Current_FD, S'Address, S'Length) then
  135.          Current_Column := Current_Column + S'Length;
  136.  
  137.       else
  138.          Set_Standard_Error;
  139.          Write_Str ("fatal error: disk full");
  140.          OS_Exit (2);
  141.       end if;
  142.  
  143.    end Write_Str;
  144.  
  145.    --------------------------
  146.    -- Debugging Procedures --
  147.    --------------------------
  148.  
  149.    procedure w (C : Character) is
  150.    begin
  151.       Write_Char (''');
  152.       Write_Char (C);
  153.       Write_Char (''');
  154.       Write_Eol;
  155.    end w;
  156.  
  157.    procedure w (S : String) is
  158.    begin
  159.       Write_Str (S);
  160.       Write_Eol;
  161.    end w;
  162.  
  163.    procedure w (I : Int) is
  164.    begin
  165.       Write_Int (I);
  166.       Write_Eol;
  167.    end w;
  168.  
  169.    procedure w (B : Boolean) is
  170.    begin
  171.       if B then
  172.          w ("True");
  173.       else
  174.          w ("False");
  175.       end if;
  176.    end w;
  177.  
  178.    procedure w (L : String; C : Character) is
  179.    begin
  180.       Write_Str (L);
  181.       Write_Char (' ');
  182.       w (C);
  183.    end w;
  184.  
  185.    procedure w (L : String; S : String) is
  186.    begin
  187.       Write_Str (L);
  188.       Write_Char (' ');
  189.       w (S);
  190.    end w;
  191.  
  192.    procedure w (L : String; I : Int) is
  193.    begin
  194.       Write_Str (L);
  195.       Write_Char (' ');
  196.       w (I);
  197.    end w;
  198.  
  199.    procedure w (L : String; B : Boolean) is
  200.    begin
  201.       Write_Str (L);
  202.       Write_Char (' ');
  203.       w (B);
  204.    end w;
  205.  
  206. end Output;
  207.