Fortran and Win32 programming

[p_p_1]

I'm not really experienced in Fortran, I tried unsuccessfully to call a Windows API function as a test (previously I tried some other tests such as locking the screen, with success).
The function is QueryProcessCycleTime (just for curiosity, it retrieves the cpu cycles count of a process, in my test code with a fixed pid of an actually existent process). Its syntax:

BOOL WINAPI QueryProcessCycleTime(
  _In_  HANDLE   ProcessHandle,
  _Out_ PULONG64 CycleTime
);

I couldn't find the Fortran "translation" for these data types and I tried several combinations in my code (for each variables) with no luck. I compiled with
ifort /libs:static /exe: ...   or
ifort /libs:qwin,static /exe: ...
but the output is always:
 F                  4936                     0
 (return value,  pid,  cycles count).

The function doesn't appear in the kernel32.f90 supplied by Intel (see Calling Windows API Routines for syntax not involving ISO_C_BINDING).
 
Going beyond the specific test I wondered if:
really Fortran can't load dlls supplying full path (without adding it as an environment variable)?
Or more in general and in a few words:

Can Fortran be used as a Win32 programming language?
(I don't mean only for a limited set of functions)

Or, at the end, is it (very, we know) useful only for number crunching?

My test code:

module process_cpu_cycles
use ISO_C_BINDING
implicit none

public QueryProcessCycleTime
interface
    function QueryProcessCycleTime(proc_id, cpu_cycles) bind(C,Name='QueryProcessCycleTime')
        use ISO_C_BINDING
        implicit NONE
        !DEC$ ATTRIBUTES STDCALL :: QueryProcessCycleTime
        logical(C_BOOL) :: QueryProcessCycleTime        ! tried C_INT too
        integer(C_INTPTR_T), value :: proc_id           ! tried without value
        integer(C_INTPTR_T), value :: cpu_cycles        ! tried C_INT64_T too
    end function QueryProcessCycleTime
end interface

end module process_cpu_cycles


program cycles
use process_cpu_cycles
use ISO_C_BINDING
implicit none

logical(C_BOOL) :: ret_val
integer(C_INTPTR_T) :: pid
integer(C_INTPTR_T) :: ccycle        ! tried C_INT64_T too

ccycle=0
pid=4936
ret_val = QueryProcessCycleTime(pid,ccycle)
write (*,*) ret_val, pid, ccycle
end program cycles

[Steven_L_Intel1]

If you get the calling convention wrong in a 32-bit application (don't use STDCALL when you should, or vice-versa), you corrupt the stack. Depending on what else goes on in your program you may or may not notice.  In particular it will seem to work fine in a small test program, but if your program does anything more complex you'll start seeing weird errors (wrong results, access violations, etc.) that may be far removed from the source of the problem. Current Intel Fortran does have /check:stack that can detect some of these issues at run-time.

And I know I'm being pedantic here, but the phrase "ISO_C_BINDING wrapper" isn't meaningful. ISO_C_BINDING is simply a set of declarations that help you interface with C. Using it or not doesn't affect compiler behavior. BIND(C) is a language feature and is not directly related to ISO_C_BINDING, even though some of the letters in the names are the same.

I would rather see people use standard Fortran intrinsics where they are suitable, such as DATE_AND_TIME or SYSTEM_CLOCK (depending on what it is you're looking for.)

And lastly, there was no need to write your own interfaces for LoadLibrary and GetProcAddress - these have been defined in module KERNEL32 "forever".

[p_p_1]

Steve Lionel (Intel) wrote:

If you get the calling convention wrong in a 32-bit application (don't use STDCALL when you should, or vice-versa), you corrupt the stack. Depending on what else goes on in your program you may or may not notice.  In particular it will seem to work fine in a small test program, but if your program does anything more complex you'll start seeing weird errors (wrong results, access violations, etc.) that may be far removed from the source of the problem. Current Intel Fortran does have /check:stack that can detect some of these issues at run-time.

Well, and in addition we could cite contibutions like this Determining Which Linking Method to Use.
That said, it's not so clear if you are referring to the code which involves the LoadLibrary function and for what reason, if yes.
Beacuse the/my assumption is that (with correct programming) one should be able to perform runtime linking to a dll (even when that dll is not directly 'supported' by that particular Fortran installation. To cases like this the attribute unsupported shouldn't apply).

[Steven_L_Intel1]

Sure, you can use LoadLibrary all you want. We even provide a sample showing its use. What I meant was that Intel doesn't provide predeclared interfaces for functions that don't have import libraries.

The comment about STDCALL was a general warning to make sure you get it right, especially when calling Windows system routines. In your "gettime" interface you didn't say STDCALL and therefore when you called that routine, the stack got corrupted.

[JVanB]

I noticed more problems when working with your example. Tab source form is nonstandard and a really bad idea. Use spaces instead. Also you had NtQuerySystemTime typed out as a subroutine when in fact it's a function. I tried a little experiment to see if I could cause a crash due to NtQuerySystemTime not being declared STDCALL. In the following code, when the !DEC$ ATTRIBUTES STDCALL :: NtQuerySystemTimeX line is commented out, N >= 22, and the program is compiled with 32-bit ifort, it crashes.

module M
   use ISO_C_BINDING
   implicit none
   private
   integer, parameter, public :: LONGLONG = C_INT64_T
   integer, parameter, public :: NTSTATUS = C_INT32_T
   integer, parameter, public :: HANDLE = C_INTPTR_T
   type, public, bind(C) ::T_LARGE_INTEGER
      INTEGER(LONGLONG) QuadPart
   end type T_LARGE_INTEGER
   public LoadLibrary,GetProcAddress,NtQuerySystemTimeX
   public C_FUNPTR,C_F_PROCPOINTER
   interface 
      function LoadLibrary(lpFileName) bind(C,name='LoadLibraryA')   ! the ansi version
         import
         implicit none
         character(kind=C_CHAR) :: lpFileName(*) 
         !DEC$ ATTRIBUTES STDCALL :: LoadLibrary 
         !GCC$ ATTRIBUTES STDCALL :: LoadLibrary 
         INTEGER(HANDLE) :: LoadLibrary 
      end function LoadLibrary 

      function GetProcAddress(hModule, lpProcName) bind(C, name='GetProcAddress')
         import
         implicit none
         !DEC$ ATTRIBUTES STDCALL :: GetProcAddress
         !GCC$ ATTRIBUTES STDCALL :: GetProcAddress
         TYPE(C_FUNPTR) :: GetProcAddress
         INTEGER(HANDLE), value :: hModule
         character(kind=C_CHAR) :: lpProcName(*)
      end function GetProcAddress
   end interface

   abstract interface
      function NtQuerySystemTimeX(SystemTime) bind(C)
         import
         implicit none
!         !DEC$ ATTRIBUTES STDCALL :: NTQuerySystemTimeX
         !GCC$ ATTRIBUTES STDCALL :: NTQuerySystemTimeX
         TYPE (T_LARGE_INTEGER) SystemTime
         integer(NTSTATUS) NTQuerySystemTimeX
      end function NtQuerySystemTimeX
   end interface

end module M

program P
   use M
   implicit none
   character(260) lpLibFileName
   character(260) lpProcName
   integer(HANDLE) module_handle
   type(C_FUNPTR) module_address
   procedure(NtQuerySystemTimeX), pointer :: NtQuerySystemTime
   integer N
   type(T_LARGE_INTEGER), allocatable :: times(:)

   N = 22 ! Failure point in ifort
   lpLibFileName = 'ntdll.dll'//achar(0)
   lpProcName = 'NtQuerySystemTime'//achar(0)

   module_handle = LoadLibrary(lpLibFileName)
   module_address = GetProcAddress(module_handle,lpProcName)

   call C_F_PROCPOINTER(module_address,NtQuerySystemTime)
   write(*,'(*(g0))') 'This is a ',bit_size(module_handle),'-bit program'
   allocate(times(N))
   times = T_LARGE_INTEGER(0)
   call S(NtQuerySystemTime,times,N)
   write(*,*) times(1:min(10,N))
end program P

subroutine S(timer,times,N)
   use M
   implicit none
   procedure(NtQuerySystemTimeX) timer
   integer N
   type(T_LARGE_INTEGER) times(N)
   integer i
   integer(NTSTATUS) status

   do i = 1, N
      status = timer(times(i))
   end do
end subroutine S

This is a 32-bit program
forrtl: severe (157): Program Exception - access violation
Image              PC        Routine            Line        Source
NtQuery.exe        0089993E  Unknown               Unknown  Unknown
NtQuery.exe        00898B5B  Unknown               Unknown  Unknown
NtQuery.exe        008913F6  Unknown               Unknown  Unknown
NtQuery.exe        008D579F  Unknown               Unknown  Unknown
NtQuery.exe        008D5A89  Unknown               Unknown  Unknown
KERNEL32.DLL       77777C04  Unknown               Unknown  Unknown
ntdll.dll          77C9AD5F  Unknown               Unknown  Unknown
ntdll.dll          77C9AD2A  Unknown               Unknown  Unknown

Change any of those things (N < 22, !DEC$ ATTRIBUTES STDCALL :: NtQuerySystemTimeX in force, or 64-bit compile) and the program runs to completion. I avoided using IFWIN so that I could try the program on gfortran. Unfortunately it crashed, even with the !GCC$ ATTRIBUTES STDCALL :: NtQuerySystemTimeX line in force, no doubt due to a bug in gfortran. Ran OK in 64 bits, though.

[Steven_L_Intel1]

64-bit has only one calling convention. ATTRIBUTES STDCALL (without BIND(C)) on 64-bit changes only the name case and argument passing defaults. With BIND(C) it has no effect whatsoever.

[p_p_1]

Thanks Steve. I was a bit confused by the "abstract interface", I thought it was a different beast against interface. Hence the subroutine call and not a function, etc.. So now I compiled with simply "interface" in the code (had no problems).

@Repeat  Interesting debug. In my case /check:stack couldn't find anything. I rewrote my code taking into account the observations (converted tabs in space too! But I love tabs...). I changed some name following your scheme.

I allow myself to re-post my code (I hope correct, this time) only because more compact, so it's easier to concentrate on the essentials.

A notation about the 64 bit integer data type (your T_LARGE_INTEGER). I didn't know it could be joined directly storing it in a suitable variable, because it's provided in two parts originally, for what I understood. I did the same in my new code (but without declaring a new type). Anyway, I wonder if this is the better choice. The IFWINTY matching type (T_FILETIME) leaves the two parts separated. I used it previously in a little code and joined manually the two parts of an unsigned one (with the necessary math) even changing some bits, when needed (in case of negative values, by the Fortran perspective). And, once again, I wonder how dangerous this practice could be, if applied in an automated way.

[JVanB]

Yeah, that's why I had the program print out the bitness of the Fortran processor. When that is critically important to the outcome of the test the bitness should be manifest from the output.

Getting back to the example of Quote #15: I neglected to mention that

character(C_CHAR) :: x

is kind of a silly statement, declaring as it does LEN(x) = C_CHAR, while leaving the default KIND(x) = KIND('A'). Having composed an example showing that not getting the calling convention correct in an interface body can cause errors that are intermittent, hence potentially difficult to debug, I would like to show that not properly NUL-terminating a string that will be digested by a C function can have similar consequences.

module M
   use ISO_C_BINDING
   implicit none
   private
   integer, parameter, public :: HANDLE = C_INTPTR_T
   integer, parameter, public :: DWORD = C_LONG
   public LoadLibrary, GetLastError
   interface 
      function LoadLibrary(lpFileName) bind(C,name='LoadLibraryA')   ! the ansi version
         import
         implicit none
         character(kind=C_CHAR) :: lpFileName(*) 
         !DEC$ ATTRIBUTES STDCALL :: LoadLibrary 
         !GCC$ ATTRIBUTES STDCALL :: LoadLibrary 
         INTEGER(HANDLE) :: LoadLibrary 
      end function LoadLibrary 

      function GetLastError() bind(C,name='GetLastError')
         import
         implicit none
         !DEC$ ATTRIBUTES STDCALL :: GetLastError
         !GCC$ ATTRIBUTES STDCALL :: GetLastError
         integer(DWORD) GetLastError
      end function GetLastError
   end interface

end module M

program P
   use M
   implicit none
   character(260) lpLibFileName(2)
   integer(HANDLE) module_handle
   integer(DWORD) LastError

   lpLibFileName = [character(260)::'ntdll.dll','Garbage'//achar(0)]
!   lpLibFileName = [character(260)::'ntdll.dll',achar(0)//'Garbage']
   module_handle = LoadLibrary(lpLibFileName(1))
   LastError = GetLastError()

   write(*,'(*(g0))') 'This is a ',bit_size(module_handle),'-bit program'
   if(module_handle /= 0) then
      write(*,'(a,z0)') 'LoadLibrary succeeded. Handle = ',module_handle
   else
      write(*,'(a,i0)') 'LoadLibrary failed with error status = ',LastError
   end if
end program P

In the above code, in all cases (ifort/gfortran; 32/64 bits) LoadLibrary fails with error code 126 (ERROR_MOD_NOT_FOUND), but if the commented line is instead left in effect, then LoadLibrary does indeed return a valid module handle. The successful code had a NUL as the first nonblank character after the FileName and the failing code had other nonblank garbage between the file name and the first NUL. That's real common for improperly terminated strings to work for a while and then mysteriously fail, and hopefully this test can make you appreciate why that should be the case.

BTW, in the first version of this example, the call to GetLastError was positioned after the first WRITE statement and then ifort (but not gfortran) would return LastError = 203 (ERROR_ENVVAR_NOT_FOUND). I suppose ifort checks environmental variables to determine how it's supposed to do I/O, and that's why the error status gets reset like this?

[andrew_4619]

BTW, in the first version of this example, the call to GetLastError was positioned after the first WRITE statement and then ifort (but not gfortran) would return LastError = 203 (ERROR_ENVVAR_NOT_FOUND). I suppose ifort checks environmental variables to determine how it's supposed to do I/O, and that's why the error status gets reset like this?

I had a small whinge about in a thread last year. Lots of the Fortran run-time does operations that leave a windows error status set on exit even if there is no 'Fortran' error. In my debug software I have a general error trapper that is called routinely and pulls up 'false' errors in this way, it is a useful development tool so show errors I have not properly trapped and dealt with, but I have to add matching error reset calls for each of these "false positives".  My opinion is that the Fortran run functions such as 'OPEN' , 'INQUIRE' etc should leave the windows error state unchanged if the exit without a "Fortran" error. I did however get shot down in flames..... 

[Steven_L_Intel1]

p. p., your revised example is not really correct. The distinction between "interface" and "abstract interface" is that "interface" always declares an external procedure - that is, one the linker could find. "abstract interface" is just a model of a procedure, a prototype in C terms. When you are declaring a procedure pointer, you would generally use an abstract interface unless you had an actual procedure somewhere specified by the (non-abstract) interface.

I'd also recommend against hard-coding the path to ntdll.dll, as the path to that will vary depending on whether you build a 32 or 64-bit application, or if the program is used on a non-English Windows system. Since ntdll.dll is always going to be in PATH, you can just use the DLL name.

As for the error 203, my guess is that this was actually a side-effect of stack corruption and the number is meaningless.

[p_p_1]

Edited after report in #31. Just replaced a "interface" with "abstract interface".

An example for loading a module with the Windows' LoadLibrary and GetProcAddress.

program CallingLoadLibrary
use ISO_C_BINDING
implicit none

interface 
    function LoadLibrary(lpFileName) bind(C, name='LoadLibraryA')    ! the ansi version
        use ISO_C_BINDING
        implicit none
        !DEC$ ATTRIBUTES STDCALL :: LoadLibrary 
        character(C_CHAR) :: lpFileName(*) 
        INTEGER(C_INTPTR_T) :: LoadLibrary 
    end function LoadLibrary 

    function GetProcAddress(hModule, lpProcName) bind(C, name='GetProcAddress')
        use ISO_C_BINDING
        implicit none
        !DEC$ ATTRIBUTES STDCALL :: GetProcAddress
        TYPE(C_FUNPTR) :: GetProcAddress
        INTEGER(C_INTPTR_T), value :: hModule
        character(C_CHAR) :: lpProcName(*)
    end function GetProcAddress
end interface

abstract interface
    function NtQuerySystemTimeX(SystemTime) bind(C)
        use ISO_C_BINDING
        implicit none
        !DEC$ ATTRIBUTES STDCALL :: NtQuerySystemTimeX
        INTEGER(C_LONG) NTQuerySystemTimeX
        INTEGER(C_INT64_T) :: SystemTime
    end function
end interface

character*(260) lpLibFileName
character*(260) lpProcName
INTEGER(C_INT64_T) :: SystemTime
INTEGER(C_INTPTR_T) :: module_handle
TYPE(C_FUNPTR) :: module_address
INTEGER(C_LONG) :: ret_val
PROCEDURE(NtQuerySystemTimeX), POINTER :: NtQuerySystemTime


lpLibFileName="C:\Windows\system32\ntdll.dll" // achar(0)        ! "ntdll.dll" is good anyway
lpProcName="NtQuerySystemTime" // achar(0)

module_handle=LoadLibrary(lpLibFileName)
module_address=GetProcAddress(module_handle,lpProcName)

call C_F_PROCPOINTER(module_address, NtQuerySystemTime)
ret_val=NtQuerySystemTime(SystemTime)

write (*,*) ret_val                    ! return value, 0=success
write (*,*) trim(lpLibFileName)        ! loaded module name
write (*,*) module_handle              ! module handle
write (*,*) SystemTime                 ! 100-nanosecond intervals since January 1, 1601 (UTC)

end program CallingLoadLibrary

Command line:  ifort source.f90 /libs:static /exe:program.exe

[JVanB]

Except that the 203 happened in the test code that didn't corrupt the stack. Here, let me show you:

program P
   use IFWIN
   implicit none
   integer(HANDLE) module_handle
   integer(DWORD) LastError
   integer(DWORD) FirstError

   module_handle = LoadLibrary('Total junk'//achar(0))
   FirstError = GetLastError()

   write(*,'(*(g0))') 'This is a ',bit_size(module_handle),'-bit program'
   if(module_handle /= 0) then
      write(*,'(a,z0)') 'LoadLibrary succeeded. Handle = ',module_handle
   else
      LastError = GetLastError()
      write(*,'(a,i0)') 'LoadLibrary failed with error status = ',LastError
   end if
   write(*,'(a,i0)') 'FirstError = ',FirstError
end program P

Output:

This is a 64-bit program
LoadLibrary failed with error status = 203
FirstError = 126

As can be seen, trying to load 'total junk' causes a 126, and it's the WRITE statement (and its context) that causes the 203.

[Steven_L_Intel1]

I see. The WRITE causes an implicit OPEN that queries several environment variables. Some of these may not exist and the query fails. This is harmless, but changes the "last error". Moral: Always call GetLastError right away and don't do other things that call out to the OS in the middle.

[jimdempseyatthecove]

R.O.,

Stack corruption could still be the case where:

LoadLibrary('ValidLibraryName'//achar(0))

gets corrupted to:

LoadLibrary('corrupted name or corrupted address of name')

Since 203 is being reported, I suspect the name is getting corrupted (else a different runtime error may have been expected).

Jim Dempsey

[p_p_1]

Steve Lionel (Intel) wrote:

...

I'd also recommend against hard-coding the path to ntdll.dll, as the path to that will vary depending on whether you build a 32 or 64-bit application, or if the program is used on a non-English Windows system. Since ntdll.dll is always going to be in PATH, you can just use the DLL name.

I know the generally Fortran is used for certain purposes, but if we want to look at it as a real Win32 programming language the perspective may change.

Without specifying a full path you are more easily exposed to a DLL hijacking attack. In this article is Microsoft itself that at the first place of this guidelines affirms: "Wherever possible, specify a fully qualified path when using the LoadLibrary, LoadLibraryEx, CreateProcess, or ShellExecute functions.". Just to make things clear, this countermeasure alone could be unuseful (as often happens).

More in general, a module could be located anywhere on disk and one may prefer avoiding to fill the PATH of the environment variables. Just recently I exhausted the space available for PATH (maybe 2048 characters, can't remember) and had to clean up several (unuseful) entries.

Till now, it seems to me that the only way to freely specify the path is not to use the Fortran module loader.

[Ambaprasad_P_]

Dear Steve

Thanks for your reply,It has got me started.

How do i invoke the 64 bit IVF compiler from visual studio by default.?

Do vb.net programs compile to a 64 bit binary from VS2012 by default?

Thanks

Regards

Ambaprasad P

[Steven_L_Intel1]

In VS you need to go to Build > Configuration Manager, create a New configuration for the x64 platform, and use that. This will select the 64-bit compiler. There is no concept of selecting a 32/64-bit compiler "by default".

VB.NET builds for "Any CPU", which will NOT work with DLLs on a 64-bit platform. You need to explicitly set the target to be x64.

[p_p_1]

Tried to enable the SeDebugPrivilege for the current process, but failed.

Can't understand if it's a permissions issue or programming itself.

Some of the used functions are OpenProcessToken, LookupPrivilegeValue, AdjustTokenPrivileges.

The code:

program change_token
use IFWINTY
use KERNEL32, only: GetLastError, GetCurrentProcess
use ADVAPI32, only: OpenProcessToken, AdjustTokenPrivileges, LookupPrivilegeValue
implicit none

integer(DWORD) :: geterror
! GetCurrentProcess
integer(HANDLE) :: handle_CurrentProcess
! LookupPrivilegeValue
integer(BOOL) :: ret_val_LookupPrivilegeValue
character*(48) :: lpSystemName
character*(48) :: lpName
type(T_LUID) :: lpLuid
! OpenProcessToken
integer(BOOL) :: ret_val_OpenProcessToken
integer(HANDLE) :: ProcessHandle
integer(DWORD) :: DesiredAccess
integer(HANDLE) :: TokenHandle
! AdjustTokenPrivileges
integer(BOOL) :: ret_val_AdjustTokenPrivileges
integer(HANDLE) :: TokenHandle2
integer(BOOL) :: DisableAllPrivileges
type(T_TOKEN_PRIVILEGES) :: NewState
integer(DWORD) :: BufferLength
type(T_TOKEN_PRIVILEGES) :: PreviousState
integer(LPDWORD) :: ReturnLength


! GetCurrentProcess
handle_CurrentProcess=GetCurrentProcess()

! OpenProcessToken
DesiredAccess=TOKEN_ADJUST_PRIVILEGES .OR. TOKEN_QUERY         ! DesiredAccess=(#0008) .OR. (#0020)
ret_val_OpenProcessToken=OpenProcessToken(handle_CurrentProcess, DesiredAccess, TokenHandle)

! LookupPrivilegeValue
lpSystemName=achar(0)
lpName="SeDebugPrivilege" // achar(0)
ret_val_LookupPrivilegeValue=LookupPrivilegeValue(lpSystemName, lpName, lpLuid)

! AdjustTokenPrivileges
DisableAllPrivileges=FALSE
NewState%PrivilegeCount=1
NewState%Privileges%Luid=lpLuid
NewState%Privileges%Attributes=SE_PRIVILEGE_ENABLED
BufferLength=50000                                         ! tried 500000 too
TokenHandle2=TokenHandle
ret_val_AdjustTokenPrivileges=AdjustTokenPrivileges(&
          TokenHandle2, DisableAllPrivileges, NewState, BufferLength, PreviousState, ReturnLength)
geterror=GetLastError()


write (*,*)
write (*,*)
write (*,"('ret_val_OpenProcessToken:',i6,'   (non-zero=ok)')") ret_val_OpenProcessToken
write (*,"('DesiredAccess:',i6)") DesiredAccess
write (*,"('TokenHandle:',i6)") TokenHandle
write (*,*)
write (*,"('ret_val_LookupPrivilegeValue:',i6,'   (non-zero=ok)')") ret_val_LookupPrivilegeValue
write (*,"('lpLuid LowPart:',i6)") lpLuid%LowPart
write (*,"('lpLuid HighPart:',i6)") lpLuid%HighPart
write (*,*)
write (*,"('ret_val_AdjustTokenPrivileges:',i6,'   (non-zero=ok)')") ret_val_AdjustTokenPrivileges
write (*,"('PreviousState PrivilegeCount:',i6,'   (number of privileges changed)')") PreviousState%PrivilegeCount
write (*,"('LastError (Windows):',i6)") geterror
write (*,*)
write (*,*)

call system ('pause')       ! to check SeDebugPrivilege status with third party software

end program change_token

[p_p_1]

I had a bit of time and could review the code above.

This time I could enable the SeDebugPrivilege for the current process, but only calling AdjustTokenPrivileges with LoadLibrary.

In the non-working code I used the Intel libraries, but always getting a Windows last error code 998 (Invalid access to memory location).
IFWINTY forces you to treat the NewState parameter as a structure and not as a pointer. At first I thought it could be an error, the again I saw in advapi32.f90 that the directive
!DEC$ ATTRIBUTES REFERENCE, IGNORE_LOC, ALLOW_NULL :: NewState
was used. Anyway it didn't work for me.

My new code "seems" to work, but with some odd behavior. AdjustTokenPrivileges indicated success even when the privilege was not changed; the MSDN page says: "Call the GetLastError function to determine whether the function adjusted all of the specified privileges", but it returned always zero. I was able to change the privilege always (and not only few times, seemingly randomly) only passing by value the DisableAllPrivileges parameter, which is BOOL.

You may chech the privileges status of running processes with Sysinternals Process Explorer or Process Hacker.

Command line: ifort source.f90 /exe:program.exe

program change_token
use IFWINTY
use ISO_C_BINDING
use KERNEL32, only: GetLastError, GetCurrentProcess
use ADVAPI32, only: OpenProcessToken, LookupPrivilegeValue
implicit none

interface 
    function LoadLibrary(lpFileName) bind(C,name='LoadLibraryA')
        use ISO_C_BINDING
        implicit none
        character(C_CHAR) :: lpFileName(*) 
        !DEC$ ATTRIBUTES STDCALL :: LoadLibrary 
        INTEGER(C_INTPTR_T) :: LoadLibrary 
    end function LoadLibrary 

    function GetProcAddress(hModule, lpProcName) bind(C, name='GetProcAddress')
        use ISO_C_BINDING
        implicit none
        !DEC$ ATTRIBUTES STDCALL :: GetProcAddress
        TYPE(C_FUNPTR) :: GetProcAddress
        INTEGER(C_INTPTR_T), value :: hModule
        character(C_CHAR) :: lpProcName(*)
    end function GetProcAddress
end interface

abstract interface
    function AdjustTokenPrivileges_Z(TokenHandle2,DisableAllPrivileges,NewState,BufferLength,PreviousState,ReturnLength) bind(C)
        use IFWINTY
        use ISO_C_BINDING
        implicit none
        !DEC$ ATTRIBUTES STDCALL :: AdjustTokenPrivileges_Z
        integer(BOOL) :: AdjustTokenPrivileges_Z
        integer(HANDLE), value :: TokenHandle2
        integer(BOOL), value :: DisableAllPrivileges
        !DEC$ ATTRIBUTES ALLOW_NULL :: NewState
        type(C_PTR), value :: NewState
        integer(DWORD), value :: BufferLength
        !DEC$ ATTRIBUTES ALLOW_NULL :: PreviousState
        type(C_PTR), value :: PreviousState
        integer(LPDWORD) :: ReturnLength
    end function
end interface


character*(260) lpLibFileName
character*(260) lpProcName
INTEGER(C_INTPTR_T) :: module_handle
TYPE(C_FUNPTR) :: module_address
integer(DWORD) :: geterror
! GetCurrentProcess
integer(HANDLE) :: handle_CurrentProcess
! LookupPrivilegeValue
integer(BOOL) :: ret_val_LookupPrivilegeValue
character*(48) :: lpSystemName
character*(48) :: lpName
type(T_LUID) :: lpLuid
! OpenProcessToken
integer(BOOL) :: ret_val_OpenProcessToken
integer(HANDLE) :: ProcessHandle
integer(DWORD) :: DesiredAccess
integer(HANDLE) :: TokenHandle
! AdjustTokenPrivileges
procedure(AdjustTokenPrivileges_Z), pointer :: AdjustTokenPrivileges
integer(BOOL) :: ret_val_AdjustTokenPrivileges
integer(HANDLE) :: TokenHandle2
integer(BOOL) :: DisableAllPrivileges
type(C_PTR) :: NewState
integer(DWORD) :: BufferLength
type(C_PTR) :: PreviousState
integer(LPDWORD) :: ReturnLength
type(T_TOKEN_PRIVILEGES) :: NewState_structure


! GetCurrentProcess
handle_CurrentProcess=GetCurrentProcess()

! OpenProcessToken
DesiredAccess=TOKEN_ADJUST_PRIVILEGES .OR. TOKEN_QUERY        ! DesiredAccess=(#0008) .OR. (#0020)
ProcessHandle=handle_CurrentProcess
ret_val_OpenProcessToken=OpenProcessToken(ProcessHandle, DesiredAccess, TokenHandle)

! LookupPrivilegeValue
lpSystemName=achar(0)
lpName="SeDebugPrivilege" // achar(0)
ret_val_LookupPrivilegeValue=LookupPrivilegeValue(lpSystemName, lpName, lpLuid)

! AdjustTokenPrivileges
NewState_structure%PrivilegeCount=1              ! NewState structure with desired values
NewState_structure%Privileges%Luid=lpLuid
NewState_structure%Privileges%Attributes=SE_PRIVILEGE_ENABLED          ! = (#00000002)

lpLibFileName="advapi32.dll" // achar(0)
lpProcName="AdjustTokenPrivileges" // achar(0)
module_handle=LoadLibrary(lpLibFileName)
module_address=GetProcAddress(module_handle,lpProcName)
call C_F_PROCPOINTER(module_address, AdjustTokenPrivileges)

TokenHandle2=TokenHandle
DisableAllPrivileges=FALSE
NewState=c_loc(NewState_structure)            ! gets the address of the NewState structure
BufferLength=256
ret_val_AdjustTokenPrivileges=AdjustTokenPrivileges(&
                        TokenHandle2, DisableAllPrivileges, NewState, BufferLength, PreviousState, ReturnLength)

                        
geterror=GetLastError()
write (*,*)
write (*,*)
write (*,"('ret_val_AdjustTokenPrivileges:',i6,'   (non-zero=ok)')") ret_val_AdjustTokenPrivileges
write (*,"('LastError (Windows):',i6)") geterror
write (*,*)
write (*,*)

call system ('pause')              ! to check SeDebugPrivilege status with third party software

end program change_token

[p_p_1]

Steve, two different methods have been used and there have been issues, only partially solved.

It would be certainly well accepted a clarification about this.

[Steven_L_Intel1]

I can tell you why your first version didn't work - you told AdjustTokenPrivileges that the size of PreviousToken was 5000 when it is more like 8. If you fix that, then the call returns success. When I tried it, it said that no privileges were changed - that's something I can't help with. (Though it looks as if you asked for debug privilege, which I'm pretty sure my process already had.)

There's nothing particularly wrong with the declaration of the types in IFWINTY - it matches that in winnt.h. But if you want to hold more than one privilege you have to get clever with pointers.

Here's my corrected version.

program change_token
use IFWINTY
use KERNEL32, only: GetLastError, GetCurrentProcess
use ADVAPI32, only: OpenProcessToken, AdjustTokenPrivileges, LookupPrivilegeValue
implicit none

integer(DWORD) :: geterror
! GetCurrentProcess
integer(HANDLE) :: handle_CurrentProcess
! LookupPrivilegeValue
integer(BOOL) :: ret_val_LookupPrivilegeValue
character*(48) :: lpSystemName
character*(48) :: lpName
type(T_LUID) :: lpLuid
! OpenProcessToken
integer(BOOL) :: ret_val_OpenProcessToken
integer(HANDLE) :: ProcessHandle
integer(DWORD) :: DesiredAccess
integer(HANDLE) :: TokenHandle
! AdjustTokenPrivileges
integer(BOOL) :: ret_val_AdjustTokenPrivileges
integer(HANDLE) :: TokenHandle2
integer(BOOL) :: DisableAllPrivileges
type(T_TOKEN_PRIVILEGES) :: NewState
type(T_TOKEN_PRIVILEGES) :: PreviousState
integer(LPDWORD) :: ReturnLength
pointer (P_PreviousState, PreviousState)
integer, parameter :: S_PreviousState = 5000

geterror = 0

! GetCurrentProcess
handle_CurrentProcess=GetCurrentProcess()

! OpenProcessToken
DesiredAccess=TOKEN_ADJUST_PRIVILEGES .OR. TOKEN_QUERY         ! DesiredAccess=(#0008) .OR. (#0020)
ret_val_OpenProcessToken=OpenProcessToken(handle_CurrentProcess, DesiredAccess, TokenHandle)

! LookupPrivilegeValue
lpSystemName=achar(0)
lpName="SeDebugPrivilege" // achar(0)
ret_val_LookupPrivilegeValue=LookupPrivilegeValue(lpSystemName, lpName, lpLuid)

! AdjustTokenPrivileges
DisableAllPrivileges=FALSE
NewState%PrivilegeCount=1
NewState%Privileges%Luid=lpLuid
NewState%Privileges%Attributes=SE_PRIVILEGE_ENABLED
! Allocate space for PreviousState
P_PreviousState = malloc(S_PreviousState)
TokenHandle2=TokenHandle
ret_val_AdjustTokenPrivileges=AdjustTokenPrivileges(&
          TokenHandle2, DisableAllPrivileges, NewState,S_PreviousState, PreviousState, loc(ReturnLength))
if (ret_val_AdjustTokenPrivileges == 0) geterror=GetLastError()


write (*,*)
write (*,*)
write (*,"('ret_val_OpenProcessToken:',i6,'   (non-zero=ok)')") ret_val_OpenProcessToken
write (*,"('DesiredAccess:',i6)") DesiredAccess
write (*,"('TokenHandle:',i6)") TokenHandle
write (*,*)
write (*,"('ret_val_LookupPrivilegeValue:',i6,'   (non-zero=ok)')") ret_val_LookupPrivilegeValue
write (*,"('lpLuid LowPart:',i6)") lpLuid%LowPart
write (*,"('lpLuid HighPart:',i6)") lpLuid%HighPart
write (*,*)
write (*,"('ret_val_AdjustTokenPrivileges:',i6,'   (non-zero=ok)')") ret_val_AdjustTokenPrivileges
write (*,"('PreviousState PrivilegeCount:',i6,'   (number of privileges changed)')") PreviousState%PrivilegeCount
write (*,"('LastError (Windows):',i6)") geterror
write (*,*)
write (*,*)

call system ('pause')       ! to check SeDebugPrivilege status with third party software

end program change_token

[Steven_L_Intel1]

Oh, you should replace that .OR. with a call to IOR().