/* REXX - %include book parser                                        */
/*** trace ?r ***************************************************** \| *
*               (C) Copyright Robert AH Prins, 1992-2016               *
************************************************************************
*  ------------------------------------------------------------------  *
* | Date       | By   | Remarks                                      | *
* |------------+------+----------------------------------------------| *
* |            |      |                                              | *
* |------------+------+----------------------------------------------| *
* | 2016-02-11 | RAHP | Add support for AREA                         | *
* |------------+------+----------------------------------------------| *
* | 2009-04-22 | RAHP | Update comment                               | *
* |------------+------+----------------------------------------------| *
* | 2009-03-30 | RAHP | Put under GPL V3                             | *
* |------------+------+----------------------------------------------| *
* | 2009-03-16 | RAHP | Replace LISTDSI by BXPWDYN                   | *
* |------------+------+----------------------------------------------| *
* | 2007-09-24 | RAHP | Remove call to 'GETTEMP'                     | *
* |------------+------+----------------------------------------------| *
* | 2007-08-30 | RAHP | Use '(C)' comment delimiters in parse code   | *
* |------------+------+----------------------------------------------| *
* | 2007-08-16 | RAHP | Split comment delimiters in strings          | *
* |------------+------+----------------------------------------------| *
* | 2007-04-03 | RAHP | Map FILE to pointer                          | *
* |------------+------+----------------------------------------------| *
* | 2007-03-26 | RAHP | Store pop-up panel in exec                   | *
* |------------+------+----------------------------------------------| *
* | 2005-03-31 | RAHP | Add support for CHAR lengths > 9999          | *
* |------------+------+----------------------------------------------| *
* | 2001-06-14 | RAHP | Add support for BIT & FLOAT                  | *
* |            |      | Reduce levels to lowest possible             | *
* |------------+------+----------------------------------------------| *
* | 1997-12-04 | RAHP | Allow INIT(IAL) in structures                | *
* |            |      | (INIT(IAL) CALL not yet supported and don't  | *
* |            |      | use INIT(IAL) as a name...)                  | *
* |------------+------+----------------------------------------------| *
* | 1997-05-24 | RAHP | Use GETVAR for some variables                | *
* |------------+------+----------------------------------------------| *
* | 1995-07-10 | RAHP | Add minimal support for bit variables        | *
* |            |      | (Treat as CHAR and ALIGNED!)                 | *
* |------------+------+----------------------------------------------| *
* | 1995-04-21 | RAHP | Add support for nested %includes             | *
* |------------+------+----------------------------------------------| *
* | 1994-11-02 | RAHP | Add call to GURU for errors                  | *
* |------------+------+----------------------------------------------| *
* | 1993-11-01 | RAHP | Add support for pointers                     | *
* |------------+------+----------------------------------------------| *
* | 1992-02-20 | RAHP | Initial version                              | *
* |------------+------+----------------------------------------------| *
************************************************************************
* Name      - RAP00110                                                 *
*                                                                      *
* Function  - Parse a PL/I structure into a well defined format for    *
*             use by other utilities                                   *
*                                                                      *
* Arguments - PL/I %include book compressed into a single record with  *
*             x'ff' separating the original fields                     *
*           - Optional, 'E' to 'explode' the arrays within the first   *
*             argument                                                 *
*           - Optional, 'nopli', to omit PL/I attributes from the      *
*             returned record                                          *
*                                                                      *
* Returns  : A single record containing a detailed break-up of the     *
*            original PL/I %include book.                              *
*                                                                      *
*            The record has the following structure:                   *
*                                                                      *
*            HEAD  : x'00ffd9d7'                                       *
*                                                                      *
*            followed by                                               *
*                                                                      *
*            LEVEL : level of element of structure                     *
*            SEP   : x'ff'                                             *
*            NAME  : name of element of structure                      *
*            SEP   : x'ff'                                             *
*            PLI   : PL/I attributes (Not if 'nopli' is specified)     *
*            SEP   : x'ff'                                             *
*            LENGTH: - bytes for FIXED BIN & CHAR variables            *
*                    - digits for FIXED & PIC variables                *
*            SEP   : x'ff'                                             *
*            PREC  : precision for FIXED & PIC variables               *
*            SEP   : x'ff'                                             *
*            TYPE  : one character type of element descriptor          *
*                     - A: pointer                                     *
*                     - B: fixed bin                                   *
*                     - C: char                                        *
*                     - D: float                                       *
*                     - F: fixed                                       *
*                     - I: bit                                         *
*                     - L: major structure                             *
*                     - P: picture                                     *
*                     - R: area                                        *
*                     - V: char var                                    *
*            SEP   : x'01d9d701'                                       *
*                                                                      *
*            for each element of the original structure, followed by   *
*                                                                      *
*            TAIL  : x'd7d9ff00'                                       *
*                                                                      *
* An example of the usage of this module is:                           *
*                                                                      *
* 'execio * diskr idsn ( stem anyvar. finis'                           *
*                                                                      *
* compress = ''                                                        *
* do i = 1 to anyvar.0                                                 *
*   compress = compress || x2c(ff) || strip(substr(anyvar.i, 2, 71))   *
* end                                                                  *
*                                                                      *
* call rap00110 compress (,e) (,nopli)                                 *
*                                                                      *
* tmp  = result                                                        *
*                                                                      *
* head = x2c(00ffd9d7)                                                 *
* tail = reverse(head)                                                 *
* sep  = x2c(ff)                                                       *
* rsep = x2c(01d9d701)                                                 *
*                                                                      *
* if substr(tmp, 1, 4) \= head |,                                      *
*    substr(tmp, length(tmp) - 3, 4) \= tail then                      *
*   do                                                                 *
*     say 'The parser has returned an invalid string,',                *
*         'processing terminated'                                      *
*     exit                                                             *
*   end                                                                *
*                                                                      *
* drop v.                                                              *
* vi    = 0                                                            *
*                                                                      *
* tmp = substr(tmp, 5)                                                 *
*                                                                      *
* do until tmp = tail                                                  *
*   vi = vi + 1                                                        *
*   parse value tmp with v.vi.lev (sep),                               *
*                        v.vi.nam (sep),                               *
*                        v.vi.pli (sep),                               *
*                        v.vi.len (sep),                               *
*                        v.vi.prc (sep),                               *
*                        v.vi.typ (rsep) tmp                           *
* end                                                                  *
*                                                                      *
* v.0 = vi                                                             *
************************************************************************
* Send questions, suggestions and/or bug reports to:                   *
*                                                                      *
* robert@prino.org / robert.ah.prins@gmail.com                         *
*                                                                      *
* Robert AH Prins                                                      *
* Taboralaan 46                                                        *
* 8400 Oostende                                                        *
* Belgium                                                              *
************************************************************************
* This program is free software: you can redistribute it and/or        *
* modify it under the terms of the GNU General Public License as       *
* published by the Free Software Foundation, either version 3 of       *
* the License, or (at your option) any later version.                  *
*                                                                      *
* This program is distributed in the hope that it will be useful,      *
* but WITHOUT ANY WARRANTY; without even the implied warranty of       *
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the         *
* GNU General Public License for more details.                         *
*                                                                      *
* You should have received a copy of the GNU General Public License    *
* along with this program. If not, see <http://www.gnu.org/licenses/>  *
***********************************************************************/
rap00110:
  arg inrec, expand, nopli

  parse source source
  parse value source with . . moi .
  signal on syntax

  sep   = x2c(ff)
  tmp   = translate(space(inrec))
  scom  = '/' || '*'
  ecom  = '*' || '/'

  do until post = ''
    parse value tmp with pre (scom) comment (ecom) post
    tmp = pre || post
  end

  inrec = tmp

  /*-------------------------------------------------------------------+
  | Resolve any embedded %INCLUDEs                                     |
  +-------------------------------------------------------------------*/
  do while pos('%INCLUDE', inrec) \= 0
    parse value inrec with pre '%INCLUDE' rapinc ';' post
    rapinc = strip(rapinc)
    call pop_up

    if result \= 'RESULT' then
      inrec = pre || result || post
  end

  in.0  = 8
  in.1  = ' INIT('
  in.2  = sep || 'INIT('
  in.3  = ' INIT ('
  in.4  = sep || 'INIT ('
  in.5  = ' INITIAL('
  in.6  = sep || 'INITIAL('
  in.7  = ' INITIAL ('
  in.8  = sep || 'INITIAL ('
  in.9  = ' INIT CALL '
  in.10 = sep || 'INIT CALL '
  in.11 = ' INITIAL CALL '
  in.12 = sep || 'INITIAL CALL '

  /*-------------------------------------------------------------------+
  | Remove any initialisations, except calls...                        |
  +-------------------------------------------------------------------*/
  do i = 1 to in.0
    l = length(in.i)
    p = pos(in.i, inrec)

    do while p \= 0
      pre  = substr(inrec, 1, p - 1)
      post = substr(inrec, p + l)

      par = 1

      do p = 1 until par = 0
        c = substr(post, p, 1)

        select
          when c = ')' then par = par - 1
          when c = '(' then par = par + 1
          otherwise
        end
      end

      inrec = pre || substr(post, p + 1)

      p = pos(in.i, inrec)
    end
  end

  vi     = 0
  r      = ''
  drop v.
  arrays = 0

  /*-------------------------------------------------------------------+
  | Main parse loop                                                    |
  +-------------------------------------------------------------------*/
  do until inrec = ''
    parse value strip(inrec) with t (sep) inrec
    t = r strip(t)
    if substr(t, length(t), 1) \= ',' &,
       substr(t, length(t), 1) \= ';' then
      r = t
    else
      if strip(t) \= '' then
        do
          r = ''
          parse value strip(t) with level ' ' t

          if level = 'DCL' |,
             level = 'DECLARE' then
            parse value strip(t) with level ' ' t

          parse value strip(t) with name  ' ' type

          level = strip(level, 'l', '0')
          name  = strip(name)
          type  = strip(type)

          if substr(type, 1, 1) = '(' then
            do
              parse value type with array ')' type
              type  = strip(type)
              name  = name || strip(array)')'
            end

          /*-----------------------------------------------------------+
          | Get rid of 'UNALIGNED'                                     |
          +-----------------------------------------------------------*/
          parse value type with pre 'UNALIGNED' type
          type = strip(pre)strip(type)

          /*-----------------------------------------------------------+
          | Get rid of 'UNAL'                                          |
          +-----------------------------------------------------------*/
          parse value type with pre 'UNAL' type
          type = strip(pre)strip(type)

          /*-----------------------------------------------------------+
          | Get rid of 'ALIGNED'                                       |
          +-----------------------------------------------------------*/
          parse value type with pre 'ALIGNED' type
          type = strip(pre)strip(type)

          /*-----------------------------------------------------------+
          | Get rid of 'DECIMAL'                                       |
          +-----------------------------------------------------------*/
          parse value type with pre 'DECIMAL' type
          type = strip(pre)strip(type)

          /*-----------------------------------------------------------+
          | Get rid of 'DEC'                                           |
          +-----------------------------------------------------------*/
          parse value type with pre 'DEC' type
          type = strip(pre)strip(type)

          /*-----------------------------------------------------------+
          | Get rid of 'TURE' (from picture)                           |
          +-----------------------------------------------------------*/
          parse value type with pre 'TURE' type
          type = strip(pre)strip(type)

          /*-----------------------------------------------------------+
          | Get rid of 'ARY' (from binary)                             |
          +-----------------------------------------------------------*/
          parse value type with pre 'ARY' type
          type = strip(pre)strip(type)

          /*-----------------------------------------------------------+
          | Get rid of 'ACTER' (from character)                        |
          +-----------------------------------------------------------*/
          parse value type with pre 'ACTER' type
          type = strip(pre)strip(type)

          /*-----------------------------------------------------------+
          | Get rid of 'YING' (from varying)                           |
          +-----------------------------------------------------------*/
          parse value type with pre 'YING' type
          type = strip(pre)strip(type)

          /*-----------------------------------------------------------+
          | Replace 'POINTER' by 'PTR'                                 |
          +-----------------------------------------------------------*/
          if pos('POINTER', type) \= 0 then
            do
              parse value type with pre 'POINTER' type
              type = strip(pre) 'PTR' strip(type)
            end

          /*-----------------------------------------------------------+
          | Get rid of ',0' in the precision                           |
          +-----------------------------------------------------------*/
          parse value type with pre ',0' type
          type = strip(pre)strip(type)

          /*-----------------------------------------------------------+
          | Get rid of any spaces after a variable                     |
          +-----------------------------------------------------------*/
          if length(type) \= 0 then
            if substr(type, length(type), 1) = ',' then
              type = strip(strip(type,,','))','
            else
              if substr(type, length(type), 1) = ';' then
                type = strip(strip(type,,';'))';'

          /*-----------------------------------------------------------+
          | Put 'BIN ' before the attributes                           |
          +-----------------------------------------------------------*/
          if pos('BIN', type) \= 0 then
            do
              parse value type with pre 'BIN' type
              type = 'BIN 'strip(pre)strip(type)
            end

          /*-----------------------------------------------------------+
          | Put 'FIXED ' before the attributes                         |
          +-----------------------------------------------------------*/
          if pos('FIXED', type) \= 0 then
            do
              parse value type with pre 'FIXED' type
              type = 'FIXED 'strip(pre)strip(type)
            end

          /*-----------------------------------------------------------+
          | Realign the type and precision fields                      |
          +-----------------------------------------------------------*/
          select
            when pos('BIN', type) \= 0 then
              do
                parse value type with pre '(' type
                type = strip(pre) '('type
              end

            when pos('FIXED', type) \= 0 then
              do
                parse value type with pre '(' type
                type = strip(pre)left(' ', 9 - length(type))'('type
              end

            when pos('CHAR', type) \= 0 then
              do
                parse value type with pre '(' type

                if pos('VAR', type) \= 0 then
                  do
                    type = ' ' || type || ' '
                    parse value type with ts 'VAR' te
                    type = space(ts || strip(te,,','))
                    !v   = ' VAR'
                  end
                else
                  !v = ''

                type = strip(pre) ||,
                       left(' ', 10 - length(type))'('type || !v || ','
              end

            otherwise
          end

          /*-----------------------------------------------------------+
          | Obtain the length, precision and type of the fields        |
          +-----------------------------------------------------------*/
          select
            when pos('PTR', type) \= 0 then
              do
                l    = 4
                prec = 0
                tov  = 'A'
              end

            when pos('FILE', type) \= 0 then
              do
                l    = 4
                prec = 0
                tov  = 'A'
              end

            when pos('FLOAT', type) \= 0 then
              do
                parse value type with . '(' l ')' .

                if pos('BIN', type) \= 0 then
                  select
                    when l <= 21 then l =  4
                    when l <= 53 then l =  8
                    otherwise         l = 16
                  end
                else
                  select
                    when l <=  6 then l =  4
                    when l <= 16 then l =  8
                    otherwise         l = 16
                  end

                prec = 0
                tov  = 'D'
              end

            when pos('BIN', type) \= 0 then
              do
                parse value type with . '(' l ')' .
                l    = (l + 1) % 8
                prec = 0
                tov  = 'B'
              end

            when pos('BIT', type) \= 0 then
              do
                parse value type with . '(' l ')' .
                l    = (l + 7) % 8
                prec = 0
                tov  = 'I'
              end

            when pos('CHAR', type) \= 0 then
              do
                parse value type with . '(' l ')' cv
                l    = l
                prec = 0
                if pos('VAR', cv) = 0 then
                  tov  = 'C'
                else
                  tov  = 'V'
              end

            when pos('AREA', type) \= 0 then
              do
                parse value type with . '(' l ')' .
                l    = l + 16
                prec = 0
                tov  = 'R'
              end

            when pos('FIXED', type) \= 0 then
              if pos(',', strip(type,,',')) \= 0 then
                do
                  parse value strip(type,,',') with . '(' l ',' p ')'
                  l    = l
                  prec = p
                  tov  = 'F'
                end
              else
                do
                  parse value strip(type,,',') with . '(' l ')'
                  l    = l
                  prec = 0
                  tov  = 'F'
                end

            when pos('PIC', type) \= 0 then
              do
                parse value type with . '''' tmp '''' .
                do while pos('(', tmp) \= 0
                  parse value tmp with pre '(' cnt ')' tmp
                  c   = substr(tmp, 1, 1)
                  tmp = strip(pre)          ||,
                        left(c, cnt - 1, c) ||,
                        strip(tmp)
                end

                if pos('V', tmp) \= 0 then
                  do
                    parse value tmp with b 'V' a
                    l    = length(a) + length(b)
                    prec = length(a)
                    tov  = 'P'
                  end
                else
                  do
                    l    = length(tmp)
                    prec = 0
                    tov  = 'P'
                  end
              end

            otherwise
              do
                l    = 0
                prec = 0
                tov  = 'L'
              end
          end

          vi  = vi + 1
          v.0 = vi

          v.vi.lev = level
          v.vi.nam = name
          v.vi.pli = type
          v.vi.len = l
          v.vi.prc = prec
          v.vi.typ = tov
          v.vi.arr = pos('(', name) \= 0
          arrays   = arrays + v.vi.arr
          v.vi     = v.vi.lev v.vi.nam v.vi.pli
        end
  end

  if arg(2, 'e') then
    do
      call explode

      compress = ''
      do ei = 1 to e.0
        compress = compress sep strip(e.ei)
      end

      interpret 'call' moi 'compress'
    end

  head = x2c(00ffd9d7)
  tail = reverse(head)
  rsep = x2c(01d9d701)

  /*-------------------------------------------------------------------+
  | Reduce v.vi.lev values to their lowest possible values             |
  |                                                                    |
  | - collect all levels used                                          |
  | - store in a sorted string                                         |
  | - match existing levels on string and set to wordpos of match in   |
  |   string                                                           |
  +-------------------------------------------------------------------*/
  lev.  = 0
  max   = -1
  level = ''

  do i = 1 to v.0
    l     = +v.i.lev
    lev.l = l

    max   = max(max, l)
  end

  do i = 1 to max
    if lev.i \= 0 then
      level = level lev.i
  end

  if word(level, 1) = '2' then
    level = '1' level

  do vi = 1 to v.0
    l  = +v.vi.lev
    ok = 0

    do w = 1 to words(level) until ok
      if l = word(level, w) then
        do
          v.vi.lev = w
          ok       = 1
        end
    end
  end

  /*-------------------------------------------------------------------+
  | Create output record for caller                                    |
  +-------------------------------------------------------------------*/
  outrec = head
  if arg(3, 'e') then
    do vi = 1 to v.0
      outrec = outrec || v.vi.lev || sep ||,
                         v.vi.nam || sep ||,
                         v.vi.len || sep ||,
                         v.vi.prc || sep ||,
                         v.vi.typ || rsep
    end
  else
    do vi = 1 to v.0
      outrec = outrec || v.vi.lev || sep ||,
                         v.vi.nam || sep ||,
                         v.vi.pli || sep ||,
                         v.vi.len || sep ||,
                         v.vi.prc || sep ||,
                         v.vi.typ || rsep
    end
  outrec = outrec || tail

return outrec

/***********************************************************************
* Explode:                                                             *
*                                                                      *
* This routine is optionally called to explode the arrays that may be  *
* present in the original PL/I %include member. Array explosion is     *
* necessary to map the structure to a record for the formatted         *
* browse and edit functions.                                           *
***********************************************************************/
explode:
  xpni = 0
  xpn. = 0

  do i = 1 to arrays
    slev = 0

    /*-----------------------------------------------------------------+
    | Find, starting at the end of the structure, the array that is    |
    | on the lowest level and save its position and level              |
    +-----------------------------------------------------------------*/
    do vi = v.0 to 1 by -1
      if v.vi.arr &,
         v.vi.lev > slev then
        do
          svi  = vi
          slev = v.vi.lev
        end
    end

    /*-----------------------------------------------------------------+
    | Assume the array is a non-structure array                        |
    | Reset the array indicator                                        |
    +-----------------------------------------------------------------*/
    v.svi.exp = ''
    v.svi.arr = 0

    /*-----------------------------------------------------------------+
    | Set up a list of all elements of the structure that are part     |
    | of the array, that is all subsequent elements in the structure   |
    | that are on a lower level                                        |
    +-----------------------------------------------------------------*/
    do vi = svi + 1 to v.0 while v.vi.lev > slev
      v.svi.exp = v.svi.exp vi sep
    end

    /*-----------------------------------------------------------------+
    | Initialize a temporary structure                                 |
    +-----------------------------------------------------------------*/
    drop e.
    ei  = 0
    e.0 = 0

    /*-----------------------------------------------------------------+
    | Initialize an index to hold the bounds of the array              |
    +-----------------------------------------------------------------*/
    drop bn.
    bn.0 = 0
    jj   = 0

    /*-----------------------------------------------------------------+
    | Parse out the bounds of the array                                |
    +-----------------------------------------------------------------*/
    parse value v.svi.nam with . '(' tmp ')' .
    do while tmp \= ''
      jj = jj + 1

      parse value tmp' ' with bn.jj ',' tmp

      if pos(':', bn.jj) \= 0 then
        do
          parse value bn.jj with bnl.jj ':' bnh.jj
        end
      else
        do
          bnl.jj = 1
          bnh.jj = bn.jj
        end
    end

    bn.0 = jj

    /*-----------------------------------------------------------------+
    | Explode an array using REXX' capability of dynamically building  |
    | and executing instructions. In this case a nested do-loop is     |
    | generated.                                                       |
    |                                                                  |
    | Variables used:                                                  |
    |                                                                  |
    |  - bn.   : the array containing the bounds of the array to be    |
    |            exploded                                              |
    |  - jj    : counter                                               |
    |  - ei    : counter                                               |
    |  - e.    : the array for the exploded array lines                |
    |  - pre   : the 'do v1 = 1 to n' instructions                     |
    |  - post  : the 'end' instructions                                |
    |  - postdo: the actions following the 'do' statement              |
    |  - preend: the actions before the 'end' statement                |
    +-----------------------------------------------------------------*/
    pre  = ''
    post = ''
    parse value v.svi.nam with postdo '(' .
    postdo = "ei = ei + 1; e.ei = '"postdo"('"
    preend = ''

    /*-----------------------------------------------------------------+
    | From the last bound to the first                                 |
    +-----------------------------------------------------------------*/
    do jj = bn.0 to 1 by -1
      /*---------------------------------------------------------------+
      | Add an iterative 'do' statement in front of the current one    |
      +---------------------------------------------------------------*/
      pre  = 'do jj.'jj' = 'bnl.jj' to 'bnh.jj || ';'|| pre;

      /*---------------------------------------------------------------+
      | Add an 'end' statement after the current one                   |
      +---------------------------------------------------------------*/
      post = post || ';end'

      /*---------------------------------------------------------------+
      | Add the required index to the array                            |
      +---------------------------------------------------------------*/
      preend = 'jj.'jj || "','" || preend
    end

    /*-----------------------------------------------------------------+
    | Remove that last "','" and add a "')'" or "'),'" to preend       |
    | depending on the fact of the current array is a single variable  |
    | array or an array of structures.                                 |
    +-----------------------------------------------------------------*/
    if substr(strip(v.svi.nam), length(strip(v.svi.nam)), 1) = ',' then
      preend = substr(preend, 1, length(preend) - 3)'''),'''
    else
      preend = substr(preend, 1, length(preend) - 3)''')'''

    /*-----------------------------------------------------------------+
    | Add some more code to preend to add the level and type of        |
    | variable to the e's.                                             |
    +-----------------------------------------------------------------*/
    preend = preend";e.ei = v.svi.lev e.ei v.svi.pli"

    /*-----------------------------------------------------------------+
    | Execute the generated piece of code                              |
    +-----------------------------------------------------------------*/
    interpret pre || postdo || preend || post
    e.0 = ei

    /*-----------------------------------------------------------------+
    | Save the expanded code as an additional field in the v. record   |
    +-----------------------------------------------------------------*/
    v.svi.exp2 = ''
    do jj = 1 to e.0
      v.svi.exp2 = v.svi.exp2 e.jj sep
    end

    /*-----------------------------------------------------------------+
    | Save order of records that have exp2 fields                      |
    +-----------------------------------------------------------------*/
    xpni     = xpni + 1
    xpn.xpni = svi
    xpn.0    = xpni
  end

  /*-------------------------------------------------------------------+
  | Set the exp2 fields of all records that don't have one to the      |
  | reformatted record                                                 |
  +-------------------------------------------------------------------*/
  do vi = 1 to v.0
    if symbol('v.vi.exp2') = 'LIT' then
      v.vi.exp2 = v.vi
  end

  /*-------------------------------------------------------------------+
  | Do for all variables that have an extension                        |
  +-------------------------------------------------------------------*/
  do xpni = 1 to xpn.0
    psi = 0
    drop ps.
    q  = xpn.xpni

    /*-----------------------------------------------------------------+
    | Parse out the positions of the extensions                        |
    +-----------------------------------------------------------------*/
    tmp = v.q.exp
    do while pos(sep, tmp) \= 0
      psi = psi + 1
      parse value tmp with ps.psi (sep) tmp
    end
    ps.0 = psi

    /*-----------------------------------------------------------------+
    | Parse out the individual elements of the exploded array          |
    +-----------------------------------------------------------------*/
    exi = 0
    drop ex.
    tmp = v.q.exp2
    do while pos(sep, tmp) \= 0
      exi = exi + 1
      parse value tmp with ex.exi (sep) tmp
    end
    ex.0 = exi

    /*-----------------------------------------------------------------+
    | Add the extension(s) to each element of the exploded array       |
    +-----------------------------------------------------------------*/
    do exi = 1 to ex.0
      do psi = 1 to ps.0
        l      = strip(ps.psi)
        ex.exi = ex.exi sep v.l.exp2
      end
    end

    /*-----------------------------------------------------------------+
    | Remove the extension (This is possible because they reside on    |
    | a lower level in the structure)                                  |
    +-----------------------------------------------------------------*/
    do psi = 1 to ps.0
      l = strip(ps.psi)
      v.l.exp2 = ''
    end

    /*-----------------------------------------------------------------*
    | Concatenate the extensions for the individual array elements     |
    | into an extension for the current level of the structure         |
    +-----------------------------------------------------------------*/
    v.q.exp2 = ''
    do exi = 1 to ex.0
      v.q.exp2 = v.q.exp2 sep ex.exi
    end
  end

  /*-------------------------------------------------------------------+
  | Concatenate all residual extensions into a new compressed          |
  | structure                                                          |
  +-------------------------------------------------------------------*/
  fin = ''
  do vi = 1 to v.0
    if v.vi.exp2 \= '' then
      fin = fin sep v.vi.exp2
  end

  drop e.
  ei  = 1
  e.0 = 0

  /*-------------------------------------------------------------------+
  | Break up the new structure in its individual elements, removing    |
  | all extra separators.                                              |
  +-------------------------------------------------------------------*/
  do while fin \= ''
    parse value fin with e.ei (sep) fin
    if e.ei \= '' then
      ei = ei + 1
  end
  e.ei = ''
  e.0 = ei - 1

  /*-------------------------------------------------------------------+
  | Translate all ';'s (except the last) that may have been created    |
  | by exploding the arrays into ','s                                  |
  +-------------------------------------------------------------------*/
  do ei = 1 to e.0
    if ei < e.0 then
      e.ei = translate(e.ei, ',', ';')
  end
return

/***********************************************************************
* SYNTAX:                                                              *
*                                                                      *
* This procedure gives a 'clean' exit for errors                       *
***********************************************************************/
syntax:
  call guru source,rc,sigl,sourceline(sigl)
exit

/***********************************************************************
* POP_UP:                                                              *
*                                                                      *
* Display a pop-up panel to ask for the .INC library                   *
***********************************************************************/
pop_up:
  call load_dynlib

  "ispexec libdef ispplib library id("dynlib") stack"

  "ispexec addpop row(10) column(-1)"

  cursor = 'raplib'

  do until rc = 'OK' | resp = 'END'
    do until rc \= 0
      "ispexec display panel("moi") msg(isrz001) cursor("cursor")"
    end

    if resp \= 'END' then
      do
        rapincm = ''
        raplibm = ''

        /*-------------------------------------------------------------+
        | Check that the user entered a valid dataset                  |
        +-------------------------------------------------------------*/
        if raplib \= strip(raplib,, '''') then
          do
            incdsn = "'" || strip(raplib,,'''')'('rapinc')' || "'"
            rc = sysdsn("'" || strip(raplib,,'''')'('rapinc')' || "'")
          end
        else
          do
            incdsn = raplib'('rapinc')'
            rc = sysdsn(raplib'('rapinc')')
          end

        select
          when rc = 'OK' then nop

          when rc = 'DATASET NOT FOUND' then
            do
              raplibm = raplib 'not found'
              cursor  = 'raplib'
            end

          when rc = 'MEMBER NOT FOUND' then
            do
              rapincm = ''''rapinc''' not found in' raplib
              cursor  = 'raplib'
            end

          otherwise
            do
              zedlmsg = rc
              cursor  = 'raplib'
            end
        end
      end
  end

  "ispexec rempop"

  "ispexec libdef ispplib"

  "free f("dynlib")"

  /*-------------------------------------------------------------------+
  | User entered 'END', display a message                              |
  +-------------------------------------------------------------------*/
  if resp = 'END' then
    do
      zedsmsg = ''
      zedlmsg =         left('*', 75, '*')
      zedlmsg = zedlmsg '*' center('Nested %INCLUDE not resolved,',
                                   'application terminated', 71) '*'
      zedlmsg = zedlmsg left('*', 75, '*')
      "ispexec setmsg msg(ISRZ001)"

      exit '%INCLUDE'
    end

  /*-------------------------------------------------------------------+
  | Save for multiple invocations in same session                      |
  +-------------------------------------------------------------------*/
  "ispexec vput (raplib) shared"

  "alloc f(#) da("incdsn") shr reu"
  'execio * diskr # ( stem #. finis'
  "free f(#)"

  !inc = ''
  scom = '/' || '*'
  ecom = '*' || '/'

  do ! = 1 to #.0
    !inc = !inc || sep || substr(#.!, 2, 71)
  end

  !inc = space(!inc)

  do until !post = ''
    parse value !inc with !pre (scom) comment (ecom) !post
    !inc = !pre || !post
  end
return !inc

/***********************************************************************
* LOAD_DYNLIB:                                                         *
*                                                                      *
* This procedure loads the via EPANQ generated panel, message and      *
* skeleton code into a library. Note that there is no reason to use    *
* different libraries for any of these objects, as long as they are    *
* named differently|                                                   *
***********************************************************************/
load_dynlib:
dynlib = 'dyn'random(99999)
alloc  = "alloc fi("dynlib") rtdsn(sysdsname) "   ||,
                   "lrecl(80) blksize(0) dir(5) " ||,
                   "new delete reuse "            ||,
                   "space(1,1)"
rc = bpxwdyn(alloc)

if rc = 0 then
  ispdyn = sysdsname
else
  ispdyn = 'NOT FOUND'

"newstack"

member = moi

queue ')attr default({$_)'
queue '/' || '***************************************************' ||,
      '*******************' || '/'
queue '/' || '*              (C) Copyright Robert AH Prins, 1995-' ||,
      '2007              *' || '/'
queue '/' || '***************************************************' ||,
      '*******************' || '/'
queue '/' || '*  ------------------------------------------------' ||,
      '----------------  *' || '/'
queue '/' || '* | Date       | By   | Remarks                    ' ||,
      '                | *' || '/'
queue '/' || '* |------------+------+----------------------------' ||,
      '----------------| *' || '/'
queue '/' || '* |            |      |                            ' ||,
      '                | *' || '/'
queue '/' || '* |------------+------+----------------------------' ||,
      '----------------| *' || '/'
queue '/' || '* | 2007-03-26 | RAHP | Change layout              ' ||,
      '                | *' || '/'
queue '/' || '* |------------+------+----------------------------' ||,
      '----------------| *' || '/'
queue '/' || '* | 1995-04-24 | RAHP | Initial version            ' ||,
      '                | *' || '/'
queue '/' || '* |------------+------+----------------------------' ||,
      '----------------| *' || '/'
queue '/' || '***************************************************' ||,
      '*******************' || '/'
queue '/' || '* Panel - RAP00110                                 ' ||,
      '                  *' || '/'
queue '/' || '*                                                  ' ||,
      '                  *' || '/'
queue '/' || '* This panel is used by the PL/I %include book pars' ||,
      'er to obtain the  *' || '/'
queue '/' || '* library for any nested %includes.                ' ||,
      '                  *' || '/'
queue '/' || '***************************************************' ||,
      '*******************' || '/'
queue ' : type(text)   intens(low)  color(green)'
queue ' ^ type(text)   intens(low)  skip(on)'
queue ' { type(text)   intens(high) color(white)'
queue ' _ type(input)  intens(high) color(red)'
queue ' $ type(text)   intens(low)  color(blue)'
queue ' ¢ type(text)   intens(high) color(yellow)'
queue ' ` type(text)   intens(high) color(yellow)'
queue ' \ type(text)   intens(high) color(turq)'
queue ' ~ type(output) intens(high) color(white) caps(off)'
queue ' @ type(output) intens(high) color(red)'
queue ' '
queue ')body window(77,9) expand(||)'
queue '\'moi' - Nested %include library specification -|-|-'
queue ':Command{==>_zcmd                                         ' ||,
      '       ^'
queue ' '
queue '$%INCLUDE member  {==>@rapinc'
queue '                      ~rapincm'
queue '$%INCLUDE library {==>_raplib                             ' ||,
      '         ^'
queue '                      ~raplibm'
queue ' '
queue '$Press¢ENTER$to parse the nested include or¢END$to cancel ' ||,
      'the operation'
queue ')init'
queue '  &rtn = PFK(RETURN)'
queue ')proc'
queue '  &pfkey = .pfkey'
queue ' '
queue '  if (&rtn ^= &z)'
queue '    if (&pfkey = &rtn)'
queue '      .resp = END'
queue '      &resp = end'
queue ' '
queue '  if (.resp = END)'
queue '    &resp = END'
queue ' '
queue '  if (.resp ^= END)'
queue '    if (&raplib = &z)'
queue '      ver(&raplib nb dsnamepq)'
queue ' '
queue '    if (&raplib ^= &z)'
queue '      ver(&raplib dsnamepq)'
queue ' '
queue '    if (.msg ^= '' '')'
queue '      .attr(.cursor) = ''color(green) hilite(reverse)'''
queue '      .resp = ENTER'
queue ' '
queue '    if (.msg = '' '')'
queue '      .resp = END'
queue '      &resp = OK'
queue ')end'

put_object:
  tfil = 'tfil'random(9999)

  "alloc f("tfil") da('"ispdyn"("member")') shr reu"
  "execio" queued() "diskw "tfil" (finis"
  "free f("tfil")"

  "delstack"
return