Shareware Supreme Volume 6 #1/swsii.zip/swsii/215/DDJWIN.ZIP/FORTAN.ASC

Text File | 1993-08-31 | 21KB | 705 lines

_MULTITASKING FORTRAN AND WINDOWS NT_
by Shakar Vaidyanathan


[LISTING ONE]

 interface to integer*4 function CreateEvent
+    [stdcall, alias: '_CreateEventA@16']
+    (security, reset, init_state, string)
   integer*4 security [value]
   Logical*4 reset [value]
   Logical*4 init_state [value]
   integer*4 string [value]
 end

 interface to integer*4 function CreateMutex
+    [stdcall, alias: '_CreateMutexA@12']
+    (security, owner, string)
    integer*4 security [value]
    Logical*4 owner [value]
    integer*4 string [value]
  end

  interface to logical*4 function CreateProcess
 +    [stdcall, alias: '_CreateProcessA@40']
 +    (lpApplicationName, lpCommandLine, lpProcessAttributes,
 +    lpThreadAttributes, bInheritHandles, dwCreationFlags,
 +    lpEnvironment, lpCurrentDirectory, lpStartupInfo,
 +    lpProcessInformation)
    integer*4 lpApplicationName [value]
    integer*4 lpCommandLine [value]
    integer*4 lpProcessAttributes [value]
    integer*4 lpThreadAttributes [value]
    logical*4 bInheritHandles [value]
    integer*4 dwCreationFlags [value]
    integer*4 lpEnvironment [value]
    integer*4 lpCurrentDirectory [value]
    integer*4 lpStartupInfo [value]
    integer*4 lpProcessInformation [value]
  end

  interface to integer*4 function CreateSemaphore
 +    [stdcall, alias: '_CreateSemaphoreA@16']
 +    (security, InitialCount, MaxCount, string)
    integer*4 security [value]
    integer*4 InitialCount [value]
    integer*4 MaxCount [value]
    integer*4 string [value]
  end

  interface to integer*4 function CreateThread
 +    [stdcall, alias: '_CreateThread@24']
 +    (security, stack, thread_func,
 +    argument, flags, thread_id)
    integer*4 security [value]
    integer*4 stack [value]
    integer*4 thread_func [value]
    integer*4 argument [reference]
    integer*4 flags [value]
    integer*4 thread_id [reference]
  end

  interface to subroutine DeleteCriticalSection
 +    [stdcall, alias: '_DeleteCriticalSection@4'] (object)
    integer*4 object [value]
  end

  interface to logical*4 function DuplicateHandle
 +    [stdcall, alias: '_DuplicateHandle@28']
 +    (hSourceProcessHandle, hSourceHandle,
 +     hTargetProcessHandle, lpTargetHandle,
 +     dwDesiredAccess, bInheritHandle, dwOptions)
    integer*4 hSourceProcessHandle [value]
    integer*4 hSourceHandle [value]
    integer*4 hTargetProcessHandle [value]
    integer*4 lpTargetHandle [reference]
    integer*4 dwDesiredAccess [value]
    logical*4 bInheritHandle [value]
    integer*4 dwOptions [value]
  end

  interface to subroutine EnterCriticalSection
 +    [stdcall, alias: '_EnterCriticalSection@4'] (object)
    integer*4 object [value]
  end

  interface to subroutine ExitProcess
 +    [stdcall, alias: '_ExitProcess@4'] (ExitCode)
    integer*4 ExitCode [value]
  end

  interface to subroutine ExitThread
 +    [stdcall, alias: '_ExitThread@4'] (ExitCode)
    integer*4 ExitCode [value]
  end

  interface to integer*4 function GetCurrentProcess
 +   [stdcall, alias: '_GetCurrentProcess@0'] ()
  end

  interface to integer*4 function GetCurrentProcessId
 +   [stdcall, alias: '_GetCurrentProcessId@0'] ()
  end

  interface to integer*4 function GetCurrentThread
 +   [stdcall, alias: '_GetCurrentThread@0'] ()
  end

  interface to integer*4 function GetCurrentThreadId
 +   [stdcall, alias: '_GetCurrentThreadId@0'] ()
  end

  interface to logical*4 function GetExitCodeProcess
 +   [stdcall, alias: '_GetExitCodeProcess@8']
 +   (hProcess, lpExitCode)
    integer*4 hProcess [value]
    integer*4 lpExitCode [reference]
  end

  interface to logical*4 function GetExitCodeThread
 +   [stdcall, alias: '_GetExitCodeThread@8']
 +   (hThread, lpExitCode)
    integer*4 hThread [value]
    integer*4 lpExitCode [reference]
  end

  interface to integer*4 function GetLastError
 +    [stdcall, alias: '_GetLastError@0'] ()
  end

  interface to integer*4 function GetThreadPriority
 +   [stdcall, alias: '_GetThreadPriority@4'] (hThread)
    integer*4 hThread [value]
  end

  interface to logical*4 function GetThreadSelectorEntry
 +   [stdcall, alias: '_GetThreadSelectorEntry@12']
 +   (hThread, dwSelector, lpSelectorEntry)
    integer*4 hThread [value]
    integer*4 dwSelector [value]
    integer*4 lpSelectorEntry [value]    ! Pass loc of the struct
  end

  interface to subroutine InitializeCriticalSection
 +    [stdcall, alias: '_InitializeCriticalSection@4'] (object)
    integer*4 object [value]
  end

  interface to subroutine LeaveCriticalSection
 +    [stdcall, alias: '_LeaveCriticalSection@4'] (object)
    integer*4 object [value]
  end

  interface to integer*4 function OpenEvent
 +     [stdcall, alias: '_OpenEventA@12']
 +     (dwDesiredAccess, bInheritHandle, lpName)
    integer*4 dwDesiredAccess [value]
    logical*4 bInheritHandle [value]
    integer*4 lpName [value]
  end

  interface to integer*4 function PulseEvent
 +    [stdcall, alias: '_PulseEvent@4'] (hEvent)
    integer*4 hEvent [value]
  end

  interface to Logical*4 function ReleaseMutex
 +    [stdcall, alias: '_ReleaseMutex@4'] (handle)
    integer*4 handle [value]
  end

  interface to Logical*4 function ReleaseSemaphore
 +    [stdcall, alias: '_ReleaseSemaphore@12']
 +    (handle, ReleaseCount, LpPreviousCount)
    integer*4 handle [value]
    integer*4 ReleaseCount [value]
    integer*4 LpPreviousCount [reference]
  end

  interface to integer*4 function ResumeThread
 +   [stdcall, alias: '_ResumeThread@4'] (hThread)
    integer*4 hThread [value]
  end

  interface to integer*4 function SetEvent
 +    [stdcall, alias: '_SetEvent@4'] (handle)
    integer*4 handle [value]
  end

  interface to subroutine SetLastError
 +    [stdcall, alias: '_SetLastError@4'] (dwErrorCode)
    integer*4 dwErrorCode [value]
  end

  interface to logical*4 function SetThreadPriority
 +   [stdcall, alias: '_SetThreadPriority@8'](hThread, nPriority)
    integer*4 hThread [value]
    integer*4 nPriority [value]
  end

  interface to integer*4 function SuspendThread
 +   [stdcall, alias: '_SuspendThread@4'] (hThread)
    integer*4 hThread [value]
  end

  interface to logical*4 function TerminateProcess
 +   [stdcall, alias: '_TerminateProcess@8']
 +   (hProcess, uExitCode)
    integer*4 hProcess [value]
    integer*4 uExitCode [value]
  end

  interface to logical*4 function TerminateThread
 +   [stdcall, alias: '_TerminateThread@8']
 +   (hThread, dwExitCode)
    integer*4 hThread [value]
    integer*4 dwExitCode [value]
  end

  interface to integer*4 function TlsAlloc
 +   [stdcall, alias: '_TlsAlloc@0'] ()
  end

  interface to logical*4 function TlsFree
 +   [stdcall, alias: '_TlsFree@4'] (dwTlsIndex)
    integer*4 dwTlsIndex [value]
  end

  interface to integer*4 function TlsGetValue
 +   [stdcall, alias: '_TlsGetValue@4'] (dwTlsIndex)
    integer*4 dwTlsIndex [value]
  end

  interface to logical*4 function TlsSetValue
 +   [stdcall, alias: '_TlsSetValue@8'] (dwTlsIndex, lpTlsVal)
    integer*4 dwTlsIndex [value]
    integer*4 lpTlsVal [value]
  end

  interface to integer*4 function WaitForMultipleObjects
 +    [stdcall, alias: '_WaitForMultipleObjects@16']
 +    (Count, LpHandles, WaitAll, Mseconds)
    integer*4 Count [value]
    integer*4 LpHandles [reference]
    logical*4 WaitAll [value]
    integer*4 Mseconds [value]
  end

  interface to integer*4 function WaitForSingleObject
 +    [stdcall, alias: '_WaitForSingleObject@8']
 +    (handle, Mseconds)
    integer*4 handle [value]
    integer*4 Mseconds [value]
  end



[LISTING TWO]

PARAMETER (MAX_THREADS = 50)
PARAMETER (WAIT_INFINITE = -1)
PARAMETER (STANDARD_RIGHTS_REQUIRED = #F0000)
PARAMETER (SYNCHRONIZE = #100000)

STRUCTURE /PROCESS_INFORMATION/
    integer*4 hProcess
    integer*4 hThread
    integer*4 dwProcessId
    integer*4 dwThreadId
END STRUCTURE

STRUCTURE /RTL_CRITICAL_SECTION_DEBUG/
    integer*4 Type
    integer*4 CreatorBackTraceIndex
    integer*4 Address
    integer*4 ProcessLocksList
    integer*4 EntryCount
    integer*4 ContentionCount
    integer*4 Depth
    integer*4 OwnerBackTrace(5)
END STRUCTURE

STRUCTURE /RTL_CRITICAL_SECTION/
    integer*4 Address
    integer*4 LockCount
    integer*4 RecursionCount
    integer*4 OwningThread
    integer*4 LockSemaphore
    integer*4 Reserved
END STRUCTURE

STRUCTURE /SECURITY_ATTRIBUTES/
    integer*4 nLength
    integer*4 lpSecurityDescriptor
    logical*4 bInheritHandle
END STRUCTURE

STRUCTURE /STARTUPINFO/
    integer*4 cb
    integer*4 lpReserved
    integer*4 lpDesktop
    integer*4 lpTitle
    integer*4 dwX
    integer*4 dwY
    integer*4 dwXSize
    integer*4 dwYSize
    integer*4 dwXCountChars
    integer*4 dwYCountChars
    integer*4 dwFillAttribute
    integer*4 dwFlags
    integer*2 wShowWindow
    integer*2 cbReserved2
    integer*4 lpReserved2
END STRUCTURE



[LISTING THREE]

Program to demonstrate thread creation and critical section object
      include 'mt.fi'

Thread function as a subroutine
      subroutine ThreadFunc (param)
      include 'mt.fd'
      integer*4 param, result
      record /RTL_CRITICAL_SECTION/ GlobalCriticalSection
      record /RTL_CRITICAL_SECTION_DEBUG/ AuxCriticalSection
      common result, GlobalCriticalSection

Critical section region begins...
      Call EnterCriticalSection ( loc(GlobalCriticalSection))
          result = param + result

Critical section region ends...
      Call LeaveCriticalSection ( loc(GlobalCriticalSection))
      Call ExitThread(0)
      return
      end

Main program begins here
      program test
      include 'mt.fd'
      external ThreadFunc
      integer*4 ThreadHandle(MAX_THREADS), inarray(MAX_THREADS)
      integer*4 CreateThread, threadId
      integer*4 waitResult, WaitForMultipleObjects
      integer*4 loop, result
      record /RTL_CRITICAL_SECTION/ GlobalCriticalSection
      record /RTL_CRITICAL_SECTION_DEBUG/ AuxCriticalSection
      common result, GlobalCriticalSection

Creating the cyclic structure for the critical section object
      GlobalCriticalSection.Address = loc(AuxCriticalSection)
      AuxCriticalSection.Address = loc(GlobalCriticalSection)

      result = 0

Initializing critical section...
      Call InitializeCriticalSection(loc(GlobalCriticalSection))

      do loop = 1, MAX_THREADS
         inarray(loop)= loop
         write(*, '(1x, A, I3)') 'Creating Thread # ', loop
         ThreadHandle(loop) = CreateThread( 0, 0, loc(ThreadFunc), inarray(loop), 0, threadId)
      end do

      write(*,*) 'Waiting for all the threads to complete ...'
      waitResult = WaitForMultipleObjects
     +   (MAX_THREADS, ThreadHandle, .TRUE. , WAIT_INFINITE)
      write(*, '(1x, A, I6, A, I10)' )
     +   'The sum of the first ', MAX_THREADS,' #s is ', result
      end


[LISTING FOUR]

Program to demostrate the semaphore and mutual exclusion objects
      include 'mt.fi'

The thread function begins here
      subroutine ThreadFunc (param)
      include 'mt.fd'
      integer*4 param, waitResult, WaitForSingleObject
      integer*4 ThreadCounter
      integer*4 result, hMutex, hSemaphore, PreviousCount
      logical*4 release, ReleaseMutex, ReleaseSemaphore
      common result, hMutex, hSemaphore, ThreadCounter

Mutual exclusion region begins here
      waitResult = WaitForSingleObject(hMutex, WAIT_INFINITE)

Modifying the global variables
          result = param + result
          ThreadCounter = ThreadCounter + 1

Release the sempahore if this is the last thread
          if (ThreadCounter .EQ. MAX_THREADS)
     +         release = ReleaseSemaphore(hSemaphore, 1, PreviousCount)

Mutual exclusion region ends here
      release = ReleaseMutex(hMutex)
      return
      end

Main program begins here
      program test
      include 'mt.fd'
      external ThreadFunc
      integer*4 ThreadHandle, threadId
      integer*4 CreateSemaphore, CreateThread, CreateMutex
      integer*4 waitResult, WaitForSingleObject
      integer*4 loop
      integer*4 result, hMutex, hSemaphore, ThreadCounter
      integer*4 inarray
      dimension inarray(MAX_THREADS)
      common result, hMutex, hSemaphore, ThreadCounter

Initializing the global variables
      ThreadCounter = 0
      result = 0
      hMutex = CreateMutex(0, .FALSE. , 0)
      hSemaphore = CreateSemaphore(0, 0, 1, 0)

      do loop = 1, MAX_THREADS
         inarray(loop)= loop
         write(*,*) "Generating Thread #", loop
         ThreadHandle = CreateThread( 0, 0, loc(ThreadFunc),
     +         inarray(loop), 0, threadId)
      end do

      write(*,*) 'Waiting for the semaphore release...'
      waitResult = WaitForSingleObject(hSemaphore, WAIT_INFINITE)
      write(*, '(1x, A, I4, A, I8)')
     +    'The sum of the first ', MAX_THREADS,' #s is', result
      end



[LISTING FIVE]

Parent Program (process) passing names of event objects to child process
      include 'mt.fi'

      program Parent
      include 'mt.fd'
      logical*4 procHandle, CreateProcess
      integer*4 CreateEvent, hReadEvent, hWriteEvent, SetEvent
      integer*4 waitResult, WaitForSingleObject
      character*255 buffer
      character*10 strReadEvent, strWriteEvent, FileName

      record /PROCESS_INFORMATION/ pi
      record /STARTUPINFO/ si

Initializing the strings
      strReadEvent = 'ReadEvent '
      strWriteEvent = 'WriteEvent '
      FileName = ' file.out '
      buffer = "child "//strReadEvent//strWriteEvent//FileName//" "C
      strReadEvent(10:10) = char(0)
      strWriteEvent(10:10) = char(0)

Initializing the STARTUPINFO structure
      si.cb = 56             ! sizeof (STARTUPINFO)
      si.lpReserved = 0
      si.lpDeskTop = 0
      si.lpTitle = 0
      si.dwFlags = 0
      si.cbReserved2 = 0
      si.lpReserved2 = 0

Creating Read and Write Event objects
      hReadEvent = CreateEvent(0, .FALSE., .FALSE., loc(strReadEvent))
      hWriteEvent = CreateEvent(0, .FALSE., .FALSE.,loc(strWriteEvent))

Spawning the child prcoess
      procHandle=CreateProcess(0,loc(buffer),0,0,.TRUE.,0,0,0,loc(si),loc(pi))

Providing a question for the child
      open (10, file= FileName)
      write(10, '(A)') "What issue of Dr. Dobb's is this?"
      close (10)

      write(*,*) 'Providing the green signal for child to continue...'
      waitResult = SetEvent(hWriteEvent)
      write(*,*) 'Waiting for the child to answer the question - '
      waitResult = WaitForSingleObject (hReadEvent, WAIT_INFINITE)

Writing the reply from the child on to the screen
      open (10, file= FileName)
      read(10, '(A)') buffer
      close (10)
      write(*,*) buffer
      end




[LISTING SIX]

Child program (process) accepting named objects from the parent
      include 'mt.fi'

      program ChildProcess
      include 'mt.fd'

      character*255 buffer
      character*100 filename, strReadEvent, strWriteEvent
      integer*4 hReadEvent, hWriteEvent, OpenEvent, SetEvent
      integer*2 status
      integer*4 EVENT_ALL_ACCESS
      integer*4 waitResult, WaitForSingleObject

Retrieving the first command line parameter which is the name of the ReadEvent
      Call Getarg (1, buffer, status)
      strReadEvent(1:status) = buffer(1:status)
      status = status+1
      strReadEvent(status:status) = char(0) ! to make it a C string

Retrieving the second command line parameter which is the name of the WriteEvent
      Call Getarg (2, buffer, status)
      strWriteEvent(1:status) = buffer(1:status)
      status = status+1
      strWriteEvent(status:status) = char(0) ! to make it a C string

Setting the access privilege for the child
      EVENT_ALL_ACCESS = IOR (STANDARD_RIGHTS_REQUIRED, SYNCHRONIZE)
      EVENT_ALL_ACCESS = IOR (EVENT_ALL_ACCESS, #3)

Opening the handles for the event objects passed from the parent as named objects
      hReadEvent=OpenEvent(EVENT_ALL_ACCESS, .FALSE.,  loc(strReadEvent))
      hWriteEvent=OpenEvent(EVENT_ALL_ACCESS, .FALSE., loc(strWriteEvent))

Wait until the parent signals the WriteEvent
      waitResult = WaitForSingleObject(hWriteEvent, WAIT_INFINITE)

Retrieve the file name which is the third argument
      Call Getarg (3, buffer, status)
      filename (1:status) = buffer(1:status)

Read the parent's question and then reply
      open (11, file= filename, mode ='readwrite')
      read(11, '(A)') buffer
      print *, buffer
      rewind 11
      write(11, '(A)') 'September 1993 issue'
      close (11)

Signal the parent to continue
      waitResult = SetEvent(hReadEvent)
      end


[LISTING SEVEN]

A fragment of the parent program

 ...

Initialization of Security attributes for Read and Write Events
      record /SECURITY_ATTRIBUTES/ saR
      record /SECURITY_ATTRIBUTES/ saW

      saR.nLength = 12
      saR.lpSecurityDescriptor = 0
      saR.bInheritHandle = .TRUE.

      saW.nLength = 12
      saW.lpSecurityDescriptor = 0
      saW.bInheritHandle = .TRUE.

Creating events whose handles can be inherited
      hReadEvent = CreateEvent(loc(saR), .FALSE., .FALSE., 0)
      hWriteEvent = CreateEvent(loc(saW), .FALSE., .FALSE., 0)
 ...
-----------------------------------------------------------------------------
A fragment of the child program. Retrieve the handle to Read and Write
Events from the command line using Getarg, and assign them to integer
variables through Internal Read
      CALL GETARG(1, buffer, status)
      read(buffer(1:status), '(i4)') hReadEvent
      CALL GETARG(2, buffer, status)
      read(buffer(1:status), '(i4)') hWriteEvent

      waitResult = WaitForSingleObject(hWriteEvent, WAIT_INFINITE)
  ...



Example 1: (a) Prototyping CreateThread; (b) first argument to CreateThread is a structure prototyped in winbase.h; (c) implenting the structure using STRUCTURE/END STRUCTURE

(a)

    HANDLE WINAPI CreateThread (
        LP_SECURITY_ATTRIBUTES lpThreadAttributes,
        DWORD  dwStackSize,
        LPTHREAD_START_ROUTINE  lpStartAddress,
        LPVOID  lpParameter,
        DWORD  dwCreationFlags,
        LPDWORD  lpThreadId
        );


(b)

    typedef struct _SECURITY_ATTRIBUTES {
        DWORD nLength;
        LPVOID lpSecurityDescriptor;
        BOOL bInheritHandle;
    } SECURITY_ATTRIBUTES, *LPSECURITY_ATTRIBUTES;


(c)
    STRUCTURE /SECURITY_ATTRIBUTES/
        integer*4 length
        integer*4 lpSecurityDescriptor
        logical*4 bInheritHandle
    END STRUCTURE


Example 2:

(a)


typedef struct _RTL_CRITICAL_SECTION_DEBUG {
        WORD   Type;
        WORD   CreatorBackTraceIndex;
        struct _RTL_CRITICAL_SECTION *CriticalSection;
        LIST_ENTRY ProcessLocksList;
        DWORD EntryCount;
        DWORD ContentionCount;
        DWORD Depth;
        PVOID OwnerBackTrace[ 5 ];
} RTL_CRITICAL_SECTION_DEBUG, *PRTL_CRITICAL_SECTION_DEBUG;

typedef struct _RTL_CRITICAL_SECTION {
        PRTL_CRITICAL_SECTION_DEBUG DebugInfo;
        LONG LockCount;
        LONG RecursionCount;
        HANDLE OwningThread;        // from the thread's ClientId->UniqueThread
        HANDLE LockSemaphore;
        DWORD Reserved;
} RTL_CRITICAL_SECTION, *PRTL_CRITICAL_SECTION;



(b)

STRUCTURE /RTL_CRITICAL_SECTION_DEBUG/
    integer*4 Type
    integer*4 CreatorBackTraceIndex
    integer*4 Address
    integer*4 ProcessLocksList
    integer*4 EntryCount
    integer*4 ContentionCount
    integer*4 Depth
    integer*4 OwnerBackTrace(5)
END STRUCTURE

STRUCTURE /RTL_CRITICAL_SECTION/
    integer*4 Address
    integer*4 LockCount
    integer*4 RecursionCount
    integer*4 OwningThread
    integer*4 LockSemaphore
    integer*4 Reserved
END STRUCTURE
record /RTL_CRITICAL_SECTION/ GlobalCriticalSection
record /RTL_CRITICAL_SECTION_DEBUG/ AuxCriticalSection

GlobalCriticalSection.Address = loc(AuxCriticalSection)
AuxCriticalSection.Address = loc(GlobalCriticalSection)


Example 3:

    BOOL WINAPI CreateProcessA(
            LPCSTR lpApplicationName,
            LPCSTR lpCommandLine,
            LPSECURITY_ATTRIBUTES lpProcessAttributes,
            LPSECURITY_ATTRIBUTES lpThreadAttributes,
            BOOL bInheritHandles,
            DWORD dwCreationFlags,
            LPVOID lpEnvironment,
            LPSTR lpCurrentDirectory,
            LPSTARTUPINFOA lpStartupInfo,
            LPPROCESS_INFORMATION lpProcessInformation
    );


Figure 1: Interface statement for CreateThread

interface to integer*4 function CreateThread [stdcall, alias: '_CreateThread@24']
+   (security, stack, thread_func, arguments, flags, thread_id)
   integer*4  security, stack     [value]
   integer*4  thread_func [value] ! loc(thread_func) is passed by value
   integer*4  arguments   [reference]
   integer*4  flags       [value]
   integer*4  thread_id   [reference]
 end