ADDRESS ISPEXEC
'ISREDIT MACRO NOPROCESS'
'ISREDIT PROCESS RANGE C'
'ISREDIT (FIRST) = LINENUM .ZFRANGE'
'ISREDIT (LAST) = LINENUM .ZLRANGE'
'ISREDIT (NUM1,NUM2) = NUMBER'
PDLINE = ' '
PICLEN = 0
/******************LOOP 60 TIMES !!!!*********************/
DO X = 1 TO 60
LEVEL.X = 0
END
/********************************************************/
/* YOU CAN START TRACE FROM HERE AND FORWARD */
TRACE OFF
/********************************************************/
DTO = ''
CURRLVL = ''
PREVLVL = ''
LOWLVL = ''
HILVL = ''
REDEFINE = ''
PLINE = ''
REFLVL = '' /* 05-22-97 */
FRSTRC = '' /* 05-22-97 */
DO FOREVER
/*************************************************************/
/* READ A LINE FROM THE VIRTUAL FILE (SCREEN) */
/*************************************************************/
IF FIRST > LAST THEN DO
QUEUE ''
LEAVE
END
'ISREDIT (DATA) = LINE' FIRST
IF RC ^= 0 THEN DO
QUEUE ''
LEAVE
END
IF DATA = '' THEN DO
FIRST = FIRST + 1
ITERATE
END
COB1 = POS('NOCOB',NUM2)
COMM = SUBSTR(DATA,7,1)
IF NUM1 = 'ON' & COB1 = 0 THEN COMM = SUBSTR(DATA,1,1)
IF COMM ^= ' ' & COMM ^= '-' THEN DO
FIRST= FIRST + 1
ITERATE
END
DATA = SUBSTR(DATA,1,72)
IF NUM1 = 'ON' & COB1 = 0 THEN DATA = SUBSTR(DATA,2,67)
ELSE DATA = SUBSTR(DATA,7,67)
IF COMM = '-' THEN DO
DATA = STRIP(DATA,'L','-')
DATA = ' ' || DATA
END
IF DATA = 'EJECT' | DATA = 'SKIP1' | DATA = 'SKIP2' | DATA = 'SKIP3' THEN DO
FIRST = FIRST + 1
ITERATE
END
IF PLINE = '' THEN ELINE = FIRST
PLINE = PLINE || DATA
/********************************************************************/
/* PUT THE WHOLE LINE TOGETHER AS ONE (CONCATINATE LINES UNTIL '.') */
/* WE ARE GONNA STACK THEM LIFO */
/********************************************************************/
PCK = POS('. ',PLINE)
IF PCK = 0 THEN DO
FIRST = FIRST + 1
PDLINE = 'X'
ITERATE
END
PLINE = SUBSTR(PLINE,2,PCK)
PLINE = STRIP(PLINE,'L')
PLINE = STRIP(PLINE,'T')
LCHK = SUBSTR(PLINE,1,2)
IF LCHK = '88' THEN DO
PLINE = ''
FIRST = FIRST + 1
ITERATE
END
IF LCHK = '77' THEN DO
ZEDLMSG = '77 LEVELS ARE NOT NOT ALLOWED,SORRY'
'ISPEXEC SETMSG MSG(ISRZ000)'
CALL DRPBF
EXIT
END
PLINE = ELINE PLINE
CALL LITCHK
PUSH PLINE
PDLINE = ' '
PLINE = ''
FIRST = FIRST + 1
END
/********************03-21-97**CHECK*FOR*LAST*LINE*HAVING*PERIOD**/
IF PDLINE = 'X' THEN DO
ERRLINE = ELINE
ZEDLMSG = 'THERE IS A MISSING PERIOD IN ' ERRLINE
'ISPEXEC SETMSG MSG(ISRZ000)'
CALL DRPBF
EXIT
END
/*************END*OF*MOD*032197***************************/
TRACE OFF
DO FOREVER
/*********************************************************/
/* GET A LINE OFF THE STACK IN 3 WORDS */
/* ELINE = THE ERROR LINE NUMBER (IF NEEDED) */
/* WRD = THE LEVEL NUMBER (THE FIRST TIME THROUGH) */
/* REST = THE REST OF THE LINE */
/* WE WILL CHEW THE REST OFF ONE WORD AT A TIME LATER */
/* REMEMBER THE LAST LINE COMES FIRST */
/*********************************************************/
WRD = ''
CURRLVL = ''
PIC = ''
DTNAME = ''
PULL ELINE WRD REST
IF ELINE = '' THEN LEAVE
ERRLINE = ELINE
REST = STRIP(REST,'T') /* STIP OUT TRAILING BLANKS */
CHKP = POS('.',REST)
IF CHKP = 0 THEN DO
ZEDLMSG = 'THERE IS A MISSING PERIOD IN ' ERRLINE
'ISPEXEC SETMSG MSG(ISRZ000)'
CALL DRPBF
EXIT
END
REST = STRIP(REST,'T','.') /* WE DON'T NEED THE PERIOD ANYMORE*/
OCCURS = 1
CALL GET_COBOL_WORDS /* START CHEWING */
PLINE = ''
END
/*********************************************************/
/* WELL WE ARE ALL DONE WITH THE CACULATION */
/* SO, EITHER RETURN THE LENGTH OR AN ERROR MESSGAE */
/*********************************************************/
IF PREVLVL > LOWLVL THEN DO
CALL DRPBF
ZEDLMSG = 'LINE 'ERRLINE 'LOWER LEVEL FOUND BEFORE HIGHER ONE'
'ISPEXEC SETMSG MSG(ISRZ000)'
EXIT
END
DO X = HILVL TO LOWLVL BY -1
IF X = LOWLVL THEN LEAVE
IF LEVEL.X = 0 THEN ITERATE
LN = LENGTH(X)
XD = X
IF LN = 1 THEN XD = '0' || X
ZEDLMSG = 'LINE 'ERRLINE 'LOWER LEVEL FOUND BEFORE HIGHER ONE'
'ISPEXEC SETMSG MSG(ISRZ000)'
CALL DRPBF
EXIT
END
IF REDEFINE ^= '' THEN DO
ZEDLMSG = 'LENGTH IS ' LEVEL.PREVLVL 'WARN REDEFINES UNRESOLVED'
'ISPEXEC SETMSG MSG(ISRZ000)'
EXIT
END
IF DTO = 'TO' THEN DO
ZEDLMSG = 'LENGTH IS ' LEVEL.PREVLVL 'WARN DEPENDING ON IS UNRESOLVED'
'ISPEXEC SETMSG MSG(ISRZ000)'
EXIT
END
ZEDLMSG = 'YOUR DATA DEFINITION LENGTH IS ' LEVEL.PREVLVL
'ISPEXEC SETMSG MSG(ISRZ000)'
EXIT
/***************************************************************/
/******************END OF EXEC RLCL*****************************/
/***************************************************************/
/* ************************************************** */
/* ************************************ */
/* ************************ */
/* ************ */
/* ***** */
/* IT STOPS HERE * SUB ROUTINES FOLLOW */
/***************************************************************/
GET_COBOL_WORDS:
/*****************************************************************/
/* GET NEEDED COBOL CLAUSES AND VALUES FROM THE REST OF THE LINE */
/* ONE WORD AT A TIME */
/*****************************************************************/
DO FOREVER
IF WRD = '' THEN DO /* NO MORE WORDS ? THEN CALCULATE */
CALL CALCIT
LEAVE
END
IF WRD = 'COMP-3' THEN COMP3 = 'X'
IF WRD = 'COMP' THEN COMP = 'X'
CHK = DATATYPE(WRD)
IF (WRD >= '01' & WRD < '99') & CHK = 'NUM' THEN DO
IF CURRLVL ^= '' THEN DO
ZEDLMSG = 'THERE IS A MISSING PERIOD IN ' ERRLINE
'ISPEXEC SETMSG MSG(ISRZ000)'
CALL DRPBF
EXIT
END
CURRLVL = WRD
IF FRSTRC = '' THEN DO /* 05-22-97 */
REFLVL = WRD
FRSTRC = 'X'
END /* END 05-22-97 */
PUSH REST
PULL DTNAME REST
IF REDEFINE ^= '' THEN DO
IF REDEFINE = DTNAME THEN DO
RED = POS('REDEFINES ',REST)
IF RED ^= 0 THEN DO
REST = SUBSTR(REST,RED,60)
PUSH REST
PULL . REDEFINE
LEAVE
END
ELSE DO
REDEFINE = ''
LEAVE
END
END
ELSE DO
LEAVE
END
END
END
IF WRD = 'VALUE' | WRD = 'VALUES' THEN DO
PUSH REST
PULL VALUE REST
IF VALUE = '' THEN DO
ZEDLMSG = 'LINE 'ERRLINE 'VALUE CLAUSE HAS NO VALUE'
'ISPEXEC SETMSG MSG(ISRZ000)'
CALL DRPBF
EXIT
END
END
IF WRD = 'OCCURS' THEN DO
PUSH REST
PULL OCCURS REST
DEP = POS(' DEPENDING ',REST)
IF DEP ^= 0 THEN DO
PUSH REST
PULL DTO REST
PUSH REST
PULL OCCURS REST
END
END
IF WRD = 'PIC' THEN DO
IF PIC ^= '' THEN DO
ZEDLMSG = 'LINE 'ERRLINE 'PIC HAS BEEN DEFINED TWICE'
'ISPEXEC SETMSG MSG(ISRZ000)'
CALL DRPBF
EXIT
END
PUSH REST
PULL PIC REST
END
IF WRD = 'PICTURE' THEN DO
PUSH REST
PULL PIC REST
IF PIC = 'IS' THEN DO
PUSH REST
PULL PIC REST
END
END
IF WRD = 'REDEFINES' THEN DO
PUSH REST
PULL REDEFINE REST
END
PUSH REST
PULL WRD REST
END
RETURN
CALCIT:
/**************************************************************/
/* CALCULATE THE PIC LENGTH AND/OR GROUP FIELD LENGTH */
/**************************************************************/
CURRLVL = STRIP(CURRLVL,'L','0')
IF PREVLVL = '' THEN DO
PREVLVL = CURRLVL
LOWLVL = CURRLVL
HILVL = CURRLVL
END
IF CURRLVL >= PREVLVL & PIC = '' THEN DO
ZEDLMSG = 'AROUND LINE 'ERRLINE 'ELEMENTRY WITH NO PICTURE'
'ISPEXEC SETMSG MSG(ISRZ000)'
CALL DRPBF
EXIT
END
IF CURRLVL < PREVLVL & PIC ^= '' THEN DO
ZEDLMSG = 'AROUND LINE 'ERRLINE 'GROUP ITEM HAS A PICTURE,BONEHEAD'
'ISPEXEC SETMSG MSG(ISRZ000)'
CALL DRPBF
EXIT
END
/*****05-02-97**FIX*REDEFINE*PROBLEM*******/
IF (CURRLVL < PREVLVL) THEN DO
IF REDEFINE ^= '' & CURRLVL >= REFLVL THEN DO /* 05-22-97 */
LEVEL.PREVLVL = 0
PREVLVL = CURRLVL
REDEFINE = ''
END
/******************************************/
ELSE DO
CALL GROUP_COMP_3
CALL GROUP_COMP_BIN
LEVEL.CURRLVL = LEVEL.CURRLVL + (LEVEL.PREVLVL * OCCURS)
LEVEL.PREVLVL = 0
PREVLVL = CURRLVL
IF CURRLVL < LOWLVL THEN LOWLVL = CURRLVL
/* 05-22-97 */
IF REDEFINE ^= '' & CURRLVL < REFLVL THEN REFLVL = CURRLVL
END
RETURN
END
CALL PICTURE
/****************05-02-97***FIX*REDEFINE***PROB**/
IF REDEFINE = '' THEN PREVLVL = CURRLVL
REDEFINE = ''
/************************************************/
IF CURRLVL > HILVL THEN HILVL = CURRLVL
RETURN
PICTURE:
/**************************************************************/
/* FIND THE LENGTH OF THE ACTUAL PICTURE CLAUSE */
/**************************************************************/
PIC = STRIP(PIC,'L','S')
PICLEN = 0
PIC = TRANSLATE(PIC,' ','V')
IF POS(')',PIC) = 0 THEN PICLEN = LENGTH(WORD(PIC,1))+LENGTH(WORD(PIC,2))
ELSE DO
PIC = TRANSLATE(PIC,' ',')')
DO WRDNBR = 1 TO WORDS(PIC)
SPEC = WORD(PIC,WRDNBR)
IF POS('(',SPEC) = 0 THEN PICLEN = PICLEN + LENGTH(SPEC)
ELSE DO
SPEC = TRANSLATE(SPEC,' ','(')
PICLEN = PICLEN + LENGTH(WORD(SPEC,1)) + WORD(SPEC,2) - 1
END
END
END
CALL FIELD_COMP_3
CALL FIELD_COMP_BIN
/******************05-02-97***FIX*REDEFINE*PROBLEM*******/
IF REDEFINE = '' THEN DO
LEVEL.CURRLVL = LEVEL.CURRLVL + (PICLEN * OCCURS)
END
/******************************************/
RETURN
FIELD_COMP_3:
/******************************************************/
/* PACK THE FIELD LENGTH IF NEEDED */
/******************************************************/
IF COMP3 ^= 'X' THEN RETURN
PICLEN = (PICLEN % 2 ) + 1
COMP3 = ''
RETURN
GROUP_COMP_3:
/******************************************************/
/* PACK THE GROUP FIELD LENGTH IF NEEDED */
/******************************************************/
IF COMP3 ^= 'X' THEN RETURN
LEVEL.PREVLVL = (LEVEL.PREVLVL % 2) + 1
COMP3 = ''
RETURN
FIELD_COMP_BIN:
/******************************************************/
/* DETERMINE THE BINARY FIELD LENGTH IF NEEDED */
/******************************************************/
IF COMP ^= 'X' THEN RETURN
IF PICLEN > = 1 & PICLEN < = 4 THEN PICLEN = 2
IF PICLEN > = 5 & PICLEN < = 9 THEN PICLEN = 4
IF PICLEN > = 10 & PICLEN < = 18 THEN PICLEN = 8
IF PICLEN > = 19 & PICLEN < = 20 THEN PICLEN = 2
IF PICLEN > 20 THEN DO
CALL DRPBF
ZEDLMSG = 'COMP FIELD EXCEEDS 20 CHARACTERS'
'ISPEXEC SETMSG MSG(ISRZ000)'
EXIT
END
COMP = ''
RETURN
GROUP_COMP_BIN:
/************************************************************/
/* DETERMINE THE BINARY GROUP FIELD LENGTH IF NEEDED */
/************************************************************/
IF COMP ^= 'X' THEN RETURN
IF LEVEL.PREVLVL > = 1 & LEVEL.PREVLVL < = 4 THEN LEVEL.PREVLVL = 2
IF LEVEL.PREVLVL > = 5 & LEVEL.PREVLVL < = 9 THEN LEVEL.PREVLVL = 4
IF LEVEL.PREVLVL > = 10 & LEVEL.PREVLVL < = 18 THEN LEVEL.PREVLVL = 8
IF LEVEL.PREVLVL > = 19 & LEVEL.PREVLVL < = 20 THEN LEVEL.PREVLVL = 2
IF LEVEL.PREVLVL > 20 THEN DO
CALL DRPBF
ZEDLMSG = 'COMP FIELD EXCEEDS 20 CHARACTERS'
'ISPEXEC SETMSG MSG(ISRZ000)'
EXIT
END
COMP = ''
RETURN
LITCHK:
LITCHK = POS("'",PLINE)
IF LITCHK = 0 THEN RETURN
LITCHK = LITCHK + 1
LITCHK2 = POS("'",PLINE,LITCHK)
LITCHK = LITCHK - 2
IF LITCHK2 = 0 THEN RETURN
LITLEN = LITCHK2 + 3
PLINEA = SUBSTR(PLINE,1,LITCHK)
/*********DONT DECOMMENT THIS********************/
/* LITCHK2 = LITCHK2 + 1 */
/*********OR YOU'LL BE SORRY*********************/
/* I AM LEAVING ONE OF THE ' AS A VALUE OR YOULL*/
/* GET A 'VALUE CLAUSE WITH NO VALUE' ERROR MSG */
/************************************************/
PLINEB = SUBSTR(PLINE,LITCHK2)
PLINE = PLINEA PLINEB
RETURN
DRPBF:
/************************************************************/
/* CLEAR THE STACK OUT */
/************************************************************/
DO QUEUED()
PULL DUMMY
END
RETURN
'ISREDIT MACRO NOPROCESS'
'ISREDIT PROCESS RANGE C'
'ISREDIT (FIRST) = LINENUM .ZFRANGE'
'ISREDIT (LAST) = LINENUM .ZLRANGE'
'ISREDIT (NUM1,NUM2) = NUMBER'
PDLINE = ' '
PICLEN = 0
/******************LOOP 60 TIMES !!!!*********************/
DO X = 1 TO 60
LEVEL.X = 0
END
/********************************************************/
/* YOU CAN START TRACE FROM HERE AND FORWARD */
TRACE OFF
/********************************************************/
DTO = ''
CURRLVL = ''
PREVLVL = ''
LOWLVL = ''
HILVL = ''
REDEFINE = ''
PLINE = ''
REFLVL = '' /* 05-22-97 */
FRSTRC = '' /* 05-22-97 */
DO FOREVER
/*************************************************************/
/* READ A LINE FROM THE VIRTUAL FILE (SCREEN) */
/*************************************************************/
IF FIRST > LAST THEN DO
QUEUE ''
LEAVE
END
'ISREDIT (DATA) = LINE' FIRST
IF RC ^= 0 THEN DO
QUEUE ''
LEAVE
END
IF DATA = '' THEN DO
FIRST = FIRST + 1
ITERATE
END
COB1 = POS('NOCOB',NUM2)
COMM = SUBSTR(DATA,7,1)
IF NUM1 = 'ON' & COB1 = 0 THEN COMM = SUBSTR(DATA,1,1)
IF COMM ^= ' ' & COMM ^= '-' THEN DO
FIRST= FIRST + 1
ITERATE
END
DATA = SUBSTR(DATA,1,72)
IF NUM1 = 'ON' & COB1 = 0 THEN DATA = SUBSTR(DATA,2,67)
ELSE DATA = SUBSTR(DATA,7,67)
IF COMM = '-' THEN DO
DATA = STRIP(DATA,'L','-')
DATA = ' ' || DATA
END
IF DATA = 'EJECT' | DATA = 'SKIP1' | DATA = 'SKIP2' | DATA = 'SKIP3' THEN DO
FIRST = FIRST + 1
ITERATE
END
IF PLINE = '' THEN ELINE = FIRST
PLINE = PLINE || DATA
/********************************************************************/
/* PUT THE WHOLE LINE TOGETHER AS ONE (CONCATINATE LINES UNTIL '.') */
/* WE ARE GONNA STACK THEM LIFO */
/********************************************************************/
PCK = POS('. ',PLINE)
IF PCK = 0 THEN DO
FIRST = FIRST + 1
PDLINE = 'X'
ITERATE
END
PLINE = SUBSTR(PLINE,2,PCK)
PLINE = STRIP(PLINE,'L')
PLINE = STRIP(PLINE,'T')
LCHK = SUBSTR(PLINE,1,2)
IF LCHK = '88' THEN DO
PLINE = ''
FIRST = FIRST + 1
ITERATE
END
IF LCHK = '77' THEN DO
ZEDLMSG = '77 LEVELS ARE NOT NOT ALLOWED,SORRY'
'ISPEXEC SETMSG MSG(ISRZ000)'
CALL DRPBF
EXIT
END
PLINE = ELINE PLINE
CALL LITCHK
PUSH PLINE
PDLINE = ' '
PLINE = ''
FIRST = FIRST + 1
END
/********************03-21-97**CHECK*FOR*LAST*LINE*HAVING*PERIOD**/
IF PDLINE = 'X' THEN DO
ERRLINE = ELINE
ZEDLMSG = 'THERE IS A MISSING PERIOD IN ' ERRLINE
'ISPEXEC SETMSG MSG(ISRZ000)'
CALL DRPBF
EXIT
END
/*************END*OF*MOD*032197***************************/
TRACE OFF
DO FOREVER
/*********************************************************/
/* GET A LINE OFF THE STACK IN 3 WORDS */
/* ELINE = THE ERROR LINE NUMBER (IF NEEDED) */
/* WRD = THE LEVEL NUMBER (THE FIRST TIME THROUGH) */
/* REST = THE REST OF THE LINE */
/* WE WILL CHEW THE REST OFF ONE WORD AT A TIME LATER */
/* REMEMBER THE LAST LINE COMES FIRST */
/*********************************************************/
WRD = ''
CURRLVL = ''
PIC = ''
DTNAME = ''
PULL ELINE WRD REST
IF ELINE = '' THEN LEAVE
ERRLINE = ELINE
REST = STRIP(REST,'T') /* STIP OUT TRAILING BLANKS */
CHKP = POS('.',REST)
IF CHKP = 0 THEN DO
ZEDLMSG = 'THERE IS A MISSING PERIOD IN ' ERRLINE
'ISPEXEC SETMSG MSG(ISRZ000)'
CALL DRPBF
EXIT
END
REST = STRIP(REST,'T','.') /* WE DON'T NEED THE PERIOD ANYMORE*/
OCCURS = 1
CALL GET_COBOL_WORDS /* START CHEWING */
PLINE = ''
END
/*********************************************************/
/* WELL WE ARE ALL DONE WITH THE CACULATION */
/* SO, EITHER RETURN THE LENGTH OR AN ERROR MESSGAE */
/*********************************************************/
IF PREVLVL > LOWLVL THEN DO
CALL DRPBF
ZEDLMSG = 'LINE 'ERRLINE 'LOWER LEVEL FOUND BEFORE HIGHER ONE'
'ISPEXEC SETMSG MSG(ISRZ000)'
EXIT
END
DO X = HILVL TO LOWLVL BY -1
IF X = LOWLVL THEN LEAVE
IF LEVEL.X = 0 THEN ITERATE
LN = LENGTH(X)
XD = X
IF LN = 1 THEN XD = '0' || X
ZEDLMSG = 'LINE 'ERRLINE 'LOWER LEVEL FOUND BEFORE HIGHER ONE'
'ISPEXEC SETMSG MSG(ISRZ000)'
CALL DRPBF
EXIT
END
IF REDEFINE ^= '' THEN DO
ZEDLMSG = 'LENGTH IS ' LEVEL.PREVLVL 'WARN REDEFINES UNRESOLVED'
'ISPEXEC SETMSG MSG(ISRZ000)'
EXIT
END
IF DTO = 'TO' THEN DO
ZEDLMSG = 'LENGTH IS ' LEVEL.PREVLVL 'WARN DEPENDING ON IS UNRESOLVED'
'ISPEXEC SETMSG MSG(ISRZ000)'
EXIT
END
ZEDLMSG = 'YOUR DATA DEFINITION LENGTH IS ' LEVEL.PREVLVL
'ISPEXEC SETMSG MSG(ISRZ000)'
EXIT
/***************************************************************/
/******************END OF EXEC RLCL*****************************/
/***************************************************************/
/* ************************************************** */
/* ************************************ */
/* ************************ */
/* ************ */
/* ***** */
/* IT STOPS HERE * SUB ROUTINES FOLLOW */
/***************************************************************/
GET_COBOL_WORDS:
/*****************************************************************/
/* GET NEEDED COBOL CLAUSES AND VALUES FROM THE REST OF THE LINE */
/* ONE WORD AT A TIME */
/*****************************************************************/
DO FOREVER
IF WRD = '' THEN DO /* NO MORE WORDS ? THEN CALCULATE */
CALL CALCIT
LEAVE
END
IF WRD = 'COMP-3' THEN COMP3 = 'X'
IF WRD = 'COMP' THEN COMP = 'X'
CHK = DATATYPE(WRD)
IF (WRD >= '01' & WRD < '99') & CHK = 'NUM' THEN DO
IF CURRLVL ^= '' THEN DO
ZEDLMSG = 'THERE IS A MISSING PERIOD IN ' ERRLINE
'ISPEXEC SETMSG MSG(ISRZ000)'
CALL DRPBF
EXIT
END
CURRLVL = WRD
IF FRSTRC = '' THEN DO /* 05-22-97 */
REFLVL = WRD
FRSTRC = 'X'
END /* END 05-22-97 */
PUSH REST
PULL DTNAME REST
IF REDEFINE ^= '' THEN DO
IF REDEFINE = DTNAME THEN DO
RED = POS('REDEFINES ',REST)
IF RED ^= 0 THEN DO
REST = SUBSTR(REST,RED,60)
PUSH REST
PULL . REDEFINE
LEAVE
END
ELSE DO
REDEFINE = ''
LEAVE
END
END
ELSE DO
LEAVE
END
END
END
IF WRD = 'VALUE' | WRD = 'VALUES' THEN DO
PUSH REST
PULL VALUE REST
IF VALUE = '' THEN DO
ZEDLMSG = 'LINE 'ERRLINE 'VALUE CLAUSE HAS NO VALUE'
'ISPEXEC SETMSG MSG(ISRZ000)'
CALL DRPBF
EXIT
END
END
IF WRD = 'OCCURS' THEN DO
PUSH REST
PULL OCCURS REST
DEP = POS(' DEPENDING ',REST)
IF DEP ^= 0 THEN DO
PUSH REST
PULL DTO REST
PUSH REST
PULL OCCURS REST
END
END
IF WRD = 'PIC' THEN DO
IF PIC ^= '' THEN DO
ZEDLMSG = 'LINE 'ERRLINE 'PIC HAS BEEN DEFINED TWICE'
'ISPEXEC SETMSG MSG(ISRZ000)'
CALL DRPBF
EXIT
END
PUSH REST
PULL PIC REST
END
IF WRD = 'PICTURE' THEN DO
PUSH REST
PULL PIC REST
IF PIC = 'IS' THEN DO
PUSH REST
PULL PIC REST
END
END
IF WRD = 'REDEFINES' THEN DO
PUSH REST
PULL REDEFINE REST
END
PUSH REST
PULL WRD REST
END
RETURN
CALCIT:
/**************************************************************/
/* CALCULATE THE PIC LENGTH AND/OR GROUP FIELD LENGTH */
/**************************************************************/
CURRLVL = STRIP(CURRLVL,'L','0')
IF PREVLVL = '' THEN DO
PREVLVL = CURRLVL
LOWLVL = CURRLVL
HILVL = CURRLVL
END
IF CURRLVL >= PREVLVL & PIC = '' THEN DO
ZEDLMSG = 'AROUND LINE 'ERRLINE 'ELEMENTRY WITH NO PICTURE'
'ISPEXEC SETMSG MSG(ISRZ000)'
CALL DRPBF
EXIT
END
IF CURRLVL < PREVLVL & PIC ^= '' THEN DO
ZEDLMSG = 'AROUND LINE 'ERRLINE 'GROUP ITEM HAS A PICTURE,BONEHEAD'
'ISPEXEC SETMSG MSG(ISRZ000)'
CALL DRPBF
EXIT
END
/*****05-02-97**FIX*REDEFINE*PROBLEM*******/
IF (CURRLVL < PREVLVL) THEN DO
IF REDEFINE ^= '' & CURRLVL >= REFLVL THEN DO /* 05-22-97 */
LEVEL.PREVLVL = 0
PREVLVL = CURRLVL
REDEFINE = ''
END
/******************************************/
ELSE DO
CALL GROUP_COMP_3
CALL GROUP_COMP_BIN
LEVEL.CURRLVL = LEVEL.CURRLVL + (LEVEL.PREVLVL * OCCURS)
LEVEL.PREVLVL = 0
PREVLVL = CURRLVL
IF CURRLVL < LOWLVL THEN LOWLVL = CURRLVL
/* 05-22-97 */
IF REDEFINE ^= '' & CURRLVL < REFLVL THEN REFLVL = CURRLVL
END
RETURN
END
CALL PICTURE
/****************05-02-97***FIX*REDEFINE***PROB**/
IF REDEFINE = '' THEN PREVLVL = CURRLVL
REDEFINE = ''
/************************************************/
IF CURRLVL > HILVL THEN HILVL = CURRLVL
RETURN
PICTURE:
/**************************************************************/
/* FIND THE LENGTH OF THE ACTUAL PICTURE CLAUSE */
/**************************************************************/
PIC = STRIP(PIC,'L','S')
PICLEN = 0
PIC = TRANSLATE(PIC,' ','V')
IF POS(')',PIC) = 0 THEN PICLEN = LENGTH(WORD(PIC,1))+LENGTH(WORD(PIC,2))
ELSE DO
PIC = TRANSLATE(PIC,' ',')')
DO WRDNBR = 1 TO WORDS(PIC)
SPEC = WORD(PIC,WRDNBR)
IF POS('(',SPEC) = 0 THEN PICLEN = PICLEN + LENGTH(SPEC)
ELSE DO
SPEC = TRANSLATE(SPEC,' ','(')
PICLEN = PICLEN + LENGTH(WORD(SPEC,1)) + WORD(SPEC,2) - 1
END
END
END
CALL FIELD_COMP_3
CALL FIELD_COMP_BIN
/******************05-02-97***FIX*REDEFINE*PROBLEM*******/
IF REDEFINE = '' THEN DO
LEVEL.CURRLVL = LEVEL.CURRLVL + (PICLEN * OCCURS)
END
/******************************************/
RETURN
FIELD_COMP_3:
/******************************************************/
/* PACK THE FIELD LENGTH IF NEEDED */
/******************************************************/
IF COMP3 ^= 'X' THEN RETURN
PICLEN = (PICLEN % 2 ) + 1
COMP3 = ''
RETURN
GROUP_COMP_3:
/******************************************************/
/* PACK THE GROUP FIELD LENGTH IF NEEDED */
/******************************************************/
IF COMP3 ^= 'X' THEN RETURN
LEVEL.PREVLVL = (LEVEL.PREVLVL % 2) + 1
COMP3 = ''
RETURN
FIELD_COMP_BIN:
/******************************************************/
/* DETERMINE THE BINARY FIELD LENGTH IF NEEDED */
/******************************************************/
IF COMP ^= 'X' THEN RETURN
IF PICLEN > = 1 & PICLEN < = 4 THEN PICLEN = 2
IF PICLEN > = 5 & PICLEN < = 9 THEN PICLEN = 4
IF PICLEN > = 10 & PICLEN < = 18 THEN PICLEN = 8
IF PICLEN > = 19 & PICLEN < = 20 THEN PICLEN = 2
IF PICLEN > 20 THEN DO
CALL DRPBF
ZEDLMSG = 'COMP FIELD EXCEEDS 20 CHARACTERS'
'ISPEXEC SETMSG MSG(ISRZ000)'
EXIT
END
COMP = ''
RETURN
GROUP_COMP_BIN:
/************************************************************/
/* DETERMINE THE BINARY GROUP FIELD LENGTH IF NEEDED */
/************************************************************/
IF COMP ^= 'X' THEN RETURN
IF LEVEL.PREVLVL > = 1 & LEVEL.PREVLVL < = 4 THEN LEVEL.PREVLVL = 2
IF LEVEL.PREVLVL > = 5 & LEVEL.PREVLVL < = 9 THEN LEVEL.PREVLVL = 4
IF LEVEL.PREVLVL > = 10 & LEVEL.PREVLVL < = 18 THEN LEVEL.PREVLVL = 8
IF LEVEL.PREVLVL > = 19 & LEVEL.PREVLVL < = 20 THEN LEVEL.PREVLVL = 2
IF LEVEL.PREVLVL > 20 THEN DO
CALL DRPBF
ZEDLMSG = 'COMP FIELD EXCEEDS 20 CHARACTERS'
'ISPEXEC SETMSG MSG(ISRZ000)'
EXIT
END
COMP = ''
RETURN
LITCHK:
LITCHK = POS("'",PLINE)
IF LITCHK = 0 THEN RETURN
LITCHK = LITCHK + 1
LITCHK2 = POS("'",PLINE,LITCHK)
LITCHK = LITCHK - 2
IF LITCHK2 = 0 THEN RETURN
LITLEN = LITCHK2 + 3
PLINEA = SUBSTR(PLINE,1,LITCHK)
/*********DONT DECOMMENT THIS********************/
/* LITCHK2 = LITCHK2 + 1 */
/*********OR YOU'LL BE SORRY*********************/
/* I AM LEAVING ONE OF THE ' AS A VALUE OR YOULL*/
/* GET A 'VALUE CLAUSE WITH NO VALUE' ERROR MSG */
/************************************************/
PLINEB = SUBSTR(PLINE,LITCHK2)
PLINE = PLINEA PLINEB
RETURN
DRPBF:
/************************************************************/
/* CLEAR THE STACK OUT */
/************************************************************/
DO QUEUED()
PULL DUMMY
END
RETURN
Code;d
