Portal | Manuals | References | Downloads | Info | Programs | JCLs | Master the Mainframes
IBM Mainframe Computers Forums Index
 
Register
 
IBM Mainframe Computers Forums Index Mainframe: Search IBM Mainframe Forum: FAQ Memberlist Usergroups Profile Log in to check your private messages Log in
 

 

COBDFSYM code text

 
Post new topic   Reply to topic    IBMMAINFRAMES.com Support Forums -> DFSORT/ICETOOL
View previous topic :: :: View next topic  
Author Message
smijoss

Active User


Joined: 30 Aug 2007
Posts: 114
Location: pune

PostPosted: Mon Jul 12, 2010 12:15 pm    Post subject: COBDFSYM code text
Reply with quote

Hi,

Does anyone have the COBDFSYM code. I tried copying it from the PDF but it doesnt seem to work.It enters into some infinite loop. mainly because the text is getting altered.

I got a FTP link. but Ftps are blocked here. can i find it on some site or email it at E-addr removed or may be attach it here.
Back to top
View user's profile Send private message

smijoss

Active User


Joined: 30 Aug 2007
Posts: 114
Location: pune

PostPosted: Mon Jul 12, 2010 8:31 pm    Post subject: Reply to: COBDFSYM code text
Reply with quote

hi..

i found it ... in case any 1 needs it for future referenec.. i have attached it.
(attachment deleted)

Code:
/*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
Back to top
View user's profile Send private message
dbzTHEdinosauer

Global Moderator


Joined: 20 Oct 2006
Posts: 6966
Location: porcelain throne

PostPosted: Mon Jul 12, 2010 8:42 pm    Post subject:
Reply with quote

does the download contain the version that
Quote:
... doesnt seem to work.It enters into some infinite loop. mainly because the text is getting altered.


or does the download contain code that actually works?
Back to top
View user's profile Send private message
smijoss

Active User


Joined: 30 Aug 2007
Posts: 114
Location: pune

PostPosted: Tue Jul 13, 2010 11:22 am    Post subject:
Reply with quote

the first code i had taken from the PDF. it didnt work since multiple spaces were getting converted to 1.

However the one i obtained from the FTP site too seems to be in a deadlock.

Has anyone faced such a problem ??
Back to top
View user's profile Send private message
smijoss

Active User


Joined: 30 Aug 2007
Posts: 114
Location: pune

PostPosted: Tue Jul 13, 2010 1:54 pm    Post subject:
Reply with quote

HI ,

it finally worked. the code had to be converted into uppercase.

found it by trace r. my mistake.
Back to top
View user's profile Send private message
dick scherrer

Site Director


Joined: 23 Nov 2006
Posts: 19270
Location: Inside the Matrix

PostPosted: Tue Jul 13, 2010 7:37 pm    Post subject: Reply to: COBDFSYM code text
Reply with quote

Thanks for letting us know icon_smile.gif

d
Back to top
View user's profile Send private message
Frank Yaeger

DFSORT Moderator


Joined: 15 Feb 2005
Posts: 7130
Location: San Jose, CA

PostPosted: Tue Jul 13, 2010 10:54 pm    Post subject:
Reply with quote

Quote:
However the one i obtained from the FTP site too seems to be in a deadlock.


Quote:
it finally worked. the code had to be converted into uppercase.


This must be something peculiar to your system. I've run COBDFSYM fine as downloaded with no changes (as have many other people).
Back to top
View user's profile Send private message
Ronald Burr

Active User


Joined: 22 Oct 2009
Posts: 293
Location: U.S.A.

PostPosted: Tue Jul 13, 2010 11:16 pm    Post subject:
Reply with quote

Frank, I "think" he meant that the COBOL source code ( input to the Rexx Exec ) had to be changed to all uppercase, not the Rexx Exec itself.
Back to top
View user's profile Send private message
Frank Yaeger

DFSORT Moderator


Joined: 15 Feb 2005
Posts: 7130
Location: San Jose, CA

PostPosted: Tue Jul 13, 2010 11:20 pm    Post subject:
Reply with quote

Wow, I never would have figured that out from what the OP posted considering he never even mentioned the COBOL source code.
Back to top
View user's profile Send private message
smijoss

Active User


Joined: 30 Aug 2007
Posts: 114
Location: pune

PostPosted: Wed Jul 14, 2010 2:00 pm    Post subject:
Reply with quote

No. i had to change the REXX code to upper case.

the cobol source code is always in capital .. i have never seen them in lowercase.
Back to top
View user's profile Send private message
enrico-sorichetti

Global Moderator


Joined: 14 Mar 2007
Posts: 10203
Location: italy

PostPosted: Wed Jul 14, 2010 2:46 pm    Post subject: Reply to: COBDFSYM code text
Reply with quote

Quote:
No. i had to change the REXX code to upper case.


the problem must be somewhere else, and You inferred a wrong conclusion!

mixed case REXX scripts have always worked without any issues
Back to top
View user's profile Send private message
dick scherrer

Site Director


Joined: 23 Nov 2006
Posts: 19270
Location: Inside the Matrix

PostPosted: Wed Jul 14, 2010 8:03 pm    Post subject:
Reply with quote

Hello,

Quote:
the cobol source code is always in capital .. i have never seen them in lowercase.
The posted rexx looks like it will only work for COBOL source with uppercase, but the compiler allows source with mixed case.
Back to top
View user's profile Send private message
ojdiaz

New User


Joined: 19 Nov 2008
Posts: 90
Location: Spain

PostPosted: Thu Jul 15, 2010 2:16 pm    Post subject:
Reply with quote

Sometime in the past it happened the same to me. I downloaded the code from a different source and it worked. I think that the one in the PDF worked fine for me. My problem was that when I uploaded it to the HOST system, all "|" were changed to "&" chars and that gave me errors, but i don't remember if that was the infinite loop.

As for the rexx code, it works fine in all the shops i have used it with mixed case letters
Back to top
View user's profile Send private message
View previous topic :: :: View next topic  
Post new topic   Reply to topic    IBMMAINFRAMES.com Support Forums -> DFSORT/ICETOOL All times are GMT + 6 Hours
Page 1 of 1

 

Search our Forum:

Similar Topics
Topic Author Forum Replies Posted
No new posts PL/I code tuning/Performance improvement Virendra Shambharkar PL/I & Assembler 4 Mon Dec 05, 2016 11:57 am
No new posts What is the code in CLIST to enable t... jackzhang75 CLIST & REXX 1 Fri Dec 02, 2016 3:02 am
No new posts IDEAL - Code Retrieval yugendran CA Products 0 Fri Nov 25, 2016 3:27 pm
No new posts How to update a portion of text in a ... Bill Woodger DFSORT/ICETOOL 25 Wed Nov 09, 2016 9:41 pm
This topic is locked: you cannot edit posts or make replies. Need to code a Rexx PGM sundaram.naveen CLIST & REXX 18 Thu Oct 06, 2016 6:45 pm


Facebook
Back to Top
 
Mainframe Wiki | Forum Rules | Bookmarks | Subscriptions | FAQ | Tutorials | Contact Us