Find the record length in cobol



IBM's Command List programming language & Restructured Extended Executor

Find the record length in cobol

Postby David2k8 » Mon Mar 23, 2015 10:43 am

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


Code;d
David2k8
 
Posts: 7
Joined: Mon Mar 23, 2015 10:32 am
Has thanked: 0 time
Been thanked: 2 times

Return to CLIST & REXX

 


  • Related topics
    Replies
    Views
    Last post