=============================================================================== PROGRAM 1: (File COMM_SERVER.FOR) =============================================================================== PROGRAM COMM_SERVER C Author: J. Crum C Date : 6/25/91 C This program is run as a detached process. C It receives device communication requests from other processes, C acting as a communication server for a shared device such as a C PLC (Programmable Logic Controller) or other device which requires C frequent short messages. C The inter-process communication is performed via the lock C manager routines, using a common resource. This program C requires SYSLCK privilege. C This example program is set up to access device logical name PLC_12. C This name should be assigned to the physical or Lat port to which C the device is connected. This name is also used by the VMS Lock C Management routines as the resource name. C To compile and link: C $ FORTRAN COMM_SERVER C $ LINK COMM_SERVER C Assign the logical for the device: C $ ASSIGN/SYSTEM/EXEC LTA200: PLC_12 !For example C To run this program as a detached process: C $ RUN COMM_SERVER/DETACHED/PRIVILEGE=SYSLCK/PROCESS=COMM_SERVER_12 IMPLICIT INTEGER*4 (A-Z) INCLUDE '($LCKDEF)' !Lock manager definitions INCLUDE '($SSDEF)' !Status values CHARACTER*20 DEVICE_NAME /'PLC_12'/ !Resource name and !logical name of TT port. STRUCTURE /STATUS/ !Layout of lock status block INTEGER*2 CONDITION !VMS condition value INTEGER*2 %FILL !Reserved to DEC INTEGER*4 LOCKID !Lock ID longword BYTE VAL_BLOCK(16) !Lock value block END STRUCTURE RECORD /STATUS/ LCKSTB !Record for lock status block COMMON /LCKCOM/ LCKSTB !Share status block VOLATILE LCKCOM !Prevent compiler optimization INTEGER*4 FLAG1,FLAG2 !Flags for $ENQ INTEGER*4 ISTAT EXTERNAL BLOCKING,COMPLETION !AST entry points C INTEGER*2 LAT_IOST(4) !For LAT QIO example below C EXTERNAL IO$_TTY_PORT,IO$M_LT_CONNECT C First we open an I/O channel for communication to the device. C In this example, we don't do actual device I/O, but it might look C something like the commented lines below. Of course, you would C need to add error checking to the system service calls, and you C may want to specify an exit handler to clean up the LAT connection C at program exit, if applicable. C ISTAT=SYS$ASSIGN('PLC_12',CHANNEL,,) !Get channel for i/o. C LAT_FUNC=(%LOC(IO$_TTY_PORT) .OR. %LOC(IO$M_LT_CONNECT)) !LAT QIO funct. C ISTAT=SYS$QIOW(,%VAL(CHANNEL),%VAL(LAT_FUNC),LAT_IOST,,,,,,,,) C Set up the flag bits for both the initial EX lock and the subsequent C lock conversions. If all processes performing communication run C with the same UIC, the LCK$M_SYSTEM bit is optional. If it is not C used, the program does not require SYSLCK priv. FLAG1 = LCK$M_SYSTEM .OR. LCK$M_VALBLK !Flag bits for initial lock. FLAG2 = LCK$M_CONVERT .OR. LCK$M_VALBLK !Flag bits for lock conversions. ISTAT = SYS$CLREF(%VAL(33)) !Clear E.F. used by completion AST. C Obtain an initial EX-mode lock on the resource, specifying C the blocking AST "BLOCKING", which will execute when another C process requests a lock on the resource name in DEVICE_NAME. ISTAT = SYS$ENQW(%VAL(34),%VAL(LCK$K_EXMODE),LCKSTB, * %VAL(FLAG1),DEVICE_NAME,,,,BLOCKING,,) IF(ISTAT .NE. SS$_NORMAL)THEN !If error in enqueue, CALL LOG_ERROR(ISTAT) !Log it. ELSE IF (LCKSTB.CONDITION .NE. SS$_NORMAL)THEN !If error returned, ISTAT=LCKSTB.CONDITION !Log it instead. CALL LOG_ERROR(ISTAT) END IF DO I = 1,16 LCKSTB.VAL_BLOCK(I) = 0 !Initialize value block END DO C This is the main loop, where we wait for the blocking AST to C complete, then we obtain another EX-mode lock and wait for the C blocking AST to complete, then we obtain another EX-mode lock C and... well, you get the idea. Note that the ENQ call is C asynchronous, and the completion AST "COMPLETION" is executed C as soon as the EX-mode lock is obtained. DO WHILE(.TRUE.) !Loop forever ISTAT=SYS$WAITFR(%VAL(33)) !Wait for blocking AST completion ISTAT=SYS$CLREF(%VAL(33)) !Clear ef set by blocking AST ISTAT=SYS$ENQ(,%VAL(LCK$K_EXMODE),LCKSTB,%VAL(FLAG2), * ,,COMPLETION,,BLOCKING,,) !Convert to EX lock again. IF(ISTAT .NE. SS$_NORMAL)THEN !If error in enqueue, CALL LOG_ERROR(ISTAT) !Log it. ELSE IF (LCKSTB.CONDITION .NE. SS$_NORMAL)THEN !If error returned, ISTAT=LCKSTB.CONDITION !Log it instead. CALL LOG_ERROR(ISTAT) END IF END DO END C----------------------------------------------------------------------------- SUBROUTINE BLOCKING C This AST is executed when another process requests a non-NL mode C lock on the resource. It converts the current EX lock to a NL C lock to allow the other process to claim the resource and obtain C its lock value block. IMPLICIT INTEGER*4 (A-Z) INCLUDE '($LCKDEF)' INCLUDE '($SSDEF)' STRUCTURE /STATUS/ !Layout of lock status block INTEGER*2 CONDITION !VMS condition value INTEGER*2 %FILL !Reserved to DEC INTEGER*4 LOCKID !Lock ID longword BYTE VAL_BLOCK(16) !Lock value block END STRUCTURE RECORD /STATUS/ LCKSTB !Record for lock status block COMMON /LCKCOM/LCKSTB !Share status block VOLATILE LCKCOM !Prevent compiler optimization INTEGER*4 FLAG FLAG = LCK$M_CONVERT .OR. LCK$M_VALBLK !Flag bits for conversion ISTAT = SYS$ENQW(%VAL(33),%VAL(LCK$K_NLMODE),LCKSTB, * %VAL(FLAG),,,,,,,) !Other program requested lock, cnv to NL mode IF(ISTAT .NE. SS$_NORMAL)THEN !If error in enqueue, CALL LOG_ERROR(ISTAT) !Log it. ELSE IF (LCKSTB.CONDITION .NE. SS$_NORMAL)THEN !If error returned, ISTAT=LCKSTB.CONDITION !Log it instead. CALL LOG_ERROR(ISTAT) END IF RETURN END C----------------------------------------------------------------------------- SUBROUTINE COMPLETION C This routine fires upon completion of the conversion back to exclusive C mode, and performs the requested communication with the device. IMPLICIT INTEGER*4 (A-Z) INCLUDE '($LCKDEF)' INCLUDE '($SSDEF)' STRUCTURE /STATUS/ !Layout of lock status block INTEGER*2 CONDITION !VMS condition value INTEGER*2 %FILL !Reserved to DEC INTEGER*4 LOCKID !Lock ID longword BYTE VAL_BLOCK(16) !Lock value block END STRUCTURE RECORD /STATUS/ LCKSTB !Record for lock status block COMMON /LCKCOM/ LCKSTB !Share status block VOLATILE LCKCOM !Prevent compiler optimization INTEGER*4 FLAG,ISTAT,JSTAT CHARACTER*23 TIME_STR !Time stamp buffer IF(LCKSTB.VAL_BLOCK(1) .NE. 0)THEN !If data received, C The next CALL should be to a routine which will perform the actual C device communication required. This example shows one-way C communication, but it could be two-way, with the returned message C being placed in the lock value block. CALL DEV_COMM(LCKSTB.VAL_BLOCK,ISTAT) !Send msg to device. IF(ISTAT.LT.0)THEN !If error in dev. communication, CALL LOG_ERROR(ISTAT) !Log it to the log file. END IF DO I = 1,16 LCKSTB.VAL_BLOCK(I) = 0 !Initialize value block END DO END IF RETURN END C------------------------------------------------------------------------------ C Dummy routines to be replaced with real ones. SUBROUTINE LOG_ERROR(ISTAT) C This routine should be modified to report or log errors as they C occur. RETURN END C------ SUBROUTINE DEV_COMM(BUFFER,ISTAT) IMPLICIT INTEGER*4 (A-Z) BYTE BUFFER(16) CHARACTER*23 DATE_TIME C This is where we communicate with the device. C In this example, we just write the first message byte to a C file with a date/time stamp. CALL LIB$DATE_TIME(DATE_TIME) OPEN(UNIT=25,FILE='SERVER.OUT',TYPE='UNKNOWN',ACCESS='APPEND') WRITE(UNIT=25,FMT=10)DATE_TIME,BUFFER(1) 10 FORMAT(1X,A,' BUFFER(1)=',I5) CLOSE(UNIT=25) ISTAT=1 RETURN END =============================================================================== Program 2: (File SERVER_SEND.FOR) =============================================================================== SUBROUTINE SERVER_SEND(DEVICE_NAME,BUFFER,STATUS) C Author: J. Crum C Date : 2/19/90 C This routine sends a message to the communication server process C for the device specified in DEVICE_NAME. IMPLICIT INTEGER*4 (A-Z) INCLUDE '($LCKDEF)' INCLUDE '($SSDEF)' CHARACTER*20 DEVICE_NAME !Device logical name STRUCTURE /STATUS/ !Layout of lock status block INTEGER*2 CONDITION !VMS condition value INTEGER*2 %FILL !Reserved to DEC INTEGER*4 LOCKID !Lock ID longword BYTE VAL_BLOCK(16) !Lock value block END STRUCTURE BYTE BUFFER(16) INTEGER*4 FLAG,STATUS,LOOPS LOGICAL STARTED /.FALSE./ COMMON /LOCK_SAVE/ STARTED,FLAG RECORD /STATUS/ STATBLK !Device lock status block IF(.NOT. STARTED)THEN !If this is the first call to this routine, FLAG = LCK$M_SYSTEM .OR. LCK$M_VALBLK !Build initial flag. !Initially queue a null lock on resource ISTAT = SYS$ENQW(,%VAL(LCK$K_NLMODE),STATBLK,%VAL(FLAG), * DEVICE_NAME,,,,,,) STARTED = .TRUE. !Remember we have initialized the lock, FLAG = LCK$M_CONVERT .OR. LCK$M_VALBLK !Build convert flag. END IF C Now we get an EX lock on the server's resource, which gives us C access to the lock value block. ISTAT = SYS$ENQW(,%VAL(LCK$K_EXMODE),STATBLK,%VAL(FLAG), * ,,,,,,) !Get EX lock on server's resource IF(ISTAT .NE. SS$_NORMAL)THEN !If error in enqueue, CALL LIB$SIGNAL(%VAL(ISTAT)) !Display error message, STATUS = ISTAT !and return error status. RETURN END IF IF (STATBLK.CONDITION .NE. SS$_NORMAL)THEN !If error in status, CALL LIB$SIGNAL(%VAL(STATBLK.CONDITION)) !Display error message, STATUS = STATBLK.CONDITION !and return error status. RETURN END IF LOOPS = 0 !Init. loop counter. C If we intercepted a message from another client (or if we C received our own message), enter this loop to give the server C process a chance to handle it while we wait our turn. DO WHILE(STATBLK.VAL_BLOCK(1) .NE. 0 .AND. LOOPS .LT. 100) ISTAT=SYS$ENQW(,%VAL(LCK$K_NLMODE),STATBLK,%VAL(FLAG), * ,,,,,,) !Convert to NL mode to send value block CALL LIB$WAIT(0.05) !Wait a little while... LOOPS = LOOPS + 1 !Count loop iterations. ISTAT=SYS$ENQW(,%VAL(LCK$K_EXMODE),STATBLK,%VAL(FLAG), * ,,,,,,) !Convert to EX mode again. END DO IF(LOOPS .GE. 100)THEN !If we can't get an available value STATUS = -3 !block in 100 tries, return bad RETURN !status to caller. END IF C Now we have an available lock value block, so let's put our stuff into C it and release it back to the server process by converting the lock C to NL mode. That was easy. DO I = 1,16 STATBLK.VAL_BLOCK(I) = BUFFER(I) !Put request buffer into value block. END DO ISTAT=SYS$ENQ(,%VAL(LCK$K_NLMODE),STATBLK,%VAL(FLAG),,,,,,,) !Cnv to NL IF(ISTAT .NE. SS$_NORMAL)THEN !If error in enqueue, CALL LIB$SIGNAL(%VAL(ISTAT)) !Display error message, STATUS = ISTAT !and return error status to caller. RETURN END IF IF (STATBLK.CONDITION .NE. SS$_NORMAL)THEN !If error in status, CALL LIB$SIGNAL(%VAL(STATBLK.CONDITION)) !Display error message, STATUS = STATBLK.CONDITION !and return error status to caller. RETURN END IF STATUS=1 !Everything worked, return status = 1. RETURN END =============================================================================== Program 3: (File SUB_TEST.FOR) =============================================================================== PROGRAM SUB_TEST C This program is used to test subroutine SERVER_SEND C To compile and link: C FORTRAN SUB_TEST C FORTRAN SERVER_SEND C LINK SUB_TEST,SERVER_SEND CHARACTER*20 DEVICE_NAME /'PLC_12'/ BYTE BUFFER(16) INTEGER*4 STATUS CHARACTER*23 DATE_TIME CALL LIB$DATE_TIME(DATE_TIME) TYPE *,DATE_TIME !Display starting time BUFFER(1) = 0 10 BUFFER(1) = BUFFER(1) + 1 CALL SERVER_SEND(DEVICE_NAME,BUFFER,STATUS) IF(BUFFER(1) .LT. 100)GO TO 10 CALL LIB$DATE_TIME(DATE_TIME) TYPE *,DATE_TIME !Display time after 100 test loops. END