|
000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID.
000300 SM203A.
000400****************************************************************
000500* *
000600* VALIDATION FOR:- *
000700* *
000800* "ON-SITE VALIDATION, NATIONAL INSTITUTE OF STD & TECH. ".
000900* *
001000* "COBOL 85 VERSION 4.2, Apr 1993 SSVG ".
001100* *
001200****************************************************************
001300* *
001400* X-CARDS USED BY THIS PROGRAM ARE :- *
001500* *
001600* X-55 - SYSTEM PRINTER NAME. *
001700* X-82 - SOURCE COMPUTER NAME. *
001800* X-83 - OBJECT COMPUTER NAME. *
001900* *
002000****************************************************************
002100* *
002200* PROGRAM SM203A TESTS THE USE OF THE "COPY" STATEMENT *
002300* "REPLACING" PHRASE IN THE ENVIRONMENT DIVISION. *
002400* A SEQUENTIAL FILE IS PRODUCED USING "COPY"ED TEXT AND *
002500* THIS IS CHECKED IN PROGRAM SM204A. *
002600* *
002700****************************************************************
002800 ENVIRONMENT DIVISION.
002900 CONFIGURATION SECTION.
003000 SOURCE-COMPUTER.
003100 Card0130.
003200 OBJECT-COMPUTER.
003300 Card0131.
003400 SPECIAL-NAMES. COPY K3SNB
003500 REPLACING DUMMY-SW-1 BY SW-1
003600 DUMMY-ON BY SWITCH-ON
003700 DUMMY-OFF BY SWITCH-OFF.
003800 INPUT-OUTPUT SECTION.
003900
004000
004100
004200
004300
004400*
004500*********************** COPY STATEMENT USED **********************
004600*
004700*FILE-CONTROL. COPY K3FCB
004800* REPLACING DUMMY-TEST-FILE BY TEST-FILE.
004900*
005000******************** COPIED TEXT BEGINS BELOW ********************
005100 FILE-CONTROL. COPY K3FCB
005200 REPLACING DUMMY-TEST-FILE BY TEST-FILE.
005300*********************** END OF COPIED TEXT ***********************
005400
005500
005600
005700
005800
005900*
006000*********************** COPY STATEMENT USED **********************
006100*
006200*I-O-CONTROL. COPY K3IOB
006300* REPLACING DUMMY-PRINT-FILE BY PRINT-FILE.
006400*
006500******************** COPIED TEXT BEGINS BELOW ********************
006600 I-O-CONTROL. COPY K3IOB
006700 REPLACING DUMMY-PRINT-FILE BY PRINT-FILE.
006800*********************** END OF COPIED TEXT ***********************
006900 DATA DIVISION.
007000 FILE SECTION.
007100 FD PRINT-FILE.
007200 01 PRINT-REC PICTURE X(120).
007300 01 DUMMY-RECORD PICTURE X(120).
007400 FD TEST-FILE
007500 LABEL RECORD STANDARD
007600 VALUE OF
007700 Impl1
007800 IS
007900 4711
008000
008100 DATA RECORD IS PROOF-REC.
008200 01 PROOF-REC.
008300 02 TF-1 PICTURE 9(5).
008400 02 FILLER PICTURE X(115).
008500 WORKING-STORAGE SECTION.
008600 77 RCD-1 PICTURE 9(5) VALUE 97532.
008700 77 RCD-2 PICTURE 9(5) VALUE 23479.
008800 77 RCD-3 PICTURE 9(5) VALUE 10901.
008900 77 RCD-4 PICTURE 9(5) VALUE 02734.
009000 77 RCD-5 PICTURE 9(5) VALUE 14003.
009100 77 RCD-6 PICTURE 9(5) VALUE 19922.
009200 77 RCD-7 PICTURE 9(5) VALUE 03543.
009300 01 TEST-RESULTS.
009400 02 FILLER PIC X VALUE SPACE.
009500 02 FEATURE PIC X(20) VALUE SPACE.
009600 02 FILLER PIC X VALUE SPACE.
009700 02 P-OR-F PIC X(5) VALUE SPACE.
009800 02 FILLER PIC X VALUE SPACE.
009900 02 PAR-NAME.
010000 03 FILLER PIC X(19) VALUE SPACE.
010100 03 PARDOT-X PIC X VALUE SPACE.
010200 03 DOTVALUE PIC 99 VALUE ZERO.
010300 02 FILLER PIC X(8) VALUE SPACE.
010400 02 RE-MARK PIC X(61).
010500 01 TEST-COMPUTED.
010600 02 FILLER PIC X(30) VALUE SPACE.
010700 02 FILLER PIC X(17) VALUE
010800 " COMPUTED=".
010900 02 COMPUTED-X.
011000 03 COMPUTED-A PIC X(20) VALUE SPACE.
011100 03 COMPUTED-N REDEFINES COMPUTED-A
011200 PIC -9(9).9(9).
011300 03 COMPUTED-0V18 REDEFINES COMPUTED-A PIC -.9(18).
011400 03 COMPUTED-4V14 REDEFINES COMPUTED-A PIC -9(4).9(14).
011500 03 COMPUTED-14V4 REDEFINES COMPUTED-A PIC -9(14).9(4).
011600 03 CM-18V0 REDEFINES COMPUTED-A.
011700 04 COMPUTED-18V0 PIC -9(18).
011800 04 FILLER PIC X.
011900 03 FILLER PIC X(50) VALUE SPACE.
012000 01 TEST-CORRECT.
012100 02 FILLER PIC X(30) VALUE SPACE.
012200 02 FILLER PIC X(17) VALUE " CORRECT =".
012300 02 CORRECT-X.
012400 03 CORRECT-A PIC X(20) VALUE SPACE.
012500 03 CORRECT-N REDEFINES CORRECT-A PIC -9(9).9(9).
012600 03 CORRECT-0V18 REDEFINES CORRECT-A PIC -.9(18).
012700 03 CORRECT-4V14 REDEFINES CORRECT-A PIC -9(4).9(14).
012800 03 CORRECT-14V4 REDEFINES CORRECT-A PIC -9(14).9(4).
012900 03 CR-18V0 REDEFINES CORRECT-A.
013000 04 CORRECT-18V0 PIC -9(18).
013100 04 FILLER PIC X.
013200 03 FILLER PIC X(2) VALUE SPACE.
013300 03 COR-ANSI-REFERENCE PIC X(48) VALUE SPACE.
013400 01 CCVS-C-1.
013500 02 FILLER PIC IS X(99) VALUE IS " FEATURE PA
013600- "SS PARAGRAPH-NAME
013700- " REMARKS".
013800 02 FILLER PIC X(20) VALUE SPACE.
013900 01 CCVS-C-2.
014000 02 FILLER PIC X VALUE SPACE.
014100 02 FILLER PIC X(6) VALUE "TESTED".
014200 02 FILLER PIC X(15) VALUE SPACE.
014300 02 FILLER PIC X(4) VALUE "FAIL".
014400 02 FILLER PIC X(94) VALUE SPACE.
014500 01 REC-SKL-SUB PIC 9(2) VALUE ZERO.
014600 01 REC-CT PIC 99 VALUE ZERO.
014700 01 DELETE-COUNTER PIC 999 VALUE ZERO.
014800 01 ERROR-COUNTER PIC 999 VALUE ZERO.
014900 01 INSPECT-COUNTER PIC 999 VALUE ZERO.
015000 01 PASS-COUNTER PIC 999 VALUE ZERO.
015100 01 TOTAL-ERROR PIC 999 VALUE ZERO.
015200 01 ERROR-HOLD PIC 999 VALUE ZERO.
015300 01 DUMMY-HOLD PIC X(120) VALUE SPACE.
015400 01 RECORD-COUNT PIC 9(5) VALUE ZERO.
015500 01 ANSI-REFERENCE PIC X(48) VALUE SPACES.
015600 01 CCVS-H-1.
015700 02 FILLER PIC X(39) VALUE SPACES.
015800 02 FILLER PIC X(42) VALUE
015900 "OFFICIAL COBOL COMPILER VALIDATION SYSTEM".
016000 02 FILLER PIC X(39) VALUE SPACES.
016100 01 CCVS-H-2A.
016200 02 FILLER PIC X(40) VALUE SPACE.
016300 02 FILLER PIC X(7) VALUE "CCVS85 ".
016400 02 FILLER PIC XXXX VALUE
016500 "4.2 ".
016600 02 FILLER PIC X(28) VALUE
016700 " COPY - NOT FOR DISTRIBUTION".
016800 02 FILLER PIC X(41) VALUE SPACE.
016900
017000 01 CCVS-H-2B.
017100 02 FILLER PIC X(15) VALUE
017200 "TEST RESULT OF ".
017300 02 TEST-ID PIC X(9).
017400 02 FILLER PIC X(4) VALUE
017500 " IN ".
017600 02 FILLER PIC X(12) VALUE
017700 " HIGH ".
017800 02 FILLER PIC X(22) VALUE
017900 " LEVEL VALIDATION FOR ".
018000 02 FILLER PIC X(58) VALUE
018100 "ON-SITE VALIDATION, NATIONAL INSTITUTE OF STD & TECH. ".
018200 01 CCVS-H-3.
018300 02 FILLER PIC X(34) VALUE
018400 " FOR OFFICIAL USE ONLY ".
018500 02 FILLER PIC X(58) VALUE
018600 "COBOL 85 VERSION 4.2, Apr 1993 SSVG ".
018700 02 FILLER PIC X(28) VALUE
018800 " COPYRIGHT 1985 ".
018900 01 CCVS-E-1.
019000 02 FILLER PIC X(52) VALUE SPACE.
019100 02 FILLER PIC X(14) VALUE IS "END OF TEST- ".
019200 02 ID-AGAIN PIC X(9).
019300 02 FILLER PIC X(45) VALUE SPACES.
019400 01 CCVS-E-2.
019500 02 FILLER PIC X(31) VALUE SPACE.
019600 02 FILLER PIC X(21) VALUE SPACE.
019700 02 CCVS-E-2-2.
019800 03 ERROR-TOTAL PIC XXX VALUE SPACE.
019900 03 FILLER PIC X VALUE SPACE.
020000 03 ENDER-DESC PIC X(44) VALUE
020100 "ERRORS ENCOUNTERED".
020200 01 CCVS-E-3.
020300 02 FILLER PIC X(22) VALUE
020400 " FOR OFFICIAL USE ONLY".
020500 02 FILLER PIC X(12) VALUE SPACE.
020600 02 FILLER PIC X(58) VALUE
020700 "ON-SITE VALIDATION, NATIONAL INSTITUTE OF STD & TECH. ".
020800 02 FILLER PIC X(13) VALUE SPACE.
020900 02 FILLER PIC X(15) VALUE
021000 " COPYRIGHT 1985".
021100 01 CCVS-E-4.
021200 02 CCVS-E-4-1 PIC XXX VALUE SPACE.
021300 02 FILLER PIC X(4) VALUE " OF ".
021400 02 CCVS-E-4-2 PIC XXX VALUE SPACE.
021500 02 FILLER PIC X(40) VALUE
021600 " TESTS WERE EXECUTED SUCCESSFULLY".
021700 01 XXINFO.
021800 02 FILLER PIC X(19) VALUE
021900 "*** INFORMATION ***".
022000 02 INFO-TEXT.
022100 04 FILLER PIC X(8) VALUE SPACE.
022200 04 XXCOMPUTED PIC X(20).
022300 04 FILLER PIC X(5) VALUE SPACE.
022400 04 XXCORRECT PIC X(20).
022500 02 INF-ANSI-REFERENCE PIC X(48).
022600 01 HYPHEN-LINE.
022700 02 FILLER PIC IS X VALUE IS SPACE.
022800 02 FILLER PIC IS X(65) VALUE IS "************************
022900- "*****************************************".
023000 02 FILLER PIC IS X(54) VALUE IS "************************
023100- "******************************".
023200 01 CCVS-PGM-ID PIC X(9) VALUE
023300 "SM203A".
023400 PROCEDURE DIVISION.
023500 CCVS1 SECTION.
023600 OPEN-FILES.
023700 OPEN OUTPUT PRINT-FILE.
023800 MOVE CCVS-PGM-ID TO TEST-ID. MOVE CCVS-PGM-ID TO ID-AGAIN.
023900 MOVE SPACE TO TEST-RESULTS.
024000 PERFORM HEAD-ROUTINE THRU COLUMN-NAMES-ROUTINE.
024100 GO TO CCVS1-EXIT.
024200 CLOSE-FILES.
024300 PERFORM END-ROUTINE THRU END-ROUTINE-13. CLOSE PRINT-FILE.
024400 TERMINATE-CCVS.
024500 EXIT PROGRAM.
024600 TERMINATE-CALL.
024700 STOP RUN.
024800 INSPT. MOVE "INSPT" TO P-OR-F. ADD 1 TO INSPECT-COUNTER.
024900 PASS. MOVE "PASS " TO P-OR-F. ADD 1 TO PASS-COUNTER.
025000 FAIL. MOVE "FAIL*" TO P-OR-F. ADD 1 TO ERROR-COUNTER.
025100 DE-LETE. MOVE "*****" TO P-OR-F. ADD 1 TO DELETE-COUNTER.
025200 MOVE "****TEST DELETED****" TO RE-MARK.
025300 PRINT-DETAIL.
025400 IF REC-CT NOT EQUAL TO ZERO
025500 MOVE "." TO PARDOT-X
025600 MOVE REC-CT TO DOTVALUE.
025700 MOVE TEST-RESULTS TO PRINT-REC. PERFORM WRITE-LINE.
025800 IF P-OR-F EQUAL TO "FAIL*" PERFORM WRITE-LINE
025900 PERFORM FAIL-ROUTINE THRU FAIL-ROUTINE-EX
026000 ELSE PERFORM BAIL-OUT THRU BAIL-OUT-EX.
026100 MOVE SPACE TO P-OR-F. MOVE SPACE TO COMPUTED-X.
026200 MOVE SPACE TO CORRECT-X.
026300 IF REC-CT EQUAL TO ZERO MOVE SPACE TO PAR-NAME.
026400 MOVE SPACE TO RE-MARK.
026500 HEAD-ROUTINE.
026600 MOVE CCVS-H-1 TO DUMMY-RECORD. PERFORM WRITE-LINE 2 TIMES.
026700 MOVE CCVS-H-2A TO DUMMY-RECORD. PERFORM WRITE-LINE 2 TIMES.
026800 MOVE CCVS-H-2B TO DUMMY-RECORD. PERFORM WRITE-LINE 3 TIMES.
026900 MOVE CCVS-H-3 TO DUMMY-RECORD. PERFORM WRITE-LINE 3 TIMES.
027000 COLUMN-NAMES-ROUTINE.
027100 MOVE CCVS-C-1 TO DUMMY-RECORD. PERFORM WRITE-LINE.
027200 MOVE CCVS-C-2 TO DUMMY-RECORD. PERFORM WRITE-LINE 2 TIMES.
027300 MOVE HYPHEN-LINE TO DUMMY-RECORD. PERFORM WRITE-LINE.
027400 END-ROUTINE.
027500 MOVE HYPHEN-LINE TO DUMMY-RECORD. PERFORM WRITE-LINE 5 TIMES.
027600 END-RTN-EXIT.
027700 MOVE CCVS-E-1 TO DUMMY-RECORD. PERFORM WRITE-LINE 2 TIMES.
027800 END-ROUTINE-1.
027900 ADD ERROR-COUNTER TO ERROR-HOLD ADD INSPECT-COUNTER TO
028000 ERROR-HOLD. ADD DELETE-COUNTER TO ERROR-HOLD.
028100 ADD PASS-COUNTER TO ERROR-HOLD.
028200* IF PASS-COUNTER EQUAL TO ERROR-HOLD GO TO END-ROUTINE-12.
028300 MOVE PASS-COUNTER TO CCVS-E-4-1.
028400 MOVE ERROR-HOLD TO CCVS-E-4-2.
028500 MOVE CCVS-E-4 TO CCVS-E-2-2.
028600 MOVE CCVS-E-2 TO DUMMY-RECORD PERFORM WRITE-LINE.
028700 END-ROUTINE-12.
028800 MOVE "TEST(S) FAILED" TO ENDER-DESC.
028900 IF ERROR-COUNTER IS EQUAL TO ZERO
029000 MOVE "NO " TO ERROR-TOTAL
029100 ELSE
029200 MOVE ERROR-COUNTER TO ERROR-TOTAL.
029300 MOVE CCVS-E-2 TO DUMMY-RECORD.
029400 PERFORM WRITE-LINE.
029500 END-ROUTINE-13.
029600 IF DELETE-COUNTER IS EQUAL TO ZERO
029700 MOVE "NO " TO ERROR-TOTAL ELSE
029800 MOVE DELETE-COUNTER TO ERROR-TOTAL.
029900 MOVE "TEST(S) DELETED " TO ENDER-DESC.
030000 MOVE CCVS-E-2 TO DUMMY-RECORD. PERFORM WRITE-LINE.
030100 IF INSPECT-COUNTER EQUAL TO ZERO
030200 MOVE "NO " TO ERROR-TOTAL
030300 ELSE MOVE INSPECT-COUNTER TO ERROR-TOTAL.
030400 MOVE "TEST(S) REQUIRE INSPECTION" TO ENDER-DESC.
030500 MOVE CCVS-E-2 TO DUMMY-RECORD. PERFORM WRITE-LINE.
030600 MOVE CCVS-E-3 TO DUMMY-RECORD. PERFORM WRITE-LINE.
030700 WRITE-LINE.
030800 ADD 1 TO RECORD-COUNT.
030900 IF RECORD-COUNT GREATER 50
031000 MOVE DUMMY-RECORD TO DUMMY-HOLD
031100 MOVE SPACE TO DUMMY-RECORD
031200 WRITE DUMMY-RECORD AFTER ADVANCING PAGE
031300 MOVE CCVS-C-1 TO DUMMY-RECORD PERFORM WRT-LN
031400 MOVE CCVS-C-2 TO DUMMY-RECORD PERFORM WRT-LN 2 TIMES
031500 MOVE HYPHEN-LINE TO DUMMY-RECORD PERFORM WRT-LN
031600 MOVE DUMMY-HOLD TO DUMMY-RECORD
031700 MOVE ZERO TO RECORD-COUNT.
031800 PERFORM WRT-LN.
031900 WRT-LN.
032000 WRITE DUMMY-RECORD AFTER ADVANCING 1 LINES.
032100 MOVE SPACE TO DUMMY-RECORD.
032200 BLANK-LINE-PRINT.
032300 PERFORM WRT-LN.
032400 FAIL-ROUTINE.
032500 IF COMPUTED-X NOT EQUAL TO SPACE GO TO FAIL-ROUTINE-WRITE.
032600 IF CORRECT-X NOT EQUAL TO SPACE GO TO FAIL-ROUTINE-WRITE.
032700 MOVE ANSI-REFERENCE TO INF-ANSI-REFERENCE.
032800 MOVE "NO FURTHER INFORMATION, SEE PROGRAM." TO INFO-TEXT.
032900 MOVE XXINFO TO DUMMY-RECORD. PERFORM WRITE-LINE 2 TIMES.
033000 MOVE SPACES TO INF-ANSI-REFERENCE.
033100 GO TO FAIL-ROUTINE-EX.
033200 FAIL-ROUTINE-WRITE.
033300 MOVE TEST-COMPUTED TO PRINT-REC PERFORM WRITE-LINE
033400 MOVE ANSI-REFERENCE TO COR-ANSI-REFERENCE.
033500 MOVE TEST-CORRECT TO PRINT-REC PERFORM WRITE-LINE 2 TIMES.
033600 MOVE SPACES TO COR-ANSI-REFERENCE.
033700 FAIL-ROUTINE-EX. EXIT.
033800 BAIL-OUT.
033900 IF COMPUTED-A NOT EQUAL TO SPACE GO TO BAIL-OUT-WRITE.
034000 IF CORRECT-A EQUAL TO SPACE GO TO BAIL-OUT-EX.
034100 BAIL-OUT-WRITE.
034200 MOVE CORRECT-A TO XXCORRECT. MOVE COMPUTED-A TO XXCOMPUTED.
034300 MOVE ANSI-REFERENCE TO INF-ANSI-REFERENCE.
034400 MOVE XXINFO TO DUMMY-RECORD. PERFORM WRITE-LINE 2 TIMES.
034500 MOVE SPACES TO INF-ANSI-REFERENCE.
034600 BAIL-OUT-EX. EXIT.
034700 CCVS1-EXIT.
034800 EXIT.
034900 INITIALIZATION SECTION.
035000 SM203-INIT.
035100 OPEN OUTPUT TEST-FILE.
035200 BUILD SECTION.
035300 COPY-TEST-1.
035400 MOVE RCD-1 TO TF-1.
035500 WRITE PROOF-REC.
035600 MOVE RCD-2 TO TF-1.
035700 WRITE PROOF-REC.
035800 MOVE RCD-3 TO TF-1.
035900 WRITE PROOF-REC.
036000 MOVE RCD-4 TO TF-1.
036100 WRITE PROOF-REC.
036200 MOVE RCD-5 TO TF-1.
036300 WRITE PROOF-REC.
036400 MOVE RCD-6 TO TF-1.
036500 WRITE PROOF-REC.
036600 MOVE RCD-7 TO TF-1.
036700 WRITE PROOF-REC.
036800 PERFORM PASS.
036900 GO TO COPY-WRITE-1.
037000 COPY-DELETE-1.
037100 PERFORM DE-LETE.
037200 COPY-WRITE-1.
037300 MOVE "COPY ENV DIV REPLAC" TO FEATURE.
037400 MOVE "COPY-TEST-1 " TO PAR-NAME.
037500 PERFORM PRINT-DETAIL.
037600 CLOSE TEST-FILE.
037700 CCVS-EXIT SECTION.
037800 CCVS-999999.
037900 GO TO CLOSE-FILES.
¤ Dauer der Verarbeitung: 0.9 Sekunden
(vorverarbeitet)
¤
|
Haftungshinweis
Die Informationen auf dieser Webseite wurden
nach bestem Wissen sorgfältig zusammengestellt. Es wird jedoch weder Vollständigkeit, noch Richtigkeit,
noch Qualität der bereit gestellten Informationen zugesichert.
Bemerkung:
Die farbliche Syntaxdarstellung ist noch experimentell.
|
