Trailing-Edge
-
PDP-10 Archives
-
tops20tools_v6_9-jan-86_dumper
-
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.
02 CTL-FIRST-CHAR PIC X(001).
88 CTL-COMMENT VALUE ';' '!'.
88 CTL-BYPASS VALUE '*' '.'.
*& MAYBE MORE?
88 CTL-FIRST-SPACE VALUE ' '.
02 CTL-REMAINDER PIC X(104).
01 CONTROL-WORK-REC display-7.
02 CONTROL-WORK pic X(001) occurs 105.
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.
05 FILLER PIC X(010).
05 SKELETON-BODY PIC X(105).
*
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
*=============================================================
*& TEMP AMT
01 W-MAIN-CMD-TABLE OCCURS 999
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-CHAR REDEFINES
W-MCMD-NAME PIC X(01)
OCCURS 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).
* VALUES FOR NEXT SWITCH: 0=NO, 1=YES, 2=MAYBE!
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).
*& TEMP AMT
01 W-MCMD-MAX-TBL PIC S9(03) COMP VALUE 999.
01 WSS-TABLE-NAME PIC X(10).
01 WSS-RETURN-NAME PIC X(10).
01 W-SUB-CMD-WHOLE.
*& TEMP AMT
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).
* VALUES FOR NEXT SWITCH: 0=NO, 1=YES, 2=MAYBE!
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(03) COMP.
01 W-SCMD-ABS-MAX-TBL PIC S9(03) COMP VALUE 999.
01 W-SCMD-MAX-CHAR PIC S9(01) COMP VALUE 6.
*& TEMP AMT
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).
*& TEMP AMT
01 W-MDIR-MAX-TBL PIC S9(03) COMP VALUE 999.
01 W-SUB-DIR-WHOLE.
*& TEMP AMT
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).
*& TEMP AMT
01 W-SDIR-MAX-TBL PIC S9(03) COMP VALUE 999.
01 WSS-MORE-ZEROES-SW PIC S9(01) COMP.
88 WSS-NO-MORE-ZEROES VALUE 0.
88 WSS-MORE-ZEROES 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-SAME-YES VALUE 1.
88 W-HCMD-SAME-EXC VALUE 2.
* VALUES FOR NEXT SWITCH: 0=NO, 1=YES, 2=MAYBE!
05 W-HCMD-FILE-NEXT PIC 9(01).
88 W-HCMD-FILE-NEXT-YES VALUE 1.
88 W-HCMD-FILE-NEXT-MBE VALUE 2.
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).
*& TEMP AMT
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).
*& TEMP AMT
01 W-STR-MAX-TBL PIC S9(03) COMP VALUE 999.
*& TEMP AMT
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).
*& TEMP AMT
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'.
*& TEMP AMT
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).
*========== 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 105.
01 CT-TOKEN
pic X(105).
01 filler redefines CT-TOKEN.
02 CT-TOKEN-1 pic X(01).
02 filler pic X(104).
01 filler redefines CT-TOKEN.
02 CT-TOKEN-2 pic X(02).
02 filler pic X(103).
01 filler redefines CT-TOKEN.
02 CT-TOKEN-3 pic X(03).
02 filler pic X(102).
01 filler redefines CT-TOKEN.
02 CT-TOKEN-4 pic X(04).
02 filler pic X(101).
01 filler redefines CT-TOKEN.
02 CT-TOKEN-5.
04 filler pic X(03).
04 CT-TOKEN-5-2 pic X(02).
02 filler pic X(100).
01 filler redefines CT-TOKEN.
02 CT-TOKEN-6 pic X(06).
02 filler pic X(099).
01 filler redefines CT-TOKEN.
02 CT-TOKEN-7 pic X(07).
02 filler pic X(098).
01 filler redefines CT-TOKEN.
02 CT-TOKEN-10 pic X(10).
02 filler pic X(95).
01 filler redefines CT-TOKEN.
02 CT-TOKEN-15 pic X(15).
02 filler pic X(90).
01 filler redefines CT-TOKEN.
02 CT-TOKEN-16 pic X(16).
02 filler pic X(89).
01 filler redefines CT-TOKEN.
02 CT-TOKEN-20 PIC X(20).
02 filler pic X(85).
01 filler redefines CT-TOKEN.
02 CT-TOKEN-30 pic X(30).
02 filler pic X(75).
01 filler redefines CT-TOKEN.
02 CT-TOKEN-40 pic X(40).
02 filler pic X(65).
01 filler redefines CT-TOKEN.
02 CT-TOKEN-80 pic X(80).
02 filler pic X(25).
01 CT-TOKEN-ASCII redefines
CT-TOKEN pic X(105).
01 CT-TOKEN-ARRAY redefines CT-TOKEN
occurs 105
indexed by CT-IDX
pic X(01).
01 TOKEN-HOLD
pic X(105).
01 TOKEN-HOLD-ARRAY redefines TOKEN-HOLD
occurs 105
indexed by TH-IDX
pic X(01).
01 TH-MAX PIC S9(03) COMP VALUE 105.
01 HOLD-IDX USAGE INDEX.
*&01 HOLD-CHAR PIC X(01).
01 CURR-CHAR PIC X(01).
01 TOKEN-END-SW pic S9(01) comp.
88 TOKEN-END value 1.
01 TEMP-TOKEN PIC X(105).
01 TEMP-TOKEN-ARRAY REDEFINES
TEMP-TOKEN PIC X(001)
OCCURS 105
INDEXED BY TEMP-IDX.
01 WSS-FILE-DATA.
05 WSS-STRUCTURE PIC X(16).
05 WSS-FILE-ID.
10 WSS-FILE-NAME PIC X(06).
10 WSS-FILE-EXT PIC X(03).
05 WSS-DIRECT PIC X(80).
05 WSS-DIRECT-ARRAY REDEFINES
WSS-DIRECT PIC X(01)
OCCURS 80
INDEXED BY W-DIR-IDX.
05 WSS-OLD-PROT PIC 9(03).
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) VALUE 'CTL'.
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 > '.
01 TEST-PIC DISPLAY-6.
88 DATE-PIC value 'DATE@'.
02 TEST-PIC-ARRAY occurs 20
indexed by TEST-PIC-INDEX
pic X(01).
01 PRT-PIC display-6.
02 PRT-PIC-ARRAY occurs 20
indexed by PRT-PIC-INDEX
pic X(01).
01 PRT-PIC-LEFT usage index.
01 PRT-PIC-RIGHT usage index.
01 CHAR-COUNT usage index.
01 TEMP-INDEX usage index.
*=============================================================
* M A C R O E X P A N S I O N W S
*=============================================================
*----------------
* Command Data
*----------------
*
01 LINE-POINTERS.
02 HOLD-PTR PIC S9(03) COMP.
02 CONTROL-PTR pic S9(03) comp.
02 MAX-CONTROL-PTR pic S9(03) comp.
02 LAST-CONTROL-PTR PIC S9(03) 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 105.
02 LAST-COMMAND-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 WSS-CONTROL.
05 WSS-CONTROL-FIRST PIC X(105).
05 WSS-CONTROL-WORK REDEFINES
WSS-CONTROL-FIRST OCCURS 105
INDEXED BY WSS-CTL-IDX
PIC X(001).
05 WSS-CONTROL-SECOND PIC X(105).
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 COMMAND-STATE-SWITCHES.
02 COMMAND-VALID-SW pic S9(01) comp.
88 COMMAND-VALID value 1.
02 SKL-END-SW pic S9(01) comp.
88 SKL-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.
88 IS-ERROR 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 COMNT-NAME VALUE 'COMNT'.
88 DATA1-NAME VALUE 'DATA1'.
88 DATA2-NAME VALUE 'DATA2'.
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 LABLE-NAME VALUE 'LABLE'.
88 PROG-NAME VALUE 'PROG'.
88 SAVE-NAME VALUE 'SAVE'.
88 STRC1-NAME VALUE 'STRC1'.
88 STRC2-NAME VALUE 'STRC2'.
*& 88 SVALU-NAME VALUE 'SVALU'.
88 SWTCH-NAME VALUE 'SWTCH'.
88 TOKEN-NAME VALUE 'TOKEN'.
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 WSS-LAST-TOKEN-NAME PIC X(06).
01 TOKEN-DATA.
02 COMNT PIC X(105).
02 DATA1 PIC X(105).
02 DATA2 PIC X(105).
02 DIREC PIC X(105).
02 EXT1 PIC X(105).
02 FILE1 PIC X(105).
02 FILE2 PIC X(105).
02 FILNM PIC X(105).
02 LABLE PIC X(105).
02 PROG PIC X(105).
02 STRC1 PIC X(105).
02 STRC2 PIC X(20).
02 SWTCH PIC X(105).
02 TOKEN PIC X(105).
*& NO SVALU FIELD -- 'NAME' ALONE IS USED TO ALERT NEED FOR '=' IN
*& STRING INSTEAD OF '/'
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 COM-TABLE-FILE-EXT PIC X(03) VALUE 'TBL'.
01 STR-TABLE-FILE-ID.
02 STR-TABLE-FILE-NAME PIC X(06).
02 STR-TABLE-FILE-EXT PIC X(03) VALUE 'TBL'.
01 DIR-TABLE-FILE-ID.
02 DIR-TABLE-FILE-NAME PIC X(06).
02 DIR-TABLE-FILE-EXT PIC X(03) VALUE 'TBL'.
01 SKELETON-FILE-ID.
02 SKELETON-FILE-NAME pic X(06) VALUE 'VAXCOM'.
02 SKELETON-FILE-EXT pic X(03) VALUE 'SKL'.
01 COMMAND-FILE-ID.
02 COMMAND-FILE-NAME pic X(06).
02 COMMAND-FILE-EXT pic X(03) VALUE 'COM'.
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-SAVE pic S9(01) comp.
01 CONTROL-FILE-STATUS PIC S9(01) COMP VALUE 0.
88 CONTROL-FILE-CLOSED VALUE 0.
88 CONTROL-FILE-OPEN VALUE 1.
01 SKL-STATUS PIC S9(01) COMP VALUE 0.
88 SKL-FILE-CLOSED VALUE 0.
88 SKL-FILE-OPEN VALUE 1.
01 COMMAND-FILE-STATUS PIC S9(01) COMP VALUE 0.
88 COMMAND-FILE-CLOSED VALUE 0.
88 COMMAND-FILE-OPEN VALUE 1.
*=========================================================
* S C R A T C H P A D
*=========================================================
* 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.
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 RESERVED-VARIABLE-ERROR pic X(40)
value '30 Undefined reserved variable. @'.
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-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(10) 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 WSS-LEVEL PIC 9(01) COMP.
88 WSS-LEVEL-NOT-SET VALUE 0.
88 WSS-OPER-LEVEL VALUE 1.
88 WSS-USER-LEVEL VALUE 2.
88 WSS-LEVEL-SET VALUES 1, 2.
01 WSS-CHAR-CHECK PIC X(01).
*& TEMP VAL
88 WSS-OPER-CHAR VALUE '.' '@'.
88 WSS-USER-CHAR VALUE '*'.
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-PERIOD VALUE '.'.
88 WSS-COMMA VALUE ','.
88 WSS-COLON VALUE ':'.
88 WSS-SEMICOLON VALUE ';'.
88 WSS-ASTERISK VALUE '*'.
88 WSS-LEFT-ANGLE VALUE '<'.
88 WSS-RIGHT-ANGLE VALUE '>'.
88 WSS-LEFT-BRACKET VALUE '['.
88 WSS-RIGHT-BRACKET VALUE ']'.
88 WSS-AT-SIGN VALUE '@'.
88 WSS-EXCLAMATION VALUE '!'.
88 WSS-QUESTION VALUE '?'.
01 WSS-FL-DELIMITER-CK PIC X(01) VALUE 'X'.
88 WSS-FL-NO-DELIMITER VALUE 'X'.
88 WSS-FL-PERIOD VALUE '.'.
88 WSS-FL-COMMA VALUE ','.
88 WSS-FL-COLON VALUE ':'.
88 WSS-FL-SEMICOLON VALUE ';'.
88 WSS-FL-ASTERISK VALUE '*'.
88 WSS-FL-LEFT-ANGLE VALUE '<'.
88 WSS-FL-RIGHT-ANGLE VALUE '>'.
88 WSS-FL-LEFT-BRACKET VALUE '['.
88 WSS-FL-RIGHT-BRACKET VALUE ']'.
88 WSS-FL-AT-SIGN VALUE '@'.
88 WSS-FL-EXCLAMATION VALUE '!'.
88 WSS-FL-QUESTION VALUE '?'.
01 WSS-LAST-DELIMITER-CK PIC X(01) VALUE 'X'.
88 WSS-LAST-NO-DELIMITER VALUE 'X'.
88 WSS-LAST-PERIOD VALUE '.'.
88 WSS-LAST-COMMA VALUE ','.
88 WSS-LAST-COLON VALUE ':'.
88 WSS-LAST-SEMICOLON VALUE ';'.
88 WSS-LAST-ASTERISK VALUE '*'.
88 WSS-LAST-LEFT-ANGLE VALUE '<'.
88 WSS-LAST-RIGHT-ANGLE VALUE '>'.
88 WSS-LAST-LEFT-BRACKET VALUE '['.
88 WSS-LAST-RIGHT-BRACKET VALUE ']'.
88 WSS-LAST-AT-SIGN VALUE '@'.
88 WSS-LAST-EXCLAMATION VALUE '!'.
88 WSS-LAST-QUESTION VALUE '?'.
01 WSS-HOLD-DELIMITER PIC X(01).
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-COMMENT PIC X(105).
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
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
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 SKELETON-FILE
PERFORM 0120-LOAD-SKELETON-FILE
UNTIL SKL-END
CLOSE SKELETON-FILE
IF CONTINUE-PROCESSING
OPEN INPUT STR-TABLE-FILE
PERFORM 0130-LOAD-STR-TABLE-FILE
UNTIL STR-TABLE-END
CLOSE STR-TABLE-FILE
IF CONTINUE-PROCESSING
OPEN INPUT DIR-TABLE-FILE
PERFORM 0140-LOAD-DIR-TABLE-FILE
UNTIL DIR-TABLE-END
CLOSE DIR-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-SKELETON-FILE.
PERFORM 8200-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).
0130-LOAD-STR-TABLE-FILE.
PERFORM 8300-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).
0140-LOAD-DIR-TABLE-FILE.
PERFORM 8400-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).
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 9900-LOAD-SUB-CMD-TABLE.
IF CONTINUE-PROCESSING
PERFORM 9500-LOAD-SUB-DIR-TABLE.
IF CONTINUE-PROCESSING
*& SET ANY SWITCHES? CHECK FOLLOWING...
MOVE 0 TO LINE-NUMBER,
W-HOLD-CMD-FLAGS
ERROR-NUMBER
ERROR-SW
WSS-UNIQUE-SW
SET SKELETON-PTR,
COMMAND-PTR,
PAGE-NUMBER,
WSS-LEVEL,
ERROR-LINE-PTR TO 1
MOVE SPACE TO ERROR-LINE,
SUBSTITUTE-NAME
perform 1000-CREATE-COMMAND-FILE
UNTIL CONTROL-END
*& OR NOT CONTINUE OR ERROR?
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
move 'CTL' 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.
PERFORM 9710-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
*& HOLD-CHAR
CT-TOKEN
WSS-SAVE-COMMAND
WSS-LAST-TOKEN-NAME.
SET CONTROL-COUNT
LAST-CONTROL-PTR TO 0.
* Initial level is 1 -- operating system level
*& LEVEL SHOULD BE SET FOR CONT LINES ('-') FURTHER COMMANDS (',')...
*& OR USER LEVEL? TO GO BACK TO OPER LEVEL...
IF WSS-LEVEL-NOT-SET
PERFORM 2010-SET-LEVEL
UNTIL WSS-LEVEL-SET
OR WSS-END-OF-LINE.
IF WSS-OPER-LEVEL
*& IF WSS-TABLE-NAME NOT = 'TABLE1'
*& MOVE 'TABLE1' TO WSS-TABLE-NAME
*& PERFORM 9900-LOAD-SUB-CMD-TABLE
PERFORM 3000-OPER-LEVEL
UNTIL WSS-END-OF-LINE
SET WSS-END-OF-LINE-SW TO NO-VALUE
MOVE 'END' TO WSS-NEXT-COMMAND
PERFORM 3000-OPER-LEVEL
UNTIL WSS-END-OF-LINE
PERFORM 3200-END-OF-LINE-PROC
*& ELSE
*& PERFORM 3000-OPER-LEVEL
*& UNTIL WSS-END-OF-LINE
*& IF NO-ERROR
*& SET WSS-END-OF-LINE-SW TO NO-VALUE
*& MOVE 'END' TO WSS-NEXT-COMMAND
*& PERFORM 3000-OPER-LEVEL
*& UNTIL WSS-END-OF-LINE
*& PERFORM 3200-END-OF-LINE-PROC
*& ELSE
*& NEXT SENTENCE
ELSE
IF WSS-USER-LEVEL
*& MOVE IN APPROPRIATE TABLE?
PERFORM 4000-USER-LEVEL
UNTIL WSS-END-OF-LINE.
IF NO-ERROR
IF WSS-USER-LEVEL
OR (W-HCMD-END-COM = YES-VALUE
AND (WSS-OPER-LEVEL))
*& AND LINE NOT CONTINUING? (-)
*& MOVE 'TABLE1' TO WSS-TABLE-NAME
*& PERFORM 9900-LOAD-SUB-CMD-TABLE
*& PERFORM 9500-LOAD-SUB-DIR-TABLE
IF COMMAND-RECORD NOT = SPACES
OR (WSS-DO-WRITE)
MOVE ZEROES TO W-HOLD-CMD-FLAGS
*& MOVE SPACES TO TOKEN-DATA
PERFORM 8500-WRITE-COMMAND-LINE
ELSE
NEXT SENTENCE
ELSE
NEXT SENTENCE
ELSE
SET ERROR-SW TO 0.
2010-SET-LEVEL.
*& THIS NEEDS THOUGHT...
SET CONTROL-PTR UP BY 1.
MOVE CONTROL-WORK(CONTROL-PTR) TO WSS-CHAR-CHECK
IF WSS-USER-CHAR
OR WSS-OPER-CHAR
SET CONTROL-PTR UP BY 1
IF WSS-OPER-CHAR
MOVE 1 TO WSS-LEVEL
ELSE
IF WSS-USER-CHAR
MOVE 2 TO WSS-LEVEL.
3000-OPER-LEVEL.
IF CT-TOKEN = SPACES
SET CT-IDX TO 1.
IF WSS-SAVE-COMMAND = SPACES
SET SAV-IDX TO 1.
*&
*& DISPLAY 'HOLD-CHAR ' HOLD-CHAR ' WSS-COMMAND ' WSS-COMMAND.
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) = '-'
*&
*SHOULD THE FOLLOWING BE HANDLED IN THE TABLES?
PERFORM 9700-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.
*& ELSE
*&
DISPLAY 'CURR-CHAR ' CURR-CHAR ' CONTROL-PTR ' CONTROL-PTR
*& IF NOT WSS-END-OF-LINE
IF WSS-NEXT-COMMAND = SPACES
*& IF W-HCMD-DATA-NEXT = YES-VALUE
*& MOVE 'DATA' TO WSS-COMMAND
*& ELSE
MOVE CURR-CHAR TO WSS-COMMAND
ELSE
MOVE WSS-NEXT-COMMAND TO WSS-COMMAND
MOVE SPACES TO WSS-NEXT-COMMAND.
*& IF NOT WSS-END-OF-LINE
IF WSS-COMMAND = (SPACE OR WS-TAB)
MOVE 'SPTAB' TO WSS-COMMAND.
*& ELSE
*& PERFORM 3200-END-OF-LINE-PROC
*& ELSE
*& 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 NOT WSS-END-OF-LINE
IF NO-ERROR
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 WSS-COMMAND-ARRAY(2) = SPACES
AND (WSS-COMMAND-ARRAY(1) ALPHABETIC
OR WSS-COMMAND-ARRAY(1) NUMERIC)
PERFORM S1
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
SET WSS-TABLE-MATCH-SW TO 9
PERFORM Q1
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
PERFORM R1
SET WSS-TABLE-MATCH-SW TO 9.
*& IF NOT WSS-END-OF-LINE
IF NO-ERROR
IF (WSS-TABLE-NO-MATCH)
AND (WSS-COMMAND = WSS-COMMAND-ARRAY(1))
* SEARCH AGAIN IF COMMAND IS SINGLE CHARACTER
PERFORM 3115-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 NOT WSS-END-OF-LINE
IF NO-ERROR
IF WSS-TABLE-MATCH
SET WSS-UNIQUE-SW TO NO-VALUE
MOVE SPACES TO WSS-SAVE-COMMAND
PERFORM 9200-TABLE-MATCH
ELSE
IF WSS-TABLE-NO-MATCH
PERFORM 3110-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 9900-LOAD-SUB-CMD-TABLE
STRING WSS-SAVE-COMMAND DELIMITED BY SPACE
INTO CT-TOKEN
WITH POINTER CT-IDX
MOVE SPACES TO WSS-SAVE-COMMAND
PERFORM F1
ELSE
*& ERROR
MOVE NO-EQUIV-ERROR TO CURRENT-ERROR
SET WSS-END-OF-LINE-SW TO YES-VALUE
PERFORM 9999-RECORD-ERROR
*& DISPLAY 'ERROR!' W-SCMD-CHAR(HOLD-IDX,SAV-IDX - 1) ' ' WSS-SAVE-COMMAND-ARRAY(SAV-IDX - 1)
PERFORM F1
*& DISPLAY 'CT-TOKEN ' CT-TOKEN ' CT-IDX ' CT-IDX
ELSE
*& IF W-SCMD-NXT-TBL(HOLD-IDX) NOT = SPACES
MOVE W-SCMD-NXT-TBL(HOLD-IDX) TO W-HCMD-NXT-TBL
MOVE W-SCMD-SKL-NAME(HOLD-IDX) TO W-HCMD-SKL-NAME
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
*&NOTE: MORE THINGS MAY NEED TO BE MOVED -- SEE 9200
*& ELSE
*& NEXT SENTENCE
ELSE
SET WSS-TABLE-MATCH-SW TO 0
*& MOVE CT-TOKEN-10 TO WSS-COMMAND
MOVE WSS-SAVE-COMMAND TO WSS-COMMAND
PERFORM 3120-SEARCH-TABLE
IF WSS-UNIQUE
*& AND W-SCMD-NXT-TBL(HOLD-IDX) NOT = SPACES
MOVE W-SCMD-NXT-TBL(HOLD-IDX) TO W-HCMD-NXT-TBL
MOVE W-SCMD-SKL-NAME(HOLD-IDX) TO W-HCMD-SKL-NAME
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
ELSE
IF WSS-TABLE-NO-MATCH
IF WSS-TABLE-NAME = 'PROGNAM'
MOVE 'USRPROG' TO WSS-TABLE-NAME
PERFORM 9900-LOAD-SUB-CMD-TABLE
STRING WSS-SAVE-COMMAND DELIMITED BY SPACE
INTO CT-TOKEN
WITH POINTER CT-IDX
PERFORM D1
ELSE
*& PERFORM 3120-SEARCH-TABLE
*& IF WSS-TABLE-NO-MATCH
*& ERROR
MOVE NO-EQUIV-ERROR TO CURRENT-ERROR
SET WSS-END-OF-LINE-SW TO YES-VALUE
PERFORM 9999-RECORD-ERROR
*& DISPLAY 'ABORT ON COMMAND ' WSS-COMMAND
*&
PERFORM D1
SET WSS-END-OF-LINE-SW TO YES-VALUE.
IF WSS-NEXT-COMMAND NOT = SPACES
SET WSS-END-OF-LINE-SW TO NO-VALUE.
PERFORM X1.
*& SET PROG-PROCESSING-FLAG TO 9.
*& ELSE
*& IF WSS-TABLE-MATCH
*& PERFORM 9200-TABLE-MATCH.
*& IF WSS-END-OF-LINE
*& PERFORM 3200-END-OF-LINE-PROC.
*&
D1.
F1.
X1.
Q1.
R1.
S1.
3110-STRING-COMMAND.
*& SHOULD THIS BE CURR-CHAR INSTEAD OF CONTROL?
*& STRING CONTROL-WORK(CONTROL-PTR) DELIMITED BY SIZE
STRING CURR-CHAR DELIMITED BY SIZE
*& INTO CT-TOKEN
*& WITH POINTER CT-IDX.
INTO WSS-SAVE-COMMAND
WITH POINTER SAV-IDX.
*& SET CONTROL-PTR UP BY 1.
3115-DETERMINE-TYPE.
IF WSS-COMMAND-ARRAY(1) ALPHABETIC
OR WSS-COMMAND-ARRAY(1) NUMERIC
MOVE 'ALPHAN' TO WSS-COMMAND
ELSE
MOVE 'NONALP' TO WSS-COMMAND.
3120-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 3125-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 3125-REST-OF-SEARCH
UNTIL WSS-TABLE-MATCH-END
IF WSS-TABLE-PART-MATCH
* Duplicate - key word is not unique in table, so no match
*& SET WSS-TABLE-MATCH-SW TO 9
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.
3125-REST-OF-SEARCH.
* If WSS-COMMAND is one character long, it must match exactly.
*& IF WSS-COMMAND-ARRAY(2) = SPACE
*& IF W-SCMD-NAME(W-SCMD-IDX) NOT = WSS-COMMAND
*& SET WSS-TABLE-MATCH-SW TO 9
*& ELSE
*& SET WSS-TABLE-MATCH-SW TO 1.
* 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 NOT WSS-TABLE-MATCH-END
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
OR WSS-COMMAND-ARRAY(CM-IDX) = SPACE
AND W-SCMD-CHAR(W-SCMD-IDX,CM-IDX) = SPACE
SET WSS-TABLE-MATCH-SW TO 1
ELSE
IF WSS-COMMAND-ARRAY(CM-IDX) = SPACE
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
*& IF W-SCMD-IDX > W-SCMD-MAX-TBL
*& SET WSS-TABLE-MATCH-SW TO 9
*& ELSE
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.
3132-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 9500-LOAD-SUB-DIR-TABLE.
PERFORM 3132-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.
3132-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 9311-STRING-DATA
UNTIL TH-IDX > TH-MAX
OR TOKEN-HOLD-ARRAY(TH-IDX) = (SPACE OR ',' OR '@').
*&
*&DISPLAY TH-IDX ' ' WSS-FL-DELIMITER-CK ' ' CT-TOKEN
IF CT-TOKEN = SPACES
NEXT SENTENCE
ELSE
PERFORM 9314-DIR-CONVERT.
3132-DIR-PROT-CONVERT.
*& DO SOMETHING ABOUT PROTECTION HERE? OR WHERE?
3200-END-OF-LINE-PROC.
MOVE SPACE TO CURR-CHAR.
IF W-HCMD-END-COM = NO-VALUE
*& OR SCMD? ALSO SEE BELOW...
SET W-SCMD-IDX TO 1
SEARCH W-SUB-CMD-TABLE
*& AT END
*& DISPLAY '? No "end" in sub-table -- program aborting.'
*& SET PROG-PROCESSING-FLAG TO 9
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) = 'END'
SET WSS-UNIQUE-SW TO NO-VALUE
PERFORM 9200-TABLE-MATCH.
*& THIS NEEDS FIXING...
*& IF CONTINUE-PROCESSING
IF NO-ERROR
IF W-HCMD-END-COM = YES-VALUE
SET COMMAND-PTR TO 1
PERFORM 3230-CHECK-LABLE
IF W-HCMD-SKL-NAME NOT = SPACES
PERFORM 3210-OBTAIN-SKL
IF CONTINUE-PROCESSING
SET WSS-WRITE-FLAG TO YES-VALUE
PERFORM 3220-FILL-SKL
PERFORM 3240-CHECK-COMMENT.
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
*& ELSE
*& MOVE 'TABLE1' TO WSS-TABLE-NAME
*& ELSE
*& MOVE 'TABLE1' TO WSS-TABLE-NAME.
PERFORM 9900-LOAD-SUB-CMD-TABLE.
3210-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
*& DISPLAY '? Skeleton table error -- program aborting.'
*& SET PROG-PROCESSING-FLAG TO 9
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.
3220-FILL-SKL.
SET SKELETON-PTR TO 1.
*& MAX MAY NOT WORK, BECAUSE SKL PTR NOT ALLOWING FOR SIZE OF LABLE...
MOVE SPACES TO COMMAND-WORK.
PERFORM 9400-LINE-SCAN
UNTIL SKELETON-PTR > MAX-COMMAND-PTR.
MOVE SPACES TO TOKEN-DATA.
3230-CHECK-LABLE.
IF LABLE NOT = SPACES
STRING LABLE DELIMITED BY '@'
INTO COMMAND-RECORD
WITH POINTER COMMAND-PTR
MOVE SPACES TO LABLE.
3240-CHECK-COMMENT.
*& THIS IS CRUDE...NO CHECKING FOR RECORD OVERFLOW
IF COMNT NOT = SPACES
PERFORM 9800-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
STRING ' !' COMNT DELIMITED BY SIZE
INTO COMMAND-RECORD
WITH POINTER COMMAND-PTR
MOVE SPACES TO COMNT.
4000-USER-LEVEL.
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-SKL.
READ SKELETON-FILE
AT END
SET SKL-END-SW TO YES-VALUE.
8300-READ-STR-TBL.
READ STR-TABLE-FILE
AT END
SET STR-TABLE-END-SW TO YES-VALUE.
8400-READ-DIR-TBL.
READ DIR-TABLE-FILE
AT END
SET DIR-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 9800-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.
*& DETERMINE, SOMEWHERE, WHAT THE NEXT LEVEL (OPER OR USER) IS GOING
*& TO BE AND, IF NECC, BLANK OUT CURRENT SUB-TABLE AND MOVE MAIN TABLE
*& BACK IN... HERE? AND WHAT DETERMINES NEXT LEVEL -- SWITCH IN CURR
*& SUB-TABLE? AND WHAT ABOUT ONES WHERE YOU'RE NOT SURE?
9100-EAT-SPACES.
Set CONTROL-PTR up by 1.
9200-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
PERFORM A1
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
*& IF CURR-CHAR = SPACE
*& MOVE 'SPTAB' TO WSS-NEXT-COMMAND
*& ELSE
*& MOVE CURR-CHAR TO WSS-NEXT-COMMAND
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
PERFORM B1.
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
PERFORM C1
SET WSS-END-OF-LINE-SW TO NO-VALUE.
IF NO-ERROR
IF W-HCMD-FILE-NEXT = YES-VALUE
MOVE W-SCMD-TBL-NAME(W-SCMD-IDX) TO WSS-RETURN-NAME
MOVE 'FN1' TO W-HCMD-NXT-TBL
IF CURR-CHAR = SPACE
MOVE 'SPTAB' TO WSS-NEXT-COMMAND
ELSE
MOVE CURR-CHAR TO WSS-NEXT-COMMAND
PERFORM E1.
IF NO-ERROR
IF W-SCMD-TOKEN-NAME(W-SCMD-IDX) = 'SAVE'
IF CURR-CHAR = SPACE
MOVE 'SPTAB' TO WSS-NEXT-COMMAND
ELSE
MOVE CURR-CHAR TO WSS-NEXT-COMMAND
PERFORM G1.
IF NO-ERROR
IF W-HCMD-TOKEN-FIRST = YES-VALUE
MOVE W-HCMD-TOKEN-NAME TO ASCII-SUBSTITUTE-NAME
STRING W-HCMD-TOKEN-VALUE DELIMITED BY SPACE
INTO CT-TOKEN
WITH POINTER CT-IDX
PERFORM 9399-FILL-TOKEN.
*& IF NO-ERROR
*& IF W-SCMD-TOKEN-NAME(W-SCMD-IDX) = 'PROG'
*& MOVE SPACES TO WSS-NEXT-COMMAND
*& STRING FILNM DELIMITED BY '@'
*& INTO WSS-NEXT-COMMAND
*&PERFORM H1.
IF NO-ERROR
IF W-SCMD-TOKEN-NAME(W-SCMD-IDX) = 'FILE1' OR 'FILE2'
*& IF W-SCMD-TOKEN-NAME(W-SCMD-IDX) = 'FILE1' OR 'FILE2' OR 'PROG'
PERFORM 9315-FILE-DONE.
*& ELSE
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 SPACE
INTO CT-TOKEN
WITH POINTER CT-IDX
PERFORM 9399-FILL-TOKEN
ELSE
IF W-SCMD-TERM(W-SCMD-IDX) = YES-VALUE
PERFORM 9399-FILL-TOKEN
ELSE
IF WSS-COMMAND NOT = 'END'
STRING CURR-CHAR DELIMITED BY SIZE
INTO CT-TOKEN
WITH POINTER CT-IDX
PERFORM 9399-FILL-TOKEN
ELSE
PERFORM 9399-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 9900-LOAD-SUB-CMD-TABLE
MOVE SPACES TO W-HCMD-NXT-TBL.
IF NO-ERROR
IF W-HCMD-TERM = YES-VALUE
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.
*&
B1.
C1.
E1.
G1.
H1.
9311-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.
9312-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 9800-DO-NOTHING
VARYING CT-IDX FROM 105 BY -1
UNTIL CT-TOKEN-ARRAY(CT-IDX) NOT = SPACE
OR CT-IDX = 1.
IF CT-IDX < 105
SET CT-IDX UP BY 1
MOVE '@' TO CT-TOKEN-ARRAY(CT-IDX).
9313-PROT-CONVERT.
9314-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 9314-ELIM-LEADING-ZEROES
UNTIL TEMP-IDX > CT-MAX
OR TEMP-TOKEN-ARRAY(TEMP-IDX) = SPACE
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
SET WS-SAVE-PTR UP BY HOLD-IDX
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 9500-LOAD-SUB-DIR-TABLE.
9314-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.
9315-FILE-DONE.
MOVE SPACES TO CT-TOKEN.
SET CT-IDX TO 1.
IF STRC1 NOT = SPACES
MOVE STRC1 TO CT-TOKEN
PERFORM 9316-PROCESS-STRUCTURE
MOVE CT-TOKEN TO STRC1.
IF DIREC NOT = SPACES
MOVE DIREC TO CT-TOKEN
PERFORM 3132-PROCESS-DIREC
MOVE CT-TOKEN TO DIREC.
IF EXT1 NOT = SPACES
MOVE EXT1 TO CT-TOKEN
PERFORM 9312-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.
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 W-SCMD-TOKEN-VALUE(W-SCMD-IDX) NOT = SPACES
*& STRING W-SCMD-TOKEN-VALUE(W-SCMD-IDX)
*& DELIMITED BY SPACE
*& INTO CT-TOKEN
*& WITH POINTER CT-IDX.
*& MOVE W-HCMD-TOKEN-NAME TO ASCII-SUBSTITUTE-NAME.
*& PERFORM 9399-FILL-TOKEN.
MOVE SPACES TO DIREC
EXT1
FILNM
STRC1.
*& DO SOMETHING ABOUT PROTECTION HERE? OR WHERE?
*&
A1.
9316-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 9800-DO-NOTHING
VARYING CT-IDX FROM 105 BY -1
UNTIL CT-TOKEN-ARRAY(CT-IDX) NOT = SPACE
OR CT-IDX = 1.
IF CT-IDX < 105
SET CT-IDX UP BY 1
MOVE ':' TO CT-TOKEN-ARRAY(CT-IDX)
IF CT-IDX < 105
SET CT-IDX UP BY 1
MOVE '@' TO CT-TOKEN-ARRAY(CT-IDX).
9399-FILL-TOKEN.
MOVE ASCII-SUBSTITUTE-NAME TO SUBSTITUTE-NAME.
IF SUBSTITUTE-NAME = 'SWTCH'
* 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 NOT = ASCII-SUBSTITUTE-NAME
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
MOVE ASCII-SUBSTITUTE-NAME TO WSS-LAST-TOKEN-NAME.
IF TOKEN-NAME
OR SAVE-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
NEXT SENTENCE
ELSE
IF COMNT-NAME
MOVE COMNT TO TOKEN-HOLD
PERFORM 9399-FILL-IT
MOVE TOKEN-HOLD TO COMNT
ELSE
IF FILE1-NAME
MOVE FILE1 TO TOKEN-HOLD
PERFORM 9399-FILL-IT
MOVE TOKEN-HOLD TO FILE1
ELSE
IF FILE2-NAME
MOVE FILE2 TO TOKEN-HOLD
PERFORM 9399-FILL-IT
MOVE TOKEN-HOLD TO FILE2
ELSE
IF DATA1-NAME
MOVE DATA1 TO TOKEN-HOLD
PERFORM 9399-FILL-IT
MOVE TOKEN-HOLD TO DATA1
ELSE
IF DATA2-NAME
MOVE DATA2 TO TOKEN-HOLD
PERFORM 9399-FILL-IT
MOVE TOKEN-HOLD TO DATA2
ELSE
IF LABLE-NAME
MOVE LABLE TO TOKEN-HOLD
PERFORM 9399-FILL-IT
MOVE TOKEN-HOLD TO LABLE
ELSE
IF PROG-NAME
MOVE PROG TO TOKEN-HOLD
PERFORM 9399-FILL-IT
MOVE TOKEN-HOLD TO PROG
ELSE
IF EXT1-NAME
MOVE EXT1 TO TOKEN-HOLD
PERFORM 9399-FILL-IT
MOVE TOKEN-HOLD TO EXT1
ELSE
IF FILNM-NAME
MOVE FILNM TO TOKEN-HOLD
PERFORM 9399-FILL-IT
MOVE TOKEN-HOLD TO FILNM
ELSE
IF STRC1-NAME
IF WSS-AVOID-STRC-PROC
MOVE STRC1 TO TOKEN-HOLD
PERFORM 9399-FILL-IT
MOVE TOKEN-HOLD TO STRC1
SET WSS-AVOID-STRC-PROC-FL TO NO-VALUE
ELSE
PERFORM 9316-PROCESS-STRUCTURE
MOVE CT-TOKEN-20 TO STRC1
ELSE
IF STRC2-NAME
PERFORM 9316-PROCESS-STRUCTURE
MOVE CT-TOKEN-20 TO STRC2
ELSE
IF DIREC-NAME
MOVE DIREC TO TOKEN-HOLD
PERFORM 9399-FILL-IT
MOVE TOKEN-HOLD TO DIREC
ELSE
IF SWTCH-NAME
*& IF SWTCH = SPACES
*& MOVE CT-TOKEN TO SWTCH
*& ELSE
*& MOVE SWTCH TO SYMBOL-WORK
*& PERFORM 9800-DO-NOTHING
*& VARYING SYMBOL-WORK-PTR FROM 105 BY -1
*& UNTIL SYMBOL-WORK-ARRAY(SYMBOL-WORK-PTR) NOT = SPACE
*& STRING '/' CT-TOKEN '@' DELIMITED BY SIZE
*& INTO SYMBOL-WORK
*& WITH POINTER SYMBOL-WORK-PTR
*& MOVE SYMBOL-WORK TO SWTCH
MOVE SWTCH TO TOKEN-HOLD
PERFORM 9399-FILL-IT
MOVE TOKEN-HOLD TO SWTCH
*& ELSE
*& IF SVALU-NAME
*& MOVE SWTCH TO SYMBOL-WORK
*& PERFORM 9800-DO-NOTHING
*& VARYING SYMBOL-WORK-PTR FROM 105 BY -1
*& UNTIL SYMBOL-WORK-ARRAY(SYMBOL-WORK-PTR) NOT = SPACE
*& STRING '=' CT-TOKEN '@' DELIMITED BY SIZE
*& INTO SYMBOL-WORK
*& WITH POINTER SYMBOL-WORK-PTR
*& MOVE SYMBOL-WORK TO SWTCH
*& ETC.
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.
9399-FILL-IT.
IF TOKEN-HOLD = SPACES
MOVE CT-TOKEN TO TOKEN-HOLD
ELSE
MOVE TOKEN-HOLD TO SYMBOL-WORK
PERFORM 9800-DO-NOTHING
VARYING SYMBOL-WORK-PTR FROM 105 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.
*--------------
* Start Command
*--------------
9400-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 9410-SUBSTITUTE-NAME.
9410-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 If RESERVED-VARIABLE
perform 9410-RESERVED-VARIABLE
else
perform 9410-FIELD-DATA-NAMES
string SYMBOL-WORK delimited by '@'
into COMMAND-RECORD
pointer COMMAND-PTR.
9410-RESERVED-VARIABLE.
IF DATE-VARIABLE
string WS-DATE-WORK
delimited by SIZE
into COMMAND-RECORD
pointer COMMAND-PTR
else If RESERVED-NAME-CHAR-1 is numeric
unstring RESERVED-NAME delimited by space into NEXT-COL-NO
perform 9430-ADJUST-OUTPUT-COLUMN
* else If condition
else
move RESERVED-VARIABLE-ERROR to CURRENT-ERROR
SET WSS-END-OF-LINE-SW TO YES-VALUE
perform 9999-RECORD-ERROR.
9410-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 DATA2-NAME
MOVE DATA2 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.
IF SYMBOL-WORK = SPACES
MOVE '@' TO SYMBOL-WORK.
*& ELSE IF SVALU-NAME
*& MOVE SVALU TO SYMBOL-WORK.
*& ETC...
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.
9410-A.
*PARAGRAPH TO OVERCOME 24-LEVEL NESTING LIMIT ON 'IF-ELSE'.
9430-ADJUST-OUTPUT-COLUMN.
set CURR-COL-NO,
LAST-COL-NO,
LAST-COMMAND-PTR to 0.
perform 9431-CALC-LAST-COL-NO
varying WS-INDEX from 1 by 1
until WS-INDEX = COMMAND-PTR.
compute COMMAND-PTR = LAST-COMMAND-PTR + 1.
If (LAST-COL-NO + 1) > NEXT-COL-NO
perform 9432-INSERT-SPACE
varying COMMAND-PTR from COMMAND-PTR by 1
until COMMAND-PTR > MAX-COMMAND-PTR
perform 8500-WRITE-COMMAND-LINE
set LAST-COL-NO to 0
set COMMAND-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 9433-INSERT-TAB
varying COMMAND-PTR from COMMAND-PTR by 1
until LAST-COL-NO NOT< NEXT-TAB-NO
perform 9432-INSERT-SPACE
varying COMMAND-PTR from COMMAND-PTR by 1
until LAST-COL-NO NOT< NEXT-COL-NO.
9431-CALC-LAST-COL-NO.
set CURR-COL-NO up by 1.
If COMMAND-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 COMMAND-CHAR (WS-INDEX) = SPACE
NEXT SENTENCE
else
move WS-INDEX to LAST-COMMAND-PTR
move CURR-COL-NO to LAST-COL-NO.
9432-INSERT-SPACE.
move SPACE to COMMAND-CHAR (COMMAND-PTR).
set LAST-COL-NO up by 1.
9433-INSERT-TAB.
move WS-TAB to COMMAND-CHAR (COMMAND-PTR).
divide LAST-COL-NO by 8 giving TALLY
REMAINDER FILL-COUNT
COMPUTE LAST-COL-NO = LAST-COL-NO + 8 - FILL-COUNT.
9500-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.'
*&
*&DISPLAY WSS-TABLE-NAME
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 9510-REST-OF-LOAD
UNTIL WSS-SEARCH-DONE.
9510-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.
9700-PROCESS-CONT-LINE.
PERFORM 8000-READ-CTL.
PERFORM 9710-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.
9710-FIND-MAX.
PERFORM 9800-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.
9800-DO-NOTHING.
9900-LOAD-SUB-CMD-TABLE.
SET W-SCMD-MAX-TBL TO 0.
MOVE SPACES TO W-SUB-CMD-WHOLE.
*& W-HOLD-CMD-FLAGS.
*& ZERO FLAGS HERE OR ELSEWHERE?
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 9910-REST-OF-LOAD
UNTIL WSS-SEARCH-DONE.
9910-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.
*---------------------
* 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 COMMAND-PTR.
move CONTROL-RECORD to COMMAND-RECORD.
perform 8500-WRITE-COMMAND-LINE.
move SPACE to COMMAND-RECORD.
*& set COMMAND-PTR to WS-SAVE-PTR.
COMPUTE COMMAND-PTR = (CONTROL-PTR - SAV-IDX) + 1.
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.
*& set SKELETON-PTR to MAX-COMMAND-PTR.
*& set SKELETON-PTR up by 1.
display 'Error # ' ERROR-NUMBER.
*& IF WSS-USER-LEVEL
*& OR (W-HCMD-END-COM = YES-VALUE
*& AND (WSS-OPER-LEVEL))
*& AND LINE NOT CONTINUING? (-).
MOVE 'TABLE1' TO WSS-TABLE-NAME.
PERFORM 9900-LOAD-SUB-CMD-TABLE.
PERFORM 9500-LOAD-SUB-DIR-TABLE.
MOVE ZEROES TO W-HOLD-CMD-FLAGS.
MOVE SPACES TO CT-TOKEN
CURR-CHAR
*& HOLD-CHAR
WSS-NEXT-COMMAND
WSS-COMMAND.
SET CT-IDX TO 1.
MOVE SPACES TO TOKEN-DATA.