Trailing-Edge
-
PDP-10 Archives
-
LCG_Integration_Tools_Clearinghouse_T20_v7_30Apr86
-
tools/isacon/vag002.cbl
There are 5 other files named vag002.cbl in the archive. Click here to see a list.
IDENTIFICATION DIVISION.
*=======================
Program-Id. VAG002.
Author. KATHY MCKENDRY
Date-Written. October 12, 1984.
Date-Compiled.
Installation. PAPER FREE SYSTEMS INC.
*-------------
*Program Title:
*-------------
*
* System: ISACON DEC to VAX Conversion System
* Module: VAG002 Application Module (Program) Generator
*
*
*-------------------
*Program Description:
*-------------------
*
* VAG002 is a macro expander for a finite state machine.
* It uses the output of VAG001 to build an internal symbol table,
* and then, using a skeleton file as a driver, produces much
* of the COBOL source code.
*
*----------------------------
*Program Modification History:
*----------------------------
* --Date-- Who What
*
*----------------------------------------------------------------------
ENVIRONMENT DIVISION.
*====================
CONFIGURATION SECTION.
*---------------------
SOURCE-COMPUTER. DECSYSTEM-10.
OBJECT-COMPUTER. DECSYSTEM-10.
INPUT-OUTPUT SECTION.
*--------------------
FILE-CONTROL.
select FILE-LANGUAGE-FILE
assign to DSK
file status is FL-FS-STATUS
FL-FS-ERROR-NO
FL-FS-ACTION-CODE
FL-FS-FILE-SPEC
FL-FS-BLOCK-NO
FL-FS-RECORD-NO
FL-FS-FILE-NAME
FL-FS-TABLE-POINTER
recording mode ASCII.
Select SKELETON-FILE
assign to DSK
file status is SKL-FS-STATUS
SKL-FS-ERROR-NO
SKL-FS-ACTION-CODE
SKL-FS-FILE-SPEC
SKL-FS-BLOCK-NO
SKL-FS-RECORD-NO
SKL-FS-FILE-NAME
SKL-FS-TABLE-POINTER
recording mode ASCII.
select RECURS-FILE
assign to DSK
recording mode ASCII.
select SOURCE-CODE-FILE
assign to DSK
recording mode ASCII.
DATA DIVISION.
*=============
FILE SECTION.
*------------
fd FILE-LANGUAGE-FILE
value of id FILE-LANGUAGE-FILE-ID.
01 FILE-LANGUAGE-RECORD display-7.
02 FLR-NUM-TEST pic X(005).
02 filler pic X(001).
02 FLR-BODY pic X(369).
01 FILE-LANGUAGE-WORK-REC display-7.
02 FILE-LANGUAGE-WORK pic X(001) occurs 375.
fd SKELETON-FILE
value of id SKELETON-FILE-ID.
01 SKELETON-RECORD display-7.
02 SKELETON-LINE-NUMBER.
04 FIRST-SKELETON-CHAR pic X(001).
88 COMMAND-LINE value '/'.
04 filler pic X(004).
02 filler pic X(001).
02 SKELETON-BODY pic X(099).
*
fd SOURCE-CODE-FILE
value of id SOURCE-CODE-FILE-ID.
01 SOURCE-CODE-RECORD display-7.
02 SOURCE-CODE-CHAR pic X(001) occurs 105.
01 SOURCE-CODE-2 DISPLAY-7.
02 SOURCE-CODE-VAR PIC X(001) OCCURS 1 TO 105
DEPENDING ON VAR-IDX.
fd RECURS-FILE
value of id 'RECURSTMP'.
01 RECURS-RECORD pic X(105) display-7.
WORKING-STORAGE SECTION.
*=======================
*=============================================================
* S Y M B O L T A B L E
*=============================================================
*-------------------
* Module Information
*-------------------
01 MODULE-DATA display-7.
02 FILNM pic X(10).
02 MODTL pic X(40).
02 ACCES pic X(10).
02 filler pic X(05).
02 ASIGN PIC X(30).
02 ORG PIC X(10).
02 MKEY PIC X(30).
02 MMODE PIC X(10).
02 MBLCK PIC X(04).
02 MODNM PIC X(10).
02 RECNM PIC X(30).
*------------------
* Image Information
*---------------
01 IMAGE-INFO DISPLAY-7.
02 IMAGE-DATA OCCURS 15 TIMES
indexed by IMAGE-DATA-INDEX.
04 filler pic X(02).
04 ITYPE pic X(10).
04 NOITM pic X(04).
04 filler pic X(01).
04 IDATA PIC X(105).
*------------------
* Field Information
*------------------
01 FIELD-INFO.
02 FIELD-DATA occurs 300 times
indexed by FIELD-DATA-INDEX.
04 FLDIX PIC 9(03).
04 FIELD pic X(30).
04 PICT pic X(40).
04 DPICT pic X(20).
04 PPICT pic X(20).
04 FLDNO pic X(02).
04 filler pic X(02).
04 REDEF PIC X(30).
04 ISRDF PIC X(03).
04 USIGE PIC X(15).
04 FSIGN PIC X(10).
04 FSEP PIC X(10).
04 FOCUR PIC X(04).
04 FTO PIC X(04).
04 OLVL1 PIC X(04).
04 OLVL2 PIC X(04).
04 OLVL3 PIC X(04).
04 DEPND PIC X(30).
04 ASCND PIC X(30).
04 DSCND PIC X(30).
04 INDXD PIC X(30).
04 INDX1 PIC X(30).
04 INDX2 PIC X(30).
04 INDX3 PIC X(30).
04 FSYNC PIC X(05).
04 FJUST PIC X(05).
04 FBLNK PIC X(04).
04 FVALU PIC X(30).
04 FDLMT PIC X(01).
04 FDATA PIC X(105).
04 FDTA2 PIC X(105).
*========== E N D O F S Y M B O L T A B L E==========
*=============================================================
* S Y M B O L T A B L E W S
*=============================================================
01 FL-MAX-INDICES.
02 IMAGE-DATA-MAX-INDEX usage index.
02 FIELD-DATA-MAX-INDEX usage index.
01 FL-KEY-WORD pic X(12).
88 MODULE-KEY-WORD value 'MODULE'.
88 IMAGE-KEY-WORD value 'IMAGE'.
88 FIELD-KEY-WORD value 'FIELD'.
01 FL-TOKEN display-7
pic X(105).
01 filler redefines FL-TOKEN display-7.
02 FL-TOKEN-1 pic X(01).
02 filler pic X(104).
01 filler redefines FL-TOKEN display-7.
02 FL-TOKEN-2 pic X(02).
02 filler pic X(103).
01 filler redefines FL-TOKEN display-7.
02 FL-TOKEN-3 pic X(03).
02 filler pic X(102).
01 filler redefines FL-TOKEN display-7.
02 FL-TOKEN-4 pic X(04).
02 filler pic X(101).
01 filler redefines FL-TOKEN display-7.
02 FL-TOKEN-5.
04 filler pic X(03).
04 FL-TOKEN-5-2 pic X(02).
02 filler pic X(100).
01 filler redefines FL-TOKEN display-7.
02 FL-TOKEN-10 pic X(10).
02 filler pic X(95).
01 filler redefines FL-TOKEN display-7.
02 FL-TOKEN-15 pic X(15).
02 filler pic X(90).
01 filler redefines FL-TOKEN display-7.
02 FL-TOKEN-20 PIC X(20).
02 filler pic X(85).
01 filler redefines FL-TOKEN display-7.
02 FL-TOKEN-30 pic X(30).
02 filler pic X(75).
01 filler redefines FL-TOKEN display-7.
02 FL-TOKEN-40 pic X(40).
02 filler pic X(65).
01 FL-TOKEN-ARRAY redefines FL-TOKEN display-7
occurs 105
indexed by FL-TOKEN-INDEX
pic X(01).
01 FL-TOKEN-30-6 PIC X(30).
01 FL-POINTERS.
02 FILE-LANGUAGE-PTR pic S9(03) comp.
01 FL-STATE-SWITCHES.
02 FILE-LANGUAGE-END-SW pic S9(01) comp.
88 FILE-LANGUAGE-END value 1.
01 FILE-LANGUAGE-FILE-CONTROL DISPLAY-6.
02 FILE-LANGUAGE-FILE-ID.
04 FILE-LANGUAGE-FILE-NAME pic X(06).
04 FILLER REDEFINES
FILE-LANGUAGE-FILE-NAME.
06 FILE-LANG-FIRST-5 PIC X(05).
06 FILLER PIC X(01).
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 FL-FILE-SWITCHES.
02 FL-FILE-NUMBERED-FLAG pic 9(01).
88 FL-FILE-NUMBERED-NOT-SET value 0.
88 FL-FILE-NUMBERED-NO value 1.
88 FL-FILE-NUMBERED-YES value 2.
01 FL-FILE-NAME-PROMPT display-7
pic X(21)
value 'File language file > '.
01 SKELETON-FILE-CONTROL DISPLAY-6.
02 SKL-FILE-STATUS.
04 SKL-FS-STATUS pic 9(02).
88 SKL-FS-STATUS-NORMAL value 00.
88 SKL-FS-STATUS-EOF value 10.
88 SKL-FS-STATUS-DUPLICATE-KEY value 22.
88 SKL-FS-STATUS-NOT-FOUND value 23.
88 SKL-FS-STATUS-OUT-OF-BOUNDS value 24.
88 SKL-FS-STATUS-INVALID-KEY value 22, 23, 24.
88 SKL-FS-STATUS-FATAL value 30, 34.
04 SKL-FS-ERROR-NO pic 9(10).
04 filler redefines SKL-FS-ERROR-NO.
06 SKL-FS-VERB-ERROR pic 9(02).
88 SKL-FS-OPEN-ERROR value 01.
88 SKL-FS-READ-ERROR value 06.
06 SKL-FS-MONITOR-ERROR pic 9(02).
88 SKL-FS-LOOKUP-ERROR value 03.
06 filler pic 9(06).
04 SKL-FS-ACTION-CODE usage index.
04 SKL-FS-FILE-SPEC pic X(09).
04 SKL-FS-BLOCK-NO usage index.
04 SKL-FS-RECORD-NO usage index.
04 SKL-FS-FILE-NAME pic X(30).
04 SKL-FS-TABLE-POINTER usage index.
01 SKL-FILE-NAME-PROMPT DISPLAY-7
PIC X(21)
VALUE 'Skeleton > '.
01 TEMP-INDEX usage index.
01 WSS-REDEF-FIELD PIC X(30).
01 WSS-REDEF-LEVEL PIC 9(02).
01 WSS-LEVELS.
05 WSS-FOCUR-LEVEL PIC 9(02) VALUE 99.
05 WSS-LEVEL1 PIC 9(02) VALUE 99.
05 WSS-LEVEL2 PIC 9(02) VALUE 99.
05 WSS-LEVEL3 PIC 9(02) VALUE 99.
01 WSS-USAGE-FIELDS.
05 WSS-USAGE-LEVEL PIC 9(02).
05 WSS-USAGE PIC X(15).
01 WSS-LEVEL-INDEXES.
05 WSS-LEVEL1-IDX PIC X(04).
05 WSS-LEVEL2-IDX PIC X(04).
05 WSS-LEVEL3-IDX PIC X(04).
05 WSS-LEVEL1-NAME PIC X(30).
05 WSS-LEVEL2-NAME PIC X(30).
05 WSS-LEVEL3-NAME PIC X(30).
01 VAR-IDX USAGE INDEX.
*=============================================================
* M A C R O E X P A N S I O N W S
*=============================================================
*----------------
* Command Data
*----------------
01 MACRO-COMMAND pic X(12).
88 NO-COMMAND value SPACE.
88 EACH-FIELD-COMMAND value 'EACH-FIELD'.
88 EACH-IMAGE-COMMAND value 'EACH-IMAGE'.
88 ELSE-COMMAND value 'ELSE'.
88 END-COMMAND value 'END'.
88 END-FIELD-COMMAND value 'END-FIELD'.
88 END-IF-COMMAND value 'END-IF'.
88 END-IMAGE-COMMAND value 'END-IMAGE'.
88 END-NOTE-COMMAND value 'END-NOTE'.
88 IF-COMMAND value 'IF'.
88 IF-NOT-COMMAND value 'IF-NOT'.
88 NOTE-COMMAND value 'NOTE'.
88 PAGE-COMMAND value 'PAGE'.
88 SET-COMMAND value 'SET'.
88 START-COMMAND value 'START'.
*
* n.b. The following table must be kept in alphabetical
* order since it is searched binarily.
01 MACRO-COMMAND-TABLE.
02 filler pic X(12) value 'EACH-FIELD'.
02 filler pic X(12) value 'EACH-IMAGE'.
02 filler pic X(12) value 'ELSE'.
02 filler pic X(12) value 'END'.
02 filler pic X(12) value 'END-FIELD'.
02 filler pic X(12) value 'END-IF'.
02 filler pic X(12) value 'END-IMAGE'.
02 filler pic X(12) value 'END-NOTE'.
02 filler pic X(12) value 'IF'.
02 filler pic X(12) value 'IF-NOT'.
02 filler pic X(12) value 'NOTE'.
02 filler pic X(12) value 'PAGE'.
02 filler pic X(12) value 'SET'.
02 filler pic X(12) value 'START'.
01 MACRO-COMMAND-ARRAY redefines MACRO-COMMAND-TABLE.
02 MACRO-COMMAND-ENTRY pic X(12)
occurs 14 times
indexed by MACRO-COMMAND-INDEX
ascending key MACRO-COMMAND-ENTRY.
*
01 MACRO-COMMAND-INFO.
02 MACRO-COMMAND-STACK pic X(12)
occurs 30 times
indexed by MACRO-COMMAND-STACK-PTR.
*
01 LINE-POINTERS.
02 SKELETON-PTR pic S9(03) comp.
02 SOURCE-CODE-PTR pic S9(03) comp.
02 MAX-SOURCE-CODE-PTR pic S9(03) comp value 105.
02 LAST-SOURCE-PTR pic S9(03) comp.
02 LAST-COL-NO pic S9(03) comp.
02 CURR-COL-NO pic S9(03) comp.
02 NEXT-COL-NO pic S9(03) comp.
02 NEXT-TAB-NO pic S9(03) comp.
02 FILL-COUNT pic S9(02) comp.
02 ERROR-LINE-PTR pic S9(03) comp.
02 SYMBOL-WORK-PTR pic S9(03) comp.
*
01 SOURCE-CODE-WORK display-7
pic X(105).
01 SOURCE-CODE-ARRAY redefines SOURCE-CODE-WORK display-7
occurs 105
indexed by SOURCE-CODE-INDEX
pic X(01).
*
01 COMMAND-SPECIAL-CHAR display-7.
02 CURRENT-DELIMITER pic X(01).
02 BEGIN-DELIMITER pic X(01) value '{'.
02 END-DELIMITER pic X(01) value '}'.
02 filler pic X(02).
*
01 COMMAND-STATE-SWITCHES.
02 COMMAND-VALID-SW pic S9(01) comp.
88 COMMAND-VALID value 1.
02 SKELETON-FILE-END-SW pic S9(01) comp.
88 COMMAND-STATE-END value 1.
*
01 ERROR-HANDLING display-7.
02 ERROR-LINE pic X(105).
02 ERROR-NUMBER pic S9(10) comp.
01 filler display-7.
02 TEMP-SUBSTITUTE-NAME pic X(06).
02 filler pic X(04).
*
01 filler display-7.
02 ASCII-SUBSTITUTE-NAME pic X(06).
02 filler pic X(04).
*
01 SUBSTITUTE-NAME display-6.
88 FILNM-NAME value 'FILNM'.
88 MODTL-NAME value 'MODTL'.
88 ACCES-NAME value 'ACCES'.
88 ASIGN-NAME VALUE 'ASIGN'.
88 ORG-NAME VALUE 'ORG'.
88 MKEY-NAME VALUE 'MKEY'.
88 MMODE-NAME VALUE 'MMODE'.
88 MBLCK-NAME VALUE 'MBLCK'.
88 MODNM-NAME VALUE 'MODNM'.
88 RECNM-NAME VALUE 'RECNM'.
88 ITYPE-NAME value 'ITYPE'.
88 NOITM-NAME value 'NOITM'.
88 IDATA-NAME VALUE 'IDATA'.
88 FLDIX-NAME VALUE 'FLDIX'.
88 FIELD-NAME value 'FIELD'.
88 PICT-NAME value 'PICT'.
88 DPICT-NAME value 'DPICT'.
88 PPICT-NAME value 'PPICT'.
88 FLDNO-NAME value 'FLDNO'.
88 REDEF-NAME VALUE 'REDEF'.
88 ISRDF-NAME VALUE 'ISRDF'.
88 USIGE-NAME VALUE 'USIGE'.
88 FSIGN-NAME VALUE 'FSIGN'.
88 FSEP-NAME VALUE 'FSEP'.
88 FOCUR-NAME VALUE 'FOCUR'.
88 FTO-NAME VALUE 'FTO'.
88 OLVL1-NAME VALUE 'OLVL1'.
88 OLVL2-NAME VALUE 'OLVL2'.
88 OLVL3-NAME VALUE 'OLVL3'.
88 DEPND-NAME VALUE 'DEPND'.
88 ASCND-NAME VALUE 'ASCND'.
88 DSCND-NAME VALUE 'DSCND'.
88 INDXD-NAME VALUE 'INDXD'.
88 INDX1-NAME VALUE 'INDX1'.
88 INDX2-NAME VALUE 'INDX2'.
88 INDX3-NAME VALUE 'INDX3'.
88 FSYNC-NAME VALUE 'FSYNC'.
88 FJUST-NAME VALUE 'FJUST'.
88 FBLNK-NAME VALUE 'FBLNK'.
88 FVALU-NAME VALUE 'FVALU'.
88 FDLMT-NAME VALUE 'FDLMT'.
88 FDATA-NAME VALUE 'FDATA'.
88 FDTA2-NAME VALUE 'FDTA2'.
02 filler pic X(01).
88 RESERVED-VARIABLE value '%'.
02 RESERVED-NAME.
88 DATE-VARIABLE value 'DATE'.
04 RESERVED-NAME-CHAR-1 pic X(01).
04 filler pic X(04).
01 SKELETON-FILE-ID.
02 SKELETON-FILE-NAME pic X(06).
02 FILLER REDEFINES
SKELETON-FILE-NAME.
04 SKELETON-FILE-FIRST PIC X(01).
04 FILLER PIC X(05).
02 SKELETON-FILE-EXT pic X(03).
01 SKL-FILE-SWITCHES.
02 SKL-FILE-NUMBERED-FLAG pic s9(01) comp.
88 SKL-FILE-NUMBERED-NOT-SET value 2.
88 SKL-FILE-NOT-NUMBERED value 0.
88 SKL-FILE-NUMBERED value 1.
01 SOURCE-CODE-FILE-ID.
02 SOURCE-CODE-FILE-NAME pic X(06).
02 SOURCE-CODE-FILE-EXT pic X(03).
01 WS-FILE-NAME DISPLAY-6
PIC X(12).
01 LINE-NUMBER pic S9(05) comp.
01 LINE-NUMBER-PRT pic ZZZZ9.
01 PAGE-NUMBER pic S9(05) comp.
01 SYMBOL-WORK display-7
pic X(105).
01 SYMBOL-WORK-ARRAY redefines SYMBOL-WORK display-7
occurs 105
pic X(01).
01 SIXBIT-SYMBOL-WORK display-6
pic X(105).
01 INPUT-FLAG pic S9(01) comp value 0.
88 SKELETON-FILE-READ value 0.
88 RECURS-FILE-READ value 1.
88 FIELD-FILE-READ value 2.
01 INPUT-FLAG-SAVE pic S9(01) comp.
01 SKL-STATUS PIC S9(01) COMP VALUE 0.
88 SKL-FILE-CLOSED VALUE 0.
88 SKL-FILE-OPEN VALUE 1.
01 SOURCE-FILE-STATUS PIC S9(01) COMP VALUE 0.
88 SOURCE-FILE-CLOSED VALUE 0.
88 SOURCE-FILE-OPEN VALUE 1.
01 RECURS-FILE-STATUS pic S9(01) comp value 0.
88 RECURS-FILE-CLOSED value 0.
88 RECURS-FILE-WRITE value 1.
88 RECURS-FILE-INPUT value 2.
01 FIELD-FILE-STATUS pic S9(01) comp value 0.
88 FIELD-FILE-CLOSED value 0.
88 FIELD-FILE-WRITE value 1.
88 FIELD-FILE-INPUT value 2.
01 CONDITION-VALUE pic S9(01) comp.
88 CONDITION-FALSE value 0.
88 CONDITION-TRUE value 1.
01 CONDITION-STACK occurs 25
indexed by CONDITION-INDEX
pic S9(01) comp.
01 CONDITION-WORK pic X(12).
01 CONDITION-TEMP pic X(12).
01 SET-NAME pic X(12).
88 IMAGE-SET-NAME value 'IMAGE' 'IMAGE-INDEX'.
01 filler display-7.
02 SET-VALUE pic X(02).
02 filler pic X(03).
01 FIELD-FILE-INFO DISPLAY-7.
02 FIELD-FILE-ARRAY OCCURS 300
indexed by FIELD-FILE-INDEX
pic X(105).
*=========================================================
* S C R A T C H P A D
*==========================================================
01 YES-NO-VALUES.
02 YES-VALUE pic S9(01) comp value 1.
02 NO-VALUE pic S9(01) comp value 0.
*
01 ERROR-TABLE display-7.
02 CURRENT-ERROR.
04 ERROR-LENGTH pic 9(02).
04 ERROR-TEXT pic X(38).
02 COMMAND-INTERP-ERROR pic X(40)
value '29 This is an unknown command. @'.
02 END-DELIMITER-ERROR pic X(40)
value '36 Beginning but no ending delimiter. @'.
02 SYMBOL-ERROR pic X(40)
value '22 Unrecognized symbol. @'.
02 END-COMMAND-ERROR pic X(40)
value '20 Early END command. @'.
02 DATA-TYPE-ERROR pic X(40)
value '33 Current data type is undefined. @'.
02 RESERVED-VARIABLE-ERROR pic X(40)
value '30 Undefined reserved variable. @'.
02 RECURS-FILE-ERROR pic X(40)
value '34 Image file end before END-IMAGE. @'.
02 FIELD-FILE-ERROR pic X(40)
value '34 Field file end before END-FIELD. @'.
02 END-IMAGE-ERROR pic X(40)
value '26 Early END-IMAGE command. @'.
02 END-FIELD-ERROR pic X(40)
value '26 Early END-FIELD command. @'.
02 IF-COMMAND-ERROR pic X(40)
value '21 IF statement error. @'.
02 IF-SYNC-ERROR pic X(40)
value '17 END-IF missing. @'.
01 PROG-HEADING display-7
pic X(55)
value 'VAG002: Application Module 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(10).
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 WS-TODAY display-6.
02 WS-DATE.
04 WS-DATE-YY pic X(02).
04 WS-DATE-MM pic X(02).
04 WS-DATE-DD pic X(02).
01 WS-TODAY-WORK display-7.
02 WS-DATE-WORK.
04 WS-DATE-MM-WORK pic X(02).
04 filler pic X(01) value '/'.
04 WS-DATE-DD-WORK pic X(02).
04 filler pic X(01) value '/'.
04 WS-DATE-YY-WORK pic X(02).
01 WS-SAVE-PTR pic S9(03) comp.
01 WS-INDEX pic S9(03) comp.
01 WS-NUMBER-6 pic 9(06).
01 filler redefines WS-NUMBER-6.
02 filler pic 9(03).
02 WS-NUMBER-3 pic 9(03).
01 filler redefines WS-NUMBER-6.
02 filler pic 9(04).
02 WS-NUMBER-2 pic 9(02).
01 TAB-WIDTH pic S9(01) comp value 8.
01 NO-WARNING-COMP display-6
pic S9(06).
01 NO-WARNING-6 redefines NO-WARNING-COMP.
02 filler pic X(01).
02 NO-WARNING-5.
04 filler pic X(01).
04 NO-WARNING-4.
06 filler pic X(01).
06 NO-WARNING-3.
08 filler pic X(01).
08 NO-WARNING-2.
10 filler pic X(01).
10 NO-WARNING-1
pic 9(01).
01 TALLY pic 9(10) COMP.
01 WSS-88-FIELDS.
05 WSS-88-INDEX USAGE INDEX.
05 WSS-88-TOTAL PIC 9(02).
01 WSS-HELP-CHECK PIC X(10).
88 WSS-HELP VALUE 'HELP', 'Help', 'help', 'H', 'h', '?'.
01 WSS-FIG-CONSTANTS.
05 WSS-SPACE-5 PIC X(05) VALUE '" "'.
05 WSS-SPACE-6 PIC X(06) VALUE '" "'.
05 WSS-ZERO-4 PIC 9(04) VALUE 0.
05 WSS-ZERO-5 PIC 9(05) VALUE 0.
05 WSS-ZERO-6 PIC 9(06) VALUE 0.
05 WSS-QUOTE-5 PIC X(05) VALUE '"'.
05 WSS-QUOTE-6 PIC X(06) VALUE '"'.
PROCEDURE DIVISION.
*==================
DECLARATIVES.
*------------
D100-INPUT-ERROR SECTION. use after standard error procedure on FILE-LANGUAGE-FILE.
D110-INPUT-ERROR.
If FL-FS-OPEN-ERROR
If FL-FS-LOOKUP-ERROR
display space
display '% File ['
FILE-LANGUAGE-FILE-NAME '.' FILE-LANGUAGE-FILE-EXT
'] not found.'
display space
set TERMINAL-INPUT-SW TO YES-VALUE
set FL-FS-ACTION-CODE TO 1
else
display space
display '? Fatal error on file ['
FILE-LANGUAGE-FILE-NAME '.' FILE-LANGUAGE-FILE-EXT
'].'
display ' (File Status / Error Number = '
FL-FS-STATUS ' / ' FL-FS-ERROR-NO ')'.
D200-INPUT-ERROR SECTION. use after standard error procedure on SKELETON-FILE.
D210-INPUT-ERROR.
If SKL-FS-OPEN-ERROR
SET SKL-STATUS TO NO-VALUE
If SKL-FS-LOOKUP-ERROR
display space
display '% File ['
SKELETON-FILE-NAME '.' SKELETON-FILE-EXT
'] not found.'
display space
set TERMINAL-INPUT-SW TO YES-VALUE
set SKL-FS-ACTION-CODE TO 1
else
display space
display '? Fatal error on file ['
SKELETON-FILE-NAME '.' SKELETON-FILE-EXT
'].'
display ' (File Status / Error Number = '
SKL-FS-STATUS ' / ' SKL-FS-ERROR-NO ')'.
END DECLARATIVES.
*----------------
THE-PROGRAM SECTION.
0000-PROG-MAIN-LOGIC.
perform 0100-INITIALIZE.
PERFORM 0200-PROCESS-ALL
UNTIL NOT CONTINUE-PROCESSING.
perform 0300-TERMINATE.
STOP RUN.
0100-INITIALIZE.
display SPACE.
display PROG-HEADING.
display SPACE.
accept WS-DATE from DATE.
move WS-DATE-YY to WS-DATE-YY-WORK.
move WS-DATE-MM to WS-DATE-MM-WORK.
move WS-DATE-DD to WS-DATE-DD-WORK.
0200-PROCESS-ALL.
SET SKELETON-FILE-END-SW,
FILE-LANGUAGE-END-SW,
PROG-PROCESSING-FLAG to 0.
set TERMINAL-INPUT-SW TO 1.
PERFORM 0210-COLLECT-TERMINAL
UNTIL NOT TERMINAL-INPUT.
If CONTINUE-PROCESSING
PERFORM 0220-INIT-PROCESS
PERFORM 1000-BUILD-SYMBOL-TABLE
UNTIL FILE-LANGUAGE-END
CLOSE FILE-LANGUAGE-FILE
perform 2000-CREATE-SOURCE-FILE
UNTIL COMMAND-STATE-END.
0210-COLLECT-TERMINAL.
display FL-FILE-NAME-PROMPT
WITH NO ADVANCING.
accept TERMINAL-REPLY.
If TERMINAL-REPLY = SPACE
set PROG-PROCESSING-FLAG to 9
set FILE-LANGUAGE-END-SW to YES-VALUE
set SKELETON-FILE-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 .FL file to be used to create the source code'
ELSE
perform 0215-OPEN-FL.
0215-OPEN-FL.
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.
set TERMINAL-INPUT-SW to NO-VALUE.
open INPUT FILE-LANGUAGE-FILE.
set FL-FILE-NUMBERED-FLAG to 0.
0220-INIT-PROCESS.
MOVE SPACE TO ERROR-LINE,
SUBSTITUTE-NAME
MODULE-DATA
IMAGE-INFO
FIELD-INFO.
set COMMAND-VALID-SW,
ERROR-NUMBER,
MACRO-COMMAND-STACK-PTR,
IMAGE-DATA-INDEX,
FIELD-DATA-INDEX TO 0.
SET SKELETON-PTR,
SOURCE-CODE-PTR,
ERROR-LINE-PTR TO 1.
0300-TERMINATE.
IF SKL-FILE-OPEN
close SKELETON-FILE.
IF SOURCE-FILE-OPEN
CLOSE SOURCE-CODE-FILE.
*============================================================
* S C R E E N L A N G U A G E S C A N
*=============================================================
1000-BUILD-SYMBOL-TABLE.
perform 8000-READ-FL.
If not FILE-LANGUAGE-END
perform 1100-TEST-SYMBOL.
1100-TEST-SYMBOL.
move SPACE to FL-KEY-WORD.
perform 1199-EAT-SPACES
until FILE-LANGUAGE-PTR > MAX-SOURCE-CODE-PTR
or (FILE-LANGUAGE-WORK(FILE-LANGUAGE-PTR) not= SPACE
and FILE-LANGUAGE-WORK(FILE-LANGUAGE-PTR) not= WS-TAB).
unstring FILE-LANGUAGE-RECORD
DELIMITED BY ','
into FL-KEY-WORD
with pointer FILE-LANGUAGE-PTR.
If FIELD-KEY-WORD
perform 1110-FIELD-SYMBOLS
else If IMAGE-KEY-WORD
perform 1120-IMAGE-SYMBOLS
else If MODULE-KEY-WORD
perform 1130-MODULE-SYMBOLS.
1110-FIELD-SYMBOLS.
set FIELD-DATA-INDEX up by 1.
set FIELD-DATA-MAX-INDEX up by 1.
move FIELD-DATA-INDEX to WS-NUMBER-6.
MOVE WS-NUMBER-3 TO FLDIX (FIELD-DATA-INDEX).
PERFORM 1199-UNSTRING-TOKEN.
MOVE FL-TOKEN-2 TO FLDNO(FIELD-DATA-INDEX).
perform 1199-UNSTRING-TOKEN.
move FL-TOKEN-30 to FIELD(FIELD-DATA-INDEX).
IF FLDNO(FIELD-DATA-INDEX) = '01'
MOVE FIELD(FIELD-DATA-INDEX) TO RECNM.
PERFORM 1199-UNSTRING-TOKEN.
MOVE FL-TOKEN-30 TO REDEF(FIELD-DATA-INDEX).
IF FL-TOKEN-4 NOT = 'NONE'
MOVE REDEF(FIELD-DATA-INDEX) TO WSS-REDEF-FIELD
MOVE FLDNO(FIELD-DATA-INDEX) TO WSS-REDEF-LEVEL
MOVE FIELD-DATA-INDEX TO TEMP-INDEX
SET FIELD-DATA-INDEX TO 1
SEARCH FIELD-DATA VARYING FIELD-DATA-INDEX
AT END MOVE TEMP-INDEX TO FIELD-DATA-INDEX
WHEN FIELD(FIELD-DATA-INDEX) = WSS-REDEF-FIELD
MOVE 'YES' TO ISRDF(FIELD-DATA-INDEX)
MOVE TEMP-INDEX TO FIELD-DATA-INDEX.
IF ISRDF(FIELD-DATA-INDEX) NOT = 'YES'
MOVE 'NO' TO ISRDF(FIELD-DATA-INDEX).
perform 1199-UNSTRING-TOKEN.
move FL-TOKEN-40 to PICT(FIELD-DATA-INDEX).
PERFORM 1199-UNSTRING-TOKEN.
MOVE FL-TOKEN-15 TO USIGE(FIELD-DATA-INDEX).
PERFORM 1199-UNSTRING-TOKEN.
MOVE FL-TOKEN-10 TO FSIGN(FIELD-DATA-INDEX).
PERFORM 1199-UNSTRING-TOKEN.
MOVE FL-TOKEN-10 TO FSEP(FIELD-DATA-INDEX).
PERFORM 1199-UNSTRING-TOKEN.
MOVE FL-TOKEN-4 TO FOCUR(FIELD-DATA-INDEX).
PERFORM 1199-UNSTRING-TOKEN.
MOVE FL-TOKEN-4 TO FTO(FIELD-DATA-INDEX).
PERFORM 1199-UNSTRING-TOKEN.
MOVE FL-TOKEN-30 TO DEPND(FIELD-DATA-INDEX).
PERFORM 1199-UNSTRING-TOKEN.
MOVE FL-TOKEN-30 TO ASCND(FIELD-DATA-INDEX).
PERFORM 1199-UNSTRING-TOKEN.
MOVE FL-TOKEN-30 TO DSCND(FIELD-DATA-INDEX).
PERFORM 1199-UNSTRING-TOKEN.
MOVE FL-TOKEN-30 TO INDXD(FIELD-DATA-INDEX).
PERFORM 1199-UNSTRING-TOKEN.
MOVE FL-TOKEN-5 TO FSYNC(FIELD-DATA-INDEX).
PERFORM 1199-UNSTRING-TOKEN.
MOVE FL-TOKEN-5 TO FJUST(FIELD-DATA-INDEX).
PERFORM 1199-UNSTRING-TOKEN.
MOVE FL-TOKEN-4 TO FBLNK(FIELD-DATA-INDEX).
PERFORM 1199-UNSTRING-TOKEN.
MOVE FL-TOKEN-30 TO FL-TOKEN-30-6.
INSPECT FL-TOKEN-30-6
REPLACING 'SPACES' BY WSS-SPACE-6
'SPACE' BY WSS-SPACE-5
'ZEROES' BY WSS-ZERO-6
'ZEROS' BY WSS-ZERO-5
'ZERO' BY WSS-ZERO-4
'QUOTES' BY WSS-QUOTE-6
'QUOTE' BY WSS-QUOTE-5.
MOVE FL-TOKEN-30-6 TO FVALU(FIELD-DATA-INDEX).
IF FL-TOKEN-1 = "'"
OR FL-TOKEN-1 = '"'
MOVE FL-TOKEN-1 TO FDLMT(FIELD-DATA-INDEX)
ELSE
MOVE 'N' TO FDLMT(FIELD-DATA-INDEX).
PERFORM 1199-UNSTRING-TOKEN.
MOVE FL-TOKEN TO FDATA(FIELD-DATA-INDEX).
IF USIGE(FIELD-DATA-INDEX) = 'DISPLAY@'
INSPECT FL-TOKEN
REPLACING WS-TAB BY SPACE
INSPECT FL-TOKEN
REPLACING ' DISPLAY-6.' BY '. '
' DISPLAY-6 ' BY SPACES
' DISPLAY-7.' BY '. '
' DISPLAY-7 ' BY SPACES
ELSE IF USIGE(FIELD-DATA-INDEX) = 'COMP@'
INSPECT FL-TOKEN
REPLACING WS-TAB BY SPACE
INSPECT FL-TOKEN
REPLACING ' COMPUTATIONAL.' BY '. '
' COMPUTATIONAL ' BY SPACES
' COMP.' BY '. '
' COMP ' BY SPACES
ELSE IF USIGE(FIELD-DATA-INDEX) = 'COMP-1@'
INSPECT FL-TOKEN
REPLACING WS-TAB BY SPACE
INSPECT FL-TOKEN
REPLACING ' COMPUTATIONAL-1.' BY '. '
' COMPUTATIONAL-1 ' BY SPACES
' COMP-1.' BY '. '
' COMP-1 ' BY SPACES
ELSE IF USIGE(FIELD-DATA-INDEX) = 'COMP-3@'
INSPECT FL-TOKEN
REPLACING WS-TAB BY SPACE
INSPECT FL-TOKEN
REPLACING ' COMPUTATIONAL-3.' BY '. '
' COMPUTATIONAL-3 ' BY SPACES
' COMP-3.' BY '. '
' COMP-3 ' BY SPACES.
IF FL-TOKEN = FDATA(FIELD-DATA-INDEX)
MOVE 'NONE@' TO FDTA2(FIELD-DATA-INDEX)
ELSE
MOVE FL-TOKEN TO FDTA2(FIELD-DATA-INDEX).
IF FOCUR(FIELD-DATA-INDEX) NOT = 'NONE'
MOVE FLDNO(FIELD-DATA-INDEX) TO WSS-FOCUR-LEVEL
IF WSS-FOCUR-LEVEL NOT > WSS-LEVEL1
MOVE SPACES TO WSS-LEVEL-INDEXES
MOVE 99 TO WSS-LEVEL2
WSS-LEVEL3
MOVE WSS-FOCUR-LEVEL TO WSS-LEVEL1
MOVE FOCUR(FIELD-DATA-INDEX) TO WSS-LEVEL1-IDX
MOVE INDXD(FIELD-DATA-INDEX) TO WSS-LEVEL1-NAME
ELSE IF WSS-FOCUR-LEVEL NOT > WSS-LEVEL2
MOVE SPACES TO WSS-LEVEL3-IDX
WSS-LEVEL3-NAME
MOVE 99 TO WSS-LEVEL3
MOVE WSS-FOCUR-LEVEL TO WSS-LEVEL2
MOVE FOCUR(FIELD-DATA-INDEX) TO WSS-LEVEL2-IDX
MOVE INDXD(FIELD-DATA-INDEX) TO WSS-LEVEL2-NAME
ELSE IF WSS-FOCUR-LEVEL NOT > WSS-LEVEL3
MOVE WSS-FOCUR-LEVEL TO WSS-LEVEL3
MOVE FOCUR(FIELD-DATA-INDEX) TO WSS-LEVEL3-IDX
MOVE INDXD(FIELD-DATA-INDEX) TO WSS-LEVEL3-NAME.
* FOR ELEMENTARY ITEMS WITH NO PICTURE CLAUSE (USAGE ONLY) MOVE 'YES'
* TO PICTURE FIELD...
IF FIELD-DATA-INDEX > 1
IF PICT(FIELD-DATA-INDEX - 1) = 'NONE@'
AND USIGE(FIELD-DATA-INDEX - 1) NOT = 'NONE@'
AND FLDNO(FIELD-DATA-INDEX) NOT = '00'
AND FLDNO(FIELD-DATA-INDEX) NOT > FLDNO(FIELD-DATA-INDEX - 1)
MOVE 'YES' TO PICT(FIELD-DATA-INDEX - 1).
IF WSS-REDEF-FIELD NOT = SPACES
IF WSS-REDEF-FIELD = REDEF(FIELD-DATA-INDEX)
NEXT SENTENCE
ELSE
IF FLDNO(FIELD-DATA-INDEX) > WSS-REDEF-LEVEL
MOVE WSS-REDEF-FIELD TO REDEF(FIELD-DATA-INDEX)
ELSE
MOVE SPACES TO WSS-REDEF-FIELD
MOVE 0 TO WSS-REDEF-LEVEL.
MOVE 'NONE' TO OLVL1(FIELD-DATA-INDEX)
OLVL2(FIELD-DATA-INDEX)
OLVL3(FIELD-DATA-INDEX)
INDX1(FIELD-DATA-INDEX)
INDX2(FIELD-DATA-INDEX)
INDX3(FIELD-DATA-INDEX).
IF WSS-LEVEL1 < FLDNO(FIELD-DATA-INDEX)
OR (WSS-LEVEL1 = FLDNO(FIELD-DATA-INDEX)
AND FOCUR(FIELD-DATA-INDEX) NOT = 'NONE')
IF PICT(FIELD-DATA-INDEX) NOT = 'NONE@'
MOVE WSS-LEVEL1-IDX TO OLVL1(FIELD-DATA-INDEX)
MOVE WSS-LEVEL1-NAME TO INDX1(FIELD-DATA-INDEX)
IF WSS-LEVEL2 < FLDNO(FIELD-DATA-INDEX)
OR (WSS-LEVEL2 = FLDNO(FIELD-DATA-INDEX)
AND FOCUR(FIELD-DATA-INDEX) NOT = 'NONE')
MOVE WSS-LEVEL2-IDX TO OLVL2(FIELD-DATA-INDEX)
MOVE WSS-LEVEL2-NAME TO INDX2(FIELD-DATA-INDEX)
IF WSS-LEVEL3 < FLDNO(FIELD-DATA-INDEX)
OR (WSS-LEVEL3 = FLDNO(FIELD-DATA-INDEX)
AND FOCUR(FIELD-DATA-INDEX) NOT = 'NONE')
MOVE WSS-LEVEL3-IDX TO OLVL3(FIELD-DATA-INDEX)
MOVE WSS-LEVEL3-NAME TO INDX3(FIELD-DATA-INDEX)
ELSE IF WSS-LEVEL3 = FLDNO(FIELD-DATA-INDEX)
AND FOCUR(FIELD-DATA-INDEX) = 'NONE'
MOVE SPACES TO WSS-LEVEL3-IDX
WSS-LEVEL3-NAME
MOVE 99 TO WSS-LEVEL3
ELSE
NEXT SENTENCE
ELSE IF WSS-LEVEL2 = FLDNO(FIELD-DATA-INDEX)
AND FOCUR(FIELD-DATA-INDEX) = 'NONE'
MOVE SPACES TO WSS-LEVEL2-IDX
WSS-LEVEL2-NAME
WSS-LEVEL3-IDX
WSS-LEVEL3-NAME
MOVE 99 TO WSS-LEVEL2
WSS-LEVEL3
ELSE
NEXT SENTENCE
ELSE
NEXT SENTENCE
ELSE IF FLDNO(FIELD-DATA-INDEX) = '00'
NEXT SENTENCE
ELSE
MOVE 99999999 TO WSS-LEVELS
MOVE SPACES TO WSS-LEVEL-INDEXES.
IF PICT(FIELD-DATA-INDEX) = 'NONE@'
MOVE FLDNO(FIELD-DATA-INDEX) TO WSS-USAGE-LEVEL
IF USIGE(FIELD-DATA-INDEX) = 'NONE@'
MOVE 'DISPLAY@' TO WSS-USAGE
ELSE
MOVE USIGE(FIELD-DATA-INDEX) TO WSS-USAGE
ELSE IF FLDNO(FIELD-DATA-INDEX) > WSS-USAGE-LEVEL
AND USIGE(FIELD-DATA-INDEX) = 'NONE@'
MOVE WSS-USAGE TO USIGE(FIELD-DATA-INDEX)
ELSE IF USIGE(FIELD-DATA-INDEX) = 'NONE@'
MOVE 'DISPLAY@' TO USIGE(FIELD-DATA-INDEX).
IF FLDNO(FIELD-DATA-INDEX) = '88'
IF WSS-88-TOTAL = 0
MOVE FIELD-DATA-INDEX TO WSS-88-INDEX
SUBTRACT 1 FROM WSS-88-INDEX
SET WSS-88-TOTAL UP BY 1
ELSE
SET WSS-88-TOTAL UP BY 1
ELSE
IF WSS-88-TOTAL > 0
MOVE SPACES TO FVALU(WSS-88-INDEX)
STRING WSS-88-TOTAL DELIMITED BY SIZE
'@' DELIMITED BY SIZE
INTO FVALU(WSS-88-INDEX)
MOVE 0 TO WSS-88-TOTAL
WSS-88-INDEX.
IF FIELD-DATA-INDEX < FIELD-DATA-MAX-INDEX
SET FIELD-DATA-INDEX UP BY 1.
1120-IMAGE-SYMBOLS.
set IMAGE-DATA-INDEX up by 1.
set FIELD-DATA-INDEX to 0.
set FIELD-DATA-MAX-INDEX to 0.
perform 1199-UNSTRING-TOKEN.
move FL-TOKEN-10 to ITYPE(IMAGE-DATA-INDEX).
PERFORM 1199-UNSTRING-TOKEN.
MOVE FL-TOKEN TO IDATA(IMAGE-DATA-INDEX).
1130-MODULE-SYMBOLS.
perform 1199-UNSTRING-TOKEN.
move FL-TOKEN-10 to FILNM.
perform 1199-UNSTRING-TOKEN.
move FL-TOKEN-40 to MODTL.
PERFORM 1199-UNSTRING-TOKEN.
MOVE FL-TOKEN-30 TO ASIGN.
PERFORM 1199-UNSTRING-TOKEN.
MOVE FL-TOKEN-10 TO ORG.
PERFORM 1199-UNSTRING-TOKEN.
MOVE FL-TOKEN-10 TO ACCES.
PERFORM 1199-UNSTRING-TOKEN.
MOVE FL-TOKEN-30 TO MKEY.
PERFORM 1199-UNSTRING-TOKEN.
MOVE FL-TOKEN-10 TO MMODE.
PERFORM 1199-UNSTRING-TOKEN.
MOVE FL-TOKEN-4 TO MBLCK.
1199-UNSTRING-TOKEN.
IF FILE-LANGUAGE-PTR > 375
perform 8000-READ-FL
perform 1199-EAT-SPACES
until FILE-LANGUAGE-PTR > MAX-SOURCE-CODE-PTR
or (FILE-LANGUAGE-WORK(FILE-LANGUAGE-PTR) not= SPACE
and FILE-LANGUAGE-WORK(FILE-LANGUAGE-PTR) not= WS-TAB).
If FILE-LANGUAGE-PTR < 375
IF FILE-LANGUAGE-WORK(FILE-LANGUAGE-PTR) = '<'
set FILE-LANGUAGE-PTR up by 1
unstring FILE-LANGUAGE-RECORD
delimited by '>,' or '>'
into FL-TOKEN
with pointer FILE-LANGUAGE-PTR
else
unstring FILE-LANGUAGE-RECORD
delimited by ','
into FL-TOKEN
with pointer FILE-LANGUAGE-PTR.
perform 9900-DO-NOTHING
varying FL-TOKEN-INDEX from 105 by -1
until FL-TOKEN-ARRAY(FL-TOKEN-INDEX) not= SPACE
or FL-TOKEN-INDEX = 1.
IF FL-TOKEN-INDEX < 105
set FL-TOKEN-INDEX up by 1
move '@' to FL-TOKEN-ARRAY (FL-TOKEN-INDEX).
1199-EAT-SPACES.
Set FILE-LANGUAGE-PTR up by 1.
2000-CREATE-SOURCE-FILE.
SET TERMINAL-INPUT-SW TO YES-VALUE.
IF SKL-FILE-OPEN
SET SKL-STATUS TO 0
CLOSE SKELETON-FILE.
perform 2100-COLLECT-SKELETON
UNTIL NOT TERMINAL-INPUT.
IF SOURCE-FILE-OPEN
SET SOURCE-FILE-STATUS TO 0
CLOSE SOURCE-CODE-FILE.
IF CONTINUE-PROCESSING
PERFORM 2200-OPEN-CBL-FILE
MOVE SPACES TO MACRO-COMMAND-INFO
MACRO-COMMAND
FIELD-FILE-INFO
MOVE 0 TO RECURS-FILE-STATUS
FIELD-FILE-STATUS
INPUT-FLAG
perform 3000-COMMAND-STATE-INIT
perform 4000-SOURCE-GENERATION
until COMMAND-STATE-END
IF CONTINUE-PROCESSING
SET SKELETON-FILE-END-SW TO 0
ELSE
NEXT SENTENCE
ELSE
SET PROG-PROCESSING-FLAG TO 0.
2100-COLLECT-SKELETON.
display SKL-FILE-NAME-PROMPT
WITH NO ADVANCING.
Accept TERMINAL-REPLY.
If TERMINAL-REPLY = SPACE
set PROG-PROCESSING-FLAG to 9
set SKELETON-FILE-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 .SKL file to be used to create the source file'
DISPLAY ' Choices are:'
DISPLAY ' UNLOAD - Convert DEC ISAM file to SEQ file'
DISPLAY ' LOADIT - Convert SEQ file to VAX IDX file'
DISPLAY ' CDDICT - Create Common Data Dictionary DDL'
ELSE
perform 2110-OPEN-SKL.
2110-OPEN-SKL.
unstring TERMINAL-REPLY
delimited by '.'
into SKELETON-FILE-ID,
SKELETON-FILE-EXT.
If SKELETON-FILE-EXT = SPACE
move 'SKL' to SKELETON-FILE-EXT.
SET TERMINAL-INPUT-SW TO NO-VALUE.
IF SKL-FILE-OPEN
CLOSE SKELETON-FILE
OPEN INPUT SKELETON-FILE
ELSE
SET SKL-STATUS TO YES-VALUE
open INPUT SKELETON-FILE.
2200-OPEN-CBL-FILE.
MOVE SPACES TO SOURCE-CODE-FILE-NAME.
STRING FILE-LANG-FIRST-5 DELIMITED BY SPACE
SKELETON-FILE-FIRST DELIMITED BY SIZE
INTO SOURCE-CODE-FILE-NAME.
STRING SOURCE-CODE-FILE-NAME DELIMITED BY SIZE
'@' DELIMITED BY SIZE
INTO MODNM.
move 'CBL' to SOURCE-CODE-FILE-EXT.
SET SOURCE-FILE-STATUS TO YES-VALUE.
open OUTPUT SOURCE-CODE-FILE.
MOVE SPACES TO WS-FILE-NAME.
string SOURCE-CODE-FILE-NAME delimited by space
'.' delimited by size
SOURCE-CODE-FILE-EXT delimited by space
into WS-FILE-NAME.
display space.
display 'Creating ', WS-FILE-NAME.
display space.
*
3000-COMMAND-STATE-INIT.
set SKL-FILE-NUMBERED-FLAG to 2.
set PAGE-NUMBER to 1.
set LINE-NUMBER to 0.
set CONDITION-INDEX to 0.
set IMAGE-DATA-MAX-INDEX to IMAGE-DATA-INDEX.
set CONDITION-VALUE to 1.
If IMAGE-DATA-INDEX > 0
set IMAGE-DATA-INDEX to 1.
If FIELD-DATA-INDEX > 0
set FIELD-DATA-INDEX to 1.
perform 3100-NOITM
varying TEMP-INDEX from 1 by 1
until TEMP-INDEX > IMAGE-DATA-MAX-INDEX.
3100-NOITM.
move FIELD-DATA-MAX-INDEX to NO-WARNING-COMP.
move NO-WARNING-4 to NOITM (TEMP-INDEX).
*===========================================================
* S O U R C E C O D E G E N E R A T I O N
*============================================================
4000-SOURCE-GENERATION.
perform 8100-READ.
If not COMMAND-STATE-END
If COMMAND-LINE
perform 5000-COMMAND-INTERPRETATION
until END-COMMAND
move SPACE to MACRO-COMMAND
else
move SKELETON-RECORD to SOURCE-CODE-RECORD
perform 8600-WRITE-SOURCE-LINE.
5000-COMMAND-INTERPRETATION.
set SKELETON-PTR to 2.
unstring SKELETON-RECORD
delimited by ALL SPACE or ALL WS-TAB
into MACRO-COMMAND
with pointer SKELETON-PTR.
set COMMAND-VALID-SW to NO-VALUE.
search all MACRO-COMMAND-ENTRY
when MACRO-COMMAND = MACRO-COMMAND-ENTRY(MACRO-COMMAND-INDEX)
set COMMAND-VALID-SW to YES-VALUE.
If COMMAND-VALID
perform 5000-COMMAND-DISPATCH
perform 5000-COMMAND-DISPATCH
until NO-COMMAND or END-COMMAND
else
MOVE 'END' TO MACRO-COMMAND
set SOURCE-CODE-PTR to 2
move COMMAND-INTERP-ERROR to CURRENT-ERROR
perform 9999-RECORD-ERROR.
5000-COMMAND-DISPATCH.
If EACH-FIELD-COMMAND
perform 5110-EACH-FIELD-COMMAND
else If EACH-IMAGE-COMMAND
perform 5120-EACH-IMAGE-COMMAND
else If ELSE-COMMAND
perform 5130-ELSE-COMMAND
until not ELSE-COMMAND
else If END-COMMAND
perform 5140-END-COMMAND
else If END-FIELD-COMMAND
perform 5150-END-FIELD-COMMAND
until not END-FIELD-COMMAND.
If END-IF-COMMAND
perform 5210-END-IF-COMMAND
until not END-IF-COMMAND
else If END-IMAGE-COMMAND
perform 5220-END-IMAGE-COMMAND
until not END-IMAGE-COMMAND
else If IF-COMMAND
perform 5230-IF-COMMAND
until not IF-COMMAND
else If IF-NOT-COMMAND
perform 5240-IF-NOT-COMMAND
until not IF-NOT-COMMAND
else If SET-COMMAND
perform 5250-SET-COMMAND.
If START-COMMAND
perform 9300-START-COMMAND
until not START-COMMAND
else If PAGE-COMMAND
perform 5310-PAGE-COMMAND
else If NOTE-COMMAND
perform 9500-EAT
until END-NOTE-COMMAND or END-COMMAND
else If END-NOTE-COMMAND
perform 5320-END-NOTE-COMMAND.
*===========================================================
* M A C R O C O M M A N D R O U T I N E S
*============================================================
*-------------------
* Each-Field Command
*-------------------
5110-EACH-FIELD-COMMAND.
If FIELD-FILE-CLOSED
set FIELD-FILE-INDEX to 0
set FIELD-FILE-STATUS to 1.
perform 9300-START-COMMAND
until not EACH-FIELD-COMMAND.
*-------------------
* Each-Image Command
*-------------------
5120-EACH-IMAGE-COMMAND.
If RECURS-FILE-CLOSED
open OUTPUT RECURS-FILE
set RECURS-FILE-STATUS to 1.
perform 9300-START-COMMAND
until not EACH-IMAGE-COMMAND.
*-------------
* Else Command
*-------------
5130-ELSE-COMMAND.
If CONDITION-STACK (CONDITION-INDEX) = 1
If CONDITION-FALSE
set CONDITION-VALUE to 1
perform 9400-POP-COMMAND
else
set CONDITION-VALUE to 0
perform 9500-EAT
perform 9500-EAT
until END-IF-COMMAND or IF-COMMAND or IF-NOT-COMMAND
or END-COMMAND
else
perform 9500-EAT
perform 9500-EAT
until END-IF-COMMAND or IF-COMMAND or IF-NOT-COMMAND
or END-COMMAND.
*------------
* End Command
*------------
5140-END-COMMAND.
perform 9400-POP-COMMAND.
If not START-COMMAND
set SOURCE-CODE-PTR to 2
move END-COMMAND-ERROR to CURRENT-ERROR
perform 9999-RECORD-ERROR.
If CONDITION-INDEX NOT ZERO
set SOURCE-CODE-PTR to 2
move IF-SYNC-ERROR to CURRENT-ERROR
perform 9999-RECORD-ERROR.
move 'END' to MACRO-COMMAND.
*------------------
* End-Field Command
*------------------
5150-END-FIELD-COMMAND.
perform 9400-POP-COMMAND.
If not EACH-FIELD-COMMAND
move END-FIELD-ERROR to CURRENT-ERROR
perform 9999-RECORD-ERROR.
set FIELD-DATA-INDEX up by 1.
If FIELD-DATA-INDEX > FIELD-DATA-MAX-INDEX
perform 5151-WRAPUP-FIELD
else
perform 5152-REPEAT-FIELD.
5151-WRAPUP-FIELD.
perform 9400-POP-COMMAND.
set FIELD-DATA-INDEX to 1.
set FIELD-FILE-STATUS to 0.
If RECURS-FILE-STATUS = 2
set INPUT-FLAG to 1
else
set INPUT-FLAG to 0.
5152-REPEAT-FIELD.
set FIELD-FILE-INDEX to 0.
set INPUT-FLAG to 2.
set FIELD-FILE-STATUS to 2.
*---------------
* End-If Command
*---------------
5210-END-IF-COMMAND.
perform 5211-POP-CONDITION.
If CONDITION-TRUE
perform 9400-POP-COMMAND
else
perform 9500-EAT
perform 9500-EAT
until END-IF-COMMAND or ELSE-COMMAND or IF-COMMAND
or IF-NOT-COMMAND or END-COMMAND.
5211-POP-CONDITION.
IF CONDITION-INDEX > 0
set CONDITION-VALUE to CONDITION-STACK (CONDITION-INDEX)
set CONDITION-INDEX down by 1
ELSE
SET CONDITION-VALUE TO 0.
*------------------
* End-Image Command
*------------------
5220-END-IMAGE-COMMAND.
perform 9400-POP-COMMAND.
If not EACH-IMAGE-COMMAND
move END-IMAGE-ERROR to CURRENT-ERROR
perform 9999-RECORD-ERROR.
set IMAGE-DATA-INDEX up by 1.
If IMAGE-DATA-INDEX > IMAGE-DATA-MAX-INDEX
perform 5221-WRAPUP-IMAGE
else
perform 5222-REPEAT-IMAGE.
5221-WRAPUP-IMAGE.
set IMAGE-DATA-INDEX to 1.
CLOSE RECURS-FILE DELETE.
set RECURS-FILE-STATUS to 0.
set INPUT-FLAG to 0.
perform 9400-POP-COMMAND.
5222-REPEAT-IMAGE.
CLOSE RECURS-FILE.
open INPUT RECURS-FILE.
set INPUT-FLAG to 1.
set RECURS-FILE-STATUS to 2.
*-----------
* If Command
*-----------
5230-IF-COMMAND.
perform 9600-PUSH-CONDITION.
IF CONDITION-TRUE
perform 9700-TEST-CONDITION.
IF CONDITION-TRUE
perform 9400-POP-COMMAND
else
perform 9500-EAT
perform 9500-EAT
until END-IF-COMMAND or ELSE-COMMAND or IF-NOT-COMMAND
or IF-COMMAND or END-COMMAND.
*---------------
* If-not Command
*---------------
* False is true and true is false.
5240-IF-NOT-COMMAND.
perform 9600-PUSH-CONDITION.
IF CONDITION-TRUE
perform 9700-TEST-CONDITION
If CONDITION-TRUE
set CONDITION-VALUE to 0
else
set CONDITION-VALUE to 1.
IF CONDITION-TRUE
perform 9400-POP-COMMAND
else
perform 9500-EAT
perform 9500-EAT
until END-IF-COMMAND or ELSE-COMMAND or IF-NOT-COMMAND
or IF-COMMAND or END-COMMAND.
*------------
* set Command
*------------
5250-SET-COMMAND.
set SKELETON-PTR to 6.
unstring SKELETON-RECORD
delimited by ALL SPACE
into SET-NAME
pointer SKELETON-PTR.
Set SKELETON-PTR up by 3.
Unstring SKELETON-RECORD
delimited by ALL SPACE
into SET-VALUE
pointer SKELETON-PTR.
If IMAGE-SET-NAME
move SET-VALUE to IMAGE-DATA-INDEX.
If MACRO-COMMAND-STACK-PTR > 0
perform 9400-POP-COMMAND
ELSE
move 'END' to MACRO-COMMAND.
*-------------
* Page command
*-------------
5310-PAGE-COMMAND.
move WS-PAGE-EJECT to SOURCE-CODE-RECORD.
perform 8600-WRITE-SOURCE-LINE.
If MACRO-COMMAND-STACK-PTR > 0
perform 9400-POP-COMMAND
else
move 'END' to MACRO-COMMAND.
*------------------
* End-note Command
*-----------------
5320-END-NOTE-COMMAND.
If MACRO-COMMAND-STACK-PTR > 0
perform 9400-POP-COMMAND
else
move 'END' TO MACRO-COMMAND.
8000-READ-FL.
set FILE-LANGUAGE-PTR to 1.
read FILE-LANGUAGE-FILE
at end
set FILE-LANGUAGE-END-SW to YES-VALUE.
If not FILE-LANGUAGE-END
If FL-FILE-NUMBERED-NO
NEXT SENTENCE
else
If FL-FILE-NUMBERED-YES
set FILE-LANGUAGE-PTR to 7
else
If FLR-NUM-TEST IS NUMERIC
set FL-FILE-NUMBERED-FLAG to 2
set FILE-LANGUAGE-PTR to 7
else
set FL-FILE-NUMBERED-FLAG to 1.
8100-READ.
set SKELETON-PTR to 1.
If SKELETON-FILE-READ
perform 8200-READ-SKELETON
else If RECURS-FILE-READ
perform 8300-READ-RECURS
else If FIELD-FILE-READ
perform 9100-INPUT-FIELD.
8200-READ-SKELETON.
read SKELETON-FILE
at end
move 'END' to MACRO-COMMAND
set SKELETON-FILE-END-SW to YES-VALUE
move SPACE to SKELETON-RECORD.
If SKL-FILE-NUMBERED-NOT-SET
If SKELETON-LINE-NUMBER NUMERIC
set SKL-FILE-NUMBERED-FLAG to YES-VALUE
else
set SKL-FILE-NUMBERED-FLAG to NO-VALUE.
If SKL-FILE-NUMBERED
move SKELETON-BODY to SKELETON-RECORD.
If RECURS-FILE-WRITE
perform 8500-RECURS-WRITE.
If FIELD-FILE-WRITE
perform 9200-FIELD-OUTPUT.
8300-READ-RECURS.
read RECURS-FILE
at end
close RECURS-FILE DELETE
move RECURS-FILE-ERROR to CURRENT-ERROR
perform 9999-RECORD-ERROR.
move RECURS-RECORD to SKELETON-RECORD.
If FIELD-FILE-WRITE
perform 9200-FIELD-OUTPUT.
8500-RECURS-WRITE.
move SKELETON-RECORD to RECURS-RECORD.
write RECURS-RECORD.
8600-WRITE-SOURCE-LINE.
If SOURCE-CODE-CHAR (1) = WS-PAGE-EJECT
set LINE-NUMBER TO 0
set PAGE-NUMBER up by 1
else
set LINE-NUMBER up by 100.
PERFORM 9900-DO-NOTHING
VARYING VAR-IDX FROM 105 BY -1
UNTIL SOURCE-CODE-VAR(VAR-IDX) NOT = SPACE
OR VAR-IDX = 1.
write SOURCE-CODE-2
BEFORE ADVANCING 1 LINE.
set SOURCE-CODE-PTR to 1.
move SPACE to SOURCE-CODE-RECORD.
If LINE-NUMBER > 99700
move WS-PAGE-EJECT to SOURCE-CODE-CHAR (1)
perform 8600-WRITE-SOURCE-LINE.
9100-INPUT-FIELD.
set FIELD-FILE-INDEX up by 1.
move FIELD-FILE-ARRAY (FIELD-FILE-INDEX) to SKELETON-RECORD.
9200-FIELD-OUTPUT.
set FIELD-FILE-INDEX up by 1.
If FIELD-FILE-INDEX > 300
Display "? Field file length exceeded.".
move SKELETON-RECORD to FIELD-FILE-ARRAY (FIELD-FILE-INDEX).
*--------------
* Start Command
*--------------
9300-START-COMMAND.
perform 8100-READ.
If COMMAND-LINE
perform 9310-PUSH-COMMAND
else
perform 9320-LINE-SCAN
until SKELETON-PTR > MAX-SOURCE-CODE-PTR
perform 8600-WRITE-SOURCE-LINE.
9310-PUSH-COMMAND.
set MACRO-COMMAND-STACK-PTR up by 1.
move MACRO-COMMAND to MACRO-COMMAND-STACK(MACRO-COMMAND-STACK-PTR).
move SPACE to MACRO-COMMAND.
9320-LINE-SCAN.
move SPACE to CURRENT-DELIMITER.
unstring SKELETON-RECORD
delimited by BEGIN-DELIMITER
into SOURCE-CODE-WORK
DELIMITER IN CURRENT-DELIMITER
COUNT IN SOURCE-CODE-INDEX
pointer SKELETON-PTR.
set SOURCE-CODE-INDEX up by 1.
If SKELETON-PTR not> MAX-SOURCE-CODE-PTR
move '@' to SOURCE-CODE-ARRAY(SOURCE-CODE-INDEX).
string SOURCE-CODE-WORK delimited by '@'
into SOURCE-CODE-RECORD
pointer SOURCE-CODE-PTR.
If CURRENT-DELIMITER = BEGIN-DELIMITER
perform 9710-SUBSTITUTE-NAME.
9400-POP-COMMAND.
IF MACRO-COMMAND-STACK-PTR > 0
move MACRO-COMMAND-STACK(MACRO-COMMAND-STACK-PTR) to MACRO-COMMAND
set MACRO-COMMAND-STACK-PTR down by 1
ELSE
MOVE SPACES TO MACRO-COMMAND.
9500-EAT.
move SPACE to SKELETON-RECORD.
perform 8100-READ
until COMMAND-LINE.
set SKELETON-PTR to 2.
unstring SKELETON-RECORD
delimited by ALL SPACE or ALL WS-TAB
into MACRO-COMMAND
pointer SKELETON-PTR.
9600-PUSH-CONDITION.
set CONDITION-INDEX up by 1.
set CONDITION-STACK (CONDITION-INDEX) to CONDITION-VALUE.
9700-TEST-CONDITION.
unstring SKELETON-RECORD
delimited by BEGIN-DELIMITER
into SUBSTITUTE-NAME
pointer SKELETON-PTR.
unstring SKELETON-RECORD
delimited by END-DELIMITER
into SUBSTITUTE-NAME
pointer SKELETON-PTR.
perform 9710-FIELD-DATA-NAMES.
inspect SYMBOL-WORK
replacing all '@'
by space.
set SKELETON-PTR up by 3.
unstring SKELETON-RECORD
delimited by ALL SPACE
into CONDITION-TEMP
pointer SKELETON-PTR.
set CONDITION-VALUE to NO-VALUE.
set SYMBOL-WORK-PTR to 1.
perform 9720-SEARCH
until SYMBOL-WORK-PTR > 105
or CONDITION-TRUE.
9710-SUBSTITUTE-NAME.
unstring SKELETON-RECORD
delimited by END-DELIMITER
into ASCII-SUBSTITUTE-NAME
delimiter in CURRENT-DELIMITER
pointer SKELETON-PTR.
move ASCII-SUBSTITUTE-NAME to SUBSTITUTE-NAME.
If SKELETON-PTR > MAX-SOURCE-CODE-PTR
move END-DELIMITER-ERROR to CURRENT-ERROR
perform 9999-RECORD-ERROR
else If RESERVED-VARIABLE
perform 9710-RESERVED-VARIABLE
else
perform 9710-FIELD-DATA-NAMES
string SYMBOL-WORK delimited by '@'
into SOURCE-CODE-RECORD
pointer SOURCE-CODE-PTR.
9710-RESERVED-VARIABLE.
IF DATE-VARIABLE
string WS-DATE-WORK
delimited by SIZE
into SOURCE-CODE-RECORD
pointer SOURCE-CODE-PTR
else If RESERVED-NAME-CHAR-1 is numeric
unstring RESERVED-NAME delimited by space into NEXT-COL-NO
perform 9730-ADJUST-OUTPUT-COLUMN
* else If condition
else
move RESERVED-VARIABLE-ERROR to CURRENT-ERROR
perform 9999-RECORD-ERROR.
9710-FIELD-DATA-NAMES.
If FIELD-NAME
move FIELD (FIELD-DATA-INDEX) to SYMBOL-WORK
ELSE IF FLDIX-NAME
MOVE FLDIX (FIELD-DATA-INDEX) TO SYMBOL-WORK
move '@' to SYMBOL-WORK-ARRAY (4)
else If FLDNO-NAME
move FLDNO (FIELD-DATA-INDEX) to SYMBOL-WORK
move '@' to SYMBOL-WORK-ARRAY (3)
ELSE IF REDEF-NAME
MOVE REDEF (FIELD-DATA-INDEX) TO SYMBOL-WORK
ELSE IF ISRDF-NAME
MOVE ISRDF (FIELD-DATA-INDEX) TO SYMBOL-WORK
else If PICT-NAME
move PICT (FIELD-DATA-INDEX) to SYMBOL-WORK
ELSE IF USIGE-NAME
MOVE USIGE (FIELD-DATA-INDEX) TO SYMBOL-WORK
ELSE IF FSIGN-NAME
MOVE FSIGN (FIELD-DATA-INDEX) TO SYMBOL-WORK
ELSE IF FSEP-NAME
MOVE FSEP (FIELD-DATA-INDEX) TO SYMBOL-WORK
ELSE IF FOCUR-NAME
MOVE FOCUR (FIELD-DATA-INDEX) TO SYMBOL-WORK
ELSE IF OLVL1-NAME
MOVE OLVL1 (FIELD-DATA-INDEX) TO SYMBOL-WORK
ELSE IF OLVL2-NAME
MOVE OLVL2 (FIELD-DATA-INDEX) TO SYMBOL-WORK
ELSE IF OLVL3-NAME
MOVE OLVL3 (FIELD-DATA-INDEX) TO SYMBOL-WORK
ELSE IF FTO-NAME
MOVE FTO (FIELD-DATA-INDEX) TO SYMBOL-WORK
ELSE IF DEPND-NAME
MOVE DEPND (FIELD-DATA-INDEX) TO SYMBOL-WORK
ELSE IF ASCND-NAME
MOVE ASCND (FIELD-DATA-INDEX) TO SYMBOL-WORK
ELSE IF DSCND-NAME
MOVE DSCND (FIELD-DATA-INDEX) TO SYMBOL-WORK
ELSE IF INDXD-NAME
MOVE INDXD (FIELD-DATA-INDEX) TO SYMBOL-WORK
ELSE IF INDX1-NAME
MOVE INDX1 (FIELD-DATA-INDEX) TO SYMBOL-WORK
ELSE IF INDX2-NAME
MOVE INDX2 (FIELD-DATA-INDEX) TO SYMBOL-WORK
ELSE IF INDX3-NAME
MOVE INDX3 (FIELD-DATA-INDEX) TO SYMBOL-WORK
ELSE IF FSYNC-NAME
MOVE FSYNC (FIELD-DATA-INDEX) TO SYMBOL-WORK
ELSE IF FJUST-NAME
MOVE FJUST (FIELD-DATA-INDEX) TO SYMBOL-WORK
ELSE IF FBLNK-NAME
MOVE FBLNK (FIELD-DATA-INDEX) TO SYMBOL-WORK
ELSE
PERFORM 9710-A.
MOVE substitute-name TO temp-substitute-name.
IF temp-substitute-name = ascii-substitute-name
MOVE symbol-work TO sixbit-symbol-work
MOVE sixbit-symbol-work TO symbol-work.
9710-A.
*PARAGRAPH TO OVERCOME 24-LEVEL NESTING LIMIT ON 'IF-ELSE'.
IF FVALU-NAME
MOVE FVALU (FIELD-DATA-INDEX) TO SYMBOL-WORK
ELSE IF FDLMT-NAME
MOVE FDLMT (FIELD-DATA-INDEX) TO SYMBOL-WORK
ELSE IF FDATA-NAME
MOVE FDATA (FIELD-DATA-INDEX) TO SYMBOL-WORK
ELSE IF FDTA2-NAME
MOVE FDTA2 (FIELD-DATA-INDEX) TO SYMBOL-WORK
else
perform 9710-IMAGE-DATA-NAMES.
9710-IMAGE-DATA-NAMES.
If ITYPE-NAME
move ITYPE (IMAGE-DATA-INDEX) to SYMBOL-WORK
ELSE IF IDATA-NAME
MOVE IDATA (IMAGE-DATA-INDEX) TO SYMBOL-WORK
else
perform 9710-MODULE-DATA-NAMES.
9710-MODULE-DATA-NAMES.
If MODTL-NAME
move MODTL to SYMBOL-WORK
else If FILNM-NAME
move FILNM to SYMBOL-WORK
ELSE IF ASIGN-NAME
MOVE ASIGN TO SYMBOL-WORK
ELSE IF ORG-NAME
MOVE ORG TO SYMBOL-WORK
else If ACCES-NAME
move ACCES to SYMBOL-WORK
ELSE IF MKEY-NAME
MOVE MKEY TO SYMBOL-WORK
ELSE IF MMODE-NAME
MOVE MMODE TO SYMBOL-WORK
ELSE IF MBLCK-NAME
MOVE MBLCK TO SYMBOL-WORK
ELSE IF MODNM-NAME
MOVE MODNM TO SYMBOL-WORK
ELSE IF RECNM-NAME
MOVE RECNM TO SYMBOL-WORK
else
move SYMBOL-ERROR to CURRENT-ERROR
perform 9999-RECORD-ERROR.
9720-SEARCH.
unstring SYMBOL-WORK
delimited by all space or ','
into CONDITION-WORK
pointer SYMBOL-WORK-PTR.
If CONDITION-WORK = CONDITION-TEMP
set CONDITION-VALUE to YES-VALUE.
9730-ADJUST-OUTPUT-COLUMN.
set CURR-COL-NO,
LAST-COL-NO,
LAST-SOURCE-PTR to 0.
perform 9731-CALC-LAST-COL-NO
varying WS-INDEX from 1 by 1
until WS-INDEX = SOURCE-CODE-PTR.
compute SOURCE-CODE-PTR = LAST-SOURCE-PTR + 1.
If (LAST-COL-NO + 1) > NEXT-COL-NO
perform 9732-INSERT-SPACE
varying SOURCE-CODE-PTR from SOURCE-CODE-PTR by 1
until SOURCE-CODE-PTR > MAX-SOURCE-CODE-PTR
perform 8600-WRITE-SOURCE-LINE
set LAST-COL-NO to 0
set SOURCE-CODE-PTR to 1.
If (LAST-COL-NO + 1) not> NEXT-COL-NO
divide NEXT-COL-NO by TAB-WIDTH giving NEXT-TAB-NO
multiply NEXT-TAB-NO by TAB-WIDTH giving NO-WARNING-COMP
move NO-WARNING-3 TO NEXT-TAB-NO
perform 9733-INSERT-TAB
varying SOURCE-CODE-PTR from SOURCE-CODE-PTR by 1
until LAST-COL-NO NOT< NEXT-TAB-NO
perform 9732-INSERT-SPACE
varying SOURCE-CODE-PTR from SOURCE-CODE-PTR by 1
until LAST-COL-NO NOT< NEXT-COL-NO.
9731-CALC-LAST-COL-NO.
set CURR-COL-NO up by 1.
If SOURCE-CODE-CHAR (WS-INDEX) = WS-TAB
divide CURR-COL-NO by 8 giving TALLY
REMAINDER FILL-COUNT
COMPUTE CURR-COL-NO = CURR-COL-NO + 8 - FILL-COUNT
else
If SOURCE-CODE-CHAR (WS-INDEX) = SPACE
NEXT SENTENCE
else
move WS-INDEX to LAST-SOURCE-PTR
move CURR-COL-NO to LAST-COL-NO.
9732-INSERT-SPACE.
move SPACE to SOURCE-CODE-CHAR (SOURCE-CODE-PTR).
set LAST-COL-NO up by 1.
9733-INSERT-TAB.
move WS-TAB to SOURCE-CODE-CHAR (SOURCE-CODE-PTR).
divide LAST-COL-NO by 8 giving TALLY
REMAINDER FILL-COUNT
COMPUTE LAST-COL-NO = LAST-COL-NO + 8 - FILL-COUNT.
9900-DO-NOTHING.
*---------------------
* Record Error Routine
*---------------------
* 1. Make sure SOURCE-CODE-PTR is where you want '^'.
* 2. move error-name-ERROR to CURRENT-ERROR.
* 3. perform 9999-RECORD-ERROR.
9999-RECORD-ERROR.
set WS-SAVE-PTR to SOURCE-CODE-PTR.
move SKELETON-RECORD to SOURCE-CODE-RECORD.
perform 8600-WRITE-SOURCE-LINE.
move SPACE to SOURCE-CODE-RECORD.
set SOURCE-CODE-PTR to WS-SAVE-PTR.
string '^' delimited by SIZE
into SOURCE-CODE-RECORD
pointer SOURCE-CODE-PTR.
SUBTRACT ERROR-LENGTH
from MAX-SOURCE-CODE-PTR giving ERROR-LINE-PTR.
If SOURCE-CODE-PTR > ERROR-LINE-PTR
subtract ERROR-LENGTH,1 from SOURCE-CODE-PTR.
string ERROR-TEXT delimited by '@'
into SOURCE-CODE-RECORD
pointer SOURCE-CODE-PTR.
perform 8600-WRITE-SOURCE-LINE.
set ERROR-NUMBER up by 1.
set SKELETON-PTR to MAX-SOURCE-CODE-PTR.
set SKELETON-PTR up by 1.
move LINE-NUMBER to LINE-NUMBER-PRT.
display 'Error # ' ERROR-NUMBER ' (line/page) '
LINE-NUMBER-PRT '/' PAGE-NUMBER.