Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-03 - decus/20-0081/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.