/*REXX - COBDFSYM : Create DFSORT symbols from COBOL listing
*** Freeware courtesy of SEB IT Partner and IBM ***
trace r
*/
call read_coblist
call fix_duplicates
call put_symnames
exit
Put_symnames:
/* Write generated symbol definitions */
   do i = 1 to nf
     queue dnam.i','dval.i
     say   dnam.i','dval.i
   end
/* Write appended  symbol definitions */
   do i = 1 to na
     queue dapp.i
     say   dapp.i
   end
   queue ''
   'EXECIO * DISKW SYMNAMES (FINIS'
   return
Put_line:
/*   Analyze Data Division Map line     */
   parse var line linenr level dataname .
   parse var dataname dataname '.' .
   if dataname = 'FILLER'   then Return
   if level = 'PROGRAM-ID'  then Return
   if level = 88            then Do
     nf = nf + 1
     dnam.nf  = dataname
     dval.nf  = d88.linenr
     dlvl.nf  = lev
     Return
   end
   blk      = substr(line,64,4)
   if level = 1 then nf = 0
   hexoff   = substr(line,79,3) || substr(line,83,3)
   if hexoff = '      ' then hexoff = '000000'
   parse var line 92 asmdef datatyp .
   if datatyp = 'Group' | datatyp = 'Grp-VarLen'
        then parse var asmdef . 'CL' len
        else do
         len = left(asmdef,length(asmdef)-1)
         if right(asmdef,2) = '1H' then len = 2
         if right(asmdef,2) = '1F' then len = 4
         if right(asmdef,2) = '2F' then len = 8
        end

   select
     when datatyp = 'Group'         then typ = 'CH'
     when datatyp = 'Grp-VarLen'    then typ = 'CH'
     when datatyp = 'Display'       then typ = 'CH'
     when datatyp = 'Disp-Num'      then typ = 'ZD'
     when datatyp = 'Packed-Dec'    then typ = 'PD'
     when datatyp = 'Binary'        then typ = 'FI'
     when datatyp = 'Comp-1'        then typ = 'FL'
     when datatyp = 'Comp-2'        then typ = 'FL'
     otherwise                           typ = 'CH'
   end
   if typ = 'FI' then do
     if s9.linenr /= 'Y' then typ = 'BI'
   end
   else do
     if typ = 'ZD' then
       if sp.linenr = 'Y' then
         if ld.linenr = 'Y' then typ = 'FS'
         else typ = 'CST'
       else
         if ld.linenr = 'Y' then typ = 'CLO'
   end
   off = 1 + x2d(hexoff)
   nf = nf + 1
   dnam.nf  = dataname
   dval.nf  = off','len','typ
   dlvl.nf  = lev
Return
Read_COBLIST:
   l88 = 0
   lx = 0
   na  = 0
   'EXECIO * DISKR COBLIST (FINIS'
   parse pull line
   do until substr(line,2,16)  = '  LineID  PL SL '
      parse pull line
   end
/* Process program text lines */
   do until substr(line,2,16) /= '  LineID  PL SL '
      parse pull line
      do until left(line,1) = '1'
         call Check_Code_line
         parse pull line
      end
      parse pull line
   end
/* Skip lines */
   do until substr(line,2,18)  = 'LineID   Data Name'
      parse pull line
   end
/* Process Data Division Map lines */
   do until substr(line,2,18) /= 'LineID   Data Name'
      parse pull line
      do until left(line,1) = '1'
         call Put_line
         parse pull line
      end
      parse pull line
      parse pull line
   end
/* Skip rest  */
   do until queued() = 0
      parse pull line
   end
Return
Fix_Duplicates:
/* Append _n to any duplicate data names */
   nd = 0
   tdup. = ''
   Do i = 1 to nf
      nam = dnam.i
      parse var tdup.nam flag i1
      if flag     = '' then do
         tdup.nam = '0' i
         iterate
      end
      if flag     = '0' then do
         nd = nd + 1
         td1.nd = i1 i
         tdup.nam = '1' nd
         iterate
      end
      td1.i1 = td1.i1 i
   End
   Do id = 1 to nd
      parse var td1.id i tail
      n = 0
      Do while i /= ''
         n = n + 1
         dnam.i = dnam.i || '_' || n
         parse var tail i tail
      End
   End
Return
Check_code_line:
/* Analyze program text line , capture 88 VALUE clauses */
/* Capture S9, LEADING, SEPARATE parameters             */
/* Make append lines from *+ comments                   */
   parse var line 4 linenr 10 flag . 19 . 25 stmt 91
   if linenr = '' then return
   linenr = linenr + 0
   if left(stmt,2) = '*+' then do
     na = na + 1
     dapp.na = substr(stmt,3)
     return
   end
   if left(stmt,1) = '*'  then return
   if left(stmt,1) = '/'  then return
   if lastpos('.',stmt) = 0 then do
     parse pull line
     if left(line,1) = '1' then parse pull line
     if substr(line,2,16) = '  LineID  PL SL ' then parse pull line
     parse var line 4 x1 10 x2 . 19 . 25 stmt2 91
     stmt = stmt||stmt2
   end
   parse var stmt w1 .
   if w1 = '88' then do
    l88 = linenr
    if l88 /= 0 then do
      parse var stmt . 'VALUE' tail
      if tail /= '' then do
         parse var tail value '.' .
         d88.l88 = strip(value)
         if left(d88.l88,6) = 'SPACES'
           then d88.l88 = ''' '''
         if left(d88.l88,4) = 'ZERO'
           then d88.l88 = '0'
         if left(d88.l88,9) = 'LOW-VALUE'
           then d88.l88 = 'X''00'''
         l88 = 0
      end
    end
    return
   end
   else do
    lx = linenr
    if lx /= 0 then do
     parse var stmt x1 x2 x3
     if pos(' S9',x3) /=0 then s9.lx = 'Y'
     if pos(' LEADING',x3) /=0 then ld.lx ='Y'
     if pos(' SEPARATE',x3) /=0 then sp.lx = 'Y'
     lx = 0
    end
   end
Return