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 / i-cpoint.adb < prev    next >
Text File  |  1996-09-28  |  8KB  |  273 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --                I N T E R F A C E S . C . P O I N T E R S                 --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.8 $                              --
  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. with Interfaces.C.Strings; use Interfaces.C.Strings;
  27. with System;               use System;
  28.  
  29. with Unchecked_Conversion;
  30.  
  31. package body Interfaces.C.Pointers is
  32.  
  33.    type Addr is mod Memory_Size;
  34.  
  35.    function To_Pointer is new Unchecked_Conversion (Addr,      Pointer);
  36.    function To_Addr    is new Unchecked_Conversion (Pointer,   Addr);
  37.    function To_Addr    is new Unchecked_Conversion (ptrdiff_t, Addr);
  38.    function To_Ptrdiff is new Unchecked_Conversion (Addr,      ptrdiff_t);
  39.  
  40.    Elmt_Size : ptrdiff_t :=
  41.                  (Element'Size + Storage_Unit - 1) / Storage_Unit;
  42.  
  43.    subtype Index_Base is Index'Base;
  44.  
  45.    ---------
  46.    -- "+" --
  47.    ---------
  48.  
  49.    function "+" (Left : in Pointer;   Right : in ptrdiff_t) return Pointer is
  50.    begin
  51.       if Left = null then
  52.          raise Pointer_Error;
  53.       end if;
  54.  
  55.       return To_Pointer (To_Addr (Left) + To_Addr (Elmt_Size * Right));
  56.    end "+";
  57.  
  58.    function "+" (Left : in ptrdiff_t; Right : in Pointer) return Pointer is
  59.    begin
  60.       if Right = null then
  61.          raise Pointer_Error;
  62.       end if;
  63.  
  64.       return To_Pointer (To_Addr (Elmt_Size * Left) + To_Addr (Right));
  65.    end "+";
  66.  
  67.    ---------
  68.    -- "-" --
  69.    ---------
  70.  
  71.    function "-" (Left : in Pointer; Right : in ptrdiff_t) return Pointer is
  72.    begin
  73.       if Left = null then
  74.          raise Pointer_Error;
  75.       end if;
  76.  
  77.       return To_Pointer (To_Addr (Left) - To_Addr (Right * Elmt_Size));
  78.    end "-";
  79.  
  80.  
  81.    function "-" (Left : in Pointer; Right : in Pointer) return ptrdiff_t is
  82.    begin
  83.       if Left = null or else Right = null then
  84.          raise Pointer_Error;
  85.       end if;
  86.  
  87.       return To_Ptrdiff (To_Addr (Left) - To_Addr (Right)) / Elmt_Size;
  88.    end "-";
  89.  
  90.    ----------------
  91.    -- Copy_Array --
  92.    ----------------
  93.  
  94.    procedure Copy_Array
  95.      (Source  : in Pointer;
  96.       Target  : in Pointer;
  97.       Length  : in ptrdiff_t)
  98.    is
  99.       T : Pointer := Target;
  100.       S : Pointer := Source;
  101.  
  102.    begin
  103.       if S = null or else T = null then
  104.          raise Dereference_Error;
  105.  
  106.       else
  107.          for J in 1 .. Length loop
  108.             T.all := S.all;
  109.             Increment (T);
  110.             Increment (S);
  111.          end loop;
  112.       end if;
  113.    end Copy_Array;
  114.  
  115.    ---------------------------
  116.    -- Copy_Terminated_Array --
  117.    ---------------------------
  118.  
  119.    procedure Copy_Terminated_Array
  120.      (Source     : in Pointer;
  121.       Target     : in Pointer;
  122.       Limit      : in ptrdiff_t := ptrdiff_t'Last;
  123.       Terminator : in Element := Default_Terminator)
  124.    is
  125.       S : Pointer   := Source;
  126.       T : Pointer   := Target;
  127.       L : ptrdiff_t := Limit;
  128.  
  129.    begin
  130.       if S = null or else T = null then
  131.          raise Dereference_Error;
  132.  
  133.       else
  134.          while S.all /= Terminator and then L > 0 loop
  135.             T.all := S.all;
  136.             Increment (T);
  137.             Increment (S);
  138.             L := L - 1;
  139.          end loop;
  140.       end if;
  141.    end Copy_Terminated_Array;
  142.  
  143.    ---------------
  144.    -- Decrement --
  145.    ---------------
  146.  
  147.    procedure Decrement (Ref : in out Pointer) is
  148.    begin
  149.       Ref := Ref - 1;
  150.    end Decrement;
  151.  
  152.    ---------------
  153.    -- Increment --
  154.    ---------------
  155.  
  156.    procedure Increment (Ref : in out Pointer) is
  157.    begin
  158.       Ref := Ref + 1;
  159.    end Increment;
  160.  
  161.    -----------
  162.    -- Value --
  163.    -----------
  164.  
  165.    function Value
  166.      (Ref        : in Pointer;
  167.       Terminator : in Element := Default_Terminator)
  168.       return       Element_Array
  169.    is
  170.       P : Pointer;
  171.       L : constant Index_Base := Index'First;
  172.       H : Index_Base;
  173.  
  174.    begin
  175.       if Ref = null then
  176.          raise Dereference_Error;
  177.  
  178.       else
  179.          H := L;
  180.          P := Ref;
  181.  
  182.          loop
  183.             exit when P.all = Terminator;
  184.             H := Index_Base'Succ (H);
  185.             Increment (P);
  186.          end loop;
  187.  
  188.          declare
  189.             subtype A is Element_Array (L .. H);
  190.  
  191.             type PA is access A;
  192.             function To_PA is new Unchecked_Conversion (Pointer, PA);
  193.  
  194.          begin
  195.             return To_PA (Ref).all;
  196.          end;
  197.       end if;
  198.    end Value;
  199.  
  200.    function Value
  201.      (Ref    : in Pointer;
  202.       Length : in ptrdiff_t)
  203.       return   Element_Array
  204.    is
  205.       P : Pointer;
  206.       L : Index_Base;
  207.       H : Index_Base;
  208.  
  209.    begin
  210.       if Ref = null then
  211.          raise Dereference_Error;
  212.  
  213.       --  For length zero, we need to returna null slice, but we can't make
  214.       --  the bounds of this slice Index'First, since this could cause a
  215.       --  Constraint_Error if Index'First = Index'Base'First.
  216.  
  217.       elsif Length <= 0 then
  218.          declare
  219.             X : Element_Array (Index'Succ (Index'First) .. Index'First);
  220.  
  221.          begin
  222.             return X;
  223.          end;
  224.  
  225.       --  Normal case (length non-zero)
  226.  
  227.       else
  228.          L := Index'First;
  229.          H := Index'Val (Index'Pos (Index'First) + Length - 1);
  230.  
  231.          declare
  232.             subtype A is Element_Array (L .. H);
  233.  
  234.             type PA is access A;
  235.             function To_PA is new Unchecked_Conversion (Pointer, PA);
  236.  
  237.          begin
  238.             return To_PA (Ref).all;
  239.          end;
  240.       end if;
  241.    end Value;
  242.  
  243.    --------------------
  244.    -- Virtual_Length --
  245.    --------------------
  246.  
  247.    function Virtual_Length
  248.      (Ref        : in Pointer;
  249.       Terminator : in Element := Default_Terminator)
  250.       return       ptrdiff_t
  251.    is
  252.       P : Pointer;
  253.       C : ptrdiff_t;
  254.  
  255.    begin
  256.       if Ref = null then
  257.          raise Dereference_Error;
  258.  
  259.       else
  260.          C := 0;
  261.          P := Ref;
  262.  
  263.          while P.all /= Terminator loop
  264.             C := C + 1;
  265.             Increment (P);
  266.          end loop;
  267.  
  268.          return C;
  269.       end if;
  270.    end Virtual_Length;
  271.  
  272. end Interfaces.C.Pointers;
  273.