cobol_paragraph_gen.pl1 05/24/89 1042.8rew 05/24/89 0832.7 47349 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_paragraph_gen.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /*{*/ /* format: style3 */ cobol_paragraph_gen: proc (in_token_ptr); /* The procedure cobol_paragraph_gen performs the following functions; 1. Generates an end-of-perform range alterable GO and incre- ments perform_para_index by 1 if the paragraph being ter- minated is at the end of a perform range as determined by examining para_eop_flag (1, it is; 0, it is not). 2. Determines if the paragraph being entered is at the end of a perform range by examining perform_list.perf.proc_num (perform_para_index) and if it is sets para_eop_flag to 1. If it is not, para_eop_flag is set to 0. 3. Determines if the paragraph being entered is alterable by examining alter_list.goto.proc_num(alter_index). If it is, alter_flag is set to 1. If it is not, alter_flag is set to 0. 4. Associates the paragraph's procedure number with the text location into which the first instruction emitted by the next generator called will be placed (this is the first free text location following the code, if any, emitted by cobol_paragraph_gen). U__s_a_g_e:_ declare cobol_paragraph_gen entry (ptr); call cobol_paragraph_gen(in_token_ptr); */ %include cobol_in_token; /* G__e_n_e_r_a_t_e_d_C__o_d_e:_ The following code is generated by cobol_paragraph_gen if the para- graph just processed is at the end of a perform range i.e. if para_eop_flag is 0 upon entry; lda target_An tra 0,al where: target_An is a 36-bit variable allocated in the program's COBOL data segment. Each target_An, for n = 1, 2, 3, ..., is uniquely associated with the procedure at whose end these instructions are generated. */ /* D__a_t_a:_ % include cobol_; Items in cobol_$incl.pl1 used (u) and/or (s) by cobol_paragraph_gen; cobol_ptr (u) alter_flag (s) alter_index (s) alter_list_ptr (u) para_eop_flag (u/s) perform_list_ptr (u) perform_para_index (u/s) */ %include cobol_alter_list; %include cobol_perform_list; %include cobol_perform_altgo; %include cobol_type7; dcl proc_no fixed bin; /* Tag number of paragraph being entered. */ /* P__r_o_c_e_d_u_r_e_s_C__a_l_l_e_d:_ */ dcl cobol_addr entry (ptr, ptr, ptr), cobol_emit entry (ptr, ptr, fixed bin), cobol_define_tag entry (fixed bin), cobol_register$load entry (ptr); /* B__u_i_l_t-__i_n_F__u_n_c_t_i_o_n_s_U__s_e_d:_ */ dcl addr builtin, null builtin; /*}*/ %include cobol_; start: /* Get procedure (tag) number of paragraph being entered. */ proc_no = in_token.token_ptr (1) -> proc_def.proc_num; /* Paragraph alterable? */ if cobol_$alter_list_ptr ^= null then do; if cobol_$alter_index <= alter_list.n then if alter_list.goto.proc_num (cobol_$alter_index) = proc_no then cobol_$alter_flag = 1; else cobol_$alter_flag = 0; else cobol_$alter_flag = 0; end; /* Paragraph at end-of-perform range? */ if cobol_$perform_list_ptr ^= null then do; /* Paragraph being terminated. */ if cobol_$para_eop_flag ^= 0 then /* Insert alterable GO */ do; call cobol_register$load (addr (register_request)); input_struc_basic.segno = perform_list.perf.target_a_segno (cobol_$perform_para_index); input_struc_basic.char_offset = perform_list.perf.target_a_offset (cobol_$perform_para_index); call cobol_addr (addr (input_struc_basic), addr (prfrm_altgo_inst_pr), null); call cobol_emit (addr (prfrm_altgo_inst_pr), null, 2); call cobol_define_tag (perform_list.perf.int_tag_no (cobol_$perform_para_index)); cobol_$para_eop_flag = 0; cobol_$perform_para_index = cobol_$perform_para_index + 1; end; /* Paragraph being entered. */ if cobol_$perform_para_index <= perform_list.n then if proc_no = perform_list.perf.proc_num (cobol_$perform_para_index) then cobol_$para_eop_flag = 1; else cobol_$para_eop_flag = 0; else cobol_$para_eop_flag = 0; end; /* Associate procedure number with next location in text. */ call cobol_define_tag (proc_no); return; end cobol_paragraph_gen;  cobol_paste.pl1 05/24/89 1042.8rew 05/24/89 0830.0 146097 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_paste.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 04/08/81 by FCH, [4.4-2], COMMUNICATION mispelled, BUG481(TR9775) */ /* Modified on 04/01/81 by FCH, fix decl for map_data_table, [4.4-1], BUG472(TR8896,8970) */ /* Modified on 07/21/78 by RAL, [3.0-2], fix bad call to ioa_$rs */ /* Modified on 07/14/78 by FCH, [3.0-1], cobol_object_map.incl.pl1 changed */ /* Modified since Version 3.0 */ /*{*/ /* format: style3 */ cobol_paste: proc (value_ptr); /* This is the final procedure called in the fixup phase. It provides for the creation of the object segment and produces the object map. When this routine returns, the object segment is complete and in the user's working directory with proper access set. */ /* DECLARATIONS */ dcl relseg_ptr ptr; dcl temp fixed bin (35); dcl 1 relseg (4) based (relseg_ptr), 2 pt ptr, 2 maxoff fixed bin, 2 abscnt fixed bin; dcl block_relp (4) bit (18); dcl bytes char (262144) based (bptr); dcl seg char (262144) based (segptr); dcl long_mes char (100) aligned; dcl short_mes char (8) aligned; dcl (bptr, segptr) ptr; dcl aclinfop ptr; dcl i fixed bin; dcl bc fixed bin (24); dcl code fixed bin (35); dcl woff fixed bin; dcl (bpos, blen) fixed bin (21); dcl (wlen, tlen) fixed bin; dcl 1 map_data_table aligned based (cobol_$map_data_ptr), 2 no_source_stmts fixed bin aligned, 2 data (0 refer (map_data_table.no_source_stmts)), 3 line_no fixed bin unaligned, 3 text_addr fixed bin unaligned, /*[4.4-1]*/ 3 col fixed bin unal, /*[4.4-1]*/ 3 label bit unal; dcl cobol_make_list entry (ptr, fixed bin); dcl ioa_$rs entry options (variable); dcl ioa_$rsnnl options (variable); dcl hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)); dcl cobol_call_op$get_op entry (ptr); dcl cobol_reloc$constants entry (fixed bin, ptr); dcl get_wdir_ entry returns (char (168) aligned); dcl tssi_$get_segment entry (char (*), char (*) aligned, ptr, ptr, fixed bin (35)); dcl tssi_$finish_segment entry (ptr, fixed bin (24), bit (36) aligned, ptr, fixed bin (35)); dcl tssi_$clean_up_segment entry (ptr); dcl convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned); dcl signal_ entry (char (*), ptr, ptr); dcl cleanup condition; /*************************************/ start: aclinfop = null; on cleanup call CL; call tssi_$get_segment (get_wdir_ (), cobol_$obj_seg_name, segptr, aclinfop, code); if code ^= 0 then go to multics_error; call cobol_reloc$constants (value.con_len, relseg_ptr); object_map.text_relp = (18)"0"b; bptr = addrel (cobol_$con_end_ptr, -value.con_len + 1); blen = 4 * value.con_len; substr (seg, 1, blen) = substr (bytes, 1, blen); bpos = blen + 1; blen = 4 * value.code_len; substr (seg, bpos, blen) = substr (cobol_$text_base_ptr -> bytes, 1, blen); object_map.text_length = substr (unspec (value.text_len), 19, 18); bpos = bpos + blen; woff = value.text_len; object_map.def_relp = substr (unspec (woff), 19, 18); blen = 4 * value.def_len; substr (seg, bpos, blen) = substr (cobol_$def_base_ptr -> bytes, 1, blen); object_map.def_length = substr (unspec (value.def_len), 19, 18); bpos = bpos + blen; woff = woff + value.def_len; if mod (woff, 2) = 1 then do; /* link section must begin on even word */ substr (seg, bpos, 4) = (4)""; /* "\000" */ bpos = bpos + 4; woff = woff + 1; end; object_map.link_relp = substr (unspec (woff), 19, 18); temp = fixed (object_map.link_relp) + 8; /* [3.0-1] */ object_map.static_relp = substr (unspec (temp), 19, 18); /* [3.0-1] */ temp = fixed (linkage_header.links_relp) - 8; /* [3.0-1] */ object_map.static_length = substr (unspec (temp), 19, 18); /* [3.0-1] */ blen = 4 * value.link_len; substr (seg, bpos, blen) = substr (cobol_$link_base_ptr -> bytes, 1, blen); object_map.link_length = substr (unspec (value.link_len), 19, 18); bpos = bpos + blen; woff = woff + value.link_len; sym_ptr = addrel (segptr, woff); object_map.symb_relp = substr (unspec (woff), 19, 18); blen = 4 * value.sym_len; substr (seg, bpos, blen) = substr (cobol_$sym_base_ptr -> bytes, 1, blen); bpos = bpos + blen; woff = woff + value.sym_len; tlen = value.sym_len; do i = 1 to 4; /* append relocation blocks */ relptr = relseg.pt (i); relinfo.decl_vers = 1; /*[3.0-1]*/ wlen = 3 + divide (n_bits - 1, 36, 17, 0); blen = 4 * wlen; substr (seg, bpos, blen) = substr (relptr -> bytes, 1, blen); block_relp (i) = substr (unspec (tlen), 19, 18); bpos = bpos + blen; woff = woff + wlen; tlen = tlen + wlen; end; symbol_block_header.text_relocation_relp = block_relp (1); symbol_block_header.def_relocation_relp = block_relp (2); symbol_block_header.link_relocation_relp = block_relp (3); symbol_block_header.symbol_relocation_relp = block_relp (4); object_map.symb_length = substr (unspec (tlen), 19, 18); symbol_block_header.block_size = object_map.symb_length; object_map.last_word.object_map_relp = substr (unspec (woff), 19, 18); substr (seg, bpos, 48) = substr (addr (object_map) -> bytes, 1, 48); /* [3.0-1] */ bc = 36 * (woff + 12); /* [3.0-1] */ if fixed_common.options.xrn then call print_map; if fixed_common.options.obj then call cobol_make_list (addrel (segptr, value.exec_off + value.con_len), value.code_len - value.exec_off); call tssi_$finish_segment (segptr, bc, "1100"b, aclinfop, code); if code ^= 0 then go to multics_error; revert cleanup; exit: return; CL: proc; call tssi_$clean_up_segment (aclinfop); end CL; /*************************************/ /* print_map */ print_map: proc; dcl char_off fixed bin (24), char_string char (1048576) based (cobol_$list_ptr), p ptr, nl char (1), print_line char (600) unal based; dcl line_len fixed bin; dcl 1 acc aligned based, 2 length fixed bin (8) unal, 2 string char (0 refer (acc.length)) unal; dcl 1 type_pair aligned based, 2 type bit (18) unal, 2 trap_relp bit (18) unal, 2 segname_relp bit (18) unal, 2 offset_relp bit (18) unal; dcl 1 exp_word aligned based, 2 type_pair_relp bit (18) unal, 2 expression bit (18) unal; dcl auto_len fixed bin; dcl operator_struc_ptr ptr; dcl 1 operator_struc aligned based, 2 op_bits bit (200); dcl op_space char (115); dcl oper_name char (nsize) based (nptr) aligned; dcl nsize fixed bin; dcl nptr ptr; dcl (i, j, k, l) fixed bin; dcl cobol_operator_names_$cobol_operator_names_ ext; dcl 1 operator_names based (addr (cobol_operator_names_$cobol_operator_names_)), 2 first fixed bin, 2 last fixed bin, 2 first_special fixed bin, 2 last_special fixed bin, 2 no_special fixed bin, 2 name (0 refer (first):1 refer (last)), 3 namep bit (18), 3 len bit (18); dcl mcode fixed bin (35); dcl 1 link aligned based, 2 header bit (18) unal, 2 not_used bit (18) unal, 2 expr_relp bit (18) unal, 2 not_used1 char (18) unal; dcl (str1, str2, str3, str4, str5) char (132), strlen fixed bin; dcl no_links fixed bin, fill char (1), (object_len, text_len, def_len, link_len, symb_len, static_len) fixed bin, temp_ptr ptr, seg_ptr ptr, temp_name char (65), link_ptr ptr; start_print_map: nl = " "; char_off = cobol_$list_off; p = addr (substr (char_string, char_off, 1)); p -> print_line = nl || "STORAGE REQUIREMENTS FOR THIS PROGRAM." || nl || nl || " Object Text Defs Link Symb Static" || nl; char_off = char_off + 84; p = addr (substr (char_string, char_off, 1)); auto_len = fixed (object_map.link_relp) + 8; text_len = fixed (object_map.text_relp); def_len = fixed (object_map.def_relp); link_len = fixed (object_map.link_relp); symb_len = fixed (object_map.symb_relp); static_len = fixed (object_map.link_relp) + 8; call ioa_$rs ("Start^-^6o^-^6o^-^6o^-^6o^-^6o^-^6o", p -> print_line, line_len, text_len, text_len, def_len, link_len, symb_len, static_len); char_off = char_off + line_len; p = addr (substr (char_string, char_off, 1)); object_len = fixed (object_map_relp) + 10; text_len = fixed (object_map.text_length); def_len = fixed (object_map.def_length); link_len = fixed (object_map.link_length); symb_len = fixed (object_map.symb_length); call ioa_$rs ("Length^-^6o^-^6o^-^6o^-^6o^-^6o^-^6o", p -> print_line, line_len, object_len, text_len, def_len, link_len, symb_len, value.int_storage_len); char_off = char_off + line_len; p = addr (substr (char_string, char_off, 1)); text_ptr = cobol_$text_base_ptr; auto_len = fixed (substr (entry_seq.eax7, 1, 18)); stat_ptr = addrel (cobol_$link_base_ptr, 8); if cobol_$fs_charcnt = 0 then str1 = " FILE SECTION: No files defined" || nl; else do; if fixed_common.file_count ^= 1 then fill = "s"; else fill = " "; call ioa_$rs (" FILE SECTION:^-^-^d characters for record storage for ^d file^a (DATA:0->^o)", str1, strlen, cobol_$fs_charcnt, fixed_common.file_count, fill, cobol_$fs_wdoff, (cobol_$ws_wdoff - 1)); end; if cobol_$ws_charcnt = 0 then str2 = " WORKING-STORAGE SECTION: No data defined" || nl; else do; if cobol_$value_cnt ^= 1 then fill = "s"; else fill = " "; call ioa_$rs ( " WORKING-STORAGE SECTION:^-^d characters for general storage with ^d item^a initialized (DATA:^o->^o)", str2, strlen, cobol_$ws_charcnt, cobol_$value_cnt, fill, cobol_$ws_wdoff, (cobol_$coms_wdoff - 1)); end; if cobol_$coms_charcnt = 0 then str3 = " COMMUNICATION SECTION: No data defined" || nl; /*[4.4-2]*/ else do; if cobol_$cd_cnt ^= 1 then fill = "s"; else fill = " "; call ioa_$rs ( " COMMUNICATION SECTION:^-^d characters for cd-area storage for ^d cd-name^a (DATA:^o->^o)", str3, strlen, cobol_$coms_charcnt, cobol_$cd_cnt, fill, cobol_$coms_wdoff, stat.data_len); end; if cobol_$ls_charcnt = 0 then str4 = " LINKAGE SECTION: No parameters defined" || nl; else do; if fixed_common.number_of_ls_pointers ^= 1 then fill = "s"; else fill = " "; call ioa_$rs ( " LINKAGE SECTION:^-^-^d character^a for argument storage for ^d parameter^a (allocated by caller)", str4, strlen, cobol_$ls_charcnt, fill, fixed_common.number_of_ls_pointers, fill); /* [3.0-2] */ end; if cobol_$cons_charcnt = 0 then call ioa_$rs ( " CONSTANT SECTION:^-^-No constants defined explicitly; ^d words for constant storage (TEXT:0->^o)", str5, strlen, value.con_len, value.con_len - 1); else do; call ioa_$rs ( " CONSTANT SECTION:^-^-^d characters for explicit constants; ^d words for constant storage (TEXT:0->^o)", str5, strlen, cobol_$cons_charcnt, value.con_len, value.con_len - 1); end; call ioa_$rs ( "^/External procedure ^a uses ^d words of temporary storage^/^a^a^a^a^aTotal allocation required for cobol data is ^d words", p -> print_line, line_len, fixed_common.prog_name, auto_len, str1, str2, str3, str4, str5, stat.data_len); char_off = char_off + line_len; p = addr (substr (char_string, char_off, 1)); call cobol_call_op$get_op (operator_struc_ptr); if substr (operator_struc_ptr -> op_bits, 1, operator_names.last + 1) then ; else do; p -> print_line = nl || "THERE IS NO EXTERNAL OPERATOR CALLED BY THIS PROGRAM." || nl; char_off = char_off + 55; p = addr (substr (char_string, char_off, 1)); goto ext_entry_label; end; p -> print_line = nl || "THE FOLLOWING EXTERNAL OPERATORS ARE CALLED BY THIS PROGRAM." || nl; char_off = char_off + 62; p = addr (substr (char_string, char_off, 1)); j = 0; op_space = (115)" "; do i = operator_names.first to operator_names.last; if substr (operator_struc_ptr -> op_bits, i + 1, 1) = "1"b then do; nptr = pointer (addr (operator_names.first), operator_names.namep (i)); nsize = fixed (operator_names.len (i)); substr (op_space, j * 23 + 1, nsize) = oper_name; j = j + 1; if j = 5 then do; j = 0; p -> print_line = substr (op_space, 1, 115) || nl; char_off = char_off + 116; p = addr (substr (char_string, char_off, 1)); op_space = (115)" "; end; end; end; if j ^= 0 then do; p -> print_line = substr (op_space, 1, j * 23) || nl; char_off = char_off + j * 23 + 1; p = addr (substr (char_string, char_off, 1)); end; ext_entry_label: p -> print_line = nl || "THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM." || nl; char_off = char_off + 60; p = addr (substr (char_string, char_off, 1)); no_links = cobol_$link_wd_off - 8 - value.int_storage_len; no_links = divide (no_links, 2, 17, 0); link_ptr = addrel (cobol_$link_base_ptr, linkage_header.links_relp); j = 0; op_space = (115)" "; do i = 1 to no_links; temp_ptr = addrel (cobol_$def_base_ptr, link_ptr -> link.expr_relp); temp_ptr = addrel (cobol_$def_base_ptr, temp_ptr -> exp_word.type_pair_relp); if temp_ptr -> type_pair.type = "000000000000000100"b then do; seg_ptr = addrel (cobol_$def_base_ptr, temp_ptr -> type_pair.segname_relp); temp_ptr = addrel (cobol_$def_base_ptr, temp_ptr -> type_pair.offset_relp); temp_name = (64)" "; temp_name = temp_ptr -> acc.string || temp_name; if temp_ptr ^= seg_ptr then temp_name = seg_ptr -> acc.string || "$" || temp_name; k = index (temp_name, " ") - 1; l = divide (k, 23, 17, 0) + 1; if (j + l > 5) then do; p -> print_line = substr (op_space, 1, j * 23) || nl; char_off = char_off + j * 23 + 1; p = addr (substr (char_string, char_off, 1)); op_space = (115)" "; j = 0; end; substr (op_space, j * 23 + 1, l * 23) = substr (temp_name, 1, l * 23); j = j + l; if j = 5 then do; j = 0; p -> print_line = op_space || nl; char_off = char_off + 116; p = addr (substr (char_string, char_off, 1)); op_space = (115)" "; end; end; link_ptr = addrel (link_ptr, 2); end; if j ^= 0 then do; p -> print_line = substr (op_space, 1, j * 23) || nl; char_off = char_off + j * 23 + 1; end; cobol_$list_off = char_off; call hcs_$set_bc_seg (cobol_$list_ptr, 9 * (cobol_$list_off - 1), mcode); exit_print_map: return; end print_map; /*************************************/ multics_error: error_info.name = "cobol_paste"; call convert_status_code_ (code, short_mes, long_mes); call ioa_$rsnnl ("^a Can't create object segment ^a in directory ^a", error_info.message, error_info.message_len, long_mes, cobol_$obj_seg_name, get_wdir_ ()); call signal_ ("command_abort_", null, addr (error_info)); abort: return; /***** Declaration for builtin function *****/ dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index) builtin; /***** End of declaration for builtin function *****/ %include cobol_object_map; /* [3.0-1] */ %include cobol_fixup_value; %include cobol_relinfo; %include cobol_sbh; %include cobol_error_info; %include cobol_; %include cobol_fixed_common; %include cobol_ext_; %include cobol_entry_seq; %include cobol_linkage_header; %include cobol_fixed_static; end cobol_paste;  cobol_patch.pl1 05/24/89 1042.8rew 05/24/89 0832.7 38232 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_patch.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 07/18/78 by RAL, [3.0-1], changed cobol_linkage_header.incl.pl1 */ /* Modified since 3.0 */ /*{*/ /* format: style3 */ cobol_patch: proc (value_ptr); /* This procedure is called by cobol_fixup_driver_ to perform all fixed patches to the object segment. These are as follows: In the text section: 1) set instruction address field (offset 1, lower half) to maximum stack size used modulo 16. In the definition section: 1) add to the value field in the Type 0 definition the word length of the constants. 2) if flags.descr_sw = "1"b in the Type 0 definition, add to each descriptor relp the word length of the constants. In the linkage section: 1) In the header, set def_section_relp to the word length of the constants plus the word length of the text section. 2) In the header, set linkage_section_length to the word length of then linkage section. 3) In the static data area, set stat.data_len to the word length of the cobol data used modulo 4. /*}*/ dcl utemp fixed bin; dcl (i, temp) fixed bin; /*************************************/ start: utemp = cobol_$max_stack_off + 15; /*6/14/76*/ text_ptr = cobol_$text_base_ptr; substr (entry_seq.eax7, 1, 18) = substr (unspec (utemp), 19, 14) || "0000"b; /* modulo 16 */ def_ptr = addrel (cobol_$def_base_ptr, fixed (def_header.def_list_relp, 18)); do while (definition.class ^= "000"b); def_ptr = addrel (cobol_$def_base_ptr, fixed (definition.forward_thread, 18)); end; do while (definition.class = "000"b); text_ptr = addrel (cobol_$text_base_ptr, fixed (definition.value, 28) - 2); value.exec_off = fixed (definition.value, 28) - 2; utemp = fixed (definition.value, 18) + value.con_len; definition.value = substr (unspec (utemp), 19, 18); if entry_seq.flags.has_descriptors then do; utemp = fixed (entry_seq.descr_relp_offset, 18) + 1; parm_desc_ptr = addrel (cobol_$con_end_ptr, utemp); do i = 1 to parm_desc.n_args; utemp = fixed (parm_desc.descriptor_relp (i), 18) + value.con_len; parm_desc.descriptor_relp (i) = substr (unspec (utemp), 19, 18); end; utemp = fixed (entry_seq.descr_relp_offset, 18) + value.con_len; entry_seq.descr_relp_offset = substr (unspec (utemp), 19, 18); end; def_ptr = addrel (cobol_$def_base_ptr, fixed (definition.forward_thread, 18)); end; linkage_header.def_section_relp = substr (unspec (value.text_len), 19, 18); linkage_header.linkage_section_length = substr (unspec (value.link_len), 19, 18); stat_ptr = addrel (cobol_$link_base_ptr, 8); utemp = cobol_$cobol_data_wd_off + 3; /*08-26-77*/ stat.data_len = fixed (substr (unspec (utemp), 17, 18), 18) * 4; /* modulo 4 */ return; /*************************************/ /***** Declaration for builtin function *****/ dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index) builtin; /***** End of declaration for builtin function *****/ %include cobol_fixup_value; %include cobol_entry_seq; %include cobol_definitions; %include cobol_linkage_header; /* [3.0-1] */ %include cobol_fixed_static; %include cobol_; end cobol_patch;  cobol_perform_gen.pl1 05/24/89 1042.8rew 05/24/89 0832.7 230436 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_perform_gen.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 06/20/80 by FCH, [4.2-1], dont call cobol_addr if in-line perform */ /* Modified on 06/20/79 by FCH, [4.0-1], in-line performs added for debug */ /* Modified since Version 4.0 */ /* format: style3 */ cobol_perform_gen: proc (in_token_ptr); declare bit_18 bit (18) based, /* 18-bit temp used to address id_10_fb*/ code_ptr ptr, /* Working pointer used to locate */ /* appropriate position in code seq. */ con_tag (3) fixed bin, /* Tags associated with first inst of */ /* Format 4 condition code sequences. */ eop_proc_no fixed bin, /* Procedure no of procedure at end of */ /* perform range. */ er_loc fixed bin, /* Location of first inst of call to */ /* cobol_error_. */ false_tag fixed bin, /* Tag associated with condition false.*/ format_no fixed bin, /* Format no of PERFORM statement being*/ /* processed. */ i_tag fixed bin, /* Tag to be associated with loc_i in */ /* Formats 3 and 4. */ id_tok_no (4) fixed bin, /* Token no of Format 4 varying ids. */ /* id_tok_no(varying_ids) containg no */ /* of tokens in perform statement + 1. */ index fixed bin, /* Do loop index. */ init_req_flag fixed bin, /* Set to 1 if seg initialization not */ /* required; to 2, if it is. */ init_tag fixed bin, /* Tag associated with first instruc- */ /* tion of code generated to initial- */ /* ize alterable GO's in COBOL segment */ /* containing procedure-name-1. */ integer fixed bin, /* If non-zero, fixed bin value of */ /* integer-1. */ jndex fixed bin, /* Do loop index. */ lit_ptr ptr, /* Working ptr used in determining */ /* value of integer-1. */ lit_str (30) bit (9) /* Bit string array used in determin- */ unaligned based, /* ing value of integer-1. */ lo_lim fixed bin, /* From - to limits of do loop index */ hi_lim fixed bin, /* used in processing conditions. */ next_stmt_tag fixed bin, /* Tag associated with next executable */ /* statement following procedure at */ /* end of perform range. */ no_inst fixed bin, /* No instructions to be emitted. */ no_tokens fixed bin, /* No of tokens in statement. */ p_token_ptr ptr, /* Pointer to area currently being used*/ /* for building in_token structure */ /* passed to cobol_arithop_gen and/or */ /* cobol_compare_gen. */ p1_token_ptr ptr, /* Pointers to areas reserved for */ p2_token_ptr ptr, /* building in_token structure passed */ /* to cobol_arithop_gen and/or */ /* to cobol_compare_gen. */ s_tag fixed bin, /* Utility tag. */ space_req fixed bin, /* Approximate space required for */ /* in_token structure containing input */ /* for cobol_arithop_gen and/or */ /* cobol_compare_gen. */ stackoff fixed bin, /* Offset of wd allocated in stack. */ temp fixed bin, /* Temporary used for calculations. */ pn1_no fixed bin, /* Procedure no of procedure at */ /* beginning of perform range. */ pn1_priority fixed bin, /* COBOL segment no of seg containing */ /* procedure-name-1. */ temp_chars fixed bin (24), /* Number of characters in COBOL data */ /* segment required for temporaries. */ type fixed bin, /* Token type. */ varying_ids fixed bin, /* No of identifiers varied in Format 4*/ wk_ptr ptr; /* Ptr to token of current interest. */ dcl temp_wk_ptr ptr; dcl move_token_ptr ptr; dcl dn_ptr ptr; dcl keep_scanning bit (1); /*[4.0-1]*/ declare (L1, L2, L3) fixed bin, out_line bit (1); /* Functions common to all formats */ /* Determine format number of statement being processed. */ start: no_tokens = in_token.n; /*[4.0-1]*/ eos_ptr = in_token.token_ptr (no_tokens); /*[4.0-1]*/ format_no = binary (eos_ptr -> end_stmt.a, 17) + 1; /*[4.0-1]*/ if end_stmt.d = "00"b then out_line = "1"b; else out_line = "0"b; /* Is segment initialization required? */ init_req_flag = 1; /*[4.0-1]*/ if out_line /*[4.0-1]*/ then do; if cobol_$seg_init_list_ptr ^= null () then do; pn1_priority = binary (unspec (in_token.token_ptr (2) -> proc_ref.priority), 17); if cobol_$priority_no ^= pn1_priority then if pn1_priority > 49 then do index = 1 to seg_init_list.n; if seg_init_list.seg.priority (index) = pn1_priority then do; init_req_flag = 2; init_tag = seg_init_list.seg.int_tag_no (index); goto next_step; end; end; end; /*[4.0-1]*/ end; next_step: /* Extract beginning-of-perform range procedure number from */ /* second token. */ /*[4.0-1]*/ L1, pn1_no = in_token.token_ptr (2) -> proc_ref.proc_num; /* Extract end_of_perform range procedure number from third */ /* token, locate this procedure number in perform_list and */ /* extract target_a_PN2 segno and char offset, and the tag */ /* associated with the "next executable statement". */ /*[4.0-1]*/ L3, eop_proc_no = in_token.token_ptr (3) -> proc_ref.proc_num; /*[4.0-1]*/ if out_line /*[4.0-1]*/ then do index = 1 to perform_list.n; if perform_list.perf.proc_num (index) = eop_proc_no then do; if in_token.token_ptr (no_tokens) -> end_stmt.h = 1 then if perform_list.perf.proc_num (index + 1) = eop_proc_no then index = index + 1; target.segno = perform_list.perf.target_a_segno (index); target.char_offset = perform_list.perf.target_a_offset (index); next_stmt_tag = abs (perform_list.perf.int_tag_no (index)); goto format (format_no); end; end; /*[4.0-1]*/ else go to format (format_no); /* End of Common Functions */ /* Process Format 1 PERFORM statements */ format (1): /*[4.0-1]*/ if ^out_line then return; call cobol_register$load (addr (register_request)); if init_req_flag = 1 then code_ptr = addr (seq2 (3)); else code_ptr = addr (seq2i (3)); /*[4.2-1]*/ if out_line then call cobol_addr (addr (target), addrel (code_ptr, 1), null ()); call cobol_emit (code_ptr, null (), init_req_flag + 2); call cobol_make_tagref (pn1_no, cobol_$text_wd_off - init_req_flag, null ()); if init_req_flag = 2 then call cobol_make_tagref (init_tag, cobol_$text_wd_off - 1, null ()); call cobol_reset_r$in_line; call cobol_register$load (addr (register_request)); /*[4.2-1]*/ if out_line then call cobol_addr (addr (target), addr (seq3 (13)), null ()); call cobol_emit (addr (seq3 (11)), null (), 2); call cobol_make_tagref (next_stmt_tag, cobol_$text_wd_off - 2, null ()); call cobol_reset_r$in_line; return; /* Process Format 2 PERFORM statements */ format (2): if in_token.token_ptr (4) -> numeric_lit.type = 2 then do; integer = 0; lit_ptr = addr (in_token.token_ptr (4) -> numeric_lit.literal); do index = 1 to in_token.token_ptr (4) -> numeric_lit.places while (integer < 131072); integer = integer * 10 + binary (substr (lit_ptr -> lit_str (index), 6, 4), 17); end; temp_chars = 4; end; else temp_chars = 8; call cobol_alloc$cobol_data (temp_chars, 2, count.char_offset); call cobol_register$load (addr (register_request)); if init_req_flag = 1 then code_ptr = addr (seq2); else code_ptr = addr (seq2i); count.char_offset = count.char_offset * 4; call cobol_addr (addr (count), code_ptr, null ());/*[4.2-1]*/ if out_line then call cobol_addr (addr (target), addrel (code_ptr, 2), null ()); if temp_chars = 8 then do; if (in_token.token_ptr (4) -> data_name.bin_36 | in_token.token_ptr (4) -> data_name.bin_18) then do; /* Identifier specifying number of times to PERFORM is long or short binary. */ /* Make a data name token for the temporary to receive the long or short binary. */ temp_wk_ptr = null (); call cobol_make_type9$long_bin (temp_wk_ptr, 2 /*cobol data */, count.char_offset + 4); move_token_ptr = addr (move_in_token (1)); if move_data_init ^= cobol_$compile_count then do; /* Initialize structure used in calls to the move generator. */ move_token_ptr -> in_token.token_ptr (1) = null (); move_token_ptr -> in_token.token_ptr (4) = addr (move_eos); move_token_ptr -> in_token.n = 4; move_data_init = cobol_$compile_count; end; /* Initialize structure used in calls to the move geerator. */ move_token_ptr -> in_token.token_ptr (2) = in_token.token_ptr (4); /* long or short bin item */ move_token_ptr -> in_token.token_ptr (3) = temp_wk_ptr; /* temporary in cobol data */ call cobol_move_gen (move_token_ptr); /* Emit code to set indicators from storage (the value just moved to cobol data) and transfer to error routine if zero or negative. */ szn_seq (1) = code_ptr -> bit_18; temp = binary (substr (szn_seq (1), 4, 15)) + 1; /* address portion */ substr (szn_seq (1), 4, 15) = substr (unspec (temp), 22, 15); call cobol_emit (addr (szn_seq (1)), null (), 1); /* SZN from temp */ call cobol_emit (addr (seq1 (7)), null (), 1); /* tmoz */ seq3 (7) = szn_seq (1); end; /* Identifier specifying the number of times to perform is long or short binary. */ else do; /* Identifier is unpacked or packed decimal, or overpunch sign data */ if (in_token.token_ptr (4) -> data_name.item_signed & in_token.token_ptr (4) -> data_name.sign_separate = "0"b) then do; /* Overpunch sign data. */ input_struc.token_ptr = null (); call cobol_num_to_udts (in_token.token_ptr (4), input_struc.token_ptr); end; /* Overpunch sign data. */ else input_struc.token_ptr = in_token.token_ptr (4); call cobol_addr (addr (input_struc), addr (seq1), null ()); seq1 (1) = "000000000001000000"b; seq1 (5) = code_ptr -> bit_18; temp = binary (substr (seq1 (5), 4, 15), 17) + 1; substr (seq1 (5), 4, 15) = substr (unspec (temp), 22, 15); call cobol_emit (addr (seq1), null (), 4); seq3 (7) = seq1 (5); end; /* Identifier is unpacked or packed decimal, or overpunch sign data. */ seq3 (8) = cmpq_id_10; /*[4.0-1]*/ if out_line /*[4.0-1]*/ then call cobol_make_tagref (cobol_$next_tag, cobol_$text_wd_off - 1, null ()); /*[4.0-1]*/ else call cobol_make_tagref (eop_proc_no, cobol_$text_wd_off - 1, null ()); end; else do; seq3 (7) = substr (unspec (integer), 19, 18); seq3 (8) = cmpq_int_1; end; /*[4.0-1]*/ if out_line /*[4.0-1]*/ then do; call cobol_emit (code_ptr, null (), init_req_flag + 3); call cobol_make_tagref (pn1_no, cobol_$text_wd_off - init_req_flag, null ()); /*[4.0-1]*/ end; /*[4.0-1]*/ else do; L2 = cobol_$next_tag; /*[4.0-1]*/ cobol_$next_tag = cobol_$next_tag + 1; /*[4.0-1]*/ call cobol_emit (addr (seq2 (1)), null (), 1); /*[4.0-1]*/ call cobol_emit (addr (seq2 (7)), null (), 1); /*[4.0-1]*/ call cobol_make_tagref (L2, cobol_$text_wd_off - 1, null ()); /*[4.0-1]*/ call cobol_define_tag_nc (L1, cobol_$text_wd_off); /*[4.0-1]*/ end; if init_req_flag = 2 then call cobol_make_tagref (init_tag, cobol_$text_wd_off - 1, null ()); call cobol_reset_r$in_line; call cobol_register$load (addr (register_request)); call cobol_addr (addr (count), addr (seq3 (1)), null ()); seq3 (5) = seq3 (1); /*[4.2-1]*/ if out_line then call cobol_addr (addr (target), addr (seq3 (13)), null ()); /*[4.0-1]*/ if out_line /*[4.0-1]*/ then do; call cobol_emit (addr (seq3), null (), 7); call cobol_make_tagref (pn1_no, cobol_$text_wd_off - 3, null ()); call cobol_make_tagref (next_stmt_tag, cobol_$text_wd_off - 2, null ()); /*[4.0-1]*/ end; /*[4.0-1]*/ else do; call cobol_emit (addr (seq3), null (), 5); call cobol_make_tagref (L2, cobol_$text_wd_off - 1, null ()); /*[4.0-1]*/ call def_L2; /*[4.0-1]*/ end; call cobol_reset_r$in_line; if temp_chars = 8 then /*[4.0-1]*/ if out_line then do; call cobol_define_tag_nc (cobol_$next_tag, cobol_$text_wd_off); cobol_$next_tag = cobol_$next_tag + 1; end; return; set_false_tag: proc; /*[4.0-1]*/ if out_line /*[4.0-1]*/ then false_tag = pn1_no; /*[4.0-1]*/ else do; false_tag, L2 = cobol_$next_tag; /*[4.0-1]*/ cobol_$next_tag = cobol_$next_tag + 1; /*[4.0-1]*/ end; end; format (3): /* Set alterable GO at end of PN2. */ seq4 (3) = "000000000000000010"b; call cobol_register$load (addr (register_request)); if init_req_flag = 1 then do; code_ptr = addr (seq4 (3)); /*[4.0-1]*/ call set_false_tag; end; else do; code_ptr = addr (seq4); i_tag = cobol_$next_tag; false_tag = i_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_alloc$cobol_data (4, 2, count.char_offset); count.char_offset = count.char_offset * 4; call cobol_addr (addr (count), code_ptr, null ()); end; /*[4.2-1]*/ if out_line then call cobol_addr (addr (target), addr (seq4 (5)), null ()); /*[4.0-1]*/ if out_line /*[4.0-1]*/ then call cobol_emit (code_ptr, null (), init_req_flag + 1); /*[4.0-1]*/ else call cobol_define_tag_nc (L1, cobol_$text_wd_off); call cobol_reset_r$in_line; /* Get space for token structure. */ space_req = no_tokens * 2 - 6; call get_token_space; /* Process condition-1. */ lo_lim = 4; hi_lim = no_tokens - 1; call process_condition; /* Reset alterable GO at end of PN2. */ call reset_f_3_4; /*[4.0-1]*/ if ^out_line then call def_L2; return; def_L2: proc; /*[4.0-1]*/ call cobol_emit (addr (seq2 (7)), null (), 1); /*[4.0-1]*/ call cobol_make_tagref (L3, cobol_$text_wd_off - 1, null ()); /*[4.0-1]*/ call cobol_define_tag_nc (L2, cobol_$text_wd_off); end; format (4): /* Get token numbers of pointers to varying identifiers and */ /* compute space required for token structure to be passed */ /* to generators. */ varying_ids = in_token.token_ptr (no_tokens) -> end_stmt.e; index = 1; jndex = 4; id_tok_no (index) = jndex; if index = varying_ids then keep_scanning = "0"b; else do; keep_scanning = "1"b; index = index + 1; jndex = jndex + 3; end; do while (keep_scanning); /* Scan to find all varying identifiers. */ if (in_token.token_ptr (jndex) -> end_stmt.type = 1 & in_token.token_ptr (jndex) -> reserved_word.key = 72 /* AFTER */) then do; /* Found reserved word AFTER. */ /* Next token is the VARYING identifier. */ id_tok_no (index) = jndex + 1; if index = varying_ids then keep_scanning = "0"b; else do; index = index + 1; jndex = jndex + 3; end; end; /* Found reserved word AFTER. */ else jndex = jndex + 1; end; /* Scan to find all varying identifiers. */ id_tok_no (varying_ids + 1) = no_tokens + 1; space_req = 0; do index = varying_ids to 1 by -1; if (id_tok_no (index + 1) - id_tok_no (index)) * 2 - 6 > space_req then space_req = (id_tok_no (index + 1) - id_tok_no (index)) * 2 - 6; end; call get_token_space; /* Generate call to cobol_error. */ do index = 1 to varying_ids; if in_token.token_ptr (id_tok_no (index) + 2) -> end_stmt.type = 9 then do; call cobol_alloc$stack (4, 1, stackoff); substr (ret_inst (1), 4, 15) = substr (unspec (stackoff), 22, 15); tra_inst (3) = ret_inst (1); s_tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_pointer_register$get (addr (ptr_register_request)); call cobol_emit (addr (tra_inst), null (), 3); call cobol_make_tagref (s_tag, cobol_$text_wd_off - 1, null ()); er_loc = cobol_$text_wd_off; call cobol_process_error (44, in_token.token_ptr (1) -> end_stmt.line, 0); call cobol_emit (addr (ret_inst), null (), 1); call cobol_define_tag (s_tag); goto end_loop; end; end; end_loop: /* Initialize varying identifiers. */ p_token_ptr -> in_token.n = 4; p_token_ptr -> in_token.code = 0; p_token_ptr -> in_token.token_ptr (1) = in_token.token_ptr (1); p_token_ptr -> in_token.token_ptr (4) = addr (eos_token); eos_token.e = 1; do index = 1 to varying_ids; call init_var_id; end; /* Get tags to be associated with first instruction of */ /* condition code sequences. */ do index = 1 to varying_ids; con_tag (index) = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; end; /* Set alterable GO at end of PN2. */ seq4 (3) = "000000000000000011"b; call cobol_register$load (addr (register_request)); if init_req_flag = 1 then do; code_ptr = addr (seq4 (3)); /*[4.0-1]*/ call set_false_tag; end; else do; code_ptr = addr (seq4); i_tag = cobol_$next_tag; false_tag = i_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_alloc$cobol_data (4, 2, count.char_offset); count.char_offset = count.char_offset * 4; call cobol_addr (addr (count), code_ptr, null ()); end; /*[4.2-1]*/ if out_line then call cobol_addr (addr (target), addr (seq4 (5)), null ()); /*[4.0-1]*/ if out_line /*[4.0-1]*/ then call cobol_emit (code_ptr, null (), init_req_flag + 2); /*[4.0-1]*/ else call cobol_emit (addr (seq4 (7)), null (), 1); call cobol_make_tagref (con_tag (1), cobol_$text_wd_off - 1, null ()); /*[4.0-1]*/ if ^out_line then call cobol_define_tag_nc (L1, cobol_$text_wd_off); call cobol_reset_r$in_line; /* BY identifier zero? */ do index = varying_ids to 1 by -1; if in_token.token_ptr (id_tok_no (index) + 2) -> end_stmt.type = 9 then do; p_token_ptr -> in_token.n = 2; p_token_ptr -> in_token.code = 0; p_token_ptr -> in_token.token_ptr (1) = in_token.token_ptr (id_tok_no (index) + 2); p_token_ptr -> in_token.token_ptr (2) = addr (eos_token); s_tag = cobol_$next_tag; eos_token.h = s_tag; eos_token.verb = 13; eos_token.e = 180; unspec (eos_token.i) = "010000000000000000000000000000000000"b; cobol_$next_tag = cobol_$next_tag + 1; call cobol_compare_gen (p_token_ptr); temp = stackoff + 1; substr (seq6 (1), 4, 15) = substr (unspec (temp), 22, 15); temp = er_loc - cobol_$text_wd_off - 1; seq6 (3) = substr (unspec (temp), 19, 18); call cobol_emit (addr (seq6), null (), 2); call cobol_define_tag_nc (s_tag, cobol_$text_wd_off); end; /* Increment varying identifier. */ p_token_ptr -> in_token.n = 4; p_token_ptr -> in_token.code = 0; p_token_ptr -> in_token.token_ptr (1) = in_token.token_ptr (1); p_token_ptr -> in_token.token_ptr (4) = addr (eos_token); eos_token.e = 1; eos_token.b = "0"b; if in_token.token_ptr (id_tok_no (index)) -> end_stmt.type = 9 then do; p_token_ptr -> in_token.token_ptr (2) = in_token.token_ptr (id_tok_no (index) + 2); p_token_ptr -> in_token.token_ptr (3) = in_token.token_ptr (id_tok_no (index)); eos_token.a = "000"b; eos_token.h = 1; eos_token.verb = 2; call cobol_add_gen (p_token_ptr, s_tag); end; else do; ind_ptr = in_token.token_ptr (id_tok_no (index)); p_token_ptr -> in_token.token_ptr (2) = ind_ptr; index_name.max = index_name.max + 1; p_token_ptr -> in_token.token_ptr (3) = in_token.token_ptr (id_tok_no (index) + 2); eos_token.a = "001"b; eos_token.verb = 31; call cobol_set_gen (p_token_ptr); end; /* Process condition. */ call cobol_define_tag (con_tag (index)); lo_lim = id_tok_no (index) + 3; hi_lim = id_tok_no (index + 1) - 2; call process_condition; /* Set false tag for next pass and initialize varying id. */ if index > 1 then do; false_tag = con_tag (index); p_token_ptr -> in_token.n = 4; p_token_ptr -> in_token.code = 0; p_token_ptr -> in_token.token_ptr (1) = in_token.token_ptr (1); p_token_ptr -> in_token.token_ptr (4) = addr (eos_token); eos_token.e = 1; call init_var_id; end; end; /* Reset alterable GO at end of PN2. */ call reset_f_3_4; /*[4.0-1]*/ if ^out_line then call def_L2; return; format (7): /*[4.0-1]*/ call cobol_emit (addr (seq2 (7)), null (), 1); /*[4.0-1]*/ call cobol_make_tagref (end_stmt.e, cobol_$text_wd_off - 1, null ()); /*[4.0-1]*/ call cobol_define_tag_nc (end_stmt.h, cobol_$text_wd_off); /*[4.0-1]*/ return; format (8): /*[4.2-1]*/ if out_line then call cobol_addr (addr (target), addr (seq8 (3)), null ()); call cobol_emit (addr (seq8), null (), 3); call cobol_make_tagref (pn1_no, cobol_$text_wd_off - 1, null ()); return; get_token_space: proc; if binary (rel (temp_token_ptr), 17) + space_req * 2 > 262143 then do; signal_ovfl_error: call signal_ ("command_abort_", null (), addr (seg_ovfl_error)); goto signal_ovfl_error; end; if substr (rel (temp_token_ptr), 18, 1) = "1"b then temp_token_ptr = addrel (temp_token_ptr, 1); p1_token_ptr = temp_token_ptr; temp_token_ptr = addrel (temp_token_ptr, space_req); p2_token_ptr = temp_token_ptr; temp_token_ptr = addrel (temp_token_ptr, space_req); p_token_ptr = p1_token_ptr; return; end get_token_space; init_var_id: proc; if in_token.token_ptr (id_tok_no (index)) -> end_stmt.type = 9 & in_token.token_ptr (id_tok_no (index) + 1) -> end_stmt.type ^= 10 then do; p_token_ptr -> in_token.token_ptr (2) = in_token.token_ptr (id_tok_no (index) + 1); p_token_ptr -> in_token.token_ptr (3) = in_token.token_ptr (id_tok_no (index)); eos_token.verb = 18; call cobol_move_gen (p_token_ptr); end; else do; p_token_ptr -> in_token.token_ptr (2) = in_token.token_ptr (id_tok_no (index)); p_token_ptr -> in_token.token_ptr (3) = in_token.token_ptr (id_tok_no (index) + 1); eos_token.verb = 31; eos_token.a = "000"b; call cobol_set_gen (p_token_ptr); end; return; end init_var_id; reset_f_3_4: proc; call cobol_register$load (addr (register_request)); if init_req_flag = 1 then no_inst = 2; else do; no_inst = 8; call cobol_addr (addr (count), addr (seq5 (7)), null ()); seq5 (11) = seq5 (7); end; /*[4.2-1]*/ if out_line /*[4.2-1]*/ then do; call cobol_addr (addr (target), addr (seq5 (3)), null ()); /*[4.2-1]*/ call cobol_emit (addr (seq5), null (), no_inst); /*[4.2-1]*/ call cobol_make_tagref (next_stmt_tag, cobol_$text_wd_off - no_inst, null ()); /*[4.2-1]*/ end; if init_req_flag = 2 then do; call cobol_make_tagref (pn1_no, cobol_$text_wd_off - 4, null ()); call cobol_make_tagref (pn1_no, cobol_$text_wd_off - 2, null ()); call cobol_make_tagref (init_tag, cobol_$text_wd_off - 1, null ()); call cobol_define_tag_nc (i_tag, cobol_$text_wd_off - 5); end; call cobol_pointer_register$priority (4, 4, "000"b); return; end reset_f_3_4; process_condition: proc; p_token_ptr -> in_token.n = 0; p_token_ptr -> in_token.code = 0; do jndex = lo_lim to hi_lim; wk_ptr = in_token.token_ptr (jndex); type = wk_ptr -> end_stmt.type; if type = 30 then if wk_ptr -> int_tag.perform_bit = "1"b & wk_ptr -> int_tag.true_path = "0"b then do; equate_tag.equated_tag = wk_ptr -> int_tag.proc_num; equate_tag.true_tag = false_tag; call cobol_equate_tag (addr (equate_tag)); end; else call cobol_define_tag_nc (binary (wk_ptr -> int_tag.proc_num, 17), cobol_$text_wd_off); else do; p_token_ptr -> in_token.n = p_token_ptr -> in_token.n + 1; p_token_ptr -> in_token.token_ptr (p_token_ptr -> in_token.n) = wk_ptr; if type = 19 then do; if wk_ptr -> end_stmt.verb = 13 then call cobol_compare_gen (p_token_ptr); else call cobol_arithop_gen (p_token_ptr); if p_token_ptr -> in_token.code > 0 then p_token_ptr -> in_token.n = p_token_ptr -> in_token.code; else do; if p_token_ptr -> in_token.code = -1 then if p_token_ptr -> in_token.code = -1 then if p_token_ptr = p1_token_ptr then p_token_ptr = p2_token_ptr; else p_token_ptr = p1_token_ptr; p_token_ptr -> in_token.n = 0; end; p_token_ptr -> in_token.code = 0; end; end; end; return; end process_condition; %include cobol_perform_gen_info; %include cobol_perform_gen_data; end cobol_perform_gen;  cobol_pointer_register.pl1 05/24/89 1042.8rew 05/24/89 0837.3 185616 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_pointer_register.pl1 Added Trace statements. END HISTORY COMMENTS */ /* Modified on 11/19/84 by FCH, [4.3-1}, BUG563(phx18381), new cobol_addr_tokens.incl.pl1 */ /* Modified on 09/08/83 by FCH, [5.2...], trace added */ /* Modified on 01/14/77 by ORN to signal command_abort rather than cobol_compiler_error */ /* Modified since Version 2.0 */ /*{*/ /* format: style3 */ cobol_pointer_register: proc; /* the procedure is not a valid entry point */ /*}*/ return; /*************************************/ /*{*/ call: entry; /* This entry is called immediately before a call is to be generated; thus PR0 must point to cobol_operators, PR4 must point to linkage section; and PR2 will be destroyed. }*/ start_call: return; /* for now */ /*************************************/ /*{*/ get: entry (struc_ptr); /* This entry obtains a pointer register for the caller. */ dcl struc_ptr ptr; /* struc_ptr is a pointer to the following structure. (input) */ dcl 1 structure based (struc_ptr), 2 what_pointer fixed bin, 2 pointer_no bit (3), 2 lock fixed bin, 2 switch fixed bin, 2 segno fixed bin, 2 offset fixed bin (24), 2 reset fixed bin; /* what_pointer specifies the pointer register to be obtained. (input) 0-7 - get this pointer register. 10 - get any temporary pointer register. pointer_no is the register that is assigned, in the range 0-7. (output) lock can have the following values. (input) 0 - do not change the lock or unlock status of this pointer. 1 - lock the pointer register. 2 - unlock all pointer registers. 3 - unlock all pointer registers and A register and Q register and all index registers. switch has the following values. (input) 0 - the register will not contain a value that is meaningful for register optimization. Segment number and offset are meaningless. 1 - a segment number and word offset are supplied. 2 - a segment number and character offset are supplied segno is the segment number. (input) values recognized are: 2 - cobol data. 1000 - stack. 3000 - constants. 3002 - multics linkage. 4000 - cobol operators. 2nnnn - cobol linkage. -n - link in multics linkage. offset is the word or character offset (depending on switch). Any case when the offset is meaningless a 0 value must be used. If a character offset is provided only the word portion is meaningful. (input) reset specifies that the caller has requested a register that must have a preset value. For example a preset register to cobol data or the pointer to pl/1 operators (likely). This is only of interest to callers who request a specific register (what_pointer = 0-7) Such callers should test reset. If it is 1, a call to cobol_reset_r should be made in order to emit instructions to reload the register to its proper value. Notes: 1. If switch has a non zero value and the pointer register does not contain the specified segno and offset this utility will emit instructions to load the pointer register. 2. (a) Generally a register should not be locked. (b) Exceptions would be the case when (1) several calls must be make to this utility and the caller does not wish to obtain the same register (2) Calls to this utility are interspurced with calls to the addressability utilities and the user does not wish to obtain the same register. 3. There is no need to call to get pointer register 6 (the stack frame). We can always assume this is set. 4. If the caller requests a specific pointer register who's priority was lock a compile time error will occur. This may change if we need more sophisticated pointer register handling. */ /*}*/ dcl 1 reg_err static, 2 name char (32) init ("cobol_register$get"), 2 message_len fixed bin (35) init (30), 2 message char (30) init ("Unable to get a register"); dcl 1 ptr_err static, 2 name char (32) init ("cobol_register$get"), 2 message_len fixed bin (35) init (30), 2 message char (30) init ("unable to get pointer register"); dcl 1 contents_err static, 2 name char (32) init ("cobol_pointer_register$get"), 2 message_len fixed bin init (53), 2 message char (54) init ("Attempt to load invalid contents into pointer register"); dcl (i, k, m) fixed bin; dcl save_i fixed bin; dcl best_yet fixed bin; dcl best_current fixed bin; dcl new_wd_off fixed bin (24); dcl call_pr_num bit (3); dcl reloc_ptr ptr; dcl call_off fixed bin (24); dcl 1 inst (10) aligned, 2 i_y unaligned, 3 i_pr bit (3) unaligned, 3 i_off bit (15) unaligned, 2 i_op bit (10) unaligned, 2 i_zero bit (1) unaligned, 2 i_ar bit (1) unaligned, 2 i_tm bit (2) unaligned, 2 i_td bit (4) unaligned; dcl 1 reloc (20) aligned, 2 r_left bit (5) aligned, 2 r_right bit (5) aligned; dcl cobol_emit entry (ptr, ptr, fixed bin); /* DECLARATION OF EXTERNAL ENTRIES */ dcl cobol_register_util$restore_pointer ext entry (bit (4)); dcl cobol_register_util$restore ext entry (bit (4)); dcl cobol_register_util$save_pointer ext entry (bit (4)); dcl cobol_register$load ext entry (ptr); dcl signal_ entry (char (*), ptr, ptr); dcl char_no bit (2); dcl bit_4 bit (4); dcl temp_reg fixed bin int static init (0); dcl r fixed bin; dcl 1 register_struc, 2 what_reg fixed bin, 2 reg_no bit (4), 2 lock fixed bin, 2 already_there fixed bin, 2 contains fixed bin, 2 tok_ptr ptr, 2 literal bit (36); /***..... dcl LOCAL_NAME char (4) int static init ("$GET");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME||LOCAL_NAME);/**/ reset = 0; if switch = 1 then new_wd_off = offset; else if switch = 2 then do; new_wd_off = binary (substr (unspec (offset), 1, 34)); char_no = substr (unspec (offset), 35, 2); end; if what_pointer = 10 then do; /* get any temporary pointer register */ best_yet = 0; do i = 0 to 7; if usage (i) = 0 then do; /* the current register is temporary pointer */ best_current = 0; if switch = 0 then do; /* a specific value was not supplied by caller */ if p_lock (i) = 0 then do; /* register not locked */ if p_priority (i) = 0 & contents_sw (i) = 0 then go to specific_1; if p_priority (i) = 0 & contents_sw (i) = 1 then best_current = 3; else if p_priority (i) = 1 & contents_sw (i) = 0 then best_current = 2; else best_current = 1; end; end; else do; /* a specific value has been supplied by caller */ if contents_sw (i) ^= 0 & seg_num (i) = segno & wd_offset (i) = new_wd_off then go to specific_1; /* contents do not match */ if p_lock (i) = 0 then do; /* register not locked*/ if p_priority (i) = 0 & contents_sw (i) = 0 then best_current = 4; else if p_priority (i) = 0 & contents_sw (i) = 1 then best_current = 3; else if p_priority (i) = 1 & contents_sw (i) = 0 then best_current = 2; else best_current = 1; end; end; /* has a better register been found */ if best_current > best_yet then do; best_yet = best_current; save_i = i; end; end; end; i = save_i; if best_yet = 0 then do; /* unable to get any temporary register */ /* Pick a temporary pointer register, and save it. */ temp_reg = mod (temp_reg + 1, 7); if temp_reg > 2 then temp_reg = 7; bit_4 = substr (unspec (temp_reg), 33, 4); call cobol_register_util$save_pointer (bit_4); i = temp_reg; ptr_status.p_priority (i) = 0; ptr_status.contents_sw (i) = 0; ptr_status.seg_num (i) = 0; ptr_status.wd_offset (i) = 0; end; go to specific_1; end; else do; /* a specific pointer register was requested */ i = what_pointer; if p_lock (i) = 1 then do; /* the pointer register is locked */ /* Save the current contents of the register, and unlock it. */ call cobol_register_util$save_pointer (substr (unspec (i), 33, 4)); ptr_status.p_lock (i) = 0; ptr_status.contents_sw (i) = 0; ptr_status.seg_num (i) = 0; ptr_status.wd_offset (i) = 0; end; specific_1: structure.pointer_no = pointer_num (i); if (structure.lock = 1) | (ptr_status.save_stack_count (i) > 0) then p_lock (i) = 1; if switch = 0 then do; /* caller has not supplied contents */ contents_sw (i) = 0; reset = p_reset (i); end; else do; if contents_sw (i) = 0 then do; go to load; end; else if (^(seg_num (i) = segno & wd_offset (i) = new_wd_off)) then do; load: /* emit instructions to load pointer registers*/ m = 0; reloc_ptr = null (); /* cobol data */ if segno = 2 then do; if new_wd_off > 262143 then do; cont_err: call signal_ ("command_abort_", null (), addr (contents_err)); return; end; /* epbpr pr6|110,* */ /* 7/9/76*/ call make_inst ("110"b, 110, "0111010001"b, "1"b, "01"b, "0"b); /* adwpr call_off,du */ call_off = new_wd_off - 16384; call make_inst ("0"b, call_off, "0001010000"b, "0"b, "00"b, "0011"b); go to emit; end; /* stack */ if segno = 1000 then do; if new_wd_off > 16383 then go to cont_err; /* eppr pr6|new_wd_off */ call make_inst ("110"b, new_wd_off, "0111010000"b, "1"b, "00"b, "0000"b) ; go to emit; end; /* constant portion of text segment */ if segno = 3000 then do; call_off = (-(cobol_$text_wd_off + new_wd_off)); /* eppr call_off,ic */ call make_inst ("0"b, call_off, "0111010000"b, "0"b, "00"b, "0100"b); go to emit; end; /* multics linkage section */ if segno = 3002 then do; if new_wd_off > 16383 then go to cont_err; reloc_ptr = addr (reloc (1)); if contents_sw (4) = 1 & seg_num (4) = 3002 & wd_offset (4) = 0 then do; /* pr4 is set to the multics linkage section */ /* eppr pr4|new_wd_off */ call make_inst ("100"b, new_wd_off, "0111010000"b, "1"b, "00"b, "0000"b); r_left (m) = "11001"b; /* internal static 15 */ r_right (m) = "0"b; end; else do; call_pr_num = pointer_num (i); /* eppr pr6|36,* */ call make_inst ("110"b, 36, "0111010000"b, "1"b, "01"b, "0000"b); r_left (m) = "0"b; r_right (m) = "0"b; /* eppr prr | new_wd_off */ call make_inst (call_pr_num, new_wd_off, "0111010000"b, "1"b, "00"b, "0000"b); r_left (m) = "11001"b; /* internal static 18 */ r_right (m) = "0"b; end; go to emit; end; /* cobol operators */ if segno = 4000 then do; /* eppr pr6|24,* */ call make_inst ("110"b, 24, "0111010000"b, "1"b, "01"b, "0000"b); go to emit; end; /* cobol linkage section */ if segno >= 20000 then do; /* sets pointer reg to argument list */ /* eppr pr6|26,* */ call make_inst ("110"b, 26, "0111010000"b, "1"b, "01"b, "0000"b); if segno > 20000 then do; /* sets pointer reg to the argument */ /* eppr prr|2nnnn,* */ call_pr_num = pointer_num (i); call_off = 2 * (segno - 20000); call make_inst (call_pr_num, call_off, "0111010000"b, "1"b, "01"b, "0000"b); end; go to emit; end; /* link in multics linkage section */ if segno < 0 then do; if segno < -16384 then go to cont_err; if new_wd_off > 262143 then go to cont_err; call_off = (-(segno)); reloc_ptr = addr (reloc (1)); if contents_sw (4) = 1 & seg_num (4) = 3002 & wd_offset (4) = 0 then do; /* pr4 is set to multics linkage section */ /* eppr pr4|n,* */ /* put link into the register */ call make_inst ("100"b, call_off, "0111010000"b, "1"b, "01"b, "0000"b); r_left (m) = "10100"b; /* link 15 */ r_right (m) = "0"b; end; else do; /* eppr pr6|36,* */ /* set ponter register to linkage section base */ call make_inst ("110"b, 36, "0111010000"b, "1"b, "01"b, "0000"b); r_left (m) = "0"b; r_right (m) = "0"b; /* eppr prr|n,* put link into the register */ call_pr_num = pointer_num (i); call make_inst (call_pr_num, call_off, "0111010000"b, "1"b, "01"b, "0000"b); r_left (m) = "10100"b; /* link 15 */ r_right (m) = "0"b; end; if new_wd_off ^= 0 then do; /* adwpr new_wd_off,du */ call make_inst ("0"b, new_wd_off, "0001010000"b, "0"b, "00"b, "0011"b); r_left (m) = "0"b; r_right (m) = "0"b; end; go to emit; end; /* invalid segment number */ go to cont_err; /* emit the instructions */ emit: /* acount char offset if needed */ if char_no ^= "00"b & switch ^= 1 then do; /* get a register */ /* Set up a register request structure to get any index register. */ register_struc.what_reg = 5; /* Any index. */ register_struc.lock = 0; register_struc.contains = 0; call cobol_register$load (addr (register_struc)); load_char: /* ldxn : load char no into register */ m = m + 1; r_left (m) = "0"b; r_right (m) = "0"b; string (inst (m)) = "000000000000000000010010000000000011"b; substr (inst.i_y.i_off (m), 14, 2) = char_no; substr (inst.i_op (m), 7, 3) = substr (register_struc.reg_no, 2, 3); /* a9bd */ m = m + 1; r_left (m) = "0"b; r_right (m) = "0"b; string (inst (m)) = "000000000000000000101000000101101000"b; substr (inst.i_td (m), 2, 3) = substr (register_struc.reg_no, 2, 3); inst.i_y.i_pr (m) = pointer_num (i); contents_sw (i) = 0; end; else do; seg_num (i) = segno; wd_offset (i) = new_wd_off; contents_sw (i) = 1; end; call cobol_emit (addr (inst (1)), reloc_ptr, m); end; reset_test: if p_reset (i) ^= 0 then do; if seg_num (i) = reset_seg_num (i) & wd_offset (i) = reset_wd_offset (i) then go to lock_test; else reset = 1; end; end; lock_test: if structure.lock > 1 then do k = 0 to 7; /* unlock all pointer registers */ p_lock (k) = 0; end; if structure.lock > 2 then do k = 0 to 9; /* unlock A, Q and index registers */ r_lock (k) = 0; end; end; go to prx; /*************************************/ /*{*/ priority: entry (lock_value, priority, reg_no); /***..... dcl LOCAL_NAME2 char (9) int static init ("$PRIORITY");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME||LOCAL_NAME2);/**/ /* set the priority and/or lock of one or more registers. */ dcl lock_value fixed bin; dcl priority fixed bin; dcl reg_no bit (3); /* lock_value can have the following values (input) 0 - do not change the lock or unlock status. 1 - lock this pointer register. 2 - unlock this pointer register. 3 - unlock all pointer registers. 4 - unlock all pointer registers and all index registers, and the A and Q registers. priority can have the following values (input) 0 - do not change register priority. 1 - set this pointer register to normal priority 2 - set this pointer register to high priority. The register handler will attempt to preserve the contents of this register as long as possible 3 - set all pointer registers to normal priority. 4 - set all pointer registers and all index registers, and the A and Q registers to normal priority. reg_no is the pointer register number. (input) */ /*}*/ /* manage lock */ if lock_value ^= 0 then do; if lock_value = 1 then p_lock (fixed (reg_no)) = 1; else if lock_value = 2 then do; k = fixed (reg_no); if ptr_status.save_stack_count (k) ^= 0 then do; /* Restore the pointer register. */ call cobol_register_util$restore_pointer ("0"b || substr (unspec (k), 34, 3)); ptr_status.p_lock (k) = 1; end; /* Restore the pointer register. */ else p_lock (k) = 0; end; else do; do k = 0 to 7; if ptr_status.save_stack_count (k) ^= 0 then do; /* Restore the pointer register. */ call cobol_register_util$restore_pointer ("0"b || substr (unspec (k), 34, 3)) ; ptr_status.p_lock (k) = 1; end; /* Restore the pointer register. */ else p_lock (k) = 0; end; if lock_value = 4 then do k = 0 to 9; if reg_status.save_stack_count (k) ^= 0 then do; /* Restore the register. */ call cobol_register_util$restore ((get_bit_code (k))); reg_status.r_lock (k) = 1; end; /* Restore the register. */ else r_lock (k) = 0; end; end; end; /* manage priority */ if priority ^= 0 then do; if priority = 1 then p_priority (fixed (reg_no)) = 0; else if priority = 2 then p_priority (fixed (reg_no)) = 1; else do; do k = 0 to 7; p_priority (k) = 0; end; if priority = 4 then do k = 0 to 9; r_priority (k) = 0; end; end; end; prx: /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(MY_NAME);/**/ return; /* MAKE_INST PROC /* make an instruction */ make_inst: proc (pr, off, op, ar, tm, td); dcl pr bit (3); dcl off fixed bin (24); dcl op bit (10); dcl ar bit (1); dcl tm bit (2); dcl td bit (4); /* i must be set as index to ptr_status table */ /* m must be set as index into inst table */ /* op codes recognized are adwpr 050 (0) eppr 350 (0) epbpr 350 (1) */ m = m + 1; string (inst (m)) = "0"b; i_op (m) = op; i_ar (m) = ar; i_tm (m) = tm; i_td (m) = td; if ar = "0"b then string (i_y (m)) = substr (unspec (off), 19, 18); else do; i_pr (m) = pr; i_off (m) = substr (unspec (off), 22, 15); end; if op = "0001010000"b then do; /* adwpr */ substr (i_op (m), 3, 1) = substr (pointer_num (i), 1, 1); substr (i_op (m), 8, 2) = substr (pointer_num (i), 2, 2); end; else if op = "0111010000"b then do; /* eppr */ substr (i_op (m), 5, 1) = substr (pointer_num (i), 1, 1); substr (i_op (m), 8, 2) = substr (pointer_num (i), 2, 2); substr (i_op (m), 10, 1) = substr (pointer_num (i), 3, 1); end; else if op = "0111010001"b then do; /* epbpr */ substr (i_op (m), 5, 1) = substr (pointer_num (i), 1, 1); substr (i_op (m), 8, 2) = substr (pointer_num (i), 2, 2); substr (i_op (m), 10, 1) = (^(substr (pointer_num (i), 3, 1))); end; return; end make_inst; get_bit_code: proc (fbin_code) returns (bit (4)); dcl fbin_code fixed bin; dcl bit_code bit (4); if fbin_code = 9 then bit_code = "0010"b; /* Q */ else if fbin_code = 8 then bit_code = "0001"b; /* A */ else bit_code = "1"b || substr (unspec (fbin_code), 34, 3); return (bit_code); end get_bit_code; /***..... dcl cobol_gen_driver_$Tr_Beg entry(char(*));/**/ /***..... dcl cobol_gen_driver_$Tr_End entry(char(*));/**/ /***..... dcl Trace_Bit bit(1) static external;/**/ /***..... dcl Trace_Lev fixed bin static external;/**/ /***..... dcl Trace_Line char(36) static external;/**/ /***..... dcl ioa_ entry options(variable); /**/ /***..... dcl MY_NAME char (22) int static init ("COBOL_POINTER_REGISTER");/**/ dcl 1 ptr_status (0:7) based (cobol_$ptr_status_ptr) aligned, %include cobol_ptr_status; dcl 1 reg_status (0:9) based (cobol_$reg_status_ptr) aligned, %include cobol_reg_status; %include cobol_; end cobol_pointer_register;  cobol_pool.pl1 05/24/89 1042.8rew 05/24/89 0832.7 78345 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_pool.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 1/5/76 by Bob Chang to search operators only when nchar=8 or nchar<5. */ /* Modified since Version 2.0. */ /* format: style3 */ cobol_pool: cobol_pool_: proc (constant, boundary, offset, in_op, byte_count); /*} function: This procedure pools a constant in the constant portion of the cobol object text section. NOTE: NO conversion, blank or zero padding is performed. usage: dcl cobol_pool entry (char(*), fixed bin, fixed bin(24)); call cobol_pool (constant, boundary, offset); where: constant (input): is the constant to be pooled boundary (input): specifies the allocation of the left-most char of the constant = 0 := any word alloc; return offset in CHARS = 1 := any word alloc; return offset in WORDS = 2 := EVEN word alloc; return offset in WORDS = 3 := ODD word alloc; return offset in WORDS = 4 := any char alloc; return offset in CHARS NOTE: cobol_pool ALWAYS places the 1st char of the constant in the LEFT-MOST char position of the 1st word allocated offset (output): is the WORD or CHARACTER offset of the pooled constant relative to the END of the constant portion of the text section. NOTE: the CHARACTER offset refers to the 1st char in the constant and the WORD offset refers to the word containing the 1st character of the constant. (This offset is in the same form as the offset supplied by Data Division Allocation.) in_op output from the search_op entry . = 0 := the constant is not in cobol_operators_ = 1 := the constant is in cobol_operators_. the output offset is based on the cobol_operators_. byte_count input to search_op_byte for the number of bytes which are neglected when searching. }*/ /* written by: Bob McDowell entered system: 7/29/74 last modified: 12/06/74 */ /* note: still needs; n) */ dcl ( ioa_, ioa_$rsnnl, signal_ ) entry options (variable); dcl (substr, unspec, fixed, rel, index) builtin; dcl (addr, addrel, length, null, string) builtin; dcl 1 create_con_pool aligned based (con_wrk_ptr), 2 next_const char (no_char); dcl 1 search_con_pool aligned based (con_wrk_ptr), 2 all_consts char (char_size); dcl 1 op_con_base based (op_con_ptr), 2 num fixed bin, 2 filler fixed bin, 2 op_con char (0 refer (op_con_base.num)); dcl 1 error_info aligned, 2 module_name char (32) init ("cobol_pool"), 2 err_msg_lngth fixed bin, 2 error_msg char (168); dcl constant char (*); dcl msg_1 char (32) init ("constant entered had 0 length; "); dcl msg_2 char (44) init ("illegal boundary code value - [0<=code<=4]; "); dcl msg_3 char (40) init ("constant section overlaps text section; "); dcl msg_4 char (47) init ("illegal byte_count value - [0<=byte_count<=7]; "); dcl utemp fixed bin; dcl (nchar, nword, word_size, char_size) fixed bin; dcl (boundary, end_loc, srch_loc, found_loc, reset_loc) fixed bin; dcl in_op fixed bin; dcl byte_count fixed bin; dcl no_char fixed bin; dcl char_count fixed bin; dcl start_loc fixed bin; dcl (insert_loc, char_loc, bits35_36, bit_36) fixed bin; dcl offset fixed bin (24); dcl (con_base_ptr, con_wrk_ptr) ptr; start: reset_loc = con_wd_off; char_count = 0; nchar = length (constant); if (nchar > 0) then goto ck_bndry; call error (msg_1); return; ck_bndry: if ((boundary >= 0) & (boundary <= 4)) then goto begin; call error (msg_2); return; begin: utemp = nchar + char_count + 3; nword = fixed (substr (unspec (utemp), 1, 34), 36); end_loc = fixed (rel (con_end_ptr), 18); con_base_ptr = addrel (con_end_ptr, -end_loc); /* search for this constant already in pool */ if (con_wd_off = 1) then srch_loc = end_loc - 1; else srch_loc = end_loc - (con_wd_off - 1) + 1; search_1: con_wrk_ptr = addrel (con_base_ptr, srch_loc); word_size = end_loc - srch_loc; word_size = mod (word_size, 256); char_size = word_size * 4; start_loc = 1; char_loc = fixed (rel (con_wrk_ptr), 18); if (substr (unspec (char_loc), 36, 1) = "1"b & boundary = 2) | (substr (unspec (char_loc), 36, 1) = "0"b & boundary = 3) then start_loc = 5; loop: if substr (all_consts, start_loc + char_count, nchar) = constant then goto found; else if boundary = 0 | boundary = 1 then start_loc = start_loc + 4; else if boundary = 4 then start_loc = start_loc + 1; else start_loc = start_loc + 8; if start_loc + nchar - 1 <= char_size then goto loop; goto pool_it; found: char_loc = start_loc - 1; offset = fixed (substr (unspec (char_loc), 1, 34), 36); found_loc = srch_loc + offset; offset = end_loc - found_loc + 1; if boundary = 0 | boundary = 4 then offset = offset * 4; if boundary ^= 4 then goto exit; char_loc = mod (char_loc, 4); if char_loc ^= 0 then offset = offset + char_loc; return; /* pool constant after satisfying boundary conditions */ pool_it: con_wd_off = con_wd_off + nword; bump_it: offset = con_wd_off - 1; insert_loc = end_loc - offset + 1; if ((boundary = 0) | (boundary = 4) | (boundary = 1)) then goto ck_fit; bit_36 = fixed (substr (unspec (insert_loc), 36, 1), 36); /* check current pool loc satisfies boundary conditions */ ck_bound: if ((boundary = 2) & (bit_36 = 0)) then goto ck_fit; if ((boundary = 3) & (bit_36 = 1)) then goto ck_fit; /* boundary conditions unsatisfied; bump offset */ con_wd_off = con_wd_off + 1; goto bump_it; /* check if this constant will fit in constant pool */ ck_fit: if (insert_loc > text_wd_off) then goto insert; call error (msg_3); return; /* insert this constant in the constant pool */ insert: con_wrk_ptr = addrel (con_base_ptr, insert_loc); no_char = nchar + char_count; if char_count ^= 0 then substr (next_const, 1, char_count) = ""; substr (next_const, char_count + 1, nchar) = substr (constant, 1, nchar); if boundary = 0 | boundary = 4 then offset = offset * 4; exit: return; /* ***************************************/ /* The following entry are implemented to search the constant in cobol_operators_ before the try on constant section in text segment. The fourth parameter in_op is the output explained on the main entry. */ search_op: entry (constant, boundary, offset, in_op, byte_count); char_count = 0; goto start_op; /*****************************************/ /* This procedure is for the search of cobol_operatorwith the leading null chars neglected. The word alignment is the same as usual.*/ search_op_byte: entry (constant, boundary, offset, in_op, byte_count); char_count = byte_count; start_op: in_op = 0; if char_count < 0 | char_count > 7 then call error (msg_4); nchar = length (constant); if (nchar > 0) then goto ck_bndry_op; call error (msg_1); return; ck_bndry_op: if ((boundary >= 0) & (boundary <= 4)) then goto begin_op; call error (msg_2); return; begin_op: if (nchar > 4) & (nchar ^= 8) then goto begin; if boundary = 3 then start_loc = 5; else start_loc = 1; loop_op: if substr (op_con, start_loc + char_count, nchar) = constant then goto found_op; if boundary = 4 then start_loc = start_loc + 1; else if boundary = 1 | boundary = 0 then start_loc = start_loc + 4; else start_loc = start_loc + 8; if start_loc + nchar - 1 <= op_con_base.num then goto loop_op; goto begin; found_op: offset = start_loc + 8199; if (boundary ^= 0) & (boundary ^= 4) then offset = fixed (substr (unspec (offset), 1, 34)); in_op = 1; return; /***************************************/ error: proc (err_msg); dcl err_msg char (*); call ioa_$rsnnl ("^a ABORTING const -> ""^a""", error_msg, err_msg_lngth, err_msg, constant); call signal_ ("command_abort_", null, addr (error_info)); offset = 0; con_wd_off = reset_loc; return; end error; %include cobol_; end cobol_pool;  cobol_process_error.pl1 05/24/89 1042.8rew 05/24/89 0832.7 51354 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_process_error.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 5/18/76 by Bob Chang to fix the aos instruction. */ /* Modified on 05/05/76 by Bob Chang to interface with cobol_reg_manager. */ /* Modified on 4/24/76 by Bob Chang to interface with cobol_rts_. */ /* Modified on 4/19/76 by Bob Chang to interface with cobol operator. */ /* Modified on 4/2/76 by Bob Chang to interface with cobol operator. */ /*{*/ /* format: style3 */ cobol_process_error: proc (cobol_error_code, line_no, error_code_relp); /* This sub-generator produces code to generate an object time error message via the run-time support routine cobol_error_. */ dcl cobol_error_code fixed bin; dcl line_no fixed bin; dcl error_code_relp fixed bin; /* cobol_error_code a fixed bin number indicating the "COBOL error number" (see below). If 0, then there is no associated COBOL error number and no COBOL message is printed. This program will set up a call to a run-time error routine cobol_error_. Run-time support routines encountering errors will also call cobol_error_. Thus all error messages will be funnelled through one run-time routine. The interface is as follows: call cobol_error_ (cobol_code,multics_code,line_no1, line_no2,progname,error_ptr); cobol_code corresponds to cobol_error_code described above. multics_code a fixed bin corresponding to the location identified by sp|error_code_relp described above. line_no1 a fixed bin containing the line number on which the error occurred. This is derived from the internal line number given in line_no described above. If it is 0, no line number is applicable to this error and no such indication will be given in the error message. line_no2 a fixed bin containing the additional line number. This is derived from the internal line number line_no described above. If it is 0, then only a one-part line number is given. progname a varying char field containing the name of the program which produced the error. The cobol_process_error sub-generator will always set it to the name of the program for which code is being generated. Run-time support routines may identify the program which called them or themselves, depending on the error. error_ptr a pointer to the location at which the error was discovered or to the location at which cobol_control_ is called from. The cobol_process_error sub-generator will always set it to the latter. The following message(s) will be output to the "error_output" stream: ["progname": Multics message (from com_err_)] ["progname": COBOL error message] Error occurred at "segno|offset" [in "progname" [on line ["line_no2"] "line_no1"]] The first line is printed only if multics_code is non-zero. The second line is printed only if cobol_code is non-zero. The third line is always printed. The progname portion of it is not present if progname is null; the line_no2 portion of it is not present is line_no2 is zero; the line_no1 portion of it is not present if line_no1 is zero. If progname is null and the first and/or the second line is present, the the string "cobol_error" is used in place of it. }*/ dcl inst_seq bit (36) static init ("000000000000000000111000000001000000"b); /* tsx0 pr0|4095+cobol_code */ dcl add_use_code bit (36) static init ("110000000001001001000101100001000000"b); /* aos pr6|73 */ /* -5-18-76- */ dcl sw fixed bin; dcl temp fixed bin; dcl cobol_emit entry (ptr, ptr, fixed bin); dcl cobol_reg_manager$before_op entry (fixed bin); dcl cobol_reg_manager$after_op entry (fixed bin); /*************************************/ sw = 1; go to start; use: entry (cobol_error_code, line_no, error_code_relp); sw = 2; start: if cobol_error_code = 0 then cobol_error_code = 58; temp = 4095 + cobol_error_code; call cobol_reg_manager$before_op (temp); if sw = 2 then call cobol_emit (addr (add_use_code), null (), 1); substr (inst_seq, 4, 15) = substr (unspec (temp), 22, 15); call cobol_emit (addr (inst_seq), null (), 1); call cobol_reg_manager$after_op (temp); return; /*************************************/ /***** Declaration for builtin function *****/ dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index) builtin; /***** End of declaration for builtin function *****/ %include cobol_; end cobol_process_error;  cobol_profile.pl1 05/24/89 1042.8rew 05/24/89 0832.7 18621 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_profile.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Create on 1/21/77 by Bob Chang to implement profile option. */ /* format: style3 */ cobol_profile: proc; /* This procedure is called to generate a AOS instruction when profile option is specified on cobol program compilation.*/ dcl first_time static fixed bin, link_offset fixed bin static; dcl aos_inst (2) bit (18) static init ("100000000000000000"b, "000101100001000000"b); /* aos pr4|link_offset */ dcl rel_aos (2) bit (5) aligned static init ("11001"b, "00000"b); dcl cobol_emit entry (ptr, ptr, fixed bin); start: if first_time ^= cobol_$compile_count then do; first_time = cobol_$compile_count; link_offset = 65; end; else link_offset = link_offset + 2; substr (aos_inst (1), 4, 15) = substr (unspec (link_offset), 22, 15); call cobol_emit (addr (aos_inst), addr (rel_aos), 1); exit: return; /***** Declaration for builtin function *****/ dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index) builtin; /***** End of declaration for builtin function *****/ %include cobol_; end cobol_profile;  cobol_prologue_gen.pl1 05/24/89 1042.8rew 05/24/89 0832.7 73944 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_prologue_gen.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified since Version 5.1 */ /* format: style3 */ cobol_prologue_gen: proc (in_token_ptr, binit_tag, fxs_tag, fxs_locno, decl_flag); declare ( binit_tag fixed bin, fxs_tag fixed bin, fxs_locno fixed bin, decl_flag fixed bin ) parameter; /* CREATE CLASS-0 DEFINITION FOR PROGRAM'S ENTRY POINT AND */ /* RELOCATION INFORMATION FOR SAME */ eos_ptr = in_token.token_ptr (in_token.n); if end_stmt.a = "000"b then n_args = 0; else n_args = end_stmt.e; object_name = (32)" "; substr (object_name, 1, 30) = fixed_common.prog_name; object_name_len = index (fixed_common.prog_name, " ") - 1; if object_name_len = -1 then object_name_len = 30; text_ptr = cobol_$text_base_ptr; if fixed_common.init_cd then n_args = 1; call cobol_def_util (n_args, object_name, object_name_len, text_ptr, 1, null (), in_token_ptr); /* PREPARE AND EMIT ENTRY SEQUENCE CODE AND RELOCATION */ /* INFORMATION */ entry_seq.trace_cntrl_relp = "000000000000111111"b; if fixed_common.options.st = "1"b then do; call cobol_make_link$type_1 (offset, 2); if fixed_common.options.profile then do; fixup_directive.location.offset = cobol_$text_wd_off + 6; call cobol_make_fixup (addr (fixup_directive)); end; entry_seq.link_relp = substr (unspec (offset), 19, 18); entry_seq_reloc (13) = "10010"b; entry_seq_reloc (14) = "10110"b; end; else do; entry_seq.link_relp = (18)"0"b; entry_seq.block_relp = (18)"0"b; entry_seq_reloc (13) = (5)"0"b; entry_seq_reloc (14) = (5)"0"b; end; call cobol_emit (text_ptr, addr (entry_seq_reloc), 7); /* PREPARE AND EMIT INITIALIZATION CODE AND RELOCATION */ /* INFORMATION */ fxs_tag = 0; /*-11/30/76-*/ if seg_init_flag ^= 0 | data_init_flag ^= 0 then do; call cobol_r_initialize; /* Reserve 80 words in stack for the run time package. */ call cobol_alloc$stack (336, 2, offset); binit_tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_emit (addr (init_seq), null (), 1); call cobol_make_tagref (binit_tag, cobol_$text_wd_off - 1, null); end; else do; binit_tag = 0; call cobol_emit (addr (aos_inst), addr (rel_aos), 1); call cobol_r_initialize; /* Reserve 80 words in stack for the run time package. */ call cobol_alloc$stack (336, 2, offset); end; if fixed_common.options.profile then do; fixup_directive.location.offset = cobol_$text_wd_off; call cobol_make_fixup (addr (fixup_directive)); end; call cobol_emit (addr (inst_rts (1)), addr (rel_rts (1)), 1); /* Relocation info for cobol_rts_ */ if fixed_common.options.profile then call cobol_profile; if fixed_common.init_cd then do; alpha_type9.seg = fixed_common.init_cd_seg; alpha_type9.off = fixed_common.init_cd_offset; call cobol_set_pr (addr (pr_struc), addr (alpha_type9)); call cobol_call_op (77, 0); end; else if (fixed_common.options.oc & fixed_common.descriptor ^= "00"b) then call cobol_emit (addr (inst_oc), null (), 1); cobol_$init_stack_off = cobol_$stack_off; if decl_flag ^= 0 then do; fxs_tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_emit (addr (init_seq1), null (), 1); fxs_locno = cobol_$text_wd_off; call cobol_make_tagref (fxs_tag, cobol_$text_wd_off - 1, null); end; return; dcl n_args fixed bin, /* No of operands in USING phrase*/ i fixed bin, /* Do loop index */ object_name char (32), object_name_len fixed bin, offset fixed bin, /* Offset as returned by various */ /* subroutines */ n_con fixed bin, /* No of conditions */ n_off fixed bin, /* Offset of 1st wd of stack */ /* allocation */ name (2) char (32), /* Array of condition names */ ln_nm (2) fixed bin, /* Array of condition name lngths*/ temp fixed bin; /* Entry sequence code */ dcl entry_seq_reloc (14) bit (5) aligned static init ("10000"b, "00000"b, "10000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "11001"b, "11000"b, "00000"b, "00000"b); /* Initialization sequence code and relocation information */ dcl init_seq1 (2) bit (18) static init ("000000000000000000"b, "111001000000000100"b); /* tra decl_loc,ic */ dcl nop_instr (2) bit (18) static init ("000000000000000000"b, "000001001000000000"b); /* nop */ dcl inst_oc (2) bit (18) static init ("000000000000001100"b, "111000000001000000"b); /* tsx0 pr0|14 */ dcl init_seq (2) bit (18) unaligned static init ("000000000000000000"b, "111000000000000100"b); /* tsx0 init_data,ic */ dcl aos_inst (2) bit (18) static init ("100000000000001110"b, "000101100001000000"b); /* aos pr4|16 */ dcl rel_aos (2) bit (5) aligned static init ("11001"b, "00000"b); dcl inst_rts (2) bit (18) static init ("000000000001000000"b, "000001001001000000"b); /* nop 100 */ dcl rel_rts (2) bit (5) aligned static init ("10100"b, "00000"b); /* fixup directive for link, used when profile options is specified. */ dcl 1 fixup_directive aligned static, 2 operation bit (1) unal init ("0"b), 2 type bit (4) unal init ("1111"b), 2 reserved bit (9) unal init ("000000000"b), 2 location unal, 3 half bit (1) unal init ("0"b), 3 base bit (3) unal init ("001"b), 3 offset fixed bin unal, 2 tag_number fixed bin aligned; /* Declaration for static data. */ dcl 1 pr_struc static, 2 what_ptr fixed bin init (1), 2 pointer_no bit (3), 2 lock fixed bin init (0), 2 switch fixed bin init (0); dcl 1 alpha_type9 static, 2 header (4) fixed bin init (112, 0, 0, 9), 2 repl_ptr (2) ptr init ((2) null ()), 2 fill1 bit (108) init (""b), 2 file_key_info, 3 fb1 (3) fixed bin init (0, 0, 0), 3 size fixed bin init (0), 3 fb2 (2) fixed bin init (0, 0), 3 flags1 bit (36) init ("000000100100000000010000000100000000"b), 3 flags2 bit (36) init (""b), 3 seg fixed bin init (0), 3 off fixed bin, 2 fill2 (7) fixed bin init (0, 0, 0, 0, 0, 0, 0); /* P__r_o_c_e_d_u_r_e_s_C__a_l_l_e_d:_ */ dcl cobol_alloc$stack entry (fixed bin, fixed bin, fixed bin), cobol_define_tag_nc entry (fixed bin, fixed bin), cobol_call_op entry (fixed bin, fixed bin), cobol_set_pr entry (ptr, ptr), cobol_profile entry, cobol_emit entry (ptr, ptr, fixed bin), cobol_make_link$type_1 entry (fixed bin, fixed bin), cobol_make_link$type_4 entry (fixed bin, char (*)), cobol_make_tagref entry (fixed bin, fixed bin, ptr), cobol_make_fixup entry (ptr), cobol_pool entry (char (*), fixed bin, fixed bin), cobol_r_initialize entry, cobol_reloc entry (ptr, fixed bin, fixed bin), cobol_def_util entry (fixed bin, char (32), fixed bin, ptr, fixed bin, ptr, ptr); /***** Declaration for builtin function *****/ dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index) builtin; /***** End of declaration for builtin function *****/ %include cobol_; %include cobol_entry_seq; %include cobol_fixed_common; %include cobol_ext_; %include cobol_fixed_static; %include cobol_definitions; %include cobol_type19; %include cobol_in_token; end cobol_prologue_gen;  cobol_purge_gen.pl1 05/24/89 1042.8rew 05/24/89 0832.7 31401 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_purge_gen.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 10/04/77 by Bob Chang to fix theb bug for mcs_ocdp. */ /* Modified on 03/23/77 by Bob Chang to implement purge verb. */ /* Created as a stub on 11/18/76 by ORN */ /*{*/ /* format: style3 */ cobol_purge_gen: proc (in_token_ptr); /* Declaration for static data. */ dcl 1 pr_struc static, 2 what_ptr fixed bin init (2), 2 pointer_no bit (3), 2 lock fixed bin init (0), 2 switch fixed bin init (0); dcl 1 alpha_type9 static, 2 header (4) fixed bin init (112, 0, 0, 9), 2 repl_ptr (2) ptr init ((2) null ()), 2 fill1 bit (108) init (""b), 2 file_key_info, 3 fb1 (3) fixed bin init (0, 0, 0), 3 size fixed bin init (0), 3 fb2 (2) fixed bin init (0, 0), 3 flags1 bit (36) init ("000000100100000000010000000100000000"b), 3 flags2 bit (36) init (""b), 3 seg fixed bin init (0), 3 off fixed bin, 2 fill2 (7) fixed bin init (0, 0, 0, 0, 0, 0, 0); dcl inst_seq (6) bit (18) unaligned static init ("110000000000000000"b, "010101010001000000"b, /* spri2 pr6|offset */ "110000000000000000"b, "010011100001000000"b, /* szn pr6|offset */ "000000000000000000"b, "110000000000000100"b); /* tze 0,ic */ /* Automatic data */ dcl dn_ptr ptr, stoff fixed bin, temp fixed bin; /* External procedure */ dcl cobol_call_op entry (fixed bin, fixed bin), cobol_define_tag entry (fixed bin), cobol_make_tagref entry (fixed bin, fixed bin, ptr), cobol_reg_manager$after_op entry (fixed bin), cobol_emit entry (ptr, ptr, fixed bin), cobol_set_pr entry (ptr, ptr); start: /* Generate epp2 instruction for communication token. */ cdtoken_ptr = in_token.token_ptr (2); alpha_type9.seg = cdtoken.cd_seg; alpha_type9.off = cdtoken.cd_off - 20; call cobol_set_pr (addr (pr_struc), addr (alpha_type9)); /* Allocate 12 words in stack frame for parameters */ stoff = 74; /* Communication stack frame from pr6|74 */ /* Store cd_token address. */ substr (inst_seq (1), 4, 15) = substr (unspec (stoff), 22, 15); call cobol_emit (addr (inst_seq (1)), null, 1); /* Call cobol_operators_ */ call cobol_call_op (72, 0); call cobol_reg_manager$after_op (72); exit: return; /***** Declaration for builtin function *****/ dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index) builtin; /***** End of declaration for builtin function *****/ %include cobol_; %include cobol_type13; %include cobol_type9; %include cobol_in_token; end cobol_purge_gen;  cobol_r_initialize.pl1 05/24/89 1042.8rew 05/24/89 0832.7 63099 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_r_initialize.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 04/08/76 by Bob Chnag to take out the preset of pr5. It is set in operator. */ /* Modified on 3/19/76 by Bob Chang to interface with the cobol_operators_. */ /*{*/ /* revised 09-07-74 by wko*/ /* format: style3 */ cobol_r_initialize: proc; /* 1. Initialize structures containing information about the object time A register,Q register, index registers and pointer registers. 2. Emit instructions to load the preset pointer registers to cobol data. ie pr3 and pr5 (if more than 32k of cobol data). 3. Emit instruction to store pr3 and pr5 (if needed) in the object time stack. POINTER REGISTER ASSIGNMENTS: the current assignment of object time pointer registers follows. The intent is to be able to change these assignments by making changes to only this utility and other pointer register management utilities, and making no changes to the main body of the generator PR0: function - permanently set to cobol operators obtained - pr6 |24 representation - segment 4000, offset 0. PR1: function - temporary register PR2: function - temporary register PR3: function - permanently set to location 16k (words) of cobol data. obtained - initially pr4 | 8 contains the base address of cobol data. Subsequent to its initial setting it is obtained from pr6 | 64 representation - segment 2, offset 40000 (octal) PR4: function - permanently set to the multics linkage section. obtained - pr6 | 36 representation - segment 3002, offset 0 PR5: function - (a) If there is more than 32k (words) of cobol data permanently set to location 48k (words) of cobol data (b) otherwise a temporary register obtained - initially pr4 |8 contains the base address of cobol data. Subsequent to its initial setting it is obtained from pr6 | 66 representation - segment 2, offset 140000 (octal) PR6: function - this is always set to the stack frame of the object program. All components of the generator can assume this. There is no need to use the pointer register management utilities, but it will not hurt if the are used. representation - segment 1000, offset 0 PR7: function - temporary register. */ /*}*/ dcl i fixed bin; dcl cobol_emit entry (ptr, ptr, fixed bin) ext; dcl reloc (6) bit (5) aligned init ("11001"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b); /* epp5 pr4|8,* */ dcl ld5 bit (36) aligned init ("100000000000001000011111001101010000"b); /* adwp5 49152,du */ dcl add5 bit (36) aligned init ("001100000000000000001101001000000011"b); /* spri5 pr6|66 */ dcl st5 bit (36) aligned init ("110000000001000010110101001101000000"b); dcl save_stack_max_value fixed bin int static init (10); cobol_$ptr_status_ptr = addr (ptr_status (0)); cobol_$reg_status_ptr = addr (reg_status (0)); /* clear pointer register structure */ do i = 0 to 7; usage (i) = 0; contents_sw (i) = 0; seg_num (i) = 0; wd_offset (i) = 0; p_lock (i) = 0; p_priority (i) = 0; p_reset (i) = 0; reset_seg_num (i) = 0; reset_wd_offset (i) = 0; ptr_status.save_stack_max (i) = save_stack_max_value; ptr_status.save_stack_count (i) = 0; end; /* set up pr0 for cobol operators */ /* the prologue generation process loads pr0 */ i = 0; pointer_num (i) = "000"b; usage (i) = 1; contents_sw (i) = 1; seg_num (i) = 4000; p_reset (i) = 1; reset_seg_num (i) = seg_num (i); /* set up pr1 as temporary register */ i = i + 1; pointer_num (i) = "001"b; /* set up pr2 as temporary register */ i = i + 1; pointer_num (i) = "010"b; /* set up pr3 to location 16k (words) of cobol data */ i = i + 1; pointer_num (i) = "011"b; usage (i) = 1; contents_sw (i) = 1; seg_num (i) = 2; wd_offset (i) = 16384; p_reset (i) = 1; reset_seg_num (i) = seg_num (i); reset_wd_offset (i) = wd_offset (i); /* emit instructions to load pr3 and save it */ /* set up pr4 as multics linkage */ /* the prologue generation process loads pr4 */ i = i + 1; pointer_num (i) = "100"b; usage (i) = 1; contents_sw (i) = 1; seg_num (i) = 3002; p_reset (i) = 1; reset_seg_num (i) = seg_num (i); /* set up pr5 to location 48k (words) of cobol data (if there is over 32k (words) of cobol data), or as a temporary register otherwise */ /* Commented out on cobol operator interface. */ /*-04/08/76-*/ i = i + 1; pointer_num (i) = "101"b; if cobol_$cobol_data_wd_off > 32767 then do; usage (i) = 1; contents_sw (i) = 1; seg_num (i) = 2; wd_offset (i) = 49152; p_reset (i) = 1; reset_seg_num (i) = seg_num (i); reset_wd_offset (i) = wd_offset (i); /* call cobol_emit(addr(ld5),addr(reloc),3); */ end; /* set up pr6 as stack frame */ /* the prologue generation process sets pr6 */ i = i + 1; pointer_num (i) = "110"b; usage (i) = 1; contents_sw (i) = 1; seg_num (i) = 1000; /* set up pr7 as temporary register */ i = i + 1; pointer_num (i) = "111"b; /* set up A,Q,index structure */ /* Initialize register status structures for A,Q, and index registers 0 thru 7 */ do i = 0 to 9; reg_status.r_lock (i) = 0; reg_status.r_priority (i) = 0; reg_status.save_stack_max (i) = save_stack_max_value; reg_status.save_stack_count (i) = 0; if i < 8 then reg_status.register_num = "1"b || bit (fixed (i, 3), 3); else if i < 9 then reg_status.register_num = "0001"b; /* A register */ else reg_status.register_num = "0010"b; /* MUST BE Q */ end; return; dcl 1 ptr_status (0:7) static aligned, %include cobol_ptr_status; /***** Declaration for builtin function *****/ dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index) builtin; /***** End of declaration for builtin function *****/ dcl 1 reg_status (0:9) static aligned, %include cobol_reg_status; %include cobol_; end cobol_r_initialize;  cobol_read_ft.pl1 05/24/89 1042.8rew 05/24/89 0832.7 19548 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_read_ft.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /*{*/ /* format: style3 */ cobol_read_ft: proc (file_no, ft_ptr); cobol_read_ft_: entry (file_no, ft_ptr); dcl file_no fixed bin; dcl ft_ptr ptr; /* file_no is the internal number assigned to the file and recorded in the Type 12 token (input). ft_ptr is a Multics ptr to the file_table for the corresponding file (output). }*/ dcl rec_id char (5); dcl (i, j, code) fixed bin; dcl cobol_read_rand entry (fixed bin, char (5), ptr); /*************************************/ start: if file_no < 21 then rec_id = fixed_common.filedescr_offsets (file_no); else do; rec_id = fixed_common.filedescr_offsets (20); j = file_no - 20; do i = 1 to j; call cobol_read_rand (1, rec_id, ft_ptr); rec_id = file_table.next; end; end; call cobol_read_rand (1, rec_id, ft_ptr); return; /*************************************/ /***** Declaration for builtin function *****/ dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index) builtin; /***** End of declaration for builtin function *****/ %include cobol_file_table; %include cobol_fixed_common; %include cobol_ext_; %include cobol_; end cobol_read_ft;  cobol_read_gen.pl1 05/24/89 1042.8rew 05/24/89 0832.7 132831 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_read_gen.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 06/27/79 by FCH, [4.0-1], not option added for debug */ /* Modified on 11/11/78 at 1111 by FCH,[3.0-2], alt rec keys */ /* Modified on 06/08/78 by FCH,[3.0-1], open i-o(ext,ind-seq) fixed */ /* Modified since Version 3.0 */ /* format: style3 */ cobol_read_gen: proc (mp_ptr, passed_tag); dcl passed_tag fixed bin; /* for in-line error handling */ dcl ptag fixed bin; dcl mp_ptr ptr; dcl 1 mp based (mp_ptr), 2 n fixed bin, /* from 3 or 4 */ 2 pt (0 refer (mp.n)) ptr; /* pt(1) pts to type1 token for READ */ /* pt(2) pts to type12 token for file to be read */ /* pt(3) pts to type9 token for INTO data IF eos.b = "1"b */ /* pt(n) pts to type19 token (eos) */ dcl 1 args, 2 entryno fixed bin, 2 arglist_off fixed bin, 2 stacktemp_off fixed bin, 2 n fixed bin, 2 arg (5), 3 pt ptr, 3 type fixed bin, 3 off1 fixed bin, 3 off2 fixed bin, 3 value bit (18) unal, 3 indirect bit (1) unal, 3 overlay bit (1) unal, 3 repeat_nogen bit (1) unal, 3 regsw bit (1) unal, 3 regno bit (3) unal; dcl file_key_desc char (40) based; dcl output_errno fixed bin init (40); /* Invalid I/O operation. Attempt to read a file opened as output */ dcl text (0:10000) bit (36) based (cobol_$text_base_ptr); dcl argb (5) bit (216) based (addr (args.arg (1))); dcl ft_ptr ptr; dcl fkey_ptr ptr; dcl dn_ptr ptr; dcl name_ptr ptr; dcl arg_ptr ptr; dcl ioerror_ptr ptr; dcl stoff fixed bin; dcl aloff fixed bin; dcl sbuf_off fixed bin; dcl size fixed bin; dcl offset fixed bin; dcl reclen_off fixed bin; dcl buflen_off fixed bin; dcl buf_off fixed bin; dcl declen_off fixed bin; dcl keylen_off fixed bin; dcl temp fixed bin; dcl ntag fixed bin; dcl (iosw, alt_sw, read_next_sw) bit (1); /*[3.0-2]*/ dcl char5 char (5), key_ctr fixed bin, skip_read_tag fixed bin; /*************************************/ /*************************************/ /* INITIALIZATION */ start: pr5_struct_ptr = addr (pr5_struct); rw_ptr = mp.pt (1); eos_ptr = mp.pt (mp.n); ioerror_ptr = addr (ioerror); ioerror.cobol_code = 0; ioerror.type1_ptr = mp.pt (1); ioerror.is_tag = 0; ioerror.mode = 0; if end_stmt.a ^= "000"b then do; /* in-line error coding follows */ ioerror.is_tag = cobol_$next_tag; /* to be defined at end of generated code for WRITE */ ptag, passed_tag = cobol_$next_tag + 1; /* to be defined by gen driver at end of in-line coding */ ioerror.ns_tag = ptag; cobol_$next_tag = cobol_$next_tag + 2; end; else do; ioerror.is_tag = 0; ptag = 0; ioerror.ns_tag = cobol_$next_tag; /* to be defined at end of generated code */ cobol_$next_tag = cobol_$next_tag + 1; end; arg_ptr = addr (args); iocb_arg.pt = addr (iocb_basic_struct); cra_arg.pt = addr (cra_basic_struct); call cobol_read_ft (mp.pt (2) -> fd_token.file_no, ft_ptr); /*[3.0-3]*/ read_next_sw = file_table.access < 2 /* seq */ /*[3.0-3]*/ | /*[3.0-3]*/ end_stmt.d = "01"b; /* read_next */ /*[3.0-2]*/ alt_sw = file_table.organization = 3 /* ind */ /*[3.0-2]*/ & /*[3.0-2]*/ file_table.alternate_keys ^= 0; /*[3.0-2]*/ if read_next_sw & alt_sw /*[3.0-2]*/ then do; skip_read_tag = cobol_$next_tag; /*[3.0-2]*/ cobol_$next_tag = cobol_$next_tag + 1; /*[3.0-2]*/ end; if file_table.organization = 5 then file_table.organization = 4; /* temporary */ if file_table.code_set_clause & file_table.code_set = 12 then do; /* 12 = ebcdic */ call cobol_alloc$stack (file_table.max_cra_size + 1, 2, stoff); alpha_type9.seg, trans_type9.seg = 1000;/* stack */ alpha_type9.off, trans_type9.off = stoff * 4; trans_type9.size = file_table.max_cra_size; end; else do; alpha_type9.seg = file_table.cra_seg; alpha_type9.off = file_table.cra_offset; end; alpha_type9.size = file_table.max_cra_size; call cobol_alloc$stack (80, 2, aloff); /* enough for 20 words - aloff is a wd offset */ args.arglist_off = aloff; argb (1) = unspec (iocb_arg); buflen_off = 80; reclen_off = 47; declen_off = aloff + 16; keylen_off = aloff + 19; /*************************************/ /* START CODE GENERATION */ start_codegen: /* MAKE SURE FILE IS OPEN */ ntag = cobol_$next_tag; ioerror.retry_tag = cobol_$next_tag + 1; call cobol_define_tag (ioerror.retry_tag); cobol_$next_tag = cobol_$next_tag + 2; call cobol_set_fsbptr (ft_ptr); /* OPERATOR63(init_read) */ call cobol_call_op (63, ntag); /* INT_READ_OP */ if end_stmt.a = "000"b then do; call cobol_emit (addr (opt_text), null, 2); call cobol_make_tagref (ntag, cobol_$text_wd_off - 1, null); end; call cobol_gen_ioerror (ft_ptr, ioerror_ptr); call cobol_define_tag (ntag); /* ESTABLISH MAXIMUM CURRENT RECORD AREA SIZE */ temp = file_table.max_cra_size; if file_table.organization = 4 then temp = temp + 1; /* allow for the nl character */ call cobol_io_util$move_direct ("110"b, buflen_off * 4, 4, 1, substr (unspec (temp), 19, 18)); /* STREAM INPUT */ if file_table.organization = 4 then do; call cobol_alloc$stack (file_table.max_cra_size + 1, 1, sbuf_off); ntag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; alpha_type9.size = file_table.max_cra_size; alpha_type9.seg = 1000; alpha_type9.off = sbuf_off * 4; call cobol_set_pr (pr5_struct_ptr, addr (alpha_type9)); /* OPERATOR64(get_line) */ call cobol_call_op (64, ntag); /* iox_$get_line */ call cobol_gen_ioerror (ft_ptr, ioerror_ptr); call cobol_define_tag (ntag); alpha_type9.seg = file_table.cra_seg; alpha_type9.off = file_table.cra_offset; call cobol_io_util$move_from_varlen ("110"b, reclen_off * 4, addr (alpha_type9), "110"b, sbuf_off * 4) ; end; else do; if file_table.access = 3 /* dynamic - must prevent reads for output opening */ & (file_table.external | file_table.open_ext) then do; ntag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_io_util$bypass_mode_error (ntag, "11"b); /* OPERATOR54(delete_error) */ call cobol_call_op (54, ntag);/* ERROR_OP */ call cobol_gen_ioerror (ft_ptr, ioerror_ptr); call cobol_define_tag (ntag); end; iosw = (file_table.external | file_table.delete | file_table.rewrite) & file_table.access < 2; if read_next_sw /* FORMAT 1 READ */ then do; /* READ NEXT */ if (file_table.organization > 1 & iosw & file_table.access < 2) /* to verify rewrite and delete */ | (file_table.organization = 2 & file_table.relative_key) /* to set relative_key */ then do; /* remember key of next rec - i.e. the rec to be read */ /* PROVIDE FOE BYPASSING READ KEY IF WORTHWHILE */ ntag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; if (file_table.open_in | file_table.external) & file_table.organization = 3 then do; call cobol_io_util$bypass_readkey (ntag); end; /* READ KEY OF NEXT RECORD */ call cobol_alloc$stack (260, 2, stoff); /* area know as TEMP read key area */ call cobol_ioop_util$lda_du (stoff); /*OPERATOR69(read_key_for_read) */ call cobol_call_op (69, ntag); /* iox_$read_key */ call cobol_gen_ioerror (ft_ptr, ioerror_ptr); call cobol_define_tag (ntag); /*[3.0-1]*/ if iosw then do; call cobol_set_fsbptr (ft_ptr); call cobol_io_util$move ("110"b, keylen_off * 4, 4, "001"b, fsb_keylen_sw, 4); call cobol_io_util$move_direct ("001"b, fsb_keylen_sw, 4, 1, ""b); /* until successful read */ end; end; else do; if iosw then do; if file_table.organization ^= 1 then call cobol_io_util$move ("110"b, keylen_off * 4, 4, "001"b, fsb_keylen_sw, 4); call cobol_io_util$move_direct ("001"b, fsb_keylen_sw, 4, 1, ""b); /* until sucessful read */ end; /*[3.0-2]*/ if alt_sw /*[3.0-2]*/ then do; ntag = cobol_$next_tag; /*[3.0-2]*/ cobol_$next_tag = cobol_$next_tag + 1; /*[3.0-2]*/ call cobol_io_util$file_desc (file_table.file_desc_1_offset); /*[3.0-2]*/ call cobol_call_op$skip (92, ntag, skip_read_tag); /* OPERATOR92(alt_find_rec) */ /*[3.0-2]*/ call cobol_define_tag (ntag); /*[3.0-2]*/ call cobol_set_fsbptr (ft_ptr); /*[3.0-2]*/ end; end; end; else do; /* FORMAT 2 READ */ /*[3.0-2]*/ if alt_sw & end_stmt.e ^= 511 /*[3.0-2]*/ then do; char5 = file_table.alt_key_info; /*[3.0-2]*/ /*[3.0-2]*/ do key_ctr = 1 by 1 to end_stmt.e; /*[3.0-2]*/ /*[3.0-2]*/ call cobol_read_rand (1, char5, fkey_ptr); /*[3.0-2]*/ /*[3.0-2]*/ char5 = file_key.next_alt; /*[3.0-2]*/ end; /*[3.0-2]*/ end; else call cobol_read_rand (1, file_table.r_key_info, fkey_ptr); addr (fkey_type9.file_key_info) -> file_key_desc = file_key.desc; mpout.pt1 = mp.pt (1); mpout.pt2 = addr (fkey_type9); if file_table.organization = 2 then do; /* relative */ mpout.pt3 = addr (num_type9); size, num_type9.size, num_type9.places_left = 16; num_type9.seg = 5001; /* from PR1 */ num_type9.off = file_table.fsb.off + fsb_key; end; else do; /* indexed */ mpout.pt3 = addr (alpha_type9); size, alpha_type9.size = fkey_type9.size; alpha_type9.seg = 5001; /* from PR1 */ alpha_type9.off = file_table.fsb.off + fsb_key; end; mpout.pt4 = addr (type19); call cobol_move_gen (addr (mpout)); call cobol_io_util$move_direct ("001"b, fsb_keylen_sw, 4, 1, substr (unspec (size), 19, 18)) ; /*[3.0-2]*/ if alt_sw /*[3.0-1]*/ then do; call cobol_io_util$key_loc (0, 0); /*[3.0-2]*/ call cobol_io_util$file_desc (file_table.file_desc_1_offset); /*[3.0-2]*/ call cobol_io_util$key_num (end_stmt.e); /*[3.0-2]*/ call cobol_call_op (84, 0); /*[3.0-2]*/ call cobol_set_fsbptr (ft_ptr); /*[3.0-2]*/ end; ntag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; /* OPERATOR67(read_seek_key) */ call cobol_call_op (67, ntag);/* iox_$seek_key */ call cobol_gen_ioerror (ft_ptr, ioerror_ptr); call cobol_define_tag (ntag); end; /* PERFORM READ */ ntag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; alpha_type9.size = file_table.max_cra_size; alpha_type9.seg = file_table.cra_seg; alpha_type9.off = file_table.cra_offset; call cobol_set_pr (pr5_struct_ptr, addr (alpha_type9)); /*[3.0-2]*/ if read_next_sw /*[3.0-2]*/ then do; call cobol_call_op (65, ntag);/* OPERATOR65(read_record) */ /*[3.0-2]*/ if alt_sw then call cobol_define_tag (skip_read_tag); /*[3.0-2]*/ end; /*[3.0-2]*/ else call cobol_call_op (66, ntag); /* OPERATOR66(nonseq_read_key) */ call cobol_gen_ioerror (ft_ptr, ioerror_ptr); call cobol_define_tag (ntag); /*[3.0-2]*/ if alt_sw /*[3.0-2]*/ then do; call cobol_io_util$file_desc (file_table.file_desc_1_offset); /*[3.0-2]*/ call cobol_set_fsbptr (ft_ptr); /*[3.0-2]*/ if read_next_sw /*[3.0-2]*/ then call cobol_call_op (80, 0); /* OPERATOR80(alt_read_next) */ /*[3.0-2]*/ else call cobol_call_op (81, 0); /* OPERATOR81(alt_read_key) */ end; /* SET KEY IN FSB IF NECESSARY */ if iosw then do; call cobol_set_fsbptr (ft_ptr); if file_table.organization = 1 then call cobol_io_util$move_direct ("001"b, fsb_keylen_sw, 4, 1, (18)"1"b); else call cobol_io_util$move ("001"b, fsb_keylen_sw, 4, "110"b, keylen_off * 4, 4); end; end; if file_table.rec_do then do; /* must set depending-on variable */ if file_table.organization = 4 then call cobol_io_util$fixed_add ("110"b, reclen_off * 4, -1, ""b, 0); /*for nl*/ call cobol_io_util$bin_to_dec ("110"b, declen_off * 4, 12, "110"b, reclen_off * 4, 4); call cobol_read_rand (1, file_table.rec_do_info, fkey_ptr); addr (fkey_type9.file_key_info) -> file_key_desc = file_key.desc; mpout.pt1 = mp.pt (1); mpout.pt2 = addr (num_type9); num_type9.size, num_type9.places_left = 12; num_type9.seg = 1000; /* in stack */ num_type9.off = declen_off * 4; mpout.pt3 = addr (fkey_type9); mpout.pt4 = addr (type19); call cobol_move_gen (addr (mpout)); end; if file_table.code_set_clause & file_table.code_set = 12 then do; /* 12 = ebcdic */ call cobol_trans_alphabet$io (addr (trans_type9), addr (alpha_type9), fixed (file_table.code_set), 1); end; if end_stmt.b = "1"b then do; /* move record INTO variable */ mpout.pt1 = mp.pt (1); mpout.pt2 = addr (alpha_type9); mpout.pt3 = mp.pt (3); mpout.pt4 = addr (type19); call cobol_move_gen (addr (mpout)); end; /* SET RELATIVE KEY IF NECESSARY */ if file_table.organization = 2 & (file_table.access < 2 | end_stmt.d = "01"b) & file_table.relative_key then do; call cobol_read_rand (1, file_table.r_key_info, fkey_ptr); addr (fkey_type9.file_key_info) -> file_key_desc = file_key.desc; call cobol_set_fsbptr (ft_ptr); mpout.pt1 = mp.pt (1); mpout.pt2 = addr (num_type9); num_type9.size, num_type9.places_left = 16; num_type9.seg = 5001; num_type9.off = file_table.fsb.off + fsb_key; mpout.pt3 = addr (fkey_type9); mpout.pt4 = addr (type19); call cobol_move_gen (addr (mpout)); end; call cobol_reg_manager$after_op (4095 + ioerror.cobol_code); /*[4.0-1]*/ if end_stmt.f = "01"b /*[4.0-1]*/ then passed_tag = ioerror.is_tag; /*[4.0-1]*/ else call cobol_gen_ioerror$finish_up (ft_ptr, ioerror_ptr); return; %include cobol_read_gen_info; %include cobol_read_gen_data; end cobol_read_gen;  cobol_read_rand.pl1 05/24/89 1042.8rew 05/24/89 0832.7 20952 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_read_rand.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 01/14/77 by ORN for new name_table handling */ /* Modified since Version 2.0 */ /*{*/ /* format: style3 */ cobol_read_rand: cobol_read_rand_: proc (file_id, rec_id, file_ptr); arec_id = rec_id; goto start; fixed_bin: entry (file_id, fb_rec_id, file_ptr); brec_id = fb_rec_id; dcl fb_rec_id fixed bin; dcl file_id fixed bin; dcl rec_id char (5); dcl file_ptr ptr; /* file_id identifies the direct access file as follows: 1 variable common 2 name table 3 name table buffer (input). rec_id,fb_rec_id identifies the record within the specified direct access file (input). file_ptr points to the record (output). }*/ dcl arec_id char (5) aligned; dcl brec_id fixed bin based (addr (arec_id)); dcl inptr ptr; /*************************************/ start: if file_id = 3 | file_id = 2 then do; inptr = cobol_ext_$cobol_ntfp; file_ptr = pointer (inptr, brec_id); end; else do; inptr = cobol_ext_$cobol_cmfp; file_ptr = pointer (inptr, brec_id + 1); end; return; /*************************************/ /***** Declaration for builtin function *****/ dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index, pointer) builtin; /***** End of declaration for builtin function *****/ %include cobol_ext_; end cobol_read_rand;  cobol_receive_gen.pl1 05/24/89 1042.8rew 05/24/89 0832.7 47592 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_receive_gen.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 10/02/77 by Bob Chang to fix the bug for mcs_icdp. */ /* Modified on 03/03/77 by Bob Chang to implement communication receive verb. */ /* Created as a stub on 11/18/76 by ORN */ /* format: style3 */ cobol_receive_gen: proc (in_token_ptr, next_stmt_tag); /* Declaration for static data. */ dcl 1 pr_struc static, 2 what_ptr fixed bin init (2), 2 pointer_no bit (3), 2 lock fixed bin init (0), 2 switch fixed bin init (0); dcl 1 alpha_type9 static, 2 header (4) fixed bin init (112, 0, 0, 9), 2 repl_ptr (2) ptr init ((2) null ()), 2 fill1 bit (108) init (""b), 2 file_key_info, 3 fb1 (3) fixed bin init (0, 0, 0), 3 size fixed bin init (0), 3 fb2 (2) fixed bin init (0, 0), 3 flags1 bit (36) init ("000000100100000000010000000100000000"b), 3 flags2 bit (36) init (""b), 3 seg fixed bin init (0), 3 off fixed bin, 2 fill2 (7) fixed bin init (0, 0, 0, 0, 0, 0, 0); dcl inst_seq (12) bit (18) unaligned static init ("110000000000000000"b, "010101010001000000"b, /* spri2 pr6|offset */ "000000000000000000"b, "010011101000000111"b, /* lda 0,dl */ "110000000000000000"b, "111101101001000000"b, /* sta pr6|offset */ "110000000000000000"b, "100101000001000000"b, /* stz pr6|offset */ "110000000000000000"b, "010011100001000000"b, /* szn pr6|offset */ "000000000000000000"b, "110000000000000100"b); /* tze 0,ic */ /* Automatic data */ dcl next_stmt_tag fixed bin, /* PARAMETER for NO DATA statement */ stoff fixed bin, dn_ptr ptr, temp fixed bin; /* External procedure */ dcl cobol_call_op entry (fixed bin, fixed bin), cobol_pointer_register$priority entry (fixed bin, fixed bin, bit (3)), cobol_emit entry (ptr, ptr, fixed bin), cobol_define_tag entry (fixed bin), cobol_make_tagref entry (fixed bin, fixed bin, ptr), cobol_set_pr entry (ptr, ptr), cobol_reg_manager$after_op entry (fixed bin), cobol_get_size entry (ptr, fixed bin, fixed bin); start: /* Generate epp2 instruction for communication token. */ cdtoken_ptr = in_token.token_ptr (2); alpha_type9.seg = cdtoken.cd_seg; eos_ptr = in_token.token_ptr (in_token.n); alpha_type9.off = cdtoken.cd_off - 60; call cobol_set_pr (addr (pr_struc), addr (alpha_type9)); /* Allocate 12 words in stack frame for parameters */ stoff = 74; /* Communication stack frame from pr6|74 */ /* Store cd_token address. */ substr (inst_seq (1), 4, 15) = substr (unspec (stoff), 22, 15); call cobol_emit (addr (inst_seq (1)), null, 1); /* Set up parameter for message type. */ temp = stoff + 4; if end_stmt.b | end_stmt.c then do; if ^end_stmt.b then substr (inst_seq (3), 17, 2) = "01"b; else if end_stmt.c then substr (inst_seq (3), 17, 2) = "11"b; else substr (inst_seq (3), 17, 2) = "10"b; substr (inst_seq (5), 4, 15) = substr (unspec (temp), 22, 15); call cobol_emit (addr (inst_seq (3)), null, 2); end; else do; substr (inst_seq (7), 4, 15) = substr (unspec (temp), 22, 15); call cobol_emit (addr (inst_seq (7)), null, 1); end; /* Generate epp2 instruction for receiving data item. */ dn_ptr = in_token.token_ptr (3); call cobol_set_pr (addr (pr_struc), dn_ptr); /* Store into stack frame. */ temp = stoff + 2; substr (inst_seq (1), 4, 15) = substr (unspec (temp), 22, 15); call cobol_emit (addr (inst_seq (1)), null, 1); /* Set up the size of the data token. */ temp = stoff + 5; call cobol_get_size (dn_ptr, temp, 0); /* Call cobol_operators_ */ call cobol_call_op (70, 0); call cobol_reg_manager$after_op (70); /* Handle NO DATA statement. */ if end_stmt.b then do; temp = stoff + 7; substr (inst_seq (9), 4, 15) = substr (unspec (temp), 22, 15); call cobol_emit (addr (inst_seq (9)), null, 2); next_stmt_tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_make_tagref (next_stmt_tag, cobol_$text_wd_off - 1, null); end; exit: return; /***** Declaration for builtin function *****/ dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index) builtin; /***** End of declaration for builtin function *****/ %include cobol_in_token; %include cobol_; %include cobol_type19; %include cobol_type9; %include cobol_type13; end cobol_receive_gen;  cobol_reg_manager.pl1 05/24/89 1042.8rew 05/24/89 0832.7 52650 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_reg_manager.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 12/17/79 by FCH, [4.3-1] illegal subscript ref deleted (TR4096) */ /* Modified since Version 4.3 */ /* format: style3 */ cobol_reg_manager: proc; /* This procedure is called by any procedure that generates code to call a PL1 or Cobol operator. This entry point must be called before any code is generated to establish the interface with the PL1 or Cobol operator. (i.e. before loading registers with parameters to be passed to the operator). This entry point: 1. genertaes code to save all locked registers. They must be restored after the return from the operator. This can be done by a call to cobol_reset_r$after_operator. 2. unlocks all locked registers. */ /* DECLARATION OF EXTERNAL ENTRIES */ dcl cobol_register_util$restore_pointer ext entry (bit (4)); dcl cobol_register_util$restore ext entry (bit (4)); dcl cobol_register_util$save ext entry (bit (4)); dcl cobol_emit ext entry (ptr, ptr, fixed bin); dcl cobol_reg_manager entry (fixed bin); dcl cobol_reg_manager$set_pr5 entry; dcl cobol_reg_manager$after_op entry (fixed bin); dcl cobol_register_util$save_pointer ext entry (bit (4)); /* DECLARATION OF AUTOMATIC DATA. */ dcl i fixed bin, temp fixed bin, operator_num fixed bin; /*[4.3-1]*/ /* pointer_not_needed (200) bit(8) static options(constant) init( (200)(1)"00000000"b), index_reg_not_needed (200) bit(10) static options(constant) init( (200)(1)"0000000000"b); */ /*[4.3-1]*/ /**************************************************/ /* START OF EXECUTION */ before_op: entry (operator_num); /*[4.3-1]*/ if operator_num = 0 | operator_num >= 4096 then temp = 1; else temp = operator_num; /**************************************************/ /* Save any register (A,Q or index) that is locked. */ do i = 0 to 9; /*[4.3-1]*/ /* if substr(index_reg_not_needed(temp),i,1)="0"b then do;*/ if reg_status.r_lock (i) ^= 0 then do; /* This register is locked. */ call cobol_register_util$save ((get_bit_code (i))); /* save the register. */ reg_status.r_lock (i) = 0; /* Unlock it. */ end; /* This register is locked. */ end; /*[4.3-1]*/ /* end;*/ /* Save any pointer register that is locked. */ do i = 0 to 7; /*[4.3-1]*/ /* if substr(pointer_not_needed(temp),i,1)="0"b then do;*/ if ptr_status.p_lock (i) ^= 0 then do; /* This pointer register is locked. */ call cobol_register_util$save_pointer (substr (unspec (i), 33, 4)); ptr_status.p_lock (i) = 0; end; /* This pointer register is locked. */ end; /*[4.3-1]*/ /* end;*/ /************************************** entry for set_pr5 *****************************************/ set_pr5: entry; return; /******************************************** entry for after_op **********************************************/ after_op: entry (operator_num); /*[4.3-1]*/ if operator_num = 0 | operator_num >= 4096 then temp = 1; else temp = operator_num; do i = 0 to 9; /*[4.3-1]*/ /* if substr(index_reg_not_needed(temp),i,1)="0"b then do;*/ reg_status.r_priority (i) = 0; if reg_status.save_stack_count (i) ^= 0 then do; /* Must restore this register. */ call cobol_register_util$restore ((get_bit_code (i))); reg_status.r_lock (i) = 1; end; else reg_status.r_lock (i) = 0; /* ORN */ /* reg_status.contents_sw(i)=0; */ /*[4.3-1]*/ /* end;*/ end; do i = 1, 2, 7; /* 7/7/76 */ /*[4.3-1]*/ /* if substr(pointer_not_needed(temp),i,1)="0"b then do;*/ if ptr_status.save_stack_count (i) ^= 0 then do; call cobol_register_util$restore_pointer (substr (unspec (i), 33, 4)); ptr_status.contents_sw (i) = 0; ptr_status.p_priority (i) = 0; ptr_status.p_lock (i) = 1; end; else do; ptr_status.p_lock (i) = 0; end; /*[4.3-1]*/ /* end;*/ end; return; get_bit_code: proc (fbin_code) returns (bit (4)); dcl fbin_code fixed bin, bit_code bit (4); if fbin_code = 9 then bit_code = "0010"b; /* Q */ else if fbin_code = 8 then bit_code = "0001"b; /* A */ else bit_code = "1"b || substr (unspec (fbin_code), 34, 3); return (bit_code); end get_bit_code; /* INCLUDE FILES USED BY THIS PROCEDUURE */ dcl 1 ptr_status (0:9) based (cobol_$ptr_status_ptr) aligned, %include cobol_ptr_status; /***** Declaration for builtin function *****/ dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index) builtin; /***** End of declaration for builtin function *****/ dcl 1 reg_status (0:9) based (cobol_$reg_status_ptr) aligned, %include cobol_reg_status; %include cobol_; end cobol_reg_manager;  cobol_register.pl1 05/24/89 1042.8rew 05/24/89 0832.7 167247 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_register.pl1 Added Trace statements. END HISTORY COMMENTS */ /* Modified on 10/19/84 by FCH, [4.3-1], BUG563(phx18381), new cobol_addr_tokens.incl.pl1 */ /* Modified on 09/03/83 by FCH, [4.1...], trace added */ /* Modified on 2/24/76 to cover the pl1 bit string handling */ /* Last modified 1-21-76 by bc. */ /* format: style3 */ cobol_register: proc (reg_struc_ptr); /* The procedure is not a valid entry point. */ dcl reg_struc_ptr ptr; /* reg_struc_ptr is a pointer to the following structure (input) */ dcl 1 reg_struc based (reg_struc_ptr), 2 what_reg fixed bin, 2 reg_no bit (4) unaligned, 2 filler1 bit (32) unaligned, /* for bit string handling */ 2 lock fixed bin, 2 already_there fixed bin, 2 contains fixed bin, 2 pointer ptr, 2 literal bit (36); /* what_reg specifies the register to be obtained. (input) 0 - A or Q or any index register. 1 - A register. 2 - Q register. 3 - A and Q registers. 4 - A or Q register. 5 - any index register. 1n - index register n. reg_no is the register that is assigned. (output). 1 - A register. 2 - Q register. 3 - A and Q registers. 1n - index register n. lock can have the following values. (input). 0 - do not change the lock or unlock status of the register. 1 - lock this register. 2 - unlock all index registers and the A and Q registers. 3 - unlock all index registers and the A and Q registers and all pointer registers. already_there has the followoutg values. (output). 0 - the register must be loaded. 1 - the specified contents are already in the register and it does not need to loaded. contains specifies the form of the contents of the register. (input). 0 - the register will not contain a value that is meaningful for register optimatization. pointer and literal are not meaningful. 1 - the register will contain a data item. pointer must have a meaningful value. 2 - the register will contain the value specified in "literal". 3 - the register will contain a computed subscript, pointer must have a meaningful value. 4 - the register will contain a computed index, pointer must have a meaningful value. 5 - the register will contain a modified computed index, pointer must have a meaningful value. Note: The values 3, 4 and 5 are intended for the use by the addressibility handler and should not be of interest to the most generators. pointer is one of the following: (a) - A pointer to a type 9 token. In this case "contains" is 1 (data item). (b) - A pointer to a structure (to be defined) for index or subscript computations. In this case, "contains" is 3 (subscript), 4 (index) or 5 (modified index). literal is the literal value that will be in the register. */ /* DECLARATION OF EXTERNAL ENTRIES */ dcl ioa_$ioa_stream entry options (variable); dcl cobol_register_util$save ext entry (bit (4)); dcl cobol_register_util$restore ext entry (bit (4)); dcl cobol_register_util$save_pointer ext entry (bit (4)); dcl cobol_register_util$restore_pointer ext entry (bit (4)); dcl signal_ entry (char (*), ptr, ptr); dcl 1 error_message, 2 name char (32) init ("cobol_register"), 2 length fixed bin init (80), 2 message char (80); dcl (i, max) fixed bin; dcl temp_ptr ptr; dcl zero_word bit (36) based (temp_ptr); /*}*/ /*{*/ load: entry (reg_struc_ptr); /***..... dcl LOCAL_NAME char (5) int static init ("$LOAD");/**/ /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME||LOCAL_NAME);/**/ /* This entry may be used for the following function: (a) - Obtain a register ( A, Q or an index register) for the caller. (b) - If the register is locked by someone already, save its content and make it available to me. (c) - Make the contents of the register known to the utility. (d) - Inform the caller if the contents are already in the register. NOTE: (c) and (d) are not implemented yet. USAGE: declare cobol_register$load entry(ptr); The declaration of reg_struc is described in the main entry point. call cobol_register$load(reg_struc_ptr); NOTE: (1) The caller is assured that the register he want will be available to him whatever it is locked or not. (2) If the register is locked already, the content will be stored into some location and the address of that location will be saved on the top of register storage stack. (3) Some instruction may be emitted to save the register content. (4) Always remember to call the release entry to release the register when it is not needed anymore. */ /*}*/ dcl bit_reg_code bit (4); /**************************************************/ /* START OF EXECUTION */ /* ENTRY POINT: load */ /**************************************************/ reg_struc.already_there = 0; /* Unlock registers, if requested. */ if reg_struc.lock = 2 | reg_struc.lock = 3 then do; /* Unlock was requested. */ do i = 0 to 9; /* Unlock A, Q, index registers. */ if reg_status.save_stack_count (i) ^= 0 then do; /* Restore the register. */ call cobol_register_util$restore ((reg_bit_code (i))); reg_status.r_lock (i) = 1; end; /* Restore the register. */ else reg_status.r_lock (i) = 0; end; /* UNlock A, Q, and index registers. */ if reg_struc.lock = 3 then do; /* UNlock temporary pointer registers. */ if ptr_status.save_stack_count (1) ^= 0 then do; /* Restore PR1 */ call cobol_register_util$restore_pointer (substr (unspec (binary (1)), 33, 4)); ptr_status.p_lock (1) = 1; end; /* Restore PR1 */ else ptr_status.p_lock (1) = 0; if ptr_status.save_stack_count (2) ^= 0 then do; /* Restore PR2 */ call cobol_register_util$restore_pointer (substr (unspec (binary (2)), 33, 4)); ptr_status.p_lock (2) = 1; end; /* Restore PR2 */ else ptr_status.p_lock (2) = 0; if ptr_status.save_stack_count (7) ^= 0 then do; /* Restore PR 7 */ call cobol_register_util$restore_pointer (substr (unspec (binary (7)), 33, 4)); ptr_status.p_lock (7) = 1; end; /* Restore PR7 */ else ptr_status.p_lock (7) = 0; end; /* Unlock temporary pointer registers. */ end; /* UNlock was requested. */ if (reg_struc.what_reg = 0 | reg_struc.what_reg = 4 | reg_struc.what_reg = 5) then call pick_a_register (reg_struc.what_reg, reg_struc.lock, reg_struc.reg_no); else call get_specific_reg (reg_struc.what_reg, reg_struc.lock, reg_struc.reg_no); reg_struc.filler1 = (32)"0"b; /**************************************************/ /* RETURN POINT */ /* ENTRY: load */ /**************************************************/ go to crx; get_specific_reg: proc (reg_code, lock_code, return_bit_code); /* This internal procedure gets a specific register, locks it, if requested, and returns the four bit code that describes the register. */ /* DECLARATION OF THE PARAMETERS */ dcl reg_code fixed bin; dcl lock_code fixed bin; dcl return_bit_code bit (4); /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION reg_code A fixedd binary code that indicates the register to get. (input) This code is defined in the following table. reg_code | register to get ==================================== 1 | A 2 | Q 3 | A and Q |n | index register "n" ==================================== lock_code A code that indicates whether the register is to be locked after it is gotten. (input) This code is defined as follows: 0 - don't lock 1 - lock return_bit_code A bit code that identifies the register gotten. (output) This code is defined in the following table. code | register ============================== "0001"b | A "0010"b | Q "0011"b | A and Q "1nnn"b | index register "n" */ dcl work_reg_code fixed bin; /**************************************************/ /* START OF EXECUTION */ /* INTERNAL PROCEDURE get_specific_reg */ /**************************************************/ if reg_code = 1 then do; /* A register. */ work_reg_code = 8; return_bit_code = "0001"b; end; /* A register. */ else if reg_code = 2 then do; /* Q register. */ work_reg_code = 9; return_bit_code = "0010"b; end; /* Q register. */ else if reg_code > 9 then do; /* Index register. */ work_reg_code = reg_code - 10; return_bit_code = "1"b || substr (unspec (work_reg_code), 34, 3); end; /* Index register. */ else do; /* Must be A and Q */ return_bit_code = "0011"b; if reg_status.r_lock (8) ^= 0 then call cobol_register_util$save ("0001"b); reg_status.r_lock (8) = lock_code; return_bit_code = "0010"b; /* Q */ work_reg_code = 9; end; /* Must be A and Q */ if reg_status.r_lock (work_reg_code) ^= 0 then do; call cobol_register_util$save (return_bit_code); reg_status.r_lock (work_reg_code) = 1; end; else reg_status.r_lock (work_reg_code) = lock_code; if reg_code = 3 then return_bit_code = "0011"b; /* A and Q */ end get_specific_reg; pick_a_register: proc (reg_code, lock_code, return_bit_code); /* This procedure picks a register from a set of registers specified by the input parameter reg_code, locks it if specified, and returns a four bit code that defines the register gotten. */ /* DECLARATION OF THE PARAMETERS */ dcl reg_code fixed bin; dcl lock_code fixed bin; dcl return_bit_code bit (4); /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION reg_code A code that indicates the set of registers from which one is to be gotten. (inputt) This code is defined in the following table: code | register set =================================== 0 | any register (A,Q, or index) 4 | A or Q 5 | any index register ===================================== lock_code A code that indicates whether the register gotten is to be locked. (input) 0 - no lock 1 - lock the register return_bit_code A code that identifies the register gotten by this procedure. (output) return_bit_code | register gotten ========================================= "0001"b | A "0010"b | Q "1nnn"b | index register "n" */ /**************************************************/ /* START OF EXECUTION */ /* INTERNAL PROCEDURE pick_a_register */ /**************************************************/ dcl found_index fixed bin; dcl i fixed bin; dcl work_reg_code fixed bin int static init (4); if (reg_code = 0 | reg_code = 5) then do; /* Any register. */ /* Pick any index register. */ found_index = 0; do i = 0 to 7 while (found_index = 0); /* Scan for unlocked index register. */ if reg_status.r_lock (i) = 0 then found_index = i; end; /* Scan for unlocked index register. */ if found_index = 0 then do; /* All index registers are locked, pick one. */ work_reg_code = mod ((work_reg_code + 1), 7); return_bit_code = "1"b || substr (unspec (work_reg_code), 34, 3); end; /* All index registers are locked, pick one. */ else do; /* Found an unlocked index register. */ work_reg_code = found_index; return_bit_code = "1"b || substr (unspec (found_index), 34, 3); end; /* Found an unlocked index register. */ end; /* Any register. */ else do; /* A or Q */ if reg_status.r_lock (8) = 0 then do; /* A is not locked, use A. */ work_reg_code = 8; return_bit_code = "0001"b; end; /* A is not locked, use A. */ else if reg_status.r_lock (9) = 0 then do; /* Q is not locked, use Q */ work_reg_code = 9; return_bit_code = "0010"b; end; /* Q is not locked, use Q */ else do; /* A and Q both locked. */ /* PICK A !!! */ work_reg_code = 8; return_bit_code = "0001"b; end; /* A and Q both locked. */ end; /* A or Q */ if reg_status.r_lock (work_reg_code) ^= 0 then call cobol_register_util$save (return_bit_code); reg_status.r_lock (work_reg_code) = lock_code; end pick_a_register; reg_bit_code: proc (fixed_reg_code) returns (bit (4)); /* This internal procedure maps a fixed binary register code into a four bit code. */ dcl fixed_reg_code fixed bin; /* The fixed binary register code. */ /* This procedure maps a fixed binary register code into a four bit code. The following table defines the mapping. fixed_reg_code | meaning | mapped to bit code ======================================================== 0 - 7 |x0 - x7 | "1nnn"b 8 A | "0001"b 9 | Q | "0010"b */ dcl return_bit_code bit (4); if fixed_reg_code = 8 then return_bit_code = "0001"b; /* A */ else if fixed_reg_code = 9 then return_bit_code = "0010"b; /* Q */ else return_bit_code = "1"b || substr (unspec (fixed_reg_code), 34, 3); return (return_bit_code); end reg_bit_code; /*{*/ release: entry (reg_struc_ptr); /***..... dcl LOCAL_NAME2 char (8) int static init ("$RELEASE");/**/ /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME||LOCAL_NAME2);/**/ /* This entry is used for the following function: (a) - Makes the register management aware that the contents of the register (A, Q or index register) will be released. (b) - Restore the register from the top of the register saving stack if there is something saved before. Perform the register unlocking. (c) - Basically the caller is telling the utility: "I plan to release the register which I have asked to get it before. Please make it available to uture use again.". NOTE: (1) If the register stack is not empty, some instruction will be emitted to restore the register from the top of the stack. USAGE: declare cobol_register$release entry(ptr); The declaration of the register structure is the same as in the main entry point. However the meaning is a little bit different. what_reg not used here. reg_no is the reg_no to be released. (input). 1 - A register. 2 - Q register. 3 - A and Q registers. 1n - index register n. lock same meaning as described in main entry point. (input). already_there not used. contains 0 - the register will not contain a value that is meaningful for register optimatization. 1 - the register will be stored into a data item. "pointer" must have a meaningful value. pointer is a pointer to a type 9 token. literal not used. call cobol_register$release(reg_struc_ptr); */ /*}*/ /**************************************************/ /* START OF EXECUTION */ /* ENTRY POINT: release */ /**************************************************/ if reg_struc.reg_no = "0001"b then do; /* Unlock A */ if reg_status.save_stack_count (8) ^= 0 then do; /* Restore A */ call cobol_register_util$restore (reg_struc.reg_no); reg_status.r_lock (8) = 1; end; /* Restore A */ else reg_status.r_lock (8) = 0; end; /* Unlock A */ else if reg_struc.reg_no = "0010"b then do; /* Unlock Q */ if reg_status.save_stack_count (9) ^= 0 then do; /* Restore Q */ call cobol_register_util$restore (reg_struc.reg_no); reg_status.r_lock (9) = 1; end; /* Restore Q */ else reg_status.r_lock (9) = 0; end; /* Unlock Q */ else if reg_struc.reg_no = "0011"b then do; /* Unlock A and Q */ if reg_status.save_stack_count (8) ^= 0 then do; /* Restore A */ call cobol_register_util$restore ("0001"b); reg_status.r_lock (8) = 1; end; /* Restore A */ else reg_status.r_lock (8) = 0; if reg_status.save_stack_count (9) ^= 0 then do; /* Restore Q */ call cobol_register_util$restore ("0010"b); reg_status.r_lock (9) = 1; end; /* Restore Q */ else reg_status.r_lock (9) = 0; end; /* Unlock a and Q */ else do; /* Must be an index register. */ i = fixed (reg_struc.reg_no, 17, 0) - 8; if reg_status.save_stack_count (i) ^= 0 then do; /* Restore the index. */ call cobol_register_util$restore (reg_struc.reg_no); reg_status.r_lock (i) = 1; end; /* Restore the index. */ else reg_status.r_lock (i) = 0; end; /* Must be an index register. */ /**************************************************/ /* RETURN POINT */ /* ENTRY: release */ /**************************************************/ crx: /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(MY_NAME);/**/ return; priority: entry; call ioa_$ioa_stream ("error_output", "cobol_register$priority not yet implemented"); return; /***..... dcl cobol_gen_driver_$Tr_Beg entry(char(*));/**/ /***..... dcl cobol_gen_driver_$Tr_End entry(char(*));/**/ /***..... dcl Trace_Bit bit(1) static external;/**/ /***..... dcl Trace_Lev fixed bin static external;/**/ /***..... dcl Trace_Line char(36) static external;/**/ /***..... dcl ioa_ entry options(variable); /**/ /***..... dcl MY_NAME char (14) int static init ("COBOL_REGISTER");/**/ /* INCLUDE FILES USED BY THIS PROCEDURE */ /***** Declaration for builtin function *****/ dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index) builtin; /***** End of declaration for builtin function *****/ %include cobol_ext_; %include cobol_fixed_common; %include cobol_; dcl 1 ptr_status (0:7) based (cobol_$ptr_status_ptr) aligned, %include cobol_ptr_status; dcl 1 reg_status (0:9) based (cobol_$reg_status_ptr) aligned, %include cobol_reg_status; end cobol_register;  cobol_register_util.pl1 05/24/89 1042.8rew 05/24/89 0832.7 142857 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_register_util.pl1 Added Trace statements. END HISTORY COMMENTS */ /* Modified on 10/19/84 by FCH, [4.3-1], BUG563(phx18381), new cobol_addr_tokens.incl.pl1 */ /* Modified on 09/03/83 by FCH, [5.2...], trace added */ /* Modified on 01/14/77 by ORN to signal command_abort_ rather than cobol_compiler_error */ /* Modified since Version 2.0 */ /* format: style3 */ cobol_register_util: proc (bit_reg_code); /* This procedure generates code to save and restore the arithmetic registers, and pointer registers. There are four entry points: 1. save - generates code to save A,Q,A and Q, or index. 2. restore- generates code to restore A,Q,A and Q, or index 3. save_pointer - generates code to save a pointer register. 4. restore_pointer - generates code to restore a pointer register. /*}*/ /* DECLARATION OF THE PARAMETER */ dcl bit_reg_code bit (4); /* DESCRIPTION OF THE PARAMETER */ /* PARAMETER DESCRIPTION bit_reg_code A code that identifies the register to be saved or restored. The code is defined by the following tables: If this procedure is being called to save or restore A,Q, or index register: code | register ======================================= "0001"b | A "0010"b | Q "0011"b | A and Q "1nnn"b | index register nnn ========================================= If this procedure is being called to save or restore a pointer register the code values are: code | register ======================================== "0nnn"b | pointer register "nnn"b ========================================= */ /* DECLARATIONS OF EXTERNAL ENTRIES */ dcl signal_ ext entry (char (*), ptr, ptr); dcl cobol_emit ext entry (ptr, ptr, fixed bin); dcl cobol_alloc$stack ext entry (fixed bin, fixed bin, fixed bin); dcl cobol_addr ext entry (ptr, ptr, ptr); /* DECLARATION OF INTERNAL STATIC DATA */ dcl STO bit (7) int static init ("1111011"b); /* Leftmost 7 bits of STA,STQ,STAQ opcodes. */ dcl STXN bit (6) int static init ("111100"b); /* Leftmost 6 bits of STXN opcode. */ dcl LOAD bit (7) int static init ("0100111"b); /* Leftmost 7 bits of LDA,LDQ,LDAQ opcodes. */ dcl LDXN bit (6) int static init ("010010"b); /* Leftmost 6 bits of LDXN opcode. */ dcl SPRPN bit (6) int static init ("101100"b); /* Leftmost 6 bits of SPRPn */ dcl LPRPN bit (6) int static init ("111110"b); /* Leftmost 6 bits of LPRPn */ /***..... dcl MY_NAME char (19) int static init ("COBOL_REGISTER_UTIL"); dcl SAVE_NAME char (5) int static init ("$SAVE"); dcl RESTORE_NAME char (8) int static init ("$RESTORE"); dcl SAVE_POINTER_NAME char (13) int static init ("$SAVE_POINTER"); dcl RESTORE_POINTER_NAME char (16) int static init ("$RESTORE_POINTER"); /**/ dcl 1 error_message int static, 2 name char (32) init ("cobol_register_util"), 2 length fixed bin init (80), 2 message char (80); /* DECLARATIONS OF INTERNAL AUTOMATIC VARIABLES */ dcl work_reg_code fixed bin; dcl work_opcode bit (9); dcl fixed_reg_code fixed bin; dcl temp_chars fixed bin; dcl temp_offset fixed bin; dcl binary_reg_code fixed bin; dcl 1 input_buff aligned, 2 buffer (1:10) fixed bin; /*************************************/ save: entry (bit_reg_code); /* This entry point generates code to save a register (A,Q,A-Q, or index) into temporary storage, and saves the address and relocation information in the register save_stack for the register being saved. */ /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME||SAVE_NAME);/**/ /* Map the bit register code into a fixed binary register code. */ fixed_reg_code = get_reg_code (bit_reg_code); if reg_status.save_stack_count (fixed_reg_code) = reg_status.save_stack_max (fixed_reg_code) then do; /* SAve stack is full, signal compile time error. */ error_message.message = "save_stack overflow ($save entry)"; stack_overflow: call signal_ ("command_abort_", null (), addr (error_message)); return; end; /* Save stack is full, signal compile time error. */ if fixed_reg_code = 10 then do; /* Saving A and Q. */ work_reg_code = 8; /* Save address of the temporary into which A-Q is stored into the save stack for the A register. */ temp_chars = 8; end; /* Saving A and Q */ else do; work_reg_code = fixed_reg_code; temp_chars = 4; end; call get_temp_storage (temp_chars, temp_offset); call establish_address (work_reg_code, temp_offset); /* Insert the proper opcode into the save_stack entry. */ if fixed_reg_code > 7 then work_opcode = STO || substr (bit_reg_code, 3, 2); /* Store A,Q,A-Q */ else work_opcode = STXN || substr (bit_reg_code, 2, 3); /* Store index n */ temp_stack_count = reg_status.save_stack_count (fixed_reg_code); substr (reg_status.save_stack (fixed_reg_code, temp_stack_count), 19, 9) = work_opcode; /* Emit the store instruction. */ call cobol_emit (inst_ptr, reloc_ptr, 1); go to exit_save; /*************************************/ restore: entry (bit_reg_code); /* This entry point generates code to restore a register from a saved value in the stack. */ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME||RESTORE_NAME);/**/ /* Map the bit code into a fixed binary code. */ work_reg_code = get_reg_code (bit_reg_code); if work_reg_code = 10 /* A and Q */ then fixed_reg_code = 8; /* Address of the temp in which A and Q is stored is saved in the A register save_stack. */ else fixed_reg_code = work_reg_code; if reg_status.save_stack_count (fixed_reg_code) = 0 then do; /* No register is saved..none can be restored. */ error_message.message = "save stack underflow ($restore entry)"; stack_underflow: call signal_ ("command_abort_", null (), addr (error_message)); return; end; /* No register is saved..non can be restored. */ temp_stack_count = reg_status.save_stack_count (fixed_reg_code); inst_ptr = addr (reg_status.save_stack (fixed_reg_code, temp_stack_count)); reloc_ptr = addr (reg_status.reloc_stack (fixed_reg_code, temp_stack_count)); if work_reg_code > 7 then work_opcode = LOAD || substr (bit_reg_code, 3, 2); /* Load A,Q or A-Q */ else work_opcode = LDXN || substr (bit_reg_code, 2, 3); /* Load index n */ temp_stack_count = reg_status.save_stack_count (fixed_reg_code); substr (reg_status.save_stack (fixed_reg_code, temp_stack_count), 19, 9) = work_opcode; /* Decrement the top of stack pointer for the save_stack. */ reg_status.save_stack_count (fixed_reg_code) = reg_status.save_stack_count (fixed_reg_code) - 1; call cobol_emit (inst_ptr, reloc_ptr, 1); exit_save: exit_save_pointer: exit_restore_pointer: /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(MY_NAME);/**/ return; /*************************************/ save_pointer: entry (bit_reg_code); /* This entry point generates code to save a pointer register into temporary storage, and saves the address at which the pointer register is stored, and relocation information in the pointer register save statck for the pointer register being saved. */ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME||SAVE_POINTER_NAME);/**/ start_save_pointer: /* Convert the bit pointer register code to fixed binary. */ fixed_reg_code = fixed (bit_reg_code, 17); temp_stack_count = ptr_status.save_stack_max (fixed_reg_code); if ptr_status.save_stack_count (fixed_reg_code) = temp_stack_count then do; /* Pointer save stack for this pointer register is full. */ error_message.message = "save_stack overflow ($save_pointer entry)"; pointer_stack_overflow: call signal_ ("command_abort_", null (), addr (error_message)); return; end; /* Pointer save stack for this pointer register is full. */ call get_temp_storage (4 /* number of bytes */, temp_offset); call establish_address (fixed_reg_code + 10, temp_offset); /* Insert the opcode into the save stack entry. */ temp_stack_count = ptr_status.save_stack_count (fixed_reg_code); substr (ptr_status.save_stack (fixed_reg_code, temp_stack_count), 19, 9) = SPRPN || substr (bit_reg_code, 2, 3); /* Emit the instruction to store the pointer register into the temporary. */ call cobol_emit (inst_ptr, reloc_ptr, 1); go to exit_save_pointer; /*************************************/ restore_pointer: entry (bit_reg_code); /* This entry point generates code to restore a pointer register from a saved value in a temporary (in the stack). */ /***..... dcl RESTORE_POINTER char (15) int static init ("RESTORE_POINTER");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME||RESTORE_POINTER);/**/ start_restore_pointer: fixed_reg_code = fixed (bit_reg_code, 17); /* Check for stack underflow. */ if ptr_status.save_stack_count (fixed_reg_code) = 0 then do; /* No pointer is saved...none can be restored. */ error_message.message = "save_stack underflow ($save_pointer entry)"; pointer_stack_underflow: call signal_ ("command_abort_", null (), addr (error_message)); return; end; /* No pointer is saved...none can be restored. */ temp_stack_count = ptr_status.save_stack_count (fixed_reg_code); inst_ptr = addr (ptr_status.save_stack (fixed_reg_code, temp_stack_count)); temp_stack_count = ptr_status.save_stack_count (fixed_reg_code); reloc_ptr = addr (ptr_status.reloc_stack (fixed_reg_code, temp_stack_count)); inst_struc_basic.fill1_op = LPRPN || substr (bit_reg_code, 2, 3); /* Emit the instruction to restore the pointer register from the saved value in temporary storage. */ call cobol_emit (inst_ptr, reloc_ptr, 1); /* Decrement the top of stack pointer (counter) for the save stack. */ ptr_status.save_stack_count (fixed_reg_code) = ptr_status.save_stack_count (fixed_reg_code) - 1; go to exit_restore_pointer; get_reg_code: proc (reg_bit_code) returns (fixed bin); /* This internal procedure maps a four bit register code into a fixed binary register code. */ dcl reg_bit_code bit (4); dcl binary_code fixed bin; if reg_bit_code = "0001"b then binary_reg_code = 8; /* A */ else if reg_bit_code = "0010"b then binary_reg_code = 9; /* Q */ else if reg_bit_code = "0011"b then binary_reg_code = 10; /* A and Q */ else binary_reg_code = fixed (reg_bit_code, 17, 0) - 8; /* Index register. */ return (binary_reg_code); end get_reg_code; get_temp_storage: proc (byte_length, char_offset); /* This internal procedure allocates space on the stack for a temporary in which a register is to be stored. */ /* DECLARATION OF THE PARAMETERS */ dcl byte_length fixed bin; dcl char_offset fixed bin; /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION byte_length The number of bytes to allocate in the stack. This length will be 4 if the register being stored is A,Q,any index register or any pointer register, and 8 if the register being stored is the A-Q. (input) char_offset The character offset of the leftmost character of the stack temporary. (output) */ /* Allocate space, aligned on a double word boundary. */ call cobol_alloc$stack (byte_length, 2, char_offset); /* Convert the returned word offset to a character offset. */ char_offset = char_offset * 4; end get_temp_storage; establish_address: proc (binary_reg_code, temp_char_offset); /* This internal procedure establishes the address of the temporary in the stack to receive a stored register. */ /* DECLARATION OF THE PARAMETERS */ dcl binary_reg_code fixed bin; dcl temp_char_offset fixed bin; /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION binary_reg_code A code that identifies the register being stored, and that indicates the subscript of the register status structure entry in which the address is to be stored. This code specifies either a register (A,Q, or index) or a pointer register, as shown in the folllowing table: code | register identified ========================================= 0-7 | index register 0-7 8 | A 9 | Q 10-17 | pointer register 0-7 ========================================== temp_char_offset The character offset of the leftmost byte of the word in the stack into whichh the registe is to be stored. (input) */ if binary_reg_code < 10 then do; /* Storing a register (A,Q,A-Q, or index) */ reg_status.save_stack_count (binary_reg_code) = reg_status.save_stack_count (binary_reg_code) + 1; temp_stack_count = reg_status.save_stack_count (binary_reg_code); inst_ptr = addr (reg_status.save_stack (binary_reg_code, temp_stack_count)); temp_stack_count = reg_status.save_stack_count (binary_reg_code); reloc_ptr = addr (reg_status.reloc_stack (binary_reg_code, temp_stack_count)); end; /* Storing a register (A,Q,A-Q, or index) */ else do; /* Storing a pointer register. */ temp_stack_count = ptr_status.save_stack_count (binary_reg_code - 10); ptr_status.save_stack_count (binary_reg_code - 10) = temp_stack_count + 1; temp_stack_count = ptr_status.save_stack_count (binary_reg_code - 10); inst_ptr = addr (ptr_status.save_stack (binary_reg_code - 10, temp_stack_count)); temp_stack_count = ptr_status.save_stack_count (binary_reg_code - 10); reloc_ptr = addr (ptr_status.reloc_stack (binary_reg_code - 10, temp_stack_count)); end; /* Storing a pointer register. */ /* Set up to call the addressability utility to establish the address of the stack temporary. Note that the address and reloc information are stored into the proper save_stack for the register being stored. */ input_ptr = addr (input_buff); input_struc_basic.type = 1; input_struc_basic.operand_no = 0; input_struc_basic.lock = 0; input_struc_basic.segno = 1000; /* Stack */ input_struc_basic.char_offset = temp_offset; call cobol_addr (input_ptr, inst_ptr, reloc_ptr); end establish_address; /***..... dcl cobol_gen_driver_$Tr_Beg entry(char(*));/**/ /***..... dcl cobol_gen_driver_$Tr_End entry(char(*));/**/ /***..... dcl Trace_Bit bit(1) static external;/**/ /***..... dcl Trace_Lev fixed bin static external;/**/ /***..... dcl Trace_Line char(36) static external;/**/ /***..... dcl ioa_ entry options(variable); /**/ dcl temp_stack_count fixed bin; /* INCLUDE FILES USED BY THIS PROCEDURE */ /***** Declaration for builtin function *****/ dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index) builtin; /***** End of declaration for builtin function *****/ %include cobol_addr_tokens; dcl 1 reg_status (0:9) based (cobol_$reg_status_ptr) aligned, %include cobol_reg_status; dcl 1 ptr_status (0:9) based (cobol_$ptr_status_ptr) aligned, %include cobol_ptr_status; %include cobol_; end cobol_register_util;  cobol_release_gen.pl1 05/24/89 1042.8rew 05/24/89 0832.7 82305 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_release_gen.pl1 Added Trace statements. 2) change(89-04-23,Zimmerman), approve(89-04-23,MCR8072), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8072 cobol_release_gen.pl1 Correct inverted sorts for some binary data types. END HISTORY COMMENTS */ /* Modified on 10/23/84 by FCH, [5.3-2], BUG564(phx17268), SORT statement produces ipc fault at run time */ /* Modified on 10/19/84 by FCH, [5.3-1], BUG563(phx18381), new cobol_addr_tokens.inal.pl1 */ /* Modified on 5/16/76 by Bob Chang to implement the retry after error. */ /* Modified on 05/05/76 by Bob Chang to use call_op. */ /* Modified on 05/03/76 by Bob Chang to interface with cobol_rts_. */ /* Modified on 04/07/76 by Bob Chang to interface with multics sort package. */ /* Modified on 3/19/76 by Bob Chang to interface with the cobol_operators_. */ /* format: style3 */ cobol_release_gen: proc (in_token_ptr); /* The procedure cobol_release_gen generates the code necessary to implement the COBOL RELEASE statement. The format of the RELEASE statement is as follows: R_E_L_E_A_S_E_ record-name [F_R_O_M_ identifier ] The execution of a RELEASE statement causes the record named by record-name to be released to the initial phase of a sort operation. If the FROM phrase is used, the contents of the identifier data area are moved to the record-name, then the contents of record-name aare released to the sort file. Moving takes place according to the rules specified for the MOVE statement without the CORRESPONDING phrase. The information in the record area is no longer available, but the information in the data area associated with identifier is available. After the execution of the RELEASE statement, the logical record is no longer available in the record area unless the associated sort file is named in a SAME RECORD AREA clause. The logical record is also available to the program as a record of other files referenced in the same SAME RECORD AREA clause as the associated sort file, as well as to the file associated with record-name. */ /* Code and relocation sequences. */ dcl 1 mpout static, 2 n fixed bin init (4), 2 pt1 ptr, 2 pt2 ptr, 2 pt3 ptr, 2 pt4 ptr; dcl 1 alpha_type9 static, 2 header (4) fixed bin init (112, 0, 0, 9), 2 repl_ptr (2) ptr init ((2) null ()), 2 fill1 bit (108) init (""b), 2 file_key_info, 3 fb1 (3) fixed bin init (0, 0, 0), 3 size fixed bin init (0), 3 fb2 (2) fixed bin init (0, 0), 3 flags1 bit (36) init ("000000100100000000010000000100000000"b), 3 flags2 bit (36) init (""b), 3 seg fixed bin init (0), 3 off fixed bin, 2 fill2 (7) fixed bin init (0, 0, 0, 0, 0, 0, 0); dcl 1 num_type9 static, 2 header (4) fixed bin init (112, 0, 0, 9), 2 repl_ptr (2) ptr init ((2) null ()), 2 fill1 bit (108) init (""b), 2 file_key_info, 3 fb1 (3) fixed bin init (0, 0, 0), 3 size fixed bin init (0), 3 fb2 (2) fixed bin init (0, 0), 3 flags1 bit (36) init ("000000100100000001000000000100000000"b), 3 flags2 bit (36) init (""b), 3 seg fixed bin init (0), 3 off fixed bin, 2 fill2 (7) fixed bin init (0, 0, 0, 0, 0, 0, 0); dcl 1 mlr_struct static, 2 type fixed bin init (4), 2 operand_no fixed bin init (2), 2 lock fixed bin init (0), 2 operand1, 3 token_ptr ptr init (null ()), 3 sr fixed bin init (0), 3 icmod fixed bin init (0), 3 size_sw fixed bin init (0), 2 operand2, 3 token_ptr ptr, 3 sr fixed bin init (1), 3 icmod fixed bin, 3 size_sw fixed bin init (0); dcl mlr_reg_to_reg bit (36) init ("000100000001000000001000000101000000"b); dcl instr (3) bit (36) unaligned static init ("000000000000000000000000000000000000"b, "000000000000000000000000000000000000"b, "000000000000000000000000000000000000"b); dcl rel_instr (6) bit (5) aligned static init ("00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b); dcl inst_seq (4) bit (18) unaligned static init ("000000000000000000"b, "011101011100010000"b, /* epp3 data_name */ "000000000000000000"b, "010011110000000111"b); /* ldq length,dl */ /* Automatic data */ dcl retry_tag fixed bin, dn_ptr ptr; /* pointer to type 9 token */ dcl buff1 (10) ptr, buff2 (10) ptr, buff3 (10) ptr; /* Procedures Called */ dcl cobol_call_op entry (fixed bin, fixed bin), cobol_define_tag entry (fixed bin), cobol_reg_manager$after_op entry (fixed bin), cobol_addr entry (ptr, ptr, ptr), cobol_emit entry (ptr, ptr, fixed bin); start: /* reserve space for input structure. */ input_ptr = addr (buff1); inst_ptr = addr (buff2); reloc_ptr = addr (buff3); retry_tag = cobol_$next_tag; call cobol_define_tag (retry_tag); cobol_$next_tag = cobol_$next_tag + 1; if in_token_ptr ^= null () then do; /* Extract the data_name item from second token. */ if in_token.n = 4 then do; mlr_struct.operand1.token_ptr = in_token.token_ptr (3); mlr_struct.operand2.token_ptr = in_token.token_ptr (2); instr (1) = mlr_reg_to_reg; instr (2) = "0"b; instr (3) = "0"b; /*[5.3-2]*/ dn_ptr = in_token.token_ptr (2); /*[5.3-2]*/ call elem_to_non_elem; /*[5.3-2]*/ dn_ptr = in_token.token_ptr (3); /*[5.3-2]*/ call elem_to_non_elem; call cobol_addr (addr (mlr_struct), addr (instr (1)), null ()); substr (instr (1), 1, 9) = "000100000"b; call cobol_emit (addr (instr (1)), null (), 3); end; end; if in_token_ptr = null () then do; call cobol_call_op (22, retry_tag); call cobol_reg_manager$after_op (22); end; else do; /* Set up link_off and rel_stack_off for inseq to call sort_$release. */ substr (inst_seq (3), 4, 15) = substr (unspec (in_token.token_ptr (2) -> data_name.item_length), 22, 15); input_struc.operand_no = 1; input_struc.type = 2; input_struc.token_ptr (1) = in_token.token_ptr (2); input_struc.lock = 0; call cobol_addr (input_ptr, addr (inst_seq (1)), reloc_ptr); call cobol_emit (addr (inst_seq), null (), 2); call cobol_call_op (11, retry_tag); call cobol_reg_manager$after_op (11); end; /* Reset the registers. */ return; elem_to_non_elem: proc; /* elem token to non-elem token */ /*[5.3-2]*/ if data_name.non_elementary then return; /* non-elementary token */ /*[5.3-2]*/ /*[5.3-2]*/ data_name.non_elementary = "1"b; /*[5.3-2]*/ data_name.elementary = "0"b; /*[5.3-2]*/ /*[5.3-2]*/ if data_name.display then return; /* display data */ /*[5.3-2]*/ /*[5.3-2]*/ data_name.display = "1"b; /*[5.3-2]*/ data_name.comp = "0"b; /*[5.3-2]*/ data_name.places_right = 0; /*[5.3-2]*/ /*[5.3-2]*/ if data_name.ascii_packed_dec_h | data_name.ascii_packed_dec /*[5.3-2]*/ then do; data_name.ascii_packed_dec_h = "0"b; /* comp or comp-8 */ /*[5.3-2]*/ data_name.ascii_packed_dec = "0"b; /*[5.3-2]*/ end; /*[5.3-2]*/ else /*[5.3-2]*/ if data_name.bin_18 /* half word binary */ /*[5.3-2]*/ then do; data_name.bin_18 = "0"b; /*[5.3-2]*/ /*[5.3-2]*/ if data_name.sync /* sychronized */ /*[5.3-2]*/ then data_name.item_length = 4; /*[5.3-2]*/ else data_name.item_length = 2; /*[5.3-2]*/ /*[5.3-2]*/ data_name.sync = "0"b; /*[5.3-2]*/ end; /*[5.3-2]*/ else /*[5.3-2]*/ if data_name.bin_36 /* full word binary */ /*[5.3-2]*/ then do; data_name.item_length = 4; /*[5.3-2]*/ data_name.bin_36 = "0"b; /*[5.3-2]*/ end; /*[5.3-2]*/ else /*[5.3-2]*/ if data_name.usage_index /* indexed data item */ /*[5.3-2]*/ then do; data_name.item_length = 6; /*[5.3-2]*/ data_name.usage_index = "0"b; /*[5.3-2]*/ end; /*[5.3-2]*/ /*[5.3-2]*/ data_name.places_left = data_name.item_length; end; /***** Declaration for builtin function *****/ dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index) builtin; /***** End of declaration for builtin function *****/ %include cobol_in_token; %include cobol_addr_tokens; %include cobol_; %include cobol_type1; %include cobol_type9; %include cobol_type19; end cobol_release_gen;  cobol_reloc.pl1 05/24/89 1042.8rew 05/24/89 0832.7 93501 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_reloc.pl1 Added Trace statements. END HISTORY COMMENTS */ /* Modified on 08/21/83 by FCH, [5.2 ...], trace added */ /* Modified on 01/14/77 by ORN to signal command_abort_ rather than cobol_compiler_error */ /* Modified since Version 2.0 */ /*{*/ /* format: style3 */ cobol_reloc: proc (reloc_ptr, count, code); dcl reloc_ptr ptr; /* pts to array of count bit(5)'s */ dcl count fixed bin; /* number of half-words */ dcl code fixed bin; /* internal segment code */ /* This routine is called to append information to one of the relocation blocks associated with either the text, linkage, definition, or symbol section. The argument code is the value of the internal segment number of one of the above sections (i.e. 3001, 3002, 3003, or 3004 respectively) or merely the unit position digit (i.e. 1, 2, 3, or 4). The relocation block for each of the four sections are declared identically as follows: */ %include cobol_relinfo; /* If reloc_ptr is null then it is assumed that count half-words of absolute relocation are to be added to the block. Otherwise, reloc_ptr points to the following array: dcl reloc (count) bit(5) aligned based(reloc_ptr); Each bit(5) field contains the relocation code for a half-word (with "00000"b indicating absolute relocation and "11110"b invalid). Compaction of absolute relocatable half-words is handled automatically by cobol_reloc. The relinfo.n_bits field in each block is always kept up to date. */ /*}*/ /*************************************/ dcl creloc_ptr ptr; dcl ccount fixed bin; dcl reloc (ccount) bit (5) aligned based (creloc_ptr); /* the real one */ dcl 1 seg (4) static, 2 pt ptr, 2 maxoff fixed bin, 2 abscnt fixed bin; dcl bits bit (2359296) based; dcl bytes char (262144) based; dcl (i, j, n) fixed bin; dcl tcnt fixed bin; dcl textbits fixed bin; dcl null builtin; dcl substr builtin; dcl addr builtin; dcl ioa_$rsnnl entry options (variable); dcl signal_ entry (char (*), ptr, ptr); dcl bname (4) char (10) init ("Text", "Definition", "Link", "Symbol"); /*************************************/ start: start_reloc: creloc_ptr = reloc_ptr; ccount = count; if code > 3000 then n = code - 3000; else n = code; if n = 2 then n = 3; else if n = 3 then n = 2; join: /* cobol_emit joins code here */ if cobol_$reloc_sym_base_ptr -> relinfo.decl_vers ^= 2 then do; /* blocks truncated to zeros by cobol driver */ seg.pt (1) = cobol_$reloc_text_base_ptr; seg.maxoff (1) = cobol_$reloc_text_max; seg.pt (2) = cobol_$reloc_def_base_ptr; seg.maxoff (2) = cobol_$reloc_def_max; seg.pt (3) = cobol_$reloc_link_base_ptr; seg.maxoff (3) = cobol_$reloc_link_max; seg.pt (4) = cobol_$reloc_sym_base_ptr; seg.maxoff (4) = cobol_$reloc_sym_max; do i = 1 to 4; seg.abscnt (i) = 0; seg.pt (i) -> relinfo.n_bits = 0; seg.pt (i) -> relinfo.decl_vers = 2; end; end; relptr = seg.pt (n); if creloc_ptr = null then do; /* all absolute */ if seg.abscnt (n) < 15 then call start_abs (ccount); /* no ongoing compaction */ else call cont_abs (ccount); /* increase compaction ccount */ end; else do i = 1 to ccount; /* creloc_ptr is non-null */ if reloc (i) ^= "00000"b then do; /* relocation other than absolute */ if n_bits + 5 > seg.maxoff (n) then go to overflow_error; substr (relbits, n_bits + 1, 5) = reloc (i); n_bits = n_bits + 5; seg.abscnt (n) = 0; end; else do; do j = i + 1 to ccount while (reloc (j) = "00000"b); end; if seg.abscnt (n) < 15 then call start_abs (j - i); else call cont_abs (j - i); i = j - 1; end; end; return; /*************************************/ start_abs: proc (pnum); dcl pnum fixed bin parameter; tcnt = pnum + seg.abscnt (n); if tcnt < 15 then call add_abs (pnum); /* no sense compacting */ else do; n_bits = n_bits - seg.abscnt (n); if tcnt > 1023 then call fill_abs; /* 1023 is max for one compaction record */ if tcnt < 15 then call add_abs (tcnt); else do; if n_bits + 15 > seg.maxoff (n) then go to overflow_error; substr (relbits, n_bits + 1, 5) = "11110"b; /* compaction code */ substr (relbits, n_bits + 6, 10) = substr (unspec (tcnt), 27, 10); seg.abscnt (n) = tcnt; n_bits = n_bits + 15; end; end; return; end start_abs; cont_abs: proc (pnum); dcl pnum fixed bin parameter; tcnt = seg.abscnt (n) + pnum; if tcnt > 1023 then do; n_bits = n_bits - 15; call fill_abs; if tcnt < 15 then do; call add_abs (tcnt); return; end; if n_bits + 15 > seg.maxoff (n) then go to overflow_error; substr (relbits, n_bits + 1, 5) = "11110"b; n_bits = n_bits + 15; end; substr (relbits, n_bits - 9, 10) = substr (unspec (tcnt), 27, 10); seg.abscnt (n) = tcnt; return; end cont_abs; add_abs: proc (pnum); dcl pnum fixed bin parameter; if pnum + n_bits > seg.maxoff (n) then go to overflow_error; substr (relbits, n_bits + 1, pnum) = "0"b; n_bits = n_bits + pnum; seg.abscnt (n) = seg.abscnt (n) + pnum; return; end add_abs; fill_abs: proc; do while (tcnt > 1023); if n_bits + 15 > seg.maxoff (n) then go to overflow_error; substr (relbits, n_bits + 1, 15) = "111101111111111"b; tcnt = tcnt - 1023; seg.abscnt (n) = 0; n_bits = n_bits + 15; end; return; end fill_abs; /*************************************/ /*{*/ constants: entry (con_len, seg_ptr); /* This is a special entry for use by cobol_paste in order to create the relocation block for the constant portion of the text section and insert it in front of the text relocation block. */ dcl con_len fixed bin; /* number of words in constant section (input) */ dcl seg_ptr ptr; /* set to addr of seg array (output) */ /*}*/ start_constants: relptr = seg.pt (1); n = 1; textbits = n_bits; n_bits = 0; seg.abscnt (1) = 0; substr (cobol_$reloc_work_base_ptr -> bits, 1, textbits) = substr (seg.pt (1) -> bits, 73, textbits); call start_abs (con_len * 2); substr (seg.pt (1) -> bits, 73 + n_bits, textbits) = substr (cobol_$reloc_work_base_ptr -> bits, 1, textbits); n_bits = n_bits + textbits; seg_ptr = addr (seg); return; /*************************************/ /*{*/ cobol_emit: entry (wd_ptr, text_reloc_ptr, numb_wds); /* This procedure emits one or more words of information (plus relocation code) into the executable portion of the text section. */ dcl wd_ptr ptr; dcl text_reloc_ptr ptr; dcl numb_wds fixed bin; /* dcl words (numb_wds) bit(36) based(wd_ptr); */ /* dcl text_reloc (2*numb_wds) bit(5) aligned based(text_reloc_ptr); */ /* wd_ptr is a pointer to an array of words (input). text_reloc_ptr is a pointer to an array of relocation codes "text_reloc" (input). If this pointer is null, absolute relocation is assumed for the next numb_wds words. numb_wds is the number of words to be emmitted (input). */ /*}*/ start_emit: if cobol_$text_wd_off + cobol_$con_wd_off + numb_wds > 131072 then go to emit_error; i = numb_wds * 4; /***..... if Trace_Bit then call T1;/**/ substr (addrel (cobol_$text_base_ptr, cobol_$text_wd_off) -> bytes, 1, i) = substr (wd_ptr -> bytes, 1, i); cobol_$text_wd_off = cobol_$text_wd_off + numb_wds; creloc_ptr = text_reloc_ptr; /* set common ptr */ ccount = 2 * numb_wds; /* set common count */ n = 1; /* text relocation block */ go to join; /***..... dcl Trace_Bit bit(1) static external;/**/ /***..... dcl Trace_Lev fixed bin static external;/**/ /***..... dcl Trace_Line char(36) static external;/**/ /***..... dcl cobol_display_text$trace entry(ptr,fixed bin);/**/ /***..... dcl ioa_ entry options(variable);/**/ /***..... T1: proc;/**/ /***..... dcl (wd,wdc) fixed bin;/**/ /***..... dcl code(64) bit(36) based(wd_ptr);/**/ /***..... wdc=divide(i,4,31,0);/**/ /***..... call cobol_display_text$trace(addr(code(1)),wdc);/**/ /***..... end;/**/ /*************************************/ emit_error: error_info.name = "cobol_emit"; call ioa_$rsnnl ("Object instructions exceed 131072 words", message, message_len); go to error; overflow_error: error_info.name = "cobol_reloc"; call ioa_$rsnnl ("Overflow in ^a relocation block at ^d bits", message, message_len, bname (n), seg.maxoff (n)); error: call signal_ ("command_abort_", null, addr (error_info)); %include cobol_error_info; %include cobol_; /*************************************/ /*{*/ /* display: entry; /* /* This is an entry to be used for debugging purposes. It is called from command level and continues to prompt the user for the internal segment number of the relocation block he is interested in. It informs him of the current number of bits in that block and then prompts for a starting offset from which it will display the rest of the block in 5-bit units. */ /*}*/ /* /*dcl read_list_$prompt entry options(variable); /*dcl ioa_ entry options(variable); /*dcl ioa_$nnl entry options(variable); /*dcl write_list_ entry options(variable); /* /* call read_list_$prompt("Enter segment number: ",n); /* call ioa_("relinfo.n_bits for ^a relocation block is ^d",bname(n),seg.pt(n)->n_bits); /* call read_list_$prompt("Enter starting offset: ",j); /* do i = j to seg.pt(n)->n_bits by 5; /* call ioa_$nnl("^3d ",i); /* call write_list_(substr(seg.pt(n)->relinfo.relbits,i+1,5)); /* end; /**/ end cobol_reloc;  cobol_reset_r.pl1 05/24/89 1042.8rew 05/24/89 0832.6 60939 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_reset_r.pl1 Added Trace statements. END HISTORY COMMENTS */ /* Modified on 09/23/83 by FCH, [5.2...], trace added */ /* Modified on 01/14/77 by ORN to signal command_abort_ rather than cobol_compiler_error */ /* Modified since Version 2.0 */ /* format: style3 */ cobol_reset_r: proc; /* DECLARATION OF EXTERNAL ENTRIES */ dcl cobol_register_util$restore_pointer ext entry (bit (4)); dcl cobol_register_util$restore ext entry (bit (4)); dcl signal_ entry (char (*), ptr, ptr); dcl 1 error_message static, 2 name char (32) init ("cobol_reset_r"), 2 length fixed bin init (24), 2 message char (24); dcl reset_r_instr (4) bit (36) static init ("110000000000011000011101000001010000"b, /* epp0 pr6|30,* */ "110000000000100100011111000001010000"b, /* epp4 pr6|44,* */ "110000000001101110011101011101010000"b, /* epp3 pr6|156,* */ "110000000001110000011111001101010000"b); /* epp5 pr6|160,* */ dcl cobol_emit entry (ptr, ptr, fixed bin); dcl (i, j) fixed bin; dcl k fixed bin; dcl op_flag fixed bin static init (1); dcl ptr_val (1:4) fixed bin int static init (0, 4, 3, 5); dcl ptr_no bit (3); /*************************************/ pointer_register: entry (ptr_no); start_pointer_register: /***..... dcl LOCAL_NAME char (17) int static init ("$POINTER_REGISTER");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME||LOCAL_NAME);/**/ i = 0; if ptr_no = "000"b then i = 1; else if ptr_no = "011"b then i = 3; else if ptr_no = "100"b then i = 2; else if ptr_no = "101"b then i = 4; if i = 0 then go to error_exit; if ptr_status.save_stack_count (ptr_val (i)) ^= 0 then do; /* Must restore this pointer register. */ call cobol_register_util$restore_pointer ("0"b || ptr_no); ptr_status.contents_sw (i) = 0; ptr_status.p_lock (i) = 1; end; /* Must restore this pointer register. */ else call cobol_emit (addr (reset_r_instr (i)), null (), 1); go to exit_pointer_register; /*************************************/ after_call: entry; start_after_call: /***..... dcl LOCAL_NAME4 char (11) int static init ("$AFTER_CALL");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME||LOCAL_NAME4);/**/ i = 2; j = 4; emit_: do k = i to j; if ptr_status.save_stack_count (ptr_val (k)) > 0 then do; /* Register must be restored. */ ptr_status.save_stack_count (ptr_val (k)) = ptr_status.save_stack_count (ptr_val (k)) - 1; ptr_status.contents_sw (ptr_val (k)) = 0; ptr_status.p_lock (ptr_val (k)) = 1; ptr_status.p_priority (ptr_val (k)) = 0; end; /* Register must be restored. */ end; reset: ptr_status.contents_sw (1) = 0; ptr_status.p_priority (1) = 0; if ptr_status.save_stack_count (1) ^= 0 then do; call cobol_register_util$restore_pointer ("0001"b); ptr_status.p_lock (1) = 1; end; else ptr_status.p_lock (1) = 0; ptr_status.contents_sw (2) = 0; ptr_status.p_priority (2) = 0; if ptr_status.save_stack_count (2) ^= 0 then do; call cobol_register_util$restore_pointer ("0010"b); ptr_status.p_lock (2) = 1; end; else ptr_status.p_lock (2) = 0; ptr_status.contents_sw (7) = 0; ptr_status.p_priority (7) = 0; if ptr_status.save_stack_count (7) ^= 0 then do; call cobol_register_util$restore_pointer ("0111"b); ptr_status.p_lock (7) = 1; end; else ptr_status.p_lock (7) = 0; do i = 0 to 9; reg_status.r_priority (i) = 0; if reg_status.save_stack_count (i) ^= 0 then do; /* Must restore this register. */ call cobol_register_util$restore ((get_bit_code (i))); reg_status.r_lock (i) = 1; end; else reg_status.r_lock (i) = 0; /* ORN */ /* reg_status.contents_sw(i)=0; */ end; exit_pointer_register: /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(MY_NAME);/**/ return; /*************************************/ after_operator: entry; start_after_operator: /***..... dcl LOCAL_NAME2 char (15) int static init ("$AFTER_OPERATOR");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME||LOCAL_NAME2);/**/ i = 1; j = 4; go to emit_; /*************************************/ in_line: entry; start_in_line: /***..... dcl LOCAL_NAME3 char (8) int static init ("$IN_LINE");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME||LOCAL_NAME3);/**/ go to reset; /*************************************/ error_exit: error_message.message = "Invalid PR specification"; call signal_ ("command_abort_", null (), addr (error_message)); return; /*************************************/ get_bit_code: proc (fbin_code) returns (bit (4)); dcl fbin_code fixed bin; dcl bit_code bit (4); if fbin_code = 9 then bit_code = "0010"b; /* Q */ else if fbin_code = 8 then bit_code = "0001"b; /* A */ else bit_code = "1"b || substr (unspec (fbin_code), 34, 3); return (bit_code); end get_bit_code; /***..... dcl cobol_gen_driver_$Tr_Beg entry(char(*));/**/ /***..... dcl cobol_gen_driver_$Tr_End entry(char(*));/**/ /***..... dcl Trace_Bit bit(1) static external;/**/ /***..... dcl Trace_Lev fixed bin static external;/**/ /***..... dcl Trace_Line char(36) static external;/**/ /***..... dcl ioa_ entry options(variable); /**/ /***..... dcl MY_NAME char (13) int static init ("COBOL_RESET_R");/**/ /* INCLUDE FILES USED BY THIS PROCEDURE */ dcl 1 ptr_status (0:7) based (cobol_$ptr_status_ptr) aligned, %include cobol_ptr_status; /***** Declaration for builtin function *****/ dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index) builtin; /***** End of declaration for builtin function *****/ dcl 1 reg_status (0:9) based (cobol_$reg_status_ptr) aligned, %include cobol_reg_status; %include cobol_; end cobol_reset_r;  cobol_return_gen.pl1 05/24/89 1042.8rew 05/24/89 0832.6 108945 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_return_gen.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 11/20/76 by Bob Chang to handle same_sort_merge flag. */ /* Modified on 11/12/76 by Bob Chang to interface with merge_gen. */ /* Modified since Version 2.0 */ /* format: style3 */ cobol_return_gen: proc (in_token_ptr, passed_tag); /* This procedure cobol_return generates the code necessary to implement the COBOL RETURN statement. This format of the RETURN staatement is as follows: R_E_T_U_R_N_ file-name RECORD [I_N_T_O_ identifier ]; AT E_N_D_ imperative-statement The execution of the RETURN statement causes the next record, in the order specified by the keys listed in the SORT statement, to be made available for processing in the record areas associated with the sort file. If the INTO phrase is specified, the current record is moved from the input area to the area specified by identifier according to the rules for MOVE statement without the CORRESPONDING phrase. The implied MOVE does not occur if there is an AT END condition. Any subscripting or indexing associated with identifier is evaluated after the record has been returned and immediately before it is moved to the data item. When the INTO phrase is used, the data is available in both the input record area and the data area associated with identifier. If no next logical record exist for the file at the time of the execution of a RETURN statement, the AT END condition occurs. The contents of the record area associated with the file when the AT END condition occurs are undefined. After the execution of the imperative-statement in the AT END phrase, no RETURN statement may be executed as part of the current output procedure. NOTE: The contents of any data items which lie beyound the range of the current data record are undefined at the completion of the execution of the RETURN statement. */ /* Code and relocation sequences. */ dcl 1 read_in_token static, 2 n fixed bin init (4), 2 code fixed bin init (0), 2 pt1 ptr, 2 pt2 ptr, 2 pt3 ptr, 2 pt4 ptr; dcl 1 mlr_struct static, 2 type fixed bin init (4), 2 operand_no fixed bin init (2), 2 lock fixed bin init (0), 2 operand1, 3 token_ptr ptr init (null ()), 3 sr fixed bin init (0), 3 icmod fixed bin init (0), 3 size_sw fixed bin init (0), 2 operand2, 3 token_ptr ptr, 3 sr fixed bin init (1), 3 icmod fixed bin, 3 size_sw fixed bin init (0); dcl mlr_reg_to_reg bit (36) init ("000100000001010000001000000101000000"b); dcl instr (3) bit (36) unaligned static init ("000000000000000000000000000000000000"b, "000000000000000000000000000000000000"b, "000000000000000000000000000000000000"b); dcl rel_instr (6) bit (5) aligned static init ("00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b); dcl inst_seq1 (6) bit (18) static init ("110000000001001100"b, "010011101001000000"b, /* lda pr6|76 */ "000000000000000000"b, "110000000000000100"b, /* tze 0,ic */ "110000000001001010"b, "011101010001010000"b); /* epp2 pr6|74,* */ dcl tra_inst (2) bit (18) static init ("000000000000000000"b, "111001000000000100"b); /* tra 0,ic */ dcl merge_check_inst (4) bit (18) static init ("100000000000101001"b, "010011101001000000"b, /* lda pr4|sort_merge_sw */ "000000000000000000"b, "110000000000000100"b); /* tze sort_tag */ dcl rel_merge_check (4) bit (5) aligned static init ("11001"b, "00000"b, "00000"b, "00000"b); dcl temp_type12 char (60) static, temp_file_ptr ptr static, temp_type12_ptr ptr static, temp_type9_ptr ptr static; dcl 1 temp_type9 static, 2 header (4) fixed bin init (112, 0, 0, 9), 2 repl_ptr (2) ptr init ((2) null ()), 2 fill1 bit (108) init (""b), 2 file_key_info, 3 fb1 (3) fixed bin init (0, 0, 0), 3 size fixed bin init (0), 3 fb2 (2) fixed bin init (0, 0), 3 flags1 bit (36) init ("000000100100000000010000000100000000"b), 3 flags2 bit (36) init (""b), 3 seg fixed bin init (0), 3 off fixed bin, 2 fill2 (7) fixed bin init (0, 0, 0, 0, 0, 0, 0); dcl 1 type19_read_into static, 2 header (4) fixed bin init (38, 0, 0, 19), 2 verb fixed bin init (0), 2 e fixed bin init (0), 2 h fixed bin init (0), 2 ij (2) fixed bin init (0, 0), 2 abcdfgk bit (16) init ("0011000000000000"b); dcl 1 mpout static, 2 n fixed bin init (4), 2 pt1 ptr, 2 pt2 ptr, 2 pt3 ptr, 2 pt4 ptr; dcl file_key_desc char (40) based; dcl fkey_ptr ptr; dcl eos_buff (5) ptr; dcl 1 fkey_type9 static, 2 header (4) fixed bin init (112, 0, 0, 9), 2 repl_ptr (2) ptr init ((2) null ()), 2 fill1 bit (108) init (""b), 2 file_key_info, 3 fb1 (3) fixed bin init (0, 0, 0), 3 size fixed bin init (0), 3 fb2 (2) fixed bin init (0, 0), 3 flags1 bit (36) init (""b), 3 flags2 bit (36) init (""b), 3 seg fixed bin, 3 off fixed bin, 2 fill2 (7) fixed bin init (0, 0, 0, 0, 0, 0, 0); dcl 1 alpha_type9 static, 2 header (4) fixed bin init (112, 0, 0, 9), 2 repl_ptr (2) ptr init ((2) null ()), 2 fill1 bit (108) init (""b), 2 file_key_info, 3 fb1 (3) fixed bin init (0, 0, 0), 3 size fixed bin init (0), 3 fb2 (2) fixed bin init (0, 0), 3 flags1 bit (36) init ("000000100100000000010000000100000000"b), 3 flags2 bit (36) init (""b), 3 seg fixed bin init (0), 3 off fixed bin, 2 fill2 (7) fixed bin init (0, 0, 0, 0, 0, 0, 0); dcl 1 num_type9 static, 2 header (4) fixed bin init (112, 0, 0, 9), 2 repl_ptr (2) ptr init ((2) null ()), 2 fill1 bit (108) init (""b), 2 file_key_info, 3 fb1 (3) fixed bin init (0, 0, 0), 3 size fixed bin init (0), 3 places_left fixed bin, 3 places_right fixed bin init (0), 3 flags1 bit (36) init ("000000100100000001000000000100000000"b), 3 flags2 bit (36) init (""b), 3 seg fixed bin init (0), 3 off fixed bin, 2 fill2 (7) fixed bin init (0, 0, 0, 0, 0, 0, 0); /* Automatic data */ dcl retry_tag fixed bin, sort_tag fixed bin, exit_tag fixed bin, dn_ptr ptr, /* pointer to type 9 token */ ft_ptr ptr, /* pointer to the file table */ name_ptr ptr, /* pointer to type12 token */ linkoff fixed bin, /* word offset of entry point link */ passed_tag fixed bin, def_tag fixed bin, hold_addr bit (18) based, return_error_code fixed bin static init (53), merge_bit bit (1) static init ("0"b), stackoff fixed bin static init (0); /* word offset in stack */ /* Procedures Called */ dcl cobol_read_rand entry (fixed bin, char (5), ptr), cobol_read_gen entry (ptr, fixed bin), cobol_io_util$bin_to_dec entry (bit (3) aligned, fixed bin, fixed bin, bit (3) aligned, fixed bin, fixed bin), cobol_move_gen entry (ptr), cobol_addr entry (ptr, ptr, ptr), cobol_call_op entry (fixed bin, fixed bin), cobol_define_tag entry (fixed bin), cobol_merge_return_gen entry (ptr, fixed bin), cobol_reg_manager$after_op entry (fixed bin), cobol_read_ft entry (fixed bin, ptr), cobol_make_tagref entry (fixed bin, fixed bin, ptr), cobol_make_merge_file entry (ptr, ptr, ptr, ptr), cobol_emit entry (ptr, ptr, fixed bin); start: eos_ptr = in_token.token_ptr (in_token.n); if end_stmt.f = "01"b | end_stmt.f = "00"b then do; passed_tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call sort; return; end; else if end_stmt.f = "10"b then do; call merge; return; end; else do; sort_tag = cobol_$next_tag; exit_tag = cobol_$next_tag + 1; cobol_$next_tag = cobol_$next_tag + 2; call cobol_emit (addr (merge_check_inst), addr (rel_merge_check), 2); call cobol_make_tagref (sort_tag, cobol_$text_wd_off - 1, null ()); call merge; call cobol_emit (addr (tra_inst), null (), 1); call cobol_make_tagref (exit_tag, cobol_$text_wd_off - 1, null ()); call cobol_define_tag (sort_tag); call sort; call cobol_define_tag (exit_tag); return; end; /* BEGIN sort */ sort: proc; retry_tag = cobol_$next_tag; call cobol_define_tag (retry_tag); cobol_$next_tag = cobol_$next_tag + 1; eos_ptr = addr (eos_buff); name_ptr = in_token.token_ptr (2); def_tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_call_op (13, retry_tag); call cobol_reg_manager$after_op (13); call cobol_read_ft (fd_token.file_no, ft_ptr); /* Added to fix the bug for variable length item. */ if file_table.rec_do then do; call cobol_io_util$bin_to_dec ("110"b, 328, 12, "110"b, 304, 4); call cobol_read_rand (1, file_table.rec_do_info, fkey_ptr); addr (fkey_type9.file_key_info) -> file_key_desc = file_key.desc; mpout.pt1 = null (); mpout.pt2 = addr (num_type9); num_type9.size = 12; num_type9.places_left = 12; num_type9.seg = 1000; num_type9.off = 328; mpout.pt3 = addr (fkey_type9); mpout.pt4 = eos_ptr; end_stmt.e = 1; call cobol_move_gen (addr (mpout)); end; call cobol_emit (addr (inst_seq1 (1)), null (), 3); call cobol_make_tagref (def_tag, cobol_$text_wd_off - 2, null ()); alpha_type9.size = file_table.max_cra_size; alpha_type9.seg = file_table.cra_seg; alpha_type9.off = file_table.cra_offset; dn_ptr = addr (alpha_type9); instr (1) = mlr_reg_to_reg; instr (2) = "010000000000000000000000"b || substr (unspec (file_table.max_cra_size), 25, 12); instr (3) = ""b; mlr_struct.operand2.token_ptr = dn_ptr; call cobol_addr (addr (mlr_struct), addr (instr (1)), null ()); call cobol_emit (addr (instr (1)), null (), 3); if in_token.n >= 4 then do; mlr_struct.operand2.token_ptr = in_token.token_ptr (3); in_token.token_ptr (3) -> data_name.numeric = "0"b; in_token.token_ptr (3) -> data_name.alphanum = "1"b; instr (1) = mlr_reg_to_reg; instr (2) = "010000000000000000000000"b || substr (unspec (file_table.max_cra_size), 25, 12); instr (3) = ""b; call cobol_addr (addr (mlr_struct), addr (instr (1)), null ()); substr (instr (1), 1, 9) = "000100000"b; call cobol_emit (addr (instr (1)), null (), 3); end; call cobol_emit (addr (tra_inst (1)), null (), 1); /* AT END processing */ call cobol_make_tagref (passed_tag, cobol_$text_wd_off - 1, null ()); call cobol_define_tag (def_tag); return; end sort; /* END sort */ /* BEGIN merge */ merge: proc; call cobol_make_merge_file (in_token.token_ptr (2), temp_file_ptr, temp_type12_ptr, temp_type9_ptr); read_in_token.pt2 = temp_type12_ptr; read_in_token.pt3 = in_token.token_ptr (3); if in_token.n = 4 then do; read_in_token.n = 4; read_in_token.pt4 = addr (type19_read_into); end; else read_in_token.n = 3; call cobol_read_gen (addr (read_in_token), passed_tag); return; end merge; /* END merge */ /***** Declaration for builtin function *****/ dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index) builtin; /***** End of declaration for builtin function *****/ %include cobol_in_token; %include cobol_file_key; %include cobol_; %include cobol_file_table; %include cobol_type1; %include cobol_type9; %include cobol_type12; %include cobol_type19; end cobol_return_gen;  cobol_rewrite_gen.pl1 05/24/89 1042.8rew 05/24/89 0832.6 106560 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_rewrite_gen.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 03/18/81 by FCH, [4.4-2], rewrite with alt rec keys can cause abort, BUG470 */ /* Modified on 02/18/81,[4.4-1], operator 87 replaced by operator 93 */ /* Modified on 06/27/79 by FCH,[4.0-1], not option added for debug */ /* Modified on 11/13/78 by FCH,[3.0-1], alt rec_keys added */ /* Modified since Version 3.0 */ /* format: style3 */ cobol_rewrite_gen: proc (mp_ptr, passed_tag); dcl passed_tag fixed bin; /* for in-line error handling */ dcl ptag fixed bin; dcl mp_ptr ptr; dcl 1 mp based (mp_ptr), 2 n fixed bin, /* from 3 to 4 */ 2 pt (0 refer (mp.n)) ptr; /* pt(1) pts to type1 token for REWRITE */ /* pt(2) pts to type9 token for record to be rewritten */ /* pt(3) pts to type9 token for FROM data IF end_stmt.c = "1"b */ /* pt(n) pts to type19 token (eos) */ dcl 1 args, 2 entryno fixed bin, 2 arglist_off fixed bin, 2 stacktemp_off fixed bin, 2 n fixed bin, 2 arg (4), 3 pt ptr, 3 type fixed bin, 3 off1 fixed bin, 3 off2 fixed bin, 3 value bit (18) unal, 3 indirect bit (1) unal, 3 overlay bit (1) unal, 3 repeat_nogen bit (1) unal, 3 regsw bit (1) unal, 3 regno bit (3) unal; dcl adjust_recptr_sw bit (1); dcl argb (4) bit (216) based (addr (args.arg (1))); dcl text (0:100000) bit (36) based (cobol_$text_base_ptr); dcl ft_ptr ptr; dcl fkey_ptr ptr; dcl name_ptr ptr; dcl dn_ptr ptr; dcl arg_ptr ptr; dcl ioerror_ptr ptr; /*[3.0-1]*/ declare alt_sw bit (1); dcl temp fixed bin; dcl aloff fixed bin; dcl size fixed bin; dcl buflen_off fixed bin; dcl buf_off fixed bin; dcl ntag fixed bin; dcl unopened_error_tag fixed bin; dcl stoff fixed bin; dcl hold_keylen_sw fixed bin; dcl hold_key_wdoff fixed bin; /*************************************/ /*************************************/ /* INITIALIZATION */ start: pr5_struct_ptr = addr (pr5_struct); adjust_recptr_sw = "0"b; rw_ptr = mp.pt (1); dn_ptr = mp.pt (2); eos_ptr = mp.pt (mp.n); ioerror_ptr = addr (ioerror); ioerror.cobol_code = 0; ioerror.type1_ptr = mp.pt (1); ioerror.is_tag = 0; ioerror.mode = 0; if end_stmt.b = "1"b then do; /* in-line error coding follows */ ioerror.is_tag = cobol_$next_tag; /* to be defined at end of generated code for WRITE */ ptag, passed_tag = cobol_$next_tag + 1; /* to be defined by gen driver at end of in-line coding */ ioerror.ns_tag = ptag; cobol_$next_tag = cobol_$next_tag + 2; end; else do; ioerror.is_tag = 0; ptag = 0; ioerror.ns_tag = cobol_$next_tag; /* to be defined at end of generated code */ cobol_$next_tag = cobol_$next_tag + 1; end; arg_ptr = addr (args); call cobol_read_ft (data_name.file_num, ft_ptr); call cobol_alloc$stack (316, 2, aloff); /* enough for 79 words - aloff is a wd offset */ args.arglist_off = aloff; buflen_off = 80; /*************************************/ /* START CODE GENERATION */ start_codegen: /* MAKE SURE FILE IS OPEN */ ioerror.retry_tag = cobol_$next_tag; unopened_error_tag = cobol_$next_tag + 1; cobol_$next_tag = cobol_$next_tag + 2; call cobol_define_tag (ioerror.retry_tag); call cobol_set_fsbptr (ft_ptr); /* MOVE FROM DATANAME TO BUFFER IF NECESSARY */ if end_stmt.c = "1"b then do; /* FROM specified */ mpout.pt1 = mp.pt (1); mpout.pt2 = mp.pt (3); mpout.pt3 = mp.pt (2); mpout.pt4 = addr (type19); call cobol_move_gen (addr (mpout)); end; /* ESTABLISH RECORD LENGTH */ if ^file_table.variable then do; temp = file_table.max_cra_size; call cobol_io_util$move_direct ("110"b, buflen_off * 4, 4, 1, substr (unspec (temp), 19, 18)); end; else do; if ^file_table.rec_do then call cobol_get_size (dn_ptr, buflen_off, reserved_word.line); else do; call cobol_read_rand (1, file_table.rec_do_info, fkey_ptr); addr (fkey_type9.file_key_info) -> file_key_desc = file_key.desc; call cobol_io_util$t9dec_to_bin ("110"b, buflen_off * 4, addr (fkey_type9)); end; end; /* CONVERT IF CODE SET INDICATES SO */ if file_table.code_set_clause then if file_table.code_set = 12 then do; /* 12 = ebcdic */ call cobol_alloc$stack (data_name.size + 1, 2, stoff); /*-10/07/76-*/ trans_type9.seg = 1000; /* in stack */ trans_type9.off = stoff * 4; /*-10/07/76-*/ trans_type9.size = data_name.size; call cobol_trans_alphabet$io (dn_ptr, addr (trans_type9), fixed (file_table.code_set), 0); dn_ptr = addr (trans_type9); /* set to converted record for remainder of this generator */ end; /*[3.0-1]*/ alt_sw = file_table.organization = 3 /* ind */ /*[3.0-1]*/ & /*[3.0-1]*/ file_table.alternate_keys ^= 0; if file_table.access < 2 then do; /* sequential access */ ntag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_io_util$bypass_seqerror (ntag); call cobol_ioop_util$set_x5 (rewrite_seq_errno); /* OPERATOR54(delete_error) */ call cobol_call_op (54, ntag); /* ERROR_OP */ call cobol_gen_ioerror (ft_ptr, ioerror_ptr); call cobol_define_tag (ntag); if file_table.organization = 3 /* indexed */ then do; /* make sure key matches - always will for relative */ call cobol_read_rand (1, file_table.r_key_info, fkey_ptr); addr (fkey_type9.file_key_info) -> file_key_desc = file_key.desc; ntag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_io_util$compare_key (ntag, addr (fkey_type9)); call cobol_io_util$move_direct ("001"b, fsb_keylen_sw, 4, 1, ""b); /* zero the switch */ call cobol_ioop_util$set_x5 (key_mismatch_errno); /* OPERATOR54(delete_error) */ call cobol_call_op (54, ntag);/* ERROR_OP */ call cobol_gen_ioerror (ft_ptr, ioerror_ptr); call cobol_define_tag (ntag); end; call cobol_io_util$move_direct ("001"b, fsb_keylen_sw, 4, 1, ""b); /* zero the switch */ call rew_rec; end; else do; /* random or dynamic access - use specified key */ call cobol_read_rand (1, file_table.r_key_info, fkey_ptr); addr (fkey_type9.file_key_info) -> file_key_desc = file_key.desc; mpout.pt1 = mp.pt (1); mpout.pt2 = addr (fkey_type9); if file_table.organization = 2 then do; /*relative */ mpout.pt3 = addr (num_type9); size, num_type9.size, num_type9.places_left = 16; num_type9.seg = 5001; /* from PR1 */ num_type9.off = file_table.fsb.off + fsb_key; end; else do; /* indexed */ if file_table.access = 3 & (file_table.external | file_table.open_out) then do; ntag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_io_util$bypass_mode_error (ntag, "11"b); /* must cause error if in output mode */ call cobol_ioop_util$set_x5 (output_errno); /* OPERATOR54(delete_error) */ call cobol_call_op (54, ntag); /* ERROR_OP */ call cobol_gen_ioerror (ft_ptr, ioerror_ptr); call cobol_define_tag (ntag); /*[4.4-2]*/ /* call cobol_set_fsbptr(ft_ptr); */ end; mpout.pt3 = addr (alpha_type9); size, alpha_type9.size = fkey_type9.size; alpha_type9.seg = 5001; /* from PR1 */ alpha_type9.off = file_table.fsb.off + fsb_key; end; /*[4.4-2]*/ call cobol_set_fsbptr (ft_ptr); /*[4.4-2]*/ call cobol_io_util$set_fsb_loc; if ^alt_sw & file_table.access = 3 & file_table.read_next then do; /* read key */ call cobol_alloc$stack (260, 2, stoff); /* area known as TEMP read key area */ call cobol_ioop_util$lda_du (stoff); call cobol_ioop_util$set_icode; ntag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_call_op (55, ntag);/* OPERATOR55(read_key) */ call cobol_gen_ioerror (ft_ptr, ioerror_ptr); call cobol_define_tag (ntag); call cobol_set_fsbptr (ft_ptr); mpout.pt4 = addr (type19); call cobol_move_gen (addr (mpout)); call cobol_io_util$move_direct ("001"b, fsb_keylen_sw, 4, 1, substr (unspec (size), 19, 18)) ; ntag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_ioop_util$lda_du (stoff); call cobol_ioop_util$set_icode; call cobol_set_pr (pr5_struct_ptr, dn_ptr); /* OPERATOR58(special_rewrite) */ call cobol_call_op (58, ntag);/* seek_key BUFF,rewrite_record,seek_key TEMP,position if EOF*/ call cobol_gen_ioerror (ft_ptr, ioerror_ptr); call cobol_define_tag (ntag); end; else do; ntag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; /*[4.4-2]*/ /* call cobol_set_fsbptr(ft_ptr); */ mpout.pt4 = addr (type19); call cobol_move_gen (addr (mpout)); call cobol_io_util$move_direct ("001"b, fsb_keylen_sw, 4, 1, substr (unspec (size), 19, 18)) ; /*[3.0-1]*/ if alt_sw /*[4.4-2]*/ then do; call cobol_io_util$fsb_key_loc (6); /* epp1 pr1|6 */ /*[3.0-1]*/ call cobol_io_util$file_desc (file_table.file_desc_1_offset); /*[3.0-1]*/ call cobol_call_op (85, 0); /* OPERATOR85(alt_special_delete) */ /*[3.0-1]*/ call cobol_set_fsbptr (ft_ptr); /*[3.0-1]*/ end; call cobol_ioop_util$set_icode; call cobol_call_op (41, ntag);/* OPERATOR41(seek_key) */ call cobol_gen_ioerror (ft_ptr, ioerror_ptr); call cobol_define_tag (ntag); call rew_rec; end; end; call cobol_reg_manager$after_op (4095 + ioerror.cobol_code); /*[4.0-1]*/ if end_stmt.f = "01"b /*[4.0-1]*/ then passed_tag = ioerror.is_tag; /*[4.0-1]*/ else call cobol_gen_ioerror$finish_up (ft_ptr, ioerror_ptr); return; rew_rec: proc; /*[3.0-1]*/ if alt_sw /*[3.0-1]*/ then do; ntag = cobol_$next_tag; /*[3.0-1]*/ cobol_$next_tag = cobol_$next_tag + 1; /*[4.4-1]*/ call cobol_set_pr (pr5_struct_ptr, dn_ptr); /*[4.4-1]*/ call cobol_call_op (93, ntag); /* OPERATOR93(alt_rewrite) */ /*[3.0-1]*/ call cobol_gen_ioerror (ft_ptr, ioerror_ptr); /*[3.0-1]*/ call cobol_define_tag (ntag); /*[3.0-1]*/ call cobol_set_fsbptr (ft_ptr); /*[3.0-1]*/ end; ntag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_set_fsbptr (ft_ptr); call cobol_set_pr (pr5_struct_ptr, dn_ptr); call cobol_ioop_util$set_icode; call cobol_call_op (59, ntag); /* OPERATOR59(rewrite) */ call cobol_gen_ioerror (ft_ptr, ioerror_ptr); call cobol_define_tag (ntag); /*[3.0-1]*/ if alt_sw /*[3.0-1]*/ then do; ntag = cobol_$next_tag; /*[3.0-1]*/ cobol_$next_tag = cobol_$next_tag + 1; /*[3.0-1]*/ call cobol_call_op (88, ntag); /* OPERATOR88(alt_rewrite_add) */ /*[3.0-1]*/ call cobol_gen_ioerror (ft_ptr, ioerror_ptr); /*[3.0-1]*/ call cobol_define_tag (ntag); /*[3.0-1]*/ end; end; /*************************************/ %include cobol_rewrite_gen_info; %include cobol_rewrite_gen_data; end cobol_rewrite_gen;  cobol_search_gen.pl1 05/24/89 1042.8rew 05/24/89 0832.6 436932 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_search_gen.pl1 Added Trace statements. 2) change(89-04-23,Zimmerman), approve(89-04-23,MCR8082), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8082 cobol_search_gen.pl1 Fix wild array subscript. END HISTORY COMMENTS */ /* Modified on 02/11/85 by FCH, [5.3-2], BUG561, search_flag=0 in fmt4_eos */ /* Modified on 10/19/84 by FCH, [5.3-1], BUG563(phx18381), new cobol_addr_tokens.incl.pl1 */ /* Modified on 09/11/81 by FCH, [5.0-1], set search_flag to 1 in fmt3_eos not fmt1_eos, BUG503(phx11385) */ /* Modified on 09/08/77 by Bob Chang to fix the bug for not setting numeric_lit.places_left. */ /* Modified on 7/18/76 by Bob Chang to handle the varying length data. */ /* format: style3 */ cobol_search_gen: proc (in_token_ptr, search_flag); /* This procedure generates code for the Cobol Search statment. */ /* Because of the way the PD syntax phase parses the SEARCH statement, cobol_search_gen will be called more than once to generate code for a single SEARCH statement. See details below in the documentation for the separate internal procedures used to implement the code generation. */ /* The current implemenattion generates code only for format 1 SEARCH statements. If called to generate code for format 2 SEARCH statements, a diagnostic is issued, and unpredictable code is generated. */ /* DECLARATION OF THE PARAMETERS */ /* dcl in_token_ptr ptr; */ /* THIS PARAMETER IS DECLARED BELOW IN AN INCLUDE FILE */ dcl search_flag fixed bin; /* DECLARATION OF EXTERNAL ENTRIES */ dcl cobol_register$load ext entry (ptr); dcl ioa_$ioa_stream ext entry options (variable); dcl cobol_compare_gen ext entry (ptr); dcl cobol_emit ext entry (ptr, ptr, fixed bin); dcl cobol_make_tagref ext entry (fixed bin, fixed bin, ptr); dcl cobol_define_tag ext entry (fixed bin); dcl cobol_set_gen ext entry (ptr); dcl cobol_add_gen ext entry (ptr, fixed bin); dcl cobol_read_rand entry (fixed bin, char (5), ptr); dcl cobol_make_type9$copy ext entry (ptr, ptr); dcl cobol_addr ext entry (ptr, ptr, ptr); dcl cobol_process_error ext entry (fixed bin, fixed bin, fixed bin); dcl cobol_alloc$stack ext entry (fixed bin, fixed bin, fixed bin); /*}*/ /*************************************************/ /* START OF EXECUTION */ /* cobol_search_gen */ /**************************************************/ /* Save the in_token_ptr. */ save_in_token_ptr = in_token_ptr; if in_token.token_ptr (in_token.n) -> end_stmt.a = "000"b then call format1_search; else call format2_search; /* Restore the in_token_ptr to its original value. */ in_token_ptr = save_in_token_ptr; /* DECLARATIONS OF INTERNAL STATIC VARIABLES */ dcl 1 set_eos_token int static, 2 size fixed bin (15) init (38), 2 line fixed bin (15) init (0), 2 column fixed bin (15) init (0), 2 type fixed bin (15) init (19), /* EOS */ 2 verb fixed bin (15) init (31), /* SET */ 2 e fixed bin (15), 2 h fixed bin (15), 2 i fixed bin (15), 2 j fixed bin (15), 2 a bit (3) init ("000"b), /* SET FOR EITHER FMT 1 OR FMT 2 */ 2 b bit (1) init ("0"b); /* SET FOR FMT 1 OR FMT 2 */ dcl 1 numeric_lit_1 int static, 2 size fixed bin (15) init (36), 2 line fixed bin (15) init (0), 2 column fixed bin (15) init (0), 2 type fixed bin (15) init (2), /* NUMERIC LITERAL */ 2 integral bit (1) init ("1"b), 2 floating bit (1) init ("0"b), 2 filler1 bit (5) init ("00000"b), 2 subscript bit (1) init ("0"b), 2 sign char (1) init (" "), 2 exp_sign char (1) init (" "), 2 exp_places fixed bin (15) init (0), 2 places_left fixed bin (15) init (1), 2 places_right fixed bin (15) init (0), 2 places fixed bin (15) init (1), 2 literal char (1) init ("1"); dcl 1 add_eos_token int static, 2 size fixed bin (15) init (38), 2 line fixed bin (15) init (0), 2 column fixed bin (15) init (0), 2 type fixed bin (15) init (19), /* EOS */ 2 verb fixed bin (15) init (2), /* ADD */ 2 e fixed bin (15) init (1), /* left operands */ 2 h fixed bin (15) init (1), /* right operands */ 2 i fixed bin (15) init (0), 2 j fixed bin (15) init (0), 2 a bit (3) init ("000"b), /* FORMAT 1 */ 2 b bit (1) init ("0"b); /* NO OSE CLAUSE PRESENT */ dcl 1 compare_eos_token int static, 2 size fixed bin (15) init (38), 2 line fixed bin (15) init (0), 2 column fixed bin (15) init (0), 2 type fixed bin (15) init (19), /* EOS */ 2 verb fixed bin (15) init (13), /* BRANCH */ 2 e fixed bin (15) init (0), /* SET TO GREATER OR EQUAL */ 2 h fixed bin (15) init (0), 2 i bit (36) init ("010"b); /* TRANSFER IF CONDITION NOT TRUE */ dcl 1 work_numeric_lit int static, 2 size fixed bin (15) init (36), 2 line fixed bin (15) init (0), 2 column fixed bin (15) init (0), 2 type fixed bin (15) init (2), /* NUMERIC LITERAL */ 2 integral bit (1) init ("1"b), 2 floating bit (1) init ("0"b), 2 filler1 bit (5) init ("00000"b), 2 subscript bit (1) init ("0"b), 2 sign char (1) init (" "), 2 exp_sign char (1) init (" "), 2 exp_places fixed bin (15) init (0), 2 places_left fixed bin (15) init (0), 2 places_right fixed bin (15) init (0), 2 places fixed bin (15) init (0), 2 literal char (20); /* Declaration of an unconditional transfer instruction */ dcl tra_inst bit (36) int static init ("000000000000000000111001000000000000"b); dcl mlr_op bit (10) int static init ("0010000011"b /*010(1)*/); dcl ldq_op bit (10) int static init ("0100111100"b /*236(0)*/); dcl stq_op bit (10) int static init ("1111011100"b /*756(0)*/); dcl lda_op bit (10) int static init ("0100111010"b /*235(0)*/); dcl div_op bit (10) int static init ("1010001100"b /*506(0)*/); dcl asa_op bit (10) int static init ("0001011010"b /*055(0)*/); dcl aos_op bit (10) int static init ("0001011000"b /* 054(0)*/); dcl sta_op bit (10) int static init ("1111011010"b /*755(0)*/); dcl do_ptr ptr, com2_ptr ptr; dcl next_compare_tag fixed bin static; dcl next_stmt_tag fixed bin int static; dcl compare_code_tag fixed bin int static; dcl increment_code_tag fixed bin int static; dcl next_when_tag fixed bin int static; dcl check_index_tag fixed bin int static; dcl at_end_tag fixed bin int static; dcl save_in_token_ptr ptr; dcl work_in_token (1:20) ptr; /* Structure used to communicate with the register handling routines. */ dcl 1 register_struc, 2 what_reg fixed bin, 2 reg_no bit (4), 2 lock fixed bin, 2 already_there fixed bin, 2 contains fixed bin; dcl dn_ptr ptr; format1_search: proc; /* Declaration of an entry array */ dcl eos_proc (1:4) entry init (fmt1_eos, fmt2_eos, fmt3_eos, fmt4_eos); /* DECLARATIONS OF INTERNAL VARIABLES */ dcl index_token_ptr ptr; dcl varying_token_ptr ptr; dcl add_next_stmt_tag fixed bin; dcl work_string char (20); dcl varying_done bit (1); dcl ix fixed bin; dcl iy fixed bin; dcl offset_inst_word bit (36); dcl occurrence_inst_word bit (36); dcl element_length_inst_word bit (36); /**************************************************/ /* START OF EXECUTION */ /* INTERNAL PROCEDURE */ /* format1_search */ /**************************************************/ call eos_proc (in_token.token_ptr (in_token.n) -> end_stmt.e); fmt1_eos: proc; /* Reserve a tag to be defined at the next Cobol statement (the statement following this SEARCH stetement) */ next_stmt_tag = cobol_$next_tag; /* Reserve a tag to be defined at the first instruction of the code generated to compare the index name value with the maximum size of the table. */ compare_code_tag = next_stmt_tag + 1; /* Reserve a tag to be defined at the next WHEN clause in the SEARCH statement. */ next_when_tag = next_stmt_tag + 2; /* Reserve a tag to be defined at the first instruction generated to increment the index name. */ next_compare_tag = cobol_$next_tag + 4; at_end_tag = cobol_$next_tag + 5; increment_code_tag = next_stmt_tag + 3; /* Update the next tag variable in the external data segment. */ cobol_$next_tag = cobol_$next_tag + 6; eos_ptr = in_token.token_ptr (in_token.n); dn_ptr = in_token.token_ptr (2); if data_name.occurs_do then do; call cobol_read_rand (1, data_name.do_rec, com2_ptr); call cobol_read_rand (3, odo_rec.descr, dn_ptr); do_ptr = dn_ptr; end; else do_ptr = null (); if end_stmt.c = "1"b /* VARYING clause present. */ then if (in_token.token_ptr (in_token.n - 1) -> data_name.type = rtc_dataname & in_token.token_ptr (in_token.n - 1) -> data_name.usage_index) then /* VARYING variabble is an index data item. */ /* Generate code to extract data from the index data item to be used in incrementing the index data item during the execution of the SEARCH. */ call get_index_item_data (in_token.token_ptr (in_token.n - 1), offset_inst_word, occurrence_inst_word, element_length_inst_word); /* Generate an unconditional transfer to the compare_code_tag. */ call cobol_emit (addr (tra_inst), null (), 1); /* Make a tag reference to compare_code_tag at the instruction just emitted. */ call cobol_make_tagref (compare_code_tag, cobol_$text_wd_off - 1, null ()); /* Define the increment_code_tag at the next instruction location. */ call cobol_define_tag (increment_code_tag); /* Determine what index name should be used to search the table. */ if end_stmt.c = "0"b then do; /* No VARYING clause present. */ index_token_ptr = in_token.token_ptr (in_token.n - 1); dn_ptr = in_token.token_ptr (in_token.n - 2); occurs_ptr = addrel (dn_ptr, divide (data_name.occurs_ptr, 4, 35, 0)); varying_token_ptr = null (); end; /* No VARYING clause present. */ else do; /* VARYING present, determine whether the index name appearing in the VARYING clause should be used to search the table. */ dn_ptr = in_token.token_ptr (in_token.n - 3); /* Build a pointer to the occurs extension of the table being searched. */ occurs_ptr = addrel (dn_ptr, divide (data_name.occurs_ptr, 4, 35, 0)); if in_token.token_ptr (in_token.n - 1) -> data_name.type = rtc_indexname then do; /* VARYING variable is an index name. */ /* Check to see if the index name in the VARYING clause appears in the INDEXED BY clause of the table being searched. This index name appears in the INDEXED BY clause of the table if the index_no value in the index name token is equal to the index_no value in the occurs extension of the table. */ if occurs.level.index_no (occurs.dimensions) = in_token.token_ptr (in_token.n - 1) -> index_name.index_no then do; /* It does appear in the INDEXED BY clause of the table. */ /* Use the index name in the VARYING clause for the SEARCH. */ index_token_ptr = in_token.token_ptr (in_token.n - 1); varying_token_ptr = null (); /* no varying identifier to worry about. */ end; /* It does appear in the INDEXED BY clause of the table. */ else do; /* Index name not associated with the table via INDEXED BY clause. */ /* The first index name token appears on cobol_pdout_ immediately following the data name token for the table. */ index_token_ptr = in_token.token_ptr (in_token.n - 2); /* The INDEX name in the varying clause is also incremented during the search. */ varying_token_ptr = in_token.token_ptr (in_token.n - 1); end; /* The Index name not associated with the table via INDEXED BY clause. */ end; /* VARYING variable is an index name. */ else do; /* VARYING VARIABLE is not an index name. */ /* Index used to search the table is the first index appearing in the INDEXED BY clause. */ index_token_ptr = in_token.token_ptr (in_token.n - 2); varying_token_ptr = in_token.token_ptr (in_token.n - 1); end; /* VARYING variable is not an index name. */ end; /* VARYING present, determine whether the index name appearing in the VARYING clause should be used to search the table. */ /* AT THIS POINT IN PROCESSING: 1. dn_ptr points to the data name token (type 9) for the table to be searched. 2. index_token_ptr points to the index name token (type 10) for the index to be used in the search. 3. varying_token_ptr points to the token appearing in the VARYING clause, to be incremented along with the index name used in the search. If there was no VARYING clause, or if the variable referenced in the VARYING clause was the index name now being used in the search, then this pointer is null. */ /* Generate code to increment the index name, and the variable referenced in the VARYING clause. */ varying_done = "0"b; in_token_ptr = addr (work_in_token (1)); in_token.token_ptr (1) = save_in_token_ptr -> in_token.token_ptr (1); in_token.token_ptr (2) = index_token_ptr; if varying_token_ptr ^= null () then do; /* VARYING variable is present. */ if varying_token_ptr -> data_name.type = rtc_indexname then do; /* VARYING variable is an index name. */ /* We will call the SET generator once to increment both index names. */ varying_done = "1"b; in_token.token_ptr (3) = varying_token_ptr; in_token.token_ptr (4) = addr (numeric_lit_1); /* Numeric literal 1 is increment. */ in_token.token_ptr (5) = addr (set_eos_token); in_token.n = 5; in_token.token_ptr (5) -> end_stmt.e = 2; /* Two operands to be SET. */ set_eos_token.a = "001"b; /* Format 2 set stmt. */ set_eos_token.b = "0"b; /* UP */ end; /* VARYING variable is an index name. */ else if (varying_token_ptr -> data_name.type = rtc_dataname & varying_token_ptr -> data_name.usage_index = "1"b) then do; /* VARYING variable is an index data item. */ call increment_index_data_item (varying_token_ptr, offset_inst_word, occurrence_inst_word, element_length_inst_word); end; /* VARYING variable is an index data item. */ end; /* VARYING variable is present. */ if ^varying_done then do; /* VARYING not present, or if present, varying variable is not index name */ in_token.token_ptr (3) = addr (numeric_lit_1); /* Increment is literal 1. */ in_token.token_ptr (4) = addr (set_eos_token); in_token.n = 4; in_token.token_ptr (4) -> end_stmt.e = 1; /* One operand to be set. */ set_eos_token.a = "001"b; /* Format 2 SET stmt. */ set_eos_token.b = "0"b; /* UP */ end; /* VARYING not present, or if present, varying variable is not an index name. */ /* Call the SET generator to increment the index. */ /* Modify the maximum value field in the index name token so the SET generator will allow it to be set to one greater than the maximum size defined in the occurs clause. */ index_token_ptr -> index_name.max = index_token_ptr -> index_name.max + 1; /* Increment the same field in the varying token if it is also an index name. */ if varying_token_ptr ^= null () then if varying_token_ptr -> data_name.type = rtc_indexname then varying_token_ptr -> index_name.max = varying_token_ptr -> index_name.max + index_token_ptr -> index_name.max - 1; /* Call the SET generator. */ call cobol_set_gen (in_token_ptr); if varying_token_ptr ^= null () then if (varying_token_ptr -> data_name.type = rtc_dataname & varying_token_ptr -> data_name.usage_index = "0"b) then do; /* VARYING present, and the varying variable is a dataname, but not usage index. */ /* Generate code to add one to the variable referenced in the VARYING clause. */ in_token_ptr = addr (work_in_token (1)); in_token.token_ptr (1) = null (); in_token.token_ptr (2) = addr (numeric_lit_1); in_token.token_ptr (3) = varying_token_ptr; in_token.token_ptr (4) = addr (add_eos_token); in_token.n = 4; call cobol_add_gen (in_token_ptr, add_next_stmt_tag); end; /* VARYING present, and the varying variable is a dataname, but not usage index. */ /* Define the compare_code_tag at the next instruction. */ call cobol_define_tag (compare_code_tag); /* Generate code to compare the index name being used to search the table, to its maximum size. */ /* Convert the maximum size of the table being searched (in fixed binary representation) to a character string. */ call bin_to_char (index_token_ptr -> index_name.max - 1, /* Remember that we incremented "max" by 1 before calling the set generator. */ work_numeric_lit.literal, work_numeric_lit.places); work_numeric_lit.places_left = work_numeric_lit.places; in_token.n = 3; in_token.token_ptr (3) = addr (compare_eos_token); in_token.token_ptr (1) = index_token_ptr; compare_eos_token.e = 113; /* GREATER */ compare_eos_token.i = "010"b; /* Transfer if not greater. */ /* Generate code to do the comparison. */ if do_ptr ^= null () then do; in_token.token_ptr (2) = do_ptr; compare_eos_token.h = next_compare_tag; call cobol_compare_gen (in_token_ptr); call cobol_emit (addr (tra_inst), null (), 1); if end_stmt.b = "0"b then call cobol_make_tagref (next_stmt_tag, cobol_$text_wd_off - 1, null ()); else call cobol_make_tagref (at_end_tag, cobol_$text_wd_off - 1, null ()); end; call cobol_define_tag (next_compare_tag); in_token.token_ptr (2) = addr (work_numeric_lit); compare_eos_token.h = next_when_tag; call cobol_compare_gen (in_token_ptr); /* Check to see if an AT END clause was not present, and generate a transfer to the next Cobol statement. */ if end_stmt.b ^= "1"b then do; /* AT END clause not present. */ /* Emit a transfer to the next Cobol statement. */ /* Make a tag reference at the instruction just emitted. */ /* Define the next when tag at the next instruction to be generated. */ /*[5.3-2]*/ call TG (next_stmt_tag, next_when_tag); end; /* AT END clause not present. */ call cobol_define_tag (at_end_tag); /* Set the output parameter to non_zero. */ /*[5.0-1]*/ /* search_flag = 1; */ end fmt1_eos; fmt2_eos: proc; if in_token.token_ptr (in_token.n) -> end_stmt.b = "1"b then do; /* This EOS is the last EOS for the sEARCH statement. */ /* Generate code to transfer to increment code tag. */ call cobol_emit (addr (tra_inst), null (), 1); call cobol_make_tagref (increment_code_tag, cobol_$text_wd_off - 1, null ()); /* Define the next_stmt_tag. */ /*[5.3-2]*/ call TG (increment_code_tag, next_stmt_tag); /* Set the output parameter search_flag to zero. */ search_flag = 0; end; /* This EOS is the last EOS for the SEaRCH statement. */ else do; /* This EOs is not the last EOS for the sEaRCH statement. */ /* Generate a transfer to the next Cobol statement. */ /* Make a reference to the next Cobol statement at the instruction just emitted. */ /* Define the next_when_tag. */ /*[5.3-2]*/ call TG (next_stmt_tag, next_when_tag); end; /* This EOS is not the last EOS for the sEaRCH statement. */ end fmt2_eos; TG: proc (T1, T2); /*[5.3-2]*/ dcl (T1, T2) fixed bin; /*[5.3-2]*/ call cobol_emit (addr (tra_inst), null (), 1); /*[5.3-2]*/ call cobol_make_tagref (T1, cobol_$text_wd_off - 1, null ()); /*[5.3-2]*/ call cobol_define_tag (T2); end; fmt3_eos: proc; /*[5.0-1]*/ search_flag = 1; return; end fmt3_eos; fmt4_eos: proc; /* Save the internal tag defined in the internal tag token (type 30) as the next_when_tag. */ next_when_tag = in_token.token_ptr (in_token.n - 1) -> int_tag.proc_num; /*[5.3-2]*/ search_flag = 0; end fmt4_eos; end format1_search; /*************************************************/ /* INTERNAL PROCEDURE */ /* get_index_item_data */ /**************************************************/ get_index_item_data: proc (index_data_item_ptr, work_offset_inst, work_occurrence_inst, element_length_inst); /* This internal proceduure generates code to get the following information for an index data item that is to be incremented during the execution of a SEARCH statement: 1. occurrence number 2. byte offset of the item referenced by "occurrence number". 3. element length of the item referenced by the index data item. (this length is calculated by dividing "byte offset" by "occurrence number".) An index data item in Multics cobol consists of six bytes of data. the first four bytes contain the byte offset, and the last two bytes contain the occurrence number. However, within each byte, only the least significant 8 bits contain meaningful data. Therefore, to do any computation or incrementing of The data in an index data item, it is necessary to squeeze out the junk bits, and store the resulting data into temporary storage. This procedure does That silly bit squeezing. */ /* DECLARATION OF THE PARAMETERS */ dcl index_data_item_ptr ptr; dcl work_offset_inst bit (36); dcl work_occurrence_inst bit (36); dcl element_length_inst bit (36); /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION index_data_item_ptr Pointer to the index data item token (type 9) from which data is to be extracted by this procedure. (input) work_offset_inst a word in which the basic, non-eis address of the word in wich the fixed binary offset value is stored by this procedure. (output) work_occurrence_inst a word in which the basic, non-eis address of the word in which the fixed binary occurrence number is stored by this procedure. (output) element_length_inst a word in which the basic, non-eis address of the word in which the fixed binary element length is stored by this procedure. (output) */ /* DECLARATIONS OF INTERNAL STATIC VARIABLES */ dcl 1 get_occurrence_no_code int static, 2 i1 bit (36) init ("000000000000000000010011101000000011"b), /* lda 0,du */ 2 i2 bit (36) init ("000000000000001010111011111000000000"b), /* lls 10 */ 2 i3 bit (36) init ("000000000000000001111011001000000000"b), /* ars 1 */ 2 i4 bit (36) init ("000000000000011100111011011000000000"b), /* lrs 28 */ 2 i5 bit (36) init ("000000000000000000110000001000000000"b); /* tnz 0 */ dcl 1 get_offset_code int static, 2 i1 bit (36) init ("000000000000001000111011011000000000"b), /* lrs 8 */ 2 i2 bit (36) init ("000000000000000001111011001000000000"b), /* ars 1 */ 2 i3 bit (36) init ("000000000000001000111011011000000000"b), /* lrs 8 */ 2 i4 bit (36) init ("000000000000000001111011001000000000"b), /* ars 1 */ 2 i5 bit (36) init ("000000000000001000111011011000000000"b), /* lrs 8 */ 2 i6 bit (36) init ("000000000000000001111011001000000000"b), /* ars 1 */ 2 i7 bit (36) init ("000000000000001100111011011000000000"b); /* lrs 12 */ dcl search_occurrence_error fixed bin int static init (46); /* DECLARATION OF INTERNAL VARIABLES */ dcl work_offset1 fixed bin; dcl work_offset2 fixed bin; dcl work_offset3 fixed bin; dcl work_ptr ptr; dcl work_offset_inst_ptr ptr; dcl work_occurrence_inst_ptr ptr; dcl element_length_inst_ptr ptr; dcl buff1 (1:10) ptr; dcl buff2 (1:10) ptr; dcl buff3 (1:10) ptr; dcl occurrence_ok_tag fixed bin; input_ptr = addr (buff1 (1)); inst_ptr = addr (buff2 (1)); reloc_ptr = addr (buff3 (1)); /* allocate 3 words (12 bytes) on an even word boundary in the stack. these three words ar to be used to hold: 1. first word-byte offset of the index data item. 2. second occurrence number from the index data item 3. element length of the array item described by the index data item. */ call cobol_alloc$stack (12, 2, work_offset1); /* Convert the word offset returned by cobol_alloc$stack to a byte offset. */ work_offset1 = work_offset1 * 4; /* calculate the byte offset of the word for the occurrence number from the index data item. */ work_offset2 = work_offset1 + 4; /* calculate the byte offset for the word to contain the element length. */ work_offset3 = work_offset1 + 8; /* Make a copy of the input index data item token. */ work_ptr = null (); /* Utility provides buffer for the token. */ call cobol_make_type9$copy (work_ptr, index_data_item_ptr); /* Modify the token so that it describes the temporary space just allocated in the stack. */ work_ptr -> data_name.seg_num = 1000; /* stack */ work_ptr -> data_name.offset = work_offset1; work_ptr -> data_name.subscripted = "0"b; /* generate code to move the index data item ( 6 bytes long) to the stack space. */ input_struc.type = 5; /* EIS, 2 operands input, instruction and 2 descriptors returned. */ input_struc.operand_no = 2; input_struc.lock = 0; input_struc.operand.token_ptr (1) = index_data_item_ptr; input_struc.operand.send_receive (1) = 0; /* sending */ input_struc.operand.size_sw (1) = 0; input_struc.operand.token_ptr (2) = work_ptr; input_struc.operand.send_receive (2) = 1; /* receiving */ input_struc.operand.size_sw = 0; /* call the addressability utility */ call cobol_addr (input_ptr, inst_ptr, reloc_ptr); /* set the MLR opcode into the instruction returned. */ inst_struc.inst.fill1_op = mlr_op; /* emit the instruction and 2 descriptors. */ call cobol_emit (inst_ptr, reloc_ptr, 3); /* get the basic addresses (6180 non-eis addresses of the offset, occurrence number, and element length words. */ work_offset_inst_ptr = addr (work_offset_inst); work_occurrence_inst_ptr = addr (work_occurrence_inst); element_length_inst_ptr = addr (element_length_inst); input_struc_basic.type = 1; /* basic, non-eis */ input_struc_basic.operand_no = 0; input_struc_basic.segno = 1000; /* get basic address of the offset word */ input_struc_basic.char_offset = work_offset1; call cobol_addr (input_ptr, work_offset_inst_ptr, reloc_ptr); /* get the basic address of the occurrence number wordl */ input_struc_basic.char_offset = work_offset2; call cobol_addr (input_ptr, work_occurrence_inst_ptr, reloc_ptr); /* get basic address of the element length word. */ input_struc_basic.char_offset = work_offset3; call cobol_addr (input_ptr, element_length_inst_ptr, reloc_ptr); /* get the a and q registera */ register_struc.what_reg = 3; /* A and Q */ register_struc.lock = 0; /* no change to locks. */ register_struc.contains = 0; /* Contents of A and Q will not be meaningful ofr register optimization, because the code to be generated shifts the contents of the registers. */ call cobol_register$load (addr (register_struc)); /* build instruction to load the Q register with the occurrence number. */ work_occurrence_inst_ptr -> inst_struc_basic.fill1_op = ldq_op; /* Emit the ldq instruction */ call cobol_emit (work_occurrence_inst_ptr, null (), 1); /* at this point we have generated code to load the occurrence number into the Q register. */ /* emit a stream of code to convert the occurrence number into a fixed bin (35) value in the Q register */ /* The code stream emitted is: lda 0,dl lls 10 ars 1 lrs 28 tnz */ call cobol_emit (addr (get_occurrence_no_code), null (), 5); /* Reserve a tag to which to transfer if the occurrence number is OK (non-zero) */ occurrence_ok_tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; /* Make a reference to the tag just reserved at the tnz instruction just emitted. */ call cobol_make_tagref (occurrence_ok_tag, cobol_$text_wd_off - 1, null ()); /* Generate code to signal an error, if the occurrence number is zero. */ call cobol_process_error (search_occurrence_error, fixed (index_data_item_ptr -> data_name.line, 17), 0); /* Define the occurrence_ok_tag. */ call cobol_define_tag (occurrence_ok_tag); /* Generate code to store the occurrence number, back into the temporary in the stack. */ work_occurrence_inst_ptr -> inst_struc_basic.fill1_op = stq_op; /* Emit the instruction. */ call cobol_emit (work_occurrence_inst_ptr, null (), 1); /* Now generate code to load the offset into the A-Q register and squeeze out the junk bits. */ work_offset_inst_ptr -> inst_struc_basic.fill1_op = lda_op; call cobol_emit (work_offset_inst_ptr, null (), 1); /* Emit a stream of code to squeeze out the junk bits. */ /* The stream of code is: lrs 8 ars 1 lrs 8 ars 1 lrs 8 ars 1 lrs 12 RESULT WINDS UP IN Q */ call cobol_emit (addr (get_offset_code), null (), 7); /* Generate code to store the Q into the owrk offset word. */ work_offset_inst_ptr -> inst_struc_basic.fill1_op = stq_op; call cobol_emit (work_offset_inst_ptr, null (), 1); /* Now generate code to calculate the element length of the item described by the index data item, and store the element length in the stack for use later when the index data item is incremented. */ /* Note at this point in the generated code, the offset is contained in the Q register, the occurrence number is sorted in the stack. The element length is calculated by dividing the offset by the occurrence number. */ work_occurrence_inst_ptr -> inst_struc_basic.fill1_op = div_op; call cobol_emit (work_occurrence_inst_ptr, null (), 1); /* Store the quotient (in the Q ) into the stack space allocated to hold the element length */ element_length_inst_ptr -> inst_struc_basic.fill1_op = stq_op; call cobol_emit (element_length_inst_ptr, null (), 1); end get_index_item_data; /**************************************************/ /* INTERNAL PROCEDURE */ /* increment_index_data_item */ /**************************************************/ increment_index_data_item: proc (index_data_item_ptr, work_offset_inst, work_occurrence_inst, element_length_inst); /* This procedure generates code to increment an index data item that is referenced in the VARYING clause of a format 1 SEARCH statement. When this procedure is entered, code has been generated to convert the contents of the index data item into the format of an index data name in the stack. (i.e. two consecutinve words of storage; the first word contains the byte offset, the second word contains the occurrence number.) The value to be used to increment the byte offset is also contained in a temporary in the stack. This procedure generates code that 1. increments the value of the temporary index name representation. 2. converts this index name representation to the index data item representation. 3. moves the index data item representation into the index data item referenced in the VARYING clause. */ /* DECLARATION OF THE PARAMETERS */ dcl index_data_item_ptr ptr; dcl work_offset_inst bit (36); dcl work_occurrence_inst bit (36); dcl element_length_inst bit (36); /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION index_data_item_ptr Pointer to the index data item token (type9) that is be be incremented because it appears in the VARYING clause of a SEARCH statement. work_offset_inst A word that contains the basic, non-eis address of the word containing the byte offset in the index data name format. (input) work_occurrence_inst A word that contains the basic,non-eis address of the word containing the occurrence number in index data name format. (input) element_length_inst A word that contains the basic, non-eis address of the word containing the element length of the item represented by the index data item that appears in the VARYING clause. (input) */ /* DECLARATION OF INTERNAL STATIC VARIABLES */ dcl 1 get_offset_code int static, 2 i1 bit (36) init ("000000000000001100111011111000000000"b), /* lrs 12 */ 2 i2 bit (36) init ("000000000000000001111011101000000000"b), /* als 1 */ 2 i3 bit (36) init ("000000000000001000111011111000000000"b), /* lls 8 */ 2 i4 bit (36) init ("000000000000000001111011101000000000"b), /* als 1 */ 2 i5 bit (36) init ("000000000000001000111011111000000000"b), 2 i6 bit (36) init ("000000000000000001111011101000000000"b), /* als 1 */ 2 i7 bit (36) init ("000000000000001000111011111000000000"b); /* lls 8 */ dcl 1 get_occurrence_code int static, 2 i1 bit (36) init ("000000000000011100111011111000000000"b), /* lls 28 */ 2 i2 bit (36) init ("000000000000000001111011101000000000"b), /* als 1 */ 2 i3 bit (36) init ("000000000000011010111011111000000000"b); /* lls 26 */ /* DECLARATION OF INTERNAL VARIABLES */ dcl work_offset_inst_ptr ptr; dcl work_occurrence_inst_ptr ptr; dcl element_length_inst_ptr ptr; dcl temp_ptr ptr; dcl work_offset1 fixed bin; dcl work_offset2 fixed bin; dcl buff1 (1:10) ptr; dcl buff2 (1:10) ptr; dcl buff3 (1:10) ptr; dcl temp_offset_inst_ptr ptr; dcl temp_occurrence_inst_ptr ptr; dcl temp_offset_inst bit (36); dcl temp_occurrence_inst bit (36); /**************************************************/ /* START OF EXECUTION */ /* INTERNAL PROCEDURE */ /* increment_index_data_item */ /**************************************************/ work_offset_inst_ptr = addr (work_offset_inst); work_occurrence_inst_ptr = addr (work_occurrence_inst); element_length_inst_ptr = addr (element_length_inst); input_ptr = addr (buff1 (1)); inst_ptr = addr (buff2 (1)); reloc_ptr = addr (buff3 (1)); /* Generate code to increment the work occurrence number by one. */ work_occurrence_inst_ptr -> inst_struc_basic.fill1_op = aos_op; call cobol_emit (work_occurrence_inst_ptr, null (), 1); /* Get the A and Q registers */ register_struc.what_reg = 3; /* A AND Q */ register_struc.lock = 0; register_struc.contains = 0; call cobol_register$load (addr (register_struc)); /* Load the element length into the A register. */ element_length_inst_ptr -> inst_struc_basic.fill1_op = lda_op; call cobol_emit (element_length_inst_ptr, null (), 1); /* Add the contents of the A register to the byte offset in temporary storage. */ work_offset_inst_ptr -> inst_struc_basic.fill1_op = asa_op; call cobol_emit (work_offset_inst_ptr, null (), 1); /* At this point, code has been generated to increment the occurrence number by one, and the byte offset by the stored element length. */ /* Allocate 6 bytes on an even word boundary on the stack to receive the index data item format information. */ call cobol_alloc$stack (6, 2, work_offset1); /* Convert the word offset to a byte offset. */ work_offset1 = work_offset1 * 4; /* Calculate the byte offset of the occurrence number bytes of the temporary index data item. */ work_offset2 = work_offset1 + 4; /* Get the basic, non-eis address of the byte offset and occurrence number bytes. */ temp_offset_inst_ptr = addr (temp_offset_inst); temp_occurrence_inst_ptr = addr (temp_occurrence_inst); input_struc_basic.type = 1; /* basic, non-eis */ input_struc_basic.operand_no = 0; input_struc_basic.segno = 1000; /* stack */ input_struc_basic.char_offset = work_offset1; call cobol_addr (input_ptr, temp_offset_inst_ptr, reloc_ptr); input_struc_basic.char_offset = work_offset2; call cobol_addr (input_ptr, temp_occurrence_inst_ptr, reloc_ptr); /* Generate an instruction to load the stored offset into the Q. */ work_offset_inst_ptr -> inst_struc_basic.fill1_op = ldq_op; call cobol_emit (work_offset_inst_ptr, null (), 1); /* Emit a stream of code to expand the offset and insert the junk bits. The expanded result winds up in the A register. */ /* The emitted code stream is: lls 12 als 1 lls 8 als 1 lls 8 als 1 lls 8 */ call cobol_emit (addr (get_offset_code), null (), 7); /* Emit code to store the A register into the temporary storage set aside for the offset part of the index data item. */ temp_offset_inst_ptr -> inst_struc_basic.fill1_op = sta_op; call cobol_emit (temp_offset_inst_ptr, null (), 1); /* Emit code to load the Q register with the occurrence number from the temporary. */ work_occurrence_inst_ptr -> inst_struc_basic.fill1_op = ldq_op; call cobol_emit (work_occurrence_inst_ptr, null (), 1); /* Emit a stream of code to expand the occurrence number and insert the junk bits. The expanded result winds up in the 2 leftmost bytes of the a register. */ /* The emitted stream is: lls 28 als 1 lls 26 */ /* Emit the stream of code. */ call cobol_emit (addr (get_occurrence_code), null (), 3); /* Emit code to store the A register into the temporary storage for the occurrence number part of the index data item. */ temp_occurrence_inst_ptr -> inst_struc_basic.fill1_op = sta_op; call cobol_emit (temp_occurrence_inst_ptr, null (), 1); /* At this point, we have generated code to expand the offset and occurrence number and store these values in index data item format in the six bytes of storage in the stack. */ /* Now we must generate code to move the temporary index stat item from the stack into the index data item being incremented during the execution of the SEARCH. */ /* Make a copy of the input index data item token. */ temp_ptr = null (); call cobol_make_type9$copy (temp_ptr, index_data_item_ptr); /* Modify the copy so that it describes the six byte temporary in the stack. */ temp_ptr -> data_name.seg_num = 1000; /* stack */ temp_ptr -> data_name.offset = work_offset1; temp_ptr -> data_name.subscripted = "0"b; /* Build the input structure to the addressability utility. */ input_struc.type = 5; /* EIS, 2 operands input; instruction and 2 descriptors returned. */ input_struc.operand_no = 2; input_struc.lock = 0; input_struc.operand.token_ptr (1) = temp_ptr; input_struc.operand.send_receive (1) = 0; /* Sending */ input_struc.operand.size_sw (1) = 0; input_struc.operand.token_ptr (2) = index_data_item_ptr; input_struc.operand.send_receive (2) = 1; /* Receiving */ input_struc.operand.size_sw (2) = 0; call cobol_addr (input_ptr, inst_ptr, reloc_ptr); /* Set the mlr opcode into the instruction */ inst_struc.inst.fill1_op = mlr_op; /* Emit the instruction to move the temp index data item image to the index data item being incremented. */ call cobol_emit (inst_ptr, reloc_ptr, 3); end increment_index_data_item; format2_search: proc; /* DECLARATION OF AN ENTRY ARRAY. */ dcl fmt2_eos_proc (1:3) entry init (fmt2_eos1, fmt2_eos2, fmt2_eos3); /**************************************************/ /* START OF EXECUTION */ /* INTERNAL PROCEDURE */ /* format2_search */ /**************************************************/ call fmt2_eos_proc (in_token.token_ptr (in_token.n) -> end_stmt.e); fmt2_eos1: proc; /* Reserve a tag to be defined at the first instruction generated to test whether the index name is within limits. */ check_index_tag = cobol_$next_tag; /* Reserve a tag to be defined at the first instruction generated for the WHEN clause. */ next_when_tag = check_index_tag + 1; /* Reserve a tag to be defined at the first instruction of the next cobol statement. (The statement following this SEARCH statement. ) */ next_stmt_tag = check_index_tag + 2; next_compare_tag = cobol_$next_tag + 3; /* Update the next tag counter in MCOBOL external data segment. */ cobol_$next_tag = cobol_$next_tag + 4; dn_ptr = in_token.token_ptr (2); if data_name.occurs_do then do; call cobol_read_rand (1, data_name.do_rec, com2_ptr); call cobol_read_rand (3, odo_rec.descr, dn_ptr); do_ptr = dn_ptr; end; else do_ptr = null (); /* Generate code to initialize the index name being used in the search. */ /* Set up the in_token structure for a call to the SET generator. */ in_token_ptr = addr (work_in_token (1)); in_token.token_ptr (1) = save_in_token_ptr -> in_token.token_ptr (1); /* Reserved word SEARCH */ in_token.token_ptr (2) = save_in_token_ptr -> in_token.token_ptr (3); /* Index name token. */ in_token.token_ptr (3) = addr (numeric_lit_1); in_token.token_ptr (4) = addr (set_eos_token); in_token.n = 4; set_eos_token.a = "000"b; /* Format 1 set. */ set_eos_token.e = 1; /* One operand to be set. */ /* Call the SET generator. */ call cobol_set_gen (in_token_ptr); /* Generate code to determine whether the index is at its maximum value. */ eos_ptr = save_in_token_ptr -> in_token.token_ptr (save_in_token_ptr -> in_token.n); /* Build an in_token structure for calling cobol_compare_gen. */ in_token.token_ptr (1) = null (); /* in_token.token_ptr(2) points to the index name already. (It was set above when the in_token structure was built for the call to cobol_set_gen. */ in_token.token_ptr (3) = addr (work_numeric_lit); in_token.token_ptr (4) = addr (compare_eos_token); in_token.n = 4; /* Convert the maximum value that can be contained in the index name to a character string literal. */ work_numeric_lit.places_left = work_numeric_lit.places; compare_eos_token.e = 102; /* COMPARE EQUAL */ compare_eos_token.i = "000"b; /* Transfer if equal to the tag in end_stmt.h. */ if end_stmt.b = "1"b then do; /* AT END CLAUSE present. */ /* Reserve a tag to be defined at the first instruction generated for the AT END clause. */ at_end_tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; compare_eos_token.h = at_end_tag; /* Transfer to the at_end_tag when the index equals its maximum value. */ end; /* AT END CLAUSE present. */ else compare_eos_token.h = next_stmt_tag; /* Transfer to the next Cobol statement when the index equals its maximum value. */ if do_ptr ^= null () then do; in_token.token_ptr (3) = do_ptr; call bin_to_char (fixed (in_token.token_ptr (2) -> index_name.max, 17), work_numeric_lit.literal, work_numeric_lit.places); work_numeric_lit.places_left = work_numeric_lit.places; compare_eos_token.e = 113; /* greater compare */ call cobol_compare_gen (in_token_ptr); compare_eos_token.e = 102; end; /* Generate an instruction to transfer to the next_when_tag. */ call cobol_emit (addr (tra_inst), null (), 1); /* Make a tag reference at the instruction just emitted. */ call cobol_make_tagref (next_when_tag, cobol_$text_wd_off - 1, null ()); /* Define the check_index_tag at the next instruction to be generated. */ call cobol_define_tag (check_index_tag); call bin_to_char (fixed (in_token.token_ptr (2) -> index_name.max, 17), work_numeric_lit.literal, work_numeric_lit.places); work_numeric_lit.places_left = work_numeric_lit.places; if do_ptr ^= null () then do; call cobol_compare_gen (in_token_ptr); in_token.token_ptr (3) = addr (work_numeric_lit); end; call cobol_compare_gen (in_token_ptr); /* Generate code to increment the index by 1. */ in_token.token_ptr (1) = save_in_token_ptr -> in_token.token_ptr (1); /* in_token.token_ptr(2) still points to the index name token. */ in_token.token_ptr (3) = addr (numeric_lit_1); in_token.token_ptr (4) = addr (set_eos_token); set_eos_token.a = "001"b; /* FOR AT 2 SET */ set_eos_token.b = "0"b; /* UP */ call cobol_set_gen (in_token_ptr); /* Check to see if AT END clause was present. If present, generate a transfer to the WHEN clause. */ if end_stmt.b = "1"b then do; /* AT END CLAUSE present. */ /* Generate a transfer. */ call cobol_emit (addr (tra_inst), null (), 1); /* Make a reference to the next_when_tag at the instruction just emitted. */ call cobol_make_tagref (next_when_tag, cobol_$text_wd_off - 1, null ()); /* Define the at_end_tag at the next instruction location. */ call cobol_define_tag (at_end_tag); end; /* AT END CLAUSE present. */ else /* Define the next_when tag at the next instruction location. */ call cobol_define_tag (next_when_tag); end fmt2_eos1; fmt2_eos2: proc; if in_token.token_ptr (in_token.n) -> end_stmt.b = "1"b then /* This is the lase EOS2 in the SEARCH statement. */ /* Define the next_stmt_tag. */ call cobol_define_tag (next_stmt_tag); else do; /* This is not the last EOS2 in the SEARCH statement. */ /* Generate code to transfer to the next_stmt_tag. */ call cobol_emit (addr (tra_inst), null (), 1); /* Make a tagref at the instruction just emitted. */ call cobol_make_tagref (next_stmt_tag, cobol_$text_wd_off - 1, null ()); /* Define the next_when_tag at the next instruction location. */ call cobol_define_tag (next_when_tag); end; /* This is not the last EOS2 in the SEARCH statement. */ end fmt2_eos2; fmt2_eos3: proc; dcl ix fixed bin; dcl iy fixed bin; /* Build an in_token structure for calling cobol_compare_gen. */ in_token_ptr = addr (work_in_token); in_token.n = 3; in_token.token_ptr (3) = addr (compare_eos_token); compare_eos_token.h = check_index_tag; compare_eos_token.i = "010"b; /* Transfer if not equal to check_index_tag. */ ix = 1; iy = 1; /* Generate code to compare two operands and transfer to check_index_tag if not equal. */ /* Process each pair of operands in the input token structure. */ do while (save_in_token_ptr -> in_token.token_ptr (iy) -> end_stmt.type ^= rtc_eos); /* Get a pointer to the first operand of the comparison. */ in_token.token_ptr (1) = save_in_token_ptr -> in_token.token_ptr (ix); /* Get a pointer to the second operand of the comparison. Note that the token for the reserved word EQUAL is in in_token.token_ptr(ix+ 1) */ in_token.token_ptr (2) = save_in_token_ptr -> in_token.token_ptr (ix + 2); call cobol_compare_gen (in_token_ptr); /* Increment the index to reference the pointer following the 2nd operand. */ ix = ix + 4; iy = ix - 1; end; end fmt2_eos3; end format2_search; bin_to_char: proc (bin_value, ret_string, ret_length); dcl bin_value fixed bin; dcl ret_string char (*); dcl ret_length fixed bin (15); dcl digit fixed bin; dcl work_string char (20); dcl work_value fixed bin; dcl iy fixed bin; dcl char_value (0:9) char (1) int static init ("0", "1", "2", "3", "4", "5", "6", "7", "8", "9"); if bin_value = 0 then do; /* INput value is zero. */ ret_length = 1; substr (ret_string, 1, 1) = char_value (0); end; /* Input value is zero. */ else do; /* Input value non-zero. */ work_value = bin_value; iy = 0; do while (work_value ^= 0); iy = iy + 1; digit = mod (work_value, 10); work_value = work_value / 10; substr (work_string, 21 - iy, 1) = char_value (digit); end; substr (ret_string, 1, iy) = substr (work_string, 21 - iy, iy); ret_length = iy; end; end bin_to_char; /**************************************************/ /* INCLUDE FILES USED BY THIS PROCEDURE */ /**************************************************/ /***** Declaration for builtin function *****/ dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index) builtin; /***** End of declaration for builtin function *****/ %include cobol_type19; %include cobol_type30; %include cobol_type10; %include cobol_type9; %include cobol_in_token; %include cobol_record_types; %include cobol_; %include cobol_occurs_ext; %include cobol_addr_tokens; %include cobol_odo_rec; /**************************************************/ /* END OF EXTERNAL PROCEDURE */ /* cobol_search_gen */ /**************************************************/ end cobol_search_gen;  cobol_section_gen.pl1 05/24/89 1042.8rew 05/24/89 0832.6 85248 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_section_gen.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /*{*/ /* format: style3 */ cobol_section_gen: proc (in_token_ptr); /* The procedure cobol_section_gen performs the following functions: 1. Generates an end-of-perform range alterable GO and incre- ments perform_para_index by 1 if the paragraph being ter- minated is at the end of a perform range as determined by examining para_eop_flag ((1, it is; 0, it is not). 2. Generates the number of end-of-perform range alterable GO's dictated by the value of sect_eop_flag; 0, 1, or 2. 3. Determines if the section being entered is at the end of a PERFORM statement and/or SORT statement perform range by examining perform_list.perf.proc_num(perform_para_index). If it is not, sect_eop_flag is set to 0. If it is, sect_ eop_flag is set to 1, perform_sect_index is set equal to perform_para_index, and perform_para_index is incremented by 1. Then, perform_list.perf.proc_num(perform_para_index) is examined, using the new value of perform_para_index, to determine if the section has been referenced in both a PERFORM and a SORT statement (in this case there are two entries for the procedure in perform_list - the first for PERFORM statements and the second for SORT statements). If there is no second entry in perform_list for the section, then no further action is taken. If there is, then sect_ eop_flag and perform_para_index are both incremented by 1. 4. Determines if the section being entered must be initialized prior to its execution as a result of an implicit transfer of control from the preceding section. (Initialization is required if the section being entered has a COBOL segment number different from that of its predessor and if the seg- ment of which the section is a member is independent and contains alterable GO's.) If initialization is required, code is generated to cause execution of an initialization sequence for the segment prior to execution of code gener- ated to implement the statements that comprise the section. 5. Associates the section's procedure number with the text location into which the first instruction emitted by the next generator called will be placed (this is the first free text location following the code, if any, generated by cobol_section_gen). U__s_a_g_e:_ declare cobol_section_gen entry (ptr); call cobol_section_gen (in_token_ptr); */ %include cobol_in_token; /* G__e_n_e_r_a_t_e_d_C__o_d_e:_ Two sequences of code may be generated by cobol_section_gen. They are as follows; Sequence 1: Implements end-of-perform range alterable GO's. Sequence 2: Implements the transfer of control to and estab- lishes return from the appropriate segment initi- alization code sequence. Sequence 1 - lda target_An tra 0,al where: target_An is a 36-bit variable allocated in the program's COBOL data segment. Each target_An, for n = 1, 2, 3, ..., is uniquely associated with the procedure at whose end these instructions are generated. Sequence 2 - eaa 2,ic tra s_init_relp,ic where: s_init_relp is the offset, relative to the instruction in which it appears, of the first instruction of the initial- ization code sequence provided for the COBOL segment of which the section being entered is a part. Note that following the execution of the eaa instruction bits 0 - 17 inc. of the a-register (au) will contain the address of the instruction following the tra instruction i.e. the address of the first instruction generated to implement the statements contained in the section being entered. Since the terminal instruction of the initialization sequences for independent segments (which do not otherwise employ the a-register) is tra 0,au, control will be transferred to this instruction. */ /* D__a_t_a:_ % include cobol_; Items in cobol_$incl.pl1 used (u) and/or set (s) by cobol_section_gen; cobol_ptr (u) para_eop_flag (u/s) perform_list_ptr (u) perform_para_index (u/s) perform_sect_index (u/s) priority_no (u/s) sect_eop_flag (u/s) seg_init_list_ptr (u) text_wd_off (u) */ %include cobol_perform_altgo; %include cobol_perform_list; %include cobol_seg_init_list; %include cobol_type7; dcl proc_no fixed bin, /* Tag number of the section being entered. */ index fixed bin; /* Do loop index. */ /* Instruction pair to transfer control to and establish return from independent segment initialization code sequence. */ dcl seg_init_tra_inst_pr (4) bit (18) unaligned static init ("000000000000000010"b, "110011101000000100"b, "000000000000000000"b, "111001000000000100"b); /* The instructions produced are: eaa 2,ic, tra 0,1c */ /* P__r_o_c_e_d_u_r_e_s_C__a_l_l_e_d:_ */ dcl cobol_addr entry (ptr, ptr, ptr), cobol_define_tag entry (fixed bin), cobol_emit entry (ptr, ptr, fixed bin), cobol_make_tagref entry (fixed bin, fixed bin, ptr), cobol_register$load entry (ptr); /* B__u_i_l_t-__i_n_F__u_n_c_t_i_o_n_s_U__s_e_d:_ */ dcl addr builtin, null builtin, substr builtin, unspec builtin; /*}*/ %include cobol_; start: /* Get procedure (tag) number of section being entered. */ proc_no = in_token.token_ptr (1) -> proc_def.proc_num; /* "PERFORM" Functions */ if cobol_$perform_list_ptr ^= null then do; /* Paragraph terminated at end-of-perform range? */ if cobol_$para_eop_flag ^= 0 then /* Insert alterable GO */ do; call cobol_register$load (addr (register_request)); input_struc_basic.segno = perform_list.perf.target_a_segno (cobol_$perform_para_index); input_struc_basic.char_offset = perform_list.perf.target_a_offset (cobol_$perform_para_index); call cobol_addr (addr (input_struc_basic), addr (prfrm_altgo_inst_pr), null); call cobol_emit (addr (prfrm_altgo_inst_pr), null, 2); call cobol_define_tag (perform_list.perf.int_tag_no (cobol_$perform_para_index)); cobol_$para_eop_flag = 0; cobol_$perform_para_index = cobol_$perform_para_index + 1; end; /* Section terminated at end-of-perform range? */ do index = 1 to cobol_$sect_eop_flag; call cobol_register$load (addr (register_request)); input_struc_basic.segno = perform_list.perf.target_a_segno (cobol_$perform_sect_index); input_struc_basic.char_offset = perform_list.perf.target_a_offset (cobol_$perform_sect_index); call cobol_addr (addr (input_struc_basic), addr (prfrm_altgo_inst_pr), null); call cobol_emit (addr (prfrm_altgo_inst_pr), null, 2); if in_token.token_ptr (1) -> proc_def.declarative_proc = "0"b then call cobol_define_tag (perform_list.perf.int_tag_no (cobol_$perform_sect_index)); else perform_list.perf.int_tag_no (cobol_$perform_sect_index) = -perform_list.perf.int_tag_no (cobol_$perform_sect_index); cobol_$perform_sect_index = cobol_$perform_sect_index + 1; end; /* Section entered at end-of-perform range? */ cobol_$sect_eop_flag = 0; cobol_$perform_sect_index = cobol_$perform_para_index; if cobol_$perform_para_index <= perform_list.n then do while (proc_no = perform_list.perf.proc_num (cobol_$perform_para_index)); cobol_$sect_eop_flag = cobol_$sect_eop_flag + 1; cobol_$perform_para_index = cobol_$perform_para_index + 1; end; end; /* Initialize segment containing section entered. */ if cobol_$seg_init_list_ptr ^= null then do; if unspec (in_token.token_ptr (1) -> proc_def.priority) ^= substr (unspec (cobol_$priority_no), 19, 18) then do; substr (unspec (cobol_$priority_no), 19, 18) = unspec (in_token.token_ptr (1) -> proc_def.priority); if cobol_$priority_no > 49 then do index = 1 to seg_init_list.n; if seg_init_list.seg.priority (index) = cobol_$priority_no then do; call cobol_emit (addr (seg_init_tra_inst_pr), null, 2); call cobol_make_tagref (seg_init_list.seg.int_tag_no (index), cobol_$text_wd_off - 1, null); goto end_do_loop; end; end; end_do_loop: end; end; /* Associate procedure number with next location in text. */ call cobol_define_tag (proc_no); return; end cobol_section_gen;  cobol_seginit_gen.pl1 05/24/89 1042.8rew 05/24/89 0830.0 147312 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_seginit_gen.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 5/19/76 by Bob Chang to interface with prologue_gen changes. */ /* Modified on 5/18/76 by Bob Chang to interface with prologue_gen changes. */ /*{*/ /* format: style3 */ cobol_seginit_gen: proc (fxs_locno, last_decl_proc); /* The procedure cobol_seginit_gen is called by cobol_gen_driver_ only if data and/or segment initialization is required for the program being compiled. The primary function of cobol_seginit_gen is to generate code sequences to initialize explicit and implicit al- terable GO's, if any, contained in the program. (An explicit al- terable GO is one resulting from the implementation of an ALTER statement. An implicit alterable GO is one introduced at the end of a procedure which terminates a perform range.) In addition, however, this procedure always updates stat.call_cnt from zero to one to indicate that initialization has been accomplished and generates the transfer instruction at the end of the data/fixed- segment initialization code sequence necessary to transfer con- trol to the first instruction generated to implement the first non-DECLARATIVE statement of the program. U__s_a_g_e:_ declare cobol_seginit_gen entry (fixed bin, fixed bin); call cobol_seginit_gen (fxs_locno, last_decl_proc); */ declare fxs_locno fixed bin parameter, last_decl_proc fixed bin parameter; /* fxs_locno is the compile time offset of the first instruc- tion of the first executable statement of the pro- gram. (Input) last_decl_proc is the procedure (tag) number of the last section of the DECLARATIVES. (Input) */ /* G__e_n_e_r_a_t_e_d_C__o_d_e:_ The following code is generated to initialize implicit alterable GO's (alterable GO's introduced at the end of perform ranges): eaxn t_relp,ic sxln target_a_PNn where: n designates an index reqister number. Any may be used but two is reserved and used in the generated code. t_relp is the offset, relative to the instruction in which it appears, of an instruction defined by a tag uni- quely associated with target_a_PNn. (Usually, this is the instruction immediately following the end-of- perform range alterable GO.) target_a_PNn is a 36-bit variable allocated in the program's COBOL data segment. It is uniquely associated with procedure-name-n which has been specified in a PER- FORM statement as defining the end of a PERFORM range. Explicit Alterable GO's Format 1 GO's with optional procedure-name present Code Sequence 1, below, is generated if the COBOL segment con- taining procedure-name-2 does not require initialization before control is transferred to procedure-name-2. Code Sequence 2, be- low, is generated if initialization is required. Initialization is not required if procedure-name-1 and procedure-name-2 are in the same COBOL segment, if procedure-name-2 is in a fixed COBOL segment, or if procedure-name-2 is in an independent COBOL seg- ment which contains no alterable GO's. The term "alterable GO" is used here to designate a GO that is referenced by an ALTER statement. Procedure_name_1 is the procedure which conatins the the GO statement and procedure-name-2 is the procedure to which control is to be transferred. Sequence 1 eaxn pn2_relp,ic sxln target_a_pn1 Sequence 2 eaxn s(pn2)_init_relp,ic sxln target_a_pn1 eaxn pn2_relp,ic stxn target_a_pn1 where: n designates an index reqister number. Any may be used but two is reserved and used in the genera- ted code. pn2_relp is the offset, relative to the instruction in which it appears, of the first instruction of procedure-name-2. target_a_pn1 is a 36-bit variable, allocated in COBOL data on a word boundary and uniquely associated with procedure-name-1 (see alter_list), which con- tains transfer address data. s(pn2)_init_relp is the offset, relative to the instruction in which it appears, of the first instruction of a code sequence provided to initialize the alter- able GO's in the segment containing procedure- name-2. Format 1 GO's with optional procedure-name absent The following code initializes target_a_pn1 such that control is transferred to the first instruction of a call to cobol_error_ which informs the user at execution time that no procedure has been named to which control can be transferred. eaxn er_relp,ic sxln target_a_pn1 where: er_relp is the offset, relative to the instruction in which it appears, of the first instruction of a call to cobol_error_. target_a_pn1 is a 36-bit variable, allocated in the program's COBOL data segment and uniquely associated with the procedure containing the GO statement being initia- lized (see alter_list), which contains transfer ad- dress data. Transfer instructions An unconditional transfer instruction is generated at the end of each initialization sequence. The following instruction is gen- erated at the end of the initialization sequence for fixed seg- ments and is preceded by an instruction to update stat.call_cnt from 0 to 1 (see fixed_static.incl.pl1 for a description of the stat structure): aos stat.call_cnt tra 0,0 where: fxs_relp is the offset, relative to the transfer instruction, of the first instruction of the first executable statement of the program. The following instruction is generated at the end of each code sequence generated to initialize independent COBOL segments: tra 0,au Prior to making the transfer to the initialization sequence, reg- ister a, bits(0-17), will have been loaded with the offset within the Text Section of the instruction to which control is to be transferred subsequent to initialization. */ /* R__e_l_o_c_a_t_i_o_n_I__n_f_o_r_m_a_t_i_o_n:_ All instructions generated directly by cobol_seginit_gen except those referencing data in the Linkage Section of the Object Seg- ment are non-relocatable. The relocation code generated for each half of each non-relocatable instruction is "00000"b. Instructions generated directly by cobol_seginit_gen that reference data in the Linkage Section i.e. those instructions in the code sequence of the form pr4| are relocatable with respect to their left hand half and non-re- locatable with respect to thier right hand half. The relocation code generated for the relocatable half of each such instruction is "11001"b, when the operand referenced by the instruction is internal data, and "10100"b, when it is a link. In either case, the code generated for the non_relocatable half is "00000"b. */ /* D__a_t_a:_ % include cobol_; Items in cobol_$incl.pl1 used (u) and/or set (s) by cobol_seginit_gen: cobol_ptr (u) text_wd_off (u) perform_list_ptr (u) seg_init_flag (u) seg_init_list_ptr (u) */ %include cobol_seg_init_list; %include cobol_perform_list; /* Input structure for cobol_register$load */ declare 1 register_request aligned static, 2 requested_reg fixed bin aligned init (12), 2 assigned_reg bit (4) aligned, 2 lock fixed bin aligned init (1), 2 reg_set_now fixed bin aligned, 2 use_code fixed bin aligned init (0), 2 adjust_ptr_addr fixed bin aligned init (0), 2 content_ptr ptr aligned init (null), 2 literal_content bit (36) aligned init ((36)"0"b); /* requested_reg is a code designating the register requested; 0 - a- or q- or any index-register 1 - a-register 2 - q-register 3 - a- and q-register 4 - a- or q-register 5 - any index-register 1n - index-register n assigned_reg is a code designating the register assigned. It has no significance if a specific register is requested. lock indicates locking requirements; 1 requests that the register be locked. reg_set_now not applicable for use_code = 0. use_code specifies how the register is to be used by the requester; 0 signifies that such information is not meaningful for register optimization. adjust_ptr_addr inserted to make evident that since all pointers must be allocated on even word boundaries, the pl1 compiler will allocate structures containing pointers and all pointers therein on even word boundaries leaving "gaps" where necessary. content_ptr not applicable for use_code = 0. literal_content not applicable for use_code = 0. */ /* Input structure for cobol_addr */ declare 1 target aligned static, 2 type fixed bin aligned init (1), 2 operand_no fixed bin aligned init (0), 2 lock fixed bin aligned init (0), 2 segno fixed bin aligned, 2 char_offset fixed bin (24) aligned, 2 send_receive fixed bin aligned init (0); /* type indicates type of addressing requested. Type 1 indicates basic; i.e., data to be addressed is specified by segno and char_offset. operand_no not applicable to type 1. lock indicates lock requirements for registers used in addressing; 0 - do not lock registers used. 1 - lock registers used. segno is the compiler designation of the segment in which the data to be addressed is located. char_offset is the character offset within segno of the data to be addressed. send_receive indicates whether the data being addressed is a sending or receiving field for the instruction whose address field is being set; 0 indicates sending. */ /* Equate tag token */ declare 1 equate_tags aligned static, 2 size fixed bin aligned init (0), 2 line fixed bin aligned init (0), 2 column fixed bin aligned init (0), 2 type fixed bin aligned init (31), 2 filler1 fixed bin aligned init (0), 2 equated_tag fixed bin aligned, 2 true_tag fixed bin aligned, 2 filler2 fixed bin aligned init (0), 2 filler3 fixed bin aligned init (0), 2 filler4 bit (16) aligned init ((16)"0"b); /* where: type is the token type. equated_tag is the tag number to be equated to true_tag. true_tag is a tag which has been or will be associated with an instruction location in the text. No other fields of the token are used. */ /* Instruction declarations */ dcl init_perf_go (4) bit (18) unaligned static init ("000000000000000000"b, "110010010000000100"b, /* eax2 0,ic */ "000000000000000000"b, "100100010001000000"b); /* sxl2 pr0|0 */ dcl init_alt_go (8) bit (18) unaligned static init ("000000000000000000"b, "110010010000000100"b, /* eax2 0,ic */ "000000000000000000"b, "100100010001000000"b, /* sxl2 pr0|0 */ "000000000000000000"b, "110010010000000100"b, /* eax2 0,ic */ "000000000000000000"b, "111100010001000000"b); /* stx2 pr0|0 */ dcl tra_ic_inst (4) bit (18) unaligned static init ("100000000000001110"b, "000101100001000000"b, /* aos pr4|14 */ "000000000000000000"b, "111001000000001000"b); /* tra 0,0 */ /* -5-18-76-*/ dcl tra_a_inst (2) bit (18) unaligned static init ("000000000000000000"b, "111001000000000001"b); /* tra 0,au */ dcl tra_ic_reloc (4) bit (5) aligned static init ("11001"b, "00000"b, "00000"b, "00000"b); /* Local data */ declare index fixed bin, /* Do loop index. */ jndex fixed bin, /* Do loop index. */ init_ptr ptr, /* Ptr to initialization data in */ /* seg_init_list. */ no_inst fixed bin, /* No of instructions emitted. */ tag fixed bin, /* Tag number. */ temp fixed bin; /* Temporary qualtity. */ /* Based structure used to extract initialization data from */ /* seg_init_list. */ declare 1 init_data aligned based (init_ptr), 2 target_a_segno fixed bin aligned, 2 target_a_offset fixed bin aligned, 2 pn2 fixed bin unaligned, 2 init fixed bin unaligned; /* P__r_o_c_e_d_u_r_e_s_C__a_l_l_e_d:_ */ dcl cobol_addr entry (ptr, ptr, ptr), cobol_define_tag entry (fixed bin), cobol_emit entry (ptr, ptr, fixed bin), cobol_equate_tag entry (ptr), cobol_make_tagref entry (fixed bin, fixed bin, ptr), cobol_register$load entry (ptr), cobol_reset_r$in_line entry; /* B__u_i_l_t-__i_n_F__u_n_c_t_i_o_n_s_U__s_e_d:_ */ dcl addr builtin, addrel builtin, null builtin, substr builtin, unspec builtin; /*}*/ %include cobol_; start: /* Initialize alterable GO's in fixed segments. */ if cobol_$seg_init_flag ^= 0 then do; call cobol_register$load (addr (register_request)); /* Initialize end-of-perform range alterable GO's in all segments. */ if cobol_$perform_list_ptr ^= null then do; if last_decl_proc ^= 0 then do; equate_tags.true_tag = last_decl_proc; do index = 1 to perform_list.n while (perform_list.perf.proc_num (index) < last_decl_proc); if perform_list.perf.int_tag_no (index) < 0 then do; perform_list.perf.int_tag_no (index) = -perform_list.perf.int_tag_no (index); equate_tags.equated_tag = perform_list.perf.int_tag_no (index); call cobol_equate_tag (addr (equate_tags)); end; end; end; do index = 1 to perform_list.n; target.segno = perform_list.perf.target_a_segno (index); target.char_offset = perform_list.perf.target_a_offset (index); call cobol_addr (addr (target), addr (init_perf_go (3)), null); call cobol_emit (addr (init_perf_go), null, 2); call cobol_make_tagref (perform_list.perf.int_tag_no (index), cobol_$text_wd_off - 2, null); end; call cobol_reset_r$in_line; end; /* Initialize explicit GO's. */ if cobol_$seg_init_list_ptr ^= null then do; if seg_init_list.seg.priority (1) = 0 then do; index = 1; call initialize_go; index = 2; end; end; end; else index = 1; /* Generate transfer to first executable instruction of program. */ temp = fxs_locno - cobol_$text_wd_off - 1; call cobol_emit (addr (tra_ic_inst), addr (tra_ic_reloc), 2); /* Initialize alterable GO's in independent segments. */ if cobol_$seg_init_list_ptr ^= null then do index = index to seg_init_list.n; call cobol_define_tag (seg_init_list.seg.int_tag_no (index)); call initialize_go; call cobol_emit (addr (tra_a_inst), null, 1); end; return; initialize_go: proc; do jndex = 0 to seg_init_list.seg.no_gos (index) - 1; init_ptr = addrel (seg_init_list.seg.init_ptr (index), 3 * jndex); target.segno = init_data.target_a_segno; target.char_offset = init_data.target_a_offset; call cobol_addr (addr (target), addr (init_alt_go (3)), null); if init_data.init = 0 then no_inst = 2; else do; init_alt_go (7) = init_alt_go (3); tag = init_data.init; call cobol_make_tagref (tag, cobol_$text_wd_off, addr (init_alt_go)); no_inst = 4; end; call cobol_emit (addr (init_alt_go), null, no_inst); tag = init_data.pn2; call cobol_make_tagref (tag, cobol_$text_wd_off - 2, null); end; return; end initialize_go; end cobol_seginit_gen;  cobol_send_gen.pl1 05/24/89 1042.8rew 05/24/89 0832.6 102294 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_send_gen.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 10/02/77 by Bob Chang to fix the bug for mcs_ocdp. */ /* Modified on 05/05/77 by Bob Chang to fix the bug for mnemonic name hof. */ /* Modified on 04/12/77 by Bob Chang to fix the bug for end_indicator. */ /* Modified on 03/24/77 by Bob Chang to implement communication send verb. */ /* Created as a stub on 11/18/76 by ORN */ /* format: style3 */ cobol_send_gen: proc (in_token_ptr); /* Declaration for static data. */ dcl 1 pr_struc static, 2 what_ptr fixed bin init (2), 2 pointer_no bit (3), 2 lock fixed bin init (0), 2 switch fixed bin init (0); dcl 1 alpha_type9 static, 2 header (4) fixed bin init (112, 0, 0, 9), 2 repl_ptr (2) ptr init ((2) null ()), 2 fill1 bit (108) init (""b), 2 file_key_info, 3 fb1 (3) fixed bin init (0, 0, 0), 3 size fixed bin init (0), 3 fb2 (2) fixed bin init (0, 0), 3 flags1 bit (36) init ("000000100100000000010000000100000000"b), 3 flags2 bit (36) init (""b), 3 seg fixed bin init (0), 3 off fixed bin, 2 fill2 (7) fixed bin init (0, 0, 0, 0, 0, 0, 0); dcl 1 type19_move static, 2 header (4) fixed bin init (38, 0, 0, 19), 2 verb fixed bin init (0), 2 e fixed bin init (1), 2 h fixed bin init (0), 2 ij (2) fixed bin init (0, 0), 2 abcdfgk bit (16) init ("0000000000000000"b); dcl 1 mpout static, 2 n fixed bin init (4), 2 pt1 ptr, 2 pt2 ptr, 2 pt3 ptr, 2 pt4 ptr; dcl 1 fb17_type9 static, 2 header (4) fixed bin init (112, 0, 0, 9), 2 repl_ptr (2) ptr init ((2) null ()), 2 fill1 bit (108) init (""b), 2 file_key_info, 3 fb1 (3) fixed bin init (0, 0, 0), 3 size fixed bin init (2), 3 places_left fixed bin init (4), 3 places_right fixed bin init (0), 3 flags1 bit (36) init ("000000100100010001000000000000000000"b), 3 flags2 bit (36) init (""b), 3 seg fixed bin init (0), 3 off fixed bin, 2 fill2 (7) fixed bin init (0, 0, 0, 0, 0, 0, 0); dcl inst_seq (20) bit (18) unaligned static init ("110000000000000000"b, "010101010001000000"b, /* spri2 pr6|offset */ "000000000000000000"b, "010011101000000111"b, /* lda 0,dl */ "110000000000000000"b, "111101101001000000"b, /* sta pr6|offset */ "110000000000000000"b, "100101000001000000"b, /* stz pr6|offset */ "110000000000000000"b, "010011100001000000"b, /* szn pr6|offset */ "000000000000000000"b, "110000000000000100"b, /* tze 0,ic */ "000000000000000000"b, "010011101000000100"b, /* lda 0,ic */ "000000000000000000"b, "010011111001000000"b, /* ldaq pr0|offset */ "000000000000000000"b, "010011101000000011"b, /* lda 0,du */ "110000000000000000"b, "111101111001000000"b); /* staq pr6|offset */ dcl inst_buff bit (36), inst_char char (4) based (addr (inst_buff)); dcl btd (6) bit (18) static init ("000000000001000000"b, "011000001101000000"b, /* btd */ "110000000000000000"b, "000000000000000100"b, "110000000000000000"b, "000011000000000100"b); /* Automatic data */ dcl null_ptr ptr static init (null), null_ptr_char char (8) based (addr (null_ptr)), conoff fixed bin, temp_char char (4), temp_char1 char (1), temp_bit1 bit (9) based (addr (temp_char1)), con_flag fixed bin, stoff fixed bin, dn_ptr ptr, name_ptr ptr, in_op fixed bin, char_conv char (9), dec_conv fixed dec (6), temp fixed bin; /* External procedure */ dcl cobol_call_op entry (fixed bin, fixed bin), cobol_reg_manager$after_op entry (fixed bin, fixed bin), cobol_move_gen entry (ptr), cobol_pool entry (char (*), fixed bin, fixed bin), cobol_pool$search_op entry (char (*), fixed bin, fixed bin, fixed bin), cobol_pointer_register$priority entry (fixed bin, fixed bin, bit (3)), cobol_emit entry (ptr, ptr, fixed bin), cobol_define_tag entry (fixed bin), cobol_make_tagref entry (fixed bin, fixed bin, ptr), cobol_set_pr entry (ptr, ptr), cobol_get_size entry (ptr, fixed bin, fixed bin); start: mpout.pt1 = in_token.token_ptr (1); mpout.pt4 = addr (type19_move); eos_ptr = in_token.token_ptr (in_token.n); /* Generate epp2 instruction for communication token. */ cdtoken_ptr = in_token.token_ptr (2); alpha_type9.seg = cdtoken.cd_seg; alpha_type9.off = cdtoken.cd_off - 20; call cobol_set_pr (addr (pr_struc), addr (alpha_type9)); /* Allocate 12 words in stack frame for parameters */ stoff = 74; /* Communication stack frame from pr6|74 */ /* Store cd_token address. */ substr (inst_seq (1), 4, 15) = substr (unspec (stoff), 22, 15); call cobol_emit (addr (inst_seq (1)), null, 1); /* Set up parameter for message type. */ temp = stoff + 4; if end_stmt.a = "000"b | end_stmt.b then do; /* Generate epp2 instruction for receiving data item. */ dn_ptr = in_token.token_ptr (3); call cobol_set_pr (addr (pr_struc), dn_ptr); /* Store into stack frame. */ temp = stoff + 2; substr (inst_seq (1), 4, 15) = substr (unspec (temp), 22, 15); call cobol_emit (addr (inst_seq (1)), null, 1); if ^data_name.variable_length then do; dec_conv = dec (data_name.item_length); char_conv = char (dec_conv); temp_char = substr (char_conv, 6, 4); con_flag = 1; end; else do; temp = stoff + 16; call cobol_get_size (dn_ptr, temp, 0); /* Generate btd instruction */ substr (btd (3), 4, 15) = substr (unspec (temp), 22, 15); temp = stoff + 4; substr (btd (5), 4, 15) = substr (unspec (temp), 22, 15); call cobol_emit (addr (btd), null, 3); con_flag = 0; end; end; else do; call cobol_pool$search_op (null_ptr_char, 2, conoff, in_op); substr (inst_seq (15), 4, 15) = substr (unspec (conoff), 22, 15); call cobol_emit (addr (inst_seq (15)), null, 1); /* Store into stack frame. */ temp = stoff + 2; substr (inst_seq (19), 4, 15) = substr (unspec (temp), 22, 15); call cobol_emit (addr (inst_seq (19)), null, 1); temp_char = "9999"; con_flag = 1; end; if con_flag = 1 then do; call cobol_pool (temp_char, 1, conoff); temp = -cobol_$text_wd_off - conoff; inst_seq (13) = substr (unspec (temp), 19, 18); temp = stoff + 4; substr (inst_seq (5), 4, 15) = substr (unspec (temp), 22, 15); call cobol_emit (addr (inst_seq (13)), null, 1); call cobol_emit (addr (inst_seq (5)), null, 1); end; if end_stmt.a = "000"b then do; temp = stoff + 5; substr (inst_seq (7), 4, 15) = substr (unspec (temp), 22, 15); call cobol_emit (addr (inst_seq (7)), null, 1); temp = stoff + 6; substr (inst_seq (7), 4, 15) = substr (unspec (temp), 22, 15); call cobol_emit (addr (inst_seq (7)), null, 1); end; else do; if end_stmt.d = "00"b then do; if end_stmt.b then mpout.pt2 = in_token.token_ptr (4); else mpout.pt2 = in_token.token_ptr (3); mpout.pt3 = addr (alpha_type9); alpha_type9.size = 1; alpha_type9.seg = 1000; alpha_type9.off = (stoff + 5) * 4; call cobol_move_gen (addr (mpout)); end; else do; dec_conv = dec (fixed (end_stmt.d)); char_conv = char (dec_conv); temp_char1 = substr (char_conv, 9, 1); substr (inst_seq (17), 1, 9) = temp_bit1; call cobol_emit (addr (inst_seq (17)), null, 1); temp = stoff + 5; substr (inst_seq (5), 4, 15) = substr (unspec (temp), 22, 15); call cobol_emit (addr (inst_seq (5)), null, 1); end; if end_stmt.f = "00"b then do; /* no linage */ temp = stoff + 6; substr (inst_seq (7), 4, 15) = substr (unspec (temp), 22, 15); call cobol_emit (addr (inst_seq (7)), null, 1); end; else do; dn_ptr = in_token.token_ptr (in_token.n - 1); if data_name.type = 9 then do; /* line count in identifier */ mpout.pt2 = dn_ptr; mpout.pt3 = addr (fb17_type9); fb17_type9.seg = 1000; fb17_type9.off = (stoff + 6) * 4 + 2; call cobol_move_gen (addr (mpout)); end; if end_stmt.f = "01"b then substr (inst_buff, 1, 9) = "000000001"b; else substr (inst_buff, 1, 9) = "000000010"b; if data_name.type = 9 then do; /* ldx2 type of line control */ substr (inst_buff, 19, 18) = "010010010000000011"b; substr (inst_buff, 10, 9) = "000000001"b; call cobol_emit (addr (inst_buff), null, 1); /* stx2 pr6|stoff+6 */ temp = stoff + 6; substr (inst_buff, 1, 3) = "110"b; substr (inst_buff, 4, 15) = substr (unspec (temp), 22, 15); substr (inst_buff, 19, 18) = "111100010001000000"b; call cobol_emit (addr (inst_buff), null, 1); end; else do; if data_name.type = 2 then do; /* advancing integer lines. */ substr (inst_buff, 10, 9) = "000000001"b; temp = fixed ( substr (dn_ptr -> numeric_lit.literal, 1, dn_ptr -> numeric_lit.places_left)); substr (inst_buff, 19, 18) = substr (unspec (temp), 19, 18); end; else if data_name.type = 1 & dn_ptr -> reserved_word.key = reswd_PAGE then /* advancing page. */ substr (inst_buff, 10, 27) = "000000010000000000000000001"b; else if data_name.type = 17 then do; if dn_ptr -> mnemonic_name.iw_key < 227 & dn_ptr -> mnemonic_name.iw_key > 210 then do; /* slew, channel number mnemonic name. */ substr (inst_buff, 10, 9) = "000000011"b; temp = dn_ptr -> mnemonic_name.iw_key - 210; substr (inst_buff, 19, 18) = substr (unspec (temp), 19, 18); end; else substr (inst_buff, 10, 27) = "000000010000000000000000001"b; end; call cobol_pool (inst_char, 1, conoff); temp = -cobol_$text_wd_off - conoff; inst_seq (13) = substr (unspec (temp), 19, 18); temp = stoff + 6; substr (inst_seq (5), 4, 15) = substr (unspec (temp), 22, 15); call cobol_emit (addr (inst_seq (13)), null, 1); call cobol_emit (addr (inst_seq (5)), null, 1); end; end; end; /* Call cobol_operators_ */ call cobol_call_op (73, 0); call cobol_reg_manager$after_op (73, 0); exit: return; /***** Declaration for builtin function *****/ dcl (substr, mod, binary, fixed, addr, addrel, rel, char, string, unspec, null, index) builtin; /***** End of declaration for builtin function *****/ %include cobol_in_token; %include cobol_; %include cobol_type19; %include cobol_type9; %include cobol_type13; %include cobol_type1; %include cobol_reswd_values; %include cobol_type2; %include cobol_type17; end cobol_send_gen;  cobol_set_fsbptr.pl1 05/24/89 1042.8rew 05/24/89 0832.6 30492 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_set_fsbptr.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 1/25/77 by Bob Chang to implement profile option. */ /* Modified on 11/11/76 by Bob Chang to change mft into file_table. */ /* Modified since Version 2.0. */ /* format: style3 */ cobol_set_fsbptr: proc (ft_ptr); dcl ft_ptr ptr; dcl 1 basic_struct static, 2 type fixed bin init (1), 2 operand_no fixed bin init (0), 2 lock fixed bin init (0), 2 seg fixed bin, 2 offset fixed bin, 2 send_receive fixed bin init (0); dcl instr (3) bit (36); dcl reloc (6) bit (5) aligned; dcl instr_ptr ptr; dcl reloc_ptr ptr; /* fixup directive for link, used when profile options is specified. */ dcl 1 fixup_directive aligned static, 2 operation bit (1) unal init ("0"b), 2 type bit (4) unal init ("1111"b), 2 reserved bit (9) unal init ("000000000"b), 2 location unal, 3 half bit (1) unal init ("0"b), 3 base bit (3) unal init ("001"b), 3 offset fixed bin unal, 2 tag_number fixed bin aligned; dcl epp1 bit (12) static init ("011101001101"b); dcl epp1_indmod bit (18) static init ("011101001101010000"b); dcl utemp fixed bin; dcl i fixed bin; dcl ic fixed bin; dcl cobol_addr entry (ptr, ptr, ptr); dcl cobol_make_fixup entry (ptr); dcl cobol_emit entry (ptr, ptr, fixed bin); /*************************************/ start: instr_ptr = addr (instr); reloc_ptr = addr (reloc); do i = 1 to 6; reloc (i) = ""b; end; ic = 1; if file_table.fsb.seg < 0 then do; /* external file - link to fsb */ utemp = -file_table.fsb.seg; instr (1) = "100"b || substr (unspec (utemp), 22, 15) || epp1_indmod; if file_table.fsb.off ^= 0 then do; instr (2) = "001"b || substr (unspec (file_table.fsb.off), 22, 15) || epp1; ic = 2; end; reloc (1) = "10100"b; end; else do; /* internal file - fsb in cobol data segment */ instr (1) = (18)"0"b || epp1_indmod; basic_struct.seg = file_table.fsb.seg; basic_struct.offset = file_table.fsb.off; call cobol_addr (addr (basic_struct), instr_ptr, reloc_ptr); end; if fixed_common.options.profile then do; fixup_directive.location.offset = cobol_$text_wd_off; call cobol_make_fixup (addr (fixup_directive)); end; call cobol_emit (instr_ptr, reloc_ptr, ic); exit: return; /*************************************/ %include cobol_file_table; %include cobol_ext_; %include cobol_fixed_common; %include cobol_; end cobol_set_fsbptr;  cobol_set_gen.pl1 05/24/89 1042.8rew 05/24/89 0832.6 210366 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_set_gen.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 04/05/80/ by FCH, [4.2-1], fix out-of range checking, BUG430(TR4533) */ /* Modified since Version 4.2 */ /*{*/ /* format: style3 */ cobol_set_gen: proc (in_token_ptr); dcl opno fixed bin; dcl ok_tag fixed bin; dcl retry_tag fixed bin; dcl slen fixed bin; dcl (i, j) fixed bin; dcl temp fixed bin; dcl value fixed bin; dcl litoff fixed bin; dcl temp_numlit char (18); dcl char4 char (4) based; dcl char8 char (8) based; dcl done bit (1); dcl ocsw bit (1); dcl subsw bit (1); dcl iptr ptr; dcl s1p ptr; dcl r1p ptr; dcl s2p ptr; dcl r2p ptr; dcl dn_ptr ptr; dcl name_ptr ptr; dcl rterror_SET_RANGE fixed bin static options (constant) init (61); dcl A fixed bin static options (constant) init (1); dcl Q fixed bin static options (constant) init (2); dcl AQ fixed bin static options (constant) init (3); dcl X5 fixed bin static options (constant) init (15); dcl ADQ bit (11) static options (constant) init ("00011111000"b); dcl CWL bit (11) static options (constant) init ("00100100100"b); dcl LDA bit (11) static options (constant) init ("01001110100"b); dcl LDQ bit (11) static options (constant) init ("01001111000"b); dcl LCQ bit (11) static options (constant) init ("01101111000"b); dcl LDAQ bit (11) static options (constant) init ("01001111100"b); dcl STAQ bit (11) static options (constant) init ("11110111100"b); dcl STA bit (11) static options (constant) init ("11110110100"b); dcl STQ bit (11) static options (constant) init ("11110111000"b); dcl STBQ bit (11) static options (constant) init ("10110101000"b); dcl LXL5 bit (11) static options (constant) init ("11101010100"b); dcl LDX5 bit (11) static options (constant) init ("01001010100"b); dcl STX5 bit (11) static options (constant) init ("11110010100"b); dcl AOS bit (11) static options (constant) init ("00010110000"b); dcl STBQ_MASK bit (6) static options (constant) init ("110000"b); dcl set_seq (2) bit (36) static options (constant) init ("000000000000000001010011101000000111"b, /* lda 1,dl */ "100000000000001010011101010001010000"b); /*epp2 pr4|12,**/ dcl set_reloc (4) bit (5) aligned static options (constant) init ("00000"b, "00000"b, "11001"b, "00000"b); dcl QRS_instr bit (36) static options (constant) init ("000000000000010010111011010000000000"b); /* qrs 22 */ dcl QLS_instr bit (36) static options (constant) init ("000000000000010010111011110000000000"b); /* qls 22 */ dcl ANQ1_instr bit (36) static options (constant) init ("000000000000000000011111110000000011"b); /* anq 0,du */ dcl qls_instr bit (36) static init ("000000000000000000111011110000000000"b); /* qls X */ dcl sta_instr bit (36) static init ("010000000000000000111101101001000000"b); /* sta 2|x */ dcl stz_instr bit (36) static init ("010000000000000000100101000001000000"b); /* stz 2|x */ dcl mpy_instr bit (36) static init ("000000000000000000100000010000000111"b); /* mpy X,dl */ dcl tze_instr bit (36) static init ("000000000000000000110000000000000100"b); /* tze X */ dcl ldaq_ic_instr bit (36) static init ("000000000000000000010011111000000100"b); /* ldaq X,ic */ dcl ldq_ic_instr bit (36) static init ("000000000000000000010011110000000100"b); /* ldq X,ic */ dcl ldq_dl_instr bit (36) static init ("000000000000000000010011110000000111"b); /* ldq X,dl */ dcl lcq_ic_instr bit (36) static init ("000000000000000000011011110000000100"b); /* lcq X,ic */ dcl lcq_dl_instr bit (36) static init ("000000000000000000011011110000000111"b); /* lcq X,dl */ dcl reloc (2) bit (5); dcl 1 instr, 2 address, 3 regno bit (3), 3 offset bit (15), 2 op bit (11), 2 reg bit (1), 2 tag bit (12); dcl 1 out_token, 2 n fixed bin, 2 fill fixed bin, 2 ptr (4) ptr; dcl 1 pool, 2 num1 fixed bin (35), 2 num2 fixed bin (35); dcl 1 add_eos static options (constant), 2 size fixed bin init (10), 2 line fixed bin init (0), 2 column fixed bin init (0), 2 type fixed bin init (19), 2 verb fixed bin init (2), 2 e fixed bin init (1), 2 h fixed bin init (1), 2 i fixed bin init (0), 2 j fixed bin init (0), 2 a bit (3) init (""b), 2 b bit (1) init (""b), 2 c bit (1) init (""b), 2 d bit (2) init (""b), 2 f bit (2) init (""b), 2 g bit (2) init (""b), 2 k bit (5) init (""b); dcl 1 subtract_eos static options (constant), 2 size fixed bin init (10), 2 line fixed bin init (0), 2 column fixed bin init (0), 2 type fixed bin init (19), 2 verb fixed bin init (11), 2 e fixed bin init (1), 2 h fixed bin init (1), 2 i fixed bin init (0), 2 j fixed bin init (0), 2 a bit (3) init (""b), 2 b bit (1) init (""b), 2 c bit (1) init (""b), 2 d bit (2) init (""b), 2 f bit (2) init (""b), 2 g bit (2) init (""b), 2 k bit (5) init (""b); dcl 1 move_eos static options (constant), 2 size fixed bin init (10), 2 line fixed bin init (0), 2 column fixed bin init (0), 2 type fixed bin init (19), 2 verb fixed bin init (18), 2 e fixed bin init (1), 2 h fixed bin init (0), 2 i fixed bin init (0), 2 j fixed bin init (0), 2 a bit (3) init (""b), 2 b bit (1) init (""b), 2 c bit (1) init (""b), 2 d bit (2) init (""b), 2 f bit (2) init (""b), 2 g bit (2) init (""b), 2 k bit (5) init (""b); dcl 1 reg aligned static, 2 num fixed bin, 2 assigned_reg bit (4), 2 lock fixed bin init (1), 2 reg_set_now fixed bin, 2 use_code fixed bin init (0), 2 content_ptr ptr init (null ()), 2 literal_content bit (36) init (""b); dcl 1 ss1 aligned static, 2 type fixed bin init (1), 2 operand_no fixed bin init (0), 2 lock fixed bin init (0), 2 segno fixed bin, 2 offset fixed bin (24), 2 send_receive fixed bin init (0); dcl 1 rs1 aligned static, 2 type fixed bin init (1), 2 operand_no fixed bin init (0), 2 lock fixed bin init (0), 2 segno fixed bin, 2 offset fixed bin (24), 2 send_receive fixed bin init (1); dcl 1 ss2 aligned static, 2 type fixed bin init (2), 2 operand_no fixed bin init (1), 2 lock fixed bin init (0), 2 operand, 3 token_ptr ptr init (null ()), 3 send_receive fixed bin init (0), 3 ic_mod fixed bin, 3 size_sw fixed bin init (1); dcl 1 rs2 aligned static, 2 type fixed bin init (2), 2 operand_no fixed bin init (1), 2 lock fixed bin init (0), 2 operand, 3 token_ptr ptr init (null ()), 3 send_receive fixed bin init (1), 3 ic_mod fixed bin, 3 size_sw fixed bin init (1); declare 1 ptr_register_request aligned static, 2 what_pointer fixed bin aligned init (2), 2 assigned_ptr fixed bin aligned, 2 lock fixed bin aligned init (1), 2 switch fixed bin aligned init (0), 2 segno fixed bin aligned init (0), 2 offset fixed bin aligned init (0), 2 reset fixed bin aligned; dcl cobol_pool entry (char (*), fixed bin, fixed bin); dcl cobol_addr entry (ptr, ptr, ptr); dcl cobol_emit entry (ptr, ptr, fixed bin); dcl cobol_register$load entry (ptr); dcl cobol_register$release entry (ptr); dcl cobol_pointer_register$get entry (ptr); dcl cobol_pointer_register$priority entry (fixed bin, fixed bin, bit (3)); dcl cobol_make_type9$long_bin entry (ptr, fixed bin, fixed bin (24)); dcl cobol_move_gen entry (ptr); dcl cobol_add_gen entry (ptr); dcl cobol_subtract_gen entry (ptr); dcl cobol_define_tag entry (fixed bin); dcl cobol_make_tagref entry (fixed bin, fixed bin, ptr); dcl cobol_gen_error entry (fixed bin, fixed bin); dcl addr builtin, binary builtin, null builtin, substr builtin, unspec builtin, fixed builtin; /*************************************/ start: ocsw = fixed_common.options.oc; eos_ptr = in_token.token_ptr (in_token.n); opno = end_stmt.e; dn_ptr = in_token.token_ptr (opno + 2); s1p = addr (ss1); r1p = addr (rs1); s2p = addr (ss2); r2p = addr (rs2); go to format (binary (end_stmt.a)); /*************************************/ format (0): /* set {IN | IDN | ID} to {IN | IDN | ID | LIT} */ start0: if data_name.type = 10 then do; /* set x to IN */ ind_ptr = dn_ptr; ss1.segno = index_name.seg_num; ss1.offset = index_name.offset; slen = index_name.struc_length; do i = 1 to opno; dn_ptr = in_token.token_ptr (i + 1); if data_name.type = 10 then do; /* set IN to IN */ ind_ptr = dn_ptr; rs1.segno = index_name.seg_num; rs1.offset = index_name.offset + 4; if ocsw then call oc_start; if slen = index_name.struc_length then do; /* equal element lengths */ call addr_emit (s1p, LDAQ); call reg_lock (AQ); rs1.offset = rs1.offset - 4; call addr_emit (r1p, STAQ); call reg_unlock (AQ); end; else do; /* unequal element lengths */ ss1.offset = ss1.offset + 4; call addr_emit (s1p, LDQ); ss1.offset = ss1.offset - 4; call reg_lock (AQ); ; call addr_emit (r1p, STQ); call mpy; call adj_emit (-1, STQ); call reg_unlock (AQ); end; if ocsw then call oc_finish; end; else if data_name.type = 9 then if data_name.usage_index then do; /* set IDN to IN */ rs2.token_ptr = dn_ptr; call addr_emit (s1p, LDA); call adj_emit (1, LXL5); call reg_lock (A); call reg_lock (X5); call addr_emit (r2p, STA); call adj_emit (1, STX5); call reg_unlock (A); call reg_unlock (X5); end; else do; /* set ID to IN */ out_token.n = 4; out_token.ptr (1) = in_token.token_ptr (1); out_token.ptr (2) = null (); out_token.ptr (3) = dn_ptr; out_token.ptr (4) = addr (move_eos); call cobol_make_type9$long_bin (out_token.ptr (2), ss1.segno, ss1.offset + 4); call cobol_move_gen (addr (out_token)); end; end; end; else if data_name.type = 9 then if data_name.usage_index then do; /* set x to IDN */ ss2.token_ptr = dn_ptr; do i = 1 to opno; dn_ptr = in_token.token_ptr (i + 1); if data_name.type = 10 then do; /* set IN to IDN */ ind_ptr = dn_ptr; rs1.segno = index_name.seg_num; rs1.offset = index_name.offset; if ocsw then call oc_start; call addr_emit (s2p, LDAQ); call reg_lock (AQ); call cobol_emit (addr (QRS_instr), null (), 1); call addr_emit (r1p, STAQ); call reg_unlock (AQ); if ocsw then do; call oc_finish; call oc_finish_idn; end; end; else do; /* set IDN to IDN */ rs2.token_ptr = dn_ptr; if data_name.subscripted then do; /* can't use STBQ instruction */ call addr_emit (s2p, LDA); call adj_emit (1, LDX5); call reg_lock (A); call reg_lock (X5); call addr_emit (r2p, STA); call adj_emit (1, STX5); call reg_unlock (A); call reg_unlock (X5); end; else do; call addr_emit (s2p, LDAQ); call reg_lock (AQ); call addr_emit (r2p, STA); instr.tag = STBQ_MASK; call adj_emit (1, STBQ); call reg_unlock (AQ); end; end; end; end; else if (data_name.bin_18 & ^data_name.subscripted) /* set IN to ID(short binary) */ | data_name.bin_36 then do; /* set to ID(long binary) */ ss2.token_ptr = dn_ptr; do i = 1 to opno; ind_ptr = in_token.token_ptr (i + 1); rs1.segno = index_name.seg_num; rs1.offset = index_name.offset + 4; if ocsw then call oc_start; call addr_emit (s2p, LDQ); call reg_lock (Q); if data_name.bin_18 then do; if mod (data_name.offset, 4) ^= 0 & ^data_name.linkage_section then call cobol_emit (addr (QLS_instr), null (), 1); call cobol_emit (addr (QRS_instr), null (), 1); end; call addr_emit (r1p, STQ); call mpy; call adj_emit (-1, STQ); call reg_unlock (Q); ; if ocsw then call oc_finish; end; end; else do; /* set IN to ID(general) */ out_token.n = 4; out_token.ptr = in_token.token_ptr (1); out_token.ptr (2) = dn_ptr; out_token.ptr (4) = addr (move_eos); do i = 1 to opno; ind_ptr = in_token.token_ptr (i + 1); rs1.segno = index_name.seg_num; rs1.offset = index_name.offset + 4; if ocsw then call oc_start; out_token.ptr (3) = null (); call cobol_make_type9$long_bin (out_token.ptr (3), rs1.segno, rs1.offset); call cobol_move_gen (addr (out_token)); call addr_emit (r1p, LDQ); call reg_lock (Q); call mpy; call adj_emit (-1, STQ); call reg_unlock (Q); if ocsw then call oc_finish; end; end; else do; /* set IN to LIT */ nlit_ptr = dn_ptr; temp_numlit = (18)"0"; substr (temp_numlit, 19 - numeric_lit.places_left, numeric_lit.places) = numeric_lit.literal; pool.num2 = fixed (temp_numlit); if pool.num2 = 0 then call oc_unconditional; else do i = 1 to opno; ind_ptr = in_token.token_ptr (i + 1); rs1.segno = index_name.seg_num; rs1.offset = index_name.offset; /*[4.2-1]*/ if pool.num2 < 1 | pool.num2 > index_name.max then call oc_unconditional; else do; pool.num1 = pool.num2 * index_name.struc_length; call cobol_pool (addr (pool) -> char8, 2, litoff); temp = -(cobol_$text_wd_off + litoff); substr (ldaq_ic_instr, 1, 18) = substr (unspec (temp), 19, 18); call cobol_emit (addr (ldaq_ic_instr), null (), 1); call reg_lock (AQ); call addr_emit (r1p, STAQ); call reg_unlock (AQ); ; end; end; end; return; /*************************************/ format (1): /* set IN {up | down} {ID | LIT} */ start1: dn_ptr = in_token.token_ptr (opno + 2); if data_name.type = 9 then do; if (data_name.bin_18 & ^data_name.subscripted) /* set IN up | down ID(short binary) */ | data_name.bin_36 then do; /* set IN up | down ID(long binary) */ ss2.token_ptr = dn_ptr; do i = 1 to opno; ind_ptr = in_token.token_ptr (i + 1); rs1.segno = index_name.seg_num; rs1.offset = index_name.offset + 4; if ocsw then call oc_start; if end_stmt.b then call addr_emit (s2p, LCQ); /* DOWN */ else call addr_emit (s2p, LDQ); /* UP */ call reg_lock (Q); if data_name.bin_18 then do; if mod (data_name.offset, 4) ^= 0 & ^data_name.linkage_section then call cobol_emit (addr (QLS_instr), null (), 1); call cobol_emit (addr (QRS_instr), null (), 1); end; call addr_emit (r1p, ADQ); call adj_emit (0, STQ); call mpy; call adj_emit (-1, STQ); call reg_unlock (Q); if ocsw then call oc_finish; end; end; else do; /* set IN up | down ID(general) */ out_token.n = 4; out_token.ptr (1) = in_token.token_ptr (1); out_token.ptr (2) = dn_ptr; do i = 1 to opno; ind_ptr = in_token.token_ptr (i + 1); rs1.segno = index_name.seg_num; rs1.offset = index_name.offset + 4; if ocsw then call oc_start; out_token.ptr (3) = null (); call cobol_make_type9$long_bin (out_token.ptr (3), rs1.segno, rs1.offset); if end_stmt.b then do; /* DOWN */ out_token.ptr (4) = addr (subtract_eos); call cobol_subtract_gen (addr (out_token)); end; else do; out_token.ptr (4) = addr (add_eos); call cobol_add_gen (addr (out_token)); end; call addr_emit (r1p, LDQ); call reg_lock (Q); call mpy; call adj_emit (-1, STQ); call reg_unlock (Q); if ocsw then call oc_finish; end; end; end; else do; /* set IN up | down LIT */ nlit_ptr = dn_ptr; temp_numlit = (18)"0"; substr (temp_numlit, 19 - numeric_lit.places_left, numeric_lit.places) = numeric_lit.literal; value = fixed (temp_numlit); if numeric_lit.sign = "-" then subsw = ^end_stmt.b; else subsw = end_stmt.b; if value > 1 | subsw then do i = 1 to opno; ind_ptr = in_token.token_ptr (i + 1); rs1.segno = index_name.seg_num; rs1.offset = index_name.offset + 4; if ocsw then call oc_start; if value < 262144 then do; if subsw then do; substr (lcq_dl_instr, 1, 18) = substr (unspec (value), 19, 18); call cobol_emit (addr (lcq_dl_instr), null (), 1); end; else do; substr (ldq_dl_instr, 1, 18) = substr (unspec (value), 19, 18); call cobol_emit (addr (ldq_dl_instr), null (), 1); end; end; else do; call cobol_pool (addr (value) -> char4, 1, litoff); temp = -(cobol_$text_wd_off + litoff); if subsw then do; substr (lcq_ic_instr, 1, 18) = substr (unspec (temp), 19, 18); call cobol_emit (addr (lcq_ic_instr), null (), 1); end; else do; substr (ldq_ic_instr, 1, 18) = substr (unspec (temp), 19, 18); call cobol_emit (addr (ldq_ic_instr), null (), 1); end; end; call reg_lock (Q); call addr_emit (r1p, ADQ); call adj_emit (0, STQ); call mpy; call adj_emit (-1, STQ); call reg_unlock (Q); if ocsw then call oc_finish; end; else if value = 1 then do i = 1 to opno; ind_ptr = in_token.token_ptr (i + 1); rs1.segno = index_name.seg_num; rs1.offset = index_name.offset + 4; if ocsw then call oc_start; call addr_emit (r1p, AOS); if index_name.struc_length = 1 then call adj_emit (-1, AOS); else do; call reg_lock (Q); call adj_emit (0, LDQ); call mpy; call adj_emit (-1, STQ); call reg_unlock (Q); end; if ocsw then call oc_finish; end; end; return; /*************************************/ format (2): start2: call cobol_pointer_register$get (addr (ptr_register_request)); if end_stmt.c = "1"b then do; call cobol_emit (addr (set_seq (1)), addr (set_reloc (1)), 2); string (instr) = sta_instr; end; else do; /* OFF */ call cobol_emit (addr (set_seq (2)), addr (set_reloc (3)), 1); string (instr) = stz_instr; end; do i = 1 to opno; name_ptr = in_token.token_ptr (i + 1); temp = mnemonic_name.iw_key - 1; instr.offset = substr (unspec (temp), 22, 15); call cobol_emit (addr (instr), null (), 1); end; call cobol_pointer_register$priority (2, 0, "010"b); return; /*************************************/ /* INTERNAL PROCEDURES */ adj_emit: proc (n, opcode); dcl n fixed bin; dcl opcode bit (11); start: temp = fixed (instr.offset) + n; instr.offset = substr (unspec (temp), 22, 15); instr.op = opcode; call cobol_emit (addr (instr), null (), 1); return; end adj_emit; addr_emit: proc (struc_ptr, opcode); dcl struc_ptr ptr; dcl opcode bit (11); start: instr.op = opcode; call cobol_addr (struc_ptr, addr (instr), addr (reloc (1))); call cobol_emit (addr (instr), addr (reloc (1)), 1); return; end addr_emit; mpy: proc; dcl n fixed bin (35); start: n = index_name.struc_length; if n ^= 1 then do; done = "0"b; do j = 19 to 36 while (^done); if substr (unspec (n), j, 1) = "1"b then do; if substr (unspec (n), j + 1) = ""b then do; temp = 36 - j; substr (qls_instr, 1, 18) = substr (unspec (temp), 19, 18); iptr = addr (qls_instr); end; else do; substr (mpy_instr, 1, 18) = substr (unspec (n), 19, 18); iptr = addr (mpy_instr); end; done = "1"b; end; end; if ^done then iptr = addr (ANQ1_instr); call cobol_emit (iptr, null (), 1); end; return; end mpy; reg_lock: proc (regno); dcl regno fixed bin; start: reg.num = regno; call cobol_register$load (addr (reg)); return; end reg_lock; reg_unlock: proc (regno); dcl regno fixed bin; start: if regno >= 10 then temp = regno - 2; else temp = regno; reg.assigned_reg = substr (unspec (temp), 33, 4); reg.num = regno; call cobol_register$release (addr (reg)); return; end reg_unlock; oc_start: proc; start: ok_tag = cobol_$next_tag; retry_tag = cobol_$next_tag + 1; cobol_$next_tag = cobol_$next_tag + 2; call cobol_define_tag (retry_tag); return; end oc_start; oc_finish: proc; start: /*[4.2-1]*/ pool.num1 = 1; if pool.num1 = 0 then pool.num1 = 1; pool.num2 = index_name.max; call cobol_pool (addr (pool) -> char8, 2, litoff); temp = -(cobol_$text_wd_off + litoff); substr (ldaq_ic_instr, 1, 18) = substr (unspec (temp), 19, 18); call cobol_emit (addr (ldaq_ic_instr), null (), 1); rs1.offset = index_name.offset + 4; call reg_lock (AQ); call addr_emit (r1p, CWL); call reg_unlock (AQ); call cobol_emit (addr (tze_instr), null (), 1); call cobol_make_tagref (ok_tag, cobol_$text_wd_off - 1, null ()); call cobol_gen_error (rterror_SET_RANGE, retry_tag); call cobol_define_tag (ok_tag); return; end oc_finish; oc_finish_idn: proc; start: ok_tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; if index_name.struc_length ^= 1 then do; /* otherwise AQ will be already loaded */ pool.num1 = pool.num1 * index_name.struc_length; pool.num2 = pool.num2 * index_name.struc_length; call cobol_pool (addr (pool) -> char8, 2, litoff); temp = -(cobol_$text_wd_off + litoff); substr (ldaq_ic_instr, 1, 18) = substr (unspec (temp), 19, 18); call cobol_emit (addr (ldaq_ic_instr), null (), 1); end; call reg_lock (AQ); rs1.offset = rs1.offset - 4; call addr_emit (r1p, CWL); call reg_unlock (AQ); call cobol_emit (addr (tze_instr), null (), 1); call cobol_make_tagref (ok_tag, cobol_$text_wd_off - 1, null ()); call cobol_gen_error (rterror_SET_RANGE, retry_tag); call cobol_define_tag (ok_tag); return; end oc_finish_idn; oc_unconditional: proc; retry_tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_define_tag (retry_tag); /* no escape */ call cobol_gen_error (rterror_SET_RANGE, retry_tag); return; end oc_unconditional; /*************************************/ /* INCLUDE FILES */ %include cobol_in_token; %include cobol_type2; %include cobol_type9; %include cobol_type10; %include cobol_type17; %include cobol_type19; %include cobol_fixed_common; %include cobol_; %include cobol_ext_; end cobol_set_gen;  cobol_set_pr.pl1 05/24/89 1042.8rew 05/24/89 0832.5 74853 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_set_pr.pl1 Added Trace statements. END HISTORY COMMENTS */ /* Modified on 09/23/83 by FCH, [5.2...], trace added */ /* Modified on 09/25/80 by FCH, [4.4-1], values in array epp_instr were being changed, BUG445 */ /* Modified on 01/12/78 by FCH, [3.0-1], a9db_instr changed from static to automatic */ /* Changes made since Version 3.0 */ /* format: style3 */ cobol_set_pr: proc (struc_ptr, dn_ptr); dcl struc_ptr ptr; /* pts to a structure identical to that used by cobol_pointer_register */ dcl dn_ptr ptr; /* pts to a type 9 token */ /* This routine is passed an input structure identical to that passed to cobol_pointer_register$get and additionally a pointer to a type 9 token. The pointer register specified in the structure is set to point to the data item described by the type 9 token (to the byte). The switch field in the input structure should be set to 0. If it is not, a call to this routine is no different than a call to cobol_pointer_register$get, i.e. the ptr to the type 9 token is ignored and the segno and offset fields in the structure are used instead. */ dcl 1 structure based (struc_ptr), 2 what_pointer fixed bin, 2 pointer_no bit (3), 2 lock fixed bin, 2 switch fixed bin, 2 segno fixed bin, 2 offset fixed bin (24), 2 reset fixed bin; /* what_pointer specifies the pointer register to be obtained. (input) 0-7 - get this pointer register. 10 - get any temporary pointer register. pointer_no is the register that is assigned, in the range 0-7. (output) lock can have the following values. (input) 0 - do not change the lock or unlock status of this pointer. 1 - lock the pointer register. 2 - unlock all pointer registers. 3 - unlock all pointer registers and A register and Q register and all index registers. switch has the following values. (input) 0 - the dn_ptr is to be used to set the pointer register rather than segno and offset fields which follow. In this case the value is not meaningful for register optimization. Segment number and offset are meaningless. 1 - a segment number and word offset are supplied. 2 - a segment number and character offset are supplied segno is the segment number. (input) values recognized are: 2 - cobol data. 1000 - stack. 3000 - constants. 3002 - multics linkage. 4000 - pl1 operators. 2nnnn - cobol linkage. -n - link in multics linkage. offset is the word or character offset (depending on switch). Any case when the offset is meaningless a 0 value must be used. If a character offset is provided only the word portion is meaningful. (input) reset specifies that the caller has requested a register that must have a preset value. For example a preset register to cobol data or the pointer to pl/1 operators (likely). This is only of interest to callers who request a specific register (what_pointer = 0-7) Such callers should test reset. If it is 1, a call to cobol_reset_r should be made in order to emit instructions to reload the register to its proper value. /*}*/ dcl 1 addr_struc static, 2 type fixed bin, 2 operand_no fixed bin init (1), 2 lock fixed bin init (0), 2 operand, 3 token_ptr ptr, 3 send_receive fixed bin init (0), 3 ic_mod fixed bin, 3 size_sw fixed bin init (1); /* don't bother with size */ /*[4.4-1]*/ dcl instr bit (36); dcl epp_instr (0:7) bit (36) static init ("000000000000000000011101000000000000"b, "000000000000000000011101001100000000"b, "000000000000000000011101010000000000"b, "000000000000000000011101011100000000"b, "000000000000000000011111000000000000"b, "000000000000000000011111001100000000"b, "000000000000000000011111010000000000"b, "000000000000000000011111011100000000"b) options (constant); dcl a9bd_instr bit (36); /*[3.0-1]*/ dcl omit_sign_instr (2) bit (36) static init ("000000000000000001010010010000000011"b, /* ldx2 1,du */ "010000000000000000101000000101001010"b) /* a9bd pr2|0,2 */ options (constant); dcl reloc (2) bit (5) aligned; dcl reloc_ptr ptr; dcl instr_ptr ptr; dcl addr_struc_ptr ptr; dcl i fixed bin; dcl backup fixed bin; dcl subsw bit (1); dcl omitsw bit (1); dcl cobol_emit entry (ptr, ptr, fixed bin); dcl cobol_addr entry (ptr, ptr, ptr); dcl cobol_pointer_register$get entry (ptr); /***..... dcl cobol_gen_driver_$Tr_Beg entry(char(*));/**/ /***..... dcl cobol_gen_driver_$Tr_End entry(char(*));/**/ /***..... dcl Trace_Bit bit(1) static external;/**/ /***..... dcl Trace_Lev fixed bin static external;/**/ /***..... dcl Trace_Line char(36) static external;/**/ /***..... dcl ioa_ entry options(variable); /**/ /***..... dcl MY_NAME char (12) int static init ("COBOL_SET_PR");/**/ /*************************************/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME);/**/ omitsw = "0"b; go to start; omit_sign: entry (struc_ptr, dn_ptr); /***..... dcl LOCAL_NAME char (10) int static init ("$OMIT_SIGN");/**/ /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME||LOCAL_NAME);/**/ omitsw = "1"b; start: if structure.switch ^= 0 | dn_ptr = null () then do; call cobol_pointer_register$get (struc_ptr); go to pr_done; end; if data_name.subscripted then do; subsw = "1"b; data_name.subscripted = "0"b; occurs_ptr = addrel (dn_ptr, substr (unspec (data_name.occurs_ptr), 17, 18)); backup = 0; do i = 1 to occurs.dimensions; backup = backup + divide (occurs.level.struc_length (i), 2, 35, 0); /* accumulate size of each dimension */ end; data_name.offset = data_name.offset - backup; /* backup to zeroth element */ end; else subsw = "0"b; call cobol_pointer_register$get (struc_ptr); addr_struc.type = 2; addr_struc.operand.token_ptr = dn_ptr; addr_struc_ptr = addr (addr_struc); /*[4.4-1]*/ instr_ptr = addr (instr); /*[4.4-1]*/ instr = epp_instr (fixed (structure.pointer_no, 3)); reloc_ptr = addr (reloc); call cobol_addr (addr_struc_ptr, instr_ptr, reloc_ptr); call cobol_emit (instr_ptr, reloc_ptr, 1); a9bd_instr = "000000000000000000101000000100000000"b; /*[3.0-1]*/ if subsw then do; data_name.subscripted = "1"b; substr (a9bd_instr, 1, 3) = structure.pointer_no; addr_struc.type = 7; instr_ptr = addr (a9bd_instr); call cobol_addr (addr_struc_ptr, instr_ptr, reloc_ptr); call cobol_emit (instr_ptr, reloc_ptr, 1); data_name.offset = data_name.offset + backup; /* readjust offset to base of array */ end; else if mod (data_name.offset, 4) ^= 0 then do; /* non-word-aligned scalar data */ substr (a9bd_instr, 1, 3) = structure.pointer_no; addr_struc.type = 7; instr_ptr = addr (a9bd_instr); call cobol_addr (addr_struc_ptr, instr_ptr, reloc_ptr); call cobol_emit (instr_ptr, reloc_ptr, 1); end; if omitsw then if data_name.sign_separate then call cobol_emit (addr (omit_sign_instr), null (), 2); /* adjust pr */ pr_done: /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(MY_NAME);/**/ return; /*************************************/ /***** Declaration for builtin function *****/ dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index) builtin; /***** End of declaration for builtin function *****/ %include cobol_occurs_ext; %include cobol_type9; %include cobol_; end cobol_set_pr;  cobol_set_type40.pl1 05/24/89 1042.8rew 05/24/89 0832.5 15921 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_set_type40.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Created on 7/23/76 By Bob Chang for the table set up of type40 token. */ /* format: style3 */ cobol_set_type40: proc (alpha_name_ptr); ebcdic: entry (alpha_name_ptr); /* This procedure is called to set up the table for type40 token, */ dcl temp fixed bin, table_char char (512) based (table_ptr), table_ptr ptr; start: temp = fixed (op_con.ascii_ebcdic, 17) - 2048; table_ptr = addrel (cobol_$op_con_ptr, temp); alphabet_name.table = table_char; alphabet_name.segno = 3; alphabet_name.offset = fixed (op_con.ascii_ebcdic, 17) * 4; alphabet_name.iw_key = 12; alphabet_name.hival_char = "ÿ"; alphabet_name.loval_char = ""; return; dcl (addrel, fixed) builtin; %include cobol_; %include cobol_op_con; %include cobol_type40; end cobol_set_type40;  cobol_short_to_longbin.pl1 05/24/89 1042.8rew 05/24/89 0834.6 108108 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_short_to_longbin.pl1 Added Trace statements. END HISTORY COMMENTS */ /* Modified on 11/16/84 by FCH, [5.3...], trace added */ /* Modified on 10/19/84 by FCH, [5.3-1], BUG563(phx18381), new cobol_addr_tokens.incl.pl1 */ /* Modified since Version 5.3 */ /*{*/ /* format: style3 */ cobol_short_to_longbin: proc (source_token_ptr, target_token_ptr); /* This procedure generates code to convert a short binary datum to a long binary datum using the hardware registers. */ /* DECLARATION OF THE PARAMETERS */ dcl source_token_ptr ptr; dcl target_token_ptr ptr; /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION source_token_ptr Pointer to a token that describes the short binary datum to be converted. This token will always be a data name (type 9) token. (input) target_token_ptr Pointer to a token that describes the long binary result of the conversion. The contents of this pointer on input to this procedure vary in meaning, depending on the entry point called. See "Additional Details" below. */ /* Additional Details This procedure has two entry points: 1. $register 2. $temp When called at the "register" entry point, code is generated to convert the short binary to a long binary, and leave the long binary result in a hardware register. (either A orQ). The token poihted at by target_token_ptr will be a register (type100) token. The register containing the long binary value will be locked. If target_token_ptr is null on input, then this procedure chooses the register in which the short binary value is converted. Space for the register token in provided by this procedure. If target_token_ptr is not null on input, then it must point to a register token (type 100) that specifies the register into which the short binary value is to be converted and returned. This procedure acquires (loads) and locks the specified register. When called at the "temp" entry point, code is generated to convert the short binary to a long binary, and store the result into a temporary in the stack. The token pointed at by target_token_ptr on exit will be a data name (type 9) token. If target_token_ptr is null on input, then space for the data name token is provided by this procedure. If target_token_ptr is not null, then it must point to a buffer in which the data name token is to be built. */ /* DECLARATION OF EXTERNAL ENTRIES */ dcl cobol_alloc$stack ext entry (fixed bin, fixed bin, fixed bin (24)); dcl cobol_make_type9$long_bin ext entry (ptr, fixed bin, fixed bin (24)); dcl cobol_addr ext entry (ptr, ptr, ptr); dcl cobol_emit ext entry (ptr, ptr, fixed bin); dcl cobol_register$release ext entry (ptr); dcl cobol_register$load ext entry (ptr); /* DECLARATION OF INTERNAL STATIC DATA */ dcl shift_inst bit (36) int static init ("000000000000010010000000000000000000"b); /* 18 in upper half */ dcl STA bit (10) int static init ("1111011010"b); /* 755(0) */ dcl STQ bit (10) int static init ("1111011100"b); /* 756(0) */ dcl LDA bit (10) int static init ("0100111010"b); /* 235(0) */ dcl LDQ bit (10) int static init ("0100111100"b); /* 236(0) */ dcl ALS bit (10) int static init ("1110111010"b); /* 735(0) */ dcl QLS bit (10) int static init ("1110111100"b); /* 736(0) */ dcl ARS bit (10) int static init ("1110110010"b); /* 731(0) */ dcl QRS bit (10) int static init ("1110110100"b); /* 732(0) */ /* DECLARATION OF INTERNAL VARIABLES */ dcl char_offset fixed bin (24); dcl temp_target_ptr ptr; dcl 1 input_buff aligned, 2 buff (1:10) ptr; dcl 1 inst_buff aligned, 2 buff (1:5) fixed bin; dcl 1 reloc_buff aligned, 2 buff (1:6) bit (5) aligned; dcl 1 register_struc, 2 what_reg fixed bin, 2 reg_no bit (4), 2 lock fixed bin, 2 already_there fixed bin, 2 contains fixed bin, 2 tok_ptr ptr, 2 literal bit (36); dcl shift_inst_ptr ptr; dcl any_register bit (1); dcl dn_ptr ptr; /*************************************************/ /* ENTRY POINT: register */ /**************************************************/ register: entry (source_token_ptr, target_token_ptr); /* This entry point generates code to convert a short binary datum to a long binary datum, and leaves the long binary result in a hardware register. (either A or Q). */ /***..... dcl LOCAL_NAME char (9) int static init ("$REGISTER");/**/ /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME||LOCAL_NAME);/**/ any_register = "0"b; if target_token_ptr = null () then do; /* Create space for the target token. */ target_token_ptr = cobol_$temp_token_ptr; cobol_$temp_token_ptr = addrel (cobol_$temp_token_ptr, 5); any_register = "1"b; end; /* Create space for the target token. */ call common_processing (source_token_ptr, target_token_ptr, any_register); /***************************************************/ /* RETURN POINT: register */ /**************************************************/ clbx: /***..... if Trace_Bit then call cobol_gen_driver_$Tr_End(MY_NAME);/**/ return; /**************************************************/ /* ENTRY POINT: temp */ /**************************************************/ temp: entry (source_token_ptr, target_token_ptr); dcl work_buff (1:5) ptr; /***..... dcl LOCAL_NAME2 char (5) int static init ("$TEMP");/**/ /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME||LOCAL_NAME2);/**/ /* Allocate space in the stack to hold the long binary result of the conversion. */ call cobol_alloc$stack (4, 0, char_offset); /* Make a long binary data name (type 9) token */ call cobol_make_type9$long_bin (target_token_ptr, 1000 /*stack*/, char_offset); temp_target_ptr = addr (work_buff (1)); temp_target_ptr -> cobol_type100.type = 100; any_register = "1"b; call common_processing (source_token_ptr, temp_target_ptr, any_register); /* On returning from common_processing, code has been generated to convert the short binary in a register. The result is in the register, and temp_target_ptr points to the register token that describes the register that contains the result. */ input_ptr = addr (input_buff); inst_ptr = addr (inst_buff); reloc_ptr = addr (reloc_buff); input_struc_basic.type = 1; input_struc_basic.operand_no = 0; input_struc_basic.lock = 0; input_struc_basic.segno = target_token_ptr -> data_name.seg_num; input_struc_basic.char_offset = target_token_ptr -> data_name.offset; /* Get the address of the temp in which to store the long fixed binary. */ call cobol_addr (input_ptr, inst_ptr, reloc_ptr); if register_struc.reg_no = "0001"b /* A register */ then inst_struc_basic.fill1_op = STA; else inst_struc_basic.fill1_op = STQ; /* Emit code to store the register into the temp */ call cobol_emit (inst_ptr, null (), 1); /* Unlock the register */ call cobol_register$release (addr (register_struc)); /**************************************************/ /* RETURN POINT: temp */ /**************************************************/ go to clbx; /**************************************************/ /* INTERNAL PROCEDURE */ /* common_processing */ /**************************************************/ common_processing: proc (source_tok_ptr, target_tok_ptr, any_register_flag); /* This internal procedure generates code to load a short binary value into the A or Q register, and shift it as necessary to extend the sign, and produce an equivalent long binary value in the same register. */ dcl source_tok_ptr ptr; dcl target_tok_ptr ptr; dcl any_register_flag bit (1); /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION source_tok_ptr Pointer to the data name token (type9) for the short binary datum to be converted to long binary. (input) target_tok_ptr Pointer to a register token (type 100) for the register which is to contain the converted value. (input) any_register_flag A flag that indicates whether any register may be used for the conversion, or whether the input register token specifies a particular register to be used. If "1"b, then any register may be used. */ /* Establish addressability to the source of conversion */ input_ptr = addr (input_buff); inst_ptr = addr (inst_buff); reloc_ptr = addr (reloc_buff); input_struc.type = 2; input_struc.operand_no = 1; input_struc.operand.token_ptr (1) = source_tok_ptr; input_struc.operand.size_sw (1) = 0; call cobol_addr (input_ptr, inst_ptr, reloc_ptr); if any_register_flag then register_struc.what_reg = 4; /* A or Q */ else if target_token_ptr -> cobol_type100.register = "0001"b then register_struc.what_reg = 1; /* A */ else register_struc.what_reg = 2; /* Q */ register_struc.lock = 1; /* LOCK the register */ register_struc.contains = 0; call cobol_register$load (addr (register_struc)); if register_struc.reg_no = "0001"b /* A */ then inst_struc_basic.fill1_op = LDA; else inst_struc_basic.fill1_op = LDQ; call cobol_emit (inst_ptr, reloc_ptr, 1); shift_inst_ptr = addr (shift_inst); if mod (source_tok_ptr -> data_name.offset, 4) ^= 0 then do; /* source is half-word aligned, and is presently in A or Qlower */ if register_struc.reg_no = "0001"b then shift_inst_ptr -> inst_struc_basic.fill1_op = ALS; else shift_inst_ptr -> inst_struc_basic.fill1_op = QLS; /* Emit code to shift the short binary to upper of A or Q */ call cobol_emit (shift_inst_ptr, null (), 1); end; /* Source is half-word aligned, and is presently in A or q lower. */ if register_struc.reg_no = "0001"b /* A */ then shift_inst_ptr -> inst_struc_basic.fill1_op = ARS; else shift_inst_ptr -> inst_struc_basic.fill1_op = QRS; /* Emit code to shift the value in upper to lower, extending the sign */ call cobol_emit (shift_inst_ptr, null (), 1); /* Set the register number of the register containing the long binary value into the output token. */ target_tok_ptr -> cobol_type100.register = register_struc.reg_no; target_tok_ptr -> cobol_type100.type = 100; end common_processing; /***..... dcl cobol_gen_driver_$Tr_Beg entry(char(*));/**/ /***..... dcl cobol_gen_driver_$Tr_End entry(char(*));/**/ /***..... dcl Trace_Bit bit(1) static external;/**/ /***..... dcl Trace_Lev fixed bin static external;/**/ /***..... dcl Trace_Line char(36) static external;/**/ /***..... dcl ioa_ entry options(variable); /**/ /***..... dcl MY_NAME char (22) int static init ("COBOL_SHORT_TO_LONGBIN");/**/ /* INCLUDE FILES USED BY THIS PROCEDRUE */ /***** Declaration for builtin function *****/ dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index) builtin; /***** End of declaration for builtin function *****/ %include cobol_type9; %include cobol_addr_tokens; %include cobol_; %include cobol_type100; /**************************************************/ /* END OF EXTERNAL PROCEDURE */ /* cobol_short_to_longbin */ /**************************************************/ end cobol_short_to_longbin;  cobol_sort_gen.pl1 05/24/89 1042.8rew 05/24/89 0832.5 114687 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8072), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8072 cobol_sort_gen.pl1 Correct inverted sorts for some binary data types. END HISTORY COMMENTS */ /* Modified on 10/23/84 by FCH, [5.3-1], BUG564(phx17268), sort can produce inverted results */ /* Modified on 11/15/76 by Bob Chang to cooperate with merge statement for setting static data. */ /* Modified since Version 2.0 */ /* format: style3 */ cobol_sort_gen: proc (in_token_ptr); /* Code and relocation sequences. */ dcl 1 pr_struc static, 2 what_ptr fixed bin, 2 pointer_no bit (3), 2 lock fixed bin init (1), 2 switch fixed bin init (0); dcl 1 alpha_type9 static, 2 header (4) fixed bin init (112, 0, 0, 9), 2 repl_ptr (2) ptr init ((2) null ()), 2 fill1 bit (108) init (""b), 2 file_key_info, 3 fb1 (3) fixed bin init (0, 0, 0), 3 size fixed bin init (0), 3 fb2 (2) fixed bin init (0, 0), 3 flags1 bit (36) init ("000000100100000000010000000100000000"b), 3 flags2 bit (36) init (""b), 3 seg fixed bin init (0), 3 off fixed bin, 2 fill2 (7) fixed bin init (0, 0, 0, 0, 0, 0, 0); dcl 1 alpha_type9_based based, 2 header (4) fixed bin, 2 repl_ptr (2) ptr, 2 fill1 bit (108), 2 file_key_info, 3 fb1 (3) fixed bin, 3 size fixed bin, 3 fb2 (2) fixed bin, 3 flags1 bit (36), 3 flags2 bit (36), 3 seg fixed bin, 3 off fixed bin, 2 fill2 (7) fixed bin; dcl 1 type19 static, 2 header (4) fixed bin init (38, 0, 0, 19), 2 verb fixed bin init (0), 2 e fixed bin init (0), 2 h fixed bin init (0), 2 ij (2) fixed bin init (0, 0), 2 abcdfgk bit (16) init ("0000000000000000"b); dcl instr_seq (2) bit (18) static init ("000000000000000000"b, "111001000000000100"b); /* tra 0,ic */ dcl instr_seq7 (14) bit (18) static init ("000000000000000000"b, "000000000000000000"b, /* descr_relp_offset. */ "000000000000000000"b, "000000000000000000"b, "000000000000000000"b, "110010111000000000"b, /* eax7 0 */ "111000000000101000"b, "011101010001010000"b, /* epp2 pr7|40,* */ "010000000000000110"b, "011101010101010000"b, /* epbp2 pr2|6,* */ "010000000000001010"b, "010111010001000000"b, /* tsp2 pr2|10 */ "000000000000000000"b, "000000000000000000"b); /* no symbol table for compare routine. */ dcl rel_seq7 (14) bit (5) aligned static init ("10000"b, "00000"b, "10101"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b); dcl instr_seq8 (2) bit (18) static init ("000000000000000011"b, "111001000001000000"b); /* tra pr0|3 */ dcl rel_seq8 (2) bit (5) aligned static init ("00000"b, "00000"b); dcl instr_seq11 (10) bit (18) static init ("000000000000000011"b, "110000010000000100"b, /* tnc 3,ic */ "000000100000010011"b, "010011110001000000"b, /* ldq pr0|2048+23 for -2 */ "111000000000000110"b, "111101110001010000"b, /* stq pr7|6,* */ "111000000000000110"b, "000101100001010000"b, /* aos pr7|6,* */ "000000000000000000"b, "111001000000000100"b); /* tra 0,ic */ dcl rel_seq10 (10) bit (5) aligned static init ("00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b); dcl 1 sort_in_token static, 2 n fixed bin init (3), 2 code fixed bin init (0), 2 pt1 ptr, 2 pt2 ptr, 2 pt3 ptr; dcl mvt_ptr ptr, mvt_table char (512) based (mvt_ptr), to_offset fixed bin; /* Automatic data */ dcl workpt2 ptr, /* work pointer */ last_token fixed bin, dn_ptr ptr, /* pointer to the type 9 token */ alpha_ptr ptr, ft_ptr ptr, /* pointer to the type 12 token */ sort_file_ptr ptr, /* pointer to the type 12 token */ sort_gen_ptr ptr, line_temp fixed bin, compare_hold_ic fixed bin, hold_addr bit (18) based, desc_off (3) fixed bin, desc_ptr ptr, object_name_len fixed bin, name_ptr ptr, object_name char (32), first_call fixed bin static init (0), sort_stack_off fixed bin static init (0), /* returned value of cobol_alloc$stack */ temp fixed bin, sort_gen_text_wd_off fixed bin, retry_tag fixed bin, passed_tag fixed bin, passed_tag1 fixed bin, i fixed bin, /* work variable */ linkoff fixed bin; /* word offset of entry point link */ dcl bit18 bit (18) based; /* Procedures Called */ dcl cobol_compare_gen$sort entry (ptr, ptr), cobol_def_util entry (fixed bin, char (32), fixed bin, ptr, fixed bin, ptr, ptr), cobol_sort_util entry (ptr, ptr, char (32), fixed bin), cobol_emit entry (ptr, ptr, fixed bin), cobol_alloc$stack entry (fixed bin, fixed bin, fixed bin), cobol_pointer_register$priority ext entry (fixed bin, fixed bin, bit (3)), cobol_pointer_register$get ext entry (ptr), cobol_call_op entry (fixed bin, fixed bin), cobol_define_tag entry (fixed bin), cobol_reg_manager$after_op entry (fixed bin), cobol_pool entry (char (*), fixed bin, fixed bin), cobol_define_tag_nc entry (fixed bin, fixed bin), cobol_make_tagref entry (fixed bin, fixed bin, ptr), cobol_read_ft entry (fixed bin (15), ptr), cobol_release_gen entry (ptr); start: eos_ptr = in_token.token_ptr (1); sort_file_ptr = in_token.token_ptr (2); desc_ptr = addr (desc_off (1)); if first_call ^= cobol_$compile_count then do; first_call = cobol_$compile_count; call cobol_alloc$stack (56, 2, sort_stack_off); cobol_$init_stack_off = cobol_$stack_off; end; if end_stmt.type = 19 then if (end_stmt.verb = reswd_SORT & end_stmt.h = 91) then call cobol_release_gen (null ()); else if end_stmt.h = 90 then do; call cobol_call_op (18, 0); call cobol_call_op (17, 0); end; else ; else do; eos_ptr = in_token.token_ptr (in_token.n); call initiate; last_token = in_token.n - 1; alpha_name_ptr = null (); if end_stmt.d ^= "00"b then do; alpha_name_ptr = in_token.token_ptr (in_token.n - 1); last_token = in_token.n - 2; if alphabet_name.iw_key = 11 /* ascii */ then do; alpha_name_ptr = null (); goto continue; end; if alphabet_name.iw_key = 0 then do; mvt_ptr = addr (alphabet_name.table); call cobol_pool (mvt_table, 2, to_offset); alphabet_name.offset = to_offset * 4; alphabet_name.segno = 3000; end; end; /* CODE for internal procedure building */ continue: dn_ptr = addr (alpha_type9); passed_tag = cobol_$next_tag; passed_tag1 = cobol_$next_tag + 1; cobol_$next_tag = cobol_$next_tag + 2; substr (instr_seq7 (3), 1, 18) = substr (cobol_$text_base_ptr -> bit18, 1, 18); call cobol_emit (addr (instr_seq), null (), 1); text_ptr = addrel (cobol_$text_base_ptr, cobol_$text_wd_off); call cobol_sort_util (sort_file_ptr, desc_ptr, object_name, object_name_len); call cobol_def_util (3, object_name, object_name_len, text_ptr, 0, desc_ptr, null ()); entry_seq.flags.function = "1"b; instr_seq7 (1) = entry_seq.descr_relp_offset; instr_seq7 (3) = entry_seq.def_relp; instr_seq7 (4) = string (entry_seq.flags); call cobol_emit (addr (instr_seq7 (1)), addr (rel_seq7 (1)), 7); sort_gen_text_wd_off = cobol_$text_wd_off - 5; call cobol_make_tagref (passed_tag, cobol_$text_wd_off - 8, null ()); call cobol_call_op (19, 0); /* Lock the pointer register 1 2 and 7 */ pr_struc.what_ptr = 7; call cobol_pointer_register$get (addr (pr_struc)); pr_struc.what_ptr = 1; call cobol_pointer_register$get (addr (pr_struc)); pr_struc.what_ptr = 2; call cobol_pointer_register$get (addr (pr_struc)); /* INSERT compare code */ do i = 3 to (last_token); pt1 = in_token.token_ptr (i); pt2 = addr (alpha_type9); alpha_type9 = pt1 -> alpha_type9_based; pt3 = addr (type19); type19.e = 102; /* EQUAL */ pt2 -> data_name.seg_num = 5002; pt1 -> data_name.seg_num = 5001; if data_name.numeric = "0"b then do; /* switch compare operands around */ workpt2 = pt2; pt2 = pt1; pt1 = workpt2; end; type19.h = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_compare_gen$sort (addr (sort_in_token), alpha_name_ptr); /*[5.3-1]*/ ad_bit = data_name.ad_bit; /*[5.3-1]*/ if data_name.display /*[5.3-1]*/ then if data_name.numeric /*[5.3-1]*/ then call cmpn_test; /*[5.3-1]*/ else call cmpc_test; /*[5.3-1]*/ else if data_name.bin_18 | data_name.bin_36 /*[5.3-1]*/ then call cmpq_test; /*[5.3-1]*/ else call cmpn_test; /*[5.3-1]*/ substr (instr_seq11 (2), 7, 3) = op; temp = fixed (op_con.zero_con, 18) - 2; instr_seq11 (3) = substr (unspec (temp), 19, 18); if i ^= last_token then do; call cobol_emit (addr (instr_seq11 (1)), null (), 5); call cobol_make_tagref (passed_tag1, cobol_$text_wd_off - 1, null ()); call cobol_define_tag_nc (type19.h, cobol_$text_wd_off); end; else call cobol_emit (addr (instr_seq11 (1)), null (), 4); substr (instr_seq11 (2), 7, 3) = "010"b; /* reset */ end; call cobol_pointer_register$priority (2, 0, "001"b); call cobol_pointer_register$priority (2, 0, "010"b); call cobol_pointer_register$priority (2, 0, "111"b); call cobol_define_tag (type19.h); call cobol_define_tag (passed_tag1); call cobol_emit (addr (instr_seq8 (1)), null (), 1); temp = cobol_$stack_off + 16; substr (unspec (temp), 33, 4) = "0000"b; sort_gen_ptr = addrel (cobol_$text_base_ptr, sort_gen_text_wd_off); substr (sort_gen_ptr -> bit18, 1, 18) = substr (unspec (temp), 19, 18); call cobol_define_tag (passed_tag); end; return; /*[5.3-1]*/ dcl 1 instr static, /*[5.3-1]*/ 2 tmi bit (3) init ("100"b), /*[5.3-1]*/ 2 tpl bit (3) init ("101"b), /*[5.3-1]*/ 2 tnc bit (3) init ("010"b), /*[5.3-1]*/ 2 trc bit (3) init ("011"b); /*[5.3-1]*/ dcl ad_bit bit (1) aligned, op bit (3) aligned; cmpn_test: proc; /*[5.3-1]*/ if ad_bit then op = tmi; else op = tpl; end; cmpc_test: proc; /*[5.3-1]*/ if ad_bit then op = tnc; else op = trc; end; cmpq_test: proc; /*[5.3-1]*/ if ad_bit then op = tpl; else op = tmi; end; /* Interal procedure to generate codes to call sort_$initiate. The call is through the operator sort_initiate. */ initiate: proc; dcl inst_seq (4) bit (18) init ("000000000000000000"b, "011101011100000100"b, /* epp3 compare,ic */ "000000000000000000"b, "111010010000000111"b); /* lxl2 sort_stack_off,dl */ dcl rel_seq (4) bit (5) aligned init ("00000"b, "00000"b, "00000"b, "00000"b); call cobol_call_op (16, 0); retry_tag = cobol_$next_tag; call cobol_define_tag_nc (retry_tag, cobol_$text_wd_off); cobol_$next_tag = cobol_$next_tag + 1; if cobol_$same_sort_merge_proc ^= "0"b then temp = -sort_stack_off; else temp = sort_stack_off; inst_seq (3) = substr (unspec (temp), 19, 18); call cobol_emit (addr (inst_seq), addr (rel_seq), 2); compare_hold_ic = cobol_$text_wd_off - 2; call cobol_call_op (14, retry_tag); call cobol_reg_manager$after_op (14); temp = cobol_$text_wd_off + 3 - compare_hold_ic; addrel (cobol_$text_base_ptr, compare_hold_ic) -> hold_addr = substr (unspec (temp), 19, 18); end initiate; /***** Declaration for builtin function *****/ dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index) builtin; /***** End of declaration for builtin function *****/ %include cobol_in_token; %include cobol_op_con; %include cobol_entry_seq; %include cobol_fixed_static; %include cobol_; %include cobol_file_table; %include cobol_type1; %include cobol_type9; %include cobol_type12; %include cobol_type19; %include cobol_type40; %include cobol_reswd_values; %include cobol_alpha_def; %include cobol_ext_; %include cobol_definitions; end cobol_sort_gen;  cobol_sort_util.pl1 05/24/89 1042.8rew 05/24/89 0832.5 28620 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_sort_util.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 11/18/76 by Bob Chang to interface with merge generators. */ /* Modified since Version 2.0 */ /*{*/ /* format: style3 */ cobol_sort_util: proc (file_ptr, desc_ptr, object_name, object_name_len); /* This procedure is called by sort_gen for: 1. create the object_name for sort compare routine. 2 set the argument offset which is based on desc_ptr. The input to this procedure is: 1 sort_merge_count to identify the count for the number of times for sort. 2 file_ptr which points to the type12 token to get the sort file file. */ dcl sort_merge_count fixed bin static, first_call fixed bin static init (0), file_ptr ptr, desc_ptr ptr, desc_off (3) fixed bin, object_name char (32), object_name_len fixed bin; /*}*/ dcl desc_bit1 bit (36) static init ("100110100000000000000000000000000000"b), desc_bit2 bit (36) static init ("100000100000000000000000000000000001"b), desc_char1 char (4) based (addr (desc_bit1)), desc_char2 char (4) based (addr (desc_bit2)), (i, j, k) fixed bin, sort_char char (3), name_ptr ptr, conv_char (0:9) char (1) static init ("0", "1", "2", "3", "4", "5", "6", "7", "8", "9"); dcl cobol_pool entry (char (*), fixed bin, fixed bin); /* ******************************/ start: if first_call ^= cobol_$compile_count then do; first_call = cobol_$compile_count; sort_merge_count = 0; end; sort_merge_count = sort_merge_count + 1; sort_char = ""; j = sort_merge_count; do i = 1 to 3; k = mod (j, 10); j = divide (j, 10, 17, 0); sort_char = conv_char (k) || sort_char; end; name_ptr = file_ptr; object_name = (32)" "; object_name = "cmp" || sort_char || "_" || substr (fd_token.name, 1, fd_token.name_size); object_name_len = index (object_name, " ") - 1; if object_name_len = -1 then object_name_len = 32; desc_ptr = addr (desc_off (1)); call cobol_pool (desc_char1, 1, desc_off (1)); call cobol_pool (desc_char1, 1, desc_off (2)); call cobol_pool (desc_char2, 1, desc_off (3)); do i = 1 to 3; desc_off (i) = -desc_off (i); end; return; /***** End of declaration for builtin function *****/ %include cobol_type12; %include cobol_; end cobol_sort_util;  cobol_start_gen.pl1 05/24/89 1042.8rew 05/24/89 0832.5 89046 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_start_gen.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modifile on 08/27/79 by PRP, [4.0-2] new operator for alternate keys*/ /* Modified on 06/27/79 by FCH, [4.0-1], not option added for debug */ /* Modified on 11/1/78 by FCH,[3.0-1], alt rec keys added */ /* Modifies since Version 3.0 */ /* format: style3 */ cobol_start_gen: proc (mp_ptr, passed_tag); dcl passed_tag fixed bin; /* for in-line error handling */ dcl ptag fixed bin; dcl mp_ptr ptr; dcl 1 mp based (mp_ptr), 2 n fixed bin, /* from 3 to 4 */ 2 pt (0 refer (mp.n)) ptr; /* pt(1) pts to type1 token for START */ /* pt(2) pts to type 12 token for the file in question */ /* pt(3) pts to type9 token for key IF end_stmt.a = "1"b */ /* pt(n) pts to type19 token (eos) */ dcl 1 args, 2 entryno fixed bin, 2 arglist_off fixed bin, 2 stacktemp_off fixed bin, 2 n fixed bin, 2 arg (4), 3 pt ptr, 3 type fixed bin, 3 off1 fixed bin, 3 off2 fixed bin, 3 value bit (18) unal, 3 indirect bit (1) unal, 3 overlay bit (1) unal, 3 repeat_nogen bit (1) unal, 3 regsw bit (1) unal, 3 regno bit (3) unal; dcl file_key_desc char (40) based; dcl argb (4) bit (216) based (addr (args.arg (1))); dcl text (0:10000) bit (36) based (cobol_$text_base_ptr); dcl ft_ptr ptr; dcl fkey_ptr ptr; dcl name_ptr ptr; dcl dn_ptr ptr; dcl arg_ptr ptr; dcl ioerror_ptr ptr; dcl aloff fixed bin; dcl size fixed bin; dcl reclen_off fixed bin; dcl order_off fixed bin; dcl relation_off fixed bin; dcl keylen_off fixed bin; dcl key_off fixed bin; dcl ntag fixed bin; dcl errno fixed bin; dcl alt_sw bit (1); dcl seek_head_sw bit (1); dcl temp_bit2 bit (2); /*[3.0-1]*/ dcl char5 char (5), key_ctr fixed bin; /*************************************/ /*************************************/ /* INITIALIZATION */ start: rw_ptr = mp.pt (1); eos_ptr = mp.pt (mp.n); ioerror_ptr = addr (ioerror); ioerror.cobol_code = 0; ioerror.type1_ptr = mp.pt (1); ioerror.mode = 0; if end_stmt.b = "1"b then do; /* in-line error coding follows */ ioerror.is_tag = cobol_$next_tag; /* to be defined at end of generated code for WRITE */ ptag, passed_tag = cobol_$next_tag + 1; /* to be defined by gen driver at end of in-line coding */ ioerror.ns_tag = ptag; cobol_$next_tag = cobol_$next_tag + 2; end; else do; ioerror.is_tag = 0; ptag = 0; ioerror.ns_tag = cobol_$next_tag; /* to be defined at end of generated code */ cobol_$next_tag = cobol_$next_tag + 1; end; arg_ptr = addr (args); iocb_arg.pt = addr (iocb_basic_struct); call cobol_read_ft (mp.pt (2) -> fd_token.file_no, ft_ptr); call cobol_alloc$stack (368, 2, aloff); /* enough for 92 words - aloff is a wd offset */ args.arglist_off = aloff; argb (1) = unspec (iocb_arg); reclen_off = aloff + 22; order_off = aloff + 23; relation_off = aloff + 26; keylen_off = aloff + 27; key_off = aloff + 28; /*************************************/ /* START CODE GENERATION */ start_codegen: /* MAKE SURE FILE IS OPEN */ ioerror.retry_tag = cobol_$next_tag; ntag = cobol_$next_tag + 1; cobol_$next_tag = cobol_$next_tag + 2; call cobol_define_tag (ioerror.retry_tag); call cobol_set_fsbptr (ft_ptr); /* OPERATOR21(init_start) */ call cobol_call_op (21, ntag); /* INT_START_OP */ call cobol_gen_ioerror (ft_ptr, ioerror_ptr); call cobol_define_tag (ntag); /*[3.0-1]*/ alt_sw = file_table.organization = 3 /* ind */ /*[3.0-1]*/ & /*[3.0-1]*/ file_table.alternate_keys ^= 0; if file_table.external | file_table.open_out then do; ntag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_io_util$bypass_mode_error (ntag, "11"b); if (file_table.external | file_table.rewrite | file_table.delete) & file_table.access < 2 then call cobol_io_util$move_direct ("001"b, fsb_keylen_sw, 4, 1, ""b); /* zero the switch */ /* OPERATOR54(delete error) */ call cobol_call_op (54, ntag); /* ERROR_OP */ call cobol_gen_ioerror (ft_ptr, ioerror_ptr); call cobol_define_tag (ntag); end; /*[3.0-1]*/ if alt_sw & end_stmt.e ^= 511 /*[3.0-1]*/ then do; char5 = file_table.alt_key_info; /*[3.0-1]*/ /*[3.0-1]*/ do key_ctr = 1 by 1 to end_stmt.e; /*[3.0-1]*/ /*[3.0-1]*/ call cobol_read_rand (1, char5, fkey_ptr); /*[3.0-1]*/ char5 = file_key.next_alt; /*[3.0-1]*/ /*[3.0-1]*/ end; /*[3.0-1]*/ end; else call cobol_read_rand (1, file_table.r_key_info, fkey_ptr); addr (fkey_type9.file_key_info) -> file_key_desc = file_key.desc; seek_head_sw = "0"b; if end_stmt.a ^= "0"b then do; if end_stmt.d = "00"b then if mp.pt (3) -> data_name.item_length = fkey_type9.size then ; /* = whole key */ else seek_head_sw = "1"b; else seek_head_sw = "1"b; end; if ^seek_head_sw then do; mpout.pt1 = mp.pt (1); mpout.pt2 = addr (fkey_type9); if file_table.organization = 2 then do; /* relative */ mpout.pt3 = addr (num_type9); size, num_type9.size, num_type9.places_left = 16; num_type9.seg = 5001; /* from PR1 */ num_type9.off = file_table.fsb.off + fsb_key; end; else do; /* indexed */ mpout.pt3 = addr (alpha_type9); size, alpha_type9.size = fkey_type9.size; alpha_type9.seg = 5001; /* from PR1 */ alpha_type9.off = file_table.fsb.off + fsb_key; end; mpout.pt4 = addr (type19); call cobol_move_gen (addr (mpout)); call cobol_io_util$move_direct ("001"b, fsb_keylen_sw, 4, 1, substr (unspec (size), 19, 18)); ntag = cobol_$next_tag; /*[3.0-1]*/ if alt_sw /*[3.0-1]*/ then do; call cobol_io_util$key_loc (0, 0); /*[3.0-1]*/ call alt_start (84); /*[3.0-1]*/ end; cobol_$next_tag = cobol_$next_tag + 1; call cobol_set_fsbptr (ft_ptr); call cobol_ioop_util$set_icode; /* OPERATOR67(read_seek_key) */ call cobol_call_op (67, ntag); /* iox_$seek_key */ call cobol_gen_ioerror (ft_ptr, ioerror_ptr); call cobol_define_tag (ntag); errno = seek_errno; end; else do; /* must call iox_$control */ temp_bit2 = end_stmt.d; /* relational code */ call cobol_io_util$move_direct ("110"b, relation_off * 4, 4, 1, (16)"0"b || temp_bit2); mpout.pt1 = mp.pt (1); mpout.pt2 = addr (fkey_type9); if file_table.organization = 2 then do; /* relative */ mpout.pt3 = addr (num_type9); size, num_type9.size, num_type9.places_left = 16; num_type9.seg = 1000; /* stack */ num_type9.off = key_off * 4; end; else do; /* indexed */ mpout.pt3 = addr (alpha_type9); size, alpha_type9.size = mp.pt (3) -> data_name.item_length; alpha_type9.seg = 1000; /* stack */ alpha_type9.off = key_off * 4; end; mpout.pt4 = addr (type19); call cobol_move_gen (addr (mpout)); call cobol_io_util$move_direct ("110"b, keylen_off * 4, 4, 1, substr (unspec (size), 19, 18)); /*[3.0-1]*/ if alt_sw /*[3.0-1]*/ then do; call cobol_io_util$key_loc (1, relation_off); /*[3.0-1]*/ call alt_start (82); /*[3.0-1]*/ end; /* CALL iox_$control(iocb_ptr,order_name,struc_ptr,code) where: order_name char(*) - "seek_head", struc_ptr ptr -> 1 struc, 2 relation fixed bin, 2 keylen fixed bin, 2 key char(0 refer (keylen)); relation: 0 - head = key 1 - head >= key 2 - head > key */ ntag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_set_fsbptr (ft_ptr); call cobol_ioop_util$set_icode; call cobol_ioop_util$ldaldx5 (9, reclen_off); /* OPERATOR23(start_control) */ if alt_sw then call cobol_call_op (83, ntag); /*[4.0-2] iox_$control for alternate keys */ else call cobol_call_op (23, ntag); /* iox_$control */ call cobol_gen_ioerror (ft_ptr, ioerror_ptr); call cobol_define_tag (ntag); errno = control_errno; end; if (file_table.external | file_table.delete | file_table.rewrite) & file_table.access < 2 then do; call cobol_set_fsbptr (ft_ptr); call cobol_io_util$move_direct ("001"b, fsb_keylen_sw, 4, 1, ""b); /* zero the switch */ end; /*[3.0-1]*/ if alt_sw /*[3.0-1]*/ then do; call cobol_io_util$file_desc (file_table.file_desc_1_offset); /*[3.0-1]*/ call cobol_call_op (79, 0); /*[3.0-1]*/ end; call cobol_reg_manager$after_op (4095 + ioerror.cobol_code); /*[4.0-1]*/ if end_stmt.f = "01"b /*[4.0-1]*/ then passed_tag = ioerror.is_tag; /*[4.0-1]*/ else call cobol_gen_ioerror$finish_up (ft_ptr, ioerror_ptr); return; alt_start: proc (i); /*[3.0-1]*/ declare i fixed bin; /*[3.0-1]*/ call cobol_io_util$file_desc (file_table.file_desc_1_offset); /*[3.0-1]*/ call cobol_io_util$key_num (end_stmt.e); /*[3.0-1]*/ call cobol_call_op (i, 0); /* OPERATORi(*) */ end; /*************************************/ %include cobol_start_gen_info; %include cobol_start_gen_data; end cobol_start_gen;  cobol_stop_gen.pl1 05/24/89 1042.8rew 05/24/89 0832.5 96948 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_stop_gen.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 06/11/81 by FCH, OPERATOR(94) used for STOP RUN if CD INITIAL */ /* Modified on 01/14/77 by ORN to signal command_abort_ rather than cobol_compiler_error */ /* Modified since Version 2.0 */ /*{*/ /* format: style3 */ cobol_stop_gen: proc (in_token_ptr); /* The procedure cobol_stop_gen generates the code necessary to imple- ment the STOP statement. The general format of the STOP state- ment is: S_T_O_P_ {R_U_N_|literal} If RUN is specified, execution of the run-unit ceases and control is transferred to the operating system. This is accomplished by calling cobol_stoprun_, a program supplied as part of the run time package. If literal is specified, the execution of the run-unit is sus- pended and the literal plus prog_id, as contained in the stat structure of the program, is communicated to the terminal. A start command issued from the terminal reactivates the run-unit. The DISPLAY generator is called to generate the code necessary to transmit the desired message to the terminal and the system sub- routine cu_$cl is called to reach command level. Execution is resumed with the instruction following the call to cu_$cl. U__s_a_g_e:_ declare cobol_stop_gen entry (ptr); call cobol_stop_gen(in_token_ptr); */ /* G__e_n_e_r_a_t_e_d_C__o_d_e:_ STOP RUN - For the STOP RUN statement, code is generated to place the line number of the STOP RUN source statement in the program's stat structure and to call cobol_stoprun_, a program supplied as part of the run time package. cobol_stoprun_ has no parameters. The code generated to set line_no in stat and call cobol_stoprun_ is as follows: loc_a lda iln1,dl ldq iln2,dl staq pr4|36 stat.line_no eax1 pr6|46 fld 0,dl epp2 pr4|ep_c_sr_,* tsx0 pr0|call_eo tra loc_a_relp,ic where: iln1 and iln2 are the two parts of the internal line number of the source line containing the STOP RUN statement as determined at compile time. ep_c_sr_ is the offset, relative to the base of the Linkage Section, of an execution time pointer (created as a Type 4 link in the Object Segment) to the entry point of cobol_stoprun_. call_eo is the location, relative to the label operator_ table in cobol_operators_, of the first instruction of the PLI call operator call_ext_out. The current value of call_eo is 6. loc_a_relp is the offset, relative to the instruction in which it appears, of the first instruction generated to implement the STOP RUN statement (it may be either the instruction labeled loc_a in the above code or an instruction generated to load pr4 to point to the Linkage Section). STOP literal - For the STOP literal statement, code is generated to print a mes- sage comprising the program identification (stat.prog_id), a colon space, and the literal on the terminal and to suspend the execution of the run-unit. Mc_stop_run calls cobol_display_gen to generate the code for printing the message at the terminal and itself generates the code for calling system subroutine cu_$cl which affects the required suspension of execution. A description of the functionality of cu_$cl may be found in the MPM. The code generated to call cu_$cl, which has no arguments, is as follows: eax1 pr6|46 fld 0,dl epp2 pr4|ep_cu_$cl,* tsx0 pr0|call_eo where: ep_cu_$cl is the offset, relative to the base of the Linkage Sec- tion, of an execution time pointer (created as a Type 4 link in the Object Segment) to the entry point of cu_$cl. all_eo is the location, relative to the label operator_table in cobol_operators_, of the first instruction of the PLI call operator call_ext_out. The current value of call_eo is 6. R__e_l_o_c_a_t_i_o_n_I__n_f_o_r_m_a_t_i_o_n:_ All instructions generated directly by cobol_stop_gen except those referencing data in the Linkage Section of the Object Segment are non-relocatable. The relocation code generated for each half of each non-relocatable instruction is "00000"b. Instructions generated directly by cobol_stop_gen that reference data in the Linkage Section i.e. those instructions in the code sequence of the form pr4| are relocatable with respect to their left hand half and non-re- locatable with respect to thier right hand half. The relocation code generated for the relocatable half of each such instruction is "11001"b, when the operand referenced by the instruction is internal data, and "10100"b, when it is a link. In either case, the code generated for the non_relocatable half is "00000"b. D__a_t_a:_ % include cobol_; Items in cobol_ include file used (u) and/or set (s) by cobol_stop_gen: cobol_ptr (u) temp_token_ptr (u) text_wd_off (u) */ dcl inst_seq (4) bit (18) unaligned static init ("000000000000000000"b, "010011101000000111"b, /* lda iln1,dl */ "000000000000000000"b, "010011110000000111"b); /* ldq iln2,dl */ dcl tra_ic (2) bit (18) unaligned static init ("000000000000000000"b, "111001000000000100"b); /* tra loc-a-relp,ic */ declare 1 token3 aligned static, 2 size fixed bin aligned init (25), 2 line fixed bin aligned init (0), 2 column fixed bin aligned init (0), 2 type fixed bin aligned init (3), 2 lit_type bit (1) unaligned init ("0"b), 2 all_lit bit (1) unaligned init ("0"b), 2 filler1 bit (6) unaligned init ((6)"0"b), 2 lit_size fixed bin aligned init (2), 2 string char (2) aligned init (": "); declare 1 display_eos aligned static, 2 size fixed bin aligned init (38), 2 line fixed bin aligned init (0), 2 column fixed bin aligned init (0), 2 type fixed bin aligned init (19), 2 verb fixed bin aligned init (42), 2 e fixed bin aligned init (3), 2 h fixed bin aligned init (0), 2 i fixed bin aligned init (0), 2 j fixed bin aligned init (0), 2 a bit (3) unaligned init ("001"b), 2 b bit (1) unaligned init ("0"b), 2 c bit (1) unaligned init ("0"b), 2 d bit (2) unaligned init ("00"b), 2 f bit (2) unaligned init ("00"b), 2 g bit (2) unaligned init ("00"b), 2 k bit (5) unaligned init ((5)"0"b); /* Local Data */ declare offset fixed bin, /* Word offset. */ line_no fixed bin, /* Line number from type1 token. */ local_in_token_ptr ptr, /* Ptr to in_token structure */ /* passed to display generator. */ type9_token_ptr ptr; /* Ptr to type 9 token for */ /* stat.prog_id. */ dcl next_tag1; dcl dn_ptr ptr; /* Ptr to data_name token. */ declare 1 seg_ovfl_error aligned static, 2 my_name char (32) init ("cobol_stop_gen"), 2 message_len fixed bin init (40), 2 message char (40) init ("temp_token_area segment length exceeded!"); /* P__r_o_c_e_d_u_r_e_s_C__a_l_l_e_d:_ */ dcl cobol_display_gen entry (ptr), cobol_emit entry (ptr, ptr, fixed bin), cobol_reg_manager$before_op entry (fixed bin), cobol_make_type9$alphanumeric entry (ptr, fixed bin, fixed bin, fixed bin), cobol_reg_manager$after_op entry (fixed bin), cobol_call_op entry (fixed bin, fixed bin), cobol_define_tag entry (fixed bin), signal_ entry (char (*), ptr, ptr); /* B__u_i_l_t-__i_n_F__u_n_c_t_i_o_n_s_U__s_e_d:_ */ dcl addr builtin, addrel builtin, binary builtin, null builtin, rel builtin, substr builtin, unspec builtin; /*}*/ %include cobol_; %include cobol_type1; %include cobol_type9; %include cobol_type19; %include cobol_in_token; /*************************************/ /*[4.4-1]*/ dcl A bit (3), op_num fixed bin; start: /*[4.4-1]*/ A = in_token.token_ptr (in_token.n) -> end_stmt.a; /*[4.4-1]*/ if A ^= "001"b then goto stop_run; else goto stop_literal; /* Implementation for STOP RUN statement */ stop_run: line_no = in_token.token_ptr (1) -> reserved_word.line; /* Insert table look-up to determine iln1 and iln2. In mean- */ /* time, use line_no as iln1 and 0 as iln2. */ /*[4.4-1]*/ if A = "010"b then op_num = 94; else op_num = 48; inst_seq (1) = substr (unspec (line_no), 19, 18); next_tag1 = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_reg_manager$before_op (0); call cobol_define_tag (next_tag1); call cobol_emit (addr (inst_seq), null (), 2); /*[4.4-1]*/ call cobol_call_op (op_num, next_tag1); return; /* Implementation of STOP literal. */ stop_literal: if 262143 - binary (rel (temp_token_ptr), 17) < 40 then goto signal_seg_ovfl; if substr (rel (temp_token_ptr), 18, 1) = "1"b then temp_token_ptr = addrel (temp_token_ptr, 1); local_in_token_ptr = temp_token_ptr; type9_token_ptr = addrel (local_in_token_ptr, 12); temp_token_ptr = addrel (local_in_token_ptr, 40); call cobol_make_type9$alphanumeric (type9_token_ptr, 3002, 76, 65); type9_token_ptr -> data_name.size_rtn = -1; type9_token_ptr -> data_name.variable_length = "1"b; local_in_token_ptr -> in_token.n = 5; local_in_token_ptr -> in_token.code = 0; local_in_token_ptr -> in_token.token_ptr (1) = in_token_ptr -> in_token.token_ptr (1); local_in_token_ptr -> in_token.token_ptr (2) = type9_token_ptr; local_in_token_ptr -> in_token.token_ptr (3) = addr (token3); local_in_token_ptr -> in_token.token_ptr (4) = in_token_ptr -> in_token.token_ptr (2); local_in_token_ptr -> in_token.token_ptr (5) = addr (display_eos); call cobol_display_gen (local_in_token_ptr); call cobol_reg_manager$after_op (0); call cobol_call_op (43, 0); return; signal_seg_ovfl: call signal_ ("command_abort_", null, addr (seg_ovfl_error)); return; end cobol_stop_gen;  cobol_store_binary.pl1 05/24/89 1042.8rew 05/24/89 0832.4 197100 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_store_binary.pl1 Added Trace statements. END HISTORY COMMENTS */ /* Modified on 11/16/84 by FCH, [5.3...], trace added */ /* Modified on 10/19/84 by FCH, [5.3-1], BUG563(phx18381), new cobol_addr_tokens.incl.pl1 */ /* Modified on 02/22/77 by Bob Chang to fix the bug for reloc bits. */ /* Modified on 01/17/77 by ORN to call cobol_make_reg_token instead of cobol_make_register_token */ /* Modified since Version 2.0 */ /* format: style3 */ cobol_store_binary: proc (source_ptr, target_ptr, call_again); /* This procedure generates code to store a fixed vinary datum inot another fixed binary datum, in the arithmetic (as opposed to the Cobol MOVE) sense. */ /* DECLARATION OF THE PARAMETERS */ dcl source_ptr ptr; dcl target_ptr ptr; dcl call_again bit (1); /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION source_ptr Pointer to a token that describes the value to be stored. (input) The source can be in one of the following places: a. index register (short binary value) b. A or Q (long binary value) c. A and Q (result of multiplication) d. in a data item (long or short binary) e. in an immediate constant token (type 102) target_ptr Pointer to the data name token of the target. (input) The target is always either a long binary or short binary datum. call_again A flag that is set to "1"b by this procedure if the calling procedure should call this procedure again to store the result into the target. This flag will be set only when the size of the source is greater than the size of the target, and code has been generated to move the source into a temporary, in order to force overflow. Under these circumstances, the input parameter source_ptr is set to a token that describes the temporary, and call_again is set to "1"b. A subsequent call to this procedure, with no additional changes to the input parameters by the calling procedure, will then generate code to move the temporary, (which is now of the same size as the target) into the target. */ /* DECLARATION OF EXTERNAL ENTRIES */ dcl cobol_addr ext entry (ptr, ptr, ptr); dcl cobol_emit ext entry (ptr, ptr, fixed bin); dcl cobol_make_reg_token ext entry (ptr, bit (4)); dcl cobol_short_to_longbin$register ext entry (ptr, ptr); dcl cobol_register$load ext entry (ptr); dcl cobol_register$release ext entry (ptr); dcl cobol_make_type9$decimal_9bit ext entry (ptr, fixed bin, fixed bin (24), fixed bin, fixed bin); dcl cobol_make_type9$long_bin ext entry (ptr, fixed bin, fixed bin (24)); dcl cobol_make_type9$short_bin ext entry (ptr, fixed bin, fixed bin (24)); dcl cobol_alloc$stack ext entry (fixed bin, fixed bin, fixed bin (24)); /* DECLARATION OF INTERNALL STATIC DATA */ dcl STA bit (10) int static init ("1111011010"b); /* 755(0) */ dcl STQ bit (10) int static init ("1111011100"b); /* 756(0) */ dcl STX bit (10) int static init ("1111000000"b); /* 740(0) */ dcl SXL bit (10) int static init ("1001000000"b); /* 440(0) */ dcl LDA bit (10) int static init ("0100111010"b); /* 235(0) */ dcl LDQ bit (10) int static init ("0100111100"b); /* 236(0) */ dcl LDX bit (10) int static init ("0100100000"b); /* 220(0) */ dcl LXL bit (10) int static init ("1110100000"b); /* 720(0) */ dcl BTD bit (10) int static init ("0110000011"b); /* 301(1) */ dcl DTB bit (10) int static init ("0110001011"b); /* 305(1) */ dcl STAQ bit (10) int static init ("1111011110"b); /* 757(0) */ /* DECLARATION OF INTERNAL VARIABLES */ dcl source_length fixed bin; dcl target_length fixed bin; dcl temp_source_ptr ptr; dcl temp_ptr ptr; dcl 1 input_buff aligned, 2 buff (1:10) ptr; dcl 1 inst_buff aligned, 2 buff (1:4) fixed bin; dcl 1 reloc_buff aligned, 2 buff (1:10) bit (5) aligned; dcl temp_op bit (10); dcl 1 register_struc, 2 what_reg fixed bin, 2 reg_no bit (4), 2 lock fixed bin, 2 already_there fixed bin, 2 contains fixed bin, 2 tok_ptr ptr, 2 literal bit (36); dcl dn_ptr ptr; /**************************************************/ start: /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(csb);/**/ if source_ptr -> data_name.type = rtc_immed_const then do; /* Source is an immediate constant token */ /* Load the constant into an index register. */ temp_ptr = null (); if target_ptr -> data_name.bin_18 then call immed_to_index (source_ptr, temp_ptr); else call immed_to_register (source_ptr, temp_ptr); source_ptr = temp_ptr; end; /* Source is an immediate constant token. */ call get_length (source_ptr, source_length); call get_length (target_ptr, target_length); if target_length < source_length then call difficult_store (source_ptr, target_ptr, call_again); else call easy_store (source_ptr, target_ptr, call_again); exit: /***..... if Trace_Bit then call cobol_gen_driver_$Tr_End(csb);/**/ return; /***..... dcl csb char(18) init("COBOL_STORE_BINARY");/**/ /***..... dcl cobol_gen_driver_$Tr_Beg entry(char(*));/**/ /***..... dcl cobol_gen_driver_$Tr_End entry(char(*));/**/ /***..... dcl Trace_Bit bit(1) static external;/**/ /***..... dcl Trace_Lev fixed bin static external;/**/ /***..... dcl Trace_Line char(36) static external;/**/ /***..... dcl ioa_ entry options(variable); /**/ /**************************************************/ easy_store: proc (es_source_ptr, es_target_ptr, es_call_again); /* This procedure generates code to store a fixed binary datum into another fixed binary datum of length equal to or greater than the source datum. The source may be in an index register, or the A or Q register, or in a cobol data item. The target is always a cobol data item. */ /* DECLARATION OF THE PARAMETERS */ dcl es_source_ptr ptr; dcl es_target_ptr ptr; dcl es_call_again bit (1); start_easy_store: es_call_again = "0"b; /* Set up the input structure for calling the addressability utility. */ input_ptr = addr (input_buff); inst_ptr = addr (inst_buff); reloc_ptr = addr (reloc_buff); input_struc.type = 2; input_struc.operand_no = 1; input_struc.lock = 0; input_struc.send_receive (1) = 1; /* receiving */ input_struc.operand.size_sw (1) = 0; if es_source_ptr -> data_name.type = rtc_register then do; /* Source is in a register. */ /* Establish addressability to the target*/ input_struc.operand.token_ptr (1) = es_target_ptr; call cobol_addr (input_ptr, inst_ptr, reloc_ptr); if (es_source_ptr -> cobol_type100.register = "0001"b /* A */ | es_source_ptr -> cobol_type100.register = "0010"b /* Q */) then do; /* Source is in the A or Q */ if es_source_ptr -> cobol_type100.register = "0001"b /* source in A */ then inst_struc_basic.fill1_op = STA; else inst_struc_basic.fill1_op = STQ; call cobol_emit (inst_ptr, reloc_ptr, 1); end; /* Source is in the A or Q */ else do; /* Source is in an index register */ /* Note that if the source is in an index register, the target must be a short binary, because arithmetic is done in the index registers only if all targets are short binary. */ if mod (es_target_ptr -> data_name.offset, 4) = 0 then temp_op = STX; /* Target is word aligned */ else temp_op = SXL; /* Target is half-word aligned */ substr (temp_op, 7, 3) = substr (es_source_ptr -> cobol_type100.register, 2, 3); inst_struc_basic.fill1_op = temp_op; call cobol_emit (inst_ptr, reloc_ptr, 1); end; /* Source is in an index register */ end; /* Source is in a register */ else do; /* Source must be in a cobol data item */ if es_source_ptr -> data_name.bin_36 then do; /* Source is a long binary. */ /* Note that if the source is a long binary, then the target is also a long binary. */ /* Establish addressability to the source. */ input_struc.operand.token_ptr (1) = es_source_ptr; call cobol_addr (input_ptr, inst_ptr, reloc_ptr); /* Get the A or Q register */ register_struc.what_reg = 4; /* A or Q */ register_struc.lock = 1; register_struc.contains = 1; register_struc.tok_ptr = es_source_ptr; call cobol_register$load (addr (register_struc)); if register_struc.reg_no = "0001"b /* A */ then inst_struc_basic.fill1_op = LDA; else inst_struc_basic.fill1_op = LDQ; call cobol_emit (inst_ptr, reloc_ptr, 1); /* Establish addressability to the target. */ input_struc.operand.token_ptr (1) = es_target_ptr; call cobol_addr (input_ptr, inst_ptr, reloc_ptr); if register_struc.reg_no = "0001"b /* A */ then inst_struc_basic.fill1_op = STA; else inst_struc_basic.fill1_op = STQ; call cobol_emit (inst_ptr, reloc_ptr, 1); /* The source is now in the A or Q */ /* Make a register token for the A or Q, and set the source pointer (es_source_ptr) to point to this register token, so that additional sotres (if any) can be done directly from the A or Q. */ es_source_ptr = null (); call cobol_make_reg_token (es_source_ptr, register_struc.reg_no); end; /* Source is a long binary */ else do; /* Source must be a short binary. */ if es_target_ptr -> data_name.bin_18 then do; /* Target is a short binary */ /* Establish addressability to the source */ input_struc.operand.token_ptr (1) = es_source_ptr; call cobol_addr (input_ptr, inst_ptr, reloc_ptr); /* Get an index register into which to load the short binary, and lock it */ register_struc.what_reg = 5; register_struc.lock = 1; register_struc.contains = 1; register_struc.tok_ptr = es_source_ptr; call cobol_register$load (addr (register_struc)); if mod (es_source_ptr -> data_name.offset, 4) = 0 then temp_op = LDX; /* Source is word aligned. */ else temp_op = LXL; /* Source is half_word aligned */ substr (temp_op, 7, 3) = substr (register_struc.reg_no, 2, 3); inst_struc_basic.fill1_op = temp_op; /* Emit the instruction to load the source into an index register. */ call cobol_emit (inst_ptr, reloc_ptr, 1); /* Establish addressability to the target. */ input_struc.operand.token_ptr (1) = es_target_ptr; call cobol_addr (input_ptr, inst_ptr, reloc_ptr); if mod (es_target_ptr -> data_name.offset, 4) = 0 then temp_op = STX; /* Target is word aligned. */ else temp_op = SXL; /* Target is holf-word aligned. */ substr (temp_op, 7, 3) = substr (register_struc.reg_no, 2, 3); inst_struc_basic.fill1_op = temp_op; /* Emit the instruction to store the index register into the target. */ call cobol_emit (inst_ptr, reloc_ptr, 1); /* Make a register token for the index register, and set the source pointer to point to the register token, so that additional stores (if any) can be done directly from the index register. */ es_source_ptr = null (); call cobol_make_reg_token (es_source_ptr, register_struc.reg_no); end; /* Target is a short binary. */ else do; /* Target is a long binary */ temp_source_ptr = null (); /* Convert the short binary source to a long binary in the A or Q */ call cobol_short_to_longbin$register (es_source_ptr, temp_source_ptr); /* Establish addressabiity to the target. */ input_struc.operand.token_ptr (1) = es_target_ptr; call cobol_addr (input_ptr, inst_ptr, reloc_ptr); if temp_source_ptr -> cobol_type100.register = "0001"b /* A */ then inst_struc_basic.fill1_op = STA; else inst_struc_basic.fill1_op = STQ; /* Emit the instruction to store the register into the target. */ call cobol_emit (inst_ptr, reloc_ptr, 1); /* Set the source pointer to the register token for the long binary, so that additional stores (if any) can be done directly from the register. */ es_source_ptr = temp_source_ptr; end; /* Target is a long binary */ end; /* Source must be a short binary. */ end; /* Source must be a cobol data item. */ exit_easy_store: return; end easy_store; /**************************************************/ difficult_store: proc (ds_source_ptr, ds_target_ptr, ds_call_again); /* DECLARATION OF THE PARAMETERS */ dcl ds_source_ptr ptr; dcl ds_target_ptr ptr; dcl ds_call_again bit (1); /* This procedure generates code that attempts to force a fixed point overflow condition because the source (to be stored) is potentially larger than the receiving target. */ /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION ds_source_ptr Pointer to a token that describes the value to be stored. (input) This token may be a register token for either A,Q, or A-Q, or a data name token (type 9) for a long binary cobol data item. ds_target_ptr Pointer to a token that describes the target of the store.(input) This token is always a data name (type 9) token for either a long binary or short binary data item. ds_call_again A flag that is always set to "1"b by this procedure. */ /* DECLARATION OF INTERNAL VARIABLES */ dcl temp_length fixed bin; dcl ret_offset fixed bin (24); dcl temp_op bit (10); dcl temp_source_ptr ptr; dcl temp_dec_token_ptr ptr; dcl temp_bin_token_ptr ptr; /**************************************************/ start_difficult_store: /* Set up for calling the addressability utility. */ input_ptr = addr (input_buff); inst_ptr = addr (inst_buff); reloc_ptr = addr (reloc_buff); if ds_source_ptr -> data_name.type = rtc_register then do; /* Source is in a register. */ /* Store the register(s) into temporary storage */ if ds_source_ptr -> cobol_type100.register = "0011"b /* A and Q */ then temp_length = 8; else temp_length = 4; /* Allocate some temporary, aligned on a double word boundary. */ call cobol_alloc$stack (temp_length, 2, ret_offset); /* Make a long binary data name token for the temporary. */ temp_source_ptr = null (); call cobol_make_type9$long_bin (temp_source_ptr, 1000 /*stack*/, 4 * ret_offset); /* Modify the item length, because make_type9$long_bin assumes a length of 4 bytes. */ temp_source_ptr -> data_name.item_length = temp_length; /* Set up for calling the addressability utility. */ input_struc_basic.type = 1; input_struc_basic.operand_no = 0; input_struc_basic.lock = 0; input_struc_basic.char_offset = ret_offset * 4; input_struc_basic.segno = 1000; /* stack */ call cobol_addr (input_ptr, inst_ptr, reloc_ptr); /* Insert the appropriate opode to store the register(s) into the temporary */ if ds_source_ptr -> cobol_type100.register = "0001"b then temp_op = STA; else if ds_source_ptr -> cobol_type100.register = "0010"b then temp_op = STQ; else temp_op = STAQ; /* Emit code to store the source into a temporary */ inst_struc_basic.fill1_op = temp_op; call cobol_emit (inst_ptr, reloc_ptr, 1); /* Unlock the register that contained the source. */ register_struc.reg_no = ds_source_ptr -> cobol_type100.register; call cobol_register$release (addr (register_struc)); end; /* Source is in a register. */ else temp_source_ptr = ds_source_ptr; /* Allocate space in the stack into which the fixed binary will be converted to decimal. */ if temp_source_ptr -> data_name.item_length = 4 then temp_length = 11; /* source is single-word fixed binary. */ else temp_length = 22; /* source is double-word fixed binary */ call cobol_alloc$stack (temp_length, 0, ret_offset); /* Make a data name token for the temporary */ temp_dec_token_ptr = null (); call cobol_make_type9$decimal_9bit (temp_dec_token_ptr, 1000 /*stack*/, ret_offset, temp_length, 0); /* Set up to build the BTD instruction. */ input_struc.type = 5; input_struc.operand_no = 2; input_struc.lock = 0; input_struc.operand.token_ptr (1) = temp_source_ptr; input_struc.operand.size_sw (1) = 0; input_struc.operand.token_ptr (2) = temp_dec_token_ptr; input_struc.operand.size_sw (2) = 0; call cobol_addr (input_ptr, inst_ptr, reloc_ptr); /* Insert the opcode and emit the EIS BTD instruction */ inst_struc_basic.fill1_op = BTD; call cobol_emit (inst_ptr, reloc_ptr, 3); /* Allocate work space the size of the target. The decimal number will be converted into this work space, using a DTB instruction. If the decimal number is too long, overflow will occur. */ call cobol_alloc$stack (fixed (ds_target_ptr -> data_name.item_length, 17), 0, ret_offset); temp_bin_token_ptr = null (); if ds_target_ptr -> data_name.item_length = 4 then call cobol_make_type9$long_bin (temp_bin_token_ptr, 1000, ret_offset); else call cobol_make_type9$short_bin (temp_bin_token_ptr, 1000, ret_offset); input_struc.operand.token_ptr (1) = temp_dec_token_ptr; input_struc.operand.token_ptr (2) = temp_bin_token_ptr; call cobol_addr (input_ptr, inst_ptr, reloc_ptr); /* Insert the opcode and emit the EIS DTB instruction */ inst_struc_basic.fill1_op = DTB; call cobol_emit (inst_ptr, reloc_ptr, 3); /* Set the source pointer to point to the fixed binary temporary */ ds_source_ptr = temp_bin_token_ptr; ds_call_again = "1"b; exit_difficult_store: return; end difficult_store; /**************************************************/ get_length: proc (token_ptr, datum_length); /* This procedure determines the number of data bytes required by the datum described by the token pointed at by token_ptr. */ /* DECLARATION OF THE PARAMETERS */ dcl token_ptr ptr; dcl datum_length fixed bin; start_get_length: if token_ptr -> data_name.type = rtc_register then do; /* Token describes a register */ if (token_ptr -> cobol_type100.register = "0001"b /* A */ | token_ptr -> cobol_type100.register = "0010"b /* Q */) then datum_length = 4; /* 4 bytes = 36 bits = full word */ else if token_ptr -> cobol_type100.register = "0011"b /* A and Q */ then datum_length = 8; else datum_length = 2; /* Must be an index register. */ end; /* token describes a register. */ else datum_length = token_ptr -> data_name.item_length; exit_get_length: return; end get_length; immed_to_index: proc (source_tok_ptr, index_tok_ptr); /* This procedure generates code to load an immediate constant into an index register. */ /* DECLARATION OF THE PARAMETERS */ dcl source_tok_ptr ptr; dcl index_tok_ptr ptr; /* DECLARATION OF INTERNAL STATIC DATA */ dcl ldx_du_inst bit (36) int static init ("000000000000000000010010000000000011"b); /* LDXn 0,du */ /**************************************************/ start_immed_to_index: /* Get an index register and lock it. */ register_struc.what_reg = 5; /* any index register */ register_struc.lock = 1; /* lock it */ register_struc.contains = 0; call cobol_register$load (addr (register_struc)); /* Build LDXn const,du instruction */ substr (ldx_du_inst, 25, 3) = substr (register_struc.reg_no, 2, 3); substr (ldx_du_inst, 1, 18) = substr (unspec (source_tok_ptr -> immed_const.const_value), 19, 18); call cobol_emit (addr (ldx_du_inst), null (), 1); /* Make a register token tor the index that contains the constant. */ call cobol_make_reg_token (index_tok_ptr, register_struc.reg_no); exit_immed_to_index: return; end immed_to_index; immed_to_register: proc (source_tok_ptr, register_tok_ptr); /* This procedure generates code to load an immediate constant into the A or Q register. */ /* DECLARATION OF THE PARAMETERS */ dcl source_tok_ptr ptr; dcl register_tok_ptr ptr; /* DECLARATION OF INTERNAL STATIC DATA */ dcl direct_lower_inst bit (36) int static init ("000000000000000000000000000000000111"b); /* zero,dl */ start_immed_to_register: /* Get a register and lock it. */ register_struc.what_reg = 4; /* A or Q */ register_struc.lock = 1; register_struc.contains = 0; call cobol_register$load (addr (register_struc)); /* Build LDA/Q const,dl instruction */ substr (direct_lower_inst, 1, 18) = substr (unspec (source_tok_ptr -> immed_const.const_value), 19, 18); if register_struc.reg_no = "0001"b then substr (direct_lower_inst, 19, 10) = LDA; else substr (direct_lower_inst, 19, 10) = LDQ; call cobol_emit (addr (direct_lower_inst), null (), 1); /* Make a register token for the register that contains the constant. */ call cobol_make_reg_token (register_tok_ptr, register_struc.reg_no); exit_immed_to_register: return; end immed_to_register; /* INCLUDE FILES USED BY THIS PROCEDURE */ /***** Declaration for builtin function *****/ dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index) builtin; /***** End of declaration for builtin function *****/ %include cobol_type100; %include cobol_addr_tokens; %include cobol_type9; %include cobol_record_types; %include cobol_type102; end cobol_store_binary;  cobol_string.pl1 05/24/89 1042.8rew 05/24/89 0832.3 196443 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_string.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 04/14/80 by FCH, [4.2-1], incorrect code if lit is sending field, BUG437(TR5906) */ /* Modified on 03/14/77 by Bob Chang to change the loading of registers after setting of pointer. */ /* format: style3 */ cobol_string: proc (sptr); dcl sptr ptr; dcl 1 s based (sptr), 2 n fixed bin, 2 tag fixed bin, 2 rtp ptr, /* ptr to receiving item token */ 2 ptp ptr, /* ptr to pointer item token (none if null) */ 2 str (0 refer (s.n)), 3 stp ptr, /* ptr to sending item token */ 3 dtp ptr; /* ptr to delimiter item token (none if null) */ dcl fixlen_mlr_instr (3) bit (36) static init ("000000000001000000001000000101000000"b, /* mlr (pr),(pr) */ "000000000000000000000000000000000000"b, /* desc9a */ "000000000000000000000000000000000000"b); /* desc9a */ dcl move_instr (3) bit (36) static init ("000000000001101001001000000101100000"b, /* mlr (pr,rl),(pr,rl,x1) */ "010000000000000000000000000000000101"b, /* desc9a pr2|0 (sending item for A chars) */ "001000000000000000000000000000000101"b); /* desc9a pr1|0 (indexed by x1 for A chars) */ dcl scan_instr (3) bit (36) based (scan_instr_ptr); dcl scm_instr (5) bit (36) static init ("000000000000000011001010100101100000"b, /* scm (pr,rl),(du),mask(000) */ "010000000000000000000000000000000101"b, /* desc9a pr2|0 (len in A) */ "000000000000000000000000000000000000"b, /* desc9a literal (len ignored) */ "110000000000110111000000000001000000"b, /* arg pr6|67 (tally) */ "110000000000110111010011101001000000"b); /* lda pr6|67 (tally) */ dcl scd_instr (6) bit (36) static init ("000000000000000011001010000101100000"b, /* scd (pr,rl),(du),mask(000) */ "010000000000000000000000000000000101"b, /* desc9a pr2|0 (len in A) */ "000000000000000000000000000000000000"b, /* desc9a literal (len ignored) */ "110000000000110111000000000001000000"b, /* arg pr6|67 (tally) */ "000000000000000010110000110100000100"b, /* ttn 2,ic (len already in A) */ "110000000000110111010011101001000000"b); /* lda pr6|67 (tally) */ dcl bypass_ovfl_instr (2) bit (36) static init ("110000000000110110010011100001000000"b, /* szn pr6|66 (ovfl) */ "000000000000000000110000000000000100"b); /* tze [tag],ic (bypass ovfl code) */ dcl check_ovfl_instr (5) bit (36) static init ("000000000000010010111011101000000000"b, /* als 22 */ "110000000000110001111101101001000000"b, /* sta pr6|61 (atemp) */ "110000000000110001000110001001000000"b, /* adx1 pr6|61 (atemp) */ "110000000000110110010011100001000000"b, /* szn pr6|66 (ovfl) */ "000000000000000000110000001000000100"b); /* tnz [endtag],ic */ dcl adjust_length_instr (12) bit (36) static init ("110000000000110001111101101001000000"b, /* sta pr6|61 (atemp) */ "110000000000110100100101000001000000"b, /* stz pr6|64 (x1temp) */ "110000000000110100100100001001000000"b, /* sxl1 pr6|64 (x1temp) */ "110000000000110100000111101001000000"b, /* ada pr6|64 (x1temp) */ "110000000000110101001001101001000000"b, /* cmpa pr6|65 (rlen) */ "000000000000000110110000100100000100"b, /* tmoz 6,ic (not ovfl) */ "110000000000110110000101100001000000"b, /* aos pr6|66 (ovfl) */ "110000000000110100011011101001000000"b, /* lca pr6|64 (x1temp) */ "110000000000110101000111101001000000"b, /* ada pr6|65 (rlen) */ "000000000000000000110000000000000100"b, /* tze [endtag],ic (none left) */ "000000000000000010111001000000000100"b, /* tra 2,ic (join) */ "110000000000110001010011101001000000"b); /* lda pr6|61 (atemp) */ dcl scan_loop_instr (16) bit (36) static init ("110000000000110011111010010001000000"b, /* lxl2 pr6|63 (dlen) */ "110000000000110001100101000001000000"b, /* stz pr6|61 (atemp) */ "110000000000110001010011101001000000"b, /* lda pr6|61 (atemp) */ "110000000000110011000111101001000000"b, /* ada pr6|63 (dlen) */ "110000000000110010001001101001000000"b, /* cmpa pr6|62 (slen) */ "000000000000000011110000100100000100"b, /* tmoz 3,ic (still more) */ "110000000000110010010011101001000000"b, /* lda pr6|62 (slen) */ "000000000000001001111001000000000100"b, /* tra 11,ic (no luck, exit) */ "110000000000110001010011101001000000"b, /* lda pr6|61 (atemp) */ "000000000001100101001000110101100000"b, /* cmpc (pr,rl),(pr,rl,al) */ "000000000000000000000000000000001010"b, /* desc9a delimiter (len in A) */ "010000000000000000000000000000001010"b, /* desc9a pr2|0 (len in A) */ "000000000000000100110000000000000100"b, /* tze 4,ic (found it) */ "000000000000000001000111101000000111"b, /* ada 1,dl (bump index) */ "110000000000110001111101101001000000"b, /* sta pr6|61 (atemp) */ "111111111111110100111001000000000100"b); /* tra -14,ic (and again) */ dcl adjust_and_test_x1_instr (8) bit (36) static init ("000000000000000001010011110000000111"b, /* ldq 1,du (in case of ovfl) */ "110000000000110110111101110001000000"b, /* stq pr6|66 (ovfl) */ "110000000000110000111010001001000000"b, /* lxl1 pr6|60 (ptr) */ "000000000000000001001110001000000011"b, /* sbx1 1,du (create offset) */ "000000000000000000110000100000000100"b, /* tmi [endtag],ic ((out of range) */ "110000000000110000001001101001000000"b, /* cmpa pr6|60 (ptr) */ "000000000000000000110000100000000100"b, /* tmi [endtag],ic (out of range) */ "110000000000110110100101000001000000"b); /* stz pr6|66 (ovfl) */ dcl set_x1_instr (2) bit (36) static init ("000000000000000000110010001000000000"b, /* eax1 0 */ "110000000000110110100101000001000000"b); /* stz pr6|66 (ovfl) */ dcl set_pointer_instr (2) bit (36) static init ("000000000000000001000110001000000011"b, /* adx1 1,du */ "110000000000110000100100001001000000"b); /* sxl1 pr6|60 (ptr) */ dcl asa_instr bit (36) static init ("110000000001010000000101101001000000"b) options (constant); /*-05/05/76-*/ dcl tra_instr bit (36) static init ("000000000000000000111001000000000100"b); dcl 1 addr_struct static, 2 type fixed bin init (4), 2 operand_no fixed bin init (2), 2 lock fixed bin init (0), 2 op1, 3 tptr ptr, 3 sr fixed bin init (0), 3 ic_mod fixed bin, 3 size_sw fixed bin init (1), 2 op2, 3 tptr ptr, 3 sr fixed bin init (0), 3 ic_mod fixed bin, 3 size_sw fixed bin init (1); dcl 1 pr_struct static, 2 pr fixed bin, 2 pointer_no bit (3), 2 lock fixed bin init (1), 2 switch fixed bin init (0), 2 segno fixed bin, 2 offset fixed bin, 2 reset fixed bin; dcl 1 reg_struct static, 2 what_reg fixed bin, 2 reg_no bit (4), 2 lock fixed bin init (1), 2 already_there fixed bin, 2 contains fixed bin init (0), 2 pointer ptr init (null ()), 2 literal bit (36) init (""b); dcl ptr_off fixed bin static init (48); dcl ptr_offx4 fixed bin static init (192); dcl atemp_off fixed bin static init (49); dcl slen_off fixed bin static init (50); dcl dlen_off fixed bin static init (51); dcl x1temp_off fixed bin static init (52); dcl rlen_off fixed bin static init (53); dcl ovfl_off fixed bin static init (54); dcl ovfl_offx4 fixed bin static init (216); dcl 1 type3, 2 alignment ptr, /* so as to double word align the space */ 2 rest char (26); dcl 1 stype9, 2 alignment ptr, 2 rest char (140); dcl 1 rtype9, 2 alignment ptr, 2 rest char (140); dcl 1 dtype9, 2 alignment ptr, 2 rest char (140); dcl type9_chars char (148) aligned based (type9_ptr); dcl fixlen (0:255) fixed bin auto; dcl endtag fixed bin; dcl (i, j, next) fixed bin; dcl ic fixed bin; dcl temp fixed bin; dcl (from_len, to_len) fixed bin; dcl (varlen, litlen) fixed bin; dcl total_fixlen fixed bin; dcl rlen fixed bin (20); dcl ovfl_no fixed bin; dcl varlen_no fixed bin; dcl fill_char char (1); dcl temp_lit char (256); dcl pr2set bit (1); dcl lit bit (18); dcl nolimit bit (1); dcl two_in_one bit (1); dcl move_completed bit (1); dcl scan_instr_ptr ptr; dcl stptr ptr; dcl dtptr ptr; dcl dn_ptr ptr; dcl pr_struct_ptr ptr; dcl type9_ptr ptr; dcl cobol_addr entry (ptr, ptr, ptr); dcl cobol_emit entry (ptr, ptr, fixed bin); dcl cobol_get_size entry (ptr, fixed bin, fixed bin); dcl cobol_set_pr entry (ptr, ptr); dcl cobol_make_type9$type2_3 entry (ptr, ptr); dcl cobol_make_type3$type1 entry (ptr, ptr); dcl cobol_io_util$move_lit entry (bit (3) aligned, fixed bin, fixed bin, char (*)); dcl cobol_io_util$move entry (bit (3) aligned, fixed bin, fixed bin, bit (3) aligned, fixed bin, fixed bin); dcl cobol_io_util$t9dec_to_bin entry (bit (3) aligned, fixed bin, ptr); dcl cobol_io_util$bin_to_t9dec entry (bit (3) aligned, fixed bin, ptr); dcl cobol_reset_r$in_line entry; dcl cobol_pointer_register$priority entry (fixed bin, fixed bin, bit (3) aligned); dcl cobol_register$load entry (ptr); dcl cobol_make_tagref entry (fixed bin, fixed bin, ptr); dcl cobol_define_tag_nc entry (fixed bin, fixed bin); /*************************************/ start: endtag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; total_fixlen = 0; if s.rtp -> data_name.item_length = 0 then do; /* special case - string into unlimited stack area */ nolimit = "1"b; rlen = 1048575; /* segment size is only limiting factor */ end; else do; nolimit = "0"b; if s.rtp -> data_name.variable_length then rlen = 0; else rlen = s.rtp -> data_name.item_length; end; /* varlen_no = 1st sending field whose length can't be predetermined; 0 indicates all fixed */ if s.ptp = null () & rlen ^= 0 then do; /* try optimizing */ ovfl_no, varlen_no = 0; do i = 1 to s.n while (varlen_no = 0 & ovfl_no = 0); if s.dtp (i) ^= null () /*[4.2-1]*/ then do; varlen_no = i; /*[4.2-1]*/ fixlen (i) = 0; /*[4.2-1]*/ end; else do; dn_ptr = s.stp (i); if data_name.type = 9 then do; if data_name.variable_length then varlen_no = i; else fixlen (i) = data_name.item_length; end; else if data_name.type = 3 then fixlen (i) = dn_ptr -> alphanum_lit.lit_size; else if data_name.type = 2 then fixlen (i) = dn_ptr -> numeric_lit.places; else fixlen (i) = 1; /* fig-con */ end; if varlen_no = 0 then do; if rlen < total_fixlen + fixlen (i) then do; /* overflow */ fixlen (i) = rlen - total_fixlen; ovfl_no = i; end; else do; total_fixlen = total_fixlen + fixlen (i); if rlen = total_fixlen then if s.n > i then ovfl_no = i; end; end; end; if varlen_no ^= 1 then do; /* at least one fixed length */ type9_ptr = addr (rtype9); type9_chars = s.rtp -> type9_chars; addr_struct.op2.tptr = type9_ptr; fixlen (0) = 0; end; end; else varlen_no = 1; /* can't optimize */ if varlen_no ^= 0 then do; /* at least one non-fixed length */ /* SET PR1 TO PT TO RECEIVING ITEM */ pr_struct_ptr = addr (pr_struct); pr_struct.pr = 1; call cobol_set_pr (pr_struct_ptr, s.rtp); do reg_struct.what_reg = 1, 11, 12; /* lock A, X1, and X2 */ call cobol_register$load (addr (reg_struct)); end; /* ESTABLISH SIZE OF RECEIVING ITEM */ if ^nolimit then call cobol_get_size (s.rtp, rlen_off, 0); /* INITIALIZE X1 (indexes receiving item) */ if s.ptp = null () then do; if nolimit then ic = 1; /* no ovfl checking will be done */ else ic = 2; substr (set_x1_instr (1), 1, 18) = substr (unspec (total_fixlen), 19, 18); call cobol_emit (addr (set_x1_instr), null (), ic); end; else do; call cobol_io_util$t9dec_to_bin ("110"b, ptr_offx4, ptp); call cobol_emit (addr (adjust_and_test_x1_instr), null (), 8); call cobol_make_tagref (endtag, cobol_$text_wd_off - 4, null ()); call cobol_make_tagref (endtag, cobol_$text_wd_off - 2, null ()); end; end; do i = 1 to s.n; /* DETERMINE NUMBER OF CHARS TO BE MOVED AND STORE IN A */ dn_ptr = s.stp (i); if data_name.type = 9 then stptr = dn_ptr; else do; if data_name.type = 1 then do; dn_ptr = addr (type3); call cobol_make_type3$type1 (dn_ptr, s.stp (i)); end; stptr = addr (stype9); call cobol_make_type9$type2_3 (stptr, dn_ptr); end; pr2set = "0"b; if varlen_no = 0 | i < varlen_no then do; /* fixed length move */ type9_ptr -> data_name.offset = type9_ptr -> data_name.offset + fixlen (i - 1); addr_struct.op1.tptr = stptr; from_len, to_len = fixlen (i); fixlen_mlr_instr (2) = unspec (from_len); fill_char = ""; two_in_one = "0"b; if i < s.n & i ^= ovfl_no then do; /* try optimizing with fill char */ next = i + 1; dn_ptr = s.stp (next); /*[4.2-1]*/ if fixlen (next) ^= 0 & data_name.type < 4 then do; /* not a variable */ if data_name.type = 1 then do; dn_ptr = addr (type3); call cobol_make_type3$type1 (dn_ptr, s.stp (next)); end; litlen = fixlen (next); if data_name.type = 3 then substr (temp_lit, 1, litlen) = substr (dn_ptr -> alphanum_lit.string, 1, litlen); else substr (temp_lit, 1, litlen) = substr (dn_ptr -> numeric_lit.literal, 1, litlen); fill_char = substr (temp_lit, 1, 1); to_len = from_len + litlen; two_in_one = "1"b; do j = 2 to litlen while (two_in_one); if substr (temp_lit, j, 1) ^= fill_char then do; to_len = from_len; fill_char = ""; two_in_one = "0"b; end; end; if two_in_one then do; /* skip next move */ fixlen (next) = fixlen (i) + fixlen (next); i = next; end; end; end; fixlen_mlr_instr (3) = unspec (to_len); call cobol_addr (addr (addr_struct), addr (fixlen_mlr_instr), null ()); move_completed = "0"b; if ^two_in_one then do; /* try to optimize */ if substr (fixlen_mlr_instr (1), 12, 7) = "1000000"b then do; if s.stp (i) -> data_name.type = 3 then do; call cobol_io_util$move_lit (substr (fixlen_mlr_instr (3), 1, 3), fixed (substr (fixlen_mlr_instr (3), 4, 17)), fixed (substr (fixlen_mlr_instr (3), 25, 12)), substr (s.stp (i) -> alphanum_lit.string, 1, s.stp (i) -> alphanum_lit.lit_size)); move_completed = "1"b; end; else if substr (fixlen_mlr_instr (1), 30, 7) = "1000000"b then do; call cobol_io_util$move (substr (fixlen_mlr_instr (3), 1, 3), fixed (substr (fixlen_mlr_instr (3), 4, 17)), fixed (substr (fixlen_mlr_instr (3), 25, 12)), substr (fixlen_mlr_instr (2), 1, 3), fixed (substr (fixlen_mlr_instr (2), 4, 17)), fixed (substr (fixlen_mlr_instr (2), 25, 12))); move_completed = "1"b; end; end; end; /* try to optimize */ if ^move_completed then do; substr (fixlen_mlr_instr (1), 1, 9) = unspec (fill_char); call cobol_emit (addr (fixlen_mlr_instr), null (), 3); end; if i = ovfl_no then return; /* just like that */ end; else do; /* variable length move */ if s.dtp (i) = null () then do; /* no delimiter */ call cobol_get_size (stptr, 0, 0); if nolimit then if stptr -> data_name.type = 9 then if stptr -> data_name.variable_length then call cobol_emit (addr (asa_instr), null (), 1); end; else do; call cobol_get_size (stptr, slen_off, 0); dn_ptr = s.dtp (i); litlen, varlen = 0; if data_name.type < 4 then do; if data_name.type = 1 then do; dn_ptr = addr (type3); call cobol_make_type3$type1 (dn_ptr, s.dtp (i)); end; if data_name.type = 2 then do; if dn_ptr -> numeric_lit.places < 3 then do; lit = substr (unspec (dn_ptr -> numeric_lit.literal), 1, 18); litlen = dn_ptr -> numeric_lit.places; end; end; else if data_name.type = 3 then do; if dn_ptr -> alphanum_lit.lit_size < 3 then do; lit = substr (unspec (dn_ptr -> alphanum_lit.string), 1, 18); litlen = dn_ptr -> alphanum_lit.lit_size; end; end; if litlen = 0 then do; dtptr = addr (dtype9); call cobol_make_type9$type2_3 (dtptr, dn_ptr); end; end; else do; /* type9 token */ if ^data_name.variable_length & data_name.item_length < 3 then varlen = data_name.item_length; dtptr = dn_ptr; end; call cobol_pointer_register$priority (2, 0, "010"b); /* unlock pr2 */ pr_struct.pr = 2; call cobol_set_pr (pr_struct_ptr, stptr); pr2set = "1"b; if litlen > 0 | varlen > 0 then do; if litlen = 2 | varlen = 2 then do; /* SCD */ scan_instr_ptr = addr (scd_instr); ic = 6; end; else do; /* SCM */ scan_instr_ptr = addr (scm_instr); ic = 5; end; if varlen > 0 then do; /* scan to variable */ addr_struct.op1.tptr = null (); addr_struct.op2.tptr = dtptr; call cobol_addr (addr (addr_struct), scan_instr_ptr, null ()); end; else do; /* scan to literal */ substr (scan_instr (1), 12, 7) = "0000011"b; /* du */ scan_instr (3) = lit; end; call cobol_emit (scan_instr_ptr, null (), ic); end; else do; call cobol_get_size (dtptr, dlen_off, 0); addr_struct.op1.tptr = dtptr; addr_struct.op1.ic_mod = 0; addr_struct.op2.tptr = null (); call cobol_addr (addr (addr_struct), addr (scan_loop_instr (10)), null ()); if addr_struct.op1.ic_mod = 1 then do; temp = fixed (substr (scan_loop_instr (11), 1, 18), 18) - 9; substr (scan_loop_instr (11), 1, 18) = substr (unspec (temp), 19, 18); end; call cobol_emit (addr (scan_loop_instr), null (), 16); end; end; /* ADJUST LENGTH IF NECESSARY AND RECORD OVERFLOW */ if ^nolimit then do; call cobol_emit (addr (adjust_length_instr), null (), 12); call cobol_make_tagref (endtag, cobol_$text_wd_off - 3, null ()); end; /* MOVE STRING AND CHECK OVERFLOW */ if ^pr2set then do; addr_struct.op1.tptr = stptr; addr_struct.op2.tptr = null (); call cobol_addr (addr (addr_struct), addr (move_instr), null ()); end; else do; substr (move_instr (1), 30, 7) = "1100000"b; move_instr (2) = "010000000000000000000000000000000101"b; end; call cobol_emit (addr (move_instr), null (), 3); if i = s.n then do; if s.ptp ^= null () then call cobol_emit (addr (check_ovfl_instr), null (), 3); end; else if nolimit then call cobol_emit (addr (check_ovfl_instr), null (), 3); else do; call cobol_emit (addr (check_ovfl_instr), null (), 5); call cobol_make_tagref (endtag, cobol_$text_wd_off - 1, null ()); end; end; end; if ^nolimit then do; call cobol_define_tag_nc (endtag, cobol_$text_wd_off); if s.ptp ^= null () then do; /* must set pointer */ call cobol_emit (addr (set_pointer_instr), null (), 2); call cobol_io_util$bin_to_t9dec ("110"b, ptr_offx4, s.ptp); end; if s.tag > 0 then do; if varlen_no = 0 then call cobol_emit (addr (tra_instr), null (), 1); /* overflow impossible */ else call cobol_emit (addr (bypass_ovfl_instr), null (), 2); call cobol_make_tagref (s.tag, cobol_$text_wd_off - 1, null ()); end; end; call cobol_reset_r$in_line; exit: return; /*************************************/ /***** Declaration for builtin function *****/ dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index) builtin; /***** End of declaration for builtin function *****/ %include cobol_type1; %include cobol_type2; %include cobol_type3; %include cobol_type9; %include cobol_; end cobol_string;  cobol_string_gen.pl1 05/24/89 1042.8rew 05/24/89 0832.2 28134 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_string_gen.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* format: style3 */ cobol_string_gen: proc (mp_ptr, passed_tag); dcl mp_ptr ptr; dcl passed_tag fixed bin; dcl 1 mp based (mp_ptr), 2 n fixed bin, 2 pt (0 refer (mp.n)) ptr; dcl 1 s auto, 2 n fixed bin, 2 tag fixed bin, 2 rtp ptr, 2 ptp ptr, 2 str (256), 3 stp ptr, 3 dtp ptr; dcl (i, j, k, startj) fixed bin; dcl into_key fixed bin static init (116); dcl size_key fixed bin static init (161); dcl delimited_key fixed bin static init (90); dcl dn_ptr ptr; dcl tptr ptr; dcl cobol_string entry (ptr); /*************************************/ start: eos_ptr = mp.pt (mp.n); if end_stmt.b then do; passed_tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; s.tag = passed_tag; end; else s.tag = 0; j = 0; startj = 1; do i = 2 to mp.n - 1; dn_ptr = mp.pt (i); if data_name.type = 1 then do; if dn_ptr -> reserved_word.key = into_key then do; /* INTO */ i = i + 1; s.rtp = mp.pt (i); if end_stmt.c then do; i = i + 1; s.ptp = mp.pt (i); end; else s.ptp = null (); end; else if dn_ptr -> reserved_word.key = delimited_key then do; i = i + 1; dn_ptr = mp.pt (i); tptr = dn_ptr; if data_name.type = 1 then if dn_ptr -> reserved_word.key = size_key then tptr = null (); do k = startj to j; s.str.dtp (k) = tptr; end; startj = j + 1; end; else do; /* fig con */ j = j + 1; s.stp (j) = mp.pt (i); end; end; else do; /* non-type1 */ j = j + 1; s.stp (j) = mp.pt (i); end; end; s.n = j; /* s.str.dtp(s.n)=null();*/ call cobol_string (addr (s)); return; /*************************************/ /***** Declaration for builtin function *****/ dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index) builtin; /***** End of declaration for builtin function *****/ %include cobol_type1; %include cobol_type9; %include cobol_type19; %include cobol_; end cobol_string_gen;  cobol_subtract_gen.pl1 05/24/89 1042.8rew 05/24/89 0832.2 16299 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_subtract_gen.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* format: style3 */ cobol_subtract_gen: proc (in_token_ptr, next_stmt_tag); /* This procedure acts as an interface between the Multics COBOL compiler generator driver, cobol_gen_driver_, and the procedure that actually generates code to do the work to accomplish a COBOL SUBTRACT. This procedure actually is not required. The cobol generator driver could be modified to call cobol_add_gen directyl for SUBTRACT statements. */ dcl in_token_ptr ptr; dcl next_stmt_tag fixed bin; dcl cobol_add_gen ext entry (ptr, fixed bin); call cobol_add_gen (in_token_ptr, next_stmt_tag); /***** Declaration for builtin function *****/ dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index) builtin; /***** End of declaration for builtin function *****/ end cobol_subtract_gen;  cobol_sym_init.pl1 05/24/89 1042.8rew 05/24/89 0832.2 73260 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_sym_init.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 10/13/81 by FCH, [5.0-1], 32 char used-id caused seg-fault, BUG514(phx11725) */ /* Modified on 05/29/81 by FCH, [4.4-1], dtm incorrectly stored in obj module, phx09946(BUG485) */ /* Modified on 10/25/78 by FCH, [3.0-4], c_name decl changed */ /* Modified on 06/22/78 by RAL, [3.0-3], rewrote symbol_section to handle source and include files */ /* Modified on 04/27/78 by FCH, [3.0-2], symbol_section(source module path name) */ /* Modified on 04/27/78 by FCH, [3.0-1], compiler options to symbol sect */ /* Modified since Version 3.0 */ /* format: style3 */ cobol_sym_init: proc (tpath); /* [3.0-2] */ /* This procedure builds the SYMBOL SECTION (header, source_map, variable_area, symbol_relocation_block) The external procedure RELP1 is used to calculate the relative pointers used within all structures. */ sym_ptr = cobol_$sym_base_ptr; /* =====HEADER================ */ relp = "000000000000010100"b; /* set start of header variable area +20(decimal) words */ symbol_block_header.decl_vers = 1; symbol_block_header.identifier = "symbtree"; symbol_block_header.gen_version_number = 1; time = clock_ (); call date_time_ (time, string); symbol_block_header.gen_creation_time = time; /* TBD */ symbol_block_header.object_creation_time = time; symbol_block_header.generator = "cobol "; /* Build and Set gen_version_name */ pp = addrel (sym_ptr, relp); symbol_block_header.gen_version_name_relp = relp; /* always begins at 20th word in symbol section. */ substr (is, 1, 48) = "Multics COBOL, Version " || fixed_common.compiler_rev_no; symbol_block_header.gen_version_name_length = "000000000000110000"b; /* 48(decimal) */ /* Build and Set userid */ char_string = get_group_id_ (); l = symbol_block_header.gen_version_name_length; symbol_block_header.userid_relp = RELP1 (relp, l); n = index (char_string, " ") - 1; /*[5.0-1]*/ if n < 1 then n = 32; symbol_block_header.userid_length = substr (unspec (n), 19, 18); pp = addrel (sym_ptr, userid_relp); substr (is, 1, n) = char_string; /* no comments */ l = symbol_block_header.userid_length; relp = symbol_block_header.userid_relp; /* [3.0-1] */ symbol_block_header.comment_relp = RELP1 (relp, l); /* [3.0-1] */ symbol_block_header.comment_length = substr (unspec (cobol_options_len), 19, 18); /* [3.0-1] */ pp = addrel (sym_ptr, symbol_block_header.comment_relp); /* [3.0-1] */ substr (is, 1, cobol_options_len) = cobol_options;/* [3.0-1] */ symbol_block_header.text_boundary = "000000000000000010"b; /* 2 */ symbol_block_header.stat_boundary = "000000000000000010"b; /* 2 */ /* the following items are set further into the compilation */ symbol_block_header.section_relp = "0"b; symbol_block_header.block_size = "0"b; symbol_block_header.next_block_thread = "0"b; symbol_block_header.text_relocation_relp = "0"b; symbol_block_header.def_relocation_relp = "0"b; symbol_block_header.link_relocation_relp = "0"b; /* Build and Set source map */ RR = fixed (symbol_block_header.gen_version_name_length, 18) + fixed (symbol_block_header.userid_length, 18) + fixed (symbol_block_header.comment_length, 18); l = substr (unspec (RR), 19, 18); symbol_block_header.source_map_relp = RELP1 (relp, l); if substr (userid_length, 17, 2) ^= "00"b then do; RR = fixed (symbol_block_header.source_map_relp, 18) + 1; symbol_block_header.source_map_relp = substr (unspec (RR), 19, 18); RR = fixed (l, 18) + 4; l = substr (unspec (RR), 19, 18); end; /* =====SOURCE_MAP============ */ /* [3.0-3] */ p1 = addrel (sym_ptr, source_map_relp); source_map.decl_vers = 1; call cobol$pop_name (c_name_ptr); source_map.size = c_name.ct; RR = fixed (l, 18) + 8 + (16 * source_map.size); l = substr (unspec (RR), 19, 18); do i = source_map.size to 1 by -1; RR = c_name.size + 1; source_map.map.pathname_length (i) = substr (unspec (RR), 19, 18); source_map.map.pathname_relp (i) = RELP1 (relp, l); RR = fixed (l, 18); RR = RR + fixed (pathname_length (i), 18); l = substr (unspec (RR), 19, 18); source_map.map.uid (i) = c_name.uid; /*[4.4-1]*/ source_map.map.dtm (i) = 10000000000000000b * binary (c_name.dtm, 36); pp = addrel (sym_ptr, source_map.pathname_relp (i)); substr (is, 1, fixed (source_map.pathname_length (i), 18)) = substr (c_name.pname, 1, c_name.size); seg_name_length = c_name.size + 1; call cobol$pop_name (c_name_ptr); end; /* [3.0-3] */ /* =====VARIABLE_AREA========= */ RR = fixed (l, 18) + fixed (pathname_length (source_map.size), 18); l = substr (unspec (RR), 19, 18); area_relp = RELP1 (relp, l); p2 = addrel (sym_ptr, area_relp); variable_area.decl_vers = 1; variable_area.identifier = "pl1info "; variable_area.flags = 0; variable_area.greatest_severity = 0; variable_area.root = "0"b; variable_area.profile = "0"b; variable_area.map_first = "0"b; variable_area.map_last = "0"b; RR = fixed (area_relp, 18) + 8; variable_area.segname_relp = substr (unspec (RR), 19, 18); variable_area.segname_length = substr (unspec (seg_name_length), 19, 18); RR = fixed (l, 18) + 32; l = substr (unspec (RR), 19, 18); pp = addrel (sym_ptr, RELP1 (relp, l)); substr (is, 1, seg_name_length) = cobol_$obj_seg_name; /* =====clean up================== */ RR = fixed (l, 18) + seg_name_length; l = substr (unspec (RR), 19, 18); default_truncate = RELP1 (relp, l); optional_truncate = default_truncate; sym_wd_off = fixed (default_truncate, 18); call cobol_reloc (null (), 2 * sym_wd_off, 3004); return; RELP1: proc (RC, RL) returns (bit (18)); declare (RC, RL) bit (18), (rc, rl) fixed bin; rl = fixed (RL, 18); rc = fixed (RC, 18); RR = rl + mod (-rl, 4); RL = substr (unspec (RR), 19, 18); RR = divide (RR, 4, 31, 0) + rc; return (substr (unspec (RR), 19, 18)); end RELP1; /* [3.0-3] */ dcl i fixed bin; /* [3.0-3] */ dcl 1 c_name based (c_name_ptr), /*[3.0-4]*/ 2 ct fixed bin, /*[3.0-4]*/ 2 size fixed bin, /*[3.0-4]*/ 2 last_name_ptr ptr, /* [3.0-3] */ 2 pname char (168) aligned, /* [3.0-3] */ 2 uid bit (36), /* [3.0-3] */ 2 dtm bit (36); /* [3.0-3] */ dcl c_name_ptr ptr; /* [3.0-3] */ dcl cobol$pop_name entry (ptr); declare tpath char (168) aligned; /* [3.0-2] */ dcl date_time_ entry (fixed bin (71), char (*)) ext, cobol_reloc entry (ptr, fixed bin, fixed bin) ext, get_group_id_ entry returns (char (32)) ext, clock_ entry returns (fixed bin (71)) ext, get_wdir_ entry returns (char (168)) ext, (relp, l) bit (18), (n, seg_name_length) fixed bin, RR fixed bin, time fixed bin (71) aligned, dirname char (168) aligned, string char (24), char_string char (32), temp_string char (26000) aligned, (p1, p2, pp) ptr, is char (262000) aligned based (pp); dcl addrel builtin; dcl unspec builtin; dcl fixed builtin; dcl index builtin; dcl null builtin; dcl substr builtin; %include cobol_sbh; %include cobol_fixed_common; %include cobol_ext_; %include cobol_source_map; %include cobol_variable_area; %include cobol_relinfo; %include cobol_; end;  cobol_trans_alphabet.pl1 05/24/89 1042.8rew 05/24/89 0832.2 97866 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_trans_alphabet.pl1 Added Trace statements. END HISTORY COMMENTS */ /* Modified on 10/19/84 by FCH, [5.3-1], BUG563(phx18381), new cobol_addr_toke.nincl.pl1 */ /* Modified on 10/9/76 by George Mercuri to fix the bug for code_set. */ /* Modified on 9/01/76 by Bob Chang to fix the bug for code_set. */ /* Modified on 7/30/76 by Bob Chang to fix the bug for high vaule. */ /* Modified on 7/26/76 by Bob Chang to fix the bug for table of alphabet_name . */ /* Created on 6/21/76 by Bob Chang to implement the alphabet_name. */ /* format: style3 */ cobol_trans_alphabet: proc (lop_ptr, rop_ptr, code_set, from_flag, sort_pcs_ptr, cmpc_filler); /* This procedure generates code that translates the ascii alphanumeric operands of an alphanumeric comparison to alphabet alphanumeric operands. */ /* Assertions at entry: 1. lop_ptr points to the left alphanumeric (ascii) data name (type 9) token. 2. rop_ptr points to the right alphanumeric (ascii) data name (type 9) token. 3. cmpc_filler contains the ascii fill character to be inserted into the cmpc instruction. Assertions at exit: 1. lop_ptr points to the left alphanumeric (alphabet) data name (type 9) token. 2. rop_ptr points to the right alphanumeric (alphabet) data name (type 9) token. 3 cmpc_filler contains the alphabet fill character to be inserted into the cmpc instruction. */ io_flag = 0; goto start; io: entry (lop_ptr, rop_ptr, code_set, from_flag); io_flag = 1; /* The entry for io has the lop_ptr as the input operand and rop_ptr as the output operand of the type9 token on the stack frame. */ /* DECLARATIONS OF THE PARAMETERS */ dcl lop_ptr ptr; dcl rop_ptr ptr; dcl sort_pcs_ptr ptr; dcl cmpc_filler char (1); /*}*/ /* Declarations of internal variables */ dcl alphabet_lop_ptr ptr; dcl alphabet_rop_ptr ptr; dcl t_offset fixed bin; dcl continue bit (1); dcl cond bit (1); dcl io_flag fixed bin; dcl code_set fixed bin; dcl from_flag fixed bin; dcl source_ptr ptr; dcl dest_ptr ptr; dcl work_binary fixed bin (35); dcl descrip_ptr ptr; dcl descrip bit (72) based (descrip_ptr); dcl 1 alpha_type9 static, 2 header (4) fixed bin init (112, 0, 0, 9), 2 repl_ptr (2) ptr init ((2) null ()), 2 fill1 bit (108) init (""b), 2 file_key_info, 3 fb1 (3) fixed bin init (0, 0, 0), 3 size fixed bin init (512), 3 fb2 (2) fixed bin init (0, 0), 3 flags1 bit (36) init ("010000100100000000010000000100000000"b), 3 flags2 bit (36) init (""b), 3 seg fixed bin init (0), 3 off fixed bin, 2 fill2 (7) fixed bin init (0, 0, 0, 0, 0, 0, 0); dcl 1 eis_inst aligned based (eis_ptr), 2 unused bit (18) unaligned, 2 opcode bit (10) unaligned; dcl 1 work_inst based (inst_ptr), 2 left_half bit (18), 2 right_half bit (18); /* DECLARATIONS OF VARIABLES USED TO TRANSLATE ASCII TO EBCDIC */ dcl alphabet_allocated fixed bin int static init (0); dcl mvt_op bit (10) int static init ("0011100001"b /* 160(1) */); dcl mvt_table char (512) based (mvt_table_ptr), mvt_table_ptr ptr; dcl dn_ptr ptr; dcl eis_ptr ptr; dcl alphabet_mvt_type9 (1:40) fixed bin int static; /* Buffer in which the data name operand (type 9) that describes the alphabet mvt table is built. */ dcl alphabet_mvt_type9_ptr ptr int static; /* Pointer to the alphabet_mvt_type9 operand */ dcl alphabet_lop (1:40) fixed bin int static; /* Buffer in which the data name operand (type 9) for the alphabet left operand is built. */ dcl alphabet_rop (1:40) fixed bin int static; /* Buffer in which the data name operrand (type 9) for the alphabet right operand is built */ /* Definition of eis fill character */ dcl 1 eis_fill_def int static, 2 space char (1) init (" "), 2 zero char (1) init ("0"), 2 quote char (1) init (""""), 2 high_value char (1) init (""), /* INIT TO OCTAL 177. */ 2 low_value char (1) init (""); /* INIT TO OCTAL 000. */ /* Declaration for the procedures to be called. */ dcl cobol_addr entry (ptr, ptr, ptr), cobol_alloc$stack entry (fixed bin, fixed bin, fixed bin), cobol_emit entry (ptr, ptr, fixed bin); dcl cobol_make_type9$copy ext entry (ptr, ptr); /* WORK BUFFER IN WHICH INPUT TO THE ADDRESSABILITY UTILITY IS BUILT */ dcl wkbuff1 (1:20) fixed bin; /* WORK BUFFER IN WHICH THE OUTPUT FROM THE ADDRESSABILITY UTILITY IS RETURNED */ dcl wkbuff2 (1:5) fixed bin; /* WORK BUFFER IN WHICH RELOCATION INFORMATION IS PLACED BY THE ADDRESSABILITY UTILITY */ dcl wkbuff3 (1:10) fixed bin; /**************************************************/ /* START OF EXECUTION */ /* cobol_trans_alphabet */ /**************************************************/ start: input_ptr = addr (wkbuff1 (1)); inst_ptr = addr (wkbuff2 (1)); reloc_ptr = addr (wkbuff3 (1)); cond = "0"b; continue = "1"b; dn_ptr = addr (alpha_type9); if io_flag > 0 then do; data_name.seg_num = 3; if from_flag = 1 then data_name.offset = alphabet_from_offset (code_set) * 4; else data_name.offset = alphabet_to_offset (code_set) * 4; source_ptr = lop_ptr; /* TEMPORARY */ dest_ptr = rop_ptr; /* TEMPORARY */ end; else do; if sort_pcs_ptr = null () then alpha_name_ptr = cobol_$main_pcs_ptr; else alpha_name_ptr = sort_pcs_ptr; data_name.seg_num = alphabet_name.segno; data_name.offset = alphabet_name.offset; /* Make copies of the input data name tokens */ alphabet_lop_ptr = addr (alphabet_lop (1)); alphabet_rop_ptr = addr (alphabet_rop (1)); call cobol_make_type9$copy (alphabet_lop_ptr, lop_ptr); call cobol_make_type9$copy (alphabet_rop_ptr, rop_ptr); alphabet_lop_ptr -> data_name.subscripted = "0"b; alphabet_rop_ptr -> data_name.subscripted = "0"b; /* Allocate on the run-time stack, a striing of bytes equal to the length of the left operand */ call cobol_alloc$stack (fixed (alphabet_lop_ptr -> data_name.item_length, 17), 0, t_offset); /* Update the left operand to the stack segment number, and the offset just returned */ alphabet_lop_ptr -> data_name.seg_num = 1000; /* Run time stack */ alphabet_lop_ptr -> data_name.offset = t_offset; /* offset from alloc$stack */ /* Allocate on the run time stack, a string of bytes equal to the length of the right operand */ call cobol_alloc$stack (fixed (alphabet_rop_ptr -> data_name.item_length, 17), 0, t_offset); /* Update the right operand to the stack segment number and the offset just returned */ alphabet_rop_ptr -> data_name.seg_num = 1000; /* Stack */ alphabet_rop_ptr -> data_name.offset = t_offset; /* offset from alloc$stack */ /* Generate the instructions to move and translate the ascii data to alphabet form in the stack temporaries */ /* Generate code to translate left operand first */ source_ptr = lop_ptr; dest_ptr = alphabet_lop_ptr; end; /* TEMPORARY */ do while (continue); /* Generate mvt instruction for left and right operands */ /* Build the input structure for the addressability utility */ input_struc.type = 5; /* eis, 2 input operands, 2 eis descriptors and an instruction returned */ input_struc.operand_no = 2; input_struc.lock = 0; input_struc.operand.token_ptr (1) = source_ptr; input_struc.operand.send_receive (1) = 0; /* Send */ input_struc.operand.size_sw (1) = 0; input_struc.operand.token_ptr (2) = dest_ptr; input_struc.operand.send_receive (2) = 1; /* Receive */ input_struc.operand.size_sw (2) = 0; /* Call the addressability utility */ call cobol_addr (input_ptr, inst_ptr, reloc_ptr); /* Insert the mvt opcode into the operand field of the returned instruction */ inst_ptr -> eis_inst.opcode = mvt_op; /* Emit the instruction and first two descriptors */ call cobol_emit (inst_ptr, reloc_ptr, 3); /* Build the third descriptor */ input_struc.type = 3; /* eis, 1 input operand, an instruction only returned */ input_struc.operand_no = 1; input_struc.lock = 0; input_struc.operand.token_ptr (1) = dn_ptr; input_struc.operand.send_receive (1) = 0; /* Send */ /* Call the addressability utility */ call cobol_addr (input_ptr, inst_ptr, reloc_ptr); /* Zero the opcode field of the returned instruction */ inst_ptr -> eis_inst.opcode = "0"b; /* Increment the address of the instruction, because addressability calculated it relative to itself, instead of relative to the mvt instruction. */ work_binary = binary (work_inst.left_half, 18); if data_name.seg_num = 3000 then work_binary = work_binary + 3; work_inst.left_half = substr (unspec (work_binary), 19, 18); /* Emit the third descriptor */ call cobol_emit (inst_ptr, reloc_ptr, 1); if io_flag = 1 then return; /* Test to see whether both operands have been translated */ if source_ptr = lop_ptr then do; /* Must translate the right operand next */ source_ptr = rop_ptr; dest_ptr = alphabet_rop_ptr; end; /* Must translate the right operand next */ else continue = "0"b; /* To exit from the loop */ end; /* Generate mvt_instructions for left and right operands */ /* Set lop_ptr and rop_ptr to the data name tokens for the alphabet strings in the stack */ lop_ptr = alphabet_lop_ptr; rop_ptr = alphabet_rop_ptr; /* Translate the cmpc filler character from ascii to alphabet */ cmpc_filler = substr (alphabet_name.table, binary (unspec (cmpc_filler)) + 1, 1); /***** Declaration for builtin function *****/ dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index) builtin; /***** End of declaration for builtin function *****/ %include cobol_; %include cobol_alphabet_offset; %include cobol_addr_tokens; %include cobol_type9; %include cobol_record_types; %include cobol_ext_; %include cobol_type40; end cobol_trans_alphabet;  cobol_unstring.pl1 05/24/89 1042.8rew 05/24/89 0832.1 204264 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_unstring.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 03/26/76 by ORN to MOVE only _o_n_e character of a DELIMITED BY figcon into DELIMITER IN field. */ /* Modified on 03/17/76 by ORN to allow unstringing into non-separate sign numeric data fields by utilizing the new cobol_addr variable length encodement in the seg field of the type 9 token */ /* format: style3 */ cobol_unstring: proc (uptr, rwtp); dcl uptr ptr; dcl rwtp ptr; dcl 1 u based (uptr), 2 n fixed bin, 2 tag fixed bin, 2 stp ptr, /* pts to sending token */ 2 dptr ptr, /* pts to d struct - may be null */ 2 ptp ptr, /* pts to pointer token - may be null */ 2 ttp ptr, /* pts to tallying token - may be null */ 2 unstr (256), 3 rtp ptr, /* pts to receiving token(i) */ 3 dtp ptr, /* pts to delimiter token(i) - may be null */ 3 ctp ptr; /* pts to count token(i) - may be null */ dcl 1 d based (u.dptr), 2 n fixed bin, 2 all_cnt fixed bin, /* number of entries with ALL */ 2 delimiter (256), 3 dtp ptr, /* pts to delimited token */ 3 allsw fixed bin; /* 1 means ALL precedes delimiter */ dcl text (0:10000) bit (36) based (cobol_$text_base_ptr); dcl tra_instr bit (36) static init ("000000000000000000111001000000000100"b); /* tra -,ic */ dcl epp2_instr bit (36) static init ("110000000000000000011101010001000000"b); /* epp2 pr6|- */ dcl spri2_instr bit (36) static init ("110000000000000000010101010001000000"b); /* spri2 pr6|- */ dcl bump_tally_instr bit (36) static init ("110000000000110001000101100001000000"b); /* aos pr6|61 (tally) */ dcl all_loop1_instr (7) bit (36) static init ("110000000000111010111100010001000000"b, /* stx2 pr6|72 */ "000000000000000000110011101000001010"b, /* eaa 0,2 */ "000000000000010010111111001000000000"b, /* arl 22 */ "110000000000111001000111101001000000"b, /* ada pr6|71 */ "000000000000000000110010010000000101"b, /* eax2 0,al */ "110000000000110111001001101001000000"b, /* cmpa pr6|67 */ "000000000000000101110000101100000100"b); /* tpnz 5,ic */ dcl all_loop2_instr (7) bit (36) static init ("111111111111111001110000000000000100"b, /* tze -7,ic */ "110000000000111010010010010001000000"b, /* ldx2 pr6|72 */ "110000000000111010111100001001000000"b, /* stx1 pr6|72 */ "110000000000111010001100010001000000"b, /* ssx2 pr6|72 */ "110000000000111010010010011001000000"b, /* ldx3 pr6|72 */ "110000000000111001001111101001000000"b, /* sba pr6|71 */ "000000000000000000110010010000000101"b); /* eax2 0,al */ dcl init_x2_instr (3) bit (36) static init ("000000000000000000110010010000001001"b, /* eax2 0,1 */ "110000000000111011100101000001000000"b, /* stz pr6|73 */ "000000000000000000111001000000000100"b); /* tra 0,ic */ dcl check_x2_instr (2) bit (36) static init ("110000000000111101001000010001000000"b, /* cmpx2 pr6|75 */ "000000000000000000110000100000000100"b); /* tmi 0,ic */ dcl check_new_x1_instr (9) bit (36) static init ("000000000000000000110011101000001010"b, /* eaa 0,2 */ "000000000000010010111111001000000000"b, /* arl 22 */ "110000000000111001000111101001000000"b, /* ada pr6|71 */ "110000000000110000111101101001000000"b, /* sta pr6|60 */ "000000000000000000110010001000000101"b, /* eax1 0,al */ "110000000000111101001000001001000000"b, /* cmpx1 pr6|75 */ "000000000000000000110000101000000100"b, /* tpl 0,ic */ "000000000000000000110010010000001001"b, /* eax2 0,x1 */ "000000000000000000111001000000000100"b); /* tra 0,ic */ dcl check_del_instr (5) bit (36) static init ("000000000000000000110010011000000101"b, /* eax3 0,al */ "110000000000111011100100010001000000"b, /* sxl2 pr6|73 */ "110000000000111011000111101001000000"b, /* ada pr6|73 */ "110000000000110111001001101001000000"b, /* cmpa pr6|67 */ "000000000000000000110000101100000100"b); /* tpnz 0,ic */ dcl comp_del_instr (4) bit (36) static init ("000000000000000000001000110100000000"b, /* cmpc (EIS) */ "000000000000000000000000000000001011"b, /* (EIS desc.) */ "001000000000000000000000000000001011"b, /* (EIS desc.) */ "000000000000000000110000001000000100"b); /* tnz 0,ic */ dcl set_x3_instr (3) bit (36) static init ("110000000000111010111100001001000000"b, /* stx1 pr6|72 */ "110000000000111010001100010001000000"b, /* ssx2 pr6|72 */ "110000000000111010010010011001000000"b); /* ldx3 pr6|72 */ dcl bump_x2_instr (2) bit (36) static init ("000000000000000001000110010000000011"b, /* adx2 1,du */ "000000000000000000111001000000000100"b); /* tra 0,ic */ dcl bump_x1_instr (5) bit (36) static init ("110000000000111010111100011001000000"b, /* stx3 pr6|72 */ "110000000000111010000110001001000000"b, /* adx1 pr6|72 */ "110000000000110000100100001001000000"b, /* sxl1 pr6|60 */ "110000000000111101001000001001000000"b, /* cmpx1 pr6|75 */ "000000000000000000110000101000000100"b); /* tpl 0,ic */ dcl save_send_len_instr (2) bit (36) static init ("000000000000000000110010010000000101"b, /* eax2 0,al */ "110000000000111101111100010001000000"b); /* stx2 pr6|75 */ dcl set_pointer_instr (6) bit (36) static init ("110000000000111101001000001001000000"b, /* cmpx1 pr6|75 */ "000000000000000010110000100100000100"b, /* tmoz 2,ic */ "110000000000111101010010001001000000"b, /* ldx1 pr6|75 */ "000000000000000001000110001000000011"b, /* adx1 1,du */ "110000000000110000100100001001000000"b, /* sxl1 pr6|60 */ "000000000000000001001110001000000011"b); /* sbx1 1,du */ dcl set_count_instr (3) bit (36) static init ("000000000000000000110011101000001011"b, /* eaa 0,3 */ "000000000000010010111111001000000000"b, /* arl 22 */ "110000000000111011111101101001000000"b); /* sta pr6|73 (temp) */ dcl adjust_length_instr (8) bit (36) static init ("000000000000000000110010011000000101"b, /* eax3 0,al */ "110000000000110000000111101001000000"b, /* ada pr6|60 (ptr) */ "110000000000110111001001101001000000"b, /* cmpa pr6|67 (slen) */ "000000000000000101110000100100000100"b, /* tmoz 5,ic (OK) */ "110000000000110111001111101001000000"b, /* sba pr6|67 (slen) */ "000000000000010010111011101000000000"b, /* als 22 */ "110000000000111010111101101001000000"b, /* sta pr6|72 (utemp) */ "110000000000111010001110011001000000"b); /* sbx3 pr6|72 (utemp) */ dcl bypass_ovfl_instr (2) bit (36) static init ("110000000000111101001000001001000000"b, /* cmpx1 pr6|75 */ "000000000000000000110000101000000100"b); /* tpl 0,ic */ dcl adjust_and_test_x1_instr (6) bit (36) static init ("110000000000110000111010001001000000"b, /* lxl1 pr6|60 (ptr) */ "000000000000000001001110001000000011"b, /* sbx1 1,du (create offset) */ "000000000000000000110000100000000100"b, /* tmi [end_tag],ic (out of range) */ "110000000000110000001001101001000000"b, /* cmpa pr6|60 (ptr) */ "000000000000000000110000100000000100"b, /* tmi [end_tag],ic (out of range) */ "110000000000110000100100001001000000"b); /* sxl1 pr6|60 (ptr) */ dcl zero_x1_instr (2) bit (36) static init ("000000000000000000110010001000000000"b, /* eax1 0 */ "110000000000110000100101000001000000"b); /* stz pr6|60 (ptr) */ dcl 1 mpout auto, 2 n fixed bin, 2 pt1 ptr, 2 pt2 ptr, 2 pt3 ptr, 2 pt4 ptr; dcl 1 addr_struct static, 2 type fixed bin init (4), 2 operand_no fixed bin init (2), 2 lock fixed bin init (0), 2 op1, 3 tptr ptr, 3 sr fixed bin init (0), 3 ic_mod fixed bin, 3 size_sw fixed bin init (1), 2 op2, 3 tptr ptr, 3 sr fixed bin init (0), 3 ic_mod fixed bin, 3 size_sw fixed bin init (0); dcl 1 pr_struct static, 2 pr fixed bin, 2 pointer_no bit (3), 2 lock fixed bin init (1), 2 switch fixed bin init (0), 2 segno fixed bin, 2 offset fixed bin, 2 reset fixed bin; dcl 1 reg_struct static, 2 what_reg fixed bin, 2 reg_no bit (4), 2 lock fixed bin init (1), 2 already_there fixed bin, 2 contains fixed bin init (0), 2 pointer ptr init (null ()), 2 literal bit (36) init (""b); /* scratch pad use 60 ptr 61 tally 62 paddr 64 taddr 67 slen 71 dlen 72 utemp 73 temp 75 uslen */ dcl ptr_off fixed bin static init (48); dcl ptr_offx4 fixed bin static init (192); dcl paddr_off fixed bin static init (50); dcl tally_offx4 fixed bin static init (196); dcl count_offx4 fixed bin static init (236); dcl taddr_off fixed bin static init (52); dcl slen_off fixed bin static init (55); dcl dlen_off fixed bin static init (57); dcl 1 alpha_type9 static, 2 header (4) fixed bin init (112, 0, 0, 9), 2 repl_ptr (2) ptr init ((2) null ()), 2 fill1 bit (108) init (""b), 2 file_key_info, 3 fb1 (3) fixed bin init (0, 0, 0), 3 size fixed bin init (40), 3 fb2 (2) fixed bin init (0, 0), 3 flags1 bit (36) init ("010000100100000000010000000100000000"b), 3 flags2 bit (36) init (""b), 3 seg fixed bin init (11161), /* PR1 with offset X1 and length in X3 (010 1011 1001 1001) */ /*-03/17/76-*/ 3 off fixed bin init (0), 2 fill2 (7) fixed bin init (0, 0, 0, 0, 0, 0, 0); dcl 1 zero_type2 static, 2 size fixed bin init (37), 2 line fixed bin init (0), 2 column fixed bin init (0), 2 type fixed bin init (2), 2 integral bit (1) init ("1"b), 2 floating bit (1) init ("0"b), 2 filler1 bit (5) init (""b), 2 subscript bit (1) init ("0"b), 2 sign char (1) init (" "), 2 exp_sign char (1) init (" "), 2 exp_places fixed bin init (0), 2 places_left fixed bin init (1), 2 places_right fixed bin init (0), 2 places fixed bin init (1), 2 literal char (1) init ("0"); dcl 1 blank_type3 static, 2 size fixed bin init (25), 2 line fixed bin init (0), 2 column fixed bin init (0), 2 type fixed bin init (3), 2 lit_type bit (1) init ("0"b), 2 all_lit bit (1) init ("1"b), 2 filler1 bit (6) init (""b), 2 lit_size fixed bin init (1), 2 string char (1) init (" "); dcl type9_chars char (112) based (addr (type9)); dcl 1 type3 auto, 2 alignment ptr, /* so as to double-word align the space */ 2 rest char (26); dcl 1 type9 auto, 2 header (4) fixed bin, 2 repl_ptr (2) ptr, 2 fill1 bit (108), 2 fb1 (3) fixed bin, 2 size fixed bin, 2 fb2 (2) fixed bin, 2 flags bit (72), 2 seg fixed bin, 2 offset fixed bin, 2 rest char (28); dcl 1 move_eos static, 2 size fixed bin init (38), 2 line fixed bin init (0), 2 column fixed bin init (0), 2 type fixed bin init (19), 2 verb fixed bin init (18), 2 e fixed bin init (1), 2 h fixed bin init (0), 2 i fixed bin init (0), 2 j fixed bin init (0), 2 a bit (3) init (""b), 2 b bit (1) init (""b), 2 c bit (1) init (""b), 2 d bit (2) init (""b), 2 f bit (2) init (""b), 2 g bit (2) init (""b), 2 k bit (5) init (""b); dcl end_tag fixed bin; dcl ovfl_tag fixed bin; dcl nextdel_tag fixed bin; dcl delfound_tag fixed bin; dcl nextpos_tag fixed bin; dcl nextrt_tag fixed bin; dcl (i, j) fixed bin; dcl ic fixed bin; dcl temp fixed bin; dcl psub bit (1); dcl tsub bit (1); dcl lit bit (18); dcl dn_ptr ptr; dcl pr_struct_ptr ptr; dcl cobol_move_gen entry (ptr); dcl cobol_addr entry (ptr, ptr, ptr); dcl cobol_emit entry (ptr, ptr, fixed bin); dcl cobol_get_size entry (ptr, fixed bin, fixed bin); dcl cobol_get_size$omit_sign entry (ptr, fixed bin, fixed bin); dcl cobol_set_pr entry (ptr, ptr); dcl cobol_make_type9$type2_3 entry (ptr, ptr); dcl cobol_make_type3$type1 entry (ptr, ptr); dcl cobol_io_util$t9dec_to_bin entry (bit (3) aligned, fixed bin, ptr); dcl cobol_io_util$bin_to_t9dec entry (bit (3) aligned, fixed bin, ptr); dcl cobol_reset_r$in_line entry; dcl cobol_register$load entry (ptr); dcl cobol_$register$load entry (ptr); dcl cobol_make_tagref entry (fixed bin, fixed bin, ptr); dcl cobol_define_tag_nc entry (fixed bin, fixed bin); /*************************************/ start: mpout.n = 4; mpout.pt1 = rwtp; mpout.pt4 = addr (move_eos); do reg_struct.what_reg = 1, 11, 12, 13; /* lock A, X1, X2 and X3 */ call cobol_register$load (addr (reg_struct)); end; end_tag = cobol_$next_tag; ovfl_tag = end_tag + 1; cobol_$next_tag = cobol_$next_tag + 2; /* SET PR1 TO PT TO SENDING ITEM */ pr_struct_ptr = addr (pr_struct); pr_struct.pr = 1; call cobol_set_pr (pr_struct_ptr, u.stp); /* ESTABLISH SIZE OF SENDING ITEM */ call cobol_get_size (u.stp, slen_off, 0); call cobol_emit (addr (save_send_len_instr), null (), 2); /* ESTABLISH TALLY (if specified) */ if u.ttp ^= null () then do; dn_ptr = u.ttp; if ^data_name.subscripted then tsub = "0"b; else do; tsub = "1"b; pr_struct.pr = 2; call cobol_set_pr (pr_struct_ptr, u.ttp); substr (spri2_instr, 4, 15) = substr (unspec (taddr_off), 22, 15); call cobol_emit (addr (spri2_instr), null (), 1); type9_chars = dn_ptr -> type9_chars; type9.seg = 5002; /* pointed to by PR2 */ dn_ptr = addr (type9); end; call cobol_io_util$t9dec_to_bin ("110"b, tally_offx4, dn_ptr); end; /* INITIALIZE X1 (indexes sending item) */ if u.ptp = null () then call cobol_emit (addr (zero_x1_instr), null (), 2); else do; dn_ptr = u.ptp; if ^data_name.subscripted then psub = "0"b; else do; psub = "1"b; pr_struct.pr = 2; call cobol_set_pr (pr_struct_ptr, u.ptp); substr (spri2_instr, 4, 15) = substr (unspec (paddr_off), 22, 15); call cobol_emit (addr (spri2_instr), null (), 1); type9_chars = dn_ptr -> type9_chars; type9.seg = 5002; /* pointed to by PR2 */ dn_ptr = addr (type9); end; call cobol_io_util$t9dec_to_bin ("110"b, ptr_offx4, dn_ptr); call cobol_emit (addr (adjust_and_test_x1_instr), null (), 6); call cobol_make_tagref (ovfl_tag, cobol_$text_wd_off - 4, null ()); call cobol_make_tagref (ovfl_tag, cobol_$text_wd_off - 2, null ()); end; /* MAIN LOOP */ if u.dptr = null () then do i = 1 to u.n; /* no delimiters specified */ call cobol_get_size$omit_sign (u.rtp (i), 0, 0); call cobol_emit (addr (adjust_length_instr), null (), 8); mpout.pt2 = addr (alpha_type9); mpout.pt3 = rtp (i); call cobol_move_gen (addr (mpout)); if u.ttp ^= null () then call cobol_emit (addr (bump_tally_instr), null (), 1); if u.ctp (i) ^= null () then do; call cobol_emit (addr (set_count_instr), null (), 3); call cobol_io_util$bin_to_t9dec ("110"b, count_offx4, u.ctp (i)); end; if u.dtp (i) ^= null () then do; if u.dtp (i) -> data_name.numeric then mpout.pt2 = addr (zero_type2); else mpout.pt2 = addr (blank_type3); mpout.pt3 = u.dtp (i); call cobol_move_gen (addr (mpout)); end; if i = u.n then do; /* may be able to avoid for last time */ if u.tag > 0 then temp = 5; else if u.ptp ^= null () then temp = 2; else temp = 0; end; else temp = 5; if temp > 0 then do; call cobol_emit (addr (bump_x1_instr), null (), temp); if temp = 5 then call cobol_make_tagref (end_tag, cobol_$text_wd_off - 1, null ()); end; end; else do; /* delimiter(s) specified */ nextdel_tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_emit (addr (init_x2_instr), null (), 3); call cobol_make_tagref (nextdel_tag, cobol_$text_wd_off - 1, null ()); do i = 1 to u.n; if i > 1 then call cobol_define_tag_nc (nextrt_tag, cobol_$text_wd_off); if u.n > 1 then do; call cobol_emit (addr (check_new_x1_instr), null (), 9); call cobol_make_tagref (end_tag, cobol_$text_wd_off - 3, null ()); call cobol_make_tagref (nextdel_tag, cobol_$text_wd_off - 1, null ()); end; nextpos_tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_define_tag_nc (nextpos_tag, cobol_$text_wd_off); call cobol_emit (addr (check_x2_instr), null (), 2); call cobol_make_tagref (nextdel_tag, cobol_$text_wd_off - 1, null ()); /* NO MATCH FOUND */ if u.dtp (i) ^= null () then do; if u.dtp (i) -> data_name.numeric then mpout.pt2 = addr (zero_type2); else mpout.pt2 = addr (blank_type3); mpout.pt3 = u.dtp (i); call cobol_move_gen (addr (mpout)); end; /* MOVE */ call cobol_emit (addr (set_x3_instr), null (), 3); delfound_tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_define_tag_nc (delfound_tag, cobol_$text_wd_off); mpout.pt2 = addr (alpha_type9); mpout.pt3 = u.rtp (i); call cobol_move_gen (addr (mpout)); if u.ttp ^= null () then call cobol_emit (addr (bump_tally_instr), null (), 1); if u.ctp (i) ^= null () then do; call cobol_emit (addr (set_count_instr), null (), 3); call cobol_io_util$bin_to_t9dec ("110"b, count_offx4, u.ctp (i)); end; call cobol_emit (addr (tra_instr), null (), 1); nextrt_tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_make_tagref (nextrt_tag, cobol_$text_wd_off - 1, null ()); do j = 1 to d.n; call cobol_define_tag_nc (nextdel_tag, cobol_$text_wd_off); nextdel_tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; dn_ptr = d.dtp (j); if data_name.type = 1 then do; dn_ptr = addr (type3); call cobol_make_type3$type1 (dn_ptr, d.dtp (j)); end; if data_name.type = 2 | data_name.type = 3 then do; addr_struct.op1.tptr = addr (type9); call cobol_make_type9$type2_3 (addr_struct.op1.tptr, dn_ptr); end; else addr_struct.op1.tptr = d.dtp (j); addr_struct.op2.tptr = null (); call cobol_get_size (addr_struct.op1.tptr, dlen_off, 0); call cobol_emit (addr (check_del_instr), null (), 5); call cobol_make_tagref (nextdel_tag, cobol_$text_wd_off - 1, null ()); addr_struct.op1.ic_mod = 0; call cobol_addr (addr (addr_struct), addr (comp_del_instr), null ()); substr (comp_del_instr (1), 31, 1) = "1"b; /* len in register */ substr (comp_del_instr (1), 12, 7) = "1101010"b; /* pr,rl,x2 */ call cobol_emit (addr (comp_del_instr), null (), 4); call cobol_make_tagref (nextdel_tag, cobol_$text_wd_off - 1, null ()); if u.dtp (i) ^= null () then do; mpout.pt2 = addr_struct.op1.tptr; /* type 9 token for this delimiter */ /*-03/26/76-*/ mpout.pt3 = u.dtp (i); call cobol_move_gen (addr (mpout)); end; if d.allsw (j) = 0 then call cobol_emit (addr (set_x3_instr), null (), 3); else do; /* ALL specified */ call cobol_emit (addr (all_loop1_instr), null (), 7); if addr_struct.op1.ic_mod ^= 0 then call cobol_addr (addr (addr_struct), addr (comp_del_instr), null ()); call cobol_emit (addr (comp_del_instr), null (), 3); call cobol_emit (addr (all_loop2_instr), null (), 7); end; call cobol_emit (addr (tra_instr), null (), 1); call cobol_make_tagref (delfound_tag, cobol_$text_wd_off - 1, null ()); if j = d.n then do; /* last time - provide exit via nextdel_tag */ call cobol_define_tag_nc (nextdel_tag, cobol_$text_wd_off); nextdel_tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_emit (addr (bump_x2_instr), null (), 2); call cobol_make_tagref (nextpos_tag, cobol_$text_wd_off - 1, null ()); end; end; if i = u.n then do; /* last time - provide exit via nextrt_tag */ call cobol_define_tag_nc (nextrt_tag, cobol_$text_wd_off); if u.ptp ^= null () | u.tag > 0 then call cobol_emit (addr (check_new_x1_instr), null (), 5); end; end; end; call cobol_define_tag_nc (end_tag, cobol_$text_wd_off); /* SET TALLY */ if u.ttp ^= null () then do; dn_ptr = u.ttp; if tsub then do; substr (epp2_instr, 4, 15) = substr (unspec (taddr_off), 22, 15); call cobol_emit (addr (epp2_instr), null (), 1); type9_chars = dn_ptr -> type9_chars; dn_ptr = addr (type9); end; call cobol_io_util$bin_to_t9dec ("110"b, tally_offx4, dn_ptr); end; /* SET POINTER */ if u.ptp ^= null () then do; dn_ptr = u.ptp; if psub then do; substr (epp2_instr, 4, 15) = substr (unspec (paddr_off), 22, 15); call cobol_emit (addr (epp2_instr), null (), 1); type9_chars = dn_ptr -> type9_chars; type9.seg = 5002; dn_ptr = addr (type9); end; if tag > 0 then temp = 6; /* must check x1 for overflow */ else temp = 5; /* forget it */ call cobol_emit (addr (set_pointer_instr), null (), temp); call cobol_io_util$bin_to_t9dec ("110"b, ptr_offx4, u.ptp); end; /* CHECK FOR OVERFLOW */ if u.tag > 0 then do; call cobol_emit (addr (bypass_ovfl_instr), null (), 2); call cobol_make_tagref (tag, cobol_$text_wd_off - 1, null ()); end; call cobol_define_tag_nc (ovfl_tag, cobol_$text_wd_off); call cobol_reset_r$in_line; return; /*************************************/ /***** Declaration for builtin function *****/ dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index) builtin; /***** End of declaration for builtin function *****/ %include cobol_type1; %include cobol_type2; %include cobol_type3; %include cobol_type9; %include cobol_; end cobol_unstring;  cobol_unstring_gen.pl1 05/24/89 1042.8rew 05/24/89 0832.1 35136 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_unstring_gen.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* format: style3 */ cobol_unstring_gen: proc (mp_ptr, passed_tag); dcl mp_ptr ptr; dcl passed_tag fixed bin; dcl 1 mp based (mp_ptr), 2 n fixed bin, 2 pt (0 refer (mp.n)) ptr; dcl 1 u auto, 2 n fixed bin, 2 tag fixed bin, 2 stp ptr, /* pts to sending token */ 2 dptr ptr, /* pts to d struct - may be null */ 2 ptp ptr, /* pts to pointer token - may be null */ 2 ttp ptr, /* pts to tallying token - may be null */ 2 unstr (256), 3 rtp ptr, /* pts to receiving token(i) */ 3 dtp ptr, /* pts to delimiter token(i) - may be null */ 3 ctp ptr; /* pts to count token(i) - may be null */ dcl 1 d auto, 2 n fixed bin, 2 all_cnt fixed bin, /* number of entries with ALL */ 2 delimiter (256), 3 dtp ptr, /* pts to delimited token */ 3 allsw fixed bin; /* 1 means ALL precedes delimiter */ dcl (i, j, temp) fixed bin; dcl delimiter_key fixed bin static init (91); dcl count_key fixed bin static init (84); dcl all_key fixed bin static init (73); dcl dn_ptr ptr; dcl cobol_unstring entry (ptr, ptr); /*************************************/ start: eos_ptr = mp.pt (mp.n); if end_stmt.b then do; passed_tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; u.tag = passed_tag; end; else u.tag = 0; u.stp = mp.pt (2); j = 3; if end_stmt.e > 0 then do; /* at least one operand after DELIMITED */ u.dptr = addr (d); d.all_cnt = 0; d.n = end_stmt.e; do i = 1 to d.n; dn_ptr = mp.pt (j); d.allsw (i) = 0; if data_name.type = 1 then if dn_ptr -> reserved_word.key = all_key then do; /*ALL */ d.allsw (i) = 1; d.all_cnt = d.all_cnt + 1; j = j + 1; end; d.dtp (i) = mp.pt (j); j = j + 1; end; end; else u.dptr = null (); u.n = end_stmt.h; do i = 1 to u.n; u.rtp (i) = mp.pt (j); temp = j + 1; if mp.pt (temp) -> data_name.type = 1 & mp.pt (temp) -> reserved_word.key = delimiter_key then do; j = j + 2; u.dtp (i) = mp.pt (j); end; else u.dtp (i) = null (); temp = j + 1; if mp.pt (temp) -> data_name.type = 1 & mp.pt (temp) -> reserved_word.key = count_key then do; j = j + 2; u.ctp (i) = mp.pt (j); end; else u.ctp (i) = null (); j = j + 1; end; if end_stmt.d = "01"b then u.ptp = mp.pt (j); else u.ptp = null (); if end_stmt.c = "1"b then u.ttp = mp.pt (mp.n - 1); else u.ttp = null (); call cobol_unstring (addr (u), mp.pt (1)); return; /*************************************/ /***** Declaration for builtin function *****/ dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index) builtin; /***** End of declaration for builtin function *****/ %include cobol_type1; %include cobol_type9; %include cobol_type19; %include cobol_; end cobol_unstring_gen;  cobol_write_gen.pl1 05/24/89 1042.8rew 05/24/89 0832.1 133407 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_write_gen.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 12/07/80 by FCH, [4.4-1], report writer added */ /* modified on 08/15/79 by MHD, [4.0-2], fixed problem in write with LINAGE clause */ /* modified on 06/27/79 by FCH, [4.0-1], not option added for debug */ /* Modified on 11/13/78 by FCH, [3.0-1], alt rec keys added */ /* Modified since Version 3.0 */ /* format: style3 */ cobol_write_gen: proc (mp_ptr, passed_tag); dcl stoff fixed bin; dcl (good_tag, stream_tag, seek_tag, write_tag, skip_tag, alt_tag, alt_seek_tag) fixed bin; dcl passed_tag fixed bin; /* for in-line error handling */ dcl ptag fixed bin; dcl linage_ptr ptr; dcl mp_ptr ptr; dcl 1 mp based (mp_ptr), 2 n fixed bin, /* from 3 - 5 */ 2 pt (0 refer (mp.n)) ptr; /* pt(1) pts to type1 token for WRITE */ /* pt(2) pts to type9 token (record name) or type12 token(file name) */ /* pt(3) pts to type9 token for FROM data IF eos.c = "1"b */ /* pt(n-1) pts to type9 token for ADVANCING data IF eos.d ^= "00"b */ /* pt(n) pts to type19 token (eos) */ dcl 1 args, 2 entryno fixed bin, 2 arglist_off fixed bin, 2 stacktemp_off fixed bin, 2 n fixed bin, 2 arg (4), 3 pt ptr, 3 type fixed bin, 3 off1 fixed bin, 3 off2 fixed bin, 3 value bit (18) unal, 3 indirect bit (1) unal, 3 overlay bit (1) unal, 3 repeat_nogen bit (1) unal; dcl file_key_desc char (40) based; dcl extend_sw bit (1) aligned; dcl (alt_sw, code_set_sw, var) bit (1); dcl text (0:100000) bit (36) based (cobol_$text_base_ptr); dcl argb (4) bit (216) based (addr (args.arg (1))); dcl save_mp2_ptr ptr; dcl ft_ptr ptr; dcl fkey_ptr ptr; dcl dn_ptr ptr; dcl name_ptr ptr; dcl arg_ptr ptr; dcl ioerror_ptr ptr; dcl (temp, fn) fixed bin; dcl aloff fixed bin init (0); dcl size fixed bin; dcl offset fixed bin; dcl reclen_off fixed bin; dcl buflen_off fixed bin; dcl buf_off fixed bin; dcl ntag fixed bin; /*************************************/ /*************************************/ /* INITIALIZATION */ start: pr5_struct_ptr = addr (pr5_struct); rw_ptr = mp.pt (1); eos_ptr = mp.pt (mp.n); ioerror.retry_tag = cobol_$next_tag; good_tag = cobol_$next_tag + 1; stream_tag = cobol_$next_tag + 2; seek_tag = cobol_$next_tag + 3; write_tag = cobol_$next_tag + 4; /* [3.0-1] */ alt_tag = cobol_$next_tag + 5; /* [3.0-1] */ alt_seek_tag = cobol_$next_tag + 6; cobol_$next_tag = cobol_$next_tag + 7; /*[4.4-1]*/ call set_up; arg_ptr = addr (args); ioerror.cobol_code = 0; ioerror.type1_ptr = mp.pt (1); ioerror.mode = 0; ioerror_ptr = addr (ioerror); iocb_arg.pt = addr (iocb_struct); if end_stmt.b = "1"b then do; passed_tag, ioerror.ns_tag = cobol_$next_tag; ioerror.is_tag = cobol_$next_tag + 1; cobol_$next_tag = cobol_$next_tag + 2; end; else do; ioerror.is_tag = 0; ioerror.ns_tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; end; /*[4.4-1]*/ call cobol_read_ft (fn, ft_ptr); if file_table.organization = 5 then file_table.organization = 4; /* temporary */ iocb_struct.seg = file_table.fsb.seg; iocb_struct.offset = file_table.fsb.off; call cobol_alloc$stack (56, 2, aloff); /* enough for 14 words - aloff is a wd offset */ args.arglist_off = aloff; args.n = 4; argb (1) = unspec (iocb_arg); argb (4) = unspec (status_arg); buflen_off = 80; /*************************************/ /* START CODE GENERATION */ start_codegen: /* MOVE FROM DATANAME TO BUFFER IF NECESSARY */ if end_stmt.c = "1"b /* FROM specified */ then do; mpout.pt1 = mp.pt (1); mpout.pt2 = mp.pt (3); mpout.pt3 = mp.pt (2); mpout.pt4 = addr (type19); call cobol_move_gen (addr (mpout)); end; /* MAKE SURE FILE IS OPEN */ call cobol_define_tag (ioerror.retry_tag); call cobol_set_fsbptr (ft_ptr); /* generates epp1 pr4|102,* */ /* OPERATOR39(init_write) */ call cobol_call_op (39, good_tag); /* INT_WRITE_OP */ call cobol_gen_ioerror (ft_ptr, ioerror_ptr); call cobol_define_tag (good_tag); if file_table.linage /* LINAGE TOP initialization */ then do; call cobol_read_rand (1, file_table.linage_info, linage_ptr); if linage_rec.top > 0 then do; if linage_rec.top ^= 5 then call linage_init (linage_rec.top, 94 * 4); else call cobol_ioop_util$set_fsb (linage_rec.top_int, 94); end; end; /*[4.4-1]*/ if var /*[4.4-1]*/ then do; var = data_name.variable_length; temp = data_name.item_length; end; /*[4.4-1]*/ else do; var = file_table.variable; temp = file_table.max_cra_size; end; /* ESTABLISH RECORD LENGTH */ /*[4.4-1]*/ if ^var then do; call cobol_io_util$move_direct ("110"b, buflen_off * 4, 4, 1, substr (unspec (temp), 19, 18)); end; else do; if ^file_table.rec_do then call cobol_get_size (dn_ptr, buflen_off, reserved_word.line); else do; call cobol_read_rand (1, file_table.rec_do_info, fkey_ptr); addr (fkey_type9.file_key_info) -> file_key_desc = file_key.desc; call cobol_io_util$t9dec_to_bin ("110"b, buflen_off * 4, addr (fkey_type9)); end; end; /* CONVERT IF CODE SET INDICATES SO */ code_set_sw = file_table.code_set_clause & file_table.code_set = 12; if code_set_sw then do; call cobol_alloc$stack (data_name.size + 1, 2, stoff); /*-10/07/76-*/ trans_type9.seg = 1000; /* in stack */ trans_type9.off = stoff * 4; /*-10/07/76-*/ trans_type9.size = data_name.size; call cobol_trans_alphabet$io (dn_ptr, addr (trans_type9), fixed (file_table.code_set), 0); dn_ptr = addr (trans_type9); /* set to converted record for remainder of this generator */ end; /* STREAM OUTPUT */ /* [3.0-1] */ alt_sw = file_table.organization = 3 /* ind */ /* [3.0-1] */ & /* [3.0-1] */ file_table.alternate_keys ^= 0; if file_table.organization = 4 | file_table.device = 1 | file_table.device = 3 then do; if end_stmt.b = "1"b then /* in-line error coding follows */ call cobol_ioop_util$set_icode; if code_set_sw then do; save_mp2_ptr = mp.pt (2); mp.pt (2) = addr (trans_type9); end; call cobol_linage (ft_ptr, mp_ptr, buflen_off, buf_off, ioerror_ptr); /* OPPERATOR52(LINAGE) */ call init_linage; /*[4.0-2]*/ if code_set_sw then mp.pt (2) = save_mp2_ptr; call cobol_set_fsbptr (ft_ptr); call cobol_ioop_util$disp (buf_off); /* OPERATOR68(write_stream_linage) */ if file_table.linage then call cobol_call_op (68, stream_tag); /* write_stream_linage_op */ /* OPERATOR40(write_stream) */ else call cobol_call_op (40, stream_tag); /* write_stream_op */ call cobol_gen_ioerror (ft_ptr, ioerror_ptr); end; else do; if file_table.access < 2 then if file_table.external | file_table.open_io then do; ntag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_io_util$bypass_mode_error (ntag, "10"b); call cobol_define_tag (ntag); end; /* SEEK KEY FOR RELATIVE OR INDEXED FILES */ if file_table.organization ^= 1 /* not sequential */ then do; if file_table.relative_key | file_table.record_key then do; call cobol_read_rand (1, file_table.r_key_info, fkey_ptr); addr (fkey_type9.file_key_info) -> file_key_desc = file_key.desc; end; if file_table.organization = 2 & file_table.access < 2 /* relative sequential */ then do; call cobol_io_util$fixed_add ("001"b, fsb_relkey, 1, ""b, 0); /* must maintain own relkey */ call cobol_io_util$bin_to_dec ("001"b, fsb_key, 16, "001"b, fsb_relkey, 4); call cobol_io_util$move_direct ("001"b, fsb_keylen_sw, 4, 1, "000000000000010000"b); end; else do; mpout.pt1 = mp.pt (1); mpout.pt2 = addr (fkey_type9); if file_table.organization = 2 then do; mpout.pt3 = addr (num_type9); size, num_type9.size, num_type9.places_left = 16; num_type9.seg = 5001; /* from PR1 */ num_type9.off = file_table.fsb.off + fsb_key; end; else do; /* indexed */ mpout.pt3 = addr (alpha_type9); size, alpha_type9.size = fkey_type9.size; alpha_type9.seg = 5001; /* from PR1 */ alpha_type9.off = file_table.fsb.off + fsb_key; end; mpout.pt4 = addr (type19); call cobol_move_gen (addr (mpout)); /* must always move reckey to varying string */ call cobol_io_util$move_direct ("001"b, fsb_keylen_sw, 4, 1, substr (unspec (size), 19, 18)); end; if alt_sw then call EMIT_OP_91; call cobol_call_op (41, seek_tag); /* OPERATOR41(seek_tag) */ call cobol_gen_ioerror (ft_ptr, ioerror_ptr); call cobol_define_tag (seek_tag); /* RESET "LAST-KEY-READ" IF NECESSARY */ if file_table.access < 2 & (file_table.external | file_table.open_io) then do; call cobol_set_fsbptr (ft_ptr); /* set pr1 to fsb */ call cobol_io_util$move_direct ("001"b, fsb_keylen_sw, 4, 1, ""b); /* zero fsb.keylen_sw */ end; end; else if alt_sw then call EMIT_OP_91; /* WRITE THE RECORD */ call cobol_set_pr (pr5_struct_ptr, dn_ptr); if end_stmt.b = "1"b then call cobol_ioop_util$set_icode; call cobol_call_op (42, write_tag); /* OPERATOR42(write_record) */ call cobol_gen_ioerror (ft_ptr, ioerror_ptr); call cobol_define_tag (write_tag); /* [3.0-1] */ if alt_sw /* [3.0-1] */ then do; call cobol_io_util$file_desc (file_table.file_desc_1_offset); /* [3.0-1] */ call cobol_call_op (90, stream_tag); /* OPERATOR90(alt_add_write_keys) */ /* [3.0-1] */ call cobol_gen_ioerror (ft_ptr, ioerror_ptr); /* [3.0-1] */ end; /* SET RELATIVE KEY IF NECESSARY */ if file_table.organization = 2 & file_table.access < 2 & file_table.relative_key then do; call cobol_set_fsbptr (ft_ptr); mpout.pt1 = mp.pt (1); mpout.pt2 = addr (num_type9); num_type9.size, num_type9.places_left = 16; num_type9.seg = 5001; /* from PR1 */ num_type9.off = file_table.fsb.off + fsb_key; mpout.pt3 = addr (fkey_type9); mpout.pt4 = addr (type19); call cobol_move_gen (addr (mpout)); end; end; call cobol_define_tag (stream_tag); /* [3.0-1] */ if alt_sw then call cobol_set_fsbptr (ft_ptr); call cobol_reg_manager$after_op (4095 + ioerror.cobol_code); /*[4.0-1]*/ if end_stmt.f = "01"b /*[4.0-1]*/ then passed_tag = ioerror.is_tag; /*[4.0-1]*/ else call cobol_gen_ioerror$finish_up (ft_ptr, ioerror_ptr); return; EMIT_OP_91: proc; /* [3.0-1] */ call cobol_io_util$file_desc (file_table.file_desc_1_offset); /* [3.0-1] */ call cobol_set_pr (pr5_struct_ptr, dn_ptr); /* [3.0-1] */ call cobol_call_op (91, alt_seek_tag); /* OPERATOR91(alt_seek_key) */ /* [3.0-1] */ call cobol_gen_ioerror (ft_ptr, ioerror_ptr); /* [3.0-1] */ call cobol_define_tag (alt_seek_tag); /* [3.0-1] */ call cobol_set_fsbptr (ft_ptr); end; /**/ /****************************************/ linage_init: proc (index_value, fsb_offset); dcl index_value fixed bin (15); dcl fsb_offset fixed bin; addr (fkey_type9.file_key_info) -> file_key_desc = linage_rec.name_desc (index_value); mpout.n = 4; mpout.pt1 = mp.pt (1); mpout.pt2 = addr (fkey_type9); mpout.pt3 = addr (comp6_type9); comp6_type9.size, comp6_type9.places_left = 4; comp6_type9.seg = 5001; /* TO PR1 */ comp6_type9.off = file_table.fsb.off + fsb_offset; mpout.pt4 = addr (type19); call cobol_move_gen (addr (mpout)); return; end linage_init; init_linage: proc; /*[4.0-2]*/ /* This block of code was made into a subroutine in order to fix a bug in the write using a LINAGE clause. This is the code genetated that assigns the new Page-Size, Footing-Size, and Bottom-Size */ if file_table.linage /* LINAGE initialization */ then do; call cobol_set_fsbptr (ft_ptr); skip_tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_ioop_util$bypass_reset (skip_tag); call cobol_read_rand (1, file_table.linage_info, linage_ptr); if linage_rec.body > 0 then do; if linage_rec.body ^= 5 then call linage_init (linage_rec.body, 92 * 4); else call cobol_ioop_util$set_fsb (linage_rec.body_int, 92); end; else do; linage_rec.body_int = 66; /* default should no reach this point. */ linage_rec.body = 5; call cobol_ioop_util$set_fsb (linage_rec.body_int, 92); end; if linage_rec.footing > 0 then do; if linage_rec.footing ^= 5 then call linage_init (linage_rec.footing, 93 * 4); else do; if linage_rec.footing_int = 0 then call cobol_ioop_util$set_fsb (linage_rec.body_int, 135); else call cobol_ioop_util$set_fsb (linage_rec.footing_int, 93); end; end; else do; if linage_rec.body ^= 5 then call linage_init (linage_rec.body, 93 * 4); else call cobol_ioop_util$set_fsb (linage_rec.body_int, 93); end; if linage_rec.bottom > 0 then do; if linage_rec.bottom ^= 5 then call linage_init (linage_rec.bottom, 95 * 4); else call cobol_ioop_util$set_fsb (linage_rec.bottom_int, 95); end; call cobol_define_tag (skip_tag); end; end init_linage; set_up: proc; /*[4.4-1]*/ if end_stmt.a = "010"b /*[4.4-1]*/ then do; end_stmt.c = "0"b; /* write fn from dn (report) */ /*[4.4-1]*/ end_stmt.a = "001"b; /*[4.4-1]*/ dn_ptr = mp.pt (3); /*[4.4-1]*/ fn = mp.pt (2) -> fd_token.file_no; /*[4.4-1]*/ mp.pt (2) = mp.pt (3); /*[4.4-1]*/ var = "1"b; /*[4.4-1]*/ end; /*[4.4-1]*/ else do; dn_ptr = mp.pt (2); /*[4.4-1]*/ fn = data_name.file_num; /*[4.4-1]*/ var = "0"b; /*[4.4-1]*/ end; end; %include cobol_write_gen_info; %include cobol_write_gen_data; declare 1 fd_token based, %include cobol_TYPE12; end cobol_write_gen; */ ----------------------------------------------------------- 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 */