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&2maxlength&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;%skip4;
54 nosize:reclose: entry I_rcbpI_code;
55
56 &indent&.I_ptra = I_rcbp;
57 &indent&.goto close_;
58
59 nosize:close: entry I_rcbpI_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=dec20float &then &let dec=1&;&fi
81 &if &3=float dec20 &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&.entryI_rcbpI_option_arrayI_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_nameI_ptraI_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_argprocI_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_ entrychar12varchar8char8char12varchar5;
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_nameD_lI_code;
166 %include area_info;
167 dcl 1 ai like area_info;
168 dcl sys_info$max_seg_size fixed bin 24ext static;
169 &indent&.end;
170 &let dclist =
171 dcl D_place area basedD_p;
172 dcl 1 D_list based,
173 2 R_ecct fixed bin,
174 2 R_ecp4000 ptr unal;
175 dcl R_ecptr ptr;
176 &;
177 &fi
178 &indent&.return;
179
180 dcl &report&.$write entryptr ptr fixed bin21 fixed bin35;
181 dcl &report&.$close entryptr fixed bin35;
182 dcl &report&.$reclose entryptr fixed bin35;
183 &if &parm_sw &then
184
185 I_swarg:
186 &indent&.proc code;
187
188 dcl code fixed bin35;
189
190 &indent&. I_argno = I_argno + 1;
191 &indent&. if I_argno > hboundI_option_array1
192 &indent&. then code = 1;
193 &indent&. else do;
194 &indent&. I_argp = addreladdrI_option_arrayI_argno1;
195 &indent&. I_argl = lengthI_option_arrayI_argno;
196 &indent&. code = 0;
197 &indent&. if arg = "--EOP--"
198 &indent&. then code = -2;
199 &indent&. end;
200
201 dcl arg charI_arglbasedI_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 bit9, /* control bits */
212 P_alch char1, /* 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 basedP_pt;
217
218 dcl P_i P_j P_l P_vis P_use fixed bin;
219
220 dcl 1 P definedP_ctl,
221 2 bsp bit1, /* need BSP processing */
222 2 left bit1, /* set-left in output width */
223 2 center bit1, /* set-centered */
224 2 right bit1, /* set-right */
225 2 align bit1, /* align on character */
226 2 numeric bit1, /* value is numeric */
227 2 space bit1; /* add space after field */
228 dcl BSP char1int 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 = indexsubstrP_dataP_iP_use-P_i+1BSP;
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 substrc.I_recc.I_len+1P_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 = indexsubstrc.I_recP_iP_l-P_i+1BSP;
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 = indexP_dataP_alch; /* look for the alignment character */
274 if P_i = 0 /* if one isn't there, assume one */
275 then P_i = lengthP_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 substrc.I_rec1P_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 substrc.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 = maxc.I_vlenc.I_vloc;
325 c.I_len = max c.I_lenc.I_loc;
326 end;
327 &if &A_dec_char&then
328 &let P_dec_char = 1&;
329 &.^K
330 A_dec_char: procvalintonamelinereturnschar60var;
331
332 dcl val float dec20,
333 into fixed bin,
334 name char32,
335 line fixed bin;
336
337 dcl v60 char60var;
338
339 v60=P_dec_charval;
340 if into < lengthv60
341 then call com_err_0R_name"Truncation when doing decimal/character conversion line ^i
342 ^-^a := ^a;
343 Receiving field is only ^i chars long."
344 linenamev60into;
345 returnv60;
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: procvalreturnschar60var;
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 dvalreturns char 60var;
366
367 dcl dval float dec20;
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 = verifyP_64" ";
376 j = verifyreverseP_64"0";
377 k = lengthP_64-j+1;
378 if substrP_64k1 = "."
379 then k = k - 1;
380 v60 = substrP_64ik-i+1;
381 returnv60;
382
383 dcl v60 char60var;
384 dcl ijk fixed bin;
385 dcl verify builtin;
386
387 end;
388 &fi
389 &if &P_skip&then
390 &.^K
391 P_skip: procin;
392
393 dcl in char*;
394 end;
395 &fi
396 &if &P_stop&then
397 &.^K
398 P_stop: procin;
399
400 dcl in char*;
401 end;
402 &fi
403 &if &P_if&then
404 &.^K
405 P_if: proclogtrufal returnschar256var;
406
407 dcl log bit1,
408 tru char*,
409 fal char*;
410 dcl res char256var;
411
412 if log
413 then res = tru;
414 else res = fal;
415 returnres;
416
417 end;
418 &fi
419 &if &P_bool_char&then
420 &.^K
421 P_bool_char: procinreturnschar5var;
422
423 dcl in bit1;
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: procinreturnsfloat dec20;
434
435 dcl in bit1;
436
437 if in
438 then return1;
439 return0;
440
441 end;
442 &fi
443 &if &P_char_bool&then
444 &.^K
445 P_char_bool: procinreturnsbit1;
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: procinreturnsbit1;
460
461 dcl in float dec20;
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: procinreturnsfloat dec20;
472
473 dcl in char*;
474 dcl fd float dec20;
475 dcl convert builtin;
476
477 returnconvertfdin;
478
479 end;
480 &fi
481 dcl 1 H_F_common based, /* DUMMY STRUCTURE */
482 2 I_name char32, /* 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 char200, /* 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 bit1, /* 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 dec20;
527 dcl P_15 pic "14-9";
528 dcl P_64 pic "30-9v.309";
529 dcl iox_$put_chars entry ptr ptr fixed bin 21 fixed bin 35;
530 dcl I_ptra ptr;
531 dcl get_temp_segment_ entrychar*ptrfixed bin35;
532 dcl com_err_ entry optionsvariable;
533 &dclist
534 dcl I_str char2000basedI_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_codeR_name"&1";
549 &indent&. &if &&*=1&then return&else goto &2&fi;
550 &indent&.end;&expend
551 ^L
552 &expand et_
553 &int et_50list&;
554 &if &&*=0
555 &then
556 dcl error_table_$&et_ fixed bin35ext static;
557 dcl error_table_$ fixed bin35ext 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_nameD_lI_code;
597 &fi
598 &indent&. call release_temp_segment_ R_nameI_ptraI_code;
599 dcl release_temp_segment_ entrychar*ptrfixed bin35;
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&.entryI_rcbpI_irpI_irlI_code;
634
635 dcl I_rcbp ptr, /* pointer to report control block */
636 I_irp ptr, /* pointer to input record */
637 I_irl fixed bin21, /* length of input record*/
638 I_code fixed bin35;
639
640 dcl I_iri fixed bin21; /* 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=dec20float&+
685 &then &let SPEC=1&;
686 &let DEC=1&;
687 &fi&+
688
689
690 &if &kind=float dec20&+
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=dec20float&then &let sz=&;&fi
733 &if &kind=float dec20&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 = addrI_carI_iri->I_fd30;
747 &. &let dclist = dcl I_car2000char1unal basedI_irp;
748 &;&+
749 &indent&. I_iri = I_iri + 4;
750 &+ &let leng=I_i&;
751 &+ &fi&+
752 &indent&. &field = &+
753 &if &DEC&+
754 &then convertF_d20substrI_strI_iri&leng&+
755 &else substrI_strI_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 = indexsubstrI_strI_iriI_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 convertF_d20 substrI_strI_iriI_i&+
771 &else substrI_strI_iriI_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_repaddrH_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 dec20&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_atdnullI_code;
887 &mrpg$errAttaching &report.&cur_rep.
888 &indent&.if substr&cur_rep.I_atd15 ^= "syn_"
889 &indent&.then call iox_$open &cur_rep.I_iocb2"0"bI_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 bit2 fixed bin 35;
893 &;
894 &let dclist = dcl iox_$close entry ptr fixed bin35;
895 &;
896 &let dclist = dcl iox_$detach_iocb entry ptr fixed bin35;
897 &;
898 &mrpg$errOpening &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 charI_arglbasedI_argp;
916 I_argproc:
917 &indent&.procI_get_argcode;
918 &let indent = &mrpg$indent&;
919 &.
920 dcl I_get_arg entry fixed bin35 parm,
921 code fixed bin35 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 substrI_arg11 ^= "-"
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_positionalI_pos_no;
948 &indent&. call com_err_0R_name"Too many positional arguments";
949 &else
950 &indent&. call com_err_0R_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 bit1
968 &else &if &&3=0
969 &then
970 &mrpg$rcb_put
971 &. 2 &1 char256var
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_argcode;
997 &Indent&.if code ^= 0
998 &Indent&.then do;
999 &Indent&. call com_err_codeR_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_badoptR_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_presentI_i
1062 &indent&. then do;
1063 &indent&. I_error = "1"b;
1064 &indent&. call com_err_0R_name"Parameter ""^a"" missing."I_parameterI_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 PIC300&;
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 = convertP_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 reports25list&;
1113 &ext cur_rep=H_F&;
1114 &ext break_no&;
1115 &ext report=&3&;
1116 &ext keylist50var&;
1117 &ext argdone=0&;
1118 &ext dclist100list&;
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 char32;
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 35ext static;
1183 dcl iox_$attach_name entry char * ptr char * ptr fixed bin 35;
1184 dcl iox_$open entry ptrfixed binbit 1fixed bin 35;
1185 dcl iox_$&read entry ptrptrfixed bin 21fixed bin 21fixed bin 35;
1186 dcl iox_$&write entry ptrptrfixed bin 21fixed bin 35;
1187 dcl iox_$close entry ptrfixed bin 35;
1188 dcl iox_$detach_iocb entry ptrfixed 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$errAttach 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_cmdargI_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_argsR_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$errOpen outputdto
1234
1235 &indent&.call iox_$attach_name sn||"_i" icbp &4 null I_code;
1236 &mrpg$errAttach inputclo
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 icbpaddr bufflength buffreclI_code;
1246 &indent&.if I_code = error_table_$end_of_info
1247 &indent&.then goto quit;
1248 &mrpg$errOn inputcli
1249 &indent&.call iox_$&write ocbpaddr buffreclI_code;
1250 &mrpg$errOn outputcli
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_argnoI_argpI_arglI_codeI_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$rcbH_Fwork area for building headers/footers256
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&. substrstring&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_repdata fields for REPORT &cur_rep500&+
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&.rcbplcbplin;
1443
1444 &if &db_sw&then dcl lno fixed bin18;
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 basedrcbp;
1451 dcl 1 l like H_F basedlcbp;
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 returnsfixed bin18;
1457 &;&let dclist = dcl ioa_ entry optionsvariable;
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 bit1 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"lnorcbplcbplinr.I_linel.I_lenl.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 addrFF 1 I_code;
1478 &if &db_sw &then
1479 /* ## */ if db_sw then call iox_$put_charsiox_$user_output addrFF10;
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 chari;
1488 ch = copyNLi;
1489 call iox_$put_charsr.I_iocbaddrchiI_code;
1490 &if &db_sw &then
1491 /* ## */ if db_sw then call iox_$put_charsiox_$user_outputaddrchi0;
1492 &fi
1493 &. end;
1494 if lin > 0
1495 then do;
1496 substrl.I_recl.I_len+11 = NL;
1497 call iox_$put_charsr.I_iocbaddrl.I_recl.I_len+1I_code;
1498 &if &db_sw &then
1499 /* ## */ if db_sw then call iox_$put_charsiox_$user_outputaddrl.I_recl.I_len+10;
1500 &fi
1501 &. r.I_line = maxr.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 bit9 int static init "014"b3;
1512 dcl NL char1 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 bin18;
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"lnolin&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$errPut 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 bin35;
1721 &;
1722 &let dclist = dcl iox_$detach_iocb entry ptr fixed bin35;
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 keys50list&; &empty keys&;
1743 &int key_ct&; &let key_ct=0&;
1744 &return
1745 &fi
1746 &int movein150list&;
1747 &int movout150list&;
1748 &int dcls150list&;
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 dec20&then &let sz=&;&fi
1771 &if &&4=0&then &let sz=&;&fi
1772 &if &&4<0&then &let sz=&.&substr &42&;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 basedR_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 returnsfixed bin1;
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_ecpI_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 fromlist100&;
1831 &int count=0&;
1832 &int tolen=0&;
1833 &int fromlen=0&;
1834 &int tolist100&;
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: procxx returns&if &totype^=&then &scan &totype&;&else bit1&fi;
1865
1866 dcl xx &if &substr &fromtype,1,5&;=float&then float dec20&else char*&fi;
1867
1868 &let leng=&fromlen&;
1869 dcl in &count &scan &fromtype&;&. int static options constant init
1870 &fromlist1:&count
1871 ;
1872 dcl i fixed bin;
1873
1874 do i = 1 to &count;
1875 if ini = xx
1876 &if &totype=&+
1877 &then
1878 &. then return"1"b;
1879 end;
1880 return"0"b;
1881 &else
1882 &. then returnouti;
1883 end;
1884 &.&if &substr &fromtype,1,5&;=float&+
1885 &.&then
1886 &.&. call com_err_0R_name"Value not found in table &table. ^f"xx;
1887 &.&else
1888 &.&. call com_err_0R_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 &tolist1:&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_fieldaddr&cur_rep&col"&align"b"&alch"&leng&NL&value;
1943 &else call P_fieldaddr&. H_F&col"&align"b"&alch"&leng&NL&value;
1944 &fi
1945 &expend
1946 ^L
1947 &expand undent
1948 &substr &indent,4&;&expend