Re: Interfaces.C + generics: stack overflow

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

On 03/23/2017 09:03 PM, Randy Brukardt wrote:
> I agree with Jeff, there's not enough detail here to even see if there is a
> bug or your mistake. We need to know how/where the generic is instantiated,
> where/how the access-to-function value is created, and probably more.
>
The complete code follows below. The suggestion from Jeffrey is already 
realized. The packages are:
  - GSL			wrapper for the C library
  - Test_Integration	main program, instantiates GSL
  - Integ_Aux		defines the function to be handed over

> But let me say that the rules for access-to-subprogram types are different
> inside of generics than they are in normal packages, in order to allow for
> the possibility of generic sharing. That ought to manifest as compile-time
> errors and/or the raising of Program_Error, so it seems that there might be
> a compiler bug in your code. But to find that, one needs to see the whole
> thing, not just a little corner.
>
> If you really want to write portable interfacing code, you would not use any
> generics in the raw interface. (Have the generics call non-generic interface
> code with appropriate type conversions.) Janus/Ada doesn't allow any
> convention C stuff in generic units, because it is incompatible with the
> extra dope needed to implemented universal generic sharing. I'd expect
> something similar to happen for any implementation that supports almost any
> form of generic sharing. (If you only care about GNAT, do what ever you
> want.)
>
I am not writing this program only for its result, but also as an 
exercise in Ada programming. So I want to do it the right way. So far I 
know basically the book from John Barnes, where this topic is not 
treated, so thanks for your comments, I will modify my program accordingly.

---------------------------------------------------------------------------
generic
    type Real is digits <>;
    type Parameters is private;	-- for future use
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:			in out 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:	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,
          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;
------------------------------------------------------------------------------
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;
------------------------------------------------------------------------------
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