1 This library contains the following macros used for mrpg PL/I code generation:
   2   indent              input_field         rcb
   3   assign              line                rcb_begin
   4   bg                  local               rcb_end
   5   break               on                  rcb_put
   6   edit                parm_begin          rep_break
   7   end                 parm_check          rep_head
   8   err                 parm_default        report
   9   et_                 parm_end            sort
  10   exec                picture             table
  11   if                  print               value
  12   input               proc                undent^L
  13 &expand assign
  14 &if &3==:&then
  15 &let A_dec_char=1&;
  16 &fi
  17 &indent&if &3=:=&then&1 = &2&else &1 = A_dec_char(&2,maxlength(&1),"&1",&4)&fi;
  18 &expend
  19 ^L
  20 &expand bg
  21 &if &db_sw &then
  22 &.                                      /* bg &1 &phase_ct*/
  23 &fi
  24 &if &(&1=1)
  25 &then
  26 /* ----                         BEGIN PHASE &phase_ct                            ----  */
  27 
  28 &if &phase_ct=0&then
  29 &indent&.if (I_phase = -1)
  30 &indent&.then do;
  31 &let indent = &mrpg$indent()&;
  32 &indent&.I_phase = 0;
  33 &fi
  34 &new_phase
  35 &return
  36 &fi
  37 &if &(&1=2)
  38 &then
  39 &if &phase_ct=0&then
  40 &let indent = &mrpg$undent()&;
  41 &indent&.end;
  42 &let phase_ct = 00&;
  43 &fi
  44 &return
  45 &fi
  46 &if &(&1=3)
  47 &then
  48      &if &(&phase_ct ^= 0)
  49      &then
  50      &let indent = &mrpg$undent()&;
  51      &indent&.end;
  52      &else
  53      &indent&.return;%skip(4);
  54 (nosize):reclose:   entry (I_rcbp,I_code);
  55 
  56 &indent&.I_ptra = I_rcbp;
  57 &indent&.goto close_;
  58 
  59 (nosize):close:     entry (I_rcbp,I_code);
  60 
  61 dcl C_size label;             /* error handler for size condition */
  62 
  63 &indent&.I_ptra = I_rcbp;
  64 &indent&.I_close = &report&.$reclose;             /* inhibit further $close */
  65 &indent&.C_size = H_default;
  66 &indent&.on size goto C_size;
  67 &indent&.if (I_write_count = 0)
  68 &indent&.then goto close_;
  69 
  70      &fi
  71 
  72      &let phase_ct = &(&phase_ct+1)&;
  73      &return;
  74 &fi
  75 &error 4,Invalid argument 1.&;
  76 &expend
  77 ^L
  78 &expand break
  79 &loc dec=0&;
  80 &if &3=dec(20)float &then &let dec=1&;&fi
  81 &if &3=float dec(20) &then &let dec=1&;&fi
  82 &mrpg$rcb_put(
  83 &.       3 B_&1 &3&if &(&4>0) &then &if &dec &then &else (&4)&fi&fi                       /* level &2 break field */)&+
  84 &indent&.if (&cur_rep.I_level <= &2)
  85 &indent&.| (&cur_rep.B_&1 ^= &1)
  86 &indent&.then do;
  87 &indent&.   &cur_rep.B_&1 = &1;
  88 &indent&.   &cur_rep.I_level = min (&cur_rep.I_level, &2);
  89 &indent&.end;
  90 &if &dec&then
  91 &let initial2= &initial2
  92      &cur_rep.B_&1 = 0;&;&fi
  93 &expend
  94 ^L
  95 &expand edit
  96 &indent&.call mrpg_edit(&1,&2,&3);
  97 &expend
  98 ^L
  99 &expand end
 100 %page;&if &db_sw &then
 101 &.                                                                              /* % % mrpg$end */
 102 &fi
 103 &.
 104 &int P_skip=0&;
 105 &int P_stop=0&;
 106 &int P_bool_char=0&;
 107 &int P_bool_dec=0&;
 108 &int P_char_bool=0&;
 109 &int P_char_dec=0&;
 110 &int P_dec_bool=0&;
 111 &scan &6&;
 112 attach:
 113 &indent&.entry(I_rcbp,I_option_array,I_code);
 114 
 115 dcl I_option_array(*) char(*)var;
 116 dcl R_name char (32) int static options (constant) init ("&report");
 117 
 118 &indent&.call get_temp_segment_(R_name,I_ptra,I_code);
 119 &indent&.I_rcbp = I_ptra;
 120 
 121 &indent&.call I_init;
 122 &indent&.I_mode = &open_mode;
 123 
 124 &indent&.I_write = &report&.$write;
 125 &indent&.I_close = &report&.$close;
 126 
 127 &if &parm_sw &then
 128 &indent&.I_argno = 1;
 129 &indent&.call I_argproc(I_swarg, I_code);
 130 &fi
 131 
 132 &indent&.I_phase = -1;
 133 &indent&.I_write_count = 0;
 134 &if &1&2&3&4&5^=&then
 135 &indent&.begin;
 136 &indent&.   call mrpg_date_ (&+
 137 &if &1=&then ""&else &1&fi
 138 ,&if &2=&then ""&else &2&fi
 139 ,&if &3=&then ""&else &3&fi
 140 ,&if &4=&then ""&else &4&fi
 141 ,&if &5=&then ""&else &5&fi);
 142 dcl mrpg_date_ entry(char(12)var,char(8),char(8),char(12)var,char(5));
 143 &indent&.end;
 144 &fi
 145 &indent&.H_F.I_rec = "";
 146 &indent&.H_F.I_len, H_F.I_vlen = 0;
 147 
 148 &indent&.&cur_rep.I_next = null();
 149 
 150 &ext D_place=0&;
 151 &if &D_place &then
 152 &indent&.begin;
 153 &indent&.   ai.version = area_info_version_1;
 154 &indent&.   ai.extend = "1"b;
 155 &indent&.   ai.zero_on_alloc = "1"b;
 156 &indent&.   ai.zero_on_free = "0"b;
 157 &indent&.   ai.dont_free = "0"b;
 158 &indent&.   ai.no_freeing = "1"b;
 159 &indent&.   ai.owner = R_name;
 160 &indent&.   ai.size = sys_info$max_seg_size;
 161 &indent&.   ai.areap = null ();
 162 &indent&.   call define_area_ (addr (ai), I_code);
 163 dcl define_area_ entry (ptr, fixed bin (35));
 164 &indent&.   D_p = ai.areap;
 165 &indent&.   call get_temp_segment_(R_name,D_l,I_code);
 166 %include area_info;
 167 dcl 1 ai like area_info;
 168 dcl sys_info$max_seg_size fixed bin (24)ext static;
 169 &indent&.end;
 170 &let dclist =
 171 dcl D_place area based(D_p);
 172 dcl 1 D_list based,
 173     2 R_ecct fixed bin,
 174     2 R_ecp(4000) ptr unal;
 175 dcl R_ecptr ptr;
 176 &;
 177 &fi
 178 &indent&.return;
 179 
 180 dcl &report&.$write entry(ptr, ptr, fixed bin(21), fixed bin(35));
 181 dcl &report&.$close entry(ptr, fixed bin(35));
 182 dcl &report&.$reclose entry(ptr, fixed bin(35));
 183 &if &parm_sw &then
 184 
 185 I_swarg:
 186 &indent&.proc (code);
 187 
 188 dcl code fixed bin(35);
 189 
 190 &indent&.   I_argno = I_argno + 1;
 191 &indent&.   if (I_argno > hbound(I_option_array,1))
 192 &indent&.   then code = 1;
 193 &indent&.   else do;
 194 &indent&.      I_argp = addrel(addr(I_option_array(I_argno)),1);
 195 &indent&.      I_argl = length(I_option_array(I_argno));
 196 &indent&.      code = 0;
 197 &indent&.      if (arg = "--EOP--")
 198 &indent&.      then code = -2;
 199 &indent&.   end;
 200 
 201 dcl arg char(I_argl)based(I_argp);
 202 &indent&.end;
 203 &fi&.
 204 
 205 %page;
 206 /* - - - SUPPORT PROCEDURES - - - */
 207 P_field:     proc (P_pt, P_loc, P_ctl, P_alch, P_leng, P_data);
 208 
 209 dcl P_pt ptr,                           /* pointer to control block */
 210      P_loc fixed bin,                   /* visual location of field */
 211      P_ctl bit(9),                      /* control bits */
 212      P_alch char(1),                    /* align character */
 213      P_leng fixed bin,                  /* desired visual length */
 214      P_data char(*);                    /* data to put */
 215 
 216 dcl 1 c like H_F based(P_pt);
 217 
 218 dcl (P_i, P_j, P_l, P_vis, P_use) fixed bin;
 219 
 220 dcl 1 P defined(P_ctl),
 221      2 bsp bit(1),                      /* need BSP processing */
 222      2 left bit(1),                     /* set-left in output width */
 223      2 center bit(1),                   /* set-centered */
 224      2 right bit(1),                    /* set-right */
 225      2 align bit(1),                    /* align on character */
 226      2 numeric bit(1),                  /* value is  numeric */
 227      2 space bit(1);                    /* add space after field */
 228 dcl BSP char(1)int static init("^H");
 229 
 230       P_vis, P_use = length (P_data);
 231       if bsp                            /* field may contain BSP, */
 232       then do;                          /*  adjust visual length */
 233          P_i = 1;
 234          do while (P_i<P_use);
 235             P_j = index(substr(P_data,P_i,P_use-P_i+1),BSP);
 236             if (P_j = 0)
 237             then P_i = P_use+1;
 238             else do;
 239                P_i = P_i + P_j;
 240                P_vis = P_vis - 2;
 241             end;
 242          end;
 243       end;
 244 
 245       if (P_loc > 0)                    /* is location being specified? */
 246       then do;
 247          P_i = (P_loc-1) - c.I_vlen;
 248          if (P_i > 0)                   /* if haven't gotten that far */
 249          then do;                       /* extend record out to there */
 250             substr(c.I_rec,c.I_len+1,P_i) = " ";
 251             c.I_len, c.I_loc = c.I_len + P_i;
 252             c.I_vloc, c.I_vlen = P_loc -1;
 253          end;
 254          else if (P_i < 0)              /* go back into record?  USER BEWARE */
 255          then do;                       /* BSP will louse up positioning */
 256             P_l = P_loc;
 257             P_i = 1;
 258             do while (P_i<P_l);
 259                P_j = index(substr(c.I_rec,P_i,P_l-P_i+1),BSP);
 260                if (P_j = 0)
 261                then P_i = P_l;
 262                else do;
 263                   P_i = P_i + P_j;
 264                   P_l = P_l + 2;
 265                end;
 266             end;
 267             c.I_loc = P_l-1;
 268             c.I_vloc = P_loc;
 269          end;
 270       end;
 271       if align
 272       then do;
 273          P_i = index(P_data,P_alch);    /* look for the alignment character */
 274          if (P_i = 0)                   /* if one isn't there, assume one */
 275          then P_i = length(P_data);     /* just after last character */
 276          else P_i = P_i - 1;
 277          c.I_loc = c.I_loc - P_i;       /* back up JUST far enough */
 278          if (c.I_loc < 1)               /* did we fall off front? */
 279          then do;
 280             P_use = P_use + c.I_loc;
 281             substr(c.I_rec,1,P_use) = copy ("#",P_use);
 282             c.I_loc = P_use;
 283             P_use = 0;
 284             call com_err_(0 ,R_name,"Report ^a; page ^i; line ^i; Data truncated.", c.I_name, c.I_page, c.I_line);
 285          end;
 286          else P_vis = P_vis - P_i;      /* amount backed up does not increace visual length */
 287       end;
 288       else if (P_leng > 0)
 289       then do;
 290          P_i = P_leng - P_vis;          /* amount of padding field needs */
 291          if (P_i > 0)
 292          then do;                       /* AH! some is needed */
 293             P_use = P_use + P_i;
 294             P_vis = P_leng;
 295             if center
 296             then P_i = divide (P_i, 2, 17, 0);
 297             if right | center | ^left&&numeric
 298             then do;                    /* skip print positions if needed */
 299                substr (c.I_rec, c.I_loc+1, P_i) = " ";
 300                c.I_loc = c.I_loc + P_i;
 301                P_use = P_use - P_i;
 302             end;
 303          end;
 304          else if (P_i < 0)
 305          then do;                       /* value is TOO BIG for field */
 306             if numeric                  /* don't truncate a numeric field */
 307             then do;
 308                substr (c.I_rec, c.I_loc+1, P_leng) = copy("#",P_leng);
 309                c.I_loc = c.I_loc + P_leng;
 310                P_use = 0;
 311             end;
 312             else P_use = P_use + P_i; /* assumes none of the "extra" characters are BSP */
 313             P_vis = P_leng;
 314          end;
 315       end;
 316       substr(c.I_rec, c.I_loc+1, P_use) = P_data; /* move it in */
 317       c.I_loc = c.I_loc + P_use;
 318       /*       if space then do;
 319                substr (c.I_rec, c.I_loc+1, 1) = " ";
 320                c.I_loc = c.I_loc + 1;
 321                P_vis = P_vis + 1;
 322             end;*/
 323       c.I_vloc = c.I_vloc + P_vis;
 324       c.I_vlen = max(c.I_vlen,c.I_vloc);
 325       c.I_len = max (c.I_len,c.I_loc);
 326    end;
 327 &if &A_dec_char&then
 328 &let P_dec_char = 1&;
 329 &.^K
 330 A_dec_char:         proc(val,into,name,line)returns(char(60)var);
 331 
 332 dcl val             float dec(20),
 333     into            fixed bin,
 334     name            char(32),
 335     line            fixed bin;
 336 
 337 dcl v60             char(60)var;
 338 
 339       v60=P_dec_char(val);
 340       if (into < length(v60))
 341       then call com_err_(0,R_name,"Truncation when doing decimal/character conversion (line ^i)
 342 ^-^a := ^a;
 343      Receiving field is only ^i chars long.",
 344          line,name,v60,into);
 345       return(v60);
 346 
 347    end;
 348 &let P_dec_char=1&;
 349 &fi
 350 &if &P_int&P_dec_char^=00&then
 351 &.^K
 352 &fi
 353 &if &P_int&then
 354 P_int:    proc(val)returns(char(60)var);
 355 
 356 dcl val             fixed bin;
 357 
 358       P_64 = val;
 359 &fi
 360 &if &P_int&P_dec_char=11&then
 361 &.      goto start;
 362 
 363 &fi
 364 &if &P_dec_char&then
 365 P_dec_char:         &if &P_int&then entry&else proc&fi (dval)returns (char (60)var);
 366 
 367 dcl dval            float dec(20);
 368 
 369       P_64 = dval;
 370 &fi
 371 &if &P_int&P_dec_char=11&then
 372 start:
 373 &fi
 374 &if &P_int&P_dec_char^=00&then
 375 &.      i = verify(P_64," ");
 376       j = verify(reverse(P_64),"0");
 377       k = length(P_64)-j+1;
 378       if  (substr(P_64,k,1) = ".")
 379       then k = k - 1;
 380       v60 = substr(P_64,i,k-i+1);
 381       return(v60);
 382 
 383 dcl v60             char(60)var;
 384 dcl (i,j,k)         fixed bin;
 385 dcl verify          builtin;
 386 
 387    end;
 388 &fi
 389 &if &P_skip&then
 390 &.^K
 391 P_skip:   proc(in);
 392 
 393 dcl in              char(*);
 394 end;
 395 &fi
 396 &if &P_stop&then
 397 &.^K
 398 P_stop:   proc(in);
 399 
 400 dcl in              char(*);
 401 end;
 402 &fi
 403 &if &P_if&then
 404 &.^K
 405 P_if:     proc(log,tru,fal) returns(char(256)var);
 406 
 407 dcl log             bit(1),
 408     tru             char(*),
 409     fal             char(*);
 410 dcl res             char(256)var;
 411 
 412       if log
 413       then res = tru;
 414       else res = fal;
 415       return(res);
 416 
 417    end;
 418 &fi
 419 &if &P_bool_char&then
 420 &.^K
 421 P_bool_char:        proc(in)returns(char(5)var);
 422 
 423 dcl in               bit(1);
 424 
 425       if in
 426       then return("true");
 427       return("false");
 428 
 429    end;
 430 &fi
 431 &if &P_bool_dec&then
 432 &.^K
 433 P_bool_dec:         proc(in)returns(float dec(20));
 434 
 435 dcl in              bit(1);
 436 
 437       if in
 438       then return(1);
 439       return(0);
 440 
 441 end;
 442 &fi
 443 &if &P_char_bool&then
 444 &.^K
 445 P_char_bool:        proc(in)returns(bit(1));
 446 
 447 dcl in              char(*);
 448 
 449       if (in = "0")
 450       then return("0"b);
 451       if (in = "false")
 452       then return("0"b);
 453       return("1"b);
 454 
 455    end P_char_bool;
 456 &fi
 457 &if &P_dec_bool&then
 458 &.^K
 459 P_dec_bool:         proc(in)returns(bit(1));
 460 
 461 dcl in              float dec(20);
 462 
 463       if (in = 0)
 464       then return("0"b);
 465       return("1"b);
 466 
 467    end;
 468 &fi
 469 &if &P_char_dec&then
 470 &.^K
 471 P_cd:     proc(in)returns(float dec(20));
 472 
 473 dcl in              char(*);
 474 dcl fd              float dec(20);
 475 dcl convert builtin;
 476 
 477       return(convert(fd,in));
 478 
 479    end;
 480 &fi
 481 dcl 1 H_F_common based,                 /* DUMMY STRUCTURE */
 482       2 I_name      char(32),           /* name of report */
 483       2 I_next      ptr,                /* pointer to next control block */
 484       2 I_filno     fixed bin,          /* sequence #, if any */
 485       2 I_atd       char(200),          /* attach description */
 486       2 I_len       fixed bin,          /* last char in use in output record */
 487       2 I_vlen      fixed bin,          /* visual last char */
 488       2 I_loc       fixed bin,          /* current location in putput record */
 489       2 I_vloc      fixed bin,          /* visual current location */
 490       2 I_page      fixed bin,          /* current page # */
 491       2 I_minl      fixed bin,          /* minimum detail line # */
 492       2 I_line      fixed bin,          /* line # last printed on this page */
 493       2 I_maxl      fixed bin,          /* maximum detail line # */
 494       2 I_pl        fixed bin,          /* pagelength */
 495       2 I_pw        fixed bin,          /* pagewidth */
 496       2 E_P         fixed bin,          /* line where end-of-page leaves you */
 497       2 I_inited    bit(1),             /* first-time switch */
 498       2 I_level     fixed bin,          /* break level in this report */
 499       2 I_iocb      ptr;
 500 
 501 &mrpg$rcb_end()
 502 &let initial = &initial
 503      R_cb0.O_data_p,&;
 504 &mrpg$rcb_put(
 505 &.    2 O_ (size (&Ircb)) bit (36)      /* old input data */;)&+
 506 &comment close it all up &;
 507 dcl 1 R_cb0 based (I_ptra),
 508       2 I_mode fixed bin,                         /* allowable open mode */
 509       2 I_write entry (ptr, ptr, fixed bin (21), fixed bin (35)),
 510       2 I_close entry (ptr, fixed bin (35)),
 511       2 I_write_count fixed bin,
 512       2 I_phase fixed bin,
 513       2 I_base (&rcb_ct) ptr,           /* point to all data pieces */
 514       2 O_data_p ptr,
 515       2 N_data_p ptr,
 516       2 D_p ptr,                        /* ptr to record allocation area */
 517       2 D_l ptr,                        /* pointer to record list areas */
 518       2 D_ummy ptr;
 519 &rcb
 520 
 521 I_init: proc;
 522 &initial
 523 &initial2
 524    end I_init;
 525 
 526 dcl F_d20           float dec(20);
 527 dcl P_15            pic "(14)-9";
 528 dcl P_64            pic "(30)-9v.(30)9";
 529 dcl iox_$put_chars  entry (ptr, ptr, fixed bin (21), fixed bin (35));
 530 dcl I_ptra          ptr;
 531 dcl get_temp_segment_ entry(char(*),ptr,fixed bin(35));
 532 dcl com_err_        entry options(variable);
 533 &dclist{}
 534 dcl I_str           char(2000)based(I_irp);
 535 dcl I_i             fixed bin;
 536 &mrpg$et_()
 537 
 538 dcl (addr, copy, divide, index, length, max, min, null, reverse, substr) builtin;
 539 %page;
 540 /*        -----     macros used         -----     */
 541 &usage /* ^a>^a$^a ^-*/^/&;
 542 &indent&.end;
 543 &expend
 544 ^L
 545 &expand err
 546 &indent&.if (I_code ^= 0)
 547 &indent&.then do;
 548 &indent&.   call com_err_(I_code,R_name,"&1");
 549 &indent&.   &if &(&*=1)&then return&else goto &2&fi;
 550 &indent&.end;&expend
 551 ^L
 552 &expand et_
 553 &int et_{50}list&;
 554 &if &(&*=0)
 555 &then
 556 dcl error_table_$&et_{, fixed bin(35)ext static;
 557 dcl error_table_$} fixed bin(35)ext static;
 558 &return
 559 &fi
 560 &let et_=&1&;
 561 error_table_$&1&expend
 562 ^L
 563 &expand exec
 564 &int refct=0&;
 565 &if &db_sw &then
 566 &.                                                                              /* % % mrpg$exec &refct */
 567 &fi
 568 &if &(&refct=0)
 569 &then
 570      &let refct=1&;
 571      &let phase_ct=0&;
 572      &return
 573 &fi
 574 &if &(&refct=1)
 575 &then
 576      &let refct=2&;
 577      &if &(&phase_ct=0)&+
 578      &then
 579 &indent&.return;
 580 
 581 close:    entry (I_rcbp, I_code);
 582 
 583 &indent&.I_ptra = I_rcbp;
 584 &+   &else
 585 &.
 586 
 587 &+   &fi
 588 close_:                                                     /* close out all reports */
 589 &indent&.call &reports{,;
 590 &indent&.call };
 591 &ext D_place=0&;
 592 &indent&.begin;
 593 &if &D_place &then
 594 &indent&.   call release_area_ (D_p);
 595 dcl release_area_ entry (ptr);
 596 &indent&.   call release_temp_segment_ (R_name,D_l,I_code);
 597 &fi
 598 &indent&.   call release_temp_segment_ (R_name,I_ptra,I_code);
 599 dcl release_temp_segment_ entry(char(*),ptr,fixed bin(35));
 600 &indent&.end;
 601 &indent&.return;
 602      &return
 603 &fi
 604 &error 3,Improper sequence of calls&;
 605 &expend
 606 ^L
 607 &expand if
 608 &if &(&1=1)
 609 &then
 610 &indent&.if ( &2 )
 611 &indent&.then do;
 612 &let indent=&mrpg$indent()&;
 613 &return
 614 &fi
 615 &let indent=&mrpg$undent()&;
 616 &indent&.end;
 617 &if &(&1=3)
 618 &then &return
 619 &fi
 620 &indent&.else do;
 621 &let indent=&mrpg$indent()&;
 622 &expend
 623 ^L
 624 &expand indent
 625 &indent   &expend
 626 ^L
 627 &expand input
 628 %page;&if &db_sw &then
 629 &.                                                                              /* % % mrpg$input */
 630 &fi
 631 
 632 (nosize): write:
 633 &indent&.entry(I_rcbp,I_irp,I_irl,I_code);
 634 
 635 dcl I_rcbp ptr,                                   /* pointer to report control block */
 636      I_irp ptr,                                   /* pointer to input record */
 637      I_irl fixed bin(21),                         /* length of input record*/
 638      I_code fixed bin(35);
 639 
 640 dcl I_iri fixed bin(21);                          /* current character in input record */
 641 dcl I_ire fixed bin (21);                         /* last char to use in input record */
 642 &indent&.C_size = H_default;
 643 &indent&.if "0"b then do;
 644 H_default:
 645 &indent&. call ioa_("^a: Unexpected size condition.", R_name);
 646 &indent&.   stop;
 647 &indent&.end;
 648 &indent&.on size goto C_size;
 649 &indent&.on conversion begin;
 650 &indent&.   I_write_count = 0;          /* inhibit $close output */
 651 &indent&.   call continue_to_signal_;
 652 dcl continue_to_signal_ entry;
 653 &indent&.end;
 654 &indent&.I_ptra = I_rcbp;
 655 &indent&.I_write_count = I_write_count + 1;
 656 &indent&.I_iri = 1;
 657 &indent&.I_ire = I_irl;
 658 &indent&.if (substr (I_str, I_ire, 1) = "
 659 ") then I_ire = I_ire - 1;
 660 /************ DCL 1 INPUT */
 661 &mrpg$rcb_end()
 662 &let initial = &initial
 663      R_cb0.N_data_p,&;
 664 &mrpg$rcb_put(
 665 &.    2 I_,                   /* ----- input data ----- */)&+
 666 &let Ircb=R_cb&rcb_ct&;&expend
 667 ^L
 668 &expand input_field
 669 &loc pos=&3&;
 670 &loc field=&2&;
 671 &loc kind=&4&;
 672 &loc leng=&5&;
 673 &loc delim=&6&;
 674 &loc SPEC=0&;
 675 &loc DEC=0&;
 676 &loc opt&;&+
 677 
 678 
 679 &if &kind=varying char&+
 680 &then &let SPEC=1&;
 681 &fi&+
 682 
 683 
 684 &if &kind=dec(20)float&+
 685 &then &let SPEC=1&;
 686      &let DEC=1&;
 687 &fi&+
 688 
 689 
 690 &if &kind=float dec(20)&+
 691 &then &let DEC=1&;
 692 &fi&+
 693 
 694 
 695 &if &(&leng < 0)
 696 &then &let leng=&substr &leng,2&;&;
 697       &let opt= -OPT-&;
 698 &fi
 699 
 700 /*(line &1)     , 2 &field &+
 701 &if     &kind=varying char&+
 702 &then   char (&(&leng)) SPEC&+
 703 &else   &kind&+
 704      &if &leng^=0&+
 705      &then &. (&(&leng))&+
 706      &fi&+
 707 &fi&+
 708 &if &delim^=&+
 709 &then &. DELIM &delim&+
 710    &if &delim="
 711 "&+
 712    &then &let opt= -OPT-&;&+
 713    &fi&+
 714 &fi  &+
 715 &if &pos^=0&+
 716 &then POS &pos &+
 717 &fi&+
 718 &opt&+
 719 &if &db_sw&+
 720 &then &.  [mrpg$input_field]&+
 721 &fi */
 722 &+
 723 
 724 &if |&kind|=| FILL|&then
 725 &indent&.I_iri = I_iri + &leng;
 726 
 727 &return
 728 &fi&+
 729 
 730 
 731 &loc sz=&.(&leng)&;
 732 &if &kind=dec(20)float&then &let sz=&;&fi
 733 &if &kind=float dec(20)&then &let sz=&;&fi
 734 &mrpg$rcb_put(
 735 &.      3 &field &kind &sz)
 736 &if &pos^=0&+
 737 &then&indent&.I_iri = &pos;
 738 &fi
 739 &indent&.if (I_iri <= I_ire)
 740 &indent&.then do;
 741 &if &delim=&+
 742 &then &if &SPEC
 743       &then&+
 744             &let dclist = dcl I_fd30 fixed dec (3, 0) based;
 745 &;&+
 746             &indent&.   I_i = addr(I_car(I_iri))->I_fd30;
 747 &.          &let dclist = dcl I_car(2000)char(1)unal based(I_irp);
 748 &;&+
 749             &indent&.   I_iri = I_iri + 4;
 750 &+          &let leng=I_i&;
 751 &+    &fi&+
 752       &indent&.   &field = &+
 753       &if &DEC&+
 754       &then convert(F_d20,substr(I_str,I_iri,&leng))&+
 755       &else substr(I_str,I_iri,&leng)&+
 756       &fi;
 757 &+    &indent&.   I_iri = I_iri + &leng;
 758 &+    &indent&.   if (I_iri > I_ire +1)
 759 &+    &indent&.   then do;
 760 &+    &indent&.      call ioa_ ("^a: Record exhausted. Field &field is defined as length ^i, but there were not that many chars left in record.", R_name, &leng);
 761 &+    &indent&.      return;
 762 &+    &indent&.   end;
 763 &else&comment delim^= "" &;&+
 764 &+    &indent&.   I_i = index(substr(I_str,I_iri,I_ire-I_iri+1),&delim);
 765 &+    &indent&.   if (I_i ^= 0)
 766 &+    &indent&.   then I_i = I_i - 1;             /* take next part */
 767 &+    &indent&.   else I_i = I_ire - I_iri + 1;   /* take the rest */
 768 &+    &indent&.   &field = &+
 769       &if &DEC&+
 770             &then convert(F_d20, substr(I_str,I_iri,I_i))&+
 771             &else substr(I_str,I_iri,I_i)&+
 772       &fi;
 773 &+    &indent&.   I_iri = I_iri + I_i + &length &unquote &delim&;&;;
 774 &fi
 775 &indent&.end;
 776 &if &opt=-OPT-&+
 777 &then &indent&.else &field = &if &DEC &then 0&else ""&fi;
 778 &else &indent&.else do;
 779 &+    &indent&.   call ioa_ ("^a: Non-optional field &field missing.", R_name);
 780 &+    &indent&.   return;
 781 &+    &indent&.end;
 782 &fi&+
 783 &expend
 784 undent
 785 ^L
 786 &expand line
 787 &if &db_sw &then
 788 &.                                                                              /* % % mrpg$line(&rep_no) &1 &2 */
 789 &fi
 790 &if &1=1&+
 791 &then
 792      &int absline&;
 793      &int relline&;
 794      &int ctl&;
 795      &if &(&2 < 0)
 796      &then
 797           &let absline=&(-(&2))&;
 798           &let relline=0&;
 799      &else
 800           &let absline = 0&;
 801           &let relline=&2&;
 802      &fi
 803      &if &3=&+
 804      &then
 805           &let ctl=0&;
 806      &else
 807           &let ctl=1&;
 808 &indent&.if (&3)
 809 &indent&.then do;
 810 &+        &let indent = &mrpg$indent()&;
 811      &fi
 812      &return
 813 &fi
 814 
 815 &if &1=2&+
 816 &then
 817 &if &[index " DH DT DF " &rep_no]^=0&then
 818 &indent&.call P_line (&if &db_sw&then mrpg_get_ln_(),&fi&.&if &relline^=0&then &cur_rep.I_line + (&relline-1)&else &absline&fi);
 819 &else
 820 &indent&.call P_chars (&if &db_sw&then mrpg_get_ln_(),&fi&.addr (&cur_rep),addr(H_F),&if &relline^=0&then &cur_rep.I_line + &(&relline-1)&else &absline&fi);
 821 &fi
 822 &+   &if &ctl=1&+
 823      &then
 824      &let indent = &mrpg$undent()&;
 825 &indent&.end;
 826 &+   &fi
 827      &return
 828 &fi
 829 &error 3,mrpg$line: first parameter not 1|2&;
 830 &expend
 831 ^L
 832 &comment xxx field pos kind leng delim
 833          &1  &2    &3  &4   &5   &6    &;
 834 &expand local
 835 &if &local=0
 836 &then &let local=1&;
 837 &mrpg$rcb_end()
 838 &mrpg$rcb_put(
 839 /* ----- local data variables ----- */)&+
 840 &fi
 841 &if &substr &2,1,5&;=&then &return&fi
 842 &mrpg$rcb_put(
 843 &.      2 &2 &4&if &(&5>0)&then &. (&5)&fi&if &(&1>0) &then &.                  /* line &1 */&fi)&+
 844 &if &4=float dec(20)&then
 845      &let initial2=&initial2
 846      &2 = 0;&;
 847 &fi
 848 &expend
 849 ^L
 850 &expand on
 851 &int count=0&;
 852 &if &count=3&+
 853 &then &let count=0&;
 854       &let label=0&;
 855 &fi
 856 &int label=0&;
 857 &loc ELS=&if &count>0&then else &fi&;
 858 &if &3^=&+
 859 &then &+
 860       &indent&.&ELS&.if (&3)
 861 &+    &indent&.then do;
 862 &else &let count=3&;&+
 863       &indent&.&ELS&.do;
 864 &fi
 865 &if &count=0&then &let count=1&;&fi
 866 &if &1=SW&+
 867 &then &if &2="user_output"&+
 868       &then
 869 &indent&.   &cur_rep.I_iocb = iox_$user_output;
 870 &indent&.   &cur_rep.I_atd = "user_output";
 871 &indent&.   &cur_rep.E_P, &cur_rep.I_line = 1;
 872 &let dclist = dcl iox_$user_output ptr ext static;
 873 &;
 874 &indent&.end;
 875 &return
 876       &fi
 877 &fi
 878 &indent&.   &cur_rep.I_atd = &if &1=FL&then "vfile_ " || &fi&2;
 879 &indent&.   &cur_rep.I_filno = &4;
 880 &if &label
 881 &then
 882 &indent&.   goto att;
 883 &else &let label=1&;
 884 att:
 885 &let indent = &indent   &;
 886 &indent&.call iox_$attach_name("&report.&cur_rep",&cur_rep.I_iocb,&cur_rep.I_atd,null(),I_code);
 887 &mrpg$err(Attaching &report.&cur_rep.)
 888 &indent&.if (substr(&cur_rep.I_atd,1,5) ^= "syn_")
 889 &indent&.then call iox_$open (&cur_rep.I_iocb,2,"0"b,I_code);
 890 &let dclist = dcl iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35));
 891 &;
 892 &let dclist = dcl iox_$open entry (ptr, fixed bin, bit(2), fixed bin (35));
 893 &;
 894 &let dclist = dcl iox_$close entry (ptr, fixed bin(35));
 895 &;
 896 &let dclist = dcl iox_$detach_iocb entry (ptr, fixed bin(35));
 897 &;
 898 &mrpg$err(Opening &report.&cur_rep.)
 899 &indent&.&cur_rep.E_P, &cur_rep.I_line = 4;
 900 &let indent = &mrpg$undent()&;
 901 &fi
 902 &indent&.end;
 903 &if &count=0&then &let count=1&;&fi
 904 &expend
 905 ^L
 906 &expand parm_begin
 907 &if &db_sw&then
 908 &.                                                                              /* % % mrpg$parm_begin */
 909 &fi
 910 ^K
 911 /* DO argument processing */
 912 dcl I_argno fixed bin;
 913 dcl I_argp ptr;
 914 dcl I_argl fixed bin;
 915 dcl I_arg char(I_argl)based(I_argp);
 916 I_argproc:
 917 &indent&.proc(I_get_arg,code);
 918 &let indent = &mrpg$indent()&;
 919 &.
 920 dcl I_get_arg entry (fixed bin(35)) parm,
 921      code fixed bin(35) parm;
 922 
 923 &ext parmct=&(&1+&2)&;
 924 dcl I_present (&parmct) bit (1) init ((&parmct) (1)"0"b);
 925 
 926 dcl I_pos_no fixed bin;
 927 
 928 &indent&.I_error = "0"b;
 929 &indent&.I_pos_no = 0;
 930 &indent&.code = 0;
 931 I_argloop:
 932 &indent&.call I_get_arg (code);
 933 &indent&.if (code ^= 0)
 934 &indent&.then do;
 935 &indent&.   if (code = -2)
 936 &indent&.   then do;
 937 &indent&.      code = 0;
 938 &indent&.      return;
 939 &indent&.   end;
 940 &indent&.   goto I_argdone;
 941 &indent&.end;
 942 &indent&.if (substr(I_arg,1,1) ^= "-")
 943 &indent&.then do;
 944 &indent&.   I_pos_no = I_pos_no + 1;
 945 &if &(&1>0)&then
 946 &indent&.   if (I_pos_no <= &1)
 947 &indent&.   then goto I_positional(I_pos_no);
 948 &indent&.   call com_err_(0,R_name,"Too many positional arguments");
 949 &else
 950 &indent&.   call com_err_(0,R_name,"No positional arguments allowed.");
 951 &fi
 952 &indent&.   goto I_exit;
 953 &indent&.end;
 954 &expend
 955 ^L
 956 &expand parm_check
 957 &if &db_sw &then
 958 &.                                                                              /* % % mrpg$parm_check */
 959 &fi
 960 &int ELSE&;
 961 &loc Indent&;
 962 &loc num&;
 963 &if &(&*^=0)
 964 &then &if &(&3=-1)
 965 &then
 966 &mrpg$rcb_put(
 967 &.      2 &1 bit(1))
 968 &else &if &(&3=0)
 969       &then
 970 &mrpg$rcb_put(
 971 &.      2 &1 char(256)var)
 972       &else
 973 &mrpg$rcb_put(
 974 &.      2 &1 char(&3))
 975 &+      &fi
 976 &fi
 977 &.
 978 &let keylist{&2}=&1&;
 979 &if &(&*=3)
 980 &then I_positional(&2):
 981 &let Indent=&indent&;
 982 &else
 983 &indent&.&ELSE&.if (I_arg = &4)
 984 &let ELSE = else &;
 985 &let num=5&;
 986 &do
 987     &while &(&num <= &*)&;
 988 &indent&.| (I_arg = &{&num})
 989 &+  &let num = &(&num+1)&;
 990 &od
 991 &indent&.then do;
 992 &let Indent=&indent&.   &;
 993 &fi
 994 &if &((&*>3) * (&3>=0))
 995 &then
 996 &Indent&.call I_get_arg(code);
 997 &Indent&.if (code ^= 0)
 998 &Indent&.then do;
 999 &Indent&.   call com_err_(code,R_name,"Value for &unquote &4&;");
1000 &Indent&.   return;
1001 &Indent&.end;
1002 &fi
1003 &if &(&3=-1)
1004 &then
1005 &Indent&1 = "1"b;
1006 &else
1007 &Indent&1 = I_arg;
1008 &fi
1009 &Indent&.I_present(&2) = "1"b;
1010 &if &(&* ^= 3)
1011 &then
1012 &indent&.end;
1013 &else
1014 &indent&.goto I_argloop;
1015 &fi
1016 &.
1017 &else
1018 &indent&.else do;
1019 &indent&.   call com_err_(&mrpg$et_(badopt),R_name,"^a",I_arg);
1020 &indent&.   I_error = "1"b;
1021 &indent&.end;
1022 &indent&.goto I_argloop;
1023 
1024 &fi&.
1025 &expend
1026 ^L
1027 &expand parm_default
1028 &if &db_sw&then
1029 &.                                                                              /* % % mrpg$parm_default */
1030 &fi
1031 &if &(&argdone=0)
1032 &then
1033 I_argdone:
1034 &indent&.code = 0;
1035 &let argdone=1&;
1036 &fi
1037 
1038 &.        if ^I_present(&2)
1039 &indent&.then do;
1040 &.             &1 = &4;
1041 &.             I_present(&2) = "1"b;
1042 &indent&.end;
1043 &expend
1044 ^L
1045 &expand parm_end
1046 &if &db_sw &then
1047 &.                                                                              /* % % mrpg$parm_end */
1048 &fi
1049 &.
1050 dcl I_parameter(&parmct) char(&1) int static init(
1051 "&keylist{,",
1052 "}" );
1053 &if &(&argdone=0)
1054 &then
1055 &.
1056 I_argdone:
1057 &indent&.code = 0;
1058 &let argdone=1&;
1059 &fi
1060 &indent&.do I_i = 1 to &parmct;
1061 &indent&.   if ^I_present(I_i)
1062 &indent&.   then do;
1063 &indent&.      I_error = "1"b;
1064 &indent&.      call com_err_(0,R_name,"Parameter ""^a"" missing.",I_parameter(I_i));
1065 &indent&.   end;
1066 &indent&.end;
1067 &indent&.if I_error
1068 &indent&.then code = 1;
1069 &let indent = &mrpg$undent()&;
1070 &indent&.end;
1071 
1072 /* END parameter processing */
1073 
1074 &expend
1075 ^L
1076 &expand picture
1077 &int PIC{300}&;
1078 &int pic_ct=0&;
1079 &let pic_ct=&(&pic_ct+1)&;
1080 &let PIC{&pic_ct}=&3&;
1081 &loc i=0&;
1082 &do &let i=&(&i+1)&;
1083   &while  &PIC{&i}^=&3&;
1084 &od
1085 &if &pic_ct=&i
1086 &then
1087   &let dclist=dcl P_IC&pic_ct pic&3;
1088 &;
1089 &fi
1090 &indent&.C_size = H_pic&pic_ct;
1091 &indent&.(size):&1 = convert(P_IC&i,&2);          /* &3 */
1092 &indent&.if "0"b then do;
1093 H_pic&pic_ct:
1094 &indent&.   call ioa_("^a: The value of &2 (^f) does not fit in picture "&3"",
1095 &indent&.      R_name, &2);
1096 &indent&.   &1 = "**";
1097 &indent&.end;
1098 &indent&.C_size = H_default;
1099 &expend
1100 ^L
1101 &expand print
1102 &indent&.call X_&1;
1103 &expend
1104 ^L
1105 &expand proc
1106 &ext db_sw=&7&;
1107 &ext parm_sw=&8&;
1108 &if &db_sw &then
1109 &.                                                                              /* % % mrpg$proc */
1110 &fi
1111 &ext rep_no=0&;&+
1112 &ext reports{25}list&;
1113 &ext cur_rep=H_F&;
1114 &ext break_no&;
1115 &ext report=&3&;
1116 &ext keylist{50}var&;
1117 &ext argdone=0&;
1118 &ext dclist{100}list&;
1119 &ext P_int=0&;
1120 &ext P_if=0&;
1121 &ext P_dec_char=0&;
1122 &ext A_dec_char=0&;
1123 &ext phase_ct = -1&;
1124 &ext report=&3&;
1125 &ext initial&;
1126 &ext initial2&;
1127 &ext indent=&.       &;
1128 &ext open_mode&;
1129 &let open_mode=&if &5=-2&+
1130 &then 2&+
1131 &else 5&+
1132 &fi&;
1133 /*
1134 &indent&.GENERATED FROM &2>&3.mrpg
1135 &indent&.Generated by : &1
1136 &indent&.Generated on : &unquote &[date_time]&;&.
1137 */
1138 
1139 &report:  proc;
1140 
1141 dcl M_version char(32);
1142           M_version = "&1";
1143 
1144 dcl I_error bit (1);
1145 dcl (size, conversion) condition;
1146 
1147 &let dclist = dcl ioa_ entry options (variable);
1148 &;&+
1149 &if &4V=V&+
1150 &then
1151 &.        call com_err_ (0, R_name, "This report cannot be called as
1152      a command since the INPUT specification contained neither the
1153      FILE nor the ATTACH option in &report.mrpg.");
1154 &else
1155 &loc read =
1156       &if &5=-1&+
1157       &then read_record&+
1158       &else &if &5=-2&+
1159             &then get_line&+
1160             &else get_line&+
1161             &fi
1162       &fi&;
1163 &loc write =
1164       &if &5=-1&+
1165       &then write_record&+
1166       &else put_chars&+
1167       &fi&;
1168 &if &parm_sw &then
1169 &indent&.call cu_$arg_list_ptr (I_arglp);
1170 &let dclist = dcl cu_$arg_list_ptr entry (ptr);
1171 &;
1172 &fi
1173 &indent&.call cu_$arg_count (I_i);
1174 &let dclist = dcl cu_$arg_count entry (fixed bin);
1175 &;
1176 &indent&.begin;
1177 &let indent=&mrpg$indent()&;
1178 dcl buff char (&scan &&+&6&;);
1179 dcl cleanup condition;
1180 dcl I_code fixed bin (35);
1181 dcl recl fixed bin (21);
1182 dcl error_table_$end_of_info fixed bin (35)ext static;
1183 dcl iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35));
1184 dcl iox_$open entry (ptr,fixed bin,bit (1),fixed bin (35));
1185 dcl iox_$&read entry (ptr,ptr,fixed bin (21),fixed bin (21),fixed bin (35));
1186 dcl iox_$&write entry (ptr,ptr,fixed bin (21),fixed bin (35));
1187 dcl iox_$close entry (ptr,fixed bin (35));
1188 dcl iox_$detach_iocb entry (ptr,fixed bin (35));
1189 dcl unique_bits_ entry returns (bit (70));
1190 dcl unique_chars_ entry (bit (*)) returns (char (15));
1191 dcl sn char (15);
1192 dcl icbp ptr;
1193 dcl ocbp ptr;
1194 %include iocb;
1195 
1196 
1197 &indent&.icbp, ocbp, I_ptra = null ();
1198 &indent&.on condition (cleanup) begin;
1199 &indent&.   if (I_ptra ^= null ())
1200 &indent&.   then I_write_count = 0;
1201 &indent&.   if (icbp ^= null ())
1202 &indent&.   then do;
1203 &indent&.      call iox_$close (icbp, 0);
1204 &indent&.      call iox_$detach_iocb (icbp, 0);
1205 &indent&.      icbp = null();
1206 &indent&.   end;
1207 &indent&.   if (ocbp ^= null ())
1208 &indent&.   then do;
1209 &indent&.      call iox_$close (ocbp, 0);
1210 &indent&.      call iox_$detach_iocb (ocbp, 0);
1211 &indent&.      ocbp = null();
1212 &indent&.   end;
1213 &indent&.end;
1214 &indent&.sn = unique_chars_ (unique_bits_ ());
1215 &indent&.call iox_$attach_name (sn||"_o", ocbp, "report_ &report --EOP--", null(), I_code);
1216 &mrpg$err(Attach output)
1217 &indent&.I_ptra = ocbp->attach_data_ptr;
1218 &if &parm_sw &then
1219 &indent&.I_argno = 0;
1220 &indent&.call I_argproc (I_cmdarg,I_code);                  /* process arguments */
1221 &indent&.if (I_code ^= 0)
1222 &indent&.then goto dto;
1223 &else
1224 &indent&.if (I_i > 0)
1225 &indent&.then do;
1226 &indent&.   call com_err_ (&mrpg$et_(too_many_args),R_name);
1227 &indent&.   goto dto;
1228 &indent&.end;
1229 &let dclist = dcl cu_$arg_count entry (fixed bin);
1230 &;
1231 &fi
1232 &indent&.call iox_$open (ocbp,&open_mode, "0"b, I_code);
1233 &mrpg$err(Open output,dto)
1234 
1235 &indent&.call iox_$attach_name (sn||"_i", icbp, &4, null(), I_code);
1236 &mrpg$err(Attach input,clo)
1237 &indent&.call iox_$open (icbp,&(&open_mode-1), "0"b, I_code);
1238 &indent&.if (I_code ^= 0)
1239 &indent&.then do;
1240 &indent&.   call com_err_ (I_code, R_name, "Trying to open ^a",&4);
1241 &indent&.   goto dti;
1242 &indent&.end;
1243 
1244 loop:
1245 &indent&.call iox_$&read (icbp,addr (buff),length (buff),recl,I_code);
1246 &indent&.if (I_code = error_table_$end_of_info)
1247 &indent&.then goto quit;
1248 &mrpg$err(On input,cli)
1249 &indent&.call iox_$&write (ocbp,addr (buff),recl,I_code);
1250 &mrpg$err(On output,cli)
1251 &indent&.goto loop;
1252 
1253 quit:
1254 cli:
1255 &indent&.call iox_$close (icbp, 0);
1256 dti:
1257 &indent&.call iox_$detach_iocb (icbp, 0);
1258 clo:                                    /* there is trouble if records are being held, this $close is done,             */
1259                                         /* ..QUIT is hit while the report is printing, and then release is typed.       */
1260                                         /* So we must insure that the cleanup handler doesn't $close again.             */
1261 &indent&.begin;
1262 dcl tp ptr;
1263 &indent&.   tp = ocbp;
1264 &indent&.   ocbp = null();
1265 &indent&.   call iox_$close (tp, 0);
1266 &indent&.end;
1267 dto:
1268 &indent&.call iox_$detach_iocb (ocbp, 0);
1269 
1270 &if &parm_sw &then
1271 I_cmdarg:
1272 &indent&.proc (code);
1273 
1274 dcl code fixed bin (35);
1275 
1276 
1277 &let indent=&mrpg$indent()&;
1278 &indent&.I_argno = I_argno + 1;
1279 &indent&.call cu_$arg_ptr_rel (I_argno,I_argp,I_argl,I_code,I_arglp);
1280 
1281 dcl cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr);
1282 
1283 &let indent=&mrpg$undent()&;
1284 &indent&.end;
1285 dcl cu_$arg_list_ptr entry (ptr);
1286 &fi
1287 &let indent=&mrpg$undent()&;
1288 &indent&.end;
1289 dcl I_arglp ptr;
1290 &fi
1291 I_exit:
1292 &indent&.return;
1293 &ext new_phase=/* Initialize for phase begin */
1294 &;
1295 &ext local=0&;
1296 &ext rcb_lines=0&;
1297 &ext rcb&;
1298 &ext last_rcb=0&;
1299 &ext Ircb=***&;
1300 &ext rcb_ct=0&;
1301 &mrpg$rcb_put(&mrpg$rcb(H_F,work area for building headers/footers,256))
1302 &mrpg$rcb_end()
1303 &mrpg$rcb_put(
1304 /* ----- parameters ----- */)
1305 &expend
1306 ^L
1307 &expand rcb
1308 &if &3^=500&then
1309 &if &3^=256&then
1310       &[signal rcb_error]
1311 &fi &fi
1312 &let initial2 = &initial2
1313      &1.I_name = "&1";&;
1314 &.    2 &1                                        /* &2 */,
1315       3 I_H_F like H_F_common,
1316       3 I_rec char(&3)                            /* record area */&expend
1317 ^L
1318 &expand rcb_begin
1319 &let rcb_ct=&(&rcb_ct+1)&;
1320 &let initial = &initial
1321      R_cb0.I_base(&rcb_ct) = addr (R_cb&last_rcb.D_ummy);&;
1322 &let last_rcb = &rcb_ct&;
1323 &let rcb_lines=0&;
1324 &let rcb = &rcb
1325 dcl 1 R_cb&rcb_ct based (R_cb0.I_base(&rcb_ct))&;
1326 &expend
1327 ^L
1328 &expand rcb_end
1329 &if &rcb_lines=0&+
1330 &then&return
1331 &fi
1332 &let rcb_lines=0&;
1333 &let rcb = &rcb,
1334     2 D_ummy ptr;             /* get a double word alignment */
1335 &;&expend
1336 ^L
1337 &expand rcb_put
1338 &if &rcb_lines=250&+
1339 &then &mrpg$rcb_end()
1340 &fi
1341 &if &rcb_lines=0&+
1342 &then &mrpg$rcb_begin()
1343 &fi
1344 &let rcb_lines=&(&rcb_lines+1)&;
1345 &let rcb = &rcb&if&substr &1,1,2&;^=/*&then,&fi&.
1346 &1&;&expend
1347 ^L
1348 &expand rep_break
1349 &if &db_sw &then
1350 &.                                                                              /* % % mrpg_$rep_break */
1351 &fi
1352 &let break_no=&(&break_no+1)&;
1353 
1354 &mrpg$rcb_put(
1355 &.    4 &1 &2&;)
1356 
1357 &if &break_no= 1
1358 &then &indent&.string(&cur_rep.I_level) = "0"b;
1359 &fi
1360 &indent&.&if &break_no^=1&then else &;if (&cur_rep.&1 ^= I.&1)
1361 &indent&.then do;
1362 &indent&.   substr(string(&cur_rep.I_level),&break_no+1) = "11111111111111111111111111111111"b;
1363 &indent&.end;
1364 
1365 &expend
1366 ^L
1367 &expand rep_head
1368 &if &db_sw &then
1369 &.                                                                              /* % % mrpg$rep_head */
1370 &fi&.
1371 
1372 &indent&.if &cur_rep.I_first
1373 &indent&.then do;
1374 &indent&.   &cur_rep.I_first = "0"b;
1375 
1376 &expend
1377 ^L
1378 &expand report
1379 &if &1=PF&then&.%page;&fi
1380 &+
1381 
1382 
1383 &if &db_sw &then
1384 &.                                                                              /* % % mrpg$report &1 */
1385 &fi&+
1386 
1387 
1388 &int undent=0&;&+
1389 
1390 
1391 &if &rep_no=RF&+
1392 &then
1393 &indent&.call P_line (&if &db_sw&then mrpg_get_ln_(),&fi&.0);
1394 &indent&.return;
1395 &let indent = &mrpg$undent()&;
1396 &indent&.end;
1397 &.
1398 &fi&+
1399 
1400 &do &while&(&undent>0)&;
1401 &let undent=&(&undent-1)&;
1402 &let indent = &mrpg$undent()&;
1403 &indent&.end;
1404 &od&+
1405 
1406 
1407 &let rep_no=&1&;
1408 &if &1=PF&+
1409 &then
1410 &int detail=0&;
1411 &let detail=1&;
1412 &ext first_rep=&2&;
1413 &let reports=C_&2&;
1414 &let initial2 = &initial2
1415      &cur_rep.I_next = addr(&2);
1416 &;
1417 &let cur_rep=&2&;
1418 &let new_phase = &new_phase   &cur_rep.I_level = -1;
1419 &;&+
1420 
1421 
1422 &let break_no=0&;
1423 
1424 &int pagelength&;
1425 &let pagelength=&4&;
1426 &let initial2=&initial2
1427      &cur_rep.I_level = 999;
1428      &cur_rep.I_minl = &5;
1429      &cur_rep.I_maxl = &6;
1430      &indent&cur_rep.I_pl = &4;
1431      &cur_rep.I_pw = &3;
1432      &cur_rep.I_inited = "0"b;
1433 &;
1434 
1435 &mrpg$rcb_end()
1436 &mrpg$rcb_put(
1437 /* ----- report data ----- */)
1438 &mrpg$rcb_put(&mrpg$rcb(&cur_rep,data fields for REPORT &cur_rep,500))&+
1439 &int put_chars=1&;
1440 &if &put_chars &then
1441 &let put_chars=0&;
1442 P_chars:     proc(&if &db_sw&then lno,&fi&.rcbp,lcbp,lin);
1443 
1444 &if &db_sw&then dcl lno                 fixed bin(18);
1445 &fi
1446 dcl rcbp            ptr,                /* report control block */
1447      lcbp           ptr,                /* line control block */
1448      lin            fixed bin;          /* line on which to print */
1449 
1450 dcl 1 r like H_F based(rcbp);
1451 dcl 1 l like H_F based(lcbp);
1452 dcl i fixed bin (21);
1453 
1454 &if &db_sw &then
1455 &let dclist = dcl iox_$user_output      ptr ext static;
1456 &;&let dclist = dcl mrpg_get_ln_        entry returns(fixed bin(18));
1457 &;&let dclist = dcl ioa_      entry options(variable);
1458 &;&let dclist = dbn: entry; db_sw = "1"b; return;
1459 &;&let dclist = dbf: entry; db_sw = "0"b; return;
1460 &;&let dclist = dcl db_sw     bit(1) int static init("0"b);
1461 &;
1462 &fi
1463 &if &db_sw &then
1464 /* ## */ if db_sw then call ioa_("^i: ^p ^p ^i ^i ^i ^i",lno,rcbp,lcbp,lin,r.I_line,l.I_len,l.I_vlen);
1465 &fi
1466 &.      if (r.I_pl ^= 0)
1467       then do;
1468          if (lin = 0)
1469          then i = r.E_P - r.I_line;
1470          else i = max (lin, r.E_P) - r.I_line;
1471       end;
1472       else i = lin - r.I_line;
1473       if (i < 0)
1474       then do;
1475          if (r.E_P = 4)
1476          then do;
1477             call iox_$put_chars (r.I_iocb, addr(FF), 1, I_code);
1478 &if &db_sw &then
1479 /* ## */ if db_sw then call iox_$put_chars(iox_$user_output, addr(FF),1,0);
1480 &fi
1481 &.         i = min (0, lin-4);
1482          end;
1483          else i = r.I_pl - r.I_line + lin;
1484       end;
1485       if (i > 0)
1486       then begin;
1487 dcl ch              char(i);
1488           ch = copy(NL,i);
1489                          call iox_$put_chars(r.I_iocb,addr(ch),i,I_code);
1490 &if &db_sw &then
1491 /* ## */ if db_sw then call iox_$put_chars(iox_$user_output,addr(ch),i,0);
1492 &fi
1493 &.      end;
1494       if (lin > 0)
1495       then do;
1496          substr(l.I_rec,l.I_len+1,1) = NL;
1497          call iox_$put_chars(r.I_iocb,addr(l.I_rec),l.I_len+1,I_code);
1498 &if &db_sw &then
1499 /* ## */ if db_sw then call iox_$put_chars(iox_$user_output,addr(l.I_rec),l.I_len+1,0);
1500 &fi
1501 &.         r.I_line = max(r.E_P, lin) + 1;
1502       end;
1503       else if (r.I_pl ^= 0)
1504       then r.I_line = r.E_P;
1505       else r.I_line = lin + 1;
1506       l.I_len = 0;
1507       l.I_vlen = 0;
1508       l.I_loc = 0;
1509       l.I_vloc = 0;
1510       l.I_rec = "";
1511 dcl FF              bit(9) int static init ("014"b3);
1512 dcl NL              char(1) int static init("
1513 ");
1514    end P_chars;
1515 &.%page;&fi
1516 &.                                      /* DEFINE 1 REPORT &cur_rep */
1517 X_&cur_rep:
1518 &indent&.proc;
1519 &let indent = &mrpg$indent()&;
1520 &.
1521 
1522 P_line:
1523 &indent&.proc (&if &db_sw&then lno,&fi&.lin);
1524 
1525 &if &db_sw&then dcl lno fixed bin(18);
1526 &fi
1527 dcl lin fixed bin;
1528 
1529 dcl W_line fixed bin;
1530 
1531 &let indent = &mrpg$indent()&;
1532 &if &db_sw &then
1533 /* ## */ if db_sw then call ioa_("&cur_rep ^i: ^i ^i",lno,lin,&cur_rep.I_minl);
1534 &fi
1535 &if &pagelength
1536 &then
1537 &indent&.if (lin = 0)
1538 &indent&.then do;
1539 &indent&.   if (&cur_rep.I_line = &cur_rep.E_P)
1540 &indent&.   then return;                          /* already at E_P */
1541 &indent&.   goto I_pagefoot;
1542 &indent&.end;
1543 &indent&.W_line = max (lin, &cur_rep.I_minl);
1544 &indent&.if (&cur_rep.I_line = &cur_rep.E_P)
1545 &indent&.then goto I_pagehead;
1546 &indent&.if (W_line > &cur_rep.I_maxl)
1547 &indent&.| (&cur_rep.I_page = 0)
1548 &indent&.then do;
1549 &let indent = &mrpg$indent()&;
1550 &indent&.W_line = &cur_rep.I_minl;
1551 I_pagefoot:
1552 &indent&.if (&cur_rep.I_page > 0)
1553 &indent&.then do;
1554 &let indent = &mrpg$indent()&;
1555 &fi
1556 &return
1557 &fi&+
1558 
1559 
1560 &if &1=PH&+
1561 &then
1562 &if &pagelength
1563 &then
1564 &indent&.call P_chars (&if &db_sw&then mrpg_get_ln_(), &fi addr (&cur_rep), addr (H_F), 0);
1565 &let indent = &mrpg$undent()&;
1566 &indent&.end;
1567 &indent&.if (lin ^= 0)
1568 &indent&.then do;
1569 &let indent = &mrpg$indent()&;
1570 I_pagehead:
1571 &indent&.&cur_rep.I_page = &cur_rep.I_page + 1;
1572 &fi
1573 &return
1574 &fi&+
1575 
1576 
1577 &if &1=ON&+
1578 &then
1579 &if &pagelength
1580 &then
1581 &indent&.W_line = max (W_line, &cur_rep.I_line);
1582 &let indent = &mrpg$undent()&;
1583 &indent&.end;
1584 &let indent = &mrpg$undent()&;
1585 &indent&.end;
1586 &indent&.if (lin = 0)
1587 &indent&.then return;
1588 &else
1589 &indent&.W_line = lin;
1590 &indent&.&cur_rep.I_page = 1;           /* show we've started output */
1591 &fi
1592 &indent&.call P_chars (&if &db_sw&then mrpg_get_ln_(), &fi addr (&cur_rep), addr (&cur_rep), W_line);
1593 &mrpg$err(Put to REPORT &cur_rep)
1594 &let indent = &mrpg$undent()&;
1595 &indent&.end;
1596 
1597 E_nvir:        proc;
1598 &let indent = &mrpg$indent()&;
1599 &indent&.if ^&cur_rep.I_inited
1600 &indent&.then do;
1601 &let indent = &mrpg$indent()&;
1602 &indent&.&cur_rep.I_inited = "1"b;
1603 &return
1604 &fi&+
1605 
1606 
1607 &if &1=BR&+
1608 &then
1609 &indent&.&cur_rep.I_page = 0;
1610 &indent&.&cur_rep.I_len = 0;
1611 &indent&.&cur_rep.I_vlen = 0;
1612 &indent&.&cur_rep.I_loc = 0;
1613 &indent&.&cur_rep.I_vloc = 0;
1614 &let indent = &mrpg$undent()&;
1615 &indent&.end;
1616 &return
1617 &fi&+
1618 
1619 
1620 &if &1=DF&+
1621 &then
1622 &indent&.if (&cur_rep.I_level <= &2) && (&cur_rep.I_page > 0)
1623 &indent&.then begin;
1624 dcl 1 L_ like I_ based (R_cb0.O_data_p);
1625 &let indent = &mrpg$indent()&;
1626 &let undent=&(&undent+1)&;
1627 &if &*=4&then
1628 &indent&.if ( &4 )
1629 &indent&.then do;
1630 &let indent = &mrpg$indent()&;
1631 &let undent=&(&undent+1)&;
1632 &fi
1633 &return
1634 &fi&+
1635 
1636 
1637 &if &1=RF&+
1638 &then
1639 &indent&.if (&cur_rep.I_level = 0)
1640 &indent&.then do;
1641 &let indent = &mrpg$indent()&;
1642 I_reportfoot:
1643 &return;
1644 &fi&+
1645 
1646 
1647 &if &1=RH&+
1648 &then
1649 &indent&.if (&cur_rep.I_page = 0)
1650 &indent&.then do;
1651 &let indent = &mrpg$indent()&;
1652 &let undent=&(&undent+1)&;
1653 I_reporthead:
1654 &return
1655 &fi&+
1656 
1657 
1658 &if &1=DH&+
1659 &then
1660 &indent&.if (&cur_rep.I_level <= &2)
1661 &indent&.then do;
1662 &let indent = &mrpg$indent()&;
1663 &let undent=&(&undent+1)&;
1664 &if &*=4&then
1665 &indent&.if ( &4 )
1666 &indent&.then
1667 &let indent = &mrpg$indent()&;
1668 &let undent=&(&undent+1)&;
1669 &fi
1670 &return;
1671 &fi&+
1672 
1673 
1674 &if &1=DT&+
1675 &then
1676 &if &detail &then
1677 &let detail=0&;
1678 &let indent = &mrpg$undent()&;
1679 &indent&.end;
1680 &else
1681 &indent&.return;
1682 &fi&.
1683 
1684 X_&2:
1685 &indent&.entry;
1686 
1687 &if &*=4&then
1688 &indent&.if ^(&4)
1689 &indent&.then return;
1690 &fi
1691 &indent&.if (&cur_rep.I_level < 0)
1692 &indent&.then &cur_rep.I_level = 1;
1693 &indent&.else &cur_rep.I_level = 999;
1694 &indent&.call E_nvir;
1695 &indent&.R_cb0.O_data_p -> I_ = R_cb0.N_data_p -> I_;
1696 &if &(&3>0)&then
1697 &indent&.if (&cur_rep.I_line > &3)
1698 &indent&.then call P_line(&if &db_sw&then mrpg_get_ln_(),&fi&.0);
1699 &fi
1700 &indent&./* do DETAIL */
1701 &return;
1702 &fi&+
1703 
1704 
1705 &if &1=9&+
1706 &then
1707 &indent&.return;
1708 
1709 C_&cur_rep:
1710 &indent&.entry;                         /* entry to close out this report */
1711 
1712 &indent&.&cur_rep.I_level = 0;
1713 &indent&.if &cur_rep.I_inited
1714 &indent&.then do;
1715 &indent&.   if (I_write_count ^= 0)
1716 &indent&.   then call E_nvir;
1717 &indent&.   if (&cur_rep.I_atd ^= "user_output")
1718 &indent&.   then do;
1719 &indent&.      call iox_$close (&cur_rep.I_iocb, 0);
1720 &let dclist = dcl iox_$close entry (ptr, fixed bin(35));
1721 &;
1722 &let dclist = dcl iox_$detach_iocb entry (ptr, fixed bin(35));
1723 &;
1724 &indent&.      call iox_$detach_iocb (&cur_rep.I_iocb, 0);
1725 &indent&.   end;
1726 &indent&.end;
1727 &let indent = &mrpg$undent()&;
1728 &indent&.end;
1729 &return;
1730 &fi
1731 &error 3,Unknown type "&1".&;
1732 &expend
1733 ^L
1734 &expand sort
1735 &if &db_sw &then
1736 &.                                                                    /* mrpg$sort &1 &2 */
1737 &fi
1738 &if &(&*=1)
1739 &then
1740      &int mode&;
1741      &let mode=&1&;
1742      &int keys{50}list&;     &empty keys&;
1743      &int key_ct&;     &let key_ct=0&;
1744      &return
1745 &fi
1746      &int movein{150}list&;
1747      &int movout{150}list&;
1748      &int dcls{150}list&;
1749      &int dclsct=0&;
1750 &if &(&*^=0)
1751 &then
1752      &if &1^=&+
1753      &then
1754           &if &1=D&+
1755           &then &loc v=-1&;
1756           &else &loc v= 1&;
1757           &fi
1758           &let key_ct = &(&key_ct+1)&;
1759           &let keys = &indent   if (P_1 -> N_&2 < P_2 -> N_&2)
1760 &indent&.   then return (&(-(&v)));
1761 &indent&.   if (P_1 -> N_&2 > P_2 -> N_&2)
1762 &indent&.   then return (&v);
1763 &;
1764      &else
1765      &let movein= &indent&.N_&2 = &2;
1766 &;
1767      &let movout= &indent&.   &2 = N_&2;
1768 &;
1769      &loc sz=&.(&4)&;
1770      &if &3=float dec(20)&then &let sz=&;&fi
1771      &if &(&4=0)&then &let sz=&;&fi
1772      &if &(&4<0)&then &let sz=&.(&substr &4,2&;)var&;&fi
1773      &let dcls=N_&2   &3&sz&;
1774      &let dclsct = &(&dclsct+1)&;
1775      &fi
1776      &return;
1777 &fi
1778 &if &mode=HD&then
1779 &if &((&phase_ct=0)*(&dclsct>0))&then
1780 &indent&.allocate D_ph in (D_place) set (R_ecptr);
1781 &ext D_place=1&;
1782 &indent&.D_l->D_list.R_ecct = D_l->D_list.R_ecct+1;
1783 &indent&.D_l->D_list.R_ecp (D_l->D_list.R_ecct) = R_ecptr;
1784 
1785 dcl 1 D_ph based(R_ecptr),
1786       2 &dcls{,,
1787       2 };
1788 
1789 &fi
1790 &movein{,}
1791 &fi
1792 &if &key_ct^=0&then
1793 S_ph&phase_ct: proc (P_1, P_2) returns(fixed bin(1));
1794 
1795 dcl (P_1, P_2) ptr unal;
1796 
1797 &keys{}
1798 &indent&.   return (0);
1799 
1800 &indent&.end;
1801 
1802 &fi
1803 &if &key_ct^=0&then
1804 &indent&.call sort_items_$general (D_l, S_ph&phase_ct);
1805 &let dclist = dcl sort_items_$general entry (ptr, entry);
1806 &;&fi
1807 &if &mode^=HD&then
1808 &if &(&phase_ct^=0)&then
1809 &indent&.do I_curec = 1 to D_l->D_list.R_ecct;
1810 &let indent = &mrpg$indent()&;
1811 &if &mode=SU&then&indent&.lptr = R_ecptr;
1812 &fi
1813 &indent&.R_ecptr = D_l->D_list.R_ecp(I_curec);
1814 &let dclist = dcl I_curec fixed bin (24);
1815 &;
1816 &if &mode=SU&then&indent&.if (S_ph&phase_ct (lptr, R_ecptr) = 0)
1817 &indent&.then do;
1818 &indent&.   goto somewhere;
1819 &indent&.end;
1820 &fi
1821 &movout{,}
1822 &fi
1823 &fi
1824 &expend
1825 ^L
1826 &expand table
1827 &int table&;
1828 &int fromtype&;
1829 &int totype&;
1830 &int fromlist{100}&;
1831 &int count=0&;
1832 &int tolen=0&;
1833 &int fromlen=0&;
1834 &int tolist{100}&;
1835 &if &(&*>2)
1836 &then
1837      &let table=&2&;
1838      &let fromtype = &3&;
1839      &let totype = &4&;
1840      &let count=0&;
1841      &let tolen=0&;
1842      &let fromlen=0&;
1843      &return
1844 &fi
1845 &loc i = &(&length &1&;-2)&;
1846 &if &(&*^=0)
1847 &then
1848      &let count=&(&count+1)&;
1849      &let fromlist{&count}=&1&;
1850      &if &(&i > &fromlen)
1851      &then &let fromlen = &i&;
1852      &fi
1853      &if &totype^=&then
1854           &let tolist{&count}=&2&;
1855           &let i = &(&length &2&;-2)&;
1856           &if &(&i > &tolen)
1857           &then &let tolen = &i&;
1858           &fi
1859      &fi
1860      &return
1861 &fi
1862 &loc leng=&tolen&;
1863 &.
1864 &table:   proc(xx) returns(&if &totype^=&then &scan &totype&;&else bit(1)&fi);
1865 
1866 dcl xx &if &substr &fromtype,1,5&;=float&then float dec(20)&else char(*)&fi;
1867 
1868 &let leng=&fromlen&;
1869 dcl in (&count) &scan &fromtype&;&. int static options (constant) init (
1870           &fromlist{1:&count,,
1871           });
1872 dcl i fixed bin;
1873 
1874           do i = 1 to &count;
1875                if (in(i) = xx)
1876 &if &totype=&+
1877 &then
1878 &.             then return("1"b);
1879           end;
1880           return("0"b);
1881 &else
1882 &.             then return(out(i));
1883           end;
1884 &.&if &substr &fromtype,1,5&;=float&+
1885 &.&then
1886 &.&.      call com_err_(0,R_name,"Value not found in table &table. ^f",xx);
1887 &.&else
1888 &.&.      call com_err_(0,R_name,"Value not found in table &table. ""^a""",xx);
1889 &.&fi
1890 &.        I_write_count = 0;            /* block action of next $close */
1891           signal condition (conversion_error);
1892 &.&if &substr &totype,1,5&;=float&+
1893 &.&then&. return (0);                   /* can't think of any better value */
1894 &.&else&. return ("");                  /* can't think of any better value */
1895 &.&fi&.
1896 dcl conversion_error condition;
1897 &fi
1898 &if &totype^=&then
1899 &let leng = &tolen&;
1900 dcl out (&count) &scan &totype&;&. int static options (constant) init (
1901           &tolist{1:&count,,
1902           });
1903 &fi
1904 end;
1905 &expend
1906 ^L
1907 &expand value
1908 &if &db_sw &then
1909 &.                                                /* % % mrpg$value(&rep_no) &{1:&*} */
1910 &fi
1911 &if &1&5=""0&then&return&fi
1912 &loc value = &1&;
1913 &loc type  = &2&;
1914 &loc size  = &3&;
1915 &loc col   = &4&;
1916 &loc leng  = &5&;
1917 &loc align = &6&;
1918 &loc alch  = &7&;
1919 &loc fold1 = &8&;
1920 &loc fold2 = &9&;
1921 &if &type=4&+
1922 &then
1923 &let value = &.(P_int(&value))&;
1924 &let P_int=1&;
1925 &fi
1926 &if &((&type=5)+(&type=18))&+
1927 &then
1928 &let value = &.(P_dec_char(&value))&;
1929 &let P_dec_char=1&;
1930 &fi
1931 &if &((&type=2)+(&type=3)+(&type=7))&+
1932 &then &let value = &.(&value)&;
1933 &fi
1934 &loc NL&;
1935 &if &substr &value,1,1&;="&+
1936 &then &if &(&length &value&;>55)&+
1937       &then &let NL=&.
1938 &indent   &;&+
1939       &fi&+
1940 &fi
1941 &indent&if &[index " DH DT DF " &rep_no]^=0&+
1942 &then call P_field(addr(&cur_rep),&col,"&align"b,"&alch",&leng,&NL&value);
1943 &else call P_field(addr(&.   H_F),&col,"&align"b,"&alch",&leng,&NL&value);
1944 &fi
1945 &expend
1946 ^L
1947 &expand undent
1948 &substr &indent,4&;&expend