gcc/testsuite/ada/acats/tests/cxb/cxb30132.am

   1 -- CXB30132.AM
   2 --
   3 --                             Grant of Unlimited Rights
   4 --
   5 --     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
   6 --     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
   7 --     unlimited rights in the software and documentation contained herein.
   8 --     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making
   9 --     this public release, the Government intends to confer upon all
  10 --     recipients unlimited rights  equal to those held by the Government.
  11 --     These rights include rights to use, duplicate, release or disclose the
  12 --     released technical data and computer software in whole or in part, in
  13 --     any manner and for any purpose whatsoever, and to have or permit others
  14 --     to do so.
  15 --
  16 --                                    DISCLAIMER
  17 --
  18 --     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
  19 --     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
  20 --     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
  21 --     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
  22 --     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
  23 --     PARTICULAR PURPOSE OF SAID MATERIAL.
  24 --*
  25 --
  26 -- OBJECTIVE:
  27 --      Check that imported, user-defined C language functions can be
  28 --      called from an Ada program.
  29 --
  30 -- TEST DESCRIPTION:
  31 --      This test checks that user-defined C language functions can be
  32 --      imported and referenced from an Ada program.  Two C language
  33 --      functions are specified in files CXB30130.C and CXB30131.C.
  34 --      These two functions are imported to this test program, using two
  35 --      calls to Pragma Import.  Each function is then called in this test,
  36 --      and the results of the call are verified.
  37 --
  38 --      This test assumes that the following characters are all included
  39 --      in the implementation defined type Interfaces.C.char:
  40 --      ' ', 'a'..'z', and 'A'..'Z'.
  41 --
  42 -- APPLICABILITY CRITERIA:
  43 --      This test is applicable to all implementations that provide
  44 --      packages Interfaces.C and Interfaces.C.Strings.  If an
  45 --      implementation provides packages Interfaces.C and
  46 --      Interfaces.C.Strings, this test must compile, execute, and
  47 --      report "PASSED".
  48 --
  49 -- SPECIAL REQUIREMENTS:
  50 --      The files CXB30130.C and CXB30131.C must be compiled with a C
  51 --      compiler.  Implementation dialects of C may require alteration of
  52 --      the C program syntax (see individual C files).
  53 --
  54 --      Note that the compiled C code must be bound with the compiled Ada
  55 --      code to create an executable image.  An implementation must provide
  56 --      the necessary commands to accomplish this.
  57 --
  58 --      Note that the C code included in CXB30130.C and CXB30131.C conforms
  59 --      to ANSI-C.  Modifications to these files may be required for other
  60 --      C compilers.  An implementation must provide the necessary
  61 --      modifications to satisfy the function requirements.
  62 --
  63 -- TEST FILES:
  64 --      The following files comprise this test:
  65 --
  66 --         CXB30130.C
  67 --         CXB30131.C
  68 --         CXB30132.AM
  69 --
  70 --
  71 -- CHANGE HISTORY:
  72 --      13 Oct 95   SAIC    Initial prerelease version.
  73 --      13 May 96   SAIC    Incorporated reviewer comments for ACVC 2.1.
  74 --      26 Oct 96   SAIC    Incorporated reviewer comments.
  75 --
  76 --!
  77
  78 with Report;
  79 with Impdef;
  80 with Interfaces.C;                                            -- N/A => ERROR
  81 with Interfaces.C.Strings;                                    -- N/A => ERROR
  82
  83 procedure CXB30132 is
  84 begin
  85
  86    Report.Test ("CXB3013", "Check that user-defined C functions can " &
  87                            "be imported into an Ada program");
  88
  89    Test_Block:
  90    declare
  91
  92       package IC  renames Interfaces.C;
  93       package ICS renames Interfaces.C.Strings;
  94
  95       use type IC.char_array;
  96       use type IC.int;
  97       use type IC.short;
  98       use type IC.C_float;
  99       use type IC.double;
 100
 101       type Short_Ptr          is access all IC.short;
 102       type Float_Ptr          is access all IC.C_float;
 103       type Double_Ptr         is access all IC.double;
 104       subtype Char_Array_Type is IC.char_array(0..20);
 105
 106       TC_Default_int      : IC.int             :=   49;
 107       TC_Default_short    : IC.short           :=    3;
 108       TC_Default_float    : IC.C_float         :=   50.0;
 109       TC_Default_double   : IC.double          := 1209.0;
 110
 111       An_Int_Value        : IC.int             := TC_Default_int;
 112       A_Short_Value       : aliased IC.short   := TC_Default_short;
 113       A_Float_Value       : aliased IC.C_float := TC_Default_float;
 114       A_Double_Value      : aliased IC.double  := TC_Default_double;
 115
 116       A_Short_Int_Pointer : Short_Ptr          := A_Short_Value'access;
 117       A_Float_Pointer     : Float_Ptr          := A_Float_Value'access;
 118       A_Double_Pointer    : Double_Ptr         := A_Double_Value'access;
 119
 120       Char_Array_1        : Char_Array_Type;
 121       Char_Array_2        : Char_Array_Type;
 122       Char_Pointer        : ICS.chars_ptr;
 123
 124       TC_Char_Array       : constant Char_Array_Type :=
 125                               "Look before you leap" & IC.nul;
 126       TC_Return_int       : IC.int := 0;
 127
 128       -- The Square_It function returns the square of the value The_Int
 129       -- through the function name, and returns the square of the other
 130       -- parameters through the parameter list (the last three parameters
 131       -- are access values).
 132
 133       function Square_It (The_Int    : in IC.int;
 134                           The_Short  : in Short_Ptr;
 135                           The_Float  : in Float_Ptr;
 136                           The_Double : in Double_Ptr) return IC.int;
 137
 138       -- The Combine_Strings function returns the result of the catenation
 139       -- of the two string parameters through the function name.
 140
 141       function Combine_Strings (First_Part  : in IC.char_array;
 142                                 Second_Part : in IC.char_array)
 143         return ICS.chars_ptr;
 144
 145
 146       -- Use the user-defined C function square_it as a completion to the
 147       -- function specification above.
 148
 149      pragma Import (Convention    => C,
 150                     Entity        => Square_It,
 151                     External_Name => Impdef.CXB30130_External_Name);
 152
 153       -- Use the user-defined C function combine_two_strings as a completion
 154       -- to the function specification above.
 155
 156      pragma Import (C, Combine_Strings, Impdef.CXB30131_External_Name);
 157
 158
 159    begin
 160
 161       -- Check that the imported version of C function CXB30130 produces
 162       -- the correct results.
 163
 164       TC_Return_int := Square_It (The_Int    => An_Int_Value,
 165                                   The_Short  => A_Short_Int_Pointer,
 166                                   The_Float  => A_Float_Pointer,
 167                                   The_Double => A_Double_Pointer);
 168
 169       -- Compare the results with the expected results.  Note that in the
 170       -- case of the three "pointer" parameters, the objects being pointed
 171       -- to have been modified as a result of the function.
 172
 173       if TC_Return_int           /= An_Int_Value      * An_Int_Value      or
 174          A_Short_Int_Pointer.all /= TC_Default_short  * TC_Default_Short  or
 175          A_Short_Value           /= TC_Default_short  * TC_Default_Short  or
 176          A_Float_Pointer.all     /= TC_Default_float  * TC_Default_float  or
 177          A_Float_Value           /= TC_Default_float  * TC_Default_float  or
 178          A_Double_Pointer.all    /= TC_Default_double * TC_Default_double or
 179          A_Double_Value          /= TC_Default_double * TC_Default_double
 180       then
 181          Report.Failed("Incorrect results returned from function square_it");
 182       end if;
 183
 184
 185       -- Check that two char_array values are combined by the imported
 186       -- C function CXB30131.
 187
 188       Char_Array_1(0..12) := "Look before " & IC.nul;
 189       Char_Array_2(0..8)  := "you leap"     & IC.nul;
 190
 191       Char_Pointer := Combine_Strings (Char_Array_1, Char_Array_2);
 192
 193       if ICS.Value(Char_Pointer) /= TC_Char_Array then
 194          Report.Failed("Incorrect value returned from imported function " &
 195                        "combine_two_strings");
 196       end if;
 197
 198
 199    exception
 200       when others => Report.Failed ("Exception raised in Test_Block");
 201    end Test_Block;
 202
 203    Report.Result;
 204
 205 end CXB30132;