PROGRAM MAP.MODULES
*
*    Application:
*    Parse a CATALOGED object code and record the static code relationships
*    as a basis for documenting an execution and dependency tree.
*
*    Limitations:
*    Currently coded specifically for Pick R83 & D3 variants, predicated on 
*    Pick-format CATALOG pointers.
*
*    ========================================================================
*
*    Conditions of use:
*    This source code is the property and copyright of Gulraj Rijhwani and
*    Courtfields Limited.  Specific licence is granted to copy and use this
*    program source, in accordance with the terms and conditions laid out
*    following.  For the purposes of these terms and conditions the term
*    "developer" is defined to be the individual or company employing the
*    author incorporating use of this source.  Any use of this source code is
*    deemed to be full and unreserved acceptance of these stated terms.
*
*    1)  All instances of this source code must carry all attached
*        annotations and comments including, but not limited to, these
*        these conditions of use in their entirety.
*    2)  The developer may not alter the program source in any way, without
*        first obtaining the express written consent of duly authorised
*        company officers of Courtfields Limited, or its successors.
*    3)  This source code may not be included in whole or in part in any
*        proprietary program suite except as a separately compiled module
*        in wholly unmodified form.  Any installed object code must be
*        accompanied by the original source code at all times.
*    4)  In the event of any breach of these terms and conditions the
*        developer shall be liable for an annual usage charge of 200 pounds
*        sterling for every end user terminal or session using or having
*        access to use the resulting executable code.
*    5)  Gulraj Rijhwani and Courtfields Limited make no warranties for
*        the fitness of this source code, and may not be held liable
*        for any failure to fulfil the expectations or requirements of
*        the developer.
*
*    ========================================================================
*
     BASE.ATT = 8
     skip.strings = 1
     wind.string = '/-\|'
     db.level = 0
*
     port.no = FIELD(OCONV('','U50BB'),' ',1)
*
     OPEN 'MD' TO local.md.file THEN
      OPEN 'PROGRAM.MAP' TO map.file THEN
*
       acct.names = ''
       file.names = ''
       prog.names = ''
*
       IF acct.names='' THEN
        CRT 'Selecting accounts - ':
        winder = 0
        OPEN 'SYSTEM' TO system.file THEN
         SELECT system.file TO system.list
         loop.done = 0
         LOOP
          READNEXT acct.name FROM system.list ELSE loop.done = 1
         UNTIL loop.done DO
          winder = REM(winder,4) + 1
          CRT wind.string[winder,1]:CHAR(8):
          READ acct.rec FROM system.file,acct.name THEN
           IF acct.rec<1>[1,1]='D' THEN
            LOCATE acct.name IN acct.names SETTING a.ptr ELSE
             LOCATE acct.name IN acct.names BY 'AL' SETTING a.ptr ELSE
              acct.names = INSERT(acct.names,a.ptr;acct.name)
             END
            END
           END
          END
         REPEAT
         CRT 'DONE'
         LOOP
         UNTIL acct.names<2>='' DO
          acct.names = INSERT(DELETE(DELETE(acct.names,1),1),1;acct.names<1>:';':acct.names<2>)
         REPEAT
        END
       END
*
       a.ptr = 0
       LOOP
        a.ptr = a.ptr + 1
        acct.name = TRIM(FIELD(acct.names,';',a.ptr))
       UNTIL acct.name='' DO
*
        CRT 'ACCT NAME: "':acct.name:'"'
*
        file.key = 'CF@':acct.name:'@MD'
        READU XXX FROM local.md.file,file.key ELSE XXX=''
        IF XXX<1>='Q' OR XXX<1>='' THEN
         file.ptr = 'Q'
         file.ptr<2> = acct.name
         WRITE file.ptr ON local.md.file,file.key
        END ELSE
         RELEASE local.md.file,file.key
        END
        OPEN file.key TO remote.md.file THEN
         sel.cmd = ''
         FOR a=DCOUNT(prog.names,';') TO 1 STEP -1
          sel.cmd = '"':FIELD(prog.names,';',a):'"':sel.cmd
         NEXT a
         IF sel.cmd='' ELSE sel.cmd = ' ':sel.cmd
         sel.cmd = 'SSELECT ':file.key:sel.cmd
         EXECUTE sel.cmd CAPTURING BA
         SELECT remote.md.file TO remote.list
        END ELSE
         remote.list = ''
        END
*
        routine.list = ''
        loop.done = 0
        LOOP
         READNEXT prog.name FROM remote.list ELSE loop.done = 1
        UNTIL loop.done DO
         READ catalog.ptr FROM remote.md.file,prog.name ELSE catalog.ptr = ''
         BEGIN CASE
          CASE catalog.ptr<1>='P' AND catalog.ptr<2>='E6'
           catalog.ptr = catalog.ptr<5>
          CASE catalog.ptr<1>='vr'
           catalog.ptr = catalog.ptr<4>
          CASE 1
           catalog.ptr = ''
         END CASE
         IF catalog.ptr='' ELSE
          routine.list<1> = prog.name
          routine.list<2> = FIELD(catalog.ptr<1>,' ',1)
          GOSUB 1000
         END
        REPEAT
*
       REPEAT
*
      END
     END
*
     GOTO 9999
*
1000 *
*
     p.ctr = 0
*
     LOOP
     UNTIL routine.list<1>='' DO
*
      p.ctr = p.ctr + 1
      prog.name = routine.list<1,1>
      routine.list = DELETE(routine.list,1,1)
      file.name = routine.list<2,1>
      routine.list = DELETE(routine.list,2,1)
*
      LOCATE prog.name IN routine.list<3> BY 'AL' SETTING p.ptr ELSE
       routine.list = INSERT(routine.list,3,p.ptr;prog.name)
*
       READ catalog.ptr FROM remote.md.file,prog.name ELSE catalog.ptr = ''
       GOSUB 2200; * Interpret catalog pointer
       parent.acct = child.acct
       parent.file = child.file
       IF catalog.ptr<1>='' ELSE file.name = catalog.ptr<1>
       source.name = catalog.ptr<2>
       IF source.name = '' THEN source.name = prog.name
*
       IF FIELD(source.name,'.',1)='PIX' OR FIELD(source.name,'.',1)='WIN' ELSE
        CRT SPACE(2):'PROGRAM: (':p.ctr:') ':file.name:' ':prog.name:
*
        READ file.ptr FROM remote.md.file,file.name THEN
*
         IF file.ptr<1>='Q' ELSE
          file.ptr = 'Q'
          file.ptr<2> = acct.name
          file.ptr<3> = file.name
         END
*
         file.key = 'CF@':acct.name:'@':file.name
         READU XXX FROM local.md.file,file.key ELSE XXX='Q'
         IF XXX<1>='Q' THEN
          WRITE file.ptr ON local.md.file,file.key
         END ELSE
          RELEASE local.md.file,file.key
         END
*
         OPEN file.key TO program.file THEN
*
          READ parent.source FROM program.file,source.name THEN
*
           IF file.name='' THEN
            CRT 'File name error (calling program)'
            DEBUG
           END
           no.lines = DCOUNT(parent.source,CHAR(254))
           parent.key = parent.acct:'*':parent.file:'*':prog.name
           READU parent.details FROM map.file,parent.key ELSE parent.details=''
           IF source.name#prog.name THEN parent.details<2> = source.name
           parent.details<3> = parent.file
           parent.details<4> = parent.acct
           parent.details<5> = no.lines
           WRITE parent.details ON map.file,parent.key
*
           parent.details<2> = source.name
           READU XXX FROM map.file,port.no ELSE NULL
           WRITE parent.details ON map.file,port.no
*
           CRT ' ':no.lines
*
           FOR line.no = 1 TO no.lines
            source.line = parent.source<line.no>
            CRT SPACE(4):line.no'R%4':CHAR(13):
            GOSUB 2000
           NEXT line.no
*
           READU XXX FROM map.file,port.no THEN
            DELETE map.file,port.no
           END ELSE
            RELEASE map.file,port.no
           END
*
          END ELSE
           CRT ' - no source'
          END
*
         END ELSE
          PRINT ' - cannot open source file (':parent.file:' in ':parent.acct:')'
         END
*
        END ELSE
         CRT ' - cannot retrieve file pointer (':file.name:' in MD of ':acct.name:')'
        END
*
       END
      END
*
     REPEAT
*
     RETURN
*
2000 *
*
     IF db.level THEN
      CRT source.line
     END
     cp = 1
     LOOP
      GOSUB 2100 ; * Get word
     UNTIL word='' OR word[1,1]='*' OR word[1,1]='!' OR word='REM' DO
*
      BEGIN CASE
       CASE word='CALL' OR word='CHAIN' OR word='EXECUTE'
*
        token = word
*
        BEGIN CASE
         CASE token='CHAIN' OR token='EXECUTE'
          OSET = 6
          skip.strings = 0
          ASSUME.CODE = 0
         CASE 1
          OSET = 0
          ASSUME.CODE = 1
        END CASE
        GOSUB 2100
        skip.strings = 1
*
        CRT SPACE(4):line.no'R%4':' ':token:' ':string:' ':
*
        BEGIN CASE
         CASE token='CALL'
          IF string[1,1]='@' THEN word = ''
         CASE 1
          ch = string[1,1]
          IF ch='"' OR ch="'" OR ch='\' ELSE word = ''
        END CASE
*
        IF word='' THEN
* DEBUG
        END ELSE
         child.routine = word
         READ catalog.ptr FROM remote.md.file,child.routine ELSE catalog.ptr = ''
*        IF ASSUME.CODE OR (catalog.ptr<1>='P' AND catalog.ptr<2>='E6')ELSE word = ''
         BEGIN CASE
          CASE ASSUME.CODE
           NULL
          CASE catalog.ptr<1>='P' AND catalog.ptr<2>='E6'
           NULL
          CASE catalog.ptr<1>='vr'
           NULL
          CASE 1
           word = ''
         END CASE
        END
*
        IF word='' THEN
         CRT '- ':
        END ELSE
*
         GOSUB 2200; * Interpret catalog pointer
         LOCATE child.routine IN routine.list<3> SETTING p.ptr ELSE
          LOCATE child.routine IN routine.list<1> SETTING p.ptr ELSE
           routine.list = INSERT(routine.list,1,p.ptr;child.routine)
           routine.list = INSERT(routine.list,2,p.ptr;catalog.ptr<1>)
           IF routine.list<2,p.ptr>='' THEN routine.list<2,p.ptr> = file.name
           CRT '* ':
          END
         END
*
         f.base = BASE.ATT + OSET
         READU parent.details FROM map.file,parent.key ELSE parent.details=''
         LOCATE child.routine IN parent.details<f.base> SETTING call.ptr ELSE
          LOCATE child.routine IN parent.details<f.base> BY 'AL' SETTING call.ptr ELSE
           parent.details = INSERT(parent.details,f.base,call.ptr;child.routine)
           parent.details = INSERT(parent.details,f.base+1,call.ptr;'') 
           parent.details = INSERT(parent.details,f.base+2,call.ptr;'') 
          END
         END
         parent.details<f.base+1,call.ptr> = child.file
         parent.details<f.base+2,call.ptr> = child.acct
         WRITE parent.details ON map.file,parent.key
*
         IF child.file='' THEN
          CRT 'File name error (called routine)'
          DEBUG
         END
*        child.key = acct.name:'*':child.acct:'*':child.file:'*':child.routine
         child.key = child.acct:'*':child.file:'*':child.routine
         READU child.details FROM map.file,child.key ELSE child.details=''
         LOCATE prog.name IN child.details<f.base+3> SETTING call.ptr ELSE
          LOCATE prog.name IN child.details<f.base+3> BY 'AL' SETTING call.ptr ELSE NULL
         END
         LOOP
          located = (child.details<f.base+3,call.ptr>=prog.name)
          IF located THEN located = (child.details<f.base+4,call.ptr>=file.name)
          IF located THEN located = (child.details<f.base+5,call.ptr>=acct.name)
         UNTIL located OR (child.details<f.base+3,call.ptr>#prog.name) DO
          call.ptr = call.ptr + 1
         REPEAT
         IF located ELSE
          child.details = INSERT(child.details,f.base+3,call.ptr;prog.name)
          child.details = INSERT(child.details,f.base+4,call.ptr;file.name)
          child.details = INSERT(child.details,f.base+5,call.ptr;acct.name)
          WRITEU child.details ON map.file,child.key
         END
         RELEASE map.file,child.key
        END
        PRINT
*
      END CASE
*
     REPEAT
*
     RETURN
*
2100 *
*
     GOSUB 3000 ; * Skip spaces
     IF db.level THEN DEBUG
     quote.char = ''
     start.cp = cp
     string = ''
     LOOP
      ch = source.line[cp,1]
      IF ch=CHAR(9) THEN ch = ' '
      is.word = (quote.char#'')AND ch#''
      is.quote = (ch='\' OR ch='"' OR ch="'")
      IF is.word ELSE
       is.word = is.quote
       is.word = is.word OR (OCONV(ch,'MCA')=ch OR OCONV(ch,'MCN')=ch) AND ch#''
       is.word = is.word OR (ch='@' OR ch='.' OR ch='_' OR ch='$' OR ch='*' OR ch='!' OR ch=':') 
      END
     WHILE is.word DO
      BEGIN CASE
       CASE quote.char='' AND is.quote
        quote.char = ch
       CASE quote.char=ch
        quote.char = ''
      END CASE
      string = string:ch
      cp = cp + 1
     REPEAT
*
     word = FIELD(string,' ',1)
     ch = word[1,1]
     IF ch="'" OR ch='"' OR ch='\' THEN
      word = FIELD(word,ch,2)
     END
*
     RETURN
*
2200 *
*
     catalog.error = 0
*
     child.acct = acct.name
     BEGIN CASE
      CASE catalog.ptr<1>='P' AND catalog.ptr<2>='E6'
       catalog.ptr = catalog.ptr<5>
      CASE catalog.ptr<1>='VR'
       catalog.ptr = catalog.ptr<4>
      CASE 1
       catalog.ptr = ''
     END CASE
*
     catalog.ptr<2> = FIELD(catalog.ptr,' ',2)
     catalog.ptr<1> = FIELD(catalog.ptr<1>,' ',1)
     IF catalog.ptr<2>='' THEN catalog.ptr = INSERT(catalog.ptr,1;'')
*
     child.file = catalog.ptr<1>
     IF child.file='' THEN child.file = file.name
     file.type = ''
     remote.catalog.file = remote.md.file
     FOR file.level=1 TO 10 UNTIL file.type='D' OR catalog.error
      READ file.ptr FROM remote.catalog.file,child.file ELSE file.ptr = ''
      file.type = file.ptr<1>[1,1]
      BEGIN CASE
       CASE file.type='D'
        NULL
       CASE file.type='Q'
        child.acct = file.ptr<2>
        child.file = file.ptr<3>
        q.rec = 'Q'
        q.rec<2> = child.acct
        q.key = '$CK$':port.no
        q.key.ok = 1
        READU xxx FROM local.md.file,q.key THEN
         q.key.ok = xxx<1>[1,1]#'D'
         q.key.ok = q.key.ok AND xxx<1>#'vr' AND xxx<1>[1,1]#'P'
        END
        IF q.key.ok THEN
         WRITEU q.rec ON local.md.file,q.key
        END
        RELEASE local.md.file,q.key
        IF q.key.ok THEN OPEN q.key TO remote.catalog.file ELSE q.key.ok = 0
        IF q.key.ok ELSE catalog.error = 1
       CASE 1
        catalog.error = 1
      END CASE
     NEXT file.level
     IF catalog.error ELSE catalog.error = (file.type#'D')
*
     IF catalog.error ELSE
      IF catalog.ptr<2>='' ELSE
       child.routine = catalog.ptr<2>
      END
     END
*
     RETURN
*
3000 *
*
     GOSUB 3100
*
     RETURN
*
3100 *
*
     skip.more = 1
*
     LOOP
      ch = source.line[cp,1]
      BEGIN CASE
       CASE ch = ''
        skip.more = 0
       CASE OCONV(ch,'MCAN') =ch
        skip.more = 0
       CASE ch='*' OR ch='!'
        IF db.level THEN DEBUG
        skip.more = 0
       CASE ch='('
        GOSUB 3200
       CASE (ch='"' OR ch="'" OR ch="\")
        IF skip.strings THEN
         GOSUB 3300
        END ELSE
         skip.more = 0
        END
       CASE 1
        cp = cp + 1
      END CASE
     WHILE skip.more DO
     REPEAT
*
     RETURN
*
3200 *
*
     bracket.closed = 0
     LOOP
      cp = cp + 1
      ch = source.line[cp,1]
      BEGIN CASE
       CASE ch='('
        GOSUB 3200
       CASE ch='"' OR ch="'" OR ch='\'
        GOSUB 3300
      END CASE
     UNTIL bracket.closed DO
      bracket.closed = (ch=')' OR ch='') 
     REPEAT
*
     RETURN
*
3300 *
*
     string.closed = 0
     end.string = ch
     LOOP
      cp = cp + 1
      ch = source.line[cp,1]
     UNTIL string.closed DO
      string.closed = (ch=end.string OR ch='') 
     REPEAT
*
     RETURN
*
9999 * Exit