/* -order %ABSENT
          %DAY
          %FIT
          %HHMMSS
          %LEVEL
          %MMDDYY
          %MONTH
          %PAGENUMBER
          %PRESENT
          %REPEAT
          %ROMAN
          %SUBSTR
          %YYDDD
          (
          )
          *
          +
          ,
          -
          ->
          /
          :=
          ;
          ALIGN
          AND
          ASCENDING
          ATTACH
          BEGIN
          BEGINS
          DECIMAL
          BREAK
          CENTER
          CHARACTER
          COLUMN
          CONCATENATE
          CONTAIN
          CONTAINS
          DECLARE
          DECLARE_1
          DEFAULT
          DEFINE_1
          DELIMITED
          DESCENDING
          DETAIL
          DETAILFOOT
          DETAILHEAD
          DUPLICATE
          EDIT
          END
          ENDS
          EQ
          FALSE
          FILE
          FILL
          FIT
          BOOLEAN
                    FLOAT_unused
          FOLD
          GE
          GT
          HOLD
          IF
          IN
          INPUT
          PAUSE
          KEY
          LE
          LEFT
          LET
          LINE
          LT
          MAXLINE
          MINLINE
          NE
          NO
          NOT
          NUMBER
          ON
          OPTIONAL
          OR
          PAGEFOOT
          PAGEHEAD
          PAGELENGTH
          PAGEWIDTH
          PARAMETER
          PICTURE
          POSITION
          PRINT
          RECORD
          REPORT
          REPORTFOOT
          REPORTHEAD
          RETURNS
          RIGHT
          SORT
          STREAM
          SWITCH
          TABLE
          TRANSFORM
          TRUE
          VARYING
          WORD
          <identifier>
          <number>
          <quoted_str>
          ,2
          ,3
          ,4
          BSP
          SPECIAL
          STOP
          SKIP
          SET
          THEN
          ELSE
          FI
          FI;
-sem mrpg_sem_.incl.pl1
-table mrpg_tables_
-recover RECOVERY_TOKEN ;
-tl
-parse */
dcl  partl(7) fixed bin;
dcl partno fixed bin;
dcl  report_sw bit(1);
dcl (T_01ptr,T_02ptr) ptr;
dcl  beginptr ptr;
dcl depth fixed bin;
dcl  hold_ct fixed bin;
dcl  stmtlistptr ptr;
dcl  elselistptr (10)ptr;
dcl if_nest fixed bin;
dcl  begin_ct fixed bin;
dcl set_type fixed bin;
dcl 1     hold_list like tree.table;
dcl 1     sort_list like tree.table;
dcl 1     stmt_list like tree.table;
semantics:          proc(rulen,altn);

dcl       rulen     fixed bin(24),      /* rule number being applied */
          altn      fixed bin(24);      /* alternate number */

          goto rule(rulen);

dcl       bch       fixed bin(24);
dcl       tptr      ptr;
dcl       ki        fixed bin(17);
dcl       li        fixed bin(24);
dcl       ch2       char(2);

dcl 1     param_list like tree.table;
dcl class fixed bin;
dcl keyword bit(1);
dcl  lstop_line fixed bin;
dcl  dflt_ptr ptr;


/* <language>          ::= <input...> END ;  ! */
rule(0001):
          if (if_nest > 0)
          then call mrpg_error_(2,(lstk.line(ls_top)),"END reached with ^i unterminated IFs.",if_nest);
          if (ifi < ife)
          then do;
               call mrpg_error_ (1,(linenumber), "Text follows END statment.");
               ifi = ife+1;
          end;
          if (exec.b = exec.e)
          then do;
               stmtptr = exec.b;
               stmtptr = stmt.ref3.e;
               if (stmt.type = "HD")
               | (stmt.type = "SR")
               | (stmt.type = "SU")
               then stmt.type = "NT";
          end;
          return;

/* <input...>          ::= <input> | <input...> <input> ! */
/* <input>             ::= <dcl_parm>
            | <dcl_input>
            | <dcl>
            | <report>
            | <phase> ! */









/* <parm_key>          ::= DECLARE_1 PARAMETER  ! */
rule(0004):
          paptr, dflt_ptr = null();
          keyword = "0"b;
          if (pkey_ct ^= 0)
          | (ppos_ct ^= 0)
          then call mrpg_error_ (2,(lstk.line(ls_top-1)),"Only 1 PARAMETER declaration allowed.");
          return;

/* <dcl_parm>          ::= <parm_key> <parm...> , <stop...> ;  ! */
rule(0005):
          call link_list(parm_check,lstk.node_ptr(ls_top-1)->a_list);
          return;

/* <dcl_parm>          ::= <parm_key> <parm...> ;  ! */

/* <parm...>           ::= <parm>  ! */;
rule(0007):

/* <parm...>           ::= <parm...> <parm>  ! */
rule(0008):
          paptr, dflt_ptr = null();
          keyword = "0"b;
          return;


/* <parm>              ::= ,2 <identifier> <parm_spec...>  ! */
rule(0009):
          if (paptr = null())
          then do;
               call mrpg_error_ (2,(lstk.line(ls_top -1)),"Missing data-type");
               return;
          end;
          if (param.kind = Bool) & ^keyword
          then do;
               call mrpg_error_ (2,(lstk.line(ls_top-1)),"Missing keyword specification on Boolean parameter");
          end;
          if (dflt_ptr ^= null) & (param.leng = 0)
          then do;
               if (dflt_ptr->symref.type ^= "SY")
               then do;
                    call mrpg_error_ (2,(lstk.line(ls_top-2)),"Default cannot be an expression on CHAR(*) parameter");
               end;
          end;
          param.line = lstk.line(ls_top-1);
          param.sym = lstk.node_ptr(ls_top-1);
          call use_def(paptr);
          if keyword
          then do;
               call link(parm_key,paptr);
               pkey_ct = pkey_ct + 1;
          end;
          else do;
               call link(parm_pos,paptr);
               ppos_ct = ppos_ct + 1;
          end;
          if dmp_sw then call mrpg_dump_$all((paptr),0);
          return;


/* <parm_spec...>      ::= <parm_spec>  ! */;
/* <parm_spec...>      ::= <parm_spec...> <parm_spec>  ! */

/* <parm_spec>         ::= CHARACTER ( * )  ! */
rule(0012):
          bch = ls_top-3;
          ki = Char;
          li = 0;
          goto parm_spec;

/* <parm_spec>         ::= CHARACTER ( <number> )  ! */
rule(0013):
          bch = ls_top-3;
          ki = Char;
          li = lstk.val(ls_top-1);
          goto parm_spec;

/* <parm_spec>         ::= BOOLEAN  ! */
rule(0014):
          bch = ls_top;
          ki = Bool;
          li = -1;
parm_spec:
          call aloc_param(bch);
          if (param.kind ^= 0)
          then do;
               call mrpg_error_ (2,(lstk.line(ls_top)),"Multiple data-type");
               goto end_parm;
          end;
          param.kind = ki;
          param.leng = li;
          param.echar = lstk(ls_top).echar;
          lstk.node_ptr(bch) = paptr;
          if (ki = Bool)
          then do;
               call st_search("""0""b",tptr,"ST",0,0);
               call aloc_attr(ls_top-1);
               attr.type = "DV";
               attr.sym = tptr;
               call link(param.attr,atptr);
               param.echar = lstk.echar(ls_top);
               dflt_ptr = attr.sym;
          end;
          goto end_parm;


/* <parm_spec>         ::= DEFAULT <cexp>  ! */;
rule(0015):
          call aloc_param(ls_top-1);
          call aloc_attr(ls_top-1);
          attr.type = "DV";
          attr.sym = lstk.node_ptr(ls_top);
          call link(param.attr,atptr);
          param.echar = lstk.echar(ls_top);
          dflt_ptr = attr.sym;
          goto end_parm;

/* <parm_spec>         ::= KEY ( <keyword , ...> )  ! */

/* <keyword , ...>     ::= <keyword>  ! */;
/* <keyword , ...>     ::= <keyword , ...> , <keyword>  ! */

/* <keyword>           ::= <quoted_str>  ! */
rule(0019):
          srefptr = lstk.node_ptr(ls_top);
          if (substr(symref.sym->symtab.data,2,1) ^= "-")
          then do;
               call mrpg_error_ (2,(lstk.line(ls_top)),"Keyword ^a does not begin with ""-""",symref.sym->symtab.data);
               goto end_parm;
          end;
          call aloc_param(ls_top);
          call aloc_attr(ls_top);
          attr.type = "KY";
          attr.sym = srefptr;
          call link(param.attr,atptr);
          param.echar = lstk.echar(ls_top);
          keyword = "1"b;
end_parm:
          return;

/* <parm_spec>         ::= <stop>  ! */
rule(0020):
          if (paptr = null())
          then do;
               call mrpg_error_ (2,(lstk.line(ls_top)),"No data-type specified.");
               return;
          end;
          call link_list(param.check,lstk.node_ptr(ls_top)->a_list);
          return;


/* <input_key>         ::= DECLARE_1 INPUT ! */
rule(0021):
          daptr = null();
          if (tree.input.b ^= null())
          then call mrpg_error_ (2,(lstk.line(ls_top-1)),"Only 1 INPUT declaration allowed.");
          return;

/* <dcl_input>         ::= <input_key> <[input_ctl...]>
                                        <ifld...> <[skip_stop...]> ; ! */

/* <[skip_stop...]>    ::= <skip_stop...> | ! */
/* <skip_stop...>      ::= <skip_stop> ! */;
/* <skip_stop...>      ::= <skip_stop...> <skip_stop> ! */
/* <skip_stop>         ::= , <skip> ! */;
/* <skip_stop>         ::= , <stop> ! */

/* <[input_ctl...]>    ::= <input_ctl...> ! */;;
/* <[input_ctl...]>    ::= ! */

/* <input_ctl...>      ::= <input_ctl>  ! */;
/* <input_ctl...>      ::= <input_ctl...> <input_ctl>  ! */

/* <ifld...>           ::= <ifld> ! */;
/* <ifld...>           ::= <ifld...> <ifld> ! */
/* <input_ctl>         ::= RECORD <number>  ! */;
rule(0034):
          tree.res_siz = lstk.val(ls_top);
          tree.rec_str = -1;
          return;

/* <input_ctl>         ::= STREAM <number>  ! */;
rule(0035):
          tree.res_siz = lstk.val(ls_top);
          tree.rec_str = -2;
          return;

/* <input_ctl>         ::= RECORD ! */;
rule(0036):
          tree.rec_str = -1;
          return;

/* <input_ctl>         ::= STREAM  ! */
rule(0037):
          tree.rec_str = -2;
          return;


/* <input_ctl>         ::= FILE <cexp>  ! */;
rule(0038):
          symbol_leng = 9;
          allocate symtab in (space);
          symtab.type = "ST";
          symtab.use.b, symtab.use.e = null();
          symtab.data = """vfile_ """;
          call aloc_opn(Cat,ls_top-1);
          opn.kind = Char;
          opn.op1 = symtabptr;
          opn.op2 = lstk.node_ptr(ls_top);
          call aloc_value("VL",ls_top-1);
          value.sym = opptr;
          value.numb = 0;
          tree.from = valptr;
          return;

/* <input_ctl>         ::= ATTACH <cexp>  ! */
rule(0039):
          call aloc_value("VL",ls_top-1);
          value.sym = lstk.node_ptr(ls_top);
          tree.from = valptr;
          return;

/* <stop...>           ::= <stop>  ! */;
/* <skip...>           ::= <skip>  ! */;
/* <stop...>           ::= <stop...> <stop>  ! */
rule(0042):
/* <skip...>           ::= <skip...> <skip>  ! */
rule(0043):
          call link_list(lstk.node_ptr(ls_top-1)->a_list,lstk.node_ptr(ls_top)->a_list);
          return;

dcl 1 a_list based like tree.table;

/* <skip>              ::= IF ( <expr> ) SKIP ( <expr> ) ! */
rule(0044):
         call mrpg_error_(2,(lstk.line(ls_top-3)),"SKIP not implemented.");
          call make_bool(ls_top-5);
          call make_char(ls_top-1);
          call aloc_opn(Skip,ls_top-7);
          opn.op1 = lstk.node_ptr(ls_top-5);
          opn.op2 = lstk.node_ptr(ls_top-1);
          call aloc_head;
          call link(head.list,opptr);
          lstk.node_ptr(ls_top-7) = headptr;
          return;

/* <stop>              ::= IF ( <expr> ) STOP ( <expr> ) ! */
rule(0045):
         call mrpg_error_(2,(lstk.line(ls_top-3)),"STOP not implemented.");
          call make_bool(ls_top-5);
          call make_char(ls_top-1);
          call aloc_opn(Stop,ls_top-7);
          opn.op1 = lstk.node_ptr(ls_top-5);
          opn.op2 = lstk.node_ptr(ls_top-1);
          call aloc_head;
          call link(head.list,opptr);
          lstk.node_ptr(ls_top-7) = headptr;
          return;


/* <ifld>              ::= ,2 <identifier> <idcl_spec> <skip...>  ! */;
rule(0046):
/* <ifld>              ::= ,2 <identifier> <idcl_spec> <stop...>  ! */;
rule(0047):
          call link_list(datum.check,lstk.node_ptr(ls_top)->a_list);
          lstop_line = ls_top - 2;
          goto ifld_com;

/* <ifld>              ::= ,2 <identifier> <idcl_spec> <skip...> <stop...>  ! */;
rule(0048):
          call link_list(lstk.node_ptr(ls_top-1)->a_list,lstk.node_ptr(ls_top)->a_list);
          call link_list(datum.check,lstk.node_ptr(ls_top-1)->a_list);
          lstop_line = ls_top - 3;
          goto ifld_com;

/* <ifld>              ::= ,2 <identifier> <idcl_spec>  ! */
rule(0049):
          lstop_line = ls_top - 1;
ifld_com:
          if (daptr = null())
          then do;
               call mrpg_error_ (2,(lstk.line(lstop_line)),"Missing data-type");
               return;
          end;
          datum.sym = lstk.node_ptr(lstop_line);
indcl:
          datum.type = "IN";
          datum.line = lstk.line(lstop_line);
          if (datum.sym ^= null())
          then call use_def(daptr);
          call link(tree.input,daptr);
          daptr = null();
          return;

/* <idcl_spec>         ::= CHARACTER ( <number> ) POSITION <number>  ! */;
rule(0050):
          call aloc_datum;
          datum.pos = lstk.val(ls_top);
          datum.kind = Char;
          datum.leng = lstk.val(ls_top-3);
          return;

/* <idcl_spec>         ::= CHARACTER ( <number> )  ! */;
rule(0051):
          call aloc_datum;
          datum.kind = Char;
          datum.leng = lstk.val(ls_top-1);
          return;

/* <idcl_spec>         ::= CHARACTER ( <number> ) OPTIONAL  ! */
rule(0052):
          call aloc_datum;
          datum.kind = Char;
          datum.leng = -lstk.val(ls_top-2);
          return;

/* <idcl_spec>         ::= CHARACTER ( <number> ) DELIMITED <quoted_str>  ! */;
rule(0053):
          call aloc_datum;
          datum.kind = Chard;
          datum.leng = lstk.val(ls_top-3);
          call link(datum.datal, lstk.node_ptr(ls_top));
          return;

/* <idcl_spec>         ::= CHARACTER ( <number> ) DELIMITED <quoted_str> OPTIONAL  ! */
rule(0054):
          call aloc_datum;
          datum.kind = Chard;
          datum.leng = -lstk.val(ls_top-4);
          call link(datum.datal, lstk.node_ptr(ls_top-1));
          return;

/* <idcl_spec>         ::= CHARACTER ( <number> ) SPECIAL  ! */;
rule(0055):
          call aloc_datum;
          datum.kind = Charn;
          datum.leng = lstk.val(ls_top-2);
          return;

/* <idcl_spec>         ::= CHARACTER ( <number> ) SPECIAL OPTIONAL  ! */
rule(0056):
          call aloc_datum;
          datum.kind = Charn;
          datum.leng = -lstk.val(ls_top-3);
          return;

/* <idcl_spec>         ::= CHARACTER ( <number> ) OPTIONAL POSITION <number>  ! */
rule(0057):
          call aloc_datum;
          datum.kind = Char;
          datum.leng = -lstk.val(ls_top-4);
          datum.pos = lstk.val(ls_top);
          return;

/* <idcl_spec>         ::= CHARACTER ( <number> ) DELIMITED <quoted_str> POSITION <number>  ! */;
rule(0058):
          call aloc_datum;
          datum.kind = Chard;
          datum.leng = lstk.val(ls_top-5);
          call link(datum.datal, lstk.node_ptr(ls_top-2));
          datum.pos = lstk.val(ls_top);
          return;

/* <idcl_spec>         ::= CHARACTER ( <number> ) DELIMITED <quoted_str> OPTIONAL POSITION <number>  ! */
rule(0059):
          call aloc_datum;
          datum.kind = Chard;
          datum.leng = -lstk.val(ls_top-6);
          call link(datum.datal, lstk.node_ptr(ls_top-3));
          datum.pos = lstk.val(ls_top);
          return;

/* <idcl_spec>         ::= CHARACTER ( <number> ) SPECIAL POSITION <number>  ! */;
rule(0060):
          call aloc_datum;
          datum.kind = Charn;
          datum.leng = lstk.val(ls_top-4);
          datum.pos = lstk.val(ls_top);
          return;

/* <idcl_spec>         ::= CHARACTER ( <number> ) SPECIAL OPTIONAL POSITION <number>  ! */
rule(0061):
          call aloc_datum;
          datum.kind = Charn;
          datum.leng = -lstk.val(ls_top-5);
          datum.pos = lstk.val(ls_top);
          return;

/* <idcl_spec>         ::= DECIMAL ( <number> ) POSITION <number>  ! */;
rule(0062):
          call aloc_datum;
          datum.pos = lstk.val(ls_top);
          datum.kind = Decimal;
          datum.leng = lstk.val(ls_top-3);
          return;

/* <idcl_spec>         ::= DECIMAL ( <number> )  ! */;
rule(0063):
          call aloc_datum;
          datum.kind = Decimal;
          datum.leng = lstk.val(ls_top-1);
          return;

/* <idcl_spec>         ::= DECIMAL ( <number> ) OPTIONAL  ! */
rule(0064):
          call aloc_datum;
          datum.kind = Decimal;
          datum.leng = -lstk.val(ls_top-2);
          return;

/* <idcl_spec>         ::= DECIMAL SPECIAL  ! */;
rule(0065):
          call aloc_datum;
          datum.kind = DecSpec;
          datum.leng = 0;
          return;

/* <idcl_spec>         ::= DECIMAL SPECIAL OPTIONAL  ! */
rule(0066):
          call aloc_datum;
          datum.kind = DecSpec;
          datum.leng = -1;
          return;

/* <idcl_spec>         ::= DECIMAL ( <number> ) OPTIONAL POSITION <number>  ! */
rule(0067):
          call aloc_datum;
          datum.kind = Decimal;
          datum.leng = -lstk.val(ls_top-4);
          datum.pos = lstk.val(ls_top);
          return;

/* <idcl_spec>         ::= DECIMAL SPECIAL POSITION <number>  ! */;
rule(0068):
          call aloc_datum;
          datum.kind = DecSpec;
          datum.leng = 0;
          datum.pos = lstk.val(ls_top);
          return;

/* <idcl_spec>         ::= DECIMAL SPECIAL OPTIONAL POSITION <number>  ! */
rule(0069):
          call aloc_datum;
          datum.kind = DecSpec;
          datum.leng = -1;
          datum.pos = lstk.val(ls_top);
          return;

/* <idcl_spec>         ::= DECIMAL DELIMITED <quoted_str>  ! */;
rule(0070):
          call aloc_datum;
          datum.kind = Decimal;
          call link(datum.datal, lstk.node_ptr(ls_top));
          return;

/* <idcl_spec>         ::= DECIMAL DELIMITED <quoted_str> OPTIONAL  ! */
rule(0071):
          call aloc_datum;
          datum.kind = Decimal;
          datum.leng = -1;
          call link(datum.datal, lstk.node_ptr(ls_top-1));
          return;

/* <idcl_spec>         ::= DECIMAL DELIMITED <quoted_str> POSITION <number>  ! */;
rule(0072):
          call aloc_datum;
          datum.kind = Decimal;
          call link(datum.datal, lstk.node_ptr(ls_top-2));
          datum.pos = lstk.val(ls_top);
          return;

/* <idcl_spec>         ::= DECIMAL DELIMITED <quoted_str> OPTIONAL POSITION <number>  ! */
rule(0073):
          call aloc_datum;
          datum.kind = Decimal;
          datum.leng = -1;
          call link(datum.datal, lstk.node_ptr(ls_top-3));
          datum.pos = lstk.val(ls_top);
          return;

/* <ifld>              ::= ,2 FILL ( <number> )  ! */;
rule(0074):
          call aloc_datum;
          datum.kind = Fill;
          datum.leng = lstk.val(ls_top-1);
          datum.sym = null();
          lstop_line = ls_top - 3;
          goto indcl;


/* <dcl_key>           ::= DECLARE ! */
rule(0075):
          call aloc_datum;
          datum.type = "DC";
          return;

/* <dcl>               ::= <dcl_key> <identifier> <dcl_spec> ;  ! */
rule(0076):
          datum.sym = lstk.node_ptr(ls_top-2);
          datum.line = lstk.line(ls_top-2);
          call use_def(daptr);
          call link(tree.local,daptr);
          daptr = null();
          return;


/* <dcl_spec>          ::= DECIMAL  ! */;
rule(0077):
          datum.kind = Decimal;
          datum.echar = lstk.echar(ls_top);
          return;

/* <dcl_spec>          ::= CHARACTER ( <number> )  ! */
rule(0078):
          datum.kind = Char;
          datum.leng = lstk.val(ls_top-1);
          datum.echar = lstk.echar(ls_top);
          return;

/* <dcl_spec>          ::= CHARACTER ( <number> ) VARYING  ! */;
rule(0079):
          datum.kind = Charn;
          datum.leng = lstk.val(ls_top-2);
          datum.echar = lstk.echar(ls_top);
          return;

/* <dcl_spec>          ::= BOOLEAN  ! */;
rule(0080):
          datum.kind = Bool;
          datum.echar = lstk.echar(ls_top);
          return;

/* <dcl_spec>          ::= SET ( <set> ) ! */;
rule(0081):
          datum.kind = Set;
          return;

/* <dcl_spec>          ::= TABLE ( <init> )  ! */;
rule(0082):
          if (datum.kind = 0)
          then datum.kind = Table;
          return;

/* <dcl_spec>          ::= TABLE ( <init> ) VARYING  ! */
rule(0083):
          if (datum.kind = 0)
          then datum.kind = Tablev;
          return;

/* <init>              ::= <initaa...>  ! */

/* <initaa...>         ::= <initaa>  ! */;
/* <initaa...>         ::= <initaa...>  <initaa>  ! */

/* <initaa>            ::= <number> -> <number>  ! */
rule(0087):
          opptr = datum.datal.b;
          if (opptr ^= null())
          then if (opn.op ^= n_n)
               then do;
                    call mrpg_error_ (2,(lstk.line(ls_top-2)),"Table cannot have mixed conversions.");
                    return;
               end;

          call aloc_opn(n_n,ls_top-2);
          opn.kind = Decimal;
          opn.op1 = lstk.node_ptr(ls_top-2);
          opn.op2 = lstk.node_ptr(ls_top);
          call link(datum.datal,opptr);
          return;


/* <init>              ::= <inital...>  ! */

/* <inital...>         ::= <inital>  ! */;
/* <inital...>         ::= <inital...>  <inital>  ! */

/* <inital>            ::= <number> -> <quoted_str>  ! */
rule(0091):
          opptr = datum.datal.b;
          if (opptr ^= null())
          then if (opn.op ^= n_s)
               then do;
                    call mrpg_error_ (2,(lstk.line(ls_top-2)),"Table cannot have mixed conversions.");
                    return;
               end;
          call aloc_opn(n_s,ls_top-2);
          opn.kind = Char;
          opn.op1 = lstk.node_ptr(ls_top-2);
          opn.op2 = lstk.node_ptr(ls_top);
          call link(datum.datal,opptr);
          return;

/* <init>              ::= <initla...>  ! */

/* <initla...>         ::= <initla>  ! */;
/* <initla...>         ::= <initla...>  <initla>  ! */

/* <initla>            ::= <quoted_str> -> <number>  ! */
rule(0095):
          opptr = datum.datal.b;
          if (opptr ^= null())
          then if (opn.op ^= s_n)
               then do;
                    call mrpg_error_ (2,(lstk.line(ls_top-2)),"Table cannot have mixed conversions.");
                    return;
               end;
          call aloc_opn(s_n,ls_top-2);
          opn.kind = Decimal;
          opn.op1 = lstk.node_ptr(ls_top-2);
          opn.op2 = lstk.node_ptr(ls_top);
          call link(datum.datal,opptr);
          return;


/* <init>              ::= <initll...>  ! */

/* <initll...>         ::= <initll>  ! */;
/* <initll...>         ::= <initll...>  <initll>  ! */

/* <initll>            ::= <quoted_str> -> <quoted_str>  ! */
rule(0099):
          opptr = datum.datal.b;
          if (opptr ^= null())
          then if (opn.op ^= s_s)
               then do;
                    call mrpg_error_ (2,(lstk.line(ls_top-2)),"Table cannot have mixed conversions.");
                    return;
               end;
          call aloc_opn(s_s,ls_top-2);
          opn.kind = Char;
          opn.op1 = lstk.node_ptr(ls_top-2);
          opn.op2 = lstk.node_ptr(ls_top);
          call link(datum.datal,opptr);
          return;

/* <rep_key>           ::= DEFINE_1 REPORT <identifier> ! */
rule(0100):
          allocate report in (space);
          report.type = "RP";
          report.onlist.b, report.onlist.e = null();
          report.brlist.b, report.brlist.e = null();
          report.part.b, report.part.e = null();
          report.line = lstk.line(ls_top-1);
          report.sym = lstk.node_ptr(ls_top);
          report.minl = -1;
          report.maxl = -1;
          partl = 0;
          report.pw = 65;
          report.pl = 66;
          hold_list.b, hold_list.e = null();
          call use_def(repptr);
          return;



/* <report>            ::= <rep_key>
                    <[report_ctl...]>
                    <[heading...]>
                    <detail...>   
                    <[footing...]>
                    ;  ! */
rule(0101):
          if (report.maxl = -1)
          then report.maxl = report.pl;
          if (report.minl = -1)
          then report.minl = min(1,report.pl);
          if (report.minl > report.maxl)
          then call mrpg_error_ (2,(lstk.line (ls_top-5)), "Effective MINLINE > effective MAXLINE.");
          report.echar = lstk.echar(ls_top);
          call link(tree.report,repptr);
          if (report.onlist.b = null())
          then do;
               call st_search("""user_output""",tptr,"ST",0,0);
               call aloc_value("SW",ls_top-5);
               value.sym = tptr;
               call linkr(report.onlist,valptr);
          end;
          repptr = null();
          return;


/* <[report_ctl...]>   ::= <report_ctl...>  ! */;
/* <[report_ctl...]>   ::= ! */

/* <report_ctl...>     ::= <report_ctl>  ! */;
/* <report_ctl...>     ::= <report_ctl...> <report_ctl>  ! */

/* <report_ctl>        ::= PAGEWIDTH <number>  ! */;
rule(0106):
          report.pw = lstk.val(ls_top);
          return;

/* <report_ctl>        ::= PAGELENGTH <number>  ! */;
rule(0107):
          report.pl = lstk.val(ls_top);           /* pagelength 0 means unpaged report */
          return;

/* <report_ctl>        ::= MINLINE <number>  ! */;
rule(0108):
          report.minl = lstk.val(ls_top);
          return;

/* <report_ctl>        ::= MAXLINE <number>  ! */;
rule(0109):
          report.maxl = lstk.val(ls_top);
          return;

/* <report_ctl>        ::= BREAK ( <identifier , ...> )  ! */;
rule(0110):
          report.brlist = hold_list;
          hold_list.b, hold_list.e = null();
          return;

/* <report_ctl>        ::= ON <output_sel>  ! */;
rule(0111):
          call linkr(report.onlist,lstk.node_ptr(ls_top));
          return;

/* <report_ctl>        ::= ON ( <output_sel_OR> )  ! */

/* <output_sel_OR>     ::= <output_sel>  ! */;
rule(0113):
          call linkr(report.onlist,lstk.node_ptr(ls_top));
          return;

/* <output_sel_OR>     ::= <output_sel>  IF ( <expr> ) OR <output_sel_OR>  ! */
rule(0114):
          call make_bool(ls_top-3);
          valptr = lstk.node_ptr(ls_top - 6);
          value.ctl = lstk.node_ptr (ls_top-3);
          call linkr(report.onlist,valptr);
          lstk.node_ptr (ls_top-6) = lstk.node_ptr(ls_top);
          return;

/* <output_sel>        ::= FILE <cexp>  ! */;
rule(0115):
          call aloc_value("FL",ls_top-1);
          value.sym = lstk.node_ptr(ls_top);
          lstk.node_ptr (ls_top - 1) = valptr;
          return;

/* <output_sel>        ::= FILE <cexp> NUMBER <number>  ! */;
rule(0116):
         call mrpg_error_(2,(lstk.line(ls_top-1)),"FILE...NUMBER not implemented.");
          call aloc_value("FL",ls_top-3);
          value.sym = lstk.node_ptr(ls_top-2);
          value.numb = lstk.val(ls_top);
          lstk.node_ptr (ls_top - 3) = valptr;
          return;

/* <output_sel>        ::= SWITCH <cexp>  ! */
rule(0117):
          call aloc_value("SW",ls_top-1);
          value.sym = lstk.node_ptr(ls_top);
          lstk.node_ptr (ls_top - 1) = valptr;
          return;


/* <[heading...]>      ::= <heading...>  ! */;
/* <[heading...]>      ::=  ! */

/* <heading...>        ::= <heading>  ! */;
/* <heading...>        ::= <heading...> <heading>  ! */

/* <heading>           ::= ,2 <reporthead_key> <lines...>  ! */;
/* <heading>           ::= ,2 <pagehead_key> <lines...>  ! */;
/* <reporthead_key>    ::= REPORTHEAD ! */
rule(0124):
          ch2 = "RH";
          partno = 1;
          goto part_common;

/* <pagehead_key>      ::= PAGEHEAD ! */
rule(0125):
          ch2 = "PH";
          partno = 2;
          goto part_common;

/* <detailhead_key>    ::= DETAILHEAD ! */
rule(0126):
          if (report.brlist.b = null())
          then do;
               call mrpg_error_ (2,(lstk(ls_top).line), "No break fields specified in this report.");
               return;
          end;
          ch2 = "DH";
          partno = 3;
          goto part_common;

/* <detail_key>        ::= DETAIL ! */
rule(0127):
          ch2 = "DT";
          partno = 4;
          goto part_common;

/* <detailfoot_key>    ::= DETAILFOOT ! */
rule(0128):
          if (report.brlist.b = null())
          then do;
               call mrpg_error_ (2,(lstk(ls_top).line), "No break fields specified in this report.");
               return;
          end;
          ch2 = "DF";
          partno = 5;
          goto part_common;

/* <pagefoot_key>      ::= PAGEFOOT ! */
rule(0129):
          ch2 = "PF";
          partno = 6;
          goto part_common;

/* <reportfoot_key>    ::= REPORTFOOT ! */
rule(0130):
          ch2 = "RF";
          partno = 7;
part_common:
          allocate part in (space);
          part.type = ch2;
          part.ctl = null();
          part.maxl = 0;
          part.lines.b, part.lines.e = null();
          part.sym = null();
          call link(report.part,partptr);
          return;

/* <heading>           ::= ,2 <detailhead_key> <identifier> <detail_body>  ! */
rule(0131):
/* <footing>           ::= ,2 <detailfoot_key> <identifier> <detail_body>  ! */;
rule(0132):
          part.sym = lstk.node_ptr(ls_top-1);
          call use_ref((part.sym));
          if (break_number (lstk.node_ptr (ls_top-1)) = 0)
          then call mrpg_error_ (2,(lstk.line (ls_top-1)), "Identifier ""^a"" is not a break field in this report",pull_name(ls_top-1));
          return;


/* <detail...>         ::= <detail>  ! */;
/* <detail...>         ::= <detail...> <detail>  ! */

/* <detail>            ::= ,2 <detail_key> <identifier> <detail_body>  ! */
rule(0135):
          part.sym = lstk.node_ptr(ls_top-1);
          part.line = lstk.line(ls_top-1);
          call use_def(partptr);
          return;

/* <detail>            ::= ,2 <detail_key> <identifier>  ! */
rule(0136):
          part.sym = lstk.node_ptr(ls_top);
          part.line = lstk.line(ls_top);
          call use_def(partptr);
          return;


/* <detail_body>       ::= <lines...>
                              | <detail_ctl...> <lines...> ! */



/* <detail_ctl...>     ::= <detail_ctl>  ! */;
/* <detail_ctl...>     ::= <detail_ctl...> <detail_ctl>  ! */

/* <detail_ctl>        ::= <if_ctl>  ! */
/* <if_ctl>            ::= IF ( <expr> )  ! */
rule(0141):
          part.ctl = lstk(ls_top-1).node_ptr;
          return;

/* <detail_ctl>        ::= MAXLINE <number>  ! */;
rule(0142):
          part.maxl = lstk(ls_top).val;
          return;

/* <detail_ctl>        ::= FIT  ! */
rule(0143):
         call mrpg_error_(2,(lstk.line(ls_top)),"FIT not implemented.");
          return;


/* <[footing...]>      ::= <footing...>  ! */;
/* <[footing...]>      ::=  ! */

/* <footing...>        ::= <footing>  ! */;
/* <footing...>        ::= <footing...> <footing>  ! */

/* <footing>           ::= ,2 <pagefoot_key> <lines...>  ! */;
/* <footing>           ::= ,2 <reportfoot_key> <lines...>  ! */

/* <lines...>          ::= <line>  ! */;
/* <lines...>          ::= <lines...> <line>  ! */

/* <line_key>          ::= LINE ! */
rule(0152):
          allocate lines in (space);
          lines.type = "LN";
          lines.ctl = null();
          lines.field.b, lines.field.e = null();
          lines.number = 1;
          call link(part.lines,linptr);
          return;

/* <line>              ::= ,3 <line_key> <[line_ctl]> <[field...]>  ! */
rule(0153):
          partl (partno) = partl (partno) + 1;
          if (partno = 2)
          then do;
               if (partl(2) = 1)
               then do;
                    if (lines.number > 0)
                    then do;
                         call mrpg_error_ (2,(lstk.line(ls_top-2)), "First PAGEHEAD must have absolute line number.");
                         return;
                    end;
               end;
               return;
          end;
          if (partno = 6)
          then do;
               if (partl(6) = 1)
               then do;
                    if (lines.number > 0)
                    then do;
                         call mrpg_error_ (2,(lstk.line(ls_top-2)), "First PAGEFOOT must have absolute line number.");
                         return;
                    end;
                    if (report.maxl = -1)
                    then report.maxl = -lines.number - 1;
                    else if (-lines.number < report.maxl)
                    then call mrpg_error_(2,(lstk.line(ls_top-2)),"Page footing starts above MAXLINE.");
               end;
               return;
          end;
          return;


/* <[line_ctl]>        ::= <line_ctl>  ! */;
/* <[line_ctl]>        ::=  ! */

/* <line_ctl>          ::=   <number> IF ( <expr> )  ! */
rule(0156):
          call make_bool(ls_top-1);
          lines.number = -lstk.val(ls_top-4);
          lines.ctl = lstk.node_ptr(ls_top-1);
          goto check_absolute;

/* <line_ctl>          ::= + <number> IF ( <expr> )  ! */
rule(0157):
          call make_bool(ls_top-1);
          lines.number = lstk.val(ls_top-4);
          lines.ctl = lstk.node_ptr(ls_top-1);
          return;

/* <line_ctl>          ::=   <number>  ! */;
rule(0158):
          lines.number = -lstk.val(ls_top);
check_absolute:
          if (-lines.number > report.pl)
          then do;
               call mrpg_error_ (2,(lstk.line(ls_top)), "Absolute line number beyond end-of-page.");
          end;
          return;

/* <line_ctl>          ::= + <number>  ! */;
rule(0159):
          lines.number = lstk.val(ls_top);
          return;

/* <line_ctl>          ::=            IF ( <expr> )  ! */
rule(0160):
          call make_bool(ls_top-1);
          lines.ctl = lstk.node_ptr(ls_top-1);
          return;

/* <line_ctl>          ::= PAUSE IF ( <expr> ) ! */;
rule(0161):
          call make_bool(ls_top-1);
          lines.ctl = lstk.node_ptr(ls_top-1);
/* <line_ctl>          ::= PAUSE  ! */
rule(0162):
          lines.number = 0;
/*        lines.pause = "1"b; */
          return;


/* <[field...]>        ::= <field...>  ! */;
/* <[field...]>        ::= ! */

/* <field...>          ::= <field>  ! */;
/* <field...>          ::= <field...> <field>  ! */

/* <,4>                ::= ,4 ! */
rule(0167):
          if (lines.number = 0)
          then do;
               call mrpg_error_ (2,(lstk.line(ls_top)),"LINE 0 and LINE PAUSE cannot have any fields specified.");
               lines.number = 1;
          end;
          allocate field in (space);
          field.type = "FD";
          field.alch = "";
          field.value.b, field.value.e = null();
          field.let.b, field.let.e = null();
          field.data = null();
          field.bsp = "0"b;
          call link(lines.field,fldptr);
          report_sw = "1"b;
          return;

/* <field>             ::= <,4>   <cexp>       
                                        <field_ctl...>  ! */;
rule(0168):
          li = ls_top-1;
          goto field_1;


/* <field>             ::= <,4>   <cexp>        ! */;
rule(0169):
          li = ls_top;
field_1:
          field.line = lstk.line(li);
          if (lstk.datype(li) = BOOL)
          then call make_char(li);
          tptr = lstk.node_ptr(li);
          if (tptr = null())
          then return;                  /* cant do anything */
          if (tptr->symref.type = "OP")
          then do;
               if (lstk.datype(li) = DEC)
               then call st_search("D_01",T_01ptr,"ID",Decimal,0);
               else call st_search("T_01",T_01ptr,"ID",Chard,256);
               call aloc_stmt(":=",ls_top);
               call link (stmt.ref1,T_01ptr);
               call link (stmt.ref2,lstk.node_ptr(li));
               call link (field.value,stmtptr);
          end;
          else do;
               call aloc_value("VL",ls_top);
               value.sym = tptr;
               call link (field.value,valptr);
          end;
          if dmp_sw then call mrpg_dump_$all((fldptr),0);
          report_sw = "0"b;
          if (field.value.b->stmt.type = ":=")
          then do;
               tptr = field.value.b->stmt.ref1.b;
               call link_list(field.let,field.value);
               call aloc_value("VL",ls_top-1);
               value.sym = tptr;
               field.value.b, field.value.e = null();
               call link (field.value, valptr);
               if (field.kind = 0)
               then field.kind = Chard;
          end;
          if (field.kind = Pic)
          then do;
               ch2 = "cP";
               goto pe_field;
          end;
          if (field.kind = Edit)
          then do;
               ch2 = "cE";
pe_field:
               call st_search("T_02",T_02ptr,"ID",Chard,256);
               call aloc_stmt(ch2,ls_top);
               call link(stmt.ref1,T_02ptr);
               call link(stmt.ref2,(field.value.b));
               call link(stmt.ref2,(field.data));
               call link(field.let,stmtptr);
               call aloc_value("VL",ls_top-1);
               value.sym = T_02ptr;
               field.value.b, field.value.e = null();
               call link (field.value, valptr);
               field.kind = Chard;
          end;
          valptr = field.value.b;
          if (value.type = "VL")
          then do;
               srefptr = value.sym;
               if (symref.type = "SY")
               then do;
                    symtabptr = symref.sym;
                    if (symtab.type = "ST")
                    then if (index(symtab.data,BSP) ^= 0)
                    then field.bsp = "1"b;
               end;
          end;
          fldptr = null();
          return;
dcl  BSP char(1) int static init("");


/* <field_ctl...>      ::= <field_ctl>  ! */;
/* <field_ctl...>      ::= <field_ctl...> <field_ctl>  ! */

/* <field_ctl>         ::= PICTURE <quoted_str>  ! */
rule(0172):
          if (field.kind ^= 0)
          then do;
               call mrpg_error_ (2,(lstk.line(ls_top-1)),"Multiple data-type");
               return;
          end;
          symtabptr = lstk.node_ptr(ls_top)->symref.sym;
          call check_picture;
          field.kind = Pic;
          field.data = lstk.node_ptr(ls_top);
          return;

check_picture:      proc;

dcl info char(100);
dcl pic char(symtab.leng-2);
dcl  picture_info_ entry (char(*),ptr,fixed bin);

          pic = substr(symtab.data,2);
          call picture_info_(pic,addr(info),ki);
          if (ki = 0)
          then return;
          if (ki = 414)
          then call mrpg_error_(2,(lstk.line(ls_top)),"Normalized picture > 64 characters. ""^a""",pic);
          else if (ki = 434)
          then call mrpg_error_(2,(lstk.line(ls_top)),"Picture scale factor outside range -128:+127 ""^a""",pic);
          else call mrpg_error_(2,(lstk.line(ls_top)),"Syntax error in picture. ""^a""",pic);
          return;

       end check_picture;

/* <field_ctl>         ::= EDIT <quoted_str>  ! */
rule(0173):
          call mrpg_error_(2,(lstk.line(ls_top-1)),"EDIT not implemented");
          if (field.kind ^= 0)
          then do;
               call mrpg_error_ (2,(lstk.line(ls_top-1)),"Multiple data-type");
               return;
          end;
          field.kind = Edit;
          field.data = lstk.node_ptr(ls_top);
          return;

/* <field_ctl>         ::= CHARACTER ( <number> )  ! */
rule(0174):
          if (field.kind ^= 0)
          then do;
               call mrpg_error_ (2,(lstk.line(ls_top-1)),"Multiple data-type");
               return;
          end;
          field.kind = Char;
          field.leng = lstk.val(ls_top-1);
          return;


/* <let>               ::= LET  ! */
rule(0175):
          min_paren = 1;
          report_sw = "0"b;
          return;


/* <field_ctl>         ::= <let> ( <assign...> )  ! */;
rule(0176):
          min_paren = 0;
          report_sw = "1"b;
          return;

/* <field_ctl>         ::= COLUMN <number>  ! */;
rule(0177):
          field.col = lstk.val(ls_top);
          return;


/* <field_ctl>         ::= BSP ! */;
rule(0178):
          field.bsp = "1"b;
          return;

/* <field_ctl>         ::= LEFT  ! */;
rule(0179):
          if (field.align ^= 0)
          then do;
               call mrpg_error_ (2,(lstk.line(ls_top-1)),"Multiple aligning");
               return;
          end;
          field.align = Left;
          return;

/* <field_ctl>         ::= CENTER  ! */;
rule(0180):
          if (field.align ^= 0)
          then do;
               call mrpg_error_ (2,(lstk.line(ls_top-1)),"Multiple aligning");
               return;
          end;
          field.align = Center;
          return;

/* <field_ctl>         ::= RIGHT  ! */;
rule(0181):
          if (field.align ^= 0)
          then do;
               call mrpg_error_ (2,(lstk.line(ls_top-1)),"Multiple aligning");
               return;
          end;
          field.align = Right;
          return;

/* <field_ctl>         ::= FILL  ! */;
rule(0182):
         call mrpg_error_(2,(lstk.line(ls_top)),"FILL not implemented.");
          if (field.align ^= 0)
          then do;
               call mrpg_error_ (2,(lstk.line(ls_top-1)),"Multiple aligning");
               return;
          end;
          field.align = Fill;
          return;

/* <field_ctl>         ::= FILL ( <number> , <number> )  ! */;
rule(0183):
         call mrpg_error_(2,(lstk.line(ls_top-5)),"FILL not implemented.");
          if (field.align ^= 0)
          then do;
               call mrpg_error_ (2,(lstk.line(ls_top-1)),"Multiple aligning");
               return;
          end;
          field.align = Fill;
          field.fill(1) = lstk.val(ls_top-3);
          field.fill(2) = lstk.val(ls_top-1);
          return;

/* <field_ctl>         ::= ALIGN <quoted_str>  ! */;
rule(0184):
          if (field.align ^= 0)
          then do;
               call mrpg_error_ (2,(lstk.line(ls_top-1)),"Multiple aligning");
               return;
          end;
          field.align = Align;
          tptr = lstk.node_ptr(ls_top);
          if (tptr ^= null())
          then do;
               if (tptr->symref.sym->symtab.leng ^= 3)
               then call mrpg_error_ (2,(lstk.line(ls_top-1)),"Align string more than 1 character");
               field.alch = substr(tptr->symref.sym->symtab.data,2,1);
          end;
          return;

/* <field_ctl>         ::= FOLD  ! */
rule(0185):
         call mrpg_error_(2,(lstk.line(ls_top)),"FOLD not implemented.");
          if (field.align ^= 0)
          then do;
               call mrpg_error_ (2,(lstk.line(ls_top-1)),"Multiple aligning");
               return;
          end;
          field.align = Fold;
          return;


/* <begin>             ::= BEGIN ! */
rule(0186):
          if (if_nest > 0)
          then do;
               call mrpg_error_(2,(lstk.line(ls_top)),"BEGIN preceded by ^i unterminated IFs.",if_nest);
          end;
          call aloc_stmt("BG",ls_top);
          beginptr = stmtptr;
          begin_ct = begin_ct + 1;
          stmtlistptr = addr(stmt.ref3);
          stmt_list.b, stmt_list.e = null();
          min_paren = 1;
          return;

/* <begin_etc>         ::= <begin> ( <[assign...]> ) ! */
rule(0187):
          min_paren = 0;
          return;

/* <phase>             ::= <begin_etc>
                        <[sort]>
                        <[stmt...]>
                        <[hold]>  ! */
rule(0188):
          call link(exec,beginptr);
          beginptr = null();
          return;

/* <[stmt...]>         ::=  ! */;
rule(0189):
          if (begin_ct > 1)
          then call mrpg_error_ (2,(lstk.line(ls_top-4)),"No useful statements in this phase.");
          return;

/* <[stmt...]>         ::= <stmt...>  ! */

/* <stmt...>           ::= <stmt>  ! */;
/* <stmt...>           ::= <stmt...> <stmt> ! */
/* <then>              ::= THEN  ! */
rule(0193):
          if_nest = if_nest + 1;
          call aloc_stmt("IF",ls_top-2);
          call link(stmtlistptr->a_list,stmtptr);
          call link(stmt.ref1,lstk.node_ptr(ls_top-1));
          lstk.node_ptr(ls_top-2) = stmtlistptr;
          stmtlistptr = addr(stmt.ref2);
          elselistptr (if_nest) = addr(stmt.ref3);
          return;

/* <else>              ::= ELSE  ! */
rule(0194):
          stmtlistptr = elselistptr (if_nest);
          return;

/* <stmt>              ::= IF <expr> <then> <stmt...> FI ;  ! */;
rule(0195):
          call make_bool(ls_top-4);
          if_nest = if_nest - 1;
          stmtlistptr = lstk.node_ptr(ls_top-5);
          return;

/* <stmt>              ::= IF <expr> <then> <stmt...> FI;  ! */;
rule(0196):
          if_nest = if_nest - 1;
          stmtlistptr = lstk.node_ptr(ls_top-4);
          call mrpg_error_(0,(lstk.line(ls_top-4)),"Is the ""IF"" terminated.");
          return;

/* <stmt>              ::= IF <expr> <then> <stmt...> <else> <stmt...> FI ;  ! */
rule(0197):
          call make_bool(ls_top-6);
          if_nest = if_nest - 1;
          stmtlistptr = lstk.node_ptr(ls_top-7);
          return;

/* <stmt>              ::= IF <expr> <then> <stmt...> <else> <stmt...> FI;  ! */
rule(0198):
          if_nest = if_nest - 1;
          stmtlistptr = lstk.node_ptr(ls_top-6);
          call mrpg_error_(0,(lstk.line(ls_top-6)),"Is the ""IF"" terminated.");
          return;

/* <stmt>              ::= <assign>  ! */;
rule(0199):
          call link(stmtlistptr->a_list,lstk.node_ptr(ls_top));
          return;

/* <stmt>              ::= PRINT <identifier> ;  ! */;
rule(0200):
          call aloc_stmt("PR",ls_top-2);
          call link(stmt.ref1, lstk.node_ptr(ls_top-1));
          tptr = lstk.node_ptr(ls_top-1);
          call use_ref((tptr));
          ch2 = tptr->symref.sym->symtab.use.b->datum.type;
          if (ch2 ^= "RP") & (ch2 ^= "DT")
          then do;
               call mrpg_error_ (2,(tptr->symref.line),"The ^a name ""^a"" cannot be the object of a PRINT statement."
                    ,dt_s(lstk.datype(ls_top)),pull_name(ls_top-1));
          end;
          call link(stmtlistptr->a_list,stmtptr);
          return;

/* <stmt>              ::= ; ! */
/* <stmt>              ::= THEN ! */
rule(0202):
          call mrpg_error_(2,(lstk.line(ls_top)),"Extra THEN present.");
          return;

/* <hold_key>          ::= HOLD  ! */
rule(0203):
          hold_list.b, hold_list.e = null();
          return;

/* <[hold]>            ::=  ! */;
rule(0204):
          if (begin_ct = 1)
          then do;
               call hold_input;
               goto hold_common;
          end;
          return;

/* <[hold]>            ::=  <hold_key> ;  ! */
rule(0205):
          if (begin_ct = 1)
          then call hold_input;
          goto hold_common;

/* <[hold]>            ::= <hold_key> <identifier , ...> ;  ! */
rule(0206):
          if (begin_ct ^= 1)
          then do;
               call mrpg_error_ (2,(lstk.line(ls_top-2)),"HOLD values allowed only in first phase.");
               hold_list.b, hold_list.e = null();
          end;
hold_common:
          call aloc_stmt("HD",ls_top);
          stmt.ref1 = hold_list;
          call link(stmtlistptr->a_list,stmtptr);
          hold_list.b, hold_list.e = null();
          return;

/* <[sort]>            ::=  ! */;
rule(0207):
          ch2 = "SR";
          li = -1;
          goto sort_common;

/* <sort_key>          ::= SORT  ! */
rule(0208):
          if (begin_ct = 1)
          then call mrpg_error_ (2,(lstk.line(ls_top)),"SORT not allowed in first phase.");
          return;

/* <[sort]>            ::= <sort_key> <sortkey , ...> ;  ! */;
rule(0209):
          ch2 = "SR";
          li = 2;
          goto sort_common;

/* <[sort]>            ::= <sort_key> <sortkey , ...> NO DUPLICATE ;  ! */;
rule(0210):
          ch2 = "SU";
          li = 4;
sort_common:
          call aloc_stmt(ch2,ls_top-li);
          stmt.ref2 = sort_list;
          call link (stmtlistptr->a_list,stmtptr);
          sort_list.b, sort_list.e = null();
          return;

/* <sortkey , ...>     ::= <sortkey>  ! */;
/* <sortkey , ...>     ::= <sortkey , ...> , <sortkey>  ! */

/* <sortkey>           ::= <identifier>  ! */;
rule(0213):
          allocate attr in (space);
          attr.type = "KY";
          attr.asc = "1"b;
          ki = ls_top;
sortkey:
          attr.sym = lstk.node_ptr(ki);
          if (lstk.datype(ki) = 0)
          | (lstk.datype(ki) > DEC)
          then do;
               call mrpg_error_(2,lstk.line(ki),"The ^a name ""^a"" cannot be a sort key."
                    ,dt_s(lstk.datype(ki)),pull_name(ki));
               return;
          end;
          call use_ref((attr.sym));
          call link(sort_list,atptr);
          return;

/* <sortkey>           ::= <identifier> ASCENDING  ! */;
rule(0214):
          allocate attr in (space);
          attr.type = "KY";
          attr.asc = "1"b;
          ki = ls_top-1;
          goto sortkey;

/* <sortkey>           ::= <identifier> DESCENDING  ! */
rule(0215):
          allocate attr in (space);
          attr.type = "KY";
          attr.des = "1"b;
          ki = ls_top-1;
          goto sortkey;

/* <[assign...]>       ::=  ! */;
/* <[assign...]>       ::= <assign...>  ! */
/* <assign...>         ::= <assign>  ! */;
rule(0218):
/* <assign...>         ::= <assign...> <assign>  ! */
rule(0219):
          tptr = lstk.node_ptr(ls_top);
          if (fldptr ^= null())
          then do;
               call link(field.let,tptr);
          end;
          else do;
               call link(beginptr->stmt.ref1,tptr);
          end;
          return;

/* <assign>            ::= <identifier> := <expr> ;  ! */;
rule(0220):
          goto cv_assign(lstk.datype(ls_top-3));
cv_assign(0):
cv_assign(4):
cv_assign(5):
cv_assign(6):
cv_assign(7):
          call mrpg_error_(2,(lstk.line(ls_top-3)),"The ^a name ""^a"" cannot be the object of an assignment."
                    ,dt_s(lstk.datype(ls_top-3)),pull_name(ls_top-3));
          return;

cv_assign(1):                 /* BOOLEAN receiver */
          call make_bool(ls_top-1);
          goto cvassign;

cv_assign(2):                 /* CHAR receiver */
          if (lstk.node_ptr(ls_top-3)->symref.sym->symtab.use.b->datum.kind = Pic)
          then goto cvassign;
          if (lstk.datype(ls_top-1) = DEC)
          then do;
               call aloc_stmt("=:",ls_top-3);
               goto cvassign1;
          end;
          call make_char(ls_top-1);
          goto cvassign;

cv_assign(3):                 /* DECIMAL receiver */
          call make_dec(ls_top-1);

cvassign:

          call aloc_stmt(":=",ls_top-3);
cvassign1:
          call link(stmt.ref1, lstk.node_ptr(ls_top-3));
          call use_ref((lstk.node_ptr(ls_top-3)));
          call link(stmt.ref2, lstk.node_ptr(ls_top-1));
          lstk.node_ptr(ls_top-3) = stmtptr;
          return;


/* <substr_key>        ::= %SUBSTR ! */
rule(0221):
/* <roman_key>         ::= %ROMAN ! */
rule(0222):
/* <repeat_key>        ::= %REPEAT ! */
rule(0223):
/* <tran_key>          ::= TRANSFORM ! */
rule(0224):
          depth = depth + 1;
          return;

/* <transform>         ::= <tran_key> ( <expr> , <identifier> )! */;
rule(0225):
          depth = depth - 1;
          if (lstk.datype(ls_top-1) ^= TABLE)
          then do;
               call mrpg_error_(2,(lstk.line(ls_top-1)),"TRANSFORM must reference a table.");
               return;
          end;
          call use_ref ((lstk.node_ptr(ls_top-1)));
          ki = lstk.node_ptr(ls_top-1)->symref.sym->symtab.use.b->datum.datal.b->opn.op;
          if (ki = n_n)
          then do;
               call make_dec(ls_top-3);
               lstk.datype(ls_top-5) = DEC;
          end;
          else if (ki = n_s)
          then do;
               call make_dec(ls_top-3);
               lstk.datype(ls_top-5) = CHAR;
          end;
          else if (ki = s_n)
          then do;
               call make_char(ls_top-3);
               lstk.datype(ls_top-5) = DEC;
          end;
          else if (ki = s_s)
          then do;
               call make_char(ls_top-3);
               lstk.datype(ls_top-5) = CHAR;
          end;
          else do;
               call mrpg_error_(3,(lstk.line(ls_top-5)),"Bad table type.");
               return;
          end;
          call aloc_opn(Tran,ls_top-5);
          opn.kind = lstk.node_ptr(ls_top-1)->symref.kind;
          opn.op1 = lstk.node_ptr(ls_top-1);
          opn.op2 = lstk.node_ptr(ls_top-3);
          lstk.node_ptr(ls_top-5) = opptr;
          return;

/* <identifier , ...>  ::= <identifier>  ! */;
rule(0226):
/* <identifier , ...>  ::= <identifier , ...> , <identifier>  ! */
rule(0227):
          call link(hold_list,lstk.node_ptr(ls_top));
          call use_ref((lstk.node_ptr(ls_top)));
          return;

/* <identifier , ...>  ::= INPUT ! */
rule(0228):
          call hold_input;
          return;

hold_input: proc;
               do daptr = tree.input.b
                         repeat (datum.next)
                         while (daptr ^= null());
                    if (datum.sym ^= null())
                    then do;
                         allocate symref in (space);
                         symref = datum.sym->symref;
                         symref.next = null();
                         call link(hold_list,srefptr);
                         call use_ref(srefptr);
                    end;
               end;
          end hold_input;

/* <expr>              ::= <expr> OR <bterm>  ! */;
rule(0229):
          call make_bool (ls_top-2);
          call make_bool (ls_top);
          call aloc_opn(Or,ls_top-2);
          opn.kind = Bool;
          opn.op1 = lstk.node_ptr(ls_top-2);
          opn.op2 = lstk.node_ptr(ls_top);
          lstk.node_ptr(ls_top-2) = opptr;
          lstk.datype(ls_top-2) = BOOL;
          lstk.datype(ls_top-2) = BOOL;
          return;

/* <expr>              ::= <bterm>  ! */

/* <bterm>             ::= <bterm> AND <bfact>  ! */;
rule(0231):
          call make_bool (ls_top-2);
          call make_bool (ls_top);
          call aloc_opn(And,ls_top-2);
          opn.kind = Bool;
          opn.op1 = lstk.node_ptr(ls_top-2);
          opn.op2 = lstk.node_ptr(ls_top);
          lstk.node_ptr(ls_top-2) = opptr;
          return;

/* <bterm>             ::= <bfact>  ! */

/* <bfact>             ::=     <bref>  ! */;
/* <bfact>             ::= NOT <bref>  ! */;
rule(0234):
          call make_bool(ls_top);
          call aloc_opn(Not,ls_top-1);
          opn.kind = Bool;
          opn.op2 = lstk.node_ptr(ls_top);
          lstk.node_ptr(ls_top-1) = opptr;
          lstk.datype(ls_top-1) = BOOL;
          return;

/* <bfact>             ::= <relation>  ! */;
/* <bfact>             ::= <membership>  ! */
/* <compare>           ::= EQ  ! */;
rule(0237):
          lstk.val(ls_top) = EQ;
          return;

/* <compare>           ::= NE  ! */;
rule(0238):
          lstk.val(ls_top) = NE;
          return;

/* <compare>           ::= LE  ! */;
rule(0239):
          lstk.val(ls_top) = LE;
          return;

/* <compare>           ::= GE  ! */;
rule(0240):
          lstk.val(ls_top) = GE;
          return;

/* <compare>           ::= LT  ! */;
rule(0241):
          lstk.val(ls_top) = LT;
          return;

/* <compare>           ::= GT  ! */
rule(0242):
          lstk.val(ls_top) = GT;
          return;

/* <relation>          ::= <cexp> <compare> <cexp>  ! */
rule(0243):
          if (lstk.datype(ls_top-2) ^= lstk.datype(ls_top))
          then do;
               if (lstk.datype(ls_top) = CHAR)
               then call make_char(ls_top-2);
               else if (lstk.datype(ls_top-2) = CHAR)
               then call make_char(ls_top);
               else do;
                    call make_dec(ls_top);
                    call make_dec(ls_top-2);
               end;
          end;
          goto rels;

/* <relation>          ::= <cexp> <str_rel> <cexp>  ! */
rule(0244):
/* <relation>          ::= <cexp> <word_rel> <cexp>  ! */
rule(0245):
          call make_char (ls_top-2);
          call make_char (ls_top);
rels:
          call aloc_opn((lstk.val(ls_top-1)),ls_top-2);
          opn.kind = Bool;
          opn.op1 = lstk.node_ptr(ls_top-2);
          opn.op2 = lstk.node_ptr(ls_top);
          lstk.node_ptr(ls_top-2) = opptr;
          lstk.val(ls_top-2) = 1;
          lstk.datype(ls_top-2) = BOOL;
          return;

/* <str_rel>           ::=     BEGINS  ! */;
rule(0246):
          lstk.val (ls_top) = Beg;
          return;

/* <str_rel>           ::= NOT BEGIN  ! */;
rule(0247):
          lstk.val (ls_top - 1) = Nbeg;
          return;

/* <str_rel>           ::=     ENDS  ! */;
rule(0248):
          lstk.val (ls_top) = End;
          return;

/* <str_rel>           ::= NOT END  ! */;
rule(0249):
          lstk.val (ls_top - 1) = Nend;
          return;

/* <str_rel>           ::=     CONTAINS  ! */;
rule(0250):
          lstk.val (ls_top) = Cont;
          return;

/* <str_rel>           ::= NOT CONTAIN  ! */
rule(0251):
          lstk.val (ls_top - 1) = Ncont;
          return;

/* <word_rel>          ::=     BEGINS WORD  ! */;
rule(0252):
          lstk.val (ls_top - 1) = Begw;
          return;

/* <word_rel>          ::= NOT BEGIN  WORD  ! */;
rule(0253):
          lstk.val (ls_top - 2) = Nbegw;
          return;

/* <word_rel>          ::=     ENDS WORD  ! */;
rule(0254):
          lstk.val (ls_top - 1) = Endw;
          return;

/* <word_rel>          ::= NOT END  WORD  ! */;
rule(0255):
          lstk.val (ls_top - 2) = Nendw;
          return;

/* <word_rel>          ::=     CONTAINS WORD  ! */;
rule(0256):
          lstk.val (ls_top - 1) = Contw;
          return;

/* <word_rel>          ::= NOT CONTAIN  WORD  ! */
rule(0257):
          lstk.val (ls_top - 2) = Ncontw;
          return;

/* <membership>        ::= <cexp>     IN <identifier>  ! */;
rule(0258):
          class = ls_top-2;
          call aloc_opn(In,(class));
IN_rtn:
          if (lstk.datype(ls_top) ^= SET)
          then do;
               call mrpg_error_(2,(lstk.line(ls_top)),"The ^a name ""^a"" cannot be the object of an IN."
                    ,dt_s(lstk.datype(ls_top)),pull_name((ls_top)));
               return;
          end;
          ki = lstk.node_ptr(ls_top)->symref.sym->symtab.use.b->datum.datal.b->opn.op;
          if (ki = n_n) & (lstk.datype (class) ^= DEC)
             | (ki = s_s) &  (lstk.datype (class) ^= CHAR)
             then do;
                call mrpg_error_ (2, (lstk.line (class)), """^a"" has the wrong data type for SET ""^a"".",
                   pull_name ((class)), pull_name ((ls_top)));
                return;
             end;
          call use_ref ((lstk.node_ptr(ls_top)));
          opn.kind = Bool;
          opn.op1 = lstk.node_ptr(ls_top);
          opn.op2 = lstk.node_ptr(class);
          lstk.node_ptr(class) = opptr;
          lstk.datype(class) = BOOL;
          return;

/* <membership>        ::= <cexp> NOT IN <identifier>  ! */
rule(0259):
          class = ls_top-3;
          call aloc_opn(Nin,(class));
          goto IN_rtn;

/* <set>               ::= <number , ...>  ! */;

/* <set>               ::= <quoted_str , ...>  ! */

/* <number , ...>      ::= <number>  ! */;
rule(0262):
          set_type = n_n;
          goto set_comm;

/* <quoted_str , ...>  ::= <quoted_str>  ! */;
rule(0263):
          set_type = s_s;
          goto set_comm;

/* <number , ...>      ::= <number , ...> , <number>  ! */
rule(0264):
/* <quoted_str , ...>  ::= <quoted_str , ...> , <quoted_str>  ! */
rule(0265):
set_comm:
          call aloc_opn(set_type,ls_top);
          opn.kind = Bool;
          opn.op1 = lstk.node_ptr(ls_top);
          call link (datum.datal,opptr);
          return;


/* <bref>              ::= <cexp>  ! */;

/* <bref>              ::= TRUE  ! */;
rule(0267):
/* <bref>              ::= FALSE  ! */;
rule(0268):
          lstk.node_ptr(ls_top)->symref.kind = Bool;
          lstk.datype(ls_top) = BOOL;
          return;

/* <bref>              ::= <bbuiltin>  ! */

/* <bbuiltin>          ::= %LEVEL ( <identifier> )  ! */;
rule(0270):
          if (repptr ^= null())
          then do;
               li = break_number(lstk.node_ptr(ls_top-1));
               if (li = 0)
               then do;
                    call mrpg_error_(2,(lstk.line(ls_top-1)),"Identifier ""^a"" is not a break field in this report.",
                              pull_name(ls_top-1));
                    return;
               end;
               lstk.val(ls_top-1) = li;
          call use_ref ((lstk.node_ptr(ls_top-1)));
          end;

/* <bbuiltin>          ::= %LEVEL ( <number> )  ! */;
rule(0271):
          if (repptr = null)
          then do;
               call mrpg_error_(2,(lstk.line(ls_top-3)),"%LEVEL is only allowed within a REPORT definition.");
               return;
          end;
          call aloc_opn (Level, ls_top-3);
          opn.kind = Bool;
          opn.op1 = report.sym;
dcl pic2 pic"99";
          pic2 = lstk.val(ls_top-1);
          call st_search((pic2),tptr,"NU",0,0);
          opn.op2 = tptr;
          lstk.node_ptr(ls_top-3) = opptr;
          lstk.datype(ls_top-3) = BOOL;
          return;

/* <bbuiltin>          ::= %ABSENT ( <identifier> )  ! */;
rule(0272):
         call mrpg_error_(2,(lstk.line(ls_top-3)),"%ABSENT not implemented.");
          return;

/* <bbuiltin>          ::= %PRESENT ( <identifier> )  ! */;
rule(0273):
         call mrpg_error_(2,(lstk.line(ls_top-3)),"%PRESENT not implemented.");
          return;

/* <bbuiltin>          ::= %FIT  ! */
rule(0274):
         call mrpg_error_(2,(lstk.line(ls_top-3)),"%FIT not implemented.");
          return;

/* <crefa>             ::= IF ( <expr> ) <cref>  ! */;
rule(0275):
          call make_bool(ls_top-2);
          call make_char(ls_top);
          tptr = lstk.node_ptr(ls_top);
          call aloc_opn(If,ls_top-4);
          opn.kind = tptr->symref.kind;
          opn.op1 = lstk.node_ptr(ls_top-2);
          opn.op2 = tptr;
          lstk.node_ptr(ls_top-4) = opptr;
          lstk(ls_top-4).datype = tptr->symref.kind;
          return;

/* <cexp>              ::= <crefa> ! */
/* <cexp>              ::= <cexp> CONCATENATE <crefa>  ! */;
rule(0277):
          call make_char (ls_top-2);
          call make_char (ls_top);
          call aloc_opn(Cat,ls_top-2);
          opn.kind = Char;
          opn.op1 = lstk.node_ptr(ls_top-2);
          opn.op2 = lstk.node_ptr(ls_top);
          lstk.node_ptr(ls_top-2) = opptr;
          lstk.datype(ls_top-2) = CHAR;
          return;

/* <crefa>             ::= <cref>  ! */

/* <cref>              ::= <aexp>  ! */;
/* <cref>              ::= <quoted_str>  ! */;
/* <cref>              ::= <cbuiltin>  ! */

/* <cbuiltin>          ::= <substr_key> ( <cexp> , <aexp> , <aexp> )  ! */;
rule(0282):
          call make_char (ls_top-5);
          call make_dec (ls_top-3);
          call make_dec (ls_top-1);
          call aloc_opn(Substr,ls_top-7);
          opn.kind = Char;
          opn.op1 = lstk.node_ptr(ls_top-5);
          opn.op2 = lstk.node_ptr(ls_top-3);
          opn.op3 = lstk.node_ptr(ls_top-1);
          lstk.node_ptr(ls_top-7) = opptr;
          lstk.datype(ls_top-7) = CHAR;
          depth = depth - 1;
          return;

/* <cbuiltin>          ::= <substr_key> ( <cexp> , <aexp> )  ! */;
rule(0283):
          call make_dec (ls_top-1);
          call make_char (ls_top-3);
          call aloc_opn(Substr,ls_top-5);
          opn.kind = Char;
          opn.op1 = lstk.node_ptr(ls_top-3);
          opn.op2 = lstk.node_ptr(ls_top-1);
          lstk.node_ptr(ls_top-5) = opptr;
          lstk.datype(ls_top-5) = CHAR;
          depth = depth - 1;
          return;

/* <cbuiltin>          ::= <roman_key> ( <aexp> )  ! */;
rule(0284):
         call mrpg_error_(2,(lstk.line(ls_top-3)),"%ROMAN not implemented.");
          depth = depth - 1;
          return;

/* <cbuiltin>          ::= %MMDDYY  ! */;
/* <cbuiltin>          ::= %YYDDD  ! */;
/* <cbuiltin>          ::= %MONTH  ! */;
/* <cbuiltin>          ::= %DAY  ! */;
/* <cbuiltin>          ::= %HHMMSS  ! */;
/* <cbuiltin>          ::= <repeat_key> ( <cexp> , <aexp> )  ! */
rule(0290):
          call make_dec(ls_top-1);
          call make_char(ls_top-3);
          call aloc_opn(Rpt,ls_top-5);
          opn.kind = Char;
          opn.op1 = lstk.node_ptr(ls_top-3);
          opn.op2 = lstk.node_ptr(ls_top-1);
          lstk.node_ptr(ls_top-5) = opptr;
          lstk.datype(ls_top-5) = CHAR;
          depth = depth - 1;
          return;


/* <aexp>              ::= <aexp> + <aterm>  ! */;
rule(0291):
          call make_dec (ls_top-2);
          call make_dec(ls_top);
          call aloc_opn(Add,ls_top-2);
          opn.kind = Decimal;
          opn.op1 = lstk.node_ptr(ls_top-2);
          opn.op2 = lstk.node_ptr(ls_top);
          lstk.node_ptr(ls_top-2) = opptr;
          lstk.datype(ls_top-2) = DEC;
          return;

/* <aexp>              ::= <aexp> - <aterm>  ! */;
rule(0292):
          call make_dec (ls_top-2);
          call make_dec(ls_top);
          call aloc_opn(Sub,ls_top-2);
          opn.kind = Decimal;
          opn.op1 = lstk.node_ptr(ls_top-2);
          opn.op2 = lstk.node_ptr(ls_top);
          lstk.node_ptr(ls_top-2) = opptr;
          lstk.datype(ls_top-2) = DEC;
          return;

/* <aexp>              ::= <aterm>  ! */

/* <aterm>             ::= <aterm> * <afact>  ! */;
rule(0294):
          call make_dec (ls_top-2);
          call make_dec(ls_top);
          call aloc_opn(Mul,ls_top-2);
          opn.kind = Decimal;
          opn.op1 = lstk.node_ptr(ls_top-2);
          opn.op2 = lstk.node_ptr(ls_top);
          lstk.node_ptr(ls_top-2) = opptr;
          lstk.datype(ls_top-2) = DEC;
          return;

/* <aterm>             ::= <aterm> / <afact>  ! */;
rule(0295):
          call make_dec (ls_top-2);
          call make_dec(ls_top);
          call aloc_opn(Div,ls_top-2);
          opn.kind = Decimal;
          opn.op1 = lstk.node_ptr(ls_top-2);
          opn.op2 = lstk.node_ptr(ls_top);
          lstk.node_ptr(ls_top-2) = opptr;
          lstk.datype(ls_top-2) = DEC;
          return;

/* <aterm>             ::= <afact>  ! */

/* <afact>             ::= <aref>  ! */;
/* <afact>             ::= - <aref>  ! */;
rule(0298):
          call make_dec(ls_top);
          call aloc_opn(Sub,ls_top-2);
          opn.kind = Decimal;
          opn.op2 = lstk.node_ptr(ls_top);
          lstk.node_ptr(ls_top-1) = opptr;
          lstk.datype(ls_top-1) = DEC;
          return;

/* <afact>             ::= + <aref>  ! */;
rule(0299):
          call make_dec(ls_top);
          call aloc_opn(Add,ls_top-1);
          opn.kind = Decimal;
          opn.op2 = lstk.node_ptr(ls_top);
          lstk.node_ptr(ls_top-1) = opptr;
          lstk.datype(ls_top-1) = DEC;
          return;

/* <afact>             ::= - ( <aexp> )  ! */;
rule(0300):
          call make_dec(ls_top-1);
          call aloc_opn(Paren,ls_top-2);
          opn.kind = Decimal;
          opn.op1 = lstk.node_ptr(ls_top-1);
          lstk.node_ptr(ls_top) = opptr;
          lstk.datype(ls_top-3) = DEC;
          call aloc_opn(Sub,ls_top-3);
          opn.kind = Decimal;
          opn.op2 = lstk.node_ptr(ls_top);
          lstk.node_ptr(ls_top-3) = opptr;
          return;

/* <afact>             ::= + ( <aexp> )  ! */;
rule(0301):
          call make_dec(ls_top-1);
          call aloc_opn(Paren,ls_top-2);
          opn.kind = Decimal;
          opn.op1 = lstk.node_ptr(ls_top-1);
          lstk.node_ptr(ls_top) = opptr;
          lstk.datype(ls_top-3) = DEC;
          call aloc_opn(Add,ls_top-3);
          opn.kind = Decimal;
          opn.op2 = lstk.node_ptr(ls_top);
          lstk.node_ptr(ls_top-3) = opptr;
          return;

/* <afact>             ::=  ( <expr> )  ! */
rule(0302):
          call aloc_opn(Paren,ls_top-2);
          opn.kind = lstk.node_ptr(ls_top-1)->datum.kind;
          opn.op1 = lstk.node_ptr(ls_top-1);
          lstk.node_ptr(ls_top-2) = opptr;
          lstk.datype(ls_top-2) = lstk.datype(ls_top-1);
          return;


/* <aref>              ::= <transform>  ! */;
/* <aref>              ::= <number>  ! */;
rule(0304):
          lstk.datype(ls_top) = DEC;
          return;

/* <aref>              ::= <identifier>  ! */;
rule(0305):
          if (lstk.datype (ls_top) = 0)
          then do;
               call mrpg_error_ (2,((lstk.line(ls_top))),"Variable ""^a"" not defined before reference.",symtab.data);
               return;
          end;
          return;

/* <aref>              ::= <abuiltin>  ! */

/* <abuiltin>          ::= %PAGENUMBER ( <identifier> )  ! */;
rule(0307):
          tptr = lstk.node_ptr(ls_top-1);
          call use_ref((tptr));
          ch2 = tptr->symref.sym->symtab.use.b->datum.type;
          if (ch2 ^= "RP")
          then do;
               call mrpg_error_ (2,(tptr->symref.line),"The ^a name ""^a"" cannot be in a %PAGENUMBER function."
                    ,dt_s(lstk.datype(ls_top)),pull_name(ls_top-1));
          end;
          call use_ref ((lstk.node_ptr(ls_top)));
          srefptr = lstk.node_ptr(ls_top-1);
          ki = ls_top - 3;
          goto pgno;

/* <abuiltin>          ::= %PAGENUMBER ( )  ! */
rule(0308):
          srefptr = report.sym;
          ki = ls_top-2;
pgno:
          symtabptr = symref.sym;
          call st_search (symtab.data || ".I_page",tptr,"ID",Integer,0);
          lstk(ki).node_ptr = tptr;
          lstk.datype(ki) = DEC;
          return;

       end semantics;

make_dec: proc(e);

dcl e fixed bin(24);

          if (lstk.datype(e) = DEC)
          then return;
          call aloc_opn(c_d,e);
          opn.kind = Decimal;
          if (lstk.datype(e) = BOOL)
          then opn.op = b_d;
          opn.op1 = lstk.node_ptr(e);
          lstk.node_ptr(e) = opptr;
          if db_sw then call ioa_$ioa_switch_nnl(iox_$user_output," ^2i^a",e,op_char(opn.op));
          return;

       end make_dec;

make_char:          proc(e);

dcl e fixed bin(24);

          if (lstk.datype(e) = CHAR)
          then return;
          call aloc_opn(d_c,e);
          opn.kind = Char;
          if (lstk.datype(e) = BOOL)
          then opn.op = b_c;
          opn.op1 = lstk.node_ptr(e);
          lstk.node_ptr(e) = opptr;
          if db_sw then call ioa_$ioa_switch_nnl(iox_$user_output," ^2i^a",e,op_char(opn.op));
          return;

       end make_char;

make_bool:          proc(e);

dcl e fixed bin(24);

          if (lstk.datype(e) = BOOL)
          then return;
          call aloc_opn(c_b,e);
          opn.kind = Bool;
          if (lstk.datype(e) = DEC)
          then opn.op = d_b;
          opn.op1 = lstk.node_ptr(e);
          lstk.node_ptr(e) = opptr;
          if db_sw then call ioa_$ioa_switch_nnl(iox_$user_output," ^2i^a",e,op_char(opn.op));
          return;

end make_bool;

break_number:       proc(p)returns(fixed bin);

dcl  p ptr;
dcl  i fixed bin;

          i = 0;
          do srefptr = report.brlist.b
                    repeat (symref.next)
                    while (srefptr ^= null());
               i = i + 1;
               if (symref.sym =  p->symref.sym)
               then return(i);
          end;
          return (0);

end break_number;

aloc_datum:         proc;

          allocate datum in (space);
          datum.check.b, datum.check.e = null();
          datum.datal.b, datum.datal.e = null();
          datum.echar = lstk.echar(ls_top);

end aloc_datum;

aloc_attr:          proc(first);
dcl       first     fixed bin(24);

dcl       tptr      ptr;

          allocate attr in (space);
          tptr = lstk.node_ptr(first);
          if (tptr ^= null())
          then do;
               attr.line = tptr->symref.line;
          end;
          tptr = lstk.node_ptr(ls_top);
          attr.echar = tptr->symref.echar;

end aloc_attr;

aloc_param:         proc(first);
dcl       first     fixed bin(24);

          if (paptr ^= null())
          then return;
          allocate param in (space);
          param.type = "PM";
          param.attr.b, param.attr.e = null();
          param.check.b, param.check.e = null();
          call fill_hdr(paptr,first);

       end aloc_param;

aloc_opn: proc(operand,first);
dcl       operand   fixed bin,
          first     fixed bin(24);

dcl       tptr      ptr;

          allocate opn in (space);
          opn.type = "OP";
          opn.op = operand;
          opn.op1, opn.op2, opn.op3 = null();
          call fill_hdr(opptr,first);

       end aloc_opn;

aloc_value:         proc(id,first);
dcl       id        char(2),
          first     fixed bin(24);

dcl       tptr      ptr;

          allocate value in (space);
          value.type = id;
          value.ctl = null();
          call fill_hdr(valptr,first);

       end aloc_value;

aloc_stmt:          proc(id,first);
dcl       id        char(2),
          first     fixed bin(24);

dcl       tptr      ptr;

          allocate stmt in (space);
          stmt.type = id;
          stmt.ref1.b, stmt.ref1.e = null();
          stmt.ref2.b, stmt.ref2.e = null();
          stmt.ref3.b, stmt.ref3.e = null();
          call fill_hdr(stmtptr,first);

       end aloc_stmt;

fill_hdr: proc(refp,first);

dcl       refp      ptr,
          first     fixed bin(24);

          tptr = lstk.node_ptr(first);
          if (tptr = null())
          then do;
               refp->stmt.line = lstk.line(first);
          end;
          else do;
               refp->stmt.line = tptr->symref.line;
          end;
          tptr = lstk.node_ptr(ls_top);
          if (tptr = null())
          then do;
               refp->stmt.echar = lstk.echar(ls_top);
          end;
          else do;
               refp->stmt.echar = tptr->symref.echar;
          end;
          refp->stmt.usage = null();
          refp->stmt.sym = null();
          refp->stmt.next = null();

       end fill_hdr;

aloc_head:          proc;

          allocate head in (space);
          head.type = "HD";

       end aloc_head;

link_list: proc(lista,listb);

                                                  /* splice listb onto end of lista */

dcl 1 (lista,listb) like tree.table;

          if (listb.b = null())
          then return;

          if (lista.b = null())
          then do;
               lista.b = listb.b;
               lista.e = listb.e;
          end;
          else do;
               lista.e-> symref.next = listb.b;
               lista.e = listb.e;
          end;
          listb.b, listb.e = null();

end link_list;

link:     proc(list,ref);

                                                  /* add new element to end of list */
dcl       1 list like tree.table,
          ref ptr;

          if (ref = null())
          then return;
          if (list.b = null())
          then do;
               list.b, list.e = ref;
               ref->symref.next = null();
          end;
          else do;
               list.e-> symref.next = ref;
               list.e = ref;
          end;
          ref-> symref.next = null();

       end link;

linkr:    proc(list,ref);

                                                  /* add new element to beginning of list */
dcl       1 list like tree.table,
          ref ptr;

          if (list.b = null())
          then do;
               list.b, list.e = ref;
               ref-> symref.next = null();
          end;
          else do;
               ref-> symref.next = list.b;
               list.b = ref;
          end;

       end linkr;
use_def:  proc(ref);
dcl  ref ptr;

dcl tptr ptr;

          if (ref = null())
          then return;
          tptr = ref->datum.sym;
          if (tptr  = null())
          then return;
          tptr = tptr->symref.sym;
          if (tptr = null())
          then return;
          if (tptr->symtab.use.b = null())
          then do;
               tptr->symtab.use.b, tptr->symtab.use.e = ref;
               ref-> datum.usage = null();
          end;
          else do;
dcl  ch2 char(2);
               ch2 = tptr->symtab.use.b->symref.type;
               if (index("*IN*DC*PM*RP*RH*PH*DH*DT*DF*PF*RF*",ch2)^=0)
               then do;
                    call mrpg_error_ (2,(ref->symref.line),"Symbol ""^a"" already defined.",tptr->symtab.data);
                    return;
               end;
               ref-> datum.usage = tptr->symtab.use.b;
               tptr->symtab.use.b = ref;
          end;

       end use_def;

use_ref:  proc(ref);
dcl  ref ptr;

dcl tptr ptr;

          if (ref = null())
          then return;
          tptr = ref->symref.sym;
          if (tptr = null())
          then return;
          if (tptr->symtab.use.b = null())
          then tptr->symtab.use.b, tptr->symtab.use.e = ref;
          else do;
               tptr->symtab.use.e-> datum.usage = ref;
               tptr->symtab.use.e = ref;
          end;
          ref-> datum.usage = null();

       end use_ref;

pull_name:          proc(ii)returns(char(64)var);

dcl  ii fixed bin;

          tptr = lstk.node_ptr(ii);
          if (tptr = null())
          then return("** NULL NODEPTR **");
          tptr = tptr->symref.sym;
          if (tptr = null())
          then return("** NULL SYMREF **");
          return (tptr -> symtab.data);
       end pull_name;



*/
                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull
and Bull HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato. Users consider that Multics provided the best software architecture for 
managing computer hardware properly and for executing programs. Many subsequent operating systems 
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by Bull HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved

*/