Trailing-Edge
-
PDP-10 Archives
-
integ_tools_tops20_v7_30-apr-86_dumper
-
tools/isacon/vag001.cbl
There are 5 other files named vag001.cbl in the archive. Click here to see a list.
IDENTIFICATION DIVISION.
*=======================
Program-Id. VAG001.
Author. KATHY MCKENDRY
Date-Written. 16-Oct-84.
Date-Compiled.
Installation. PAPER FREE SYSTEMS, INC.
*-------------
*Program Title:
*-------------
*
* System: ISACON DEC to VAX Conversion System
* Module: VAG001 File Language File Generator
*
*
*-------------------
*Program Description:
*-------------------
*
* VAG001 creates a file based on the SELECT, FILE DESCRIPTION and
* DATA DESCRIPTION portions of a user-designated file in a COBOL
* listing. The created file will be used by the source code
* generator program, VAG002, to create programs which will
* convert the original file from DEC-10 format to VAX-11 format
* (VMS), as well as create a Common Data Dictionary for the
* converted file.
*
*----------------------------
*Program Modification History:
*----------------------------
* --Date-- Who What
*
*----------------------------------------------------------------------
ENVIRONMENT DIVISION.
*====================
CONFIGURATION SECTION.
*---------------------
SOURCE-COMPUTER. DECSYSTEM-10.
OBJECT-COMPUTER. DECSYSTEM-10.
INPUT-OUTPUT SECTION.
*--------------------
FILE-CONTROL.
select COBOL-LISTING-FILE
assign to DSK
file status is CL-FS-STATUS
CL-FS-ERROR-NO
CL-FS-ACTION-CODE
CL-FS-FILE-SPEC
CL-FS-BLOCK-NO
CL-FS-RECORD-NO
CL-FS-FILE-NAME
CL-FS-TABLE-POINTER
recording mode ASCII.
select FILE-LANGUAGE-FILE
assign to DSK
recording mode ASCII.
DATA DIVISION.
*=============
FILE SECTION.
*------------
fd COBOL-LISTING-FILE
value of id COBOL-LISTING-FILE-ID.
01 COBOL-LISTING-RECORD display-7.
02 CLR-NUM-TEST pic X(04).
02 FILLER REDEFINES
CLR-NUM-TEST.
04 CLR-COMM-CHECK PIC X(01).
88 CLR-COMMENT-LINE VALUE '*'.
04 FILLER PIC X(03).
02 FILLER PIC X(02).
02 CLR-BODY PIC X(99).
01 COBOL-LISTING-WORK-REC display-7.
02 COBOL-LISTING-WORK pic X(001) occurs 105.
fd FILE-LANGUAGE-FILE
value of id FILE-LANGUAGE-FILE-ID.
01 FILE-LANGUAGE-RECORD PIC X(375) display-7.
01 FILE-LANGUAGE-2 DISPLAY-7.
05 FILE-LANGUAGE-VAR PIC X(001)
OCCURS 1 TO 375
DEPENDING ON VAR-IDX.
*
WORKING-STORAGE SECTION.
*=======================
01 VAR-IDX USAGE INDEX.
01 CL-POINTERS.
02 COBOL-LISTING-PTR pic S9(03) comp.
01 CL-STATE-SWITCHES.
02 COBOL-LISTING-END-SW pic S9(01) comp.
88 COBOL-LISTING-END value 1.
02 COBOL-LISTING-STAT PIC S9(01) COMP VALUE 0.
88 COBOL-LISTING-OPEN VALUE 1.
01 COBOL-LISTING-FILE-CONTROL DISPLAY-6.
02 COBOL-LISTING-FILE-ID.
04 COBOL-LISTING-FILE-NAME pic X(06).
04 COBOL-LISTING-FILE-EXT pic X(03).
02 CL-FILE-STATUS.
04 CL-FS-STATUS pic 9(02).
88 CL-FS-STATUS-NORMAL value 00.
88 CL-FS-STATUS-EOF value 10.
88 CL-FS-STATUS-DUPLICATE-KEY value 22.
88 CL-FS-STATUS-NOT-FOUND value 23.
88 CL-FS-STATUS-OUT-OF-BOUNDS value 24.
88 CL-FS-STATUS-INVALID-KEY value 22, 23, 24.
88 CL-FS-STATUS-FATAL value 30, 34.
04 CL-FS-ERROR-NO pic 9(10).
04 filler redefines CL-FS-ERROR-NO.
06 CL-FS-VERB-ERROR pic 9(02).
88 CL-FS-OPEN-ERROR value 01.
88 CL-FS-READ-ERROR value 06.
06 CL-FS-MONITOR-ERROR pic 9(02).
88 CL-FS-LOOKUP-ERROR value 03.
06 filler pic 9(06).
04 CL-FS-ACTION-CODE usage index.
04 CL-FS-FILE-SPEC pic X(09).
04 CL-FS-BLOCK-NO usage index.
04 CL-FS-RECORD-NO usage index.
04 CL-FS-FILE-NAME pic X(30).
04 CL-FS-TABLE-POINTER usage index.
01 CL-FILE-NAME-PROMPT display-7
pic X(27)
value 'Listing file > '.
01 WSS-COPY-INDS DISPLAY-7.
*NOTE THAT THE FOLLOWING VALUES ARE MEANT TO INCLUDE ALL POSSIBLE
*COMBINATIONS OF TABS AND SPACES PRECEDING AND TRAILING THE 'COPY'
*COMMAND IN A LISTING. IND1 HAS LEADING AND TRAILING SPACE, IND2 HAS
*LEADING AND TRAILING TAB, IND3 HAS LEADING TAB AND TRAILING SPACE AND
*IND4 HAS LEADING SPACE AND TRAILING TAB.
02 WSS-COPY-IND1 PIC X(06) VALUE ' COPY '.
02 WSS-COPY-IND2 PIC X(06) VALUE ' COPY '.
02 WSS-COPY-IND3 PIC X(06) VALUE ' COPY '.
02 WSS-COPY-IND4 PIC X(06) VALUE ' COPY '.
01 FILE-LANGUAGE-FILE-CONTROL DISPLAY-6.
02 FILE-LANG-STAT PIC S9(01) COMP VALUE 0.
88 FILE-LANG-OPEN VALUE 1.
02 FILE-LANGUAGE-SEL-NAME PIC X(30).
02 FILE-LANGUAGE-FILE-ID.
04 FILE-LANGUAGE-FILE-NAME pic X(06).
04 FILE-LANGUAGE-FILE-EXT pic X(03).
02 FL-FILE-STATUS.
04 FL-FS-STATUS pic 9(02).
88 FL-FS-STATUS-NORMAL value 00.
88 FL-FS-STATUS-EOF value 10.
88 FL-FS-STATUS-DUPLICATE-KEY value 22.
88 FL-FS-STATUS-NOT-FOUND value 23.
88 FL-FS-STATUS-OUT-OF-BOUNDS value 24.
88 FL-FS-STATUS-INVALID-KEY value 22, 23, 24.
88 FL-FS-STATUS-FATAL value 30, 34.
04 FL-FS-ERROR-NO pic 9(10).
04 filler redefines FL-FS-ERROR-NO.
06 FL-FS-VERB-ERROR pic 9(02).
88 FL-FS-OPEN-ERROR value 01.
88 FL-FS-READ-ERROR value 06.
06 FL-FS-MONITOR-ERROR pic 9(02).
88 FL-FS-LOOKUP-ERROR value 03.
06 filler pic 9(06).
04 FL-FS-ACTION-CODE usage index.
04 FL-FS-FILE-SPEC pic X(09).
04 FL-FS-BLOCK-NO usage index.
04 FL-FS-RECORD-NO usage index.
04 FL-FS-FILE-NAME pic X(30).
04 FL-FS-TABLE-POINTER usage index.
01 WS-FILE-NAME PIC X(12).
01 FL-FILE-ID-PROMPT DISPLAY-7
PIC X(27)
VALUE 'File language (.FL) name > '.
*
01 FL-SELECT-NAME-PROMPT DISPLAY-7
PIC X(27)
VALUE 'Select name > '.
*
01 PROG-HEADING display-7
pic X(55)
value 'VAG001: File Language File Generator - Version 1'.
01 PROG-PROCESSING-FLAG pic S9(01) comp value 0.
88 CONTINUE-PROCESSING value 0.
88 PROG-PROCESSING-END value 9.
01 TERMINAL-INPUT-SW pic S9(01) comp.
88 TERMINAL-INPUT value 1.
01 TERMINAL-REPLY pic X(30).
01 ERROR-MESSAGE DISPLAY-7 PIC X(80).
01 VAR-VALUES.
02 YES-VALUE pic S9(01) comp value 1.
02 MID-VALUE PIC S9(01) COMP VALUE 1.
02 NO-VALUE pic S9(01) comp value 0.
02 BEG-VALUE PIC S9(01) COMP VALUE 0.
02 END-LN-VALUE PIC S9(01) COMP VALUE 2.
02 END-VALUE PIC S9(01) COMP VALUE 9.
*
01 SEARCH-STATUS-FLAG PIC 9(01) VALUE 0.
88 SS-SEARCH-SELECT-FILE VALUE 0.
88 SS-FOUND-SELECT-FILE VALUE 1.
88 SS-NO-SELECT-FILE VALUE 2.
88 SS-SEARCH-FILE-DESC VALUE 3.
88 SS-FOUND-FILE-DESC VALUE 4.
88 SS-FOUND-DATA-DESC VALUE 5.
88 SS-END-OF-DATA-DESC VALUE 6.
*
01 SEARCH-STATUS-VALUES.
05 SEARCH-SELECT-FILE PIC S9(01) COMP VALUE 0.
05 FOUND-SELECT-FILE PIC S9(01) COMP VALUE 1.
05 NO-SELECT-FILE PIC S9(01) COMP VALUE 2.
05 SEARCH-FILE-DESC PIC S9(01) COMP VALUE 3.
05 FOUND-FILE-DESC PIC S9(01) COMP VALUE 4.
05 FOUND-DATA-DESC PIC S9(01) COMP VALUE 5.
05 END-OF-DATA-DESC PIC S9(01) COMP VALUE 6.
*
01 TBL-IDX USAGE INDEX.
*
01 SELECT-TABLE.
*
*NOTE: 'FILE ID' IS LEVEL #1
*
05 FILLER PIC X(24) VALUE 'ACCESS 005DYNAMIC'.
05 FILLER PIC X(24) VALUE 'AREA 000'.
05 FILLER PIC X(24) VALUE 'AREAS 000'.
05 FILLER PIC X(24) VALUE 'ASSIGN 103'.
05 FILLER PIC X(24) VALUE 'CHECKPOINT 000'.
05 FILLER PIC X(24) VALUE 'DEFERRED 000'.
05 FILLER PIC X(24) VALUE 'DYNAMIC 000'.
05 FILLER PIC X(24) VALUE 'EVERY 000'.
05 FILLER PIC X(24) VALUE 'FILE-STATUS 000'.
05 FILLER PIC X(24) VALUE 'INDEXED 000'.
05 FILLER PIC X(24) VALUE 'IS 000'.
05 FILLER PIC X(24) VALUE 'KEY 000'.
05 FILLER PIC X(24) VALUE 'MODE 000'.
05 FILLER PIC X(24) VALUE 'ORGANIZATION 004INDEXED'.
05 FILLER PIC X(24) VALUE 'RANDOM 000'.
05 FILLER PIC X(24) VALUE 'RECORD 106'.
05 FILLER PIC X(24) VALUE 'RECORDING 107SIXBIT'.
05 FILLER PIC X(24) VALUE 'RECORDS 000'.
05 FILLER PIC X(24) VALUE 'RESERVE 000'.
05 FILLER PIC X(24) VALUE 'SELECT 102'.
05 FILLER PIC X(24) VALUE 'SEQUENTIAL 000'.
05 FILLER PIC X(24) VALUE 'TO 000'.
05 FILLER PIC X(24) VALUE 'WITH 000'.
*
01 SELECT-ARRAY REDEFINES
SELECT-TABLE.
05 SELECT-ENTRIES OCCURS 23 TIMES
INDEXED BY SEL-IDX
ASCENDING KEY SEL-WORD.
10 SEL-WORD PIC X(14).
10 SEL-TYPE PIC 9(01).
88 SEL-OPTIONAL VALUE 0.
88 SEL-KEY-WORD VALUE 1.
10 SEL-INDEX PIC 9(02).
10 SEL-DEFAULT PIC X(07).
*
01 FILE-TABLE.
05 FILLER PIC X(17) VALUE 'ARE 000'.
05 FILLER PIC X(17) VALUE 'BLOCK 108'.
05 FILLER PIC X(17) VALUE 'CHARACTERS 000'.
05 FILLER PIC X(17) VALUE 'CONTAINS 000'.
05 FILLER PIC X(17) VALUE 'DATA 000'.
05 FILLER PIC X(17) VALUE 'DATE-WRITTEN 000'.
05 FILLER PIC X(17) VALUE 'FD 000'.
05 FILLER PIC X(17) VALUE 'ID 000'.
05 FILLER PIC X(17) VALUE 'IDENTIFICATION000'.
05 FILLER PIC X(17) VALUE 'IS 000'.
05 FILLER PIC X(17) VALUE 'LABEL 000'.
05 FILLER PIC X(17) VALUE 'MODE 000'.
05 FILLER PIC X(17) VALUE 'OF 000'.
05 FILLER PIC X(17) VALUE 'RECORD 000'.
05 FILLER PIC X(17) VALUE 'RECORDING 107'.
05 FILLER PIC X(17) VALUE 'RECORDS 000'.
05 FILLER PIC X(17) VALUE 'TO 000'.
05 FILLER PIC X(17) VALUE 'USER-NUMBER 000'.
05 FILLER PIC X(17) VALUE 'VALUE 000'.
*
01 FILE-ARRAY REDEFINES
FILE-TABLE.
05 FILE-ENTRIES OCCURS 19 TIMES
INDEXED BY FIL-IDX
ASCENDING KEY FIL-WORD.
10 FIL-WORD PIC X(14).
10 FIL-TYPE PIC 9(01).
88 FIL-OPTIONAL VALUE 0.
88 FIL-KEY-WORD VALUE 1.
10 FIL-INDEX PIC 9(02).
*
01 DATA-TABLE.
*
*NOTE: 'LEVEL NUMBER' IS INDEX #1 -- IT'S NOT MISSING...
* 'FIELD ID ' IS INDEX #2
*
05 FILLER PIC X(26) VALUE 'ASCENDING 111'.
05 FILLER PIC X(26) VALUE 'BLANK 016ZERO'.
05 FILLER PIC X(26) VALUE 'BY 000'.
05 FILLER PIC X(26) VALUE 'COMP 005COMP'.
05 FILLER PIC X(26) VALUE 'COMP-1 005COMP-1'.
05 FILLER PIC X(26) VALUE 'COMP-3 005COMP-3'.
05 FILLER PIC X(26) VALUE 'COMPUTATIONAL 005COMP'.
05 FILLER PIC X(26) VALUE 'COMPUTATIONAL-1005COMP-1'.
05 FILLER PIC X(26) VALUE 'COMPUTATIONAL-3005COMP-3'.
05 FILLER PIC X(26) VALUE 'DEPENDING 110'.
05 FILLER PIC X(26) VALUE 'DESCENDING 112'.
05 FILLER PIC X(26) VALUE 'DISPLAY 005DISPLAY'.
05 FILLER PIC X(26) VALUE 'DISPLAY-6 005DISPLAY'.
05 FILLER PIC X(26) VALUE 'DISPLAY-7 005DISPLAY'.
05 FILLER PIC X(26) VALUE 'INDEX 005INDEX'.
05 FILLER PIC X(26) VALUE 'INDEXED 113'.
05 FILLER PIC X(26) VALUE 'IS 000'.
05 FILLER PIC X(26) VALUE 'JUST 115'.
05 FILLER PIC X(26) VALUE 'JUSTIFIED 115'.
05 FILLER PIC X(26) VALUE 'KEY 000'.
05 FILLER PIC X(26) VALUE 'OCCURS 108'.
05 FILLER PIC X(26) VALUE 'ON 000'.
05 FILLER PIC X(26) VALUE 'PIC 104'.
05 FILLER PIC X(26) VALUE 'PICTURE 104'.
05 FILLER PIC X(26) VALUE 'REDEFINES 103'.
05 FILLER PIC X(26) VALUE 'SEPARATE 007SEPARATE'.
05 FILLER PIC X(26) VALUE 'SIGN 106'.
05 FILLER PIC X(26) VALUE 'SYNC 114'.
05 FILLER PIC X(26) VALUE 'SYNCHRONIZED 114'.
05 FILLER PIC X(26) VALUE 'TIMES 000'.
05 FILLER PIC X(26) VALUE 'TO 109'.
05 FILLER PIC X(26) VALUE 'USAGE 105'.
05 FILLER PIC X(26) VALUE 'VALUE 117'.
05 FILLER PIC X(26) VALUE 'VALUES 117'.
05 FILLER PIC X(26) VALUE 'WHEN 000'.
*
01 DATA-ARRAY REDEFINES
DATA-TABLE.
05 DATA-ENTRIES OCCURS 35 TIMES
INDEXED BY DTA-IDX
ASCENDING KEY DTA-WORD.
10 DTA-WORD PIC X(15).
10 DTA-TYPE PIC 9(01).
88 DTA-OPTIONAL VALUE 0.
88 DTA-KEY-WORD VALUE 1.
10 DTA-INDEX PIC 9(02).
10 DTA-DEFAULT PIC X(08).
*
01 CL-KEY-WORD PIC X(30).
88 SELECT-KEY-WORD VALUE 'SELECT'.
88 DATA-KEY-WORD VALUE 'DATA'.
88 FILE-KEY-WORD VALUE 'FD'.
01 CL-KEY-TEST REDEFINES
CL-KEY-WORD.
05 CL-KEY-NUM-TEST PIC X(02).
05 FILLER PIC X(28).
*
01 LINE-POINTERS.
02 SOURCE-CODE-PTR pic S9(03) comp.
02 FILE-LANG-PTR pic S9(03) comp.
02 MAX-SOURCE-CODE-PTR pic S9(03) comp value 105.
01 WS-SPECIAL-CHARACTERS pic S9(10) comp value 3090.
01 filler redefines WS-SPECIAL-CHARACTERS display-7.
02 filler pic X(03).
02 WS-PAGE-EJECT pic X(01).
02 WS-TAB pic X(01).
*
01 TABLE-FOUND-SW PIC S9(01) COMP.
88 TABLE-NOT-FOUND VALUE 0.
88 TABLE-FOUND VALUE 1.
01 TALLY pic 9(10) COMP.
*
01 WSS-FIELD-COUNT USAGE INDEX.
*
01 WSS-FILE-INFO.
05 WSS-FILE-DATA PIC X(30)
OCCURS 17
INDEXED BY FL-INDEX.
01 WSS-FILE-ARR.
05 WSS-FILE-ARRAY PIC X(01)
OCCURS 30
INDEXED BY ARR-IDX.
*
01 WSS-SENTENCE-STAT-FL PIC S9(01) COMP.
88 WSS-BEG-SENTENCE VALUE 0.
88 WSS-MID-SENTENCE VALUE 1.
88 WSS-END-SEN-LINE VALUE 2, 9.
88 WSS-END-SENTENCE VALUE 9.
*
01 WSS-END-OF-LINE-SW PIC S9(01) COMP.
88 WSS-END-OF-LINE VALUE 1.
*
01 WSS-FILLER-TRANS.
05 FILLER PIC X(03) VALUE 'FIL'.
05 WSS-FILLER-IDX PIC 9(03) VALUE 0.
01 WSS-HELP-CHECK PIC X(30).
88 WSS-HELP VALUE 'HELP', 'Help', 'help', 'H', 'h', '?'.
01 COBOL-LISTING-SIXBIT PIC X(105).
PROCEDURE DIVISION.
*==================
DECLARATIVES.
*------------
D100-INPUT-ERROR SECTION. use after standard error procedure on COBOL-LISTING-FILE.
D110-INPUT-ERROR.
If CL-FS-OPEN-ERROR
SET COBOL-LISTING-STAT TO NO-VALUE
If CL-FS-LOOKUP-ERROR
display space
display '% File ['
COBOL-LISTING-FILE-NAME '.' COBOL-LISTING-FILE-EXT
'] not found.'
display space
set TERMINAL-INPUT-SW TO YES-VALUE
set CL-FS-ACTION-CODE TO 1
else
display space
display '? Fatal error on file ['
COBOL-LISTING-FILE-NAME '.' COBOL-LISTING-FILE-EXT
'].'
display ' (File Status / Error Number = '
CL-FS-STATUS ' / ' CL-FS-ERROR-NO ')'.
END DECLARATIVES.
*----------------
THE-PROGRAM SECTION.
0000-PROG-MAIN-LOGIC.
perform 0100-INITIALIZE.
PERFORM 0200-WHOLE-PROCESS
UNTIL NOT CONTINUE-PROCESSING.
PERFORM 0300-TERMINATE.
STOP RUN.
0100-INITIALIZE.
set COBOL-LISTING-END-SW,
PROG-PROCESSING-FLAG to 0.
display SPACE.
display PROG-HEADING.
DISPLAY SPACE.
0200-WHOLE-PROCESS.
SET TERMINAL-INPUT-SW TO YES-VALUE.
PERFORM 9300-COLLECT-TERMINAL
UNTIL NOT TERMINAL-INPUT.
IF CONTINUE-PROCESSING
SET TERMINAL-INPUT-SW TO YES-VALUE
SET SEARCH-STATUS-FLAG
COBOL-LISTING-END-SW TO 0
PERFORM 0210-FILE-LANG-PROCESS
UNTIL NOT CONTINUE-PROCESSING
SET PROG-PROCESSING-FLAG TO 0.
0210-FILE-LANG-PROCESS.
PERFORM 9000-OBTAIN-FILE-LANG-NAMES
UNTIL NOT TERMINAL-INPUT.
IF CONTINUE-PROCESSING
PERFORM 9315-OPEN-CL
SET WSS-SENTENCE-STAT-FL TO END-VALUE
perform 8000-READ-LISTING
perform 0800-PROCESS-LISTING
UNTIL NOT CONTINUE-PROCESSING
SET TERMINAL-INPUT-SW TO 1.
0300-TERMINATE.
IF COBOL-LISTING-OPEN
close COBOL-LISTING-FILE.
IF FILE-LANG-OPEN
CLOSE FILE-LANGUAGE-FILE.
*
0800-PROCESS-LISTING.
IF (NOT CLR-COMMENT-LINE)
AND COBOL-LISTING-RECORD NOT = SPACES
PERFORM 9100-UNSTRING-COBOL-LISTING
IF SS-SEARCH-SELECT-FILE
PERFORM 1000-SEARCH-SELECT
ELSE
IF SS-FOUND-SELECT-FILE
PERFORM 1100-FOUND-SELECT
ELSE
IF SS-SEARCH-FILE-DESC
PERFORM 1200-SEARCH-FILE
ELSE
IF SS-FOUND-FILE-DESC
PERFORM 1300-FOUND-FILE
ELSE
IF SS-FOUND-DATA-DESC
PERFORM 1400-FOUND-DATA
ELSE
NEXT SENTENCE
ELSE
SET WSS-END-OF-LINE-SW TO YES-VALUE.
IF SS-NO-SELECT-FILE
OR SS-END-OF-DATA-DESC
OR COBOL-LISTING-END
SET TERMINAL-INPUT-SW TO YES-VALUE
PERFORM 9000-OBTAIN-FILE-LANG-NAMES
UNTIL NOT TERMINAL-INPUT
IF CONTINUE-PROCESSING
SET COBOL-LISTING-END-SW
SEARCH-STATUS-FLAG TO 0
PERFORM 9315-OPEN-CL
PERFORM 8000-READ-LISTING
ELSE
SET COBOL-LISTING-END-SW TO YES-VALUE
ELSE
IF WSS-END-OF-LINE
SET WSS-END-OF-LINE-SW TO NO-VALUE
PERFORM 8000-READ-LISTING.
*
1000-SEARCH-SELECT.
IF DATA-KEY-WORD
SET SEARCH-STATUS-FLAG TO NO-SELECT-FILE
DISPLAY SPACE
MOVE SPACES TO ERROR-MESSAGE
STRING 'Select name ' DELIMITED BY SIZE
FILE-LANGUAGE-SEL-NAME DELIMITED BY SPACE
' not found.' DELIMITED BY SIZE
INTO ERROR-MESSAGE
DISPLAY ERROR-MESSAGE
DISPLAY SPACE
ELSE
IF NOT SELECT-KEY-WORD
SET WSS-END-OF-LINE-SW TO YES-VALUE
ELSE
PERFORM 9100-UNSTRING-COBOL-LISTING
IF CL-KEY-WORD NOT = FILE-LANGUAGE-SEL-NAME
SET WSS-END-OF-LINE-SW TO YES-VALUE
ELSE
SET SEARCH-STATUS-FLAG TO FOUND-SELECT-FILE
DISPLAY SPACE
DISPLAY 'Creating ' WS-FILE-NAME
DISPLAY SPACE
IF FILE-LANG-OPEN
CLOSE FILE-LANGUAGE-FILE
SET FILE-LANG-STAT TO NO-VALUE
OPEN OUTPUT FILE-LANGUAGE-FILE
SET FILE-LANG-STAT TO YES-VALUE
IF WSS-END-OF-LINE
STRING 'IMAGE,SELECT,' DELIMITED BY SIZE
COBOL-LISTING-RECORD DELIMITED BY SIZE
INTO FILE-LANGUAGE-RECORD
PERFORM 8100-WRITE-FILE-LANGUAGE-FILE
ELSE
NEXT SENTENCE
ELSE
OPEN OUTPUT FILE-LANGUAGE-FILE
SET FILE-LANG-STAT TO YES-VALUE
IF WSS-END-OF-LINE
STRING 'IMAGE,SELECT,' DELIMITED BY SIZE
COBOL-LISTING-RECORD DELIMITED BY SIZE
INTO FILE-LANGUAGE-RECORD
PERFORM 8100-WRITE-FILE-LANGUAGE-FILE.
IF SS-FOUND-SELECT-FILE
IF TALLY > 0
SET WSS-END-OF-LINE-SW TO YES-VALUE
MOVE 2 TO FL-INDEX
MOVE FILE-LANGUAGE-SEL-NAME TO WSS-FILE-DATA(FL-INDEX)
PERFORM 9900-DELIMIT
MOVE 0 TO FL-INDEX
SET SEARCH-STATUS-FLAG TO SEARCH-FILE-DESC.
*
1100-FOUND-SELECT.
SET TABLE-FOUND-SW TO NO-VALUE.
SEARCH ALL SELECT-ENTRIES
WHEN CL-KEY-WORD = SEL-WORD(SEL-IDX)
SET TABLE-FOUND-SW TO YES-VALUE.
IF TABLE-FOUND
IF SEL-OPTIONAL(SEL-IDX)
IF SEL-INDEX(SEL-IDX) > 0
MOVE SEL-INDEX(SEL-IDX) TO FL-INDEX
MOVE SEL-DEFAULT(SEL-IDX) TO WSS-FILE-DATA(FL-INDEX)
PERFORM 9900-DELIMIT
MOVE 0 TO FL-INDEX
ELSE
NEXT SENTENCE
ELSE
IF SEL-KEY-WORD(SEL-IDX)
MOVE SEL-INDEX(SEL-IDX) TO FL-INDEX
ELSE
NEXT SENTENCE
ELSE
IF FL-INDEX > 0
MOVE CL-KEY-WORD TO WSS-FILE-DATA(FL-INDEX)
PERFORM 9900-DELIMIT
MOVE 0 TO FL-INDEX.
IF TALLY > 0
SET WSS-END-OF-LINE-SW TO YES-VALUE
MOVE 2 TO FL-INDEX
MOVE FILE-LANGUAGE-SEL-NAME TO WSS-FILE-DATA(FL-INDEX)
PERFORM 9900-DELIMIT
MOVE 0 TO FL-INDEX
SET SEARCH-STATUS-FLAG TO SEARCH-FILE-DESC.
IF WSS-END-OF-LINE
STRING 'IMAGE,SELECT,' DELIMITED BY SIZE
COBOL-LISTING-RECORD DELIMITED BY SIZE
INTO FILE-LANGUAGE-RECORD
PERFORM 8100-WRITE-FILE-LANGUAGE-FILE.
*
1200-SEARCH-FILE.
IF NOT FILE-KEY-WORD
SET WSS-END-OF-LINE-SW TO YES-VALUE
ELSE
PERFORM 9100-UNSTRING-COBOL-LISTING
IF CL-KEY-WORD NOT = FILE-LANGUAGE-SEL-NAME
SET WSS-END-OF-LINE-SW TO YES-VALUE
ELSE
SET SEARCH-STATUS-FLAG TO FOUND-FILE-DESC
IF WSS-END-OF-LINE
STRING 'IMAGE,FD,' DELIMITED BY SIZE
COBOL-LISTING-RECORD DELIMITED BY SIZE
INTO FILE-LANGUAGE-RECORD
PERFORM 8100-WRITE-FILE-LANGUAGE-FILE.
IF SS-FOUND-FILE-DESC
AND TALLY > 0
SET WSS-END-OF-LINE-SW TO YES-VALUE
SET FILE-LANG-PTR TO 1
STRING 'MODULE,' DELIMITED BY SIZE
FILE-LANGUAGE-FILE-NAME DELIMITED BY SPACE
INTO FILE-LANGUAGE-RECORD
WITH POINTER FILE-LANG-PTR
SET FL-INDEX TO 1
IF WSS-FILE-DATA(7) = SPACES
MOVE 'SIXBIT@' TO WSS-FILE-DATA(7)
PERFORM 9200-FINAL-OUTPUT-FORMAT
7 TIMES
MOVE 0 TO FL-INDEX
PERFORM 8100-WRITE-FILE-LANGUAGE-FILE
MOVE SPACES TO WSS-FILE-INFO
SET SEARCH-STATUS-FLAG TO FOUND-DATA-DESC
ELSE
PERFORM 9200-FINAL-OUTPUT-FORMAT
7 TIMES
MOVE 0 TO FL-INDEX
PERFORM 8100-WRITE-FILE-LANGUAGE-FILE
MOVE SPACES TO WSS-FILE-INFO
SET SEARCH-STATUS-FLAG TO FOUND-DATA-DESC.
*
1300-FOUND-FILE.
SET TABLE-FOUND-SW TO NO-VALUE.
SEARCH ALL FILE-ENTRIES
WHEN CL-KEY-WORD = FIL-WORD(FIL-IDX)
SET TABLE-FOUND-SW TO YES-VALUE.
IF TABLE-FOUND
IF FIL-OPTIONAL(FIL-IDX)
NEXT SENTENCE
ELSE
IF FIL-KEY-WORD(FIL-IDX)
MOVE FIL-INDEX(FIL-IDX) TO FL-INDEX
ELSE
NEXT SENTENCE
ELSE
IF FL-INDEX > 0
MOVE CL-KEY-WORD TO WSS-FILE-DATA(FL-INDEX)
PERFORM 9900-DELIMIT
MOVE 0 TO FL-INDEX.
IF TALLY > 0
SET WSS-END-OF-LINE-SW TO YES-VALUE
SET FILE-LANG-PTR TO 1
STRING 'MODULE,' DELIMITED BY SIZE
FILE-LANGUAGE-FILE-NAME DELIMITED BY SPACE
INTO FILE-LANGUAGE-RECORD
WITH POINTER FILE-LANG-PTR
SET FL-INDEX TO 1
IF WSS-FILE-DATA(7) = SPACES
MOVE 'SIXBIT@' TO WSS-FILE-DATA(7)
PERFORM 9200-FINAL-OUTPUT-FORMAT
7 TIMES
MOVE 0 TO FL-INDEX
PERFORM 8100-WRITE-FILE-LANGUAGE-FILE
MOVE SPACES TO WSS-FILE-INFO
SET SEARCH-STATUS-FLAG TO FOUND-DATA-DESC
ELSE
PERFORM 9200-FINAL-OUTPUT-FORMAT
7 TIMES
MOVE 0 TO FL-INDEX
PERFORM 8100-WRITE-FILE-LANGUAGE-FILE
MOVE SPACES TO WSS-FILE-INFO
SET SEARCH-STATUS-FLAG TO FOUND-DATA-DESC.
IF WSS-END-OF-LINE
STRING 'IMAGE,FD,' DELIMITED BY SIZE
COBOL-LISTING-RECORD DELIMITED BY SIZE
INTO FILE-LANGUAGE-RECORD
PERFORM 8100-WRITE-FILE-LANGUAGE-FILE.
*
1400-FOUND-DATA.
SET WSS-END-OF-LINE-SW TO NO-VALUE.
*& IF TALLY > 0
IF WSS-END-SENTENCE
SET WSS-SENTENCE-STAT-FL TO BEG-VALUE
ELSE
SET WSS-SENTENCE-STAT-FL TO MID-VALUE.
IF CL-KEY-WORD = 'FD' OR 'WORKING-STORAGE' OR 'PROCEDURE'
SET SEARCH-STATUS-FLAG TO END-OF-DATA-DESC
ELSE
PERFORM 1410-REST-OF-DATA-LINE
UNTIL WSS-END-SEN-LINE.
*
1410-REST-OF-DATA-LINE.
SET TABLE-FOUND-SW TO NO-VALUE.
IF CL-KEY-NUM-TEST NUMERIC AND WSS-BEG-SENTENCE
MOVE 1 TO FL-INDEX
SET WSS-SENTENCE-STAT-FL TO MID-VALUE
MOVE CL-KEY-WORD TO WSS-FILE-DATA(FL-INDEX)
PERFORM 9900-DELIMIT
SET FL-INDEX TO 2
ELSE
IF FL-INDEX = 2
PERFORM 1415-FILLER-TEST
MOVE CL-KEY-WORD TO WSS-FILE-DATA(FL-INDEX)
PERFORM 9900-DELIMIT
MOVE 0 TO FL-INDEX
ELSE
SEARCH ALL DATA-ENTRIES
WHEN CL-KEY-WORD = DTA-WORD(DTA-IDX)
SET TABLE-FOUND-SW TO YES-VALUE.
IF WSS-END-OF-LINE
SET WSS-SENTENCE-STAT-FL TO END-LN-VALUE.
IF TABLE-FOUND
IF DTA-OPTIONAL(DTA-IDX)
IF DTA-INDEX(DTA-IDX) > 0
MOVE DTA-INDEX(DTA-IDX) TO FL-INDEX
MOVE DTA-DEFAULT(DTA-IDX) TO WSS-FILE-DATA(FL-INDEX)
PERFORM 9900-DELIMIT
MOVE 0 TO FL-INDEX
ELSE
NEXT SENTENCE
ELSE
IF DTA-KEY-WORD(DTA-IDX)
MOVE DTA-INDEX(DTA-IDX) TO FL-INDEX
ELSE
NEXT SENTENCE
ELSE
IF FL-INDEX > 0 AND NOT = 2
MOVE CL-KEY-WORD TO WSS-FILE-DATA(FL-INDEX)
PERFORM 9900-DELIMIT
MOVE 0 TO FL-INDEX.
IF TALLY > 0
SET WSS-SENTENCE-STAT-FL TO END-VALUE
SET WSS-END-OF-LINE-SW TO YES-VALUE
SET FILE-LANG-PTR TO 1
STRING 'FIELD' DELIMITED BY SIZE
INTO FILE-LANGUAGE-RECORD
WITH POINTER FILE-LANG-PTR
SET FL-INDEX TO 0
PERFORM 9200-FINAL-OUTPUT-FORMAT
17 TIMES
MOVE 0 TO FL-INDEX
STRING ',' DELIMITED BY SIZE
COBOL-LISTING-RECORD DELIMITED BY SIZE
INTO FILE-LANGUAGE-RECORD
WITH POINTER FILE-LANG-PTR
PERFORM 8100-WRITE-FILE-LANGUAGE-FILE
MOVE SPACES TO WSS-FILE-INFO
ELSE
IF WSS-END-OF-LINE
SET WSS-SENTENCE-STAT-FL TO END-LN-VALUE
STRING 'FIELD,00,NONE,NONE,NONE,NONE,NONE,NONE,'
DELIMITED BY SIZE
'NONE,NONE,NONE,NONE,NONE,NONE,NONE,NONE,NONE,NONE,'
DELIMITED BY SIZE
COBOL-LISTING-RECORD DELIMITED BY SIZE
INTO FILE-LANGUAGE-RECORD
PERFORM 8100-WRITE-FILE-LANGUAGE-FILE
ELSE
IF NOT WSS-END-OF-LINE
PERFORM 9100-UNSTRING-COBOL-LISTING.
1415-FILLER-TEST.
IF CL-KEY-WORD = 'FILLER'
SET WSS-FILLER-IDX UP BY 1
MOVE WSS-FILLER-TRANS TO CL-KEY-WORD
MOVE COBOL-LISTING-RECORD TO COBOL-LISTING-SIXBIT
INSPECT COBOL-LISTING-SIXBIT
REPLACING 'FILLER' BY WSS-FILLER-TRANS
MOVE COBOL-LISTING-SIXBIT TO COBOL-LISTING-RECORD.
8000-READ-LISTING.
PERFORM 8010-DO-READ.
IF CLR-NUM-TEST NOT NUMERIC
PERFORM 8010-DO-READ
2 TIMES.
IF NOT COBOL-LISTING-END
MOVE CLR-BODY TO COBOL-LISTING-RECORD
PERFORM 8020-REMOVE-ANY-COPY-STMT.
PERFORM 8030-SPACE-TAB-CHECK.
*
8010-DO-READ.
SET COBOL-LISTING-PTR TO 1.
IF NOT COBOL-LISTING-END
READ COBOL-LISTING-FILE
AT END
SET COBOL-LISTING-END-SW TO YES-VALUE.
IF COBOL-LISTING-END
SET PROG-PROCESSING-FLAG TO 9.
*
8020-REMOVE-ANY-COPY-STMT.
INSPECT COBOL-LISTING-RECORD REPLACING
ALL ',' BY SPACES
ALL WSS-COPY-IND1 BY SPACES
ALL WSS-COPY-IND2 BY SPACES
ALL WSS-COPY-IND3 BY SPACES
ALL WSS-COPY-IND4 BY SPACES
CHARACTERS BY SPACES AFTER INITIAL WSS-COPY-IND1
CHARACTERS BY SPACES AFTER INITIAL WSS-COPY-IND2
CHARACTERS BY SPACES AFTER INITIAL WSS-COPY-IND3
CHARACTERS BY SPACES AFTER INITIAL WSS-COPY-IND3.
*
8030-SPACE-TAB-CHECK.
PERFORM 9110-EAT-SPACES
UNTIL COBOL-LISTING-PTR > MAX-SOURCE-CODE-PTR
OR (COBOL-LISTING-WORK(COBOL-LISTING-PTR) NOT = SPACE
AND COBOL-LISTING-WORK(COBOL-LISTING-PTR) NOT = WS-TAB).
IF COBOL-LISTING-PTR > MAX-SOURCE-CODE-PTR
MOVE SPACES TO COBOL-LISTING-RECORD.
*
8100-WRITE-FILE-LANGUAGE-FILE.
PERFORM 9999-DO-NOTHING
VARYING VAR-IDX FROM 375 BY -1
UNTIL FILE-LANGUAGE-VAR(VAR-IDX) NOT = SPACE
OR VAR-IDX = 1.
WRITE FILE-LANGUAGE-2 BEFORE ADVANCING 1.
MOVE SPACES TO FILE-LANGUAGE-RECORD.
*
9000-OBTAIN-FILE-LANG-NAMES.
PERFORM 9010-OBTAIN-SHORT-NAME
UNTIL NOT TERMINAL-INPUT.
IF CONTINUE-PROCESSING
SET TERMINAL-INPUT-SW TO YES-VALUE
PERFORM 9020-OBTAIN-SEL-NAME
UNTIL NOT TERMINAL-INPUT
IF NOT CONTINUE-PROCESSING
SET PROG-PROCESSING-FLAG TO 0
SET TERMINAL-INPUT-SW TO YES-VALUE.
9010-OBTAIN-SHORT-NAME.
DISPLAY FL-FILE-ID-PROMPT WITH NO ADVANCING.
ACCEPT TERMINAL-REPLY.
IF TERMINAL-REPLY = SPACE
SET TERMINAL-INPUT-SW TO NO-VALUE
SET PROG-PROCESSING-FLAG TO 9
ELSE
MOVE TERMINAL-REPLY TO WSS-HELP-CHECK
IF WSS-HELP
DISPLAY ' Enter the short name of the file to be converted'
DISPLAY ' Default extension is .FL'
ELSE
SET TERMINAL-INPUT-SW TO NO-VALUE
UNSTRING TERMINAL-REPLY
DELIMITED BY '.'
INTO FILE-LANGUAGE-FILE-NAME,
FILE-LANGUAGE-FILE-EXT
IF FILE-LANGUAGE-FILE-EXT = SPACE
MOVE 'FL' TO FILE-LANGUAGE-FILE-EXT.
9020-OBTAIN-SEL-NAME.
DISPLAY FL-SELECT-NAME-PROMPT
WITH NO ADVANCING
ACCEPT TERMINAL-REPLY
IF TERMINAL-REPLY = SPACE
SET TERMINAL-INPUT-SW TO NO-VALUE
SET PROG-PROCESSING-FLAG TO 9
ELSE
MOVE TERMINAL-REPLY TO WSS-HELP-CHECK
IF WSS-HELP
DISPLAY ' Enter the name of the file to be converted exactly as it appears in the'
DISPLAY ' SELECT statement of the .LST file'
ELSE
SET TERMINAL-INPUT-SW TO NO-VALUE
UNSTRING TERMINAL-REPLY
DELIMITED BY ALL SPACES
INTO FILE-LANGUAGE-SEL-NAME
MOVE SPACE TO WS-FILE-NAME
STRING FILE-LANGUAGE-FILE-NAME DELIMITED BY SPACE
'.' DELIMITED BY SIZE
FILE-LANGUAGE-FILE-EXT DELIMITED BY SPACE
INTO WS-FILE-NAME.
*
9100-UNSTRING-COBOL-LISTING.
MOVE SPACES TO CL-KEY-WORD.
PERFORM 9110-EAT-SPACES
UNTIL COBOL-LISTING-PTR > MAX-SOURCE-CODE-PTR
OR (COBOL-LISTING-WORK(COBOL-LISTING-PTR) NOT = SPACE
AND COBOL-LISTING-WORK(COBOL-LISTING-PTR) NOT = WS-TAB).
IF COBOL-LISTING-PTR > MAX-SOURCE-CODE-PTR
NEXT SENTENCE
ELSE
IF FL-INDEX NOT = 17
UNSTRING COBOL-LISTING-RECORD
DELIMITED BY ALL WS-TAB OR ALL SPACE
OR ';' OR ','
INTO CL-KEY-WORD
WITH POINTER COBOL-LISTING-PTR
ELSE
UNSTRING COBOL-LISTING-RECORD
INTO CL-KEY-WORD
WITH POINTER COBOL-LISTING-PTR.
SET TALLY TO 0.
INSPECT CL-KEY-WORD TALLYING TALLY FOR ALL '.'
REPLACING ALL '.' BY SPACES.
IF COBOL-LISTING-PTR > MAX-SOURCE-CODE-PTR
SET WSS-END-OF-LINE-SW TO YES-VALUE.
9110-EAT-SPACES.
SET COBOL-LISTING-PTR UP BY 1.
*
9200-FINAL-OUTPUT-FORMAT.
STRING ',' DELIMITED BY SIZE
INTO FILE-LANGUAGE-RECORD
WITH POINTER FILE-LANG-PTR.
SET FL-INDEX UP BY 1.
IF WSS-FILE-DATA(FL-INDEX) = SPACES
IF FL-INDEX = 1
MOVE '00@' TO WSS-FILE-DATA(FL-INDEX)
ELSE
MOVE 'NONE@' TO WSS-FILE-DATA(FL-INDEX).
STRING WSS-FILE-DATA(FL-INDEX) DELIMITED BY '@'
INTO FILE-LANGUAGE-RECORD
WITH POINTER FILE-LANG-PTR.
9300-COLLECT-TERMINAL.
display CL-FILE-NAME-PROMPT
WITH NO ADVANCING.
accept TERMINAL-REPLY.
If TERMINAL-REPLY = SPACE
set PROG-PROCESSING-FLAG to 9
set COBOL-LISTING-END-SW to YES-VALUE
set TERMINAL-INPUT-SW to NO-VALUE
else
MOVE TERMINAL-REPLY TO WSS-HELP-CHECK
IF WSS-HELP
DISPLAY ' Enter the name of the COBOL listing to be read - default extension .LST'
ELSE
perform 9310-OBTAIN-CL.
9310-OBTAIN-CL.
unstring TERMINAL-REPLY
delimited by '.'
into COBOL-LISTING-FILE-ID,
COBOL-LISTING-FILE-EXT.
If COBOL-LISTING-FILE-EXT = SPACE
move 'LST' to COBOL-LISTING-FILE-EXT.
set TERMINAL-INPUT-SW to NO-VALUE.
PERFORM 9315-OPEN-CL.
9315-OPEN-CL.
IF COBOL-LISTING-OPEN
CLOSE COBOL-LISTING-FILE
SET COBOL-LISTING-STAT TO NO-VALUE.
SET COBOL-LISTING-STAT TO YES-VALUE.
open INPUT COBOL-LISTING-FILE.
*
9900-DELIMIT.
MOVE WSS-FILE-DATA(FL-INDEX) TO WSS-FILE-ARR.
PERFORM 9999-DO-NOTHING
VARYING ARR-IDX FROM 30 BY -1
UNTIL WSS-FILE-ARRAY(ARR-IDX) NOT = SPACE
OR ARR-IDX = 1.
IF ARR-IDX < 30
SET ARR-IDX UP BY 1
MOVE '@' TO WSS-FILE-ARRAY(ARR-IDX).
MOVE WSS-FILE-ARR TO WSS-FILE-DATA(FL-INDEX).
9999-DO-NOTHING.