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 / s-imgbiu.adb < prev    next >
Text File  |  1996-09-28  |  5KB  |  148 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT RUNTIME COMPONENTS                          --
  4. --                                                                          --
  5. --                       S Y S T E M . I M G _ B I U                        --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.4 $                              --
  10. --                                                                          --
  11. --           Copyright (c) 1992,1993,1994 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. with System.Unsigned_Types; use System.Unsigned_Types;
  27.  
  28. package body System.Img_BIU is
  29.  
  30.    -----------------------------
  31.    -- Set_Image_Based_Integer --
  32.    -----------------------------
  33.  
  34.    procedure Set_Image_Based_Integer
  35.      (V : Integer;
  36.       B : Natural;
  37.       W : Integer;
  38.       S : out String;
  39.       P : in out Natural)
  40.    is
  41.       Start : Natural;
  42.  
  43.    begin
  44.       --  Positive case can just use the unsigned circuit directly
  45.  
  46.       if V >= 0 then
  47.          Set_Image_Based_Unsigned (Unsigned (V), B, W, S, P);
  48.  
  49.       --  Negative case has to set a minus sign. Note also that we have to be
  50.       --  careful not to generate overflow with the largest negative number.
  51.  
  52.       else
  53.          P := P + 1;
  54.          S (P) := ' ';
  55.          Start := P;
  56.  
  57.          begin
  58.             pragma Suppress (Overflow_Check);
  59.             pragma Suppress (Range_Check);
  60.             Set_Image_Based_Unsigned (Unsigned (-V), B, W - 1, S, P);
  61.          end;
  62.  
  63.          --  Set minus sign in last leading blank location. Because of the
  64.          --  code above, there must be at least one such location.
  65.  
  66.          while S (Start + 1) = ' ' loop
  67.             Start := Start + 1;
  68.          end loop;
  69.  
  70.          S (Start) := '-';
  71.       end if;
  72.  
  73.    end Set_Image_Based_Integer;
  74.  
  75.    ------------------------------
  76.    -- Set_Image_Based_Unsigned --
  77.    ------------------------------
  78.  
  79.    procedure Set_Image_Based_Unsigned
  80.      (V : Unsigned;
  81.       B : Natural;
  82.       W : Integer;
  83.       S : out String;
  84.       P : in out Natural)
  85.    is
  86.       Start : constant Natural := P;
  87.       F, T  : Natural;
  88.       BU    : constant Unsigned := Unsigned (B);
  89.       Hex   : constant array
  90.                 (Unsigned range 0 .. 15) of Character := "0123456789ABCDEF";
  91.  
  92.       procedure Set_Digits (T : Unsigned);
  93.       --  Set digits of absolute value of T
  94.  
  95.       procedure Set_Digits (T : Unsigned) is
  96.       begin
  97.          if T >= BU then
  98.             Set_Digits (T / BU);
  99.             P := P + 1;
  100.             S (P) := Hex (T mod BU);
  101.          else
  102.             P := P + 1;
  103.             S (P) := Hex (T);
  104.          end if;
  105.       end Set_Digits;
  106.  
  107.    --  Start of processing for Set_Image_Based_Unsigned
  108.  
  109.    begin
  110.  
  111.       if B >= 10 then
  112.          P := P + 1;
  113.          S (P) := '1';
  114.       end if;
  115.  
  116.       P := P + 1;
  117.       S (P) := Character'Val (Character'Pos ('0') + B mod 10);
  118.  
  119.       P := P + 1;
  120.       S (P) := '#';
  121.  
  122.       Set_Digits (V);
  123.  
  124.       P := P + 1;
  125.       S (P) := '#';
  126.  
  127.       --  Add leading spaces if required by width parameter
  128.  
  129.       if P - Start < W then
  130.          F := P;
  131.          P := Start + W;
  132.          T := P;
  133.  
  134.          while F > Start loop
  135.             S (T) := S (F);
  136.             T := T - 1;
  137.             F := F - 1;
  138.          end loop;
  139.  
  140.          for J in Start + 1 .. T loop
  141.             S (J) := ' ';
  142.          end loop;
  143.       end if;
  144.  
  145.    end Set_Image_Based_Unsigned;
  146.  
  147. end System.Img_BIU;
  148.