Re: Interfaces.C questions

[hreba <f_hreba@yahoo.com.br>]

My posting earlier was too fast: the program compiles, but terminates with a
STORAGE_ERROR : stack overflow or erroneous memory access.
This happens right at the call of gsl_integration_qng(), the function 
exported from the C library.

If somebody has an idea what could be wrong ...

My wrapper is package GSL:

----------------------------------------------------------------------
generic
    type Real is digits <>;
    type Parameters is private;
package GSL is

    gsl_Ex:	Exception;
    error_code:	Integer;	-- of the last operation

    type Real_Function is access function (x: Real) return Real;

    procedure Integration_QNG
      (f:			Real_Function;
       a, b, epsabs, epsrel:	Real;
       result, abserr:		out Real;
       neval:			out Natural);

end GSL;
-----------------------------------------------------------------------
-----------------------------------------------------------------------
with Interfaces.C;	use Interfaces;

package body GSL is

    type Void_Ptr is access all Parameters;
    pragma Convention (C, Void_Ptr);

    type GSL_Inner_Function is
      access function (x: C.double; params: Void_Ptr) return C.double;
    pragma Convention (C, GSL_Inner_Function);

    type GSL_Function is record
       func:	GSL_Inner_Function;
       params:	Void_Ptr;
    end record;

    real_func:	Real_Function;

    ---------------------------------------------------------------------
    --	Auxiliary Subprograms
    ---------------------------------------------------------------------

    function func (x: C.double; params: Void_Ptr) return C.double;
    pragma Convention (C, func);

    function func (x: C.double; params: Void_Ptr) return C.double is
    begin return C.double (real_func (Real(x)));
    end func;


    function gsl_integration_qng
      (f: access GSL_Function;
       a, b, epsabs, epsrel: C.double;
       result, abserr: out C.double;
       neval: out C.size_t)
      return C.int;
    pragma Import (C, gsl_integration_qng,	"gsl_integration_qng");


    ---------------------------------------------------------------------
    -- Exported Subprograms
    ---------------------------------------------------------------------

    procedure Integration_QNG
      (f: Real_Function;
       a, b, epsabs, epsrel:	Real;
       result, abserr:		out Real;
       neval:			out Natural)
    is
       use type C.int;
       gslf:	aliased GSL_Function;
       status:	C.int;
       res, ae:	C.double;
       ne:	C.size_t;
    begin
       real_func:= f;
       gslf.func:= func'Access;
       gslf.params:= null;
       status:= gsl_integration_qng    -- <-- STORAGE_ERROR occurs here
	(gslf'Access,
	 C.double(a), C.double(b), C.double(epsabs), C.double(epsrel),
	 res, ae, ne);
       if status /= 0 then
	 error_code:= Integer (status);
	 raise gsl_Ex with
	   "gsl_integration_qng() returns error code " & C.int'Image(status);
       end if;
       result:= Real(res);
       abserr:= Real(ae);
       neval:= Natural(ne);
    end Integration_QNG;

end GSL;
-------------------------------------------------------------------------

The test application is

-------------------------------------------------------------------------
with Ada.Text_IO;	use Ada.Text_IO;
with GSL;
with Integ_Aux;

procedure Test_Integration
is
    package GSL_Test is new GSL (Integ_Aux.Real, Integer);
    use type Integ_Aux.Real;
    a, abserr:	Integ_Aux.Real;
    neval:	Natural;
begin
    GSL_Test.Integration_QNG
      (Integ_Aux.Circle'Access, 0.0, 1.0, 0.001, 0.001, a, abserr, neval);
    Put_Line("4*int_0^1 sqrt(1-x^2) dx = " & Integ_Aux.Real'Image(4.0*a));
    Put_Line(Natural'Image(neval) & " function evaluations, " &
	      Integ_Aux.Real'Image(abserr) & " abs. error");
end Test_Integration;
---------------------------------------------------------------------------

which imports also

---------------------------------------------------------------------------
with Interfaces;

package Integ_Aux is

    type Real is new Interfaces.IEEE_Float_32;
    function Circle (x: Real) return Real;

end Integ_Aux;
---------------------------------------------------------------------------
---------------------------------------------------------------------------
with Ada.Numerics.Generic_Elementary_Functions;

package body Integ_Aux is

    package Functions is new
      Ada.Numerics.Generic_Elementary_Functions (Real);

    function Circle (x: Real) return Real is
    begin return Functions.Sqrt(abs(1.0-x*x));
    end Circle;

end Integ_Aux;
------------------------------------------------------------------------------

-- 
Frank Hrebabetzky		+49 / 6355 / 989 5070