IDENTIFICATION DIVISION. PROGRAM-ID. CREATE. AUTHOR. DONALD FITZGERALD. REMARKS. THIS PROGRAM CREATES THE NECESSARY COBOL STATEMENTS TO CREATE A SIMPLE COBOL PROGRAM TO BE USED AS A TOOL USING TECO TO FURTHER YOUR PROGRAM. ENVIRONMENT DIVISION. CONFIGURATION SECTION. OBJECT-COMPUTER. PDP-10. INPUT-OUTPUT SECTION. FILE-CONTROL. SELECT TO-PRINTER ASSIGN TO DSK RECORDING MODE IS ASCII. DATA DIVISION. FILE SECTION. FD TO-PRINTER LABEL RECORD STANDARD VALUE OF ID SOME-NAME DATA RECORD PRINT-OUT, FOR-ID. 01 PRINT-OUT PIC X(56). 01 FOR-ID. 02 PRG-ID PIC X(12). 02 ID-NAME PIC X(6) JUSTIFIED RIGHT. 02 DOT PIC X. 02 FILLER PIC X(6). ****************************************** WORKING-STORAGE SECTION. 77 Z INDEX VALUE 1. 77 N INDEX VALUE 1. 77 I INDEX. 77 J INDEX. 77 DN INDEX. 01 IO PIC XX VALUE SPACES. *------------------------------------------------------- 77 ANS PIC XXX. 01 SOME-NAME. 02 FILE-N PIC X(6). 02 EXT PIC XXX. 01 SOME-NAMEX. 02 FILE-NX PIC X(6) JUSTIFIED RIGHT. 02 FILLER PIC X VALUE ".". 02 EXTX PIC XXX. *------------------------------------------------------- 01 COBOL-NAMES. 02 FILLER PIC X(24) VALUE "IDENTIFICATION DIVISION.". 02 FILLER PIC X(24) VALUE "PROGRAM-ID. . ". 02 FILLER PIC X(24) VALUE "ENVIRONMENT DIVISION. ". 02 FILLER PIC X(24) VALUE "CONFIGURATION SECTION. ". 02 FILLER PIC X(24) VALUE "OBJECT-COMPUTER. PDP-10.". 02 FILLER PIC X(24) VALUE "INPUT-OUTPUT SECTION. ". 02 FILLER PIC X(24) VALUE "FILE-CONTROL. ". 02 FILLER PIC X(24) VALUE "DATA DIVISION. ". 02 FILLER PIC X(24) VALUE "FILE SECTION. ". 02 FILLER PIC X(24) VALUE "WORKING-STORAGE SECTION.". 02 FILLER PIC X(24) VALUE "PROCEDURE DIVISION. ". 02 FILLER PIC X(24) VALUE "START. DISPLAY TODAY. ". 02 FILLER PIC X(24) VALUE " STOP RUN. ". 01 REDEF REDEFINES COBOL-NAMES. 02 RED OCCURS 13 TIMES PIC X(24). *------------------------------------------------------- 01 D-N-H. 02 D-NAME-HLD OCCURS 11 TIMES PIC X(30). 01 D-HLD. 02 DEV-HLD OCCURS 11 TIMES PIC XXXX. *------------------------------------------------------- 01 FILE-SELECT. 02 FILLER PIC X(4). 02 RESERV-W1 PIC X(7) VALUE "SELECT ". 02 D-NAME PIC X(30). 02 RESERV-W2 PIC X(11) VALUE " ASSIGN TO ". 02 DEV PIC X(4). *------------------------------------------------------- 01 REC-MODE. 02 FILLER PIC XXXX VALUE SPACES. 02 FILLER PIC X(18) VALUE "RECORDING MODE IS ". 02 MOD PIC X(7). *------------------------------------------------------- 01 FD-SEC. 02 F PIC XXXX VALUE "FD ". 02 FD-NAME PIC X(30). *------------------------------------------------------- 01 LABELS. 02 FILLER PIC XXXX VALUES SPACES. 02 FILLER PIC X(18) VALUE "LABEL RECORDS ARE ". 02 S-OR-O PIC X(8). *------------------------------------------------------- 01 VALUE-IDENT. 02 FILLER PIC XXXX VALUE SPACES. 02 FILLER PIC X(13) VALUE "VALUE OF ID '". 02 VALUE-ID PIC X(9). 02 FILLER PIC X VALUE "'". *------------------------------------------------------- 01 BLOCK-IT. 02 FILLER PIC X(4) VALUE SPACES. 02 FILLER PIC X(15) VALUE "BLOCK CONTAINS ". 02 BLK-NO PIC XXX. 02 FILLER PIC X(8) VALUE " RECORDS". *------------------------------------------------------- 01 DATA-REC. 02 FILLER PIC XXXX VALUE SPACES. 02 FILLER PIC X(12) VALUE "DATA RECORD ". 02 REC-HLD. 03 REC-CHK OCCURS 30 TIMES PIC X. *------------------------------------------------------- 01 O1-REC. 02 FILLER PIC XXXX VALUE "01 ". 02 REC-HLD1. 03 REC-CHK1 OCCURS 30 TIMES PIC X. 02 FILLER PIC X(7) VALUE " PIC X(". 02 SIZE-FILL. 03 SIZE-F OCCURS 6 TIMES PIC X. 01 IO-REC. 02 FILLER PIC X(4) VALUE SPACES. 02 IO-HLD PIC X(12) VALUE SPACES. 02 IO-D-NAME PIC X(30). 02 FILLER PIC X. 01 CHOP-C. 02 CHOP-CHAR OCCURS 31 TIMES PIC X. 01 STALL-P-REC OCCURS 10 TIMES PIC X(47). 01 STALL-P-REC1 OCCURS 10 TIMES PIC X(47). *:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 01 HELP-STATUS. 02 FILLER PIC X(40) VALUE "THERE IS CURRENTLY 2 MODES OF OPERATIONS". 02 FILLER PIC X(40) VALUE "1) FAST-MODE WHICH WILL PRODUCE AN ". 02 FILLER PIC X(40) VALUE " EXECUTABLE COBOL PROGRAM W/NO I-O ". 02 FILLER PIC X(40) VALUE " ANSWER NO TO-SELECT FILES FOR I-O? ". 02 FILLER PIC X(40) VALUE "2) LONG-MODE WHICH WILL ALLOW YOU TO ". 02 FILLER PIC X(40) VALUE " SELECT UP TO 10 I-O FILES. ". 02 FILLER PIC X(40) VALUE " 29 CHAR. LIMIT ON DATA-NAMES. ". 02 FILLER PIC X(40) VALUE " PROGRAM OPTIONS FOR LONG-MODE ARE: ". 02 FILLER PIC X(40) VALUE "----SELECT & ASSIGN TO DEV. ". 02 FILLER PIC X(40) VALUE "----RECORDING MODE IS ASCII OR SIXBIT ". 02 FILLER PIC X(40) VALUE "----FD DATA-NAME ". 02 FILLER PIC X(40) VALUE "----LABEL RECORDS OMITTED OR STANDARD ". 02 FILLER PIC X(40) VALUE "----VALUE OF ID '123456789' ". 02 FILLER PIC X(40) VALUE "----DATA RECORDS ARE DATA-NAME-2 ". 02 FILLER PIC X(40) VALUE "----01 DATA-NAME-2. ". 01 HELP REDEFINES HELP-STATUS. 02 H OCCURS 15 TIMES PIC X(40). *::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: *------------------------------------------------------- *------------------------------------------------------- PROCEDURE DIVISION. HELP-START. DISPLAY "/H FOR HELP ELSE ANY CHAR. " WITH NO ADVANCING. ACCEPT ANS. IF ANS NOT EQUAL "/H " GO TO START. MOVE 1 TO I. ITERATE-HELP. DISPLAY H(I). ADD 1 TO I. IF I > 15 GO TO START. GO TO ITERATE-HELP. START. MOVE LOW-VALUES TO SOME-NAME, D-N-H, D-HLD. DISPLAY "KEY-IN NAME OF PROGRAM YOU WANT TO CREATE". DISPLAY "NO PERIODS (.) ALLOWED IN STRING " WITH NO ADVANCING ACCEPT SOME-NAME. IF EXT = " " MOVE "CBL" TO EXT. OPEN OUTPUT TO-PRINTER. MOVE 1 TO I, DN. BEGIN. MOVE RED (I) TO PRINT-OUT. WRITE PRINT-OUT. ADD 1 TO I. IF I = 2 PERFORM MOVE-ID. IF I = 8 DISPLAY "DO YOU WISH TO SELECT FILES FOR I/O? " WITH NO ADVANCING ACCEPT ANS IF ANS = "YES" OR ANS = "Y " GO TO SELECT-SECTION. IF I = 10 MOVE 1 TO DN GO TO FD-SECTION. IF I = 13 MOVE 1 TO N PERFORM WRITE-O-C THRU DONE-O-C. IF I = 14 GO TO EOJ. GO TO BEGIN. MOVE-ID. MOVE RED (I) TO FOR-ID. MOVE FILE-N TO ID-NAME, FILE-NX. MOVE EXT TO EXTX. WRITE FOR-ID. ADD 1 TO I. SELECT-SECTION. DISPLAY "KEY-IN A DATA-NAME TO BE SELECTED " WITH NO ADVANCING. ACCEPT D-NAME. MOVE D-NAME TO D-NAME-HLD (DN). DISPLAY "DEVICE? CDR,CDP,LPT,DSK OR MTA# " WITH NO ADVANCING. ACCEPT DEV. MOVE DEV TO DEV-HLD (DN). WRITE PRINT-OUT FROM FILE-SELECT. SMARTS. MOVE SPACES TO ANS. DISPLAY "IS " D-NAME-HLD(DN) " ASCII OR SIXBIT" DISPLAY "A OR S " WITH NO ADVANCING. ACCEPT ANS. IF ANS = "A " GO TO ASCII-MODE. IF ANS = "S " GO TO SIXBIT-MODE. GO TO SMARTS. ASCII-MODE. MOVE "ASCII." TO MOD. WRITE PRINT-OUT FROM REC-MODE. MOVE SPACES TO MOD. GO TO CONT. SIXBIT-MODE. MOVE "SIXBIT." TO MOD. WRITE PRINT-OUT FROM REC-MODE. MOVE SPACES TO MOD. CONT. DISPLAY "ANYMORE FILES " WITH NO ADVANCING. ACCEPT ANS. IF ANS = "YES" OR ANS = "Y " NEXT SENTENCE ELSE GO TO BEGIN. ADD 1 TO DN. MOVE SPACES TO D-NAME, DEV, ANS. GO TO SELECT-SECTION. FD-SECTION. IF D-NAME-HLD(DN) = LOW-VALUES GO TO BEGIN. MOVE D-NAME-HLD(DN) TO FD-NAME. WRITE PRINT-OUT FROM FD-SEC. IF DEV-HLD(DN) = "DSK " MOVE "STANDARD" TO S-OR-O WRITE PRINT-OUT FROM LABELS MOVE SPACES TO S-OR-O GO TO GET-ID. MOVE "OMITTED " TO S-OR-O WRITE PRINT-OUT FROM LABELS. GO TO CHOICE-OF-BLOCKING. GET-ID. DISPLAY "YOU HAVE CHOSEN -DSK- AS YOUR DEVICE". DISPLAY "KEY-IN 9 CONTIGUOUS CHARS. (NO SPEC. CHARS. ALLOWED". DISPLAY "FOR YOUR VALUE OF ID ON " D-NAME-HLD(DN). ACCEPT VALUE-ID. WRITE PRINT-OUT FROM VALUE-IDENT. CHOICE-OF-BLOCKING. DISPLAY "DO YOU WISH TO SPECIFY BLOCKING FOR " D-NAME-HLD(DN) MOVE SPACES TO ANS BLK-NO. ACCEPT ANS. IF ANS = "YES" OR ANS = "Y " DISPLAY "HOW MANY RECORDS PER BLOCK " ACCEPT BLK-NO WRITE PRINT-OUT FROM BLOCK-IT. GET-REC. MOVE LOW-VALUES TO REC-HLD, SIZE-FILL. DISPLAY "KEY-IN RECORD NAME FOR 01 LEVEL ON " D-NAME-HLD(DN). ACCEPT REC-HLD. DISPLAY "KEY-IN SIZE OF " REC-HLD. ACCEPT SIZE-FILL. MOVE 1 TO J. SIZE-REC. IF SIZE-F (J) = LOW-VALUES MOVE ")" TO SIZE-F(J) MOVE "." TO SIZE-F(J + 1) GO TO NEXT-1. ADD 1 TO J. GO TO SIZE-REC. NEXT-1. MOVE 1 TO J. DO-IT-AGAIN. IF REC-CHK(J) = LOW-VALUES MOVE REC-HLD TO REC-HLD1 MOVE "." TO REC-CHK(J) WRITE PRINT-OUT FROM DATA-REC WRITE PRINT-OUT FROM O1-REC PERFORM OPEN-I-O THRU MOVE-OPEN-IO GO TO GET-BACK. ADD 1 TO J. GO TO DO-IT-AGAIN. OPEN-I-O. IF D-NAME-HLD(DN) = LOW-VALUES GO TO BEGIN. DISPLAY "IS " D-NAME-HLD(DN). DISPLAY "INPUT OUTPUT OR I-O KEY-IN I O OR IO". ACCEPT IO. IF IO = "I" MOVE "OPEN INPUT " TO IO-HLD GO TO MOVE-OPEN-IO. IF IO = "O" MOVE "OPEN OUTPUT" TO IO-HLD GO TO MOVE-OPEN-IO. IF IO = "IO" MOVE "OPEN I-O " TO IO-HLD GO TO MOVE-OPEN-IO. GO TO OPEN-I-O. MOVE-OPEN-IO. MOVE D-NAME-HLD(DN) TO IO-D-NAME. PERFORM CHOP-CHAR-IO THRU CHOP-CHAR-EXIT. MOVE IO-REC TO STALL-P-REC(N). MOVE SPACES TO IO-HLD. MOVE "CLOSE" TO IO-HLD. MOVE IO-REC TO STALL-P-REC1(N). ADD 1 TO N. GET-BACK. MOVE LOW-VALUES TO REC-HLD, REC-HLD1. ADD 1 TO DN. GO TO FD-SECTION. WRITE-O-C. WRITE PRINT-OUT FROM STALL-P-REC(N). ADD 1 TO N. IF STALL-P-REC(N) = LOW-VALUES MOVE 1 TO N GO TO WRITE-CLOSE. GO TO WRITE-O-C. WRITE-CLOSE. WRITE PRINT-OUT FROM STALL-P-REC1(N). ADD 1 TO N. IF STALL-P-REC1(N) = LOW-VALUES GO TO DONE-O-C. GO TO WRITE-CLOSE. DONE-O-C. EXIT. CHOP-CHAR-IO. MOVE IO-D-NAME TO CHOP-C. NEXT-CHOP. IF CHOP-CHAR(Z) = SPACE MOVE "." TO CHOP-CHAR(Z) MOVE CHOP-C TO IO-D-NAME MOVE 1 TO Z GO TO CHOP-CHAR-EXIT. ADD 1 TO Z. GO TO NEXT-CHOP. CHOP-CHAR-EXIT. EXIT. EOJ. CLOSE TO-PRINTER. DISPLAY "PROGRAM-ID " FILE-N WITH NO ADVANCING. DISPLAY " TYPE " SOME-NAMEX. STOP RUN.