Trailing-Edge
-
PDP-10 Archives
-
decuslib10-04
-
43,50343/cobols.cbl
There is 1 other file named cobols.cbl in the archive. Click here to see a list.
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. <CR> " 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.