Trailing-Edge
-
PDP-10 Archives
-
k20v7d
-
uetp/lib/rmtcbb.cbl
There are 4 other files named rmtcbb.cbl in the archive. Click here to see a list.
ID DIVISION.
PROGRAM-ID. RMTCBB.
* RMS TEST FOR COBOL.
* THIS IS A SIMPLE TEST OF THE VARIOUS RMS FUNCTIONS NEEDED FOR COBOL.
* IT TRIES TO TEST A LITTLE OF EVERYTHING FOR RMS INDEXED AND RELATIVE
* FILES FOR APPLY BASIC-LOCKING.
*
* COPYRIGHT (c) 1984 BY DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
*
ENVIRONMENT DIVISION.
I-O SECTION.
FILE-CONTROL.
SELECT FILE-1 ASSIGN TO DSK
ORGANIZATION IS RMS INDEXED
ACCESS MODE IS DYNAMIC
RECORD KEY IS RK1
ALTERNATE RECORD KEY IS AK1-1
ALTERNATE RECORD KEY IS AK1-2 WITH DUPLICATES.
SELECT FILE-2 ASSIGN TO DSK
ORGANIZATION IS RMS RELATIVE
ACCESS MODE IS DYNAMIC
RELATIVE KEY IS RK2.
I-O-CONTROL.
APPLY BASIC-LOCKING ON FILE-1 FILE-2.
DATA DIVISION.
FILE SECTION.
FD FILE-1 VALUE OF ID IS "RMTF1 RBL".
01 REC-1 DISPLAY-7.
02 RK1 PIC X(5).
02 AK1-1 PIC X(5).
02 AK1-2 PIC 9(5).
02 FILLER PIC X(10).
FD FILE-2 VALUE OF ID IS "RMTF2 RBL".
01 REC-2.
02 FILLER PIC X(10).
02 AK2-1 PIC X(5).
02 AK2-2 PIC 9(5).
02 FILLER PIC X(5).
WORKING-STORAGE SECTION.
01 RK2 PIC 9(5) COMP.
01 F1R1 PIC X(25) VALUE "AAAAADDDDD11111XXXXXXXXXX".
01 F1R2 PIC X(25) VALUE "BBBBBEEEEE11111XXXXXXXXXX".
01 F1R3 PIC X(25) VALUE "CCCCCFFFFF22222XXXXXXXXXX".
01 F1R4 PIC X(25) VALUE "DDDDDGGGGG22222XXXXXXXXXX".
01 F1R5 PIC X(25) VALUE "EEEEEHHHHH11111YYYYYYYYYY".
01 F2R1 PIC X(25) VALUE "XXXXXAAAAADDDDD55555XXXXX".
01 F2R2 PIC X(25) VALUE "YYYYYBBBBBEEEEE66666XYXYX".
01 F2R3 PIC X(25) VALUE "XXXXYCCCCCFFFFF77777XXYXX".
01 F2R4 PIC X(25) VALUE "XXYYXDDDDDGGGGG88888YXYXY".
01 F2R5 PIC X(25) VALUE "YYXXYEEEEEHHHHH99999YYYYX".
PROCEDURE DIVISION.
STARTER.
OPEN OUTPUT FILE-1.
OPEN OUTPUT FILE-2.
S-1.
WRITE REC-1 FROM F1R1
INVALID KEY DISPLAY "?S-1".
S-2.
WRITE REC-1 FROM F1R2
INVALID KEY DISPLAY "?S-2".
S-3.
WRITE REC-1 FROM F1R3
INVALID KEY DISPLAY "?S-3".
S-4.
WRITE REC-1 FROM F1R4
INVALID KEY DISPLAY "?S-4".
S-5.
WRITE REC-1 FROM F1R5
INVALID KEY DISPLAY "?S-5".
S-6.
CLOSE FILE-1.
OPEN I-O FILE-1 FOR READ ALLOWING OTHERS ANY.
MOVE 0 TO RK2.
S-7.
ADD 1 TO RK2.
WRITE REC-2 FROM F2R1
INVALID KEY DISPLAY "?S-7".
S-8.
ADD 1 TO RK2.
WRITE REC-2 FROM F2R2
INVALID KEY DISPLAY "?S-8".
S-9.
ADD 1 TO RK2.
WRITE REC-2 FROM F2R3
INVALID KEY DISPLAY "?S-9".
S-10.
ADD 1 TO RK2.
WRITE REC-2 FROM F2R4
INVALID KEY DISPLAY "?S-10".
S-11.
ADD 1 TO RK2.
WRITE REC-2 FROM F2R5
INVALID KEY DISPLAY "?S-11".
S-12.
CLOSE FILE-2.
OPEN I-O FILE-2 FOR READ ALLOWING OTHERS ANY.
S-13.
MOVE F1R1 TO REC-1.
READ FILE-1 INVALID KEY DISPLAY "?S-13".
S-14.
READ FILE-1 NEXT RECORD AT END DISPLAY "?S-14".
S-15.
IF REC-1 NOT = F1R2 DISPLAY "?S-15".
S-16.
READ FILE-1 NEXT RECORD AT END DISPLAY "?S-16".
S-17.
IF REC-1 NOT = F1R3 DISPLAY "?S-17".
S-18.
READ FILE-1 NEXT RECORD AT END DISPLAY "?S-18".
S-19.
IF REC-1 NOT = F1R4 DISPLAY "?S-19".
S-20.
READ FILE-1 NEXT RECORD AT END DISPLAY "?S-20".
S-21.
IF REC-1 NOT = F1R5 DISPLAY "?S-21".
S-22.
READ FILE-1 NEXT RECORD AT END GO TO S-23.
DISPLAY "?S-22".
S-23.
CLOSE FILE-1.
OPEN I-O FILE-1 FOR ANY ALLOWING OTHERS READ.
S-24.
MOVE F1R4 TO REC-1.
START FILE-1 KEY = RK1 INVALID KEY DISPLAY "?S-24".
S-25.
READ FILE-1 NEXT RECORD AT END DISPLAY "?S-25".
S-25A.
IF REC-1 NOT = F1R4 DISPLAY "?S-25A".
S-26.
READ FILE-1 NEXT RECORD AT END DISPLAY "?S-26".
S-27.
MOVE F1R4 TO REC-1.
START FILE-1 KEY NOT LESS RK1 INVALID KEY DISPLAY "?S-27".
S-28.
READ FILE-1 NEXT AT END DISPLAY "?S-28".
S-29.
IF REC-1 NOT = F1R4 DISPLAY "?S-29".
S-30.
READ FILE-1 NEXT RECORD AT END DISPLAY "?S-30".
S-31.
MOVE F1R4 TO REC-1.
START FILE-1 KEY GREATER RK1 INVALID KEY DISPLAY "?S-31".
S-32.
READ FILE-1 NEXT RECORD AT END DISPLAY "?S-32".
S-33.
IF REC-1 NOT = F1R5 DISPLAY "?S-33".
S-34.
READ FILE-2 NEXT RECORD AT END DISPLAY "?S-34".
S-35.
IF REC-2 NOT = F2R1 DISPLAY "?S-35".
S-36.
READ FILE-2 NEXT RECORD AT END DISPLAY "?S-36".
S-37.
IF REC-2 NOT = F2R2 DISPLAY "?S-37".
S-38.
READ FILE-2 NEXT RECORD AT END DISPLAY "?S-38".
S-39.
IF REC-2 NOT = F2R3 DISPLAY "?S-39".
S-40.
READ FILE-2 NEXT RECORD AT END DISPLAY "?S-40".
S-41.
IF REC-2 NOT = F2R4 DISPLAY "?S-41".
S-42.
READ FILE-2 NEXT RECORD AT END DISPLAY "?S-42".
S-43.
IF REC-2 NOT = F2R5 DISPLAY "?S-43".
S-44.
READ FILE-2 NEXT RECORD AT END GO TO S-45.
DISPLAY "?S-44".
S-45.
CLOSE FILE-2.
MOVE F1R3 TO REC-1.
DELETE FILE-1 INVALID KEY DISPLAY "?S-45".
S-46.
MOVE F1R4 TO REC-1.
MOVE 00000 TO AK1-2.
REWRITE REC-1 INVALID KEY DISPLAY "?S-46".
S-46A.
OPEN I-O FILE-2 FOR ANY ALLOWING OTHERS READ.
CLOSE FILE-1, FILE-2.
T-DONE.
DISPLAY "[RMS/COBOL - Completed test for BASIC-LOCKING]".
STOP RUN.