This library contains the following macros used for mrpg PL/I code generation: indent input_field rcb assign line rcb_begin bg local rcb_end break on rcb_put edit parm_begin rep_break end parm_check rep_head err parm_default report et_ parm_end sort exec picture table if print value input proc undent &expand assign &if &3==:&then &let A_dec_char=1&; &fi &indent&if &3=:=&then&1 = &2&else &1 = A_dec_char(&2,maxlength(&1),"&1",&4)&fi; &expend &expand bg &if &db_sw &then &. /* bg &1 &phase_ct*/ &fi &if &(&1=1) &then /* ---- BEGIN PHASE &phase_ct ---- */ &if &phase_ct=0&then &indent&.if (I_phase = -1) &indent&.then do; &let indent = &mrpg$indent()&; &indent&.I_phase = 0; &fi &new_phase &return &fi &if &(&1=2) &then &if &phase_ct=0&then &let indent = &mrpg$undent()&; &indent&.end; &let phase_ct = 00&; &fi &return &fi &if &(&1=3) &then &if &(&phase_ct ^= 0) &then &let indent = &mrpg$undent()&; &indent&.end; &else &indent&.return;%skip(4); (nosize):reclose: entry (I_rcbp,I_code); &indent&.I_ptra = I_rcbp; &indent&.goto close_; (nosize):close: entry (I_rcbp,I_code); dcl C_size label; /* error handler for size condition */ &indent&.I_ptra = I_rcbp; &indent&.I_close = &report&.$reclose; /* inhibit further $close */ &indent&.C_size = H_default; &indent&.on size goto C_size; &indent&.if (I_write_count = 0) &indent&.then goto close_; &fi &let phase_ct = &(&phase_ct+1)&; &return; &fi &error 4,Invalid argument 1.&; &expend &expand break &loc dec=0&; &if &3=dec(20)float &then &let dec=1&;&fi &if &3=float dec(20) &then &let dec=1&;&fi &mrpg$rcb_put( &. 3 B_&1 &3&if &(&4>0) &then &if &dec &then &else (&4)&fi&fi /* level &2 break field */)&+ &indent&.if (&cur_rep.I_level <= &2) &indent&.| (&cur_rep.B_&1 ^= &1) &indent&.then do; &indent&. &cur_rep.B_&1 = &1; &indent&. &cur_rep.I_level = min (&cur_rep.I_level, &2); &indent&.end; &if &dec&then &let initial2= &initial2 &cur_rep.B_&1 = 0;&;&fi &expend &expand edit &indent&.call mrpg_edit(&1,&2,&3); &expend &expand end %page;&if &db_sw &then &. /* % % mrpg$end */ &fi &. &int P_skip=0&; &int P_stop=0&; &int P_bool_char=0&; &int P_bool_dec=0&; &int P_char_bool=0&; &int P_char_dec=0&; &int P_dec_bool=0&; &scan &6&; attach: &indent&.entry(I_rcbp,I_option_array,I_code); dcl I_option_array(*) char(*)var; dcl R_name char (32) int static options (constant) init ("&report"); &indent&.call get_temp_segment_(R_name,I_ptra,I_code); &indent&.I_rcbp = I_ptra; &indent&.call I_init; &indent&.I_mode = &open_mode; &indent&.I_write = &report&.$write; &indent&.I_close = &report&.$close; &if &parm_sw &then &indent&.I_argno = 1; &indent&.call I_argproc(I_swarg, I_code); &fi &indent&.I_phase = -1; &indent&.I_write_count = 0; &if &1&2&3&4&5^=&then &indent&.begin; &indent&. call mrpg_date_ (&+ &if &1=&then ""&else &1&fi ,&if &2=&then ""&else &2&fi ,&if &3=&then ""&else &3&fi ,&if &4=&then ""&else &4&fi ,&if &5=&then ""&else &5&fi); dcl mrpg_date_ entry(char(12)var,char(8),char(8),char(12)var,char(5)); &indent&.end; &fi &indent&.H_F.I_rec = ""; &indent&.H_F.I_len, H_F.I_vlen = 0; &indent&.&cur_rep.I_next = null(); &ext D_place=0&; &if &D_place &then &indent&.begin; &indent&. ai.version = area_info_version_1; &indent&. ai.extend = "1"b; &indent&. ai.zero_on_alloc = "1"b; &indent&. ai.zero_on_free = "0"b; &indent&. ai.dont_free = "0"b; &indent&. ai.no_freeing = "1"b; &indent&. ai.owner = R_name; &indent&. ai.size = sys_info$max_seg_size; &indent&. ai.areap = null (); &indent&. call define_area_ (addr (ai), I_code); dcl define_area_ entry (ptr, fixed bin (35)); &indent&. D_p = ai.areap; &indent&. call get_temp_segment_(R_name,D_l,I_code); %include area_info; dcl 1 ai like area_info; dcl sys_info$max_seg_size fixed bin (24)ext static; &indent&.end; &let dclist = dcl D_place area based(D_p); dcl 1 D_list based, 2 R_ecct fixed bin, 2 R_ecp(4000) ptr unal; dcl R_ecptr ptr; &; &fi &indent&.return; dcl &report&.$write entry(ptr, ptr, fixed bin(21), fixed bin(35)); dcl &report&.$close entry(ptr, fixed bin(35)); dcl &report&.$reclose entry(ptr, fixed bin(35)); &if &parm_sw &then I_swarg: &indent&.proc (code); dcl code fixed bin(35); &indent&. I_argno = I_argno + 1; &indent&. if (I_argno > hbound(I_option_array,1)) &indent&. then code = 1; &indent&. else do; &indent&. I_argp = addrel(addr(I_option_array(I_argno)),1); &indent&. I_argl = length(I_option_array(I_argno)); &indent&. code = 0; &indent&. if (arg = "--EOP--") &indent&. then code = -2; &indent&. end; dcl arg char(I_argl)based(I_argp); &indent&.end; &fi&. %page; /* - - - SUPPORT PROCEDURES - - - */ P_field: proc (P_pt, P_loc, P_ctl, P_alch, P_leng, P_data); dcl P_pt ptr, /* pointer to control block */ P_loc fixed bin, /* visual location of field */ P_ctl bit(9), /* control bits */ P_alch char(1), /* align character */ P_leng fixed bin, /* desired visual length */ P_data char(*); /* data to put */ dcl 1 c like H_F based(P_pt); dcl (P_i, P_j, P_l, P_vis, P_use) fixed bin; dcl 1 P defined(P_ctl), 2 bsp bit(1), /* need BSP processing */ 2 left bit(1), /* set-left in output width */ 2 center bit(1), /* set-centered */ 2 right bit(1), /* set-right */ 2 align bit(1), /* align on character */ 2 numeric bit(1), /* value is numeric */ 2 space bit(1); /* add space after field */ dcl BSP char(1)int static init(""); P_vis, P_use = length (P_data); if bsp /* field may contain BSP, */ then do; /* adjust visual length */ P_i = 1; do while (P_i 0) /* is location being specified? */ then do; P_i = (P_loc-1) - c.I_vlen; if (P_i > 0) /* if haven't gotten that far */ then do; /* extend record out to there */ substr(c.I_rec,c.I_len+1,P_i) = " "; c.I_len, c.I_loc = c.I_len + P_i; c.I_vloc, c.I_vlen = P_loc -1; end; else if (P_i < 0) /* go back into record? USER BEWARE */ then do; /* BSP will louse up positioning */ P_l = P_loc; P_i = 1; do while (P_i 0) then do; P_i = P_leng - P_vis; /* amount of padding field needs */ if (P_i > 0) then do; /* AH! some is needed */ P_use = P_use + P_i; P_vis = P_leng; if center then P_i = divide (P_i, 2, 17, 0); if right | center | ^left&&numeric then do; /* skip print positions if needed */ substr (c.I_rec, c.I_loc+1, P_i) = " "; c.I_loc = c.I_loc + P_i; P_use = P_use - P_i; end; end; else if (P_i < 0) then do; /* value is TOO BIG for field */ if numeric /* don't truncate a numeric field */ then do; substr (c.I_rec, c.I_loc+1, P_leng) = copy("#",P_leng); c.I_loc = c.I_loc + P_leng; P_use = 0; end; else P_use = P_use + P_i; /* assumes none of the "extra" characters are BSP */ P_vis = P_leng; end; end; substr(c.I_rec, c.I_loc+1, P_use) = P_data; /* move it in */ c.I_loc = c.I_loc + P_use; /* if space then do; substr (c.I_rec, c.I_loc+1, 1) = " "; c.I_loc = c.I_loc + 1; P_vis = P_vis + 1; end;*/ c.I_vloc = c.I_vloc + P_vis; c.I_vlen = max(c.I_vlen,c.I_vloc); c.I_len = max (c.I_len,c.I_loc); end; &if &A_dec_char&then &let P_dec_char = 1&; &. A_dec_char: proc(val,into,name,line)returns(char(60)var); dcl val float dec(20), into fixed bin, name char(32), line fixed bin; dcl v60 char(60)var; v60=P_dec_char(val); if (into < length(v60)) then call com_err_(0,R_name,"Truncation when doing decimal/character conversion (line ^i) ^-^a := ^a; Receiving field is only ^i chars long.", line,name,v60,into); return(v60); end; &let P_dec_char=1&; &fi &if &P_int&P_dec_char^=00&then &. &fi &if &P_int&then P_int: proc(val)returns(char(60)var); dcl val fixed bin; P_64 = val; &fi &if &P_int&P_dec_char=11&then &. goto start; &fi &if &P_dec_char&then P_dec_char: &if &P_int&then entry&else proc&fi (dval)returns (char (60)var); dcl dval float dec(20); P_64 = dval; &fi &if &P_int&P_dec_char=11&then start: &fi &if &P_int&P_dec_char^=00&then &. i = verify(P_64," "); j = verify(reverse(P_64),"0"); k = length(P_64)-j+1; if (substr(P_64,k,1) = ".") then k = k - 1; v60 = substr(P_64,i,k-i+1); return(v60); dcl v60 char(60)var; dcl (i,j,k) fixed bin; dcl verify builtin; end; &fi &if &P_skip&then &. P_skip: proc(in); dcl in char(*); end; &fi &if &P_stop&then &. P_stop: proc(in); dcl in char(*); end; &fi &if &P_if&then &. P_if: proc(log,tru,fal) returns(char(256)var); dcl log bit(1), tru char(*), fal char(*); dcl res char(256)var; if log then res = tru; else res = fal; return(res); end; &fi &if &P_bool_char&then &. P_bool_char: proc(in)returns(char(5)var); dcl in bit(1); if in then return("true"); return("false"); end; &fi &if &P_bool_dec&then &. P_bool_dec: proc(in)returns(float dec(20)); dcl in bit(1); if in then return(1); return(0); end; &fi &if &P_char_bool&then &. P_char_bool: proc(in)returns(bit(1)); dcl in char(*); if (in = "0") then return("0"b); if (in = "false") then return("0"b); return("1"b); end P_char_bool; &fi &if &P_dec_bool&then &. P_dec_bool: proc(in)returns(bit(1)); dcl in float dec(20); if (in = 0) then return("0"b); return("1"b); end; &fi &if &P_char_dec&then &. P_cd: proc(in)returns(float dec(20)); dcl in char(*); dcl fd float dec(20); dcl convert builtin; return(convert(fd,in)); end; &fi dcl 1 H_F_common based, /* DUMMY STRUCTURE */ 2 I_name char(32), /* name of report */ 2 I_next ptr, /* pointer to next control block */ 2 I_filno fixed bin, /* sequence #, if any */ 2 I_atd char(200), /* attach description */ 2 I_len fixed bin, /* last char in use in output record */ 2 I_vlen fixed bin, /* visual last char */ 2 I_loc fixed bin, /* current location in putput record */ 2 I_vloc fixed bin, /* visual current location */ 2 I_page fixed bin, /* current page # */ 2 I_minl fixed bin, /* minimum detail line # */ 2 I_line fixed bin, /* line # last printed on this page */ 2 I_maxl fixed bin, /* maximum detail line # */ 2 I_pl fixed bin, /* pagelength */ 2 I_pw fixed bin, /* pagewidth */ 2 E_P fixed bin, /* line where end-of-page leaves you */ 2 I_inited bit(1), /* first-time switch */ 2 I_level fixed bin, /* break level in this report */ 2 I_iocb ptr; &mrpg$rcb_end() &let initial = &initial R_cb0.O_data_p,&; &mrpg$rcb_put( &. 2 O_ (size (&Ircb)) bit (36) /* old input data */;)&+ &comment close it all up &; dcl 1 R_cb0 based (I_ptra), 2 I_mode fixed bin, /* allowable open mode */ 2 I_write entry (ptr, ptr, fixed bin (21), fixed bin (35)), 2 I_close entry (ptr, fixed bin (35)), 2 I_write_count fixed bin, 2 I_phase fixed bin, 2 I_base (&rcb_ct) ptr, /* point to all data pieces */ 2 O_data_p ptr, 2 N_data_p ptr, 2 D_p ptr, /* ptr to record allocation area */ 2 D_l ptr, /* pointer to record list areas */ 2 D_ummy ptr; &rcb I_init: proc; &initial &initial2 end I_init; dcl F_d20 float dec(20); dcl P_15 pic "(14)-9"; dcl P_64 pic "(30)-9v.(30)9"; dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl I_ptra ptr; dcl get_temp_segment_ entry(char(*),ptr,fixed bin(35)); dcl com_err_ entry options(variable); &dclist{} dcl I_str char(2000)based(I_irp); dcl I_i fixed bin; &mrpg$et_() dcl (addr, copy, divide, index, length, max, min, null, reverse, substr) builtin; %page; /* ----- macros used ----- */ &usage /* ^a>^a$^a ^-*/^/&; &indent&.end; &expend &expand err &indent&.if (I_code ^= 0) &indent&.then do; &indent&. call com_err_(I_code,R_name,"&1"); &indent&. &if &(&*=1)&then return&else goto &2&fi; &indent&.end;&expend &expand et_ &int et_{50}list&; &if &(&*=0) &then dcl error_table_$&et_{, fixed bin(35)ext static; dcl error_table_$} fixed bin(35)ext static; &return &fi &let et_=&1&; error_table_$&1&expend &expand exec &int refct=0&; &if &db_sw &then &. /* % % mrpg$exec &refct */ &fi &if &(&refct=0) &then &let refct=1&; &let phase_ct=0&; &return &fi &if &(&refct=1) &then &let refct=2&; &if &(&phase_ct=0)&+ &then &indent&.return; close: entry (I_rcbp, I_code); &indent&.I_ptra = I_rcbp; &+ &else &. &+ &fi close_: /* close out all reports */ &indent&.call &reports{,; &indent&.call }; &ext D_place=0&; &indent&.begin; &if &D_place &then &indent&. call release_area_ (D_p); dcl release_area_ entry (ptr); &indent&. call release_temp_segment_ (R_name,D_l,I_code); &fi &indent&. call release_temp_segment_ (R_name,I_ptra,I_code); dcl release_temp_segment_ entry(char(*),ptr,fixed bin(35)); &indent&.end; &indent&.return; &return &fi &error 3,Improper sequence of calls&; &expend &expand if &if &(&1=1) &then &indent&.if ( &2 ) &indent&.then do; &let indent=&mrpg$indent()&; &return &fi &let indent=&mrpg$undent()&; &indent&.end; &if &(&1=3) &then &return &fi &indent&.else do; &let indent=&mrpg$indent()&; &expend &expand indent &indent &expend &expand input %page;&if &db_sw &then &. /* % % mrpg$input */ &fi (nosize): write: &indent&.entry(I_rcbp,I_irp,I_irl,I_code); dcl I_rcbp ptr, /* pointer to report control block */ I_irp ptr, /* pointer to input record */ I_irl fixed bin(21), /* length of input record*/ I_code fixed bin(35); dcl I_iri fixed bin(21); /* current character in input record */ dcl I_ire fixed bin (21); /* last char to use in input record */ &indent&.C_size = H_default; &indent&.if "0"b then do; H_default: &indent&. call ioa_("^a: Unexpected size condition.", R_name); &indent&. stop; &indent&.end; &indent&.on size goto C_size; &indent&.on conversion begin; &indent&. I_write_count = 0; /* inhibit $close output */ &indent&. call continue_to_signal_; dcl continue_to_signal_ entry; &indent&.end; &indent&.I_ptra = I_rcbp; &indent&.I_write_count = I_write_count + 1; &indent&.I_iri = 1; &indent&.I_ire = I_irl; &indent&.if (substr (I_str, I_ire, 1) = " ") then I_ire = I_ire - 1; /************ DCL 1 INPUT */ &mrpg$rcb_end() &let initial = &initial R_cb0.N_data_p,&; &mrpg$rcb_put( &. 2 I_, /* ----- input data ----- */)&+ &let Ircb=R_cb&rcb_ct&;&expend &expand input_field &loc pos=&3&; &loc field=&2&; &loc kind=&4&; &loc leng=&5&; &loc delim=&6&; &loc SPEC=0&; &loc DEC=0&; &loc opt&;&+ &if &kind=varying char&+ &then &let SPEC=1&; &fi&+ &if &kind=dec(20)float&+ &then &let SPEC=1&; &let DEC=1&; &fi&+ &if &kind=float dec(20)&+ &then &let DEC=1&; &fi&+ &if &(&leng < 0) &then &let leng=&substr &leng,2&;&; &let opt= -OPT-&; &fi /*(line &1) , 2 &field &+ &if &kind=varying char&+ &then char (&(&leng)) SPEC&+ &else &kind&+ &if &leng^=0&+ &then &. (&(&leng))&+ &fi&+ &fi&+ &if &delim^=&+ &then &. DELIM &delim&+ &if &delim=" "&+ &then &let opt= -OPT-&;&+ &fi&+ &fi &+ &if &pos^=0&+ &then POS &pos &+ &fi&+ &opt&+ &if &db_sw&+ &then &. [mrpg$input_field]&+ &fi */ &+ &if |&kind|=| FILL|&then &indent&.I_iri = I_iri + &leng; &return &fi&+ &loc sz=&.(&leng)&; &if &kind=dec(20)float&then &let sz=&;&fi &if &kind=float dec(20)&then &let sz=&;&fi &mrpg$rcb_put( &. 3 &field &kind &sz) &if &pos^=0&+ &then&indent&.I_iri = &pos; &fi &indent&.if (I_iri <= I_ire) &indent&.then do; &if &delim=&+ &then &if &SPEC &then&+ &let dclist = dcl I_fd30 fixed dec (3, 0) based; &;&+ &indent&. I_i = addr(I_car(I_iri))->I_fd30; &. &let dclist = dcl I_car(2000)char(1)unal based(I_irp); &;&+ &indent&. I_iri = I_iri + 4; &+ &let leng=I_i&; &+ &fi&+ &indent&. &field = &+ &if &DEC&+ &then convert(F_d20,substr(I_str,I_iri,&leng))&+ &else substr(I_str,I_iri,&leng)&+ &fi; &+ &indent&. I_iri = I_iri + &leng; &+ &indent&. if (I_iri > I_ire +1) &+ &indent&. then do; &+ &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); &+ &indent&. return; &+ &indent&. end; &else&comment delim^= "" &;&+ &+ &indent&. I_i = index(substr(I_str,I_iri,I_ire-I_iri+1),&delim); &+ &indent&. if (I_i ^= 0) &+ &indent&. then I_i = I_i - 1; /* take next part */ &+ &indent&. else I_i = I_ire - I_iri + 1; /* take the rest */ &+ &indent&. &field = &+ &if &DEC&+ &then convert(F_d20, substr(I_str,I_iri,I_i))&+ &else substr(I_str,I_iri,I_i)&+ &fi; &+ &indent&. I_iri = I_iri + I_i + &length &unquote &delim&;&;; &fi &indent&.end; &if &opt=-OPT-&+ &then &indent&.else &field = &if &DEC &then 0&else ""&fi; &else &indent&.else do; &+ &indent&. call ioa_ ("^a: Non-optional field &field missing.", R_name); &+ &indent&. return; &+ &indent&.end; &fi&+ &expend undent &expand line &if &db_sw &then &. /* % % mrpg$line(&rep_no) &1 &2 */ &fi &if &1=1&+ &then &int absline&; &int relline&; &int ctl&; &if &(&2 < 0) &then &let absline=&(-(&2))&; &let relline=0&; &else &let absline = 0&; &let relline=&2&; &fi &if &3=&+ &then &let ctl=0&; &else &let ctl=1&; &indent&.if (&3) &indent&.then do; &+ &let indent = &mrpg$indent()&; &fi &return &fi &if &1=2&+ &then &if &[index " DH DT DF " &rep_no]^=0&then &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); &else &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); &fi &+ &if &ctl=1&+ &then &let indent = &mrpg$undent()&; &indent&.end; &+ &fi &return &fi &error 3,mrpg$line: first parameter not 1|2&; &expend &comment xxx field pos kind leng delim &1 &2 &3 &4 &5 &6 &; &expand local &if &local=0 &then &let local=1&; &mrpg$rcb_end() &mrpg$rcb_put( /* ----- local data variables ----- */)&+ &fi &if &substr &2,1,5&;=&then &return&fi &mrpg$rcb_put( &. 2 &2 &4&if &(&5>0)&then &. (&5)&fi&if &(&1>0) &then &. /* line &1 */&fi)&+ &if &4=float dec(20)&then &let initial2=&initial2 &2 = 0;&; &fi &expend &expand on &int count=0&; &if &count=3&+ &then &let count=0&; &let label=0&; &fi &int label=0&; &loc ELS=&if &count>0&then else &fi&; &if &3^=&+ &then &+ &indent&.&ELS&.if (&3) &+ &indent&.then do; &else &let count=3&;&+ &indent&.&ELS&.do; &fi &if &count=0&then &let count=1&;&fi &if &1=SW&+ &then &if &2="user_output"&+ &then &indent&. &cur_rep.I_iocb = iox_$user_output; &indent&. &cur_rep.I_atd = "user_output"; &indent&. &cur_rep.E_P, &cur_rep.I_line = 1; &let dclist = dcl iox_$user_output ptr ext static; &; &indent&.end; &return &fi &fi &indent&. &cur_rep.I_atd = &if &1=FL&then "vfile_ " || &fi&2; &indent&. &cur_rep.I_filno = &4; &if &label &then &indent&. goto att; &else &let label=1&; att: &let indent = &indent &; &indent&.call iox_$attach_name("&report.&cur_rep",&cur_rep.I_iocb,&cur_rep.I_atd,null(),I_code); &mrpg$err(Attaching &report.&cur_rep.) &indent&.if (substr(&cur_rep.I_atd,1,5) ^= "syn_") &indent&.then call iox_$open (&cur_rep.I_iocb,2,"0"b,I_code); &let dclist = dcl iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35)); &; &let dclist = dcl iox_$open entry (ptr, fixed bin, bit(2), fixed bin (35)); &; &let dclist = dcl iox_$close entry (ptr, fixed bin(35)); &; &let dclist = dcl iox_$detach_iocb entry (ptr, fixed bin(35)); &; &mrpg$err(Opening &report.&cur_rep.) &indent&.&cur_rep.E_P, &cur_rep.I_line = 4; &let indent = &mrpg$undent()&; &fi &indent&.end; &if &count=0&then &let count=1&;&fi &expend &expand parm_begin &if &db_sw&then &. /* % % mrpg$parm_begin */ &fi /* DO argument processing */ dcl I_argno fixed bin; dcl I_argp ptr; dcl I_argl fixed bin; dcl I_arg char(I_argl)based(I_argp); I_argproc: &indent&.proc(I_get_arg,code); &let indent = &mrpg$indent()&; &. dcl I_get_arg entry (fixed bin(35)) parm, code fixed bin(35) parm; &ext parmct=&(&1+&2)&; dcl I_present (&parmct) bit (1) init ((&parmct) (1)"0"b); dcl I_pos_no fixed bin; &indent&.I_error = "0"b; &indent&.I_pos_no = 0; &indent&.code = 0; I_argloop: &indent&.call I_get_arg (code); &indent&.if (code ^= 0) &indent&.then do; &indent&. if (code = -2) &indent&. then do; &indent&. code = 0; &indent&. return; &indent&. end; &indent&. goto I_argdone; &indent&.end; &indent&.if (substr(I_arg,1,1) ^= "-") &indent&.then do; &indent&. I_pos_no = I_pos_no + 1; &if &(&1>0)&then &indent&. if (I_pos_no <= &1) &indent&. then goto I_positional(I_pos_no); &indent&. call com_err_(0,R_name,"Too many positional arguments"); &else &indent&. call com_err_(0,R_name,"No positional arguments allowed."); &fi &indent&. goto I_exit; &indent&.end; &expend &expand parm_check &if &db_sw &then &. /* % % mrpg$parm_check */ &fi &int ELSE&; &loc Indent&; &loc num&; &if &(&*^=0) &then &if &(&3=-1) &then &mrpg$rcb_put( &. 2 &1 bit(1)) &else &if &(&3=0) &then &mrpg$rcb_put( &. 2 &1 char(256)var) &else &mrpg$rcb_put( &. 2 &1 char(&3)) &+ &fi &fi &. &let keylist{&2}=&1&; &if &(&*=3) &then I_positional(&2): &let Indent=&indent&; &else &indent&.&ELSE&.if (I_arg = &4) &let ELSE = else &; &let num=5&; &do &while &(&num <= &*)&; &indent&.| (I_arg = &{&num}) &+ &let num = &(&num+1)&; &od &indent&.then do; &let Indent=&indent&. &; &fi &if &((&*>3) * (&3>=0)) &then &Indent&.call I_get_arg(code); &Indent&.if (code ^= 0) &Indent&.then do; &Indent&. call com_err_(code,R_name,"Value for &unquote &4&;"); &Indent&. return; &Indent&.end; &fi &if &(&3=-1) &then &Indent&1 = "1"b; &else &Indent&1 = I_arg; &fi &Indent&.I_present(&2) = "1"b; &if &(&* ^= 3) &then &indent&.end; &else &indent&.goto I_argloop; &fi &. &else &indent&.else do; &indent&. call com_err_(&mrpg$et_(badopt),R_name,"^a",I_arg); &indent&. I_error = "1"b; &indent&.end; &indent&.goto I_argloop; &fi&. &expend &expand parm_default &if &db_sw&then &. /* % % mrpg$parm_default */ &fi &if &(&argdone=0) &then I_argdone: &indent&.code = 0; &let argdone=1&; &fi &. if ^I_present(&2) &indent&.then do; &. &1 = &4; &. I_present(&2) = "1"b; &indent&.end; &expend &expand parm_end &if &db_sw &then &. /* % % mrpg$parm_end */ &fi &. dcl I_parameter(&parmct) char(&1) int static init( "&keylist{,", "}" ); &if &(&argdone=0) &then &. I_argdone: &indent&.code = 0; &let argdone=1&; &fi &indent&.do I_i = 1 to &parmct; &indent&. if ^I_present(I_i) &indent&. then do; &indent&. I_error = "1"b; &indent&. call com_err_(0,R_name,"Parameter ""^a"" missing.",I_parameter(I_i)); &indent&. end; &indent&.end; &indent&.if I_error &indent&.then code = 1; &let indent = &mrpg$undent()&; &indent&.end; /* END parameter processing */ &expend &expand picture &int PIC{300}&; &int pic_ct=0&; &let pic_ct=&(&pic_ct+1)&; &let PIC{&pic_ct}=&3&; &loc i=0&; &do &let i=&(&i+1)&; &while &PIC{&i}^=&3&; &od &if &pic_ct=&i &then &let dclist=dcl P_IC&pic_ct pic&3; &; &fi &indent&.C_size = H_pic&pic_ct; &indent&.(size):&1 = convert(P_IC&i,&2); /* &3 */ &indent&.if "0"b then do; H_pic&pic_ct: &indent&. call ioa_("^a: The value of &2 (^f) does not fit in picture "&3"", &indent&. R_name, &2); &indent&. &1 = "**"; &indent&.end; &indent&.C_size = H_default; &expend &expand print &indent&.call X_&1; &expend &expand proc &ext db_sw=&7&; &ext parm_sw=&8&; &if &db_sw &then &. /* % % mrpg$proc */ &fi &ext rep_no=0&;&+ &ext reports{25}list&; &ext cur_rep=H_F&; &ext break_no&; &ext report=&3&; &ext keylist{50}var&; &ext argdone=0&; &ext dclist{100}list&; &ext P_int=0&; &ext P_if=0&; &ext P_dec_char=0&; &ext A_dec_char=0&; &ext phase_ct = -1&; &ext report=&3&; &ext initial&; &ext initial2&; &ext indent=&. &; &ext open_mode&; &let open_mode=&if &5=-2&+ &then 2&+ &else 5&+ &fi&; /* &indent&.GENERATED FROM &2>&3.mrpg &indent&.Generated by : &1 &indent&.Generated on : &unquote &[date_time]&;&. */ &report: proc; dcl M_version char(32); M_version = "&1"; dcl I_error bit (1); dcl (size, conversion) condition; &let dclist = dcl ioa_ entry options (variable); &;&+ &if &4V=V&+ &then &. call com_err_ (0, R_name, "This report cannot be called as a command since the INPUT specification contained neither the FILE nor the ATTACH option in &report.mrpg."); &else &loc read = &if &5=-1&+ &then read_record&+ &else &if &5=-2&+ &then get_line&+ &else get_line&+ &fi &fi&; &loc write = &if &5=-1&+ &then write_record&+ &else put_chars&+ &fi&; &if &parm_sw &then &indent&.call cu_$arg_list_ptr (I_arglp); &let dclist = dcl cu_$arg_list_ptr entry (ptr); &; &fi &indent&.call cu_$arg_count (I_i); &let dclist = dcl cu_$arg_count entry (fixed bin); &; &indent&.begin; &let indent=&mrpg$indent()&; dcl buff char (&scan &&+&6&;); dcl cleanup condition; dcl I_code fixed bin (35); dcl recl fixed bin (21); dcl error_table_$end_of_info fixed bin (35)ext static; dcl iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35)); dcl iox_$open entry (ptr,fixed bin,bit (1),fixed bin (35)); dcl iox_$&read entry (ptr,ptr,fixed bin (21),fixed bin (21),fixed bin (35)); dcl iox_$&write entry (ptr,ptr,fixed bin (21),fixed bin (35)); dcl iox_$close entry (ptr,fixed bin (35)); dcl iox_$detach_iocb entry (ptr,fixed bin (35)); dcl unique_bits_ entry returns (bit (70)); dcl unique_chars_ entry (bit (*)) returns (char (15)); dcl sn char (15); dcl icbp ptr; dcl ocbp ptr; %include iocb; &indent&.icbp, ocbp, I_ptra = null (); &indent&.on condition (cleanup) begin; &indent&. if (I_ptra ^= null ()) &indent&. then I_write_count = 0; &indent&. if (icbp ^= null ()) &indent&. then do; &indent&. call iox_$close (icbp, 0); &indent&. call iox_$detach_iocb (icbp, 0); &indent&. icbp = null(); &indent&. end; &indent&. if (ocbp ^= null ()) &indent&. then do; &indent&. call iox_$close (ocbp, 0); &indent&. call iox_$detach_iocb (ocbp, 0); &indent&. ocbp = null(); &indent&. end; &indent&.end; &indent&.sn = unique_chars_ (unique_bits_ ()); &indent&.call iox_$attach_name (sn||"_o", ocbp, "report_ &report --EOP--", null(), I_code); &mrpg$err(Attach output) &indent&.I_ptra = ocbp->attach_data_ptr; &if &parm_sw &then &indent&.I_argno = 0; &indent&.call I_argproc (I_cmdarg,I_code); /* process arguments */ &indent&.if (I_code ^= 0) &indent&.then goto dto; &else &indent&.if (I_i > 0) &indent&.then do; &indent&. call com_err_ (&mrpg$et_(too_many_args),R_name); &indent&. goto dto; &indent&.end; &let dclist = dcl cu_$arg_count entry (fixed bin); &; &fi &indent&.call iox_$open (ocbp,&open_mode, "0"b, I_code); &mrpg$err(Open output,dto) &indent&.call iox_$attach_name (sn||"_i", icbp, &4, null(), I_code); &mrpg$err(Attach input,clo) &indent&.call iox_$open (icbp,&(&open_mode-1), "0"b, I_code); &indent&.if (I_code ^= 0) &indent&.then do; &indent&. call com_err_ (I_code, R_name, "Trying to open ^a",&4); &indent&. goto dti; &indent&.end; loop: &indent&.call iox_$&read (icbp,addr (buff),length (buff),recl,I_code); &indent&.if (I_code = error_table_$end_of_info) &indent&.then goto quit; &mrpg$err(On input,cli) &indent&.call iox_$&write (ocbp,addr (buff),recl,I_code); &mrpg$err(On output,cli) &indent&.goto loop; quit: cli: &indent&.call iox_$close (icbp, 0); dti: &indent&.call iox_$detach_iocb (icbp, 0); clo: /* there is trouble if records are being held, this $close is done, */ /* ..QUIT is hit while the report is printing, and then release is typed. */ /* So we must insure that the cleanup handler doesn't $close again. */ &indent&.begin; dcl tp ptr; &indent&. tp = ocbp; &indent&. ocbp = null(); &indent&. call iox_$close (tp, 0); &indent&.end; dto: &indent&.call iox_$detach_iocb (ocbp, 0); &if &parm_sw &then I_cmdarg: &indent&.proc (code); dcl code fixed bin (35); &let indent=&mrpg$indent()&; &indent&.I_argno = I_argno + 1; &indent&.call cu_$arg_ptr_rel (I_argno,I_argp,I_argl,I_code,I_arglp); dcl cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr); &let indent=&mrpg$undent()&; &indent&.end; dcl cu_$arg_list_ptr entry (ptr); &fi &let indent=&mrpg$undent()&; &indent&.end; dcl I_arglp ptr; &fi I_exit: &indent&.return; &ext new_phase=/* Initialize for phase begin */ &; &ext local=0&; &ext rcb_lines=0&; &ext rcb&; &ext last_rcb=0&; &ext Ircb=***&; &ext rcb_ct=0&; &mrpg$rcb_put(&mrpg$rcb(H_F,work area for building headers/footers,256)) &mrpg$rcb_end() &mrpg$rcb_put( /* ----- parameters ----- */) &expend &expand rcb &if &3^=500&then &if &3^=256&then &[signal rcb_error] &fi &fi &let initial2 = &initial2 &1.I_name = "&1";&; &. 2 &1 /* &2 */, 3 I_H_F like H_F_common, 3 I_rec char(&3) /* record area */&expend &expand rcb_begin &let rcb_ct=&(&rcb_ct+1)&; &let initial = &initial R_cb0.I_base(&rcb_ct) = addr (R_cb&last_rcb.D_ummy);&; &let last_rcb = &rcb_ct&; &let rcb_lines=0&; &let rcb = &rcb dcl 1 R_cb&rcb_ct based (R_cb0.I_base(&rcb_ct))&; &expend &expand rcb_end &if &rcb_lines=0&+ &then&return &fi &let rcb_lines=0&; &let rcb = &rcb, 2 D_ummy ptr; /* get a double word alignment */ &;&expend &expand rcb_put &if &rcb_lines=250&+ &then &mrpg$rcb_end() &fi &if &rcb_lines=0&+ &then &mrpg$rcb_begin() &fi &let rcb_lines=&(&rcb_lines+1)&; &let rcb = &rcb&if&substr &1,1,2&;^=/*&then,&fi&. &1&;&expend &expand rep_break &if &db_sw &then &. /* % % mrpg_$rep_break */ &fi &let break_no=&(&break_no+1)&; &mrpg$rcb_put( &. 4 &1 &2&;) &if &break_no= 1 &then &indent&.string(&cur_rep.I_level) = "0"b; &fi &indent&.&if &break_no^=1&then else &;if (&cur_rep.&1 ^= I.&1) &indent&.then do; &indent&. substr(string(&cur_rep.I_level),&break_no+1) = "11111111111111111111111111111111"b; &indent&.end; &expend &expand rep_head &if &db_sw &then &. /* % % mrpg$rep_head */ &fi&. &indent&.if &cur_rep.I_first &indent&.then do; &indent&. &cur_rep.I_first = "0"b; &expend &expand report &if &1=PF&then&.%page;&fi &+ &if &db_sw &then &. /* % % mrpg$report &1 */ &fi&+ &int undent=0&;&+ &if &rep_no=RF&+ &then &indent&.call P_line (&if &db_sw&then mrpg_get_ln_(),&fi&.0); &indent&.return; &let indent = &mrpg$undent()&; &indent&.end; &. &fi&+ &do &while&(&undent>0)&; &let undent=&(&undent-1)&; &let indent = &mrpg$undent()&; &indent&.end; &od&+ &let rep_no=&1&; &if &1=PF&+ &then &int detail=0&; &let detail=1&; &ext first_rep=&2&; &let reports=C_&2&; &let initial2 = &initial2 &cur_rep.I_next = addr(&2); &; &let cur_rep=&2&; &let new_phase = &new_phase &cur_rep.I_level = -1; &;&+ &let break_no=0&; &int pagelength&; &let pagelength=&4&; &let initial2=&initial2 &cur_rep.I_level = 999; &cur_rep.I_minl = &5; &cur_rep.I_maxl = &6; &indent&cur_rep.I_pl = &4; &cur_rep.I_pw = &3; &cur_rep.I_inited = "0"b; &; &mrpg$rcb_end() &mrpg$rcb_put( /* ----- report data ----- */) &mrpg$rcb_put(&mrpg$rcb(&cur_rep,data fields for REPORT &cur_rep,500))&+ &int put_chars=1&; &if &put_chars &then &let put_chars=0&; P_chars: proc(&if &db_sw&then lno,&fi&.rcbp,lcbp,lin); &if &db_sw&then dcl lno fixed bin(18); &fi dcl rcbp ptr, /* report control block */ lcbp ptr, /* line control block */ lin fixed bin; /* line on which to print */ dcl 1 r like H_F based(rcbp); dcl 1 l like H_F based(lcbp); dcl i fixed bin (21); &if &db_sw &then &let dclist = dcl iox_$user_output ptr ext static; &;&let dclist = dcl mrpg_get_ln_ entry returns(fixed bin(18)); &;&let dclist = dcl ioa_ entry options(variable); &;&let dclist = dbn: entry; db_sw = "1"b; return; &;&let dclist = dbf: entry; db_sw = "0"b; return; &;&let dclist = dcl db_sw bit(1) int static init("0"b); &; &fi &if &db_sw &then /* ## */ 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); &fi &. if (r.I_pl ^= 0) then do; if (lin = 0) then i = r.E_P - r.I_line; else i = max (lin, r.E_P) - r.I_line; end; else i = lin - r.I_line; if (i < 0) then do; if (r.E_P = 4) then do; call iox_$put_chars (r.I_iocb, addr(FF), 1, I_code); &if &db_sw &then /* ## */ if db_sw then call iox_$put_chars(iox_$user_output, addr(FF),1,0); &fi &. i = min (0, lin-4); end; else i = r.I_pl - r.I_line + lin; end; if (i > 0) then begin; dcl ch char(i); ch = copy(NL,i); call iox_$put_chars(r.I_iocb,addr(ch),i,I_code); &if &db_sw &then /* ## */ if db_sw then call iox_$put_chars(iox_$user_output,addr(ch),i,0); &fi &. end; if (lin > 0) then do; substr(l.I_rec,l.I_len+1,1) = NL; call iox_$put_chars(r.I_iocb,addr(l.I_rec),l.I_len+1,I_code); &if &db_sw &then /* ## */ if db_sw then call iox_$put_chars(iox_$user_output,addr(l.I_rec),l.I_len+1,0); &fi &. r.I_line = max(r.E_P, lin) + 1; end; else if (r.I_pl ^= 0) then r.I_line = r.E_P; else r.I_line = lin + 1; l.I_len = 0; l.I_vlen = 0; l.I_loc = 0; l.I_vloc = 0; l.I_rec = ""; dcl FF bit(9) int static init ("014"b3); dcl NL char(1) int static init(" "); end P_chars; &.%page;&fi &. /* DEFINE 1 REPORT &cur_rep */ X_&cur_rep: &indent&.proc; &let indent = &mrpg$indent()&; &. P_line: &indent&.proc (&if &db_sw&then lno,&fi&.lin); &if &db_sw&then dcl lno fixed bin(18); &fi dcl lin fixed bin; dcl W_line fixed bin; &let indent = &mrpg$indent()&; &if &db_sw &then /* ## */ if db_sw then call ioa_("&cur_rep ^i: ^i ^i",lno,lin,&cur_rep.I_minl); &fi &if &pagelength &then &indent&.if (lin = 0) &indent&.then do; &indent&. if (&cur_rep.I_line = &cur_rep.E_P) &indent&. then return; /* already at E_P */ &indent&. goto I_pagefoot; &indent&.end; &indent&.W_line = max (lin, &cur_rep.I_minl); &indent&.if (&cur_rep.I_line = &cur_rep.E_P) &indent&.then goto I_pagehead; &indent&.if (W_line > &cur_rep.I_maxl) &indent&.| (&cur_rep.I_page = 0) &indent&.then do; &let indent = &mrpg$indent()&; &indent&.W_line = &cur_rep.I_minl; I_pagefoot: &indent&.if (&cur_rep.I_page > 0) &indent&.then do; &let indent = &mrpg$indent()&; &fi &return &fi&+ &if &1=PH&+ &then &if &pagelength &then &indent&.call P_chars (&if &db_sw&then mrpg_get_ln_(), &fi addr (&cur_rep), addr (H_F), 0); &let indent = &mrpg$undent()&; &indent&.end; &indent&.if (lin ^= 0) &indent&.then do; &let indent = &mrpg$indent()&; I_pagehead: &indent&.&cur_rep.I_page = &cur_rep.I_page + 1; &fi &return &fi&+ &if &1=ON&+ &then &if &pagelength &then &indent&.W_line = max (W_line, &cur_rep.I_line); &let indent = &mrpg$undent()&; &indent&.end; &let indent = &mrpg$undent()&; &indent&.end; &indent&.if (lin = 0) &indent&.then return; &else &indent&.W_line = lin; &indent&.&cur_rep.I_page = 1; /* show we've started output */ &fi &indent&.call P_chars (&if &db_sw&then mrpg_get_ln_(), &fi addr (&cur_rep), addr (&cur_rep), W_line); &mrpg$err(Put to REPORT &cur_rep) &let indent = &mrpg$undent()&; &indent&.end; E_nvir: proc; &let indent = &mrpg$indent()&; &indent&.if ^&cur_rep.I_inited &indent&.then do; &let indent = &mrpg$indent()&; &indent&.&cur_rep.I_inited = "1"b; &return &fi&+ &if &1=BR&+ &then &indent&.&cur_rep.I_page = 0; &indent&.&cur_rep.I_len = 0; &indent&.&cur_rep.I_vlen = 0; &indent&.&cur_rep.I_loc = 0; &indent&.&cur_rep.I_vloc = 0; &let indent = &mrpg$undent()&; &indent&.end; &return &fi&+ &if &1=DF&+ &then &indent&.if (&cur_rep.I_level <= &2) && (&cur_rep.I_page > 0) &indent&.then begin; dcl 1 L_ like I_ based (R_cb0.O_data_p); &let indent = &mrpg$indent()&; &let undent=&(&undent+1)&; &if &*=4&then &indent&.if ( &4 ) &indent&.then do; &let indent = &mrpg$indent()&; &let undent=&(&undent+1)&; &fi &return &fi&+ &if &1=RF&+ &then &indent&.if (&cur_rep.I_level = 0) &indent&.then do; &let indent = &mrpg$indent()&; I_reportfoot: &return; &fi&+ &if &1=RH&+ &then &indent&.if (&cur_rep.I_page = 0) &indent&.then do; &let indent = &mrpg$indent()&; &let undent=&(&undent+1)&; I_reporthead: &return &fi&+ &if &1=DH&+ &then &indent&.if (&cur_rep.I_level <= &2) &indent&.then do; &let indent = &mrpg$indent()&; &let undent=&(&undent+1)&; &if &*=4&then &indent&.if ( &4 ) &indent&.then &let indent = &mrpg$indent()&; &let undent=&(&undent+1)&; &fi &return; &fi&+ &if &1=DT&+ &then &if &detail &then &let detail=0&; &let indent = &mrpg$undent()&; &indent&.end; &else &indent&.return; &fi&. X_&2: &indent&.entry; &if &*=4&then &indent&.if ^(&4) &indent&.then return; &fi &indent&.if (&cur_rep.I_level < 0) &indent&.then &cur_rep.I_level = 1; &indent&.else &cur_rep.I_level = 999; &indent&.call E_nvir; &indent&.R_cb0.O_data_p -> I_ = R_cb0.N_data_p -> I_; &if &(&3>0)&then &indent&.if (&cur_rep.I_line > &3) &indent&.then call P_line(&if &db_sw&then mrpg_get_ln_(),&fi&.0); &fi &indent&./* do DETAIL */ &return; &fi&+ &if &1=9&+ &then &indent&.return; C_&cur_rep: &indent&.entry; /* entry to close out this report */ &indent&.&cur_rep.I_level = 0; &indent&.if &cur_rep.I_inited &indent&.then do; &indent&. if (I_write_count ^= 0) &indent&. then call E_nvir; &indent&. if (&cur_rep.I_atd ^= "user_output") &indent&. then do; &indent&. call iox_$close (&cur_rep.I_iocb, 0); &let dclist = dcl iox_$close entry (ptr, fixed bin(35)); &; &let dclist = dcl iox_$detach_iocb entry (ptr, fixed bin(35)); &; &indent&. call iox_$detach_iocb (&cur_rep.I_iocb, 0); &indent&. end; &indent&.end; &let indent = &mrpg$undent()&; &indent&.end; &return; &fi &error 3,Unknown type "&1".&; &expend &expand sort &if &db_sw &then &. /* mrpg$sort &1 &2 */ &fi &if &(&*=1) &then &int mode&; &let mode=&1&; &int keys{50}list&; &empty keys&; &int key_ct&; &let key_ct=0&; &return &fi &int movein{150}list&; &int movout{150}list&; &int dcls{150}list&; &int dclsct=0&; &if &(&*^=0) &then &if &1^=&+ &then &if &1=D&+ &then &loc v=-1&; &else &loc v= 1&; &fi &let key_ct = &(&key_ct+1)&; &let keys = &indent if (P_1 -> N_&2 < P_2 -> N_&2) &indent&. then return (&(-(&v))); &indent&. if (P_1 -> N_&2 > P_2 -> N_&2) &indent&. then return (&v); &; &else &let movein= &indent&.N_&2 = &2; &; &let movout= &indent&. &2 = N_&2; &; &loc sz=&.(&4)&; &if &3=float dec(20)&then &let sz=&;&fi &if &(&4=0)&then &let sz=&;&fi &if &(&4<0)&then &let sz=&.(&substr &4,2&;)var&;&fi &let dcls=N_&2 &3&sz&; &let dclsct = &(&dclsct+1)&; &fi &return; &fi &if &mode=HD&then &if &((&phase_ct=0)*(&dclsct>0))&then &indent&.allocate D_ph in (D_place) set (R_ecptr); &ext D_place=1&; &indent&.D_l->D_list.R_ecct = D_l->D_list.R_ecct+1; &indent&.D_l->D_list.R_ecp (D_l->D_list.R_ecct) = R_ecptr; dcl 1 D_ph based(R_ecptr), 2 &dcls{,, 2 }; &fi &movein{,} &fi &if &key_ct^=0&then S_ph&phase_ct: proc (P_1, P_2) returns(fixed bin(1)); dcl (P_1, P_2) ptr unal; &keys{} &indent&. return (0); &indent&.end; &fi &if &key_ct^=0&then &indent&.call sort_items_$general (D_l, S_ph&phase_ct); &let dclist = dcl sort_items_$general entry (ptr, entry); &;&fi &if &mode^=HD&then &if &(&phase_ct^=0)&then &indent&.do I_curec = 1 to D_l->D_list.R_ecct; &let indent = &mrpg$indent()&; &if &mode=SU&then&indent&.lptr = R_ecptr; &fi &indent&.R_ecptr = D_l->D_list.R_ecp(I_curec); &let dclist = dcl I_curec fixed bin (24); &; &if &mode=SU&then&indent&.if (S_ph&phase_ct (lptr, R_ecptr) = 0) &indent&.then do; &indent&. goto somewhere; &indent&.end; &fi &movout{,} &fi &fi &expend &expand table &int table&; &int fromtype&; &int totype&; &int fromlist{100}&; &int count=0&; &int tolen=0&; &int fromlen=0&; &int tolist{100}&; &if &(&*>2) &then &let table=&2&; &let fromtype = &3&; &let totype = &4&; &let count=0&; &let tolen=0&; &let fromlen=0&; &return &fi &loc i = &(&length &1&;-2)&; &if &(&*^=0) &then &let count=&(&count+1)&; &let fromlist{&count}=&1&; &if &(&i > &fromlen) &then &let fromlen = &i&; &fi &if &totype^=&then &let tolist{&count}=&2&; &let i = &(&length &2&;-2)&; &if &(&i > &tolen) &then &let tolen = &i&; &fi &fi &return &fi &loc leng=&tolen&; &. &table: proc(xx) returns(&if &totype^=&then &scan &totype&;&else bit(1)&fi); dcl xx &if &substr &fromtype,1,5&;=float&then float dec(20)&else char(*)&fi; &let leng=&fromlen&; dcl in (&count) &scan &fromtype&;&. int static options (constant) init ( &fromlist{1:&count,, }); dcl i fixed bin; do i = 1 to &count; if (in(i) = xx) &if &totype=&+ &then &. then return("1"b); end; return("0"b); &else &. then return(out(i)); end; &.&if &substr &fromtype,1,5&;=float&+ &.&then &.&. call com_err_(0,R_name,"Value not found in table &table. ^f",xx); &.&else &.&. call com_err_(0,R_name,"Value not found in table &table. ""^a""",xx); &.&fi &. I_write_count = 0; /* block action of next $close */ signal condition (conversion_error); &.&if &substr &totype,1,5&;=float&+ &.&then&. return (0); /* can't think of any better value */ &.&else&. return (""); /* can't think of any better value */ &.&fi&. dcl conversion_error condition; &fi &if &totype^=&then &let leng = &tolen&; dcl out (&count) &scan &totype&;&. int static options (constant) init ( &tolist{1:&count,, }); &fi end; &expend &expand value &if &db_sw &then &. /* % % mrpg$value(&rep_no) &{1:&*} */ &fi &if &1&5=""0&then&return&fi &loc value = &1&; &loc type = &2&; &loc size = &3&; &loc col = &4&; &loc leng = &5&; &loc align = &6&; &loc alch = &7&; &loc fold1 = &8&; &loc fold2 = &9&; &if &type=4&+ &then &let value = &.(P_int(&value))&; &let P_int=1&; &fi &if &((&type=5)+(&type=18))&+ &then &let value = &.(P_dec_char(&value))&; &let P_dec_char=1&; &fi &if &((&type=2)+(&type=3)+(&type=7))&+ &then &let value = &.(&value)&; &fi &loc NL&; &if &substr &value,1,1&;="&+ &then &if &(&length &value&;>55)&+ &then &let NL=&. &indent &;&+ &fi&+ &fi &indent&if &[index " DH DT DF " &rep_no]^=0&+ &then call P_field(addr(&cur_rep),&col,"&align"b,"&alch",&leng,&NL&value); &else call P_field(addr(&. H_F),&col,"&align"b,"&alch",&leng,&NL&value); &fi &expend &expand undent &substr &indent,4&;&expend ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group BULL including BULL HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell BULL Inc., Groupe BULL and BULL HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato. Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, BULL or BULL HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by BULL HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved