character for logic

Marcelo_N_ · ‎01-10-2016

If I have:

Program DW
implicit none
character(len=50) :: C
logical (kind=1) :: L

C="4 .GT. 3 .And. 5 .EQ. 2"
L=C      ! I know that this is impossible
If (L .EQV. .True.) Then ! <--- How can I do This?
    Write(*,*) "This is True"
Else
    Write(*,*) "This isn't True"
EndIf

End Program DW

Steven_L_Intel1 · ‎01-10-2016

You want Fortran logical expressions in a string to be evaluated? There is no support for that.

Marcelo_N_ · ‎01-10-2016

I need to read "C" from a file. I do not know to solve this.

mecej4 · ‎01-10-2016

You are asking for code that will function as a runtime expression evaluator. There are some solutions of this nature, but only for arithmetic/mathematical expressions. See, for example, http://gbenthien.net/strings/ (see the third item on the page).

You ask for a mixed logical/arithmetic evaluator. That is a bit more complicated; you have to parse the string into arithmetic expressions, which are evaluated first, then the results are used with comparison operators to obtain boolean results, and a final evaluation is to be made with boolean operators ( &, |, etc.).

Fortran does not attempt to interpret what is within a character string. Neither "Thou Shalt Not Kill" nor "F = m a" are strings with any specific significance. Therefore, if you wish to infer meanings, you will have to write code to parse and evaluate the string.

Steven_L_Intel1 · ‎01-10-2016

A rather crude way is to have your program write a separate Fortran program with your expression (though how you get the variables in there depends on what it is you're trying to accomplish. Then you would have to compile. link and run this program and retrieve the result.

For communicating variables you may find NAMELIST I/O to be of use. But for evaluating expressions, you're on your own.

JVanB · ‎01-10-2016

There are a few Fortran expression parsers out there that you can google up. In Windows, a more general solution would be to compile a procedure containing the expression you want to a *.dll and then access that procedure via LoadLibrary, GetProcAddress, and C_F_PROCPOINTER. In Linux, I suppose one would compile to a *.so file or a *.dylib file in OSX. See also https://software.intel.com/en-us/node/525275 . Then instead of LoadLibrary and GetProcAddress, in Linux there is dlopen and dlsym http://linux.die.net/man/3/dlopen . Looks like it would be easy to compose a small example, but I don't have a Linux machine (well, except for my TV, but I can't compile anything on that) to test it on, so maybe someone else could give it a try.

JVanB · ‎01-10-2016

I made up an example that works in Windows:

module M
   use ISO_C_BINDING
   implicit none
   private
   public GetLastError,LoadLibrary,GetProcAddress,MySub
   integer, parameter, public :: &
      DWORD = C_LONG, &
      HANDLE = C_INTPTR_T
   interface
      function GetLastError() bind(C,name='GetLastError')
         import
         implicit none
         !DEC$ ATTRIBUTES STDCALL :: GetLastError
         integer(DWORD) GetLastError
      end function GetLastError
      function LoadLibrary(lpFileName) bind(C,name='LoadLibraryA')
         import
         implicit none
         !DEC$ ATTRIBUTES STDCALL :: LoadLibrary
         integer(HANDLE) LoadLibrary
         character(kind=C_CHAR), intent(in) :: lpFileName(*)
      end function LoadLibrary
      function GetProcAddress(hModule,lpProcName) bind(C,name='GetProcAddress')
         import
         implicit none
         !DEC$ ATTRIBUTES STDCALL :: GetProcAddress
         type(C_FUNPTR) GetProcAddress
         integer(HANDLE), value :: hModule
         character(kind=C_CHAR), intent(in) :: lpProcName(*)
      end function GetProcAddress
      subroutine MySub(x)
         implicit none
         class(*), allocatable, intent(out) :: x
      end subroutine MySub
   end interface
end module M

program P
   use M
   use ISO_C_BINDING
   implicit none
   character(80) expr
   real harvest
   character(20) libname
   integer iunit
   integer Estat
   integer(HANDLE) Hlib
   integer(DWORD) LastError
   type(C_FUNPTR) Address
   interface
      subroutine SetMySub(Address,S)
         import
         implicit none
         type(C_FUNPTR), value :: Address
         procedure(MySub), pointer :: S
      end subroutine SetMySub
   end interface
   procedure(MySub), pointer :: S1
   class(*), allocatable :: x

   expr = '4 .GT. 3 .And. 5 .EQ. 2'
   call random_seed()
   call random_number(harvest)
   write(libname,'(a,i0)') 'MyLib',int(1.0e6*harvest)
   open(newunit=iunit,file=trim(libname)//'.f90',status='replace')
   write(iunit,'(a)') 'subroutine S(x)'
   write(iunit,'(a)') '   implicit none'
   write(iunit,'(a)') '   !DEC$ ATTRIBUTES DLLEXPORT :: S'
   write(iunit,'(a)') '   class(*), allocatable, intent(out) :: x'
   write(iunit,'(a)') '   allocate(x,source=('//trim(expr)//'))'
   write(iunit,'(a)') 'end subroutine S'
   close(iunit)
   call EXECUTE_COMMAND_LINE('ifort /nologo /DLL '//trim(libname)//'.f90',EXITSTAT=Estat)
   if(Estat /= 0) then
      write(*,'(a,i0)') 'Compilation failed with error status = ',Estat
      stop
   end if
   Hlib = LoadLibrary(trim(libname)//'.dll'//achar(0))
   if(Hlib == 0) then
      LastError = GetLastError()
      write(*,'(a,i0)') 'Loading '//trim(libname)//'.dll failed with error status = ',LastError
      stop
   end if
   Address = GetProcAddress(Hlib,'S'//achar(0))
   if(.NOT.C_ASSOCIATED(Address)) then
      LastError = GetLastError()
      write(*,'(a,i0)') "Accsessing 'S' failed with error status = ",LastError
      stop
   end if
   call SetMySub(Address,S1)
   call S1(x)
   select type(x)
      type is(LOGICAL)
         write(*,'(a)') trim(merge("This is True   ","This isn't True",x))
      class default
         write(*,'(a)') 'Error: type not found'
         stop
   end select
end program P

subroutine SetMySub(Address,S)
   use ISO_C_BINDING
   implicit none
   type(C_FUNPTR), value :: Address
   interface
      subroutine S2(x) bind(C)
         use ISO_C_BINDING
         implicit none
         type(C_PTR), value :: x
      end subroutine S2
   end interface
   procedure(S2), pointer :: S
   call C_F_PROCPOINTER(Address,S)
end subroutine SetMySub

Output:

   Creating library MyLib448697.lib and object MyLib448697.exp
This isn't True

My best attempt for Linux:

module M
   use ISO_C_BINDING
   implicit none
   private
   integer(C_INT), parameter, public :: &
      RTLD_LAZY = int(Z'01',C_INT), &
      RTLD_NOW = int(Z'02',C_INT), &
      RTLD_LOCAL = int(Z'04',C_INT), &
      RTLD_GLOBAL = int(Z'08',C_INT), &
      RTLD_NOLOAD = int(Z'10',C_INT), &
      RTLD_NODELETE = int(Z'80',C_INT), &
      RTLD_NEXT = int(-1,C_INT), &
      RTLD_DEFAULT = int(-2,C_INT)
   public dlopen,dlerror,dlsym,strlen,MySub
   interface
      function dlopen(filename,flag) bind(C,name='dlopen')
         import
         implicit none
         type(C_PTR) dlopen
         character(kind=C_CHAR), intent(in) :: filename(*)
         integer(C_INT), value :: flag
      end function dlopen
      function dlerror() bind(C,name='dlerror')
         import
         implicit none
         type(C_PTR) dlerror
      end function dlerror
      function dlsym(handle,symbol) bind(C,name='dlsym')
         import
         implicit none
         type(C_FUNPTR) dlsym
         type(C_PTR), value :: handle
         character(kind=C_CHAR), intent(in) :: symbol
      end function dlsym
      function strlen(str) bind(C,name='strlen')
         import
         implicit none
         integer(C_SIZE_T) strlen
         type(C_PTR), value :: str
      end function strlen
      subroutine MySub(x)
         implicit none
         class(*), allocatable, intent(out) :: x
      end subroutine MySub
   end interface
end module M

program P
   use M
   use ISO_C_BINDING
   implicit none
   character(80) expr
   real harvest
   character(20) libname
   integer iunit
   integer Estat
   type(C_PTR) Hlib
   type(C_PTR) LastPtr
   integer(C_SIZE_T) LastLen
   character(:,C_CHAR), pointer :: LastError
   type(C_FUNPTR) Address
   interface
      subroutine SetMySub(Address,S)
         import
         implicit none
         type(C_FUNPTR), value :: Address
         procedure(MySub), pointer :: S
      end subroutine SetMySub
   end interface
   procedure(MySub), pointer :: S1
   class(*), allocatable :: x

   expr = '4 .GT. 3 .And. 5 .EQ. 2'
   call random_seed()
   call random_number(harvest)
   write(libname,'(a,i0)') 'MyLib',int(1.0e6*harvest)
   open(newunit=iunit,file=trim(libname)//'.f90',status='replace')
   write(iunit,'(a)') 'subroutine S(x)'
   write(iunit,'(a)') '   implicit none'
   write(iunit,'(a)') '   !DEC$ ATTRIBUTES DLLEXPORT :: S'
   write(iunit,'(a)') '   class(*), allocatable, intent(out) :: x'
   write(iunit,'(a)') '   allocate(x,source=('//trim(expr)//'))'
   write(iunit,'(a)') 'end subroutine S'
   close(iunit)
   call EXECUTE_COMMAND_LINE('ifort -nologo -shared -fpic '//trim(libname)//'.f90',EXITSTAT=Estat)
   if(Estat /= 0) then
      write(*,'(a,i0)') 'Compilation failed with error status = ',Estat
      stop
   end if
   Hlib = dlopen(trim(libname)//'.so'//achar(0),RTLD_LAZY)
   if(.NOT.C_ASSOCIATED(Hlib)) then
      LastPtr = dlerror()
      LastLen = strlen(LastPtr)
      BLOCK
         character(LastLen,C_CHAR), pointer :: temp
         call C_F_POINTER(LastPtr,temp)
         LastError => temp
      END BLOCK
      write(*,'(a)') 'Loading '//trim(libname)//'.so failed with error status.'
      write(*,'(a)') LastError
      stop
   end if
   Address = dlsym(Hlib,'S'//achar(0))
   if(.NOT.C_ASSOCIATED(Address)) then
      LastPtr = dlerror()
      LastLen = strlen(LastPtr)
      BLOCK
         character(LastLen,C_CHAR), pointer :: temp
         call C_F_POINTER(LastPtr,temp)
         LastError => temp
      END BLOCK
      write(*,'(a)') "Accsessing 'S' failed with error status."
      write(*,'(a)') LastError
      stop
   end if
   call SetMySub(Address,S1)
   call S1(x)
   select type(x)
      type is(LOGICAL)
         write(*,'(a)') trim(merge("This is True   ","This isn't True",x))
      class default
         write(*,'(a)') 'Error: type not found'
         stop
   end select
end program P

subroutine SetMySub(Address,S)
   use ISO_C_BINDING
   implicit none
   type(C_FUNPTR), value :: Address
   interface
      subroutine S2(x) bind(C)
         use ISO_C_BINDING
         implicit none
         type(C_PTR), value :: x
      end subroutine S2
   end interface
   procedure(S2), pointer :: S
   call C_F_PROCPOINTER(Address,S)
end subroutine SetMySub

But you will have to debug it yourself :)

mecej4 · ‎01-11-2016

This is a very instructive contribution from Repeat Offender! I modified it to repeatedly read constant expressions from the keyboard and output the results. It takes about 0.4 seconds to read an expression, output the corresponding DLL source, get IFort to compile the code into a DLL, and call the DLL to evaluate the expression.

One expression that I tried,

4.gt.3 .eqv. 1.eq.2

caused the Intel compiler (16.0.1, 32-bit and 64-bit, on Windows) to run into an ICE. I added a main program to the subroutine code generated by Repeat Offender's program to make it stand-alone. The program is fine, but IFort runs into an ICE when compiling it.

program pgm
class(*) , allocatable :: x
call s(x)
select type(x)
   type is(LOGICAL)
      write(*,'(a)') trim(merge("This is True   ","This isn't True",x))
   class default
      write(*,'(a)') 'Error: type not found'
      stop
   end select
contains
subroutine S(x)
   implicit none
   class(*), allocatable, intent(out) :: x
   allocate(x,source=(4.gt.3 .eqv. 1.eq.2))
end subroutine S
end program

Steven_L_Intel1 · ‎01-11-2016

Well, isn't that exciting? Thanks, I'll write this up for the developers. Issue ID DPD200380554.

JVanB · ‎01-11-2016

Another thing I noticed (this was my first experiment with unlimited polymorphism) was those extra parentheses you can see around the SOURCE= expression are unnecessarily required by ifort. This program fails to compile with ifort, although gfortran passes it:

program P
   implicit none
   class(*), allocatable :: als
! ifort and gfortran can't handle this yet
!   als = 4 .GT. 3 .And. 5 .EQ. 2
   allocate(als,source=4 .GT. 3 .And. 5 .EQ. 2)
   select type(als)
      type is(logical)
         write(*,*) als
   end select
end program P

Also, if someone would try my Linux attempt and post the first error message displayed, I would perhaps be able to produce something that works on that platform. It seems that OSX would be quite similar: just change the command line and also change the .so suffix to .dylib .

Steven_L_Intel1 · ‎01-11-2016

Thanks, RO. Escalated as issue DPD200380559.

Steven_L_Intel1 · ‎03-02-2016

The ICE RO reported is fixed in the next major release.