Trailing-Edge
-
PDP-10 Archives
-
BB-5372D-BM
-
traffic/demonstration/sndseq.cbl
There is 1 other file named sndseq.cbl in the archive. Click here to see a list.
00100 IDENTIFICATION DIVISION.
00200 PROGRAM-ID. SNDSEQ.
00300 *
00400 * THIS PROGRAM SENDS A CONTINUOUS STREAM OF IPCF MESSAGES TO ONE
00500 * OR MORE RECEIVER PROGRAMS. THE MESSAGE CONSISTS OF A SEQUENCE
00600 * NUMBER WHICH IS INCREMENTED BY ONE FOR EACH MESSAGE SENT TO A
00700 * SINGLE RECEIVER PROGRAM.
00800 *
00900 * ANOTHER RECEIVER PROGRAM MAY BE ADDED TO THE GROUP OF RECEIVER
01000 * PROGRAMS AT ANY TIME BY TYPING "NEW RECV" ON THE TERMINAL.
01100 *
01200 * THIS PROGRAM EXPECTS TO RECEIVE REPLY MESSAGES FROM THE PROGRAMS
01300 * WHICH IT IS SENDING TO. A REPLY MESSAGE MAY BE RECEIVED AT ANY TIME.
01400 * THE FORMAT OF THE REPLY MESSAGE IS:
01500 * FIELD 1 - 3 ALPHABETIC CHARACTERS
01600 * FIELD 2 - 5 NUMERIC CHARACTERS
01700 * THE FIELDS OF THE THREE POSSIBLE REPLY MESSAGES ARE:
01800 * 1. MESSAGE RECEIVED IN SEQUENCE (POSITIVE ACKNOWLEDGEMENT):
01900 * FIELD 1 - ACK
02000 * FIELD 2 - HIGHEST MESSAGE NUMBER RECEIVED OK
02100 * 2. MESSAGE RECEIVED OUT OF SEQUENCE (NEGATIVE ACKNOWLEDGEMENT):
02200 * FIELD 1 - NAK
02300 * FIELD 2 - HIGHEST MESSAGE NUMBER RECEIVED OK
02400 * 3. THIS PROGRAM HAS COMPLETED (TERMINATION NOTICE):
02500 * FIELD 1 - XIT
02600 * FIELD 2 - HIGHEST MESSAGE NUMBER RECEIVED OK
02700 *
02800 DATA DIVISION.
02900 WORKING-STORAGE SECTION.
03000 77 ERROR-CODE PIC S9(10) COMP.
03100 77 FUNCTION-CODE PIC S9(10) COMP.
03200 77 MY-ID PIC X(29) DISPLAY-7 VALUE "SEND-NUMERIC-SEQUENCE".
03300 77 OTHER-ID-TMP PIC X(29).
03400 77 TMP-INDEX PIC S9(10) COMP.
03500 77 I PIC S9(10) COMP.
03600 77 J PIC S9(10) COMP.
03700 77 SEARCH-SWT PIC S9(10) COMP.
03800 77 BAD-IPCF-RECV-CNT PIC S9(10) COMP VALUE 0.
03900 77 TTY-MSG PIC X(10) DISPLAY-7.
04000 77 TIME-BETWEEN-SENDS PIC S9(5) COMP.
04100 77 RESUME-ALL PIC S9(5) COMP VALUE 3.
04200 77 WAIT-TIME PIC S9(5) COMP.
04300 77 STIME PIC S9(10) COMP.
04400 77 WAIT-END-TIME PIC S9(10) COMP.
04500 01 TODAY-FIELDS.
04600 02 FILLER PIC XXXXXX.
04700 02 TODAY-HH PIC 99.
04800 02 TODAY-MM PIC 99.
04900 02 TODAY-SS PIC 99.
05000 01 RECEIVE-DEFS.
05100 02 RECEIVE-INFO.
05200 03 RECEIVE-TYPE PIC XXX.
05300 88 ACK-MSG VALUE 'ACK'.
05400 88 NAK-MSG VALUE 'NAK'.
05500 88 XIT-MSG VALUE 'XIT'.
05600 03 RECEIVE-SEQ PIC X(5).
05700 02 RECEIVE-INDEX PIC S9(10) COMP.
05800 * DEFINITION OF DATA BASE FOR EXTERNAL PROGRAMS
05900 * TO CHANGE THE NUMBER OF EXTERNAL PROGRAMS SUPPORTED, MODIFY THE
06000 * VALUE OF "OTHER-PGM-MAX" AND MODIFY THE OCCURS CLAUSE OF
06100 * "OTHER-PGM-DEFS" TO AGREE WITH THAT NEW VALUE.
06200 01 OTHER-PGM-CNT PIC S9(5) COMP VALUE 0.
06300 01 OTHER-PGM-MAX PIC S9(5) COMP VALUE 1.
06400 01 OTHER-PGM-DEFS OCCURS 4 TIMES.
06500 02 OTHER-ID PIC X(29).
06600 02 OTHER-ENABLE PIC X.
06700 02 OTHER-SEQ-SENT PIC 9(5).
06800 02 OTHER-SEQ-ACK PIC 9(5).
06900 02 OTHER-ERROR-CNT PIC S9(5) COMP.
07000 PROCEDURE DIVISION.
07100 SETUP.
07200 DISPLAY " ".
07300 DISPLAY "SEND A IPCF MESSAGE AND RECEIVE RESPONSE".
07400 DISPLAY " ".
07410 DISPLAY "GIVE ME ID :"
07420 ACCEPT MY-ID.
07430 DISPLAY " ".
07500 PERFORM INITIALIZATION.
07600 PERFORM DEFINE-ME.
07700 MAIN-LOOP.
07800 IF OTHER-PGM-CNT > 0
07900 PERFORM IPCF-SEND-SEQUENCE
08000 VARYING I FROM 1 BY 1
08100 UNTIL I > OTHER-PGM-MAX.
08200 MOVE TIME-BETWEEN-SENDS TO WAIT-TIME.
08300 PERFORM WAIT-FOR-TIME.
08400 GO TO MAIN-LOOP.
08500 *
08600 * ROUTINE TO SEND THE NEXT SEQUENCE NUMBER TO EACH EXTERNAL PROGRAM
08700 *
08800 IPCF-SEND-SEQUENCE.
08900 IF OTHER-ENABLE (I) = 'E'
09000 PERFORM IPCF-SEND-SEQUENCE-1.
09100 IPCF-SEND-SEQUENCE-1.
09200 IF OTHER-ERROR-CNT (I) = 0
09300 SET OTHER-SEQ-SENT (I) UP BY 1.
09400 ENTER MACRO IPSEND USING OTHER-SEQ-SENT (I), I, ERROR-CODE.
09500 IF ERROR-CODE = 0
09600 SET OTHER-ERROR-CNT (I) TO ZERO
09700 ELSE
09800 SET OTHER-ERROR-CNT (I) UP BY 1
09900 IF OTHER-ERROR-CNT (I) > 4
10000 DISPLAY " PROBLEM WITH PROGRAM " OTHER-ID (I)
10100 PERFORM DISPLAY-IPCF-ERROR.
10200 MOVE 0 TO WAIT-TIME.
10300 PERFORM WAIT-FOR-TIME.
10400 *
10500 * ROUTINE TO PROCESS TERMINAL INPUT
10600 *
10700 TTY-INPUT.
10800 ACCEPT TTY-MSG.
10900 IF TTY-MSG = "EXIT"
11000 PERFORM TERM-THIS-PGM
11100 GO TO TTY-EXIT.
11200 IF TTY-MSG = "NEW RECV" OR "N R"
11300 PERFORM DEFINE-RECEIVER
11400 GO TO TTY-EXIT.
11500 IF TTY-MSG = 'T' OR 'TERM'
11600 PERFORM TERM-EXT-PGM
11700 GO TO TTY-EXIT.
11800 IF TTY-MSG = 'S' OR 'STATUS'
11900 PERFORM DISPLAY-STATUS
12000 GO TO TTY-EXIT.
12100 IF TTY-MSG = 'H' OR 'HELP'
12200 PERFORM HELP-THAT-USER
12300 GO TO TTY-EXIT.
12400 DISPLAY "WHAT ??".
12500 TTY-EXIT.
12600 EXIT.
12700 *
12800 * ROUTINE TO PROCESS IPCF INPUT
12900 *
13000 IPCF-INPUT.
13100 MOVE SPACES TO RECEIVE-INFO.
13200 ENTER MACRO IPRECV USING RECEIVE-INFO RECEIVE-INDEX ERROR-CODE.
13300 IF ERROR-CODE > 2
13400 DISPLAY " IPRECV " WITH NO ADVANCING
13500 PERFORM DISPLAY-IPCF-ERROR
13600 GO TO IPCF-INPUT-EXIT.
13700 IF RECEIVE-INDEX > OTHER-PGM-MAX
13800 GO TO IPCF-INPUT-99.
13900 IF OTHER-ENABLE (RECEIVE-INDEX) NOT = 'E' OR
14000 RECEIVE-SEQ IS NOT NUMERIC
14100 GO TO IPCF-INPUT-99.
14200 * POSITIVE ACKNOWLEDGEMENT - SAVE HIGHEST SEQUENCE NUMBER RECEIVED OK
14300 IF ACK-MSG
14400 MOVE RECEIVE-SEQ TO OTHER-SEQ-ACK (RECEIVE-INDEX)
14500 DISPLAY 'MSG#' RECEIVE-SEQ
14600 GO TO IPCF-INPUT-EXIT.
14700 * NEGATIVE ACKNOWLEDGEMENT - RESET LAST SEQUENCE NUMBER SENT
14800 IF NAK-MSG
14900 MOVE RECEIVE-SEQ TO OTHER-SEQ-SENT (RECEIVE-INDEX)
15000 SET OTHER-ERROR-CNT (RECEIVE-INDEX) TO ZERO
15100 GO TO IPCF-INPUT-EXIT.
15200 * EXTERNAL PROGRAM TERMINATING - DON'T SEND ANY MORE MESSAGES
15300 IF XIT-MSG
15400 MOVE 'D' TO OTHER-ENABLE (RECEIVE-INDEX)
15500 DISPLAY " "
15600 DISPLAY " EXTERNAL PROGRAM TERMINATING " OTHER-ID (RECEIVE-INDEX)
15700 MOVE RECEIVE-SEQ TO J
15800 DISPLAY " HIGHEST SEQUENCE NUMBER IS " J
15900 DISPLAY " "
16000 SET OTHER-PGM-CNT DOWN BY 1
16100 GO TO IPCF-INPUT-EXIT.
16200 IPCF-INPUT-99.
16300 SET BAD-IPCF-RECV-CNT UP BY 1.
16400 IPCF-INPUT-EXIT.
16500 EXIT.
16600 *
16700 * ROUTINE TO DISPLAY THE IPCF ERROR CODE
16800 *
16900 DISPLAY-IPCF-ERROR.
17000 DISPLAY " IPCF ERROR CODE IS " ERROR-CODE.
17100 DISPLAY " ".
17200 *
17300 * ROUTINE TO DEFINE A RECEIVER OF OUR IPCF MESSAGES
17400 *
17500 DEFINE-RECEIVER.
17600 IF OTHER-PGM-CNT = OTHER-PGM-MAX
17700 DISPLAY " EXTERNAL PROGRAM CAPACITY EXCEEDED"
17800 DISPLAY " TRY AGAIN AFTER AN EXTERNAL PROGRAM TERMINATION"
17900 ELSE
18000 SET ERROR-CODE TO -1
18100 PERFORM DEFINE-RECEIVER-1
18200 VARYING J FROM 1 BY 1
18300 UNTIL J > 5 OR ERROR-CODE = 0
18400 DISPLAY " "
18500 IF ERROR-CODE NOT = 0
18600 DISPLAY " NO RECEIVER DEFINED, TRY AGAIN SOMETIME"
18700 ELSE
18800 IF OTHER-ENABLE (TMP-INDEX) = 'E'
18900 DISPLAY " CONTINUING TRANSMISSION TO " OTHER-ID-TMP
19000 ELSE
19100 DISPLAY " BEGINNING TRANSMISSION TO " OTHER-ID-TMP
19200 MOVE OTHER-ID-TMP TO OTHER-ID (TMP-INDEX)
19300 MOVE 'E' TO OTHER-ENABLE (TMP-INDEX)
19400 SET OTHER-SEQ-SENT (TMP-INDEX)
19500 OTHER-SEQ-ACK (TMP-INDEX)
19600 OTHER-ERROR-CNT(TMP-INDEX)
19700 TO ZERO
19800 SET OTHER-PGM-CNT UP BY 1.
19900 DISPLAY " ".
20000 DEFINE-RECEIVER-1.
20100 DISPLAY " ".
20200 DISPLAY " RECEIVER IDENTIFICATION IS " WITH NO ADVANCING.
20300 ACCEPT OTHER-ID-TMP.
20400 ENTER MACRO IPCRDX USING OTHER-ID-TMP TMP-INDEX ERROR-CODE.
20500 IF ERROR-CODE NOT = 0
20600 IF ERROR-CODE = 17
20700 DISPLAY " NOT RUNNING " OTHER-ID-TMP
20800 ELSE
20900 PERFORM DISPLAY-IPCF-ERROR.
21000 *
21100 * ROUTINE TO DEFINE OUR CURRENT PROGRAM IDENTIFIER
21200 *
21300 DEFINE-ME.
21400 ENTER MACRO IPCRID USING MY-ID, ERROR-CODE.
21500 IF ERROR-CODE NOT = 0
21600 DISPLAY " FAILED TO DEFINE ME AS " MY-ID
21700 PERFORM DISPLAY-IPCF-ERROR
21800 STOP RUN.
21900 DISPLAY " I AM DEFINED AS " MY-ID.
22000 DISPLAY " ".
22100 *
22200 * ROUTINE TO WAIT FOR SOME TIME PERIOD
22300 * WAIT-TIME CONTAINS THE AMOUNT OF TIME TO WAIT IN SECONDS
22400 * THE MAXIMUM WAIT TIME IS 65 SECONDS
22500 *
22600 WAIT-FOR-TIME.
22700 IF WAIT-TIME > 65
22800 SET WAIT-TIME TO 65.
22900 PERFORM GET-STIME.
23000 COMPUTE WAIT-END-TIME = STIME + WAIT-TIME
23100 IF WAIT-TIME = 0
23200 PERFORM WAIT-FOR-TIME-1
23300 ELSE
23400 PERFORM WAIT-FOR-TIME-1 UNTIL STIME NOT < WAIT-END-TIME.
23500 WAIT-FOR-TIME-1.
23600 COMPUTE FUNCTION-CODE = WAIT-TIME * 1000.
23700 PERFORM WAIT-FOR-SOMETHING.
23800 IF FUNCTION-CODE = 1 PERFORM TTY-INPUT THRU TTY-EXIT.
23900 IF FUNCTION-CODE = 2 PERFORM IPCF-INPUT THRU IPCF-INPUT-EXIT.
24000 PERFORM GET-STIME.
24100 COMPUTE WAIT-TIME = WAIT-END-TIME - STIME.
24200 *
24300 * ROUTINE TO COMPUTE THE CURRENT TIME OF DAY IN SECONDS.
24400 *
24500 GET-STIME.
24600 MOVE TODAY TO TODAY-FIELDS.
24700 COMPUTE STIME = ((TODAY-HH * 60) + TODAY-MM) * 60 + TODAY-SS.
24800 *
24900 * ROUTINE TO WAIT FOR A SIGNIFICANT EVENT
25000 *
25100 WAIT-FOR-SOMETHING.
25200 ENTER MACRO IPWAIT USING FUNCTION-CODE,RESUME-ALL,ERROR-CODE.
25300 IF ERROR-CODE NOT = 0
25400 DISPLAY " IPWAIT ERROR " WITH NO ADVANCING
25500 PERFORM DISPLAY-IPCF-ERROR
25600 GO TO WAIT-FOR-SOMETHING.
25700 *
25800 * PROGRAM INITIALIZATION
25900 *
26000 INITIALIZATION.
26100 PERFORM INIT-ME-1
26200 VARYING I FROM 1 BY 1
26300 UNTIL I > OTHER-PGM-MAX.
26400 PERFORM INIT-ME-2
26500 UNTIL TIME-BETWEEN-SENDS IS POSITIVE.
26600 DISPLAY " ".
26700 INIT-ME-1.
26800 MOVE 'D' TO OTHER-ENABLE (I).
26900 INIT-ME-2.
27000 DISPLAY " SECONDS BETWEEN EXTERNAL PROGRAM MESSAGES? "
27100 WITH NO ADVANCING.
27200 ACCEPT TIME-BETWEEN-SENDS.
27300 *
27400 * ROUTINE TO CHECK CONDITIONS FOR TERMINATING THIS PROGRAM
27500 *
27600 TERM-THIS-PGM.
27700 DISPLAY " ".
27800 IF BAD-IPCF-RECV-CNT > 0
27900 DISPLAY " " BAD-IPCF-RECV-CNT " BAD IPCF MESSAGES RECEIVED"
28000 DISPLAY " ".
28100 IF OTHER-PGM-CNT = 0
28200 STOP RUN
28300 ELSE
28400 DISPLAY " " OTHER-PGM-CNT " EXTERNAL PROGRAMS RUNNING"
28500 DISPLAY " ARE YOU SURE ? " WITH NO ADVANCING
28600 ACCEPT TTY-MSG
28700 IF TTY-MSG = 'Y' OR 'YES'
28800 STOP RUN.
28900 *
29000 * ROUTINE TO STOP SENDING TO AN ACTIVE EXTERNAL PROGRAM
29100 *
29200 TERM-EXT-PGM.
29300 IF OTHER-PGM-CNT < 1
29400 DISPLAY " "
29500 DISPLAY " NO EXTERNAL PROGRAMS"
29600 DISPLAY " "
29700 ELSE
29800 SET SEARCH-SWT TO -1
29900 PERFORM TERM-EXT-PGM-1
30000 VARYING TMP-INDEX FROM 1 BY 1
30100 UNTIL TMP-INDEX > 5 OR SEARCH-SWT = 0
30200 IF SEARCH-SWT NOT = 0
30300 DISPLAY " TRY AGAIN SOMETIME"
30400 ELSE
30500 SET OTHER-PGM-CNT DOWN BY 1
30600 IF OTHER-PGM-CNT > 0
30700 DISPLAY " "
30800 DISPLAY " ANY MORE TO TERMINATE ? " WITH NO ADVANCING
30900 ACCEPT TTY-MSG
31000 IF TTY-MSG = 'Y' OR 'YES'
31100 GO TO TERM-EXT-PGM.
31200 TERM-EXT-PGM-1.
31300 DISPLAY " ".
31400 DISPLAY " ID TO BE TERMINATED ? " WITH NO ADVANCING.
31500 ACCEPT OTHER-ID-TMP.
31600 PERFORM SEARCH-FOR-EXT-ID
31700 VARYING J FROM 1 BY 1
31800 UNTIL J > OTHER-PGM-MAX OR SEARCH-SWT = 0.
31900 IF SEARCH-SWT NOT = 0
32000 DISPLAY " INVALID ID " OTHER-ID-TMP
32100 ELSE
32200 DISPLAY " TERMINATED PROCESSING OF " OTHER-ID (J - 1)
32300 MOVE 'D' TO OTHER-ENABLE (J - 1).
32400 SEARCH-FOR-EXT-ID.
32500 IF OTHER-ID-TMP = OTHER-ID (J)
32600 SET SEARCH-SWT TO 0.
32700 *
32800 * ROUTINE TO DISPLAY PROGRAM STATUS
32900 *
33000 DISPLAY-STATUS.
33100 DISPLAY " ".
33200 DISPLAY " MY ID IS " MY-ID.
33300 DISPLAY " ".
33400 IF BAD-IPCF-RECV-CNT > 0
33500 DISPLAY " " BAD-IPCF-RECV-CNT " BAD IPCF MESSAGES RECEIVED"
33600 DISPLAY " ".
33700 IF OTHER-PGM-CNT > 0
33800 DISPLAY " EXTERNAL PROGRAMS:"
33900 PERFORM DISPLAY-STATUS-1
34000 VARYING TMP-INDEX FROM 1 BY 1
34100 UNTIL TMP-INDEX > OTHER-PGM-MAX.
34200 DISPLAY-STATUS-1.
34300 IF OTHER-ENABLE (TMP-INDEX) = 'E'
34400 IF OTHER-ERROR-CNT (TMP-INDEX) = 0
34500 MOVE OTHER-SEQ-SENT (TMP-INDEX) TO J
34600 ELSE
34700 COMPUTE J = OTHER-SEQ-SENT (TMP-INDEX) - 1.
34800 IF OTHER-ENABLE (TMP-INDEX) = 'E'
34900 DISPLAY " "
35000 DISPLAY " PROGRAM IDENTIFIER " OTHER-ID (TMP-INDEX)
35100 DISPLAY " LAST SEQUENCE NO. SENT " J
35200 DISPLAY " LAST SEQ ACKNOWLEDGED " OTHER-SEQ-ACK (TMP-INDEX)
35300 DISPLAY " ".
35400 *
35500 * ROUTINE TO PRINT HELP MESSAGE ON THE TERMINAL
35600 *
35700 HELP-THAT-USER.
35800 DISPLAY " ".
35900 DISPLAY " THE VALID COMMANDS ARE:".
36000 DISPLAY " EXIT TO TERMINATE THE PROGRAM".
36100 DISPLAY " HELP OR"
36200 DISPLAY " H TO DISPLAY THIS MESSAGE".
36300 DISPLAY " NEW RECV OR".
36400 DISPLAY " N R TO DEFINE A NEW EXTERNAL PROGRAM ID".
36500 DISPLAY " STATUS OR".
36600 DISPLAY " S TO DISPLAY CURRENT PROGRAM STATUS".
36700 DISPLAY " TERM OR".
36800 DISPLAY " T TO TERMINATE SENDING TO AN EXTERNAL PGM".
36900 DISPLAY " ".