Quelle  sm203a.cob   Sprache: Cobol

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.