@z
This file was created by Aleksandar Donev as part of the Sphere Packing Project.
Feel free to use any portion of it and contact me at adonev@princeton.edu
@x

\Title{Support for F2x feature emulation in F95}
\author{Aleksandar Donev}
\date{\today}
\maketitle

@*0 Module |F2x_Emulation|.

In trying to emulate some of the desperately needed F2x features, I rely heavily on FWEB macros. However, some runtime support is also needed in order to make life easier. Bits of code needed for this purpose are given here, while the macros are in the always included |Fortran.F2x.hweb|.

In particular, procedure pointers are supported via a new derived datatype, and also array pointer reshaping in pointer assignment is supported. For now, for simplicity, I only support array-pointer bounds-remapping for contiguous pointers--calling these routines with non-contiguous data-target will produce {\em wrong} results! With just a bit more work strides can easily be supported: One needs a mechanism to find the actual stride and then use these when assigning the array pointer to the properly scaled assumed-size argument in the |MakeArrayPointer| functions. However, since the utility of this is not clear to me, I will skip it for now...

@a
MODULE F2x_Emulation @;
      USE Precision @;
      USE ISO_C_BINDING @;
      IMPLICIT NONE @;      
      PRIVATE @;

      PUBLIC :: AssignArrayPointer, ReshapeArrayPointer @; // Pointer reshaping in assignment
      _TYPE, PUBLIC :: Procedure_Pointer @;
         _C_PTR :: c_pointer=C_NULL_PTR @;
         _F_PROC_PTR, POINTER :: f_pointer=>NULL() @;         
      ENDTYPE @;

      @<AssignArrayPointer\_Generic@>@;
      @<ReshapeArrayPointer\_Generic@>@;
      
CONTAINS @;

      @<ReshapeArrayPointer\_Implementation@>@;
      @<AssignArrayPointer\_Implementation@>@;
      
END MODULE F2x_Emulation @;      

@*1 Array pointer bounds remapping.

@m _ReshapeArrayPointer_Body(type_,kind_,rank_) @;
SUBROUTINE ReshapeArrayPointer_@e@&kind_@e@&rank_(array_pointer, array_target, lower_bounds, upper_bounds) @;
   INTEGER(KIND=i_wp), DIMENSION(rank_), INTENT(IN) :: lower_bounds, upper_bounds @;
   type_(KIND=kind_), DIMENSION(_FullExtent(rank_)), POINTER :: array_pointer @;
   type_(KIND=kind_), DIMENSION(:), INTENT(IN), TARGET :: array_target @; 
      // This can be an array section i.e. non-contiguous  

   _C_PTR :: base_address @;
   INTEGER(KIND=i_wp), DIMENSION(rank_) :: pointer_shape @;
   INTEGER(KIND=C_INT), DIMENSION(rank_) :: strides @;

   pointer_shape=upper_bounds-lower_bounds+1 @;
   IF(_SIZE(array_target,i_wp)<PRODUCT(pointer_shape)) THEN @;
      // This is an error, so return a null pointer
      NULLIFY(array_pointer) @;
      RETURN @;
   END IF @;

   strides=1 @;
   IF(_SIZE(array_target,i_wp)>1) THEN @;
      strides[1]=C_STRIDE(array_target[1],array_target[2]) @; // Find the actual stride using C
   END IF @;  
   pointer_shape *= strides @; // Allow for the extra size needed for the stride
       
   base_address=C_LOC(array_target) @;
   CALL C_F_POINTER(CPTR=base_address, FPTR=array_pointer, SHAPE=pointer_shape) @;

   // Now we need to change the bounds and strides accordingly
   CALL AssignArrayPointer(array_pointer=array_pointer, &
        array_target=array_pointer(_STRExtent(rank_,strides)), &
        lower_bounds=lower_bounds) @;

END SUBROUTINE @;

@m _ReshapeArrayPointer_Body_TKR(tk_number_,rank_,...) @;
   _ReshapeArrayPointer_Body(_AllIntrinsicTypes(tk_number_), _AllIntrinsicKinds(tk_number_), rank_) @;  

@
@<ReshapeArrayPointer\_Generic@>=
_GenerateInterface_TKR_Array(N_TK_ALL,ReshapeArrayPointer) @;

@
@<ReshapeArrayPointer\_Implementation@>=
_GenerateBody_TKR_Array(N_TK_ALL,_ReshapeArrayPointer_Body_TKR) @;

@*1 Array pointer assignment with explicit lower bounds.

@m _AssignArrayPointer_Body(type_,kind_,rank_) @;
SUBROUTINE AssignArrayPointer_@e@&kind_@e@&rank_(array_pointer, array_target, lower_bounds) @;
   INTEGER(KIND=i_wp), DIMENSION(rank_), INTENT(IN) :: lower_bounds @;
   type_(KIND=kind_), DIMENSION(_FullExtent(rank_)), POINTER :: array_pointer @;
   type_(KIND=kind_), DIMENSION(_LBExtent(rank_,lower_bounds)), INTENT(IN), TARGET :: array_target @;   

   array_pointer=>array_target @;

END SUBROUTINE @;

@m _AssignArrayPointer_Body_TKR(tk_number_,rank_,...) @;
   _AssignArrayPointer_Body(_AllIntrinsicTypes(tk_number_), _AllIntrinsicKinds(tk_number_), rank_) @;  

@
@<AssignArrayPointer\_Generic@>=
_GenerateInterface_TKR_Array(N_TK_ALL,AssignArrayPointer) @;

@
@<AssignArrayPointer\_Implementation@>=
_GenerateBody_TKR_Array(N_TK_ALL,_AssignArrayPointer_Body_TKR) @;

@
@I C_Interop.hweb
@I Macros.hweb

@%% EOF