cobol_file_util.pl1 05/24/89 1041.5rew 05/24/89 0832.1 23814 /****^ *********************************************************** * * * 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_file_util.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 8/11/76 by George Mercuri to add code for linage initialize. */ /* Modified on 4/27/76 by G. Mercuri change code for new cobol_operators_. */ /* Modified on 4/21/76 by g. Mercuri to fix sxl5 in open_instr from 453 to 451. */ /* format: style3 */ cobol_file_util: proc (name_ptr, linage); open: entry (name_ptr, linage); dcl name_ptr ptr; /* pts to type 12 token */ dcl linage fixed bin; /* 0= no linage, 1= linage*/ dcl open_instr (4) bit (36) static init ("000000000000000000111010101000000111"b, /* lxl5 <2*no_of_files>,du */ "000000000000000000111010110000000111"b, /* lxl6 <2*fd_token.file_no>,du */ "000000000000011000111000000001000000"b, /* tsx0 pr0|30 */ "000000000000011001111000000001000000"b); /* tsx0 pr0|31 */ dcl temp fixed bin; dcl cobol_emit entry (ptr, ptr, fixed bin); /*************************************/ start: temp = 2 * fixed_common.file_count; substr (open_instr (1), 1, 18) = substr (unspec (temp), 19, 18); temp = 2 * fd_token.file_no; substr (open_instr (2), 1, 18) = substr (unspec (temp), 19, 18); call cobol_emit (addr (open_instr), null (), 2); if linage = 1 then call cobol_emit (addr (open_instr (3)), null (), 1); else call cobol_emit (addr (open_instr (4)), null (), 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_type12; %include cobol_fixed_common; %include cobol_ext_; %include cobol_; end cobol_file_util;  cobol_fix_driver_.pl1 05/24/89 1041.5rew 05/24/89 0832.1 52470 /****^ *********************************************************** * * * 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_fix_driver_.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 04/01/81 by FCH, fix decl for map_data_table, [4.4-1], BUG472(TR8869,8970) */ /* Modified on 07/18/78 by RAL, [3.0-1], cobol_linkage_header.incl.pl1 changed */ /* Modified since Version 3.0. */ /*{*/ /* format: style3 */ cobol_fix_driver_: proc; /* This is the driver for the fixup phase of the Multics COBOL compiler. It is called by the cobol driver and requires no arguments. It calls the following modules: */ dcl cobol_make_object_map entry; dcl cobol_mst entry; dcl cobol_fixup entry (ptr); dcl cobol_patch entry (ptr); dcl cobol_paste entry (ptr); /* The pointer passed to each of these is to an array containing values pertinent to the structure of the components of the object segment. */ /*}*/ dcl value_ptr ptr; dcl no_stmts_2 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 1 value aligned, 2 con_len fixed bin aligned, 2 code_len fixed bin aligned, 2 text_len fixed bin aligned, 2 def_len fixed bin aligned, 2 link_len fixed bin aligned, 2 sym_len fixed bin aligned, 2 int_storage_len fixed bin aligned, 2 exec_off fixed bin aligned; /* set by cobol_patch to wd before entry */ dcl psb_ptr ptr, psb_off fixed bin; dcl (old_link, new_link, temp_relp, i, old_reloc, new_reloc, no_links) fixed bin, (cmp_cnt, cmp_bit, cmp_rest) fixed bin, (new_link_ptr, old_link_ptr) ptr; dcl 1 link_temp (no_links) aligned based, 2 header bit (18) unal, 2 rest bit (54) unal; start: value.con_len = cobol_$constant_offset; if fixed_common.options.st then call cobol_mst; value.code_len = cobol_$text_wd_off; value.text_len = value.con_len + value.code_len; value.def_len = cobol_$def_wd_off; value.sym_len = cobol_$sym_wd_off; if fixed_common.options.profile then do; no_stmts_2 = map_data_table.no_source_stmts * 2 + 2; value.int_storage_len = fixed_static_length + no_stmts_2; sym_ptr = sym_base_ptr; psb_off = fixed (symbol_block_header.area_relp, 18); psb_ptr = addrel (sym_ptr, psb_off); psb_ptr -> pl1_symbol_block.profile = linkage_header.links_relp; psb_ptr -> pl1_symbol_block.flags.profile = "1"b; value.link_len = cobol_$link_wd_off + no_stmts_2; old_link = fixed (linkage_header.links_relp); new_link = old_link + no_stmts_2; old_link_ptr = addrel (link_base_ptr, old_link); new_link_ptr = addrel (link_base_ptr, new_link); no_links = cobol_$link_wd_off - 8 - fixed_static_length; no_links = divide (no_links, 2, 17, 0); if no_links > 0 then do; old_reloc = old_link * 10 - 19; new_reloc = new_link * 10 - 19; relptr = cobol_$reloc_link_base_ptr; i = no_stmts_2 * 2; cmp_cnt = divide (i, 1023, 17, 0); cmp_rest = mod (i, 1023); cmp_bit = 15 * (cmp_cnt + 1); n_bits = n_bits + cmp_bit; /* The 23rd bit of relbits are the first link. */ substr (relbits, 23 + cmp_bit, no_links * 12) = substr (relbits, 23, no_links * 12); if cmp_cnt ^= 0 then do i = 1 to cmp_cnt; substr (relbits, 8 + i * 15) = "111101111111111"b; end; substr (relbits, 23 + cmp_cnt * 15, 5) = "11110"b; substr (relbits, 28 + cmp_cnt * 15, 10) = substr (unspec (cmp_rest), 27, 10); linkage_header.links_relp = substr (unspec (new_link), 19, 18); cobol_$link_wd_off = cobol_$link_wd_off + no_stmts_2; do i = no_links to 1 by -1; temp_relp = fixed (old_link_ptr -> link_temp.header (i)) - no_stmts_2; new_link_ptr -> link_temp.rest (i) = old_link_ptr -> link_temp.rest (i); new_link_ptr -> link_temp.header (i) = substr (unspec (temp_relp), 19, 18); end; do i = 1 to (map_data_table.no_source_stmts + 1); temp_relp = (i - 1) * 2; old_link_ptr -> link_temp.header (i) = substr (unspec (temp_relp), 19, 18); old_link_ptr -> link_temp.rest (i) = (54)"0"b; end; end; end; else do; value.int_storage_len = fixed_static_length; value.link_len = cobol_$link_wd_off; end; value_ptr = addr (value); if fixed_common.options.m_map then call cobol_make_object_map; call cobol_fixup (value_ptr); call cobol_patch (value_ptr); call cobol_paste (value_ptr); 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_fixed_static; %include cobol_; %include cobol_fixed_common; %include cobol_ext_; %include cobol_linkage_header; /* [3.0-1] */ %include pl1_symbol_block; %include cobol_sbh; %include cobol_relinfo; end cobol_fix_driver_;  cobol_fixup.pl1 05/24/89 1041.5rew 05/24/89 0832.1 70254 /****^ *********************************************************** * * * 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_fixup.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 04/01/81 by FCH, fix decl for map_data_table, [4.4-1], BUG472(TR8869,8970) */ /* Modified on 5/16/80 by FCH, [4.2-1], compute size of DEF table */ /* Modified on 11/07/78 by FCH, [3.0-1], type31 evaluation */ /* Modified since Version 3.0 */ /* format: style3 */ cobol_fixup: proc (value_ptr); dcl val (7) fixed bin aligned based (value_ptr); dcl segptr (4) ptr; dcl wptr ptr; /* points to word to be set in cobol_text */ dcl halfword (0:1) bit (18) based (wptr); dcl 1 instr based (wptr) aligned, 2 address bit (18) unaligned, 2 fill bit (14) unaligned, 2 reg bit (4) unaligned; dcl bytes char (8) based; dcl (i, j, k) fixed bin; dcl utemp 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; /*************************************/ start_fixup: /* [3.0-1] */ call eval_equate; segptr (1) = cobol_$text_base_ptr; segptr (2) = cobol_$def_base_ptr; segptr (3) = cobol_$link_base_ptr; segptr (4) = cobol_$sym_base_ptr; if fixup_table.count > 0 then do i = 1 to fixup_table.count; if table.type (i) = (4)"0"b then do; /* tag type fixup */ wptr = addrel (cobol_$text_base_ptr, table.offset (i)); j = table.tag_number (i); /* [3.0-1] if TAG.tag_table(j) < 0 then do while(TAG.tag_table(j) < 0); j = -TAG.tag_table(j); end; */ k = TAG.tag_table (j); /* the real offset in cobol_text_seg */ if k = 0 then go to fixup_error; utemp = fixed (instr.address, 18) + k; instr.address = substr (unspec (utemp), 19, 18); end; else do; /* general "section-related" fixup */ j = fixed (table.location.half (i), 1); k = fixed (table.type (i), 4); wptr = addrel (segptr (fixed (table.base (i), 3)), table.offset (i)); utemp = fixed (halfword (j), 18); if k ^= 15 then do; if table.operation (i) then utemp = utemp - val (k); else utemp = utemp + val (k); end; else utemp = utemp + map_data_table.no_source_stmts * 2 + 2; halfword (j) = substr (unspec (utemp), 19, 18); end; fix_cont: end; return; /* [3.0-1] */ eval_equate: proc; /**/ declare (i, new, old, tt, tn, val) fixed bin; /**/ /**/ if DEF.tag_max = 0 then return; /**/ /**/ do while ("1"b); /**/ /**/ new, old = 0; /**/ /**/ do i = 1 by 1 to DEF.tag_max; /**/ /**/ tt = TAG.tag_table (i); /**/ tn = TAG.tag_no (i); /**/ /**/ if tt = 0 /**/ then if tn ^= 0 /**/ then do; val = TAG.tag_table (tn);/**/ /**/ /**/ if val ^= 0 /**/ then do; TAG.tag_table (i) = val; /**/ new = 1; /**/ end; /**/ end; /**/ old = 1; /**/ end; /**/ /**/ if new = 0 | old = 0 then return; /**/ /**/ end; end; /* [3.0-1] */ /*************************************/ cobol_define_tag: entry (tagno); /* dcl tagno fixed bin; /* internal tag number (input) */ start_define_tag: /*[3.0-1]*/ if tagno = 0 then return; if TAG.tag_table (tagno) > 0 then go to define_error; TAG.tag_table (tagno) = cobol_$text_wd_off; call cobol_reset_r$in_line; /*[4.2-1]*/ DEF.tag_max = max (DEF.tag_max, tagno); return; /*************************************/ cobol_define_tag_nc: entry (tagno, locno); dcl tagno fixed bin; /* internal tag number (input) */ dcl locno fixed bin; /* wd offset in cobol_text_seg (input) */ start_define_tag_nc: /*[3.0-1]*/ if tagno = 0 then return; if TAG.tag_table (tagno) > 0 then go to define_error; TAG.tag_table (tagno) = locno; /*[4.2-1]*/ DEF.tag_max = max (DEF.tag_max, tagno); return; /*************************************/ cobol_equate_tag: entry (token31_ptr); dcl token31_ptr ptr; /* ptr to a type 31 token (input)*/ dcl 1 token31 based (token31_ptr), 2 header, 3 size fixed bin (15), 3 line fixed bin (15), 3 column fixed bin (7), 3 type fixed bin (7), 2 body, 3 verb fixed bin (15), 3 tagno1 fixed bin (15), 3 tagno2 fixed bin (15); start_equate_tag: /* [3.0-1] */ if TAG.tag_table (token31.tagno1) = 0 /* [3.0-1] */ then TAG.tag_table (token31.tagno1) = TAG.tag_table (token31.tagno2); /* [3.0-1] */ TAG.tag_no (token31.tagno1) = token31.tagno2; /*[4.2-1]*/ DEF.tag_max = max (DEF.tag_max, token31.tagno1, token31.tagno2); return; /*************************************/ cobol_make_tagref: entry (tagno, locno, instr_ptr); /* dcl tagno fixed bin; /* internal tag number (input) */ /* dcl locno fixed bin; /* wd offset in cobol_text_seg (input) */ dcl instr_ptr ptr; /* ptr to instr wd if non-null (input) */ start_make_tagref: if instr_ptr = null () then wptr = addrel (cobol_$text_base_ptr, locno); else wptr = instr_ptr; instr.reg = "0100"b; /* IC modification */ if TAG.tag_table (tagno) > 0 then do; utemp = TAG.tag_table (tagno) - locno; instr.address = substr (unspec (utemp), 19, 18); end; else do; /* tag not yet defined - make fixup */ fixdef.wd1 = locno; fixdef.wd2 = tagno; utemp = -locno; instr.address = substr (unspec (utemp), 19, 18); i = fixup_table.count * 8 + 5; substr (cobol_$fixup_ptr -> bytes, i, 8) = substr (addr (fixdef) -> bytes, 1, 8); fixup_table.count = fixup_table.count + 1; end; /*[4.2-1]*/ DEF.tag_max = max (DEF.tag_max, tagno); return; /*************************************/ cobol_make_fixup: entry (fix_ptr); dcl fix_ptr ptr; /* pointer to fixup directive (input) */ start_make_fixup: i = fixup_table.count * 8 + 5; substr (cobol_$fixup_ptr -> bytes, i, 8) = substr (fix_ptr -> bytes, 1, 8); fixup_table.count = fixup_table.count + 1; return; /*************************************/ fixup_error: error_info.name = "cobol_fixup"; call ioa_$rsnnl ("Inconsistency in fixup table entry^d->^d at location ^o (before fixup)", message, message_len, i, j, table.offset (i)); call signal_ ("command_abort_", null (), addr (error_info)); go to fix_cont; define_error: error_info.name = "cobol_define_tag"; call ioa_$rsnnl ("Attempt to multiply define tag #^d", message, message_len, tagno); go to error; equate_error: error_info.name = "cobol_equate_error"; call ioa_$rsnnl ("Inconsistency in Type 31 token - setting ^d = ^d", message, message_len, token31.tagno1, token31.tagno2); go to error; error: call signal_ ("command_abort_", null (), addr (error_info)); /*************************************/ %include cobol_fixup_info; %include cobol_fixup_data; end cobol_fixup;  cobol_fofl_mask.pl1 05/24/89 1041.5rew 05/24/89 0832.1 35802 /****^ *********************************************************** * * * 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_fofl_mask.pl1 Added Trace statements. END HISTORY COMMENTS */ /* Modified on 10/19/85 by FCH, [5.3-1], BUG563(phx18381), new cobol_addr_tokens.incl.pl1 */ /* Modified on 05/12/77 by Bob Chang to implement continue option. */ /*{*/ /* format: style3 */ cobol_fofl_mask: proc; /* This procedure generates code to disable and enable the overflow fault trap. The fault trap is disabled by turning ON the overflow mask indicator bit in the machine indicator register, and is enabled by turning this bit OFF. */ /*}*/ /* DECLARATION OF EXTERNAL ENTRIES */ dcl cobol_addr ext entry (ptr, ptr, ptr); dcl cobol_pool ext entry (char (*), fixed bin, fixed bin (24)); dcl cobol_emit ext entry (ptr, ptr, fixed bin); /* DECLARATIONS OF INTERNAL STATIC VARIABLES */ dcl ldi_masks_pooled fixed bin int static init (0); dcl oflo_mask_on bit (36) int static init ("000000000000000000000000100000000000"b); /* overflow mask indicator bit ON */ dcl oflo_mask_off bit (36) int static init ("0"b); dcl on_mask_inst bit (36) int static; dcl on_mask_reloc (1:5) bit (5) aligned; dcl ldi_inst bit (36) static init ("110000000001110100110011100001000000"b); /* ldi pr6|164 */ dcl LDI bit (10) int static init ("1100111000"b); /* 634(0) */ dcl on_ret_offset fixed bin (24) int static; dcl off_ret_offset fixed bin (24) int static; /* DECLARATIONS OF INTERNAL VARIABLES */ dcl mask_ptr ptr; dcl mask_string char (4) based (mask_ptr); dcl input_buffer (1:10) char (4); /* ON ENTRY POINT */ on: entry; if ldi_masks_pooled ^= cobol_$compile_count then do; /* Pool the LDI masks */ /* Pool the overflow mask indicator ON constant */ mask_ptr = addr (oflo_mask_on); call cobol_pool (mask_string, 0, on_ret_offset); /* Pool the overflow mask indicator OFF constant. */ mask_ptr = addr (oflo_mask_off); call cobol_pool (mask_string, 0, off_ret_offset); ldi_masks_pooled = cobol_$compile_count; end; /* Pool the LDI masks and establish basic addressability to them. */ /* Get the basic address of the overflow mask indicator ON constant. */ input_ptr = addr (input_buffer); input_struc_basic.type = 1; input_struc_basic.operand_no = 0; input_struc_basic.lock = 0; input_struc_basic.char_offset = on_ret_offset; input_struc_basic.segno = 3000; /* constant segment */ call cobol_addr (input_ptr, addr (on_mask_inst), addr (on_mask_reloc)); inst_ptr = addr (on_mask_inst); inst_ptr -> inst_struc_basic.fill1_op = LDI; /* Emit an LDI instruction to turn on the mask indicator bit. */ call cobol_emit (addr (on_mask_inst), addr (on_mask_reloc), 1); return; /* OFF ENTRY POINT */ off: entry; call cobol_emit (addr (ldi_inst), null, 1); return; /* 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; %include cobol_; end cobol_fofl_mask;  cobol_gen_driver_.pl1 05/24/89 1041.5rew 05/24/89 0832.1 271512 /****^ *********************************************************** * * * 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_gen_driver_.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_gen_driver_.pl1 Fix wild array subscript. END HISTORY COMMENTS */ /* Modified on 02/01/85 by FCH, [5.3-2], BUG561, cond statements revised */ /* Modified on 10/19/84 by FCH, [5.3-1], BUG563(phx18381), new cobol_addr_tokens.incl.pl1 */ /* Modified on 09/03/83 by FCH, [5.2...], trace added */ /* Modified on 01/20/81 by FCH, [4.4-1], BUG461, statement map incorrect if statement follows para at end of perf range */ /* Modified on 05/16/80 by FCH, [4.2-5], decl for tag_addr corrected */ /* Modified on 04/18/80 by FCH, [4.2-4], tag stack added */ /* Modified on 04/08/80 by FCH, [4.2-3], subscripts lost if abbrev compare BUG428(TR3271) */ /* Modified on 10/20/79 by PRP, [4.1-2], recognize paragraph names for statement map */ /* Modified on 10/20/79 by PRP, [4.1-1], add to map_data_table for statement map */ /* Modified on 06/27/79 by FCH, [4.0-1], not option added for debug */ /* Modified since Version 4.0 */ /* format: style3 */ cobol_gen_driver_: proc; dcl on_err_tag fixed bin, subscript_flag fixed bin, binit_tag fixed bin, decl_flag fixed bin, last_decl_proc fixed bin, fxs_tag fixed bin, fxs_locno fixed bin, index fixed bin, pc_flag fixed bin, search_flag fixed bin, temp fixed bin, token_type fixed bin, sub_token_index fixed bin, space_ptr ptr, subscript_ptr ptr, record_ptr ptr, current_token_ptr ptr static int, temp_prev_ptr ptr, bypass_flag bit (1), temp_ptr ptr, decl_sw fixed bin, (end_flag, off) fixed bin; /*[4.2-4]*/ declare tag_stack_loc fixed bin; /*[4.2-4]*/ declare tag_stack (512) fixed bin; dcl dn_ptr ptr, h_no fixed bin; dcl seq_file_hdr (8) fixed bin aligned based (cobol_$minpral5_ptr); dcl 1 shdr based (cobol_$minpral5_ptr) aligned, /* header of working file */ 2 x1 char (12), 2 next fixed bin, /* offset of next token */ 2 code fixed bin, /* 10 for sequential file */ 2 x3 char (4), /* unused */ 2 next_file ptr, 2 prev_file ptr, /* points to previous file */ 2 fc char (4), /* file code for each different kind of file */ 2 file_no fixed bin, /* file count for each working file */ 2 x2 char (12), /* unused */ 2 first fixed bin; /* first token */ dcl 1 record aligned based (record_ptr), 2 prev_rcd_ln fixed bin aligned, 2 this_rcd_ln fixed bin aligned; dcl 1 token_hdr aligned based (in_token.token_ptr (in_token.n)), 2 size fixed bin (15) aligned, 2 line fixed bin (15) aligned, 2 column fixed bin (15) aligned, 2 type fixed bin (15) aligned, 2 sub_ptr ptr unal; dcl 1 sub_token aligned based (in_token_ptr), 2 pad1 fixed bin aligned, 2 pad2 fixed bin aligned, 2 sub_token_ptr (511) ptr aligned; 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, 3 col fixed bin unaligned, 3 label bit unaligned; /*[4.2-5]*/ declare 1 DEF aligned based (cobol_$tag_table_ptr), /*[4.2-5]*/ 2 tag_max fixed bin, /*[4.2-5]*/ 2 TAG (32767), /*[4.2-5]*/ 3 tag_addr fixed bin (17) unal, /*[4.2-5]*/ 3 tag_no fixed bin (17) unal; /*************************************/ start: /***..... Trace_Bit="0"b;/**/ /***..... Trace_Lev=0;/**/ /***..... Trace_Line="0123456789ABCDEFGHIJKLMOOPQRSTUVWXYZ";/**/ /* PROCESS ALTER/PERFORM INFORMATION */ space_ptr = cobol_$misc_end_ptr; if fixed_common.perf_alter_info ^= "00000" | fixed_common.size_perform_info ^= "00000" then call cobol_alter_perform (space_ptr, cobol_$misc_max); else do; cobol_$alter_list_ptr = null; cobol_$perform_list_ptr = null; cobol_$seg_init_list_ptr = null; seg_init_flag = 0; end; comp_token_area: cobol_$temp_token_max = cobol_$misc_max - binary (rel (space_ptr), 17) + binary (rel (cobol_$misc_end_ptr), 17); if cobol_$temp_token_max < 28 then do; error_info.message = "Temporary token area overflow"; error_info.message_len = 29; call signal_ ("command_abort_", null, addr (error_info)); goto comp_token_area; end; cobol_$temp_token_area_ptr = space_ptr; cobol_$temp_token_ptr = space_ptr; cobol_$misc_end_ptr = null; bypass_flag = "0"b; cobol_$sect_eop_flag = 0; cobol_$para_eop_flag = 0; cobol_$alter_flag = 0; cobol_$alter_index = 1; cobol_$perform_para_index = 1; cobol_$perform_sect_index = 0; cobol_$priority_no = 0; decl_flag = 0; end_flag = 0; last_decl_proc = 0; on_err_tag = 0; /*[4.2-4]*/ tag_stack_loc = 0; pc_flag = 0; search_flag = 0; subscript_flag = 0; cobol_$init_stack_off = 68; cobol_$stack_off = cobol_$init_stack_off; cobol_$max_stack_off = cobol_$init_stack_off; in_token_ptr = cobol_$token_block1_ptr; in_token.n = 0; sub_token_index = 511; in_token.code = 0; map_data_table.no_source_stmts = 0; if fixed_common.prog_coll_seq ^= 0 then do; index = fixed_common.prog_coll_seq; call cobol_read_rand$fixed_bin (2, index, alpha_name_ptr); cobol_$main_pcs_ptr = alpha_name_ptr; if alphabet_name.iw_key = 0 then do; call cobol_pool (alphabet_name.table, 2, alphabet_name.offset); alphabet_name.offset = alphabet_name.offset * 4; alphabet_name.segno = 3000; end; if alphabet_name.iw_key = 11 then alpha_name_ptr = null (); /* ascii */ end; else cobol_$main_pcs_ptr = null (); temp_prev_ptr = shdr.prev_file; if temp_prev_ptr ^= null () then do while (temp_prev_ptr ^= null ()); cobol_$minpral5_ptr = temp_prev_ptr; temp_prev_ptr = cobol_$minpral5_ptr -> shdr.prev_file; end; record_ptr = addrel (cobol_$minpral5_ptr, seq_file_hdr (5) + 4); goto eof_test; /* ....... GET TOKENS COMPRISING "STATEMENT" ....... */ get_tokens: if on_err_tag < 0 then do; on_err_tag = 0; bypass_flag = "1"b; end; if in_token.code > 0 then in_token.n = in_token.code; else do; if search_flag = 0 then do; if cobol_$stack_off > cobol_$max_stack_off then cobol_$max_stack_off = cobol_$stack_off; cobol_$stack_off = cobol_$init_stack_off; end; cobol_$temp_token_ptr = cobol_$temp_token_area_ptr; if in_token.code = -1 then if in_token_ptr = cobol_$token_block1_ptr then in_token_ptr = cobol_$token_block2_ptr; else in_token_ptr = cobol_$token_block1_ptr; in_token.n = 0; end; in_token.code = 0; /*[4.2-3]*/ if h_no ^= 13 then sub_token_index = 511; get_next_token: temp = record.this_rcd_ln + 7; record_ptr = addrel (record_ptr, substr (unspec (temp), 17, 18)); eof_test: if record.this_rcd_ln <= 0 then do; if shdr.next_file = null () then go to data_and_seg_init; else do; cobol_$minpral5_ptr = shdr.next_file; record_ptr = addrel (cobol_$minpral5_ptr, seq_file_hdr (5) + 4); if record.this_rcd_ln <= 0 then go to data_and_seg_init; end; end; type_tests: in_token.n = in_token.n + 1; token_block_ovfl_test: if in_token.n > sub_token_index then do; error_info.message = "Token block overflow"; error_info.message_len = 20; call signal_ ("command_abort_", null, addr (error_info)); goto token_block_ovfl_test; end; in_token.token_ptr (in_token.n) = addrel (record_ptr, 2); current_token_ptr = addrel (record_ptr, 2); token_type = token_hdr.type; /***..... if Trace_Bit/**/ /***..... then call ioa_("^30x^a^d^x^a^d^x^a^p^x^a^d",/**/ /***..... "TOKEN: LINE= ",token_hdr.line,"COL= ",token_hdr.column,"LOC= ",record_ptr,/**/ /***..... "TYPE= ",token_type);/**/ if token_type = 7 /*[4.1-2]*/ then do; /*[4.4-1]*/ off = cobol_$text_wd_off; /*[4.4-1]*/ if cobol_$para_eop_flag ^= 0 then off = off + 2; /* last para was end of perform */ map_data_table.no_source_stmts = map_data_table.no_source_stmts + 1; map_data_table.data.line_no (map_data_table.no_source_stmts) = current_token_ptr -> proc_def.line; map_data_table.data.text_addr (map_data_table.no_source_stmts) = off; map_data_table.col (map_data_table.no_source_stmts) = current_token_ptr -> proc_def.column; /*[4.1-1]*/ map_data_table.label (map_data_table.no_source_stmts) = "1"b; end; if token_type = reserved_wd then do; if subscript_flag ^= 0 then do; sub_token.sub_token_ptr (sub_token_index) = current_token_ptr; in_token.n = in_token.n - 1; sub_token_index = sub_token_index - 1; goto get_next_token; end; if current_token_ptr -> reserved_word.end_cobol /*[4.1-1]*/ then do; if current_token_ptr -> reserved_word.column ^= 9999 then do; map_data_table.no_source_stmts = map_data_table.no_source_stmts + 1; map_data_table.data.line_no (map_data_table.no_source_stmts) = current_token_ptr -> reserved_word.line; map_data_table.data.text_addr (map_data_table.no_source_stmts) = cobol_$text_wd_off; map_data_table.col (map_data_table.no_source_stmts) = current_token_ptr -> reserved_word.column; map_data_table.label (map_data_table.no_source_stmts) = "0"b; map_data_table.data.line_no (map_data_table.no_source_stmts + 1) = current_token_ptr -> reserved_word.line + 1; end; else map_data_table.data.line_no (map_data_table.no_source_stmts + 1) = current_token_ptr -> reserved_word.line; end; if current_token_ptr -> reserved_word.verb = "1"b then do; if pd_map_sw = 1 & end_flag = 0 then do; test1_map_data_ovfl: if map_data_table.no_source_stmts + 2 > cobol_$map_data_max then do; error_info.message = "Object map overflow"; error_info.message_len = 19; call signal_ ("command_abort_", null, addr (error_info)); goto test1_map_data_ovfl; end; map_data_table.no_source_stmts = map_data_table.no_source_stmts + 1; map_data_table.data.line_no (map_data_table.no_source_stmts) = current_token_ptr -> reserved_word.line; map_data_table.data.text_addr (map_data_table.no_source_stmts) = cobol_$text_wd_off; map_data_table.col (map_data_table.no_source_stmts) = current_token_ptr -> reserved_word.column; map_data_table.label (map_data_table.no_source_stmts) = "0"b; call cobol_reset_r$in_line; if fixed_common.options.profile then call cobol_profile; end; if current_token_ptr -> reserved_word.key = perform | current_token_ptr -> reserved_word.key = compute then pc_flag = 1; end; goto get_next_token; end; if token_type > 31 then go to get_next_token; else go to TOK (token_type); TOK (2): /* numeric literal */ if current_token_ptr -> numeric_lit.subscript = "1"b then call stack_sub; goto get_next_token; TOK (31): /* tag equivalence */ call cobol_equate_tag (current_token_ptr); in_token.n = in_token.n - 1; goto get_next_token; TOK (9): /* data name */ if current_token_ptr -> data_name.used_as_sub = "1"b then call stack_sub; else if subscript_flag = 1 then if current_token_ptr -> data_name.subscripted = "1"b then do; token_hdr.sub_ptr = subscript_ptr; sub_token.sub_token_ptr (sub_token_index) = null; sub_token_index = sub_token_index - 1; subscript_flag = 0; end; goto get_next_token; TOK (10): /* index name */ if current_token_ptr -> index_name.subscript = "1"b then do; call stack_sub; end; goto get_next_token; TOK (30): /* tag definition */ if pc_flag ^= 0 then goto get_next_token; if search_flag ^= 0 & current_token_ptr -> int_tag.true_path = "0"b then goto get_next_token; call cobol_define_tag_nc (binary (current_token_ptr -> int_tag.proc_num, 17), cobol_$text_wd_off); in_token.n = in_token.n - 1; goto get_next_token; TOK (19): /* eos */ if bypass_flag then do; if current_token_ptr -> end_stmt.verb = 3 then bypass_flag = "0"b; /* end of imperative statement */ go to get_tokens; end; h_no = current_token_ptr -> end_stmt.verb; /***.....if Trace_Bit then call ioa_("^a^d^a^d","*****HANDLER= ",h_no,"TAG= ",on_err_tag);/**/ go to handler (h_no); TOK (1): TOK (3): TOK (4): TOK (5): TOK (6): TOK (7): TOK (8): TOK (11): TOK (12): TOK (13): TOK (14): TOK (15): TOK (16): TOK (17): TOK (18): TOK (20): TOK (21): TOK (22): TOK (23): TOK (24): TOK (25): TOK (26): TOK (27): TOK (28): TOK (29): go to get_next_token; stack_sub: proc; sub_token.sub_token_ptr (sub_token_index) = current_token_ptr; if subscript_flag = 0 then do; subscript_flag = 1; subscript_ptr = addr (sub_token.sub_token_ptr (sub_token_index)); end; in_token.n = in_token.n - 1; sub_token_index = sub_token_index - 1; end; push: proc; /*[4.2-4]*/ if current_token_ptr -> end_stmt.b /*[4.2-4]*/ then do; tag_stack_loc = tag_stack_loc + 1; /*[4.2-4]*/ tag_stack (tag_stack_loc) = on_err_tag; /*[4.2-4]*/ on_err_tag = 0; /*[4.2-4]*/ end; end; push1: proc; /* Used by READ */ /*[4.2-4]*/ if current_token_ptr -> end_stmt.a ^= "0"b /*[4.2-4]*/ then do; tag_stack_loc = tag_stack_loc + 1; /*[4.2-4]*/ tag_stack (tag_stack_loc) = on_err_tag; /*[4.2-4]*/ on_err_tag = 0; /*[4.2-4]*/ end; end; pop: proc; /*[4.2-4]*/ on_err_tag = tag_stack (tag_stack_loc); /*[4.2-4]*/ tag_stack_loc = tag_stack_loc - 1; end; /* ....... HANDLERS ....... */ handler (1): call cobol_accept_gen (in_token_ptr); goto get_tokens; handler (2): /*[4.2-4]*/ call push; call cobol_add_gen (in_token_ptr, on_err_tag); goto get_tokens; handler (3): /*[4.0-1]*/ if current_token_ptr -> end_stmt.b /*[4.0-1]*/ then do; if on_err_tag ^= 0 then call cobol_gen_ioerror$finish_up_not (on_err_tag); /*[4.0-1]*/ end; /*[4.0-1]*/ else do; if on_err_tag ^= 0 then call cobol_define_tag (on_err_tag);/*[4.2-4]*/ call pop; /*[4.0-1]*/ end; go to get_tokens; handler (4): call cobol_alter_gen (in_token_ptr); goto get_tokens; handler (5): call cobol_call_gen (in_token_ptr); goto get_tokens; handler (6): error_info.message = "Unassigned verb number in EOS"; error_info.message_len = 29; call signal_ ("command_abort_", null, addr (error_info)); goto get_tokens; handler (7): call cobol_cancel_gen (in_token_ptr); go to get_tokens; handler (8): call cobol_close_gen (in_token_ptr); goto get_tokens; handler (9): /*[4.2-4]*/ call push; call cobol_divide_gen (in_token_ptr, on_err_tag); goto get_tokens; handler (10): /*[4.2-4]*/ call push; call cobol_multiply_gen (in_token_ptr, on_err_tag); goto get_tokens; handler (11): /*[4.2-4]*/ call push; call cobol_subtract_gen (in_token_ptr, on_err_tag); goto get_tokens; handler (12): call cobol_exit_gen (in_token_ptr); goto get_tokens; handler (13): if pc_flag ^= 0 then goto get_next_token; call cobol_compare_gen (in_token_ptr); goto get_tokens; handler (14): call cobol_go_gen (in_token_ptr); goto get_tokens; handler (15): call cobol_merge_gen (in_token_ptr); goto get_tokens; handler (16): error_info.message = "Verb not supported in this release"; error_info.message_len = 34; call signal_ ("command_abort_", null, addr (error_info)); goto get_tokens; handler (17): call cobol_inspect_gen (in_token_ptr); goto get_tokens; handler (18): call cobol_move_gen (in_token_ptr); goto get_tokens; handler (19): call cobol_open_gen (in_token_ptr); goto get_tokens; handler (20): call cobol_perform_gen (in_token_ptr); pc_flag = 0; goto get_tokens; handler (21): /*[4.2-4]*/ call push1; call cobol_read_gen (in_token_ptr, on_err_tag); goto get_tokens; handler (22): /*[4.2-4]*/ call push; call cobol_delete_gen (in_token_ptr, on_err_tag); goto get_tokens; handler (23): /*[4.2-4]*/ call push; call cobol_receive_gen (in_token_ptr, on_err_tag); goto get_tokens; handler (24): call cobol_release_gen (in_token_ptr); goto get_tokens; handler (25): /*[4.2-4]*/ call push; call cobol_return_gen (in_token_ptr, on_err_tag); goto get_tokens; handler (26): call cobol_search_gen (in_token_ptr, search_flag); goto get_tokens; handler (27): /*[5.3-2]*/ call push; call cobol_rewrite_gen (in_token_ptr, on_err_tag); goto get_tokens; handler (28): if pc_flag ^= 0 then goto get_next_token; call cobol_arithop_gen (in_token_ptr); goto get_tokens; handler (29): goto handler (6); /* for now */ handler (30): call cobol_send_gen (in_token_ptr); goto get_tokens; handler (31): call cobol_set_gen (in_token_ptr); goto get_tokens; handler (32): goto handler (6); /* for now */ handler (33): call cobol_stop_gen (in_token_ptr); goto get_tokens; handler (34): /*[4.2-4]*/ call push; call cobol_string_gen (in_token_ptr, on_err_tag); goto get_tokens; handler (35): goto handler (6); /* 06-30-77 */ handler (36): goto handler (6); /* 06-30-77 */ handler (37): /*[4.2-4]*/ call push; call cobol_unstring_gen (in_token_ptr, on_err_tag); goto get_tokens; handler (38): /*[4.2-4]*/ call push; call cobol_write_gen (in_token_ptr, on_err_tag); goto get_tokens; handler (39): goto get_tokens; handler (40): /*[4.2-4]*/ call push; call cobol_compute_gen (in_token_ptr, on_err_tag); pc_flag = 0; goto get_tokens; handler (41): call cobol_disable_gen (in_token_ptr); goto get_tokens; handler (42): call cobol_display_gen (in_token_ptr); goto get_tokens; handler (43): call cobol_enable_gen (in_token_ptr); goto get_tokens; handler (44): goto handler (6); /* 06-30-77 */ handler (45): goto handler (6); /* 06-30-77 */ handler (46): goto handler (6); /* 06-30-77 */ handler (47): goto handler (6); /* for now */ handler (48): goto handler (6); /* 06-30-77 */ handler (49): call cobol_sort_gen (in_token_ptr); goto get_tokens; handler (50): error_info.message = "Verb not supported in this release"; error_info.message_len = 34; call signal_ ("command_abort_", null, addr (error_info)); goto get_tokens; handler (51): error_info.message = "Verb not supported in this release"; error_info.message_len = 34; call signal_ ("command_abort_", null, addr (error_info)); goto get_tokens; handler (52): if pd_map_sw = 1 & end_flag = 0 then do; test2_map_data_ovfl: if map_data_table.no_source_stmts + 2 > cobol_$map_data_max then do; error_info.message = "Object map overflow"; error_info.message_len = 19; call signal_ ("command_abort_", null, addr (error_info)); goto test2_map_data_ovfl; end; map_data_table.no_source_stmts = map_data_table.no_source_stmts + 1; map_data_table.data.line_no (map_data_table.no_source_stmts) = in_token.token_ptr (1) -> reserved_word.line; map_data_table.data.text_addr (map_data_table.no_source_stmts) = cobol_$text_wd_off; map_data_table.col (map_data_table.no_source_stmts) = in_token.token_ptr (1) -> reserved_word.column; map_data_table.label (map_data_table.no_source_stmts) = "0"b; end; decl_sw = 0; temp = record.this_rcd_ln + 7; temp_ptr = addrel (record_ptr, substr (unspec (temp), 17, 18)); if temp_ptr -> record.this_rcd_ln > 0 then do; temp_ptr = addrel (temp_ptr, 2); if temp_ptr -> token_hdr.type = reserved_wd then if temp_ptr -> reserved_word.key = 89 then decl_sw = 1; /* DECLARATIVES */ end; call cobol_prologue_gen (in_token_ptr, binit_tag, fxs_tag, fxs_locno, decl_sw); /* Stack space used by cobol_prologue_gen is not returnable */ cobol_$init_stack_off = cobol_$stack_off; goto get_tokens; handler (53): decl_flag = 1; if fxs_tag = 0 then call cobol_decl_gen (fxs_tag); goto get_tokens; handler (54): call cobol_section_gen (in_token_ptr); goto get_tokens; handler (55): call cobol_paragraph_gen (in_token_ptr); goto get_tokens; handler (56): /*[4.2-4]*/ call push; call cobol_start_gen (in_token_ptr, on_err_tag); goto get_tokens; handler (57): goto handler (6); /* 06-30-77 */ handler (58): call cobol_purge_gen (in_token_ptr); goto get_tokens; handler (59): handler (60): handler (61): handler (62): handler (63): handler (64): handler (65): handler (66): handler (67): handler (68): handler (69): handler (70): handler (71): handler (72): handler (73): handler (74): handler (75): handler (76): handler (77): handler (78): handler (79): handler (80): handler (81): handler (82): handler (83): handler (84): handler (85): handler (86): handler (87): handler (88): handler (89): handler (90): handler (91): handler (92): handler (93): handler (94): handler (95): handler (96): handler (97): goto handler (6); /* for now */ handler (98): call cobol_end_gen (in_token_ptr, fxs_locno, fxs_tag, last_decl_proc, end_flag); if end_flag = 1 then cobol_$init_stack_off = cobol_$max_stack_off; goto get_tokens; data_and_seg_init: /***..... Trace_Bit="0"b;/**/ if binit_tag ^= 0 then do; call cobol_define_tag (binit_tag); /* Data initialization */ if data_init_flag ^= 0 then do; record_ptr = addrel (initval_base_ptr, seq_file_hdr (5) + 4); cobol_$stack_off = cobol_$init_stack_off; do while (record.this_rcd_ln > 0); do index = 1 to 4; in_token.token_ptr (index) = addrel (record_ptr, 2); temp = record.this_rcd_ln + 7; record_ptr = addrel (record_ptr, substr (unspec (temp), 17, 18)); end; in_token.n = 4; call cobol_move_gen (in_token_ptr); if cobol_$stack_off > cobol_$max_stack_off then cobol_$max_stack_off = cobol_$stack_off; cobol_$stack_off = cobol_$init_stack_off; cobol_$temp_token_ptr = cobol_$temp_token_area_ptr; end; end; /* Segment initialization */ call cobol_seginit_gen (fxs_locno, last_decl_proc); if decl_flag = 0 & fxs_tag ^= 0 then /*-11/30/76-*/ call cobol_define_tag_nc (fxs_tag, fxs_locno); end; exit: return; /***.....Tr_Beg: entry(str);/**/ /***..... Trace_Lev=Trace_Lev+1;/**/ /***..... call ioa_("^a^a",substr(Trace_Line,Trace_Lev,1)," "||str);/**/ /***.....return;/**/ /***.....Tr_End: entry(str);/**/ /***..... call ioa_("^a^a",substr(Trace_Line,Trace_Lev,1)," END:"||str);/**/ /***..... Trace_Lev=Trace_Lev-1;/**/ /***.....return;/**/ /***..... 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 str char(*);/**/ /* The function of cobol_gen_driver_ is to direct the generation of the object code necessary to implement the source code comprising a given COBOL program. The primary input to cobol_gen_driver_ is the file Minpral5. This file comprises a sequence of tokens which are, in effect, a coded version of the source program. These tokens are grouped, by PD Syntax, into logical sets for process- ing by the insertion of type-19 End of "Statement" (EOS) tokens. cobol_gen_driver_ creates a structure (in_token) consisting primarily of pointers to each token comprising a "statement", as delimited by EOS tokens, and passes a pointer to this structure to the appropriate generator. In addition, cobol_gen_driver_ performs a number of auxiliary functions, such as; 1. Initialization of a number of variables to pre-code-gener- ation values. 2. Initialization of the definition and linkage sections. 3. Deallocation of the stack and determination of maximum re- quired stack size. 4. Deallocation of the area (temp_token_area) in which tokens to temporaries are built. 5. Tabulation of data for the construction of the procedure division map. 6. Resolution of internal tag definition and tag equivalence tokens not bracketed within EOS tokens. U__s_a_g_e:_ declare cobol_gen_driver_ entry; call cobol_gen_driver_; D__a_t_a:_ include cobol_; Items in cobol_ include file used (u) and/or set (s) by cobol_gen_driver_: cobol_ptr (u) com_ptr (u) alter_flag (s) alter_index (s) alter_list_ptr (s) init_stack_off (s) map_data_ptr (u) map_data_max (u) max_stack_off (s) minpral5_ptr (u) misc_end_ptr (u) misc_max (u) para_eop_flag (s) perform_list_ptr (u/s) perform_para_index (s) perform_sect_index (s) priority_no (s) sect_eop_flag (s) seg_init_list_ptr (s) stack_off (u/s) temp_token_area_ptr (s) temp_token_ptr (s) temp_token_max (s) token_block1_ptr (u) token_block2_ptr (u) text_wd_off (u) include fixed_common; Items in fixed_common include file used (u) and/or set (s) by cobol_gen_driver_: perf_alter_info (u) size_perform_info (u) Conditional Statements: end_stmt.b="1"b if code for an option follows end_stmt.f="01"b if it is a NOT option end_stmt.a(3)b(1)c(1)d(2)f(2) (1) STATEMENT OPTION (a) cobol_pdout_ STATEMENT type19(vt = CODE, b = 1, f = 00) OPTION type19(vt = 3, b = 0) (b) generated code STATEMENT -> (L1) OPTION L1: (2) STATEMENT OPTION NOT OPTION (a) cobol_pdout_ STATEMENT type19(vt = CODE, b = 1, f = 00) OPTION type19(vt = 3, b = 1, f = 01) NOT OPTION type19(vt = 3, b = 0) (b) generated code STATEMENT -> (L1) OPTION TRA L3 L1: NOT OPTION L2: (3) STATEMENT NOT OPTION OPTION (a) cobol_pdout_ STATEMENT type19(vt = CODE, b = 1, f = 01) NOT OPTION type19(vt = 3, b = 1, f = 00) OPTION type19(vt = 3, b = 0) (b) generated code STATEMENT -> (L1) NOT OPTION TRA L2 L1: OPTION L2: (4) STATEMENT NOT OPTION (a) cobol_pdout_ STATEMENT type19(vt = CODE, b = 1, f = 01) NOT OPTION type19(vt = 3, b = 0) (b) generated code STATEMENT -> (L1) NOT-OPTION L1: */ dcl 1 error_info static aligned, 2 name char (32) aligned init ("cobol_gen_driver_"), 2 message_len fixed bin aligned, 2 message char (36) aligned; dcl reserved_wd fixed bin internal static init (1), numeric_lit_token fixed bin internal static init (2), type_9 fixed bin internal static init (9), index_name_token fixed bin internal static init (10), eos fixed bin internal static init (19), internal_tag fixed bin internal static init (30), tag_equivalence fixed bin internal static init (31), perform fixed bin internal static init (20), compute fixed bin internal static init (40); /* P__r_o_c_e_d_u_r_e_s_C__a_l_l_e_d:_ */ dcl cobol_alter_perform entry (ptr, fixed bin), cobol_reset_r$in_line entry, signal_ entry (char (*), ptr, ptr), cobol_equate_tag entry (ptr), cobol_define_tag entry (fixed bin), cobol_define_tag_nc entry (fixed bin, fixed bin), cobol_accept_gen entry (ptr), cobol_add_gen entry (ptr, fixed bin), cobol_alter_gen entry (ptr), cobol_call_gen entry (ptr), cobol_cancel_gen entry (ptr), cobol_close_gen entry (ptr), cobol_divide_gen entry (ptr, fixed bin), cobol_multiply_gen entry (ptr, fixed bin), cobol_subtract_gen entry (ptr, fixed bin), cobol_exit_gen entry (ptr), cobol_compare_gen entry (ptr), cobol_go_gen entry (ptr), cobol_move_gen entry (ptr), cobol_open_gen entry (ptr), cobol_perform_gen entry (ptr), cobol_read_gen entry (ptr, fixed bin), cobol_gen_ioerror$finish_up_not entry (fixed bin), cobol_delete_gen entry (ptr, fixed bin), cobol_receive_gen entry (ptr, fixed bin), cobol_release_gen entry (ptr), cobol_return_gen entry (ptr, fixed bin), cobol_rewrite_gen entry (ptr, fixed bin), cobol_arithop_gen entry (ptr), cobol_send_gen entry (ptr), cobol_set_gen entry (ptr), cobol_stop_gen entry (ptr), cobol_write_gen entry (ptr, fixed bin), cobol_compute_gen entry (ptr, fixed bin), cobol_disable_gen entry (ptr), cobol_display_gen entry (ptr), cobol_enable_gen entry (ptr), cobol_sort_gen entry (ptr), cobol_merge_gen entry (ptr), cobol_profile entry, cobol_prologue_gen entry (ptr, fixed bin, fixed bin, fixed bin, fixed bin), cobol_decl_gen entry (fixed bin), cobol_section_gen entry (ptr), cobol_paragraph_gen entry (ptr), cobol_start_gen entry (ptr, fixed bin), cobol_pool entry (char (*), fixed bin, fixed bin), cobol_read_rand$fixed_bin entry (fixed bin, fixed bin, ptr), cobol_seginit_gen entry (fixed bin, fixed bin), cobol_search_gen entry (ptr, fixed bin), cobol_inspect_gen entry (ptr), cobol_string_gen entry (ptr, fixed bin), cobol_unstring_gen entry (ptr, fixed bin), cobol_purge_gen entry (ptr), cobol_end_gen entry (ptr, fixed bin, fixed bin, fixed bin, fixed bin); /* B__u_i_l_t-__i_n_F__u_n_c_t_i_o_n_s_U__s_e_d:_ */ dcl (addr, size) builtin, addrel builtin, baseno builtin, binary builtin, null builtin, rel builtin, substr builtin, unspec builtin; %include cobol_in_token; %include cobol_type1; %include cobol_type2; %include cobol_type9; %include cobol_type10; %include cobol_type19; %include cobol_type30; %include cobol_; %include cobol_fixed_common; %include cobol_ext_; %include cobol_op_con; %include cobol_type40; %include cobol_type7; /*[4.1-2]*/ end cobol_gen_driver_;  cobol_gen_error.pl1 05/24/89 1041.5rew 05/24/89 0831.4 65907 /****^ *********************************************************** * * * 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_gen_error.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 7/7/76 by George Mercuri to correct use entry when error code ^= 0. */ /* Modified on 6/2/76 by Bob Chang to implement the reg_reset entry. */ /* Modified on 5/18/76 by Bob Chang to fix the aos instruction. */ /* Modified on 5/16/76 by Bob Chang to take out set_pr5 statment. */ /* Modified on 5/12/76 by George Mercuri to add pr0| to tsx0 instruction. */ /* Modified on 5/12/76 by George Mercuri for additional feature on cobol_error_code. */ /* Modified on 5/10/76 by George Mercuri for error handling. */ /* Created on 05/05/76 by Bob Chang to interface with cobol_reg_manager. */ /*{*/ /* format: style3 */ cobol_gen_error: proc (cobol_error_code, tagno); /* 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 tagno fixed bin; dcl tt fixed bin; /* cobol_error_code a fixed bin number indicating the "COBOL error number" (see below). If 0, then it is assumed that the appropriate cobol_operators_ has set the cobol_error_code value in X1. 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_gen_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_gen_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 add_use_code bit (36) static init ("110000000001001001000101100001000000"b); /* aos pr6|73 */ /* -5-18-76 - */ dcl temp fixed bin; dcl inst_seq (6) bit (18) static init ("000000000000000000"b, "111000000001000000"b, /* tsx0 pr0|op_num */ "000000000000000000"b, "111001000000000100"b, /* tra 0,ic */ "000000111111111111"b, "111000000001001001"b); /* tsx0 pr0|4095,1 */ /* Procedures Called */ dcl cobol_emit entry (ptr, ptr, fixed bin), cobol_define_tag entry (fixed bin), cobol_reg_manager$before_op entry (fixed bin), cobol_reg_manager$after_op entry (fixed bin), cobol_make_tagref entry (fixed bin, fixed bin, ptr); /***********************************/ start: if tagno = 0 then do; tt = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_define_tag (tt); end; else tt = tagno; if cobol_error_code = 0 then /*5/12/76*/ call cobol_emit (addr (inst_seq (5)), null (), 1); else do; temp = 4095 + cobol_error_code; substr (inst_seq (1), 4, 15) = substr (unspec (temp), 22, 15); call cobol_emit (addr (inst_seq (1)), null (), 1); end; call cobol_emit (addr (inst_seq (3)), null (), 1); call cobol_make_tagref (tt, cobol_$text_wd_off - 1, null ()); return; /***********************************/ reg_reset: entry (cobol_error_code, tagno); if tagno = 0 then do; tt = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_define_tag (tt); end; else tt = tagno; call cobol_reg_manager$before_op (0); if cobol_error_code = 0 then /*5/12/76*/ call cobol_emit (addr (inst_seq (5)), null (), 1); else do; temp = 4095 + cobol_error_code; substr (inst_seq (1), 4, 15) = substr (unspec (temp), 22, 15); call cobol_emit (addr (inst_seq (1)), null (), 1); end; call cobol_reg_manager$after_op (0); call cobol_emit (addr (inst_seq (3)), null (), 1); call cobol_make_tagref (tt, cobol_$text_wd_off - 1, null ()); return; /*************************************/ use: entry (cobol_error_code); /*5/12/76*/ call cobol_emit (addr (add_use_code), null (), 1); if cobol_error_code = 0 then call cobol_emit (addr (inst_seq (5)), null (), 1); else do; temp = 4095 + cobol_error_code; substr (inst_seq (1), 4, 15) = substr (unspec (temp), 22, 15); call cobol_emit (addr (inst_seq (1)), null (), 1); end; 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_gen_error;  cobol_gen_ioerror.pl1 05/24/89 1041.5rew 05/24/89 0831.4 83493 /****^ *********************************************************** * * * 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_gen_ioerror.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 06/27/79 by FCH, [4.0-1], entry finish_up_not added for debug */ /* Modified since Version 4.0 */ /* format: style3 */ cobol_gen_ioerror: proc (ft_ptr, ioerror_ptr); dcl ft_ptr ptr; /* ptr to the file table */ dcl ioerror_ptr ptr; /* ptr to additional error information */ /*[4.0-1]*/ declare passed_tag fixed bin; dcl 1 ioerror based (ioerror_ptr), 2 cobol_code fixed bin, 2 retry_tag fixed bin, /* tagno of retry address; 0 means just reissue error */ 2 is_tag fixed bin, /* tagno of imperative statement; 0 if none */ 2 ns_tag fixed bin, /* tagno of next statement; always reserved by caller */ /* defined by finish_up if is_tag=0; else by gen driver */ 2 type1_ptr ptr, /* pts to reserved word token for the verb of caller */ 2 mode fixed bin; /* -1 = file unopen at time of error - no categorical use procs apply 2 = file is being opened extend 0>m>21 3 = file is being opened input 20>m>41 4 = file is being opened i-o 40>m>61 5 = file is being opened output 60>m */ dcl file_key_desc char (40) based; /* a template for fkey_type9.file_key_info */ dcl retry_tag fixed bin; dcl ntag fixed bin; dcl mode_count fixed bin; dcl temp_error_exit fixed bin; dcl fkey_ptr ptr; dcl lda_sw bit (1); dcl fsbptr_sw bit (1); dcl perform_mode_sw bit (1); dcl io_sw bit (1); /*[4.0-1]*/ declare new_tag fixed bin; /*************************************/ start: if file_table.file_status then call set_status (addr (skey12_type9), addr (skey3_type9)); if ioerror.is_tag > 0 then do; /* an imperative statement follows */ call cobol_emit (addr (check_is_instr), null (), 2); call cobol_make_tagref (ioerror.is_tag, cobol_$text_wd_off - 1, null ()); end; perform_mode_sw = "0"b; /*-07/07/76-*/ temp_error_exit = file_table.error_exit; if file_table.error_exit ^= 0 then call perform_use (temp_error_exit); /* specific use proc */ else do; /* check for categorical use procs */ mode_count = 0; if ^file_table.external then do; /* can skip check for int file opened in only 1 mode */ if file_table.open_ext then mode_count = mode_count + 1; if file_table.open_in then mode_count = mode_count + 1; if file_table.open_out then mode_count = mode_count + 1; if file_table.open_io then mode_count = mode_count + 1; end; lda_sw, fsbptr_sw, io_sw = "0"b; if ioerror.mode = 0 then do; if fixed_common.extend_error_exit ^= 0 then /* possible to be opened EXTEND? */ if (^file_table.external & file_table.open_ext) | (file_table.external & file_table.organization = 1 & (file_table.write | file_table.close | file_table.open_ext)) then call perform_mode (fixed_common.extend_error_exit, extend_mode); if fixed_common.input_error_exit ^= 0 then /* possible to be opened INPUT? */ if (^file_table.external & file_table.open_in) | (file_table.external & (file_table.read | file_table.start | file_table.close | file_table.open_in)) then call perform_mode (fixed_common.input_error_exit, input_mode); if fixed_common.output_error_exit ^= 0 then /* possible to be opened OUTPUT? */ if (^file_table.external & file_table.open_out) | (file_table.external & (file_table.write | file_table.close | file_table.open_out)) then call perform_mode (fixed_common.output_error_exit, output_mode); if fixed_common.i_o_error_exit ^= 0 then /* possible to be opened I-O? */ if (^file_table.external & file_table.open_io) | (file_table.external & (file_table.read | file_table.rewrite | file_table.start | file_table.delete | file_table.close | file_table.open_io)) then do; io_sw = "1"b; call perform_mode (fixed_common.i_o_error_exit, i_o_mode); end; end; else if ioerror.mode > 0 then do; mode_count = 1; if ioerror.mode > 48 then if fixed_common.output_error_exit ^= 0 then call perform_mode (fixed_common.output_error_exit, output_mode); else ; else if ioerror.mode > 32 then if fixed_common.i_o_error_exit ^= 0 then call perform_mode (fixed_common.i_o_error_exit, i_o_mode); else ; else if ioerror.mode > 16 then if fixed_common.input_error_exit ^= 0 then call perform_mode (fixed_common.input_error_exit, input_mode); else ; else if fixed_common.extend_error_exit ^= 0 then call perform_mode (fixed_common.extend_error_exit, extend_mode); end; if (mode_count ^= 1 & mode_count ^= 4) | ^perform_mode_sw then do; /* must provide fall-thru */ retry_tag = ioerror.retry_tag; if retry_tag = 0 then do; retry_tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_define_tag (retry_tag); end; call cobol_gen_error (ioerror.cobol_code, retry_tag); end; end; return; /*************************************/ /* SUBROUTINES */ /*************************************/ perform_mode: proc (procno, mode); dcl procno fixed bin; dcl mode fixed bin; if mode_count ^= 1 then do; ntag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; if ^fsbptr_sw then do; call cobol_set_fsbptr (ft_ptr); fsbptr_sw = "1"b; end; if ^lda_sw then do; call cobol_emit (addr (set_mode_instr), null (), 2); lda_sw = "1"b; end; if ^(mode_count = 4 & io_sw) then do; /* no need to compare - can just fall in */ substr (cmpa_dl_instr, 1, 18) = substr (unspec (mode), 19, 18); call cobol_emit (addr (cmpa_dl_instr), null (), 1); call cobol_emit (addr (tnz_instr), null (), 1); call cobol_make_tagref (ntag, cobol_$text_wd_off - 1, null ()); end; end; call perform_use (procno); perform_mode_sw = "1"b; /* if not at least once, then must provide fall-thru */ if mode_count ^= 1 then call cobol_define_tag (ntag); return; end perform_mode; perform_use: proc (procno); dcl procno fixed bin; if ^perform_mode_sw then call cobol_gen_error$use (ioerror.cobol_code); /* record error (once) */ mpout.pt1 = ioerror.type1_ptr; type7.proc_num = procno; mpout.pt2, mpout.pt3 = addr (type7); mpout.pt4 = addr (perform_type19); call cobol_perform_gen (addr (mpout)); call cobol_emit (addr (tra_instr), null (), 1); /* and go to next statement */ call cobol_make_tagref (ioerror.ns_tag, cobol_$text_wd_off - 1, null ()); return; end perform_use; set_status: proc (skey12_ptr, skey3_ptr); dcl skey12_ptr ptr; dcl skey3_ptr ptr; call cobol_read_rand (1, file_table.file_status_info, fkey_ptr); addr (fkey_type9.file_key_info) -> file_key_desc = file_key.desc; mpout.pt1 = ioerror.type1_ptr; mpout.pt2 = skey12_ptr; mpout.pt3 = addr (fkey_type9); mpout.pt4 = addr (perform_type19); call cobol_move_gen (addr (mpout)); if file_table.extra_status then do; call cobol_read_rand (1, file_table.extra_status_info, fkey_ptr); addr (fkey_type9.file_key_info) -> file_key_desc = file_key.desc; mpout.pt2 = skey3_ptr; call cobol_move_gen (addr (mpout)); end; return; end set_status; /*************************************/ /*************************************/ finish_up: entry (ft_ptr, ioerror_ptr); if file_table.file_status then call set_status (addr (zero_type1), addr (zero_type1)); if ioerror.is_tag = 0 then call cobol_define_tag (ioerror.ns_tag); else do; /* an imperative statement follows */ call cobol_emit (addr (tra_instr), null (), 1); /* transfer around the imperative statement */ call cobol_make_tagref (ioerror.ns_tag, cobol_$text_wd_off - 1, null ()); /* gen driver will define this */ call cobol_define_tag (ioerror.is_tag); call cobol_reg_manager$set_pr5; /* must do now since we have come directly here */ end; return; finish_up_not: entry (passed_tag); /*[4.0-1]*/ new_tag = cobol_$next_tag; /*[4.0-1]*/ cobol_$next_tag = cobol_$next_tag + 1; /*[4.0-1]*/ call cobol_emit (addr (tra_instr), null (), 1); /*[4.0-1]*/ call cobol_make_tagref (new_tag, cobol_$text_wd_off - 1, null ()); /*[4.0-1]*/ call cobol_define_tag (passed_tag); /*[4.0-1]*/ passed_tag = new_tag; /*[4.0-1]*/ return; %include cobol_gen_ioerror_data; end cobol_gen_ioerror;  cobol_get_index_value.pl1 05/24/89 1041.5rew 05/24/89 0831.3 131994 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /****^ 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_get_index_value.pl1 Added Trace statements. END HISTORY COMMENTS */ /* format: style3 */ %; /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* Modified on 10/19/85 by FCH, [5.3-1], bug563(phx18381), new cobol_addr_tokens.incl.pl1 */ /* Modified since Version 2.0 */ /*{*/ cobol_get_index_value: proc (return_value_code, input_token_ptr, output_token_ptr); /* This procedure generates code to convert the value of an index (which is stored as a fixed binary number in two bytes of storage) to a decimal format operand in a temporary in the run-time stack. */ /* DECLARATION OF THE PARAMETERS */ dcl return_value_code fixed bin; dcl input_token_ptr ptr; dcl output_token_ptr ptr; /* return_value_code a code that indicates whether the index occurrence number is to be returned as a fixed bin (35) or decimal value. (input) This code can have the following values: return_value_code meaning 1 return fixed bin 2 return decimal input_token_ptr points to the input token: data name (type 9, usage is index), or index name (type 10) to be converted to decimal. (input) output_token_ptr points to a buffer in the caller's program in which the dataname (type 9) token, describing the resultant converted decimal value is built by this procedure. (input) */ /* Declaration of external entries */ dcl cobol_addr ext entry (ptr, 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_make_type9$copy ext entry (ptr, ptr); dcl cobol_register$load ext entry (ptr); dcl cobol_register$release ext entry (ptr); /* DECLARATION OF BUILTIN FUNCTIONS */ dcl addr builtin; dcl binary builtin; dcl bit builtin; dcl fixed builtin; /* Definition of internal static variables that contain op codes */ dcl btd_op bit (10) int static init ("0110000011"b /* 301(1) */); dcl mlr_op bit (10) int static init ("0010000001"b /* 100(1) */); dcl lda_op bit (10) int static init ("0100111010"b /* 235(0) */); dcl ldq_op bit (10) int static init ("0100111100"b /* 236(0) */); dcl ldaq_op bit (10) int static init ("0100111110"b /*237(0)*/); dcl lls_op bit (10) int static init ("1110111110"b /*737(0)*/); dcl lrs_op bit (10) int static init ("1110110110"b /*733(0)*/); dcl ars_op bit (10) int static init ("1110110010"b /*731(0)*/); dcl stq_op bit (10) int static init ("1111011100"b /*756(0)*/); /* Buffer in which instructions and/or descriptors are returned by the addressability utility */ dcl inst_buff (1:5) fixed bin; /* Buffer in which relocation information is returned by the addressability utility */ dcl reloc_buff (1:10) fixed bin; /* Buffer in which input to the addressabiliyt utility is built */ dcl input_buff (1:30) ptr; /* Work buffer in which a data name token (type 9) for the index value is built */ dcl wkbuff1 (1:40) fixed bin; dcl wkbuff1_ptr ptr; /* work buffer in which a data name token (type 9) for the occurence number in the stack is built */ dcl wkbuff2 (1:40) fixed bin; dcl wkbuff2_ptr ptr; dcl dn_ptr ptr; dcl byte_offset bit (2); dcl shift_val fixed bin; dcl return_decimal_value bit (1); /* Variables used to zero the descripiton bits of a data name token */ dcl descrip_ptr ptr; dcl descrip bit (72) based (descrip_ptr); dcl t_offset fixed bin; /* Structure used to communicate with the register$load procedure. */ 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 dname_ptr ptr, 2 literal bit (36); /**************************************************/ /* START OF EXECUTION */ /* cobol_get_index_value */ /**************************************************/ start: if return_value_code = 1 /* return fixed binary */ then return_decimal_value = "0"b; else return_decimal_value = "1"b; /* Set work pointers to point at the work buffers */ inst_ptr = addr (inst_buff (1)); reloc_ptr = addr (reloc_buff (1)); input_ptr = addr (input_buff (1)); wkbuff1_ptr = addr (wkbuff1 (1)); if return_decimal_value then dn_ptr = wkbuff1_ptr; /* build temporary output token */ else dn_ptr = output_token_ptr; /* Build output token in the user's work buffer */ if input_token_ptr -> data_name.type = rtc_dataname then do; /* Input token is a dataname token (type 9) with usage index bit set */ wkbuff2_ptr = addr (wkbuff2 (1)); /* Allocate four bytes on a word boundary in the stack, to receive the fixed binary occurrence number */ call cobol_alloc$stack (4, 0, t_offset); /* Make a data name token that describes the stack temporary to receive the occurrence number */ data_name.type = rtc_dataname; data_name.seg_num = 1000; /* Stack */ data_name.offset = t_offset; /* Offset returned by alloc$stack */ /* Update the two data name tokens so that alphanumeric eis descriptors will be built for them by the addressability utility. */ input_token_ptr -> data_name.alphanum = "1"b; input_token_ptr -> data_name.usage_index = "0"b; wkbuff2_ptr -> data_name.alphanum = "1"b; wkbuff2_ptr -> data_name.usage_index = "0"b; /* Allocate six bytes on an even word boundary in the stack to receive the six byte index data item. */ call cobol_alloc$stack (6, 2, t_offset); /* Convert the offset value from a word offset to a byte offset. */ t_offset = t_offset * 4; /* Make a copy of the input data name token. */ call cobol_make_type9$copy (wkbuff2_ptr, input_token_ptr); /* Modify the copy so that it describes the six byte temporary in the stack. */ wkbuff2_ptr -> data_name.seg_num = 1000;/* stack */ wkbuff2_ptr -> data_name.offset = t_offset; /* Turn off the subscripted bit in the token that describes the temporary. */ wkbuff2_ptr -> data_name.subscripted = "0"b; /* Generate code to move the index data item to the 6 byte temporary in the stack. */ /* Build the input structure to the addressability utility. */ input_struc.type = 5; /* EIS,2 input operands, instruction and 2 descriptors returned. */ input_struc.operand_no = 2; input_struc.lock = 0; input_struc.operand.token_ptr (1) = input_token_ptr; input_struc.operand.send_receive (1) = 0; /* sending */ input_struc.operand.size_sw (1) = 0; input_struc.operand.token_ptr (2) = wkbuff2_ptr; input_struc.operand.send_receive (2) = 1; /* receiving */ input_struc.operand.size_sw (2) = 0; /* Call the addressability utility. */ 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 and two descriptors. */ call cobol_emit (inst_ptr, reloc_ptr, 3); /* Get the basic address of the WORD containing the first byte of the index occurrence number */ input_struc_basic.type = 1; /* basic, non-eis */ input_struc_basic.operand_no = 0; input_struc_basic.segno = wkbuff2_ptr -> data_name.seg_num; input_struc_basic.char_offset = wkbuff2_ptr -> data_name.offset + 4; call cobol_addr (input_ptr, inst_ptr, reloc_ptr); /* Get the A and Q registers. */ register_struc.what_reg = 3; /* Get the A and Q registers, please. */ register_struc.lock = 0; /* No change to locks. */ register_struc.contains = 0; /* Contents of A and Q are not meaningful for register optimization . ( because they will be shifted once they are in the A-Q) */ call cobol_register$load (addr (register_struc)); /* Build ldq instruction referencing the address of the WORD containing the first byte of the index occurrence number */ inst_struc_basic.fill1_op = ldq_op; /* Emit the ldaq instruction */ call cobol_emit (inst_ptr, reloc_ptr, 1); /* At this point, code has been generated to get the two bytes containing the index data item occurrence number into the two most significant bytes of the Q- register. */ /* Build an instruction to load zero into the A register. */ inst_buff (1) = 0; inst_struc_basic.fill1_op = lda_op; inst_struc_basic.tm = "00"b; /* ir modivication */ inst_struc_basic.td = "0011"b; /* DU */ /* Set relocation bytes */ reloc_buff (1) = 0; reloc_buff (2) = 0; /* Emit the lda 0,du instruction */ call cobol_emit (inst_ptr, reloc_ptr, 1); /* Build a LLS instruction to get rid of the junk bit in the middle of the two 8 bit pieces of meaningful data */ inst_buff (1) = 0; inst_struc_basic.fill1_op = lls_op; inst_struc_basic.wd_offset = bit (binary (10, 15)); /* Insert the shift value into the instruction */ /* Set relocation bytes */ reloc_buff (1) = 0; reloc_buff (2) = 0; /* Emit the lls instruction */ call cobol_emit (inst_ptr, reloc_ptr, 1); /* Build ars instruction */ inst_buff (1) = 0; inst_struc_basic.fill1_op = ars_op; inst_struc_basic.wd_offset = bit (binary (1, 15)); /* Emit the ars instruction */ call cobol_emit (inst_ptr, reloc_ptr, 1); /* Build the lrs instruction */ inst_buff (1) = 0; inst_struc_basic.fill1_op = lrs_op; inst_struc_basic.wd_offset = bit (binary (28, 15)); /* Emit the lrs instruction */ call cobol_emit (inst_ptr, reloc_ptr, 1); /* Get the basic address of the temporary in the stack which is to receive the occurrence number */ input_struc_basic.type = 1; input_struc_basic.operand_no = 0; input_struc_basic.segno = data_name.seg_num; input_struc_basic.char_offset = data_name.offset; call cobol_addr (input_ptr, inst_ptr, reloc_ptr); /* Emit the stq instruction */ inst_struc_basic.fill1_op = stq_op; call cobol_emit (inst_ptr, reloc_ptr, 1); /* Set wkbuff1_ptr to point to the token for the temporary in the stack */ wkbuff1_ptr = dn_ptr; /* Release the A and Q registers. */ call cobol_register$release (addr (register_struc)); end; /* Input token is data name (type 9) with usage index bit set */ else do; /* an index name token (type 10) */ data_name.type = rtc_dataname; ind_ptr = input_token_ptr; data_name.seg_num = index_name.seg_num; /* set segment number of index name item */ data_name.offset = index_name.offset + 4; /* set offset from index name item */ end; /* an index name token (type 10) */ /* Complete the data name token in the work buffer */ data_name.item_length = 4; data_name.places_left = 4; data_name.places_right = 0; /* Zero the description bits in the data name token being built */ descrip_ptr = addr (data_name.file_section); descrip = "0"b; /* Set description bits */ data_name.display = "1"b; data_name.numeric = "1"b; data_name.elementary = "1"b; if return_decimal_value then do; /* convert the fixed binary occurrence value to decimal */ /* Allocate space on the stack to receive the decimal representation of the binary index value */ call cobol_alloc$stack (5, 0, t_offset);/* 5 bytes will hold maximum value that can be held in two bytes of fixed binary information */ /* Save the pointer to the token that describes the fixed binary occurrence number */ wkbuff1_ptr = dn_ptr; /* Build a data name token for the stack temporary just allocated */ dn_ptr = output_token_ptr; data_name.size = 116; /* 12/24/75 bc */ data_name.type = rtc_dataname; data_name.item_length = 5; data_name.places_left = 5; data_name.places_right = 0; data_name.seg_num = 1000; /* stack */ data_name.offset = t_offset; /* offset just returned by alloc$stack */ descrip_ptr = addr (data_name.file_section); descrip = "0"b; data_name.numeric = "1"b; data_name.elementary = "1"b; data_name.display = "1"b; /* Build the input 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) = wkbuff1_ptr; input_struc.operand.send_receive (1) = 0; /* sending */ input_struc.operand.size_sw (1) = 0; input_struc.token_ptr (2) = output_token_ptr; /* token for decimal representation to which the fixed binary is converted */ 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 binary to decimal op code into the opcode field of the instruction */ inst_struc.inst.fill1_op = btd_op; desc_nn_ptr = addr (inst_buff (2)); /* Zero the MBZ bits in the first descriptor */ desc_nn.desc_f.tn (1) = "0"b; /* type code bit */ desc_nn.sign_type (1) = "0"b; /* sign type bits */ desc_nn.scal (1) = "0"b; /* scale factor */ /* Zero MBZ bits in the second descriptor */ desc_nn.scal (2) = "0"b; /* scale factor */ /* Emit the instruction and two descriptors */ call cobol_emit (inst_ptr, reloc_ptr, 3); end; /* cconvert the fixed binary occurrence value to decimal */ /**************************************************/ /* END OF EXECUTABLE STATEMENTS */ /* cobol_get_index_value */ /**************************************************/ /* INCLUDE FILES USED BY THIS PROCEDURE */ %include cobol_type9; %include cobol_type10; %include cobol_addr_tokens; %include cobol_record_types; /************************************************/ /* END OF OUTERMOST PROCEDURE */ /* cobol_get_index_value */ /**************************************************/ end cobol_get_index_value;  cobol_get_num_code.pl1 05/24/89 1041.5rew 05/24/89 0831.2 25623 /****^ *********************************************************** * * * 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_get_num_code.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /*{*/ /* format: style3 */ cobol_get_num_code: proc (token_ptr, token_typecode); /* This procedure maps a data name tokne for a numeric data item into a code, according to the following table: numeric data type | type code (returned) --------------------------------------------- unpacked decimal | 1 packed decimal | 2 short binary | 3 long binary | 4 overpunch decimal | 5 --------------------------------------------- */ /* DECLARATION OF THE PARAMETERS */ dcl token_ptr ptr; dcl token_typecode fixed bin; /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION token_ptr Pointer to the numeric data name token which is to be mapped into a type code.(input) token_typecode Variable in which the typecode is returned. (output) The output value is described above. */ /*}*/ /* DECLARATIONS OF INTERNAL VARIABLES */ dcl dn_ptr ptr; /* referenced in type9 include file, but not declared there!!! */ start: if token_ptr -> data_name.sign_separate | (token_ptr -> data_name.numeric & token_ptr -> data_name.display & token_ptr -> data_name.sign_type = "000"b /* not specified */ & token_ptr -> data_name.item_signed = "0"b) /* Probably an unsigned, pooled constant */ then token_typecode = 1; /* unpacked decimal */ else if token_ptr -> data_name.ascii_packed_dec then token_typecode = 2; else if token_ptr -> data_name.bin_18 then token_typecode = 3; else if token_ptr -> data_name.bin_36 then token_typecode = 4; else token_typecode = 5; /* MUST BE OVERPUNCH!! */ /* 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_type9; end cobol_get_num_code;  cobol_get_size.pl1 05/24/89 1041.5rew 05/24/89 0831.2 52488 /****^ *********************************************************** * * * 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_get_size.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /*{*/ /* format: style3 */ cobol_get_size: proc (dn_ptr, stoff, lineno); /* This procedure is used to generate the instructions which will load the A register with the item_length of a type 9 token. If the input stoff is not equal to 0, the A register is stored into the memory location pr6|stoff. */ dcl dn_ptr ptr; dcl stoff fixed bin; dcl lineno fixed bin; dcl 1 size_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 1 mpout static, 2 n init (4), 2 pt1 ptr, 2 pt2 ptr, 2 pt3 ptr, 2 pt4 ptr; dcl 1 type1 static, /* reserve word */ 2 size fixed bin init (28), 2 line fixed bin, /* line number */ 2 column fixed bin init (0), 2 type fixed bin init (1), 2 key fixed bin init (20), /* perform */ 2 bits bit (36) init ("1"b), 2 jump_index fixed bin init (0); dcl 1 type7 static, /* procedure definition */ 2 size fixed bin init (52), 2 line fixed bin init (0), 2 column fixed bin init (0), 2 type fixed bin init (7), 2 string_ptr ptr init (null ()), 2 prev_rec ptr init (null ()), 2 bits1 bit (4) init (""b), 2 section_name bit (1) init ("0"b), 2 declarative_proc bit (1) init ("0"b), 2 bits2 bit (3) init (""b), 2 priority char (2) init ("00"), 2 bits3 bit (9) init (""b), 2 section_num fixed bin init (0), 2 proc_num fixed bin init (0), 2 def_line fixed bin init (0), 2 name_size fixed bin init (0); dcl 1 type19 static, /* eos */ 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 (20), /* verb number */ 2 e fixed bin init (0), 2 h fixed bin init (0), 2 i fixed bin init (0), 2 j fixed bin init (0), 2 a bit (3) init ("111"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 instr (3) bit (36); dcl instr_ptr ptr; dcl input_ptr ptr static; dcl mpout_ptr ptr static; dcl ic fixed bin; dcl temp fixed bin; dcl firsttime bit (1) static init ("1"b); dcl omit_sign bit (1); dcl sta bit (12) static init ("111101101001"b); dcl lda_dlmod bit (18) static init ("010011101000000111"b); dcl ada_dlmod bit (18) static init ("000111101000000111"b); dcl full_lca_ bit (36) static init ("000000000000000000011011101000000000"b); dcl full_lda_ bit (36) static init ("000000000000000000010011101000000000"b); dcl cobol_perform_gen entry (ptr); dcl cobol_addr entry (ptr, ptr, ptr); dcl cobol_emit entry (ptr, ptr, fixed bin); /*}*/ /*************************************/ omit_sign = "0"b; go to start; omit_sign: entry (dn_ptr, stoff, lineno); omit_sign = "1"b; start: instr_ptr = addr (instr); ic = 2; if data_name.variable_length then do; if data_name.size_rtn = -1 then do; /* special - varying char string */ size_basic_struct.seg = data_name.seg_num; size_basic_struct.offset = data_name.offset - 4; /* word alignment assumed */ instr (1) = full_lda_; call cobol_addr (addr (size_basic_struct), instr_ptr, null ()); ic = 2; end; else do; if firsttime then do; mpout_ptr = addr (mpout); mpout.pt1 = addr (type1); mpout.pt2, mpout.pt3 = addr (type7); mpout.pt4 = addr (type19); input_ptr = addr (size_basic_struct); firsttime = "0"b; end; mpout.pt1 -> reserved_word.line = lineno; mpout.pt2 -> proc_def.proc_num = data_name.size_rtn; call cobol_perform_gen (mpout_ptr); size_basic_struct.seg = fixed_common.size_seg; size_basic_struct.offset = fixed_common.size_offset; instr (1) = full_lca_; call cobol_addr (input_ptr, instr_ptr, null ()); instr (2) = substr (unspec (data_name.item_length), 19, 18) || ada_dlmod; ic = 3; end; end; else do; temp = data_name.item_length; if omit_sign then if data_name.sign_separate then temp = temp - 1; /* may be changed for release 1.5 */ instr (1) = substr (unspec (temp), 19, 18) || lda_dlmod; end; if stoff = 0 then ic = ic - 1; /* don't store value in memory */ else instr (ic) = "110"b || substr (unspec (stoff), 22, 15) || sta; call cobol_emit (instr_ptr, null (), ic); 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_type7; %include cobol_type9; %include cobol_fixed_common; %include cobol_ext_; %include cobol_; end cobol_get_size;  cobol_go_gen.pl1 05/24/89 1041.5rew 05/24/89 0831.0 203166 /****^ *********************************************************** * * * 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_go_gen.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 01/14/77 by ORN to signal command_abort rather than cobol_compiler_error */ /* Modified since Version 2.0 */ /*{*/ /* format: style3 */ cobol_go_gen: proc (in_token_ptr); /* The procedure cobol_go_gen generates the code necessary to implement the COBOL GO statement and, in the case of alterable GO's, pro- duces the data structures from which initialization code may be subsequently generated. The format of the GO statement is: Format 1 - G_O_ TO [procedure-name-1] Format 2 - G_O_ TO procedure-name-1 [,procedure-name-2]..., procedure-name-n D_E_P_E_N_D_I_N_G_ ON identifier The implementation of a GO statement depends upon whether or not it is the object of an ALTER statement. A Format 1 GO statement with optional procedure-name-1 present may be modified by an ALTER statement; a Format 1 GO statement without optional proce- dure-name-1 present must be modified by an ALTER statement; and a Format 2 GO statement may not be modified by an ALTER statement. The determination of whether or not the GO statement being pro- cessed is the object of an ALTER statement is made by examining the variable cobol_$alter_flag. A value of 1 indicates that the GO statement is the object of an ALTER statement and a value of 0, that it is not. cobol_$alter_flag is set by cobol_paragraph_gen. The implementation of a GO statement which is not the object of an ALTER statement is also dependent upon whether or not the COBOL segment containing the procedure to which control is to be transferred must first be initialized. Segment initialization is not required if the procedure to which control is to be transfer- red is in the same COBOL segment as the GO statement being imple- mented, is in a fixed COBOL segment, or is in an independent COBOL segment which contains no alterable GO's. The term alter- able GO, as used here, refers to a GO statement that is the ob- ject of an ALTER statement. U__s_a_g_e:_ declare cobol_go_gen entry (ptr); call cobol_go_gen (in_token_ptr); */ %include cobol_in_token; /* G__e_n_e_r_a_t_e_d_C__o_d_e:_ Format 1 - The following code is generated for Format 1 GO statements which are alterable: lda target_a tra 0,al where: target_a is a 36-bit variable, allocated in COBOL data on a word boundary and uniquely associated with the alterable GO being implemented (see alter_list), which contains transfer address data. For information on the setting of target_a, see cobol_initgo_gen. If the optional procedure-name-1 is not present, the above two instructions are followed by an execution time call to cobol_ error_ generated by a compile time call to cobol_process_error. This call will be executed only in the event that the GO state- ment is executed prior to the execution of an ALTER statement re- ferring to this GO statement. This is accomplished by initializ- ing target_a such that control is passed to the first instruction of the call to cobol_error_. Target_a is otherwise initialized to pass control to the first instruction of procedure-name-1. See cobol_seginit_gen for details on initialization. If it is found that a Format 1 GO statement without the optional procedure-name-1 present is not the subject of an ALTER statement then a compile time warning to this effect is issued to the user via system subroutine signal_ and an execution time call to cobol_error_ is generated by a call to cobol_process_error to signal this error to the user at execution time and to prevent further execution of the program in the event that this GO statement is executed in the course of executing the program. In the case of non-alterable Format 1 GO statements, code se- quence 1, below, is used if no segment initialization is required and sequence 2, if segment initialization is requierd. Sequence 1 tra pn_relp,ic Sequence 2 eaa pn_relp,ic tra s_init_relp,ic where: pn_relp is the offset, relative to the instruction in which it appears, of the first instruction of the procedure to the transfer is being made. s_init_relp is the offset, relative to the instruction in which it appears, of the first instruction of the code se- quence provided to initialize the alterable GO's in the segment containing the procedure to which the transfer is being made. Format 2 - The code generated to implement Format 2 GO statements is as follows: stz ident_bin dtb (pr),(pr) ndsc9 ident ndsc9 ident_bin lda 1,du ldq nt,du dwl ident_bin tnz nt+2mt+3,ic eax2 ident_bin,*ic tra 1,2 tra relp1,ic tra relp2,ic . . . . . . . . . tra relpn,ic eaa pn1_relp,ic tra s(pn1)_init_relp,ic eaa pn2_relp,ic tra s(pn2)_init_relp,ic . . . . . . . . . . . . . . . eaa pnm_relp,ic tra s(pnm)_init_relp,ic where: ident_bin is a fixed bin quantity allocated in the stack. Its function is to contain the binary represen- tation of the value of ident times 2**18. ident is the operand of the DEPENDING ON phrase of the Format 2 GO statement. It is allocated in COBOL data. nt is the number of procedure names given as oper- ands of the Format 2 GO statement. mt is the number of procedure names given as oper- ands of the Format 2 GO statement which are con- tained in segments that must be initialized be- fore the required transfer of control is made. mt is less than or equal to nt. relpn for n = 1, 2, 3, ... nt is a constant whose value is either: 1) The offset, relative to the instruction in which relpn appears, of the first instruction of procedure pnn (procedure-name-n), if the segment containing procedure pnn does not have to be initialized before control is transferred to the procedure. 2) nt-n+2m-1 for n = 1, 2, 3, ... nt and m = 1, 2, 3, ...mt if the segment containing proce- dure pnn requires initialization before con- trol is transferred to the procedure. pnm_relp for m = 1, 2, 3, ... mt is the offset, relative to the instruction in which pnm_relp appears, of the first instruction of procedure pnm where procedure pnm is in a segment requiring initial- ization before control is transferred to it. s(pnm)_init_relp for m = 1, 2, 3, ... mt is the offset, relative to the instruction in which s(pnm)_init_relp ap- pears, of the first instruction of the sequence provided to initialize the segment containing procedure pnn. 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 procedure cobol_go_gen (as opposed to being generated by a utility called by cobol_go_gen) are non-relocatable. */ /* D__a_t_a:_ % include cobol_; Items in cobol_ include file1 used (u) and/or set(s) by cobol_go_gen: cobol_ptr (u) alter_flag (u) alter_index (u/s) alter_list_ptr (u) next_tag (u/s) text_wd_off (u) priority_no (u) seg_init_list_ptr (u) */ %include cobol_alter_list; %include cobol_seg_init_list; %include cobol_type9; dcl dn_ptr ptr; %include cobol_type18; %include cobol_type19; /* Input structure for cobol_register$load */ declare 1 register_request aligned static, 2 requested_reg fixed bin aligned, 2 assigned_reg bit (4) aligned, 2 lock fixed bin aligned init (0), 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; 0 requests that no change be made in register status. 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 PLI 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 structures 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. */ declare 1 input_struc aligned static, 2 type fixed bin aligned init (4), 2 operand_no fixed bin aligned init (1), 2 lock fixed bin aligned init (0), 2 operand, 3 token_ptr ptr aligned init (null), 3 send_receive fixed bin aligned init (0), 3 ic_mod fixed bin aligned, 3 size_sw fixed bin aligned init (0); /* type indicates type of addressing requested. 1 - no operand, 1 wd, basic 2 - 1 operand, 1 wd, non-EIS 3 - 1 operand, 1 wd, EIS 4 - 1 operand, 1 desc, 2wd, EIS 5 - 2 operands, 2 desc, 3 wd, EIS 6 - 3 operands, 3 desc, 4 wd, EIS operand_no number of operands associated with requested type. lock indicates lock requirements for registers used in addressing. 0 - do not lock registers used 1 - lock registers used 2 - unlock all registers token_ptr is a pointer to the operand token. send_receive indicates whether the operand being addressed is a sending or receiving field for the instruction. 0 - sending operand 1 - receiving operand ic_mod indicates whether ic modification is specified in the mf field of this operand (set by cobol_addr). 0 - no ic modification 1 - ic modification size_sw indicates size (length) handlhlng requirements to cobol_addr. 0 - cobol_addr may store the operand size in a register or in the instruction 1 - cobol_addr need not be concerned with size */ /* Error message structure. */ declare 1 error_info static aligned, 2 name char (32) aligned init ("cobol_go_gen"), 2 message_len fixed bin aligned, 2 message char (168) aligned; dcl 1 comp7_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 fb2 (2) fixed bin init (6, 0), 3 flags1 bit (36) init ("000000100100010001000000010000000000"b), 3 flags2 bit (36) init (""b), 3 seg fixed bin init (1000), 3 off fixed bin init (160), 2 fill2 (7) fixed bin init (0, 0, 0, 0, 0, 0, 0); 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 (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 seq_f1_a (4) bit (18) unaligned static init ("000000000000000000"b, "010011101001001101"b, /* lda target_a */ "000000000000000000"b, "111001000000000101"b); /* tra 0,al */ dcl seq_f1_b (2) bit (18) unaligned static init ("000000000000000000"b, "111001000000000100"b); /* tra 0,ic */ dcl seq_f1_c (4) bit (18) unaligned static init ("000000000000000000"b, "110011101000000100"b, /* eaa pn_relp,ic */ "000000000000000000"b, "111001000000000100"b); /* tra s_init_relp,ic */ dcl seq_f2_1 (14) bit (18) unaligned static init ("110000000000101000"b, "100101000001000000"b, /* stz pr6|40 */ "000000000000000001"b, "010011101000000011"b, /* lda 1,du */ "000000000000000000"b, "010011110000000011"b, /* ldq nt,du */ "110000000000101000"b, "001001001001000000"b, /* cwl pr6|40 */ "000000000000000000"b, "110000001000000100"b, /* tnz nt+2mt+3,ic */ "110000000000101000"b, "110010010001110100"b, /* eax2 pr6|40,*ic */ "000000000000000001"b, "111001000000001010"b); /* tra 1,2 */ dcl trans (768) bit (36); /* Automatic data */ declare s_text_wd fixed bin, /* Saved value of cobol_$text_wd_off. */ temp fixed bin, /* Temporary used in unspec function. */ init_req_flag fixed bin, /* 1 if seg initialization is not */ /* required; 2 if it is. */ pnn_priority fixed bin, /* COBOL seg no of seg containing */ /* procedure-name-n. */ cnt_pri fixed bin, /* Priority of current procedure. */ init_tag fixed bin, /* Tag associated with 1st inst. of */ /* code generated to initialize alter-*/ /* able GO's in COBOL seg containing */ /* procedure-name-n. */ pnn_num fixed bin, /* Procedure no (tag) of procedure- */ /* name-n. */ index fixed bin, /* Do loop index. */ jndex fixed bin, /* Do loop index. */ init_ptr ptr, /* Ptr to location in seg_init_list */ /* where initialization data is to be */ /* placed. */ nt fixed bin, /* Number of procedure names given as */ /* operands in Format 2 GO statement. */ sum fixed bin; /* nt+2m where m is the current count */ /* of procedure names given as oper- */ /* ands in a Format 2 GO statement */ /* that are in segments requiring */ /* initialization. */ /* Based structure used in placing initialization data in */ /* 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 pn1 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_nc entry (fixed bin, fixed bin), cobol_emit entry (ptr, ptr, fixed bin), cobol_make_tagref entry (fixed bin, fixed bin, ptr), cobol_process_error entry (fixed bin, fixed bin, fixed bin), cobol_move_gen entry (ptr), cobol_register$load entry (ptr), ioa_$rsnnl entry options (variable), 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, substr builtin, unspec builtin; /*}*/ %include cobol_; /*************************************/ start: if in_token.token_ptr (in_token.n) -> end_stmt.a = "000"b then go to format1; else go to format2; /*************************************/ format1: proc_ref_ptr = in_token.token_ptr (in_token.n - 1); pnn_num = proc_ref.proc_num; pnn_priority = binary (unspec (proc_ref.priority), 17); if cobol_$alter_flag = 0 then /* GO statement is not object of ALTER statement. */ do; if pnn_num = 0 then /* Program is in erroor. */ do; /* This statement must be revised when two part line */ /* becomes available. */ call ioa_$rsnnl ("Line no. ^d: GO TO ?", error_info.message, error_info.message_len, in_token.token_ptr (1) -> proc_ref.line); call signal_ ("command_error", null, addr (error_info)); s_text_wd = cobol_$text_wd_off; call cobol_process_error (20, in_token.token_ptr (1) -> proc_ref.line, 0); temp = s_text_wd - cobol_$text_wd_off; seq_f1_b (1) = substr (unspec (temp), 19, 18); call cobol_emit (addr (seq_f1_b), null, 1); end; else do; if cobol_$seg_init_list_ptr = null then init_req_flag = 1; else call is_init_req; if init_req_flag = 1 then call cobol_emit (addr (seq_f1_b), null, 1); else do; register_request.requested_reg = 1; call cobol_register$load (addr (register_request)); call cobol_emit (addr (seq_f1_c), null, 2); call cobol_make_tagref (init_tag, cobol_$text_wd_off - 1, null); end; call cobol_make_tagref (pnn_num, cobol_$text_wd_off - init_req_flag, null); end; end; else /* GO statement is object of ALTER statement. */ do; s_text_wd = cobol_$text_wd_off; target.segno = alter_list.goto.target_a_segno (cobol_$alter_index); target.char_offset = alter_list.goto.target_a_offset (cobol_$alter_index); cobol_$alter_index = cobol_$alter_index + 1; call cobol_addr (addr (target), addr (seq_f1_a), null); register_request.requested_reg = 1; call cobol_register$load (addr (register_request)); call cobol_emit (addr (seq_f1_a), null, 2); /* Store initialization data. */ cnt_pri = cobol_$priority_no; if cnt_pri < 50 then cnt_pri = 0; do jndex = 1 to seg_init_list.n; if seg_init_list.seg.priority (jndex) = cnt_pri then do; init_ptr = addrel (seg_init_list.seg.init_ptr (jndex), 3 * seg_init_list.seg.next_init_no (jndex)); seg_init_list.seg.next_init_no (jndex) = seg_init_list.seg.next_init_no (jndex) + 1; init_data.target_a_segno = target.segno; init_data.target_a_offset = target.char_offset; init_data.pn1 = pnn_num; call is_init_req; if init_req_flag = 1 then init_data.init = 0; else init_data.init = init_tag; goto next_step; end; end; next_step: if pnn_num = 0 then do; init_data.pn1 = cobol_$next_tag; call cobol_define_tag_nc (cobol_$next_tag, cobol_$text_wd_off); cobol_$next_tag = cobol_$next_tag + 1; call cobol_process_error (20, in_token.token_ptr (1) -> proc_ref.line, 0); temp = s_text_wd - cobol_$text_wd_off; seq_f1_b (1) = substr (unspec (temp), 19, 18); call cobol_emit (addr (seq_f1_b), null, 1); end; end; return; /*************************************/ format2: nt = in_token.token_ptr (in_token.n) -> end_stmt.e; sum = nt; call cobol_emit (addr (seq_f2_1 (1)), null, 1); mpout.pt1 = null (); mpout.pt2 = in_token.token_ptr (nt + 2); comp7_type9.flags1 = "000000100100010001000000010000000000"b; mpout.pt3 = addr (comp7_type9); mpout.pt4 = addr (type19); call cobol_move_gen (addr (mpout)); seq_f2_1 (5) = substr (unspec (nt), 19, 18); if cobol_$seg_init_list_ptr = null then do jndex = 1 to nt; trans (jndex) = "000000000000000000111001000000000100"b; pnn_num = in_token.token_ptr (in_token.n + jndex - nt - 2) -> proc_ref.proc_num; call cobol_make_tagref (pnn_num, cobol_$text_wd_off + jndex + 5, addr (trans (jndex))); end; else do jndex = 1 to nt; trans (jndex) = "000000000000000000111001000000000100"b; proc_ref_ptr = in_token.token_ptr (in_token.n + jndex - nt - 2); pnn_num = proc_ref.proc_num; pnn_priority = binary (unspec (proc_ref.priority), 17); call is_init_req; if init_req_flag = 1 then call cobol_make_tagref (pnn_num, cobol_$text_wd_off + jndex + 5, addr (trans (jndex))); else do; sum = sum + 1; temp = sum - jndex; substr (trans (jndex), 1, 18) = substr (unspec (temp), 19, 18); trans (sum) = "000000000000000000110011101000000100"b; call cobol_make_tagref (pnn_num, cobol_$text_wd_off + sum + 5, addr (trans (sum))); sum = sum + 1; trans (sum) = "000000000000000000111001000000000100"b; call cobol_make_tagref (init_tag, cobol_$text_wd_off + sum + 5, addr (trans (sum))); end; end; temp = sum + 3; seq_f2_1 (9) = substr (unspec (temp), 19, 18); register_request.requested_reg = 1; call cobol_register$load (addr (register_request)); register_request.requested_reg = 12; call cobol_register$load (addr (register_request)); call cobol_emit (addr (seq_f2_1 (3)), null, 6); call cobol_emit (addr (trans), null, sum); return; is_init_req: proc; if cobol_$priority_no ^= pnn_priority then if pnn_priority > 49 then do index = 1 to seg_init_list.n; if seg_init_list.seg.priority (index) = pnn_priority then do; init_req_flag = 2; init_tag = seg_init_list.seg.int_tag_no (index); goto finis; end; end; init_req_flag = 1; finis: return; end is_init_req; end cobol_go_gen;  cobol_init_.pl1 05/24/89 1041.5rew 05/24/89 0830.9 63162 /****^ *********************************************************** * * * 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_init_.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 04/27/78 by FCH, [3.0-1], symbol section(source module path name) */ /* Modified since Version 3.0. */ /* format: style3 */ cobol_init_: proc (fpath, rtbuff_ptr); dcl fpath char (168), tpath char (168) aligned; /*[3.0-1] */ dcl rtbuff_ptr ptr; /* for use by replacement */ dcl segname char (32); dcl path char (168); dcl segptr ptr; dcl mcode fixed bin (35); dcl evar entry auto; dcl bptr ptr based (addr (evar)); dcl cobol_def_init entry; dcl cobol_link_init entry; dcl cobol_sym_init entry (char (168) aligned); /* [3.0-1] */ dcl com_err_ entry options (variable); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl hcs_$make_ptr entry (ptr, char (*), char (*), ptr, fixed bin (35)); dcl hcs_$initiate entry (char (*) aligned, char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$truncate_seg entry (ptr, fixed bin, fixed bin (35)); /*************************************/ start: evar = cobol_init_; cobol_$scratch_dir = fpath; segname = "cobol_seg1_"; call hcs_$make_seg (fpath, segname, "", 01011b, segptr, mcode); if segptr = null () then go to merror1; if mcode ^= 0 then do; call hcs_$truncate_seg (segptr, 0, mcode); if mcode ^= 0 then go to merror1; end; cobol_$misc_base_ptr, cobol_$misc_end_ptr = segptr; cobol_$misc_max = 32767; cobol_$pd_map_ptr = pointer (segptr, 32768); cobol_$pd_map_max = 32767; cobol_$pd_map_index = 0; cobol_$map_data_ptr = pointer (segptr, 65536); cobol_$map_data_max = 32767; cobol_$tag_table_ptr = pointer (segptr, 98304); cobol_$tag_table_max = 32767; cobol_$fixup_ptr = pointer (segptr, 131072); cobol_$fixup_max = 32767; cobol_$token_block1_ptr = pointer (segptr, 172032); cobol_$token_block2_ptr = pointer (segptr, 173056); cobol_$include_info_ptr = pointer (segptr, 174080); cobol_$allo1_max = 86000; cobol_$allo1_ptr = pointer (segptr, 176080); segname = "cobol_seg2_"; call hcs_$make_seg (fpath, segname, "", 01011b, segptr, mcode); if segptr = null () then go to merror1; if mcode ^= 0 then do; call hcs_$truncate_seg (segptr, 0, mcode); if mcode ^= 0 then go to merror1; end; cobol_$text_base_ptr = segptr; cobol_$text_wd_off = 0; cobol_$con_end_ptr = pointer (segptr, 131071); cobol_$con_wd_off = 1; cobol_$link_base_ptr = pointer (segptr, 131072); cobol_$link_max = 12287; cobol_$link_wd_off = 0; cobol_$def_base_ptr = pointer (segptr, 155648); cobol_$def_max = 32767; cobol_$def_wd_off = 0; cobol_$reloc_text_base_ptr = pointer (segptr, 188416); cobol_$reloc_text_max = 147429; cobol_$reloc_def_base_ptr = pointer (segptr, 192512); cobol_$reloc_def_max = 73692; cobol_$reloc_link_base_ptr = pointer (segptr, 194560); cobol_$reloc_link_max = 147429; cobol_$reloc_sym_base_ptr = pointer (segptr, 198656); cobol_$reloc_sym_max = 147429; cobol_$reloc_work_base_ptr = pointer (segptr, 202752); cobol_$reloc_work_max = 221148; cobol_$sym_base_ptr = pointer (segptr, 208896); cobol_$sym_max = 65535; cobol_$sym_wd_off = 0; cobol_$perform_list_ptr, cobol_$alter_list_ptr, cobol_$seg_init_list_ptr, cobol_$temp_token_area_ptr, cobol_$temp_token_ptr, cobol_$ptr_status_ptr, cobol_$reg_status_ptr = null (); segname = "cobol_seg3_"; call hcs_$make_seg (fpath, segname, "", 01011b, segptr, mcode); if segptr = null () then go to merror1; if mcode ^= 0 then do; call hcs_$truncate_seg (segptr, 0, mcode); if mcode ^= 0 then go to merror1; end; cobol_$eln_ptr = pointer (segptr, 0); cobol_$eln_max = 65535; cobol_$statement_info_ptr = pointer (segptr, 65536); cobol_$xref_token_ptr = pointer (segptr, 131072); cobol_$xref_chain_ptr = pointer (segptr, 196608); segname = "cobol_ntbuff_"; call hcs_$make_seg (fpath, segname, "", 01011b, segptr, mcode); if segptr = null () then go to merror1; if mcode ^= 0 then do; call hcs_$truncate_seg (segptr, 0, mcode); if mcode ^= 0 then go to merror1; end; rtbuff_ptr = segptr; cobol_$ntbuf_ptr = segptr; cobol_$cobol_data_wd_off, cobol_$debug_enable, cobol_$data_init_flag, cobol_$include_cnt, cobol_$fs_charcnt, cobol_$ws_charcnt, cobol_$coms_charcnt, cobol_$ls_charcnt, cobol_$cons_charcnt, cobol_$value_cnt, cobol_$cd_cnt, cobol_$fs_wdoff, cobol_$ws_wdoff, cobol_$coms_wdoff = 0; cobol_$same_sort_merge_proc = "0"b; segname = "cobol_diag_table_"; call hcs_$make_ptr (bptr, segname, segname, cobol_$diag_ptr, mcode); if cobol_$diag_ptr = null () then go to merror3; segname = "cobol_reswd_table_"; call hcs_$make_ptr (bptr, segname, segname, cobol_$reswd_ptr, mcode); if cobol_$reswd_ptr = null () then go to merror3; segname = "cobol_operators_"; call hcs_$make_ptr (bptr, segname, segname, cobol_$op_con_ptr, mcode); if cobol_$op_con_ptr = null () then go to merror3; cobol_$op_con_ptr = addrel (cobol_$op_con_ptr, 2048); return; /*************************************/ segs: entry (code, tpath); /* [3.0-1] */ dcl code fixed bin (35); start_segs: call cobol_def_init; call cobol_link_init; call cobol_sym_init (tpath); /* [3.0-1] */ cobol_$initval_flag = 0; segname = "cobol_initval_"; call hcs_$initiate (cobol_$scratch_dir, segname, "", 0b, 00b, cobol_$initval_base_ptr, mcode); if cobol_$initval_base_ptr = null () then go to merror2; code = 0; return; /*************************************/ merror1: path = fpath; rtbuff_ptr = null (); /* signal to driver */ go to merror; merror2: path = cobol_$scratch_dir; code = mcode; /* signal to driver */ merror: call com_err_ (mcode, "cobol", " ^a>^a", path, segname); return; merror3: rtbuff_ptr = null (); call com_err_ (mcode, "cobol", " ^a$^a", segname, segname); 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_init_;  cobol_inspect_gen.pl1 05/24/89 1041.5rew 05/24/89 0830.0 367479 /****^ *********************************************************** * * * 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_inspect_gen.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 02/13/81 by FCH, cobol_add_gen called with wrong arg count, [4.4-1], BUG463(TR9151) */ /* Modified on 10/10/77 by Bob Chnag to fix the table of substitution. */ /* Modified on 10/06/77 by Bob Chang to fix the bug for replacing optimatization. */ /* Modified on 06/06/77 by Bob Chang to implement further optimization. */ /* Modified on 04/21/77 by Bob Chang to implement optimization for simple cases. */ /* Modified on 03/31/77 by Bob Chang to fix the bug for overpunch data. */ /* Modified on 03/24/77 by ORN to allocate enough stack for tally and replace structures */ /* Modified since Version 2.0 */ /* format: style3 */ cobol_inspect_gen: proc (mp_ptr); dcl mp_ptr ptr; dcl 1 mp based (mp_ptr), 2 n fixed bin, 2 pt (0 refer (mp.n)) ptr; dcl 1 args, 2 entryno fixed bin, 2 arglist_off fixed bin, 2 stacktemp_off fixed bin, 2 n fixed bin, 2 arg (3), 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 1 name_arg static, 2 pt ptr init (null ()), /* set each time to pt to varying char string containing name of program to be called */ 2 type fixed bin init (6), 2 zeros bit (108) init (""b); dcl 1 ptr_arg static, 2 pt ptr init (null ()), /* always null */ 2 type fixed bin init (3), 2 off1 fixed bin init (50), 2 zeros bit (72) init (""b); dcl 1 tally_arg static, 2 pt ptr init (null ()), /* always null */ 2 type fixed bin init (3), 2 off1 fixed bin, /* set each time to allocated stack location */ 2 zeros bit (72) init (""b); dcl epp2_instr bit (36) static init ("110000000000000000011101010001000000"b); /* epp2 pr6|- */ dcl spri2_instr bit (36) static init ("110000000000000000010101010001000000"b); /* spri2 pr6|- */ dcl 1 pr2_struct static, 2 pr fixed bin init (2), 2 pointer_no bit (3), 2 lock fixed bin init (0), 2 switch fixed bin init (0), 2 segno fixed bin, 2 offset fixed bin, 2 reset fixed bin; dcl 1 pr1_struct static, 2 pr fixed bin init (1), 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 init (1), /* A */ 2 reg_no bit (4), 2 lock fixed bin init (0), 2 already_there fixed bin, 2 contains fixed bin init (0), 2 pointer ptr init (null ()), 2 literal bit (36) init (""b); dcl 1 reg1_struct static, 2 what_reg fixed bin init (11), /* x1 */ 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 1 mpout static, 2 n fixed bin init (4), 2 pt1 ptr, 2 pt2 ptr, 2 pt3 ptr, 2 pt4 ptr; 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 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 (1000), 3 off fixed bin, 2 fill2 (7) fixed bin init (0, 0, 0, 0, 0, 0, 0); dcl 1 type2_static static, 2 header (4) fixed bin init (40, 0, 0, 2), 2 flags bit (9) init ("000000000"b), 2 signs char (2) init (" "), 2 places (4) fixed bin init (0, 1, 0, 1), 2 lits char (1) init ("1"); dcl 1 type3, 2 alignment ptr, /* so as to double word align the space */ 2 rest char (26); dcl alpha_char char (112) based (addr (alpha_type9)); dcl type9 char (112); dcl 1 addpout static, 2 n fixed bin init (4), 2 pt1 ptr, 2 pt2 ptr, 2 pt3 ptr, 2 pt4 ptr; dcl 1 type19_add static, 2 header (4) fixed bin init (38, 0, 0, 19), 2 verb fixed bin init (2), 2 e fixed bin init (1), 2 h fixed bin init (1), 2 ij (2) fixed bin init (0, 0), 2 abcdfgk bit (16) init ("0000000000000000"b); dcl 1 fb35_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 (4), 3 places_left fixed bin init (4), 3 places_right fixed bin init (0), 3 flags1 bit (36) init ("000000100100001001000000000000000000"b), 3 flags2 bit (36) init (""b), 3 seg fixed bin init (1000), 3 off fixed bin, 2 fill2 (7) fixed bin init (0, 0, 0, 0, 0, 0, 0); dcl lead_inst (4) bit (18) static init ("110000000000000000"b, "010011100001000000"b, /* szn pr6 cnt_off */ "000000000000000000"b, "110000001000000100"b); /* tnz exit_tag */ dcl lxl3_inst (6) bit (18) static init ("110000000000000000"b, "111010011001000000"b, /* lxl3 pr6|cnt_off */ "000000000000000001"b, "000110011000000011"b, /* adx3 1,du */ "110000000000000000"b, "111100011001000000"b); /* stx3 pr6|temp_off */ dcl cmpx_inst (10) bit (18) static init ("110000000000000000"b, "001000001001000000"b, /* cmpx1 pr6|temp_off */ "000000000000000000"b, "110000100100000100"b, /* tmoz exit_tag,ic */ "110000000000000000"b, "001110001001000000"b, /* sbx1 pr6|temp_off */ "110000000000000000"b, "000110010001000000"b, /* sbx2 pr6|temp_of */ "000000000000000000"b, "111001000000000100"b); /* tra scan_tag,ic */ dcl (scan_tag, exit_tag, length_off, cnt_off) fixed bin; dcl ttn bit (36) static init ("000000000000000000110000110100000100"b); /* ttn exit,ic */ dcl scm (8) bit (18) static init ("000000000000000000"b, "001010100101101010"b, /* scm (pr,x2,rl),() */ "001000000000000000"b, "000000000000001001"b, /* pr1|0,x1 */ "000000000000000000"b, "000000000000000000"b, /* sacn chars or offset */ "110000000000000000"b, "000000000001000000"b); /* pr6|tally_count_off */ dcl scd (8) bit (18) static init ("000000000000000000"b, "001010000101101010"b, /* scd (pr,x2,rl),() */ "001000000000000000"b, "000000000000001001"b, /* pr1|0,x1 */ "000000000000000000"b, "000000000000000000"b, /* sacn chars or offset */ "110000000000000000"b, "000000000001000000"b); /* pr6|tally_count_off */ dcl lxl_inst (4) bit (18) static init ("110000000000000000"b, "111010001001000000"b, /* lxl1 pr6|length_off */ "000000000000000000"b, "010010010000000011"b); /* ldx2 0,du */ dcl lda_inst (8) bit (18) static init ("110000000000000000"b, "010011101001000000"b, /* lda pr6|length_off */ "000000000000000000"b, "001111101000000111"b, /* sba item_len,dl */ "110000000000000000"b, "001111101001000000"b, /* sba pr6|cnt_off */ "110000000000000000"b, "111101101001000000"b); /* sta pr6|cnt_off */ dcl lca_inst (8) bit (18) static init ("110000000000000000"b, "011011101001000000"b, /* lca pr6|cnt_off */ "000000000000000000"b, "001111101000000111"b, /* sba item_len`sght,dl */ "001000000000000000"b, "101010000101000101"b, /* s9bd pr1|0,al */ "110000000000000000"b, "000101101001000000"b); /* asa pr6|length_off */ dcl before_option fixed bin, after_flag bit (1); dcl (data_len, full_len, prev_scan) fixed bin; dcl ptr_off fixed bin static init (50); dcl all_key fixed bin static init (73); dcl characters_key fixed bin static init (83); dcl leading_key fixed bin static init (122); dcl before_key fixed bin static init (80); dcl after_key fixed bin static init (72); dcl first_key fixed bin static init (109); dcl replacing_key fixed bin static init (152); dcl mvt_table char (128); dcl mvt_table_static char (128) static init ("  !""#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~"); dcl mvt (4) bit (36); dcl mrl (3) bit (36); dcl mlr (3) bit (36); dcl mlr_tab (3) bit (36) static init ("000000000001000000001000000100000100"b, "000000000000000000000000000010000000"b, "110000000000000000000000000010000000"b); dcl ldx1_inst bit (36) static init ("000000000000000000010010001000000011"b); dcl lxl1_inst bit (36) static init ("110000000000000000111010001001000000"b); dcl argb (3) bit (216) based (addr (args.arg (1))); dcl code bit (18) aligned; dcl save_code bit (18) aligned; dcl found bit (1); dcl done bit (1); dcl char1 char (1); dcl char1_bit bit (9) based (addr (char1)); dcl char1_index fixed bin; dcl rn_opt bit (1); dcl tn_opt bit (1); dcl stack_flag fixed bin; dcl opch_flag fixed bin; dcl con_flag fixed bin; dcl conoff fixed bin; dcl i fixed bin; dcl tn fixed bin; dcl rn fixed bin; dcl j fixed bin; dcl tind fixed bin; dcl toutoff fixed bin; dcl temp fixed bin; dcl stoff fixed bin; dcl aloff fixed bin; dcl dn_ptr ptr; dcl input_area char (24); dcl reloc_area char (10); dcl pr2_struct_ptr ptr; dcl arg_ptr ptr; dcl ttp (512) ptr; dcl cobol_alloc$stack entry (fixed bin, fixed bin, fixed bin); dcl cobol_pointer_register$priority entry (fixed bin, fixed bin, bit (3)); dcl cobol_make_tagref entry (fixed bin, fixed bin, ptr); dcl cobol_define_tag_nc entry (fixed bin, fixed bin); /*[4.4-1]*/ dcl cobol_add_gen entry (ptr, fixed bin); dcl cobol_emit entry (ptr, ptr, fixed bin); dcl cobol_get_size$omit_sign entry (ptr, fixed bin, fixed bin); dcl cobol_move_gen entry (ptr); dcl cobol_set_pr$omit_sign entry (ptr, ptr); dcl cobol_addr entry (ptr, ptr, ptr); dcl cobol_pool entry (char (*), fixed bin, fixed bin); dcl cobol_register$release entry (ptr); dcl cobol_make_type3$type1 entry (ptr, ptr); dcl cobol_call_op entry (fixed bin, fixed bin); dcl cobol_make_type9$type2_3 entry (ptr, ptr); dcl cobol_io_util$bin_to_t9dec entry (bit (3) aligned, fixed bin, ptr); dcl cobol_io_util$t9dec_to_bin entry (bit (3) aligned, fixed bin, ptr); dcl cobol_io_util$move_direct entry (bit (3), fixed bin, fixed bin, fixed bin, bit (18) aligned); dcl cobol_reset_r$in_line entry; dcl cobol_register$load entry (ptr); /*************************************/ start: call cobol_register$load (addr (reg_struct)); arg_ptr = addr (args); pr2_struct_ptr = addr (pr2_struct); mpout.pt1 = mp.pt (1); mpout.pt4 = addr (type19_move); call cobol_alloc$stack (16, 2, stoff); eos_ptr = mp.pt (mp.n); i = 4; if end_stmt.a = "000"b then /* Format 1 */ call tally; else if end_stmt.a = "001"b then do; call replace; end; else do; if end_stmt.b = "0"b | end_stmt.a = "010"b then do; /* BEFORE REPLACING */ call tally; i = i + 1; if end_stmt.a = "011"b then i = i + 1; call replace; end; else do; /* AFTER REPLACING */ found = "0"b; do i = 7 to mp.n - 1 while (^found); if mp.pt (i) -> data_name.type = 1 then if mp.pt (i) -> reserved_word.key = replacing_key then do; found = "1"b; i = i + 1; call replace; i = 4; call tally; end; end; end; end; call cobol_reset_r$in_line; return; /*************************************/ /* SUBROUTINES */ /*************************************/ tally: proc; call tally_stack_count; if tn_opt then do; call tally_opt; return; end; tind = 1; tn = 0; ttp (1) = mp.pt (i); call cobol_io_util$t9dec_to_bin ("110"b, toutoff, ttp (1)); /* 7/18/76*/ /* BUILD THE FOLLOWING STRUCTURE: /* dcl 1 t, /* 2 ssp ptr, /* 2 slen fixed bin, /* 2 n fixed bin, /* 2 tally (0 refer(t.n)), /* 3 ccode fixed bin, /* 0=CHARACTERS, 1=LEADING, 2=ALL */ /* 3 lcode fixed bin, /* 0=unspecified, 1=BEFORE, 2=AFTER */ /* 3 lpos fixed bin, /* char pos to enable after's or disable before's */ /* 3 llen fixed bin, /* length of BEFORE/AFTER string */ /* 3 lsp ptr, /* ptr to BEFORE/AFTER string (if lcode ^= 0) */ /* 3 csp ptr, /* ptr to LEADING/ALL string (if ccode > 0) */ /* 3 clen fixed bin, /* length of LEADING/ALL string */ /* 3 ind fixed bin; tally index */ /**/ restart: done = "0"b; i = i + 1; do while (^done); tn = tn + 1; if mp.pt (i) -> reserved_word.key = characters_key then code = ""b; else do; if mp.pt (i) -> reserved_word.key = leading_key then code = "000000000000000001"b; else code = "000000000000000010"b; /* ALL */ i = i + 1; dn_ptr = mp.pt (i); if data_name.type ^= 9 then call get_type9; call store_pr (dn_ptr, 10 + 10 * (tn - 1)); /* t.csp(tn) */ call cobol_get_size$omit_sign (dn_ptr, stoff + 12 + 10 * (tn - 1), 0); /* t.clen(tn) */ end; call cobol_io_util$move_direct ("110"b, 4 * (stoff + 4 + 10 * (tn - 1)), 4, 1, code); /* t.ccode(tn) */ i = i + 1; code = ""b; if mp.pt (i) -> data_name.type = 1 then do; if mp.pt (i) -> reserved_word.key = before_key | mp.pt (i) -> reserved_word.key = after_key then do; if mp.pt (i + 1) -> data_name.type = 1 then if mp.pt (i + 1) -> reserved_word.key = replacing_key then go to forget_it; if mp.pt (i) -> reserved_word.key = before_key then code = "000000000000000001"b; else code = "000000000000000010"b; i = i + 1; dn_ptr = mp.pt (i); if data_name.type ^= 9 then call get_type9; call store_pr (dn_ptr, 8 + 10 * (tn - 1)); /* t.lsp(tn) */ call cobol_get_size$omit_sign (dn_ptr, stoff + 7 + 10 * (tn - 1), 0); /* t.llen(tn) */ i = i + 1; end; end; forget_it: call cobol_io_util$move_direct ("110"b, 4 * (stoff + 5 + 10 * (tn - 1)), 4, 1, code); /* t.lcode(tn) */ code = substr (unspec (tind), 19, 18); call cobol_io_util$move_direct ("110"b, 4 * (stoff + 13 + 10 * (tn - 1)), 4, 1, code); /* t.lcode(tn) */ dn_ptr = mp.pt (i); if data_name.type ^= 1 then done = "1"b; else do; temp = dn_ptr -> reserved_word.key; if temp ^= all_key & temp ^= leading_key & temp ^= characters_key then done = "1"b; end; end; if mp.n > i & mp.pt (i) -> data_name.type = 9 then do; tind = tind + 1; ttp (tind) = mp.pt (i); call cobol_io_util$t9dec_to_bin ("110"b, toutoff + (tind - 1) * 4, ttp (tind)); goto restart; end; call store_pr (mp.pt (2), 0); /* t.ssp */ call cobol_get_size$omit_sign (mp.pt (2), stoff + 2, 0); /* t.slen */ substr (epp2_instr, 4, 15) = substr (unspec (stoff), 22, 15); code = substr (unspec (tn), 19, 18); call cobol_io_util$move_direct ("110"b, 4 * (stoff + 3), 4, 1, code); /* t.n */ call cobol_emit (addr (epp2_instr), null (), 1); call cobol_call_op (50, 0); do j = 1 to tind; call cobol_io_util$bin_to_t9dec ("110"b, toutoff + (j - 1) * 4, ttp (j)); end; exit_tally: return; /* Calculate the stack needed for tallying. */ tally_stack_count: proc; dcl j fixed bin; dcl done bit (1); dcl off fixed bin; dcl tn fixed bin; tind = 1; tn = 0; j = i + 1; ; tn_opt = "1"b; try_again: done = "0"b; do while (^done); tn = tn + 1; if tn > 1 then tn_opt = "0"b; if mp.pt (j) -> reserved_word.key ^= characters_key then j = j + 1; if tn_opt then do; if mp.pt (j) -> data_name.type ^= 1 then do; if mp.pt (j) -> data_name.type = 3 then if mp.pt (j) -> alphanum_lit.lit_size > 2 then tn_opt = "0"b; else ; else if mp.pt (j) -> data_name.type = 9 then do; if mp.pt (j) -> data_name.variable_length | mp.pt (j) -> data_name.item_length > 2 then tn_opt = "0"b; end; else tn_opt = "0"b; end; if mp.pt (j + 1) -> data_name.type = 1 & (mp.pt (j + 1) -> reserved_word.key = after_key | mp.pt (j + 1) -> reserved_word.key = before_key) then do; if mp.pt (j + 2) -> data_name.type = 1 & mp.pt (j + 2) -> reserved_word.key = replacing_key then tn_opt = "0"b; else if mp.pt (j + 2) -> data_name.type = 3 then if mp.pt (j + 2) -> alphanum_lit.lit_size > 2 then tn_opt = "0"b; else ; else if mp.pt (j + 2) -> data_name.type = 9 then do; if mp.pt (j + 2) -> data_name.variable_length | mp.pt (j + 2) -> data_name.item_length > 2 then tn_opt = "0"b; end; else tn_opt = "0"b; end; end; j = j + 1; if mp.pt (j) -> data_name.type = 1 then do; if mp.pt (j) -> reserved_word.key = before_key | mp.pt (j) -> reserved_word.key = after_key then do; if mp.pt (j + 1) -> data_name.type ^= 1 | mp.pt (j + 1) -> reserved_word.key ^= replacing_key then j = j + 2; end; end; if mp.pt (j) -> data_name.type ^= 1 | (mp.pt (j) -> reserved_word.key ^= all_key & mp.pt (j) -> reserved_word.key ^= characters_key & mp.pt (j) -> reserved_word.key ^= leading_key) then done = "1"b; end; if mp.pt (j) -> data_name.type = 9 & j < mp.n then do; j = j + 1; tind = tind + 1; goto try_again; end; off = (tind + tn * 10) * 4; toutoff = (stoff + tn * 10 + 4) * 4; if tn > 1 then tn_opt = "0"b; if tn_opt then return; call cobol_alloc$stack (off, 2, j); exit_tally_stack_count: return; end tally_stack_count; /*************************************/ tally_opt: proc; addpout.pt1 = mp.pt (1); addpout.pt4 = addr (type19_add); if mp.pt (i + 1) -> reserved_word.key = characters_key then do; full_len = 0; if mp.pt (i + 2) -> data_name.type ^= 1 then full_len = 1; else if mp.pt (i + 2) -> reserved_word.key ^= after_key & mp.pt (i + 2) -> reserved_word.key ^= before_key then full_len = 1; else if mp.pt (i + 3) -> reserved_word.type = 1 then if mp.pt (i + 3) -> reserved_word.key = replacing_key then full_len = 1; if full_len = 1 then do; dn_ptr = mp.pt (2); call cobol_alloc$stack (4, 1, length_off); call cobol_get_size$omit_sign (dn_ptr, length_off, 0); fb35_type9.off = length_off * 4; addpout.pt2 = addr (fb35_type9); addpout.pt3 = mp.pt (i); /*[4.4-1]*/ call cobol_add_gen (addr (addpout), 0); end; else do; if mp.pt (i + 2) -> reserved_word.key = after_key then after_flag = "1"b; else after_flag = "0"b; call scan_opt_common (i + 3, data_len, "0"b, "1"b, "1"b, "1"b, "0"b, "0"b, "0"b, after_flag) ; if mp.pt (i + 2) -> reserved_word.key = after_key then do; substr (lda_inst (1), 4, 15) = substr (unspec (length_off), 22, 15); substr (lda_inst (3), 1, 18) = substr (unspec (data_len), 19, 18); substr (lda_inst (5), 4, 15) = substr (unspec (cnt_off), 22, 15); substr (lda_inst (7), 4, 15) = substr (unspec (cnt_off), 22, 15); call cobol_emit (addr (lda_inst (1)), null, 4); end; fb35_type9.off = cnt_off * 4; addpout.pt2 = addr (fb35_type9); addpout.pt3 = mp.pt (i); /*[4.4-1]*/ call cobol_add_gen (addr (addpout), 0); call cobol_define_tag_nc (exit_tag, cobol_$text_wd_off); call cobol_register$release (addr (reg1_struct)); reg1_struct.reg_no = "1010"b; call cobol_register$release (addr (reg1_struct)); end; if full_len = 1 then i = i + 2; else i = i + 4; return; end; else do; prev_scan = 1; rw_ptr = mp.pt (i + 3); if reserved_word.type ^= 1 then prev_scan = 0; else if reserved_word.key ^= before_key & reserved_word.key ^= after_key then prev_scan = 0; else if mp.pt (i + 4) -> reserved_word.type ^= 1 then if mp.pt (i + 4) -> reserved_word.key = replacing_key then prev_scan = 0; if prev_scan = 0 then call scan_opt_common (i + 2, data_len, "1"b, "1"b, "1"b, "1"b, "1"b, "0"b, "0"b, "1"b); else do; if mp.pt (i + 3) -> reserved_word.key = after_key then after_flag = "1"b; else after_flag = "0"b; call scan_opt_common (i + 4, data_len, "0"b, "1"b, "1"b, "1"b, "0"b, after_flag, "1"b, after_flag); call scan_opt_common (i + 2, data_len, "1"b, "0"b, "0"b, "0"b, "1"b, "0"b, "0"b, "1"b); end; end; if mp.pt (i + 1) -> reserved_word.key = leading_key then do; substr (lead_inst (1), 4, 15) = substr (unspec (cnt_off), 22, 15); call cobol_emit (addr (lead_inst (1)), null, 2); call cobol_make_tagref (exit_tag, cobol_$text_wd_off - 1, null); end; addpout.pt2 = addr (type2_static); addpout.pt3 = mp.pt (i); /*[4.4-1]*/ call cobol_add_gen (addr (addpout), 0); reg_struct.what_reg = 13; call cobol_register$load (addr (reg_struct)); temp = cnt_off + 1; substr (lxl3_inst (1), 4, 15) = substr (unspec (cnt_off), 22, 15); substr (lxl3_inst (5), 4, 15) = substr (unspec (temp), 22, 15); call cobol_emit (addr (lxl3_inst (1)), null, 3); call cobol_register$release (addr (reg_struct)); reg_struct.what_reg = 1; substr (cmpx_inst (1), 4, 15) = substr (unspec (temp), 22, 15); substr (cmpx_inst (5), 4, 15) = substr (unspec (temp), 22, 15); substr (cmpx_inst (7), 4, 15) = substr (unspec (temp), 22, 15); call cobol_emit (addr (cmpx_inst (1)), null, 5); call cobol_make_tagref (exit_tag, cobol_$text_wd_off - 4, null); call cobol_make_tagref (scan_tag, cobol_$text_wd_off - 1, null); call cobol_register$release (addr (reg1_struct)); reg1_struct.reg_no = "1001"b; call cobol_register$release (addr (reg1_struct)); call cobol_define_tag_nc (exit_tag, cobol_$text_wd_off); call cobol_pointer_register$priority (2, 0, "001"b); if prev_scan = 1 then i = i + 5; else i = i + 3; exit_tally_opt: return; end tally_opt; /******************************/ end tally; /* scan_opt_common */ /****************************************/ scan_opt_common: proc (j, data_len, x2_flag, pr1_flag, len_flag, exit_flag, scan_flag, after_flag, x1_flag, ttn_flag); dcl j fixed bin, data_len fixed bin, (x2_flag, pr1_flag, len_flag, after_flag, x1_flag, ttn_flag, exit_flag, scan_flag) bit (1); dn_ptr = mp.pt (2); if pr1_flag then do; if data_name.numeric & data_name.item_signed & ^data_name.sign_separate then call opch_move (dn_ptr); call cobol_set_pr$omit_sign (addr (pr1_struct), dn_ptr); end; if len_flag then do; call cobol_alloc$stack (20, 1, length_off); cnt_off = length_off + 1; call cobol_get_size$omit_sign (dn_ptr, length_off, 0); call cobol_register$load (addr (reg1_struct)); reg1_struct.what_reg = 12; call cobol_register$load (addr (reg1_struct)); reg1_struct.what_reg = 11; substr (lxl_inst (1), 4, 15) = substr (unspec (length_off), 22, 15); call cobol_emit (addr (lxl_inst (1)), null, 1); end; if x2_flag then do; call cobol_emit (addr (lxl_inst (3)), null, 1); substr (scm (2), 15, 4) = "1010"b; substr (scd (2), 15, 4) = "1010"b; end; else do; substr (scm (2), 15, 4) = "0000"b; substr (scd (2), 15, 4) = "0000"b; end; if exit_flag then do; exit_tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; end; dn_ptr = mp.pt (j); if data_name.type = 1 then do; call cobol_make_type3$type1 (addr (type3), dn_ptr); dn_ptr = addr (type3); end; if data_name.type = 3 then do; alit_ptr = dn_ptr; if scan_flag then do; scan_tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_define_tag_nc (scan_tag, cobol_$text_wd_off); end; if alphanum_lit.lit_size = 1 then do; data_len = 1; substr (lxl3_inst (3), 17, 2) = "01"b; substr (scm (7), 4, 15) = substr (unspec (cnt_off), 22, 15); substr (scm (5), 1, 9) = substr (unspec (alphanum_lit.string), 1, 9); substr (scm (5), 10, 9) = "000000000"b; substr (scm (1), 12, 7) = "0000011"b; call cobol_emit (addr (scm (1)), null, 4); end; else do; data_len = 2; substr (lxl3_inst (3), 17, 2) = "10"b; substr (scd (7), 4, 15) = substr (unspec (cnt_off), 22, 15); substr (scd (1), 12, 7) = "0000011"b; substr (scd (5), 1, 18) = substr (unspec (alphanum_lit.string), 1, 18); call cobol_emit (addr (scd (1)), null, 4); end; end; else do; if data_name.numeric & data_name.item_signed & ^data_name.sign_separate then call opch_move (dn_ptr); mpout.pt2 = dn_ptr; mpout.pt3 = addr (alpha_type9); alpha_type9.off = 4 * length_off + 16; alpha_type9.size = data_name.item_length; call cobol_move_gen (addr (mpout)); alpha_type9.flags1 = "000000100100000000010000000100000000"b; temp = length_off + 4; if scan_flag then do; scan_tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_define_tag_nc (scan_tag, cobol_$text_wd_off); end; if data_name.item_length = 1 then do; data_len = 1; substr (lxl3_inst (3), 17, 2) = "01"b; substr (scm (5), 1, 3) = "110"b; substr (scm (5), 4, 15) = substr (unspec (temp), 22, 15); substr (scm (7), 4, 15) = substr (unspec (cnt_off), 22, 15); substr (scm (1), 12, 7) = "100000"b; call cobol_emit (addr (scm (1)), null, 4); end; else do; data_len = 2; substr (lxl3_inst (3), 17, 2) = "10"b; substr (scd (5), 1, 3) = "110"b; substr (scd (5), 4, 15) = substr (unspec (temp), 22, 15); substr (scd (7), 4, 15) = substr (unspec (cnt_off), 22, 15); substr (scd (1), 12, 7) = "100000"b; call cobol_emit (addr (scd (1)), null, 4); end; end; if ttn_flag then do; call cobol_emit (addr (ttn), null, 1); call cobol_make_tagref (exit_tag, cobol_$text_wd_off - 1, null); end; if after_flag then do; substr (lca_inst (1), 4, 15) = substr (unspec (cnt_off), 22, 15); substr (lca_inst (3), 1, 18) = substr (unspec (data_len), 19, 18); substr (lca_inst (7), 4, 15) = substr (unspec (length_off), 22, 15); call cobol_emit (addr (lca_inst (1)), null, 4); substr (lxl_inst (1), 4, 15) = substr (unspec (length_off), 22, 15); end; else substr (lxl_inst (1), 4, 15) = substr (unspec (cnt_off), 22, 15); if x1_flag then call cobol_emit (addr (lxl_inst (1)), null, 1); exit_scan_opt_common: return; end scan_opt_common; /****************************************/ /*************************************/ replace: proc; /* BUILD THE FOLLOWING STRUCTURE: /* dcl 1 r, /* 2 ssp ptr, /* 2 slen fixed bin, /* 2 n fixed bin, /* 2 repl(0 refer(r.n)), /* 3 ccode fixed bin, /* 3=FIRST */ /* 3 lcode fixed bin, /* 3 lpos fixed bin, /* 3 llen fixed bin, /* 3 lsp ptr, /* 3 csp ptr, /* 3 clen fixed bin, /* 3 bsp ptr; /* ptr to BY string (length must = clen) */ /**/ rn = 0; save_code = ""b; call replacing_stack_count; if rn_opt then do; call repl_opt; return; end; do while (mp.pt (i) -> data_name.type ^= 19); rn = rn + 1; dn_ptr = mp.pt (i); if data_name.type = 1 then do; /* may be key-word or a fig-con */ rw_ptr = dn_ptr; if reserved_word.key = characters_key then save_code = ""b; else do; if reserved_word.key = leading_key then save_code = "000000000000000001"b; else if reserved_word.key = all_key then save_code = "000000000000000010"b; else if reserved_word.key = first_key then save_code = "000000000000000011"b; else i = i - 1; /* fig-con, save_code will have been set */ i = i + 1; dn_ptr = mp.pt (i); if data_name.type ^= 9 then call get_type9; call store_pr (dn_ptr, 10 + 12 * (rn - 1)); /* r.csp(rn) */ call cobol_get_size$omit_sign (dn_ptr, stoff + 12 + 12 * (rn - 1), 0); /* r.clen(rn) */ end; end; else do; if data_name.type ^= 9 then call get_type9; call store_pr (dn_ptr, 10 + 12 * (rn - 1)); /*r.csp(rn) */ call cobol_get_size$omit_sign (dn_ptr, stoff + 12 + 12 * (rn - 1), 0); /* r.clen(rn) */ end; call cobol_io_util$move_direct ("110"b, 4 * (stoff + 4 + 12 * (rn - 1)), 4, 1, save_code); /* r.ccode(rn) */ i = i + 1; dn_ptr = mp.pt (i); if data_name.type ^= 9 then call get_type9; call store_pr (dn_ptr, 14 + 12 * (rn - 1)); /* r.bsp(rn) */ i = i + 1; code = ""b; if mp.pt (i) -> data_name.type = 1 then do; if mp.pt (i) -> reserved_word.key = before_key | mp.pt (i) -> reserved_word.key = after_key then do; if mp.pt (i) -> reserved_word.key = before_key then code = "000000000000000001"b; else code = "000000000000000010"b; i = i + 1; dn_ptr = mp.pt (i); if data_name.type ^= 9 then call get_type9; call store_pr (dn_ptr, 8 + 12 * (rn - 1)); /* r.lsp(rn) */ call cobol_get_size$omit_sign (dn_ptr, stoff + 7 + 12 * (rn - 1), 0); /* r.llen(rn) */ i = i + 1; end; end; call cobol_io_util$move_direct ("110"b, 4 * (stoff + 5 + 12 * (rn - 1)), 4, 1, code); /* r.lcode(rn) */ end; dn_ptr = mp.pt (2); call store_pr (dn_ptr, 0); call cobol_get_size$omit_sign (mp.pt (2), stoff + 2, 0); /* r.slen */ code = substr (unspec (rn), 19, 18); call cobol_io_util$move_direct ("110"b, 4 * (stoff + 3), 4, 1, code); /* r.n */ substr (epp2_instr, 4, 15) = substr (unspec (stoff), 22, 15); call cobol_emit (addr (epp2_instr), null (), 1); call cobol_call_op (51, 0); if mp.pt (2) -> data_name.numeric & mp.pt (2) -> data_name.item_signed & ^mp.pt (2) -> data_name.sign_separate then do; mpout.pt2 = addr (alpha_type9); mpout.pt3 = mp.pt (2); call cobol_move_gen (addr (mpout)); end; return; /* Calculate replacing stack frame requirement. */ replacing_stack_count: proc; dcl j fixed bin; dcl (all_option, leading_option) fixed bin; dcl k fixed bin; dcl rn fixed bin; all_option, leading_option, before_option = 0; rn = 0; rn_opt = "1"b; con_flag = 1; j = i; do while (mp.pt (j) -> data_name.type ^= 19); rn = rn + 1; if mp.pt (j) -> data_name.type = 1 then do; if mp.pt (j) -> reserved_word.key = leading_key | mp.pt (j) -> reserved_word.key = first_key | mp.pt (j) -> reserved_word.key = characters_key then leading_option = leading_option + 1; else if mp.pt (j) -> reserved_word.key = all_key then all_option = all_option + 1; if mp.pt (j) -> reserved_word.key ^= characters_key then do; if mp.pt (j) -> reserved_word.key = leading_key | mp.pt (j) -> reserved_word.key = all_key | mp.pt (j) -> reserved_word.key = first_key then j = j + 1; end; end; do k = 1 to 2; if mp.pt (j) -> data_name.type = 3 then if mp.pt (j) -> alphanum_lit.lit_size ^= 1 then rn_opt = "0"b; else ; else if mp.pt (j) -> data_name.type = 9 then if (mp.pt (j) -> data_name.item_length ^= 1 | mp.pt (j) -> data_name.variable_length = "1"b) then rn_opt = "0"b; if rn_opt then if mp.pt (j) -> data_name.type = 9 then con_flag = 0; j = j + 1; end; if mp.pt (j) -> data_name.type = 1 then do; if mp.pt (j) -> reserved_word.key = before_key | mp.pt (j) -> reserved_word.key = after_key then do; if mp.pt (j + 1) -> data_name.type = 3 then if mp.pt (j + 1) -> alphanum_lit.lit_size > 2 then rn_opt = "0"b; else ; else if mp.pt (j + 1) -> data_name.type = 9 then if (mp.pt (j + 1) -> data_name.item_length > 2 | mp.pt (j + 1) -> data_name.variable_length = "1"b) then rn_opt = "0"b; else rn_opt = "0"b; j = j + 2; before_option = before_option + 1; end; end; end; if rn_opt then do; if (leading_option ^= 0 | (before_option ^= 0 & all_option > 1)) then rn_opt = "0"b; else if (before_option ^= 0 & rn > 1) then rn_opt = "0"b; else return; end; call cobol_alloc$stack (48 * rn, 2, j); exit_replacing_stack_count: return; end replacing_stack_count; /* Generate on line instructions for optimatization of replacing single cahracter. */ repl_opt: proc; dcl j fixed bin; dcl length_off fixed bin; dcl k fixed bin; i = i + 1; mvt_table = mvt_table_static; input_ptr = addr (input_area); reloc_ptr = addr (reloc_area); input_struc.type = 5; input_struc.operand_no = 2; input_struc.lock = 0; input_struc.size_sw (1) = 0; input_struc.size_sw (2) = 0; if before_option ^= 0 then k = mp.n - 3; else k = mp.n - 1; if con_flag = 1 then do; stack_flag = 0; do j = k to i by -1; if mp.pt (j) -> reserved_word.key = all_key then j = j - 1; j = j - 1; alit_ptr = mp.pt (j); if alphanum_lit.type = 1 then do; call cobol_make_type3$type1 (addr (type3), alit_ptr); alit_ptr = addr (type3); end; char1 = substr (alphanum_lit.string, 1, 1); char1_index = fixed (char1_bit) + 1; alit_ptr = mp.pt (j + 1); if alphanum_lit.type = 1 then do; call cobol_make_type3$type1 (addr (type3), alit_ptr); alit_ptr = addr (type3); end; substr (mvt_table, char1_index, 1) = substr (alphanum_lit.string, 1, 1); end; call cobol_pool (mvt_table, 2, conoff); substr (mvt (4), 19, 18) = "000000000000000100"b; end; else do; stack_flag = 1; call cobol_alloc$stack (132, 2, length_off); call cobol_register$load (addr (reg1_struct)); call cobol_pool (mvt_table_static, 2, conoff); temp = -conoff - cobol_$text_wd_off; substr (mlr_tab (2), 1, 18) = substr (unspec (temp), 19, 18); substr (mlr_tab (3), 4, 15) = substr (unspec (length_off), 22, 15); call cobol_emit (addr (mlr_tab (1)), null, 3); do j = k to i by -1; if mp.pt (j) -> reserved_word.key = all_key then j = j - 1; j = j - 1; if mp.pt (j) -> data_name.type ^= 9 then do; alit_ptr = mp.pt (j); if alphanum_lit.type = 1 then do; call cobol_make_type3$type1 (addr (type3), alit_ptr); alit_ptr = addr (type3); end; substr (ldx1_inst, 10, 9) = substr (unspec (alphanum_lit.string), 1, 9); call cobol_emit (addr (ldx1_inst), null, 1); end; else do; input_struc.token_ptr (1) = mp.pt (j); if mp.pt (j) -> data_name.item_signed then call opch_move (input_struc.token_ptr (1)); alpha_type9.off = length_off * 4 + 130; alpha_type9.size = 2; input_struc.token_ptr (2) = addr (alpha_type9); call cobol_addr (input_ptr, addr (mrl (1)), reloc_ptr); substr (mrl (1), 19, 10) = "0010000011"b; substr (mrl (2), 21, 8) = "00000000"b; substr (mrl (3), 21, 12) = "0000000000"b; call cobol_emit (addr (mrl (1)), reloc_ptr, 3); temp = length_off + 32; substr (lxl1_inst, 4, 15) = substr (unspec (temp), 22, 15); call cobol_emit (addr (lxl1_inst), null, 1); end; if mp.pt (j + 1) -> data_name.type ^= 9 then do; dn_ptr = mp.pt (j + 1); if mp.pt (j + 1) -> data_name.type = 1 then do; call cobol_make_type3$type1 (addr (type3), dn_ptr); dn_ptr = addr (type3); end; call cobol_make_type9$type2_3 (addr (type9), dn_ptr); input_struc.token_ptr (1) = addr (type9); end; else input_struc.token_ptr (1) = mp.pt (j + 1); if mp.pt (j + 1) -> data_name.item_signed then call opch_move (input_struc.token_ptr (1)); input_struc.token_ptr (2) = addr (alpha_type9); alpha_type9.off = length_off * 4; alpha_type9.size = 1; substr (mlr (1), 19, 10) = "0010000001"b; call cobol_addr (input_ptr, addr (mlr (1)), reloc_ptr); substr (mlr (1), 15, 4) = "1001"b; substr (mlr (2), 21, 8) = "00000000"b; call cobol_emit (addr (mlr (1)), reloc_ptr, 3); end; substr (mvt (4), 4, 15) = substr (unspec (length_off), 22, 15); substr (mvt (4), 1, 3) = "110"b; substr (mvt (4), 19, 18) = "000000000001000000"b; reg1_struct.lock = 0; call cobol_register$release (addr (reg1_struct)); reg1_struct.lock = 1; end; substr (mvt (1), 19, 10) = "0011100001"b; if before_option ^= 0 then do; if mp.pt (mp.n - 2) -> reserved_word.key = before_key then after_flag = "0"b; else after_flag = "1"b; call scan_opt_common (mp.n - 1, k, "0"b, "1"b, "1"b, "1"b, "0"b, after_flag, "1"b, after_flag); mvt (1) = "000000000001100000001110000101100000"b; mvt (2) = "001000000000000000000000000000001001"b; mvt (3) = "001000000000000000000000000000001001"b; if stack_flag = 0 then do; temp = -conoff - cobol_$text_wd_off; substr (mvt (4), 1, 18) = substr (unspec (temp), 19, 18); end; call cobol_emit (addr (mvt (1)), null, 4); if mp.pt (2) -> data_name.numeric & mp.pt (2) -> data_name.item_signed & ^mp.pt (2) -> data_name.sign_separate then do; alpha_type9.seg = 5001; alpha_type9.off = 0; mpout.pt2 = addr (alpha_type9); mpout.pt3 = mp.pt (2); call cobol_move_gen (addr (mpout)); end; call cobol_define_tag_nc (exit_tag, cobol_$text_wd_off); end; else do; input_struc.token_ptr (1) = mp.pt (2); if mp.pt (2) -> data_name.numeric & mp.pt (2) -> data_name.item_signed & ^mp.pt (2) -> data_name.sign_separate then do; call opch_move (input_struc.token_ptr (1)); opch_flag = 1; end; else opch_flag = 0; if input_struc.token_ptr (1) -> data_name.numeric then input_struc.token_ptr (1) -> data_name.alphanum = "1"b; input_struc.token_ptr (2) = input_struc.token_ptr (1); call cobol_addr (input_ptr, addr (mvt (1)), reloc_ptr); if stack_flag = 0 then do; temp = -conoff - cobol_$text_wd_off; substr (mvt (4), 1, 18) = substr (unspec (temp), 19, 18); end; call cobol_emit (addr (mvt (1)), reloc_ptr, 4); if input_struc.token_ptr (1) -> data_name.numeric then input_struc.token_ptr (1) -> data_name.alphanum = "0"b; if opch_flag = 1 then do; mpout.pt2 = input_struc.token_ptr (1); mpout.pt3 = mp.pt (2); call cobol_move_gen (addr (mpout)); end; end; exit_repl_opt: return; end repl_opt; end replace; /*************************************/ store_pr: proc (t9ptr, off); dcl i fixed bin; dcl t9ptr ptr; dcl off fixed bin; if t9ptr -> data_name.numeric & t9ptr -> data_name.item_signed & ^t9ptr -> data_name.sign_separate then call opch_move (t9ptr); call cobol_set_pr$omit_sign (pr2_struct_ptr, t9ptr); temp = stoff + off; substr (spri2_instr, 4, 15) = substr (unspec (temp), 22, 15); call cobol_emit (addr (spri2_instr), null (), 1); return; end store_pr; /************************************/ opch_move: proc (t9ptr); dcl t9ptr ptr; dcl i fixed bin; mpout.pt2 = t9ptr; mpout.pt3 = addr (alpha_type9); alpha_type9.size = t9ptr -> data_name.item_length; call cobol_alloc$stack (alpha_type9.size, 1, i); alpha_type9.off = i * 4; call cobol_move_gen (addr (mpout)); type9 = alpha_char; t9ptr = addr (type9); alpha_type9.flags1 = "000000100100000000010000000100000000"b; return; end opch_move; /*************************************/ get_type9: proc; if data_name.type = 1 then do; call cobol_make_type3$type1 (addr (type3), dn_ptr); dn_ptr = addr (type3); end; if data_name.type ^= 9 then do; call cobol_make_type9$type2_3 (addr (type9), dn_ptr); dn_ptr = addr (type9); end; return; end get_type9; /*************************************/ %include cobol_type1; %include cobol_type2; %include cobol_type3; %include cobol_type9; %include cobol_type19; %include cobol_; %include cobol_addr_tokens; end cobol_inspect_gen;  cobol_io_util.pl1 05/24/89 1041.5rew 05/24/89 0830.8 235800 /****^ *********************************************************** * * * 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_io_util.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 3/18/81 by FCH, [4.4-1], entries set_fsb_loc and fsb_key_loc added, BUG470 */ /* Modified on 11/17/78 by FCH, [3.0-1], entry file_desc added */ /*Modified since Version 3.0 */ /* format: style3 */ cobol_io_util: proc; dcl treg bit (3) aligned; /* register for target field */ dcl toff fixed bin; /* char offset from treg of target field */ dcl tlen fixed bin; /* number of characters of target */ /*[3.0-1]*/ dcl desc_off fixed bin (24), keynum fixed bin; /*[3.0-1]*/ dcl (mode, offset) fixed bin; /*[4.4-1]*/ declare 1 op_codes static internal, /*[4.4-1]*/ 2 epp1 bit (18) init ("011101001101000000"b), /*[4.4-1]*/ 2 spri1 bit (18) init ("010101001101000000"b); dcl 1 move_tokens static, 2 n fixed bin init (4), 2 fill fixed bin, 2 move_token_ptr (4) ptr init ((4) null ()); dcl 1 type19 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), /* MOVE */ 2 e fixed bin init (1), 2 h fixed bin, 2 j fixed bin, 2 a bit (3), 2 b bit (1), 2 c bit (1), 2 d bit (2), 2 f bit (2), 2 g bit (2), 2 k bit (5); dcl 1 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 fb (6) fixed bin init (0, 0, 0, 4, 0, 0), 3 flags1 bit (36) init (""b), 3 flags2 bit (36) init (""b), 3 seg fixed bin init (1000), 3 off fixed bin, 2 fill2 (7) fixed bin init (0, 0, 0, 0, 0, 0, 0); dcl 1 btd_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 send_receive fixed bin init (0), 3 ic_mod fixed bin, 3 size_sw fixed bin init (0), 2 operand2, 3 token_ptr ptr, 3 send_receive fixed bin init (1), 3 ic_mod fixed bin, 3 size_sw fixed bin init (0); dcl 1 dtb_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, 3 send_receive fixed bin init (0), 3 ic_mod fixed bin, 3 size_sw fixed bin init (0), 2 operand2, 3 token_ptr ptr init (null ()), 3 send_receive fixed bin init (0), 3 ic_mod fixed bin, 3 size_sw fixed bin init (0); dcl instr (32) bit (36); /*[3.0-1]*/ dcl descoff fixed bin; /*[3.0-1]*/ dcl ndx bit (3), addrs bit (15); dcl litlen fixed bin; /* char length of sending literal */ dcl litoff fixed bin; /* word offset from current instr to literal */ dcl swdoff fixed bin; /* word offset in stack of sending field */ dcl twdoff fixed bin; /* word offset in stack of target field */ dcl tmodoff fixed bin; /* char offset from twdoff */ dcl smodoff fixed bin; /* char offset from swdoff */ dcl dmodoff fixed bin; /* delta smodoff and tmodoff */ dcl sal fixed bin; /* 0 = sending field even word aligned */ dcl tal fixed bin; /* 0 = target field even word aligned */ dcl modlen fixed bin; dcl i fixed bin; dcl off fixed bin; dcl ic fixed bin; dcl lensw fixed bin; dcl (tlensw, slensw) fixed bin; dcl fromsw fixed bin; dcl adjustsw fixed bin; dcl boundary fixed bin; dcl temp fixed bin; dcl temp_off fixed bin; dcl ttlen fixed bin; /* target length used by move_unaligned subtrn */ dcl regsw fixed bin; /* 0=sending field has IC modification; 1=sreg or ssreg contains sending register */ dcl curlen fixed bin; dcl adj fixed bin; dcl init_count fixed bin static init (0); dcl ssreg bit (3) aligned; /* sending register used by move_aligned and move_unaligned subrtns */ dcl talsw bit (1); dcl give_up bit (1); dcl temp_tag bit (6); dcl temp_instr bit (12); dcl instr_ptr ptr; dcl nothing char (3) static options (constant) init (""); /*************************************/ move_direct: entry (treg, toff, tlen, dudl, dval); dcl dudl fixed bin; /* 0=du; 1=dl */ dcl dval bit (18) aligned; /* direct value */ start_move_direct: twdoff = divide (toff, 4, 17, 0); tmodoff = mod (toff, 4); if tlen + tmodoff > 4 then return; /* error */ if tlen = 4 & dval = ""b & tmodoff = 0 then do; instr (1) = treg || substr (unspec (twdoff), 22, 15) || stz_; ic = 1; end; else do; instr (1) = dval || lda || dmod (dudl); instr (2) = treg || substr (unspec (twdoff), 22, 15); if tlen = 4 & tmodoff = 0 then substr (instr (2), 19, 18) = sta_; else substr (instr (2), 19, 18) = stba_ || tagarray (tmodoff, tlen); ic = 2; end; call cobol_reloc$cobol_emit (addr (instr), null (), ic); return; /*************************************/ move_lit: entry (treg, toff, tlen, lit); dcl lit char (*); /* sending literal */ start_move_lit: ic = 0; litlen = length (lit); twdoff = divide (toff, 4, 17, 0); tal = mod (twdoff, 2); smodoff, tmodoff = mod (toff, 4); if litlen > tlen then litlen = tlen; /* take care of truncation */ /*-05/15/76-*/ if tlen = litlen & tlen <= 2 then do; ic = 2; fromsw = divide (tmodoff, 2, 17, 0); /* fix bug */ /*-05/15/76-*/ adjustsw = mod (tmodoff, 2); instr (1) = unspec (lit); substr (instr (1), 19, 18) = lda || dmod (fromsw); if tlen = 1 then if adjustsw ^= 0 then substr (instr (1), 1, 18) = (9)"0"b || unspec (lit); else ; else if adjustsw ^= 0 then do; instr (2) = "000000000000001001"b || rs (fromsw); ic = 3; end; instr (ic) = treg || substr (unspec (twdoff), 22, 15) || stba_ || tagarray (tmodoff, tlen); if fromsw = 1 & adjustsw = 1 & tlen = 2 then do; ic = ic + 1; temp = twdoff + 1; instr (ic) = treg || substr (unspec (temp), 22, 15) || stbq_ || "100000"b; end; end; else if tmodoff = 0 & tlen = 4 & lit = "" then do; ic = 1; instr (1) = treg || substr (unspec (twdoff), 22, 15) || stz_; end; else do; if tlen = litlen & tlen + tmodoff <= max_noshift_chars (tal) then do; temp = tlen + tmodoff; if temp > 8 then do; sal = tal; boundary = 2 + tal; end; else if temp > 4 then do; sal = 0; boundary = 2; end; else do; sal = 1; boundary = 1; end; call cobol_pool$search_op_byte (lit, boundary, litoff, regsw, smodoff); if regsw = 0 then litoff = cobol_$text_wd_off + litoff; else do; ssreg = "000"b; swdoff = litoff; /*-06/17/76-*/ end; call move_aligned; end; else do; call cobol_pool$search_op (lit, 4, litoff, regsw); if regsw = 0 then do; /* IC modification */ temp = mod (litoff, 4); litoff = -(cobol_$text_wd_off + divide (litoff, 4, 17, 0)); instr (1) = mlr_ic_to_reg; instr (2) = substr (unspec (litoff), 19, 18) || substr (unspec (temp), 35, 2) || substr (unspec (litlen), 21, 16); end; else do; /* PR0 Register modification */ instr (1) = mlr_reg_to_reg; instr (2) = "000"b || substr (unspec (litoff), 20, 17) || substr (unspec (litlen), 21, 16); end; instr (3) = treg || substr (unspec (twdoff), 22, 15) || substr (unspec (tmodoff), 35, 2) || substr (unspec (tlen), 21, 16); ic = 3; end; end; call cobol_reloc$cobol_emit (addr (instr), null (), ic); return; /*************************************/ move: entry (treg, toff, tlen, sreg, soff, slen); dcl sreg bit (3) aligned; /* register for sending field */ dcl soff fixed bin; /* char offset from sreg of sending field */ dcl slen fixed bin; /* char length of sending field */ start_move: ic = 0; swdoff = divide (soff, 4, 17, 0); sal = mod (swdoff, 2); smodoff = mod (soff, 4); twdoff = divide (toff, 4, 17, 0); tal = mod (twdoff, 2); tmodoff = mod (toff, 4); if slen > tlen then slen = tlen; /* take care of truncation */ /*-05/15/76-*/ give_up = "1"b; /* be pessimistic */ if tlen = slen then do; regsw = 1; ssreg = sreg; temp = tal + sal; /* 0=both even word aligned;2=both odd word aligned */ if tmodoff = smodoff then do; /* no shift required */ if tlen + tmodoff <= max_noshift_chars (temp) then do; give_up = "0"b; call move_aligned; end; end; else if tlen + max (tmodoff, smodoff) <= max_shift_chars (temp) then do; give_up = "0"b; curlen = tlen; do while (curlen > 0); temp_off = max (smodoff, tmodoff); temp = 8 - temp_off; if sal ^= 0 then if curlen > temp then temp = 4 - temp_off; ttlen = min (temp, curlen); call move_unaligned; temp = smodoff + ttlen; swdoff = swdoff + divide (temp, 4, 17, 0); sal = mod (swdoff, 2); smodoff = mod (temp, 4); temp = tmodoff + ttlen; twdoff = twdoff + divide (temp, 4, 17, 0); tal = mod (twdoff, 2); tmodoff = mod (temp, 4); curlen = curlen - ttlen; end; end; end; if give_up then do; /* oh well */ instr (1) = mlr_reg_to_reg; instr (2) = sreg || substr (unspec (swdoff), 22, 15) || substr (unspec (smodoff), 35, 2) || substr (unspec (slen), 21, 16); instr (3) = treg || substr (unspec (twdoff), 22, 15) || substr (unspec (tmodoff), 35, 2) || substr (unspec (tlen), 21, 16); ic = 3; end; call cobol_reloc$cobol_emit (addr (instr), null (), ic); return; /*************************************/ fixed_add: entry (treg, toff, tlen, sreg, soff); if tlen ^= 0 then do; /* tlen contains value */ temp = abs (tlen); instr (1) = substr (unspec (temp), 19, 18) || lda || dmod (1); end; else do; /* value to be added is at sreg|soff */ temp = soff * 4; instr (1) = sreg || substr (unspec (temp), 22, 15) || ld_ (0); end; if tlen < 0 then instr (2) = treg || substr (unspec (toff), 20, 15) || ssa_; else instr (2) = treg || substr (unspec (toff), 20, 15) || asa_; call cobol_reloc$cobol_emit (addr (instr), null (), 2); return; /*************************************/ dec_add: entry (treg, toff, tlen, lit); litlen = length (lit); call cobol_pool (lit, 2, litoff); litoff = -(cobol_$text_wd_off + litoff); instr (1) = ad2d_ic_to_reg; instr (2) = substr (unspec (litoff), 19, 18) || "000011000000"b || substr (unspec (litlen), 31, 6); instr (3) = treg || substr (unspec (toff), 20, 17) || "0011000000"b || substr (unspec (tlen), 31, 6); call cobol_reloc$cobol_emit (addr (instr), null (), 3); return; /*************************************/ dec_to_bin: entry (treg, toff, tlen, sreg, soff, slen); instr (1) = dtb_instr; instr (2) = sreg || substr (unspec (soff), 20, 17) || "0011000000"b || substr (unspec (slen), 31, 6); instr (3) = treg || substr (unspec (toff), 20, 27) || (10)"0"b || substr (unspec (tlen), 31, 6); call cobol_reloc$cobol_emit (addr (instr), null (), 3); return; /*************************************/ bin_to_dec: entry (treg, toff, tlen, sreg, soff, slen); instr (1) = btd_instr; instr (2) = sreg || substr (unspec (soff), 20, 17) || (10)"0"b || substr (unspec (slen), 31, 6); instr (3) = treg || substr (unspec (toff), 20, 17) || "0011000000"b || substr (unspec (tlen), 31, 6); call cobol_reloc$cobol_emit (addr (instr), null (), 3); return; /*************************************/ t9dec_to_bin: entry (breg, boff, dptr); dcl breg bit (3) aligned; /* register of the binary 4 byte data */ dcl boff fixed bin aligned; /* character offset of the binary data */ dcl dptr ptr; /* pts to type 9 token for unsigned decimal data */ /* instr(1) = dtb_instr; /* instr(2) = (20)"0"b||"0011000000"b||(6)"0"b; /* to be filled by cobol_addr */ /* instr(3) = breg||substr(unspec(boff),20,17)||"0000000000000100"b; /* dtb_struct.operand1.token_ptr = dptr; /* instr_ptr = addr(instr); /* call cobol_addr(addr(dtb_struct),instr_ptr,null()); /* call cobol_reloc$cobol_emit(instr_ptr,null(),3); */ if init_count ^= cobol_$compile_count then do; move_token_ptr (4) = addr (type19); call cobol_make_type9$long_bin (addr (type9), 0, 0); /* segno and offset filled in later */ init_count = cobol_$compile_count; end; type9.seg = 5000 + fixed (breg, 3); type9.off = boff; move_token_ptr (2) = dptr; move_token_ptr (3) = addr (type9); call cobol_move_gen (addr (move_tokens)); return; /*************************************/ bin_to_t9dec: entry (breg, boff, dptr); /* instr(1) = btd_instr; /* instr(2) = breg||substr(unspec(boff),20,27)||"000100"b; /* instr(3) = (20)"0"b||"0011000000"b||(6)"0"b; /* to be filled by cobol_addr */ /* btd_struct.operand2.token_ptr = dptr; /* instr_ptr = addr(instr); /* call cobol_addr(addr(btd_struct),instr_ptr,null()); /* call cobol_reloc$cobol_emit(instr_ptr,null(),3); */ if init_count ^= cobol_$compile_count then do; move_token_ptr (4) = addr (type19); call cobol_make_type9$long_bin (addr (type9), 0, 0); /* segno and offset filled in later */ init_count = cobol_$compile_count; end; type9.seg = 5000 + fixed (breg, 3); type9.off = boff; move_token_ptr (2) = addr (type9); move_token_ptr (3) = dptr; call cobol_move_gen (addr (move_tokens)); return; /*************************************/ bypass_error: entry (tra_tag, def_tag); dcl tra_tag fixed bin; /* tagno which to transfer to */ dcl def_tag fixed bin; /* tagno which to define */ call cobol_reloc$cobol_emit (addr (tra), null (), 1); call cobol_define_tag (def_tag); call cobol_make_tagref (tra_tag, cobol_$text_wd_off - 1, null ()); return; /*************************************/ bypass_readkey: entry (tra_tag); call cobol_reloc$cobol_emit (addr (bypass_readkey_instr), null (), 4); call cobol_make_tagref (tra_tag, cobol_$text_wd_off - 1, null ()); return; /*************************************/ bypass_seqerror: entry (tra_tag); call cobol_reloc$cobol_emit (addr (bypass_seqerror_instr), null (), 2); call cobol_make_tagref (tra_tag, cobol_$text_wd_off - 1, null ()); return; /*************************************/ bypass_mode_error: entry (tra_tag, mode_bits); dcl mode_bits bit (2) aligned; substr (bypass_mode_error_instr (3), 13, 2) = mode_bits; call cobol_reloc$cobol_emit (addr (bypass_mode_error_instr), null (), 4); call cobol_make_tagref (tra_tag, cobol_$text_wd_off - 1, null ()); return; /*************************************/ compare_word: entry (tra_tag, creg1, coff1, creg2, coff2, eqne); dcl creg1 bit (3) aligned; dcl coff1 fixed bin; dcl creg2 bit (3) aligned; dcl coff2 fixed bin; dcl eqne fixed bin; /* 0 - tra on equal; 1 - tra on ^equal */ instr (1) = creg1 || substr (unspec (coff1), 20, 15) || lda_; instr (2) = creg2 || substr (unspec (coff2), 20, 15) || cmpa_; instr (3) = tze_tnz (eqne); call cobol_reloc$cobol_emit (addr (instr), null (), 3); call cobol_make_tagref (tra_tag, cobol_$text_wd_off - 1, null ()); return; /****************************************/ compare_zero_word: entry (tra_tag, creg1, coff1, creg2, coff2, eqne); /* creg2 and coff2 are not used - compare made to a single word equal to zero */ instr (1) = creg1 || substr (unspec (coff1), 20, 15) || szn_; instr (2) = tze_tnz (eqne); call cobol_reloc$cobol_emit (addr (instr), null (), 2); call cobol_make_tagref (tra_tag, cobol_$text_wd_off - 1, null ()); return; /*************************************/ compare_varying: entry (tra_tag, creg1, coff1, creg2, coff2, eqne); temp = divide (coff1, 4, 17, 0) - 1; instr (1) = creg1 || substr (unspec (temp), 22, 15) || lda_; temp = divide (coff2, 4, 17, 0) - 1; instr (2) = creg2 || substr (unspec (temp), 22, 15) || ldq_; instr (3) = cmpc_instr; instr (4) = creg1 || substr (unspec (coff1), 20, 17) || "0000000000000101"b; instr (5) = creg2 || substr (unspec (coff2), 20, 17) || "0000000000000110"b; instr (6) = tze_tnz (eqne); call cobol_reloc$cobol_emit (addr (instr), null (), 6); call cobol_make_tagref (tra_tag, cobol_$text_wd_off - 1, null ()); return; /*************************************/ compare_key: entry (tra_tag, sptr); dcl sptr ptr; /* ptr to type9 token for alpha-numeric data */ instr (1) = "001000000000000110"b || lda_; instr_ptr = addr (instr); call cobol_reloc$cobol_emit (instr_ptr, null (), 1); instr (1) = cmpc_instr; instr (2) = ""b; instr (3) = "001000000000000111000000000000000101"b; instr (4) = tze_tnz (0); dtb_struct.operand1.token_ptr = sptr; call cobol_addr (addr (dtb_struct), instr_ptr, null ()); substr (instr (1), 1, 9) = "001111111"b; /* pad character */ call cobol_reloc$cobol_emit (instr_ptr, null (), 4); call cobol_make_tagref (tra_tag, cobol_$text_wd_off - 1, null ()); return; /*************************************/ move_from_varlen: entry (lreg, loff, dptr, sreg, soff); dcl lreg bit (3) aligned; /* register for length */ dcl loff fixed bin; /* wd offset for length (fixed bin) */ instr (1) = lreg || substr (unspec (loff), 20, 15) || lda_; instr (2) = "000000000000000001"b || sba_dlmod; instr (3) = mlr_reg_to_reg; instr (4) = sreg || substr (unspec (soff), 20, 17) || "0000000000000101"b; instr (5) = ""b; btd_struct.operand2.token_ptr = dptr; call cobol_addr (addr (btd_struct), addr (instr (3)), null ()); substr (instr (3), 1, 9) = "000100000"b; /* blank fill */ substr (instr (3), 31, 1) = "1"b; /* length in a reg */ call cobol_reloc$cobol_emit (addr (instr), null (), 5); return; /****************************************/ /*[3.0-1]*/ file_desc: entry (desc_off); /*[3.0-1]*/ /* epp7 OFFSET,ic,du */ /*[3.0-1]*/ descoff = -(cobol_$text_wd_off + desc_off); /*[3.0-1]*/ ic = 1; /*[3.0-1]*/ instr (1) = substr (unspec (descoff), 19, 18) || epp7_ic_du; /*[3.0-1]*/ call cobol_reloc$cobol_emit (addr (instr), null (), ic); /*[3.0-1]*/ return; set_fsb_loc: entry; /*[4.4-1]*/ ndx = "110"b; /*[4.4-1]*/ addrs = "000000001010110"b; /*[4.4-1]*/ call emit_instr (op_codes.spri1); /* spri1 pr6|86 */ /*[4.4-1]*/ return; key_num: entry (keynum); /* epp2 KEY_NUMBER,du */ /*[3.0-1]*/ ic = 1; /*[3.0-1]*/ instr (1) = substr (unspec (keynum), 19, 18) || lda_dl; /*[3.0-1]*/ call cobol_reloc$cobol_emit (addr (instr), null (), ic); /*[3.0-1]*/ return; fsb_key_loc: entry (offset); /*[4.4-1]*/ ndx = "001"b; /*[4.4-1]*/ addrs = substr (unspec (offset), 22, 15); /*[4.4-1]*/ call emit_instr (op_codes.epp1); /* epp1 pr1|offset */ /*[4.4-1]*/ return; key_loc: entry (mode, offset); /*[3.1-1]*/ if mode = 1 /*[3.0-1]*/ then do; ndx = "110"b; /* epp1 p6|offset */ /*[3.0-1]*/ addrs = substr (unspec (offset), 22, 15); /*[3.0-1]*/ end; /*[3.0-1]*/ else do; ndx = "001"b; /* epp1 pr1|6 */ /*[3.0-1]*/ addrs = "000000000000110"b; /*[3.0-1]*/ end; /*[4.4-1]*/ call emit_instr (op_codes.epp1); /*[4.4-1]*/ return; emit_instr: proc (op); /*[4.4-1]*/ declare op bit (18); /*[3.0-1]*/ ic = 1; /*[3.0-1]*/ instr (1) = ndx || addrs || op; /*[3.0-1]*/ call cobol_reloc$cobol_emit (addr (instr), null (), ic); /*[4.4-1]*/ end; /*************************************/ /* INTERNAL PROCEDURES */ /*************************************/ move_aligned: proc; /* move x words where both operands start at same byte offset */ adj = 0; if tmodoff > 0 then do; /* not word aligned */ talsw = "0"b; temp = 8 - tmodoff; if tal ^= 0 then if tlen > temp then if tlen + tmodoff >= 8 then do; temp = 4 - tmodoff; talsw = "1"b; end; ttlen = min (temp, tlen); call move_unaligned; if talsw then do; tal = 0; if sal = 0 then sal = 1; else sal = 0; end; adj = adj + ttlen; end; if tlen - adj >= 4 & tal ^= 0 then do; /* get started on an even word boundary */ off = divide (adj + 3, 4, 17, 0); tal = 0; if sal = 0 then sal = 1; else sal = 0; ic = ic + 1; if regsw = 0 then do; temp = -litoff + off - ic + 1; instr (ic) = substr (unspec (temp), 19, 18) || lda_icmod; end; else do; temp = swdoff + off; instr (ic) = ssreg || substr (unspec (temp), 22, 15) || lda_; end; ic = ic + 1; temp = twdoff + off; instr (ic) = treg || substr (unspec (temp), 22, 15) || sta_; adj = adj + 4; end; do i = 0 to tlen - adj - 8 by 8; ic = ic + 1; off = divide (i + tmodoff + adj, 4, 17, 0); if regsw = 0 then do; temp = -litoff + off - ic + 1; substr (instr (ic), 1, 18) = substr (unspec (temp), 19, 18); if sal = 0 then substr (instr (ic), 19, 18) = ldaq_icmod; else do; /* shouldn't happen (in the current implementation) */ substr (instr (ic), 19, 18) = lda_icmod; ic = ic + 1; instr (ic) = substr (unspec (temp), 19, 18) || ldq_icmod; end; end; else do; temp = swdoff + off; if sal = 0 then instr (ic) = ssreg || substr (unspec (temp), 22, 15) || ldaq_; else do; instr (ic) = ssreg || substr (unspec (temp), 22, 15) || lda_; ic = ic + 1; temp = temp + 1; instr (ic) = ssreg || substr (unspec (temp), 22, 15) || ldq_; end; end; ic = ic + 1; temp = twdoff + off; if tal = 0 then instr (ic) = treg || substr (unspec (temp), 22, 15) || staq_; else do; instr (ic) = treg || substr (unspec (temp), 22, 15) || sta_; ic = ic + 1; temp = temp + 1; instr (ic) = treg || substr (unspec (temp), 22, 15) || stq_; end; end; off = divide (tlen - adj, 8, 17, 0) * 2 + divide (adj + 3, 4, 17, 0); modlen = mod (tlen - adj, 8); if modlen > 0 then do; ic = ic + 1; if modlen > 4 then lensw = 1; else lensw = 0; if regsw = 0 then do; temp = -litoff + off - ic + 1; substr (instr (ic), 1, 18) = substr (unspec (temp), 19, 18); if sal = 0 then substr (instr (ic), 19, 18) = ld_icmod (lensw); else do; substr (instr (ic), 19, 18) = lda_icmod; if lensw ^= 0 then do; ic = ic + 1; instr (ic) = substr (unspec (temp), 19, 18) || ldq_icmod; end; end; end; else do; temp = swdoff + off; instr (ic) = ssreg || substr (unspec (temp), 22, 15); if sal = 0 then substr (instr (ic), 19, 18) = ld_ (lensw); else do; substr (instr (ic), 19, 18) = lda_; if lensw ^= 0 then do; ic = ic + 1; temp = temp + 1; instr (ic) = ssreg || substr (unspec (temp), 22, 15) || ldq_; end; end; end; ic = ic + 1; temp = twdoff + off; instr (ic) = treg || substr (unspec (temp), 22, 15); if modlen = 4 then substr (instr (ic), 19, 18) = sta_; else do; if modlen < 4 then substr (instr (ic), 19, 18) = stba_ || tagarray (0, modlen); else do; substr (instr (ic), 19, 18) = sta_; ic = ic + 1; temp = temp + 1; instr (ic) = treg || substr (unspec (temp), 22, 15) || stbq_ || tagarray (0, modlen - 4); end; end; end; end move_aligned; move_unaligned: proc; /* move up to one word where operands do not start at same byte offset */ if ttlen <= 4 - smodoff then slensw = 0; /* fix bug */ /*-05/15/76-*/ else slensw = 1; if ttlen <= 4 - tmodoff then tlensw = 0; else tlensw = 1; if slensw = 1 | tlensw = 1 then lensw = 1; else lensw = 0; ic = ic + 1; if regsw = 0 then do; temp = -litoff - ic + 1; substr (instr (ic), 1, 18) = substr (unspec (temp), 19, 18); if sal = 0 then substr (instr (ic), 19, 18) = ld_icmod (slensw); else do; substr (instr (ic), 19, 18) = lda_icmod; if slensw ^= 0 then do; ic = ic + 1; instr (ic) = substr (unspec (temp), 19, 18) || ldq_icmod; end; end; end; else do; substr (instr (ic), 1, 18) = ssreg || substr (unspec (swdoff), 22, 15); if sal = 0 then substr (instr (ic), 19, 18) = ld_ (slensw); else do; substr (instr (ic), 19, 18) = lda_; if slensw ^= 0 then do; ic = ic + 1; temp = swdoff + 1; instr (ic) = ssreg || substr (unspec (temp), 22, 15) || ldq_; end; end; end; dmodoff = tmodoff - smodoff; if dmodoff ^= 0 then do; ic = ic + 1; if dmodoff > 0 then do; temp = 9 * dmodoff; instr (ic) = substr (unspec (temp), 19, 18) || rs (lensw); end; else do; temp = -9 * dmodoff; instr (ic) = substr (unspec (temp), 19, 18) || ls (lensw); end; end; ic = ic + 1; temp_tag = tagarray (tmodoff, ttlen); if temp_tag = ""b then temp_instr = sta_; else temp_instr = stba_; instr (ic) = treg || substr (unspec (twdoff), 22, 15) || temp_instr || temp_tag; if tlensw ^= 0 then do; ic = ic + 1; i = ttlen + tmodoff - 4; temp = twdoff + 1; instr (ic) = treg || substr (unspec (temp), 22, 15); if i = 4 then substr (instr (ic), 19, 18) = stq_; else substr (instr (ic), 19, 18) = stbq_ || tagarray (0, i); end; return; end move_unaligned; %include cobol_io_util_info; %include cobol_io_util_data; end cobol_io_util;  cobol_iocall.pl1 05/24/89 1041.5rew 05/24/89 0830.8 142767 /****^ *********************************************************** * * * 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_iocall.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 02/22/77 by Bob Chang to fix the bug for reloc bit. */ /* Modified on 01/31/77 by Bob Chang to implement profile option. */ /* Modified since Version 2.0. */ /* format: style3 */ cobol_iocall: proc (argptr, descptr); dcl argptr ptr; dcl descptr 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 1 args based (argptr), 2 entryno fixed bin, 2 arglist_off fixed bin, 2 stacktemp_off fixed bin, 2 n fixed bin, 2 arg (0 refer (args.n)), 3 pt ptr, 3 type fixed bin, 3 seg fixed bin, 3 off fixed bin, 3 value bit (18) unaligned, 3 indirect bit (1) unaligned, 3 overlay bit (1) unaligned, 3 repeat_nogen bit (1) unaligned, 3 reg_sw bit (1) unaligned, 3 reg bit (3) unaligned; dcl desc (20) bit (36) based (descptr); dcl type9 char (144) static aligned; /* enough to hold 36 words */ dcl 1 data_name based, 2 size fixed bin (15), 2 line fixed bin (15), 2 column fixed bin (15), 2 type fixed bin (15); dcl 1 addr_struct 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, 3 send_receive fixed bin init (0), 3 ic_mod fixed bin, 3 size_sw fixed bin init (1); dcl 1 basic_struct based, 2 type fixed bin, 2 count fixed bin, 2 lock fixed bin, 2 seg fixed bin, 2 offset fixed bin, 2 sr fixed bin; dcl evad (16) bit (18) static init ("010000000000010110"b, /* (1) detach_iocb */ "010000000000011010"b, /* (2) open */ "010000000000011110"b, /* (3) close */ "010000000000100010"b, /* (4) get_line */ "010000000000100110"b, /* (5) get_chars */ "010000000000101010"b, /* (6) put_chars */ "010000000000101110"b, /* (7) modes */ "010000000000110010"b, /* (8) position */ "010000000000110110"b, /* (9) control */ "010000000000111010"b, /* (10) read_record */ "010000000000111110"b, /* (11) write_record */ "010000000001000010"b, /* (12) rewrite_record */ "010000000001000110"b, /* (13) delete_record */ "010000000001001010"b, /* (14) seek_key */ "010000000001001110"b, /* (15) read_key */ "010000000001010010"b); /* (16) read_length */ /* THE FOLLOWING DECLARATION TO TEMPORARILY CALL iox_$name */ dcl ename (16) char (20) static init ("iox_$detach_iocb", "iox_$open", "iox_$close", "iox_$get_line", "iox_$get_chars", "iox_$put_chars", "iox_$modes", "iox_$position", "iox_$control", "iox_$read_record", "iox_$write_record", "iox_$rewrite_record", "iox_$delete_record", "iox_$seek_key", "iox_$read_key", "iox_$read_length"); /* Change to interface the cobol operators_ */ /*-04/05/76-*/ dcl entry_op (4) bit (18) static init ("000000000000000000"b, "000000000000000001"b, "000000000000000101"b, "000000000000000110"b); dcl icmod bit (6) static init ("000100"b); dcl indmod bit (6) static init ("010000"b); dcl dlmod bit (6) static init ("000111"b); dcl dmod (2) bit (6) static init ("000111"b, "000011"b); dcl stz bit (12) static init ("100101000001"b); dcl fld_ bit (12) static init ("100011001000"b); dcl tsx0 bit (12) static init ("111000000001"b); dcl eax1 bit (12) static init ("110010001001"b); dcl epp2 bit (12) static init ("011101010001"b); dcl epp2_ bit (12) static init ("011101010000"b); dcl spri2 bit (12) static init ("010101010001"b); dcl st (2) bit (12) static init ("111101101001"b, "111101110001"b); dcl ld_ (2) bit (12) static init ("010011101000"b, "010011110000"b); dcl full_epp2 bit (36) static init ("000000000000000000011101010000000000"b); dcl instr (8) bit (36) static aligned; dcl reloc (12) 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, "00000"b, "00000"b); dcl 1 pr0_struct static, 2 pr0 fixed bin init (0), 2 pointer_no bit (3), 2 lock fixed bin init (0), 2 switch fixed bin init (1), 2 segno fixed bin init (4000), 2 offset fixed bin init (0), 2 reset fixed bin; dcl 1 pr2_struct static, 2 pr2 fixed bin init (2), 2 pointer_no bit (3), 2 lock fixed bin init (0), 2 switch fixed bin init (0), 2 segno fixed bin, 2 offset fixed bin, 2 reset fixed bin; dcl 1 pr4_struct static, 2 pr4 fixed bin init (4), 2 pointer_no bit (3), 2 lock fixed bin init (0), 2 switch fixed bin init (1), 2 segno fixed bin init (3002), 2 offset fixed bin init (0), 2 reset fixed bin; dcl 1 reg_struct static, 2 either_a_or_q fixed bin init (4), 2 reg_no bit (4), 2 lock fixed bin init (0), 2 already_there fixed bin, 2 contains fixed bin init (0), 2 null_ptr ptr init (null ()), 2 fill bit (18) unaligned init ((18)"0"b), 2 literal bit (18) unaligned; dcl char4b char (4) based; dcl linkstring char (65); dcl varstring char (65) varying based (arg.pt (1)); dcl (i, j) fixed bin; dcl k fixed bin; dcl conoff fixed bin; dcl aloff fixed bin; dcl stoff fixed bin; dcl a_or_q fixed bin; dcl ic fixed bin; dcl opno fixed bin; dcl linkoff fixed bin; dcl seg fixed bin; dcl off fixed bin; dcl utemp fixed bin; dcl linksw bit (1); dcl firsttime bit (1) static init ("1"b); dcl loc bit (18) aligned; dcl reg bit (3) aligned; dcl instr_ptr ptr static; dcl instr3_ptr ptr static; dcl reloc_ptr ptr static; dcl reloc5_ptr ptr static; dcl pr0_struct_ptr ptr static; dcl pr2_struct_ptr ptr static; dcl pr4_struct_ptr ptr static; dcl reg_struct_ptr ptr static; dcl type9_ptr ptr static; dcl addr_struct_ptr static ptr; dcl cobol_reset_r$after_call entry; dcl cobol_pool entry (char (*), fixed bin, fixed bin); dcl cobol_make_link$type_4 entry (fixed bin, char (*)); dcl cobol_make_fixup entry (ptr); dcl cobol_alloc$stack entry (fixed bin, fixed bin, fixed bin); dcl cobol_register$load entry (ptr); dcl cobol_emit entry (ptr, ptr, fixed bin); dcl cobol_pointer_register$get entry (ptr); dcl cobol_pointer_register$call entry; dcl cobol_addr entry (ptr, ptr, ptr); dcl cobol_make_type9$type2_3 entry (ptr, ptr); dcl cobol_set_pr entry (ptr, ptr); /*************************************/ start: if firsttime then do; instr_ptr = addr (instr); instr3_ptr = addr (instr (3)); reloc_ptr = addr (reloc); reloc5_ptr = addr (reloc (5)); pr0_struct_ptr = addr (pr0_struct); pr2_struct_ptr = addr (pr2_struct); pr4_struct_ptr = addr (pr4_struct); reg_struct_ptr = addr (reg_struct); type9_ptr = addr (type9); addr_struct_ptr = addr (addr_struct); firsttime = "0"b; end; if args.entryno = 0 then k = 1; else k = 0; /* 0=iocall; 1=other */ if args.arglist_off <= 0 then do; i = 8 * (args.n + 1 - k); if descptr ^= null () then i = 2 * i; call cobol_alloc$stack (i, 2, aloff); end; else aloff = args.arglist_off; call cobol_pointer_register$get (pr2_struct_ptr); stoff = args.stacktemp_off; do j = 1 to 11 by 2; reloc (j) = "00000"b; end; ic = 1; if args.n > k then do i = 2 to args.n; /* set up argument list */ if arg.type (i) = 0 then do; /* arg.pt points to basic structure */ instr (1) = full_epp2; call cobol_addr (arg.pt (i), instr_ptr, reloc_ptr); call cobol_pointer_register$get (pr2_struct_ptr); ic = 2; end; else if arg.type (i) < 4 then do; /* direct lower (1) or upper (2) in in arg.value(i) */ if arg.reg_sw (i) then reg = arg.reg (i); else reg = "110"b; /* use stack by default */ if arg.seg (i) = 0 then do; loc = reg || substr (unspec (stoff), 22, 15); if arg.overlay (i) then arg.seg (i) = stoff; stoff = stoff + 1; end; else loc = reg || substr (unspec (arg.seg (i)), 22, 15); if arg.type (i) < 3 then do; if arg.value (i) = (18)"0"b then instr (1) = loc || stz; else do; reg_struct.literal = arg.value (i); call cobol_register$load (reg_struct_ptr); a_or_q = fixed (reg_struct.reg_no, 4); if reg_struct.already_there = 0 then do; instr (1) = arg.value (i) || ld_ (a_or_q) || dmod (arg.type (i)); ic = ic + 1; end; instr (ic) = loc || st (a_or_q); end; ic = ic + 1; end; instr (ic) = loc || epp2; ic = ic + 1; end; else if arg.type (i) = 4 then do; /* link in seg|off */ call cobol_pointer_register$get (pr4_struct_ptr); instr (1) = "100"b || substr (unspec (arg.seg (i)), 22, 15) || epp2 || indmod; reloc (1) = "10100"b; if fixed_common.options.profile then do; fixup_directive.location.offset = cobol_$text_wd_off; call cobol_make_fixup (addr (fixup_directive)); end; if arg.off (i) ^= 0 then do; instr (2) = "010"b || substr (unspec (arg.off (i)), 22, 15) || epp2; ic = 3; end; else ic = 2; end; else if arg.type (i) = 5 then do; /* arg.pt points to a token */ if arg.pt (i) -> data_name.type = 9 then type9_ptr = arg.pt (i); else call cobol_make_type9$type2_3 (type9_ptr, arg.pt (i)); if arg.indirect (i) | args.arglist_off <= 0 | ^arg.repeat_nogen (i) then call cobol_set_pr (pr2_struct_ptr, type9_ptr); end; else if arg.type (i) = 6 then do; call cobol_pool (substr (arg.pt (i) -> varstring, 1, length (arg.pt (i) -> varstring)), 1, conoff); utemp = -(conoff + cobol_$text_wd_off); instr (1) = substr (unspec (utemp), 19, 18) || epp2_ || icmod; ic = 2; end; if arg.indirect (i) then do; /* not legal for type 4 */ if arg.off (i) = 0 then do; if mod (stoff, 2) = 1 then stoff = stoff + 1; loc = "110"b || substr (unspec (stoff), 22, 15); if arg.overlay (i) then arg.off (i) = stoff; stoff = stoff + 2; end; else loc = "110"b || substr (unspec (arg.off (i)), 22, 15); instr (ic) = loc || spri2; instr (ic + 1) = loc || epp2; ic = ic + 2; end; utemp = aloff + 2 * (i - k); instr (ic) = "110"b || substr (unspec (utemp), 22, 15) || spri2; if args.arglist_off > 0 then if arg.repeat_nogen (i) then ic = ic - 2; /* arglist already loaded */ if ic > 0 then call cobol_emit (instr_ptr, reloc_ptr, ic); do j = 1 to 11 by 2; reloc (j) = "00000"b; end; ic = 1; end; if descptr ^= null then do; ic = 1; j = aloff + 2 * (args.n + 1 - 2 * k); do i = k + 1 to args.n; call cobol_pool (addr (desc (i)) -> char4b, 1, off); utemp = -cobol_$text_wd_off - off - ic + 1; instr (ic) = substr (unspec (utemp), 19, 18) || epp2_ || icmod; /* THE FOLLOWING LINE (FOR PLACEMENT OF ARGUMENT DESCRIPTORS): utemp = j+2*(i-k); IS TEMPORARILY CHANGED (TO NEVER ALLOW FOR THE "OPTIONAL POINTER" FOR ENTRY VARIABLE CALLS) BY: */ utemp = j + 2 * i - 2; /*-04/02/76-*/ instr (ic + 1) = "110"b || substr (unspec (utemp), 22, 15) || spri2; ic = ic + 2; end; call cobol_emit (instr_ptr, null (), ic - 1); end; call cobol_pointer_register$call; instr (1) = "110"b || substr (unspec (aloff), 22, 15) || eax1; utemp = args.n - k; instr (2) = substr (unspec (utemp), 30, 7) || (11)"0"b || fld_ || dlmod; if k = 1 then do; /* non-io call */ if arg.type (1) = 6 then call cobol_make_link$type_4 (linkoff, substr (varstring, 1, length (varstring))); else linkoff = arg.seg (1); if fixed_common.options.profile then do; fixup_directive.location.offset = cobol_$text_wd_off + 2; call cobol_make_fixup (addr (fixup_directive)); end; instr (3) = "100"b || substr (unspec (linkoff), 22, 15) || epp2 || indmod; reloc (5) = "10100"b; ic = 4; opno = 3; end; else do; /* call to an iocb entry variable */ linksw = "0"b; if arg.type (1) = 4 then do; seg = arg.seg (1); off = arg.off (1); linksw = "1"b; end; else if arg.pt (1) -> basic_struct.seg < 0 then do; seg = -arg.pt (1) -> basic_struct.seg; off = -arg.pt (1) -> basic_struct.offset; linksw = "1"b; end; if linksw then do; /* external file - link to fsb */ /* THE FOLLOWING LINES TEMPORARILY DELETED (TO CALL iox_$name) */ /* instr(3) = "100"b||substr(unspec(seg),22,15)||epp2||indmod; /* reloc(5) = "10100"b; */ if args.arglist_off <= 0 | ^arg.repeat_nogen (1) then do; /* THE FOLLOWING LINES TEMPORARILY ADDED (TO CALL iox_$name) */ /**/ instr (3) = "100"b || substr (unspec (seg), 22, 15) || epp2 || indmod; /**/ reloc (5) = "10100"b; if fixed_common.options.profile then do; fixup_directive.location.offset = cobol_$text_wd_off + 2; call cobol_make_fixup (addr (fixup_directive)); end; utemp = aloff + 2; instr (4) = "110"b || substr (unspec (utemp), 22, 15) || spri2; ic = 5; end; /* else ic = 4; */ /**/ else ic = 3; /* THE FOLLOWING LINES TEMPORARILY DELETED (TO CALL iox_$name) */ /* instr(ic) = "010"b||substr(unspec(off),22,15)||epp2||indmod; /* ic = ic+1; */ end; else do; /* internal file - fsb in cobol data segment */ instr (3) = full_epp2; call cobol_addr (arg.pt (1), instr3_ptr, reloc5_ptr); if args.arglist_off <= 0 | ^arg.repeat_nogen (1) then do; utemp = aloff + 2; instr (4) = "110"b || substr (unspec (utemp), 22, 15) || spri2; ic = 5; end; else ic = 4; end; /* THE FOLLOWING LINES (FOR TRANSFERRING THROUGH THE ENTRY VARIABLE) */ /* instr(ic) = evad(args.entryno)||epp2; /* opno = 1; /* ARE TEMPORARILY REPLACED (TO CALL iox_$name) BY: */ /**/ call cobol_make_link$type_4 (linkoff, ename (args.entryno)); if fixed_common.options.profile then do; fixup_directive.location.offset = cobol_$text_wd_off + ic - 1; call cobol_make_fixup (addr (fixup_directive)); end; /**/ instr (ic) = "100"b || substr (unspec (linkoff), 22, 15) || epp2 || indmod; j = i * 2 - 1; /**/ reloc (j) = "10100"b; /**/ opno = 3; ic = ic + 1; end; if descptr = null () then opno = opno + 1; instr (ic) = entry_op (opno) || tsx0; call cobol_emit (instr_ptr, reloc_ptr, ic); call cobol_reset_r$after_call; if args.arglist_off < 0 then arglist_off = aloff; /* special meaning (for reuse of stack space) */ 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_fixed_common; %include cobol_ext_; end cobol_iocall;  cobol_ioerror.pl1 05/24/89 1041.5rew 05/24/89 0830.8 173988 /****^ *********************************************************** * * * 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_ioerror.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 01/31/77 by Bob Chang to implement profile option. */ /* Modified since Version 2.0. */ /* format: style3 */ cobol_ioerror: proc (ft_ptr, cobol_code, mcode_off, ioerror_ptr); dcl ft_ptr ptr; /* ptr to the file table */ dcl cobol_code fixed bin; /* cobol error code */ dcl mcode_off fixed bin; /* wd offset in stack of multics status code or 0 if none */ dcl ioerror_ptr ptr; /* ptr to additional error information */ /* 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 1 ioerror based (ioerror_ptr), 2 lineno fixed bin, 2 restartad fixed bin, 2 forward_tag fixed bin, 2 no_error_tag fixed bin, 2 no_error_ptr ptr, 2 unopen fixed bin, 2 special_tag fixed bin, 2 special_ptr ptr, 2 error_ptr ptr; dcl 1 s based, 2 n fixed bin, 2 link (0 refer (s.n)), 3 name char (32), 3 status2 char (4) aligned, 3 status1 char (2); dcl 1 mpout static, 2 n fixed bin init (0), 2 pt1 ptr, 2 pt2 ptr, 2 pt3 ptr, 2 pt4 ptr; dcl file_key_desc char (40) based; 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 fb (6) fixed bin init (0, 0, 0, 0, 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 type1 static, 2 size fixed bin init (28), 2 line fixed bin, /* line number */ 2 column fixed bin init (0), 2 type fixed bin init (1), 2 key fixed bin init (0), /* verb number */ 2 bits bit (36) init ("1"b), 2 jump_index fixed bin init (0); dcl 1 type19 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 (0), /* verb number */ 2 e fixed bin init (1), /* for both perform and move */ 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 type3 static, 2 size fixed bin init (28), 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), /* character string */ 2 all_lit bit (1) init ("0"b), /* not ALL lit */ 2 lit_size fixed bin init (4), 2 string char (4) init (""); dcl 1 type7 static, 2 size fixed bin init (52), 2 line fixed bin init (0), 2 column fixed bin init (0), 2 type fixed bin init (7), 2 string_ptr ptr init (null ()), 2 prev_rec ptr init (null ()), 2 bits1 bit (4) init (""b), 2 section_name bit (1) init ("1"b), 2 declarative_proc bit (1) init ("1"b), 2 bits2 bit (3) init (""b), 2 priority char (2) init ("00"), 2 bits3 bit (9) init (""b), 2 section_num fixed bin init (0), 2 proc_num fixed bin init (0), 2 def_line fixed bin init (0), 2 name_size fixed bin init (0); dcl 1 default_error_status static, 2 n fixed bin init (1), 2 link, 3 name char (32) init (""), 3 status2 char (4) init ("0030"), 3 status1 char (2) init ("30"); dcl 1 no_error_status static, 2 n fixed bin init (1), 2 link, 3 name char (32) init (""), 3 status2 char (4) init ("0000"), 3 status1 char (2) init ("00"); dcl tra_instr bit (36) static init ("000000000000000000111001000000000100"b); dcl tze_instr bit (36) static init ("000000000000000000110000000000000100"b); dcl tnz_instr bit (36) static init ("000000000000000000110000001000000100"b); dcl cmpa_dl_instr bit (36) static init ("000000000000000000001001101000000111"b); dcl cmpa_ind_instr bit (36) static init ("100000000000000000001001101001010000"b); dcl lda_instr bit (36) static init ("110000000000000000010011101001000000"b); dcl lda_mode (2) bit (36) static init ("001000000000000010010011101001000000"b, "000000000000110000011111101000000111"b); dcl link_reloc (2) bit (5) aligned static init ("10100"b, "00000"b); dcl preset_sw bit (1); /* used to comm between set_status and preset entry. */ dcl restart_ic fixed bin; dcl perform_ic fixed bin; dcl tag fixed bin; dcl next_instr_tag fixed bin; dcl ntag fixed bin; dcl pntag fixed bin; dcl temp fixed bin; dcl i fixed bin; dcl mode_count fixed bin; dcl off fixed bin; dcl line_no fixed bin; dcl fkey_ptr ptr; dcl lda_sw bit (1); dcl fsbptr_sw bit (1); dcl perform_mode_sw bit (1); dcl io_sw bit (1); dcl s1set bit (1); dcl s2set bit (2); dcl s1default char (2); dcl s1 char (2); dcl cobol_emit entry (ptr, ptr, fixed bin); dcl cobol_read_rand entry (fixed bin, char (5), ptr); dcl cobol_make_tagref entry (fixed bin, fixed bin, ptr); dcl cobol_make_link$type_4 entry (fixed bin, char (*)); dcl cobol_make_fixup entry (ptr); dcl cobol_define_tag entry (fixed bin); /* sub-generators */ dcl cobol_process_error entry (fixed bin, fixed bin, fixed bin); dcl cobol_process_error$use entry (fixed bin, fixed bin, fixed bin); dcl cobol_perform_gen entry (ptr); dcl cobol_move_gen entry (ptr); dcl cobol_set_fsbptr entry (ptr); /*************************************/ start: preset_sw = "0"b; /* set to zero unless preset entry is used. */ s1default = "**"; s1set, s2set = "0"b; line_no = ioerror.lineno; perform_ic = 0; next_instr_tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; if mcode_off = 0 then do; /* an error exists - no checking necessary */ if ioerror.special_ptr ^= null () then do; /* info assumed at ioerror.special_ptr->s.link(1) */ call set_status (ioerror.special_ptr, 1); if ioerror.special_tag ^= 0 then do; /* in-line errror coding specified */ call cobol_emit (addr (tra_instr), null (), 1); call cobol_make_tagref (ioerror.special_tag, cobol_$text_wd_off - 1, null ()); end; else call produce_error; end; else if ioerror.error_ptr ^= null () then do; /* info assumed at ioerror.error_ptr->s.link(1) */ call set_status (ioerror.error_ptr, 1); call produce_error; end; else do; call set_status (addr (default_error_status), 1); call produce_error; end; end; else do; /* must do error checking */ if ioerror.unopen = 2 then call set_status (addr (no_error_status), 1); /* a misnomer , means set 0 */ substr (lda_instr, 4, 15) = substr (unspec (mcode_off), 22, 15); call cobol_emit (addr (lda_instr), null (), 1); if ioerror.no_error_tag ^= 0 then tag = ioerror.no_error_tag; else tag = next_instr_tag; if ioerror.no_error_ptr = null () then do; /* only 0 signifies non-error code */ call cobol_emit (addr (tze_instr), null (), 1); call cobol_make_tagref (tag, cobol_$text_wd_off - 1, null ()); end; else do i = 1 to ioerror.no_error_ptr -> s.n; if ioerror.no_error_ptr -> s.link.name (i) = "" then do; /* indicates zero code */ substr (cmpa_dl_instr, 1, 18) = ""b; call cobol_emit (addr (cmpa_dl_instr), null (), 1); end; else do; /* must compare code to error_table_ value */ call cobol_make_link$type_4 (off, "error_table_$" || ioerror.no_error_ptr -> s.link.name (i)); if fixed_common.options.profile then do; fixup_directive.location.offset = cobol_$text_wd_off; call cobol_make_fixup (addr (fixup_directive)); end; substr (cmpa_ind_instr, 4, 15) = substr (unspec (off), 22, 15); call cobol_emit (addr (cmpa_ind_instr), addr (link_reloc (1)), 1); end; s1set = ^file_table.file_status | ioerror.no_error_ptr -> s.link.status1 (i) = "00"; s2set = ^file_table.extra_status | ioerror.no_error_ptr -> s.link.status2 (i) = "0000"; if s1set & s2set then do; /* status already set, so transfer out */ call cobol_emit (addr (tze_instr), null (), 1); call cobol_make_tagref (tag, cobol_$text_wd_off - 1, null ()); end; else do; ntag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_emit (addr (tnz_instr), null (), 1); call cobol_make_tagref (ntag, cobol_$text_wd_off - 1, null ()); call set_status (ioerror.no_error_ptr, i); call cobol_emit (addr (tra_instr), null (), 1); call cobol_make_tagref (tag, cobol_$text_wd_off - 1, null ()); call cobol_define_tag (ntag); end; end; s1set, s2set = "0"b; if file_table.file_status | ioerror.special_tag ^= 0 then do; s2set = "1"b; /* not really, just don't bother setting it now */ call set_status (addr (default_error_status), 1); s2set = "0"b; s1default = default_error_status.link.status1; if ioerror.special_ptr ^= null () then do i = 1 to ioerror.special_ptr -> s.n; ntag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; if ioerror.special_ptr -> s.link.name (i) = "" then do; substr (cmpa_dl_instr, 1, 18) = ""b; call cobol_emit (addr (cmpa_dl_instr), null (), 1); end; else do; call cobol_make_link$type_4 (off, "error_table_$" || ioerror.special_ptr -> s.link.name (i)); if fixed_common.options.profile then do; fixup_directive.location.offset = cobol_$text_wd_off; call cobol_make_fixup (addr (fixup_directive)); end; substr (cmpa_ind_instr, 4, 15) = substr (unspec (off), 22, 15); call cobol_emit (addr (cmpa_ind_instr), addr (link_reloc (1)), 1); end; call cobol_emit (addr (tnz_instr), null (), 1); call cobol_make_tagref (ntag, cobol_$text_wd_off - 1, null ()); call set_status (ioerror.special_ptr, i); if ioerror.special_tag ^= 0 then do; call cobol_emit (addr (tra_instr), null (), 1); call cobol_make_tagref (special_tag, cobol_$text_wd_off - 1, null ()); end; else call produce_error; call cobol_define_tag (ntag); end; if file_table.extra_status then do; if ioerror.error_ptr ^= null () then do i = 1 to ioerror.error_ptr -> s.n; ntag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; if ioerror.error_ptr -> s.link.name (i) ^= "" then do; /* otherwise the default */ call cobol_make_link$type_4 (off, "error_table_$" || ioerror.error_ptr -> s.link.name (i)); substr (cmpa_ind_instr, 4, 15) = substr (unspec (off), 22, 15); 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 (cmpa_ind_instr), addr (link_reloc (1)), 1); call cobol_emit (addr (tnz_instr), null (), 1); call cobol_make_tagref (ntag, cobol_$text_wd_off - 1, null ()) ; end; call set_status (ioerror.error_ptr, i); call produce_error; call cobol_define_tag (ntag); end; else do; /* shouldn't be necessary */ call set_status (addr (default_error_status), 1); call produce_error; end; end; else if ioerror.special_ptr = null () | ioerror.special_tag ^= 0 then do; call set_status (addr (default_error_status), 1); call produce_error; /* will have been done id special_ptr ^= null */ end; end; else call produce_error; end; call cobol_define_tag (next_instr_tag); return; /*************************************/ /* SUBROUTINES */ /*************************************/ produce_error: proc; if perform_ic ^= 0 then do; temp = perform_ic - cobol_$text_wd_off; substr (tra_instr, 1, 18) = substr (unspec (temp), 19, 18); call cobol_emit (addr (tra_instr), null (), 1); end; else do; perform_ic = cobol_$text_wd_off; if file_table.error_exit ^= 0 then call perform_use (file_table.error_exit); /* specific use proc */ else do; mode_count = 0; if ^file_table.external then do; /* can skip check for int file opened in only 1 mode */ if file_table.open_ext then mode_count = mode_count + 1; if file_table.open_in then mode_count = mode_count + 1; if file_table.open_out then mode_count = mode_count + 1; if file_table.open_io then mode_count = mode_count + 1; end; lda_sw, fsbptr_sw, perform_mode_sw, io_sw = "0"b; if fixed_common.extend_error_exit ^= 0 & ioerror.unopen ^= 1 then if (^file_table.external & file_table.open_ext) | (file_table.external & file_table.organization = 1 & (file_table.write | file_table.close | file_table.open_ext)) then call perform_mode (fixed_common.extend_error_exit, 0); if fixed_common.input_error_exit ^= 0 & ioerror.unopen ^= 1 then if (^file_table.external & file_table.open_in) | (file_table.external & (file_table.read | file_table.start | file_table.close | file_table.open_in)) then call perform_mode (fixed_common.input_error_exit, 16); if fixed_common.output_error_exit ^= 0 & ioerror.unopen ^= 1 then if (^file_table.external & file_table.open_out) | (file_table.external & (file_table.write | file_table.close | file_table.open_out)) then call perform_mode (fixed_common.output_error_exit, 48); if fixed_common.i_o_error_exit ^= 0 & ioerror.unopen ^= 1 then if (^file_table.external & file_table.open_io) | (file_table.external & (file_table.read | file_table.rewrite | file_table.start | file_table.delete | file_table.close | file_table.open_io)) then do; io_sw = "1"b; call perform_mode (fixed_common.i_o_error_exit, 32); end; if (mode_count ^= 1 & mode_count ^= 4) | ^perform_mode_sw then do; /* must provide fall-thru */ if ioerror.restartad ^= 0 then restart_ic = ioerror.restartad; else restart_ic = cobol_$text_wd_off; call cobol_process_error (cobol_code, line_no, mcode_off); temp = restart_ic - cobol_$text_wd_off; substr (tra_instr, 1, 18) = substr (unspec (temp), 19, 18); call cobol_emit (addr (tra_instr), null (), 1); end; end; end; return; perform_mode: proc (procno, mode); dcl procno fixed bin (17); dcl mode fixed bin; perform_mode_sw = "1"b; /* if not at least once, then must provide fall-thru */ if mode_count ^= 1 then do; pntag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; if mcode_off ^= 0 & ^fsbptr_sw then do; call cobol_set_fsbptr (ft_ptr); fsbptr_sw = "1"b; end; if ^lda_sw then do; call cobol_emit (addr (lda_mode), null (), 2); lda_sw = "1"b; end; if ^(mode_count = 4 & io_sw) then do; /* no need to compare - can just fall in */ substr (cmpa_dl_instr, 1, 18) = substr (unspec (mode), 19, 18); call cobol_emit (addr (cmpa_dl_instr), null (), 1); call cobol_emit (addr (tnz_instr), null (), 1); call cobol_make_tagref (pntag, cobol_$text_wd_off - 1, null ()); end; end; call perform_use (procno); if mode_count ^= 1 then call cobol_define_tag (pntag); return; end perform_mode; perform_use: proc (procno); dcl procno fixed bin; call cobol_process_error$use (cobol_code, line_no, mcode_off); /* record error message */ mpout.n = 4; mpout.pt1 = addr (type1); mpout.pt2, mpout.pt3 = addr (type7); mpout.pt4 = addr (type19); mpout.pt1 -> reserved_word.line = line_no; mpout.pt2 -> proc_def.proc_num = procno; mpout.pt3 -> end_stmt.verb = 20; /* perform */ call cobol_perform_gen (addr (mpout)); call cobol_emit (addr (tra_instr), null (), 1); if ioerror.forward_tag ^= 0 then tag = ioerror.forward_tag; else tag = next_instr_tag; call cobol_make_tagref (tag, cobol_$text_wd_off - 1, null ()); return; end perform_use; end produce_error; set_status: proc (type_ptr, eno); dcl type_ptr ptr; dcl eno fixed bin; if ^file_table.file_status then return; call cobol_read_rand (1, file_table.file_status_info, fkey_ptr); addr (fkey_type9.file_key_info) -> file_key_desc = file_key.desc; mpout.n = 4; mpout.pt1 = addr (type1); mpout.pt2 = addr (type3); mpout.pt3 = addr (fkey_type9); mpout.pt4 = addr (type19); mpout.pt1 -> reserved_word.line = line_no; mpout.pt2 -> alphanum_lit.size = 26; mpout.pt2 -> alphanum_lit.line = line_no; mpout.pt2 -> alphanum_lit.lit_size = 2; s1 = type_ptr -> s.link.status1 (eno); substr (mpout.pt2 -> alphanum_lit.string, 1, 2) = s1; mpout.pt4 -> end_stmt.verb = 18; /* move */ if ^s1set & s1default ^= s1 then call cobol_move_gen (addr (mpout)); if ^file_table.extra_status | s2set then goto end_set_status; call cobol_read_rand (1, file_table.extra_status_info, fkey_ptr); addr (fkey_type9.file_key_info) -> file_key_desc = file_key.desc; mpout.pt2 -> alphanum_lit.size = 28; mpout.pt2 -> alphanum_lit.lit_size = 4; substr (mpout.pt2 -> alphanum_lit.string, 1, 4) = type_ptr -> s.link.status2 (eno); call cobol_move_gen (addr (mpout)); /*set status entered by preset entry don't execute next two instr's. */ end_set_status: if ^preset_sw then do; substr (lda_instr, 4, 15) = substr (unspec (mcode_off), 22, 15); call cobol_emit (addr (lda_instr), null (), 1); end; return; end set_status; /*************************************/ preset: entry (ft_ptr); preset_sw = "1"b; /* set to signal set_status to skip two instr's. */ s1set, s2set = "0"b; s1default = "**"; line_no = 0; call set_status (addr (no_error_status), 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_file_table; %include cobol_file_key; %include cobol_type1; %include cobol_type3; %include cobol_type7; %include cobol_type19; %include cobol_; %include cobol_ext_; %include cobol_fixed_common; end cobol_ioerror;  cobol_ioerror_abort.pl1 05/24/89 1041.5rew 05/24/89 0830.7 45288 /****^ *********************************************************** * * * 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_ioerror_abort.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 02/10/81 by FCH, [4.4-1], tra instr not emitted in certain cases, [4.4-1], BUG462(TR8970) */ /* format: style3 */ cobol_ioerror_abort: proc (mesno, lineno, stoff, restartad, exlink); dcl mesno fixed bin; /* number of cobol error message */ dcl lineno fixed bin; /* line on which error occurred */ dcl stoff fixed bin; /* word offset in stack of code */ dcl restartad fixed bin; /* restartad for restart transfer */ dcl exlink fixed bin; /* extra error code to check */ dcl 1 pr4_struct static, 2 pr4 fixed bin init (4), 2 pointer_no bit (3), 2 lock fixed bin init (0), 2 switch fixed bin init (1), 2 segno fixed bin init (3002), 2 offset fixed bin init (0), 2 reset fixed bin; dcl 1 areg_struct static, 2 areg fixed bin init (1), 2 reg_no bit (4), 2 lock fixed bin init (0), 2 already_there fixed bin, 2 contains fixed bin init (0), 2 null_ptr ptr init (null ()), 2 lit fixed bin; dcl instr (3) bit (36); dcl reloc (6) bit (5) aligned static init ("10100"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b); dcl szn bit (12) static init ("010011100001"b); dcl cmpa bit (12) static init ("001001101001"b); dcl lda bit (12) static init ("010011101001"b); dcl tra_icmod bit (18) static init ("111001000000000100"b); dcl tnz_icmod bit (18) static init ("110000001000000100"b); dcl full_tze_icmod bit (36) static init ("000000000000000100110000000000000100"b); dcl indmod bit (6) static init ("010000"b); dcl utemp fixed bin; dcl hold_ic fixed bin static init (0); dcl hold_addr bit (18) based; dcl instr_ptr ptr; dcl cobol_process_error entry (fixed bin, fixed bin, fixed bin); dcl cobol_emit entry (ptr, ptr, fixed bin); dcl cobol_pointer_register$get entry (ptr); dcl cobol_register$load entry (ptr); /*************************************/ start: instr_ptr = addr (instr); instr (1) = "110"b || substr (unspec (stoff), 22, 15) || szn; if restartad = 0 then do; if exlink > 0 then instr (2) = full_tze_icmod; else do; utemp = hold_ic - cobol_$text_wd_off; instr (2) = substr (unspec (utemp), 19, 18) || tnz_icmod; end; if stoff > 0 then call cobol_emit (instr_ptr, null (), 2); if exlink > 0 then do; call cobol_pointer_register$get (addr (pr4_struct)); call cobol_register$load (addr (areg_struct)); instr (2) = substr (instr (1), 1, 18) || cmpa; instr (1) = "100"b || substr (unspec (exlink), 22, 15) || lda || indmod; utemp = hold_ic + 2 - cobol_$text_wd_off; instr (3) = substr (unspec (utemp), 19, 18) || tnz_icmod; call cobol_emit (instr_ptr, addr (reloc), 3); end; end; else do; if stoff > 0 then do; instr (2) = full_tze_icmod; hold_ic = cobol_$text_wd_off + 1; call cobol_emit (instr_ptr, null (), 2); if exlink > 0 then do; call cobol_pointer_register$get (addr (pr4_struct)); call cobol_register$load (addr (areg_struct)); instr (2) = substr (instr (1), 1, 18) || cmpa; instr (1) = "100"b || substr (unspec (exlink), 22, 15) || lda || indmod; instr (3) = full_tze_icmod; call cobol_emit (instr_ptr, addr (reloc), 3); end; end; call cobol_process_error (mesno, lineno, stoff); utemp = restartad - cobol_$text_wd_off; instr (1) = substr (unspec (utemp), 19, 18) || tra_icmod; /*[4.4-1]*/ if stoff ^= 0 | exlink ^= 0 then call cobol_emit (instr_ptr, null (), 1); if stoff > 0 then do; utemp = cobol_$text_wd_off - hold_ic; addrel (cobol_$text_base_ptr, hold_ic) -> hold_addr = substr (unspec (utemp), 19, 18); utemp = utemp - 3; if exlink > 0 then addrel (cobol_$text_base_ptr, hold_ic + 3) -> hold_addr = substr (unspec (utemp), 19, 18); end; end; 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_ioerror_abort;  cobol_iomode.pl1 05/24/89 1041.5rew 05/24/89 0830.7 52398 /****^ *********************************************************** * * * 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_iomode.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 04/02/77 by GM to check for device 2 and set organization to 4 */ /* Modified on 01/14/77 by ORN to signal command_abort_ rather than cobol_compiler_error */ /* modified since Version 2.0 */ /* format: style3 */ cobol_iomode: proc (ft_ptr, eos_ptr, cobol_mode, multics_mode, extend_sw); dcl cobol_mode fixed bin; dcl multics_mode fixed bin; dcl extend_sw bit (1) aligned; /***********************************************/ /* SEQUENTIAL RANDOM DYNAMIC STREAM Input 21,1,1st_byte Output 61,2,eof Extend 01,2,eof(*) SEQUENTIAL Input 25,4,1st_rec Output 65,5,eof I-O 45,7,1st_rec Extend 05,6,eof(*,**) RELATIVE Input 31,8,1st_rec 32,11,- 33,8,1st_rec Output 71,9,eof 72,12,- 73,10,1st_rec(**,***) I-O 51,10,1st_rec 52,13,- 53,10,1st_rec INDEXED Input 35,8,1st_rec 36,11,- 37,8,1st_rec Output 75,9,eof 76,12,- 77,10,1st_rec(**,***) I-O 55,10,1st_rec 56,13,- 57,10,1st_rec * extend_sw = "1"b ** reads are prevented by run-time check *** positioned to eof by special action at open /***********************************************/ /* KEY TO cobol_mode: "MMOOAA"b MM (mode): 00 extend 01 input 10 i/o 11 output OO (organization): 00 stream 01 sequential 10 relative 11 indexed AA (access method): 00 invalid 01 sequential 10 random 11 dynamic MEANINGFUL cobol_modes: 1 01,2 5 05,6 17 21,1 21 25,4 25 31,8 26 32,11 27 33,8 29 35,8 30 36,11 31 37,8 37 45,7 41 51,10 42 52,13 43 53,10 45 55,10 46 56,13 47 57,10 49 61,2 53 65,5 57 71,9 58 72,12 59 73,10 61 75,9 62 76,12 63 77,10 */ dcl mode (3 /*access*/, 4 /*organization*/, 0:3 /*mode*/, 2 /*cobol_mode,multics_mode*/) fixed bin static init (/* access: (1)sequential, (2)random, (3)dynamic organization: (1)sequential, (2)relative, (3)indexed, (4)stream mode: (0)input, (1)output, (2)i/o, (3)extend */ /* INPUT OUTPUT I/O EXTEND */ /* SEQUENTIAL SEQUENTIAL */ 21, 4, 53, 5, 37, 7, 5, 6, /**/ /* SEQUENTIAL RELATIVE */ 25, 8, 57, 9, 41, 10, 0, 0, /* SEQUENTIAL INDEXED */ 29, 8, 61, 9, 45, 10, 0, 0, /* SEQUENTIAL STREAM */ 17, 1, 49, 2, 0, 0, 1, 2, /**/ /* RANDOM SEQUENTIAL */ 0, 0, 0, 0, 0, 0, 0, 0, /* RANDOM RELATIVE */ 26, 11, 58, 12, 42, 13, 0, 0, /* RANDOM INDEXED */ 30, 11, 62, 12, 46, 13, 0, 0, /* RANDOM STREAM */ 0, 0, 0, 0, 0, 0, 0, 0, /* DYNAMIC SEQUENTIAL */ 0, 0, 0, 0, 0, 0, 0, 0, /* DYNAMIC RELATIVE */ 27, 8, 59, 10, 43, 10, 0, 0, /* DYNAMIC INDEXED */ 31, 8, 63, 10, 47, 10, 0, 0, /* DYNAMIC STREAM */ 0, 0, 0, 0, 0, 0, 0, 0); dcl 1 error_info, 2 name char (32), 2 meslen fixed bin, 2 mes char (120); dcl ioa_$rsnnl entry options (variable); dcl signal_ entry (char (*), ptr, ptr); dcl access_con (3) char (10) static init ("sequential", "random", "dynamic"); dcl org_con (4) char (10) static init ("sequential", "relative", "indexed", "stream"); dcl mode_con (0:3) char (6) static init ("input", "output", "i-o", "extend"); dcl access fixed bin; dcl org fixed bin; dcl open_mode fixed bin; dcl ft_ptr ptr; /*************************************/ start: if file_table.organization = 5 then file_table.organization = 4; /* temporary */ open_mode = fixed (end_stmt.d, 2); if file_table.device = 2 then file_table.organization = 4; if (file_table.device = 1 | file_table.device = 3) & file_table.organization = 1 then org = 4; else org = file_table.organization; access = file_table.access; if access = 0 then access = 1; cobol_mode = mode (access, org, open_mode, 1); multics_mode = mode (access, org, open_mode, 2); if cobol_mode = 0 then go to error; if cobol_mode < 6 then extend_sw = "1"b; else extend_sw = "0"b; return; /*************************************/ error: error_info.name = "cobol_iomode"; call ioa_$rsnnl ("Attempt to open file ^a in inconsistent mode - access: ^a; organization: ^a; mode: ^a", error_info.mes, error_info.meslen, file_table.ifn, access_con (access), org_con (org), mode_con (open_mode)); call signal_ ("command_abort_", null (), addr (error_info)); return; /*************************************/ translate: entry (inmode, outmode, outbit); dcl inmode fixed bin; dcl outmode fixed bin; dcl outbit bit (1) aligned; start_translate: open_mode = fixed (substr (unspec (inmode), 31, 2), 2); org = fixed (substr (unspec (inmode), 33, 2), 2); access = fixed (substr (unspec (inmode), 35, 2), 2); outmode = mode (access, org, open_mode, 2); if outmode < 6 then outbit = "1"b; else outbit = "0"b; 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_type19; %include cobol_file_table; end cobol_iomode;  cobol_ioop_util.pl1 05/24/89 1041.5rew 05/24/89 0830.7 76500 /****^ *********************************************************** * * * 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_ioop_util.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 12/17/80 by FCH, [4.4-1], dimension of array changed from 3 to 1 to prevent severity 3 error */ /* Modified on 04/28/77 by GM to implement LOCK entry */ /* Modified on 11/13/76 by GM to fix LINAGE problems. */ /* Modified on 10/2/76 by GM to fix bug on LINAGE. */ /* Modified on 7/28/76 by George Mercuri to add set_x5 entry */ /* Modified on 7/9/76 by George Mercuri to add set_icode entry */ /* Modified on 6/14/76 by George Mercuri for change to access of stack offset in open_gen.*/ /* Modified on 6/3/76 by George Mercuri for multics_mode code.*/ /* Modified on 5/24/76 by George Mercuri for addition of lda generation. */ /* Modified on 5/18/76 by George Mercuri for error interface. */ /* Modified on 5/10/76 by George Mercuri for change to error handling. */ /* Modified on 5/5/76 by George Mercuri for error handling techniques. */ /* Created on 4/29/76 by George Mercuri for the call to DISPLAY operators. */ /* format: style3 */ cobol_ioop_util: proc (stoff); disp: entry (stoff); dcl tag_off fixed bin; dcl aloff fixed bin; dcl stoff fixed bin; dcl temp fixed bin; dcl cobol_mode fixed bin; dcl multics_mode fixed bin; dcl ft_ptr ptr; /*[4.4-1]*/ dcl disp_instr (1) bit (36) static init ("110000000000000000011111001101000000"b); /* epp5 pr6| */ dcl disp_reloc (2) bit (5) aligned static init (""b, ""b); dcl stz_instr (1) bit (36) static init ("110000000000101100100101000001000000"b); /* stz pr6|54 */ dcl ldaldx5_instr (2) bit (36) static init ("000000000000000000010011101000000111"b, /* lda ,dl */ "000000000000000000010010101000000011"b); /* ldx5 ,dl */ dcl fsb_open_mode_instr (3) bit (36) static init ("000000000000000000010011101000000111"b, /* lda [cobol_mode],dl */ "000000000000000000010011110000000011"b, /* ldq [optional/opened/how,du] */ "000000000000000000111010101000000111"b); /* lxl5 [multics_code],dl */ dcl lda_instr (1) bit (36) static init ("000000000000000000010011101000000111"b); /* lda ,dl */ dcl lda_du_instr (1) bit (36) static init ("000000000000000000010011101000000011"b); /* lda offset,du */ dcl tra_instr (1) bit (36) static init ("000000000000000000111001000000000100"b); /* tra ioerror.ns_tag,ic */ dcl set_icode_instr (1) bit (36) static init ("110000000000101001000101100001000000"b); /* aos pr6|icode(51) */ dcl set_value_instr (2) bit (36) static init ("000000000000000000010011101000000111"b, /* lda advancing_value,dl */ "110000000000101111111101101001000000"b); /* sta pr6|57 */ dcl set_var_adv_instr (1) bit (36) static init ("110000000000101111111101110001000000"b); /* stq pr6|57 */ dcl set_fsb_instr (2) bit (36) static init ("000000000000000000010011101000000111"b, /* lda linage_type,dl */ "001000000000000000111101101001000000"b); /* sta pr1|fsb_offset */ dcl set_x5_instr (1) bit (36) static init ("000000000000000000010010101000000011"b); /* ldx5 io_error_no,dl */ dcl bypass_reset (2) bit (36) static init ("000000000000000001001000011000000011"b, /* cmpx3 1,du */ "000000000000000000110000001000000100"b); /* tra ,ic */ dcl ldalock (2) bit (36) static init ("000000000000000000010011101000000100"b, /* lda 0,ic */ "001000000001011010010101101001000000"b); /* orsa pr1|90 */ dcl cobol_emit entry (ptr, ptr, fixed bin); /***************************************/ start: substr (disp_instr (1), 4, 15) = substr (unspec (stoff), 22, 15); call cobol_emit (addr (disp_instr), addr (disp_reloc), 1); return; /***************************************/ set_stz: entry; call cobol_emit (addr (stz_instr), null (), 1); return; /****************************************/ ldaldx5: entry (ioname_len, aloff); dcl ioname_len fixed bin; substr (ldaldx5_instr (1), 4, 15) = substr (unspec (ioname_len), 22, 15); substr (ldaldx5_instr (2), 4, 15) = substr (unspec (aloff), 22, 15); call cobol_emit (addr (ldaldx5_instr), null (), 2); return; /****************************************/ open_clean_up: entry (ft_ptr, cobol_mode, multics_mode); substr (fsb_open_mode_instr (1), 1, 18) = substr (unspec (cobol_mode), 19, 18); if file_table.optional & file_table.external then temp = 81920; else if file_table.optional & ^file_table.external then temp = 98304; else if file_table.external then temp = 32768; else temp = 49152; substr (fsb_open_mode_instr (2), 1, 18) = substr (unspec (temp), 19, 18); substr (fsb_open_mode_instr (3), 1, 18) = substr (unspec (multics_mode), 19, 18); call cobol_emit (addr (fsb_open_mode_instr), null (), 3); return; /****************************************/ lda: entry (cobol_mode); substr (lda_instr (1), 4, 15) = substr (unspec (cobol_mode), 22, 15); call cobol_emit (addr (lda_instr), null (), 1); return; /****************************************/ lda_du: entry (stoff); substr (lda_du_instr (1), 1, 18) = substr (unspec (stoff), 19, 18); call cobol_emit (addr (lda_du_instr), null (), 1); return; /****************************************/ tra: entry (tag_off); substr (tra_instr (1), 1, 18) = substr (unspec (tag_off), 19, 18); call cobol_emit (addr (tra_instr), null (), 1); return; /****************************************/ set_icode: entry; call cobol_emit (addr (set_icode_instr), null (), 1); return; /****************************************/ set_value: entry (advancing_value); dcl advancing_value fixed bin; substr (set_value_instr (1), 1, 18) = substr (unspec (advancing_value), 19, 18); call cobol_emit (addr (set_value_instr), null (), 2); return; /****************************************/ set_fsb: entry (linage_type, fsb_offset); dcl linage_type fixed bin; dcl fsb_offset fixed bin; substr (set_fsb_instr (1), 1, 18) = substr (unspec (linage_type), 19, 18); substr (set_fsb_instr (2), 4, 15) = substr (unspec (fsb_offset), 22, 15); call cobol_emit (addr (set_fsb_instr), null (), 2); return; /****************************************/ set_var_adv: entry; call cobol_emit (addr (set_var_adv_instr), null (), 1); return; /****************************************/ set_x5: entry (io_error_no); dcl io_error_no fixed bin; substr (set_x5_instr (1), 1, 18) = substr (unspec (io_error_no), 19, 18); call cobol_emit (addr (set_x5_instr), null (), 1); return; /***************************************/ bypass_reset: entry (skip_tag); dcl skip_tag fixed bin; dcl cobol_make_tagref entry (fixed bin, fixed bin, ptr); call cobol_emit (addr (bypass_reset), null (), 2); call cobol_make_tagref (skip_tag, cobol_$text_wd_off - 1, null ()); return; /***************************************/ set_lock: entry; dcl lock_bit bit (36) static init ("000010000000000000000000000000000000"b); dcl lock_char char (4) based (addr (lock_bit)); dcl cobol_pool entry (char (*), fixed bin, fixed bin); dcl con_off fixed bin; call cobol_pool (lock_char, 1, con_off); temp = -cobol_$text_wd_off - con_off; substr (ldalock (1), 1, 18) = substr (unspec (temp), 19, 18); call cobol_emit (addr (ldalock), null (), 2); return; /****** Declaration for Builtin function *****/ dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index) builtin; /***** End of declaration dor builtin function *****/ %include cobol_file_table; %include cobol_; end cobol_ioop_util;  cobol_linage.pl1 05/24/89 1041.5rew 05/24/89 0830.7 181980 /****^ *********************************************************** * * * 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_linage.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 02/10/81 by FCH, cobol_abort_error changed not to emit tra instr, [4.4-1], BUG462(TR8970) */ /* Modified on 08/23/80 by FCH, [4.3-1], after advancing data-name with linage clause generates bad code, BUG441(SQ431) */ /* Modified since Version 4.3 */ /* format: style3 */ cobol_linage: proc (ft_ptr, mp_ptr, buflen_off, buf_off, ioerror_ptr); dcl page_sw bit (1) init ("0"b); dcl ioerror_ptr ptr; dcl pr5_struct_ptr ptr; dcl ft_ptr ptr; dcl mp_ptr ptr; dcl good_tag fixed bin; dcl advancing_count fixed bin; dcl buflen_off fixed bin; /* stack offset in words (input) */ dcl buf_off fixed bin; /* stack offset in words (output) */ dcl 1 mp based (mp_ptr), 2 n fixed bin, 2 pt (0 refer (mp.n)) ptr; dcl linage_before bit (1); dcl mrl bit (36) static init ("000000000000000000001000001100000000"b); dcl mlr bit (36) static init ("000000000000000000001000000100000000"b); dcl mlr_q bit (36) static init ("000001101001000110001000000100000000"b); dcl szn bit (12) static init ("010011100001"b); dcl aos bit (12) static init ("000101100001"b); dcl lxl5 bit (12) static init ("111010101001"b); dcl adq bit (12) static init ("000111110001"b); dcl stq bit (12) static init ("111101110001"b); dcl lda bit (12) static init ("010011101001"b); dcl ldq bit (12) static init ("010011110001"b); dcl sbq bit (12) static init ("001111110001"b); dcl adq_dlmod bit (18) static init ("000111110000000111"b); dcl ldq_dlmod bit (18) static init ("010011110000000111"b); dcl ldq_dumod bit (18) static init ("010011110000000011"b); dcl tra_icmod bit (18) static init ("111001000000000100"b); dcl tnz_icmod bit (18) static init ("110000001000000100"b); dcl num_check_instr (4) bit (36) static init ("110000000001010000010011101001000000"b, /* lda pr6|120 */ "110000000000110001010011110001000000"b, /* ldq pr6|lenoff */ "000000000001111001001001110000000111"b, /* cmpq 171,dl */ "000000000000000000110000100000000100"b); /* tmi [bypass_error]);ic */ dcl 1 ioerror based (ioerror_ptr), 2 cobol_code fixed bin, 2 retry_tag fixed bin, 2 is_tag fixed bin, 2 ns_tag fixed bin, 2 type1_ptr ptr, 2 mode fixed bin; dcl 1 pr5_struct static, 2 pr5 fixed bin init (5), 2 pointer_no bit (3), 2 lock fixed bin init (0), 2 switch fixed bin init (0), 2 segno fixed bin init (0), 2 offset fixed bin init (0), 2 reset fixed bin; dcl 1 mlr_struct, 2 type fixed bin init (5), 2 operand_no fixed bin init (2), 2 lock fixed bin init (0), 2 operand1, 3 token_ptr ptr, /* always set */ 3 send_receive fixed bin init (0), 3 ic_mod fixed bin, 3 size_sw fixed bin init (1), 2 operand2, 3 token_ptr ptr init (null ()), 3 send_receive fixed bin, 3 ic_mod fixed bin, 3 size_sw fixed bin; dcl 1 zero_token static, /*06-16-77*/ 2 size fixed bin init (40), /*06-16-77*/ 2 line fixed bin init (0), /*06-16-77*/ 2 column fixed bin init (0), /*06-16-77*/ 2 type fixed bin init (2), /*06-16-77*/ 2 integral bit (1) init ("0"b), /*06-16-77*/ 2 floating bit (1) init ("0"b), /*06-16-77*/ 2 seg_range bit (1) init ("0"b), /*06-16-77*/ 2 filler1 bit (4) init ("0"b), /*06-16-77*/ 2 subscript bit (1) init ("0"b), /*06-16-77*/ 2 sign char (1) init ("0"), /*06-16-77*/ 2 exp_sign char (1) init ("0"), /*06-16-77*/ 2 exp_places fixed bin init (0), /*06-16-77*/ 2 places_left fixed bin init (0), /*06-16-77*/ 2 places_right fixed bin init (0), /*06-16-77*/ 2 places fixed bin init (1), /*06-16-77*/ 2 literal char (1) init ("0"); dcl instr (6) bit (36); dcl text (0:100000) bit (36) based (cobol_$text_base_ptr); /* slew characters. 03-02-77 */ dcl pr_ctl char (5) static int init ("c "); dcl chan_no fixed bin; dcl convert_no (10:16) char (2) static int init ("10", "11", "12", "13", "14", "15", "16"); dcl convert_no1 (9) char (1) static int init ("1", "2", "3", "4", "5", "6", "7", "8", "9"); dcl nls char (120) static init ((120)" "); dcl advancing_error fixed bin static init (23); dcl len_off fixed bin static init (49); dcl dn_ptr ptr; dcl name_ptr ptr; dcl dn_ptr_linage ptr; dcl instr_ptr ptr; dcl mlr_struct_ptr ptr; dcl bnum fixed bin; dcl anum fixed bin; dcl ba_sw fixed bin; dcl bvalue bit (18) aligned; dcl avalue bit (18) aligned; dcl temp fixed bin; dcl utemp fixed bin; dcl restartad fixed bin; dcl patch_ic fixed bin; dcl cobol_define_tag entry (fixed bin); dcl cobol_pool entry (char (*), fixed bin, fixed bin); dcl cobol_set_pr entry (ptr, ptr); dcl cobol_call_op entry (fixed bin, fixed bin); dcl cobol_gen_ioerror entry (ptr, ptr); dcl cobol_ioop_util$set_var_adv entry; dcl cobol_ioop_util$set_value entry (fixed bin); dcl signal_ entry (char (*), ptr, ptr); dcl cobol_alloc$stack entry (fixed bin, fixed bin, fixed bin); dcl cobol_emit entry (ptr, ptr, fixed bin); dcl cobol_addr entry (ptr, ptr, ptr); dcl ioa_$rsnnl entry options (variable); /* sub-generators */ dcl cobol_io_util$move_direct entry (bit (3) aligned, fixed bin, fixed bin, fixed bin, bit (18) aligned); dcl cobol_io_util$fixed_add entry (bit (3) aligned, fixed bin, fixed bin, bit (3) aligned, fixed bin); dcl cobol_io_util$move_lit entry (bit (3) aligned, fixed bin, fixed bin, char (*)); dcl cobol_io_util$t9dec_to_bin entry (bit (3) aligned, fixed bin, ptr); dcl cobol_ioerror_abort entry (fixed bin, fixed bin, fixed bin, fixed bin, fixed bin); /*************************************/ /* Note: code is generated under the assumption that the A register is set with the length of the sending field unless the item has variable length. */ start: linage_before = "0"b; dn_ptr = mp.pt (mp.n - 1); dn_ptr_linage = mp.pt (mp.n - 2); eos_ptr = mp.pt (mp.n); mlr_struct.operand1.token_ptr = mp.pt (2); if ^file_table.variable then mp.pt (2) -> data_name.variable_length = "0"b; instr_ptr = addr (instr); mlr_struct_ptr = addr (mlr_struct); pr5_struct_ptr = addr (pr5_struct); good_tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; if data_name.type = 17 then call cobol_alloc$stack (121, 2, buf_off); /* allocate 121 only*/ else call cobol_alloc$stack (data_name.item_length + 120, 2, buf_off); /* allow up to 120 new-lines */ start_codegen: anum, bnum = 0; if buflen_off = 0 then do; /* special call from cobol_open_gen to output first TOP skips for linage. */ call move_buf_con; return; end; if data_name.type = 1 then /*06-16-77*/ if dn_ptr -> reserved_word.key = reswd_ZERO then /*06-16-77*/ dn_ptr = addr (zero_token); /*06-16-77*/ if end_stmt.d = "00"b then do; /* no ADVANCING clause - same as AFTER 1 */ dn_ptr_linage = mp.pt (mp.n - 1); if file_table.device = 1 then do; /* COBOL rules - after advancing 1 */ bvalue = "000001010000001010"b; bnum = 1; end; else do; /* MULTICS rules - before advancing 1 */ avalue = "000001010000001010"b; anum = 1; end; call move_buf_con; end; else if end_stmt.d = "10"b then do; /* AFTER ADVANCING ... specified */ if data_name.type = 2 then do; /* AFTER ADVANCING literal */ bnum = fixed (dn_ptr -> numeric_lit.literal, 17); if bnum > 120 then go to litsize_error; bvalue = "000001010000001010"b; call move_buf_con; end; else if data_name.type = 9 then do; /* AFTER ADVANCING data-name */ ba_sw = 0; call move_buf_var; end; else if data_name.type = 1 | data_name.type = 17 then do; /* AFTER ADVANCING PAGE or mnemonic-name */ if data_name.type = 17 | (data_name.type = 1 & ^file_table.linage) then do; chan_no = dn_ptr -> mnemonic_name.iw_key - 210; if chan_no < 17 & chan_no > 9 then do; bnum = 5; substr (pr_ctl, 3, 2) = convert_no (chan_no); end; else if chan_no > 0 & chan_no < 10 then do; bnum = 4; substr (pr_ctl, 3, 2) = convert_no1 (chan_no) || ""; end; else do; bvalue = "000001100"b; bnum = 1; end; call move_buf_con; end; else if file_table.linage then do; bvalue = "000001010"b; bnum = 1; page_sw = "1"b; call move_buf_con; end; end; end; else do; /* BEFORE ADVANCING ... specified */ linage_before = "1"b; if data_name.type = 2 then do; /* BEFORE ADVANCING literal */ avalue = "000001010"b; anum = fixed (dn_ptr -> numeric_lit.literal, 17); if anum > 120 then go to litsize_error; call move_buf_con; end; else if data_name.type = 9 then do; /* BEFORE ADVANCING data-name */ ba_sw = 1; call move_buf_var; end; else if data_name.type = 1 | data_name.type = 17 then do; /* BEFORE ADVANCING PAGE or mnemonic-name */ if data_name.type = 17 | (data_name.type = 1 & ^file_table.linage) then do; chan_no = dn_ptr -> mnemonic_name.iw_key - 210; if chan_no < 17 & chan_no > 9 then do; anum = 5; substr (pr_ctl, 3, 2) = convert_no (chan_no); end; else if chan_no > 0 & chan_no < 10 then do; anum = 4; substr (pr_ctl, 3, 2) = convert_no1 (chan_no) || ""; end; else do; avalue = "000001100"b; anum = 1; end; call move_buf_con; end; else if file_table.linage then do; avalue = "000001010"b; anum = 1; page_sw = "1"b; call move_buf_con; end; end; end; exit: return; /*************************************/ /* SUBROUTINES */ /*************************************/ move_buf_con: proc; /* LINAGE CODE FOLLOWS */ if file_table.linage & buflen_off ^= 0 then do; call cobol_set_pr (pr5_struct_ptr, dn_ptr_linage); if page_sw then call cobol_ioop_util$set_value (1000); /* temp high value for PAGE */ else call cobol_ioop_util$set_value (bnum + anum); call cobol_call_op (52, good_tag); /* LINAGE_OP */ call cobol_gen_ioerror (ft_ptr, ioerror_ptr); call cobol_define_tag (good_tag); end; /* else call cobol_ioop_util$set_value(0); */ /* no linage clause specified */ if bnum > 0 then do; if bnum < 3 then call cobol_io_util$move_direct ("110"b, buf_off * 4, 4, 0, bvalue); else if data_name.type = 17 then call cobol_io_util$move_lit ("110"b, buf_off * 4, bnum, substr (pr_ctl, 1, bnum)); else call cobol_io_util$move_lit ("110"b, buf_off * 4, bnum, substr (nls, 1, bnum)); instr (1) = "110"b || substr (unspec (buflen_off), 22, 15) || lda; call cobol_emit (instr_ptr, null (), 1); end; else if file_table.rec_do then do; /* in this case A will not be already set */ instr (1) = "110"b || substr (unspec (buflen_off), 22, 15) || lda; call cobol_emit (instr_ptr, null (), 1); end; if anum = 0 then if file_table.device = 1 then do; /*print file - append CR if necessary */ anum = 1; if file_table.linage then avalue = "000001010"b; /* octal 012 top bottom */ else avalue = "000001101"b; /* octal 015 = Carriage Return */ end; if anum > 0 then do; if file_table.linage then do; if bnum = 0 then do; temp = 5130; instr (1) = substr (unspec (temp), 19, 18) || ldq_dumod; temp = buf_off * 4 + 1; instr (2) = "110"b || substr (unspec (temp), 22, 15) || stq; call cobol_emit (instr_ptr, null (), 2); end; temp = buflen_off + 1; instr (1) = "110"b || substr (unspec (temp), 22, 15) || ldq; call cobol_emit (instr_ptr, null (), 1); end; else if data_name.type ^= 17 | anum = 1 then do; instr (1) = substr (unspec (anum), 19, 18) || ldq_dlmod; instr (2) = "110"b || substr (unspec (buflen_off), 22, 15) || adq; call cobol_emit (instr_ptr, null (), 2); end; end; if file_table.linage & ^linage_before then do; instr (1) = mrl; temp = buf_off * 4; end; else do; instr (1) = mlr; temp = buf_off * 4 + bnum; end; call cobol_addr (mlr_struct_ptr, instr_ptr, null ()); substr (instr (3), 1, 20) = "110"b || substr (unspec (temp), 20, 17); substr (instr (2), 21, 16) = "0000000000000101"b; /* sending length in A */ substr (instr (1), 12, 2) = "11"b; /* length of receiving in A or Q */ substr (instr (1), 31, 1) = "1"b; /* length of sending in A */ if anum = 0 then substr (instr (3), 21, 16) = substr (instr (2), 21, 16); else do; substr (instr (1), 1, 9) = avalue; substr (instr (3), 21, 16) = "0000000000000110"b; end; if data_name.type = 17 & anum > 1 then do; substr (instr (1), 1, 9) = "000000000"b; substr (instr (3), 21, 16) = "0000000000000101"b; call cobol_emit (addr (instr (1)), null (), 3); call cobol_pool (substr (pr_ctl, 1, anum), 1, temp); substr (instr (1), 12, 7) = "1000101"b; substr (instr (1), 30, 7) = "0000100"b; temp = -cobol_$text_wd_off - temp; substr (instr (2), 1, 18) = substr (unspec (temp), 19, 18); substr (instr (2), 19, 18) = substr (unspec (anum), 19, 18); substr (instr (3), 21, 16) = substr (unspec (anum), 21, 16); end; call cobol_emit (addr (instr (1)), null (), 3); if file_table.linage & ^linage_before then do; instr (1) = mlr_q; instr (2) = (36)"0"b; substr (instr (3), 33, 4) = "0001"b; call cobol_emit (addr (instr (1)), null (), 3); instr (1) = "000000000000000001000111110000000111"b; call cobol_emit (addr (instr (1)), null (), 1); end; temp = anum + bnum; if ^file_table.linage & temp > 0 then call cobol_io_util$fixed_add ("110"b, buflen_off * 4, temp, "000"b, 0); else if temp > 0 then do; instr (1) = "110"b || substr (unspec (buflen_off), 22, 15) || stq; instr (2) = "110"b || substr (unspec (buflen_off), 22, 15) || lda; call cobol_emit (addr (instr), null (), 2); end; return; end move_buf_con; move_buf_var: proc; restartad = cobol_$text_wd_off; call cobol_io_util$t9dec_to_bin ("110"b, len_off * 4, mp.pt (mp.n - 1)); patch_ic = cobol_$text_wd_off + 3; call cobol_emit (addr (num_check_instr), null (), 4); call cobol_ioerror_abort (advancing_error, mp.pt (1) -> reserved_word.line, 0, restartad, 0); /*[4.4-1]*/ /*cobol_$text_wd_off = cobol_$text_wd_off-1;*/ /* erase the transfer */ instr (1) = "110"b || substr (unspec (buflen_off), 22, 15) || lda; utemp = restartad - (cobol_$text_wd_off + 1); instr (2) = substr (unspec (utemp), 19, 18) || tra_icmod; call cobol_emit (instr_ptr, null (), 2); utemp = cobol_$text_wd_off - patch_ic; substr (text (patch_ic), 1, 18) = substr (unspec (utemp), 19, 18); if file_table.rec_do then do; /* in this case, A will not be already set */ /* instr(1) = "110"b||substr(unspec(buflen_off),22,15)||lda; */ /* already done */ call cobol_emit (instr_ptr, null (), 1); end; if file_table.linage & buflen_off ^= 0 then do; call cobol_set_pr (pr5_struct_ptr, dn_ptr_linage); call cobol_ioop_util$set_var_adv; call cobol_call_op (52, good_tag); /* LINAGE_OP */ call cobol_gen_ioerror (ft_ptr, ioerror_ptr); call cobol_define_tag (good_tag); end; if ba_sw = 0 then do; /* AFTER specified */ /*[4.3-1]*/ if file_table.linage /*[4.3-1]*/ then do; /*[4.3-1]*/ temp = buflen_off + 1; /*[4.3-1]*/ instr (1) = "110"b || substr (unspec (temp), 22, 15) || ldq; /*[4.3-1]*/ instr (2) = "110"b || substr (unspec (buflen_off), 22, 15) || sbq; /*[4.3-1]*/ call cobol_emit (instr_ptr, null (), 2); /*[4.3-1]*/ end; instr (1) = mlr; instr (2) = ""b; instr (3) = "110"b || substr (unspec (buf_off), 22, 15) || "000000000000000110"b; /* len in Q reg */ substr (instr (1), 1, 18) = "000001010001100000"b; call cobol_emit (instr_ptr, null (), 3); if file_table.device = 1 /* print file - append carriage return */ then do; instr (1) = "110"b || substr (unspec (buflen_off), 22, 15) || aos; instr (2) = substr (instr (1), 1, 18) || lxl5; /* and load it in X5 */ call cobol_emit (instr_ptr, null (), 2); end; instr (1) = mlr; call cobol_addr (mlr_struct_ptr, addr (instr (1)), null ()); substr (instr (1), 1, 18) = "000001101"b || "00"b || "1100110"b; /* CR fill, var length, indexed by Q */ substr (instr (2), 21, 16) = "0000000000000101"b; /* sending length in A */ instr (3) = "110"b || substr (unspec (buf_off), 22, 15); if file_table.device = 1 then substr (instr (3), 19, 18) = "000000000000001101"b; /* length in X5 */ else substr (instr (3), 19, 18) = "000000000000000101"b; /* length in A */ substr (instr (1), 31, 1) = "1"b; instr (4) = "110"b || substr (unspec (buflen_off), 22, 15) || adq; instr (5) = substr (instr (4), 1, 18) || stq; call cobol_emit (instr_ptr, null (), 5); end; else do; if file_table.linage then do; utemp = buflen_off + 1; instr (1) = "110"b || substr (unspec (utemp), 22, 15) || ldq; end; else do; utemp = buflen_off; instr (1) = "110"b || substr (unspec (utemp), 22, 15) || adq; end; instr (2) = mlr; call cobol_addr (mlr_struct_ptr, addr (instr (2)), null ()); substr (instr (3), 21, 16) = "0000000000000101"b; instr (4) = "110"b || substr (unspec (buf_off), 22, 15) || "000000000000000110"b; substr (instr (2), 1, 18) = "000001010001100000"b; substr (instr (2), 31, 1) = "1"b; instr (5) = "110"b || substr (unspec (buflen_off), 22, 15) || stq; call cobol_emit (instr_ptr, null (), 5); if file_table.device = 1 then do; /* print file - assure carriage return */ instr (1) = "110"b || substr (unspec (len_off), 22, 15) || szn; instr (2) = "000000000000000101"b || tnz_icmod; /* OK if at least one NL */ instr (3) = mlr; /* otherwise append CR */ substr (instr (3), 1, 18) = "000001101"b || "00"b || "100"b || "0110"b; /* CR fill at offset in Q */ instr (4) = ""b; /* for fill only */ instr (5) = "110"b || substr (unspec (buf_off), 22, 15) || "000000000000000001"b; instr (6) = "110"b || substr (unspec (buflen_off), 22, 15) || aos; /* increment length field */ call cobol_emit (instr_ptr, null (), 6); end; end; return; end move_buf_var; /*************************************/ nyi_error: call ioa_$rsnnl ("""ADVANCING mnemonic-name"" clause specified on line ^d not yet implemented", message, message_len, mp.pt (1) -> reserved_word.line); go to error; litsize_error: call ioa_$rsnnl ("Literal specified in ""ADVANCING"" clause on line ^d is too large - ^a", message, message_len, mp.pt (1) -> reserved_word.line, dn_ptr -> numeric_lit.literal); go to error; error: error_info.name = "cobol_linage"; call signal_ ("command_abort_", null (), addr (error_info)); 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_error_info; %include cobol_type1; %include cobol_type2; %include cobol_type9; %include cobol_type19; %include cobol_file_table; %include cobol_; %include cobol_type17; %include cobol_reswd_values; end cobol_linage;  cobol_link_init.pl1 05/24/89 1041.5rew 05/24/89 0830.6 47655 /****^ *********************************************************** * * * 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_link_init.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 Version 3.0 */ /* format: style3 */ cobol_link_init: proc; /* The procedure cobol_link_init initializes the Linkage Section and outputs corresponding relocation information. In particular it: 1. Initializes all items in the header with the exception of def_section_relp and linkage_section_length. 2. Initializes all fixed internal static data (stat and trace_control_word) with the exception of stat.data_len. cobol_link_init is called once per compilation, prior to code generation. U__s_a_g_e:_ declare cobol_link_init entry; call cobol_link_init; D__a_t_a:_ % include cobol_; Items in cobol include file used (u) and/or set(s) by cobol_link_init: cobol_ptr (u) com_ptr (u) link_base_ptr (u) link_wd_off (s) link_max (u) % include fixed_common; Items in fixed_common include file used (u) and/or set (s) by cobol_link_init: prog_name (u) */ %include cobol_linkage_header; /* [3.0-1] */ %include cobol_fixed_static; dcl 1 error_s aligned static, 2 my_name char (32) init ("cobol_link_init"), 2 message_len fixed bin init (32), 2 message char (168) init ("Linkage Section length exceeded!"); dcl reloc_info (4) bit (5) aligned static init ("00000"b, "00000"b, "10000"b, "00000"b); dcl no_wds fixed bin; /* Number of words in header and */ /* stat structure incremented by */ /* 1, if necessary, to be even. */ /* P__r_o_c_e_d_u_r_e_s_C__a_l_l_e_d:_ */ dcl signal_ entry (char (*), ptr, ptr); dcl cobol_reloc entry (ptr, fixed bin, fixed bin); /* _B_u_i_l_t-__i_n_F__u_n_c_t_i_o_n_s_U__s_e_d:_ */ dcl addr builtin; dcl addrel builtin; dcl binary builtin; dcl null builtin; dcl rel builtin; dcl search builtin; dcl substr builtin; dcl unspec builtin; /*}*/ %include cobol_; %include cobol_fixed_common; %include cobol_ext_; /*************************************/ start: /* UPDATE link_wd_off AND TEST AGAINST link_max */ /* Number of words occupied by header plus static data is 8 */ /* plus number of words in stat. If the trace_control_word */ /* falls on an even word boundary (no_wds odd), no_wds is in- */ /* creased by 1 so that links which follow will be on even */ /* word boundaries, as required. */ stat_ptr = addrel (link_base_ptr, 8); /* Modified to interface with cobol run time package. */ /* no_wds=binary(rel(addr(stat.reserved(16))),17)+1; /* no_wds = no_wds-binary(rel(cobol_$link_base_ptr),17); /* if substr(unspec(no_wds),36,1) = "1"b /* then /* no_wds = no_wds+1; /**/ no_wds = fixed_static_length + 8; link_wd_off = no_wds; /* if link_wd_off > link_max /* then do; /* call signal_("command_abort_",null(),addr(error_s)); /* return; /* end; /**/ /* INITIALIZE LINKAGE SECTION HEADER */ pad = (36)"0"b; /* def_section_relp not initialized by cobol_link_init */ first_reference_relp = (18)"0"b; unspec (obsolete_ptr) = (36)"0"b; /* [3.0-1] */ unspec (original_linkage_ptr) = (36)"0"b; /* [3.0-1] */ links_relp = substr (unspec (no_wds), 19, 18); /* linkage_section_length not initialized by cobol_link_init */ object_seg = (18)"0"b; obsolete_length = (18)"0"b; /* INITIALIZE FIXED INTERNAL STATIC DATA */ stat.data_ptr = null (); stat.control_ptr = null (); stat.file_info_ptr = null (); stat.call_cnt = -1; /* data_len not initialized by cobol_link_init */ stat.entry_pt_ptr = null (); stat.prog_id_len = search (fixed_common.prog_name, " ") - 1; if stat.prog_id_len = -1 then stat.prog_id_len = 30; stat.prog_id = fixed_common.prog_name; stat.line_no (1), stat.line_no (2) = 0; stat.fo_flag = 0; stat.fo_disp = 0; stat.main_prog_sw = 0; trace_control_word = 0; /* OUTPUT RELOCATION INFORMATION */ /* First Two Words of Header */ call cobol_reloc (addr (reloc_info), 4, 3002); /* Remainder of Header and Fixed Internal Static Data */ call cobol_reloc (null (), no_wds * 2 - 4, 3002); /* INITIALIZATION COMPLETE */ exit: return; end cobol_link_init;  cobol_load_register.pl1 05/24/89 1041.5rew 05/24/89 0830.5 57447 /****^ *********************************************************** * * * 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_load_register.pl1 Added Trace statements. END HISTORY COMMENTS */ /* Modified on 10/19/85 by FCH, [5.3-1], BUG563(phx18381), new cobol_addr_tokens.incl.pl1 */ /* 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_load_register: proc (operand_token_ptr, register_token_ptr); /* This procedure generates code to load a value into either the A or Q register. */ /* DECLARATION OF THE PARAMETERS */ dcl operand_token_ptr ptr; dcl register_token_ptr ptr; /* DESCRIPTION OF THE PARAMETERS */ /* PaRaMETER DEsCRIPTION operand_token_ptr Pointer to a token that describes the operand to be loaded into the register. This token can be on of the following types: 1. data name token (type 9) for a short or long binary data item. 2. immediate constant token (type 102) register_token_ptr Pointer to a register token (type 100) that describes the register into which the operand is loaded. If this pointer is null() on entry, then space for the token is provided to the user, and the value is loaded into either the A or Q register. (whichever is available) If this pointer is not null, it must point to a register token (type 100) whose entry cobol_type100.register specifies the register which is to be loaded. */ /*}*/ /* DECLARATION OF EXTERNAL ENTRIES */ dcl cobol_register$load ext entry (ptr); dcl cobol_make_reg_token ext entry (ptr, bit (4)); dcl cobol_short_to_longbin$register ext entry (ptr, ptr); dcl cobol_addr ext entry (ptr, ptr, ptr); dcl cobol_emit ext entry (ptr, ptr, fixed bin); /* DECLARATION OF INTERNAL STATIC DATA */ dcl LDA bit (10) int static init ("0100111010"b); /* LDA */ dcl LDQ bit (10) int static init ("0100111100"b); /* LDQ */ dcl direct_lower_inst bit (36) int static init ("000000000000000000000000000000000111"b); /* zero,dl */ /* DECLARATION OF INTERNAL VARIABLES */ dcl 1 input_buff aligned, 2 buff (1:10) ptr; dcl 1 inst_buff aligned, 2 buff (1:2) fixed bin; dcl 1 reloc_buff aligned, 2 buff (1:10) bit (5) aligned; dcl dn_ptr ptr; 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); /**************************************************/ start: if operand_token_ptr -> data_name.type = rtc_dataname then do; /* Operand to be loaded is long or short binary cobol data item. */ if operand_token_ptr -> data_name.bin_18 then /* Operand to be loaded is short binary. */ call cobol_short_to_longbin$register (operand_token_ptr, register_token_ptr); else do; /* Operand to be loaded is a long binary data item. */ /* Establish addressability to the operand. */ 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.operand.size_sw (1) = 0; input_struc.operand.token_ptr (1) = operand_token_ptr; call cobol_addr (input_ptr, inst_ptr, reloc_ptr); if register_token_ptr = null () then register_struc.what_reg = 4; /* A or Q */ else if register_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 it */ 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); if register_token_ptr = null () then call cobol_make_reg_token (register_token_ptr, register_struc.reg_no); end; /* Operand to be loaded is a long binary data item. */ end; /* Operand to be loaded is long or short binary cobol data item. */ else do; /* Operand to be loaded is an immediate constant. */ if register_token_ptr = null () then register_struc.what_reg = 4; /* A or Q */ else if register_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; register_struc.contains = 0; call cobol_register$load (addr (register_struc)); if register_struc.reg_no = "0001"b /* A */ then substr (direct_lower_inst, 19, 10) = LDA; else substr (direct_lower_inst, 19, 10) = LDQ; /* Insert the immediate value into the instruction */ substr (direct_lower_inst, 1, 18) = substr (unspec (operand_token_ptr -> immed_const.const_value), 19, 18); call cobol_emit (addr (direct_lower_inst), null (), 1); if register_token_ptr = null () then call cobol_make_reg_token (register_token_ptr, register_struc.reg_no); end; /* Operand to be loaded is an immediate constant. */ /* 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_type9; %include cobol_addr_tokens; %include cobol_type102; %include cobol_record_types; %include cobol_type100; end cobol_load_register;  cobol_make_bin_const.pl1 05/24/89 1041.5rew 05/24/89 0830.5 80469 /****^ *********************************************************** * * * 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_make_bin_const.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 02/11/77 by Bob Chang to fix the bug for numeric literal to comp-7 move. */ /* Modified on 1/14/77 by Bob Chang to search operator when pooling constant. */ /* Modified since Version 2.0. */ /*{*/ /* format: style3 */ cobol_make_bin_const: proc (nlit_ptr, return_token_ptr, target_code); /* This procedure converts the decimal representation of a numeric literal into a fixed binary representation. The fixed binary value is either pooled in the constant section of a cobol program, or returned in the output token from this procedure. See DISCUSSION below for more details. */ /* DECLARATION OF THE PARAMETERS */ /*dcl nlit_ptr ptr; */ /* Declared below in an include file. */ dcl return_token_ptr ptr; dcl target_code fixed bin; /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION nlit_ptr Pointer to the numeric literal token (type2) whose constant is to be converted to a binary constant. (input) return_token_ptr Pointer to a token that describes the converted binary constant. If this pointer is null() on entry to this procedure, then the token spaxe will be provided by this procedure. Otherwise this parameter must point to some work space in which the token will be built. target_code A code that specifies the type of arithemtic that is being done when this constant is being made. (input) This code has the following values: target code | meaning ========================================== 1 | short binary arithmetic | is being performed 2 | long binary arithmetic | is being performed 3 | short bin const pooled 4 | long bin const pooled =========================================== */ /* DISCUSSION If the constant can be contained in a short fixed binary variable (half-word), then the token built by and returned by this procedure is an "immediate constant" token. This token is defined by the following declaration: dcl 1 immed_constant, 2 size fixed bin(15), 2 line fixed bin (15), 2 column fixed bin (15), 2 type fixed bin (15), NOTE: type = 102 2 constant_value fixed bin (35); The binary representation of the numeric literal is returned in the field "constant_value" of this token. If the constant cannot be contained in a half-word, then the binary representation is pooled into the constant section, and a long fixed binary data name token (type 9) is returned. */ /* DECLARATION OF EXTERNAL ENTRIES */ dcl cobol_pool$search_op ext entry (char (*), fixed bin, fixed bin (24), 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)); /* DECLARATION OF INTERNAL STATIC DATA */ dcl smallest_short_binary fixed dec (6, 0) int static init (-131072); dcl largest_short_binary fixed dec (6, 0) int static init (131071); dcl smallest_long_binary fixed dec (11, 0) int static init (-32359738358); dcl largest_long_binary fixed dec (11, 0) int static init (32359738357); /* DECLARATION OF INTERNAL VARIABLES */ dcl work_fdec fixed dec (19, 0); dcl work_fdec_string char (20) based (work_fdec_ptr); dcl double_binary fixed bin (71); dcl temp fixed bin, in_op fixed bin; dcl work_fdec_ptr ptr; dcl ret_offset fixed bin (24); dcl long_bin_const fixed bin (35); dcl long_bin_ptr ptr; dcl long_bin_string char (4) based (long_bin_ptr); dcl short_bin_const fixed bin (35); dcl short_bin_ptr ptr; dcl short_bin_const_bit bit (18); dcl short_bin_string char (2) based (short_bin_ptr); /**************************************************/ /* START OF EXECUTION */ /* cobol_make_bin_const */ /**************************************************/ start: work_fdec = 0; if numeric_lit.places_left > 0 then do; /* Numeric literal has an integer part */ work_fdec_ptr = addr (work_fdec); if numeric_lit.sign = " " then substr (work_fdec_string, 1, 1) = "+"; else substr (work_fdec_string, 1, 1) = numeric_lit.sign; substr (work_fdec_string, 21 - numeric_lit.places_left, numeric_lit.places_left) = substr (numeric_lit.literal, 1, numeric_lit.places_left); end; /* Numeric literal has an integer part. */ double_binary = binary (work_fdec); if target_code = 4 then do; /* constant must be pooled into a long fixed bnary in the constant section */ if double_binary > largest_short_binary | double_binary < smallest_short_binary then do; substr (work_fdec_string, 2, 13) = (13)"0"; double_binary = binary (work_fdec); if double_binary > largest_short_binary | double_binary < smallest_short_binary then do; substr (work_fdec_string, 15, 1) = "0"; double_binary = binary (work_fdec); end; end; long_bin_const = binary (work_fdec); long_bin_ptr = addr (long_bin_const); call cobol_pool$search_op (long_bin_string, 0, ret_offset, in_op); if in_op = 0 then temp = 3000; else temp = 3; /* Make a data name token for the long binary constant just pooled. */ call cobol_make_type9$long_bin (return_token_ptr, temp, ret_offset); end; /* constant must be pooled into a fixed binary in the constant section */ else do; if double_binary > largest_long_binary | double_binary < smallest_long_binary then do; substr (work_fdec_string, 2, 8) = (8)"0"; double_binary = binary (work_fdec); if double_binary > largest_long_binary | double_binary < smallest_long_binary then do; substr (work_fdec_string, 10, 1) = "0"; double_binary = binary (work_fdec); end; end; if target_code = 3 then do; short_bin_const = binary (work_fdec); short_bin_const_bit = substr (unspec (short_bin_const), 19, 18); short_bin_ptr = addr (short_bin_const_bit); call cobol_pool$search_op (short_bin_string, 0, ret_offset, in_op); if in_op = 0 then temp = 3000; else temp = 3; /* Make a data name token for the short binary constant just pooled. */ call cobol_make_type9$short_bin (return_token_ptr, temp, ret_offset); end; /* constant must be pooled into a fixed binary in the constant section */ else if (smallest_short_binary <= work_fdec & work_fdec <= largest_short_binary) & target_code = 1 then do; /* Constant can be contained in a short fixed binary */ /* AND target is short binary, OR the constant is positive or zero. NOTE: negative immediate constants cannot be used in long binary computations. */ if return_token_ptr = null () then do; /* Make space for the token */ return_token_ptr = cobol_$temp_token_ptr; cobol_$temp_token_ptr = addrel (cobol_$temp_token_ptr, 5); end; /* Make space for the token */ return_token_ptr -> immed_const.const_value = binary (work_fdec); return_token_ptr -> immed_const.type = 102; end; /* Constant can be contained in a short fixed binary */ else do; /* constant must be pooled into a long fixed bnary in the constant section */ long_bin_const = binary (work_fdec); long_bin_ptr = addr (long_bin_const); call cobol_pool$search_op (long_bin_string, 0, ret_offset, in_op); if in_op = 0 then temp = 3000; else temp = 3; /* Make a data name token for the long binary constant just pooled. */ call cobol_make_type9$long_bin (return_token_ptr, temp, ret_offset); end; /* constant must be pooled into a fixed binary in the constant section */ 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_type2; %include cobol_type102; %include cobol_; /**************************************************/ /* END OF EXTERNAL PROCEDURE */ /* cobol_make_bin_const */ /**************************************************/ end cobol_make_bin_const;  cobol_make_fsb_link.pl1 05/24/89 1041.5rew 05/24/89 0830.5 33813 /****^ *********************************************************** * * * 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,MCR8090), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8090 cobol_make_fsb_link.pl1 Disallow duplicate prime keys in Indexed Sequential files. END HISTORY COMMENTS */ /* Modified on 12/14/84 by FCH, [5.3-1], BUG573(phx16343), cobol_fsb_type_1.incl.pl1 changed */ /* Modified on 07/03/79 by FCH, [4.0-1], multiple sizes allowed for FSBs */ /* Modified on 01/11/79 by FCH, [3.0-1], size of FSB computed */ /* Modified since Version 3.0 */ /* format: style3 */ cobol_make_fsb_link_: cobol_make_fsb_link: proc (ft_ptr); declare linkoff fixed bin, ft_ptr ptr; if first_call ^= cobol_$compile_count then do; alloc_space = 0; first_call = cobol_$compile_count; end; /*[4.0-1]*/ if file_table.alternate_keys > 0 & file_table.organization = 3 then fsb_init.n_words = size (fsb); else fsb_init.n_words = 155; call cobol_make_link$type_5 (linkoff, file_table.id, addr (fsb_init), alloc_space); file_table.fsb.seg = -linkoff; file_table.fsb.off = 0; return; /* This procedure defines a type-5 link for a file state block. If an indexed file having alternate record keys is being considered then the size of the link is computed using the size builtin function. */ /* STATIC DECLARATIONS */ dcl 1 fsb_init aligned static, 2 n_words fixed bin (35) init (0), 2 code fixed bin (35) init (3), 2 iocb_ptr ptr init (null ()), 2 open_mode fixed bin (35) init (0), 2 max_cra_size fixed bin (35) init (0), 2 relkeylen fixed bin (35) init (0), 2 relkey fixed bin (35) init (0), 2 keylen_sw fixed bin (35) init (0), 2 key char (256) init (""), 2 open_close_name char (65) unal init (" "), /*[5.3-1]*/ 2 attach_flag bit (27) unal init ("0"b), 2 linage_counter char (8) aligned init ((8)"0"), /*[5.3-1]*/ 2 indicators, /*[5.3-1]*/ 3 optional bit (36) init ("0"b), /*[5.3-1]*/ 3 opened bit (36) init ("0"b), /*[5.3-1]*/ 3 internal bit (36) init ("001"b), /*[5.3-1]*/ 2 vfile_open_mode fixed bin (35) init (0), /*[5.3-1]*/ 2 file_desc_ptr ptr init (null ()), /*[5.3-1]*/ 2 cobol_open_mode fixed bin (35) init (0), /*[5.3-1]*/ 2 last_cobol_op fixed bin (35) init (0), /*[5.3-1]*/ 2 fsb_code fixed bin (35) init (0), /*[5.3-1]*/ 2 key_of_ref fixed bin (35) init (0), /*[5.3-1]*/ 2 prime_key char (256) varying init (""), /*[5.3-1]*/ 2 alt_key char (256) varying init (""), /*[5.3-1]*/ 2 descriptor fixed bin (35) init (0), /*[5.3-1]*/ 2 last_key_read char (256) varying init (""); declare (alloc_space, first_call) fixed bin static; /* EXTERNAL ENTRY NAMES */ dcl cobol_make_link$type_5 entry (fixed bin, char (*), ptr, fixed bin); /* BUILTIN FUNCTIONS */ dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index, size) builtin; %include cobol_fsb_type_1; %include cobol_fsbskel; %include cobol_file_table; %include cobol_; end cobol_make_fsb_link;  cobol_make_link.pl1 05/24/89 1041.5rew 05/24/89 0830.5 109008 /****^ *********************************************************** * * * 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_make_link.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 07/02/79 by FCH, [4.0-1], more than one size allowed for FSBs */ /* Modified on 12/29/78 by FCH, [3.0-2], size check for initialization data */ /* Modified on 07/18/78 by RAL, [3.0-1], changed linkage_header */ /* Modified since Version 3.0 */ /* format: style3 */ cobol_make_link: proc; /* this is an improper entry point */ type = 0; module_name = "cobol_make_link"; reset_loc = def_wd_off; call error (msg_9); return; dcl 1 acc_string aligned based (ds_wrk_ptr), 2 nam_lnth bit (9) unaligned, 2 char_string char (32) unaligned; dcl ds_strng char (ds_lnth) based (def_base_ptr); dcl nam_strng char (32) based (ds_wrk_ptr); dcl 1 type_pair aligned based (ds_wrk_ptr), 2 link_type bit (18) unaligned, 2 trap_relp bit (18) unaligned, 2 seg_name_relp bit (18) unaligned, 2 ent_name_relp bit (18) unaligned; dcl typ_pr_strng char (8) based (ds_wrk_ptr); dcl 1 expression_word aligned based (ds_wrk_ptr), 2 type_pair_relp bit (18) unaligned, 2 expression bit (18) unaligned; dcl 1 link aligned based (ls_wrk_ptr), 2 header_relp bit (18) unaligned, 2 ignore_1 bit (12) unaligned, 2 tag bit (6) unaligned, 2 expr_word_relp bit (18) unaligned, 2 ignore_2 bit (12) unaligned, 2 modifier bit (6) unaligned; dcl 1 linkage_header aligned based (ls_wrk_ptr), 2 pad bit (36), 2 def_sect_relp bit (18) unaligned, 2 first_ref_relp bit (18) unaligned, 2 obsolete_ptr ptr unal, /* [3.0-1] */ 2 original_linkage_ptr ptr unal, /* [3.0-1] */ 2 unused bit (72), /* [3.0-1] */ 2 links_relp bit (18) unaligned, 2 link_sect_lgth bit (18) unaligned, 2 object_seg bit (18) unaligned, 2 obsolete_length bit (18) unaligned; dcl 1 initialization_info aligned based (init_ptr), 2 n_words fixed bin, 2 code fixed bin, 2 info (0 refer (n_words)) aligned bit (36); dcl init_info char (262144) aligned based; dcl 1 error_info aligned, 2 module_name char (32), 2 err_msg_lnth fixed bin, 2 error_msg char (168); dcl err_sw fixed bin init (-1); /*[4.0-1]*/ declare 1 init_areas static internal, /*[4.0-1]*/ 2 size fixed bin, /* table size */ /*[4.0-1]*/ 2 entry (16), /*[4.0-1]*/ 3 nwords fixed bin, /* area size */ /*[4.0-1]*/ 3 def_off fixed bin; /* offset in def section */ /*[4.0-1]*/ declare res fixed bin; dcl (ds_wrk_ptr, ls_wrk_ptr, init_ptr, type_pr_reloc_ptr) ptr; dcl (init_info_loc, seg_name_loc, ent_name_loc) fixed bin; dcl (lnk_typ, reset_loc, est_init_info_loc, express_loc) fixed bin; dcl (type_pair_loc, expr_word_loc, linkoff) fixed bin; dcl (i, j, type, x, segl, first, seg_code) fixed bin; dcl (nl, nwrds, next_loc, nchar, entl, name_sw) fixed bin; dcl (beg_link_loc, cur_link_loc, end_link_loc) fixed bin; dcl (exp_wd_loc, typ_pr_loc, name_loc, ds_lnth) fixed bin; dcl (n_lnks, n_args, code) fixed bin; dcl (ds_srch_ptr, ls_srch_ptr) ptr; dcl save_name_loc fixed bin; dcl (lnk_offset, ln_lnth) fixed bin init (0); dcl name char (*); dcl (linkoff_char, num_links_char) char (6); dcl (lo_lnth, nl_lnth) fixed bin; dcl lo_char char (lo_lnth) based (lo_ptr); dcl nl_char char (nl_lnth) based (nl_ptr); dcl (lo_ptr, nl_ptr) ptr; dcl ck_name char (64); dcl link_name char (ln_lnth) based (addr (ck_name)); dcl temp fixed bin; type_5: entry (linkoff, name, init_ptr, est_init_info_loc); type = 5; module_name = "cobol_make_link$type_5 "; reset_loc = def_wd_off; /* ck if space for type-5 link already established */ /*[4.0-1]*/ res = 1; /*[4.0-1]*/ nwrds = initialization_info.n_words; /*[4.0-1]*/ if est_init_info_loc = 0 /*[4.0-1]*/ then do; est_init_info_loc = 1; /*[4.0-1]*/ init_areas.size = 0; /*[4.0-1]*/ end; /*[4.0-1]*/ else do i = 1 by 1 to init_areas.size while (res = 1); /*[4.0-1]*/ if nwrds = init_areas.entry.nwords (i) then res = 0; /*[4.0-1]*/ end; /*[4.0-1]*/ if res = 1 /*[4.0-1]*/ then do; init_areas.size = init_areas.size + 1; /*[4.0-1]*/ init_areas.entry.nwords (init_areas.size) = nwrds; /*[4.0-1]*/ init_areas.entry.def_off (init_areas.size) = def_wd_off; /*[4.0-1]*/ init_info_loc = def_wd_off; /*[4.0-1]*/ end; /*[4.0-1]*/ else init_info_loc = init_areas.entry.def_off (i - 1); /*[4.0-1]*/ ds_wrk_ptr = addrel (def_base_ptr, init_info_loc); /*[4.0-1]*/ nwrds = nwrds + 2; call ds_size_ck (nwrds); if (err_sw = 0) then return; nchar = fixed (substr (unspec (nwrds), 3, 36), 36); substr (ds_wrk_ptr -> init_info, 1, nchar) = substr (init_ptr -> init_info, 1, nchar); /* ck if init_info structure is being posted */ if (init_info_loc = def_wd_off) then do; /* yes, update def_wd_off and emit relocation info */ def_wd_off = def_wd_off + nwrds; call cobol_reloc (null (), (2 * nwrds), 3003); end; type_pr_reloc_ptr = addr (type_pr6_reloc); call create_acc_string; return; type_4: entry (linkoff, name); type = 4; module_name = "cobol_make_link$type_4"; reset_loc = def_wd_off; init_info_loc = 0; type_pr_reloc_ptr = addr (type_pr4_reloc); call create_acc_string; return; create_acc_string: proc; if type = 5 then seg_name_loc = 5; else seg_name_loc = def_wd_off; save_name_loc = def_wd_off; nl = index (name, " ") - 1; if (nl < 0) then nl = length (name); i = index (name, "$"); if (i = 0) then do; entl = 0; segl = nl; end; else do; entl = nl - i; segl = i - 1; end; name_sw = 0; nchar = segl; first = 1; do while ("1"b); ds_wrk_ptr = addrel (def_base_ptr, def_wd_off); nam_lnth = substr (unspec (nchar), 28, 9); nwrds = 1 + fixed (substr (unspec (nchar), 1, 34), 36); /* = 1+(nchar/4) */ call ds_size_ck (nwrds); if (err_sw = 0) then return; substr (char_string, 1, nchar) = substr (name, first, nchar); /* before posting acc string, search def section to see if an acc string for this "name" already exists */ ds_lnth = def_wd_off * 4; name_loc = index (ds_strng, substr (nam_strng, 1, nchar + 1)) - 1; if (name_loc > -1) then do; /* acc strng for this name found, ck whether seg_name or ent_name */ name_loc = divide (name_loc, 4, 17, 0); if (name_sw = 0) then if type ^= 5 then seg_name_loc = name_loc; else do; seg_name_loc = 5; save_name_loc = name_loc; end; else ent_name_loc = name_loc; end; else do; def_wd_off = def_wd_off + nwrds; call cobol_reloc (null (), (2 * nwrds), 3003); end; if name_sw ^= 0 then do; call create_type_pair; return; end; if (entl = 0) then do; /* link requested contains segment name only */ if type = 5 then ent_name_loc = save_name_loc; else ent_name_loc = seg_name_loc; call create_type_pair; return; end; /* link requested contains entry name, reset parameters for entry name processing */ name_sw = 1; nchar = entl; first = i + 1; ent_name_loc = def_wd_off; end; end; type_1: entry (linkoff, seg_code); type = 1; module_name = "cobol_make_link$type_1"; reset_loc = def_wd_off; seg_name_loc = seg_code; ent_name_loc, init_info_loc = 0; type_pr_reloc_ptr = addr (type_pr1_reloc); call create_type_pair; return; create_type_pair: proc; /* The following operations are common to ALL link types */ ds_wrk_ptr = addrel (def_base_ptr, def_wd_off); type_pair_loc = def_wd_off; call ds_size_ck (3); if (err_sw = 0) then return; link_type = substr (unspec (type), 19, 18); trap_relp = substr (unspec (init_info_loc), 19, 18); seg_name_relp = substr (unspec (seg_name_loc), 19, 18); ent_name_relp = substr (unspec (ent_name_loc), 19, 18); /* before posting type-pair and expression word to def section, check to see if a type 4 or 5 link has already been made for this "name" */ ds_lnth = def_wd_off * 4; typ_pr_loc = index (ds_strng, typ_pr_strng) - 1; if (typ_pr_loc > -1) then do; /* type-pair for this link-type and "name" found, calculate expr wrd loc for this type-pair search link section to find link to this expr word return offset of this already made link */ typ_pr_loc = divide (typ_pr_loc, 4, 17, 0); exp_wd_loc = typ_pr_loc + 2; ls_wrk_ptr = link_base_ptr; beg_link_loc, cur_link_loc = fixed (substr (links_relp, 1, 18), 36); end_link_loc = beg_link_loc + fixed (substr (link_sect_lgth, 1, 18), 36); /* bypass search until AFTER 1st link has been made */ if ^(link_wd_off = beg_link_loc) then do; srch_lp: ls_srch_ptr = addrel (link_base_ptr, cur_link_loc); expr_word_loc = fixed (substr (ls_srch_ptr -> expr_word_relp, 1, 18), 36); if (exp_wd_loc = expr_word_loc) then do; /* link found, return offset to this link */ linkoff = cur_link_loc; return; end; cur_link_loc = cur_link_loc + 2; if (cur_link_loc < end_link_loc) then goto srch_lp; end; end; /* link not found, post type-pair, update def_wd_off and emit relocation information for this link type */ def_wd_off = def_wd_off + 2; call cobol_reloc (type_pr_reloc_ptr, 4, 3003); ds_wrk_ptr = addrel (def_base_ptr, def_wd_off); expr_word_loc = def_wd_off; type_pair_relp = substr (unspec (type_pair_loc), 19, 18); expression = (18)"0"b; def_wd_off = def_wd_off + 1; call cobol_reloc (addr (expr_word_reloc), 2, 3003); ls_wrk_ptr = link_base_ptr; if (link_sect_lgth = "0"b) then link_sect_lgth = links_relp; ls_wrk_ptr = addrel (link_base_ptr, link_wd_off); linkoff = link_wd_off; call ls_size_ck (2); if (err_sw = 0) then return; string (link) = "000000000000000000000000000000100110"b; temp = -link_wd_off; header_relp = substr (unspec (temp), 19, 18); expr_word_relp = substr (unspec (expr_word_loc), 19, 18); link_wd_off = link_wd_off + 2; ls_wrk_ptr = link_base_ptr; temp = fixed (link_sect_lgth, 18) + 2; link_sect_lgth = substr (unspec (temp), 19, 18); call cobol_reloc (addr (link_reloc), 4, 3002); end; size_ck: proc; dcl (ds_size_ck, ls_size_ck) entry; dcl block_size fixed bin; ds_size_ck: entry (block_size); next_loc = def_wd_off + block_size; if (next_loc > def_max) then do; call error (msg_5); return; end; return; ls_size_ck: entry (block_size); next_loc = link_wd_off + block_size; if (next_loc > link_max) then do; call error (msg_6); return; end; end size_ck; error: proc (err_msg); dcl err_msg char (*); dcl l_name char (68); if (type = 1) then l_name = "type-1"; else if ((type = 4) | (type = 5)) then l_name = name; else if (type = 0) then l_name = ""; call ioa_$rsnnl ("^a ABORTING type ^o link -> ""^a""", error_msg, err_msg_lnth, err_msg, type, l_name); call signal_ ("command_error", null, addr (error_info)); linkoff = 0; err_sw = 0; def_wd_off = reset_loc; end error; %include cobol_make_link_info; %include cobol_make_link_data; end cobol_make_link;  cobol_make_list.pl1 05/24/89 1041.5rew 05/24/89 0830.5 84024 /****^ *********************************************************** * * * 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_make_list.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 06/26/81 by FCH, [4.4-1], print_text_ replaced by cobol_display_text */ /* Modified on 05/16/80 by FCH, [4.2-2], decl for tag_addr corrected */ /* Modified on 02/28/79 by PRP, [4.2-1], size of input programs increased */ /* Modified on 10/25/79 by PRP, [4.1-1], statement output modified */ /* Modified on 08/05/79 by FCH, [4.0-1], debug statement */ /* Modified since Version 4.0 */ /* format: style3 */ cobol_make_list: proc (code_ptr, code_length); dcl code_ptr ptr; dcl (p, q) ptr; dcl len_ptr ptr; dcl code_length fixed bin (24); dcl word_count fixed bin (24); dcl instr_word_num fixed bin; dcl line_length fixed bin (24); dcl obj_off fixed bin (18); dcl last_word_off fixed bin (35); dcl stmt_no fixed bin; dcl file_num fixed bin (35); dcl line_num fixed bin (35); dcl prev_file_num fixed bin (35); dcl prev_line_num fixed bin (35); dcl fl_length fixed bin; dcl source_stmt_count fixed bin; dcl (i, j, k1, k2, k3, n) fixed bin (24); dcl (k4, k5) fixed bin (24); dcl (s1, s2, number) fixed bin (35); dcl token_type fixed bin; dcl text_off fixed bin (24); dcl label_off fixed bin (24); dcl label_count fixed bin; dcl mcode fixed bin (35); dcl char7 char (7); dcl char9 char (9); dcl segname char (37); dcl output_switch char (10) aligned; dcl len fixed bin based (len_ptr); dcl c1 char (4) based (p); dcl c2 char (4) based (q); dcl source char (256) based (cobol_sfp); dcl print_line char (256) varying aligned; 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, 3 col fixed bin unaligned, 3 label bit unaligned; /*[4.2-2]*/ declare 1 DEF aligned based (cobol_$tag_table_ptr), /*[4.2-2]*/ 2 tag_max fixed bin, /*[4.2-2]*/ 2 TAG (32767), /*[4.2-2]*/ 3 tag_addr fixed bin (17) unal, /*[4.2-2]*/ 3 tag_no fixed bin (17) unal; dcl list_iocb_ptr ptr static init (null ()); dcl cobol_display_text entry (ptr, fixed bin, char (*) aligned); dcl ioa_$ioa_stream entry options (variable); dcl com_err_ entry options (variable); dcl iox_$attach_ioname entry (char (*), ptr, char (*), fixed bin (35)); dcl iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl cleanup condition; dcl addr builtin; dcl addrel builtin; dcl divide builtin; dcl fixed builtin; dcl index builtin; dcl mod builtin; dcl null builtin; dcl pointer builtin; dcl rel builtin; dcl substr builtin; call cleanup_proc; on cleanup call cleanup_proc; segname = substr (cobol_$obj_seg_name, 1, index (cobol_$obj_seg_name, " ") - 1) || ".list"; call iox_$attach_ioname ("cobol_out_", list_iocb_ptr, "vfile_ " || segname || " -extend", mcode); if mcode ^= 0 then go to error; call iox_$open (list_iocb_ptr, 2, "1"b, mcode); if mcode ^= 0 then do; error: call cleanup_proc; revert cleanup; call com_err_ (mcode, "cobol"); return; end; output_switch = "cobol_out_"; p = addr (s1); q = addr (s2); call ioa_$ioa_stream (output_switch, "^|^a^/", "OBJECT CODE"); word_count = 1; obj_off = fixed (rel (code_ptr), 18) - cobol_$constant_offset; last_word_off = obj_off + code_length; stmt_no = 1; prev_line_num = 0; prev_file_num = 0; source_stmt_count = 1; text_off = text_addr (1); label_count = 0; label_off = -1; if fixed_common.proc_counter > 0 then do; len_ptr = pointer (cobol_ntfp, 8); proc_def_ptr = pointer (cobol_ntfp, 8); token_type = proc_def.type; do while (token_type ^= 18 & len > 0); len_ptr = addrel (proc_def_ptr, divide (len + 11, 8, 17, 0) * 2); proc_def_ptr = len_ptr; token_type = proc_def.type; end; if len > 0 then label_off = cobol_$tag_table_ptr -> tag_addr (proc_def.proc_num); end; do while (word_count <= code_length); if obj_off = cobol_$non_source_offset then do; call ioa_$ioa_stream (output_switch, "^/^a^/", "ADDITIONAL CODE"); text_off = last_word_off; end; else do; do while (obj_off = label_off); if proc_def.type = 18 then do; if ^proc_def.section_name then call ioa_$ioa_stream (output_switch, "^a.", substr (proc_def.name, 1, proc_def.name_size)); else call ioa_$ioa_stream (output_switch, "^a section.", substr (proc_def.name, 1, proc_def.name_size)); end; label_count = label_count + 1; if label_count <= fixed_common.proc_counter then do; token_type = 0; do while (token_type ^= 18 & len > 0); len_ptr = addrel (proc_def_ptr, divide (len + 11, 8, 17, 0) * 2); proc_def_ptr = len_ptr; token_type = proc_def.type; end; if len > 0 then label_off = cobol_$tag_table_ptr -> tag_addr (proc_def.proc_num); end; else label_off = -1; end; do while (obj_off = text_off); eln_index = line_no (source_stmt_count); if eln_index > 0 then do; file_num = eln_tab.fno (eln_index); line_num = eln_tab.lno (eln_index); if file_num = prev_file_num & line_num = prev_line_num then stmt_no = stmt_no + 1; else do; stmt_no = 1; prev_file_num = file_num; prev_line_num = line_num; end; s1 = mod (stmt_no, 10) + 48; fl_length = 0; if file_num > 0 then do; number = file_num; do i = 2 to 1 by -1 while (number > 0); s2 = mod (number, 10) + 48; substr (char7, i, 1) = substr (c2, 4, 1); number = divide (number, 10, 35, 0); j = i; end; fl_length = 3 - j; char9 = substr (char7, j, fl_length); fl_length = fl_length + 1; substr (char9, fl_length, 1) = "-"; end; number = line_num; do i = 7 to 1 by -1 while (number > 0); s2 = mod (number, 10) + 48; substr (char7, i, 1) = substr (c2, 4, 1); number = divide (number, 10, 35, 0); j = i; end; substr (char9, fl_length + 1, 8 - j) = substr (char7, j, 8 - j); fl_length = fl_length + 8 - j; print_line = "STATEMENT " || substr (c1, 4, 1) || " ON LINE " || substr (char9, 1, fl_length); call ioa_$ioa_stream (output_switch, "^7-^a", print_line); if file_num = 0 then if stmt_no = 1 then do; /* Print the actual source line. */ if source_stmt_count = 1 then do; print_line = "PROCEDURE DIVISION."; call ioa_$ioa_stream (output_switch, "^a", print_line); end; else do; /*[4.1-1]*/ k1 = statement_info.start (eln_index); k2 = 0; k3 = map_data_table.line_no (source_stmt_count + 1); k5 = k3 - eln_index; if k5 > 1 then do; do k4 = 1 to k5 while (file_num = eln_tab.fno (eln_index + k4)); k2 = k2 + statement_info .length (eln_index + k4 - 1) + 1; end; end; else k2 = statement_info.length (eln_index) + 1; print_line = substr (source, k1, k2); call ioa_$ioa_stream (output_switch, "^4x^a", print_line) ; end; end; end; if source_stmt_count < no_source_stmts then do; source_stmt_count = source_stmt_count + 1; text_off = text_addr (source_stmt_count); end; else text_off = cobol_$non_source_offset; end; end; instr_word_num = text_off - obj_off; /*[4.4-1]*/ call cobol_display_text (code_ptr, instr_word_num, output_switch); call ioa_$ioa_stream (output_switch, ""); code_ptr = addrel (code_ptr, instr_word_num); word_count = word_count + instr_word_num; obj_off = obj_off + instr_word_num; end; call ioa_$ioa_stream (output_switch, "^/^a", "END OBJECT CODE"); call cleanup_proc; revert cleanup; cleanup_proc: proc; if list_iocb_ptr ^= null () then do; call iox_$close (list_iocb_ptr, mcode); call iox_$detach_iocb (list_iocb_ptr, mcode); list_iocb_ptr = null (); end; end cleanup_proc; %include cobol_; %include cobol_eln_table; %include cobol_fixed_common; %include cobol_ext_; %include cobol_type7; end cobol_make_list;  cobol_make_merge_file.pl1 05/24/89 1041.5rew 05/24/89 0830.5 61758 /****^ *********************************************************** * * * 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,MCR8082), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8082 cobol_make_merge_file.pl1 Fix wild array subscript. END HISTORY COMMENTS */ /* Modified on 02/22/85 by FCH, [5.3-1], dont clobber fixed common, BUG561 */ /* Modified on 02/20/85 by FCH, [5.3...], Trace added */ /* Modified on 11/23/76 by Bob Chang to change the external bit of merge file table. */ /* Created on 11/17/76 by Bob Chang to set up the temporary merge file. */ /* format: style3 */ cobol_make_merge_file: proc (name_ptr, file_ptr, type12_ptr, type9_ptr); dcl name_ptr ptr, dn_ptr ptr, ft_ptr_save (20) ptr static, first_call fixed bin static init (0), merge_count fixed bin static, ft_ptr ptr; dcl stop_bit bit (1), temp_id char (5), temp_no fixed bin, status_code fixed bin (35), (i, j) fixed bin, rec_id char (5); 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 temp_type12 char (60), (merge_ft_ptr, merge_file_ptr) ptr, temp_file_ptr (20) ptr static, temp_type12_ptr (20) ptr static, (file_ptr, type12_ptr, type9_ptr) ptr, temp_based char (1024) based, temp_file char (1024), temp_type9_ptr (20) ptr static; dcl cobol_read_rand entry (fixed bin, char (5), ptr), cobol_read_ft entry (fixed bin, ptr), cobol_alloc$stack entry (fixed bin, fixed bin, fixed bin), cobol_io_$cobol_vdwf_sput entry (ptr, fixed bin (35), ptr, fixed bin, char (5)), cobol_make_fsb_link entry (ptr); start: /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME);/**/ /*[5.3-1]*/ merge_file_ptr = addrel (cobol_com_ptr, 8 + size (fixed_common)); if first_call = cobol_$compile_count then do i = 1 to merge_count; if ft_ptr_save (i) -> file_table.max_cra_size = temp_file_ptr (i) -> file_table.max_cra_size then do; file_ptr = temp_file_ptr (i); type9_ptr = temp_type9_ptr (i); type12_ptr = temp_type12_ptr (i); go to mfex; end; end; else do; merge_count = 0; first_call = cobol_$compile_count; end; merge_count = merge_count + 1; i = fd_token.file_no; call cobol_read_ft (i, ft_ptr_save (merge_count)); temp_type12_ptr (merge_count) = addr (temp_type12); temp_file_ptr (merge_count) = addr (temp_file); temp_type9_ptr (merge_count) = addr (temp_type9); rec_id = fixed_common.filedescr_offsets (1); stop_bit = "0"b; do while (^stop_bit); call cobol_read_rand (1, rec_id, ft_ptr); rec_id = file_table.next; if rec_id = "00000" then stop_bit = "1"b; end; substr (temp_type12, 1, 60) = substr (name_ptr -> temp_based, 1, 60); temp_no = file_table.file_no + 1; temp_type12_ptr (merge_count) -> fd_token.file_no = temp_no; i = fd_token.file_no; call cobol_read_ft (i, merge_ft_ptr); substr (temp_file, 1, 1024) = substr (merge_ft_ptr -> temp_based, 1, 1024); /*[5.3-1]*/ call cobol_io_$cobol_vdwf_sput (merge_file_ptr, status_code, addr (temp_file), 1024, temp_id); file_table.next = temp_id; if temp_no <= 20 then fixed_common.filedescr_offsets (temp_no) = temp_id; call cobol_read_rand (1, temp_id, ft_ptr); /* setup temporary file table. */ file_table.temp = "1"b; file_table.ao_len = 0; file_table.cat_nm = "cobol_temp_merge_file_"; file_table.id = "cobol_temp_merge_switch_"; file_table.device = 6; file_table.catalogued = 0; file_table.ifn = "cobol_merge_ifn_"; file_table.external = "1"b; file_table.file_status = "0"b; file_table.extra_status = "0"b; file_table.cra_seg = 1000; i = file_table.max_cra_size; file_table.file_no = temp_no; file_table.max_cra_size = ft_ptr_save (merge_count) -> file_table.max_cra_size; file_table.rec_do = ft_ptr_save (merge_count) -> file_table.rec_do; call cobol_alloc$stack (i, 2, j); file_table.cra_offset = j * 4; cobol_$init_stack_off = cobol_$stack_off; call cobol_make_fsb_link (ft_ptr); temp_file_ptr (merge_count) = ft_ptr; temp_type12_ptr (merge_count) -> fd_token.type = 12; temp_type9_ptr (merge_count) -> data_name.seg_num = file_table.cra_seg; temp_type9_ptr (merge_count) -> data_name.offset = file_table.cra_offset; temp_type9_ptr (merge_count) -> data_name.file_num = file_table.file_no; temp_type9_ptr (merge_count) -> data_name.item_length = file_table.max_cra_size; /*[5.3-1]*/ call cobol_io_$cobol_vdwf_sput (merge_file_ptr, status_code, temp_type9_ptr (merge_count), 112, temp_id); call cobol_read_rand (1, temp_id, temp_type9_ptr (merge_count)); /*[5.3-1]*/ call cobol_io_$cobol_vdwf_sput (merge_file_ptr, status_code, temp_type12_ptr (merge_count), 60, temp_id); call cobol_read_rand (1, temp_id, temp_type12_ptr (merge_count)); file_ptr = temp_file_ptr (merge_count); type12_ptr = temp_type12_ptr (merge_count); type9_ptr = temp_type9_ptr (merge_count); mfex: /***..... if Trace_Bit then call cobol_gen_driver_$Tr_End(MY_NAME);/**/ 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 (21) int static init ("COBOL_MAKE_MERGE_FILE");/**/ /***** Declaration for builtin function *****/ dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, size, index) builtin; /***** End of declaration for builtin function *****/ %include cobol_fixed_common; %include cobol_file_table; %include cobol_type12; %include cobol_type9; %include cobol_ext_; %include cobol_; end cobol_make_merge_file;  cobol_make_object_map.pl1 05/24/89 1041.5rew 05/24/89 0830.5 44595 /****^ *********************************************************** * * * 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_make_object_map.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 04/01/81 by FCH, fix decl for map_data_table, [4.4-1], BUG472(TR8869,8970) */ /* Modified since Version 4.4 */ /* format: style3 */ cobol_make_object_map: proc; /* Produces an Object Map in the List segment when "map" option is specified. */ dcl p ptr; dcl q ptr; dcl (ff, nl) char (1); dcl c char (4) based (addr (s)); dcl bit9 bit (9) based; dcl (i, j, t) fixed bin; dcl char_off fixed bin (21); dcl number fixed bin (35); dcl s fixed bin (35); dcl mcode fixed bin (35); dcl char_string char (1048576) based (cobol_$list_ptr); dcl print_line char (120) unaligned based; dcl 1 map_line unaligned based, 2 map_field (7) unaligned, 3 line_field char (7), 3 sp1 char (1), 3 loc_field char (6), 3 sp2 char (3), 2 new_line_char char (1) unaligned; dcl 1 file_line unaligned based (q), 2 file_fld char (2), 2 sp1 char (1), 2 line_fld char (4); dcl 1 header_line unaligned based, 2 form_feed_char char (1), 2 new_line_char1 char (1), 2 header_field char (119), 2 new_line_char2 char (1); 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 hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)); dcl addr builtin; dcl divide builtin; dcl mod builtin; dcl substr builtin; addr (ff) -> bit9 = "000001100"b; /* form feed char */ addr (nl) -> bit9 = "000001010"b; /* new line char */ char_off = cobol_$list_off; p = addr (substr (char_string, char_off, 1)); p -> header_line.form_feed_char = ff; p -> header_line.new_line_char1 = nl; p -> header_line.header_field = (7)" LINE LOC "; p -> header_line.new_line_char2 = nl; char_off = char_off + 122; p = addr (substr (char_string, char_off, 1)); p -> print_line = " "; j = 1; do i = 1 to no_source_stmts; eln_index = line_no (i); if eln_index > 0 then do; number = eln_tab.fno (eln_index); if number > 0 then do; /* copy file */ q = addr (p -> line_field (j)); do t = 2 to 1 by -1 while (number > 0); s = mod (number, 10) + 48; /* "0" = 48(decimal) */ substr (file_fld, t, 1) = substr (c, 4, 1); number = divide (number, 10, 35, 0); end; number = eln_tab.lno (eln_index); do t = 4 to 1 by -1 while (number > 0); s = mod (number, 10) + 48; /* "0" = 48(decimal) */ substr (line_fld, t, 1) = substr (c, 4, 1); number = divide (number, 10, 35, 0); end; end; else do; /* normal source */ number = eln_tab.lno (eln_index); do t = 6 to 1 by -1 while (number > 0); s = mod (number, 10) + 48; /* "0" = 48(decimal) */ substr (p -> line_field (j), t, 1) = substr (c, 4, 1); number = divide (number, 10, 35, 0); end; end; /* Fill location field. */ number = text_addr (i) + cobol_$constant_offset; p -> loc_field (j) = "000000"; do t = 6 to 1 by -1 while (number > 0); s = mod (number, 8) + 48; /* "0" = 48(decimal) */ substr (p -> loc_field (j), t, 1) = substr (c, 4, 1); number = divide (number, 8, 35, 0); end; if j = 7 then do; p -> map_line.new_line_char = nl; char_off = char_off + 120; j = 1; p = addr (substr (char_string, char_off, 1)); p -> print_line = " "; end; else j = j + 1; end; end; if j > 1 then do; /* print last partial line */ number = 17 * (j - 1) + 1; substr (p -> char_string, number, 1) = nl; char_off = char_off + number; end; cobol_$list_off = char_off; call hcs_$set_bc_seg (cobol_$list_ptr, 9 * (cobol_$list_off - 1), mcode); %include cobol_; %include cobol_eln_table; end cobol_make_object_map;  cobol_make_reg_token.pl1 05/24/89 1041.5rew 05/24/89 0830.5 30645 /****^ *********************************************************** * * * 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_make_reg_token.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Renamed on 01/17/77 by ORN from cobol_make_register_token to cobol_make_reg_token */ /* Modified on 01/14/77 by ORN to signal command_error rather than cobol_compiler_error */ /* Modified since Version 2.0 */ /*{*/ /* format: style3 */ cobol_make_reg_token: proc (token_ptr, reg_no); /* create a token (type 100) for registers */ dcl token_ptr ptr; dcl reg_no bit (4); /* token_ptr is a pointer to the token (input/output) (a) if not null the caller will provide the space to hold the token. (b) if null this utility will provide the space and will return the address of the token in this parameter. reg_no is the register number (input) "0001"b - A register. "0010"b - Q register. "0011"b - A and Q register. "1nnn"b - index register nnn. notes: 1. The token will have the following description. (a) A standard token header, (type of 100, size set, and the remainder zeros). 2. A field defined as bit (4). */ /*}*/ dcl 1 token_overflow static, 2 name char (32) init ("cobol_make_reg_token"), 2 message_len fixed bin (35) init (58), 2 message char (58) init ("The temporary token area has run over the end of a segment"); dcl signal_ entry (char (*), ptr, ptr); dcl 1 clear_token aligned based (cobol_type100_ptr), 2 clear_token_wd (token_wd_size) fixed bin; dcl token_wd_size fixed bin init (5); /* size of token in words */ dcl i fixed bin; /*************************************/ start: /* get space for token (if not provided) */ if token_ptr = null () then do; if (binary (rel (cobol_$temp_token_ptr)) + token_wd_size) > 262143 then do; /* token will not fit in temp token area */ call signal_ ("command_error", null (), addr (token_overflow)); return; end; token_ptr = cobol_$temp_token_ptr; cobol_$temp_token_ptr = addrel (cobol_$temp_token_ptr, token_wd_size); end; /* setup token */ cobol_type100_ptr = token_ptr; /* clear token to zeros */ do i = 1 to token_wd_size; clear_token_wd (i) = 0; end; cobol_type100.type = 100; cobol_type100.size = 4 * (token_wd_size); cobol_type100.register = reg_no; 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_type100; %include cobol_; end cobol_make_reg_token;  cobol_make_type3.pl1 05/24/89 1041.5rew 05/24/89 0830.5 23022 /****^ *********************************************************** * * * 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_make_type3.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /*{*/ /* Modified on 1/22/76 by Bob Chang to put comments */ /* format: style3 */ cobol_make_type3: proc (alit_ptr, rw_ptr); type1: entry (alit_ptr, rw_ptr); /* Create a type 3 token (alphanumeric literal) using a type 1 token (reserve word) as a model. It is used for the reserve words quote, space, zero, high value, low-value. */ dcl lit char (1); dcl alit_chars char (24) based (alit_ptr); dcl alit_init_chars char (24) based (addr (alit_init)); dcl 1 alit_init static, 2 size fixed bin init (29), 2 line fixed bin, 2 column fixed bin, 2 type fixed bin init (3), 2 lit_type bit (1) init ("0"b), 2 all_lit bit (1) init ("0"b), 2 filler1 bit (6), 2 lit_size fixed bin init (1); /*}*/ /*************************************/ start: if reserved_word.key = 192 then lit = " "; /* space */ else if reserved_word.key = 180 then lit = "0"; /* zero */ else if reserved_word.key = 235 then lit = """"; /* quote */ else if reserved_word.key = 229 then lit = ""; /* low-value */ else lit = ""; /* high-value */ alit_chars = alit_init_chars; alphanum_lit.line = reserved_word.line; alphanum_lit.column = reserved_word.column; substr (alphanum_lit.string, 1, 1) = lit; 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_type3; end cobol_make_type3;  cobol_make_type9.pl1 05/24/89 1041.5rew 05/24/89 0830.5 108954 /****^ *********************************************************** * * * 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_make_type9.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 04/20/77 by Bob Chang to add new entry copy_sub. */ /* Modified on 01/14/77 by ORN to signal command_abort_ rather than cobol_compiler_error */ /* Modified since Version 2.0 */ /*{*/ /* format: style3 */ cobol_make_type9: proc (new9_ptr, ptr2_3); /* the procedure is not a valid entry point*/ /*}*/ /* DECLARATIONS OF BUILTIN FUNCTIONS */ dcl addr builtin; dcl addrel builtin; dcl binary builtin; dcl null builtin; dcl rel builtin; dcl substr builtin; /*{*/ /* TYPE2_3 ENTRY */ type2_3: entry (new9_ptr, ptr2_3); /* create a type 9 token, using a type 2 token (numeric literal) or a type3 token (alphanumeric literal) as a model. Pool the literal in the type 2 or type 3 token. */ dcl new9_ptr ptr; dcl old9_ptr ptr; dcl ptr2_3 ptr; /* new9_ptr is a pointer to the type 9 token. (input/output) (a) If not null the caller will provide the space to hold the token. (b) If null this utility will provide the space and will return the address of the token in this parameter. ptr2_3 is a pointer to a type 2 or a type 3 token. (input) */ /*}*/ dcl 1 token_overflow static, 2 name char (32) init ("cobol_make_type9"), 2 message_len fixed bin (35) init (58), 2 message char (58) init ("The temporary token area has run over the end of a segment"); dcl 1 con_overflow static, 2 name char (32) init ("cobol_make_type9"), 2 message_len fixed bin (35) init (60), 2 message char (60) init ("object time instructions plus constants exceed 262,144 words"); dcl cobol_pool$search_op entry (char (*), fixed bin, fixed bin (24), fixed bin); dcl signal_ entry (char (*), ptr, ptr); dcl 1 clear_t9 aligned based (dn_ptr), 2 clear_t9_wd (t9_wd_size) fixed bin; dcl 1 clear_t9_sub aligned based (dn_ptr), 2 clear_t9_sub_wd (t9_sub_wd_size) fixed bin; dcl t9_string char (t9_char_size) based; dcl t9_sub_string char (t9_sub_char_size) based; dcl hold_lit char (4096); dcl lit_size fixed bin; dcl lit_wds fixed bin; dcl t9_char_size static fixed bin init (112); /* size of type 9 token in chars */ dcl t9_sub_char_size static fixed bin init (176); /* size of type 9 token in chars */ dcl t9_wd_size static fixed bin init (28); /* size of type 9 token in words */ dcl t9_sub_wd_size static fixed bin init (44); /* size of type 9 token in words */ dcl dn_ptr ptr; dcl i fixed bin; /**** change to 1048576 when get release 1.0 ***/ dcl pool char (262144) based (pool_ptr); dcl pool_ptr ptr; dcl pool_index fixed bin (24); dcl pool_remainder fixed bin (24); dcl index_result fixed bin (24); dcl temp fixed bin (24); dcl in_op fixed bin; /* get space for type 9 token (if not provided) */ call get_token9_space; /* put information in the token */ /* setup basic information in the token */ call basic_info; data_name.display = "1"b; alit_ptr = ptr2_3; nlit_ptr = ptr2_3; data_name.seg_num = 3000; /* constants */ if numeric_lit.type = 2 then do; /* numeric literal (type 2) */ data_name.places_left = numeric_lit.places_left; data_name.places_right = numeric_lit.places_right; data_name.numeric = "1"b; if numeric_lit.sign ^= " " then do; /* signed literal */ data_name.item_signed = "1"b; data_name.sign_separate = "1"b; data_name.sign_type = "100"b; lit_size = numeric_lit.places + 1; hold_lit = numeric_lit.sign || numeric_lit.literal; end; else do; lit_size = numeric_lit.places; hold_lit = numeric_lit.literal; end; data_name.item_length = lit_size; end; else do; /* alphanumeric literal (type 3) */ lit_size = alphanum_lit.lit_size; hold_lit = alphanum_lit.string; data_name.alphanum = "1"b; data_name.item_length = alphanum_lit.lit_size; end; call cobol_pool$search_op (substr (hold_lit, 1, lit_size), 0, temp, in_op); /*6/10/76*/ if in_op = 1 then data_name.seg_num = 3; data_name.offset = temp; return; /*{*/ /* COPY ENTRY*/ copy: entry (new9_ptr, old9_ptr); /* This entry creates a type 9 token by copying another type 9 token. */ /* new9_ptr is a pointer to the new type 9 token. See cobol_make_type9$type2_3 for additional details. (input/output) old9_ptr is a pointer to the original type 9 token. (input) */ /*}*/ /* get space for type 9 token (if not provided) */ call get_token9_space; /* copy the token */ substr (new9_ptr -> t9_string, 1, t9_char_size) = substr (old9_ptr -> t9_string, 1, t9_char_size); return; copy_sub: entry (new9_ptr, old9_ptr); /* This entry creates a type 9 token by copying another type 9 token. */ /* new9_ptr is a pointer to the new type 9 token. See cobol_make_type9$type2_3 for additional details. (input/output) old9_ptr is a pointer to the original type 9 token. (input) */ /*}*/ /* get space for type 9 token (if not provided) */ call get_token9_sub_space; /* copy the token */ substr (new9_ptr -> t9_sub_string, 1, t9_sub_char_size) = substr (old9_ptr -> t9_sub_string, 1, t9_sub_char_size); return; /*{*/ /* ALPHANUMERIC ENTRY*/ alphanumeric: entry (new9_ptr, segno, char_offset, size); /* create a type 9 token for an alphanumeric data item. */ dcl segno fixed bin; dcl char_offset fixed bin (24); dcl size fixed bin (24); /* new9_ptr is a pointer to the type 9 token. See cobol_make_type9$type2_3 for additional details. (input/output) segno is the artificial internal segment number, that can represent cobol data, stack, constant, multics linkage section. (including an offset from the link), definition section, symbol section, cobol linkage section. (input) char_offset is the character offset. If segno represents a constant, then char_offset represents the offset from the end of the constants. (input) size is the size, in characters. (input) Notes: the token will be cleared to zeros initially. */ /*}*/ /* get space for type 9 token (if not provided) */ call get_token9_space; /* set up basic information in the token */ call basic_info; data_name.display = "1"b; data_name.seg_num = segno; data_name.offset = char_offset; data_name.alphanum = "1"b; data_name.item_length = size; return; /*{*/ /* DECIMAL_9BIT ENTRY */ decimal_9bit: entry (new9_ptr, segno, char_offset, places_left, places_right); /* create a type 9 token for a 9 bit decimal data item */ /*dcl segno fixed bin; */ /*dcl char_offset fixed bin (24); */ dcl places_left fixed bin; dcl places_right fixed bin; /* new9_ptr see "cobol_make_type9$alphanumeric", (input/output) segno is the artificial internal segment number, that can represent cobol data, stack,constant, cobol linkage section. (input) char_offset See "cobol_make_type9$alphanumeric". (input) places_left is the number of digits left of the decimal point. Does not include sign. (input) places_right is the number of digits right of the decimal point. (input) Notes: 1. The sign is assumed to be leading and seperate. the size of the data item is assumed to be places_left + places_right + 1. The caller can modify this if the need arises. 2. The token will be cleared to zeros initially. */ /*}*/ /* get space for type 9 token (if not provided) */ call get_token9_space; /* set up basic information in the token */ call basic_info; data_name.display = "1"b; data_name.seg_num = segno; data_name.offset = char_offset; data_name.places_left = places_left; data_name.places_right = places_right; data_name.item_length = places_left + places_right + 1; data_name.numeric = "1"b; data_name.item_signed = "1"b; data_name.sign_separate = "1"b; data_name.sign_type = "100"b; /* leading separate */ return; /*{*/ /*FIXED_BIN_35 ENTRY */ fixed_bin_35: entry (new9_ptr, segno, char_offset); /* create a type 9 token for a fixed bin 35 data item */ /*dcl segno fixed bin; */ /*dcl char_offset fixed bin (24); */ /* See "cobol_make_type9$decimal_9bit" for definitions of the above. Notes: The token will be cleared to zeros initially. */ /*}*/ /* get space for a type 9 token (if not provided) */ call get_token9_space; /* set up basic information in the token */ call basic_info; data_name.seg_num = segno; data_name.offset = char_offset; /****** Note, need to set data_name.comp_8 ****/ return; /* the following is used as a non local go to */ non_local: return; /*{*/ /* SHORT BINARY ENTRY */ short_bin: entry (new9_ptr, segno, char_offset); /* Create a type 9 token for a short binary (18 bit) data item. */ /* new9_ptr,segno, and char_offset are the same as for all other entry points in this procedure. */ /*}*/ /* Get space for type 9 token (if requested) */ if new9_ptr = null () then call get_token9_space; /* Set up basic information in the token. */ call basic_info; /* Set up particular information in the token. */ data_name.numeric = "1"b; data_name.bin_18 = "1"b; data_name.half_word = "1"b; data_name.seg_num = segno; data_name.offset = char_offset; data_name.item_length = 2; data_name.places_left = 6; return; /*{*/ /* LONG BINARY ENTRY */ long_bin: entry (new9_ptr, segno, char_offset); /* Create a type 9 token for a long binary (36 bit) data item. */ /* Get space for type 9 token (if requested.) */ if new9_ptr = null () then call get_token9_space; /* Set up basic information in the token. */ call basic_info; /* Set up particular information in the token. */ data_name.numeric = "1"b; data_name.bin_36 = "1"b; data_name.word = "1"b; data_name.seg_num = segno; data_name.offset = char_offset; data_name.item_length = 4; data_name.places_left = 11; return; /* GET_TOKEN9_SPACE PROC */ get_token9_space: proc; /* get space for type 9 token (if not provided) */ if new9_ptr = null () then do; if (binary (rel (cobol_$temp_token_ptr)) + t9_wd_size) > 262143 then do; /* token will not fit in temp token area */ call signal_ ("command_abort_", null (), addr (token_overflow)); go to non_local; end; new9_ptr = cobol_$temp_token_ptr; cobol_$temp_token_ptr = addrel (cobol_$temp_token_ptr, t9_wd_size); end; return; end get_token9_space; get_token9_sub_space: proc; /* get space for type 9 token (if not provided) */ if new9_ptr = null () then do; if (binary (rel (cobol_$temp_token_ptr)) + t9_sub_wd_size) > 262143 then do; /* token will not fit in temp token area */ call signal_ ("command_abort_", null (), addr (token_overflow)); go to non_local; end; new9_ptr = cobol_$temp_token_ptr; cobol_$temp_token_ptr = addrel (cobol_$temp_token_ptr, t9_sub_wd_size); end; return; end get_token9_sub_space; /* BASIC_INFO PROC */ basic_info: proc; /* setp basic information in type 9 token */ dn_ptr = new9_ptr; /* clear token to zeros */ do i = 1 to t9_wd_size; clear_t9_wd (i) = 0; end; data_name.type = 9; data_name.elementary = "1"b; data_name.size = t9_char_size; return; end basic_info; %include cobol_type2; %include cobol_type3; %include cobol_; %include cobol_type9; end cobol_make_type9;  cobol_make_xref_.pl1 05/24/89 1041.5rew 05/24/89 0830.5 200025 /****^ *********************************************************** * * * 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_make_xref_.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 11/03/81 by FCH, char6 replaced by char8, [5.1-1], phx10955(BUG496) */ /* Modified on 05/16/80 by FCH, [4.2-1], decl for tag_addr corrected */ /* Modified on 07/08/77 by GM to fix binary output on cross ref. */ /* Modified on 02/10/77 by ORN to include cd-name info and misc changes */ /* Modified on 01/19/77 by ORN to give occurs info and full class description */ /* Modified since Version 2.0 */ /* format: style3 */ cobol_make_xref_: proc; /* Produces an Cross-Reference Listing in the List segment when "symbols" option is specified. */ dcl (p, q) ptr; dcl line_ptr ptr; dcl dn_ptr ptr; dcl name_ptr ptr; dcl ft_ptr ptr; dcl (ff, nl) char (1); /*[5.1-1]*/ dcl char8 char (8); dcl char9 char (9); dcl p_type char (1); dcl picture_string char (15); dcl noxref char (35); dcl c char (4) based (q); dcl name_string char (30) varying; dcl bit9 bit (9) based; dcl bit36 bit (36) based (addr (number)); dcl (i, n, t) fixed bin; dcl char_off fixed bin (21); dcl char_offset fixed bin; dcl c_off fixed bin; dcl cv_length fixed bin; dcl fl_length fixed bin; dcl cv_off fixed bin; dcl name_length fixed bin; dcl left fixed bin; dcl tag_loc fixed bin; dcl number fixed bin (35); dcl s fixed bin (35); dcl mcode fixed bin (35); /*[4.2-1]*/ declare 1 DEF aligned based (cobol_$tag_table_ptr), /*[4.2-1]*/ 2 tag_max fixed bin, /*[4.2-1]*/ 2 TAG (32767), /*[4.2-1]*/ 3 tag_addr fixed bin (17) unal, /*[4.2-1]*/ 3 tag_no fixed bin (17) unal; dcl code_generated bit (1); dcl alpha bit (1); dcl numeric bit (1); dcl edited bit (1); dcl varying bit (1); dcl fixed_binary bit (1); dcl char_string char (1048576) based (cobol_$list_ptr); dcl line char (120) based (line_ptr); dcl maxlen_id char (23) based (line_ptr); dcl 1 print_line unaligned based (line_ptr), 2 identifier char (18), 2 filler1 char (2), 2 level_no char (2), 2 filler2 char (2), 2 type char (4), 2 filler3 char (2), 2 offset char (6), 2 bit_offset char (4), 2 redef char (1), 2 filler4 char (1), 2 usage char (15), 2 filler5 char (1), 2 occ char (2), 2 filler6 char (2), 2 pic_string char (15), 2 filler7 char (2); dcl def_ref char (100) based (line_ptr); dcl 1 header_line unaligned based (line_ptr), 2 form_feed_char char (1), 2 new_line_char1 char (1), 2 header_field char (82), 2 new_line_char2 char (1), 2 new_line_char3 char (1); dcl 1 token based, 2 size fixed bin (15), 2 line fixed bin (15), 2 column fixed bin (15), 2 type fixed bin (15); dcl 1 c_n based (p), 2 size fixed bin (15), 2 line fixed bin (15), 2 column fixed bin (7), 2 type fixed bin (7), /* type = 11 */ 2 string_ptr ptr, 2 prev_rec ptr, 2 info bit (8), 2 def_line fixed bin (15), 2 level fixed bin (7), 2 num_lits fixed bin (15), 2 name_size fixed bin (7), 2 name char (c_n.name_size); dcl display_sign (0:4) char (6) static init ("eric", " trovr", " ldovr", " trsep", " ldsep"); dcl hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)); dcl cobol_read_ft entry (fixed bin, ptr); dcl ioa_ entry options (variable); dcl addr builtin; dcl addrel builtin; dcl divide builtin; dcl fixed builtin; dcl length builtin; dcl mod builtin; dcl substr builtin; dcl dn (1000) char (1) based (dn_ptr); /* used for calculating type 9 extension offsets */ /*************************************/ start: call sort_tokens; addr (ff) -> bit9 = "000001100"b; /* form feed char */ addr (nl) -> bit9 = "000001010"b; /* new line char */ q = addr (s); code_generated = fixed_common.fatal_no = 0; char_off = cobol_$list_off; line_ptr = addr (substr (char_string, char_off, 1)); if cobol_$xref_bypass then do; noxref = "NO CROSS-REFERENCE LISTING PRODUCED"; line = nl || noxref || nl; char_off = char_off + 37; go to finish_up; end; header_line.form_feed_char = ff; header_line.new_line_char1 = nl; header_line.header_field = "IDENTIFIER LN TYPE OFFSET USAGE/CLASS DM PICTURE DEF. REF. LINES"; header_line.new_line_char2 = nl; header_line.new_line_char3 = nl; char_off = char_off + 86; line_ptr = addr (substr (char_string, char_off, 1)); line = " "; do i = 1 to token_count; p = token_ptr (i); go to token_type (p -> token.type); token_type (7): /* Procedure Definition (label) */ token_type (18): /* Procedure Reference (label reference) */ proc_def_ptr = p; name_string = proc_def.name; call fill_identifier (23); print_line.type = "TEXT"; if code_generated then do; tag_loc = cobol_$tag_table_ptr -> tag_addr (proc_def.proc_num); do while (tag_loc < 0); tag_loc = cobol_$tag_table_ptr -> tag_addr (-tag_loc); end; number = cobol_$constant_offset + tag_loc; call convert_word_offset; end; if proc_def.section_name then print_line.usage = "section-name"; else print_line.usage = "paragraph-name"; eln_index = proc_def.def_line; go to next; token_type (9): /* Data-Name */ dn_ptr = p; if data_name.name = "FILLER" then go to token_type (0); if data_name.name = "SYSTEM-STATUS" | data_name.name = "TALLY" | data_name.name = "LINAGE-COUNTER" then go to token_type (0); fixed_binary = "0"b; name_string = data_name.name; call fill_identifier (19); number = data_name.level; call convert10; /*[5.1-1]*/ print_line.level_no = substr (char8, 7, 2); if data_name.working_storage then do; print_line.type = "DATA"; number = data_name.offset; call convert_offset; end; else if data_name.constant_section then do; print_line.type = "CNST"; if code_generated then do; number = data_name.offset; char_offset = fixed (substr (bit36, 35, 2), 17); number = cobol_$constant_offset - fixed (substr (bit36, 1, 34), 35); call convert_word_offset; call convert_bit_offset; end; end; else if data_name.file_section then do; print_line.type = "FREC"; number = data_name.offset; call convert_offset; end; else if data_name.communication_section then do; print_line.type = "CREC"; number = data_name.offset; call convert_offset; end; else if data_name.linkage_section then do; print_line.type = "PARM"; number = data_name.offset; call convert_offset; number = data_name.linkage; call convert10; if data_name.level = 01 | data_name.level = 77 then do; print_line.bit_offset = ""; print_line.offset = substr (char8, cv_off, cv_length); end; else if substr (print_line.offset, 1, cv_length + 1) = substr ("000000", 1, cv_length + 1) then substr (print_line.offset, 1, cv_length + 1) = substr (char8, cv_off, cv_length) || "/"; else do; print_line.bit_offset = ""; print_line.offset = substr (char8, cv_off, cv_length) || "/....."; end; end; if data_name.display then do; if data_name.numeric then print_line.usage = "DSPLY num" || display_sign (fixed (data_name.sign_type, 17)); else if data_name.alphanum then print_line.usage = "DSPLY alphanum"; else if data_name.numeric_edited then print_line.usage = "DSPLY num-edit"; else if data_name.alphabetic then print_line.usage = "DSPLY alphabet"; else print_line.usage = "DSPLY alph-edit"; end; else if data_name.non_elementary then print_line.usage = "GROUP alphanum"; else if data_name.usage_index then print_line.usage = "INDEX"; else if data_name.ascii_packed_dec_h then print_line.usage = "COMP8 numeric"; else if data_name.ascii_packed_dec then print_line.usage = "COMP5 numeric"; else if data_name.bin_18 then do; print_line.usage = "COMP7 numeric"; print_line.pic_string = "S9(6) bin(17)"; fixed_binary = "1"b; end; else if data_name.bin_36 then do; print_line.usage = "COMP6 numeric"; print_line.pic_string = "S9(11) bin(35)"; fixed_binary = "1"b; end; else if data_name.ebcdic_packed_dec then print_line.usage = "COMP3 numeric"; else if data_name.bin_16 then do; print_line.usage = "COMP1 numeric"; print_line.pic_string = "S9(5) bin(15)"; fixed_binary = "1"b; end; else if data_name.bin_32 then do; print_line.usage = "COMP2 numeric"; print_line.pic_string = "S9(9) bin(31)"; fixed_binary = "1"b; end; if data_name.occurs_ptr ^= 0 then do; occurs_ptr = addr (dn (data_name.occurs_ptr)); if occurs.dimensions = 1 then print_line.occ = " 1"; else if occurs.dimensions = 2 then print_line.occ = " 2"; else print_line.occ = " 3"; if data_name.occurs_do then substr (print_line.occ, 1, 1) = "*"; end; else print_line.occ = ""; if data_name.s_of_rdf then print_line.redef = "r"; else print_line.redef = ""; if ^fixed_binary then do; edited = data_name.alphanum_edited | data_name.alphabetic_edited | data_name.numeric_edited; varying = data_name.pic_has_l | data_name.pic_is_do; if edited & varying then print_line.pic_string = "EDITED,VARYING"; else do; alpha = "0"b; numeric = "0"b; if data_name.alphanum | data_name.alphanum_edited | data_name.non_elementary then do; alpha = "1"b; picture_string = "X("; c_off = 3; end; else if data_name.alphabetic | data_name.alphabetic_edited then do; alpha = "1"b; picture_string = "A("; c_off = 3; end; else do; numeric = data_name.numeric | data_name.numeric_edited; picture_string = " "; c_off = 1; end; if alpha then do; number = data_name.item_length; call convert10; substr (picture_string, c_off, cv_length + 1) = substr (char8, cv_off, cv_length) || ")"; c_off = c_off + cv_length + 1; end; else if numeric then do; left = data_name.places_left; if data_name.numeric then if data_name.item_signed then if data_name.display | data_name.ascii_packed_dec | data_name.ascii_packed_dec_h then do; substr (picture_string, c_off, 1) = "S"; c_off = 2; end; if left < 0 then do; p_type = "P"; number = -left; call fill_pic_field; end; else if left > 0 & data_name.places_right > 0 then do; p_type = "9"; number = left; call fill_pic_field; left = 0; end; if left = 0 then do; substr (picture_string, c_off, 1) = "V"; c_off = c_off + 1; end; p_type = "9"; number = left + data_name.places_right; call fill_pic_field; if data_name.places_right < 0 then do; p_type = "P"; number = -data_name.places_right; call fill_pic_field; end; end; if edited then if c_off > 12 then picture_string = "EDITED"; else if c_off > 10 then substr (picture_string, c_off) = "EDIT"; else substr (picture_string, c_off) = "EDITED"; else if varying then if c_off > 13 then picture_string = "VARYING"; else if c_off > 9 then substr (picture_string, c_off) = "VAR"; else substr (picture_string, c_off) = "VARYING"; print_line.pic_string = picture_string; end; end; eln_index = data_name.def_line; go to next; token_type (10): /* Index-Name */ ind_ptr = p; name_string = substr (index_name.name, 1, index_name.name_size); call fill_identifier (23); print_line.type = "DATA"; number = index_name.offset; call convert_offset; print_line.usage = "index-name"; eln_index = index_name.def_line; go to next; token_type (11): /* Condition Name */ name_string = c_n.name; call fill_identifier (19); print_line.level_no = "88"; print_line.usage = "CONDITION NAME"; eln_index = c_n.def_line; go to next; token_type (12): /* File Name */ print_line.level_no = "FD"; join_file: name_ptr = p; name_string = fd_token.name; call fill_identifier (19); call cobol_read_ft (fd_token.file_no, ft_ptr); print_line.type = "FILE"; number = file_table.cra_offset; call convert_offset; if p -> token.type = 16 then print_line.usage = "SORT"; else do; /* Fill in file organization and access. */ go to org (file_table.organization); org (0): org (1): print_line.usage = "SEQ"; go to fill_access; org (2): print_line.usage = "REL"; go to fill_access; org (3): print_line.usage = "INX"; go to fill_access; org (4): org (5): print_line.usage = "STR"; go to fill_access; fill_access: go to acc (file_table.access); acc (0): acc (1): substr (print_line.usage, 4, 4) = "/SEQ"; go to fill_device; acc (2): substr (print_line.usage, 4, 4) = "/RND"; go to fill_device; acc (3): substr (print_line.usage, 4, 4) = "/DYN"; go to fill_device; fill_device: go to dev (file_table.device); dev (0): dev (6): substr (print_line.usage, 8, 8) = " virtual"; go to end_fd; dev (1): substr (print_line.usage, 8, 8) = " printer"; go to end_fd; dev (2): substr (print_line.usage, 8, 8) = " cardrdr"; go to end_fd; dev (3): substr (print_line.usage, 8, 8) = " cardpch"; go to end_fd; dev (4): substr (print_line.usage, 8, 8) = " disk"; go to end_fd; dev (5): substr (print_line.usage, 8, 8) = " tape"; go to end_fd; dev (7): dev (8): dev (9): dev (10): end_fd: if file_table.external then substr (print_line.usage, 14, 3) = "ext"; picture_string = "X("; c_off = 3; number = file_table.max_cra_size; call convert10; substr (picture_string, c_off, cv_length + 1) = substr (char8, cv_off, cv_length) || ")"; c_off = c_off + cv_length + 1; print_line.pic_string = picture_string; end; eln_index = fd_token.def_line; go to next; token_type (13): cdtoken_ptr = p; print_line.level_no = "CD"; name_string = cdtoken.name; call fill_identifier (19); print_line.type = "COMM"; if cdtoken.options.input then print_line.usage = "cd-name(input)"; else print_line.usage = "cd-name(output)"; eln_index = cdtoken.def_line; go to next; token_type (16): print_line.level_no = "SD"; go to join_file; token_type (17): name_ptr = p; name_string = mnemonic_name.name; call fill_identifier (23); print_line.type = "SYS"; print_line.usage = "mnemonic-name"; eln_index = mnemonic_name.def_line; go to next; token_type (40): alpha_name_ptr = p; name_string = alphabet_name.name; call fill_identifier (23); if alphabet_name.iw_key ^= 0 then print_line.type = "SYS"; else print_line.type = "CNST"; print_line.usage = "alphabet-name"; eln_index = alphabet_name.def_line; go to next; next: call fill_def_ref; line_ptr = addr (substr (char_string, char_off, 1)); line = " "; token_type (0): token_type (1): token_type (2): token_type (3): token_type (4): token_type (5): token_type (6): token_type (8): token_type (14): token_type (15): token_type (19): token_type (20): end; finish_up: cobol_$list_off = char_off; call hcs_$set_bc_seg (cobol_$list_ptr, 9 * (cobol_$list_off - 1), mcode); exit: return; /*************************************/ fill_def_ref: proc; char_off = char_off + 79; line_ptr = addr (substr (char_string, char_off, 1)); substr (def_ref, 1, 4) = "def "; call file_line; substr (def_ref, 5, fl_length) = substr (char9, 1, fl_length); c_off = fl_length + 6; n = addrel (p, divide (p -> token.size + 3, 4, 17, 0)) -> xref_chain.first; if n = 0 then do; substr (def_ref, c_off, 5) = "NOREF"; c_off = c_off + 5; end; else do; substr (def_ref, c_off, 3) = "ref"; c_off = c_off + 3; do while (n > 0); eln_index = ref_line (n); call file_line; if c_off + fl_length > 39 then do; /* close this line and start new line */ substr (def_ref, c_off, 1) = nl; char_off = char_off + c_off; substr (char_string, char_off, 16) = (7)" " || (9)" "; /* 7 tabs + 9 spaces */ char_off = char_off + 16; line_ptr = addr (substr (char_string, char_off, 1)); def_ref = " "; c_off = 1; end; else c_off = c_off + 1; /* insert space between def-ref line nos */ substr (def_ref, c_off, fl_length) = substr (char9, 1, fl_length); c_off = c_off + fl_length; n = chain_area.next (n); end; end; substr (def_ref, c_off, 1) = nl; char_off = char_off + c_off; end fill_def_ref; file_line: proc; fl_length = 0; if eln_index ^= 0 then number = eln_tab.fno (eln_index); else number = 0; if number > 0 then do; call convert10; substr (char9, 1, cv_length) = substr (char8, cv_off, cv_length); fl_length = cv_length + 1; substr (char9, fl_length, 1) = "-"; end; if eln_index ^= 0 then number = eln_tab.lno (eln_index); else number = 1; call convert10; substr (char9, fl_length + 1, cv_length) = substr (char8, cv_off, cv_length); fl_length = fl_length + cv_length; end file_line; fill_pic_field: proc; substr (picture_string, c_off, 1) = p_type; c_off = c_off + 1; substr (picture_string, c_off, 1) = "("; c_off = c_off + 1; call convert10; substr (picture_string, c_off, cv_length) = substr (char8, cv_off, cv_length); c_off = c_off + cv_length; substr (picture_string, c_off, 1) = ")"; c_off = c_off + 1; end fill_pic_field; fill_identifier: proc (max); dcl max fixed bin parameter; name_length = length (name_string); if name_length > max then do; line = name_string || nl; char_off = char_off + name_length + 1; line_ptr = addr (substr (char_string, char_off, 1)); line = " "; end; else substr (maxlen_id, 1, max) = name_string; end fill_identifier; convert_offset: proc; char_offset = fixed (substr (bit36, 35, 2), 17); number = fixed (substr (bit36, 1, 34), 35); call convert_word_offset; convert_bit_offset: entry; if p -> data_name.type = 9 then if data_name.bit_offset ^= ""b then go to half_byte_off (char_offset); go to byte_off (char_offset); byte_off (1): print_line.bit_offset = "(9)"; return; half_byte_off (1): print_line.bit_offset = "(14)"; return; byte_off (2): print_line.bit_offset = "(18)"; return; half_byte_off (2): print_line.bit_offset = "(23)"; return; byte_off (3): print_line.bit_offset = "(27)"; return; half_byte_off (3): print_line.bit_offset = "(32)"; return; byte_off (0): return; half_byte_off (0): print_line.bit_offset = "(5)"; return; end convert_offset; convert_word_offset: proc; print_line.offset = "000000"; do t = 6 to 1 by -1 while (number > 0); s = fixed (substr (bit36, 34, 3), 35) + 48; substr (print_line.offset, t, 1) = substr (c, 4, 1); number = fixed (substr (bit36, 1, 33), 35); end; end convert_word_offset; convert10: proc; char8 = (8)"0"; /*[5.1-1]*/ do t = 8 to 1 by -1 while (number > 0); s = mod (number, 10) + 48; substr (char8, t, 1) = substr (c, 4, 1); number = divide (number, 10, 35, 0); cv_off = t; end; /*[5.1-1]*/ cv_length = 9 - cv_off; end convert10; sort_tokens: proc; /* This routine sorts the array of ptrs to Name-Table tokens. It does a Shell sort alphabetizing on the name in the token. */ dcl (d, i, j, k) fixed bin; dcl (p, p1, p2) ptr; dcl name_string char (30) varying based; d = token_count; down: d = 2 * divide (d, 4, 17, 0) + 1; do i = 1 to token_count - d; k = i + d; p2 = token_area.name_ptr (k); up: j = k - d; p1 = token_area.name_ptr (j); if p1 -> name_string > p2 -> name_string then do; token_area.name_ptr (k) = p1; token_area.name_ptr (j) = p2; p = token_ptr (k); token_ptr (k) = token_ptr (j); token_ptr (j) = p; if j > d then do; k = j; go to up; end; end; end; if d > 1 then go to down; end sort_tokens; %include cobol_; %include cobol_ext_; %include cobol_fixed_common; %include cobol_xref; %include cobol_eln_table; %include cobol_type7; %include cobol_type9; %include cobol_type10; %include cobol_type12; %include cobol_file_table; %include cobol_type13; %include cobol_type17; %include cobol_type40; %include cobol_occurs_ext; end cobol_make_xref_;  cobol_merge_gen.pl1 05/24/89 1041.5rew 05/24/89 0830.5 235287 /****^ *********************************************************** * * * 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_merge_gen.pl1 Added Trace statements. END HISTORY COMMENTS */ /* Modified on 01/20/85 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 11/20/76 by Bob Chang to cooperate with alphabet_name token. */ /* Modified on 11/15/76 by Bob Chang to cooperate with sort statement for setting static data. */ /* Created on 10/11/76 by Bob Chang for merge statemnet. */ /* format: style3 */ cobol_merge_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 an_type9_based char (112) based (addr (an_type9)); dcl an_type9_init_based char (112) based (addr (an_type9_init)); dcl 1 an_type9_init 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 an_type9, 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 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_out 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 ("0000001000000000"b); 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 1 return_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 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 type19_read 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 ("0010000000000000"b); dcl stz_inst (2) bit (18) static init ("110000000000000000"b, "100101000001000000"b); /* stz pr6|tree(i) */ dcl spr (2) bit (18) static init ("110000000000000000"b, "010101001101000000"b); /* spri1 pr6|record_ptr(i) */ dcl tra_inst (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 epp_inst (4) bit (18) static init ("000000000000000000"b, "011101010000000100"b, /* epp2 open_tag(i+1),ic */ "110000000000000000"b, "010101010001000000"b); /* spri2 pr6|ret_off */ dcl ret_inst (2) bit (18) static init ("110000000000000000"b, "111001000001010000"b); /* tra pr6|ret_off,* */ 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 1 merge_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 1 read_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 1 read_into_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 return_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 close_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 1 open_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 1 open_out_token static, 2 n fixed bin init (3), 2 code fixed bin init (0), 2 pt1 ptr, 2 pt2 ptr, 2 pt3 ptr; dcl 1 write_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 file_ptr (256) ptr, read_tag (256) fixed bin, bgn_tag fixed bin, open_tag (256) fixed bin, end_tag fixed bin, not_end_tag fixed bin, file_n fixed bin static, /* no of using files */ key_n fixed bin static; /* no of keys. */ 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, ft_ptr ptr, /* pointer to the type 12 token */ merge_file_ptr ptr, /* pointer to the type 12 token */ merge_gen_ptr ptr, ret_off fixed bin, 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), merge_stack_off fixed bin static init (0), /* returned value of cobol_alloc$stack */ temp fixed bin, merge_gen_text_wd_off fixed bin, alphabet_flag fixed bin, retry_tag fixed bin, passed_tag fixed bin, passed_tag1 fixed bin, k fixed bin, i fixed bin, /* work variable */ j fixed bin, l fixed bin, linkoff fixed bin; /* word offset of entry point link */ dcl dn_ptr ptr, /* pointer to the type 9 token */ alpha_ptr ptr; dcl in_buff char (24), /*input struc buffer */ inst_buff char (8), /* inst_struc buffer */ reloc_buff char (8); /* reloc_struc bufer */ dcl bit18 bit (18) based; dcl temp_type12 char (60) static, temp_file_ptr ptr static, temp_type12_ptr ptr static, temp_type9_ptr ptr static; /* Procedures Called */ dcl cobol_compare_gen$sort entry (ptr, ptr), cobol_addr entry (ptr, ptr, ptr), cobol_write_gen entry (ptr, fixed bin), cobol_open_gen entry (ptr), cobol_close_gen entry (ptr), cobol_read_gen entry (ptr, fixed bin), 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, ptr), cobol_make_merge_file entry (ptr, ptr, ptr, ptr); start: /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME);/**/ eos_ptr = in_token.token_ptr (1); if end_stmt.type = 19 then do; if end_stmt.h = 91 then go to mex; else if end_stmt.h = 90 then do; close_in_token.pt2 = temp_type12_ptr; call cobol_close_gen (addr (close_in_token)); go to mex; end; go to mex; end; eos_ptr = in_token.token_ptr (in_token.n); if end_stmt.h = 92 then do; call giving; go to mex; end; merge_file_ptr = in_token.token_ptr (2); desc_ptr = addr (desc_off (1)); file_n = end_stmt.i; key_n = end_stmt.e; if first_call ^= cobol_$compile_count then do; first_call = cobol_$compile_count; i = 16 * (file_n + 2); call cobol_alloc$stack (i, 2, merge_stack_off); cobol_$init_stack_off = cobol_$stack_off; end; input_ptr = addr (in_buff); inst_ptr = addr (inst_buff); reloc_ptr = addr (reloc_buff); call initiate; alpha_name_ptr = null (); if end_stmt.d ^= "00"b then do; alphabet_flag = 1; alpha_name_ptr = in_token.token_ptr (key_n + 3); if alphabet_name.iw_key = 11 then do; /* ascii */ 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; else alphabet_flag = 0; /* 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 (tra_inst), null (), 1); text_ptr = addrel (cobol_$text_base_ptr, cobol_$text_wd_off); call cobol_sort_util (merge_file_ptr, desc_ptr, object_name, object_name_len); call cobol_def_util (3, object_name, object_name_len, text_ptr, 0, desc_ptr, in_token_ptr); 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); merge_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 */ last_token = key_n + 2; do i = 3 to last_token; merge_in_token.pt1 = in_token.token_ptr (i); merge_in_token.pt2 = addr (alpha_type9); alpha_type9 = merge_in_token.pt1 -> alpha_type9_based; merge_in_token.pt3 = addr (type19); type19.e = 102; /* EQUAL */ merge_in_token.pt2 -> data_name.seg_num = 5002; merge_in_token.pt1 -> data_name.seg_num = 5001; if data_name.numeric = "0"b then do; /* switch compare operands around */ workpt2 = merge_in_token.pt2; merge_in_token.pt2 = merge_in_token.pt1; merge_in_token.pt1 = workpt2; end; type19.h = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_compare_gen$sort (addr (merge_in_token), alpha_name_ptr); if data_name.ad_bit = "0"b then substr (instr_seq11 (2), 7, 3) = "011"b;/* make TRC */ if data_name.numeric = "1"b then substr (instr_seq11 (2), 7, 3) = "100"b;/* make TMI */ if data_name.numeric = "1"b & data_name.ad_bit = "0"b then substr (instr_seq11 (2), 7, 3) = "101"b;/* make TPL */ 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; merge_gen_ptr = addrel (cobol_$text_base_ptr, merge_gen_text_wd_off); substr (merge_gen_ptr -> bit18, 1, 18) = substr (unspec (temp), 19, 18); call cobol_define_tag (passed_tag); /* open and read the using files */ open_out_token.pt3 = addr (type19_out); open_out_token.pt1 = in_token.token_ptr (1); close_in_token.pt3 = addr (type19); close_in_token.pt1 = in_token.token_ptr (1); write_in_token.pt3 = addr (type19); write_in_token.pt1 = in_token.token_ptr (1); open_in_token.pt1 = in_token.token_ptr (1); open_in_token.pt3 = addr (type19); read_in_token.pt1 = in_token.token_ptr (1); return_in_token.pt1 = in_token.token_ptr (1); return_in_token.pt2 = in_token.token_ptr (2); return_in_token.pt4 = addr (return_type19); read_in_token.pt3 = addr (type19_read); read_into_token.pt4 = addr (type19_read_into); read_into_token.pt1 = in_token.token_ptr (1); if alphabet_flag = 0 then k = key_n + 1; else k = key_n + 2; j = merge_stack_off + 2 * file_n - 1; /* set up return address for return statement. */ open_tag (1) = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; ret_off = merge_stack_off + 4 * file_n + 4; substr (epp_inst (3), 4, 15) = substr (unspec (ret_off), 22, 15); substr (ret_inst (1), 4, 15) = substr (unspec (ret_off), 22, 15); do i = 1 to file_n; /* set return address for return statement */ open_tag (i + 1) = cobol_$next_tag; read_tag (i) = cobol_$next_tag + 1; passed_tag = cobol_$next_tag + 2; cobol_$next_tag = cobol_$next_tag + 3; call cobol_define_tag (open_tag (i)); call cobol_emit (addr (epp_inst (1)), null (), 2); call cobol_make_tagref (open_tag (i + 1), cobol_$text_wd_off - 2, null ()); open_in_token.pt2 = in_token.token_ptr (i * 2 + k); file_ptr (i) = open_in_token.pt2; call cobol_open_gen (addr (open_in_token)); /* read */ call cobol_define_tag (read_tag (i)); call cobol_read_ft (file_ptr (i) -> fd_token.file_no, ft_ptr); an_type9_based = an_type9_init_based; an_type9.seg = file_table.cra_seg; an_type9.off = file_table.cra_offset; an_type9.size = file_table.max_cra_size; input_struc.type = 2; input_struc.operand_no = 1; input_struc.lock = 0; input_struc.operand.token_ptr (1) = addr (an_type9); input_struc.operand.size_sw (1) = 0; call cobol_addr (input_ptr, inst_ptr, reloc_ptr); inst_struc_basic.fill1_op = "0111010011"b; /* epp1 */ call cobol_emit (inst_ptr, reloc_ptr, 1); l = merge_stack_off + 2 * (i - 1); substr (spr (1), 4, 15) = substr (unspec (l), 22, 15); call cobol_emit (addr (spr (1)), null (), 1); read_in_token.pt2 = file_ptr (i); call cobol_read_gen (addr (read_in_token), passed_tag); /* stz pr6|tree(i) */ l = j + i; substr (stz_inst (1), 4, 15) = substr (unspec (l), 22, 15); call cobol_emit (addr (stz_inst (1)), null (), 1); call cobol_define_tag (passed_tag); call cobol_emit (addr (ret_inst (1)), null (), 1); end; call cobol_define_tag (open_tag (file_n + 1)); /* call compare routine through cobol_rts. */ call cobol_call_op (61, 0); call cobol_make_merge_file (in_token.token_ptr (2), temp_file_ptr, temp_type12_ptr, temp_type9_ptr); call create_temp_file; do i = 1 to file_n; close_in_token.pt2 = file_ptr (i); call cobol_close_gen (addr (close_in_token)); end; mex: /***..... if Trace_Bit then call cobol_gen_driver_$Tr_End(MY_NAME);/**/ 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 (15) int static init ("COBOL_MERGE_GEN");/**/ /* BEGIN create_temp_file */ create_temp_file: proc; open_out_token.pt2 = temp_type12_ptr; call cobol_open_gen (addr (open_out_token)); return_in_token.pt3 = temp_type9_ptr; bgn_tag = cobol_$next_tag; end_tag = cobol_$next_tag + 1; cobol_$next_tag = cobol_$next_tag + 2; call cobol_define_tag (bgn_tag); call return_proc (not_end_tag); call cobol_emit (addr (tra_inst), null (), 1); call cobol_make_tagref (end_tag, cobol_$text_wd_off - 1, null ()); call cobol_define_tag (not_end_tag); write_in_token.pt2 = temp_type9_ptr; call cobol_write_gen (addr (write_in_token), 0); call cobol_emit (addr (tra_inst), null (), 1); call cobol_make_tagref (bgn_tag, cobol_$text_wd_off - 1, null ()); call cobol_define_tag (end_tag); close_in_token.pt2 = temp_type12_ptr; call cobol_close_gen (addr (close_in_token)); open_in_token.pt2 = temp_type12_ptr; call cobol_open_gen (addr (open_in_token)); end create_temp_file; /* END create_temp_file */ /* BEGIN giving */ giving: proc; /* open output giving file */ open_out_token.pt2 = in_token.token_ptr (2); call cobol_open_gen (addr (open_out_token)); end_tag = cobol_$next_tag; passed_tag = cobol_$next_tag + 1; passed_tag1 = cobol_$next_tag + 2; cobol_$next_tag = cobol_$next_tag + 3; call cobol_define_tag (passed_tag1); /* read temp file */ read_into_token.pt2 = temp_type12_ptr; read_into_token.pt3 = in_token.token_ptr (1); call cobol_read_gen (addr (read_into_token), passed_tag); call cobol_emit (addr (tra_inst), null (), 1); call cobol_make_tagref (end_tag, cobol_$text_wd_off - 1, null ()); call cobol_define_tag (passed_tag); /* write giving file */ write_in_token.pt2 = in_token.token_ptr (1); call cobol_write_gen (addr (write_in_token), 0); call cobol_emit (addr (tra_inst), null (), 1); call cobol_make_tagref (passed_tag1, cobol_$text_wd_off - 1, null ()); call cobol_define_tag (end_tag); /* close output giving file */ close_in_token.pt2 = in_token.token_ptr (2); call cobol_close_gen (addr (close_in_token)); end giving; /* END giving */ /* BEGIN return_proc */ return_proc: proc (passed_tag); dcl 1 mlr_struct static, 2 type fixed bin init (5), 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 ldq_inst (16) bit (18) static init ("110000000000000000"b, "010011110001000000"b, /* ldq pr6|tree(2n-1) */ "000000000000000000"b, "110000000000000100"b, /* tze end_tag,ic */ "000000000000000001"b, "001111110000000111"b, /* sbq 1,dl */ "000000000000000100"b, "100000010000000111"b, /* mpy 4,dl */ "000000000000000000"b, "011101010000000100"b, /* epp2 def_tag,ic */ "110000000000000000"b, "010101010001000000"b, /* spri2 pr6|ret_off */ "000000000000000010"b, "011101010000000100"b, /* epp2 2,ic */ "010000000000000000"b, "111001000001000110"b); /* tra pr2|0,ql */ dcl tra_read_inst (2) bit (18) static init ("000000000000000000"b, "111001000000000100"b); /* tra read_tag(i),ic */ dcl inst_seq2 (2) bit (18) static init ("000000000000000000"b, "111001000000000100"b); /* tra 0,ic */ dcl rel_seq2 (2) bit (5) aligned static init ("00000"b, "00000"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 eos_buff (5) ptr; dcl passed_tag fixed bin, def_tag fixed bin, end_tag fixed bin; start: eos_ptr = addr (eos_buff); name_ptr = return_in_token.pt2; passed_tag = cobol_$next_tag; def_tag = cobol_$next_tag + 1; end_tag = cobol_$next_tag + 2; cobol_$next_tag = cobol_$next_tag + 3; /* check tree(2n-1) */ i = merge_stack_off + 4 * file_n - 2; substr (ldq_inst (1), 4, 15) = substr (unspec (i), 22, 15); i = i + 6; substr (ldq_inst (11), 4, 15) = substr (unspec (i), 22, 15); call cobol_emit (addr (ldq_inst (1)), null (), 8); call cobol_make_tagref (def_tag, cobol_$text_wd_off - 4, null ()); call cobol_make_tagref (end_tag, cobol_$text_wd_off - 7, null ()); /* set up mlr instruction for the move of record(i) to merge cra. */ mlr_struct.operand2.token_ptr = return_in_token.pt3; instr (1) = mlr_reg_to_reg; instr (2) = ""b; instr (3) = ""b; an_type9_based = an_type9_init_based; do i = 1 to file_n; call cobol_read_ft (file_ptr (i) -> fd_token.file_no, ft_ptr); an_type9.seg = file_table.cra_seg; an_type9.off = file_table.cra_offset; an_type9.size = file_table.max_cra_size; mlr_struct.operand1.token_ptr = addr (an_type9); call cobol_addr (addr (mlr_struct), addr (instr (1)), null ()); call cobol_emit (addr (instr (1)), null (), 3); call cobol_emit (addr (tra_read_inst (1)), null (), 1); call cobol_make_tagref (read_tag (i), cobol_$text_wd_off - 1, null ()); end; call cobol_define_tag (def_tag); call cobol_call_op (62, 0); call cobol_reg_manager$after_op (62); call cobol_emit (addr (inst_seq2 (1)), addr (rel_seq2), 1); /* AT END processing */ call cobol_make_tagref (passed_tag, cobol_$text_wd_off - 1, null ()); call cobol_define_tag (end_tag); end return_proc; /* END return_proc */ /* Interal procedure to generate codes to call merge_$initiate. The call is through the operator merge_initiate. */ initiate: proc; dcl inst_seq (6) bit (18) init ("000000000000000000"b, "011101011100000100"b, /* epp3 compare,ic */ "000000000000000000"b, "111010010000000111"b, /* lxl2 merge_stack_off,dl */ "000000000000000000"b, "111010011000000111"b); /* lxl3 file_n,dl */ dcl rel_seq (6) bit (5) aligned init ("00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b); /* merge_initiate */ 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 = -merge_stack_off; else temp = merge_stack_off; inst_seq (3) = substr (unspec (temp), 19, 18); inst_seq (5) = substr (unspec (file_n), 19, 18); call cobol_emit (addr (inst_seq), addr (rel_seq), 3); compare_hold_ic = cobol_$text_wd_off - 3; call cobol_call_op (60, 0); call cobol_reg_manager$after_op (60); 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_addr_tokens; %include cobol_entry_seq; %include cobol_; %include cobol_file_table; %include cobol_type9; %include cobol_type12; %include cobol_type19; %include cobol_type40; %include cobol_alpha_def; %include cobol_ext_; %include cobol_fixed_common; %include cobol_op_con; end cobol_merge_gen;  cobol_move_gen.pl1 05/24/89 1041.5rew 05/24/89 0830.5 1195749 /****^ *********************************************************** * * * 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_move_gen.pl1 Added Trace statements. 2) change(89-04-23,Zimmerman), approve(89-04-23,MCR8085), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8085 cobol_move_gen.pl1 Stop code generator from aborting in move statement. END HISTORY COMMENTS */ /* Modified on 10/19/84 by FCH, [5.3-1], BUG563(phx18381), new cobol_addr_tokens.incl.pl1 */ /* Modified on 08/13/83 by FCH, [5.2 ...], trace added */ /* Modified on 11/03/81 by FCH, sending tokens sometimes clobbered, [5.1-1], phx11872(BUG518) */ /* Modified on 06/11/81 by FCH, [4.4-2], type 13 token allowed as move operand, BUG468 */ /* Modified on 04/08/81 by FCH, [4.4-1], move zzzpp to xxxxx gives 0 fill not space, BUG476 */ /* Modified on 09/20/80 by FCH, [4.3-2], MOVE constant to indexed comp-6 generates bad code (TR7611, BUG443) */ /* Modified on 08/29/80 by FCH, [4.3-1], MOVE subscripted comp-6 to comp-7 generated bad code (TR5709, BUG432) */ /* Modified on 04/25/80 by FCH, [4.2-2], use MVC for pic s999 lead sep to pic xxxx */ /* Modified on 03/25/80 by FCH, indent used, [4.2-1], set ix to comp-7 fails, BUG432(TR5709) */ /* Modified on 09/01/79 by FCH, [4.0-2], variable length receiving fields fixed */ /* Modified on 05/09/79 by FCH, [4.0-1], move all literal fixed */ /* Modified on 10/19/78 by FCH, [3.0-2], decimal to binary conversion fixed */ /* Modified on 04/10/78 by FCH, [3.0-1], double-word alignment not reqd for params */ /* Modified since Version 3.0 */ /* format: style3 */ cobol_move_gen: proc (in_token_ptr); dcl MVE bit (10) static init ("0000100001"b); /* 020(1) */ dcl MVNE bit (10) static init ("0000101001"b); /* 024(1) */ dcl MLR bit (10) static init ("0010000001"b); /* 100(1) */ dcl MRL bit (10) static init ("0010000011"b); /* 101(1) */ dcl MVN bit (10) static init ("0110000001"b); /* 300(1) */ dcl CMPN bit (10) static init ("0110000111"b); /* 303(1) */ 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) */ dcl STA bit (10) int static init ("1111011010"b); /* 755(0) */ dcl STQ bit (10) int static init ("1111011100"b); /* 756(0) */ dcl ANA bit (10) int static init ("0111111010"b); /* 375(0) */ dcl ANQ bit (10) int static init ("0111111100"b); /* 376(0) */ dcl STBA bit (10) int static init ("1011010010"b); /* 551(0) */ dcl STBQ bit (10) int static init ("1011010100"b); /* 552(0) */ dcl ARL bit (10) int static init ("1111110010"b); /* 771(0) */ dcl ORSA bit (10) int static init ("0101011010"b); /* 255(0) */ dcl ORSQ bit (10) int static init ("0101011100"b); /* 256(0) */ dcl BTD bit (10) int static init ("0110000011"b); /* 301(1) */ dcl DTB bit (10) int static init ("0110001011"b); /* 305(1) */ dcl QRL bit (10) int static init ("1111110100"b); /* 772(0) */ dcl LDAQ bit (10) int static init ("0100111110"b); /* 237(0) */ dcl ANAQ bit (10) int static init ("0111111110"b); /* 377(0) */ dcl STZ bit (10) int static init ("1001010000"b); /* 450(0) */ dcl instr bit (10); dcl ses00 bit (9) static init ("000110000"b); dcl ses01 bit (9) static init ("000110100"b); dcl ses10 bit (9) static init ("000111000"b); dcl ses11 bit (9) static init ("000111100"b); dcl lte_1 bit (9) static init ("100000001"b); dcl lte_3 bit (9) static init ("100000011"b); dcl lte_5 bit (9) static init ("100000101"b); dcl enf00 bit (9) static init ("000100000"b); dcl enf01 bit (9) static init ("000100100"b); dcl enf10 bit (9) static init ("000101000"b); dcl enf11 bit (9) static init ("000101100"b); dcl ign bit (9) static init ("011000000"b); dcl mvc bit (9) static init ("011010000"b); dcl insn_0 bit (9) static init ("010100000"b); dcl insn_4 bit (9) static init ("010100100"b); dcl insm bit (9) static init ("000010000"b); dcl insa bit (9) static init ("010010000"b); dcl insb bit (9) static init ("010000000"b); dcl insp bit (9) static init ("010110000"b); dcl mvza bit (9) static init ("001010000"b); dcl mvzb bit (9) static init ("001000000"b); dcl mflc bit (9) static init ("001110000"b); dcl mfls bit (9) static init ("001100000"b); dcl loval char (1) static init (""); /* = */ dcl space char (1) static init (" "); dcl quote char (1) static init (""""); dcl slash char (1) static init ("/"); dcl hival char (1) static init (""); /* = \177 */ dcl zero char (1) static init ("0"); dcl DS char (1) static init ("f"); /* P7 dig select char */ dcl fc_zero fixed bin static init (180); dcl fc_space fixed bin static init (192); dcl fc_hival fixed bin static init (221); dcl fc_loval fixed bin static init (229); dcl fc_quote fixed bin static init (235); dcl msg_1 char (24) static init ("illegal sending field "); dcl msg_2 char (24) static init ("illegal receiving field "); dcl (save_sf_ptr, save_rf_ptr, const_ptr) ptr; dcl (m, n, n_rf, pl, pr, size, delta) fixed bin; dcl (lin, col) fixed bin; dcl (spl, spr, rpl, rpr) fixed bin; dcl (fx, fl) fixed bin; dcl (move_num, nc_move_num, ival_num, control_no) fixed bin static init (0); dcl (sf_ptr, rf_ptr) ptr; dcl stk_offset fixed bin; dcl cs_offset fixed bin (24); dcl lit_str char (256); dcl (lit_ln, idx) fixed bin; dcl req_ln fixed bin; dcl (sf_stack_sw, sf_category_sw) fixed bin; dcl snd_tkn char (500) based; dcl rec_tkn char (500) based; dcl ecm (256) char (1); dcl ecm_str char (256) based (ecm_ptr); dcl ecm_ptr ptr; dcl ecm_lnth fixed bin; dcl n_ecm fixed bin; dcl mop (256) bit (9); dcl mop_str char (256) based (mop_ptr); dcl mop_ptr ptr; dcl n_mop fixed bin; dcl (bwz, awz, asterisk, sign) fixed bin; dcl tag fixed bin; dcl obj_dec_pt_char char (1); dcl currency_char char (1); dcl (start_supp, max_supp, end_supp) fixed bin; dcl supp_char char (1); dcl (es_status, bz_status) fixed bin; dcl insert_table_status char (8); dcl (no_chars, no_char2, no_char1, count, insert_char_no) fixed bin; dcl (micro_op, insrt_op) bit (9); dcl (end_fix, rf_st) fixed bin; dcl (right_adjust, left_adjust, overlap) fixed bin; dcl (sf_places, rf_places, rf_length, rf_temp_sw) fixed bin; dcl (opnd_ln, ecm_limit) fixed bin; dcl 1 set_ptr_struc aligned, 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; dcl 1 microp_bits aligned, 2 mop bit (5) unaligned, 2 if bit (4) unaligned; /* inst buff */ dcl eis_ (4) bit (36); /* input buff */ dcl ips (18) bit (36); /* reloc buff */ dcl 1 reloc_info (4) aligned, 2 left_ri bit (5) aligned, 2 right_ri bit (5) aligned; /* type-9 token copies */ dcl new_sf_ptr ptr; dcl new_sf_tkn char (500); dcl ms_ptr ptr; dcl ms_tkn char (200); dcl sf_cpy_ptr ptr; dcl sf_tkn_cpy char (500); dcl rf_cpy_ptr ptr; dcl rf_tkn_cpy char (500); dcl temp_tkn_ptr ptr; dcl temp_tkn char (200); /* Declaration for special fixed binary MOVE ZERO TO $. statement generated by ddalloc as part of "size routines". */ dcl stz_inst (2) bit (18) unaligned static init ("000000000000000000"b, "100101000001000000"b); /* stz pr0|0 */ dcl dn_ptr ptr; dcl numeric_source_proc (1:5) entry (ptr, ptr) int init (dec_source, dec_source, sb_source, lb_source, opch_source); dcl return_code fixed bin; dcl work_sf_ptr ptr; dcl ret_offset fixed bin; dcl only_an bit (1); dcl (move_special_bit, ne_bit) bit (1) static init ("0"b); dcl temp fixed bin; dcl numeric_lit_flag fixed bin; dcl in_op fixed bin; /* P__r_o_c_e_d_u_r_e_s_C__a_l_l_e_d:_ */ dcl ioa_$rsnnl entry options (variable), cobol_addr entry (ptr, ptr, ptr), cobol_alloc$stack entry (fixed bin, fixed bin, fixed bin), cobol_define_tag entry (fixed bin), cobol_emit entry (ptr, ptr, fixed bin), cobol_make_tagref entry (fixed bin, fixed bin, ptr), cobol_make_type9$alphanumeric entry (ptr, fixed bin, fixed bin (24), fixed bin), cobol_make_type9$decimal_9bit entry (ptr, fixed bin, fixed bin (24), fixed bin, fixed bin), cobol_make_type9$type2_3 entry (ptr, ptr), cobol_pool$search_op entry (char (*), fixed bin, fixed bin (24), fixed bin), cobol_pool entry (char (*), fixed bin, fixed bin (24)), cobol_set_pr entry (ptr, ptr), cobol_get_num_code ext entry (ptr, fixed bin), cobol_register$load ext entry (ptr), cobol_make_type9$long_bin ext entry (ptr, fixed bin, fixed bin), cobol_make_type9$short_bin ext entry (ptr, fixed bin, fixed bin), cobol_make_type9$copy ext entry (ptr, ptr), cobol_make_type9$copy_sub ext entry (ptr, ptr), cobol_io_util$move_lit entry (bit (3) aligned, fixed bin, fixed bin, char (*)), signal_ entry (char (*), ptr, ptr); dcl cobol_opch_op_call ext entry (ptr, ptr); dcl cobol_make_bin_const entry (ptr, ptr, fixed bin); dcl cobol_register$release ext 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, addrel builtin, (fixed, binary) builtin, index builtin, null builtin, substr builtin, unspec builtin, verify builtin; /* |*| |*| |*| |*| |*| |*| |*| */ /* capture ordinal # and location (in the source program) of the move statement being generated */ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME);/**/ call move_init; /*[5.1-1]*/ go to begin; /* Set hival according to collating sequence */ /* |*| |*| |*| |*| |*| |*| main move loop increment rf idx (m=m+1) check for more (ie multiple) receiving fields if not, return if yes, set rf_ptr to in_token.token_ptr(m) and restore sending field. |*| |*| |*| |*| |*| |*| */ do while ("1"b); m = m + 1; /* wrap up */ /* set rf_ptr to next token pointer in stack */ if sf_category_sw = 1 /* Category was changed from numeric to alphanumeric */ then do; sf_ptr -> data_name.numeric = "1"b; sf_ptr -> data_name.alphanum = "0"b; end; if sf_category_sw = 2 /* Category was changed from alphanumeric to numeric */ then do; sf_ptr -> data_name.alphanum = "1"b; sf_ptr -> data_name.numeric = "0"b; end; /*[5.1-1]*/ if m > n_rf then go to move_done; /* If sending (sf) and receiving (rf) fields overlap or sf is sub- scripted, and there are more than one receiving field, the contents of the sending filed are copied into the stack and this temporary is used as the sending field. This is done to insure that the original value if sf (as it existed at the beginning of the MOVE operation) is moved to each rf. If sf is numeric with leading separate sign (sign_type - "100"b), the temporary is defined as numeric with trailing separate sign (sign_type = "011"b). (Depending upon the rf, a change in sf from leading to trailing sign may be required for implementa- tion purposes. The change is made here to eliminate the pos- sibility of moving from one temp to another.) In all other cases, an alphanumeric (MLR) move is employed. */ begin: /*[5.1-1]*/ rf_ptr = in_token.token_ptr (m + 2); /*[5.1-1]*/ sf_ptr = save_sf_ptr; /*[4.4-2]*/ if sf_ptr -> data_name.type = 13 then call type_13_to_9 (sf_ptr, addr (SF_dn)); /* sending field is type 13 token */ /*[4.4-2]*/ if rf_ptr -> data_name.type = 13 then call type_13_to_9 (rf_ptr, addr (RF_dn)); /* receiving field is type 13 token */ if sf_stack_sw ^= 1 then call move_stack; /* |*| |*| |*| |*| |*| |*| check data type of sending field ck sf = type-9 data name if yes, goto move_4 if not, ck sf = type-3 alphanumeric literal if yes, - pool literal and create type-9 token for it (via cobol_make_type9$type2_3) - set created token as sending field token - ck literal preceeded by word "ALL" if yes, goto move_fig_con_al if not, goto move_4 if not, ck sf = type-2 numeric literal if yes, goto move_3 if not, ck sf = type-1 figurative constant if yes, goto fig_con_rw if not, call error (illegal sending field) |*| |*| |*| |*| |*| |*| */ if (sf_ptr -> data_name.type = 9) then call move_type9; else if (sf_ptr -> data_name.type = 3) then call move_type3; else if sf_ptr -> data_name.type = 2 then call move_type2; else if sf_ptr -> data_name.type = 1 then call move_fig_con_rw; else do; call error (msg_1); go to move_done; end; end; move_done:/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(MY_NAME);/**/ return; move_init: proc; if (control_no ^= cobol_$compile_count) then do; move_num = 0; control_no = cobol_$compile_count; end; move_num = move_num + 1; if (in_token.token_ptr (1) ^= null) then do; rw_ptr = in_token.token_ptr (1); lin = reserved_word.line; col = reserved_word.column; if ((lin = 0) & (col = 0)) then ival_num = ival_num + 1; end; else do; sf_ptr = in_token.token_ptr (2); lin = sf_ptr -> data_name.line; col = sf_ptr -> data_name.column; move_num = move_num - 1; nc_move_num = nc_move_num + 1; end; /* |*| |*| |*| |*| |*| |*| |*| */ /* |*| |*| |*| |*| |*| |*| set sf_ptr = in_token.token_ptr(2) set eos_ptr = in_token.token_ptr(n) get # receiving fields from end_stmt.e set receiving field idx (m) =0 set overlap switch = 0 set error_sw = 0; create pointers to based data |*| |*| |*| |*| |*| |*| */ sf_ptr, save_sf_ptr = in_token.token_ptr (2); eos_ptr = in_token.token_ptr (in_token.n); if end_stmt.e > 9999 then do; end_stmt.e = end_stmt.e - 10000; only_an = "1"b; end; else only_an = "0"b; n_rf = end_stmt.e; /*[5.1-1]*/ m = 1; input_ptr = addr (ips); inst_ptr = addr (eis_); reloc_ptr = addr (reloc_info); new_sf_ptr = addr (new_sf_tkn); ms_ptr = addr (ms_tkn); sf_cpy_ptr = addr (sf_tkn_cpy); rf_cpy_ptr = addr (rf_tkn_cpy); temp_tkn_ptr = addr (temp_tkn); sf_category_sw = 0; numeric_lit_flag = 0; sf_stack_sw = 0; if fixed_common.obj_dec_comma = "0"b then obj_dec_pt_char = "."; else obj_dec_pt_char = ","; currency_char = fixed_common.object_sign; end; move_stack: proc; if (rf_ptr -> data_name.overlap & sf_ptr -> data_name.type = 9) | (sf_ptr -> data_name.type = 9 & sf_ptr -> data_name.subscripted = "1"b & n_rf > 1) then do; /* Allocate space on stack and create token for temp */ sf_stack_sw = 1; size = sf_ptr -> data_name.item_length; call cobol_alloc$stack (size, 0, stk_offset); substr (new_sf_ptr -> rec_tkn, 1, sf_ptr -> data_name.size) = substr (sf_ptr -> snd_tkn, 1, sf_ptr -> data_name.size); new_sf_ptr -> data_name.linkage_section = "0"b; new_sf_ptr -> data_name.subscripted = "0"b; new_sf_ptr -> data_name.seg_num = 1000; new_sf_ptr -> data_name.offset = stk_offset; if sf_ptr -> data_name.numeric then do; if sf_ptr -> data_name.sign_type = "100"b then new_sf_ptr -> data_name.sign_type = "011"b; call num_to_num (sf_ptr, new_sf_ptr); end; else call gen_move_alpha (MLR, "000100000"b, sf_ptr, new_sf_ptr, "0"b); sf_ptr, save_sf_ptr = new_sf_ptr; end; end; move_type3: proc;/***..... dcl LOCAL_NAME char (10) int static init ("MOVE_TYPE3");/**/ /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ alit_ptr = sf_ptr; if (alphanum_lit.all_lit) then do; /* sf token is type3, alphanumeric literal, with all_lit bit set to 1. Input was ALL literal, where literal is NOT one of the other figurative constants. Copy literal into lit_str and set lit_ln to length of literal. */ lit_ln = alphanum_lit.lit_size; substr (lit_str, 1, lit_ln) = substr (alphanum_lit.string, 1, lit_ln); call move_fig_con; end; else if ^(rf_ptr -> data_name.alphanum_edited) & ^(rf_ptr -> data_name.numeric_edited) & ^(rf_ptr -> data_name.numeric) & ^(rf_ptr -> data_name.alphabetic_edited) & ^(rf_ptr -> data_name.variable_length) & ^(rf_ptr -> data_name.just_right) & ^(rf_ptr -> data_name.subscripted) then do; lit_ln = alphanum_lit.lit_size; call gen_move_lit (alphanum_lit.string, lit_ln, rf_ptr); end; else do; call cobol_make_type9$type2_3 (new_sf_ptr, sf_ptr); sf_ptr, save_sf_ptr = new_sf_ptr; call move_type9; end; /***..... if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end; /* |*| |*| |*| |*| |*| |*| sending field = type-2 numeric literal check receiving field = binary data - if not, goto alloc_nl - if yes, ck literal for fractional component if yes, goto alloc_nl if not, ck magnitude of literal value for pooling if (lit val > (2**18)-1), then: create binary equivalent of literal value allocate this value as literal (alloc_nl) if (lit val < or = (2**18)-1) then: get (and LOCK) A (or Q) Register generate LDA or LDQ - DIRECT (upper or lower) - alloc_nl: - allocate numeric literal - create type-9 token for allocated literal (via make_t9_from_t2) - continue processing at move_4 |*| |*| |*| |*| |*| |*| */ move_type2: proc;/***..... dcl LOCAL_NAME char (10) int static init ("MOVE_TYPE2");/**/ /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ nlit_ptr = sf_ptr; /* allocate literal and create type-9 token continue processing at move_4 */ sf_ptr, save_sf_ptr = addr (new_sf_tkn); substr (new_sf_tkn, 1, 250) = (250)""; substr (new_sf_tkn, 251, 250) = (250)""; if rf_ptr -> data_name.bin_18 then call cobol_make_bin_const (nlit_ptr, sf_ptr, 3); else if rf_ptr -> data_name.bin_36 then call cobol_make_bin_const (nlit_ptr, sf_ptr, 4); else do; sf_ptr -> data_name.size = 112; sf_ptr -> data_name.line = numeric_lit.line; sf_ptr -> data_name.type = 9; sf_ptr -> data_name.elementary = "1"b; sf_ptr -> data_name.numeric = "1"b; sf_ptr -> data_name.display = "1"b; numeric_lit_flag = 1; if (numeric_lit.integral) then sf_ptr -> data_name.pic_integer = "1"b; sf_ptr -> data_name.places_left = numeric_lit.places_left; sf_ptr -> data_name.places_right = numeric_lit.places_right; lit_ln, sf_ptr -> data_name.item_length = numeric_lit.places; substr (lit_str, 1, lit_ln) = substr (numeric_lit.literal, 1, lit_ln); if (numeric_lit.sign ^= space) then do; sf_ptr -> data_name.sign_separate = "1"b; sf_ptr -> data_name.sign_type = "011"b; sf_ptr -> data_name.item_length = sf_ptr -> data_name.item_length + 1; substr (lit_str, lit_ln + 1, 1) = substr (numeric_lit.sign, 1, 1); end; else do; sf_ptr -> data_name.sign_type = "000"b; substr (lit_str, lit_ln + 1, 1) = " "; end; call cobol_pool$search_op (substr (lit_str, 1, sf_ptr -> data_name.item_length), 0, cs_offset, in_op); if in_op = 1 then sf_ptr -> data_name.seg_num = 3; else sf_ptr -> data_name.seg_num = 3000; sf_ptr -> data_name.offset = cs_offset; end; call move_type9; /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end; /* |*| |*| |*| |*| |*| |*| sending field = type-9 data name check receiving field parameters check rf = type-9 data name - if not, call error (illegal receiving field) check group-move (either sf or rf = non-elementary) - if yes, goto move_alpha (group-move = alpha data move) check sf = numeric data type - if not, then sf={a}|{an}; (where {an}:={an}|{ae}|{ane}|{n}|{ne}) ck rf = alphabetic or alphanumeric if yes, {a or an -> a or an} goto move_alpha if not, ck rf = alpha-ed or alphanum-ed if yes, sf={a}|{an} -> rf={ae}|{ane} goto move_alpha_edit if not, then, sf = {an} and rf = {n} or {ne} copy sf token set token_copy to numeric set sf_ptr to token_copy continue at sf = {n} - if yes, then sf = {n} ck rf = numeric if yes, {n -> n} goto move_num if not, ck rf = numeric_edited if yes, {n} -> {ne} goto move_num_ed if not, then sf = {n} and rf = {an} continue at ck_n_an |*| |*| |*| |*| |*| |*| */ move_type9: proc;/***..... dcl LOCAL_NAME char (10) int static init ("MOVE_TYPE9");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ /*[4.4-1]*/ ne_bit = sf_ptr -> data_name.numeric; if (rf_ptr -> data_name.type ^= 9) then call error (msg_2); else if (rf_ptr -> data_name.non_elementary) then do; if sf_ptr -> data_name.non_elementary = "0"b then do; if sf_ptr -> data_name.numeric then do; if sf_ptr -> data_name.variable_length then do; move_special_bit = "1"b; call move_special; end; else do; sf_category_sw = 1; sf_ptr -> data_name.numeric = "0"b; sf_ptr -> data_name.alphanum = "1"b; call move_alpha; end; end; else call move_alpha; end; else call move_alpha; end; else if sf_ptr -> data_name.non_elementary then do; /* Source is non-elementary. */ if rf_ptr -> data_name.non_elementary = "0"b then if rf_ptr -> data_name.numeric then do; /* Target is numeric. */ /* Change target token so that it looks like an alphanumeric. */ rf_ptr -> data_name.numeric = "0"b; rf_ptr -> data_name.alphanum = "1"b; end; /* Target is numeric. */ call move_alpha; end; /* Source is non-elementary. */ else if (sf_ptr -> data_name.numeric) then call ck_n_ne; else do; if sf_ptr -> data_name.numeric_edited then do; /* The only legal receiving items for ne sending items are an and ane. In moves involving such data as receiving items, the sending items must be described as alphanumeric. Make one time change in sending item. */ sf_ptr -> data_name.numeric_edited = "0"b; sf_ptr -> data_name.alphanum = "1"b; sf_ptr -> data_name.places_left = sf_ptr -> data_name.item_length; end; /* sf = {a}|{an}|{ae}|{ane} ck rf = {a}|{an}|{ae}|{ane}) */ if rf_ptr -> data_name.alphanum | rf_ptr -> data_name.alphabetic then call move_alpha; else if rf_ptr -> data_name.alphanum_edited | rf_ptr -> data_name.alphabetic_edited then call move_alpha_edit; else call move_special; end; /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end; move_special: proc;/***..... dcl LOCAL_NAME char (12) int static init ("MOVE_SPECIAL");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ if (sf_ptr -> data_name.seg_num <= 5008 & sf_ptr -> data_name.seg_num >= 5000) | (sf_ptr -> data_name.seg_num <= 12287 & sf_ptr -> data_name.seg_num >= 8192) | move_special_bit = "1"b then do; /* Length of the source is in a register, not in the data name token. */ /* NOTE: Segment number 5000 thru 5008 and 8192 thru 12287 occur only when the STRING/UNSTRING generator is attempting to STRING/UNSTRING an alphanumeric into a numeric. This is a VERY SPECIAL CASE and is handled here, only for convenience of STRING/UNSTRING. */ /* Must move the source (an alphanumeric), into a temporary, right justified, with leading decimal zeroes. */ call cobol_alloc$stack (32, 0, ret_offset); /* Make an alphanumeric token for the temporary. */ work_sf_ptr = null (); call cobol_make_type9$alphanumeric (work_sf_ptr, 1000, fixed (ret_offset, 24), 32); /* Move the source into the temporary. */ if move_special_bit then do; move_special_bit = "0"b; call gen_move_alpha (MLR, "000110000"b, sf_ptr, work_sf_ptr, "0"b); end; else call gen_move_alpha (MRL, "000110000"b /* decimal zero */, sf_ptr, work_sf_ptr, "0"b); sf_ptr = work_sf_ptr; end; /* Length of the source is in a register, not in the data name token. */ /* sf = {an}; rf = {n} or {ne} set numeric bit in token to "1"b continue at ck_n_ne */ sf_category_sw = 2; sf_ptr -> data_name.numeric = "1"b; sf_ptr -> data_name.alphanum = "0"b; sf_ptr -> data_name.places_left = sf_ptr -> data_name.item_length; sf_ptr -> data_name.display = "1"b; call ck_n_ne; /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end; ck_n_ne: proc;/***..... dcl LOCAL_NAME char (7) int static init ("CK_N_NE");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ if rf_ptr -> data_name.numeric then call num_to_num (sf_ptr, rf_ptr); else if rf_ptr -> data_name.numeric_edited then call move_numer_ed; /* |*| |*| |*| |*| |*| |*| sf = {n}; rf = {an} or {ane} Operational separate signs are not moved from n to an or ane receiving fields, therefore - - copy sf, set item_length to item_length-1, and sign type to "000"b - if sign type of sf is trailing separate, set sf_ptr to point to new token - if sign type is leading sign, generate MVN instruc- tion to move sf to a stack temporary defined by new token; then set sf_ptr to point to new token */ else do; substr (sf_cpy_ptr -> rec_tkn, 1, sf_ptr -> data_name.size) = substr (sf_ptr -> snd_tkn, 1, sf_ptr -> data_name.size); /*[4.2-2]*/ if sf_ptr -> data_name.display & sf_ptr -> data_name.sign_type = "100"b /*[4.2-2]*/ then do; sf_ptr -> data_name.offset = sf_ptr -> data_name.offset + 1; /* lead sep sign */ /*[4.2-2]*/ sf_cpy_ptr = sf_ptr; /*[4.2-2]*/ end; /*[4.2-2]*/ else if ^sf_ptr -> data_name.display /*[4.2-2]*/ | /*[4.2-2]*/ (sf_ptr -> data_name.display /*[4.2-2]*/ & /*[4.2-2]*/ sf_ptr -> data_name.item_signed /*[4.2-2]*/ & /*[4.2-2]*/ ^sf_ptr -> data_name.sign_separate /*[4.2-2]*/) then do; /* Source variable is leading separate sign, overpunch, or not display (i.e. is packed dec or bin) */ /* Generate code to convert source to unpacked decimal trailing sign */ call num_to_udts (sf_ptr, sf_cpy_ptr, return_code); if return_code ^= 0 then go to ckx; end; /* Source variable is leading separate sign, or not display (i.e. is packed dec or bin */ if sf_cpy_ptr -> data_name.sign_separate then sf_cpy_ptr -> data_name.item_length = sf_cpy_ptr -> data_name.item_length - 1; sf_ptr = sf_cpy_ptr; sf_ptr -> data_name.alphanum = "1"b; sf_ptr -> data_name.numeric = "0"b; if (rf_ptr -> data_name.alphanum) then call move_alpha; else call move_alpha_edit; end; ckx: /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end; /* ALPHA MOVE (alphabetic and/or alphanumeric) */ /* |*| |*| |*| |*| |*| |*| sf and rf described by input (or created) type-9 tokens ck rf = JUSTIFIED if yes, instr = MRL if not, instr = MLR set FILL = SPACE generate proper EIS alpha move instruction (via cobol_addr) build DESCRIPTORS (for sf and rf) emit instruction (via cobol_emit) on completion, goto move_0 |*| |*| |*| |*| |*| |*| */ move_alpha: proc;/***..... dcl LOCAL_NAME char (10) int static init ("MOVE_ALPHA");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ if (rf_ptr -> data_name.just_right) then instr = MRL; else instr = MLR; /* [4.0-2] */ /* if (rf_ptr -> data_name.non_elementary & rf_ptr -> data_name.variable_length) then rf_ptr -> data_name.variable_length = "0"b; */ /* [4.0-2] */ call gen_move_alpha (instr, "000100000"b, sf_ptr, rf_ptr, "0"b); /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end; /* NUMERIC MOVE */ /* |*| |*| |*| |*| |*| |*| sf and rf described by input (or created) type-9 tokens ck sf = decimal if yes, {sf = dec} ck rf = decimal if yes, {sf=dec; rf=dec} go to ck_sign if not, {sf=dec; rf=bin} ck sf = numeric integer (ni) if yes, {sf=dec(ni); -> rf=bin} - generate eis DTB instruction - return if not, {sf=dec(nni) -> rf=bin} - allocate space on stack (= integer portion of sf) - create type-9 token for temp_rf (on stack) - set rounded bit if actual rf = rounded - generate MVN {dec->dec} to move integer portion of actual sf to temp_rf (on stack) - establish temp_rf (on stack) as actual sf - goto generate DTB (above) to move (and convert) temp_rf (= integer portion of actual sf) to actual rf -return if not, {sf = binary} ck rf = decimal if not, {sf=bin; rf=bin} - get and LOCK A (or Q) register - generate LDA (or LDQ) using instr_basic and input_basic num_1: - generate STA (or STQ) using instr_basic and input_basic - UNLOCK A (or Q) register - return if yes, {sf=bin; rf=dec} ck rf = integer if yes, {sf=bin -> dec(ni)} - reset non_int_sw (=0) - goto generate BTD (below) if not, {sf=bin -> dec(nni)} - set non_int_sw (=1) - allocate space on stack(= integer portion of rf) - create type-9 token for temp_rf (on stack) - generate BTD move to move actual sf to temp_rf (on stack) - establish temp_rf (on stack) as actual_sf - ck non_integer_switch (=0?) if yes, {complete 2nd part of non-integer bin->dec move} - generate MVN to move temp_rf (= converted integer portion of bin sf (on stack) to actual_rf - return if not, {bin integer sf moved & converted to dec rf} - return |*| |*| |*| |*| |*| |*| */ /* FIGURATIVE CONSTANT MOVE */ /* |*| |*| |*| |*| |*| |*| figurative constant moves come in two flavors: |*| |*| |*| |*| |*| |*| |*| */ move_fig_con_rw: proc; /* sf token is type1, reserved word. Input was figurative constant including ALL literal where literal IS one of the other figurative constants. (ALL ZEROS, for example has been replaced by its equivalent, ZERO, by PD Syntax. */ /* Identify figurative constant from key, place corresponding character in lit_str, and set lit_ln to 1. */ /***..... dcl LOCAL_NAME char (15) int static init ("MOVE_FIG_CON_RW");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ rw_ptr = sf_ptr; lit_ln = 1; if reserved_word.key = fc_zero then do; /* Special code included to process MOVE ZERO TO $. statement generated by ddalloc as part of size routine for OCCOUS ---- DEPENDING clauses. */ if rf_ptr -> data_name.temporary & substr (rf_ptr -> data_name.name, 1, rf_ptr -> data_name.name_size) = "$" then do; input_struc_basic.type = 1; input_struc_basic.operand_no = 0; input_struc_basic.lock = 0; input_struc_basic.segno = rf_ptr -> data_name.seg_num; input_struc_basic.char_offset = rf_ptr -> data_name.offset; input_struc_basic.send_receive = 1; call cobol_addr (input_ptr, addr (stz_inst), null); call cobol_emit (addr (stz_inst), null, 1); end; else do; substr (lit_str, 1, 1) = zero; call move_fig_con; end; end; else if reserved_word.key = fc_space then do; substr (lit_str, 1, 1) = space; call move_fig_con; end; else if reserved_word.key = fc_hival then do; if cobol_$main_pcs_ptr ^= null () then substr (lit_str, 1, 1) = cobol_$main_pcs_ptr -> alphabet_name.hival_char; else substr (lit_str, 1, 1) = hival; call move_fig_con; end; else if reserved_word.key = fc_loval then do; if cobol_$main_pcs_ptr ^= null () then substr (lit_str, 1, 1) = cobol_$main_pcs_ptr -> alphabet_name.loval_char; else substr (lit_str, 1, 1) = loval; call move_fig_con; end; else do; if reserved_word.key = fc_quote then substr (lit_str, 1, 1) = quote; call move_fig_con; end; /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end; move_fig_con: proc; /* Proceed on basis of rf data category */ /***..... dcl LOCAL_NAME char (12) int static init ("MOVE_FIG_COM");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ if rf_ptr -> data_name.alphanum | rf_ptr -> data_name.alphabetic = "1"b | rf_ptr -> data_name.non_elementary = "1"b then do; if lit_ln = 1 then do; call replicate; go to mfcx; end; else do; pl = rf_ptr -> data_name.item_length; /* Compute minimum length string that must be created and pooled. */ /*[4.0-1]*/ if pl > 128 & pl > lit_ln then do; /*[4.0-1]*/ req_ln = ((lit_ln + 127) / lit_ln) * lit_ln; if req_ln >= pl then req_ln = pl; end; else req_ln = pl; call build_litstr; if (req_ln = pl) & (rf_ptr -> data_name.subscripted = "0"b) then do; call gen_move_lit (lit_str, req_ln, rf_ptr); end; else do; call cobol_pool$search_op (substr (lit_str, 1, req_ln), 0, cs_offset, in_op); set_ptr_struc.what_pointer = 10; set_ptr_struc.lock = 0; set_ptr_struc.switch = 0; call cobol_set_pr (addr (set_ptr_struc), rf_ptr); if in_op = 1 then eis_ (1) = "000100000001000000001000000101000000"b; else eis_ (1) = "000100000001000000001000000100000100"b; i = -(cs_offset / 4 + cobol_$text_wd_off); substr (inst_struc.desc.desc_od (1), 1, 18) = substr (unspec (i), 19, 18); substr (inst_struc.desc.desc_od (1), 19, 6) = "000000"b; substr (inst_struc.desc.desc_od (1), 25, 12) = substr (unspec (req_ln), 25, 12); substr (inst_struc.desc.desc_od (2), 1, 3) = set_ptr_struc.pointer_no; substr (inst_struc.desc.desc_od (2), 4, 15) = (15)"0"b; substr (inst_struc.desc.desc_od (2), 19, 18) = substr (inst_struc.desc.desc_od (1), 19, 18); call cobol_emit (inst_ptr, null, 3); eis_ (1) = "000100000001000000001000000101000000"b; inst_struc.desc.desc_od (1) = inst_struc.desc.desc_od (2); substr (inst_struc.desc.desc_od (2), 4, 17) = substr (unspec (req_ln), 20, 17); i = pl - req_ln; substr (inst_struc.desc.desc_od (2), 25, 12) = substr (unspec (i), 25, 12); call cobol_emit (inst_ptr, null, 3); end; end; go to mfcx; end; if rf_ptr -> data_name.alphanum_edited | rf_ptr -> data_name.alphabetic_edited = "1"b then do; req_ln = rf_ptr -> data_name.places_left; call build_litstr; call cobol_pool$search_op (substr (lit_str, 1, req_ln), 0, cs_offset, in_op); if in_op = 0 then temp = 3000; else temp = 3; call cobol_make_type9$alphanumeric (new_sf_ptr, temp, cs_offset, req_ln); sf_ptr = new_sf_ptr; call move_alpha_edit; go to mfcx; end; pl = rf_ptr -> data_name.places_left; pr = rf_ptr -> data_name.places_right; if rf_ptr -> data_name.numeric then do; if pl > 0 then do; if pr > 0 then do; req_ln = pl; pr = 0; end; else req_ln = pl + pr; call build_litstr_right_just; end; else do; substr (lit_str, 1, 1) = zero; pl = 1 - pr; end; end; else do; if pl > 0 then do; if pr > 0 then req_ln = pl; else req_ln = pl + pr; call build_litstr_right_just; end; else req_ln = 0; if pr > 0 then substr (lit_str, req_ln + 1, pl + pr - req_ln) = (30)"0"; end; call cobol_pool$search_op (substr (lit_str, 1, pl + pr), 0, cs_offset, in_op); if in_op = 0 then temp = 3000; else temp = 3; call cobol_make_type9$decimal_9bit (new_sf_ptr, temp, cs_offset, pl, pr); sf_ptr = new_sf_ptr; sf_ptr -> data_name.sign_type = "000"b; sf_ptr -> data_name.item_signed = "0"b; sf_ptr -> data_name.sign_separate = "0"b; sf_ptr -> data_name.item_length = pl + pr; if rf_ptr -> data_name.numeric then call num_to_num (sf_ptr, rf_ptr); else call move_numer_ed; mfcx: /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end; move_alpha_edit: proc;/***..... dcl LOCAL_NAME char (15) int static init ("MOVE_ALPHA_EDIT");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ ecm_ptr = addr (ecm); mop_ptr = addr (mop); delta = fixed (substr (unspec (rf_ptr -> data_name.edit_ptr), 1, 34), 36); edit_ptr = addrel (rf_ptr, delta); ecm_lnth = editor.ecm_size; substr (ecm_str, 1, ecm_lnth) = substr (editor.ecm, 1, ecm_lnth); sf_places = sf_ptr -> data_name.item_length; rf_places = rf_ptr -> data_name.places_left; rf_length = rf_ptr -> data_name.item_length; if rf_length > 63 then if rf_ptr -> data_name.subscripted then do; rf_temp_sw = 1; call cobol_alloc$stack (rf_length, 0, stk_offset); substr (rf_cpy_ptr -> rec_tkn, 1, rf_ptr -> data_name.size) = substr (rf_ptr -> snd_tkn, 1, rf_ptr -> data_name.size); save_rf_ptr = rf_ptr; rf_ptr = rf_cpy_ptr; rf_ptr -> data_name.linkage_section = "0"b; rf_ptr -> data_name.subscripted = "0"b; rf_ptr -> data_name.seg_num = 1000; rf_ptr -> data_name.offset = stk_offset; end; if sf_places > 63 then if sf_ptr = save_sf_ptr then do; substr (sf_cpy_ptr -> rec_tkn, 1, sf_ptr -> data_name.size) = substr (sf_ptr -> snd_tkn, 1, sf_ptr -> data_name.size); sf_ptr = sf_cpy_ptr; end; if rf_places > sf_places then do; count = 0; no_chars = rf_places - sf_places; /* Fix the move for scaled item. */ if sf_ptr -> data_name.places_right < 0 then no_char1 = -sf_ptr -> data_name.places_right; else no_char1 = 0; if rf_ptr -> data_name.just_right = "0"b then do n = ecm_lnth to 1 by -1 while (count < no_chars); if ecm (n) = DS then do; if count >= (no_chars - no_char1) then ecm (n) = "0"; else ecm (n) = " "; count = count + 1; end; end; else do; no_chars = no_chars - no_char1; if no_chars > 0 then do n = 1 to ecm_lnth by 1 while (count < no_chars); if ecm (n) = DS then do; ecm (n) = " "; count = count + 1; end; end; if no_char1 > 0 then do; count = 0; do n = ecm_lnth to 1 by -1 while (count < no_char1); if ecm (n) = DS then do; ecm (n) = "0"; count = count + 1; end; end; end; end; left_adjust = 0; right_adjust = 0; end; else do; if rf_ptr -> data_name.just_right = "0"b then do; left_adjust = 0; right_adjust = sf_places - rf_places; end; else do; left_adjust = sf_places - rf_places; right_adjust = 0; end; if sf_places > 63 then do; if left_adjust ^= 0 then call calc_char_offset (left_adjust, sf_ptr); sf_ptr -> data_name.item_length = rf_places; sf_ptr -> data_name.places_left = rf_places; left_adjust = 0; right_adjust = 0; end; end; /* For the move alphanumeric edited instruction, the maximum allowable length of the sending operand, the micro opera- tion, and the receiving operand is 63 characters. */ opnd_ln = 0; n_mop = 1; rf_temp_sw = 0; do while (rf_length > 0); insert_table_status = " *+-$,.0"; n_ecm = opnd_ln + 1; if rf_length > 63 then opnd_ln = 63; else opnd_ln = rf_length; if left_adjust ^= 0 then do; no_chars = left_adjust; micro_op = ign; call move_mult_micro_op; end; ecm_limit = n_ecm + opnd_ln - 1; do n = n_ecm to ecm_limit by 1; count = verify (substr (ecm_str, n, ecm_limit - n + 1), ecm (n)); if count = 0 then count = ecm_limit - n + 1; else count = count - 1; no_chars = count; if ecm (n) = DS then do; left_adjust = left_adjust + count; micro_op = mvc; call move_mult_micro_op; end; else do; insrt_op = insp; call move_insert_chars; end; n = n + count - 1; end; rf_length = rf_length - opnd_ln; rf_ptr -> data_name.item_length = opnd_ln; rf_ptr -> data_name.places_left = opnd_ln; if sf_places > 63 then do; sf_ptr -> data_name.item_length = left_adjust; sf_ptr -> data_name.places_left = left_adjust; end; else right_adjust = sf_places - left_adjust; if right_adjust ^= 0 then do; no_chars = right_adjust; micro_op = ign; call move_mult_micro_op; end; if n_mop > 64 then do; call error ("MOP string exceeds 63 char"); go to max; end; call cobol_pool (substr (mop_str, 1, n_mop - 1), 0, cs_offset); temp = 3000; call cobol_make_type9$alphanumeric (ms_ptr, temp, cs_offset, n_mop - 1); n_mop = 1; call gen_move_edit (MVE, sf_ptr, rf_ptr, ms_ptr); if rf_length ^= 0 then do; call calc_char_offset (opnd_ln, rf_ptr); if sf_places > 63 then do; call calc_char_offset (left_adjust, sf_ptr); sf_places = sf_places - left_adjust; left_adjust = 0; end; end; end; if rf_temp_sw = 1 then do; rf_ptr -> data_name.item_length = ecm_lnth; rf_ptr -> data_name.places_left = ecm_lnth; rf_ptr -> data_name.seg_num = 1000; rf_ptr -> data_name.offset = stk_offset; call gen_move_alpha (MLR, "000100000"b, rf_ptr, save_rf_ptr, "0"b); end; max: /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end; move_numer_ed: proc;/***..... dcl LOCAL_NAME char (13) int static init ("MOVE_NUMER_ED");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ if (sf_ptr -> data_name.display = "0"b) | (sf_ptr -> data_name.display = "1"b & sf_ptr -> data_name.item_signed = "1"b & sf_ptr -> data_name.sign_separate = "0"b) /* Must be overpunch sign */ then do; /* Sending field is not display, must convert it to display data. */ new_sf_ptr = null (); /* Utility provides space for the new token. */ call num_to_udts (sf_ptr, new_sf_ptr, return_code); sf_ptr = new_sf_ptr; end; /* Sending field is not display, must convert it to display data. */ spl = sf_ptr -> data_name.places_left; spr = sf_ptr -> data_name.places_right; rpl = rf_ptr -> data_name.places_left; rpr = rf_ptr -> data_name.places_right; ecm_ptr = addr (ecm); mop_ptr = addr (mop); if rf_ptr -> data_name.edit_ptr ^= 0 then do; delta = fixed (substr (unspec (rf_ptr -> data_name.edit_ptr), 1, 34), 36); edit_ptr = addrel (rf_ptr, delta); fx = editor.fixed_insert; fl = editor.float_insert; start_supp = editor.start_suppress; max_supp = editor.max_suppress; ecm_lnth = editor.ecm_size; substr (ecm_str, 1, ecm_lnth) = substr (editor.ecm, 1, ecm_lnth); end; else do; ecm_lnth = rpl + rpr; rf_st = fixed (rf_ptr -> data_name.sign_type, 36); if rf_st = 4 /* Leading separate sign */ then do; fx = 4; ecm (1) = "-"; substr (ecm_str, 2, ecm_lnth) = (30)"f"; ecm_lnth = ecm_lnth + 1; end; else do; substr (ecm_str, 1, ecm_lnth) = (30)"f"; if rf_st = 3 /* Trailing separate sign */ then do; fx = 2; ecm_lnth = ecm_lnth + 1; ecm (ecm_lnth) = "-"; end; else fx = 0; end; fl = 0; start_supp = 0; max_supp = 0; end; end_supp = start_supp + max_supp - 1; left_adjust = spl - rpl; right_adjust = spr - rpr; if left_adjust >= 0 then do; if right_adjust >= 0 then overlap = rpl + rpr; else do; overlap = rpl + spr; if overlap < 0 then do; overlap = 0; left_adjust = spl + spr; right_adjust = -(rpl + rpr); end; end; end; else do; if right_adjust < 0 then overlap = spl + spr; else do; overlap = spl + rpr; if overlap < 0 then do; overlap = 0; left_adjust = -(rpl + rpr); right_adjust = spl + spr; end; end; end; do n = 1 to ecm_lnth by 1 while (left_adjust < 0); if ecm (n) = DS then do; ecm (n) = "0"; left_adjust = left_adjust + 1; end; end; do n = ecm_lnth to 1 by -1 while (right_adjust < 0); if ecm (n) = DS then do; ecm (n) = "0"; right_adjust = right_adjust + 1; end; end; bwz = fixed (rf_ptr -> data_name.bwz, 36); awz = fixed (rf_ptr -> data_name.ast_when_zero, 36); asterisk = fixed (rf_ptr -> data_name.pic_has_ast, 36); sign = fixed (rf_ptr -> data_name.item_signed, 36); /* Treat awz = 1 as special case */ if awz = 1 then do; if overlap ^= 0 then call cmpn0_tnz; n = index (ecm_str, obj_dec_pt_char); if n = 0 then do; substr (lit_str, 1, 1) = "*"; call replicate; end; else do; substr (lit_str, 1, 256) = (254)"*" || "**"; substr (lit_str, n, 1) = obj_dec_pt_char; call cobol_pool (substr (lit_str, 1, n), 0, cs_offset); req_ln = n; call cobol_make_type9$alphanumeric (temp_tkn_ptr, 3000, cs_offset, req_ln); call gen_move_alpha (MLR, "000101010"b, temp_tkn_ptr, rf_ptr, "0"b); end; if overlap = 0 then go to mnx; else do; eis_ (1) = "000000000000000000111001000000000100"b /* tra 0,ic */; call cobol_emit (inst_ptr, null (), 1); call cobol_define_tag (tag); tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_make_tagref (tag, cobol_$text_wd_off - 1, null ()); end; end; /* Special cases of no overlap of sf and rf */ if overlap = 0 then do; if bwz = 1 then do; substr (lit_str, 1, 1) = " "; call replicate; go to mnx; end; if sign = 0 /* No fixed or floating sign insertion */ then do; if asterisk = 1 then supp_char = "*"; else supp_char = " "; if start_supp ^= 0 then do n = start_supp to end_supp by 1; ecm (n) = supp_char; end; if fl = 1 /* Float currency suppression */ then ecm (end_supp) = currency_char; /* Use ecm_str as sf */ call cobol_pool$search_op (substr (ecm_str, 1, ecm_lnth), 0, cs_offset, in_op); if in_op = 0 then temp = 3000; else temp = 3; req_ln = ecm_lnth; call cobol_make_type9$alphanumeric (temp_tkn_ptr, temp, cs_offset, req_ln); call gen_move_alpha (MLR, "000100000"b, temp_tkn_ptr, rf_ptr, "0"b); go to mnx; end; end; /* End special cases */ es_status = 0; /* es off */ bz_status = 0; /* bz off */ insert_table_status = " *+-$,.0"; n_ecm = 1; n_mop = 1; /* Take care of leading fixed sign insertion */ if fx = 3 then do; mop (1) = insn_4; n_mop = 2; n_ecm = 2; end; if fx = 4 then do; if bwz = 1 then do; mop (1) = enf01; bz_status = 1; end; else mop (1) = enf00; es_status = 1; n_mop = 2; n_ecm = 2; end; if start_supp ^= 0 then do; /* Floating insertion or zero suppression specified */ if n_ecm ^= start_supp then do; /* Fixed insertion before float or zero suppress */ /* Set es on if not on and, if bwz = 1, set bz on if not on. */ call es_on_ck_bz; do n = n_ecm to start_supp - 1 by 1; count = verify (substr (ecm_str, n, start_supp - n), ecm (n)); if count = 0 then count = start_supp - n; else count = count - 1; no_chars = count; insrt_op = insb; call move_insert_chars; n = n + count - 1; end; n_ecm = start_supp; end; /* Ignore excess sf characters on left */ if left_adjust ^= 0 then do; no_chars = left_adjust; micro_op = ign; call move_mult_micro_op; end; /* Set es off if on; bz on if not on and bwz = 1 */ if bz_status = 0 /* off */ then if bwz = 1 then do; mop (n_mop) = ses01; n_mop = n_mop + 1; bz_status = 1; es_status = 0; end; if es_status = 1 /* on */ then do; mop (n_mop) = ses00; n_mop = n_mop + 1; es_status = 0; end; /* If insert table entry 1 is not /b, load with /b */ if substr (insert_table_status, 1, 1) ^= " " then do; mop (n_mop) = lte_1; substr (mop_str, n_mop + 1, 1) = " "; substr (insert_table_status, 1, 1) = " "; n_mop = n_mop + 2; end; /* Treat zero suppression */ if fl = 0 then do; if asterisk = 1 then do; micro_op = mvza; insrt_op = insa; end; else do; micro_op = mvzb; insrt_op = insb; end; call suppress; call es_on_ck_bz; end; else do; n_ecm = n_ecm + 1; if fl = 1 then do; if currency_char ^= "$" then do; mop (n_mop) = lte_5; substr (mop_str, n_mop + 1, 1) = currency_char; substr (insert_table_status, 5, 1) = currency_char; n_mop = n_mop + 2; end; micro_op = mflc; end; else do; if fl = 3 then do; mop (n_mop) = lte_3; substr (mop_str, n_mop + 1, 1) = " "; substr (insert_table_status, 3, 1) = " "; n_mop = n_mop + 2; end; micro_op = mfls; end; insrt_op = insb; call suppress; if bz_status = 0 /* off */ then if bwz = 1 then do; if fl = 1 then mop (n_mop) = enf11; else mop (n_mop) = enf01; n_mop = n_mop + 1; bz_status = 1; es_status = 1; end; if es_status = 0 then do; if fl = 1 then mop (n_mop) = enf10; else mop (n_mop) = enf00; n_mop = n_mop + 1; es_status = 1; end; end; n_ecm = end_supp + 1; /* Remainder of ecm string, if any, is processed as fixed supression */ end; else do; /* No float insertion or zero suppression */ /* Set es on if off; bz on if off and bwz = 1 */ call es_on_ck_bz; /* Ignore excess sf characters on left */ if left_adjust ^= 0 then do; no_chars = left_adjust; micro_op = ign; call move_mult_micro_op; end; end; /* Set end of fixed insertion */ if fx = 5 then end_fix = ecm_lnth - 2; else if fx = 1 | fx = 2 then end_fix = ecm_lnth - 1; else end_fix = ecm_lnth; do n = n_ecm to end_fix by 1; count = verify (substr (ecm_str, n, end_fix - n + 1), ecm (n)); if count = 0 then count = end_fix - n + 1; else count = count - 1; no_chars = count; if ecm (n) = DS then do; if bwz = 1 then do; idx = index (substr (ecm_str, n + count, end_fix - (n + count - 1)), DS); if idx = 0 then if substr (insert_table_status, 1, 1) ^= " " then do; mop (n_mop) = lte_1; substr (mop_str, n_mop + 1, 1) = " "; substr (insert_table_status, 1, 1) = " "; n_mop = n_mop + 2; end; end; micro_op = mvc; call move_mult_micro_op; end; else do; insrt_op = insb; call move_insert_chars; end; n = n + count - 1; end; /* If bwz = 1, insure that insert table 1 is a /b */ if bwz = 1 then if substr (insert_table_status, 1, 1) ^= " " then do; mop (n_mop) = lte_1; substr (mop_str, n_mop + 1, 1) = " "; substr (insert_table_status, 1, 1) = " "; n_mop = n_mop + 2; if right_adjust = 0 then do; sf_ptr -> data_name.item_length = sf_ptr -> data_name.item_length + 1; sf_ptr -> data_name.places_right = sf_ptr -> data_name.places_right + 1; right_adjust = 1; end; end; /* Take care of trailing sign insertion */ if fx = 5 then do; mop (n_mop) = lte_1; substr (insert_table_status, 1, 1) = " "; substr (mop_str, n_mop + 1, 1) = " "; n_mop = n_mop + 2; do n = ecm_lnth - 1 to ecm_lnth by 1; mop (n_mop) = insn_0; substr (mop_str, n_mop + 1, 1) = ecm (n); n_mop = n_mop + 2; end; end; if fx = 1 then do; mop (n_mop) = insn_4; n_mop = n_mop + 1; end; if fx = 2 then do; if es_status = 1 then do; mop (n_mop) = ses00; n_mop = n_mop + 1; end; mop (n_mop) = enf00; n_mop = n_mop + 1; end; /* Ignore excess trailing sf characters */ if right_adjust ^= 0 then do; no_chars = right_adjust; micro_op = ign; call move_mult_micro_op; end; /* Move */ if n_mop > 64 then call error ("MOP string exceeds 63 char"); call cobol_pool (substr (mop_str, 1, n_mop - 1), 0, cs_offset); call cobol_make_type9$alphanumeric (ms_ptr, 3000, cs_offset, n_mop - 1); call gen_move_edit (MVNE, sf_ptr, rf_ptr, ms_ptr); if awz = 1 then call cobol_define_tag (tag); mnx: /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end; gen_move_edit: proc (instr, sf_tkn_ptr, rf_tkn_ptr, ms_tkn_ptr); /***..... dcl LOCAL_NAME char (13) int static init ("GEN_MOVE_EDIT");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ dcl instr bit (10); dcl (sf_tkn_ptr, rf_tkn_ptr, ms_tkn_ptr) ptr; eis_ (1) = (36)"0"b; inst_struc.inst.fill1_op = instr; call set_ips_type5_6 (6, sf_tkn_ptr, rf_tkn_ptr, ms_tkn_ptr); call cobol_addr (input_ptr, inst_ptr, reloc_ptr); call cobol_emit (inst_ptr, reloc_ptr, 4); /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end gen_move_edit; dec_zero: proc (temp_tkn_ptr); /***..... dcl LOCAL_NAME char (8) int static init ("DEC_ZERO");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ /* This procedure causes an unsigned decimal"0"to be pooled in the constant section and creates a token for it in a buffer pointed to by temp_tkn_ptr. */ dcl temp_tkn_ptr ptr; dcl cs_offset fixed bin (24); dcl temp_tkn char (200) based (temp_tkn_ptr); call cobol_pool$search_op ("0", 0, cs_offset, in_op); if in_op = 0 then temp = 3000; else temp = 3; substr (temp_tkn, 1, 200) = (200)""; temp_tkn_ptr -> data_name.type = 9; temp_tkn_ptr -> data_name.numeric = "1"b; temp_tkn_ptr -> data_name.display = "1"b; temp_tkn_ptr -> data_name.seg_num = temp; temp_tkn_ptr -> data_name.offset = cs_offset; temp_tkn_ptr -> data_name.places_left = 1; temp_tkn_ptr -> data_name.places_right = 0; temp_tkn_ptr -> data_name.item_length = 1; temp_tkn_ptr -> data_name.sign_type = "000"b; /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end dec_zero; cmpn0_tnz: proc;/***..... dcl LOCAL_NAME char (9) int static init ("CMPN0_TNZ");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ /* This procedure generates instructions to compare a numeric sending field to decimal "0" and transfer if sending field is not zero. It also reserves a tag for the transfer instruction, makes a reference for it, and updates cobol_$next_tag. */ call dec_zero (temp_tkn_ptr); eis_ (1) = (36)"0"b; inst_struc.inst.fill1_op = CMPN; call set_ips_type5_6 (5, sf_ptr, temp_tkn_ptr, null); call cobol_addr (input_ptr, inst_ptr, null); tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; inst_struc.desc.desc_od (3) = "000000000000000000110000001000000100"b; call cobol_emit (inst_ptr, null, 4); call cobol_make_tagref (tag, cobol_$text_wd_off - 1, null); /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end cmpn0_tnz; move_mult_micro_op: proc;/***..... dcl LOCAL_NAME char (19) int static init ("MOVE_MULTI_MICRO_OP");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ /* This procedure generates in "mop_str" (or "mop"), starting at character number "n_mop", a sufficient number of "micro_op" micro operations to move "no_chars" characters. */ do while (no_chars > 0); if no_chars >= 16 then substr (micro_op, 6, 4) = "0000"b; else substr (micro_op, 6, 4) = substr (unspec (no_chars), 33, 4); no_chars = no_chars - 16; mop (n_mop) = micro_op; n_mop = n_mop + 1; end; /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end move_mult_micro_op; move_insert_chars: proc;/***..... dcl LOCAL_NAME char (17) int static init ("MOVE_INSERT_CHARS");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ /* This procedure generates in "mop_str" (or "mop"), starting at character number "n_mop", a sufficient number of micro operations to move "no_chars" insertion characters defined by "ecm(n)" without suppression. "insm" is used if "no_chars" > 3 and the micro op contained in "insrt_op" if "no_chars" <= 3. */ if no_chars > 3 then do; if substr (insert_table_status, 1, 1) ^= ecm (n) then do; mop (n_mop) = lte_1; substr (mop_str, n_mop + 1, 1) = ecm (n); substr (insert_table_status, 1, 1) = ecm (n); n_mop = n_mop + 2; end; micro_op = insm; call move_mult_micro_op; end; else do; insert_char_no = index (insert_table_status, ecm (n)); if insert_char_no = 0 then if ecm (n) = " " then do; mop (n_mop) = lte_1; substr (mop_str, n_mop + 1, 1) = " "; substr (insert_table_status, 1, 1) = " "; insert_char_no = 1; n_mop = n_mop + 2; end; do idx = 1 to no_chars by 1; substr (insrt_op, 6, 4) = substr (unspec (insert_char_no), 33, 4); mop (n_mop) = insrt_op; n_mop = n_mop + 1; if insert_char_no = 0 then do; substr (mop_str, n_mop, 1) = ecm (n); n_mop = n_mop + 1; end; end; end; /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end move_insert_chars; es_on_ck_bz: proc;/***..... dcl LOCAL_NAME char (11) int static init ("ES_ON_CK_BZ");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ /* This procedure generates a "ses" micro op in "mop_str" (or "mop"), at character number "n_mop", to set the es flag on if it is not already on and bwz = 0 or bwz = 1 and the bz flag is already on or to set both the es and bz flags on if bwz = 1 and bz is not already on. */ if bz_status = 0 /* off */ then if bwz = 1 then do; mop (n_mop) = ses11; n_mop = n_mop + 1; bz_status = 1; es_status = 1; end; if es_status = 0 /* off */ then do; mop (n_mop) = ses10; n_mop = n_mop + 1; es_status = 1; end; /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end es_on_ck_bz; suppress: proc;/***..... dcl LOCAL_NAME char (8) int static init ("SUPPRESS");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ /* This procedure generates the micro operations in "mop_str" (or "mpo"), starting at character number "n_mop" for the supression portion of an edit numeric move. Processing of "ecm_str" (or "ecm") commences at character number "n_ecm" and ends with character number "end_supp". The micro oper- ation contained in "micro_op" is used to move digit charact- ers and that in "insrt_op" to move insertion characters. */ do n = n_ecm to end_supp by 1; count = verify (substr (ecm_str, n, end_supp - n + 1), ecm (n)); if count = 0 then count = end_supp - n + 1; else count = count - 1; no_chars = count; if ecm (n) = DS then call move_mult_micro_op; else do; insert_char_no = index (insert_table_status, ecm (n)); do idx = 1 to no_chars by 1; substr (insrt_op, 6, 4) = substr (unspec (insert_char_no), 33, 4); mop (n_mop) = insrt_op; n_mop = n_mop + 1; if insert_char_no = 0 then do; substr (mop_str, n_mop, 1) = ecm (n); n_mop = n_mop + 1; end; end; end; n = n + count - 1; end; /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end suppress; error: proc (err_msg); dcl 1 error_info aligned, 2 module_name char (32), 2 err_msg_lnth fixed bin, 2 error_msg char (168); dcl err_msg char (*); dcl ioa_str char (44) init ("move # ^d {on line(^d) col(^d)} contains ^a"); /* utilize cobol_ system error handling */ module_name = "cobol_move_gen"; call ioa_$rsnnl (ioa_str, error_msg, err_msg_lnth, move_num, lin, col, err_msg); call signal_ ("command_abort_", null, addr (error_info)); end error; gen_move_alpha: proc (op_code, fill, sf_tkn_ptr, rf_tkn_ptr, no_emit); /***..... dcl LOCAL_NAME char (14) int static init ("GEN_MOVE_ALPHA");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ /* This procedure "generates" an eis {an} move instruction (the contents of `op_code' determines whether an MLR or an MRL eis instruction is generated. The contents of `fill' is used to set the FILL character of the instr This procedure calls on `set_ips_type5_6' to set up a type-5 instruction in input_strucure (input to cobol_addr) using the type-9 tokens pointed to by sf_tkn_ptr and rf_tkn_ptr as sending and receiving field tokens. After setting the FILL character, it calls `cobol_emit' to emit the instruction (and operand descriptors) built */ dcl op_code bit (10); dcl len fixed bin; dcl fill bit (9); dcl (sf_tkn_ptr, rf_tkn_ptr) ptr; dcl no_emit bit (1); dcl cobol_io_util$move entry (bit (3) aligned, fixed bin, fixed bin, bit (3) aligned, fixed bin, fixed bin); eis_ (1) = (36)"0"b; inst_struc.inst.fill1_op = op_code; call set_ips_type5_6 (5, sf_tkn_ptr, rf_tkn_ptr, null); call cobol_addr (input_ptr, inst_ptr, reloc_ptr); if op_code = MLR & fill = "000100000"b & ^no_emit then do; /* try to optimize */ /* -05/15/76- */ if (sf_tkn_ptr -> data_name.pic_has_p = "0"b) & (sf_tkn_ptr -> data_name.places_left >= 0) & (sf_tkn_ptr -> data_name.places_right >= 0) then /* 6/14/76 */ if inst_struc.mf1.pr_spec & ^inst_struc.mf1.reg_or_length & inst_struc.mf1.reg_mod = ""b & inst_struc.mf2.pr_spec & ^inst_struc.mf2.reg_or_length & inst_struc.mf2.reg_mod = ""b then if ^sf_tkn_ptr -> data_name.linkage_section /* [3.0-1] */ & /* [3.0-1] */ ^rf_tkn_ptr -> data_name.linkage_section /* [3.0-1] */ then do; call cobol_io_util$move (substr (inst_struc.desc_od (2), 1, 3), fixed (substr (inst_struc.desc_od (2), 4, 17)), fixed (substr (inst_struc.desc_od (2), 25, 12)), substr (inst_struc.desc_od (1), 1, 3), fixed (substr (inst_struc.desc_od (1), 4, 17)), fixed (substr (inst_struc.desc_od (1), 25, 12))); go to gmx; end; end; /* try to optimize */ /* -05/15/76- */ substr (eis_ (1), 1, 9) = fill; if (sf_tkn_ptr -> data_name.pic_has_p) & (fill ^= "000110000"b) & (sf_tkn_ptr -> data_name.places_left < 0 | sf_tkn_ptr -> data_name.places_right < 0) then do; /*[4.4-1]*/ if ne_bit then substr (eis_ (1), 1, 9) = "000110000"b; /* "0" */ call cobol_emit (inst_ptr, reloc_ptr, 3); if sf_tkn_ptr -> data_name.places_left < 0 then len = sf_tkn_ptr -> data_name.item_length - sf_tkn_ptr -> data_name.places_left; else len = sf_tkn_ptr -> data_name.item_length - sf_tkn_ptr -> data_name.places_right; if rf_tkn_ptr -> data_name.variable_length = "0"b then if len >= rf_tkn_ptr -> data_name.item_length then return; inst_struc.inst.mf1 = inst_struc.mf2; inst_struc.inst.mf1.reg_or_length = "0"b; inst_struc.desc.desc_od (1) = inst_struc.desc.desc_od (2); substr (inst_struc.desc.desc_od (1), 25, 12) = substr (unspec (len), 25, 12); substr (eis_ (1), 1, 9) = fill; end; if ^no_emit then call cobol_emit (inst_ptr, reloc_ptr, 3); /* 6/3/76 */ gmx: /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end gen_move_alpha; gen_move_lit: proc (lit_str, lit_ln, rf_ptr); /***..... dcl LOCAL_NAME char (12) int static init ("GEN_MOVE_LIT");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ /* This procedure is used to interface with the entry cobol_io_util$move_lit. The input to this procedure are: lit_str: The sending alphanum literal string. lit_ln: The length of the sending alphanum literal string. rf_ptr: The pointer to the receiving field. */ dcl lit_str char (*), lit_ln fixed bin, rf_ptr ptr; eis_ (1) = (36)"0"b; call set_ips_type5_6 (5, null, rf_ptr, null); call cobol_addr (input_ptr, inst_ptr, null); call cobol_io_util$move_lit (substr (inst_struc.desc_od (2), 1, 3), fixed (substr (inst_struc.desc_od (2), 4, 17)), fixed (substr (inst_struc.desc_od (2), 25, 12)), substr (lit_str, 1, lit_ln)); /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end gen_move_lit; gen_move_dec_numer: proc (sf_tkn_ptr, rf_tkn_ptr); /***..... dcl LOCAL_NAME char (19) int static init ("GEN_MOVE_DEC_NUMBER");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ /* This procedure "generates" an eis {n} move instruction It uses the type-9 tokens pointed to by sf_tkn_ptr and rf_tkn_ptr as the sending and receiving fields of the MVN If the sending field is unsigned and the receiving field is signed, the `P-BIT' is set "ON" (thereby forcing a + sign in the signed receiving field. If the receiving field is stipulated as having the ROUNDED option applied, the `RD' bit is set "ON" (meaning that rounding will take place as a result of this move. */ dcl (sf_tkn_ptr, rf_tkn_ptr) ptr; eis_ (1) = (36)"0"b; inst_struc.inst.fill1_op = MVN; call set_ips_type5_6 (5, sf_tkn_ptr, rf_tkn_ptr, null); call cobol_addr (input_ptr, inst_ptr, reloc_ptr); if (rf_tkn_ptr -> data_name.rounded) then substr (eis_ (1), 11, 1) = "1"b; if ((sf_tkn_ptr -> data_name.sign_type = "000"b) & (rf_tkn_ptr -> data_name.sign_type ^= "000"b)) then substr (eis_ (1), 1, 1) = "1"b; if rf_tkn_ptr -> data_name.item_signed then substr (eis_ (1), 1, 1) = "1"b; if (only_an = "1"b) then do; substr (eis_ (1), 19, 10) = "0010000001"b; substr (eis_ (1), 1, 11) = "11000000000"b; substr (eis_ (2), 23, 8) = "00000000"b; substr (eis_ (3), 23, 8) = "00000000"b; end; call cobol_emit (inst_ptr, reloc_ptr, 3); /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end gen_move_dec_numer; set_ips_type5_6: proc (ips_typ, sf_tkn_ptr, rf_tkn_ptr, ms_tkn_ptr); /***..... dcl LOCAL_NAME char (15) int static init ("SET_IPS_TYPE5_6");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ /* This procedure sets up the input structure (ips_) used by cobol_addr to create addressability to the data fields in the eis MOVE instruction. - type-5 (ips_typ=5) eis instr w/ 2 operand descriptors op-descr(1) = sending field = token <- sf_tkn_ptr op-descr(2) = receiving fld = token <- rf_tkn_ptr - type-6 (ips_typ=6) eis instr w/ 3 operand descriptors op-descr(1) = sending field = token <- sf_tkn_ptr op-descr(2) = microp string = token <- ms_tkn_ptr op-descr(3) = receiving fld = token <- rf_tkn_ptr */ dcl (sf_tkn_ptr, rf_tkn_ptr, ms_tkn_ptr) ptr; dcl ips_typ fixed bin; if (ips_typ = 5) then do; input_struc.type = 5; input_struc.operand_no = 2; input_struc.lock = 0; input_struc.token_ptr (1) = sf_tkn_ptr; input_struc.send_receive (1) = 0; input_struc.ic_mod (1) = 0; input_struc.size_sw (1) = 0; input_struc.token_ptr (2) = rf_tkn_ptr; input_struc.send_receive (2) = 1; input_struc.ic_mod (2) = 0; input_struc.size_sw (2) = 0; go to setx; end; if (ips_typ = 6) then do; input_struc.type = 6; input_struc.operand_no = 3; input_struc.lock = 0; input_struc.token_ptr (1) = sf_tkn_ptr; input_struc.send_receive (1) = 0; input_struc.ic_mod (1) = 0; input_struc.size_sw = 0; input_struc.token_ptr (2) = ms_tkn_ptr; input_struc.send_receive (2) = 0; input_struc.ic_mod (2) = 0; input_struc.size_sw (2) = 0; input_struc.token_ptr (3) = rf_tkn_ptr; input_struc.send_receive (3) = 1; input_struc.ic_mod (3) = 0; input_struc.size_sw (3) = 0; end; setx: /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end set_ips_type5_6; calc_char_offset: proc (delta, dn_ptr); /***..... dcl LOCAL_NAME char (16) int static init ("CALC_CHAR_OFFSET");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ /* This procedure calculates a new character offset for a data field whenever any adjustments have to be made. Normally, the new offset = old offset + delta. There is a distinct problem, however, with data fields in the COBOL constant section. Since the constants are stored in a backwards manner (ie from the END of the constant portion of the text section) any character adjustments must use a special algorithm to calculate the new offset. The byte numbering of the data in the constant section is shown in the following diagram: --------------------- | 16 | 17 |....|....| --------------------- | 12 | 13 | 14 | 15 | --------------------- | 8 | 9 | 10 | 11 | --------------------- | 4 | 5 | 6 | 7 | --------------------- */ dcl (curr_char_off, new_char_off, nword, nchar, delta) fixed bin; dcl dn_ptr ptr; dcl tlength fixed bin; /* If data item is packed decimal, calculate the byte delta from the half-byte delta supplied. */ if dn_ptr -> data_name.ascii_packed_dec_h then do; if mod (delta, 2) = 0 then delta = divide (delta, 2, 35, 0); else if dn_ptr -> data_name.bit_offset = "0000"b then do; delta = divide (delta, 2, 35, 0); dn_ptr -> data_name.bit_offset = "0101"b; end; else do; delta = divide (delta, 2, 35, 0) + 1; dn_ptr -> data_name.bit_offset = "0000"b; end; end; else if dn_ptr -> data_name.ascii_packed_dec then do; /* Calculate the meaningful number of halfbytes in the data item. */ tlength = dn_ptr -> data_name.places_left + dn_ptr -> data_name.places_right; if dn_ptr -> data_name.item_signed then tlength = tlength + 1; /* If the number of half bytes is odd, then the leftmost halfbyte is fill. We must bump past the fill halfbyte, so add 1 to delta. */ if mod (tlength, 2) ^= 0 then delta = delta + 1; delta = divide (delta, 2, 35); end; /* ck for COBOL constant data */ if (dn_ptr -> data_name.seg_num = 3000) then do; nword = divide (dn_ptr -> data_name.offset, 4, 35) - divide (mod (dn_ptr -> data_name.offset, 4) + delta, 4, 35); curr_char_off = mod (dn_ptr -> data_name.offset + delta, 4); dn_ptr -> data_name.offset = nword * 4 + curr_char_off; end; else dn_ptr -> data_name.offset = dn_ptr -> data_name.offset + delta; /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end calc_char_offset; build_litstr: proc;/***..... dcl LOCAL_NAME char (12) int static init ("BUILD_LITSTR");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ /* This procedure builds a left_justified string of "req_ln" characters in the string "lit_str" utilizing the left- most "lit_ln" characters in "lit_str". The "lit_str" characters are replicated or truncated as necessary to achieve the required string length. */ if lit_ln < req_ln then do; do idx = lit_ln by lit_ln while (req_ln - idx >= lit_ln); substr (lit_str, idx + 1, lit_ln) = substr (lit_str, 1, lit_ln); end; if req_ln - idx < lit_ln then substr (lit_str, idx + 1, req_ln - idx) = substr (lit_str, 1, req_ln - idx); end; /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end build_litstr; replicate: proc;/***..... dcl LOCAL_NAME char (9) int static init ("REPLICATE");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ /* This procedure replicates a one-character pattern by causing the generation of a simple move from a zero-length string with the desired character as the fill character to the receiving field. The character to be replicated is assumed to be the first character of lit_str. */ eis_ (1) = (36)"0"b; call set_ips_type5_6 (5, null, rf_ptr, null); call cobol_addr (input_ptr, inst_ptr, null); inst_struc.inst.fill1_op = MLR; substr (eis_ (1), 1, 9) = substr (unspec (lit_str), 1, 9); substr (eis_ (1), 30, 7) = "0000100"b; inst_struc.desc.desc_od (1) = "111111111111111111000000000000000000"b; call cobol_emit (inst_ptr, null, 3); /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end replicate; build_litstr_right_just: proc;/***..... dcl LOCAL_NAME char (23) int static init ("BUILD_LISTR_RIGHT_JUST");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ /* This procedure builds a literal , right justified in the leftmost character positions of a work string. The literal is built for an "all" literal. The input to this procedure is contained in the following variables that are global to this procedure: lit_str this character string contains the "all" literal lit_ln this is the length of the "all" literal. req_ln this is the required length of the string to be built by this procedure. The literal string built by this procedure is returned right justified, in the leftmost "lit_ln" characters of lit_str. */ /* Declarations of internal variables. */ dcl work_string char (40); dcl whole_string_count fixed bin; dcl remainder_count fixed bin; dcl curr_char fixed bin; dcl ix fixed bin; /* calculate the number of whole literal strings to be inserted into the works string. */ whole_string_count = req_ln / lit_ln; /* calculate the number of characters in a partial move of the literal string to the work string. */ remainder_count = mod (req_ln, lit_ln); curr_char = 1; if remainder_count ^= 0 then do; /* Move partial string into the work string */ substr (work_string, curr_char, remainder_count) = substr (lit_str, curr_char + lit_ln - remainder_count, remainder_count); curr_char = curr_char + remainder_count; end; /* Move partial string into the work string */ if whole_string_count ^= 0 then do; /* Move the whole input string into the work string (one or more times) */ do ix = 1 to whole_string_count; substr (work_string, curr_char, lit_ln) = substr (lit_str, 1, lit_ln); curr_char = curr_char + lit_ln; end; end; /* Move the whole input string into the work string (one or more times) */ /* Move the work string into the input string. */ substr (lit_str, 1, req_ln) = substr (work_string, 1, req_ln); /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end build_litstr_right_just; /* { */ num_to_num: proc (sf_ptr, rf_ptr); /***..... dcl LOCAL_NAME char (10) int static init ("NUM_TO_NUM");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ /* This procedure is called to generate code to move any numeric variable to any other numeric variable. The move is accomplished in the Cobol MOVE verb sense, i.e., point alignment and truncation on the right and left are done, and overflow is avoided. */ /* Declarations of the Parameters */ dcl sf_ptr ptr; dcl rf_ptr ptr; /* } */ dcl sf_code fixed bin; /* Get the numeric type code of the source variable */ call cobol_get_num_code (sf_ptr, sf_code); /* Call a move code generation procedure based on the type of the source variable. */ call numeric_source_proc (sf_code) (sf_ptr, rf_ptr); /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end num_to_num; /* { */ dec_source: proc (sf_ptr, rf_ptr); /***..... dcl LOCAL_NAME char (10) int static init ("DEC_SOURCE");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ /* This internal procedure generates code to convert any decimal source variable to any other type of numeric variable. */ /* Declaration of the Parameters */ dcl sf_ptr ptr; dcl rf_ptr ptr; /* } */ /* Declaration of Internal Variables */ dcl work_sf_ptr ptr; dcl work_rf_ptr ptr; dcl rf_code fixed bin; work_sf_ptr = sf_ptr; work_rf_ptr = rf_ptr; call cobol_get_num_code (rf_ptr, rf_code); goto target_1 (rf_code); target_1 (1): /* TARGET IS UNPACKED DECIMAL */ call dec_dec (work_sf_ptr, work_rf_ptr); go to tgx; target_1 (2): /* TARGET IS PACKED DECIMAL */ call dec_dec (work_sf_ptr, work_rf_ptr); go to tgx; target_1 (3): /* TARGET IS SHORT FIXED BINARY */ call dec_sb (work_sf_ptr, work_rf_ptr); go to tgx; target_1 (4): /* TARGET IS LONG FIXED BINARY */ call dec_lb (work_sf_ptr, work_rf_ptr); go to tgx; target_1 (5): /* TARGET IS OVERPUNCH SIGN DATA */ call non_opch_to_opch (work_sf_ptr, work_rf_ptr); tgx: /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end dec_source; /* { */ sb_source: proc (sf_ptr, rf_ptr); /***..... dcl LOCAL_NAME char (9) int static init ("SB_SOURCE");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ /* This internal procedure generates code to convert a short binary source variable to any type numeric variable. */ /* Declarations of the Parameters */ dcl sf_ptr ptr; dcl rf_ptr ptr; /* DECLARATIONS OF INTERNAL VARIABLES */ dcl work_sf_ptr ptr; dcl work_rf_ptr ptr; dcl rf_code fixed bin; work_sf_ptr = sf_ptr; work_rf_ptr = rf_ptr; /* Get a type code for the receiving variable. */ call cobol_get_num_code (rf_ptr, rf_code); /* Goto a conversion routine based on the type of the receiving field. */ goto target_2 (rf_code); target_2 (1): /* TARGET IS UNPACKED DECIMAL */ target_2 (2): /* TARGET IS PACKED DECIMAL */ /* NOTE THAT UNPACKED AND PACKED DECIMAL ARE CONVERTED IDENTICALLY. */ call any_bin_dec (work_sf_ptr, work_rf_ptr); go to tgx; target_2 (3): /* TARGET IS SHORT BINARY */ call bin_same_bin (work_sf_ptr, work_rf_ptr); go to tgx; target_2 (4): /* TARGET IS LONG BINARY */ call sb_lb (work_sf_ptr, work_rf_ptr); go to tgx; target_2 (5): /* TARGET IS OVERPUNCH SIGN */ call non_opch_to_opch (work_sf_ptr, work_rf_ptr); tgx: /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end sb_source; /* { */ lb_source: proc (sf_ptr, rf_ptr); /***..... dcl LOCAL_NAME char (9) int static init ("LB_SOURCE");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ /* This internal procedure generates code to convert a long binary source variable to any numeric variable. */ /* DECLARATIONS OF THE PARAMETERS */ dcl sf_ptr ptr; dcl rf_ptr ptr; /* DECLARATION OF INTERNAL VARIABLES */ dcl work_sf_ptr ptr; dcl work_rf_ptr ptr; dcl rf_code fixed bin; work_sf_ptr = sf_ptr; work_rf_ptr = rf_ptr; /* Get a type code for the receiving variable. */ call cobol_get_num_code (rf_ptr, rf_code); /* Goto a conversion code sequence based on the type of the receiving variable. */ goto target_3 (rf_code); target_3 (1): /* TARGET IS UNPACKED DECIMAL */ target_3 (2): /* TARGET IS PACKED DECIMAL */ /* NOTE THAT UNPACKED AND PACKED DECIMAL RECEIVING FIELDS ARE CONVERTED IDENTICALLY. */ call any_bin_dec (work_sf_ptr, work_rf_ptr); go to tgx; target_3 (3): /* TARGET IS SHORT BINARY */ call lb_sb (work_sf_ptr, work_rf_ptr); go to tgx; target_3 (4): /* TARGET IS LONG BINARY */ call bin_same_bin (work_sf_ptr, work_rf_ptr); go to tgx; target_3 (5): /* TARGET IS OVERPUNCH SIGN DATA */ call non_opch_to_opch (work_sf_ptr, work_rf_ptr); tgx: /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end lb_source; /* { */ opch_source: proc (sf_ptr, rf_ptr); /***..... dcl LOCAL_NAME char (11) int static init ("OPCH_SOURCE");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ /* This internal procedure generates code to convert an overpunch sign variable to any type of numeric variable. */ /* Declaration of the parameters. */ dcl sf_ptr ptr; dcl rf_ptr ptr; /* } */ /* Declaration of Internal Variables. */ dcl work_sf_ptr ptr; dcl work_rf_ptr ptr; dcl rf_code fixed bin; /* ************************************************ */ /* START OF EXECUTION */ /* internal procedure */ /* opch_source */ /* ************************************************ */ work_sf_ptr = sf_ptr; work_rf_ptr = rf_ptr; /* Get a numeric type code for the receiving variable. */ call cobol_get_num_code (rf_ptr, rf_code); /* Goto a conversiion routine, based on the type of the receiving variable. */ goto target_4 (rf_code); target_4 (1): /* TARGET IS UNPACKED DECIMAL */ target_4 (2): /* TARGET IS PACKED DECIMAL */ target_4 (3): /* TARGET IS SHORT BINARY */ target_4 (4): /* TARGET IS LONG BINARY */ /* NOTE THAT ALL NON-OVERPUNCH DATA TYPES CALL THE SAME ROUTINE. */ call opch_to_non_opch (work_sf_ptr, work_rf_ptr); go to opx; target_4 (5): /* TARGET IS OVERPUNCH SIGN */ call opch_to_opch (work_sf_ptr, work_rf_ptr); opx: /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end opch_source; /* { */ dec_dec: proc (sf_ptr, rf_ptr); /***..... dcl LOCAL_NAME char (7) int static init ("DEC_DEC");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ /* This internal procedure generates code to move a decimal variable (packed or unpacked) to a decimal variable (packed or unpacked). */ /* DECLARATION OF THE PARAMETERS */ dcl sf_ptr ptr; dcl rf_ptr ptr; /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION sf_ptr Pointer to a data name token (type 9) that describes the sending field. (input) rf_ptr Pointer to a data name token that describes the receiving field. (input) */ start_dec_dec: spl = sf_ptr -> data_name.places_left; spr = sf_ptr -> data_name.places_right; rpl = rf_ptr -> data_name.places_left; rpr = rf_ptr -> data_name.places_right; if spl < 0 then do; /* No places left bytes in the sending field */ if rpr > 0 then call gen_move_dec_numer (sf_ptr, rf_ptr); else do; /* No places right bytes in the receiving field. */ call dec_zero (temp_tkn_ptr); call gen_move_dec_numer (temp_tkn_ptr, rf_ptr); end; /* No places right bytes in the receiving field. */ end; /* No places left bytes in the sending field. */ else do; /* Receiving field does have places left. */ if rpl >= spl /* receiving field can hold sending field completely. */ then call gen_move_dec_numer (sf_ptr, rf_ptr); else do; /* Receiving field not big enough to hold the sending field. */ if rpl + spr <= 0 then do; /* Move zero to the receiving field */ call dec_zero (temp_tkn_ptr); call gen_move_dec_numer (temp_tkn_ptr, rf_ptr); end; /* Move zero to the receiving field */ else do; /* Move source field to receiving field, doing point alignment and truncation if necessary. */ if sf_ptr -> data_name.sign_type = "100"b then do; /* leading separate sign sending field */ /* copy the sending field to temp as trailing separate sign. */ sf_stack_sw = 1; call cobol_alloc$stack (fixed (sf_ptr -> data_name.item_length, 17), 0, stk_offset); substr (new_sf_ptr -> rec_tkn, 1, sf_ptr -> data_name.size) = substr (sf_ptr -> rec_tkn, 1, sf_ptr -> data_name.size); new_sf_ptr -> data_name.linkage_section = "0"b; new_sf_ptr -> data_name.sign_type = "011"b; /* trailing sep */ new_sf_ptr -> data_name.seg_num = 1000; /* stack */ new_sf_ptr -> data_name.subscripted = "0"b; new_sf_ptr -> data_name.offset = stk_offset; /* Generate code to move the leading sign variable to trailing sign variable. */ call gen_move_dec_numer (sf_ptr, new_sf_ptr); sf_ptr, save_sf_ptr = new_sf_ptr; end; /* leading separate sign sending field */ /* Make a copy of the sending data name token */ substr (sf_cpy_ptr -> rec_tkn, 1, sf_ptr -> data_name.size) = substr (sf_ptr -> rec_tkn, 1, sf_ptr -> data_name.size); sf_ptr = sf_cpy_ptr; /* Must call calc_char_offset before item_length is adjusted. */ call calc_char_offset (spl - rpl, sf_ptr); sf_ptr -> data_name.places_left = rpl; sf_ptr -> data_name.item_length = rpl + spr; if sf_ptr -> data_name.sign_separate then sf_ptr -> data_name.item_length = sf_ptr -> data_name.item_length + 1; call gen_move_dec_numer (sf_ptr, rf_ptr); end; /* Move source field to receiving field, doing point alignment and truncation if necessary. */ end; /* Receiving field not big enough to hold the sending field. */ end; /* Receiving field does have places left. */ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end dec_dec; /* { */ num_to_udts: proc (sf_ptr, rf_ptr, return_code); /***..... dcl LOCAL_NAME char (11) int static init ("NUM_TO_UDTS");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ /* This procedure is called to generate code to convert any numeric data item to an unpacked decimal, trailing separate sign value. NOTE: If the source variable is already an unpacked separate trailing sign decimal variable, then no code is generated. Instead, a copy of the input data name token is made. */ /* DECLARATION OF THE PARAMETERS */ dcl sf_ptr ptr; dcl rf_ptr ptr; dcl return_code fixed bin; /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION sf_ptr Pointer to the data name token for the variable to be converted . (input) rf_ptr Pointer to a buffer in which the data name token for the unpacked decimal trailing separate sign variable is built by this procedure. (input) return_code A code that indicates whether an error was detected by this procedure during the generation of the code. A non-zero return code value indicates an error. (output) */ /* } */ /* DECLARATION OF INTERNAL VARIABLES */ dcl ret_offset fixed bin; dcl dum_buff char (500) based; return_code = 0; /* if rf_ptr is null(), then create a buffer into which the token is built. */ if rf_ptr = null () then call cobol_make_type9$decimal_9bit (rf_ptr, 1000, 0, 0, 0); /* Make a copy of the data name token of the data item to be converted. */ substr (rf_ptr -> dum_buff, 1, sf_ptr -> data_name.size) = substr (sf_ptr -> dum_buff, 1, sf_ptr -> data_name.size); /* Make the copy reference an unsubscripted trailing separate sign value. */ rf_ptr -> data_name.subscripted = "0"b; rf_ptr -> data_name.linkage_section = "0"b; rf_ptr -> data_name.sign_separate = "1"b; rf_ptr -> data_name.display = "1"b; rf_ptr -> data_name.sign_type = "011"b; /* trailing separate sign */ /* Zero bits to the usage is "COMP" bits */ rf_ptr -> data_name.ascii_packed_dec = "0"b; rf_ptr -> data_name.bin_18 = "0"b; rf_ptr -> data_name.bin_36 = "0"b; /* Determine the length and scale factor of the receiving item. */ if sf_ptr -> data_name.bin_18 then do; /* bin_18 source field */ rf_ptr -> data_name.places_left = 6; rf_ptr -> data_name.places_right = 0; rf_ptr -> data_name.item_length = 7; /* 6 places left + 1 byte for sign */ end; /* bin_18 source field. */ else if sf_ptr -> data_name.bin_36 then do; /* bin_36 source field */ rf_ptr -> data_name.places_left = 11; rf_ptr -> data_name.places_right = 0; rf_ptr -> data_name.item_length = 12; /* includes 1 byte for sign */ end; /* bin_36 source field */ else /* source field is unpacked decimal, packed decimal, or overpunch sign. */ rf_ptr -> data_name.item_length = sf_ptr -> data_name.places_right + sf_ptr -> data_name.places_left + 1; /* includes 1 byte for sign */ if (^sf_ptr -> data_name.display /* NOT DISPLAY */ | sf_ptr -> data_name.sign_type ^= "011"b /* or NOT trailing sign */ | sf_ptr -> data_name.subscripted /* or subscripted */) then do; /* Generate code to move the source to the unpacked trailing sign decimal */ /* Allocate space on the stack */ call cobol_alloc$stack (fixed (rf_ptr -> data_name.item_length, 17), 0, ret_offset); rf_ptr -> data_name.offset = ret_offset; rf_ptr -> data_name.seg_num = 1000; /* stack */ /* Call internal procedure to generate the code. */ call num_to_num (sf_ptr, rf_ptr); end; /* Generate code to move the source to the unpackde trailing sign decimal. */ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end num_to_udts; /* { */ sb_lb: proc (sf_ptr, rf_ptr); /***..... dcl LOCAL_NAME char (5) int static init ("SB_LB");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ /* This procedure generates code that moves a short fixed binary variable (18 bits) to a long fixed binary value. */ /* DECLARATION OF THE PARAMETERS */ dcl sf_ptr ptr; dcl rf_ptr ptr; /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION sf_ptr Pointer to the data name token for the source variable. (input) rf_ptr Pointer to the data name token for the receiving variable. (input) */ /* DECLARATION OF INTERNAL STATIC DATA */ dcl shift_inst bit (36) int static init ("000000000000010010000000000000000000"b); /* arg 18 */ /* DECLARATIONS OF INTERNAL VARIABLES */ dcl source_reloc bit (36); dcl ret_offset fixed bin; dcl temp_ptr ptr; dcl 1 reg_load_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 pointer ptr, 2 literal bit (36); /*[4.3-1]*/ if sf_ptr -> data_name.subscripted | rf_ptr -> data_name.subscripted /*[4.3-1]*/ then do; call bin_move_bin (sf_ptr, rf_ptr); /*[4.3-1]*/ go to sbx; /*[4.3-1]*/ end; /* Get the address of the source variable. */ eis_ (1) = (36)"0"b; source_reloc = "0"b; input_struc.type = 2; input_struc.operand_no = 1; input_struc.lock = 0; input_struc.operand.token_ptr (1) = sf_ptr; input_struc.operand.size_sw (1) = 0; call cobol_addr (input_ptr, inst_ptr, addr (source_reloc)); /* Get the A or Q register */ reg_load_struc.what_reg = 4; /* A or Q */ reg_load_struc.lock = 1; reg_load_struc.contains = 0; call cobol_register$load (addr (reg_load_struc)); /* Build LDA or LDQ instruction to load the short binary variable */ if reg_load_struc.reg_no = "0001"b then inst_struc_basic.fill1_op = LDA; else inst_struc_basic.fill1_op = LDQ; call cobol_emit (inst_ptr, addr (source_reloc), 1); if substr (unspec (sf_ptr -> data_name.offset), 35, 2) = "10"b then do; /* Source variable is aligned on a half-word boundary, and thus was loaded into the lower half of the A or Q. */ /* Emit code to shift value to upper half of A or Q. */ if reg_load_struc.reg_no = "0001"b then substr (shift_inst, 19, 10) = ALS; else substr (shift_inst, 19, 10) = QLS; call cobol_emit (addr (shift_inst), null (), 1); end; /* Source variable is aligned on a half word boundary. */ /* Emit code to shift A or Q right 18, to extend the sign bit. */ if reg_load_struc.reg_no = "0001"b then substr (shift_inst, 19, 10) = ARS; else substr (shift_inst, 19, 10) = QRS; call cobol_emit (addr (shift_inst), null (), 1); /* Emit code to store the A or Q into the receiving long fixed binary. */ input_struc.operand.token_ptr (1) = rf_ptr; call cobol_addr (input_ptr, inst_ptr, addr (source_reloc)); if reg_load_struc.reg_no = "0001"b then inst_struc_basic.fill1_op = STA; else inst_struc_basic.fill1_op = STQ; call cobol_emit (inst_ptr, addr (source_reloc), 1); /* Unlock the A or Q register */ call cobol_register$release (addr (reg_load_struc)); sbx: /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end sb_lb; /* { */ dec_lb: proc (sf_ptr, rf_ptr); /***..... dcl LOCAL_NAME char (6) int static init ("DEC_LB");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ /* This procedure generates code to convert a decimal variable (packed or unpacked, signed or unsigned) to long (36 bit) fixed binary. */ /* DECLARATION OF THE PARAMETERS */ dcl sf_ptr ptr; dcl rf_ptr ptr; /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION sf_ptr Pointer to the data name token of the sending decimal variable. (input) rf_ptr Pointer to the data name token of the receiving long binary variable. (input) */ /* DECLARATION OF INTERNAL STATIC DATA */ dcl long_binary_mask bit (72) int static init /* octal = 400000000000377777777777 */ ( "100000000000000000000000000000000000011111111111111111111111111111111111"b); /* DECLARATION OF INTERNAL VARIABLES */ dcl bump fixed bin; dcl ret_offset fixed bin; dcl 1 reg_load_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 pointer ptr, 2 literal bit (36); dcl temp_inst bit (36); dcl temp_inst_ptr ptr; dcl temp_reloc (1:2) bit (5) aligned; dcl long_bin_limit fixed bin; dcl temp_reloc_ptr ptr; dcl mask_ptr ptr; dcl const_offset fixed bin (24); dcl bin_tkn_ptr ptr; dcl binary_mask_string char (8) based (mask_ptr); spl = sf_ptr -> data_name.places_left; spr = sf_ptr -> data_name.places_right; if spl <= 0 then do; /* Sending field less than zero. Move zero to the receiving field. */ call dec_zero (temp_tkn_ptr); call set_ips_type5_6 (5, temp_tkn_ptr, rf_ptr, null ()); call cobol_addr (input_ptr, inst_ptr, reloc_ptr); inst_struc.fill1_op = DTB; call cobol_emit (inst_ptr, reloc_ptr, 3); end; /* Sending field less than zero. Move zero to the receiving field. */ else do; /* Sending field has an integer part. */ if (sf_ptr -> data_name.places_right ^= 0 | (sf_ptr -> data_name.sign_type = "100"b /* leading separate */ & sf_ptr -> data_name.places_left > rf_ptr -> data_name.places_left)) then call dec_dec_fix (sf_ptr, temp_tkn_ptr); /* fix the decimal variable. */ else temp_tkn_ptr = sf_ptr; /* Sending variable already an integer with no sign, or a trailing separate sign. */ /* At this point, if the sending decimal value was not an integer, or if it had a leading separate sign, code has been generated to convert the decimal value to an integer value with trailing separate sign. Next code is generated to convert the decimal integer value to long fixed binary. The code sequence generated is: dtb convert fixed decimal to fixed binary desc9ts source,12,0 desc9a temp1,8 ldaq temp1 anaq =o400000000000377777777777 stq temp1 orsa temp1 mlr desc9a temp1,4 desc9a final,4 */ if temp_tkn_ptr -> data_name.bin_32 then long_bin_limit = 10; else long_bin_limit = 11; if temp_tkn_ptr -> data_name.places_left > long_bin_limit then do; /* Modify the token so the least significant long_bin_limit digits are converted to binary. */ if temp_tkn_ptr = sf_ptr then do; /* Make a copy of the token. The token copy will be modified. */ temp_tkn_ptr = null (); if sf_ptr -> data_name.subscripted then call cobol_make_type9$copy_sub (temp_tkn_ptr, sf_ptr); else call cobol_make_type9$copy (temp_tkn_ptr, sf_ptr); end; /* Make a copy of the token. */ bump = temp_tkn_ptr -> data_name.places_left - long_bin_limit; call calc_char_offset (bump, temp_tkn_ptr); temp_tkn_ptr -> data_name.places_left = long_bin_limit; if temp_tkn_ptr -> data_name.sign_type = "011"b /* trailing separate */ then temp_tkn_ptr -> data_name.item_length = long_bin_limit + 1; else temp_tkn_ptr -> data_name.item_length = long_bin_limit; end; /* Modify token so least significant long_bin_limit digits are converted to binary. */ if temp_tkn_ptr -> data_name.places_left > (long_bin_limit - 1) then do; /* Sending field could possibly overflow one word (36 bits). Must convert into a double word, and then truncate on the left. */ /* Allocate 8 bytes of even word aligned storage on the stack. */ call cobol_alloc$stack (8, 2 /* even word boundary */, ret_offset); ret_offset = ret_offset * 4; /* convert word offset to char offset */ /* Make a long fixed binary data name token for the temporary. */ bin_tkn_ptr = null (); call cobol_make_type9$long_bin (bin_tkn_ptr, 1000, ret_offset); /* Set item length in the token to 8 bytes (make_type9 sets it to 4) */ bin_tkn_ptr -> data_name.item_length = 8; end; /* Sending field could possibly overflow one word. Must convert into a bouble word. */ else bin_tkn_ptr = rf_ptr; /* Can convert directly into the receiving field. */ /* Generate EIS instruction and descriptors for the DTB instruction. */ call set_ips_type5_6 (5, temp_tkn_ptr, bin_tkn_ptr, null ()); call cobol_addr (input_ptr, inst_ptr, reloc_ptr); inst_struc.fill1_op = DTB; call cobol_emit (inst_ptr, reloc_ptr, 3); if bin_tkn_ptr ^= rf_ptr then do; /* Sending field was not converted directly into the receiving field. */ /* Pool the long binary mask */ mask_ptr = addr (long_binary_mask); /* Note that the mask must be pooled on an even word boundary, because it is going to be used in a double register instruction. */ call cobol_pool$search_op (binary_mask_string, 2, const_offset, in_op); /* Convert the returned word offset to character offset. */ const_offset = const_offset * 4; /* Get the address of the temporary double word that contains the fixed binary value. */ temp_inst_ptr = addr (temp_inst); temp_reloc_ptr = addr (temp_reloc (1)); input_struc_basic.type = 1; input_struc_basic.operand_no = 0; input_struc_basic.segno = bin_tkn_ptr -> data_name.seg_num; input_struc_basic.char_offset = bin_tkn_ptr -> data_name.offset; input_struc_basic.send_receive = 1; /* sending */ call cobol_addr (input_ptr, temp_inst_ptr, temp_reloc_ptr); /* Get the A and Q registers */ reg_load_struc.what_reg = 3; /* A and Q */ reg_load_struc.lock = 0; reg_load_struc.contains = 0; call cobol_register$load (addr (reg_load_struc)); /* Build and emit LDAQ "temp" instruction */ substr (temp_inst, 19, 10) = LDAQ; call cobol_emit (temp_inst_ptr, temp_reloc_ptr, 1); /* Get basic address of the long binary mask */ if in_op = 1 then input_struc_basic.segno = 3; else input_struc_basic.segno = 3000; input_struc_basic.char_offset = const_offset; call cobol_addr (input_ptr, inst_ptr, reloc_ptr); /* Build and emit ANAQ "long bin mask" instruction. */ inst_struc_basic.fill1_op = ANAQ; call cobol_emit (inst_ptr, reloc_ptr, 1); /* Build and emit STQ "temp" instruction. */ substr (temp_inst, 19, 10) = STQ; call cobol_emit (temp_inst_ptr, temp_reloc_ptr, 1); /* Build and emit ORSA "temp" instruction. */ substr (temp_inst, 19, 10) = ORSA; call cobol_emit (temp_inst_ptr, temp_reloc_ptr, 1); /* Generate code to move the value in the stack temporary to the receiving field. */ bin_tkn_ptr -> data_name.item_length = 4; bin_tkn_ptr -> data_name.numeric = "0"b; bin_tkn_ptr -> data_name.alphanum = "1"b; rf_ptr -> data_name.numeric = "0"b; rf_ptr -> data_name.alphanum = "1"b; call set_ips_type5_6 (5, bin_tkn_ptr, rf_ptr, null ()); call cobol_addr (input_ptr, inst_ptr, reloc_ptr); inst_struc.fill1_op = MLR; call cobol_emit (inst_ptr, reloc_ptr, 3); /* Reset the receiving field token. */ rf_ptr -> data_name.numeric = "1"b; rf_ptr -> data_name.alphanum = "0"b; end; /* Sending field was not converted directly into the receiving field. */ /* Restore the A and Q */ call cobol_register$release (addr (reg_load_struc)); end; /* Sending field has an integer part. */ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end dec_lb; /* { */ lb_sb: proc (sf_ptr, rf_ptr); /***..... dcl LOCAL_NAME char (5) int static init ("LB_SB");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ /* This procedure generates code to move a long fixed binary (36 bit) variable to a short fixed binary (18 bit) variable. */ /* DECLARATION OF THE PARAMETERS */ dcl sf_ptr ptr; dcl rf_ptr ptr; dcl j fixed bin; /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION sf_ptr Pointer to the data name token for the source variable. (input) rf_ptr Pointer to the data name tokne for the receiving variable. (input) */ if rf_ptr -> data_name.subscripted = "0"b then do; call load_bin (sf_ptr, 3); if substr (unspec (rf_ptr -> data_name.offset), 35, 2) = "10"b then j = 7; else j = 6; call load_bin (rf_ptr, j); end; else do; call bin_move_bin (sf_ptr, rf_ptr); end; /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end lb_sb; /* { */ bin_same_bin: proc (sf_ptr, rf_ptr); /***..... dcl LOCAL_NAME char (12) int static init ("BIN_SAME_BIN");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ /* This procedure generates code to move a binary variable to a binary variable of the same length, that is, 1. short binary to short binary 2. long binary to long binary */ /* DECLARATION OF THE PARAMETERS */ dcl sf_ptr ptr; dcl rf_ptr ptr; dcl j fixed bin; /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION sf_ptr Pointer to the data name token for the source variable. (input) rf_ptr Pointer to the data name token for the receiving variable. (input) */ /*[4.3-2]*/ if sf_ptr -> data_name.subscripted | rf_ptr -> data_name.subscripted /*[4.3-2]*/ then do; call bin_move_bin (sf_ptr, rf_ptr); /*[4.3-2]*/ go to binx; /*[4.3-2]*/ end; if sf_ptr -> data_name.bin_36 then do; call load_bin (sf_ptr, 1); call load_bin (rf_ptr, 4); end; else do; if sf_ptr -> data_name.subscripted = "0"b & rf_ptr -> data_name.subscripted = "0"b then do; if substr (unspec (sf_ptr -> data_name.offset), 35, 2) = "10"b then j = 3; else j = 2; call load_bin (sf_ptr, j); if substr (unspec (rf_ptr -> data_name.offset), 35, 2) = "10"b then j = 7; else j = 6; call load_bin (rf_ptr, j); end; else do; call bin_move_bin (sf_ptr, rf_ptr); end; end; binx: /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end bin_same_bin; load_bin: proc (temp_ptr, code); /***..... dcl LOCAL_NAME char (8) int static init ("LOAD_BIN");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ /* load long or short bin */ dcl temp_ptr ptr; dcl code fixed bin; dcl inst_op (7) bit (10) static init ("0100111010"b, /* lda */ "0100100000"b, /* ldxn */ "1110100000"b, /* lxln */ "1111011010"b, /* sta */ "1011010010"b, /* stba */ "1111000000"b, /* stxn */ "1001000000"b); /* sxln */ /* The followings are for the register structure */ /* reg_struc_ptr is a pointer to the following structure (input) */ dcl 1 reg_struc static, 2 what_reg fixed bin, 2 reg_num bit (4), 2 lock fixed bin init (1), 2 already_there fixed bin, 2 contains fixed bin, 2 pointer ptr, 2 literal bit (36); start: input_struc.type = 2; input_struc.operand_no = 1; input_struc.lock = 0; input_struc.token_ptr (1) = temp_ptr; input_struc.size_sw (1) = 0; call cobol_addr (input_ptr, inst_ptr, reloc_ptr); if code = 1 then reg_struc.what_reg = 1; else if code = 2 | code = 3 then reg_struc.what_reg = 14; inst_struc.fill1_op = inst_op (code); if code <= 3 then do; call cobol_register$load (addr (reg_struc)); if code = 2 | code = 3 then substr (inst_struc.fill1_op, 7, 3) = substr (reg_struc.reg_num, 2, 3); call cobol_emit (inst_ptr, reloc_ptr, 1); end; else do; if code = 6 | code = 7 then substr (inst_struc.fill1_op, 7, 3) = substr (reg_struc.reg_num, 2, 3); call cobol_emit (inst_ptr, reloc_ptr, 1); call cobol_register$release (addr (reg_struc)); end; /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end load_bin; bin_move_bin: proc (sf_ptr, rf_ptr); /***..... dcl LOCAL_NAME char (12) int static init ("BIN_MOVE_BIN");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ /* This procedure generate code to move binary data to binary data through eis instruction. Because of subscripted bin_18 data is not expected for its alignment, non-eis instructions are not applicable. */ dcl (sf_ptr, rf_ptr) ptr; sf_ptr -> data_name.numeric = "0"b; sf_ptr -> data_name.alphanum = "1"b; rf_ptr -> data_name.numeric = "1"b; rf_ptr -> data_name.alphanum = "1"b; /* Build input to the addressability utility */ call set_ips_type5_6 (5, sf_ptr, rf_ptr, null ()); /* Call the addressability utility to build instruction and two descriptors. */ call cobol_addr (input_ptr, inst_ptr, reloc_ptr); /* Set the MLR opcode into the instruction. */ /* [4.2-1] */ inst_struc.fill1_op = MRL; /* Emit the instruction to move source to receiving. */ call cobol_emit (inst_ptr, reloc_ptr, 3); sf_ptr -> data_name.alphanum = "0"b; sf_ptr -> data_name.numeric = "1"b; rf_ptr -> data_name.alphanum = "0"b; rf_ptr -> data_name.numeric = "1"b; /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end bin_move_bin; /* { */ any_bin_dec: proc (sf_ptr, rf_ptr); /***..... dcl LOCAL_NAME char (11) int static init ("ANY_BIN_DEC");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ /* This procedure generates code to move any fixed binary variable to an unpacked or packed decimal variable. */ /* DECLARATION OF THE PARAMETERS */ dcl sf_ptr ptr; dcl rf_ptr ptr; /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION sf_ptr Pointer to the data name token for the fixed binary source variable. (input) rf_ptr Pointer to the data name token for the decimal (packed or unpackde) receiving variable. (input) */ /* DECLARATIONS OF INTERNAL VARIABLES */ dcl dec_temp_size fixed bin; dcl ret_offset fixed bin; dcl dec_tkn_ptr ptr; dcl temp_result bit (1); temp_result = "0"b; /* Determine the size of the temporary required to hold the decimal representation of the fixed binary. */ if sf_ptr -> data_name.bin_18 then dec_temp_size = 6; /* includes 1 byte for sign */ else dec_temp_size = 11; if (rf_ptr -> data_name.places_left < dec_temp_size | rf_ptr -> data_name.places_right ^= 0) then do; /* Convert the binary value into a temporary on the stack. */ /* Allocate space on the stack for the temporary. */ call cobol_alloc$stack (dec_temp_size + 1, 0, ret_offset); /* Make a data name token for the decimal temporary. */ dec_tkn_ptr = null (); call cobol_make_type9$decimal_9bit (dec_tkn_ptr, 1000 /* stack */, fixed (ret_offset, 24), dec_temp_size, 0); /* change sign type from leading separate to trailing separate. */ dec_tkn_ptr -> data_name.sign_type = "011"b; /* trailing separate */ temp_result = "1"b; end; /* Convert the binary value into a temporary on the stack. */ else dec_tkn_ptr = rf_ptr; /* Build input to the addressability utility */ call set_ips_type5_6 (5, sf_ptr, dec_tkn_ptr, null ()); /* Build the EIS instruction and descriptors. */ call cobol_addr (input_ptr, inst_ptr, reloc_ptr); /* Insert BTD opcode. */ inst_struc.fill1_op = BTD; /* Emit the code. */ call cobol_emit (inst_ptr, reloc_ptr, 3); /* At this point, if code has been generated to convert the short or long binary value into a trailing separate sign value in the stack, it is now necessary to move the decimal temporary to the decimal receiving field. */ if temp_result then call dec_dec (dec_tkn_ptr, rf_ptr); /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end any_bin_dec; /* { */ dec_sb: proc (sf_ptr, rf_ptr); /***..... dcl LOCAL_NAME char (6) int static init ("DEC_SB");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ /* This internal procedure generates code to convert a decimal value (packed or unpacked, unsigned or separate sign) to short fixed binary. */ /* DECLARATION OF THE PARAMETERS */ dcl sf_ptr ptr; dcl rf_ptr ptr; /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION sf_ptr Pointer to the data name token of the sending decimal field. rf_ptr Pointer to the data name token of the short binary receiving field. */ /* DECLARATION OF INTERNAL STATIC VARAIBLES */ dcl arl_18_inst bit (36) int static init ("000000000000010010000000000000000000"b); /* arg 18 */ dcl short_binary_mask bit (36) int static init ("100000000000000000011111111111111111"b); /* DECLARATIONS OF INTERNAL VARIABLES */ dcl temp_inst bit (36); dcl temp_inst_ptr ptr; dcl temp_reloc (1:5) bit (5) aligned; dcl temp_reloc_ptr ptr; dcl short_bin_limit fixed bin; dcl shift_inst_ptr ptr; dcl 1 reg_load_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 ret_offset fixed bin; dcl const_offset fixed bin (24); dcl mask_ptr ptr; dcl binary_mask_string char (4) based (mask_ptr); dcl bin_tkn_ptr ptr; dcl bump fixed bin; start_dec_sb: spl = sf_ptr -> data_name.places_left; spr = sf_ptr -> data_name.places_right; if spl <= 0 then do; /* Sending field less than zero, move zero to the receiving field. */ call dec_zero (temp_tkn_ptr); call set_ips_type5_6 (5, temp_tkn_ptr, rf_ptr, null ()); call cobol_addr (input_ptr, inst_ptr, reloc_ptr); inst_struc.fill1_op = DTB; call cobol_emit (inst_ptr, reloc_ptr, 3); end; /* Sending field less than zero, move zero to the receiving field. */ else do; /* Sending field has an integer part. */ if (sf_ptr -> data_name.places_right ^= 0 | sf_ptr -> data_name.sign_type = "100"b /* leading separate */) then call dec_dec_fix (sf_ptr, temp_tkn_ptr); else temp_tkn_ptr = sf_ptr; /* At this point, code has been generated to convert the decimal variable to an integer decimal value. (no places to the right of the decimal point) Now we generate code to convert the fixed decimal to short fixed binary. The code sequence to be generated is: dtb convert fixed decimal to fixed binary desc9ts source,7,0 desc9a temp1,4 lda temp1 ana =o400000377777 sta temp1 alr 18 orsa temp1 mlr desc9a temp1(2),2 desc9a final_result,2 */ if temp_tkn_ptr -> data_name.bin_16 then short_bin_limit = 5; else short_bin_limit = 6; if temp_tkn_ptr -> data_name.places_left > short_bin_limit then do; /* Modify the token so the short_bin_limit least significant digits of data are converted. */ if temp_tkn_ptr = sf_ptr then do; /* Make a copy of the source token . */ temp_tkn_ptr = null (); if sf_ptr -> data_name.subscripted then call cobol_make_type9$copy_sub (temp_tkn_ptr, sf_ptr); else call cobol_make_type9$copy (temp_tkn_ptr, sf_ptr); end; /* Make a copy of the source token. */ bump = temp_tkn_ptr -> data_name.places_left - short_bin_limit; call calc_char_offset (bump, temp_tkn_ptr); temp_tkn_ptr -> data_name.places_left = short_bin_limit; if temp_tkn_ptr -> data_name.sign_type = "011"b /* trailing separate */ then temp_tkn_ptr -> data_name.item_length = short_bin_limit + 1; else temp_tkn_ptr -> data_name.item_length = short_bin_limit; end; /* Modify the token so the short_bin_limit least significant digits of data are converted. */ if temp_tkn_ptr -> data_name.places_left > (short_bin_limit - 1) then do; /* Sending field could possibly overflow one half word. Must convert it into a full word, and then truncate on the left. */ /* Allocate 4 bytes of word aligned storage on the stack. */ call cobol_alloc$stack (4, 0, ret_offset); /* Make a long fixed binary data name token for the temporary storage */ bin_tkn_ptr = null (); call cobol_make_type9$long_bin (bin_tkn_ptr, 1000 /* stack */, ret_offset); end; /* Sending field could possibly overflow one half word.. */ else bin_tkn_ptr = rf_ptr; /* Can convert directly into the receiving field. */ /* Generate EIS instruction and two descriptors for a DTB instruction */ call set_ips_type5_6 (5, temp_tkn_ptr, bin_tkn_ptr, null ()); call cobol_addr (input_ptr, inst_ptr, reloc_ptr); inst_struc.fill1_op = DTB; call cobol_emit (inst_ptr, reloc_ptr, 3); if bin_tkn_ptr ^= rf_ptr then do; /* Sending field was not converted directly into the receiving field. */ /* Pool the short binary mask */ mask_ptr = addr (short_binary_mask); call cobol_pool$search_op (binary_mask_string, 0, const_offset, in_op); if in_op = 0 then temp = 3000; else temp = 3; /* Make a data name token for the mask */ mask_ptr = null (); call cobol_make_type9$alphanumeric (mask_ptr, temp /* constant section */, const_offset, 4); /* Get the address of the temporary word that contains the fixed binary value. */ temp_inst_ptr = addr (temp_inst); temp_reloc_ptr = addr (temp_reloc (1)); input_struc_basic.type = 1; input_struc_basic.operand_no = 0; input_struc_basic.lock = 0; input_struc_basic.segno = bin_tkn_ptr -> data_name.seg_num; input_struc_basic.char_offset = bin_tkn_ptr -> data_name.offset; input_struc_basic.send_receive = 1; /* sending */ call cobol_addr (input_ptr, temp_inst_ptr, temp_reloc_ptr); /* Get the A or Q */ reg_load_struc.what_reg = 4; /* A or Q */ reg_load_struc.lock = 0; reg_load_struc.contains = 0; call cobol_register$load (addr (reg_load_struc)); /* Build LDA or LDQ instruction */ if reg_load_struc.reg_no = "0001"b then substr (temp_inst, 19, 10) = LDA; else substr (temp_inst, 19, 10) = LDQ; call cobol_emit (temp_inst_ptr, temp_reloc_ptr, 1); /* Build the basic address of the short binary mask */ input_struc_basic.segno = mask_ptr -> data_name.seg_num; input_struc_basic.char_offset = mask_ptr -> data_name.offset; call cobol_addr (input_ptr, inst_ptr, reloc_ptr); if reg_load_struc.reg_no = "0001"b then inst_struc_basic.fill1_op = ANA; else inst_struc_basic.fill1_op = ANQ; call cobol_emit (inst_ptr, reloc_ptr, 1); /* Emit code to store the A or Q */ if reg_load_struc.reg_no = "0001"b then substr (temp_inst, 19, 10) = STA; else substr (temp_inst, 19, 10) = STQ; call cobol_emit (temp_inst_ptr, temp_reloc_ptr, 1); /* Emit "arl 18" or "qrl 18" instruction */ shift_inst_ptr = addr (arl_18_inst); if reg_load_struc.reg_no = "0001"b then substr (arl_18_inst, 19, 10) = ARL; else substr (arl_18_inst, 19, 10) = QRL; call cobol_emit (shift_inst_ptr, null (), 1); /* Emit code to OR the A or Q to the temp value. */ if reg_load_struc.reg_no = "0001"b then substr (temp_inst, 19, 10) = ORSA; else substr (temp_inst, 19, 10) = ORSQ; call cobol_emit (temp_inst_ptr, temp_reloc_ptr, 1); /* Generate code to move the two least significant bytes of the fixed binary temporary into the receiving field. */ /* Update the character offset in the token that describes the fixed bin temp. */ bin_tkn_ptr -> data_name.offset = bin_tkn_ptr -> data_name.offset + 2; bin_tkn_ptr -> data_name.item_length = 2; bin_tkn_ptr -> data_name.numeric = "0"b; bin_tkn_ptr -> data_name.alphanum = "1"b; rf_ptr -> data_name.numeric = "0"b; rf_ptr -> data_name.alphanum = "1"b; call set_ips_type5_6 (5, bin_tkn_ptr, rf_ptr, null ()); call cobol_addr (input_ptr, inst_ptr, reloc_ptr); inst_struc_basic.fill1_op = MLR; call cobol_emit (inst_ptr, reloc_ptr, 3); rf_ptr -> data_name.numeric = "1"b; rf_ptr -> data_name.alphanum = "0"b; end; /* Sending field was not converted directly into the receiving field. */ end; /* Sending field has an integer part. */ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end dec_sb; /* { */ dec_dec_fix: proc (sf_ptr, fixed_sf_ptr); /***..... dcl LOCAL_NAME char (11) int static init ("DEC_DEC_FIX");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ /* This procedure generates code to fix (truncate places to the right of the decimal point) a packed or unpacked decimal value. */ /* DECLARATION OF THE PARAMETERS */ dcl sf_ptr ptr; dcl fixed_sf_ptr ptr; /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION sf_ptr Pointer to the data name token for the decimal variable to be fixed. (input) fixed_sf_ptr Pointer to a buffer in which the data name token for the fixed value is built. (input) */ dcl ret_offset fixed bin; dcl temp_tok char (500) based; /* Allocate space on the stack for the fixed value. */ call cobol_alloc$stack (sf_ptr -> data_name.places_left + 1, 0, ret_offset); /* Copy the source token into the user-supplied buffer. */ substr (fixed_sf_ptr -> temp_tok, 1, sf_ptr -> data_name.size) = substr (sf_ptr -> temp_tok, 1, sf_ptr -> data_name.size); /* Modify the token copy to describe the fixed value on the stack. */ fixed_sf_ptr -> data_name.linkage_section = "0"b; fixed_sf_ptr -> data_name.item_length = fixed_sf_ptr -> data_name.places_left + 1; fixed_sf_ptr -> data_name.places_right = 0; fixed_sf_ptr -> data_name.sign_type = "011"b; /* trailing separate */ fixed_sf_ptr -> data_name.seg_num = 1000; /* stack */ fixed_sf_ptr -> data_name.offset = ret_offset; /* Generate code to move the sending filed to the stack temporary. */ call gen_move_dec_numer (sf_ptr, fixed_sf_ptr); /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end dec_dec_fix; /* { */ non_opch_to_opch: proc (sf_ptr, rf_ptr); /***..... dcl LOCAL_NAME char (16) int static init ("NON_OPCH_TO_OPCH");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ /* This internal procedure generates code to move a non-overpunch sign variable to an overpunch sign receiving field. */ /* DECLARATION OF THE PARAMETERS */ dcl sf_ptr ptr; dcl rf_ptr ptr; /* DECLARATION OF INTERNAL VARIABLES */ dcl temp_sf_ptr ptr; dcl return_code fixed bin; dcl udts_token_ptr ptr; /* The following declaration are used for numerical literal to opch. 6/1/76 bc. */ dcl temp_rf_ptr ptr, move_char char (1), temp_len fixed bin, temp_ptr ptr, temp_space char (250), temp_sign_type bit (3), move_digit fixed bin, an_ptr ptr, conv_plus (0:9) char (1) static init ("{", "A", "B", "C", "D", "E", "F", "G", "H", "I"), conv_minus (0:9) char (1) static init ("}", "J", "K", "L", "M", "N", "O", "P", "Q", "R"); dcl 1 al_lit, 2 size fixed bin, 2 line fixed bin, 2 column fixed bin, 2 type fixed bin, 2 lit_type bit (1), 2 all_lit bit (1), 2 filler1 bit (6), 2 lit_size fixed bin, 2 string char (1); /* ************************************************ */ /* START OF EXECUTION */ /* non_opch_to_opch */ /* ************************************************ */ temp_sf_ptr = sf_ptr; /* Handle the numeric to opch data. 6/1/76 by bc. */ if numeric_lit_flag = 1 & rf_ptr -> data_name.elementary then do; numeric_lit_flag = 0; temp_rf_ptr = rf_ptr; temp_rf_ptr -> data_name.item_signed = "0"b; temp_sign_type = temp_rf_ptr -> data_name.sign_type; temp_rf_ptr -> data_name.sign_type = "000"b; call dec_dec (temp_sf_ptr, temp_rf_ptr); move_char = "0"; if temp_sign_type = "010"b then do; if sf_ptr -> data_name.places_left >= temp_rf_ptr -> data_name.places_left then if (sf_ptr -> data_name.places_left - temp_rf_ptr -> data_name.places_left + 1 > 0) then move_char = substr (lit_str, sf_ptr -> data_name.places_left - temp_rf_ptr -> data_name.places_left + 1, 1); end; else do; if sf_ptr -> data_name.places_right >= temp_rf_ptr -> data_name.places_right then if (sf_ptr -> data_name.places_left + temp_rf_ptr -> data_name.places_right > 0) then move_char = substr (lit_str, sf_ptr -> data_name.places_left + temp_rf_ptr -> data_name.places_right, 1); end; move_digit = binary (move_char, 35); /* [3.0-2] */ if substr (lit_str, lit_ln + 1, 1) ^= "-" then move_char = conv_plus (move_digit); else move_char = conv_minus (move_digit); al_lit.type = 3; al_lit.size = 29; al_lit.all_lit = "0"b; al_lit.lit_type = "0"b; al_lit.lit_size = 1; al_lit.line = lin; al_lit.column = col; al_lit.string = move_char; an_ptr = addr (al_lit); temp_ptr = addr (temp_space); call cobol_make_type9$type2_3 (temp_ptr, an_ptr); temp_rf_ptr -> data_name.numeric = "0"b; temp_rf_ptr -> data_name.alphanum = "1"b; call gen_move_alpha (MLR, "000110000"b, temp_ptr, temp_rf_ptr, "1"b); if temp_sign_type = "001"b then do; temp_len = fixed (substr (inst_struc.desc_od (2), 25, 12), 12) + fixed (substr (inst_struc.desc_od (2), 4, 17), 17) - 1; substr (inst_struc.desc_od (2), 4, 17) = substr (unspec (temp_len), 20, 17); end; substr (inst_struc.desc_od (2), 25, 12) = "000000000001"b; call cobol_emit (inst_ptr, reloc_ptr, 3); temp_rf_ptr -> data_name.numeric = "1"b; temp_rf_ptr -> data_name.alphanum = "0"b; temp_rf_ptr -> data_name.item_signed = "1"b; temp_rf_ptr -> data_name.sign_type = temp_sign_type; end; else do; /* Check to see if zero should be moved to the rrceiving field, rather than the sending variable. */ call check_zero_move (temp_sf_ptr, rf_ptr); if temp_sf_ptr = sf_ptr then do; /* Sending variable should be moved. */ udts_token_ptr = null (); /* Convert the sending field to numeric decimal, trailing separate sign data if necessary. */ call num_to_udts (temp_sf_ptr, udts_token_ptr, return_code); end; /* Sending variable should be moved. */ else udts_token_ptr = temp_sf_ptr; call cobol_opch_op_call (udts_token_ptr, rf_ptr); end; /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end non_opch_to_opch; /* { */ opch_to_opch: proc (sf_ptr, rf_ptr); /***..... dcl LOCAL_NAME char (12) int static init ("OPCH_TO_OPCH");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ /* This internal procedure generates code that moves an overpunch sign variable to an overpunch sign variable. */ /* DECLARATION OF THE PARAMETERS */ dcl sf_ptr ptr; dcl rf_ptr ptr; /* DECLARATION OF INTERNAL VARIABLES */ dcl temp_sf_ptr ptr; /* ************************************************ */ /* START OF EXECUTION */ /* opch_to_opch */ /* ************************************************ */ temp_sf_ptr = sf_ptr; /* Check to see whether zero should be moved to the receiving field, rather than the sending variable. */ call check_zero_move (temp_sf_ptr, rf_ptr); call cobol_opch_op_call (temp_sf_ptr, rf_ptr); /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end opch_to_opch; /* { */ opch_to_non_opch: proc (sf_ptr, rf_ptr); /***..... dcl LOCAL_NAME char (16) int static init ("OPCH_TO_NON_OPCH");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ /* This internal procedure generates code to move an overpunch sign sending variable to any non-overpunch receiving variable. */ /* Declaration of the Parameters */ dcl sf_ptr ptr; dcl rf_ptr ptr; /* Declarations of Internal Variables. */ dcl char_offset fixed bin; dcl temp_sf_ptr ptr; dcl temp_rf_ptr ptr; /* ************************************************ */ /* START OF EXECUTION */ /* INTERNAL PROCEDURE */ /* opch_to_non_opch */ /* ************************************************ */ /* Check to see whether zero should be moved to the receiving field, rather than the sending variable. */ temp_sf_ptr = sf_ptr; call check_zero_move (temp_sf_ptr, rf_ptr); if temp_sf_ptr ^= sf_ptr /* Move zero, instead of the sending variable. */ then call num_to_num (temp_sf_ptr, rf_ptr); else do; /* Move the overpunch sign data to the receiving field. */ if (rf_ptr -> data_name.display = "0"b /* NOT display */ | rf_ptr -> data_name.sign_type ^= "011"b /* NOT trailing separate sign */) then do; /* Must build a temporary, unpacked decimal, trailing separate sign data item, and move the overpunch sign data into it. */ /* NOTE: The temporary is the length of the receiving field. */ call cobol_alloc$stack (rf_ptr -> data_name.places_left + rf_ptr -> data_name.places_right + 1, 0, char_offset); temp_rf_ptr = null (); call cobol_make_type9$decimal_9bit (temp_rf_ptr, 1000 /* stack */, fixed (char_offset, 24), fixed (rf_ptr -> data_name.places_left, 17), fixed (rf_ptr -> data_name.places_right, 17)); /* Change sign type in the temporary to trailing separate. */ temp_rf_ptr -> data_name.sign_type = "011"b; end; /* Must build a temporary, unpacked decimal, trailing separate sign data item. */ else temp_rf_ptr = rf_ptr; call cobol_opch_op_call (sf_ptr, temp_rf_ptr); if temp_rf_ptr ^= rf_ptr then call num_to_num (temp_rf_ptr, rf_ptr); end; /* Move the overpunch sign data to the receiving field. */ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end opch_to_non_opch; /* { */ check_zero_move: proc (sf_ptr, rf_ptr); /***..... dcl LOCAL_NAME char (15) int static init ("CHECK_ZERO_MOVE");/**/ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/ /* This internal procedure determines whether any part of a sending variable will fit into a receiving variable, based on the places to the left and right of the decimal point contained in the data name tokens. If no part of the sending variable will fit into the receiving field, then a representation of a constant equal to zero is allocated, a data name token is created for the constant, and the parameter sf_ptr is set to the token for the zero constant. */ /* DECLARATION OF THE PARAMETERS */ dcl sf_ptr ptr; dcl rf_ptr ptr; /* DECLARATION OF INTERNAL STATIC DATA */ dcl bin_zero fixed bin (35) int static init (0); dcl dec_zero char (2) int static init ("0+"); /* DECLARATIONS OF INTERNAL VARIABLES */ dcl const_ptr ptr; dcl const_offset fixed bin (24); dcl bin_zero_const char (4) based (const_ptr); dcl dec_zero_const char (2) based (const_ptr); dcl const_length fixed bin; dcl temp_ptr ptr; /* ****************************************** */ /* START OF EXECUTION */ /* check_zero_move */ /* ************************************************ */ if (rf_ptr -> data_name.places_left + sf_ptr -> data_name.places_right) <= 0 | (rf_ptr -> data_name.places_right + sf_ptr -> data_name.places_left) <= 0 then do; /* Move zero to the receiving field, insstead of the source variable. */ if (rf_ptr -> data_name.bin_18 | rf_ptr -> data_name.bin_36) then do; /* Receiving is fixed binary. Allocate a fixed binary zero constant. */ const_ptr = addr (bin_zero); if rf_ptr -> data_name.bin_18 then const_length = 2; else const_length = 4; call cobol_pool$search_op (substr (bin_zero_const, 1, const_length), 0, const_offset, in_op) ; if in_op = 0 then temp = 3000; else temp = 3; temp_ptr = null (); if rf_ptr -> data_name.bin_18 then call cobol_make_type9$short_bin (temp_ptr, temp, fixed (const_offset, 17)); else call cobol_make_type9$long_bin (temp_ptr, temp, fixed (const_offset, 17)); sf_ptr = temp_ptr; end; /* Receiving is fixed binary. Allocate a fixed binary zero constant. */ else do; /* Allocate a decimal, separate trailing sign plus zero constant. */ const_ptr = addr (dec_zero); call cobol_pool$search_op (dec_zero_const, 0, const_offset, in_op); if in_op = 0 then temp = 3000; else temp = 3; /* Make a data name token for the constant. */ temp_ptr = null (); call cobol_make_type9$decimal_9bit (temp_ptr, temp, const_offset, fixed (rf_ptr -> data_name.places_left, 17), 1 - rf_ptr -> data_name.places_left); /* Change the sign type to trailing separate. */ temp_ptr -> data_name.sign_type = "011"b; sf_ptr = temp_ptr; end; /* Allocate a decimal, separate trailing sign, plus zero constant. */ end; /* Move zero to the receiving field, instead of the source variable. */ /***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/ end check_zero_move; /*[4.4-2]*/ declare (SF_dn, RF_dn) char (144); type_13_to_9: proc (p, q); /* convert type 13 token to type 9 token */ declare (p, q) ptr, length fixed bin, dn bit (1296) based (q); if p -> cdtoken.options.input then length = 87; else length = 10 + 13 * p -> cdtoken.mdest; dn = "0"b; q -> data_name.size = 112 + p -> cdtoken.name_size; q -> data_name.line = p -> cdtoken.line; q -> data_name.column = p -> data_name.column; q -> data_name.type = 9; q -> data_name.item_length = length; q -> data_name.places_left = length; q -> data_name.places_right = 0; q -> data_name.communication_section = "1"b; q -> data_name.level_01 = "1"b; q -> data_name.non_elementary = "1"b; q -> data_name.alphanum = "1"b; q -> data_name.seg_num = p -> cdtoken.cd_seg; q -> data_name.offset = p -> cdtoken.cd_off; length = p -> cdtoken.name_size; q -> data_name.name_size = length; substr (q -> data_name.name, 1, length) = substr (p -> cdtoken.name, 1, length); p = q; end; /*[4.4-2]*/ /* INCLUDE FILES USED BY THIS PROCEDURE */ %include cobol_in_token; %include cobol_type40; %include cobol_type1; %include cobol_type2; %include cobol_type3; %include cobol_type9; /***..... 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_MOVE_GEN");/**/ declare 1 cdtoken based (dn_ptr), %include cobol_TYPE13; %include cobol_type19; %include cobol_edit_ext; %include cobol_; %include cobol_fixed_common; %include cobol_ext_; %include cobol_addr_tokens; end cobol_move_gen;  cobol_mpy.pl1 05/24/89 1041.5rew 05/24/89 0830.5 52029 /****^ *********************************************************** * * * 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_mpy.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, [4.3-1], BUG563(phx18381), new cobol_addr_tokens.incl.pl1 */ /* Modified on 2/25/76 by Bob Chang to fix plus sign for 1011 and 1100 . */ /* Modified on 2/24/76 by Bob Chang to handle signed/unsigned. */ /* format: style3 */ %; cobol_mpy: proc (operand_ptr, result_ptr, opcode_code); /* This proceudre generates code for the follwoing types of Cobol constructs: 1. MULTIPLY A BY B. 2. DIVIDE A INTO B. This procedure assumes that the tokens pointed at by operand_ptr and result_ptr are data name (type 9) tokens. That is, any conversion of the operands from numeric literal or figurative constant has already been done before this procedure is called. */ /* DECLARATION OF THE PARAMETERS */ dcl operand_ptr ptr; dcl result_ptr ptr; dcl opcode_code fixed bin (35); /* operand_ptr Points to the token for the multiplicand or divisor depending on whether code is to be generated for multiplication or division, respectively. (input) result_ptr Points to the token that serves as both 1. multiplier and product or 2. dividend and qoutient depending on whether code is to be generated for multiplication or division, respectively. (input) opcode_code a code that indicates whether code is to be generated for multiplication or division. (input) opcode_code meaning --------------------------------- 1 | multiplication 2 | division */ /* DECLARATION OF EXTERNAL ENTRIES */ dcl cobol_addr ext entry (ptr, ptr, ptr); dcl cobol_emit ext entry (ptr, ptr, fixed bin); /*}*/ /* DECLARATION OF INTERNAL STATIC VARIABLES */ /* Declaration of internal static variables that contain ADD2 and SUBTRACT2 opcodes */ dcl mp2d_op bit (10) int static init ("0100001101"b /*206(1)*/); dcl dv2d_op bit (10) int static init ("0100001111"b /*207(1)*/); /* DECLARATION OF INTERNAL AUTOMATIC VARIABLES */ /* Declaration of buffers used by the addressability utility */ /* Relocation info buffer */ dcl reloc_buffer (1:10) fixed bin; /* Instruction/description buffer */ dcl addr_inst_buffer (1:10) fixed bin; /* Addressability input buffer */ dcl addr_input_buffer (1:30) fixed bin; dcl dn_ptr ptr; /**************************************************/ /* START OF EXECUTION */ /* cobol_mpy */ /**************************************************/ /* Point pointers at the buffers used to establish addressability */ /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(cmp);/**/ reloc_ptr = addr (reloc_buffer (1)); input_ptr = addr (addr_input_buffer (1)); inst_ptr = addr (addr_inst_buffer (1)); /* Build the input structure to the addressability utility */ input_struc.type = 5; /* eis, 2 input operands, instruction word and 2 descriptors returned */ input_struc.operand_no = 2; input_struc.lock = 0; /* no lock */ input_struc.operand.token_ptr (1) = operand_ptr; input_struc.operand.send_receive (1) = 0; /* sending */ input_struc.operand.size_sw (1) = 0; input_struc.operand.token_ptr (2) = result_ptr; input_struc.operand.send_receive (2) = 1; /* receiving */ input_struc.operand.size_sw (2) = 0; /* Set the proper opcode into the eis instruction */ if opcode_code = 1 /* multiply */ then inst_struc.fill1_op = mp2d_op; else inst_struc.fill1_op = dv2d_op; /* Establish addressability */ call cobol_addr (input_ptr, inst_ptr, reloc_ptr); /* Set the rounding bit in the eis instruction, if necessary */ if result_ptr -> data_name.rounded then inst_struc.zero3 = "01"b; /* truncation off, rounding on */ if result_ptr -> data_name.ascii_packed_dec = "1"b & result_ptr -> data_name.seg_num = 2 then inst_struc.inst.zero1 = "10"b; /* Emit the eis instruction and 2 descriptors */ call cobol_emit (inst_ptr, reloc_ptr, 3); /***..... if Trace_Bit then call cobol_gen_driver_$Tr_End(cmp);/**/ return; /***..... dcl cmp char(9) init("COBOL_MPY");/**/ /***..... 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); /**/ /* 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_type9; %include cobol_addr_tokens; /**************************************************/ /* END OF PROCEDURE */ /* cobol_mpy */ /**************************************************/ end cobol_mpy;  cobol_mpy3.pl1 05/24/89 1041.5rew 05/24/89 0830.4 57438 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /****^ 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_mpy3.pl1 Added Trace statements. END HISTORY COMMENTS */ /* format: style3 */ %; /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* Modified on 11/16/84 by FCH, [5.3...], trace added */ /* Modified on 10/19/84 by FCH, [4.3-1], BUG563(phx18381), new cobol_addr_tokens.incl.pl1 */ /* Modified since Version 2.0 */ /*{*/ cobol_mpy3: proc (operand1_ptr, operand2_ptr, result_ptr, opcode_code); /* This procedure generates code for the following types of Cobol constructs: 1. MULTIPLY A BY B GIVING C. 2. DIVIDE A BY B GIVING C. This procedure makes one important assumption about the input operands: The operands to be multiplied (or divided) are both represented by data name (type 9) tokens. That is, any conversion of the operands from numeric literal or figurative constant has already been done before this procedure is called. */ /* Note that if the "rounded" bit is on in the token pointed at by result_ptr, then the code generated will perform multiplication/division with rounding. */ /* DECLARATION OF THE PARAMETERS */ dcl operand1_ptr ptr; dcl operand2_ptr ptr; dcl result_ptr ptr; dcl opcode_code fixed bin (35); /* operand1_ptr Points to the token for the multiplicand or dividend, depending on whether code is to be generated for multiplication or division, respectively. (input) operand2_ptr Points to the token for the multiplier or divisor, depending on whether code is to be generated for addition or subtraction, respectively. (input) result_ptr Points to the token to receive the product or quotient, depending on whether code it to be generated for multiplication or division, respectively. (input) opcode_code A code that indicates whether code is to be generated for an multiplication or division. (input) opcode_code | meaning ------------------------------------- 1 | multilplication 2 | division */ /* DECLARATION OF EXTERNAL ENTRIES */ dcl cobol_addr ext entry (ptr, ptr, ptr); dcl cobol_emit ext entry (ptr, ptr, fixed bin); /* DECLARATION OF INTERNAL STATIC VARIABLES */ /* Declaration of internal static variables that contain MP3D and DV3D opcodes */ dcl mp3d_op bit (10) int static init ("0100101101"b /*226(1)*/); dcl dv3d_op bit (10) int static init ("0100101111"b /*227(1)*/); /* DECLARATION OF INTERNAL AUTOMATIC VARIABLES */ /* Declaration of buffers used by the addressability utility */ /* Relocation info buffer */ dcl reloc_buffer (1:10) fixed bin; /* instruction/descriptor buffer */ dcl addr_inst_buffer (1:10) fixed bin; /* addressability input buffer */ dcl addr_input_buffer (1:30) fixed bin; dcl dn_ptr ptr; /**************************************************/ /* START OF EXECUTION */ /* cobol_mpy3 */ /**************************************************/ /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(cm3);/**/ /* Point pointers at the buffers used to establish addressability */ reloc_ptr = addr (reloc_buffer (1)); input_ptr = addr (addr_input_buffer (1)); inst_ptr = addr (addr_inst_buffer (1)); /* Build the input structure to the addressability utility */ input_struc.type = 6; /* eis, 3 input operands, instruction word and 3 descriptors returned */ input_struc.operand_no = 3; input_struc.lock = 0; /* no locks */ input_struc.operand.token_ptr (1) = operand1_ptr; input_struc.operand.send_receive (1) = 0; /* sending */ input_struc.operand.size_sw (1) = 0; /* utility worries about size */ input_struc.operand.token_ptr (2) = operand2_ptr; input_struc.operand.send_receive (2) = 0; /* sending */ input_struc.operand.size_sw (2) = 0; input_struc.operand.token_ptr (3) = result_ptr; input_struc.operand.send_receive (3) = 1; /* receiving */ input_struc.operand.size_sw (3) = 0; /* Set the proper opcode into the eis instruction */ if opcode_code = 1 /* mpy */ then inst_struc.fill1_op = mp3d_op; else inst_struc.fill1_op = dv3d_op; /* Establish the addresses */ call cobol_addr (input_ptr, inst_ptr, reloc_ptr); /* Set the rounding bit in the eis instruction if necessary */ if result_ptr -> data_name.rounded then inst_struc.zero3 = "01"b; /* TRUNCATION OFF, ROUNDING ON */ /* Emit the eis instruction and 3 descriptors */ call cobol_emit (inst_ptr, reloc_ptr, 4); /***..... if Trace_Bit then call cobol_gen_driver_$Tr_End(cm3);/**/ return; /***..... dcl cm3 char(10) init("COBOL_MPY3");/**/ /***..... 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); /**/ /* 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_type9; %include cobol_addr_tokens; /**************************************************/ /* END OF PROCEDDURE */ /* cobol_add3 */ /*************************************************/ end cobol_mpy3;  cobol_mst.pl1 05/24/89 1041.5rew 05/24/89 0830.4 324819 /****^ *********************************************************** * * * 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_mst.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 09/07/83 by FCH, [5.2-1], fix errors in runtime symbol table, phx15769(BUG555) */ /* Modified on 10/27/82 by FCH, [5.1-2], get last line num from fix comm, BUG543(phx13643) */ /* Modified on 11/24/81 by FCH, [5.1-1], statement table was a shambles, BUG519(phx11818) */ /* Modified on 05/16/80 by FCH, [4.2-1], decl for tag_addr corrected */ /* modified on 10/20/79 by PRP [4.1-2], communicate data types to symbol table */ /* Modified on 10/20/79 by PRP [4.1-1], fix statement map */ /* Modified on 06/28/78 by RAL [3.0-1] Allow for multiple lines for each statement */ /* Modified on 03/01/78 by Richard A. Barnes to thread runtime_symbol.next in negative direction only and to use a hash table to eliminate duplicate runtime tokens */ /* Modified since Version 3.0 */ /* format: style3 */ cobol_mst: proc; /* Builds Runtime Symbol Table for interfacing with debug. Called when "-table" option specified. Assumptions: 1) sym_base_ptr points to start of Symbol_Block_Header. 2) sym_wd_off is offset of 1st word after PL1_Symbol_Block. */ /* Initialization */ sbh_ptr = sym_base_ptr; /* get ptr to Symbol_Block_Header */ sbh_off = fixed (rel (sbh_ptr), 18); psb_off = fixed (sbh_ptr -> symbol_block_header.area_relp, 18); psb_ptr = addrel (sbh_ptr, psb_off); /* get ptr to PL1_Symbol_Block */ psb_ptr -> pl1_symbol_block.flags.table = "1"b; token_count = 0; label_count = 0; starting_wd_off = sym_wd_off; /* save offset of 1st word we will generate */ sect_off = 0; translate_it = "0"b; hash_table (*) = 0; /* Build Root Block */ root_off = sym_wd_off; psb_ptr -> pl1_symbol_block.root = bit (root_off, 18); root_blk_ptr = gen_runtime_block (0); /* Generate token node and symbol node for prog name */ name_string = fixed_common.prog_name; name_length = index (name_string, " ") - 1; call gen_runtime_nodes; root_blk_ptr -> runtime_block.start = bit (fixed (symb_off - root_off, 18), 18); ext_ent_ptr = s_ptr; /* save ptr to symbol of program name */ s_ptr -> runtime_symbol.type = "011010"b; /* external entry constant */ s_ptr -> runtime_symbol.father = bit (fixed (262144 + root_off - symb_off, 18), 18); s_ptr -> runtime_symbol.address.location = bit (fixed (cobol_$constant_offset + 1, 18), 18); s_ptr -> runtime_symbol.address.class = "1100"b; /* text reference */ sym_wd_off = sym_wd_off + symbol_size; if name_length > 1 then do; /* fill in chain of root block to point to procname */ token_size = 16; j = 4; do while (name_length < token_size); j = j - 1; token_size = divide (token_size, 2, 18, 0); end; root_blk_ptr -> runtime_block.chain (j) = root_blk_ptr -> runtime_block.start; end; /* Build Main Block */ main_off = sym_wd_off; text_ptr = cobol_$text_base_ptr; block_relp = bit (main_off, 18); main_blk_ptr = gen_runtime_block (root_off); /* Build "COBOL" token and symbol - this is data_ptr on which all data is based. */ name_string = "COBOL"; name_length = 5; call gen_runtime_nodes; data_ptr_off = symb_off; s_ptr -> runtime_symbol.location = "000000000000001000"b; /* 8 bytes */ s_ptr -> runtime_symbol.type = "001101"b; /* pointer */ s_ptr -> runtime_symbol.class = "0100"b; /* internal static */ s_ptr -> runtime_symbol.father = bit (fixed (262144 + main_off - data_ptr_off, 18), 18); sym_wd_off = sym_wd_off + symbol_size; /* Process Name-Table */ translate_it = "1"b; len_ptr = pointer (cobol_ntfp, 8); do while (len > 0); p = len_ptr; go to token_type (p -> name_table_entry.type); token_type (7): /* PROCEDURE DEFINITION (Label) */ token_type (18): proc_def_ptr = p; if label_count < fixed_common.proc_counter then do; /* do not process compiler generated labels */ name_string = proc_def_ptr -> proc_def.name; name_length = proc_def_ptr -> proc_def.name_size; call gen_runtime_nodes; s_ptr -> runtime_symbol.simple = "1"b; symbol_size = 4; /* no "size" field for labels */ tag_loc = cobol_$tag_table_ptr -> tag_addr (proc_def.proc_num); do while (tag_loc < 0); tag_loc = cobol_$tag_table_ptr -> tag_addr (-tag_loc); end; if tag_loc = 0 then do; /* ERROR - undefined label */ call ioa_ ("Procedure Definition ^a is undefined", proc_def.name); call ioa_ ("and will not appear in the Runtime Symbol Table"); token_count = token_count - 1; end; else do; s_ptr -> runtime_symbol.location = bit (fixed (tag_loc + cobol_$constant_offset, 18), 18); if proc_def_ptr -> proc_def.section_name then do; s_ptr -> runtime_symbol.level = "000001"b; s_ptr -> runtime_symbol.father = bit (fixed (262144 + main_off - symb_off, 18), 18); sect_off = symb_off; sect_ptr = s_ptr; prev_p = null (); end; else if sect_off = 0 then s_ptr -> runtime_symbol.father = bit (fixed (262144 + main_off - symb_off, 18), 18); else do; s_ptr -> runtime_symbol.level = "000010"b; s_ptr -> runtime_symbol.father = bit (fixed (262144 + sect_off - symb_off, 18), 18); if prev_p = null () then sect_ptr -> runtime_symbol.son = bit (fixed (symb_off - sect_off, 18), 18); else prev_p -> runtime_symbol.brother = bit (fixed (symb_off - prev_poff, 18), 18); prev_p = s_ptr; prev_poff = symb_off; end; s_ptr -> runtime_symbol.type = "011000"b; /* label constant */ s_ptr -> runtime_symbol.class = "1100"b; /* text-reference */ sym_wd_off = sym_wd_off + symbol_size; end; label_count = label_count + 1; end; go to token_type (0); token_type (9): /* data-name */ dn_ptr = p; /* establish data-name ptr */ name_string = dn_ptr -> data_name.name; if name_string = "SYSTEM_STATUS" | name_string = "TALLY" then go to token_type (0); name_length = dn_ptr -> data_name.name_size; call gen_runtime_nodes; symbol_size = symbol_size + 1; /* add 1 for offset field */ if dn_ptr -> data_name.display | dn_ptr -> data_name.non_elementary then do; /* non_elementary = structure - make char string so full structure can be printed */ /* [4.1-2] */ if data_name.numeric | data_name.numeric_edited then do; /*[5.2-1]*/ if data_name.numeric /*[5.2-1]*/ then do; if data_name.sign_type = "000"b then s_ptr -> runtime_symbol.type = "100011"b; else if data_name.sign_type = "100"b then s_ptr -> runtime_symbol.type = "001001"b; else if data_name.sign_type = "011"b then s_ptr -> runtime_symbol.type = "100100"b; else if data_name.sign_type = "010"b then s_ptr -> runtime_symbol.type = "011101"b; else if data_name.sign_type = "001"b then s_ptr -> runtime_symbol.type = "011110"b; else /* do nothing */ ; /*[5.2-1]*/ end; /*[5.2-1]*/ else s_ptr -> runtime_symbol.type = "010101"b; s_ptr -> runtime_symbol.size = data_name.places_left + data_name.places_right; temp_scale = data_name.places_right; s_ptr -> runtime_symbol.scale = unspec (temp_scale); end; else do; s_ptr -> runtime_symbol.type = "010101"b; s_ptr -> runtime_symbol.size = dn_ptr -> data_name.item_length; end; /*[5.2-1]*/ s_ptr -> runtime_symbol.aligned = "0"b; /*[5.2-1]*/ s_ptr -> runtime_symbol.packed = "1"b; s_ptr -> runtime_symbol.offset = dn_ptr -> data_name.offset; end; else if dn_ptr -> data_name.usage_index then do; s_ptr -> runtime_symbol.aligned = "0"b; s_ptr -> runtime_symbol.packed = "1"b; s_ptr -> runtime_symbol.type = "000001"b; /* fixed bin */ s_ptr -> runtime_symbol.size = 17; /* precision = 17 */ s_ptr -> runtime_symbol.offset = dn_ptr -> data_name.offset + 4; end; /* /* next two blocks are redundant in that both support comp-5 and comp-8. /* With the current arrangement, comp-8 is described as packed decimal /* and comp-5 as bit string. For both bitstring, eliminate the following block; /* for both packed decimal, change following test to ascii_packed_dec /* instead of ascii_packed_dec_h and elminate second block; similarly /* change array_units test. */ /* else if dn_ptr->data_name.ascii_packed_dec_h /* COMP-8 */ /* then do; /* s_ptr->runtime_symbol.aligned = "0"b; /* s_ptr->runtime_symbol.packed = "1"b; /* s_ptr->runtime_symbol.units = "11"b; /* half */ /* s_ptr->runtime_symbol.type = "011111"b; /* packed decimal */ /* packed_dec_size = dn_ptr->data_name.places_left /* + dn_ptr->data_name.places_right; /* if dn_ptr->data_name.item_signed /* then packed_dec_size = packed_dec_size + 1; /* temp_off = 9*data_name.offset+1; /* if data_name.ascii_packed_dec_h then do; /* COMP-8 */ /* if data_name.bit_offset ^= ""b then do; /* s_ptr->runtime_symbol.offset = temp_off+4; /* s_ptr->runtime_symbol.size = packed_dec_size; /* end; /* else do; /* s_ptr->runtime_symbol.offset = temp_off; /* s_ptr->runtime_symbol.size = packed_dec_size; /* end; /* end; /* else do; /* COMP-5 */ /* if temp_mod = 0 then do; /* s_ptr->runtime_symbol.offset = temp_off; /* s_ptr->runtime_symbol.size = packed_dec_size; /* end; /* else do; /* odd length */ /* s_ptr->runtime_symbol.offset = temp_off+4; /* s_ptr->runtime_symbol.size = packed_dec_size; /* end; /* end; /* end; /* else if dn_ptr->data_name.ascii_packed_dec /* COMP-5 */ /* then do; /* s_ptr->runtime_symbol.aligned = "0"b; /* s_ptr->runtime_symbol.packed = "1"b; /* s_ptr->runtime_symbol.units = "01"b; /* bits */ /* s_ptr->runtime_symbol.type = "010011"b; /* bit string */ /* packed_dec_size = dn_ptr->data_name.places_left /* + dn_ptr->data_name.places_right; /* if dn_ptr->data_name.item_signed /* then packed_dec_size = packed_dec_size + 1; /* temp_off = 9*data_name.offset+1; /* temp_size = 9*divide(packed_dec_size,2,35,0); /* temp_mod = mod(packed_dec_size,2); /* if data_name.ascii_packed_dec_h then do; /* COMP-8 */ /* temp_size = temp_size+temp_mod*4; /* if data_name.bit_offset ^= ""b then do; /* s_ptr->runtime_symbol.offset = temp_off+4; /* s_ptr->runtime_symbol.size = temp_size; /* end; /* else do; /* s_ptr->runtime_symbol.offset = temp_off; /* if temp_mod = 0 then s_ptr->runtime_symbol.size = temp_size-1; /* else s_ptr->runtime_symbol.size = temp_size; /* end; /* end; /* else do; /* COMP-5 */ /* if temp_mod = 0 then do; /* s_ptr->runtime_symbol.offset = temp_off; /* s_ptr->runtime_symbol.size = temp_size-1; /* end; /* else do; /* odd length */ /* s_ptr->runtime_symbol.offset = temp_off+4; /* s_ptr->runtime_symbol.size = temp_size+4; /* end; /* end; /* end; /**/ else if dn_ptr -> data_name.ascii_packed_dec then do; /* packed decimal */ temp_scale = data_name.places_right; s_ptr -> runtime_symbol.scale = unspec (temp_scale); s_ptr -> runtime_symbol.aligned = "0"b; s_ptr -> runtime_symbol.packed = "1"b; s_ptr -> runtime_symbol.use_digit = "1"b; s_ptr -> runtime_symbol.units = "11"b; if data_name.item_signed then do; if data_name.ascii_packed_dec_h /*[5.2-1]*/ then if dn_ptr -> data_name.sync /*[5.2-1]*/ then s_ptr -> runtime_symbol.type = "101011"b; /* 43 */ /*[5.2-1]*/ else s_ptr -> runtime_symbol.type = "101001"b; /* 41 */ else s_ptr -> runtime_symbol.type = "100111"b; end; else if data_name.ascii_packed_dec_h /*[5.2-1]*/ then if dn_ptr -> data_name.sync /*[5.2-1]*/ then s_ptr -> runtime_symbol.type = "101000"b; /* 40 */ /*[5.21]*/ else s_ptr -> runtime_symbol.type = "100110"b; /* 38 */ else s_ptr -> runtime_symbol.type = "101000"b; /* New data type 40*/ s_ptr -> runtime_symbol.size = data_name.places_left + data_name.places_right; s_ptr -> runtime_symbol.offset = 2 * data_name.offset; /* in half-bytes */ if ^data_name.ascii_packed_dec_h then do; /* COMP-5 */ if mod (s_ptr -> runtime_symbol.size, 2) = 1 then if ^data_name.item_signed then s_ptr -> runtime_symbol.offset = s_ptr -> runtime_symbol.offset + 1; else ; else if data_name.item_signed then s_ptr -> runtime_symbol.offset = s_ptr -> runtime_symbol.offset + 1; end; else if data_name.bit_offset ^= ""b then s_ptr -> runtime_symbol.offset = s_ptr -> runtime_symbol.offset + 1; end; else if dn_ptr -> data_name.bin_18 then do; s_ptr -> runtime_symbol.aligned = "0"b; /*[5.2-1]*/ if dn_ptr -> data_name.sync /*[5.2-1]*/ then s_ptr -> runtime_symbol.packed = "0"b; /*[5.2-1]*/ else s_ptr -> runtime_symbol.packed = "1"b; s_ptr -> runtime_symbol.type = "000001"b; /* fixed bin */ s_ptr -> runtime_symbol.size = 17; /* precision = 17 */ s_ptr -> runtime_symbol.offset = dn_ptr -> data_name.offset; end; else if dn_ptr -> data_name.bin_36 then do; s_ptr -> runtime_symbol.aligned = "1"b; s_ptr -> runtime_symbol.packed = "0"b; s_ptr -> runtime_symbol.type = "000001"b; /* fixed bin */ s_ptr -> runtime_symbol.size = 35; /* precision = 35 */ s_ptr -> runtime_symbol.offset = dn_ptr -> data_name.offset; end; if dn_ptr -> data_name.working_storage | dn_ptr -> data_name.file_section | dn_ptr -> data_name.communication_section /* 10/01/77 */ then do; s_ptr -> runtime_symbol.class = "0011"b; /* based */ s_ptr -> runtime_symbol.location = bit (fixed (262144 + data_ptr_off - symb_off, 18), 18); end; else if dn_ptr -> data_name.constant_section then do; s_ptr -> runtime_symbol.class = "1100"b; /* text reference */ s_ptr -> runtime_symbol.location = bit (fixed (cobol_$constant_offset - divide (dn_ptr -> data_name.offset + 3, 4, 18, 0), 18), 18); s_ptr -> runtime_symbol.offset = mod (dn_ptr -> data_name.offset, 4); end; else if dn_ptr -> data_name.linkage_section then do; /* parameter */ s_ptr -> runtime_symbol.class = "1001"b; /* parameter */ s_ptr -> runtime_symbol.location = bit (fixed (dn_ptr -> data_name.linkage, 18), 18); end; if dn_ptr -> data_name.level_77 | dn_ptr -> data_name.level = 66 | (dn_ptr -> data_name.level_01 & dn_ptr -> data_name.elementary) then s_ptr -> runtime_symbol.level = (6)"0"b; else s_ptr -> runtime_symbol.level = bit (fixed (dn_ptr -> data_name.level, 6), 6); if fixed (s_ptr -> runtime_symbol.level, 7) <= 1 then s_ptr -> runtime_symbol.father = bit (fixed (262144 + main_off - symb_off, 18), 18); if dn_ptr -> data_name.occurs_ptr = 0 then s_ptr -> runtime_symbol.ndims = "0"b; else do; /* process array info */ occurs_ptr = addrel (dn_ptr, divide (dn_ptr -> data_name.occurs_ptr, 4, 15, 0)); s_ptr -> runtime_symbol.ndims = bit (fixed (occurs_ptr -> occurs.dimensions, 6), 6); s_ptr -> runtime_symbol.virtual_org = 0; do j = 1 to occurs_ptr -> occurs.dimensions; s_ptr -> runtime_symbol.bounds.lower (j) = max (occurs_ptr -> occurs.level.min (j), 1); s_ptr -> runtime_symbol.bounds.upper (j) = occurs_ptr -> occurs.level.max (j); if dn_ptr -> data_name.ascii_packed_dec then do; /* packed decimal */ s_ptr -> runtime_symbol.bounds.multiplier (j) = occurs_ptr -> occurs.level.struc_length (j); s_ptr -> runtime_symbol.array_units = s_ptr -> runtime_symbol.units; end; else s_ptr -> runtime_symbol.bounds.multiplier (j) = divide (occurs_ptr -> occurs.level.struc_length (j) + 1, 2, 35, 0); s_ptr -> runtime_symbol.virtual_org = s_ptr -> runtime_symbol.virtual_org + s_ptr -> runtime_symbol.bounds.multiplier (j); end; symbol_size = symbol_size + 1 + 3 * (occurs_ptr -> occurs.dimensions); end; if dn_ptr -> data_name.non_elementary | (dn_ptr -> data_name.level > 1 & dn_ptr -> data_name.level <= 49) then do; /* structure or structure-member */ /* For each structure or structure-member, we will set the father,son and brother fields of the runtime_symbol node. */ if dn_ptr -> data_name.level_01 then do; /* structure */ prev_s = s_ptr; prev_level = 1; end; else do; /* structure-member */ /* Backup chain to prev brother if level < prev_level */ do while (fixed (s_ptr -> runtime_symbol.level, 17) < prev_level); prev_soff = prev_soff + fixed (prev_s -> runtime_symbol.father, 18) - 262144; prev_s = addrel (prev_s, prev_s -> runtime_symbol.father); prev_level = fixed (prev_s -> runtime_symbol.level, 18); end; if fixed (s_ptr -> runtime_symbol.level, 17) > prev_level then do; /* processing a son */ prev_s -> runtime_symbol.son = bit (fixed (symb_off - prev_soff, 18), 18); s_ptr -> runtime_symbol.father = bit (fixed (262144 + prev_soff - symb_off, 18), 18); prev_level = fixed (s_ptr -> runtime_symbol.level, 18); end; else do; /* level = prev_level, processing a brother */ prev_s -> runtime_symbol.brother = bit (fixed (symb_off - prev_soff, 18), 18); s_ptr -> runtime_symbol.father = bit ( fixed (262144 + fixed (prev_s -> runtime_symbol.father, 18) + prev_soff - symb_off, 18), 18); end; prev_s = s_ptr; end; prev_soff = symb_off; end; sym_wd_off = sym_wd_off + symbol_size; go to token_type (0); token_type (10): /* Index-Name */ ind_ptr = p; name_string = ind_ptr -> index_name.name; name_length = ind_ptr -> index_name.name_size; call gen_runtime_nodes; symbol_size = symbol_size + 1; s_ptr -> runtime_symbol.offset = ind_ptr -> index_name.offset + 4; /* use ocur. no. only */ s_ptr -> runtime_symbol.class = "0011"b; /* based */ s_ptr -> runtime_symbol.type = "000001"b; /* fixed bin */ s_ptr -> runtime_symbol.size = 35; /* precision = 35 */ s_ptr -> runtime_symbol.location = bit (fixed (262144 + data_ptr_off - symb_off, 18), 18); s_ptr -> runtime_symbol.father = bit (fixed (262144 + main_off - symb_off, 18), 18); sym_wd_off = sym_wd_off + symbol_size; go to token_type (0); token_type (0): token_type (1): token_type (2): token_type (3): token_type (4): token_type (5): token_type (6): token_type (8): token_type (11): token_type (12): token_type (13): token_type (14): token_type (15): token_type (16): token_type (17): token_type (19): token_type (20): token_type (40): len_ptr = addrel (p, divide (len + 11, 8, 35, 0) * 2); end; /* Sort tokens alphabeticly by size and form token and symbol chains for blocks */ call sort_tokens; first = 1; token_size = 2; finished = "0"b; prev_s = null; do i = 0 to 5 while (^finished); prev_t = null (); if i < 5 then first_symbol = "1"b; do j = first to token_count while (fixed (token_list (j) -> runtime_token.size, 9) < token_size); t_ptr = token_list (j); t_off = fixed (rel (t_ptr), 18) - sbh_off; if prev_t = null () then do; /* first token of this size...set block.token to point to it */ next_off = t_off - main_off; if next_off > 0 then main_blk_ptr -> runtime_block.token (i) = bit (next_off, 18); else main_blk_ptr -> runtime_block.token (i) = bit (fixed (262144 + next_off, 18), 18); root_blk_ptr -> runtime_block.token (i) = bit (fixed (t_off - root_off, 18), 18); end; else do; /* set token.next of prev token to point to this token */ next_off = t_off - prev_toff; if next_off > 0 then prev_t -> runtime_token.next = bit (next_off, 18); else prev_t -> runtime_token.next = bit (fixed (262144 + next_off, 18), 18); end; prev_t = t_ptr; prev_toff = t_off; s_ptr = t_ptr; next_offset = fixed (t_ptr -> runtime_token.dcl, 18); /* the following loop examines all symbols with the same name */ do while (next_offset ^= 0); s_ptr = addrel (s_ptr, next_offset); if fixed (s_ptr -> runtime_symbol.level, 7) <= 1 & s_ptr ^= ext_ent_ptr then do; /* link all level 0 & 1 symbols */ symb_off = fixed (rel (s_ptr), 18) - sbh_off; if first_symbol then do; /* this is the first symbol of this size, so have runtime_block.chain(i) point to this symbol. Also, if this is the very first symbol processed, have runtime_block.start point to the symbol. */ first_symbol = "0"b; next_off = symb_off - main_off; if main_blk_ptr -> runtime_block.start = "0"b then if next_off > 0 then main_blk_ptr -> runtime_block.start = bit (next_off, 18); else main_blk_ptr -> runtime_block.start = bit (fixed (262144 + next_off, 18), 18); if i > 0 & i < 5 then do; /* set main_block.chain to point to this symbol */ if next_off > 0 then main_blk_ptr -> runtime_block.chain (i) = bit (next_off, 18); else main_blk_ptr -> runtime_block.chain (i) = bit (fixed (262144 + next_off, 18), 18); end; end; if prev_s ^= null then do; /* set prev symbol.brother to point to this symbol */ /* chain this level 1 symbol to other level 1 symbols in this block */ next_off = symb_off - prev_soff; if next_off > 0 then prev_s -> runtime_symbol.brother = bit (next_off, 18); else prev_s -> runtime_symbol.brother = bit (fixed (262144 + next_off, 18), 18); end; prev_s = s_ptr; prev_soff = symb_off; end; /* get the next symbol, or exzit the loop */ if s_ptr -> runtime_symbol.next then next_offset = fixed (s_ptr -> runtime_symbol.next, 14) - 16384; else next_offset = 0; end; end; if prev_t ^= null then prev_t -> runtime_token.next = (18)"0"b;/* finish the list */ token_size = 2 * token_size; finished = j > token_count; first = j; end; /* Generate relocation bits for runtime symbol table */ call cobol_reloc (null (), 2 * (sym_wd_off - starting_wd_off), 4); /* Build Statement Map */ psb_ptr -> pl1_symbol_block.flags.map = "1"b; psb_ptr -> pl1_symbol_block.map.first = bit (fixed (sym_wd_off, 18), 18); root_blk_ptr -> runtime_block.map.first = bit (fixed (sym_wd_off - root_off, 18), 18); main_blk_ptr -> runtime_block.map.first = bit (fixed (sym_wd_off - main_off, 18), 18); prev_line_num = 0; prev_file_num = 0; /*[5.1-1]*/ statement_no = 1; /*[5.1-1]*/ do i = 1 by 1 to map_data_table.no_source_stmts; /*[5.1-1]*/ if map_data_table.label (i) /*[5.1-1]*/ then do; statement_no = 1; /*[5.2-1]*/ eln_index = map_data_table.line_no (i); /*[5.2-1]*/ if eln_index > 0 then line_num = eln_tab.lno (eln_index); /*[5.1-1]*/ do while (map_data_table.label (i)); /*[5.1-1]*/ i = i + 1; /*[5.1-1]*/ end; /*[5.1-1]*/ end; /*[5.2-1]*/ else do; eln_index = map_data_table.line_no (i); /*[5.2-1]*/ if eln_index > 0 then line_num = eln_tab.lno (eln_index); /*[5.2-1]*/ end; /*[5.1-1]*/ if i <= map_data_table.no_source_stmts /*[5.2-1]*/ then do; /*eln_index = map_data_table.line_no(i);*/ /*[5.1-1]*/ if eln_index > 0 /*[5.1-1]*/ then do; /*[5.2-1]*/ /*line_num = eln_tab.lno(eln_index);*/ /*[5.1-1]*/ file_num = eln_tab.fno (eln_index); /*[5.1-1]*/ p = addrel (sym_base_ptr, sym_wd_off); /*[5.1-1]*/ p -> statement_map.location = /*[5.1-1]*/ bit (fixed (map_data_table.text_addr (i) + cobol_$constant_offset, 18), 18); /*[5.1-1]*/ p -> statement_map.file = bit (file_num, 8); /*[5.1-1]*/ p -> statement_map.line = bit (line_num, 14); /*[5.1-1]*/ p -> statement_map.statement = bit (statement_no, 5); /*[5.1-1]*/ p -> statement_map.start = bit (fixed (statement_info.start (eln_index) + map_data_table.col (i) - 1, 18), 18); /*[5.1-1]*/ if i = map_data_table.no_source_stmts /*[5.1-2]*/ then do; span = fixed_common.cobol_cln - eln_index; /*[5.1-1]*/ next_eln_index = 0; /*[5.1-1]*/ end; /*[5.1-1]*/ else do; next_eln_index = map_data_table.line_no (i + 1); /*[5.1-1]*/ do j = eln_index by 1 to next_eln_index - 1 /*[5.1-1]*/ while (eln_tab.fno (j) = file_num); /*[5.1-1]*/ end; /*[5.1-1]*/ span = j - eln_index; /*[5.1-1]*/ end; /*[5.1-1]*/ if span = 0 /*[5.1-1]*/ then do; statement_no = statement_no + 1; /*[5.1-1]*/ new_length = map_data_table.col (i + 1) - map_data_table.col (i); /*[5.1-1]*/ end; /*[5.1-1]*/ else do; statement_no = 1; /*[5.1-1]*/ new_length = statement_info.length (eln_index) - map_data_table.col (i) + 1; /*[5.1-1]*/ if span > 1 /*[5.1-1]*/ then do j = eln_index + 1 by 1 to eln_index + span - 1; /*[5.1-1]*/ new_length = new_length + statement_info.length (j) + 1; /*[5.1-1]*/ end; /*[5.1-1]*/ if next_eln_index > 0 /*[5.1-1]*/ then if eln_index + span = next_eln_index /*[5.1-1]*/ then if file_num = eln_tab.fno (next_eln_index) /*[5.1-1]*/ then new_length = new_length + map_data_table.col (i + 1); /*[5.1-1]*/ end; /*[5.1-1]*/ p -> statement_map.length = bit (fixed (new_length, 9), 9); /*[5.1-1]*/ call cobol_reloc (addr (stmt_map_reloc_bits), 4, 4); /*[5.1-1]*/ sym_wd_off = sym_wd_off + 2; /*[5.1-1]*/ end; /*[5.1-1]*/ end; /*[5.1-1]*/ end; main_blk_ptr -> runtime_block.map.last = bit (fixed (sym_wd_off - main_off, 18), 18); /* Build dummy last statement-map entry */ p = addrel (sym_base_ptr, sym_wd_off); p -> statement_map.location = bit (fixed (cobol_$non_source_offset + cobol_$constant_offset, 18), 18); string (p -> statement_map.source_id) = (27)"1"b; string (p -> statement_map.source_info) = (26)"0"b; call cobol_reloc (addr (stmt_map_reloc_bits), 4, 4); sym_wd_off = sym_wd_off + 2; psb_ptr -> pl1_symbol_block.map.last = bit (fixed (sym_wd_off, 18), 18); root_blk_ptr -> runtime_block.map.last = bit (fixed (sym_wd_off - root_off, 18), 18); /* Finish Up */ sbh_ptr -> symbol_block_header.default_truncate = bit (fixed (sym_wd_off, 18), 18); return; /* */ gen_runtime_block: proc (father_off) returns (ptr); dcl father_off fixed bin (18); dcl p ptr; p = addrel (sym_base_ptr, sym_wd_off); /* get ptr for runtime_block area */ substr (p -> bits, 1, 360) = "0"b; /* clear runtime_block area */ p -> runtime_block.flag = "1"b; p -> runtime_block.standard = "1"b; p -> runtime_block.type = "000011"b; p -> runtime_block.father = bit (fixed (262144 + father_off - sym_wd_off, 18), 18); p -> runtime_block.header = bit (fixed (262144 - sym_wd_off, 18), 18); if father_off ^= 0 then do; /* Main Block */ p -> runtime_block.name = bit (fixed (262144 + name_off - sym_wd_off, 18), 18); root_blk_ptr -> runtime_block.son = bit (fixed (sym_wd_off - root_off, 18), 18); end; sym_wd_off = sym_wd_off + 10; return (p); end gen_runtime_block; gen_runtime_nodes: proc; dcl found bit (1) aligned; dcl name char (32) aligned based (addr (name_array)); dcl name_array (8) bit (36) aligned; dcl tok_offset fixed bin; dcl mask (3) bit (36) aligned static init ("777000000000"b3, "777777000000"b3, "777777777000"b3); dcl hash_index fixed bin; dcl mod_2_sum bit (36) aligned; dcl (j, k) fixed bin; /* find or generate runtime token node */ /* copy the name for hashing, translating if necessary */ if translate_it then substr (name, 1, name_length) = translate (substr (name_string, 1, name_length), "_", "-"); else substr (name, 1, name_length) = substr (name_string, 1, name_length); /* develop the hash_index */ if name_length = 0 then hash_index = 0; else if name_length = 1 then hash_index = binary (unspec (substr (name, 1, 1)) & "177"b3, 9); else do; mod_2_sum = "0"b; j = divide (name_length, 4, 17, 0); k = name_length - 4 * j; if k ^= 0 then do; j = j + 1; name_array (j) = name_array (j) & mask (k); end; do i = 1 to j; mod_2_sum = bool (mod_2_sum, name_array (i), "0110"b); /* XOR */ end; hash_index = mod (binary (mod_2_sum, 35), dim (hash_table, 1)); end; /* search for the runtime_token */ tok_offset = hash_table (hash_index); found = "0"b; do while (^found & tok_offset > 0); t_ptr = addrel (sym_base_ptr, tok_offset); if fixed (t_ptr -> runtime_token.size, 9) = name_length & t_ptr -> runtime_token.string = substr (name, 1, name_length) then found = "1"b; else tok_offset = fixed (t_ptr -> runtime_token.next, 18); end; if found then name_off = tok_offset + 1; else do; /* generate the node */ tok_offset = sym_wd_off; t_ptr = addrel (sym_base_ptr, tok_offset); token_count = token_count + 1; token_list (token_count) = t_ptr; name_off = tok_offset + 1; token_size = 2 + divide (name_length, 4, 18, 0); substr (t_ptr -> bits, 1, 36 * token_size) = "0"b; /* clear token */ t_ptr -> runtime_token.size = bin (name_length, 9); t_ptr -> runtime_token.string = substr (name, 1, name_length); sym_wd_off = sym_wd_off + token_size; t_ptr -> runtime_token.next = bit (hash_table (hash_index), 18); hash_table (hash_index) = tok_offset; end; /* start generating runtime symbol node...node will be completed by caller */ s_ptr = addrel (sym_base_ptr, sym_wd_off); symb_off = sym_wd_off; substr (s_ptr -> bits, 1, 180) = simple_symbol; s_ptr -> runtime_symbol.simple = ^translate_it; s_ptr -> runtime_symbol.name = bit (fixed (262144 + name_off - symb_off, 18), 18); /* if this token already has a symbol, chain the new symbol to the old one */ if t_ptr -> runtime_token.dcl then s_ptr -> runtime_symbol.next = bit (fixed (tok_offset + fixed (t_ptr -> runtime_token.dcl, 18) - symb_off + 16384, 14), 14); t_ptr -> runtime_token.dcl = bit (fixed (symb_off - tok_offset, 18), 18); symbol_size = 5; end gen_runtime_nodes; sort_tokens: proc; /* This routine sorts the array of ptrs to runtime_tokens. It does a Shell sort alphabetizing by size on the basis of the string in the token. */ dcl (d, i, j, k) fixed bin; dcl (p, p1, p2) ptr; d = token_count; down: d = 2 * divide (d, 4, 15, 0) + 1; do i = 1 to token_count - d; k = i + d; p2 = token_list (k); up: j = k - d; p1 = token_list (j); if p1 -> runtime_token.size > p2 -> runtime_token.size then go to interchange; if p1 -> runtime_token.size < p2 -> runtime_token.size then go to ok; if p1 -> runtime_token.string <= p2 -> runtime_token.string then go to ok; interchange: p = token_list (j); token_list (j) = token_list (k); token_list (k) = p; if j > d then do; k = j; go to up; end; ok: end; if d > 1 then go to down; end sort_tokens; /* temp dcls */ dcl span fixed bin; dcl temp_scale fixed bin (7) unal; dcl prev_stmt_length fixed bin; dcl (k, next_eln_index, new_length) fixed bin; dcl (temp_off, temp_size, temp_mod) fixed bin; dcl p ptr; dcl sbh_ptr ptr defined (sym_ptr); dcl psb_ptr ptr; dcl root_blk_ptr ptr; dcl main_blk_ptr ptr; dcl s_ptr ptr; dcl t_ptr ptr; dcl sect_ptr ptr; dcl prev_p ptr; dcl prev_s ptr; dcl prev_t ptr; dcl dn_ptr ptr; dcl len_ptr ptr; dcl ext_ent_ptr ptr; dcl token_list (3000) ptr; dcl hash_table (0:210) fixed bin (18); dcl next_offset fixed bin (18); dcl starting_wd_off fixed bin; dcl token_count fixed bin; dcl (i, j) fixed bin; dcl name_length fixed bin (9); dcl token_size fixed bin (18); dcl symbol_size fixed bin; dcl name_off fixed bin (18); dcl segname_off fixed bin (18); dcl sbh_off fixed bin (18); dcl psb_off fixed bin (18); dcl root_off fixed bin (18); dcl main_off fixed bin (18); dcl data_ptr_off fixed bin (18); dcl p_off fixed bin (18); dcl symb_off fixed bin (18); dcl next_off fixed bin (18); dcl sect_off fixed bin (18); dcl prev_poff fixed bin (18); dcl t_off fixed bin; dcl prev_soff fixed bin (18); dcl prev_toff fixed bin; dcl first fixed bin; dcl prev_level fixed bin; dcl prev_line_num fixed bin (14); dcl line_num fixed bin (14); dcl file_num fixed bin (8); dcl prev_file_num fixed bin (8); dcl statement_no fixed bin (5); dcl label_count fixed bin; dcl tag_loc fixed bin; dcl packed_dec_size fixed bin; dcl first_symbol bit (1) aligned; dcl translate_it bit (1); dcl finished bit (1); dcl name_string char (32); dcl len fixed bin based (len_ptr); dcl ident_sw bit (1); dcl prev_ident_s ptr; dcl charn char (n) based; dcl bits bit (3600) based; dcl 1 name_table_entry based, 2 size fixed bin (15), 2 line fixed bin (15), 2 column fixed bin (15), 2 type fixed bin (15); dcl 1 map_data_table aligned based (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, 3 col fixed bin unaligned, 3 label bit unaligned; /*[4.2-1]*/ declare 1 DEF aligned based (cobol_$tag_table_ptr), /*[4.2-1]*/ 2 tag_max fixed bin, /*[4.2-1]*/ 2 TAG (32767), /*[4.2-1]*/ 3 tag_addr fixed bin (17) unal, /*[4.2-1]*/ 3 tag_no fixed bin (17) unal; dcl stmt_map_reloc_bits (4) bit (5) static aligned init ("10000"b, ""b, ""b, ""b); dcl simple_symbol bit (36) static aligned init ("101010000000000000000000101000000000"b); dcl cobol_reloc entry (ptr, fixed bin, fixed bin); dcl ioa_ entry options (variable); dcl addr builtin; dcl addrel builtin; dcl bit builtin; dcl binary builtin; dcl bool builtin; dcl dim builtin; dcl divide builtin; dcl fixed builtin; dcl index builtin; dcl max builtin; dcl mod builtin; dcl null builtin; dcl pointer builtin; dcl rel builtin; dcl string builtin; dcl substr builtin; dcl translate builtin; dcl unspec builtin; %include runtime_symbol; %include cobol_entry_seq; %include statement_map; %include cobol_eln_table; %include cobol_; %include cobol_fixed_common; %include cobol_sbh; %include pl1_symbol_block; %include cobol_ext_; %include cobol_type7; %include cobol_type9; %include cobol_type10; %include cobol_occurs_ext; end cobol_mst;  cobol_multiply2_binary.pl1 05/24/89 1041.5rew 05/24/89 0834.8 78084 /****^ *********************************************************** * * * 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_multiply2_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, [4.3-1], BUG563(phx18381), new cobol_addr_tokens.incl.pl1 */ /* 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_multiply2_binary: proc (lop_token_ptr, rop_token_ptr, result_token_ptr, operation_code); /* This procedure generates code to multiply or divide two fixed binary data items in the hardware registers (A and Q). */ /* DECLARATIONS OF THE PARAMETERS */ dcl lop_token_ptr ptr; dcl rop_token_ptr ptr; dcl result_token_ptr ptr; dcl operation_code fixed bin; /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION lop_token_ptr Pointer to a token that describes the multiplicand (for multiplication) or the dividend (for division). This token may be a data name token (type 9) , a numeric literal token (type 2) or a toekn for the reserved word ZERO. (input) rop_token_ptr Pointer to a token that describes the multiplier (for multiplication) or the divisor (for division). This token may be a data name token (type 9), a numeric literal token (type 2), or a reserved word token (type 1) for the figurative constant ZERO. (input) result_token_ptr Pointer to a register token (type 100) that describes the register containing the result of the computation. (output) operation_code A code that identifies the operation for which code is to be generated. This code is defined in the following table: code value | operation ========================================= 1 | multiplication 2 | division ======================================== */ /* DECLARATION OF EXTERNAL ENTRIES */ dcl cobol_register$load ext entry (ptr); dcl cobol_make_bin_const ext entry (ptr, ptr, fixed bin); dcl cobol_make_reg_token ext entry (ptr, bit (4)); dcl cobol_load_register ext entry (ptr, ptr); dcl cobol_short_to_longbin$temp ext entry (ptr, ptr); dcl cobol_addr ext entry (ptr, ptr, ptr); dcl cobol_emit ext entry (ptr, ptr, fixed bin); /* Declaration of Internal Static Variables. */ dcl MPY bit (10) int static init ("1000000100"b); /* 402(0) */ dcl DIV bit (10) int static init ("1010001100"b); /* 506(0) */ dcl direct_lower_inst bit (36) int static init ("000000000000000000000000000000000111"b); /* zero,dl */ dcl 1 dec_zero_token int static, 2 size fixed bin (15), 2 line fixed bin (15), 2 column fixed bin (15), 2 type fixed bin (15) init (2), 2 integral bit (1) init ("1"b), 2 floating bit (1) bit (1) init ("0"b), 2 filler1 bit (5), 2 subscript bit (1) init ("0"b), 2 sign char (1) init (" "), 2 exp_sign char (1) init (" "), 2 exp_places fixed bin (15), 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 ("0"); /* DECLARATION OF INTERNAL VARIABLES */ /* DECLARATION OF INTERNAL VARIABLES */ dcl 1 input_buff aligned, 2 buff (1:10) ptr; dcl 1 inst_buff aligned, 2 buff (1:2) fixed bin; dcl 1 reloc_buff aligned, 2 buff (1:10) bit (5) aligned; dcl dn_ptr ptr; 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 temp_ptr ptr; dcl reg_temp bit (4); /**************************************************/ start: /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(cmb);/**/ if lop_token_ptr -> data_name.type = rtc_resword then lop_token_ptr = addr (dec_zero_token); if rop_token_ptr -> data_name.type = rtc_resword /* Right operand token is fig const ZERO */ then rop_token_ptr = addr (dec_zero_token); if lop_token_ptr -> data_name.type = rtc_numlit then do; /* Left operand is a numeric literal */ /* Make a binary constant for the numeric literal. */ temp_ptr = null (); call cobol_make_bin_const (lop_token_ptr, temp_ptr, 2); lop_token_ptr = temp_ptr; end; /* Left operand is a numeric literal. */ if rop_token_ptr -> data_name.type = rtc_numlit then do; /* Right operand is a numeric literal. */ /* Make a binary constant from the numeric literal token. */ temp_ptr = null (); call cobol_make_bin_const (rop_token_ptr, temp_ptr, 2); rop_token_ptr = temp_ptr; end; /* Right operand is a numeric literal. */ if (rop_token_ptr -> data_name.type = rtc_dataname & rop_token_ptr -> data_name.bin_18) then do; /* Right operand is a short binary. */ /* Convert from short to long binary into a temporary. */ temp_ptr = null (); call cobol_short_to_longbin$temp (rop_token_ptr, temp_ptr); rop_token_ptr = temp_ptr; end; /* Right operand is a short binary. */ /* Make a register token that references the Q register. */ temp_ptr = null (); call cobol_make_reg_token (temp_ptr, "0010"b); /* Generate code to load the left operand into the Q register. */ call cobol_load_register (lop_token_ptr, temp_ptr); if rop_token_ptr -> data_name.type = rtc_dataname then do; /* Right operand is a data name. */ /* Establish addressability to the data name. */ 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.operand.size_sw (1) = 0; input_struc.operand.token_ptr (1) = rop_token_ptr; call cobol_addr (input_ptr, inst_ptr, reloc_ptr); end; /* Right operand is a data name. */ else do; /* Right operand is an immediate constant. */ /* Insert the immediate value into the instruction. */ substr (direct_lower_inst, 1, 18) = substr (unspec (rop_token_ptr -> immed_const.const_value), 19, 18); inst_ptr = addr (direct_lower_inst); reloc_ptr = null (); end; /* Right operand is an immediate constant. */ if operation_code = 1 then inst_struc_basic.fill1_op = MPY; else inst_struc_basic.fill1_op = DIV; /* Lock the A register, because multiplication or division uses the A for the computation. */ register_struc.what_reg = 1; /* A */ register_struc.lock = 1; register_struc.contains = 0; call cobol_register$load (addr (register_struc)); /* Emit the MPY or DIV instruction. */ call cobol_emit (inst_ptr, reloc_ptr, 1); /* Make a register token that describes the result of the multiply or divide. */ if operation_code = 1 /* MPY */ then reg_temp = "0011"b; /* Product of multiply is in A and Q */ else reg_temp = "0010"b; /* Quotient of divide is in Q. (remainder is in A ) */ call cobol_make_reg_token (result_token_ptr, reg_temp); /***..... if Trace_Bit then call cobol_gen_driver_$Tr_End(cmb);/**/ return; /***..... dcl cmb char(22) init("COBOL_MULTIPLY2_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); /**/ /* 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_type9; %include cobol_record_types; %include cobol_addr_tokens; %include cobol_type102; end cobol_multiply2_binary;  cobol_multiply_bin_gen.pl1 05/24/89 1041.5rew 05/24/89 0834.8 156249 /****^ *********************************************************** * * * 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_multiply_bin_gen.pl1 Added Trace statements. END HISTORY COMMENTS */ /* Modified on 11/22/84 by FCH, [5.3...], trace added */ /* Modified on 10/19/84 by FCH, [4.3-1], BUG563(phx18381), new cobol_addr_tokens.incl.pl1 */ /* Modified on 06/29/79 by FCH, [4.0-1], not option added for debug */ /* Modified since Version 4.0 */ /*{*/ /* format: style3 */ cobol_multiply_bin_gen: proc (in_token_ptr, next_stmt_tag); /* This procedure generates code for the multiply statement which uses the hardware registers ( A and Q ) instead of using EIS instructions. */ /* DECLARATION OF THE PARAMETERS */ /* dcl in_token_ptr ptr; */ /* Declared below in an include file. */ dcl next_stmt_tag fixed bin; /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION in_token_ptr Pointer to a structurre that contains data and pointers that describes the multiply statement for which code is to be implemented. (input) See description below for more details. next_stmt_tag A tag that is to be defined at the next cobol statement by cobol_gen_driver_. (output) See below for details. */ /* DECLARATION OF EXTERNAL ENTRIES */ dcl cobol_short_to_longbin$temp ext entry (ptr, ptr); 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_store_binary ext entry (ptr, ptr, bit (1)); dcl cobol_register$release ext entry (ptr); dcl cobol_addr ext entry (ptr, ptr, ptr); dcl cobol_emit ext entry (ptr, ptr, fixed bin); dcl cobol_fofl_mask$on ext entry; dcl cobol_fofl_mask$off ext entry; dcl cobol_multiply2_binary ext entry (ptr, 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_register$load ext entry (ptr); /* DECLARATION OF INTERNAL STATIC DATA */ dcl STZ bit (10) int static init ("1001010000"b); /* 450(0) */ dcl AOS bit (10) int static init ("0001011000"b); /* 054(0) */ dcl LDA bit (10) int static init ("0100111010"b); /* 235(0) */ dcl LDQ bit (10) int static init ("0100111100"b); /* 236 (0) */ dcl tov_inst bit (36) int static init ("000000000000000000110001111000000000"b); ; /* tov 0 */ dcl tra_inst bit (36) int static init ("000000000000000000111001000000000000"b); /* tra 0 */ dcl tnz_inst bit (36) int static init ("000000000000000000110000001000000000"b); /* tnz 0 */ dcl 1 dec_zero_token int static, 2 size fixed bin (15), 2 line fixed bin (15), 2 column fixed bin (15), 2 type fixed bin (15) init (2), 2 integral bit (1) init ("1"b), 2 floating bit (1) bit (1) init ("0"b), 2 filler1 bit (5), 2 subscript bit (1) init ("0"b), 2 sign char (1) init (" "), 2 exp_sign char (1) init (" "), 2 exp_places fixed bin (15), 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 ("0"); /* DECLARATION OF INTERNAL VARIABLES */ dcl 1 input_buff, 2 buff (1:10) fixed bin; dcl 1 reloc_buff, 2 buff (1:10) 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 result_token_ptr ptr; dcl work_token_ptr ptr; dcl addend_token_ptr ptr; dcl receive_count fixed bin; dcl ret_offset fixed bin (24); dcl ovflo_flag_inst bit (36); dcl ovflo_tag fixed bin; dcl no_ovflo_tag fixed bin; dcl imperative_stmt_tag fixed bin; dcl ix fixed bin; dcl temp_target_code fixed bin; dcl multiplier_token_ptr ptr; dcl multiplicand_token_ptr ptr; dcl remainder_token_ptr ptr; dcl ose_flag bit (1); dcl tlength fixed bin; dcl temp_ptr ptr; dcl skipped_some bit (1); dcl temp_lop_token_ptr ptr; dcl temp_rop_token_ptr ptr; dcl call_again bit (1); dcl dn_ptr ptr; /*************************************/ start: /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(cmbg);/**/ /* Extract useful information from the EOS token. */ eos_ptr = in_token.token_ptr (in_token.n); ose_flag = end_stmt.b; if ose_flag then do; /* Reserve two tags for on size error processing. */ imperative_stmt_tag = cobol_$next_tag; next_stmt_tag = imperative_stmt_tag + 1; cobol_$next_tag = cobol_$next_tag + 2; end; /* Reserve two tags for on size error processing. */ result_token_ptr = null (); if end_stmt.a = "000"b then call format1_multiply; else call format2_multiply; /***..... if Trace_Bit then call cobol_gen_driver_$Tr_End(cmbg);/**/ return; /*************************************/ format1_multiply: proc; /***..... if Trace_Bit then call ioa_("^a^a",substr(Trace_Line,Trace_Lev+1,1),"FORMAT1_MULTIPLY");/**/ /* This internal procedure generates code using the hardware registers ( A and Q ) for format 1 multiply statements. */ receive_count = end_stmt.e; multiplier_token_ptr = in_token.token_ptr (2); if (multiplier_token_ptr -> data_name.type = rtc_dataname & receive_count > 1) then do; /* Divisor is long binary, and more than one multiplynd/receiving field. */ /* Generate code to store the multiplier into a temp, because if one of the multiplynds is the multiplier (i.e. MULTIPLY A BY A B C) then the original multiplier value will be destroyed. */ /* Allocate space for the temporary in the stack. */ call cobol_alloc$stack (4, 0, ret_offset); temp_ptr = null (); /* Make a data name token for the temp. */ call cobol_make_type9$long_bin (temp_ptr, 1000, ret_offset); /* Store the multiplier into the temporary. */ call cobol_store_binary (multiplier_token_ptr, temp_ptr, call_again); /* Release the register that was used in storing the multiplier. */ register_struc.reg_no = multiplier_token_ptr -> cobol_type100.register; call cobol_register$release (addr (register_struc)); multiplier_token_ptr = temp_ptr; end; /* Divisor is long binary, and move than one multiplynd/receiving field. */ if ose_flag then do; /* On size error clause was present. */ if receive_count > 1 then do; /* Multiple multiplynd/receiving fields. */ /* Allocate space on the stack for an overflow flag, and emit code to initialize it to zero. */ call cobol_alloc$stack (4, 0, ret_offset); input_ptr = addr (input_buff); reloc_ptr = addr (reloc_buff); inst_ptr = addr (ovflo_flag_inst); 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 = ret_offset; call cobol_addr (input_ptr, inst_ptr, reloc_ptr); inst_struc_basic.fill1_op = STZ; call cobol_emit (inst_ptr, reloc_ptr, 1); /* Define some tags to be used in the overflow testing */ ovflo_tag = cobol_$next_tag; no_ovflo_tag = ovflo_tag + 1; cobol_$next_tag = cobol_$next_tag + 2; end; /* Multiple multiplynd/receiving fields. */ else ovflo_tag = imperative_stmt_tag; /* Generate code to turn on the fixed overflow mask in the indicator register. */ call cobol_fofl_mask$on; end; /* On size error clause was present. */ /* Generate code to multiply the multiplier into each multiplynd/receiving field. */ do ix = 3 to in_token.n - 1; /* Do all the multiplys. */ call cobol_multiply2_binary (in_token.token_ptr (ix), multiplier_token_ptr, result_token_ptr, 1); call cobol_store_binary (result_token_ptr, in_token.token_ptr (ix), call_again); if call_again then do; /* Must call the store procedure again to get the results stored. */ if ose_flag then do; /* Must test for overflow again. */ call cobol_emit (addr (tov_inst), null (), 1); call cobol_make_tagref (ovflo_tag, cobol_$text_wd_off - 1, null ()); end; /* Must test for overflow again. */ call cobol_store_binary (result_token_ptr, in_token.token_ptr (ix), call_again); end; /* Must call the store procedure again to get the results stored. */ if result_token_ptr -> data_name.type = rtc_register then do; /* Release the register containing the result just stored. */ register_struc.reg_no = result_token_ptr -> cobol_type100.register; call cobol_register$release (addr (register_struc)); end; /* Release the register containing the result just stored. */ if ose_flag & receive_count ^= 1 then do; /* On size error and multiple multiplynds. */ /* Emit code to transfer to the next multiply sequence. */ call cobol_emit (addr (tra_inst), null (), 1); call cobol_make_tagref (no_ovflo_tag, cobol_$text_wd_off - 1, null ()); /* Define the ovflo_tag at the next instructiin location. */ call cobol_define_tag (ovflo_tag); /* Emit code to increment the overflow flag. */ inst_struc_basic.fill1_op = AOS; call cobol_emit (inst_ptr, reloc_ptr, 1); /* Define the no_ovflo_tag at the next instruction location. */ call cobol_define_tag (no_ovflo_tag); if ix ^= in_token.n - 1 then do; /* Not the last multiply, define new ovflo and no_ovflo tags. */ ovflo_tag = cobol_$next_tag; no_ovflo_tag = ovflo_tag + 1; cobol_$next_tag = cobol_$next_tag + 2; end; /* Not the last multiply, define new ovflo, no_ovflo tags */ end; /* On size error and multiple multiplynds. */ end; /* Do all the multiplys. */ if ose_flag then do; /* On size error clause was present. */ /* Generate code to turn off the fixed overflow mask in the indicator registers. */ call cobol_fofl_mask$off; if receive_count > 1 then do; /* More that one multiplynd/receiving field. */ /* Generate code to load the overflow flag, and test it for zero. */ register_struc.what_reg = 4; /* A or Q */ register_struc.lock = 0; register_struc.contains = 0; call cobol_register$load (addr (register_struc)); if register_struc.reg_no = "0001"b then inst_struc_basic.fill1_op = LDA; else inst_struc_basic.fill1_op = LDQ; call cobol_emit (inst_ptr, reloc_ptr, 1); /* Generate code to test for non-zero, and transfer to the imperative statement tag if not zero. */ call cobol_emit (addr (tnz_inst), null (), 1); call cobol_make_tagref (imperative_stmt_tag, cobol_$text_wd_off - 1, null ()); end; /* More than one multiplynd/receiving field. */ /*[4.0-1*/ if end_stmt.f = "01"b /*[4.0-1*/ then next_stmt_tag = imperative_stmt_tag; /*[4.0-1*/ else do; /* Generate code to transfer to the next cobol statement ( the one following the imperative statement. ) */ call cobol_emit (addr (tra_inst), null (), 1); call cobol_make_tagref (next_stmt_tag, cobol_$text_wd_off - 1, null ()); /* Define the imperative statement tag at the next instruction location. */ call cobol_define_tag (imperative_stmt_tag); /*[4.0-1*/ end; end; /* On size error clause was present. */ end format1_multiply; /*************************************/ format2_multiply: proc; /***..... if Trace_Bit then call ioa_("^a^a",substr(Trace_Line,Trace_Lev+1,1),"FORMAT2_MULTIPLY");/**/ /* This internal procedure generates code using the hardware registers (A and Q) for format 2,3,4, and 5 multiply statements. */ multiplicand_token_ptr = in_token.token_ptr (2); multiplier_token_ptr = in_token.token_ptr (3); /* Generate code to do the division. */ call cobol_multiply2_binary (multiplicand_token_ptr, multiplier_token_ptr, result_token_ptr, 1 /*multiply */); /* Generate code to store the product into all long binary receiving fields. */ /* Note that there is no possibliity of overflow, since result is long binary, and so are targets. */ skipped_some = "0"b; if ose_flag then call cobol_fofl_mask$on; /* Generate code to turn on the fixed overflow mask bit in the indicator register. */ do ix = 4 to in_token.n - 1; /* Store product into all long binary targets. */ if in_token.token_ptr (ix) -> data_name.bin_18 then skipped_some = "1"b; else do; /* Long binary target. */ call cobol_store_binary (result_token_ptr, in_token.token_ptr (ix), call_again); if call_again then do; /* REsult has been moved to a temp in an attempt to force overflow. */ if ose_flag then do; /* On size error clause present. */ /* Must test for overflow. */ call cobol_emit (addr (tov_inst), null (), 1); call cobol_make_tagref (imperative_stmt_tag, cobol_$text_wd_off - 1, null ()) ; end; /* On size error clause present. */ /* Generate code to store the temp into the target. */ call cobol_store_binary (result_token_ptr, in_token.token_ptr (ix), call_again); end; /* Result has been moved to a temp in an attempt to force overflow. */ end; /* Long binary target. */ end; /* Store product into all long binary targets. */ if skipped_some then do; /* Store the product into all short binary receiving fields. */ do ix = 4 to in_token.n - 1; /* Scan the targets. */ if in_token.token_ptr (ix) -> data_name.bin_18 then do; /* Short binary target. */ call cobol_store_binary (result_token_ptr, in_token.token_ptr (ix), call_again); if call_again then do; /* REsult has been moved to a temp in an attempt to force overflow. */ if ose_flag then do; /* On size error clause present. */ /* Must test for overflow. */ call cobol_emit (addr (tov_inst), null (), 1); call cobol_make_tagref (imperative_stmt_tag, cobol_$text_wd_off - 1, null ()); end; /* On size error clause present. */ /* Generate code to store the temp into the target. */ call cobol_store_binary (result_token_ptr, in_token.token_ptr (ix), call_again); end; /* Result has been moved to a temp in an attempt to force overflow. */ end; /* Short binary target. */ end; /* Scan the targets. */ end; /* Store the product into all short binary receiving fields. */ if ose_flag then do; /* On size error clause was present. */ /* Generate code to turn off the fixed overflow mask bit. */ call cobol_fofl_mask$off; /*[4.0-1*/ if end_stmt.f = "01"b /*[4.0-1*/ then next_stmt_tag = imperative_stmt_tag; /*[4.0-1*/ else do; /* Emit code to transfer to the next cobol statement. (The statement following the imperative statement.) */ call cobol_emit (addr (tra_inst), null (), 1); call cobol_make_tagref (next_stmt_tag, cobol_$text_wd_off - 1, null ()); /* Define the imperative statement tag at the next instruction location. */ call cobol_define_tag (imperative_stmt_tag); /*[4.0-1*/ end; /* Generate code to turn off the fixed overflow mask bit */ call cobol_fofl_mask$off; end; /* On size error clause was present. */ if result_token_ptr -> data_name.type = rtc_register then do; /* Result token describes a register. */ /* Release the register, since the value there has been stored into all receiving fields. */ register_struc.reg_no = result_token_ptr -> cobol_type100.register; call cobol_register$release (addr (register_struc)); end; /* Result token describes a register. */ end format2_multiply; /***..... dcl cmbg char(22) init("COBOL_MULTIPLY_BIN_GEN");/**/ /***..... 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); /**/ /* INCLUDE FILES USED IN 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_type9; %include cobol_addr_tokens; %include cobol_; %include cobol_in_token; %include cobol_record_types; %include cobol_type100; %include cobol_type19; end cobol_multiply_bin_gen;  cobol_multiply_gen.pl1 05/24/89 1041.5rew 05/24/89 0830.4 173133 /****^ *********************************************************** * * * 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_multiply_gen.pl1 Added Trace statements. END HISTORY COMMENTS */ /* Modified on 11/22/84 by FCH, [5.3...], trace added */ /* Modified on 10/19/84 by FCH, [4.3-1], BUG563(phx18381), new cobol_addr_tokens.incl.pl1 */ /* Modified on 04/18/80 by FCH, new include file cobol_arith_util, fix not option */ /* Modified on 06/28/79 by FCH, [4.0-1], not option added for debug */ /* Modified since Version 4.0 */ /* format: style3 */ cobol_multiply_gen: proc (in_token_ptr, next_stmt_tag); /* The MULTIPLY statement generator: cobol_multiply_gen FUNCTION The function of this procedure is to generate code for the Cobol MULTIPLY statement. */ /* DECLARATION OF THE PARAMETERS */ /* dcl in_token_ptr ptr; */ /* DECLARED BELOW IN AN INCLUDE FILE */ dcl next_stmt_tag fixed bin; /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION in_token_ptr Points to the in_token structure, which contains information describing the MULTIPLY statement for which code is to be generated. (input) See the description below under INPUT for the exact contents of the input structure. NOTE: This parameter is declared in an include file following the executable statements of this procedure. next_stmt_tag Contains a compiler generated tag number (label) to be associated by the code generator driver with the Cobol statement that follows the MULTIPLY statement for which this procedure was called. (output) See the discussion below under OUTPUT for more details. */ /* INPUT The input to this procedure is a structure, which is defined by a declaration of the following format: dcl 1 in_token based (in_token_ptr), 2 n fixed bin, 2 code fixed bin 2 token_ptr ( 0 refer (in_token.n)) ptr; where: in_token.n contains the number of entries in the token_ptr array. token_ptr(1) contains a pointer to a reserved word token (type 1) for the reserved word MULTIPLY. This pointer is not used by this procedure. token_ptr(n) contains a pointer to an EOS (type 19) token. A declaration that describes the contents of the EOS token is given following the executable statements of this procedure in an include file. The type 19 token contains the following information that is used by this procedure. 1. end_stmt.verb contains the code for the reserved word MULTIPLY. 2. end_stmt.a defines the format of the MULTIPLY statement: value of end_stmt.a | Mpy stmt format ---------------------------------------- "000"b | format 1 "001"b | format 2 3. end_stmt.b is "1"b if this MULTIPLY statement had an ON SIZE ERROR clause 4. end_stmt.e contains the count of the number of operands to the RIGHT of "BY" for format 1 MULTIPLY statements. 5, end_stmt.h contians the count of the number of operands to the RIGHT of "GIVING" for format 2 MULTIPLY statements. token_ptr(2) through token_ptr(n-1) point to tokens that describe: 1. the data items to be multiplied together. These tokens can be data name (type 9) tokens numeric literal (type 2) tokens. 2. the data items to receive the result of the multiplication. These tokens are always data name (type 9) tokens. OUTPUT The second parameter passed to cobol_multiply_gen is an output parameter. A value is returned to the calling procedure, cobol_gen_driver_, only for those multiply staatments that have on size error clauses. If an on size error clause is specified, then, in addition to the code that evaluates the product, and assigns it to the receiving data items, cobol_multiply_gen must also generate code that checks for size error conditions. If a size error is detected by the execution of the generated code, then the imperative statement in the MULTIPLY statment is executed, otherwise the imperative statement is skipped. The cobol_multiply_gen generator, however, when generating code to skip over the imperative statement to the next statement, does not know anything about the next statement. This situation is handled as follows: 1. cobol_multiply_gen reserves a tag for the next COBOL statement. 2. any transfers to the next statement reference the tag reserved by cobol_multiply_gen. This tag is not yet defined. (associated with an instruction location in the text segment) 3. after generation of code for an multiply statement is completed, cobol_multiply_gen passes the next statement tag back to its caller, cobol_gen_driver_, in the second parameter. 4. when cobol_gen_driver_ detects the end of the imperative statement, the tag, reserved by cobol_multiply_gen, is defined. */ /* DECLARATION OF EXTERNAL ENTRIES */ dcl cobol_binary_check$multiply ext entry (ptr, bit (1), fixed bin, fixed bin); dcl cobol_multiply_bin_gen ext entry (ptr, fixed bin); dcl cobol_num_to_udts ext entry (ptr, ptr); dcl cobol_fofl_mask$on ext entry; dcl cobol_fofl_mask$off ext entry; dcl cobol_build_resop ext entry (ptr, ptr, fixed bin, ptr, bit (1), fixed bin, bit (1)); dcl cobol_mpy3 ext entry (ptr, ptr, ptr, fixed bin); dcl cobol_mpy ext entry (ptr, ptr, fixed bin); dcl cobol_define_tag ext entry (fixed bin); dcl cobol_alloc$stack ext entry (fixed bin, fixed bin, fixed bin); dcl cobol_addr ext entry (ptr, ptr, ptr); dcl cobol_emit ext entry (ptr, ptr, fixed bin); dcl cobol_arith_move_gen ext entry (ptr); dcl cobol_move_gen ext entry (ptr); dcl cobol_make_type9$copy ext entry (ptr, ptr); dcl cobol_make_tagref ext entry (fixed bin, fixed bin, ptr); dcl cobol_register$load ext entry (ptr); dcl cobol_make_type9$fixed_bin_35 ext entry (ptr, fixed bin, fixed bin); dcl cobol_make_type9$type2_3 ext entry (ptr, ptr); /* DECLARATIONS OF BUILTIN FUNCTIONS */ dcl addr builtin; dcl fixed builtin; dcl null builtin; /* DECLARATION OF INTERNAL STATIC VARIABLES */ dcl first_ix fixed bin int static init (2); dcl mpy_code fixed bin int static init (184); /* Definition of an internal static buffer in which an EOS token is built for calls to the MOVE gen. */ dcl move_eos_buffer (1:10) ptr int static; /* Definition of an internal static buffer in which an in_token is built for calls to the MOVE gen. */ dcl move_in_token_buffer (1:10) ptr int static; dcl move_data_init fixed bin int static init (0); /* Definition of a numeric literal zero */ dcl 1 num_lit_zero int static, 2 size fixed bin (15) init (37), 2 line fixed bin (15) init (0), 2 column fixed bin (15) init (0), 2 type fixed bin (15) init (2), 2 integral bit (1) init ("1"b), 2 floating bit (1) init ("0"b), 2 filler1 bit (5) init ("0"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 lit_val char (1) init ("0"); /* DECLARATION OF INTERNAL AUTOMATIC VARIABLES */ dcl ose_flag bit (1); dcl receive_count fixed bin; dcl fmt1 bit (1); dcl ix fixed bin; dcl iy fixed bin; dcl move_eos_ptr ptr; dcl move_in_token_ptr ptr; dcl multiplicand_ptr ptr; dcl multiplier_ptr ptr; dcl resultant_operand_ptr ptr; dcl saved_ptr ptr; dcl rdmax_value fixed bin; dcl overflow_code_generated bit (1); dcl possible_ovfl_flag bit (1); dcl receiving_is_not_stored bit (1); dcl size_error_inst bit (36); dcl size_error_inst_ptr ptr; dcl size_error_token_ptr ptr; dcl stored_token_ptr ptr; dcl no_overflow_tag fixed bin; dcl op1_token_ptr ptr; dcl op2_token_ptr ptr; dcl temp_resultant_operand_ptr ptr; dcl (binary_ok, not_bit) bit (1); dcl source_code fixed bin; dcl target_code fixed bin; dcl dn_ptr ptr; /**************************************************/ start: /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(cmg);/**/ /* Check to see if binary arithmetic (using A and Q registers) can be done. */ call cobol_binary_check$multiply (in_token_ptr, binary_ok, target_code, source_code); if binary_ok then do; /* Binary arithmetic can be done. */ call cobol_multiply_bin_gen (in_token_ptr, next_stmt_tag); return; end; /* Binary arithmetic can be done. */ move_in_token_ptr = null (); /* Get meaningful data from the EOS token. */ eos_ptr = in_token.token_ptr (in_token.n); /* ON SIZE ERROR flag */ ose_flag = end_stmt.b; /* Determine the number of receiving operands. */ if end_stmt.a = "000"b then do; /* format 1 multiply. */ fmt1 = "1"b; receive_count = end_stmt.e; multiplicand_ptr = in_token.token_ptr (first_ix); if multiplicand_ptr -> data_name.type ^= rtc_dataname then do; /* Multiplicand not dataname, must be numeric literal or ZERO. */ if multiplicand_ptr -> data_name.type = rtc_numlit then saved_ptr = multiplicand_ptr; /* numeric literal */ else saved_ptr = addr (num_lit_zero); /* Assume multiplicand is figurative constant ZERO. */ multiplicand_ptr = null (); /* Utility provides buffer for dataname token. */ /* Pool the literal and get a dataname token for it. */ call cobol_make_type9$type2_3 (multiplicand_ptr, saved_ptr); end; /* Multiplicand not dataname, must be numeric literal or ZERO. */ end; /* format 1 multiply */ else do; /* fmt 2 multiply */ fmt1 = "0"b; receive_count = end_stmt.h; end; /* fmt 2 multiply */ if ose_flag /* On size error clause was present, do processing common to both format multiplies. */ then do; /* Reserve a tag to be associated (by the cobol generator driver) with the next cobol statement. */ next_stmt_tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; /* Get a size error flag in the stack, and initialize it to zero. */ size_error_inst_ptr = addr (size_error_inst); call get_size_error_flag (size_error_token_ptr, size_error_inst_ptr); end; /* On size error clause was present, do processing common to both format multiplies. */ if ^fmt1 then do; /* FORMAT 2 multiply, multiply the first two operands and store the result in a temporary. */ /* Build a resultant operand for the product. */ multiplicand_ptr = in_token.token_ptr (first_ix); multiplier_ptr = in_token.token_ptr (first_ix + 1); call cobol_build_resop (multiplicand_ptr, multiplier_ptr, mpy_code, resultant_operand_ptr, "0"b, rdmax_value, possible_ovfl_flag); /* Generate code to perform the multiplication. */ call cobol_mpy3 (multiplicand_ptr, multiplier_ptr, resultant_operand_ptr, 1 /* MPY */); move_in_token_ptr = addr (move_in_token_buffer (1)); move_eos_ptr = addr (move_eos_buffer (1)); if move_data_init ^= cobol_$compile_count then call init_move_data; end; /* FORMAT2 multiply, multiply the first two operrands and store the result in a temp. */ /* Get subscript of pointer in the in_token array that points to first receiving field. */ iy = in_token.n - receive_count; do ix = 1 to receive_count; /* Generate code to get the prdouct into the receiving field(s). */ receiving_is_not_stored = "0"b; /* Generate code to store the receiving field into a temporary, if the on size error flag is on, and the receiving field is NOT a numeric edited item. */ if ose_flag then if in_token.token_ptr (iy) -> data_name.numeric_edited /* Receiving is numeric edited. */ | (in_token.token_ptr (iy) -> data_name.display & in_token.token_ptr (iy) -> data_name.item_signed & in_token.token_ptr (iy) -> data_name.sign_separate = "0"b) /* overpunch sign */ then receiving_is_not_stored = "1"b; else call receiving_field (in_token.token_ptr (iy), stored_token_ptr, 1); /* Generate code to turn the overflow mask indicator bit ON */ if ose_flag then call cobol_fofl_mask$on; if fmt1 /* Generate code to multiply the first operand by the receiving field value, and store the result into the receiving field. */ then do; move_in_token_ptr = null (); if not_dec_operand (in_token.token_ptr (iy)) then do; /* The receiving operand is not decimal. Must convert to decimal before performing the multiplication. */ op1_token_ptr = multiplicand_ptr; op2_token_ptr = in_token.token_ptr (iy); /* Convert the non-decimal operand(s) , and build a temporary into which to store the result of the computation. */ call cobol_build_resop (op1_token_ptr, op2_token_ptr, mpy_code, temp_resultant_operand_ptr, "0"b, rdmax_value, possible_ovfl_flag); /* Generate code to multiply the two operands, and store the result into a temporary. */ call cobol_mpy3 (op1_token_ptr, op2_token_ptr, temp_resultant_operand_ptr, 1); /* Generate code to move the result of the multiply to the receiving field. */ move_in_token_ptr = addr (move_in_token_buffer (1)); move_eos_ptr = addr (move_eos_buffer (1)); if move_data_init ^= cobol_$compile_count then call init_move_data; move_in_token_ptr -> in_token.token_ptr (2) = temp_resultant_operand_ptr; move_in_token_ptr -> in_token.token_ptr (3) = in_token.token_ptr (iy); call cobol_arith_move_gen (move_in_token_ptr); if move_in_token_ptr -> in_token.code ^= 0 then receiving_is_not_stored = "1"b; end; /* The receiving operand is not decimal. Must convert to decimal before performing the multiply. */ else do; /* Receiving operand is decimal. */ if not_dec_operand (multiplicand_ptr) then do; /* Left operand is not decimal--convert to decimal. */ op1_token_ptr = multiplicand_ptr; multiplicand_ptr = null (); call cobol_num_to_udts (op1_token_ptr, multiplicand_ptr); end; /* Left operand is not decimal--convert to decimal. */ call cobol_mpy (multiplicand_ptr, in_token.token_ptr (iy), 1); end; /* Receiving operand is decimal. */ end; /* Generate code to multiply the first operand by the receiving field value, and store the result into the recieving field. */ else do; /* Generate code to move the product already calculated into the receiving field. */ move_in_token_ptr -> in_token.token_ptr (move_in_token_ptr -> in_token.n - 2) = resultant_operand_ptr; move_in_token_ptr -> in_token.token_ptr (move_in_token_ptr -> in_token.n - 1) = in_token.token_ptr (iy); call cobol_arith_move_gen (move_in_token_ptr); if move_in_token_ptr -> in_token.code ^= 0 then receiving_is_not_stored = "1"b; end; /* Generate code to move the product already calculated into the receiving fields. */ if ose_flag then do; /* Generate code to test for overflow resulting from the multiply/store or move. */ /* Reserve a tag to which to transfer if no overflow occurs. */ no_overflow_tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; /* Generate code to test for overflow. */ call test_for_overflow (no_overflow_tag, size_error_inst_ptr, move_in_token_ptr); /* Generate code to restore the stored value back into the receiving field. */ /* The value is restored only if the receiving field was not numeric edited. If the receiving field was numeric edited, the result of the multiplication has been moved into a temporary, and the receiving field has not been modified at all. */ if receiving_is_not_stored = "0"b then call receiving_field (in_token.token_ptr (iy), stored_token_ptr, 2 /* RESTORE*/); /* Define the no_overflow_tag at the next instruction in the text segment. */ call cobol_define_tag (no_overflow_tag); /* Generate code to turn the overflow mask indicator bit OFF */ call cobol_fofl_mask$off; end; /* Generate code to test for overflow resulting from the multiply/store or move. */ else if receiving_is_not_stored then call cobol_move_gen (move_in_token_ptr);/* Call cobol_move_gen to move the temp result into a numeric edited receiving field */ /* Increment the subscript to the next receiving field. */ iy = iy + 1; end; /* Get the product into the receiving field(s). */ if ose_flag then do; /* Generate code that tests whether overflow occurred, and jumps over the imperative stmt if no overflow occurred. */ /*[4.0-1]*/ if end_stmt.f = "01"b then not_bit = "1"b; else not_bit = "0"b; call test_size_error (size_error_token_ptr, size_error_inst_ptr, next_stmt_tag, "1"b, not_bit); end; /* Generate code that tests whether overflow occurred, and jumps over the imperative stmt if no overflow occurrred. */ /***..... if Trace_Bit then call cobol_gen_driver_$Tr_End(cmg);/**/ return; /*************************************/ init_move_data: proc; /* This internal procedure initializes the input token and EOS token used in calls to the cobol move generators. */ /* Initialize in_token structure and EOS token structure used in calls to the MOVE generator. */ saved_ptr = in_token_ptr; in_token_ptr = move_in_token_ptr; in_token.n = 4; in_token.code = 0; in_token.token_ptr (1) = null (); in_token.token_ptr (in_token.n) = move_eos_ptr; in_token_ptr = saved_ptr; saved_ptr = eos_ptr; eos_ptr = move_eos_ptr; end_stmt.verb = 18; /* MOVE */ end_stmt.e = 1; /* COUNT of the receiving fields */ end_stmt.type = rtc_eos; eos_ptr = saved_ptr; move_data_init = cobol_$compile_count; end init_move_data; /***..... dcl cmg char(18) init("COBOL_MULTIPLY_GEN");/**/ /***..... 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); /**/ /**************************************************/ /* INCLUDE FILES USED BY THIS PROCEDURE */ /**************************************************/ %include cobol_arith_util; %include cobol_type9; %include cobol_in_token; %include cobol_type19; %include cobol_; %include cobol_addr_tokens; %include cobol_record_types; end cobol_multiply_gen;  cobol_num_to_udts.pl1 05/24/89 1041.5rew 05/24/89 0830.4 38052 /****^ *********************************************************** * * * 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_num_to_udts.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /*{*/ /* format: style3 */ cobol_num_to_udts: proc (sf_ptr, rf_ptr); /* This procedure is called to generate code to convert any numeric data item to an unpacked decimal, trailing separate sign value. */ /* DECLARATION OF THE PARAMETERS */ dcl sf_ptr ptr; dcl rf_ptr ptr; /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION sf_ptr Pointer to the data name token for the variable to be converted . (input) rf_ptr Pointer to a buffer in which the data name token for the unpacked decimal trailing separate sign variable is built by this procedure. If rf_ptr is null() on input, then this procedure provides the buffer for the token. (input) */ /*}*/ /* DECLARATION OF INTERNAL VARIABLES */ /* DECLARATIONS OF EXTERNAL ENTRIES */ dcl cobol_move_gen ext entry (ptr); dcl cobol_make_type9$decimal_9bit ext entry (ptr, fixed bin, fixed bin (24), fixed bin, fixed bin); dcl cobol_alloc$stack ext entry (fixed bin, fixed bin, fixed bin); /* DECLARATIONS OF INTERNAL STATIC VARIABLES */ /* Definition of an EOS token used in calls to the MOVE genarator. */ dcl 1 move_eos_token int static, 2 size fixed bin (15), 2 line fixed bin (15), 2 column fixed bin (15), 2 type fixed bin (15), 2 verb fixed bin (15) init (18), /* MOVE */ 2 e fixed bin (15) init (1); /* One receiving field in the move */ /* DECLARATIONS OF INTERNAL VARIABLES */ dcl work_item_length fixed bin; dcl dn_ptr ptr; dcl ret_offset fixed bin; dcl dum_buff (1:10) ptr; /**************************************************/ /* START OF EXECUTION */ /* external procedure cobol_num_to_udts */ /**************************************************/ if sf_ptr -> data_name.bin_18 then work_item_length = 7; else if sf_ptr -> data_name.bin_36 then work_item_length = 12; else work_item_length = sf_ptr -> data_name.places_left + sf_ptr -> data_name.places_right + 1; /* Add one for sign byte */ /* Allocate space on the stack to receive the unpacked decimal value. */ call cobol_alloc$stack (work_item_length, 0, ret_offset); /* Make a data name token for the decimal value just allocated on the stack. */ call cobol_make_type9$decimal_9bit (rf_ptr, 1000 /*STACK*/, fixed (ret_offset, 24), fixed (sf_ptr -> data_name.places_left, 15), fixed (sf_ptr -> data_name.places_right, 15)); /* Change the sign type in the token just built to trailing separate. */ rf_ptr -> data_name.sign_type = "011"b; /* Set up the input token for calling the move generator. */ in_token_ptr = addr (dum_buff); in_token.n = 4; in_token.code = 0; in_token.token_ptr (1) = null (); in_token.token_ptr (2) = sf_ptr; in_token.token_ptr (3) = rf_ptr; in_token.token_ptr (4) = addr (move_eos_token); /* Call the MOVE generator to generate code to move the data (and convert it to unpacked deciaml) */ call cobol_move_gen (in_token_ptr); /* 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_type9; %include cobol_in_token; end cobol_num_to_udts;  cobol_opch_op_call.pl1 05/24/89 1041.5rew 05/24/89 0830.4 104598 /****^ *********************************************************** * * * 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_opch_op_call.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 08/15/83 by FCH, [5.2 ...], trace added */ /* Renamed on 01/17/77 by ORN from cobol_opch_operator_call to cobol_opch_op_call */ /* Modified since Version 2.0 */ /*{*/ /* format: style3 */ cobol_opch_op_call: proc (sf_ptr, rf_ptr); /* This procedure generates code that "calls" the overpunch conversion "cobol operator". The "call" to the overpunch conversion operator is effected by a tsp3 instruction. Data is passed to the conversion routine in hardware registers, and not in a parameter list. The data is passed as follows: 1. pr1 points to the target of the conversion. 2. pr2 points to the source of the conversion. 3. pr5 points to a block of work space, at the top of the stack. This work space must be aligned on a double word boundary. 4. Q register contains the scale and precision of the source of conversion. a. bits 0-17 of the Q register contains the scale. Scale is obtained from data_name.places_right of a data name token. b. Bits 18-36 of the Q contain precision. Precision is obtained from data_name.item_length of a data name token. 5. A register contains the scale and precision of the target of conversion. Bits 0-17 contain the scale, bits 18-36 contain the precision. Scale and precision are obtained as for the source of conversion. 6. X7 contains a code that identifies the data type of the source of conversion. This code is defined in the following table: x7 contents | type of source __________________________________________ 1 | overpunch,leading sign 2 | overpunch, trailing sign 3 | unpacked decimal, trailing sign 7. X6 contains a code that identifies the data type of the target of conversion. This code is the same as that described above for X7. 8. pr3 is used to store the location to which the cobol overpunch conversion operator is to reutrn. */ /* DECLARATION OF THE PARAMETERS */ dcl sf_ptr ptr; dcl rf_ptr ptr; /* DESCRIPTION OF THE PARAMETERS> */ /* PARAMETER DESCRIPTION sf_ptr Pointer to a data name token that describes the source of the conversion. This token will ALWAYS describe an unpacked decimal trailing sign data item, or an overpunch sign data item. rf_ptr Pointer to a data name token that describes the target of the conversion. This token describes the same type of data items as sf_ptr. (see above). (input) */ /* DECLARATION OF EXXTERNAL ENTRIES */ dcl cobol_register$load ext entry (ptr); dcl cobol_pointer_register$get ext entry (ptr); dcl cobol_set_pr ext entry (ptr, ptr); dcl cobol_alloc$stack ext entry (fixed bin, fixed bin, fixed bin); dcl cobol_emit ext entry (ptr, ptr, fixed bin); dcl cobol_pool ext entry (char (*), fixed bin, fixed bin (24)); dcl cobol_make_link$type_4 ext entry (fixed bin, char (*)); dcl cobol_addr ext entry (ptr, ptr, ptr); dcl cobol_reset_r$after_operator ext entry; dcl cobol_reg_manager$before_op entry (fixed bin); /*}*/ /* DECLARATIONS OF INTERNAL STATIC DATA */ dcl ldx7_inst bit (36) int static init ("000000000000000000010010111000000011"b); /* ldx7 0,du */ dcl ldx6_inst bit (36) int static init ("000000000000000000010010110000000011"b); /* ldx6 0,du */ dcl ldq_inst bit (36) int static init ("000000000000000000010011110000000000"b); /* LDQ 0 */ dcl lda_inst bit (36) int static init ("000000000000000000010011101000000000"b); /* LDA 0 */ dcl tsp3_inst bit (36) int static init ("000000000000000111010111011001000000"b); /* tsp3 pr0|7 */ dcl epp5_inst bit (36) int static init ("000000000000000000011111001101000000"b); /* epp5 */ /* DECLARATION OF INTERNAL DATA */ dcl 1 reg_load_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 wk_ptr ptr, 2 literal bit (36); dcl 1 pointer_reg_struc, 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; /***..... 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 (18) int static init ("COBOL_OPCH_OP_CALL");/**/ dcl precision_constant_ptr ptr; dcl 1 precision aligned, 2 scale fixed bin (17) unaligned, 2 precision fixed bin (17) unaligned; dcl precision_offset fixed bin (24); dcl precision_char_constant char (4) based (precision_constant_ptr); dcl input_buffer (1:10) ptr; dcl reloc_buffer (1:10) bit (5); dcl inst_buffer (1:10) ptr; dcl linkoff fixed bin; dcl ret_offset fixed bin; dcl tcode fixed bin; dcl inst_word (1:2) bit (36) init ("0"b, "0"b); dcl 1 treloc_buffer (1:2) aligned, 2 reloc1 bit (5) aligned, 2 reloc2 bit (5) aligned; dcl dn_ptr ptr; /**************************************************/ start: /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME);/**/ /* Store all locked registers, before generating any code to call the overpunch operator. */ call cobol_reg_manager$before_op (0); pointer_reg_struc.lock = 1; pointer_reg_struc.switch = 0; /* Load the pointer registers */ /* Load pr2 to point to the source of conversion. */ pointer_reg_struc.what_pointer = 2; call cobol_set_pr (addr (pointer_reg_struc), sf_ptr); /* Load pr1 to point to the target. */ pointer_reg_struc.what_pointer = 1; call cobol_set_pr (addr (pointer_reg_struc), rf_ptr); /* Allocate some work space on an even word boundary */ call cobol_alloc$stack (40, 2, ret_offset); /* First, must get and lock the index registers needed to pass data to the operator. */ reg_load_struc.lock = 1; /* lock it */ reg_load_struc.contains = 0; /* Get x6 */ reg_load_struc.what_reg = 16; /* x6 */ call cobol_register$load (addr (reg_load_struc)); /* Get x7 */ reg_load_struc.what_reg = 17; call cobol_register$load (addr (reg_load_struc)); /* Load x7 with a code that identifies the source type */ if sf_ptr -> data_name.sign_type = "010"b /* leading, not separate */ then tcode = 1; else if sf_ptr -> data_name.sign_type = "001"b /* trailing, not separate */ then tcode = 2; else if (sf_ptr -> data_name.item_signed & sf_ptr -> data_name.sign_separate = "0"b) then tcode = 2; /* Default is trailing overpunch. */ else tcode = 3; /* ASSUME unpacked decimal, trailing sign */ inst_ptr = addr (ldx7_inst); inst_struc_basic.wd_offset = bit (fixed (tcode, 15)); call cobol_emit (inst_ptr, null (), 1); /* Load x6 with a code that identifies the target of conversion. */ if rf_ptr -> data_name.sign_type = "010"b /* leading, not separate */ then tcode = 1; else if rf_ptr -> data_name.sign_type = "001"b /* trailing, not separate */ then tcode = 2; else if (rf_ptr -> data_name.item_signed & rf_ptr -> data_name.sign_separate = "0"b) then tcode = 2; /* Default is trailing overpunch. */ else tcode = 3; /* ASSUME unpacked, decimal, trailing sign */ inst_ptr = addr (ldx6_inst); inst_struc_basic.wd_offset = bit (fixed (tcode, 15)); call cobol_emit (inst_ptr, null (), 1); /* Generate code to load the Q register with the scale and precision of the source of conversion. */ /* First, get and lock the A and Q registers. */ reg_load_struc.what_reg = 3; /* A and Q */ call cobol_register$load (addr (reg_load_struc)); precision_constant_ptr = addr (precision.scale); precision.scale = sf_ptr -> data_name.places_right; precision.precision = sf_ptr -> data_name.item_length; /* Pool the constant that contains scale and precision. */ call cobol_pool (precision_char_constant, 0, /*word boundary, return char offset */ precision_offset); input_ptr = addr (input_buffer (1)); reloc_ptr = addr (reloc_buffer (1)); inst_ptr = addr (ldq_inst); /* Set up the input structure to the addressability utility. */ input_struc_basic.type = 1; input_struc_basic.operand_no = 0; input_struc_basic.lock = 0; input_struc_basic.segno = 3000; /* constant section. */ input_struc_basic.char_offset = precision_offset; input_struc_basic.send_receive = 0; /* Get the address of the pooled constant. */ call cobol_addr (input_ptr, inst_ptr, reloc_ptr); /* Emit the LDQ instruction */ call cobol_emit (inst_ptr, null (), 1); /* Generate code to load the A register with the scale and precision of the target. */ precision.scale = rf_ptr -> data_name.places_right; precision.precision = rf_ptr -> data_name.item_length; /* Pool the constant */ call cobol_pool (precision_char_constant, 0, precision_offset); input_struc_basic.char_offset = precision_offset; /* Get the address of the constant to be loaded into the A register. */ inst_ptr = addr (lda_inst); call cobol_addr (input_ptr, inst_ptr, reloc_ptr); /* Emit the LDA instruction */ call cobol_emit (inst_ptr, null (), 1); /* Emit code to load pr5 with the address of the work space. */ substr (epp5_inst, 1, 3) = "110"b; /* pr6 = stack */ substr (epp5_inst, 4, 15) = bit (fixed (ret_offset, 15), 15); call cobol_emit (addr (epp5_inst), null (), 1); /* NOTE pr3 and pr5 are used here, even though they are always supposed to point at cobol data. However, these pointer registers are needed here to communicate with the cobol operator, and are loaded to values other than pointers to cobol data immediately prior to calling the overpunch operator, so no addressability to cobol data is lost. Immediately upon returning from the operator, pointer registers 3,4, and 5 are reloaded to their expected values. */ /* Emit an instruction to transfer to the cobol overpunch operator */ call cobol_emit (addr (tsp3_inst), null (), 1); /* Reset all registers after the call to the cobol operator */ call cobol_reset_r$after_operator; /***..... if Trace_Bit then call cobol_gen_driver_$Tr_End(MY_NAME);/**/ /**************************************************/ /* 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_type9; %include cobol_addr_tokens; end cobol_opch_op_call;  cobol_open_gen.pl1 05/24/89 1041.5rew 05/24/89 0830.4 285345 /****^ *********************************************************** * * * 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,MCR8091), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8091 cobol_open_gen.pl1 Stop VALUE OF FILE-ID and VALUE OF RETENTION from being ignored. END HISTORY COMMENTS */ /* Modified on 12/10/84 by FCH, [5.3-1], BUG574(phx18559), VALUE OF FILE-ID and RETENTION */ /* Modified on 11/28/84 by FCH, [5.3...], trace added */ /* Modified on 10/28/82 by FCH, [5.1-1], length of attach options string incorrect, BUG544(phx12991) */ /* Modified on 09/30/80 by FCH, [4.4-1], density is 6250 supported, BUG447(TR7681) */ /* Modified on 09/08/79 by FCH, [4.0-2], implement apply attach-options are data-name */ /* Modified on 03/12/79 by FCH, [4.0-1], fix preattach for internal files */ /* Modified on 10/31/78 by witches and hobgoblins, [3.0-3], alt rec keys */ /* Modified on 12/15/77 by FCH, [3.0-2], ioa_ used in NUMS */ /* Modified on 12/13/77 by FCH, [3.0-1], org is ibm-(os,dos) implemented */ /* Modified since version 3.0 */ /* format: style3 */ cobol_open_gen: proc (mp_ptr); dcl mp_ptr ptr; dcl 1 mp based (mp_ptr), 2 n fixed bin, /* always 3 */ 2 pt1 ptr, /* pts to type1 token for OPEN */ 2 pt2 ptr, /* pts to type12 token for the file */ 2 pt3 ptr; /* pts to type19 token */ 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 indirecy bit (1) unal, 3 overlay bit (1) unal, 3 repeat_nogen bit (1) unal; dcl 1 mpout, 2 n fixed bin, 2 pt1 ptr, 2 pt2 ptr, 2 pt3 ptr, 2 pt4 ptr; dcl file_key_desc char (40) based; dcl atd_string char (150) varying init ((150)" "); dcl buf_off fixed bin; dcl ft_max_cra_size fixed bin; dcl ft_work char (6) init ((6)" "); dcl ft_format char (4) var init (" fb "); dcl ft_protect char (5) var init ((5)" "); dcl ft_retain char (11) var init (" -ret none "); dcl ft_force char (5) var init ((5)" "); dcl ft_output_mode char (17) var init ((17)" "); dcl ft_density_num fixed bin init (800); dcl ft_position_num fixed bin init (1); dcl ft_block_num fixed bin init (1); dcl ft_device_num fixed bin init (1); dcl ft_extend char (8) var init ((8)" "); dcl mcode_off fixed bin static init (40); dcl good_tag fixed bin; dcl iocb_tag fixed bin; dcl attach_tag fixed bin; dcl open_tag fixed bin; dcl open_tag1 fixed bin; dcl open_tag2 fixed bin; dcl stream_tag fixed bin; dcl ioname_off fixed bin static init (46); dcl ubits_off fixed bin static init (42); dcl uchars_off fixed bin static init (44); dcl len_off fixed bin static init (52); /*[5.3-1]*/ dcl ft_expire char (9) var init ((9)" "); /*[5.3-1]*/ dcl handler char (12) init ((12)" "); /*[6.3-1]*/ dcl om char (6) var init ((6)" "); dcl argb (5) bit (216) based (addr (args.arg (1))); dcl instr (0:10000) bit (36) based (cobol_$text_base_ptr); dcl char4b char (4) based; dcl char8b char (8) based; dcl (extend_sw, alt_sw, alt_output) bit (1) aligned; dcl arg_ptr ptr; dcl linage_ptr ptr; dcl com2_ptr ptr; dcl ioerror_ptr ptr; dcl ft_ptr ptr; dcl fkey_ptr ptr; dcl basic_ptr ptr; dcl name_ptr ptr; dcl dn_ptr ptr; dcl segname char (36) init (""); declare append_size fixed bin, append_string char (16) var init ((16)" "); dcl namelen fixed bin; dcl atd_len fixed bin; dcl atd_off fixed bin; dcl atd_charoff fixed bin; dcl aloff fixed bin; dcl buflen_off fixed bin; dcl define_detach fixed bin; dcl ioname_len fixed bin; dcl cobol_mode fixed bin; dcl multics_mode fixed bin; dcl file_id char (17) var init ((17)" "); dcl cata_name char (200) var init ((200)" "); dcl key_sz fixed bin; dcl temp fixed bin; dcl utemp fixed bin; dcl (i, typ) fixed bin; /*[5.3-1]*/ dcl clock_ entry returns (fixed bin (71)); /*[5.3-1]*/ dcl date_time_ entry (fixed bin (71), char (*)); /*[5.3-1]*/ dcl f_ifn char (16) var; /*[5.3-1]*/ dcl f_nm char (32) var; /*[5.3-1]*/ dcl fc_nm char (30) var; /*[5.3-1]*/ dcl vf char (12) init ("vfile_"); /*[5.3-1]*/ dcl (cata_name_loc, atd_string_loc, append_string_loc) ptr; /*************************************/ /* INITIALIZATION */ start: /* set up return tags. */ /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(cog);/**/ /*[5.3-1]*/ cata_name_loc = addr (cata_name); atd_string_loc = addr (atd_string); append_string_loc = addr (append_string); ioerror.retry_tag = cobol_$next_tag; ioerror.ns_tag = cobol_$next_tag + 1; good_tag = cobol_$next_tag + 2; iocb_tag = cobol_$next_tag + 3; attach_tag = cobol_$next_tag + 4; open_tag = cobol_$next_tag + 5; open_tag1 = cobol_$next_tag + 6; open_tag2 = cobol_$next_tag + 7; cobol_$next_tag = cobol_$next_tag + 8; /* initialize ioerror structure for cobol_gen_ioerror. */ ioerror_ptr = addr (ioerror); ioerror.cobol_code = 0; ioerror.type1_ptr = mp.pt1; ioerror.is_tag = 0; ioerror.mode = 0; basic_ptr, basic_arg.pt = addr (basic_struct); call cobol_read_ft (mp.pt2 -> fd_token.file_no, ft_ptr); basic_struct.seg = file_table.fsb.seg; basic_struct.offset = file_table.fsb.off; call cobol_iomode (ft_ptr, mp.pt3, cobol_mode, multics_mode, extend_sw); call cobol_alloc$stack (500, 2, aloff); /* for both max arglist and atd */ atd_off = aloff; atd_len = 0; ioname_off = aloff; buflen_off = 80; /*[5.3-1]*/ call cv (addr (file_table.ifn), 16, addr (f_ifn));/*[5.3-1]*/ call cv (addr (fixed_common.prog_name), 30, addr (fc_nm)); /*[5.3-1]*/ call cv (addr (file_table.cat_nm), 200, addr (cata_name)); /*[5.3-1]*/ f_nm = substr (file_table.name, 1, file_table.name_size); /*[5.3-1]*/ if file_table.catalogued = 2 then call test_cata_name; /*************************************/ /* START CODE GENERATION */ start_codegen: /* CHECK CURRENT FILE STATUS */ /* [3.0-3] */ alt_sw = file_table.organization = 3 /* ind */ /* [3.0-3] */ & /* [3.0-3] */ file_table.alternate_keys ^= 0; /* [3.0-3] */ alt_output = alt_sw /* [3.0-3] */ & /* [3.0-3] */ cobol_mode = 61; call cobol_define_tag (ioerror.retry_tag); call cobol_set_fsbptr (ft_ptr); /* generates epp1 pr4|54,* */ if file_table.external /* EXT_OPEN_OP */ then do; call cobol_ioop_util$lda (cobol_mode); /* OPERATOR 30: open_ext_file */ call cobol_call_op (30, good_tag); call cobol_ioop_util$tra (ioerror.ns_tag); call cobol_make_tagref (ioerror.ns_tag, cobol_$text_wd_off - 1, null ()); end; /* OPERATOR 31: open_int_file */ else call cobol_call_op (31, good_tag); call cobol_gen_ioerror (ft_ptr, ioerror_ptr); call cobol_define_tag (good_tag); ioname_len = index (file_table.id, " ") - 1; if ioname_len < 0 then ioname_len = 16; temp = divide (ioname_len + 3, 4, 17, 0) * 4; /* make it easy for cobol_io_util */ call ML (4 * (ioname_off + 4), temp, addr (file_table.id)); call cobol_ioop_util$ldaldx5 (ioname_len, ioname_off); /* generates lda/ldx5 ioname_len/stack_offset */ /* LOCATE OR CREATE IOCB VIA iox_$find_iocb */ /* OPERATOR 32: find_iocb */ call cobol_call_op (32, iocb_tag); call cobol_gen_ioerror (ft_ptr, ioerror_ptr); /* cobol code=7 unable to establish IOCb */ call cobol_define_tag (iocb_tag); /* CHECK CURRENT ATTACHMENT OF IO-SWITCH */ /* Operator 33: check_attach */ /*[4.0-1]*/ call cobol_call_op (33, attach_tag); /* GENERATE ERROR FOR "DEVICE IS UNATTACHED" */ if file_table.device = 7 then do; ioerror.cobol_code = 10; /* error if not attached */ call cobol_gen_ioerror (ft_ptr, ioerror_ptr); call opfin; go to cogx; end; /* PREPARE FOR ATTACHING IO-SWITCH */ atd_charoff = 4 * atd_off; if file_table.ao_len > 0 then typ = 1; else if file_table.attach_options_info ^= "00000" then typ = 2; else typ = 3; go to op (typ); op (1): atd_len = file_table.ao_len; call ML (atd_charoff + 16, atd_len, addr (file_table.ao_string)); go to opx; op (2): /*[4.0-2]*/ call MOVE (file_table.attach_options_info, 16); /*[4.0-2]*/ atd_len = key_sz; go to opx; op (3): /* BUILD ATTACH DESCRIPTION - "vfile_ [-extend]" */ if file_table.catalogued < 2 & file_table.device ^= 5 /* no pathname given */ then do; segname = fc_nm || "." || f_ifn; namelen = length (fc_nm) + length (f_ifn) + 1; if file_table.temp & file_table.device ^= 1 & file_table.device ^= 3 then do; temp = 4 * divide (namelen + 4, 4, 35, 0); call cobol_alloc$stack (80, 2, len_off); uchars_off = len_off + 2; call ML (uchars_off * 4, temp, addr (segname)); /* USE CURRENT PROCESS DIRECTORY || ">" || UNIQUE_SEGNAME */ args.entryno = 0; /* entry constant */ args.arglist_off = uchars_off + 8; argb (1) = unspec (name_arg); argb (2) = unspec (temp_arg); args.n = 2; arg.pt (1) = addr (get_pdir_vstring); arg.off1 (2) = atd_off + 7; arg.repeat_nogen (2) = "0"b; call cobol_iocall (addr (args), null ()); call cobol_set_fsbptr (ft_ptr); call cobol_open_util$make_pdir_path (atd_off + 7, len_off, uchars_off, namelen); atd_len = 202; end; else do; /* USE UNIQUE_SEGNAME ONLY (vfile_ will expand it at execution) */ atd_len = namelen; call ML (atd_charoff + 28, atd_len, addr (segname)); end; end; else do; /* cat name specified */ /* USE PATHNAME GIVEN */ if file_table.catalogued = 2 /* given as a literal */ then do; atd_len = 4 * divide (length (cata_name) + 3, 4, 35, 0); call ML (atd_charoff + 28, atd_len, addr (cata_name_loc -> vch.ch)); end; else if file_table.catalogued = 3 then do; /* given as a data_name */ if file_table.device = 5 then do; atd_type9.file_key_info.fb (4) = 6; atd_len = 6; end; else atd_len = 200; /*[4.0-2]*/ call MOVE (file_table.cat_id_info, 28); end; end; if file_table.device = 5 then do; atd_len = atd_len + 12; if file_table.catalogued < 2 | file_table.temp then ft_work = "work "; if multics_mode = 5 then ft_output_mode = " -cr "; ft_max_cra_size = file_table.max_cra_size; if file_table.block_desc = 1 then ft_block_num = divide (file_table.block_max, ft_max_cra_size, 17, 0); if file_table.spanned_recs then do; ft_format = " s "; ft_max_cra_size = ft_max_cra_size + 5; end; else if file_table.variable then do; ft_format = " d "; ft_max_cra_size = ft_max_cra_size + 4; end; else ft_format = " f "; if file_table.block_desc ^= 0 then substr (ft_format, 3, 1) = "b"; if file_table.open_out | file_table.open_ext | multics_mode = 5 then ft_protect = " -rg "; if file_table.tape.protect then ft_protect = ""; if file_table.tape.retain then ft_retain = " -ret all "; if file_table.tape.force then ft_force = " -fc "; if file_table.tape.density then ft_density_num = 1600; /*[4.4-1]*/ else if file_table.tape.den_6250 then ft_density_num = 6250; if file_table.mult_position_no > 0 then ft_position_num = file_table.mult_position_no; if file_table.block_desc = 0 then ft_block_num = ft_max_cra_size; else if file_table.block_desc = 1 then if file_table.spanned_recs then ft_block_num = file_table.block_max; else ft_block_num = ft_block_num * ft_max_cra_size; else ft_block_num = file_table.block_max * ft_max_cra_size; if file_table.output_mode < 5 then do; go to o_m (file_table.output_mode); o_m (1): om = " -gen "; /* generation */ go to omx; o_m (2): om = " -mod "; /* modification */ go to omx; o_m (3): o_m (4): /* replacement */ call set_replacement_info; go to omx; o_m (0): omx: end; if file_table.tape_device > 0 then if file_table.tape_device = 1 then ft_device_num = file_table.tape_device_num; else ; else ft_device_num = 1; if extend_sw then do; ft_extend = " -extend"; ft_output_mode = ""; /* extend and create don't mix. */ end; /*[5.3-1]*/ if file_table.retention_info ^= "00000" then call set_retention_info; /*[5.3-1]*/ if file_table.catalogued = 2 /*[5.3-1]*/ then if file_id = "" /*[5.3-1]*/ then call set_file_id; /*[5.3-1]*/ else ; /*[5.3-1]*/ else call set_file_id; /*[5.3-1]*/ atd_string = ft_work; /*[5.3-1]*/ if file_table.label_format = 1 then call set_atd1; else call set_atd2; /*[5.3-1]*/ temp = length (atd_string); call ML (atd_charoff + 16 + atd_len, temp, addr (atd_string_loc -> vch.ch)); /*[5.3-1]*/ if file_table.org_qual ^= 5 & file_table.org_qual ^= 7 & file_table.label_format = 1 /*[5.3-1]*/ then handler = "tape_ansi_ "; /*[5.3-1]*/ else handler = "tape_ibm_ "; /*[5.3-1]*/ call ML (atd_charoff + 16, 12, addr (handler)); /*[5.3-1]*/ atd_len = atd_len + length (atd_string); end; else do; /*[3.0-3]*/ if file_table.dupl_alt | extend_sw /*[3.0-3]*/ then do; if file_table.dupl_alt & extend_sw /*[3.0-3]*/ then append_string = " -extend -dup_ok"; /*[3.0-3]*/ else /*[3.0-3]*/ if extend_sw /*[3.0-3]*/ then append_string = " -extend"; /*[3.0-3]*/ else append_string = " -dup_ok"; /*[3.0-3]*/ /*[3.0-3]*/ append_size = length (append_string); /*[3.0-3]*/ atd_len = atd_len + append_size; /*[3.0-3]*/ /*[3.0-3]*/ call ML (atd_charoff + atd_len + 20, append_size, addr (append_string_loc -> vch.ch)); /**/ end; call ML (atd_charoff + 16, 12, addr (vf)); atd_len = atd_len + 12; end; go to opx; opx: /* ATTACH THE IO-SWITCH VIA iox_$attach_iocb */ temp = divide (atd_charoff, 4, 17, 0); call cobol_ioop_util$ldaldx5 (atd_len, temp); if file_table.ao_len > 0 then temp = 14; /* Unable to attach I/O switch with specified options */ else if file_table.catalogued < 2 then temp = 13; /* Unable to attach I/O switch */ else temp = 51; /* - possible invalid catalogue-name */ call opfin; go to cogx; opfin: proc; /* operator 34: attach_iocb */ call cobol_call_op (34, attach_tag); /*ATTACH_IOCB_OP*/ ioerror.cobol_code = temp; call cobol_gen_ioerror (ft_ptr, ioerror_ptr); call cobol_define_tag (attach_tag); /* OPEN THE FILE VIA iox_$open */ /* OPERATOR37(check_file) */ call cobol_call_op (37, open_tag1); /*CHECK_NONCOBOL_OP*/ if alt_output | cobol_mode = 59 | cobol_mode = 63 /* open output; close; then open update */ then do; /* OPERATOR36(open_close_file) */ call cobol_call_op (36, open_tag2); /*OPEN_OP output*/ call cobol_gen_ioerror (ft_ptr, ioerror_ptr); end; call cobol_define_tag (open_tag2); call cobol_set_fsbptr (ft_ptr); if (multics_mode = 6 & extend_sw = "1"b & file_table.device = 5) then multics_mode = 5; /* [3.0-3] */ if alt_output then multics_mode = 10; call cobol_ioop_util$open_clean_up (ft_ptr, cobol_mode, multics_mode); /* operator 35: open_file */ call cobol_call_op (35, open_tag1); if alt_output | multics_mode = 10 | (multics_mode = 13 & cobol_mode < 48) | multics_mode = 7 then do; /* OPEN FILE VIA iox_$open FOR INDEXED_SEQUENTIAL_OUTPUT or DIRECT OUTPUT */ temp = multics_mode - 1; if temp = 6 then temp = 5; /* CLOSE FILE VIA iox_$close */ call cobol_ioop_util$set_stz; call cobol_set_fsbptr (ft_ptr); call cobol_ioop_util$open_clean_up (ft_ptr, cobol_mode, temp); /* OPERATOR 29: close_op_file */ call cobol_call_op (29, open_tag2); end; call cobol_gen_ioerror (ft_ptr, ioerror_ptr); call cobol_define_tag (open_tag1); /* [3.0-3] */ if alt_sw /* [3.0-3] */ then do; call cobol_io_util$file_desc (file_table.file_desc_1_offset); /* [3.0-3] */ call cobol_call_op (78, 0); /* [3.0-3] */ call cobol_set_fsbptr (ft_ptr); /* [3.0-3] */ end; /* RECORD OPENING IN FSB RUN_UNIT CONTROL_SEG */ if file_table.linage /* LINAGE initialization */ then do; call cobol_set_fsbptr (ft_ptr); call cobol_read_rand (1, file_table.linage_info, linage_ptr); stream_tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; if linage_rec.body > 0 then 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); 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 if linage_rec.footing ^= 5 then call linage_init (linage_rec.footing, 93 * 4); else 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); else 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); 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); call cobol_alloc$stack (120, 2, buf_off); call cobol_ioop_util$disp (buf_off); end; else call cobol_ioop_util$set_fsb (0, 94); if linage_rec.bottom > 0 then 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); else call cobol_ioop_util$set_fsb (0, 95); /* OPERATOR24(set_line_file_status) */ call cobol_file_util$open (mp.pt2, 1); end; /* OPERATOR25(set_file_status) */ else call cobol_file_util$open (mp.pt2, 0); call cobol_reg_manager$after_op (4095 + ioerror.cobol_code); call cobol_gen_ioerror$finish_up (ft_ptr, ioerror_ptr); end; cogx: /***..... if Trace_Bit then call cobol_gen_driver_$Tr_End(cog);/**/ return; set_atd1: proc; /* STANDARD LABELS */ /*[5.3-1]*/ atd_string = atd_string || " -nm " || file_id; /*[5.3-1]*/ atd_string = atd_string || om; /*[5.3-1]*/ atd_string = atd_string || ft_retain || ft_force || ft_extend; /*[5.3-1]*/ atd_string = atd_string || " -rec " || NUMS (ft_max_cra_size); /*[5.3-1]*/ atd_string = atd_string || ft_output_mode; /*[5.3-1]*/ call set_atd; end; set_atd2: proc; /* NO LABELS */ /*[5.3-1]*/ ft_format = " u "; /*[5.3-1]*/ call set_atd; end; set_atd: proc; /* initialize attach descr */ /*[5.3-1]*/ if ft_expire ^= "" then atd_string = atd_string || " -exp " || ft_expire; /*[5.3-1]*/ atd_string = atd_string || " -fmt " || ft_format; /*[5.3-1]*/ if ft_protect ^= "" then atd_string = atd_string || ft_protect; /*[5.3-1]*/ atd_string = atd_string || " -den " || NUMS (ft_density_num); /*[5.3-1]*/ atd_string = atd_string || " -nb " || NUMS (ft_position_num); /*[5.3-1]*/ atd_string = atd_string || " -bk " || NUMS (ft_block_num); /*[5.3-1]*/ atd_string = atd_string || " -dv " || NUMS (ft_device_num); /*[5.3-1]*/ if file_table.org_qual = 5 then atd_string = atd_string || " -dos "; end; ML: proc (off, len, str_loc); /*[5.3-1]*/ dcl (off, len) fixed bin, str_loc ptr; /*[5.3-1]*/ dcl str char (1024) based (str_loc); /*[5.3-1]*/ call cobol_io_util$move_lit ("110"b, off, len, substr (str, 1, len)); end; get_info: proc (ch5); /*[5.3-1]*/ dcl ch5 char (5); /*[5.3-1]*/ call cobol_read_rand (1, ch5, fkey_ptr); end; set_file_id: proc; /* FILE-ID clause */ /*[5.3-1]*/ if file_table.file_id_info = "00000" /* not present */ /*[5.3-1]*/ then do; if file_table.mult_position_no = 0 /*[5.3-1]*/ then file_id = f_ifn; /*[5.3-1]*/ else file_id = f_nm; /*[5.3-1]*/ return; /*[5.3-1]*/ end; /*[5.3-1]*/ call get_info (file_table.file_id_info); /*[5.3-1]*/ if file_key.key_type = 113 /* literal */ /*[5.3-1]*/ then do; file_id = substr (file_key.name, 1, file_key.name_size); /*[5.3-1]*/ return; /*[5.3-1]*/ end; end; set_retention_info: proc; /* RETENTION cluse */ /*[5.3-1]*/ dcl tm fixed bin (71); /*[5.3-1]*/ dcl dt char (32); /*[5.3-1]*/ call get_info (file_table.retention_info); /*[5.3-1]*/ if file_key.key_type = 114 /* literal */ /*[5.3-1]*/ then do; tm = clock_ (); /*[5.3-1]*/ tm = tm + 24 * 3600 * 1000000 * fixed (substr (file_key.name, 1, file_key.name_size)); /*[5.3-1]*/ call date_time_ (tm, dt); /*[5.3-1]*/ ft_expire = substr (dt, 1, 9); /*[5.3-1]*/ end; end; set_replacement_info: proc; /* REPLACEMENT phrase */ /*[5.3-1]*/ om = " -rpl "; /*[5.3-1]*/ if file_table.replacement_info = "00000" /* no phrase */ /*[5.3-1]*/ then do; ft_output_mode = f_ifn; /*[5.3-1]*/ return; /*[5.3-1]*/ end; /*[5.3-1]*/ call get_info (file_table.replacement_info); /*[5.3-1]*/ if file_key.key_type = 109 /* literal */ /*[5.3-1]*/ then do; ft_output_mode = substr (file_key.name, 1, file_key.name_size); /*[5.3-1]*/ return; /*[5.3-1]*/ end; end; cv: proc (fch_loc, sz, vch_loc); /* convert to char varying */ /*[5.3-1]*/ dcl (fch_loc, vch_loc) ptr, (i, sz) fixed bin; /*[5.3-1]*/ dcl fch char (2048) based (fch_loc); /*[5.3-1]*/ dcl vch char (2048) varying based (vch_loc); /*[5.3-1]*/ do i = sz by -1 to 1; /*[5.3-1]*/ if substr (fch, i, 1) ^= " " /*[5.3-1]*/ then do; vch = substr (fch, 1, i); /*[5.3-1]*/ return; /*[5.3-1]*/ end; /*[5.3-1]*/ end; /*[5.3-1]*/ vch = ""; end; test_cata_name: proc; /* test for ` in cata name (obsolete) */ /*[5.3-1]*/ dcl (l, i) fixed bin; /*[5.3-1]*/ l = length (cata_name); if l = 0 then return; /*[5.3-1]*/ i = index (cata_name, "`"); if i = 0 then return; /*[5.3-1]*/ if i = l /*[5.3-1]*/ then do; if l = 1 /*[5.3-1]*/ then cata_name = ""; /*[5.3-1]*/ else cata_name = substr (cata_name, 1, l - 1); /*[5.3-1]*/ return; /*[5.3-1]*/ end; /*[5.3-1]*/ if i = 1 /*[5.3-1]*/ then do; file_id = substr (cata_name, 2); /*[5.3-1]*/ cata_name = ""; /*[5.3-1]*/ return; /*[5.3-1]*/ end; /*[5.3-1]*/ file_id = substr (cata_name, i + 1); /*[5.3-1]*/ cata_name = substr (cata_name, 1, i - 1); 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.pt1; 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; MOVE: proc (ch5, offset); /*[4.0-2]*/ declare ch5 char (5), offset fixed bin; /*[4.0-2]*/ declare p ptr; /*[4.0-2]*/ declare 1 desc based (p), /*[4.0-2]*/ 2 linkage fixed bin, /*[4.0-2]*/ 2 file_num fixed bin, /*[4.0-2]*/ 2 size_rtn fixed bin, /*[4.0-2]*/ 2 item_length fixed bin (24), /*[4.0-2]*/ 2 places_left fixed bin, /*[4.0-2]*/ 2 places_right fixed bin; /*[4.0-2]*/ call cobol_read_rand (1, ch5, fkey_ptr); /*[4.0-2]*/ mpout.n = 4; /*[4.0-2]*/ mpout.pt1 = mp.pt1; /*[4.0-2]*/ mpout.pt2 = addr (catid_type9); /*[4.0-2]*/ mpout.pt3 = addr (atd_type9); /*[4.0-2]*/ mpout.pt4 = addr (type19); /*[4.0-2]*/ unspec (catid_type9.file_key_info) = unspec (file_key.desc); /*[4.0-2]*/ mpout.pt3 -> data_name.offset = atd_charoff + offset; /*[4.0-2]*/ call cobol_move_gen (addr (mpout)); /*[4.0-2]*/ p = addr (file_key.desc); /*[5.1-1]*/ key_sz = desc.item_length; end; NUMS: proc (v) returns (char (13) var); declare v fixed bin; /*[3.0-2]*/ declare ioa_$rsnnl entry options (variable); /*[3.0-2]*/ declare S char (13) varying, len fixed bin; /*[3.0-2]*/ call ioa_$rsnnl ("^d", S, len, v); /*[3.0-2]*/ return (substr (S, 1, len)); /*[3.0-2]*/ end; /*[5.3-1]*/ dcl 1 vch based, /*[5.3-1]*/ 2 sz fixed bin (35), /*[5.3-1]*/ 2 ch char (1); /***..... dcl cog char(14) init("COBOL_OPEN_GEN");/**/ /***..... 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); /**/ /* STATIC DECLARATIONS */ dcl 1 basic_arg static, 2 pt ptr init (null ()), /* initialized to address of basic structure */ 2 zeros bit (144) init (""b); dcl 1 name_arg static, 2 pt ptr init (null ()), /* set each time to pt to varying char string containing name of program to be called */ 2 type fixed bin init (6), 2 zeros bit (108) init (""b); dcl 1 temp_arg static, 2 pt ptr init (null ()), /* always null */ 2 type fixed bin init (3), 2 zeros bit (108) init (""b); dcl 1 value_arg static, 2 pt ptr init (null ()), /* always null */ 2 type fixed bin init (1), 2 zeros bit (108) init (""b); dcl 1 upper_value_arg static, 2 pt ptr init (null ()), /* always null */ 2 type fixed bin init (2), 2 zeros bit (108) init (""b); dcl 1 status_arg static, 2 pt ptr init (null ()), /* always null */ 2 type fixed bin init (3), 2 off1 fixed bin init (40), 2 zeros bit (72) init (""b); dcl 1 pr1_struct static, 2 pr1 fixed bin init (1), 2 pointer_no bit (3), 2 lock fixed bin init (0), 2 switch fixed bin init (0), 2 segno fixed bin, 2 offset fixed bin, 2 reset fixed bin; dcl 1 x5_struct static, 2 x5 fixed bin init (15), 2 reg_no bit (4), 2 lock fixed bin init (0), 2 already_there fixed bin, 2 contains fixed bin init (0), 2 null_ptr ptr init (null ()), 2 fill bit (18) unaligned init ((18)"0"b), 2 literal bit (18) unaligned; dcl 1 aq_struct static, 2 aq fixed bin init (3), 2 reg_no bit (4), 2 lock fixed bin init (0), 2 already_there fixed bin, 2 contains fixed bin init (0), 2 null_ptr ptr init (null ()), 2 fill bit (18) unaligned init ((18)"0"b), 2 literal bit (18) unaligned; 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 1 atd_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 fb (6) fixed bin init (0, 0, 0, 200, 0, 0), 3 flags1 bit (36) init ("000000100100000000010000000100000000"b), 3 flags2 bit (36) init (""b), 3 seg fixed bin init (1000), 3 off fixed bin, 2 fill2 (7) fixed bin init (0, 0, 0, 0, 0, 0, 0); dcl 1 catid_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 fb (6) fixed bin init (0, 0, 0, 0, 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 comp6_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 ("010000100100001001000000000000000000"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 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 type19 static, 2 wd0 fixed bin init (38), 2 wd1 fixed bin init (0), 2 wd2 fixed bin init (0), 2 wd3 fixed bin init (19), 2 wd4 fixed bin init (18), /* verb number */ 2 e fixed bin init (1), /* one operand after TO */ 2 h fixed bin, 2 j fixed bin, 2 a bit (3), 2 b bit (1), 2 c bit (1), 2 d bit (2), 2 f bit (2), 2 g bit (2), 2 k bit (5); dcl 1 ioerror static, 2 cobol_code fixed bin, 2 retry_tag fixed bin, 2 is_tag fixed bin, 2 ns_tag fixed bin, 2 type1_ptr ptr, 2 mode fixed bin; dcl unique_bits_vstring char (12) varying static init ("unique_bits_"); dcl unique_chars_vstring char (13) varying static init ("unique_chars_"); dcl get_pdir_vstring char (9) varying static init ("get_pdir_"); /* EXTERNAL ENTRY NAMES */ dcl cobol_ioop_util$set_stz entry; dcl cobol_make_tagref entry (fixed bin, fixed bin, ptr); dcl cobol_ioop_util$disp entry (fixed bin); dcl cobol_ioop_util$lda entry (fixed bin); dcl cobol_ioop_util$tra entry (fixed bin); dcl cobol_ioop_util$open_clean_up entry (ptr, fixed bin, fixed bin); dcl cobol_ioop_util$ldaldx5 entry (fixed bin, fixed bin); dcl cobol_ioop_util$set_fsb entry (fixed bin (31), fixed bin); dcl cobol_gen_ioerror entry (ptr, ptr); dcl cobol_gen_ioerror$finish_up entry (ptr, ptr); dcl cobol_call_op entry (fixed bin, fixed bin); dcl cobol_reg_manager$after_op entry (fixed bin); dcl cobol_set_fsbptr entry (ptr); dcl cobol_alloc$stack entry (fixed bin, fixed bin, fixed bin); dcl cobol_read_ft entry (fixed bin, ptr); dcl cobol_read_rand entry (fixed bin, char (5), ptr); dcl cobol_define_tag entry (fixed bin); dcl cobol_iomode entry (ptr, ptr, fixed bin, fixed bin, bit (1) aligned); /* sub-generators */ dcl cobol_move_gen entry (ptr); dcl cobol_file_util$open entry (ptr, fixed bin); dcl cobol_io_util$move_lit entry (bit (3) aligned, fixed bin, fixed bin, char (*)); dcl cobol_iocall entry (ptr, ptr); dcl cobol_io_util$move entry (bit (3) aligned, fixed bin, fixed bin, bit (3) aligned, fixed bin, fixed bin); dcl cobol_io_util$file_desc entry (fixed bin (24)); dcl cobol_open_util$make_pdir_path entry (fixed bin, fixed bin, fixed bin, fixed bin); /* BUILTIN FUNCTIONS */ /***** Declaration for builtin function *****/ dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index) builtin; %include cobol_file_table; %include cobol_file_key; %include cobol_linage_rec; %include cobol_type1; %include cobol_type9; %include cobol_type12; %include cobol_type19; %include cobol_fixed_common; %include cobol_ext_; %include cobol_; end cobol_open_gen;  cobol_open_util.pl1 05/24/89 1041.5rew 05/24/89 0830.4 168534 /****^ *********************************************************** * * * 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_open_util.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 01/29/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_open_util: proc; dcl 1 ioerror based (ioerror_ptr), 2 lineno fixed bin, 2 restartad fixed bin, 2 forward_tag fixed bin, 2 no_error_tag fixed bin, 2 no_error_ptr ptr, 2 unopen fixed bin, 2 special_tag fixed bin, 2 special_ptr ptr, 2 error_ptr ptr; dcl check_noncobol_instr (7) bit (36) static init ("010000000000010000010011111001000000"b, /* ldaq pr2|20 (iocb.open_descrip_ptr)*/ "000000000000000000110111111000000100"b, /* eraq [nullptr],ic */ "000000000000000000011111111000000100"b, /* anaq [ptrmask],ic */ "000000000000000100110000000000000100"b, /* tze 4,ic (goto open) */ "111111111111111111010011101000000011"b, /* lda -1,du (noncobol open status) */ "001000000000000010111101101001000000"b, /* sta pr1|2 (fsb.open_mode) */ "000000000000000000111001000000000100"b); /* tra */ dcl ext_open_instr (4) bit (36) static init ("001000000000000010010011101001000000"b, /* lda pr1|2 (fsb.open_mode) */ "000000000000000000110000100100000100"b, /* tmoz [bypass_error],ic */ "000000000000000000001001101000000111"b, /* cmpa [cobol_mode],dl */ "000000000000000000110000000000000000"b); /* tze */ dcl int_open_instr (2) bit (36) static init ("001000000000000010010011100001000000"b, /* szn pr1|2 (fsb.open_mode) */ "000000000000000000110000000000000100"b); /* tze [bypass_error],ic */ dcl ext_close_instr (2) bit (36) static init ("001000000000000010010011100001000000"b, /* szn pr1|2 (fsb.open_mode) */ "000000000000000000110000100100000100"b); /* tmoz */ dcl int_close_instr (2) bit (36) static init ("001000000000000010010011100001000000"b, /* szn pr1|2 (fsb.open_mode) */ "000000000000000000110000001000000100"b); /* tnz [bypass_error],ic */ dcl check_attach_instr (5) bit (36) static init ("001000000000000000011101010001010000"b, /* epp2 pr1|0,* (fsb.iocb_ptr) */ "010000000000001100010011111001000000"b, /* ldaq pr2|14 (iocb.attach_descrip_ptr)*/ "000000000000000000110111111000000100"b, /* eraq [nullptr],ic */ "000000000000000000011111111000000100"b, /* anaq [ptrmask],ic */ "000000000000000000110000001000000100"b); /* tnz ,ic */ dcl check_reattach_instr (9) bit (36) static init ("001000000000000000011101010001010000"b, /* epp2 pr1|0,* (fsb.iocb_ptr) */ "010000000000001100010011111001000000"b, /* ldaq pr2|14 (iocb.attach_descrip_ptr)*/ "000000000000000000110111111000000100"b, /* eraq [nullptr],ic */ "000000000000000000011111111000000100"b, /* anaq [ptrmask],ic */ "000000000000000000110000000000000100"b, /* tze ,ic */ "010000000000010000010011111001000000"b, /* ldaq pr2|20 (iocb.open_descrip_ptr)*/ "000000000000000000110111111000000100"b, /* eraq [nullptr],ic */ "000000000000000000011111111000000100"b, /* anaq [ptrmask],ic */ "000000000000000000110000000000000100"b); /* tze ,ic */ dcl pdir_path_instr (15) bit (36) static init ("000000000000111110010011101000000111"b, /* lda 076,dl (">") */ "110000000000000000111101101001000000"b, /* sta pr6|[uchars_off-1] */ "000000000000000011001010100101000000"b, /* scm (with zero mask) */ "110000000000000000000000000010101000"b, /* desc1 pr6|[pname_off](0)->168 */ "000100000000100000000000000000000000"b, /* desc2 "/b/b" */ "110000000000000000000000000001000000"b, /* desc3 pr6|[len_off] */ "000000000000000011110000111000000100"b, /* ttf 3,ic */ "000000000010100000010011101000000111"b, /* lda 240,dl (168, pname length) */ "110000000000000000111101101001000000"b, /* sta pr6|[len_off] */ "110000000000000000111010101001000000"b, /* lxl5 pr6|[len_off] */ "000000000011001010010011101000000111"b, /* lda 312,dl (202, atd max len) */ "110000000000000000001111101001000000"b, /* sba pr6|[len_off] */ "000100000001101101001000000101000000"b, /* mlr (with blank fill) */ "110000000000000000110000000000000000"b, /* desc1 pr6|[uchars_off-1](3)->[namelen+1] */ "110000000000000000000000000000000101"b); /* desc2 pr6|[pname_off](X5)->AL */ dcl fsb_open_mode_instr (2) bit (36) static init ("000000000000000000010011101000000111"b, /* lda [cobol_mode],dl */ "001000000000000010111101101001000000"b); /* sta pr1|2 (fsb.open_mode) */ dcl fsb_close_mode_instr bit (36) static init ("001000000000000010100101000001000000"b); /* stz pr1|2 (fsb.open_mode) */ dcl fsb_name_instr (4) bit (36) static init ("100000000000010010111010101001000000"b, /* lxl5 pr4|22 (stat.id_len) */ "000100000001000000001000000101100000"b, /* mlr (with blank fill) */ "100000000000010011000000000000001101"b, /* desc1 pr4|23(0)->X5 (stat.id) */ "001000000001000111000000000001000001"b); /* desc2 pr1|107(0)->65 (fsb.open_name)*/ dcl fsb_name_reloc (8) bit (5) aligned static init ("11001"b, ""b, ""b, ""b, "11001"b, ""b, ""b, ""b); dcl fsb_relkey_instr bit (36) static init ("001000000000000101100101000001000000"b); /* stz pr1|5 (fsb.relkey) */ dcl fsb_keylen_instr bit (36) static init ("001000000000000110100101000001000000"b); /* stz pr1|6 (fsb.keylen_sw) */ dcl fsb_linage_counter_instr (2) bit (36) static init ("000000000000000000010011111000000100"b, /* ldaq ["00000001"],ic */ "001000000001011000010011111001000000"b); /* staq pr1|130 (fsb.linage_counter)*/ dcl fsb_optional_instr (2) bit (36) static init ("001111111111111111010010101000000011"b, /* ldx5 177777,du */ "001000000001011010011100101001000000"b); /* ansx5 pr1|132 (fsb.optional) */ dcl fsb_opened_ext_instr (2) bit (36) static init ("001000000000000000010010101000000011"b, /* ldx5 100000,du */ "001000000001011010010100101001000000"b); /* orsx5 pr1|132 (fsb.opened) */ dcl fsb_opened_int_instr (2) bit (36) static init ("001100000000000000010010101000000011"b, /* ldx5 140000,du */ "001000000001011010010100101001000000"b); /* orsx5 pr1|132 (fsb.opened,internal) */ dcl noentry_instr (4) bit (36) static init ("110000000000000000010011101001000000"b, /* lda pr6|mcode_off */ "000000000000000000110000000000000100"b, /* tze [bypass_error],ic */ "100000000000000000001001101001010000"b, /* cmpa pr4|error_table_$noentry],* */ "000000000000000000110000000000000100"b); /* tze [open_output],ic */ /* 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 noentry_reloc (8) bit (5) aligned static init (""b, ""b, ""b, ""b, "10100"b, ""b, ""b, ""b); dcl tra_instr bit (36) static init ("000000000000000000111001000000000100"b); /* tra [somewhere],ic */ dcl text (0:100000) bit (36) based (cobol_$text_base_ptr); dcl temp fixed bin; dcl utemp fixed bin; dcl off fixed bin; dcl i fixed bin; dcl ic fixed bin; dcl patch_ic fixed bin; dcl nulloff fixed bin; dcl maskoff fixed bin; dcl save_ic fixed bin static; dcl save_retry fixed bin static; dcl sp_uchars bit (18) aligned; dcl sp_pname bit (18) aligned; dcl sp_len bit (18) aligned; dcl cobol_set_fsbptr entry (ptr); dcl cobol_pool entry (char (*), fixed bin, fixed bin); dcl cobol_make_tagref entry (fixed bin, fixed bin, ptr); dcl cobol_make_fixup entry (ptr); dcl cobol_emit entry (ptr, ptr, fixed bin); dcl cobol_make_link$type_4 entry (fixed bin, char (*)); dcl cobol_ioerror entry (ptr, fixed bin, fixed bin, ptr); dcl cobol_ioerror$preset entry (ptr); dcl cobol_process_error entry (fixed bin, fixed bin, fixed bin); dcl cobol_io_util$move_lit entry (bit (3) aligned, fixed bin, fixed bin, char (*)); start: /*************************************/ check_noncobol: entry (ft_ptr, define_open, ioerror_ptr, ft_ptr); start_check_noncobol: temp = cobol_$text_wd_off - define_open; if file_table.external | file_table.ao_len > 0 then do; if file_table.ao_len ^> 0 then do; /* an ext file with no attach-options; if attach made here, can bypass noncobol open check */ temp = temp + 1; substr (tra_instr, 1, 18) = "000000000000001000"b; call cobol_emit (addr (tra_instr), null (), 1); end; else do; /* an int or ext file with attach-options; must reset pr1 and pr2 in case attach made here */ call cobol_set_fsbptr (ft_ptr); call cobol_emit (addr (check_attach_instr (1)), null (), 1); end; call pool_nullptr; utemp = nulloff - 1; substr (check_noncobol_instr (2), 1, 18) = substr (unspec (utemp), 19, 18); utemp = maskoff - 2; substr (check_noncobol_instr (3), 1, 18) = substr (unspec (utemp), 19, 18); call cobol_make_tagref (ioerror.forward_tag, cobol_$text_wd_off + 6, addr (check_noncobol_instr (7))); call cobol_emit (addr (check_noncobol_instr), null (), 7); end; if define_open ^= 0 then substr (text (define_open), 1, 18) = substr (unspec (temp), 19, 18); exit_chexk_nonocobol: return; /*************************************/ check_open: entry (ft_ptr, cobol_mode, ioerror_ptr); dcl ft_ptr ptr; /* pointer to the file_table */ dcl ioerror_ptr ptr; /* ptr to ioerror structure */ dcl cobol_mode fixed bin; /* cobol open mode */ start_check_open: call cobol_ioerror$preset (ft_ptr); call cobol_set_fsbptr (ft_ptr); patch_ic = cobol_$text_wd_off + 1; if cobol_mode = 0 then do; /* check for close */ if file_table.external then do; call cobol_make_tagref (ioerror.forward_tag, cobol_$text_wd_off + 1, addr (ext_close_instr (2))); call cobol_emit (addr (ext_close_instr), null (), 2); i = 0; end; else do; call cobol_emit (addr (int_close_instr), null (), 2); i = 17; end; end; else if cobol_mode > 0 then do; /* check for open request */ if file_table.external then do; substr (ext_open_instr (3), 1, 18) = substr (unspec (cobol_mode), 19, 18); call cobol_make_tagref (ioerror.forward_tag, cobol_$text_wd_off + 3, addr (ext_open_instr (4))); call cobol_emit (addr (ext_open_instr), null (), 4); i = 8; end; else do; call cobol_emit (addr (int_open_instr), null (), 2); i = 9; end; end; else do; /* check for other io request */ call cobol_emit (addr (int_close_instr), null (), 2); i = 24; end; if i ^= 0 then do; utemp = ioerror.unopen; if i = 24 then ioerror.unopen = 1; call cobol_ioerror (ft_ptr, i, 0, ioerror_ptr); ioerror.unopen = utemp; utemp = cobol_$text_wd_off - patch_ic; substr (text (patch_ic), 1, 18) = substr (unspec (utemp), 19, 18); end; exit_chexk_open: return; /*************************************/ check_attach: entry (ft_ptr, define_open); dcl define_open fixed bin; /* instr loc of "tra if attached" */ start_check_attach: call cobol_set_fsbptr (ft_ptr); call pool_nullptr; utemp = nulloff - 2; substr (check_attach_instr (3), 1, 18) = substr (unspec (utemp), 19, 18); utemp = maskoff - 3; substr (check_attach_instr (4), 1, 18) = substr (unspec (utemp), 19, 18); define_open = cobol_$text_wd_off + 4; call cobol_emit (addr (check_attach_instr), null (), 5); exit_check_attach: return; /*************************************/ check_reattach: entry (ft_ptr, define_attach, define_detach); dcl define_attach fixed bin; /* instr loc of "tra if not attached" */ dcl define_detach fixed bin; /* instr loc of "tra if not open" */ start_check_reattach: call cobol_set_fsbptr (ft_ptr); call pool_nullptr; utemp = nulloff - 2; substr (check_reattach_instr (3), 1, 18) = substr (unspec (utemp), 19, 18); utemp = maskoff - 3; substr (check_reattach_instr (4), 1, 18) = substr (unspec (utemp), 19, 18); utemp = nulloff - 6; substr (check_reattach_instr (7), 1, 18) = substr (unspec (utemp), 19, 18); utemp = maskoff - 7; substr (check_reattach_instr (8), 1, 18) = substr (unspec (utemp), 19, 18); define_attach = cobol_$text_wd_off + 4; define_detach = cobol_$text_wd_off + 8; call cobol_emit (addr (check_reattach_instr), null (), 9); exit_check_reattach: return; /*************************************/ make_pdir_path: entry (pname_off, len_off, uchars_off, namelen); dcl pname_off fixed bin; /* wd offset in stack of space for pname */ dcl len_off fixed bin; /* wd offset in stack of space for pname length */ dcl uchars_off fixed bin; /* wd offset in stack of location of uchars char(25) */ /* preceding word from uchars_off must be available */ dcl namelen fixed bin; /* length of segment portion of name */ start_make_pdir_path: utemp = uchars_off - 1; sp_uchars = "110"b || substr (unspec (utemp), 22, 15); sp_pname = "110"b || substr (unspec (pname_off), 22, 15); sp_len = "110"b || substr (unspec (len_off), 22, 15); substr (pdir_path_instr (2), 1, 18) = sp_uchars; substr (pdir_path_instr (4), 1, 18) = sp_pname; substr (pdir_path_instr (6), 1, 18) = sp_len; substr (pdir_path_instr (9), 1, 18) = sp_len; substr (pdir_path_instr (10), 1, 18) = sp_len; substr (pdir_path_instr (12), 1, 18) = sp_len; substr (pdir_path_instr (14), 1, 18) = sp_uchars; utemp = namelen + 1; /* for the leading > */ substr (pdir_path_instr (14), 28, 9) = substr (unspec (utemp), 28, 9); substr (pdir_path_instr (15), 1, 18) = sp_pname; call cobol_emit (addr (pdir_path_instr), null (), 15); exit_make_pdir_path: return; /*************************************/ check_noentry1: entry (ft_ptr, cobol_code, ioerror_ptr, mcode_off); dcl cobol_code fixed bin; dcl mcode_off fixed bin; save_retry = ioerror.restartad; save_ic = cobol_$text_wd_off + 1; patch_ic = cobol_$text_wd_off + 3; substr (noentry_instr (1), 4, 15) = substr (unspec (mcode_off), 22, 15); call cobol_make_link$type_4 (off, "error_table_$noentry"); if fixed_common.options.profile then do; fixup_directive.location.offset = cobol_$text_wd_off; call cobol_make_fixup (addr (fixup_directive)); end; substr (noentry_instr (3), 4, 15) = substr (unspec (off), 22, 15); call cobol_emit (addr (noentry_instr), addr (noentry_reloc), 4); call cobol_ioerror (ft_ptr, cobol_code, mcode_off, ioerror_ptr); call cobol_emit (addr (tra_instr), null (), 1); utemp = cobol_$text_wd_off - patch_ic; substr (text (patch_ic), 1, 18) = substr (unspec (utemp), 19, 18); exit_check_noentry1: return; check_noentry2: entry; utemp = save_retry - cobol_$text_wd_off; substr (tra_instr, 1, 18) = substr (unspec (utemp), 19, 18); call cobol_emit (addr (tra_instr), null (), 1); utemp = cobol_$text_wd_off - save_ic; substr (text (save_ic), 1, 18) = substr (unspec (utemp), 19, 18); exit_chexk_noentry2: return; /*************************************/ set_fsb: entry (ft_ptr, cobol_mode); start_set_fsb: call cobol_set_fsbptr (ft_ptr); if cobol_mode = 0 then do; /* closing file */ call cobol_emit (addr (fsb_close_mode_instr), null (), 1); if file_table.external then call cobol_emit (addr (fsb_name_instr), addr (fsb_name_reloc), 4); end; else do; substr (fsb_open_mode_instr (1), 1, 18) = substr (unspec (cobol_mode), 19, 18); call cobol_emit (addr (fsb_open_mode_instr), null (), 2); call cobol_emit (addr (fsb_name_instr), addr (fsb_name_reloc), 4); if file_table.organization = 2 then call cobol_emit (addr (fsb_relkey_instr), null (), 1); else if file_table.organization = 3 then call cobol_emit (addr (fsb_keylen_instr), null (), 1); else if file_table.organization = 1 & file_table.device = 1 then do; call cobol_pool ("00000001", 2, off); utemp = -off - cobol_$text_wd_off; substr (fsb_linage_counter_instr (1), 1, 18) = substr (unspec (utemp), 19, 18); call cobol_emit (addr (fsb_linage_counter_instr), null (), 2); end; call cobol_emit (addr (fsb_optional_instr), null (), 2); if file_table.external then call cobol_emit (addr (fsb_opened_ext_instr), null (), 2); else call cobol_emit (addr (fsb_opened_int_instr), null (), 2); end; exit_set_fsb: return; /*************************************/ /* SUBROUTINES */ /*************************************/ /*************************************/ pool_nullptr: proc; dcl nullcon bit (72) aligned static init ("111111111111111111000000000000100011000000000000000001000000000000000000"b); dcl maskcon bit (72) aligned static init ("000111111111111111000000000000111111111111111111111111000111111000111111"b); dcl char8b char (8) based; call cobol_pool (addr (nullcon) -> char8b, 2, off); nulloff = -off - cobol_$text_wd_off; call cobol_pool (addr (maskcon) -> char8b, 2, off); maskoff = -off - cobol_$text_wd_off; exit_pool_nullptr: return; end pool_nullptr; 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_file_table; %include cobol_; %include cobol_fixed_common; %include cobol_ext_; end cobol_open_util; */ ----------------------------------------------------------- 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 */