Trailing-Edge
-
PDP-10 Archives
-
LCG_Integration_Tools_Clearinghouse_T20_v7_30Apr86
-
tools/conbat/vag004.cbl
There are 5 other files named vag004.cbl in the archive. Click here to see a list.
IDENTIFICATION DIVISION.
*=======================
Program-Id. VAG004.
Author. KATHY MCKENDRY
Date-Written. 15-Jan-85.
Date-Compiled.
Installation. PAPER FREE SYSTEMS INC.
*-------------
*Program Title:
*-------------
*
* System: VAXCON DEC to VAX Conversion System
* Module: VAG004 Command File Generator
*
*
*-------------------
*Program Description:
*-------------------
*
* VAG004 converts DEC-10/20 control files (.CTL's) to VAX-11
* command files (.COM's) using a user-modifiable table of conver-
* sion factors and a file of skeleton .COM commands.
*
*----------------------------
*Program Modification History:
*----------------------------
* --Date-- Who What
*
*----------------------------------------------------------------------
ENVIRONMENT DIVISION.
*====================
CONFIGURATION SECTION.
*---------------------
SOURCE-COMPUTER. DECSYSTEM-10.
OBJECT-COMPUTER. DECSYSTEM-10.
INPUT-OUTPUT SECTION.
*--------------------
FILE-CONTROL.
select CONTROL-FILE
assign to DSK
file status is CT-FS-STATUS
CT-FS-ERROR-NO
CT-FS-ACTION-CODE
CT-FS-FILE-SPEC
CT-FS-BLOCK-NO
CT-FS-RECORD-NO
CT-FS-FILE-NAME
CT-FS-TABLE-POINTER
recording mode ASCII.
Select COM-TABLE-FILE
assign to DSK
recording mode ASCII.
Select STR-TABLE-FILE
assign to DSK
recording mode ASCII.
Select DIR-TABLE-FILE
assign to DSK
recording mode ASCII.
Select SKELETON-FILE
assign to DSK
recording mode ASCII.
select COMMAND-FILE
assign to DSK
recording mode ASCII.
DATA DIVISION.
*=============
FILE SECTION.
*------------
fd CONTROL-FILE
value of id CONTROL-FILE-ID.
01 CONTROL-RECORD display-7
PIC X(105).
01 CONTROL-WORK-REC display-7.
02 CONTROL-WORK pic X(001) occurs 105.
01 CONTROL-STASH-RECORD DISPLAY-7.
02 CTL-STASH-REC PIC X(102).
02 FILLER PIC X(003).
fd COM-TABLE-FILE
value of id COM-TABLE-FILE-ID.
01 COM-TABLE-RECORD PIC X(81).
fd STR-TABLE-FILE
value of id STR-TABLE-FILE-ID.
01 STR-TABLE-RECORD PIC X(21).
fd DIR-TABLE-FILE
value of id DIR-TABLE-FILE-ID.
01 DIR-TABLE-RECORD PIC X(109).
fd SKELETON-FILE
value of id SKELETON-FILE-ID.
01 SKELETON-RECORD display-7
PIC X(115).
*
fd COMMAND-FILE
value of id COMMAND-FILE-ID.
01 COMMAND-RECORD display-7.
02 COMMAND-CHAR pic X(001) occurs 105.
01 COMMAND-2 display-7.
02 COMMAND-VAR PIC X(001) OCCURS 1 TO 105
DEPENDING ON VAR-IDX.
WORKING-STORAGE SECTION.
*=======================
*===============================================================
* S Y M B O L T A B L E S
*===============================================================
01 W-MAIN-CMD-TABLE OCCURS 1500
INDEXED BY W-MCMD-IDX
ASCENDING KEY W-MCMD-NAME.
05 W-MCMD-TBL-NAME PIC X(10).
05 W-MCMD-NAME PIC X(10).
05 W-MCMD-FLAGS.
10 W-MCMD-NO-EQUIV PIC 9(01).
10 W-MCMD-IGNORE PIC 9(01).
10 W-MCMD-END-COM PIC 9(01).
10 W-MCMD-TERM PIC 9(01).
10 W-MCMD-FILE-NEXT PIC 9(01).
10 W-MCMD-TOKEN-FIRST PIC 9(01).
05 W-MCMD-NXT-TBL PIC X(10).
05 W-MCMD-SKL-NAME PIC X(10).
05 W-MCMD-TOKEN-NAME PIC X(05).
05 W-MCMD-TOKEN-VALUE PIC X(30).
01 W-MCMD-MAX-TBL PIC S9(04) COMP VALUE 1500.
01 WSS-TABLE-NAME PIC X(10).
01 WSS-RETURN-NAME PIC X(10).
01 W-SUB-CMD-WHOLE.
05 W-SUB-CMD-TABLE OCCURS 999
INDEXED BY W-SCMD-IDX
ASCENDING KEY W-SCMD-NAME.
10 W-SCMD-TBL-NAME PIC X(10).
10 W-SCMD-NAME PIC X(10).
10 W-SCMD-CHAR REDEFINES
W-SCMD-NAME PIC X(01)
OCCURS 10.
10 W-SCMD-FLAGS.
15 W-SCMD-NO-EQUIV PIC 9(01).
15 W-SCMD-IGNORE PIC 9(01).
15 W-SCMD-END-COM PIC 9(01).
15 W-SCMD-TERM PIC 9(01).
15 W-SCMD-FILE-NEXT PIC 9(01).
15 W-SCMD-TOKEN-FIRST PIC 9(01).
10 W-SCMD-NXT-TBL PIC X(10).
10 W-SCMD-SKL-NAME PIC X(10).
10 W-SCMD-TOKEN-NAME PIC X(05).
10 W-SCMD-TOKEN-VALUE PIC X(30).
01 W-SCMD-MAX-TBL PIC S9(04) COMP.
01 W-SCMD-ABS-MAX-TBL PIC S9(04) COMP VALUE 1500.
01 W-SCMD-MAX-CHAR PIC S9(01) COMP VALUE 6.
01 W-MAIN-DIR-TABLE OCCURS 999
INDEXED BY W-MDIR-IDX
ASCENDING KEY W-MDIR-NAME.
05 W-MDIR-TBL-NAME PIC X(10).
05 W-MDIR-NAME PIC 9(06).
05 W-MDIR-FLAGS.
10 W-MDIR-NO-EQUIV PIC 9(01).
10 W-MDIR-IGNORE PIC 9(01).
10 W-MDIR-END-DIR PIC 9(01).
05 W-MDIR-NXT-TBL PIC X(10).
05 W-MDIR-NEW-DIR PIC X(80).
01 W-MDIR-MAX-TBL PIC S9(03) COMP VALUE 999.
01 W-SUB-DIR-WHOLE.
05 W-SUB-DIR-TABLE OCCURS 999
INDEXED BY W-SDIR-IDX
ASCENDING KEY W-SDIR-NAME.
10 W-SDIR-TBL-NAME PIC X(10).
10 W-SDIR-NAME PIC 9(06).
10 W-SDIR-FLAGS.
15 W-SDIR-NO-EQUIV PIC 9(01).
15 W-SDIR-IGNORE PIC 9(01).
15 W-SDIR-END-DIR PIC 9(01).
10 W-SDIR-NXT-TBL PIC X(10).
10 W-SDIR-NEW-DIR PIC X(80).
01 W-SDIR-MAX-TBL PIC S9(03) COMP VALUE 999.
01 WSS-MORE-ZEROES-SW PIC S9(01) COMP.
88 WSS-MORE-ZEROES VALUE 1.
01 OPER-FOUND-SW PIC S9(01) COMP.
88 OPER-FOUND VALUE 1.
01 WSS-NUMERIC-SW PIC S9(01) COMP.
88 WSS-NUMERIC-FIELD VALUE 1.
01 W-HOLD-CMD-FLAGS.
05 W-HCMD-NO-EQUIV PIC 9(01).
05 W-HCMD-IGNORE PIC 9(01).
05 W-HCMD-END-COM PIC 9(01).
88 W-HCMD-END-YES VALUE 1.
05 W-HCMD-TERM PIC 9(01).
88 W-HCMD-TERM-YES VALUE 1.
05 W-HCMD-FILE-NEXT PIC 9(01).
88 W-HCMD-FILE-NEXT-YES VALUE 1.
05 W-HCMD-TOKEN-FIRST PIC 9(01).
01 WSS-MORE-HOLD-STUFF.
05 W-HCMD-NXT-TBL PIC X(10).
05 W-HCMD-SKL-NAME PIC X(10).
05 W-HCMD-TOKEN-NAME PIC X(05).
05 W-HCMD-TOKEN-VALUE PIC X(30).
01 WSS-COMMAND PIC X(10).
01 WSS-COMMAND-ARRAY REDEFINES
WSS-COMMAND OCCURS 10
INDEXED BY CM-IDX
PIC X(01).
01 WSS-NEXT-COMMAND PIC X(10).
01 W-STRUCTURE-TABLE OCCURS 999
INDEXED BY W-STR-IDX
ASCENDING KEY W-STR-OLD.
05 W-STR-OLD PIC X(06).
05 W-STR-NEW PIC X(15).
01 W-STR-MAX-TBL PIC S9(03) COMP VALUE 999.
01 W-SKL-TABLE OCCURS 999
INDEXED BY W-SKL-IDX
ASCENDING KEY W-SKL-NAME.
05 W-SKL-NAME PIC X(010).
05 W-SKL-DATA PIC X(105).
01 W-SKL-MAX-TBL PIC S9(03) COMP VALUE 999.
01 W-STANDARD-EXT-DATA.
05 FILLER PIC X(06) VALUE 'CBLCOB'.
05 FILLER PIC X(06) VALUE 'CTLCOM'.
05 FILLER PIC X(06) VALUE 'LSTLIS'.
05 FILLER PIC X(06) VALUE 'MICCOM'.
05 FILLER PIC X(06) VALUE 'PL1PLI'.
05 FILLER PIC X(06) VALUE 'RELOBJ'.
05 FILLER PIC X(06) VALUE 'TEMTMP'.
01 W-STANDARD-EXT-TABLE REDEFINES
W-STANDARD-EXT-DATA OCCURS 7
INDEXED BY W-EXT-IDX
ASCENDING KEY W-EXT-OLD.
05 W-EXT-OLD PIC X(03).
05 W-EXT-NEW PIC X(03).
01 VAR-CHECK.
05 VAR-CK-1 PIC X(01).
05 FILLER PIC X(01) VALUE '\'.
01 W-STANDARD-VAR-DATA.
05 FILLER PIC X(21) VALUE 'A\ P1\'.
05 FILLER PIC X(21) VALUE 'B\ P2\'.
05 FILLER PIC X(21) VALUE 'C\ P3\'.
05 FILLER PIC X(21) VALUE 'D\ P4\'.
05 FILLER PIC X(21) VALUE 'DATE\ F$TIME\'.
05 FILLER PIC X(21) VALUE 'E\ P5\'.
05 FILLER PIC X(21) VALUE 'F\ P6\'.
05 FILLER PIC X(21) VALUE 'G\ P7\'.
05 FILLER PIC X(21) VALUE 'H\ P8\'.
05 FILLER PIC X(21) VALUE 'JOB\ F$PROCESS()\'.
05 FILLER PIC X(21) VALUE 'LENGTH\F$LENGTH\'.
05 FILLER PIC X(21) VALUE 'PPN\ F$DIRECTORY()\'.
05 FILLER PIC X(21) VALUE 'TIME\ F$TIME()\'.
01 W-STANDARD-VAR-TABLE REDEFINES
W-STANDARD-VAR-DATA OCCURS 13
INDEXED BY W-VAR-IDX
ASCENDING KEY W-VAR-OLD.
05 W-VAR-OLD PIC X(07).
05 W-VAR-NEW PIC X(14).
*========== E N D O F S Y M B O L T A B L E S =========
*=============================================================
* S Y M B O L T A B L E W S
*=============================================================
01 CT-MAX PIC S9(03) COMP VALUE 400.
01 CT-TOKEN
pic X(400).
01 filler redefines CT-TOKEN.
02 CT-TOKEN-20 PIC X(20).
02 filler pic X(380).
01 CT-TOKEN-ARRAY redefines CT-TOKEN
occurs 400
indexed by CT-IDX
pic X(01).
01 TOKEN-HOLD
pic X(400).
01 TOKEN-HOLD-ARRAY redefines TOKEN-HOLD
occurs 400
indexed by TH-IDX
pic X(01).
01 TH-MAX PIC S9(03) COMP VALUE 400.
01 HOLD-IDX USAGE INDEX.
01 CURR-CHAR PIC X(01).
01 TOKEN-END-SW pic S9(01) comp.
88 TOKEN-END value 1.
01 TEMP-TOKEN PIC X(400).
01 TEMP-TOKEN-ARRAY REDEFINES
TEMP-TOKEN PIC X(001)
OCCURS 400
INDEXED BY TEMP-IDX.
01 WSS-DIRECT PIC X(80).
01 W-DIR-IDX USAGE INDEX.
01 DIR-MAX PIC S9(02) COMP VALUE 80.
01 W-CONTROL-REC PIC X(105).
01 CT-STATE-SWITCHES.
02 CONTROL-END-SW pic S9(01) comp.
88 CONTROL-END value 1.
01 CONTROL-FILE-CONTROL DISPLAY-6.
02 CONTROL-FILE-ID.
04 CONTROL-FILE-NAME pic X(06).
04 CONTROL-FILE-EXT pic X(03).
02 CT-FILE-STATUS.
04 CT-FS-STATUS pic 9(02).
88 CT-FS-STATUS-NORMAL value 00.
88 CT-FS-STATUS-EOF value 10.
88 CT-FS-STATUS-DUPLICATE-KEY value 22.
88 CT-FS-STATUS-NOT-FOUND value 23.
88 CT-FS-STATUS-OUT-OF-BOUNDS value 24.
88 CT-FS-STATUS-INVALID-KEY value 22, 23, 24.
88 CT-FS-STATUS-FATAL value 30, 34.
04 CT-FS-ERROR-NO pic 9(10).
04 filler redefines CT-FS-ERROR-NO.
06 CT-FS-VERB-ERROR pic 9(02).
88 CT-FS-OPEN-ERROR value 01.
88 CT-FS-READ-ERROR value 06.
06 CT-FS-MONITOR-ERROR pic 9(02).
88 CT-FS-LOOKUP-ERROR value 03.
06 filler pic 9(06).
04 CT-FS-ACTION-CODE usage index.
04 CT-FS-FILE-SPEC pic X(09).
04 CT-FS-BLOCK-NO usage index.
04 CT-FS-RECORD-NO usage index.
04 CT-FS-FILE-NAME pic X(30).
04 CT-FS-TABLE-POINTER usage index.
01 CT-FILE-NAME-PROMPT display-7
pic X(26)
value 'Control file name > '.
*=============================================================
* M A C R O E X P A N S I O N W S
*=============================================================
*----------------
* Command Data
*----------------
*
01 LINE-POINTERS.
02 CONTROL-PTR pic S9(10) comp.
02 MAX-CONTROL-PTR pic S9(10) comp.
02 LAST-CONTROL-PTR PIC S9(10) COMP.
02 CONTROL-COUNT PIC S9(03) COMP.
* NOTE: THE FOLLOWING VALUE MAY BE INCREASED IF REQUIRED FOR NESTING
02 MAX-CONTROL-COUNT PIC S9(03) COMP VALUE 5.
02 SKELETON-PTR pic S9(03) comp.
02 COMMAND-PTR pic S9(10) comp.
02 MAX-COMMAND-PTR pic S9(03) comp value 80.
02 ERROR-LINE-PTR pic S9(03) comp.
02 SYMBOL-WORK-PTR pic S9(03) comp.
01 WSS-SAVE-COMMAND PIC X(10).
01 WSS-SAVE-COMMAND-ARRAY REDEFINES
WSS-SAVE-COMMAND OCCURS 10
INDEXED BY SAV-IDX
PIC X(001).
01 COMMAND-WORK
pic X(105).
01 COMMAND-ARRAY redefines COMMAND-WORK
occurs 105
indexed by COMMAND-INDEX
pic X(01).
*
01 TOKEN-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 SKL-END-SW pic S9(01) comp.
88 SKL-END value 1.
01 STRING-END-SW PIC S9(01) COMP.
88 STRING-END VALUE 1.
*
01 VAR-IDX USAGE INDEX.
01 ERROR-HANDLING display-7.
02 ERROR-LINE pic X(105).
02 ERROR-NUMBER pic S9(10) comp.
02 ERROR-SW pic S9(01) comp.
88 NO-ERROR VALUE 0.
*& 02 WSS-ERROR-HANDLING-SW PIC S9(01) COMP.
*& 88 WSS-ERROR-HANDLING VALUE 1.
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 BLANK-NAME VALUE 'BLANK'.
88 COMNT-NAME VALUE 'COMNT'.
88 DATA1-NAME VALUE 'DATA1'.
88 DATLK-NAME VALUE 'DATLK'.
88 DIREC-NAME VALUE 'DIREC'.
88 EXT1-NAME VALUE 'EXT1'.
88 FILE1-NAME VALUE 'FILE1'.
88 FILE2-NAME VALUE 'FILE2'.
88 FILNM-NAME VALUE 'FILNM'.
88 GEN-NAME VALUE 'GEN'.
88 LABLE-NAME VALUE 'LABLE'.
88 LABLK-NAME VALUE 'LABLK'.
88 PROG-NAME VALUE 'PROG'.
88 SAVE-NAME VALUE 'SAVE'.
88 STRC1-NAME VALUE 'STRC1'.
88 STRC2-NAME VALUE 'STRC2'.
88 SWTCH-NAME VALUE 'SWTCH'.
88 SWTC2-NAME VALUE 'SWTC2'.
88 TOKEN-NAME VALUE 'TOKEN'.
88 SKL-SUB-NAME
VALUE 'COMNT', 'DATA1', 'FILE1', 'FILE2', 'PROG', 'STRC1',
'STRC2', 'SWTCH', 'SWTC2'.
02 filler pic X(06).
01 WSS-LAST-TOKEN-NAME PIC X(06).
01 TOKEN-DATA.
02 COMNT PIC X(400).
02 DATA1 PIC X(400).
02 DIREC PIC X(400).
02 EXT1 PIC X(400).
02 FILE1 PIC X(400).
02 FILE2 PIC X(400).
02 FILNM PIC X(400).
02 GEN PIC X(400).
02 LABLE PIC X(400).
02 PROG PIC X(400).
02 STRC1 PIC X(400).
02 STRC2 PIC X(20).
02 SWTCH PIC X(400).
02 SWTC2 PIC X(400).
01 TABLE-STATE-SWITCHES.
02 COM-TABLE-END-SW PIC S9(01) COMP.
88 COM-TABLE-END VALUE 1.
02 STR-TABLE-END-SW PIC S9(01) COMP.
88 STR-TABLE-END VALUE 1.
02 DIR-TABLE-END-SW PIC S9(01) COMP.
88 DIR-TABLE-END VALUE 1.
01 COM-TABLE-FILE-ID.
02 COM-TABLE-FILE-NAME PIC X(06).
02 FILLER PIC X(03) VALUE 'TBL'.
01 STR-TABLE-FILE-ID.
02 STR-TABLE-FILE-NAME PIC X(06).
02 FILLER PIC X(03) VALUE 'TBL'.
01 DIR-TABLE-FILE-ID.
02 DIR-TABLE-FILE-NAME PIC X(06).
02 FILLER PIC X(03) VALUE 'TBL'.
01 SKELETON-FILE-ID.
02 FILLER pic X(09) VALUE 'CONBATSKL'.
01 COMMAND-FILE-ID.
02 COMMAND-FILE-NAME pic X(06).
02 FILLER pic X(03) VALUE 'COM'.
01 LINE-NUMBER pic S9(05) comp.
01 PAGE-NUMBER pic S9(05) comp.
01 SYMBOL-WORK display-7
pic X(400).
01 SYMBOL-WORK-ARRAY redefines SYMBOL-WORK display-7
occurs 400
pic X(01).
01 SIXBIT-SYMBOL-WORK display-6
pic X(400).
01 CONTROL-FILE-STATUS PIC S9(01) COMP VALUE 0.
88 CONTROL-FILE-OPEN VALUE 1.
01 COMMAND-FILE-STATUS PIC S9(01) COMP VALUE 0.
88 COMMAND-FILE-OPEN VALUE 1.
*=========================================================
* S C R A T C H P A D
*=========================================================
01 STASH-REC-ARRAY DISPLAY-7
PIC X(525).
01 STASH-REC REDEFINES STASH-REC-ARRAY DISPLAY-7
OCCURS 5.
05 STASH-COM PIC X(03).
05 STASH PIC X(102).
01 STASH-IDX USAGE INDEX.
01 STASH-MAX USAGE INDEX.
01 WSS-CONTROL-REC DISPLAY-7
PIC X(105).
01 WSS-CTL-IDX USAGE INDEX.
* SET THE FOLLOWING SWITCH TO 1 OR 2 DEPENDING ON OPERATING SYSTEM USED
* TO WRITE CONTROL FILE. THIS WILL DETERMINE WHICH CONVERSION TABLE IS
* USED.
01 OP-SYS-SW PIC 9(01) VALUE 1.
88 OP-TOPS-10-SYS VALUE 1.
88 OP-TOPS-20-SYS VALUE 2.
* SET THE FOLLOWING SWITCH TO 1 OR 2 DEPENDING ON WHETHER CTL'S OR MIC'S
* ARE BEING CONVERTED. A VALUE OF 2 INSTRUCTS THE PROGRAM TO TREAT A
* SINGLE QUOTE FOLLOWED BY A LETTER (E.G., 'A) AS A VARIABLE.
01 CTL-MIC-SW PIC S9(01) VALUE 2.
88 CTL-PROC VALUE 1.
88 MIC-PROC VALUE 2.
01 COMNT-CHAR-IND PIC X(01).
88 COMNT-CHAR VALUE '!', ';'.
01 COMNT-PROC-SW PIC S9(01) COMP.
88 COMNT-PROC VALUE 1.
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 END-DELIMITER-ERROR pic X(40)
value '36 Beginning but no ending delimiter. \'.
02 SYMBOL-ERROR pic X(40)
value '22 Unrecognized symbol. \'.
02 DATA-TYPE-ERROR pic X(40)
value '33 Current data type is undefined. \'.
02 NO-SKELETON-ERROR pic x(40)
value '26 No skeleton for command. \'.
02 NO-DIRECTORY-ERROR pic X(40)
value '25 Directory not in table. \'.
02 NO-EQUIV-ERROR pic X(40)
value '25 No equivalent in table. \'.
02 NO-COMMAND-ERROR pic X(40)
value '23 Command not in table. \'.
02 CMD-TABLE-ERROR PIC X(40)
VALUE '34 Command mishandled by CMD table. \'.
02 SKL-TABLE-ERROR PIC X(40)
VALUE '34 Skeleton not found in SKL table. \'.
01 PROG-HEADING display-7
pic X(55)
value 'VAG004: Command 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(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-SAVE-PTR pic S9(10) comp.
01 WSS-OPER-CHAR PIC X(01).
01 TALLY pic 9(10) COMP.
01 WSS-HELP-CHECK PIC X(10).
88 WSS-HELP VALUE 'HELP', 'Help', 'help', 'H', 'h', '?'.
01 WSS-END-OF-LINE-SW PIC S9(01) COMP.
88 WSS-END-OF-LINE VALUE 1.
01 WSS-DELIMITER-CK PIC X(01) VALUE 'X'.
88 WSS-NO-DELIMITER VALUE 'X'.
88 WSS-APOSTROPHE VALUE ''''.
01 LABEL-IND PIC X(02) VALUE '::'.
01 WSS-TABLE-MATCH-SW PIC S9(01) COMP.
88 WSS-TABLE-MATCH-NOT-SET VALUE 0.
88 WSS-TABLE-MATCH VALUE 1.
88 WSS-TABLE-PART-MATCH VALUE 8.
88 WSS-TABLE-NO-MATCH VALUE 9.
88 WSS-TABLE-MATCH-END VALUES 1, 8, 9.
01 WSS-UNIQUE-SW PIC S9(01) COMP.
88 WSS-UNIQUE VALUE 1.
01 WSS-SEARCH-FLAG PIC S9(01) COMP.
88 WSS-SEARCH-DONE VALUE 1.
01 WSS-WRITE-FLAG PIC S9(01) COMP VALUE 0.
88 WSS-DO-WRITE VALUE 1.
01 WSS-AVOID-STRC-PROC-FL PIC S9(01) COMP VALUE 0.
88 WSS-AVOID-STRC-PROC VALUE 1.
PROCEDURE DIVISION.
*==================
DECLARATIVES.
*------------
D100-INPUT-ERROR SECTION. use after standard error procedure on CONTROL-FILE.
D110-INPUT-ERROR.
If CT-FS-OPEN-ERROR
set CONTROL-FILE-STATUS TO 0
If CT-FS-LOOKUP-ERROR
display space
display '% File ['
CONTROL-FILE-NAME '.' CONTROL-FILE-EXT
'] not found.'
display space
set TERMINAL-INPUT-SW TO YES-VALUE
set CT-FS-ACTION-CODE TO 1
else
display space
display '? Fatal error on file ['
CONTROL-FILE-NAME '.' CONTROL-FILE-EXT
'].'
display ' (File Status / Error Number = '
CT-FS-STATUS ' / ' CT-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.
IF OP-TOPS-10-SYS
MOVE 'T10COM' TO COM-TABLE-FILE-NAME
MOVE 'T10STR' TO STR-TABLE-FILE-NAME
MOVE 'T10DIR' TO DIR-TABLE-FILE-NAME
MOVE '.' TO WSS-OPER-CHAR
ELSE
IF OP-TOPS-20-SYS
MOVE 'T20COM' TO COM-TABLE-FILE-NAME
MOVE 'T20STR' TO STR-TABLE-FILE-NAME
MOVE 'T20DIR' TO DIR-TABLE-FILE-NAME
MOVE '@' TO WSS-OPER-CHAR
ELSE
DISPLAY '? OP-SYS-SW has not been set in source file VAG004.'
DISPLAY 'Program is aborting.'
SET PROG-PROCESSING-FLAG TO 9.
IF CONTINUE-PROCESSING
OPEN INPUT COM-TABLE-FILE
PERFORM 0110-LOAD-COM-TABLE-FILE
UNTIL COM-TABLE-END
CLOSE COM-TABLE-FILE
IF CONTINUE-PROCESSING
OPEN INPUT DIR-TABLE-FILE
PERFORM 0120-LOAD-DIR-TABLE-FILE
UNTIL DIR-TABLE-END
CLOSE DIR-TABLE-FILE
IF CONTINUE-PROCESSING
OPEN INPUT SKELETON-FILE
PERFORM 0130-LOAD-SKELETON-FILE
UNTIL SKL-END
CLOSE SKELETON-FILE
IF CONTINUE-PROCESSING
OPEN INPUT STR-TABLE-FILE
PERFORM 0140-LOAD-STR-TABLE-FILE
UNTIL STR-TABLE-END
CLOSE STR-TABLE-FILE.
0110-LOAD-COM-TABLE-FILE.
PERFORM 8100-READ-COM-TBL.
IF NOT COM-TABLE-END
SET W-MCMD-IDX UP BY 1
IF W-MCMD-IDX > W-MCMD-MAX-TBL
DISPLAY '? Command table length exceeded.'
DISPLAY 'Program is aborting.'
SET COM-TABLE-END-SW TO YES-VALUE
SET PROG-PROCESSING-FLAG TO 9
ELSE
MOVE COM-TABLE-RECORD TO W-MAIN-CMD-TABLE(W-MCMD-IDX).
0120-LOAD-DIR-TABLE-FILE.
PERFORM 8200-READ-DIR-TBL.
IF NOT DIR-TABLE-END
SET W-DIR-IDX UP BY 1
IF W-DIR-IDX > W-SDIR-MAX-TBL
DISPLAY '? Directory table length exceeded.'
DISPLAY 'Program is aborting.'
SET DIR-TABLE-END-SW TO YES-VALUE
SET PROG-PROCESSING-FLAG TO 9
ELSE
MOVE DIR-TABLE-RECORD TO W-MAIN-DIR-TABLE(W-DIR-IDX).
0130-LOAD-SKELETON-FILE.
PERFORM 8300-READ-SKL.
IF NOT SKL-END
SET W-SKL-IDX UP BY 1
IF W-SKL-IDX > W-SKL-MAX-TBL
DISPLAY '? Skeleton table length exceeded.'
DISPLAY 'Program is aborting.'
SET SKL-END-SW TO YES-VALUE
SET PROG-PROCESSING-FLAG TO 9
ELSE
MOVE SKELETON-RECORD TO W-SKL-TABLE(W-SKL-IDX).
0140-LOAD-STR-TABLE-FILE.
PERFORM 8400-READ-STR-TBL.
IF NOT STR-TABLE-END
SET W-STR-IDX UP BY 1
IF W-STR-IDX > W-STR-MAX-TBL
DISPLAY '? Structure table length exceeded.'
DISPLAY 'Program is aborting.'
SET STR-TABLE-END-SW TO YES-VALUE
SET PROG-PROCESSING-FLAG TO 9
ELSE
MOVE STR-TABLE-RECORD TO W-STRUCTURE-TABLE(W-STR-IDX).
0200-PROCESS-ALL.
SET CONTROL-END-SW,
PROG-PROCESSING-FLAG to 0.
set TERMINAL-INPUT-SW TO 1.
PERFORM 0210-COLLECT-TERMINAL
UNTIL NOT TERMINAL-INPUT.
If CONTINUE-PROCESSING
MOVE 'TABLE1' TO WSS-TABLE-NAME
PERFORM 9100-LOAD-SUB-CMD-TABLE.
IF CONTINUE-PROCESSING
PERFORM 9200-LOAD-SUB-DIR-TABLE.
IF CONTINUE-PROCESSING
MOVE 0 TO LINE-NUMBER,
STASH-IDX
STASH-MAX
W-HOLD-CMD-FLAGS
ERROR-NUMBER
ERROR-SW
WSS-UNIQUE-SW
SET SKELETON-PTR,
COMMAND-PTR,
PAGE-NUMBER,
ERROR-LINE-PTR TO 1
MOVE SPACE TO ERROR-LINE,
SUBSTITUTE-NAME
perform 1000-CREATE-COMMAND-FILE
UNTIL CONTROL-END
SET CONTROL-END-SW TO NO-VALUE.
0210-COLLECT-TERMINAL.
display CT-FILE-NAME-PROMPT
WITH NO ADVANCING.
accept TERMINAL-REPLY.
If TERMINAL-REPLY = SPACE
set PROG-PROCESSING-FLAG to 9
set TERMINAL-INPUT-SW to NO-VALUE
else
MOVE TERMINAL-REPLY TO WSS-HELP-CHECK
IF WSS-HELP
DISPLAY ' Enter the name of the .CTL file to be used to create the .COM file'
ELSE
perform 0215-OPEN-CTL
PERFORM 0217-OPEN-COM.
0215-OPEN-CTL.
IF CONTROL-FILE-OPEN
SET CONTROL-FILE-STATUS TO 0
CLOSE CONTROL-FILE.
unstring TERMINAL-REPLY
delimited by '.'
into CONTROL-FILE-NAME,
CONTROL-FILE-EXT.
If CONTROL-FILE-EXT = SPACE
IF CTL-PROC
move 'CTL' to CONTROL-FILE-EXT
ELSE
IF MIC-PROC
MOVE 'MIC' TO CONTROL-FILE-EXT.
set TERMINAL-INPUT-SW to NO-VALUE.
SET CONTROL-FILE-STATUS TO 1.
open INPUT CONTROL-FILE.
0217-OPEN-COM.
IF COMMAND-FILE-OPEN
SET COMMAND-FILE-STATUS TO 0
CLOSE COMMAND-FILE.
MOVE CONTROL-FILE-NAME TO COMMAND-FILE-NAME.
SET COMMAND-FILE-STATUS TO 1.
open OUTPUT COMMAND-FILE.
0300-TERMINATE.
IF CONTROL-FILE-OPEN
close CONTROL-FILE.
IF COMMAND-FILE-OPEN
CLOSE COMMAND-FILE.
1000-CREATE-COMMAND-FILE.
PERFORM 8000-READ-CTL.
SET TALLY TO 0.
INSPECT CONTROL-RECORD
TALLYING TALLY FOR ALL LABEL-IND
BEFORE INITIAL WSS-OPER-CHAR.
IF TALLY > 0
MOVE 'LABLE' TO WSS-TABLE-NAME
PERFORM 9100-LOAD-SUB-CMD-TABLE.
SET STASH-IDX, STASH-MAX UP BY 1.
MOVE CTL-STASH-REC TO STASH(STASH-IDX).
PERFORM 9300-FIND-MAX.
IF MIC-PROC
SET WSS-CTL-IDX TO 1
MOVE SPACES TO WSS-CONTROL-REC
PERFORM 9400-REPLACE-VARIABLES.
PERFORM 9300-FIND-MAX.
SET WSS-END-OF-LINE-SW TO NO-VALUE.
IF NOT CONTROL-END
PERFORM 2000-PROCESS-CTL-LINE.
2000-PROCESS-CTL-LINE.
MOVE SPACES TO W-CONTROL-REC
SYMBOL-WORK
CT-TOKEN
TOKEN-HOLD
WSS-SAVE-COMMAND
WSS-LAST-TOKEN-NAME.
SET CONTROL-COUNT
COMNT-PROC-SW
OPER-FOUND-SW
LAST-CONTROL-PTR TO 0.
PERFORM 3000-OPER-LEVEL
UNTIL WSS-END-OF-LINE.
IF NO-ERROR
SET WSS-END-OF-LINE-SW TO NO-VALUE
MOVE 'ENND' TO WSS-NEXT-COMMAND
PERFORM 3000-OPER-LEVEL
UNTIL WSS-END-OF-LINE
PERFORM 3100-END-OF-LINE-PROC.
IF NO-ERROR AND W-HCMD-END-YES
IF COMMAND-RECORD NOT = SPACES
OR (WSS-DO-WRITE)
MOVE ZEROES TO W-HOLD-CMD-FLAGS
PERFORM 8500-WRITE-COMMAND-LINE
MOVE SPACES TO STASH-REC-ARRAY
SET STASH-IDX, STASH-MAX TO 0
ELSE
NEXT SENTENCE
ELSE
SET ERROR-SW TO 0.
3000-OPER-LEVEL.
IF CT-TOKEN = SPACES
SET CT-IDX TO 1.
IF WSS-SAVE-COMMAND = SPACES
SET SAV-IDX TO 1.
IF WSS-NEXT-COMMAND = SPACES
SET CONTROL-PTR UP BY 1
MOVE CONTROL-WORK(CONTROL-PTR) TO CURR-CHAR.
IF CONTROL-PTR NOT < MAX-CONTROL-PTR
SET WSS-END-OF-LINE-SW TO YES-VALUE
IF CONTROL-WORK(MAX-CONTROL-PTR) = '-'
SET WS-SAVE-PTR TO 0
INSPECT CONTROL-RECORD
TALLYING WS-SAVE-PTR
FOR ALL '!'
WS-SAVE-PTR FOR ALL ';'
IF WS-SAVE-PTR = 0
PERFORM 3010-PROCESS-CONT-LINE
SET CONTROL-PTR UP BY 1
MOVE CONTROL-WORK(CONTROL-PTR) TO CURR-CHAR.
IF CONTROL-PTR = LAST-CONTROL-PTR
SET CONTROL-COUNT UP BY 1
IF CONTROL-COUNT > MAX-CONTROL-COUNT
MOVE CMD-TABLE-ERROR TO CURRENT-ERROR
SET WSS-END-OF-LINE-SW TO YES-VALUE
PERFORM 9999-RECORD-ERROR
ELSE
NEXT SENTENCE
ELSE
MOVE CONTROL-PTR TO LAST-CONTROL-PTR
SET CONTROL-COUNT TO 1.
* USE FOLLOWING LINE FOR DEBUGGING
*&DISPLAY 'CURR-CHAR ' CURR-CHAR ' CONTROL-PTR ' CONTROL-PTR
IF WSS-NEXT-COMMAND = SPACES
MOVE CURR-CHAR TO WSS-COMMAND
ELSE
MOVE WSS-NEXT-COMMAND TO WSS-COMMAND
MOVE SPACES TO WSS-NEXT-COMMAND.
IF WSS-COMMAND-ARRAY(2) = (SPACE OR WS-TAB)
MOVE WSS-COMMAND-ARRAY(1) TO COMNT-CHAR-IND
IF COMNT-CHAR
AND W-SCMD-TBL-NAME(1) NOT = 'TABLE1'
MOVE SPACES TO CT-TOKEN
SET CT-IDX TO 1
PERFORM 3020-PROCESS-COMNT
UNTIL WSS-END-OF-LINE
SET COMNT-PROC-SW TO YES-VALUE.
IF NOT COMNT-PROC
IF WSS-COMMAND = (SPACE OR WS-TAB)
MOVE 'SPTAB' TO WSS-COMMAND.
* SEARCH FOR CURR CHAR (OR WHATEVER HAS BEEN PUT IN COMMAND);
* IF MATCH, DO WHAT TABLE SAYS
* OTHERWISE, IF UNIQUE SWITCH ON, CK CURR CHAR AGAINST MATCHING
* CHAR IN RELEVANT TABLE ENTRY-- IF NOMATCH, ERROR
* IF UNIQUE SW OFF, STRING CURR CHAR INTO CT-TOKEN AND DO SERIAL
* SEARCH UNTIL UNIQUE OR END
IF NO-ERROR
AND NOT COMNT-PROC
SET W-SCMD-IDX TO 1
SET WSS-TABLE-MATCH-SW TO 0
SEARCH W-SUB-CMD-TABLE
AT END
SET WSS-TABLE-MATCH-SW TO 9
WHEN W-SCMD-NAME(W-SCMD-IDX) = WSS-COMMAND
SET WSS-TABLE-MATCH-SW TO 1.
IF WSS-TABLE-MATCH
AND NOT COMNT-PROC
AND W-SCMD-IGNORE(W-SCMD-IDX) = YES-VALUE
AND WSS-COMMAND-ARRAY(2) = (SPACE OR WS-TAB)
AND (WSS-COMMAND-ARRAY(1) ALPHABETIC
OR WSS-COMMAND-ARRAY(1) NUMERIC)
IF ((CONTROL-PTR < MAX-CONTROL-PTR)
AND (CONTROL-WORK(CONTROL-PTR + 1) ALPHABETIC
OR CONTROL-WORK(CONTROL-PTR + 1) NUMERIC))
AND CONTROL-WORK(CONTROL-PTR + 1) NOT = (SPACE AND WS-TAB)
SET WSS-TABLE-MATCH-SW TO 9
ELSE
IF CONTROL-PTR > 1
AND (CONTROL-WORK(CONTROL-PTR - 1) NUMERIC
OR CONTROL-WORK(CONTROL-PTR - 1) ALPHABETIC)
IF CONTROL-WORK(CONTROL-PTR - 1) NOT = (SPACE AND WS-TAB)
SET WSS-TABLE-MATCH-SW TO 9.
IF NO-ERROR
AND NOT COMNT-PROC
IF (WSS-TABLE-NO-MATCH)
AND (WSS-COMMAND = WSS-COMMAND-ARRAY(1))
* SEARCH AGAIN IF COMMAND IS SINGLE CHARACTER
PERFORM 3040-DETERMINE-TYPE
SET WSS-TABLE-MATCH-SW TO 0
SET W-SCMD-IDX TO 1
SEARCH W-SUB-CMD-TABLE
AT END
SET WSS-TABLE-MATCH-SW TO 9
WHEN W-SCMD-NAME(W-SCMD-IDX) = WSS-COMMAND
SET WSS-TABLE-MATCH-SW TO 1.
IF NO-ERROR
AND NOT COMNT-PROC
IF WSS-TABLE-MATCH
SET WSS-UNIQUE-SW TO NO-VALUE
MOVE SPACES TO WSS-SAVE-COMMAND
PERFORM 4000-TABLE-MATCH
ELSE
IF WSS-TABLE-NO-MATCH
PERFORM 3030-STRING-COMMAND
IF WSS-UNIQUE
IF W-SCMD-CHAR(HOLD-IDX,SAV-IDX - 1) NOT = WSS-SAVE-COMMAND-ARRAY(SAV-IDX - 1)
IF WSS-TABLE-NAME = 'PROGNAM'
MOVE 'USRPROG' TO WSS-TABLE-NAME
PERFORM 9100-LOAD-SUB-CMD-TABLE
MOVE 0 TO W-HOLD-CMD-FLAGS
STRING WSS-SAVE-COMMAND DELIMITED BY SPACE
INTO CT-TOKEN
WITH POINTER CT-IDX
MOVE SPACES TO WSS-SAVE-COMMAND
ELSE
IF WSS-TABLE-NAME = 'COMAND'
STRING WSS-SAVE-COMMAND DELIMITED BY SPACE
INTO CT-TOKEN
WITH POINTER CT-IDX
MOVE SPACES TO WSS-SAVE-COMMAND
MOVE 'DATA1' TO ASCII-SUBSTITUTE-NAME
PERFORM 4200-FILL-TOKEN
MOVE 'USRDATA' TO WSS-TABLE-NAME
PERFORM 9100-LOAD-SUB-CMD-TABLE
MOVE 0 TO W-HOLD-CMD-FLAGS
ELSE
MOVE NO-EQUIV-ERROR TO CURRENT-ERROR
SET WSS-END-OF-LINE-SW TO YES-VALUE
PERFORM 9999-RECORD-ERROR
ELSE
MOVE W-SCMD-NXT-TBL(HOLD-IDX) TO W-HCMD-NXT-TBL
MOVE W-SCMD-TOKEN-NAME(HOLD-IDX) TO W-HCMD-TOKEN-NAME
MOVE W-SCMD-TOKEN-VALUE(HOLD-IDX) TO W-HCMD-TOKEN-VALUE
MOVE W-SCMD-FLAGS(HOLD-IDX) TO W-HOLD-CMD-FLAGS
MOVE W-SCMD-SKL-NAME(HOLD-IDX) TO W-HCMD-SKL-NAME
ELSE
SET WSS-TABLE-MATCH-SW TO 0
MOVE WSS-SAVE-COMMAND TO WSS-COMMAND
PERFORM 3050-SEARCH-TABLE
IF WSS-UNIQUE
MOVE W-SCMD-NXT-TBL(HOLD-IDX) TO W-HCMD-NXT-TBL
MOVE W-SCMD-TOKEN-NAME(HOLD-IDX) TO W-HCMD-TOKEN-NAME
MOVE W-SCMD-TOKEN-VALUE(HOLD-IDX) TO W-HCMD-TOKEN-VALUE
MOVE W-SCMD-FLAGS(HOLD-IDX) TO W-HOLD-CMD-FLAGS
MOVE W-SCMD-SKL-NAME(HOLD-IDX) TO W-HCMD-SKL-NAME
ELSE
IF WSS-TABLE-NO-MATCH
IF WSS-TABLE-NAME = 'PROGNAM'
MOVE 'USRPROG' TO WSS-TABLE-NAME
PERFORM 9100-LOAD-SUB-CMD-TABLE
MOVE 0 TO W-HOLD-CMD-FLAGS
STRING WSS-SAVE-COMMAND DELIMITED BY SPACE
INTO CT-TOKEN
WITH POINTER CT-IDX
ELSE
IF WSS-TABLE-NAME = 'COMAND'
STRING WSS-SAVE-COMMAND DELIMITED BY SPACE
INTO CT-TOKEN
WITH POINTER CT-IDX
MOVE SPACES TO WSS-SAVE-COMMAND
MOVE 'DATA1' TO ASCII-SUBSTITUTE-NAME
PERFORM 4200-FILL-TOKEN
MOVE 'USRDATA' TO WSS-TABLE-NAME
PERFORM 9100-LOAD-SUB-CMD-TABLE
MOVE 0 TO W-HOLD-CMD-FLAGS
ELSE
MOVE NO-EQUIV-ERROR TO CURRENT-ERROR
SET WSS-END-OF-LINE-SW TO YES-VALUE
PERFORM 9999-RECORD-ERROR
SET WSS-END-OF-LINE-SW TO YES-VALUE.
IF NOT COMNT-PROC
IF WSS-NEXT-COMMAND NOT = SPACES
SET WSS-END-OF-LINE-SW TO NO-VALUE.
SET COMNT-PROC-SW TO NO-VALUE.
3010-PROCESS-CONT-LINE.
PERFORM 8000-READ-CTL.
SET STASH-IDX, STASH-MAX UP BY 1.
MOVE CTL-STASH-REC TO STASH(STASH-IDX).
PERFORM 9300-FIND-MAX.
IF MIC-PROC
SET WSS-CTL-IDX TO 1
MOVE SPACES TO WSS-CONTROL-REC
PERFORM 9400-REPLACE-VARIABLES
PERFORM 9300-FIND-MAX.
SET WSS-END-OF-LINE-SW TO NO-VALUE.
* At this point, CONTROL-PTR is 0. It will be incremented by 1 in
* paragraph 3000, so to bypass first asterisk CONTROL-PTR should be
* set to 1.
IF CONTROL-WORK(1) = '*'
SET CONTROL-PTR UP BY 1.
SET CONTROL-PTR UP BY 1.
SET WS-SAVE-PTR TO CONTROL-PTR.
PERFORM 9500-DO-NOTHING
VARYING CONTROL-PTR FROM WS-SAVE-PTR BY 1
UNTIL CONTROL-WORK(CONTROL-PTR) NOT = SPACE
OR CONTROL-PTR = MAX-CONTROL-PTR.
SET CONTROL-PTR DOWN BY 1.
3020-PROCESS-COMNT.
MOVE CONTROL-WORK(CONTROL-PTR) TO CURR-CHAR.
IF CONTROL-PTR NOT < MAX-CONTROL-PTR
SET WSS-END-OF-LINE-SW TO YES-VALUE.
IF NOT COMNT-CHAR
STRING CURR-CHAR DELIMITED BY SIZE
INTO CT-TOKEN
WITH POINTER CT-IDX
ELSE
MOVE SPACE TO COMNT-CHAR-IND.
IF WSS-END-OF-LINE
MOVE CT-TOKEN TO COMNT
MOVE SPACES TO CT-TOKEN
ELSE
SET CONTROL-PTR UP BY 1.
3030-STRING-COMMAND.
STRING CURR-CHAR DELIMITED BY SIZE
INTO WSS-SAVE-COMMAND
WITH POINTER SAV-IDX.
3040-DETERMINE-TYPE.
IF WSS-COMMAND-ARRAY(1) ALPHABETIC
OR WSS-COMMAND-ARRAY(1) NUMERIC
OR WSS-COMMAND-ARRAY(1) = "'"
*FOR VARIABLES
MOVE 'ALPHAN' TO WSS-COMMAND
ELSE
MOVE 'NONALP' TO WSS-COMMAND.
3050-SEARCH-TABLE.
SET W-SCMD-IDX TO 1.
SET CM-IDX TO 1.
SEARCH W-SUB-CMD-TABLE
AT END
SET WSS-TABLE-MATCH-SW TO 9
WHEN W-SCMD-CHAR(W-SCMD-IDX,1) = WSS-COMMAND-ARRAY(1)
PERFORM 3055-REST-OF-SEARCH
UNTIL WSS-TABLE-MATCH-END.
IF WSS-TABLE-PART-MATCH
* Make sure match is unique
SET W-SCMD-IDX UP BY 1
SET WSS-TABLE-MATCH-SW TO 0
SET CM-IDX TO 0
PERFORM 3055-REST-OF-SEARCH
UNTIL WSS-TABLE-MATCH-END
IF WSS-TABLE-PART-MATCH
* Duplicate - key word is not unique in table, so no match
NEXT SENTENCE
ELSE
SET W-SCMD-IDX DOWN BY 1
SET HOLD-IDX TO W-SCMD-IDX
SET WSS-UNIQUE-SW TO YES-VALUE
SET WSS-TABLE-MATCH-SW TO 1
ELSE
IF WSS-TABLE-MATCH
SET HOLD-IDX TO W-SCMD-IDX
SET WSS-UNIQUE-SW TO YES-VALUE.
3055-REST-OF-SEARCH.
* If WSS-COMMAND is one character long, it must match exactly.
* If the first six letters of the key and table words match,
* a match has been found (1). If the key word is smaller than
* the table word and all characters match, a partial match exists (8).
* Otherwise, there is no match (9).
IF W-SCMD-IDX > W-SCMD-MAX-TBL
SET WSS-TABLE-MATCH-SW TO 9
ELSE
SET CM-IDX UP BY 1
IF CM-IDX > W-SCMD-MAX-CHAR
SET WSS-TABLE-MATCH-SW TO 1
ELSE
IF WSS-COMMAND-ARRAY(CM-IDX) = (SPACE OR WS-TAB)
AND W-SCMD-CHAR(W-SCMD-IDX,CM-IDX) = SPACE
* If the end of the current command array has been reached, there must
* not be additional letters waiting to be strung in. This code was
* added to distinguish 'R' from 'RUN' commands.
IF CONTROL-PTR = MAX-CONTROL-PTR
OR (CONTROL-PTR < MAX-CONTROL-PTR
AND (CONTROL-WORK(CONTROL-PTR + 1) NOT ALPHABETIC
AND CONTROL-WORK(CONTROL-PTR + 1) NOT NUMERIC
OR CONTROL-WORK(CONTROL-PTR + 1) = (SPACE OR WS-TAB)))
SET WSS-TABLE-MATCH-SW TO 1
ELSE
SET WSS-TABLE-MATCH-SW TO 8
ELSE
IF WSS-COMMAND-ARRAY(CM-IDX) = (SPACE OR WS-TAB)
SET WSS-TABLE-MATCH-SW TO 8
ELSE
IF WSS-COMMAND-ARRAY(CM-IDX) > W-SCMD-CHAR(W-SCMD-IDX,CM-IDX)
* Key word is higher in the alphabet than current table word. Increase
* index of table word by one and try again, unless table is exhausted.
SET W-SCMD-IDX UP BY 1
SET CM-IDX TO 0
ELSE
IF WSS-COMMAND-ARRAY(CM-IDX) < W-SCMD-CHAR(W-SCMD-IDX,CM-IDX)
SET WSS-TABLE-MATCH-SW TO 9.
3100-END-OF-LINE-PROC.
MOVE SPACE TO CURR-CHAR.
IF W-HCMD-END-COM = NO-VALUE
SET W-SCMD-IDX TO 1
SEARCH W-SUB-CMD-TABLE
AT END
MOVE CMD-TABLE-ERROR TO CURRENT-ERROR
SET WSS-END-OF-LINE-SW TO YES-VALUE
PERFORM 9999-RECORD-ERROR
WHEN W-SCMD-NAME(W-SCMD-IDX) = 'ENND'
SET WSS-UNIQUE-SW TO NO-VALUE
PERFORM 4000-TABLE-MATCH.
IF NO-ERROR
IF W-HCMD-END-YES
SET COMMAND-PTR TO 1
PERFORM 3110-CHECK-LABLE
IF W-HCMD-SKL-NAME NOT = SPACES
PERFORM 3120-OBTAIN-SKL
IF NO-ERROR
SET WSS-WRITE-FLAG TO YES-VALUE
PERFORM 3130-FILL-SKL
PERFORM 3140-CHECK-COMMENT
MOVE SPACES TO TOKEN-DATA.
SET COMNT-PROC-SW TO NO-VALUE.
IF NO-ERROR
IF W-SCMD-IDX NOT > W-SCMD-MAX-TBL
IF W-SCMD-NXT-TBL(W-SCMD-IDX) NOT = SPACES
MOVE W-SCMD-NXT-TBL(W-SCMD-IDX) TO WSS-TABLE-NAME
PERFORM 9100-LOAD-SUB-CMD-TABLE.
3110-CHECK-LABLE.
IF LABLE NOT = SPACES
STRING LABLE DELIMITED BY '\'
INTO COMMAND-RECORD
WITH POINTER COMMAND-PTR
MOVE SPACES TO LABLE.
3120-OBTAIN-SKL.
* NOTE: FOR NOW, USE REG SEARCH; USE SEARCH ALL WHEN FINAL SIZE OF
* SKL TABLE IS DETERMINED...
SET W-SKL-IDX TO 1.
* SEARCH ALL W-SKL-TABLE
SEARCH W-SKL-TABLE
AT END
MOVE SKL-TABLE-ERROR TO CURRENT-ERROR
SET WSS-END-OF-LINE-SW TO YES-VALUE
PERFORM 9999-RECORD-ERROR
WHEN W-SKL-NAME(W-SKL-IDX) IS = W-HCMD-SKL-NAME
NEXT SENTENCE.
3130-FILL-SKL.
SET SKELETON-PTR TO 1.
MOVE SPACES TO COMMAND-WORK.
PERFORM 3135-LINE-SCAN
UNTIL SKELETON-PTR > MAX-COMMAND-PTR.
3135-LINE-SCAN.
move SPACE to CURRENT-DELIMITER.
unstring W-SKL-DATA(W-SKL-IDX)
delimited by BEGIN-DELIMITER
into COMMAND-WORK
DELIMITER IN CURRENT-DELIMITER
COUNT IN COMMAND-INDEX
pointer SKELETON-PTR.
set COMMAND-INDEX up by 1.
If SKELETON-PTR not> MAX-COMMAND-PTR
move '\' to COMMAND-ARRAY(COMMAND-INDEX).
string COMMAND-WORK delimited by '\'
into COMMAND-RECORD
pointer COMMAND-PTR.
If CURRENT-DELIMITER = BEGIN-DELIMITER
perform 3135-SUBSTITUTE-NAME.
3135-SUBSTITUTE-NAME.
unstring W-SKL-DATA(W-SKL-IDX)
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-COMMAND-PTR
move END-DELIMITER-ERROR to CURRENT-ERROR
perform 9999-RECORD-ERROR
SET WSS-END-OF-LINE-SW TO YES-VALUE
else
perform 3135-FIELD-DATA-NAMES
IF COMNT-NAME
PERFORM 9500-DO-NOTHING
VARYING VAR-IDX FROM 105 BY -1
UNTIL COMMAND-VAR(VAR-IDX) NOT = SPACE
OR VAR-IDX = 1
SET VAR-IDX UP BY 1
MOVE COMNT TO SYMBOL-WORK
PERFORM 9500-DO-NOTHING
VARYING SYMBOL-WORK-PTR FROM 400 BY -1
UNTIL SYMBOL-WORK-ARRAY(SYMBOL-WORK-PTR) NOT = SPACE
OR SYMBOL-WORK-PTR = 1
MOVE SPACE TO SYMBOL-WORK-ARRAY(SYMBOL-WORK-PTR)
MOVE SYMBOL-WORK TO COMNT
STRING COMNT DELIMITED BY SIZE
INTO COMMAND-RECORD
WITH POINTER COMMAND-PTR
MOVE SPACES TO COMNT
ELSE
SET WS-SAVE-PTR TO 0
INSPECT SYMBOL-WORK
TALLYING WS-SAVE-PTR FOR CHARACTERS
BEFORE INITIAL '\'
IF WS-SAVE-PTR + COMMAND-PTR < MAX-COMMAND-PTR
* Allow for a space at end of line for '-' (continuation char)
string SYMBOL-WORK delimited by '\'
into COMMAND-RECORD
pointer COMMAND-PTR
ELSE
SET SYMBOL-WORK-PTR TO 1
PERFORM 3135-BREAK-LINE
UNTIL SYMBOL-WORK-PTR > WS-SAVE-PTR.
3135-FIELD-DATA-NAMES.
IF FILE1-NAME
MOVE FILE1 TO SYMBOL-WORK
ELSE IF FILE2-NAME
MOVE FILE2 TO SYMBOL-WORK
ELSE IF COMNT-NAME
MOVE COMNT TO SYMBOL-WORK
ELSE IF DATA1-NAME
MOVE DATA1 TO SYMBOL-WORK
ELSE IF PROG-NAME
MOVE PROG TO SYMBOL-WORK
ELSE IF STRC1-NAME
MOVE STRC1 TO SYMBOL-WORK
ELSE IF STRC2-NAME
MOVE STRC2 TO SYMBOL-WORK
ELSE IF DIREC-NAME
MOVE DIREC TO SYMBOL-WORK
ELSE IF SWTCH-NAME
MOVE SWTCH TO SYMBOL-WORK
ELSE IF SWTC2-NAME
MOVE SWTC2 TO SYMBOL-WORK.
IF SYMBOL-WORK = SPACES
MOVE '\' TO SYMBOL-WORK.
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.
3135-A.
*PARAGRAPH TO OVERCOME 24-LEVEL NESTING LIMIT ON 'IF-ELSE'.
3135-BREAK-LINE.
IF COMMAND-PTR < MAX-COMMAND-PTR
STRING SYMBOL-WORK-ARRAY(SYMBOL-WORK-PTR)
DELIMITED BY SIZE
INTO COMMAND-RECORD
POINTER COMMAND-PTR
SET SYMBOL-WORK-PTR UP BY 1
ELSE
STRING '-' DELIMITED BY SIZE
INTO COMMAND-RECORD
POINTER COMMAND-PTR
PERFORM 8500-WRITE-COMMAND-LINE
SET COMMAND-PTR TO 5.
3140-CHECK-COMMENT.
IF COMNT NOT = SPACES
PERFORM 9500-DO-NOTHING
VARYING VAR-IDX FROM 105 BY -1
UNTIL COMMAND-VAR(VAR-IDX) NOT = SPACE
OR VAR-IDX = 1
IF VAR-IDX = 1
AND COMMAND-VAR(VAR-IDX) = (SPACE OR WS-TAB)
STRING '$ ' DELIMITED BY SIZE
INTO COMMAND-RECORD
WITH POINTER VAR-IDX
ELSE
SET VAR-IDX UP BY 2.
IF COMNT NOT = SPACES
STRING '!' COMNT DELIMITED BY SIZE
INTO COMMAND-RECORD
WITH POINTER VAR-IDX
MOVE SPACES TO COMNT.
4000-TABLE-MATCH.
IF W-SCMD-NO-EQUIV(W-SCMD-IDX) = YES-VALUE
OR W-HCMD-NO-EQUIV = YES-VALUE
MOVE NO-EQUIV-ERROR TO CURRENT-ERROR
SET WSS-END-OF-LINE-SW TO YES-VALUE
PERFORM 9999-RECORD-ERROR
ELSE
MOVE W-SCMD-FLAGS(W-SCMD-IDX) TO W-HOLD-CMD-FLAGS
IF W-SCMD-TERM(W-SCMD-IDX) = NO-VALUE
MOVE W-SCMD-TOKEN-NAME(W-SCMD-IDX) TO W-HCMD-TOKEN-NAME
MOVE W-SCMD-TOKEN-VALUE(W-SCMD-IDX) TO W-HCMD-TOKEN-VALUE
MOVE W-SCMD-NXT-TBL(W-SCMD-IDX) TO W-HCMD-NXT-TBL
MOVE W-SCMD-SKL-NAME(W-SCMD-IDX) TO W-HCMD-SKL-NAME
ELSE
MOVE WSS-COMMAND TO WSS-NEXT-COMMAND.
IF NO-ERROR
IF W-SCMD-TERM(W-SCMD-IDX) = YES-VALUE
AND W-SCMD-TOKEN-NAME(W-SCMD-IDX) NOT = SPACES
MOVE W-SCMD-TOKEN-NAME(W-SCMD-IDX) TO W-HCMD-TOKEN-NAME.
IF NO-ERROR
IF W-SCMD-TERM(W-SCMD-IDX) = YES-VALUE
AND W-SCMD-TOKEN-VALUE(W-SCMD-IDX) NOT = SPACES
MOVE W-SCMD-TOKEN-VALUE(W-SCMD-IDX) TO W-HCMD-TOKEN-VALUE.
IF W-SCMD-TERM(W-SCMD-IDX) = YES-VALUE
AND W-SCMD-NXT-TBL(W-SCMD-IDX) NOT = SPACES
MOVE W-SCMD-NXT-TBL(W-SCMD-IDX) TO W-HCMD-NXT-TBL.
IF NO-ERROR
IF W-HCMD-NXT-TBL = 'RETURN'
MOVE WSS-RETURN-NAME TO W-HCMD-NXT-TBL
MOVE W-SCMD-NAME(W-SCMD-IDX) TO WSS-NEXT-COMMAND
SET WSS-END-OF-LINE-SW TO NO-VALUE.
IF NO-ERROR
IF W-HCMD-FILE-NEXT-YES
MOVE W-SCMD-TBL-NAME(W-SCMD-IDX) TO WSS-RETURN-NAME
MOVE 'FN1' TO W-HCMD-NXT-TBL
IF CURR-CHAR = (SPACE OR WS-TAB)
MOVE 'SPTAB' TO WSS-NEXT-COMMAND
ELSE
MOVE CURR-CHAR TO WSS-NEXT-COMMAND.
IF NO-ERROR
IF W-SCMD-TOKEN-NAME(W-SCMD-IDX) = 'SAVE'
IF CURR-CHAR = (SPACE OR WS-TAB)
MOVE 'SPTAB' TO WSS-NEXT-COMMAND
ELSE
MOVE CURR-CHAR TO WSS-NEXT-COMMAND.
IF NO-ERROR
IF W-SCMD-TOKEN-NAME(W-SCMD-IDX) = 'FILE1' OR 'FILE2' OR 'SWTCH' OR 'SWTC2'
PERFORM 4100-FILE-DONE.
IF NO-ERROR
IF W-HCMD-IGNORE = NO-VALUE
IF W-HCMD-TOKEN-NAME NOT = SPACES
AND W-SCMD-TOKEN-NAME(W-SCMD-IDX) NOT = 'SAVE'
MOVE W-HCMD-TOKEN-NAME TO ASCII-SUBSTITUTE-NAME
IF W-HCMD-TOKEN-VALUE NOT = SPACES
AND W-HCMD-TOKEN-FIRST = NO-VALUE
STRING W-HCMD-TOKEN-VALUE DELIMITED BY '\'
INTO CT-TOKEN
WITH POINTER CT-IDX
PERFORM 4200-FILL-TOKEN
ELSE
IF W-SCMD-TERM(W-SCMD-IDX) = YES-VALUE
PERFORM 4200-FILL-TOKEN
ELSE
IF WSS-COMMAND NOT = 'ENND'
STRING CURR-CHAR DELIMITED BY SIZE
INTO CT-TOKEN
WITH POINTER CT-IDX
PERFORM 4200-FILL-TOKEN
ELSE
PERFORM 4200-FILL-TOKEN.
IF NO-ERROR
AND W-HCMD-IGNORE = NO-VALUE
AND (W-HCMD-NXT-TBL NOT = SPACES)
MOVE W-HCMD-NXT-TBL TO WSS-TABLE-NAME
PERFORM 9100-LOAD-SUB-CMD-TABLE
MOVE SPACES TO W-HCMD-NXT-TBL.
IF NO-ERROR
IF W-HCMD-TERM-YES
MOVE SPACES TO CT-TOKEN
SET CT-IDX TO 1.
IF NO-ERROR
IF WSS-NEXT-COMMAND = SPACES
MOVE SPACE TO CURR-CHAR
ELSE
SET WSS-END-OF-LINE-SW TO NO-VALUE.
4100-FILE-DONE.
* Check all components of file for spaces. This paragraph may be
* performed when the file has already been written out, prior to adding
* a comma or other addition to the file name.
MOVE SPACES TO CT-TOKEN.
SET CT-IDX TO 1.
IF STRC1 NOT = SPACES
MOVE STRC1 TO CT-TOKEN
PERFORM 4230-PROCESS-STRUCTURE
MOVE CT-TOKEN TO STRC1.
IF DIREC NOT = SPACES
MOVE DIREC TO CT-TOKEN
PERFORM 4110-PROCESS-DIREC
MOVE CT-TOKEN TO DIREC.
IF EXT1 NOT = SPACES
MOVE EXT1 TO CT-TOKEN
PERFORM 4120-SEARCH-EXT
MOVE CT-TOKEN TO EXT1.
MOVE SPACES TO CT-TOKEN.
SET CT-IDX TO 1.
IF STRC1 NOT = SPACES
STRING STRC1 DELIMITED BY '\'
INTO CT-TOKEN
WITH POINTER CT-IDX.
IF DIREC NOT = SPACES
STRING '[' DELIMITED BY SIZE
DIREC DELIMITED BY '\'
']' DELIMITED BY SIZE
INTO CT-TOKEN
WITH POINTER CT-IDX.
IF FILNM NOT = SPACES
STRING FILNM DELIMITED BY '\'
INTO CT-TOKEN
WITH POINTER CT-IDX.
IF EXT1 NOT = SPACES
STRING '.' DELIMITED BY SIZE
EXT1 DELIMITED BY '\'
INTO CT-TOKEN
WITH POINTER CT-IDX.
IF GEN NOT = SPACES
STRING ';' DELIMITED BY SIZE
GEN DELIMITED BY '\'
INTO CT-TOKEN
WITH POINTER CT-IDX.
MOVE SPACES TO DIREC
EXT1
GEN
FILNM
STRC1.
4110-PROCESS-DIREC.
MOVE SPACES TO WSS-DIRECT.
SET W-DIR-IDX TO 1.
* Single character wild card '?' becomes '%' on VAX
INSPECT CT-TOKEN
REPLACING ALL '?' BY '%'.
MOVE CT-TOKEN TO TOKEN-HOLD.
MOVE SPACES TO CT-TOKEN.
SET TH-IDX TO 0.
SET WSS-NUMERIC-SW TO YES-VALUE.
SET TOKEN-END-SW TO NO-VALUE.
COMPUTE HOLD-IDX = TH-IDX - 1.
MOVE 'TABLE1' TO WSS-TABLE-NAME.
PERFORM 9200-LOAD-SUB-DIR-TABLE.
PERFORM 4115-DIREC-REMAINDER
UNTIL TOKEN-END
OR NOT CONTINUE-PROCESSING
OR NOT NO-ERROR.
IF NO-ERROR
IF WSS-DIRECT NOT = SPACES
IF W-DIR-IDX NOT > DIR-MAX
STRING '\' DELIMITED BY SIZE
INTO WSS-DIRECT
WITH POINTER W-DIR-IDX
MOVE WSS-DIRECT TO CT-TOKEN
ELSE
MOVE WSS-DIRECT TO CT-TOKEN.
4115-DIREC-REMAINDER.
MOVE SPACES TO CT-TOKEN.
SET TH-IDX UP BY 1.
IF TH-IDX > TH-MAX
SET TOKEN-END-SW TO YES-VALUE
ELSE
SET CT-IDX TO 1
SET WSS-NUMERIC-SW TO YES-VALUE
COMPUTE HOLD-IDX = TH-IDX - 1
PERFORM 4115-STRING-DATA
UNTIL TH-IDX > TH-MAX
OR TOKEN-HOLD-ARRAY(TH-IDX) = ('.' OR SPACE OR ',' OR '\' OR WS-TAB).
IF CT-TOKEN = SPACES
NEXT SENTENCE
ELSE
PERFORM 4115-DIR-CONVERT.
4115-STRING-DATA.
STRING TOKEN-HOLD-ARRAY(TH-IDX) DELIMITED BY SIZE
INTO CT-TOKEN
WITH POINTER CT-IDX.
IF TOKEN-HOLD-ARRAY(TH-IDX) NOT NUMERIC
SET WSS-NUMERIC-SW TO NO-VALUE.
SET TH-IDX UP BY 1.
4115-DIR-CONVERT.
IF WSS-NUMERIC-FIELD
MOVE CT-TOKEN TO TEMP-TOKEN
MOVE SPACES TO CT-TOKEN
SET WSS-MORE-ZEROES-SW TO YES-VALUE
SET CT-IDX,
TEMP-IDX TO 1
PERFORM 4115-ELIM-LEADING-ZEROES
UNTIL TEMP-IDX > CT-MAX
OR TEMP-TOKEN-ARRAY(TEMP-IDX) = (SPACE OR WS-TAB)
MOVE SPACES TO TEMP-TOKEN.
SET W-SDIR-IDX TO 1.
SEARCH W-SUB-DIR-TABLE
AT END
SET WSS-END-OF-LINE-SW TO YES-VALUE
MOVE NO-DIRECTORY-ERROR TO CURRENT-ERROR
PERFORM 9999-RECORD-ERROR
WHEN W-SDIR-NAME(W-SDIR-IDX) = CT-TOKEN
NEXT SENTENCE.
IF NO-ERROR
IF W-SDIR-NO-EQUIV(W-SDIR-IDX) = YES-VALUE
MOVE NO-EQUIV-ERROR TO CURRENT-ERROR
SET WSS-END-OF-LINE-SW TO YES-VALUE
PERFORM 9999-RECORD-ERROR
ELSE
IF W-SDIR-NEW-DIR(W-SDIR-IDX) NOT = SPACES
IF WSS-DIRECT NOT = SPACES
STRING '.' DELIMITED BY SIZE
W-SDIR-NEW-DIR(W-SDIR-IDX) DELIMITED BY SPACE
INTO WSS-DIRECT
WITH POINTER W-DIR-IDX
ELSE
STRING W-SDIR-NEW-DIR(W-SDIR-IDX) DELIMITED BY SPACE
INTO WSS-DIRECT
WITH POINTER W-DIR-IDX.
IF NO-ERROR
IF W-SDIR-NXT-TBL(W-SDIR-IDX) NOT = SPACES
MOVE W-SDIR-NXT-TBL(W-SDIR-IDX) TO WSS-TABLE-NAME
PERFORM 9200-LOAD-SUB-DIR-TABLE.
4115-ELIM-LEADING-ZEROES.
IF WSS-MORE-ZEROES
IF TEMP-TOKEN-ARRAY(TEMP-IDX) = 0
NEXT SENTENCE
ELSE
SET WSS-MORE-ZEROES-SW TO NO-VALUE
STRING TEMP-TOKEN-ARRAY(TEMP-IDX) DELIMITED BY SIZE
INTO CT-TOKEN
WITH POINTER CT-IDX
ELSE
STRING TEMP-TOKEN-ARRAY(TEMP-IDX) DELIMITED BY SIZE
INTO CT-TOKEN
WITH POINTER CT-IDX.
SET TEMP-IDX UP BY 1.
4120-SEARCH-EXT.
INSPECT CT-TOKEN
REPLACING '\' BY SPACE.
SEARCH ALL W-STANDARD-EXT-TABLE
WHEN W-EXT-OLD(W-EXT-IDX) = CT-TOKEN
MOVE W-EXT-NEW(W-EXT-IDX) TO CT-TOKEN.
PERFORM 9500-DO-NOTHING
VARYING CT-IDX FROM 400 BY -1
UNTIL CT-TOKEN-ARRAY(CT-IDX) NOT = SPACE
OR CT-IDX = 1.
IF CT-IDX < 400
SET CT-IDX UP BY 1
MOVE '\' TO CT-TOKEN-ARRAY(CT-IDX).
4200-FILL-TOKEN.
MOVE ASCII-SUBSTITUTE-NAME TO SUBSTITUTE-NAME.
IF SUBSTITUTE-NAME = 'SWTCH' OR 'SWTC2'
* If the last token was a file or a structure,
* the switch should be strung onto the
* end of the file spec, not after the command in the skeleton 'SWTCH'
* position.
IF WSS-LAST-TOKEN-NAME NOT = SPACES
AND WSS-LAST-TOKEN-NAME = 'FILE1' OR 'FILE2' OR 'STRC1' OR 'STRC2'
MOVE WSS-LAST-TOKEN-NAME TO ASCII-SUBSTITUTE-NAME
SUBSTITUTE-NAME
SET WSS-AVOID-STRC-PROC-FL TO YES-VALUE
ELSE
MOVE ASCII-SUBSTITUTE-NAME TO WSS-LAST-TOKEN-NAME
ELSE
IF SKL-SUB-NAME
MOVE ASCII-SUBSTITUTE-NAME TO WSS-LAST-TOKEN-NAME.
IF TOKEN-NAME
OR SAVE-NAME
OR BLANK-NAME
NEXT SENTENCE
ELSE
IF CT-IDX NOT > CT-MAX
IF CT-TOKEN-ARRAY(CT-IDX) = SPACE
MOVE '\' TO CT-TOKEN-ARRAY(CT-IDX).
IF TOKEN-NAME
OR SAVE-NAME
OR BLANK-NAME
NEXT SENTENCE
ELSE
IF COMNT-NAME
MOVE COMNT TO TOKEN-HOLD
PERFORM 4210-FILL-IT
MOVE TOKEN-HOLD TO COMNT
ELSE
IF FILE1-NAME
MOVE FILE1 TO TOKEN-HOLD
PERFORM 4210-FILL-IT
MOVE TOKEN-HOLD TO FILE1
ELSE
IF FILE2-NAME
MOVE FILE2 TO TOKEN-HOLD
PERFORM 4210-FILL-IT
MOVE TOKEN-HOLD TO FILE2
ELSE
IF DATA1-NAME
MOVE DATA1 TO TOKEN-HOLD
PERFORM 4210-FILL-IT
MOVE TOKEN-HOLD TO DATA1
ELSE
IF LABLE-NAME
MOVE LABLE TO TOKEN-HOLD
PERFORM 4210-FILL-IT
MOVE TOKEN-HOLD TO LABLE
ELSE
IF LABLK-NAME
MOVE LABLE TO TOKEN-HOLD
PERFORM 4220-LOOK-UP-VAR
PERFORM 4210-FILL-IT
MOVE TOKEN-HOLD TO LABLE
ELSE
IF DATLK-NAME
MOVE DATA1 TO TOKEN-HOLD
PERFORM 4220-LOOK-UP-VAR
PERFORM 4210-FILL-IT
MOVE TOKEN-HOLD TO DATA1
ELSE
IF PROG-NAME
MOVE PROG TO TOKEN-HOLD
PERFORM 4210-FILL-IT
MOVE TOKEN-HOLD TO PROG
ELSE
IF EXT1-NAME
MOVE EXT1 TO TOKEN-HOLD
PERFORM 4210-FILL-IT
MOVE TOKEN-HOLD TO EXT1
ELSE
IF FILNM-NAME
MOVE FILNM TO TOKEN-HOLD
PERFORM 4210-FILL-IT
MOVE TOKEN-HOLD TO FILNM
ELSE
IF GEN-NAME
MOVE GEN TO TOKEN-HOLD
PERFORM 4210-FILL-IT
MOVE TOKEN-HOLD TO GEN
ELSE
IF STRC1-NAME
IF WSS-AVOID-STRC-PROC
MOVE STRC1 TO TOKEN-HOLD
PERFORM 4210-FILL-IT
MOVE TOKEN-HOLD TO STRC1
SET WSS-AVOID-STRC-PROC-FL TO NO-VALUE
ELSE
PERFORM 4230-PROCESS-STRUCTURE
MOVE CT-TOKEN-20 TO STRC1
ELSE
IF STRC2-NAME
PERFORM 4230-PROCESS-STRUCTURE
MOVE CT-TOKEN-20 TO STRC2
ELSE
IF DIREC-NAME
MOVE DIREC TO TOKEN-HOLD
PERFORM 4210-FILL-IT
MOVE TOKEN-HOLD TO DIREC
ELSE
IF SWTCH-NAME
MOVE SWTCH TO TOKEN-HOLD
PERFORM 4210-FILL-IT
MOVE TOKEN-HOLD TO SWTCH
ELSE
IF SWTC2-NAME
MOVE SWTC2 TO TOKEN-HOLD
PERFORM 4210-FILL-IT
MOVE TOKEN-HOLD TO SWTC2
ELSE
MOVE SYMBOL-ERROR TO CURRENT-ERROR
SET PROG-PROCESSING-FLAG TO 9
SET WSS-END-OF-LINE-SW TO YES-VALUE
PERFORM 9999-RECORD-ERROR.
IF NOT TOKEN-NAME
MOVE SPACES TO CT-TOKEN
SET CT-IDX TO 1.
4210-FILL-IT.
IF W-HCMD-TOKEN-FIRST = YES-VALUE
IF TOKEN-HOLD = SPACES
MOVE W-HCMD-TOKEN-VALUE TO TOKEN-HOLD
ELSE
MOVE TOKEN-HOLD TO SYMBOL-WORK
PERFORM 9500-DO-NOTHING
VARYING SYMBOL-WORK-PTR FROM 400 BY -1
UNTIL SYMBOL-WORK-ARRAY(SYMBOL-WORK-PTR) NOT = SPACE
STRING W-HCMD-TOKEN-VALUE DELIMITED BY SIZE
INTO SYMBOL-WORK
WITH POINTER SYMBOL-WORK-PTR
MOVE SYMBOL-WORK TO TOKEN-HOLD.
IF TOKEN-HOLD = SPACES
MOVE CT-TOKEN TO TOKEN-HOLD
ELSE
MOVE TOKEN-HOLD TO SYMBOL-WORK
PERFORM 9500-DO-NOTHING
VARYING SYMBOL-WORK-PTR FROM 400 BY -1
UNTIL SYMBOL-WORK-ARRAY(SYMBOL-WORK-PTR) NOT = SPACE
* Note: Position of pointer will cause 'string' to overwrite existing
* delimiter '\' in SYMBOL-WORK, since it should be at the end of the
* field only.
STRING CT-TOKEN '\' DELIMITED BY SIZE
INTO SYMBOL-WORK
WITH POINTER SYMBOL-WORK-PTR
MOVE SYMBOL-WORK TO TOKEN-HOLD.
4220-LOOK-UP-VAR.
SEARCH ALL W-STANDARD-VAR-TABLE
AT END
NEXT SENTENCE
WHEN W-VAR-OLD(W-VAR-IDX) = CT-TOKEN
MOVE W-VAR-NEW(W-VAR-IDX) TO CT-TOKEN.
4230-PROCESS-STRUCTURE.
INSPECT CT-TOKEN
REPLACING ':' BY SPACE
'\' BY SPACE.
SET W-STR-IDX TO 1.
SEARCH W-STRUCTURE-TABLE
WHEN W-STR-OLD(W-STR-IDX) = CT-TOKEN
MOVE W-STR-NEW(W-STR-IDX) TO CT-TOKEN.
PERFORM 9500-DO-NOTHING
VARYING CT-IDX FROM 400 BY -1
UNTIL CT-TOKEN-ARRAY(CT-IDX) NOT = SPACE
OR CT-IDX = 1.
IF CT-IDX < 400
SET CT-IDX UP BY 1
MOVE ':' TO CT-TOKEN-ARRAY(CT-IDX)
IF CT-IDX < 400
SET CT-IDX UP BY 1
MOVE '\' TO CT-TOKEN-ARRAY(CT-IDX).
8000-READ-CTL.
read CONTROL-FILE
at end
set CONTROL-END-SW to YES-VALUE.
8100-READ-COM-TBL.
READ COM-TABLE-FILE
AT END
SET COM-TABLE-END-SW TO YES-VALUE.
8200-READ-DIR-TBL.
READ DIR-TABLE-FILE
AT END
SET DIR-TABLE-END-SW TO YES-VALUE.
8300-READ-SKL.
READ SKELETON-FILE
AT END
SET SKL-END-SW TO YES-VALUE.
8400-READ-STR-TBL.
READ STR-TABLE-FILE
AT END
SET STR-TABLE-END-SW TO YES-VALUE.
8500-WRITE-COMMAND-LINE.
If COMMAND-CHAR (1) = WS-PAGE-EJECT
set LINE-NUMBER TO 0
set PAGE-NUMBER up by 1
else
set LINE-NUMBER up by 100.
PERFORM 9500-DO-NOTHING
VARYING VAR-IDX FROM 105 BY -1
UNTIL COMMAND-VAR(VAR-IDX) NOT = SPACE
OR VAR-IDX = 1.
write COMMAND-2
BEFORE ADVANCING 1 LINE.
set COMMAND-PTR to 1.
move SPACE to COMMAND-RECORD.
If LINE-NUMBER > 99700
move WS-PAGE-EJECT to COMMAND-CHAR (1)
perform 8500-WRITE-COMMAND-LINE.
SET WSS-WRITE-FLAG TO NO-VALUE.
9100-LOAD-SUB-CMD-TABLE.
SET W-SCMD-MAX-TBL TO 0.
MOVE SPACES TO W-SUB-CMD-WHOLE.
SET W-MCMD-IDX TO 1
SEARCH W-MAIN-CMD-TABLE
AT END
DISPLAY '? Main table error -- program aborting.'
SET PROG-PROCESSING-FLAG TO 9
SET WSS-END-OF-LINE-SW TO YES-VALUE
WHEN W-MCMD-TBL-NAME(W-MCMD-IDX) = WSS-TABLE-NAME
SET WSS-SEARCH-FLAG TO 0
SET W-SCMD-IDX
W-SCMD-MAX-TBL TO 1
MOVE W-MAIN-CMD-TABLE(W-MCMD-IDX) TO W-SUB-CMD-TABLE(W-SCMD-IDX)
PERFORM 9110-REST-OF-LOAD
UNTIL WSS-SEARCH-DONE.
9110-REST-OF-LOAD.
SET W-MCMD-IDX,
W-SCMD-IDX UP BY 1.
IF W-MCMD-IDX > W-MCMD-MAX-TBL
SET WSS-SEARCH-FLAG TO 1
ELSE
IF W-MCMD-TBL-NAME(W-MCMD-IDX) = WSS-TABLE-NAME
IF W-SCMD-IDX > W-SCMD-ABS-MAX-TBL
DISPLAY '? Sub-table size exceeded -- program aborting.'
SET PROG-PROCESSING-FLAG TO 9
SET WSS-END-OF-LINE-SW TO YES-VALUE
ELSE
SET W-SCMD-MAX-TBL UP BY 1
MOVE W-MAIN-CMD-TABLE(W-MCMD-IDX) TO W-SUB-CMD-TABLE(W-SCMD-IDX)
ELSE
SET WSS-SEARCH-FLAG TO 1.
9200-LOAD-SUB-DIR-TABLE.
MOVE SPACES TO W-SUB-DIR-WHOLE.
SET W-MDIR-IDX TO 1.
SEARCH W-MAIN-DIR-TABLE
AT END
DISPLAY '? Main table error -- program aborting.'
SET PROG-PROCESSING-FLAG TO 9
SET WSS-END-OF-LINE-SW TO YES-VALUE
WHEN W-MDIR-TBL-NAME(W-MDIR-IDX) = WSS-TABLE-NAME
SET WSS-SEARCH-FLAG TO 0
SET W-SDIR-IDX TO 1
MOVE W-MAIN-DIR-TABLE(W-MDIR-IDX) TO W-SUB-DIR-TABLE(W-SDIR-IDX)
PERFORM 9210-REST-OF-LOAD
UNTIL WSS-SEARCH-DONE.
9210-REST-OF-LOAD.
SET W-MDIR-IDX,
W-SDIR-IDX UP BY 1.
IF W-MDIR-IDX > W-MDIR-MAX-TBL
SET WSS-SEARCH-FLAG TO 1
ELSE
IF W-MDIR-TBL-NAME(W-MDIR-IDX) = WSS-TABLE-NAME
IF W-SDIR-IDX > W-SDIR-MAX-TBL
DISPLAY '? Sub-table size exceeded -- program aborting.'
SET PROG-PROCESSING-FLAG TO 9
SET WSS-END-OF-LINE-SW TO YES-VALUE
ELSE
MOVE W-MAIN-DIR-TABLE(W-MDIR-IDX) TO W-SUB-DIR-TABLE(W-SDIR-IDX)
ELSE
SET WSS-SEARCH-FLAG TO 1.
9300-FIND-MAX.
PERFORM 9500-DO-NOTHING
VARYING CONTROL-PTR FROM 105 BY -1
UNTIL CONTROL-WORK(CONTROL-PTR) NOT = SPACE
OR CONTROL-PTR = 1.
SET MAX-CONTROL-PTR TO CONTROL-PTR.
SET CONTROL-PTR TO 0.
9400-REPLACE-VARIABLES.
SET STRING-END-SW TO NO-VALUE.
PERFORM 9410-STRING-IT
UNTIL STRING-END.
IF WSS-APOSTROPHE
SET CONTROL-PTR UP BY 1
IF CONTROL-WORK(CONTROL-PTR) > "H"
STRING CONTROL-WORK(CONTROL-PTR) "'"
DELIMITED BY SIZE
INTO WSS-CONTROL-REC
WITH POINTER WSS-CTL-IDX
ELSE
MOVE CONTROL-WORK(CONTROL-PTR) TO VAR-CK-1
SEARCH ALL W-STANDARD-VAR-TABLE
WHEN W-VAR-OLD(W-VAR-IDX) = VAR-CHECK
STRING W-VAR-NEW(W-VAR-IDX) DELIMITED BY '\'
"'" DELIMITED BY SIZE
INTO WSS-CONTROL-REC
WITH POINTER WSS-CTL-IDX.
IF CONTROL-PTR < MAX-CONTROL-PTR
PERFORM 9400-REPLACE-VARIABLES.
MOVE SPACES TO CONTROL-WORK-REC
WSS-DELIMITER-CK.
MOVE WSS-CONTROL-REC TO CONTROL-WORK-REC.
9410-STRING-IT.
SET CONTROL-PTR UP BY 1.
STRING CONTROL-WORK(CONTROL-PTR) DELIMITED BY SIZE
INTO WSS-CONTROL-REC
WITH POINTER WSS-CTL-IDX.
MOVE CONTROL-WORK(CONTROL-PTR) TO WSS-DELIMITER-CK.
IF WSS-APOSTROPHE
SET STRING-END-SW TO YES-VALUE.
IF CONTROL-PTR NOT < MAX-CONTROL-PTR
SET STRING-END-SW TO YES-VALUE.
9500-DO-NOTHING.
*---------------------
* Record Error Routine
*---------------------
* 1. Make sure WS-SAVE-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 CONTROL-PTR.
SET STASH-IDX TO 0.
PERFORM 9999A-OUTPUT-STASH
UNTIL STASH-IDX = STASH-MAX.
MOVE SPACES TO STASH-REC-ARRAY.
SET STASH-IDX, STASH-MAX TO 0.
SET COMMAND-PTR TO 1.
STRING '$! ' DELIMITED BY SIZE
INTO COMMAND-RECORD
POINTER COMMAND-PTR.
SET CONTROL-PTR TO WS-SAVE-PTR.
COMPUTE COMMAND-PTR = (CONTROL-PTR - SAV-IDX) + 4.
string '^' delimited by SIZE
into COMMAND-RECORD
pointer COMMAND-PTR.
SUBTRACT ERROR-LENGTH
from MAX-COMMAND-PTR giving ERROR-LINE-PTR.
If COMMAND-PTR > ERROR-LINE-PTR
subtract ERROR-LENGTH,1 from COMMAND-PTR.
string ERROR-TEXT delimited by '\'
into COMMAND-RECORD
pointer COMMAND-PTR.
perform 8500-WRITE-COMMAND-LINE.
set ERROR-NUMBER up by 1.
set ERROR-SW TO 1.
display 'Error # ' ERROR-NUMBER.
MOVE 'TABLE1' TO WSS-TABLE-NAME.
PERFORM 9100-LOAD-SUB-CMD-TABLE.
PERFORM 9200-LOAD-SUB-DIR-TABLE.
MOVE ZEROES TO W-HOLD-CMD-FLAGS.
MOVE SPACES TO CT-TOKEN
CURR-CHAR
WSS-NEXT-COMMAND
WSS-COMMAND.
SET CT-IDX TO 1.
MOVE SPACES TO TOKEN-DATA.
IF CONTROL-WORK(MAX-CONTROL-PTR) = '-'
PERFORM 9999B-COMMENT-REMAINDER.
9999A-OUTPUT-STASH.
SET STASH-IDX UP BY 1.
MOVE '$! ' TO STASH-COM(STASH-IDX).
MOVE STASH-REC(STASH-IDX) TO COMMAND-RECORD.
PERFORM 8500-WRITE-COMMAND-LINE.
MOVE SPACE TO COMMAND-RECORD.
9999B-COMMENT-REMAINDER.
PERFORM 8000-READ-CTL.
IF NOT CONTROL-END
PERFORM 9300-FIND-MAX
STRING '$! ' CTL-STASH-REC DELIMITED BY SIZE
INTO COMMAND-RECORD
PERFORM 8500-WRITE-COMMAND-LINE
IF CONTROL-WORK(MAX-CONTROL-PTR) = '-'
SET WS-SAVE-PTR TO 0
INSPECT CONTROL-RECORD
TALLYING WS-SAVE-PTR
FOR ALL '!'
WS-SAVE-PTR FOR ALL ';'
IF WS-SAVE-PTR = 0
PERFORM 9999B-COMMENT-REMAINDER.