//MVS0140 JOB  (SMP),
//             'Build SYS2.MACLIB',
//             CLASS=A,
//             MSGCLASS=A,
//             MSGLEVEL=(1,1),
//             REGION=4096K
//*********************************************************************
//*
//*                       MVS 3.8 SYSGEN
//*                       ==============
//*
//* DESC: Build SYS2.MACLIB
//*
//*********************************************************************
//*
//CLEANUP EXEC PGM=IDCAMS
//SYSPRINT DD  SYSOUT=*
//SYSIN    DD  *
 DELETE SYS2.MACLIB NONVSAM
 SET LASTCC=0
 SET MAXCC=0
//ALLOC   EXEC PGM=IEBUPDTE,PARM=NEW
//SYSPRINT DD  SYSOUT=*
//SYSUT2   DD  DISP=(NEW,CATLG),
//             DSN=SYS2.MACLIB,
//             DCB=SYS1.MACLIB,
//             SPACE=(CYL,(5,5,20)),
//             UNIT=3350,VOL=SER=MVSDLB
//SYSIN    DD  DATA,DLM=##
./ ADD NAME=$TITLE
         MACRO
&LABEL   $TITLE &ID=,&TITLE=,&HEAD=,&HDR=
         GBLB  &BOXID
         GBLC  &BOXHDR
         LCLA  &I,&J,&N
         LCLB  &BCTR
         LCLC  &BID,&BTITLE
.*
.*       PICK UP ID FIELD
.*
.TESTID  AIF   ('&ID' EQ '' AND '&LABEL' EQ '').TESTHDR
         AIF   ('&ID' EQ '' OR '&LABEL' EQ '').TESTPRV
         MNOTE *,'BOX001: ID SPECIFIED TWICE - LABEL FIELD IGNORED'
.TESTPRV AIF   (NOT &BOXID).SETID
         MNOTE *,'BOX002: ID ALREADY SPECIFIED - THIS ONE IGNORED'
         AGO   .TESTHDR
.SETID   ANOP
&BOXID   SETB  1
&BID     SETC  '&ID'
         AIF   ('&ID' NE '').TESTHDR
&BID     SETC  '&LABEL'
         @     &BID
.*
.*       PICK UP HEADER SPECIFICATION
.*
.TESTHDR AIF   (T'&HDR EQ 'O' AND T'&HEAD EQ 'O').TESTTTL
&BOXHDR  SETC  '&HDR&HEAD'
         AIF   ('&BOXHDR'(1,1) NE '''').TESTTTL
&BOXHDR  SETC  '&BOXHDR'(2,K'&BOXHDR-2)
.*
.*       PICK UP TITLE SPECIFICATION
.*
.TESTTTL AIF   (T'&TITLE EQ 'O').MEXIT
&BTITLE  SETC  '&TITLE'
         AIF   ('&BTITLE'(1,1) NE '''').GENTTL
&BTITLE  SETC  '&BTITLE'(2,K'&BTITLE-2)
.GENTTL  ANOP
&BID     TITLE '&BOXHDR&BTITLE'
.MEXIT   MEXIT
         MEND
./ ADD NAME=@
         MACRO
         @     &LETTERS
.*********************************************************************
.*                                                                   *
.*       MACRO to create block letters in assembly listing           *
.*                                                                   *
.*********************************************************************
         LCLC  &A(50)
         LCLC  &B(62),&C(62),&D(62),&E(62),&F(62),&G(62)
         LCLA  &I,&J,&K
&B(01)   SETC  'A'
&B(02)   SETC  'B'
&B(03)   SETC  'C'
&B(04)   SETC  'D'
&B(05)   SETC  'E'
&B(06)   SETC  'F'
&B(07)   SETC  'G'
&B(08)   SETC  'H'
&B(09)   SETC  'I'
&B(10)   SETC  'J'
&B(11)   SETC  'K'
&B(12)   SETC  'L'
&B(13)   SETC  'M'
&B(14)   SETC  'N'
&B(15)   SETC  'O'
&B(16)   SETC  'P'
&B(17)   SETC  'Q'
&B(18)   SETC  'R'
&B(19)   SETC  'S'
&B(20)   SETC  'T'
&B(21)   SETC  'U'
&B(22)   SETC  'V'
&B(23)   SETC  'W'
&B(24)   SETC  'X'
&B(25)   SETC  'Y'
&B(26)   SETC  'Z'
&B(27)   SETC  '#'
&B(28)   SETC  ','
&B(29)   SETC  '$'
&B(30)   SETC  '0'
&B(31)   SETC  '1'
&B(32)   SETC  '2'
&B(33)   SETC  '3'
&B(34)   SETC  '4'
&B(35)   SETC  '5'
&B(36)   SETC  '6'
&B(37)   SETC  '7'
&B(38)   SETC  '8'
&B(39)   SETC  '9'
&B(40)   SETC  '@'
&B(41)   SETC  '%'
&B(42)   SETC  '*'
&B(43)   SETC  '/'
&B(44)   SETC  '-'
&B(45)   SETC  '('
&B(46)   SETC  ')'
&B(47)   SETC  '&&'
&B(48)   SETC  '+'
&B(49)   SETC  '_'
&B(50)   SETC  '['
&B(51)   SETC  ']'
&B(52)   SETC  '>'
&B(53)   SETC  ':'
&B(54)   SETC  ';'
&B(55)   SETC  '.'
&B(56)   SETC  '?'
&B(57)   SETC  '"'
&B(58)   SETC  '='
&B(59)   SETC  '!'
&B(60)   SETC  '<'
&B(61)   SETC  '^'
&B(62)   SETC  ' '
&C(01)   SETC  '  A  '
&D(01)   SETC  ' A A '
&E(01)   SETC  'A   A'
&F(01)   SETC  'AAAAA'
&G(01)   SETC  'A   A'
&C(02)   SETC  'BBBB '
&D(02)   SETC  'B   B'
&E(02)   SETC  'BBBB '
&F(02)   SETC  'B   B'
&G(02)   SETC  'BBBB '
&C(03)   SETC  ' CCCC'
&D(03)   SETC  'C    '
&E(03)   SETC  'C    '
&F(03)   SETC  'C    '
&G(03)   SETC  ' CCCC'
&C(04)   SETC  'DDDD '
&D(04)   SETC  'D   D'
&E(04)   SETC  'D   D'
&F(04)   SETC  'D   D'
&G(04)   SETC  'DDDD '
&C(05)   SETC  'EEEEE'
&D(05)   SETC  'E    '
&E(05)   SETC  'EEEE '
&F(05)   SETC  'E    '
&G(05)   SETC  'EEEEE'
&C(06)   SETC  'FFFFF'
&D(06)   SETC  'F    '
&E(06)   SETC  'FFFF '
&F(06)   SETC  'F    '
&G(06)   SETC  'F    '
&C(07)   SETC  ' GGGG'
&D(07)   SETC  'G    '
&E(07)   SETC  'G  GG'
&F(07)   SETC  'G   G'
&G(07)   SETC  ' GGGG'
&C(08)   SETC  'H   H'
&D(08)   SETC  'H   H'
&E(08)   SETC  'HHHHH'
&F(08)   SETC  'H   H'
&G(08)   SETC  'H   H'
&C(09)   SETC  ' III '
&D(09)   SETC  '  I  '
&E(09)   SETC  '  I  '
&F(09)   SETC  '  I  '
&G(09)   SETC  ' III '
&C(10)   SETC  '  JJJ'
&D(10)   SETC  '   J '
&E(10)   SETC  '   J '
&F(10)   SETC  'J  J '
&G(10)   SETC  ' JJ  '
&C(11)   SETC  'K  K '
&D(11)   SETC  'K K  '
&E(11)   SETC  'KK   '
&F(11)   SETC  'K K  '
&G(11)   SETC  'K  K '
&C(12)   SETC  'L    '
&D(12)   SETC  'L    '
&E(12)   SETC  'L    '
&F(12)   SETC  'L    '
&G(12)   SETC  'LLLLL'
&C(13)   SETC  'M   M'
&D(13)   SETC  'MM MM'
&E(13)   SETC  'M M M'
&F(13)   SETC  'M   M'
&G(13)   SETC  'M   M'
&C(14)   SETC  'N   N'
&D(14)   SETC  'NN  N'
&E(14)   SETC  'N N N'
&F(14)   SETC  'N  NN'
&G(14)   SETC  'N   N'
&C(15)   SETC  'OOOOO'
&D(15)   SETC  'O   O'
&E(15)   SETC  'O   O'
&F(15)   SETC  'O   O'
&G(15)   SETC  'OOOOO'
&C(16)   SETC  'PPPP '
&D(16)   SETC  'P   P'
&E(16)   SETC  'PPPP '
&F(16)   SETC  'P    '
&G(16)   SETC  'P    '
&C(17)   SETC  ' QQQ '
&D(17)   SETC  'Q   Q'
&E(17)   SETC  'Q Q Q'
&F(17)   SETC  'Q  Q '
&G(17)   SETC  ' QQ Q'
&C(18)   SETC  'RRRR '
&D(18)   SETC  'R   R'
&E(18)   SETC  'RRRR '
&F(18)   SETC  'R  R '
&G(18)   SETC  'R   R'
&C(19)   SETC  ' SSSS'
&D(19)   SETC  'S    '
&E(19)   SETC  ' SSS '
&F(19)   SETC  '    S'
&G(19)   SETC  'SSSS '
&C(20)   SETC  'TTTTT'
&D(20)   SETC  '  T  '
&E(20)   SETC  '  T  '
&F(20)   SETC  '  T  '
&G(20)   SETC  '  T  '
&C(21)   SETC  'U   U'
&D(21)   SETC  'U   U'
&E(21)   SETC  'U   U'
&F(21)   SETC  'U   U'
&G(21)   SETC  ' UUU '
&C(22)   SETC  'V   V'
&D(22)   SETC  'V   V'
&E(22)   SETC  'V   V'
&F(22)   SETC  ' V V '
&G(22)   SETC  '  V  '
&C(23)   SETC  'W   W'
&D(23)   SETC  'W   W'
&E(23)   SETC  'W W W'
&F(23)   SETC  'WW WW'
&G(23)   SETC  'W   W'
&C(24)   SETC  'X   X'
&D(24)   SETC  ' X X '
&E(24)   SETC  '  X  '
&F(24)   SETC  ' X X '
&G(24)   SETC  'X   X'
&C(25)   SETC  'Y   Y'
&D(25)   SETC  ' Y Y '
&E(25)   SETC  '  Y  '
&F(25)   SETC  '  Y  '
&G(25)   SETC  '  Y  '
&C(26)   SETC  'ZZZZZ'
&D(26)   SETC  '   Z '
&E(26)   SETC  '  Z  '
&F(26)   SETC  ' Z   '
&G(26)   SETC  'ZZZZZ'
&C(27)   SETC  ' # # '
&D(27)   SETC  '#####'
&E(27)   SETC  ' # # '
&F(27)   SETC  '#####'
&G(27)   SETC  ' # # '
&C(28)   SETC  '     '
&D(28)   SETC  '     '
&E(28)   SETC  '     '
&F(28)   SETC  ' ,,  '
&G(28)   SETC  '  ,  '
&C(29)   SETC  ' $$$$'
&D(29)   SETC  '$ $  '
&E(29)   SETC  ' $$$ '
&F(29)   SETC  '  $ $'
&G(29)   SETC  '$$$$ '
&C(30)   SETC  ' 000 '
&D(30)   SETC  '0   0'
&E(30)   SETC  '0   0'
&F(30)   SETC  '0   0'
&G(30)   SETC  ' 000 '
&C(31)   SETC  '  1  '
&D(31)   SETC  ' 11  '
&E(31)   SETC  '  1  '
&F(31)   SETC  '  1  '
&G(31)   SETC  ' 111 '
&C(32)   SETC  '2222 '
&D(32)   SETC  '    2'
&E(32)   SETC  '   2 '
&F(32)   SETC  '  2  '
&G(32)   SETC  '22222'
&C(33)   SETC  '3333 '
&D(33)   SETC  '    3'
&E(33)   SETC  ' 333 '
&F(33)   SETC  '    3'
&G(33)   SETC  '3333 '
&C(34)   SETC  '4  4 '
&D(34)   SETC  '4  4 '
&E(34)   SETC  '44444'
&F(34)   SETC  '   4 '
&G(34)   SETC  '   4 '
&C(35)   SETC  '55555'
&D(35)   SETC  '5    '
&E(35)   SETC  '5555 '
&F(35)   SETC  '    5'
&G(35)   SETC  '5555 '
&C(36)   SETC  ' 666 '
&D(36)   SETC  '6    '
&E(36)   SETC  '6666 '
&F(36)   SETC  '6   6'
&G(36)   SETC  ' 666 '
&C(37)   SETC  '77777'
&D(37)   SETC  '   7 '
&E(37)   SETC  '  7  '
&F(37)   SETC  '  7  '
&G(37)   SETC  '  7  '
&C(38)   SETC  ' 888 '
&D(38)   SETC  '8   8'
&E(38)   SETC  ' 888 '
&F(38)   SETC  '8   8'
&G(38)   SETC  ' 888 '
&C(39)   SETC  ' 999 '
&D(39)   SETC  '9   9'
&E(39)   SETC  ' 9999'
&F(39)   SETC  '    9'
&G(39)   SETC  ' 999 '
&C(40)   SETC  '@@@@ '
&D(40)   SETC  '    @'
&E(40)   SETC  '@@@ @'
&F(40)   SETC  '@ @ @'
&G(40)   SETC  '@@@@ '
&C(41)   SETC  '%%  %'
&D(41)   SETC  '   % '
&E(41)   SETC  '  %  '
&F(41)   SETC  ' %   '
&G(41)   SETC  '%  %%'
&C(42)   SETC  '* * *'
&D(42)   SETC  ' *** '
&E(42)   SETC  '*****'
&F(42)   SETC  ' *** '
&G(42)   SETC  '* * *'
&C(43)   SETC  '    /'
&D(43)   SETC  '   / '
&E(43)   SETC  '  /  '
&F(43)   SETC  ' /   '
&G(43)   SETC  '/    '
&C(44)   SETC  '     '
&D(44)   SETC  '     '
&E(44)   SETC  '-----'
&F(44)   SETC  '     '
&G(44)   SETC  '     '
&C(45)   SETC  '   ( '
&D(45)   SETC  '  (  '
&E(45)   SETC  '  (  '
&F(45)   SETC  '  (  '
&G(45)   SETC  '   ( '
&C(46)   SETC  ' )   '
&D(46)   SETC  '  )  '
&E(46)   SETC  '  )  '
&F(46)   SETC  '  )  '
&G(46)   SETC  ' )   '
&C(47)   SETC  ' &&&&&& '
&D(47)   SETC  '&&    '
&E(47)   SETC  ' &&&&  '
&F(47)   SETC  '&&   &&'
&G(47)   SETC  ' &&&&&&&&'
&C(48)   SETC  '  +  '
&D(48)   SETC  '  +  '
&E(48)   SETC  '+++++'
&F(48)   SETC  '  +  '
&G(48)   SETC  '  +  '
&C(49)   SETC  '     '
&D(49)   SETC  '     '
&E(49)   SETC  '     '
&F(49)   SETC  '     '
&G(49)   SETC  '_____'
&C(50)   SETC  '  *  '
&D(50)   SETC  ' C*C '
&E(50)   SETC  'C *  '
&F(50)   SETC  ' C*C '
&G(50)   SETC  '  *  '
&C(51)   SETC  '  ]  '
&D(51)   SETC  '  ]  '
&E(51)   SETC  '  ]  '
&F(51)   SETC  '  ]  '
&G(51)   SETC  '  ]  '
&C(52)   SETC  ' >   '
&D(52)   SETC  '  >  '
&E(52)   SETC  '   > '
&F(52)   SETC  '  >  '
&G(52)   SETC  ' >   '
&C(53)   SETC  ' ..  '
&D(53)   SETC  ' ..  '
&E(53)   SETC  '     '
&F(53)   SETC  ' ..  '
&G(53)   SETC  ' ..  '
&C(54)   SETC  ' ..  '
&D(54)   SETC  ' ..  '
&E(54)   SETC  '     '
&F(54)   SETC  ' ,,  '
&G(54)   SETC  '  ,  '
&C(55)   SETC  '     '
&D(55)   SETC  '     '
&E(55)   SETC  '     '
&F(55)   SETC  ' ..  '
&G(55)   SETC  ' ..  '
&C(56)   SETC  ' ??? '
&D(56)   SETC  '?   ?'
&E(56)   SETC  '   ? '
&F(56)   SETC  '  ?  '
&G(56)   SETC  '  ?  '
&C(57)   SETC  ' '' '' '
&D(57)   SETC  '     '
&E(57)   SETC  '     '
&F(57)   SETC  '     '
&G(57)   SETC  '     '
&C(58)   SETC  '     '
&D(58)   SETC  '====='
&E(58)   SETC  '     '
&F(58)   SETC  '====='
&G(58)   SETC  '     '
&C(59)   SETC  ' ]]  '
&D(59)   SETC  ' ]]  '
&E(59)   SETC  ' ]]  '
&F(59)   SETC  '     '
&G(59)   SETC  ' ..  '
&C(60)   SETC  '   < '
&D(60)   SETC  '  <  '
&E(60)   SETC  ' <   '
&F(60)   SETC  '  <  '
&G(60)   SETC  '   < '
&C(61)   SETC  '     '
&D(61)   SETC  '     '
&E(61)   SETC  '^^^^^'
&F(61)   SETC  '    ^'
&G(61)   SETC  '     '
&C(62)   SETC  '     '
&D(62)   SETC  '     '
&E(62)   SETC  '     '
&F(62)   SETC  '     '
&G(62)   SETC  '     '
&J       SETA  1
&K       SETA  1
         AIF   ('&LETTERS'(1,1) NE '''').JLOOP
.LLOOP   ANOP
&J       SETA  &J+1
.JLOOP   AIF   (K'&LETTERS LT &J).END
         AIF   (K'&LETTERS EQ &J AND '&LETTERS'(&J,1) EQ '''').END
&I       SETA  1
.COMP    AIF   ('&B(&I)' EQ '&LETTERS'(&J,1)).FND
&I       SETA  &I+1
         AIF   (&I LT 62).COMP
.FND     ANOP
&A(&K)   SETC  '&C(&I)'
&A(&K+1) SETC  '&D(&I)'
&A(&K+2) SETC  '&E(&I)'
&A(&K+3) SETC  '&F(&I)'
&A(&K+4) SETC  '&G(&I)'
&K       SETA  &K+5
         AIF   (&K LT 51).LLOOP
.END     ANOP
         SPACE 2
         MNOTE *,'******************************************************
               ****************'
         MNOTE *,' '
&I       SETA  1
.REDO    MNOTE *,' &A(&I)  &A(&I+5)  &A(&I+10)  &A(&I+15)  &A(&I+20)  &*
               A(&I+25)  &A(&I+30)  &A(&I+35)  &A(&I+40)  &A(&I+45)'
&I       SETA  &I+1
         AIF   (&I LT 6).REDO
         MNOTE *,' '
         MNOTE *,'******************************************************
               ****************'
         MEXIT
         SPACE 4
         MEND
./ ADD NAME=BLANK
         MACRO                            ,
&LABEL   BLANK &AREA,&CHAR=C' ',&CC=C' '  ,
         LCLC  &CHAR$,&CC$
&CHAR$   SETC  'C'' '''                   , DEFAULT FILL CHARACTER
&CC$     SETC  'C'' '''                   , DEFAULT CONTROL CHAR
         AIF   ('&CHAR' EQ '').NOFILL     , USE DEFAULT FILL CHAR
&CHAR$   SETC  '&CHAR'                    , USER FILL CHARACTER
.NOFILL  ANOP                             ,
         AIF   ('&CC' EQ '').NOCC         ,
&CC$     SETC  '&CC'                      ,
.NOCC    ANOP                             ,
&LABEL   MVI   &AREA,&CHAR$               , SET FILL BYTE
         MVC   &AREA+1(L'&AREA-1),&AREA   , FILL FIELD
         AIF   ('&CHAR$' EQ '&CC$').MEXIT ,
         MVI   &AREA,&CC$                 , INSERT CONTROL CHARACTER
.MEXIT   MEXIT                            , LEAVE MACRO
         MEND                             , OF MACRO
./ ADD NAME=BOX
         MACRO
&LABEL   BOX   &COMM,&ID=,&TITLE=,&HEAD=,&CTL1=SPACE,&CTL2=SPACE,      -
               &PRINT=,&HDR=,&CTR=NO
         GBLB  &BOXID
         GBLB  &P
         GBLC  &BOXHDR
         LCLA  &I,&J,&N
         LCLB  &BCTR
         LCLC  &BID,&BTITLE,&BCOMM,&BLANK,&BCTL1,&BCTL2
         AIF   (&P).NB01
.NB01    ANOP
&BLANK   SETC  '                                                       -
                              '
&BCTR    SETB  ('&CTR' NE 'NO')
.*
.*       TURN PRINT ON IF NECESSARY
.*
         AIF   (T'&PRINT EQ 'O').TESTID
         PUSH  PRINT
         PRINT ON,GEN
.*
.*       PICK UP ID FIELD
.*
.TESTID  AIF   ('&ID' EQ '' AND '&LABEL' EQ '').TESTHDR
         AIF   ('&ID' EQ '' OR '&LABEL' EQ '').TESTPRV
         MNOTE 4,'BOX001: ID SPECIFIED TWICE - LABEL FIELD IGNORED'
.TESTPRV AIF   (NOT &BOXID).SETID
         MNOTE 4,'BOX002: ID ALREADY SPECIFIED - THIS ONE IGNORED'
         AGO   .TESTHDR
.SETID   ANOP
&BOXID   SETB  1
&BID     SETC  '&ID'
         AIF   ('&ID' NE '').TESTHDR
&BID     SETC  '&LABEL'
.*
.*       PICK UP HEADER SPECIFICATION
.*
.TESTHDR AIF   (T'&HDR EQ 'O' AND T'&HEAD EQ 'O').TESTTTL
&BOXHDR  SETC  '&HDR&HEAD'
         AIF   ('&BOXHDR'(1,1) NE '''').TESTTTL
&BOXHDR  SETC  '&BOXHDR'(2,K'&BOXHDR-2)
.*
.*       PICK UP TITLE SPECIFICATION
.*
.TESTTTL AIF   (T'&TITLE EQ 'O').TSTCTL1
&BTITLE  SETC  '&TITLE'
         AIF   ('&BTITLE'(1,1) NE '''').GENTTL
&BTITLE  SETC  '&BTITLE'(2,K'&BTITLE-2)
.GENTTL  ANOP
&BID     TITLE '&BOXHDR&BTITLE'
         AGO   .GENCOMM
.*
.*       GENERATE LISTING CONTROL IF APPROPRIATE
.*
.TSTCTL1 AIF   (T'&CTL1 EQ 'O').GENCOMM
&BCTL1   SETC  '&CTL1'
         AIF   ('&BCTL1'(1,1) NE '''').GENCTL1
&BCTL1   SETC  '&BCTL1'(2,K'&BCTL1-2)
.GENCTL1 ANOP
         &BCTL1
.*
.*       GENERATE COMMENTS
.*
.GENCOMM AIF   (T'&COMM EQ 'O').MEND
***********************************************************************
*                                                                     *
&N       SETA  N'&SYSLIST
&I       SETA  1
.COMLOOP ANOP
&BCOMM   SETC  '&SYSLIST(&I)'
         AIF   ('&BCOMM' EQ '' OR '&BCOMM' EQ '''''').NXTCOMM
         AIF   ('&BCOMM'(1,1) NE '''').TESTLEN
&BCOMM   SETC  '&BCOMM'(2,K'&BCOMM-2)
.TESTLEN AIF   (K'&BCOMM LE 56).MNOTE
&J       SETA  56
.SCAN    AIF   ('&BCOMM'(&J,1) EQ ' ').MNOTE1
&J       SETA  &J-1
         AIF   (&J GE 10).SCAN
&J       SETA  56
.MNOTE1  AIF   (&BCTR).CENTRE1
&BTITLE  SETC  '&BLANK'(1,8).'&BCOMM'(1,&J-1).'&BLANK'
         AGO   .STAR1
.CENTRE1 ANOP
&BTITLE  SETC  '&BLANK'(1,32-&J/2).'&BCOMM'(1,&J-1).'&BLANK'
.STAR1   ANOP
&BTITLE  SETC  '&BTITLE'(1,68).'*'
         MNOTE *,'&BTITLE'
&BCOMM   SETC  '&BCOMM'(&J+1,K'&BCOMM-&J)
         AIF   (K'&BCOMM GE 56).TESTLEN
.MNOTE   AIF   (&BCTR).CENTRE
&BCOMM   SETC  '&BLANK'(1,8).'&BCOMM'.'&BLANK'
         AGO   .STAR
.CENTRE  ANOP
&BCOMM   SETC  '&BLANK'(1,(63-K'&BCOMM)/2).'&BCOMM'.'&BLANK'
.STAR    ANOP
&BCOMM   SETC  '&BCOMM'(1,68).'*'
         MNOTE *,'&BCOMM'
.NXTCOMM ANOP
&I       SETA  &I+1
         AIF   (&I LE &N).COMLOOP
*                                                                     *
***********************************************************************
.*
.*       TEST SECOND LISTING CONTROL
.*
         AIF   (T'&CTL2 EQ 'O').MEND
&BCTL2   SETC  '&CTL2'
         AIF   ('&BCTL2'(1,1) NE '''').GENCTL2
&BCTL2   SETC  '&BCTL2'(2,K'&BCTL1-2)
.GENCTL2 ANOP
         &BCTL2
.MEND    ANOP
         AIF   (T'&PRINT EQ 'O').NB02
         POP   PRINT
.NB02    ANOP
         MEND
./ ADD NAME=BSPBEG
         MACRO
&LABEL  BSPBEG &BASE=3,               , default base register          *
               &BASE2=,               , second base register           *
               &BASE3=,               , third base register            *
               &BASE4=,               , fourth base register           *
               &HEADER=               , header in title
         COPY  BSPGLBLS               , get name of globals
         COPY  BSPSGLBL               , set global values
&BSPCSCT SETC  'BSPTEMP'              , default pgm name
         AIF   ('&LABEL' EQ '').NOLAB , BIF no label given
&BSPCSCT SETC  '&LABEL'               , else set CSECT name from label
.NOLAB   ANOP                         ,
&H       SETC  ' ===> '               , first part of header
         AIF   ('&HEADER' EQ '').NOHEAD
         AIF   ('&HEADER'(1,1) EQ '''').HEADAPO
&H       SETC  '&HEADER'
         AGO   .NOHEAD
.HEADAPO ANOP
&H       SETC  '&HEADER'(2,K'&HEADER-2)
.NOHEAD  ANOP
&SAVE    SETC  'BSPA'.'&SYSNDX'       , Save Area Label
&SAVEEND SETC  'BSPB'.'&SYSNDX'       , Save Area label, end
&BEG     SETC  'BSPC'.'&SYSNDX'       , Program begin label
&BYP     SETC  'BSPD'.'&SYSNDX'       , End of eyecatcher
&LEN     SETC  'BSPE'.'&SYSNDX'       , Length of eyecatcher
         @     &BSPCSCT               , PGM name in block letters
&BSPCSCT BOX   'Module name................... &BSPCSCT',              -
               'Written by.................... &BSPAUTH',              -
               'Assembly data................. &SYSDATE',              -
               'Assembly time................. &SYSTIME',              -
               TITLE=' HOUSEKEEPING ',                                 -
               HEAD=&H
         SPACE                        ,
         REGISTER                     ,
         EJECT                        ,
&BSPCSCT CSECT                        , Start of module
         USING &BSPCSCT,R15           , Temporary addressabilty
         STM   R14,R12,12(R13)        , Save all registers
         B     &BYP                   , Branch around eyecatcher
&BEG     DS    0H                     , Eyecatcher starts here
         DC    AL2(&BYP-&BEG)         , Length of eyecatcher
         DC    CL8'&BSPCSCT'          , CSECT name
         DC    C' VER. &BSPVER..&BSPMOD ' , Version and Mod Level
         DC    C'&SYSDATE._&SYSTIME'  , ASSEMBLY DATE AND TIME
         DC    C' &BSPAUTH'           , Author
&BYP     DS    0H                     , Eyecatcher ends here
         LR    &BASE,R15              , Load first base from entry
         AIF   ('&BASE2' EQ '').@USING1
         LR    &BASE2,&BASE             Set
         LA    &BASE2,4095(&BASE2)         second
         LA    &BASE2,1(&BASE2)                  base register
         AIF   ('&BASE3' EQ '').@USING2
         LR    &BASE3,&BASE2            SET
         LA    &BASE3,4095(&BASE3)         UP
         LA    &BASE3,1(&BASE3)              THIRD BASE REG
         AIF   ('&BASE4' EQ '').@USING3
         LR    &BASE4,&BASE3            THIS IS
         LA    &BASE4,4095(&BASE4)             THE FOURTH
         LA    &BASE4,1(&BASE4)                           BASE REG
         USING &BSPCSCT,&BASE,&BASE2,&BASE3,&BASE4 ADDRESABILITY
         AGO   .@BASE00
.@USING3 ANOP
         USING &BSPCSCT,&BASE,&BASE2,&BASE3 MAKE IT ADDRESSABLE
         AGO   .@BASE00
.@USING2 ANOP
         USING &BSPCSCT,&BASE,&BASE2    MAKE ADDRESSABILITY PERMANENT
         AGO   .@BASE00
.@USING1 ANOP
         USING &BSPCSCT,&BASE           ESTABLISH ADDRESSABILITY
.@BASE00 ANOP                         ,
         DROP  R15                    , Not needed any more
         LR    R15,R13                , Old save area pointer
         CNOP  0,4                    , Align to fullword boundary
         ST    R15,&SAVE+4            , Store old savearea address
         BAL   R13,&SAVEEND           , Load new save area address
&SAVE    DC    9CL8'&BSPCSCT'         , Save area
&SAVEEND ST    R13,8(0,R15)           , Store into old save area
         MEXIT
         MEND
./ ADD NAME=BSPEND
         MACRO
&LABEL   BSPEND &ENTRY                    , end of module
         COPY   BSPGLBLS
         GBLC   &BSPDSCT,&BSPDSCE,&BSPSP
         GBLB   &BSPRENT
         LCLC   &LBL,&MODLEN
&BSPCSCT CSECT                            , Resume CSECT
         LTORG                            , Literal pool
         X2CHRTAB                         , HEX to CHAR tranlation tbl
         AIF   ('&LABEL' EQ '').NOLABEL
&LBL     SETC  '&LABEL'
         AGO   .END1
.NOLABEL ANOP
&LBL     SETC  '$$1'.'&SYSNDX'
.END1    ANOP
&LBL     DC    H'0'                       , Halfword for module length
&MODLEN  SETC  '$$2'.'&SYSNDX'            ,
&MODLEN  EQU   *-&BSPCSCT                 , MODULE LENGTH
         ORG   &LBL                       , back up some bytes
         DC    AL2(&MODLEN)               , set the length
         ORG                              , restore org
         AIF   (NOT &BSPRENT).NORENT
&BSPDSCT DSECT                            , resume workarea
&BSPDSCE DS    0F                         , end of workarea
&BSPCSCT CSECT                            , resume CSECT
.NORENT  ANOP
         AIF   ('&ENTRY' EQ '').NOENT
         END   &ENTRY                     , of module, define Entry
         MEXIT
.NOENT   ANOP
         END                              , of module
         MEND
./ ADD NAME=BSPENTER
         MACRO
&NAME BSPENTER &BASE=R3,                  , BASE REGISTER              +
               &RENT=YES,                 , MAKE REENTRANT PGM         +
               &DATA=WORKAREA,            , name of reentrant storage  +
               &SP=1,                     , SUBPOOL FOR SAVE AREA      +
               &HEADER=,                  , HEADER IN $TITLE MACRO     +
               &CHAIN=YES                 , CHAIN SAVEAREAS
.**********************************************************************
.*                                                                    *
.* NAME: BSPENTER                                                     *
.*                                                                    *
.* TYPE: ASSEMBLER MACRO                                              *
.*                                                                    *
.* DESC: PROVIDE ENTRY CODING AND HOUSE KEEPING FOR ASSEMBLER MODULES *
.*                                                                    *
.* USE: <NAME> BSPENTER BASE=(REG1,...),                              *
.*                      CSECT={YES!NO},                               *
.*                      RENT={YES!NO}                                 *
.*                      SP=<SUBPOOL NUMBER>                           *
.*                      CHAIN={YES!NO}                                *
.*                                                                    *
.*       <NAME>   - A SYMBOLIC TAG ASSIGNED TO THE FIRST INSTRUCTION  *
.*                  GENERATED OR, IF APPLICABLE, TO THE CSECT CREATED *
.*                                                                    *
.*       BASE     - A LIST OF BASE REGISTERS TO BE USED.  THE DEFAULT *
.*                  IS REGISTER 3                                     *
.*                                                                    *
.*       RENT     - YES: REENTRANT CODE IS GENERATED BY THIS MACRO    *
.*                  NO:  NON-REENTRANT CODE IS GENERATED              *
.*                                                                    *
.*       SP       - SPECIFIES THE SUBPOOL NUMBER WHERE THE SAVE AREA  *
.*                  FOR REENTRANT CODE IS GETMAINED FROM              *
.*                  THE DEFAULT IS 1                                  *
.*                                                                    *
.*       CHAIN    - YES:  SAVE AREAS ARE TO BE CHAINED                *
.*                  NO: DO NOT CHAIN SAVE AREAS.  THIS IS INTENDED    *
.*                      FOR HIGH-USE REENTRANT MODULES TO AVOID  THE  *
.*                      OVERHEAD OF GETMAIN/FREEMAIN                  *
.*                                                                    *
.**********************************************************************
         COPY  BSPGLBLS                   , GET NAMES OF GLOBALS
         COPY  BSPSGLBL                   , SET GLOBALS
         GBLC  &BSPDSCT,&BSPDSCE,&BSPSP
         GBLB  &BSPRENT
         LCLA  &NUMREGS,&REGNO
         LCLC  &REG,&CHAR,&LAST,&USING,&TEMP,&FIRST,&TMPDATA
         LCLC  &DATAEND,&BEG,&BYP,&LEN,&H
&BSPRENT SETB  0
&BSPSP   SETC  '&SP'
&TMPDATA SETC  'BSPA'.'&SYSNDX'
&DATAEND SETC  'BSPB'.'&SYSNDX'           , SAVE AREA LABEL, END
&BEG     SETC  'BSPC'.'&SYSNDX'           , PROGRAM BEGIN LABEL
&BYP     SETC  'BSPD'.'&SYSNDX'           , END OF EYECATCHER
&LEN     SETC  'BSPE'.'&SYSNDX'           , LENGTH OF EYECATCHER
&BSPDSCT SETC  '&DATA'                    , NAME OF AUTOMATIC STORAGE
&BSPDSCE SETC  '&DATAEND'                 , end of getmain area
         AIF   ('&RENT' NE 'YES').NORENT
&BSPRENT SETB  1
         AIF   ('&DATA' NE '').DATA
&BSPDSCT SETC  '&TMPDATA'                 , NAME OF DATA AREA
         MNOTE 8,'REQUIRED OPERAND ''NAME'' MISSING. &BSPDSCT USED'
.DATA    ANOP
         AIF   ('&SP' NE '').SP
&BSPSP   SETC  '1'
         MNOTE 8,'REQUIRED OPERAND ''SP'' MISSING. SP=&BSPSP USED'
.SP      ANOP
.NORENT  ANOP
&H       SETC  ' ===> '                   , PART OF HEADER
         AIF   ('&HEADER' EQ '').NOHEAD
         AIF   ('&HEADER'(1,1) EQ '''').HEADAPO
&H       SETC  '&HEADER'
         AGO   .NOHEAD
.HEADAPO ANOP
&H       SETC  '&HEADER'(2,K'&HEADER-2)
.NOHEAD  ANOP
&BSPCSCT SETC  '&NAME'
         AIF   ('&NAME' NE '').CSECT
&BSPCSCT SETC  'BSPF'.'&SYSNDX'
         MNOTE 8,'REQUIRED OPERAND ''NAME'' MISSING. &BSPCSCT USED'
.CSECT   ANOP
         @     &BSPCSCT
&BSPCSCT BOX   'MODULE NAME................... &BSPCSCT',              +
               'WRITTEN BY.................... &BSPAUTH',              +
               'ASSEMBLY DATA................. &SYSDATE',              +
               'ASSEMBLY TIME................. &SYSTIME',              +
               'WORKAREA NAME................. &BSPDSCT',              +
               TITLE=' HOUSEKEEPING ',                                 +
               HEAD=&H
&BSPCSCT CSECT
         REGISTER
         USING &BSPCSCT,R15               , Temporary addressability
         B     &BYP                       , branch around eyecatcher
&BEG     EQU   *                          , Beginning of eyecatcher
         DC    AL1(&BYP-&BEG)             , Length of eyecatcher
         DC    CL8'&BSPCSCT'              , CSECT name
         DC    C' VER. &BSPVER..&BSPMOD ' , Version and Mod Level
         DC    C'&SYSDATE._&SYSTIME'      , ASSEMBLY DATE AND TIME
         DC    C' &BSPAUTH'               , Author
&BYP     DS    0H                         , end of eyecatcher
         STM   R14,R12,12(R13)            , save callers registers
&NUMREGS SETA  1
.CKBASE  ANOP
&REG     SETC  '&BASE(&NUMREGS)'(1,3)
         AIF   ('&REG'(1,1) NE 'R').SKIPBAS
&TEMP    SETC  '&REG'(2,2)
&REGNO   SETA  &TEMP
         AIF   (&REGNO LT 2).BADBASE
         AIF   (&REGNO GT 12).BADBASE
         AIF   (&REGNO NE 2).SETBASE
         MNOTE 0,'*** WARNING - R2 IS A BASE REGISTER. TRANSLATE AND TE+
               ST INSTRUCTION WILL DESTROY CONTENTS.'
.SETBASE ANOP
         AIF   ('&FIRST' NE '').SETBAS2
         LR    &REG,R15                   , load base register
&FIRST   SETC  '&REG'
         AGO   .SETLAST
.SETBAS2 LA    &REG,2048(&LAST)           , add 2048 to last base
         LA    &REG,2048(&REG)            , make it 4096 for next base
.SETLAST ANOP
&LAST    SETC  '&REG'
&USING   SETC  '&USING.,&REG'
         AGO   .NEXTBAS
.SKIPBAS MNOTE 8,'*&REG* IS AN INVALID REGISTER FORM, IGNORED'
         AGO   .NEXTBAS
.BADBASE MNOTE 8,'*&REG* IS AN INVALID BASE REGISTER, IGNORED'
.NEXTBAS ANOP
&NUMREGS SETA  &NUMREGS+1
         AIF   (&NUMREGS LE N'&BASE).CKBASE
         DROP  R15                         , forget old base register
         USING &BSPCSCT.&USING             , TELL NEW BASE TO ASSEMBLER
.NOSPM   AIF   ('&CHAIN' EQ 'NO').DONE
         AIF   (&BSPRENT).GETMAIN
         LR    R15,R13                     , OLD SAVE AREA POINTER
         CNOP  0,4                    , Align to fullword boundary
         BAL   R13,&DATAEND           , Load new save area address
&DATA    DC    9CL8'&BSPCSCT'         , Save area
&DATAEND ST    R13,8(0,R15)           , Store into old save area
         AGO   .CHAIN
.GETMAIN ANOP
 MNOTE *,'GETMAIN R,LV=&BSPDSCE-&BSPDSCT,SP=&SP'
         GETMAIN R,LV=&BSPDSCE-&BSPDSCT,SP=&SP
         LR    R15,R13                , old save area pointer
         LR    R13,R1                 , r13 points to new save area
         USING &DATA,R13              , tell assembler
         LM    R0,R1,20(R15)          , restore original R0 and R1
.CHAIN   ST    R15,4(R13)             , address of old SA into new SA
         ST    R13,8(R15)             , address of new SA into old SA
.DONE    ANOP
         MEND
./ ADD NAME=BSPGLBLS
         GBLC  &BSPAUTH               , Program authors
         GBLC  &BSPCSCT               , Current CSECT name
         GBLC  &BSPMOD                , Modification level
         GBLC  &BSPPRFX               , Program Prefix Chars
         GBLC  &BSPPRGM               , Program id string
         GBLC  &BSPVER                , Program version number
./ ADD NAME=BSPPATCH
         MACRO
         BSPPATCH &N,&M
.**********************************************************************
.*                                                                    *
.* NAME : BSPPATCH                                                    *
.*                                                                    *
.* TYPE: ASSEMBLER MACRO                                              *
.*                                                                    *
.* PURPOSE:   TO RESERVE 5% OR 25 HALF WORDS IN A MODULE              *
.*            FOR MAINTENANCE                                         *
.*            IF &N IS SET IT IS ASSUMED TO BE % OF SPACE             *
.*            TO BE RESERVED                                          *
.*            IF &M IS SET IT IS ASSUMED TO BE NUMBER OF BYTES        *
.*            TO BE RESERVED                                          *
.*                                                                    *
.**********************************************************************
         DS    0H                         , ALIGN TO HALFWORD FIRST
&LBLA    SETC  '$$1'.'&SYSNDX'              ,
&LBLB    SETC  '$$2'.'&SYSNDX'              ,
         AIF   (T'&N NE 'O').PCNT
         AIF   (T'&M NE 'O').NUMB
.DFLT    ANOP  ,
&LBLA    EQU   ((*-&SYSECT+99)/100)*5       , DEFAULT OF 5 PERCENT
&PERC    SETC  '5 PERCENT OF MODULE SIZE '  ,
         AGO   .PTCH
.PCNT    ANOP  ,
         AIF   (T'&N NE 'N').MNT1
&LBLA    EQU   ((*-&SYSECT+99)/100)*&N      , VALUE OF N PERCENT
&PERC    SETC  '&N PERCENT OF MODULE SIZE   '
         AGO   .PTCH
.NUMB    ANOP  ,
         AIF   (T'&M NE 'N').MNT1
&PERC    SETC  '&M BYTES '                ,
&LBLA    EQU   &M                           , VALUE OF &M BYTES
         AGO   .PTCH
.PTCH    ANOP
         MNOTE *,'&PERC SET ASIDE AS PATCH AREA'
         DC    CL28'PATCH AREA - &SYSECT' , EYE CATCHER
&LBLB    DC    25S(*)                     , AT LEAST 25 HALFWORDS
         ORG   &LBLB                      , POSITION TO BEGINNING
         DC    ((&LBLA+1)/2)S(*)          , RESERVE SUFFICIENT STORAGE
         ORG   ,                          , REPOSITION
         MEXIT                            , LEAVE THE MACRO
.MNT1    MNOTE 8,'VALUE MUST BE NUMERIC'
         AGO   .DFLT
         MEND
./ ADD NAME=BSPRET
         MACRO
&LABEL   BSPRET &RC=
         COPY  BSPGLBLS
         COPY  BSPSGLBL
         GBLB  &BSPRENT
         GBLC  &BSPDSCT,&BSPDSCE,&BSPSP
&LABEL   DS    0H                     , align just to make sure
         AIF   ('&RC' EQ '').RETR15   , BIF no RC parm give
         AIF   ('&RC'(1,1) EQ '(').LR
         LA    R15,&RC.(0,0)          , set up returncode
         AGO   .RETR15
.LR      ANOP
&RT      SETC  '&RC'(2,K'&RC-2)
         LR    R15,&RT                , Load return code from register
.RETR15  ANOP
         AIF   (NOT &BSPRENT).NORENT
         LR    R1,R13                 , save current save area address
         BALR  R2,0                   , set up base register
         USING *,R2                   , tell assembler
         L     R3,4(R13)              , Get old save area address
         LR    R4,R15                 , save return code
  MNOTE *,'FREEMAIN R,LV=&BSPDSCE-&BSPDSCT,A=(1),SP=&BSPSP'
         FREEMAIN R,LV=&BSPDSCE-&BSPDSCT,A=(1),SP=&BSPSP
         LR    R15,R4                 , restore rc
         LR    R13,R3                 , restor old savearea
         DROP  R2                     , drop temporary base
         AGO   .RENT
.NORENT  ANOP
         L     R13,4(R13)             , Get old save area address
.RENT    ANOP
         L     R14,12(R13)            , restore return address
         LM    R0,R12,20(R13)         , restore remaining registers
         BR    R14                    , and return to caller
         AIF   (NOT &BSPRENT).MEXIT
&BSPDSCT DSECT                        , Automatic storage
         DS    18F                    , standard save area
&BSPCSCT CSECT                        , resume CSECT
.MEXIT   MEXIT
         MEND
./ ADD NAME=BSPSGLBL
&BSPAUTH SETC  'V.BANDKE, BSP GmbH'   , PROGRAM AUTHORS
&BSPMOD  SETC  '0'                    , MODIFICATION LEVEL
&BSPPRFX SETC  'BSP'                  , PROGRAM PREFIX CHARS
&BSPPRGM SETC  'BSPMAIN'              , PROGRAM ID STRING
&BSPVER  SETC  '1'                    , VERSION NUMBER
./ ADD NAME=DO
         MACRO
&NAME    DO    &P1,&P2,&P3,&P4,&P5,&P6,&P7,&P8,&P9,&P10,&P11,&P12,&P13,*
               &P14,&P15,&P16,&P17,&P18,&P19,&P20,&WHILE=,&FROM=,&C=
.*#-------------------------------------------------------------------*
.*#      DO    MACRO FOR STRUCTURED PROGRAMMING                       *
.*#----------------------------------------------------23-09-80-RS----*
.*#
.*#   FUNCTION:    STARTS A NEW DO GROUP
.*#
.*#   CALL(1):     DO WHILE=COND1
.*#                   WHILE=COND1,OP1,COND2
.*#                   WHILE=COND1,OP1,COND2,OP2,COND3,...,CONDN
.*#
.*#                -   CONDI : A VALID ASSEMBLER INSTRUCTION WITH
.*#                            MNEMOTECNIC CONDITION CODE (IN BRACKETS)
.*#                            EXAMPLE: (TM,SWITCH,X'04',O)
.*#                            FOR COMPARE OPERATIONS THE CONDITION-
.*#                            CODE WILL BE PUT BETWEEN THE OPERANDS
.*#                            EXAMPLE: (CLC,FIELD1,EQ,FIELD2)
.*#                -   OPI:    IS ONE OF THE LOGICAL OPERANDS 'AND' OR
.*#                            'OR'
.*#                            DO NOT MIX 'AND' AND 'OR' IN THE SAME
.*#                            DO GROUP.
.*#
.*#
.*#   CALL(2):     DO  FROM=(REG,INITVAL)
.*#
.*#                -   REG:    LOOP-REGISTER. IT CONTAINS THE NUMBER
.*#                            OF TIMES THE LOOP WILL BE EXECUTED
.*#                -   INITVAL: INITAL VALUE FOR THE LOOP REGISTER
.*#                            THIS PARAMETER MAY BE OMITTED. IN THIS
.*#                            CASE THE MACRO ASSUMES, THAT THE
.*#                            REGISTER IS ALREADY LOADED.
.*#
.*#
.*#   CALL(3):     DO  INF
.*#
.*#                AN INFINITE LOOP WILL BE GENERATED.
.*#                PLEASE USE THE 'EXIT' OR 'EXITIF' MACRO TO LEAVE
.*#                THE LOOP.
.*#
.*#
.*#--------------------------------------------------------------------
         LCLA  &I              INDEX FOR STRING SCANNING
         LCLA  &N              TOTAL NESTING LEVEL
         LCLC  &OPND
         COPY  IFGLO
.*--------------------------------------------------------------------*
.*       FIRST DO/IF: INIT GLOBALS                                    *
.*--------------------------------------------------------------------*
         AIF   (&IFINIT).START            INIT ALREADY DONE
&IFINIT  SETB  1
&IFLEVEL SETA  0
&DOLEVEL SETA  0
&IFLABEL SETA  0
&IFLIMIT SETA  100000
&IFPRAEF SETC  '##'                    WAR #I
&IFDEBUG SETB  0
.START   ANOP
&MACNA   SETC  'DO'
.*--------------------------------------------------------------------*
.*       FORMAL TESTS                                                 *
.*--------------------------------------------------------23-09-80-RS-*
.FOR01   ANOP
         AIF   ('&WHILE' EQ '').FOR02     NO WHILE PARAM
         AIF   ('&FROM'  NE '').FEHL12    FROM AND WHILE SPECIFIED
&OPND    SETC  'WHILE='
         AGO   .FOR04
.*
.FOR02   ANOP
         AIF   ('&FROM' EQ '').FOR03      DO WITHOUT FROM/WHILE
         AIF   ('&FROM'(1,1) NE '(').FEHL13 NOT IN BRCKETS
         AIF   ('&P1' NE '').FEHL14       EXCESIVE PARAMETERS
&OPND    SETC  'FROM='
         AGO   .FOR04
.*
.FOR03   ANOP
         AIF   ('&P1' NE 'INF').FEHL15
         AIF   ('&P2' NE '').FEHL18
.FOR04   ANOP
.*--------------------------------------------------------------------*
.*       INCREMENT LEVEL. GENERATE LABELS FOR FALSE/TRUE              *
.*--------------------------------------------------------------------*
&DOLEVEL SETA  &DOLEVEL+1
         AIF   (&DOLEVEL EQ 50).FEHL06
         AIF ('&SYSPARM' EQ '').OBR00
         AIF ('&SYSPARM'(1,2) EQ 'NO').OBR00
&NAME    SVDOC   COM=START,&OPND,&WHILE&FROM,C=&C,                     *
               &P1,&P2,&P3,&P4,&P5,&P6,&P7,&P8,&P9,&P10,&P11,&P12,&P13,*
               &P14,&P15,&P16,&P17,&P18,&P19,&P20
.*
&OPND    SETC  ''
.*
.OBR00   ANOP
.*
&IFLABEL SETA  &IFLABEL+1
         AIF   (&IFLABEL GE &IFLIMIT).FEHL06
.*
.*--------------------------------------------------------------------*
.*       SAVE NAME OF DO-GROUP FOR EXIT MACRO                         *
.*--------------------------------------------------------24-09-80-RS-*
&DONAME(&DOLEVEL) SETC '&NAME'
.*--------------------------------------------------------------------*
.*       FROM - CLAUSE                                                *
.*--------------------------------------------------------23-09-80-RS-*
         AIF   ('&P1' EQ 'INF').STA03     DO INFINITE
         AIF   ('&WHILE' NE '').STA03     NO FROM, SO WHILE
&DOFROM(&DOLEVEL) SETC '&FROM'            GET LOOP REGISTER
         AIF   ('&FROM(2)' EQ '').STA03   NO INITIAL VALUE
&DOFROM(&DOLEVEL) SETC '&FROM(1)'         GET LOOP REGISTER
         LA    &FROM(1),&FROM(2)          GET INITAL LOOP COUNT (DO)
.*--------------------------------------------------------------------*
.*       GENERATE START AND END LABEL                                 *
.*--------------------------------------------------------23-09-80-RS-*
.STA03   ANOP
&DOSTART(&DOLEVEL) SETC '&IFLABEL'
&OPND    SETC  '&IFPRAEF&DOSTART(&DOLEVEL)'
&OPND    DS    0H                         TARGET FOR DO-LOOP
.*
&IFLABEL SETA  &IFLABEL+1
         AIF   (&IFLABEL GE &IFLIMIT).FEHL06
.*
&DOENDLB(&DOLEVEL) SETC '&IFLABEL'        TARGET FOR END OF DO-LOOP
         AIF    ('&FROM' NE '').MACEND    DON'T CALL IF-PROCESSOR
         AIF    ('&P1' EQ  'INF').MACEND  DON'T CALL IF-PROCESSOR
.*--------------------------------------------------------------------*
.*       GENERATE LABEL FOR BRANCH ON TRUE                            *
.*--------------------------------------------------------23-09-80-RS-*
&IFLABEL SETA  &IFLABEL+1
         AIF   (&IFLABEL GE &IFLIMIT).FEHL06
.*
&DOTRUE  SETC  '&IFLABEL'
.*
.*--------------------------------------------------------------------*
.*       CALL IF-PROCESSOR TO ANALYZE CONDITION                       *
.*--------------------------------------------------------------------*
         IFPRO &DOTRUE,&DOENDLB(&DOLEVEL),&WHILE,                      *
               &P1,&P2,&P3,&P4,&P5,&P6,&P7,                            *
               &P8,&P9,&P10,&P11,&P12,&P13,&P14,&P15,&P16,&P17,&P18,   *
               &P19,&P20
.*--------------------------------------------------------------------*
.*       SET TRUE LABEL                                               *
.*--------------------------------------------------------------------*
&OPND    SETC  '&IFPRAEF&DOTRUE'
&OPND    DS    0H                        TARGET FOR BANCH ON NOT TRUE
         AGO   .MACEND
.*
         COPY IFERR
.*
.MACEND  ANOP
         MEXIT
         MEND
./ ADD NAME=ELSE
         MACRO
&NAME    ELSE  &COMMENT,&C=
.*#-------------------------------------------------------------------*
.*#  ELSE: MACRO FOR STRUCTURED PROGRAMMING                           *
.*#-------------------------------------------------------------------*
.*#                                                                   *
.*#  FUNCTION: IF ALL PRECEDING CONDITIONS IN THE 'IF' OR 'ELESIF'    *
.*#            MACROS OF THE SAME NESTING LEVEL TURN OUT TO BE        *
.*#            NOT FULLFILLED, THE CODE AFTER THE 'ELSE' MACRO        *
.*#            WILL BE EXECUTED.                                      *
.*#                                                                   *
.*#  CODING:   ELSE     (NO OPERANDS)                                 *
.*#                                                                   *
.*#-------------------------------------------------------------------*
         COPY  IFGLO
         LCLC  &OPND
         LCLA  &N
.*--------------------------------------------------------------------*
.*       GENERATE BRANCH TO ENDIF                                     *
.*--------------------------------------------------------23-09-80-RS-*
.*
&MACNA   SETC  'ELSE'
.*
         AIF ('&SYSPARM' EQ '').OBR00
         AIF ('&SYSPARM'(1,2) EQ 'NO').OBR00
&NAME    SVDOC  COM=CONT,C=&C
.OBR00   ANOP
         AIF   ('&IFENDLB(&IFLEVEL)' NE '').NOEND  KEIN ENDIF
&IFLABEL SETA  &IFLABEL+1
.*
         AIF   (&IFLABEL GE &IFLIMIT).FEHL06
&IFENDLB(&IFLEVEL) SETC '&IFLABEL'
.*
.NOEND   ANOP
&OPND    SETC  '&IFPRAEF&IFENDLB(&IFLEVEL)'
         B     &OPND                       BRANCH TO ENDIF
.*--------------------------------------------------------------------*
.*       GENERATE TARGET FOR BRANCH ON ELSE                           *
.*--------------------------------------------------------23-09-80-RS-*
&OPND    SETC  '&IFPRAEF&IFFALSE(&IFLEVEL)'
&OPND    DS    0H                          TARGET FOR BRANCH ON ELSE
.*--------------------------------------------------------------------*
.*       SIGNAL TO ENDIF: GENERATE NO ELSE LABEL                      *
.*--------------------------------------------------------23-09-80-RS-*
&IFFALSE(&IFLEVEL) SETC ''
         AGO   .MACEND
.*
         COPY  IFERR
.*
.MACEND  ANOP
         MEXIT
         MEND
./ ADD NAME=ELSEIF
         MACRO
&NAME   ELSEIF &P1,&P2,&P3,&P4,&P5,&P6,&P7,&P8,&P9,&P10,&P11,&P12,&P13,*
               &P14,&P15,&P16,&P17,&P18,&P19,&P20,&C=
.*#-------------------------------------------------------------------*
.*#     ELSEIF MACRO FOR STRUCTURED PROGRAMMING                       *
.*#----------------------------------------------------23-09-80-RS----*
.*#
.*#   FUNCTION:    STANDS ON THE PLACE OF AN 'ELSE' AND STARTS A NEW
.*#                CONDITION CLAUSE
.*#
.*#   MODEL:       ELSEIF  COND1
.*#                        COND1,OP1,COND2
.*#                        COND1,OP1,COND2,OP2,COND3,...,CONDN
.*#
.*#                -   CONDI : A VALID ASSEMBLE INSTRUCTION WITH
.*#                            MENOTECNIC CONDITION CODE (IN BRACKETS)
.*#                            EXAMPLE: (TM,SWITCH,X'04',O)
.*#                            FOR COMPARE OPERATIONS THE CONDITION-
.*#                            CODE WILL BE PUT BETWEEN THE OPERANDS
.*#                            EXAMPLE: (CLC,FIELD1,EQ,FIELD2)
.*#                -   OPI:    IS ONE OF THE LOGICAL OPERANDS 'AND' OR
.*#                            'OR'
.*#                            DO NOT MIX 'AND' AND 'OR' OPERANDS IN
.*#                            THE SAME ELSEIF.
.*#
.*#--------------------------------------------------------------------
         LCLA  &I              INDEX FOR STRING SCANNING
         LCLA  &N              TOTAL NESTING LELVEL
         LCLC  &OPND
         COPY  IFGLO
.*
&MACNA   SETC  'ELSEIF'
.*
         AIF   ('&P1' EQ '').FEHL17      FORMAL TEST
.*--------------------------------------------------------------------*
.*       GENERATE BRANCH TO ENDIF                                     *
.*--------------------------------------------------------------------*
         AIF ('&SYSPARM' EQ '').OBR00
         AIF ('&SYSPARM'(1,2) EQ 'NO').OBR00
&NAME    SVDOC   COM=CONT,C=&C,                                        *
               &P1,&P2,&P3,&P4,&P5,&P6,&P7,&P8,&P9,&P10,&P11,&P12,&P13,*
               &P14,&P15,&P16,&P17,&P18,&P19,&P20
.*
.OBR00   ANOP
         AIF   ('&IFENDLB(&IFLEVEL)' NE '').NOEND  KEIN ENDIF
&IFLABEL SETA  &IFLABEL+1
         AIF   (&IFLABEL GE &IFLIMIT).FEHL06
&IFENDLB(&IFLEVEL) SETC '&IFLABEL'
.*
.NOEND   ANOP
&OPND    SETC  '&IFPRAEF&IFENDLB(&IFLEVEL)'
         B     &OPND                       BRANCH TO ENDIF
.*--------------------------------------------------------------------*
.*       GENERATE TARGET FOR BRANCH ON ELSE                           *
.*--------------------------------------------------------23-09-80-RS-*
&OPND    SETC  '&IFPRAEF&IFFALSE(&IFLEVEL)'
&OPND    DS    0H                          TARGET FOR BRANCH ON ELSE
.*--------------------------------------------------------------------*
.*       GENERATE NEXT ELSE LABEL                                     *
.*--------------------------------------------------------23-09-80-RS-*
&IFLABEL SETA  &IFLABEL+1
         AIF   (&IFLABEL GE &IFLIMIT).FEHL06
.*
&IFFALSE(&IFLEVEL) SETC '&IFLABEL'         ID FOR NEXT ELSE ON LEVEL
.*--------------------------------------------------------------------*
.*       GENERATE TRUE LABEL                                          *
.*--------------------------------------------------------23-09-80-RS-*
&IFLABEL SETA  &IFLABEL+1
         AIF   (&IFLABEL GE &IFLIMIT).FEHL06
&IFTRUE  SETC  '&IFLABEL'                  TRUE LABEL FOR AND /OR
.*--------------------------------------------------------------------*
.*       CALL IF-PROCESSOR TO ANALYZE CONDITION                       *
.*--------------------------------------------------------------------*
         IFPRO &IFTRUE,&IFFALSE(&IFLEVEL),&P1,&P2,&P3,&P4,&P5,&P6,&P7, *
               &P8,&P9,&P10,&P11,&P12,&P13,&P14,&P15,&P16,&P17,&P18,   *
               &P19,&P20
.*--------------------------------------------------------------------*
.*       SET TRUE LABEL                                               *
.*--------------------------------------------------------------------*
&OPND    SETC  '&IFPRAEF&IFTRUE'
&OPND    DS    0H                        TARGET FOR BANCH ON NOT TRUE
         AGO   .MACEND
.*
         COPY IFERR
.*
.MACEND  ANOP
         MEXIT
         MEND
./ ADD NAME=ENDDO
         MACRO
&NAME    ENDDO &COMMENT,&C=
.*#-------------------------------------------------------------------*
.*# ENDDO: CLOSE A DO GROUP IN STRUCTURED PROGRAMMING                 *
.*#-------------------------------------------------------------------*
.*#                                                                   *
.*# FUNCTION: CLOSES A DO-LOOP   (= DO GROUP)                         *
.*#                                                                   *
.*#                                                                   *
.*# CODING:   ENDDO           (NO PARAMETERS)                         *
.*#                                                                   *
.*#                                                                   *
.*#-------------------------------------------------------------------*
         COPY  IFGLO
         LCLC  &OPND
         LCLA  &N
.*
&MACNA   SETC  'ENDDO'
.*
         AIF   (&DOLEVEL GT 0).OBR20
    MNOTE 12,' ??????  ADIOS LOGIC !!!,     EMERGENCY MESSAGE FROM STRU*
               CTURED PROGRAMMING SYSTEM.'
         MEXIT
.*
.OBR20   ANOP
         AIF ('&SYSPARM' EQ '').OBR00
         AIF ('&SYSPARM'(1,2) EQ 'NO').OBR00
&NAME    SVDOC   COM=END,C=&C
.OBR00   ANOP
.*--------------------------------------------------------------------*
.*       BRANCH BACK TO START IF FROM-REGISTER IS NOT ZERO            *
.*--------------------------------------------------------23-09-80-RS-*
.*
         AIF   ('&DOFROM(&DOLEVEL)' EQ '').WHILE
&OPND    SETC  '&DOFROM(&DOLEVEL),&IFPRAEF&DOSTART(&DOLEVEL)'
         BCT   &OPND                       BRANCH BACK TO START OF LOOP
         AGO   .LOOPEND
.*--------------------------------------------------------------------*
.*       BRANCH BACK TO START OF LOOP IN CASE OF WHILE CONTROL        *
.*--------------------------------------------------------23-09-80-RS-*
.WHILE   ANOP
&OPND    SETC  '&IFPRAEF&DOSTART(&DOLEVEL)'
         B     &OPND                       BRANCH BACK TO START OF LOOP
.*--------------------------------------------------------------------*
.*       GENERATE TARGET LABEL TO LEAVE THE LOOP (PSEUDO ELSE)        *
.*--------------------------------------------------------23-09-80-RS-*
.LOOPEND ANOP
&OPND    SETC  '&IFPRAEF&DOENDLB(&DOLEVEL)'
&OPND    DS    0H                          TARGET TO LEAVE THE LOOP
.*--------------------------------------------------------------------*
.*       RESET FUNCTIONS FOR THIS DO LEVEL                            *
.*--------------------------------------------------------23-09-80-RS-*
.RESET   ANOP
&DOTRUE  SETC  ''
&DOFALSE(&DOLEVEL) SETC ''
&DOENDLB(&DOLEVEL) SETC ''
&DOSTART(&DOLEVEL) SETC ''
&DOFROM(&DOLEVEL)  SETC ''
&DONAME(&DOLEVEL)  SETC ''
&DOLEVEL SETA  &DOLEVEL-1
         AGO   .MACEND
.*
.MACEND  ANOP
         MEXIT
         MEND
./ ADD NAME=ENDIF
         MACRO
&NAME    ENDIF &COMMENT,&C=
.*#-------------------------------------------------------------------*
.*# ENDIF: MACRO  CLOSE CURRENT IF LEVEL                              *
.*#-------------------------------------------------------------------*
.*#                                                                   *
.*# FUNCTION: THE ACTUAL 'IF' LEVEL WILL BE CLOSED.                   *
.*#                                                                   *
.*# CODING:   ENDIF      (NO OPERANDS)                                *
.*#                                                                   *
.*#-------------------------------------------------------------------*
         COPY  IFGLO
         LCLC  &OPND
         LCLA  &N
.*
&MACNA   SETC  'ENDIF'
.*
.*--------------------------------------------------------------------*
.*       IF WITHOUT ELSE: GENERATE ELSE LABEL                         *
.*--------------------------------------------------------23-09-80-RS-*
         AIF   (&IFLEVEL GT 0).OBR20
    MNOTE 12,' ??????  ADIOS LOGIC !!!,     EMERGENCY MESSAGE FROM STRU*
               CTURED PROGRAMMING SYSTEM.'
         MEXIT
.*
.OBR20   ANOP
         AIF ('&SYSPARM' EQ '').OBR00
         AIF ('&SYSPARM'(1,2) EQ 'NO').OBR00
&NAME    SVDOC   COM=END,C=&C
.OBR00   ANOP
         AIF   ('&IFFALSE(&IFLEVEL)' EQ '').NOELSE
&OPND    SETC  '&IFPRAEF&IFFALSE(&IFLEVEL)'
&OPND    DS    0H                          TARGET FOR ELSE BRANCH
.NOELSE  ANOP
.*--------------------------------------------------------------------*
.*       GENERATE ENDIF LABEL IF NECESSARY                            *
.*--------------------------------------------------------23-09-80-RS-*
         AIF   ('&IFENDLB(&IFLEVEL)' EQ '').NOENDIF
&OPND    SETC  '&IFPRAEF&IFENDLB(&IFLEVEL)'
&OPND    DS    0H                          TARGET FOR ENDIF BRANCH
.NOENDIF ANOP
.*--------------------------------------------------------------------*
.*       RESET FUNCTIONS OF THIS IF-LEVEL                             *
.*--------------------------------------------------------23-09-80-RS-*
&IFTRUE  SETC  ''
&IFFALSE(&IFLEVEL) SETC ''
&IFENDLB(&IFLEVEL) SETC ''
&IFLEVEL SETA &IFLEVEL-1
         AGO   .MACEND
.MACEND  ANOP
         MEXIT
         MEND
./ ADD NAME=EXIT
         MACRO
&NAME    EXIT  &DO=,&C=
.*#-------------------------------------------------------------------*
.*#   EXIT     MACRO FOR STRUCTURED PROGRAMMING                       *
.*#-------------------------------------------------------------------*
.*#
.*#   FUNCTION:    UNCONDITIONAL EXIT OF ONE OR MORE DO GROUPS.
.*#
.*#   SYNTAX       EXIT      : EXITS CURRENT DO GROUP
.*#
.*#                EXIT  DO=DOGROUP
.*#
.*#                -   DOGROUP: AN ASSEMBLER LABEL OF A DO-GROUP
.*#                            EXITS THE DO GROUP WITH THIS LABEL
.*#                            EXAMPLE: EXIT DO=FIRST
.*#
.*#--------------------------------------------------------------------
         LCLA  &I              INDEX DONAME SCANNING
         LCLA  &N              INDEX PRINTING NAME
         LCLC  &OPND
         COPY  IFGLO
.*
&MACNA   SETC  'EXIT'
.*
         AIF   (&DOLEVEL GT 0).OBR20
    MNOTE 12,' ??????  ADIOS LOGIC !!!,     EMERGENCY MESSAGE FROM STRU*
               CTURED PROGRAMMING SYSTEM.'
         MEXIT
.OBR20   ANOP
.**&N       SETA  &DOLEVEL+&IFLEVEL           GENERATE LEVEL MESSAGE
         AIF ('&SYSPARM' EQ '').OBR00
         AIF ('&SYSPARM'(1,2) EQ 'NO').OBR00
.**         MNOTE *,'&N CONT'                 GENERATE LEVEL MESSAGE
&NAME    SVDOC   COM=CONT,&DO,C=&C
.OBR00   ANOP
         AIF   ('&DO' EQ '').NONAME        NAME OF DO GROUP SPECIFIED
.*--------------------------------------------------------------------*
.*       LOOK UP NAME-TABLE FOR CURRENT NAME                          *
.*--------------------------------------------------------------------*
&I       SETA  1
.LOOP    ANOP
         AIF   (&I GT &DOLEVEL).FEHL19
         AIF   ('&DO' EQ '&DONAME(&I)').ENDLOOP  THE NAME IS IN TABLE
&I       SETA  &I+1                              NEXT ELEMENT
         AGO  .LOOP
.ENDLOOP ANOP
         AGO  .GENER
.*--------------------------------------------------------------------*
.*       EXIT CURRENT LOOP                                            *
.*--------------------------------------------------------------------*
.NONAME  ANOP
&I       SETA  &DOLEVEL
.GENER   ANOP
.*
.*--------------------------------------------------------------------*
.*  GENERATE CODE TO EXIT THE SPECIFIED LOOP                          *
.*--------------------------------------------------------------------*
&OPND    SETC  '&IFPRAEF&DOENDLB(&I)'
         B     &OPND                     LEAVE THE LOOP &DO
.*
         AGO   .MACEND
.*
         COPY IFERR
.*
.MACEND  ANOP
         MEXIT
         MEND
./ ADD NAME=FILL
         MACRO
&NAME    FILL  &AREA
&NAME    DC      CL(&AREA+L'&AREA-*)' '
         MEND
./ ADD NAME=IF
         MACRO
&NAME    IF    &P1,&P2,&P3,&P4,&P5,&P6,&P7,&P8,&P9,&P10,&P11,&P12,&P13,*
               &P14,&P15,&P16,&P17,&P18,&P19,&P20,&C=
.*#-------------------------------------------------------------------*
.*#      IF    MACRO FOR STRUCTURED PROGRAMMING                       *
.*#----------------------------------------------------23-09-80-RS----*
.*#
.*#   FUNCTION:    STARTS A NEW IF LEVEL
.*#
.*#   MODEL:       IF  COND1
.*#                    COND1,OP1,COND2
.*#                    COND1,OP1,COND2,OP2,COND3,...,CONDN
.*#
.*#                -   CONDI : A VALID ASSEMBLE INSTRUCTION WITH
.*#                            MENOTECNIC CONDITION CODE (IN BRACKETS)
.*#                            EXAMPLE: (TM,SWITCH,X'04',O)
.*#                            FOR COMPARE OPERATIONS THE CONDITION-
.*#                            CODE WILL BE PUT BETWEEN THE OPERANDS
.*#                            EXAMPLE: (CLC,FIELD1,EQ,FIELD2)
.*#                -   OPI:    IS ONE OF THE LOGICAL OPERANDS 'AND' OR
.*#                            'OR'
.*#                            DO NOT MIX 'AND' AND 'OR' OPERANDS IN
.*#                            THE SAME IF STATEMENT.
.*#
.*#--------------------------------------------------------------------
         LCLA  &I              INDEX FOR STRING SCANNING
         LCLA  &N              TOTAL NESTING LEVEL
         LCLC  &OPND
         COPY  IFGLO
.*--------------------------------------------------------------------*
.*       FIRST IF: INIT GLOBALS                                       *
.*--------------------------------------------------------------------*
         AIF   (&IFINIT).START            INIT ALREADY DONE
&IFINIT  SETB  1
&IFLEVEL SETA  0
&DOLEVEL SETA  0
&IFLABEL SETA  0
&IFLIMIT SETA  100000
&IFPRAEF SETC  '##'
&IFDEBUG SETB  0
.*--------------------------------------------------------------------*
.*       INCREMENT LEVEL. GENERATE LABELS FOR FALSE/TRUE              *
.*--------------------------------------------------------------------*
.START   ANOP
&MACNA   SETC  'IF'
&IFLEVEL SETA  &IFLEVEL+1
         AIF   (&IFLEVEL EQ 50).FEHL06
         AIF ('&SYSPARM' EQ '').OBR00
         AIF ('&SYSPARM'(1,2) EQ 'NO').OBR00
&NAME    SVDOC   COM=START,C=&C,                                       *
               &P1,&P2,&P3,&P4,&P5,&P6,&P7,&P8,&P9,&P10,&P11,&P12,&P13,*
               &P14,&P15,&P16,&P17,&P18,&P19,&P20
.*
.OBR00   ANOP
&IFLABEL SETA  &IFLABEL+1
         AIF   (&IFLABEL GE &IFLIMIT).FEHL06
&IFFALSE(&IFLEVEL) SETC '&IFLABEL'    LABEL FOR BRANCH ON NOT TRUE
&IFTRUE  SETC  ''
         AIF   ('&SYSLIST(2)' EQ '').STA03 KEIN TRUE LABEL ERFORDERLICH
&IFLABEL SETA  &IFLABEL+1
         AIF   (&IFLABEL GE &IFLIMIT).FEHL06
&IFTRUE  SETC  '&IFLABEL'                  TRUE LABEL FOR AND /OR
.*--------------------------------------------------------------------*
.*       CALL IF-PROCESSOR TO ANALYZE CONDITION                       *
.*--------------------------------------------------------------------*
.STA03   ANOP
         IFPRO &IFTRUE,&IFFALSE(&IFLEVEL),&P1,&P2,&P3,&P4,&P5,&P6,&P7, *
               &P8,&P9,&P10,&P11,&P12,&P13,&P14,&P15,&P16,&P17,&P18,   *
               &P19,&P20
.*--------------------------------------------------------------------*
.*       SET TRUE LABEL IF NECESSARY                                  *
.*--------------------------------------------------------------------*
         AIF   ('&IFTRUE' EQ '').MACEND
&OPND    SETC  '&IFPRAEF&IFTRUE'
&OPND    DS    0H                        TARGET FOR BANCH ON NOT TRUE
         AGO   .MACEND
.*
         COPY IFERR
.*
.MACEND  ANOP
         MEXIT
         MEND
./ ADD NAME=IFERR
.*#-------------------------------------------------------------------*
.*# IFERR: ERROR MESSAGES FOR STRUCTURED PROGRAMMING-MACROS           *
.*#-------------------------------------------------------------------*
.FEHL01  MNOTE 8,'IFINIT MACRO NOT FIRST MACRO'
         AGO   .EREND
.FEHL02  MNOTE 8,'PRAEFIX BIGGER THAN 7 POSITIONS'
         AGO   .EREND
.FEHL03  MNOTE 8,'DEBUG NOT YES OR NO'
         AGO   .EREND
.FEHL04  MNOTE 8,'TRACE SWITCH NOT YES OR NO'
         AGO   .EREND
.FEHL05  MNOTE 8,'COMPARE CODE NOT IN BRACKETS'
         AGO   .EREND
.FEHL06  MNOTE 8,'TOO MUCH STRUCTURED MACROS IN THIS PROGRAM'
         AGO   .EREND
.FEHL07  MNOTE 8,'SHOULD NOT OCCUR'
         AGO   .EREND
.FEHL08  MNOTE 8,'TOO MUCH OPERANDS IN CONDITION'
         AGO   .EREND
.FEHL09  MNOTE 8,'NOT ENOUGH OPERANDS IN CONDITION'
         AGO   .EREND
.FEHL10  MNOTE 8,'AND/OR CONTINATION MISSING'
         AGO   .EREND
.FEHL11  MNOTE 8,'INVALID COMPARE OPERANDS'
         AGO   .EREND
.FEHL12  MNOTE 8,'FROM AND WHILE ARE EXCLUSIVE'
         AGO   .EREND
.FEHL13  MNOTE 8,'WHILE PARAMETER NOT IN BRACKETS'
         AGO   .EREND
.FEHL14  MNOTE 8,'EXCESSIVE PARAMETERS IN DO STATEMENT'
         AGO   .EREND
.FEHL15  MNOTE 8,'INVALID PARAMETER'
         AGO   .EREND
.FEHL16  MNOTE 8,'EXIT NEEDS CONDITION'
         AGO   .EREND
.FEHL17  MNOTE 8,'PARAMETER MISSING'
         AGO   .EREND
.FEHL18  MNOTE 8,'INVALID OPERAND IN DO STATEMENT'
         AGO   .EREND
.FEHL19  MNOTE 8,'DONAME NOT DEFINED'
         AGO   .EREND
.EREND   ANOP
         MEXIT
.*--------------------------------------------------------------------*
./ ADD NAME=IFGLO
.*#-------------------------------------------------------------------*
.*#     GLOBALS FOR MACROS FOR STRUCTURED PROGRAMMING                 *
.*#-------------------------------------------------------------------*
.*
         GBLC  &IFFALSE(50)    -IFGLO-     TABELLE DER FALSE IDENTIF.
         GBLC  &IFENDLB(50)    -IFGLO-     TABELLE DER ENDIF ID.
         GBLC  &DOSTART(50)    -IFGLO-     TABELLE DER START ID.
         GBLC  &DOFALSE(50)    -IFGLO-     TABELLE DER FALSE ID.
         GBLC  &DOENDLB(50)    -IFGLO-     TABELLE DER ENDDO ID.
         GBLC  &DOFROM(50)     -IFGLO-     TABELLE DER DO LOOP REG
         GBLC  &DONAME(50)     -IFGLO-     TABELLE DER DO LOOP NAMEN
.*                             -IFGLO-
         GBLC  &IFPRAEF        -IFGLO-     PRAFIX ZUR LABEL ERZEUGUNG
         GBLC  &IFTRUE         -IFGLO-     TRUE LABEL FOR AND /OR
         GBLC  &DOTRUE         -IFGLO-     TRUE LABEL FOR AND/OR
.*                             -IFGLO-
         GBLA  &IFLEVEL        -IFGLO-     NESTING LEVEL
         GBLA  &DOLEVEL        -IFGLO-     NESTING LEVEL
         GBLA  &IFLABEL        -IFGLO-     ELSE ID (COUNTS UP)
         GBLA  &IFLIMIT        -IFGLO-     ENDIF ID (COUNTS DOWN)
.*                             -IFGLO-
         GBLB  &IFINIT         -IFGLO-     INIT SWITCH
         GBLB  &IFDEBUG        -IFGLO-     DEBUG MODE
.*       SBU                   -IFGLO-
.*                             -IFGLO-
         GBLC  &MACNA          -IFGLO-     MACRO NAME
.*--------------------------------------------------------------------*
./ ADD NAME=IFPRO
         MACRO
         IFPRO &TRUE,&FALSE,&P1,&P2,&P3,&P4,&P5,&P6,&P7,&P8,&P9,&P10,  *
               &P11,&P12,&P13,&P14,&P15,&P16,&P17,&P18,&P19,&P20
.*#-------------------------------------------------------------------*
.*#  IFPRO  PROCESSES CONDITION STATEMENTS IN STUCTURED PROGRAMMING   *
.*#-------------------------------------------------------------------*
         COPY  IFGLO
         LCLC  &INST                       INSTRUCTION
         LCLC  &COND                       CONDITION CODE
         LCLC  &OPND                       WORK-FIELD
         LCLA  &I
         LCLC  &OP1
         LCLC  &OP2
         LCLC  &OP3
         LCLC  &OP4
.*--------------------------------------------------------------------*
.*       FORMAL TEST: NUMBER OF OPERANDS  AND 'AND' OR  'OR' PROCESS. *
.*--------------------------------------------------------23-09-80-RS-*
&I       SETA  2                           SKIP TRUE AND FALSE PARAM
.FOR01   ANOP
&I       SETA  &I+1
         AIF   ('&SYSLIST(&I)' EQ '').FEHL10
&I       SETA  &I+1
         AIF   ('&SYSLIST(&I)' EQ 'AND').FOR01
         AIF   ('&SYSLIST(&I)' EQ 'OR').FOR01
         AIF   ('&SYSLIST(&I)' NE '').FEHL10
.*--------------------------------------------------------------------*
.*       SCANNING OF THE OPERANDS                                     *
.*--------------------------------------------------------23-09-80-RS-*
&I       SETA  2
.BIGLOP  ANOP
&I       SETA  &I+1
         AIF   ('&SYSLIST(&I)' EQ '').MACEND
.*--------------------------------------------------------------------*
.*       WORK ON ASSEMBLE INSTRUCTIONS AND GENERATE CODE              *
.*--------------------------------------------------------23-09-80-RS-*
         AIF   ('&SYSLIST(&I)'(1,1) NE '(').FEHL05 NOT IN BRACKETS
         AIF   (N'&SYSLIST(&I) GT 5).FEHL08        TOO MUCH OPERANDS
         AIF   (N'&SYSLIST(&I) LT 4).FEHL09        TOO LESS OPERANDS
.*--------------------------------------------------------------------*
.*       ELIMINATE OP-CODE AND BRANCH CONDITION                       *
.*--------------------------------------------------------------------*
&INST    SETC  '&SYSLIST(&I,1)'                    GET OP CODE
&OP1     SETC  '&SYSLIST(&I,2)'
         AIF   (N'&SYSLIST(&I) EQ 4).OP4           OP,OP1,OP2,OP3
.*
&OP2     SETC  '&SYSLIST(&I,3)'
         AIF   ('&INST'(1,1) EQ 'C').OP5C          COMPARE INSTRUCTION
.*
&OP3     SETC  '&SYSLIST(&I,4)'
&COND    SETC  '&SYSLIST(&I,5)'
         AGO   .OP5END
.*
.OP5C    ANOP
&OP3     SETC  '&SYSLIST(&I,5)'
&COND    SETC  '&SYSLIST(&I,4)'
.*
.OP5END  ANOP
&OPND    SETC  '&OP1'.','.'&OP2'.','.'&OP3'
         AGO   .OPEND
.OP4     ANOP
         AIF   ('&INST'(1,1) EQ 'C').OP4C     COMPARE INSTRUKTION
&OP2     SETC  '&SYSLIST(&I,3)'
&COND    SETC  '&SYSLIST(&I,4)'
         AGO   .OP4END
.*
.OP4C    ANOP
&OP2     SETC  '&SYSLIST(&I,4)'
&COND    SETC  '&SYSLIST(&I,3)'
.*
.OP4END  ANOP
&OPND    SETC  '&OP1,&OP2'
.*
.OPEND   ANOP
.*--------------------------------------------------------------------*
.*       GENERATE ASSEMBLER INSTRUCTION                               *
.*--------------------------------------------------------23-09-80-RS-*
         &INST &OPND
.*--------------------------------------------------------------------*
.*       COMPUTE INVERTED CONDITION CODE                              *
.*--------------------------------------------------------23-09-80-RS-*
.ER00    ANOP
         AIF   ('&COND' NE 'H').ER01
&COND    SETC  '2'
         AGO   .ER99
.*
.ER01    ANOP
         AIF   ('&COND' NE 'EQ').ER02
&COND    SETC  '8'
         AGO   .ER99
.*
.ER02    ANOP
         AIF   ('&COND' NE 'L').ER03
&COND    SETC  '4'
         AGO   .ER99
.*
.ER03    ANOP
         AIF   ('&COND' NE 'LE').ER04
&COND    SETC  '13'
         AGO   .ER99
.*
.ER04    ANOP
         AIF   ('&COND' NE 'NH').ER05
&COND    SETC  '13'
         AGO   .ER99
.*
.ER05    ANOP
         AIF   ('&COND' NE 'NL').ER06
&COND    SETC  '11'
         AGO   .ER99
.*
.ER06    ANOP
         AIF   ('&COND' NE 'NE').ER07
&COND    SETC  '7'
         AGO   .ER99
.*
.ER07    ANOP
         AIF   ('&COND' NE 'O').ER08
&COND    SETC  '1'
         AGO   .ER99
.*
.ER08    ANOP
         AIF   ('&COND' NE 'P').ER09
&COND    SETC  '2'
         AGO   .ER99
.*
.ER09    ANOP
         AIF   ('&COND' NE 'M').ER10
&COND    SETC  '4'
         AGO   .ER99
.*
.ER10    ANOP
         AIF   ('&COND' NE 'NP').ER11
&COND    SETC  '13'
         AGO   .ER99
.*
.ER11    ANOP
         AIF   ('&COND' NE 'NM').ER12
&COND    SETC  '11'
         AGO   .ER99
.*
.ER12    ANOP
         AIF   ('&COND' NE 'Z').ER13
&COND    SETC  '8'
         AGO   .ER99
.*
.ER13    ANOP
         AIF   ('&COND' NE 'NZ').ER14
&COND    SETC  '7'
         AGO   .ER99
.*
.ER14    ANOP
         AIF   ('&COND' NE 'NO').ER15
&COND    SETC  '14'
         AGO   .ER99
.*
.ER15    ANOP
         AIF   ('&COND' NE 'E').ER16
&COND    SETC  '8'
         AGO   .ER99
.*
.ER16    ANOP
         AIF   ('&COND' NE 'GE').ER17
&COND    SETC  '11'
         AGO   .ER99
.*
.ER17    ANOP
         AIF   ('&COND' NE 'GT').ER18
&COND    SETC  '2'
         AGO   .ER99
.*
.ER18    ANOP
         AIF   ('&COND' NE 'LT').ER19
&COND    SETC  '4'
         AGO   .ER99
.*
.ER19    ANOP
         AGO   .FEHL11
.*
.ER99    ANOP
.*--------------------------------------------------------------------*
.*       GENERATE BRANCH IF NOT TRUE LABEL (FOR 'AND' OR LAST PARAM   *
.*--------------------------------------------------------23-09-80-RS-*
&I       SETA  &I+1
         AIF   ('&SYSLIST(&I)' EQ 'OR').BIGOR
&OPND    SETC  '15-&COND,&IFPRAEF&FALSE'
         BC    &OPND                       BRANCH IF NOT TRUE
         AGO   .BIGLOP
.*--------------------------------------------------------------------*
.*       GENERATE BRANCH IF NOT TRUE LABEL FOR 'OR' PROCESSING        *
.*--------------------------------------------------------23-09-80-RS-*
.BIGOR   ANOP
&OPND    SETC  '&COND,&IFPRAEF&TRUE'
         BC    &OPND                       BRANCH IF TRUE
         AGO   .BIGLOP
.*
         COPY  IFERR
.*
.MACEND  ANOP
         MEXIT
         MEND
./ ADD NAME=REGISTER
         MACRO                            ,
         REGISTER &DUMMY                  , DUMMY PARAMETER
R0       EQU   0                          , GENERAL PURPOSE REGISTER 0
R1       EQU   1                          , GENERAL PURPOSE REGISTER 1
R2       EQU   2                          , GENERAL PURPOSE REGISTER 2
R3       EQU   3                          , GENERAL PURPOSE REGISTER 3
R4       EQU   4                          , GENERAL PURPOSE REGISTER 4
R5       EQU   5                          , GENERAL PURPOSE REGISTER 5
R6       EQU   6                          , GENERAL PURPOSE REGISTER 6
R7       EQU   7                          , GENERAL PURPOSE REGISTER 7
R8       EQU   8                          , GENERAL PURPOSE REGISTER 8
R9       EQU   9                          , GENERAL PURPOSE REGISTER 9
R10      EQU   10                         , GENERAL PURPOSE REGISTER 10
R11      EQU   11                         , GENERAL PURPOSE REGISTER 11
R12      EQU   12                         , GENERAL PURPOSE REGISTER 12
R13      EQU   13                         , GENERAL PURPOSE REGISTER 13
R14      EQU   14                         , GENERAL PURPOSE REGISTER 14
R15      EQU   15                         , GENERAL PURPOSE REGISTER 15
         MEND                             , END OF MACRO
./ ADD NAME=X2CHRTAB
         MACRO
&NAME    X2CHRTAB
         GBLB  &X2CHR
         LCLC  &NAM$
         LCLB  &X2CHRL
&X2CHRL  SETB  1
         AIF   (&X2CHR).BP02
&X2CHR   SETB  1
&X2CHRL  SETB  0
.BP02    AIF   ('&NAME' EQ '').NAM1
&NAM$    SETC  '&NAME'
         AGO   .BEG
.NAM1    ANOP
&NAM$    SETC  'X2CHRTAB'
.BEG     ANOP
         ORG   *-240                    SET TABLE ORIGIN
&NAM$    DS    0CL256                   TABLE NAME
         DS    CL240                    IGNORE UNUSED VALUES
         DC    10AL1(*-&NAM$)           NUMERIC TRANSLATION VALUES
         DC    6AL1(*-&NAM$.-57)        HEX VALUE A-F TRANSLATION
         AIF   (&X2CHRL).BP03
.BP03    ANOP
         MEND
./ ADD NAME=X2CHRTRN
         MACRO
         X2CHRTRN &CFLD,&XFLD,&LEN=0,&TAB=X2CHRTAB,&PRINT=NO
         LCLA  &LXFLD,&CLEN,&XLEN,&REPS,&LREM,&DXFLD,&DCFLD
         LCLB  &X2CHRIN
&X2CHRIN SETB  1
&LXFLD   SETA  &LEN                      LENGTH OF HEX FIELD
&CLEN    SETA  15                        CHAR LENGTH
&XLEN    SETA  8                         HEX LENGTH
         AIF   (&LEN NE 0).SKIPL
&LXFLD   SETA  L'&XFLD
.SKIPL   ANOP
&REPS    SETA  (&LXFLD-1)/7              REPETITIONS REQUIRED
&LREM    SETA  &LXFLD-&REPS*7            LENGTH OF REMAONDER
         AIF   ('&PRINT' NE 'YES').LOOP
.LOOP    ANOP
         AIF   (&REPS LE 0).LAST
         UNPK  &CFLD+&DCFLD.(&CLEN),&XFLD+&DXFLD.(&XLEN)
&DCFLD   SETA  &DCFLD+14
&DXFLD   SETA  &DXFLD+7
&REPS    SETA  &REPS-1
         AGO   .LOOP
.LAST    ANOP
         AIF   (&LREM EQ 0).TR
&XLEN    SETA  &LREM
&CLEN    SETA  2*&LREM-1
         UNPK  &CFLD+&DCFLD.(&CLEN),&XFLD+&DXFLD.(&XLEN)
&DCFLD   SETA  &DCFLD+&CLEN-1
         OI    &CFLD+&DCFLD,X'F0'
&DXFLD   SETA  &DXFLD+&XLEN-1
&DCFLD   SETA  &DCFLD+1
         MVC   &CFLD+&DCFLD.(1),&XFLD+&DXFLD
         OI    &CFLD+&DCFLD,X'F0'
.TR      ANOP
&CLEN    SETA  2*&LXFLD
         TR    &CFLD.(&CLEN),&TAB
         AIF   ('&PRINT' NE 'YES').BP06
.BP06    ANOP
         MEND
##
//
