cobol_.alm 11/11/82 1512.1rew 11/11/82 0955.0 42561 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " *********************************************************** " cobol_ " External data for cobol compiler " bindable as static internal name cobol_ use textc use linkc join /link/linkc join /text/textc use linkc even " DECLARATIONS... segdef text_base_ptr bss text_base_ptr,2 segdef con_end_ptr bss con_end_ptr,2 segdef def_base_ptr bss def_base_ptr,2 segdef link_base_ptr bss link_base_ptr,2 segdef sym_base_ptr bss sym_base_ptr,2 segdef reloc_text_base_ptr bss reloc_text_base_ptr,2 segdef reloc_def_base_ptr bss reloc_def_base_ptr,2 segdef reloc_link_base_ptr bss reloc_link_base_ptr,2 segdef reloc_sym_base_ptr bss reloc_sym_base_ptr,2 segdef reloc_work_base_ptr bss reloc_work_base_ptr,2 segdef pd_map_ptr bss pd_map_ptr,2 segdef fixup_ptr bss fixup_ptr,2 segdef initval_base_ptr bss initval_base_ptr,2 segdef initval_file_ptr bss initval_file_ptr,2 segdef perform_list_ptr bss perform_list_ptr,2 segdef alter_list_ptr bss alter_list_ptr,2 segdef seg_init_list_ptr bss seg_init_list_ptr,2 segdef temp_token_area_ptr bss temp_token_area_ptr,2 segdef temp_token_ptr bss temp_token_ptr,2 segdef token_block1_ptr bss token_block1_ptr,2 segdef token_block2_ptr bss token_block2_ptr,2 segdef minpral5_ptr bss minpral5_ptr,2 segdef tag_table_ptr bss tag_table_ptr,2 segdef map_data_ptr bss map_data_ptr,2 segdef ptr_status_ptr bss ptr_status_ptr,2 segdef reg_status_ptr bss reg_status_ptr,2 segdef misc_base_ptr bss misc_base_ptr,2 segdef misc_end_ptr bss misc_end_ptr,2 segdef list_ptr bss list_ptr,2 segdef allo1_ptr bss allo1_ptr,2 segdef eln_ptr bss eln_ptr,2 segdef diag_ptr bss diag_ptr,2 segdef xref_token_ptr bss xref_token_ptr,2 segdef xref_chain_ptr bss xref_chain_ptr,2 segdef statement_info_ptr bss statement_info_ptr,2 segdef reswd_ptr bss reswd_ptr,2 segdef op_con_ptr bss op_con_ptr,2 segdef ntbuf_ptr bss ntbuf_ptr,2 segdef main_pcs_ptr bss main_pcs_ptr,2 segdef include_info_ptr bss include_info_ptr,2 segdef text_wd_off bss text_wd_off,1 segdef con_wd_off bss con_wd_off,1 segdef def_wd_off bss def_wd_off,1 segdef def_max bss def_max,1 segdef link_wd_off bss link_wd_off,1 segdef link_max bss link_max,1 segdef sym_wd_off bss sym_wd_off,1 segdef sym_max bss sym_max,1 segdef reloc_text_max bss reloc_text_max,1 segdef reloc_def_max bss reloc_def_max,1 segdef reloc_link_max bss reloc_link_max,1 segdef reloc_sym_max bss reloc_sym_max,1 segdef reloc_work_max bss reloc_work_max,1 segdef pd_map_index bss pd_map_index,1 segdef cobol_data_wd_off bss cobol_data_wd_off,1 segdef stack_off bss stack_off,1 segdef max_stack_off bss max_stack_off,1 segdef init_stack_off bss init_stack_off,1 segdef pd_map_sw bss pd_map_sw,1 segdef next_tag bss next_tag,1 segdef data_init_flag bss data_init_flag,1 segdef seg_init_flag bss seg_init_flag,1 segdef alter_flag bss alter_flag,1 segdef sect_eop_flag bss sect_eop_flag,1 segdef para_eop_flag bss para_eop_flag,1 segdef priority_no bss priority_no,1 segdef compile_count bss compile_count,1 segdef ptr_assumption_ind bss ptr_assumption_ind,1 segdef reg_assumption_ind bss reg_assumption_ind,1 segdef perform_para_index bss perform_para_index,1 segdef perform_sect_index bss perform_sect_index,1 segdef alter_index bss alter_index,1 segdef list_off bss list_off,1 segdef constant_offset bss constant_offset,1 segdef misc_max bss misc_max,1 segdef pd_map_max bss pd_map_max,1 segdef map_data_max bss map_data_max,1 segdef fixup_max bss fixup_max,1 segdef tag_table_max bss tag_table_max,1 segdef temp_token_max bss temp_token_max,1 segdef allo1_max bss allo1_max,1 segdef eln_max bss eln_max,1 segdef debug_enable bss debug_enable,1 segdef non_source_offset bss non_source_offset,1 segdef initval_flag bss initval_flag,1 segdef date_compiled_sw bss date_compiled_sw,1 segdef include_cnt bss include_cnt,1 segdef fs_charcnt bss fs_charcnt,1 segdef ws_charcnt bss ws_charcnt,1 segdef coms_charcnt bss coms_charcnt,1 segdef ls_charcnt bss ls_charcnt,1 segdef cons_charcnt bss cons_charcnt,1 segdef value_cnt bss value_cnt,1 segdef cd_cnt bss cd_cnt,1 segdef fs_wdoff bss fs_wdoff,1 segdef ws_wdoff bss ws_wdoff,1 segdef coms_wdoff bss coms_wdoff,1 segdef scratch_dir bss scratch_dir,42 segdef obj_seg_name bss obj_seg_name,8 segdef xref_bypass bss xref_bypass,1 segdef same_sort_merge_proc bss same_sort_merge_proc,1 end  cobol_accept_gen.pl1 05/24/89 1040.3rew 05/24/89 0830.4 64107 /****^ *********************************************************** * * * 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_accept_gen.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 10/02/77 by Bob Chang to fix the bug for mcs_icdp. */ /* Modified on 03/08/77 by Bob Chang to implement accept message count. */ /* Modified since Version 2.0 */ /*{*/ /* format: style3 */ cobol_accept_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 */ 2 pt2 ptr, /* pts to type9 token */ 2 pt3 ptr; /* pts to typ19 token */ dcl 1 mpout, 2 n fixed bin init (4), 2 pt1 ptr, 2 pt2 ptr, 2 pt3 ptr, 2 pt4 ptr; dcl type9 (28) fixed bin (35) static init (112, 0, 0, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 604242176, 0, 1000, 0, 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), 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 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 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 fill bit (18) unaligned init ((18)"0"b), 2 literal bit (18) unaligned; dcl 1 aqreg_struct static, 2 aqreg 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 x5reg_struct static, 2 aqreg 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 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 lda_inst (2) bit (18) static init ("000000000000000000"b, "010011101000000111"b); /* lda 0,dl */ dcl inst_seq (6) bit (18) unaligned static init ("110000000000000000"b, "010101010001000000"b, /* spri2 pr6|offset */ "110000000000000000"b, "010011100001000000"b, /* szn pr6|offset */ "000000000000000000"b, "110000000000000100"b); /* tze 0,ic */ dcl tu2 (2) bit (18) static init ("000000000000000000"b, "111010101000000111"b); /* lxl5 off,dl */ dcl tu3 (2) bit (18) static init ("000000000000000000"b, "111001000000000100"b); /* tra next_tag1,ic */ dcl dn_ptr ptr; dcl item_length (0:3) fixed bin static init (6, 5, 8, 1); dcl info_ic (0:3) fixed bin static init (6, 18, 17, 4); dcl result_offset (0:3) fixed bin static init (88, 80, 88, 82); dcl lineno fixed bin, stoff fixed bin, temp fixed bin; dcl action fixed bin; dcl off fixed bin; dcl next_tag1 fixed bin; /* external procedure. */ dcl cobol_reg_manager$after_op entry (fixed bin); dcl cobol_make_tagref entry (fixed bin, fixed bin, ptr); dcl cobol_call_op entry (fixed bin, fixed bin); dcl cobol_pointer_register$get entry (ptr); dcl cobol_register$load entry (ptr); dcl cobol_emit entry (ptr, ptr, fixed bin); dcl cobol_move_gen entry (ptr); dcl cobol_alloc$stack entry (fixed bin, fixed bin, fixed bin); dcl cobol_get_size entry (ptr, fixed bin, fixed bin); dcl cobol_set_pr entry (ptr, ptr); dcl cobol_define_tag entry (fixed bin); /*************************************/ start: dn_ptr = mp.pt2; lineno = mp.pt1 -> reserved_word.line; action = mp.pt3 -> end_stmt.e; if action >= 9 then do; /* read user_input */ next_tag1 = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_define_tag (next_tag1); call cobol_set_pr (addr (pr2_struct), dn_ptr); call cobol_get_size (dn_ptr, 0, lineno); call cobol_alloc$stack (64, 2, off); tu2 (1) = substr (unspec (off), 19, 18); call cobol_register$load (addr (x5reg_struct)); call cobol_emit (addr (tu2), null (), 1); call cobol_call_op (20, next_tag1); call cobol_reg_manager$after_op (20); end; else if data_name.type = 13 then do; /* Generate epp2 instruction for communication token. */ cdtoken_ptr = mp.pt2; alpha_type9.seg = cdtoken.cd_seg; alpha_type9.off = cdtoken.cd_off - 60; call cobol_set_pr (addr (pr2_struct), addr (alpha_type9)); /* Allocate 12 words in stack frame for parameters */ stoff = 74; /* Communication stack frame from pr6|74 */ /* Store cd_token address. */ substr (inst_seq (1), 4, 15) = substr (unspec (stoff), 22, 15); call cobol_emit (addr (inst_seq (1)), null, 1); /* Call cobol_operators_ */ call cobol_call_op (71, 0); call cobol_reg_manager$after_op (71); end; else do; call cobol_call_op (action + 44, 0); mpout.pt1 = mp.pt1; mpout.pt2 = addr (type9); mpout.pt2 -> data_name.item_length, mpout.pt2 -> data_name.places_left = item_length (action); mpout.pt2 -> data_name.offset = result_offset (action) * 4; mpout.pt3 = mp.pt2; mpout.pt4 = addr (type19); call cobol_move_gen (addr (mpout)); 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_type1; %include cobol_type9; %include cobol_type19; %include cobol_; %include cobol_type13; end cobol_accept_gen;  cobol_add.pl1 05/24/89 1040.3rew 05/24/89 0830.4 53064 /****^ *********************************************************** * * * 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_add.pl1 Added Trace statements. END HISTORY COMMENTS */ /* Modified on 10/19/84 by FCH, [5.3-1], BUG563, new cobol_addr_tokens.incl.pl1 */ /* Modified on 08/31/83 by FCH, [5.2...], trace added */ /* 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. */ /* Modified on 2/25/76 by Bob Chang to fixed plus for1011 and 1100 . */ /* Modified on 2/24/76 by Bob Chang to handle signed/unsigned. */ /* format: style3 */ %; cobol_add: proc (operand_ptr, result_ptr, opcode_code); /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME);/**/ /* This proceudre generates code for the follwoing types of Cobol constructs: 1. ADD A TO B 2. sUBTRACT A FROM 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 addend or minuend depending on whether code is to be generated for addition or subtraction, respectively. (input) result_ptr Points to the token that serves as both 1. augend and sum or 2. subtrahend and difference depending on whether code is to be generated for addition or subtraction, respectively. (input) opcode_code a code that indicates whether code is to be generated for addition or subtraction. (input) opcode_code meaning --------------------------------- 1 | addition 2 | subtraction */ /* 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 add2_op bit (10) int static init ("0100000101"b /*202(1)*/); dcl subtract2_op bit (10) int static init ("0100000111"b /*203(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_add */ /**************************************************/ /* 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 = 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 /* add */ then inst_struc.fill1_op = add2_op; else inst_struc.fill1_op = subtract2_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(MY_NAME);/**/ /***..... 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 (9) int static init ("COBOL_ADD");/**/ /* 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_add */ /**************************************************/ end cobol_add;  cobol_add2_binary_long.pl1 05/24/89 1040.3rew 05/24/89 0834.9 157977 /****^ *********************************************************** * * * 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_add2_binary_long.pl1 Added Trace statements. END HISTORY COMMENTS */ /* Modified on 10/19/84 by FCH, [5.3-1], BUG563, new cobol_addr_tokens.incl.pl1 */ /* Modified on 08/31/83 by FCH, [5.2...], trace added */ /* Modified on 09/03/80 by FCH, [4.4-1], ADD a TO b generates bad code, BUG442(TR7483) */ /* Modified on 1/19/77 by Bob Chang to improve the code for add 1 to comp-6 data. */ /* 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_add2_binary_long: proc (lop_token_ptr, rop_token_ptr, result_token_ptr, operation_code); /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME);/**/ /* This procedure generates code to add or subtract two binary operands using register instructions. The operands can be short or long binary data items or constants. */ /* DECLARATION 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 the token that describes the left operand (augend or minuend) of the operation to be performed. (input) rop_token_ptr Pointer to the token that describes the right operand (addend or subtrahend) of the operation to be performed. (input) result_token_ptr Pointer to a register token (type 100) that describes the register that contains the result (sum or difference) of the operation. If this pointer is null() on entry, then a buffer in which this token is created is supplied by this procedure. Otherwise it must point to a work buffer in which the token is to be built. operation_code a code that indicates the type of arithmetic operation to be performed. (input) The code is defined in the following table: operation_code | meaning =================================== 1 | addition 2 | subtraction */ /* 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$temp ext entry (ptr, ptr); 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); dcl cobol_make_bin_const ext entry (ptr, ptr, fixed bin); 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)); /* DECLARATION OF INTERNAL STATIC VARIABLES */ /* 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 ADA bit (10) int static init ("0001111010"b); /* ADA */ dcl ADQ bit (10) int static init ("0001111100"b); /* ADQ */ dcl SBA bit (10) int static init ("0011111010"b); /* SBA */ dcl SBQ bit (10) int static init ("0011111100"b); /* SBQ */ 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 temp_lop_token_ptr ptr; dcl temp_rop_token_ptr ptr; dcl ret_offset fixed bin (24); dcl temp_op bit (10); dcl temp_ptr ptr; dcl call_again bit (1); dcl cont_bit bit (1); dcl (i, j) fixed bin; 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: input_ptr = addr (input_buff); inst_ptr = addr (inst_buff); reloc_ptr = addr (reloc_buff); /* Check to see if either operand is a constant token (type 2), and if so, convert to an immediate constant token or pooled long binary. */ if lop_token_ptr -> data_name.type = rtc_numlit then do; /* Left operand is 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. */ if (lop_token_ptr -> data_name.type = 9 & operation_code = 5 & lop_token_ptr -> data_name.bin_36 & rop_token_ptr -> numeric_lit.sign ^= "-") then do; cont_bit = "1"b; j = rop_token_ptr -> numeric_lit.places_left + rop_token_ptr -> numeric_lit.places_right; do i = 1 to j while (cont_bit); if substr (rop_token_ptr -> numeric_lit.literal, i, 1) ^= "0" then do; if substr (rop_token_ptr -> numeric_lit.literal, i, 1) ^= "1" | i ^= rop_token_ptr -> numeric_lit.places_left then cont_bit = "0"b; end; end; if cont_bit then do; if substr (rop_token_ptr -> numeric_lit.literal, rop_token_ptr -> numeric_lit.places_left, 1) = "0" then return; input_struc.type = 2; input_struc.operand_no = 1; input_struc.lock = 0; input_struc.token_ptr (1) = lop_token_ptr; input_struc.size_sw (1) = 0; call cobol_addr (input_ptr, inst_ptr, reloc_ptr); inst_struc.fill1_op = "0001011000"b; /* aos */ call cobol_emit (inst_ptr, reloc_ptr, 1); return; end; end; 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 */ /*[4.4-1]*/ if operation_code = 5 then operation_code = 1; else if operation_code = 6 then operation_code = 2; if (operation_code = 2 /* subtract */ & rop_token_ptr -> data_name.type = rtc_dataname & rop_token_ptr -> data_name.bin_18) then do; /* Subtract operation, and subtrahend is a short binary. */ temp_rop_token_ptr = null (); call cobol_short_to_longbin$temp (rop_token_ptr, temp_rop_token_ptr); temp_lop_token_ptr = lop_token_ptr; end; /* Subtract operation, and subtrahend is a short binary. */ else if (operation_code = 2 /* Subtract */ & rop_token_ptr -> data_name.type = rtc_register) /* Subtract, subtrahend is in a register */ | (lop_token_ptr -> data_name.type = rtc_register & rop_token_ptr -> data_name.type = rtc_register) /* Both operands are in registers */ then do; /* Store the right operand into a long binary te porary. */ /* Allocate space on the stack, and build a data name token for it. */ call cobol_alloc$stack (4, 0, ret_offset); temp_rop_token_ptr = null (); call cobol_make_type9$long_bin (temp_rop_token_ptr, 1000 /*stack*/, ret_offset); /* Generate code to store the register into the temporary. */ call cobol_store_binary (rop_token_ptr, temp_rop_token_ptr, call_again); temp_lop_token_ptr = lop_token_ptr; end; /* Store the right operand into a long binary temporary. */ else if (rop_token_ptr -> data_name.type = rtc_dataname & rop_token_ptr -> data_name.bin_18) & (lop_token_ptr -> data_name.type = rtc_dataname & lop_token_ptr -> data_name.bin_18) then do; /* Both operands are short binary cobol data items. */ /* Convert right operand to a long binary in a temporary. */ temp_rop_token_ptr = null (); call cobol_short_to_longbin$temp (rop_token_ptr, temp_rop_token_ptr); temp_lop_token_ptr = lop_token_ptr; end; /* Both operands are short binary cobol data items. */ else if (rop_token_ptr -> data_name.type = rtc_register | lop_token_ptr -> data_name.type = rtc_register) then do; /* Only one operand is in a register. */ /* Make the left operand the register token. */ if lop_token_ptr -> data_name.type = rtc_register then do; /* Left operand pointer already points to the register token. */ temp_lop_token_ptr = lop_token_ptr; temp_rop_token_ptr = rop_token_ptr; end; /* Left operand pointer already points to the register token. */ else do; /* Must switch the operand pointers. */ temp_lop_token_ptr = rop_token_ptr; temp_rop_token_ptr = lop_token_ptr; end; /* Must switch the operand pointers. */ end; /* Only one opernad is in a register. */ else if (rop_token_ptr -> data_name.type = rtc_dataname & rop_token_ptr -> data_name.bin_18) then do; /* Right operand only is short binary cobol data item. */ /* Switch operands, so that the right one is loaded into the register, and the left one added to it. */ temp_lop_token_ptr = rop_token_ptr; temp_rop_token_ptr = lop_token_ptr; end; /* Right operand only is a short binary cobol data item. */ else do; /* None of the above special cases. */ temp_lop_token_ptr = lop_token_ptr; temp_rop_token_ptr = rop_token_ptr; end; /* None of the above special cases. */ /* Set up to call the addressability utility */ input_struc.type = 2; input_struc.operand_no = 1; input_struc.lock = 0; input_struc.operand.size_sw (1) = 0; /* Generate code to load the A or Q, and add to or subtract from it. */ if temp_lop_token_ptr -> data_name.type = rtc_register then result_token_ptr = temp_lop_token_ptr; else call load_register (temp_lop_token_ptr, result_token_ptr); call op_to_register (temp_rop_token_ptr, result_token_ptr -> cobol_type100.register, operation_code); /***..... if Trace_Bit then call cobol_gen_driver_$Tr_End(MY_NAME);/**/ return; 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. Otherwise this pointer must point to a work buffer in which the token is to be built. */ /**************************************************/ /* START OF EXECUTION */ /* INTERNAL PROCEDURE: */ /* load_register */ /**************************************************/ start_load_register: 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_struc.operand.token_ptr (1) = operand_token_ptr; call cobol_addr (input_ptr, inst_ptr, reloc_ptr); /* Get the A or Q and locc it. */ register_struc.what_reg = 4; /* A or 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); 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. */ /* Get the A or Q, and lock it. */ register_struc.what_reg = 4; /* A or Q */ register_struc.lock = 1; register_struc.contains = 0; call cobol_register$load (addr (register_struc)); 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); call cobol_make_reg_token (register_token_ptr, register_struc.reg_no); end; /* Operand to be loaded is an immediate constant. */ exit_load_register: return; end load_register; /*{*/ op_to_register: proc (operand_token_ptr, register_code, op_code); /* This procedure generates code to add an operand to or subtract an operand from a register. (A or Q) The operand can be a long binary cobol data item, or an immediate constant. */ /* DECLARATION OF THE PARaMETERS */ dcl operand_token_ptr ptr; dcl register_code bit (4); dcl op_code fixed bin; /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION operand_token_ptr Pointer to a token that describes the operand to be added to or subtracted from a register. (input) register_code A code that identifies the register to which the operation is to be performed. (input) This code is defined below: code value | register ======================================== "0001"b | A register "0010"b | Q register ======================================== op_code A code that specifies the operation to be performed. (input) code | operation ======================================== 1 | addition 2 | subtraction ========================================= */ /*}*/ /***************************************************/ /* START OF EXECUTION */ /* INTERNAL PROCEDURE: */ /* op_to_register */ /**************************************************/ start_op_to_register: if operand_token_ptr -> data_name.type = rtc_immed_const then do; /* Operand is an immediate constant */ if op_code = 1 then do; /* Operation is ADD */ if register_code = "0001"b then substr (direct_lower_inst, 19, 10) = ADA; else substr (direct_lower_inst, 19, 10) = ADQ; end; /* Operation is ADD */ else do; /* Operation is SUBTRACT */ if register_code = "0001"b then substr (direct_lower_inst, 19, 10) = SBA; else substr (direct_lower_inst, 19, 10) = SBQ; end; /* Operation is SUBTRACT */ 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); end; /* Operand is an immediate constant. */ else do; /* Operand is a long binary data item. */ /* Establish addressability to the long binary. */ input_struc.operand.token_ptr (1) = operand_token_ptr; call cobol_addr (input_ptr, inst_ptr, reloc_ptr); if op_code = 1 then do; /* Operation is ADD */ if register_code = "0001"b then inst_struc_basic.fill1_op = ADA; else inst_struc_basic.fill1_op = ADQ; end; /* Operation is ADD */ else do; /* Operation is subtract */ if register_code = "0001"b then inst_struc_basic.fill1_op = SBA; else inst_struc_basic.fill1_op = SBQ; end; /* Operation is SUBTRACT */ call cobol_emit (inst_ptr, reloc_ptr, 1); end; /* Operand is a long binary data item. */ exit_op_to_register: return; end op_to_register; /***..... dcl cobol_gen_driver_$Tr_Beg entry(char(*));/**/ /***..... dcl cobol_gen_driver_$Tr_End entry(char(*));/**/ /***..... dcl Trace_Bit bit(1) static external;/**/ /***..... dcl Trace_Lev fixed bin static external;/**/ /***..... dcl Trace_Line char(36) static external;/**/ /***..... dcl ioa_ entry options(variable); /**/ /***..... dcl MY_NAME char (22) int static init ("COBOL_ADD2_BINARY_LONG");/**/ /* 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_type2; %include cobol_addr_tokens; %include cobol_type102; %include cobol_record_types; %include cobol_type100; end cobol_add2_binary_long;  cobol_add2_binary_short.pl1 05/24/89 1040.3rew 05/24/89 0834.9 158661 /****^ *********************************************************** * * * 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_add2_binary_short.pl1 Added Trace statements. END HISTORY COMMENTS */ /* Modified on 10/19/84 by FCH, [5.3-1], BUG563, new cobol_addr_tokens.incl.pl1 */ /* Modified on 08/31/83 by FCH, [5.2...], trace added */ /* 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_add2_binary_short: proc (lop_token_ptr, rop_token_ptr, result_token_ptr, operation_code); /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME);/**/ /* This procedure generates code to add or subtract two short binary operands using index register instructions. The operands can be short binary data items or constants. */ /* DECLARATION 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 the token that describes the left operand (augend or minuend) of the operation to be performed. (input) rop_token_ptr Pointer to the token that describes the right operand (addend or subtrahend) of the operation to be performed. (input) result_token_ptr Pointer to a register token (type 100) that describes the regisetr that contains the result (sum or difference) of the operation. If this pointer is null() on entry, then a buffer in which this token is creaded is supplied by this procedure. Otherwise it must point to a work buffer in which the token is to be built. operation_code a code that indicates the type of arithmetic operation to be performed. (input) The code is defined in the following table: operation_code | meaning =================================== 1 | addition 2 | subtraction */ /* DECLARATION OF EXTERNAL ENTRIES */ dcl cobol_register$load ext entry (ptr); dcl cobol_register$release ext entry (ptr); dcl cobol_make_reg_token ext entry (ptr, bit (4)); dcl cobol_alloc$stack ext entry (fixed bin, fixed bin, fixed bin (24)); dcl cobol_make_type9$short_bin ext entry (ptr, fixed bin, fixed bin (24)); dcl cobol_addr ext entry (ptr, ptr, ptr); dcl cobol_emit ext entry (ptr, ptr, fixed bin); dcl cobol_make_bin_const ext entry (ptr, ptr, fixed bin); dcl cobol_store_binary ext entry (ptr, ptr, bit (1)); /* DECLARATION OF INTERNAL STATIC VARIABLES */ dcl LXL bit (10) int static init ("1110100000"b); /* 720(0) */ dcl LDX bit (10) int static init ("0100100000"b); /* 220(0) */ dcl STX bit (10) int static init ("1111000000"b); /* 740(0) */ dcl ADX bit (10) int static init ("0001100000"b); /* 060(0) */ dcl SBX bit (10) int static init ("0011100000"b); /* 160(0) */ /* 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 temp_lop_token_ptr ptr; dcl temp_rop_token_ptr ptr; dcl ret_offset fixed bin (24); dcl temp_op bit (10); dcl temp_ptr ptr; dcl call_again bit (1); 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: /* Get an index register to be used in the computation, and lock it. */ register_struc.what_reg = 5; /* any index register */ register_struc.lock = 1; register_struc.contains = 0; call cobol_register$load (addr (register_struc)); /* Set up to call the addressability utility */ input_ptr = addr (input_buff); inst_ptr = addr (inst_buff); reloc_ptr = addr (reloc_buff); input_struc.type = 2; input_struc.operand_no = 1; input_struc.lock = 0; input_struc.operand.size_sw (1) = 0; /* Check to see if either operand is a constant token (type 2), and if so, convert to an immediate constant token. */ if lop_token_ptr -> data_name.type = rtc_numlit then do; /* Left operand is numeric literal. */ temp_ptr = null (); call cobol_make_bin_const (lop_token_ptr, temp_ptr, 1); 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. */ temp_ptr = null (); call cobol_make_bin_const (rop_token_ptr, temp_ptr, 1); rop_token_ptr = temp_ptr; end; /* Right operand is a numeric literal */ if (operation_code = 2 /* subtract */ & rop_token_ptr -> data_name.type = rtc_dataname) then do; /* Subtraction, and subtrahend is a data name */ if mod (rop_token_ptr -> data_name.offset, 4) = 0 then do; /* Subtrahend is word aligned */ temp_lop_token_ptr = lop_token_ptr; temp_rop_token_ptr = rop_token_ptr; end; /* Subtrahend is word aligned */ else do; /* Subtrahend is half-word aligned. */ /* Word align the subtrahend */ temp_rop_token_ptr = null (); call word_align_short (rop_token_ptr, temp_rop_token_ptr); temp_lop_token_ptr = lop_token_ptr; end; /* Subtrahend is half-word aligned */ end; /* Subtraction, and subtrahend is a data name. */ else if (operation_code = 2 /* Subtract */ & rop_token_ptr -> data_name.type = rtc_register) /* Subtract, subtrahend is in a register */ | (lop_token_ptr -> data_name.type = rtc_register & rop_token_ptr -> data_name.type = rtc_register) /* Both operands are in registers */ then do; /* Store the right operand into a short binary te porary. */ /* Allocate space on the stack, and build a data name token for it. */ call cobol_alloc$stack (2, 0, ret_offset); temp_rop_token_ptr = null (); call cobol_make_type9$short_bin (temp_rop_token_ptr, 1000 /*stack*/, ret_offset); /* Generate code to store the register into the temporary. */ call cobol_store_binary (rop_token_ptr, temp_rop_token_ptr, call_again); temp_lop_token_ptr = lop_token_ptr; end; /* Store the right operand into a short binary temporary. */ else if (rop_token_ptr -> data_name.type = rtc_register | lop_token_ptr -> data_name.type = rtc_register) then do; /* Only one operand is in a register. */ /* Make the left operand the register token. */ if lop_token_ptr -> data_name.type = rtc_register then do; /* Left operand pointer already points to the register token. */ temp_lop_token_ptr = lop_token_ptr; temp_rop_token_ptr = rop_token_ptr; end; /* Left operand pointer already points to the register token. */ else do; /* Must switch the operand pointers. */ temp_lop_token_ptr = rop_token_ptr; temp_rop_token_ptr = lop_token_ptr; end; /* Must switch the operand pointers. */ if temp_rop_token_ptr -> data_name.type = rtc_dataname then if mod (temp_rop_token_ptr -> data_name.offset, 4) ^= 0 then do; /* Right operand not word aligned. */ /* Generate code to word align the right operand. */ temp_ptr = temp_rop_token_ptr; temp_rop_token_ptr = null (); call word_align_short (temp_ptr, temp_rop_token_ptr); end; /* Right operand not word aligned. */ end; /* Only one operand is in a register. */ else if (lop_token_ptr -> data_name.type = rtc_immed_const /* Left operand a constant */ | (lop_token_ptr -> data_name.type = rtc_dataname & mod (lop_token_ptr -> data_name.offset, 4) = 0)) /* Left a word aligned data name */ & (rop_token_ptr -> data_name.type = rtc_dataname & mod (rop_token_ptr -> data_name.offset, 4) ^= 0) /* Right is half-word aligned */ then do; /* Left operand constant or word aligned, right operand half-word aligned. */ /* Switch the operands, so that half-word aligned will be loaded into the index register */ temp_lop_token_ptr = rop_token_ptr; temp_rop_token_ptr = lop_token_ptr; end; /* Left operand constant or word aligned, right operand half-word aligned. */ else if (lop_token_ptr -> data_name.type = rtc_dataname & mod (lop_token_ptr -> data_name.offset, 4) ^= 0) & (rop_token_ptr -> data_name.type = rtc_dataname & mod (rop_token_ptr -> data_name.offset, 4) ^= 0) then do; /* Both operands are data names, and both are half-word aligned. */ /* Word align the right operand */ temp_rop_token_ptr = null (); call word_align_short (rop_token_ptr, temp_rop_token_ptr); temp_lop_token_ptr = lop_token_ptr; end; /* Both operands are data names, and both are half-word aligned. */ else do; /* None of the above special cases */ temp_lop_token_ptr = lop_token_ptr; temp_rop_token_ptr = rop_token_ptr; end; /* None of the above special cases. */ /* Generate code to load the index, and add or subtract to it. */ if temp_lop_token_ptr -> data_name.type = rtc_register then do; /* Left operand is already in a register. */ /* Release the register obtained earlier . */ call cobol_register$release (addr (register_struc)); /* Set the register number of the left operand into the register structure. */ register_struc.reg_no = temp_lop_token_ptr -> cobol_type100.register; end; /* Left operand is already in a register. */ else call load_index (temp_lop_token_ptr, register_struc.reg_no); call op_to_index (temp_rop_token_ptr, register_struc.reg_no, operation_code); /* Make a register token for the register containing the result of the computation */ call cobol_make_reg_token (result_token_ptr, register_struc.reg_no); /***..... if Trace_Bit then call cobol_gen_driver_$Tr_End(MY_NAME);/**/ /*************************************/ word_align_short: proc (unaligned_tok_ptr, aligned_tok_ptr); /* This procedure generates code to word align a short binary cobol data item. */ /* DECLARATION OF THE PARAMETERS */ dcl unaligned_tok_ptr ptr; dcl aligned_tok_ptr ptr; /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION unaligned_tok_ptr Pointer to the data name token for the half-word aligned short binary data item. (input) aligned_tok_ptr Pointer to a data name token that describes the word aligned fixed binary data item. If this pointer is null() on entry, then a token will be created in compiler space, otherwise, it must point to some work space in which the token is to be built. */ /* Allocate space on the stack to receive the word aligned short binary. */ call cobol_alloc$stack (2, 0, ret_offset); /* Make a data name token for the temporary space. */ call cobol_make_type9$short_bin (aligned_tok_ptr, 1000, ret_offset); /* Establish addressability to the original operand. */ input_struc.operand.token_ptr (1) = unaligned_tok_ptr; call cobol_addr (input_ptr, inst_ptr, reloc_ptr); temp_op = LXL; substr (temp_op, 7, 3) = substr (register_struc.reg_no, 2, 3); /* Emit the code to load the subtrahend into the index register. */ inst_struc_basic.fill1_op = temp_op; call cobol_emit (inst_ptr, reloc_ptr, 1); /* Establish addressability to the temporary */ input_struc.operand.token_ptr (1) = aligned_tok_ptr; call cobol_addr (input_ptr, inst_ptr, reloc_ptr); temp_op = STX; substr (temp_op, 7, 3) = substr (register_struc.reg_no, 2, 3); /* Emit code to store the half-word aligned into the word aligned temporary. */ inst_struc_basic.fill1_op = temp_op; call cobol_emit (inst_ptr, reloc_ptr, 1); end word_align_short; /*************************************/ load_index: proc (op_token_ptr, index_reg_no); /* This procedure generates code to load an index register with a value to be used in a computation using the register. The value loaded into the index may be either a short binary data item, or a constant. */ /* DECLARATION OF THE PARAMETERS */ dcl op_token_ptr ptr; dcl index_reg_no bit (4); /* PARAMETER DESCRIPTION op_token_ptr Pointer to a token that describes the value to be loaded into the index register. This may be either a data name (type 9) token or an immediate constant (type 102) token (input) index_reg_no A code that indicates the index register to be loaded. (input) The format of this code is: "1nnn"b where nnn is the index register number (1-7) */ /* DECLARATION OF INTERNAL STATIC DATA */ dcl ldx_du_inst bit (36) int static init ("000000000000000000010010000000000011"b); /* LDXn 0,du */ /* DECLARATION OF INTERNAL DATA */ dcl work_opcode bit (10); if op_token_ptr -> data_name.type = rtc_dataname then do; /* Data name is to be loaded into the index register */ if mod (op_token_ptr -> data_name.offset, 4) ^= 0 then work_opcode = LXL; /* Data name is half-word aligned. */ else work_opcode = LDX; /* Data name is word aligned. */ /* Establish addressability to the operand */ input_struc.operand.token_ptr (1) = op_token_ptr; call cobol_addr (input_ptr, inst_ptr, reloc_ptr); substr (work_opcode, 7, 3) = substr (index_reg_no, 2, 3); inst_struc_basic.fill1_op = work_opcode; call cobol_emit (inst_ptr, reloc_ptr, 1); end; /* Data name is to be loaded into the index register */ else do; /* Constant is to be loaded into the index register */ substr (ldx_du_inst, 25, 3) = substr (index_reg_no, 2, 3); substr (ldx_du_inst, 1, 18) = substr (unspec (op_token_ptr -> immed_const.const_value), 19, 18); call cobol_emit (addr (ldx_du_inst), null (), 1); end; /* Constant is to be loaded into the index register */ end load_index; /*************************************/ op_to_index: proc (op_token_ptr, index_reg_no, operation_code); /* This procedure generates code to add a value to or subtract a value from an index register. */ /* DECLARATION OF THE PARAMETERS */ dcl op_token_ptr ptr; dcl index_reg_no bit (4); dcl operation_code fixed bin; /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION op_token_ptr Pointer to the token that describes the value to be added to or subtracted from the index register. This token can describe either a word aligned short binary or an immediate constant. (input) index_reg_no A code that indicates the index register to which the operation is to be performed. (input) The format of this code is: "1nnn"b where nnn is the index register number. (1-7) operation_code A code that specifies the operation to be performed (input) This code is: value | operation ========================================== 1 | addition 2 | subtraction ========================================= */ /* DECLARATION OF INTERNAL STATIC DATA */ dcl op_du_inst bit (36) int static init ("000000000000000000000000000000000011"b); /* zero,du */ if op_token_ptr -> data_name.type = rtc_dataname then do; /* Operand is a data name. */ input_struc.operand.token_ptr (1) = op_token_ptr; call cobol_addr (input_ptr, inst_ptr, reloc_ptr); if operation_code = 1 then inst_ptr -> inst_struc_basic.fill1_op = ADX; else inst_ptr -> inst_struc_basic.fill1_op = SBX; substr (inst_ptr -> inst_struc_basic.fill1_op, 7, 3) = substr (index_reg_no, 2, 3); call cobol_emit (inst_ptr, reloc_ptr, 1); end; /* Operand is a data name */ else do; /* Operand is an immediate constant */ substr (op_du_inst, 25, 3) = substr (index_reg_no, 2, 3); substr (op_du_inst, 1, 18) = substr (unspec (op_token_ptr -> immed_const.const_value), 19, 18); if operation_code = 1 then substr (op_du_inst, 19, 6) = ADX; else substr (op_du_inst, 19, 6) = SBX; call cobol_emit (addr (op_du_inst), null (), 1); end; /* Operand is an immediate constant. */ end op_to_index; /***..... 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 (23) int static init ("COBOL_ADD2_BINARY_SHORT");/**/ /* 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_type102; %include cobol_addr_tokens; %include cobol_record_types; %include cobol_type100; end cobol_add2_binary_short;  cobol_add3.pl1 05/24/89 1040.3rew 05/24/89 0830.4 57033 /****^ *********************************************************** * * * 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_add3.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/84 by FCH, [5.3-1], BUG563, new cobol_addr_tokens.incl.pl1 */ /* Modified on 09/22/83 by FCH, [5.2...], trace added */ cobol_add3: proc (operand1_ptr, operand2_ptr, result_ptr, opcode_code); /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME);/**/ /* This procedure generates code for the following types of Cobol constructs: 1. ADD A B GIVING C. 2. SUBTRACT A FROM B GIVING C. This procedure makes one important assumption about the input operands: The operands to be added (or subtracted) 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 addition/subtraction 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 addend or minuend, depending on whether code is to be generated for addition or subtraction, respectively. (input) operand2_ptr Points to the token for the augend or subtrahend, depending on whether code is to be generated for addition or subtraction, respectively. (input) result_ptr Points to the token to receive the sum or diffenence, depending on whether code it to be generated for addition or subtraction, respectively. (input) opcode_code A code that indicates whether code is to be generated for an addition or subtraction. (input) opcode_code | meaning ------------------------------------- 1 | addition 2 | subtraction */ /* 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 AdD3 and SUBTRACT3 opcodes */ dcl add3_op bit (10) int static init ("0100100101"b /*222(1)*/); dcl subtract3_op bit (10) int static init ("0100100111"b /*233(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_add3 */ /**************************************************/ /* 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 /* add */ then inst_struc.fill1_op = add3_op; else inst_struc.fill1_op = subtract3_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(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 (10) int static init ("COBOL_ADD3");/**/ /* 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_add3;  cobol_add_binary_gen.pl1 05/24/89 1040.3rew 05/24/89 0830.4 196173 /****^ *********************************************************** * * * 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_add_binary_gen.pl1 Added Trace statements. END HISTORY COMMENTS */ /* Modified on 10/19/84 by FCH, [5.3-1], BUG563, new cobol_addr_tokens.incl.pl1 */ /* Modified on 08/31/83 by FCH, [5.2...], trace added */ /* Modified on 06/29/79 by FCH, [4.0-1], not option added for debug */ /* Modified since Version 4.0 */ /*{*/ /* format: style3 */ cobol_add_binary_gen: proc (in_token_ptr, next_stmt_tag, target_code, source_code, operation_code); /* This procedure generates code to do adds and subtracts using the hardware registers. */ /* DECLARATION OF THE PARAMETERS */ /* dcl in_token_ptr ptr; */ /* Declared below in an include file. */ dcl next_stmt_tag fixed bin; dcl target_code fixed bin; dcl source_code fixed bin; dcl operation_code fixed bin; /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION in_token_ptr Pointer to a structure that contains pointers and data that describe the add or subtract statement for which code is to be generated. (input) See description below for 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. target_code A code that indicates the data type of the largest receiving field in the statement. (input) This code is defined in the follwoing table: target_code | largest field ========================================= 1 | short fixed binary 2 | long fixed binary ========================================= souce_code A code that indicates the data type of the largest data item in the expression to be evaluated. (input) Thhs code has the same values and meanings as for target_code above. operation_code A code that indicates whether code is to be generated for ADD or SUBTRACT. (input) This code is defined in the following table: operation_code | operation ========================================= 1 | ADDITION 2 | SUBTRACTION ========================================= */ /* DECLARATIONS OF EXTERNAL ENTRIES */ dcl cobol_make_type9$short_bin ext entry (ptr, fixed bin, fixed bin (24)); dcl cobol_make_type9$long_bin ext entry (ptr, fixed bin, fixed bin (24)); dcl cobol_make_type9$type2_3 ext entry (ptr, ptr); dcl cobol_alloc$stack ext entry (fixed bin, fixed bin, fixed bin (24)); 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_make_bin_const ext entry (ptr, ptr, fixed bin); dcl cobol_add2_binary_short ext entry (ptr, ptr, ptr, fixed bin); dcl cobol_add2_binary_long ext entry (ptr, ptr, ptr, fixed bin); dcl cobol_make_tagref ext entry (fixed bin, fixed bin, ptr); dcl cobol_store_binary ext entry (ptr, ptr, bit (1)); dcl cobol_define_tag ext entry (fixed bin); dcl cobol_register$load ext entry (ptr); dcl cobol_register$release 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 add_code fixed bin; 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 OF EXECUTION */ /* cobol_add_binary_gen */ /**************************************************/ start: /* Extract 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 use in 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 use in on size error processing. */ if end_stmt.a = "000"b then call format1; /* Format 1 add or subtract */ else call format2; /* Format 2 add or subtract. */ /***..... if Trace_Bit then call cobol_gen_driver_$Tr_End(MY_NAME);/**/ exit: return; format1: proc;/***..... dcl LOCAL_NAME char (9) int static init (": FORMAT1");/**/ /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME||LOCAL_NAME);/**/ /* This procedure generates code to do format 1 add or subtract in the hardware registers. */ /**************************************************/ /* START OF EXECUTION */ /* format1 */ /**************************************************/ start_format1: addend_token_ptr = in_token.token_ptr (2); if addend_token_ptr -> data_name.type = rtc_resword then do /* Addend is the figurative constant ZERO */; if ^ose_flag then return; addend_token_ptr = null (); call cobol_make_type9$type2_3 (addend_token_ptr, addr (dec_zero_token)); end; receive_count = end_stmt.h; if ose_flag then do; /* On size error clause was present. */ if receive_count > 1 then do; /* Multiple augend/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 augend/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. */ if (addend_token_ptr -> data_name.type = rtc_dataname & receive_count > 1) then do; /* The addend is a cobol data item, and there is more than one receiving field. */ /* Store the addend into a temporary. */ /* Allocate space for the temporary. */ if addend_token_ptr -> data_name.bin_18 then tlength = 2; else tlength = 3; call cobol_alloc$stack (tlength, 0, ret_offset); temp_ptr = null (); if tlength = 2 then call cobol_make_type9$short_bin (temp_ptr, 1000, ret_offset); else call cobol_make_type9$long_bin (temp_ptr, 1000, ret_offset); call cobol_store_binary (addend_token_ptr, temp_ptr, call_again); /* Release the register that was used in storing away the addend. */ register_struc.reg_no = addend_token_ptr -> cobol_type100.register; call cobol_register$release (addr (register_struc)); addend_token_ptr = temp_ptr; end; /* The addend is a cobol data item, and there is more than one receiving field. */ /* Generate code to add the addend to each augend/receiving field */ do ix = 3 to (receive_count + 2); /* Do all the adds/subtracts */ /* Determine the type of the augend. */ if in_token.token_ptr (ix) -> data_name.bin_18 then temp_target_code = 1; /* short binary */ else temp_target_code = 2; /* long binary */ /* Determine what registers should be used for the computation */ if source_code > temp_target_code then add_code = source_code; else add_code = temp_target_code; work_token_ptr = addend_token_ptr; /* Generate code to do the add or subtract. */ result_token_ptr = null (); /* Note that in the floowing calls, the operands are reversed. This is necessary because the called procedure expects the minuend as the first parameter. Reversing the operands has no effect on addition, because addition is commutative. */ if add_code = 1 then call cobol_add2_binary_short (in_token.token_ptr (ix), work_token_ptr, result_token_ptr, operation_code); else call cobol_add2_binary_long (in_token.token_ptr (ix), work_token_ptr, result_token_ptr, operation_code + 4); if ose_flag then do; /* On size error clause was present. */ /* Emit code to transfer on overflow to the overflow tag. */ call cobol_emit (addr (tov_inst), null (), 1); /* Make a reference to the overflow tag at the instruction just emitted. */ call cobol_make_tagref (ovflo_tag, cobol_$text_wd_off - 1, null ()); end; /* On size error clause was present. */ if result_token_ptr ^= null then do; 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. */ /* Release the register that contains the result of the add or subtract. */ register_struc.reg_no = result_token_ptr -> cobol_type100.register; call cobol_register$release (addr (register_struc)); end; if ose_flag & receive_count ^= 1 then do; /* On size error and multiple augends. */ /* Emit code to transfer to the next add 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 add or subtract, 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 add or subtract, define new ovflo, no_ovflo tags */ end; /* On size error and multiple augends. */ end; /* Do add/subtract. */ 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 augend/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 augend/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. */ exit_format1: return; end format1; format2: proc;/***..... dcl LOCAL_NAME char (9) int static init (": FORMAT2");/**/ /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME||LOCAL_NAME);/**/ /* This procedure generates code for format 2 add and subtract statements. */ start_format2: /* Reverse the operands, because the cobol_add2_binary procedures require that the minuend be the first parameter, and in the in_token structure, the minuend follows the subtrahend. Since addition is commutative, reversing the operands has no effect on addition. */ temp_lop_token_ptr = in_token.token_ptr (3); temp_rop_token_ptr = in_token.token_ptr (2); if temp_lop_token_ptr -> data_name.type = rtc_resword then do; /* "Left" operand is the figurative constant ZERO. */ temp_lop_token_ptr = null (); call cobol_make_type9$type2_3 (temp_lop_token_ptr, addr (dec_zero_token)); end; /* "Left" operand is the figurative constant ZERO. */ if temp_rop_token_ptr -> data_name.type = rtc_resword then do; /* "Right" operand is the figurative constant ZERO. */ temp_rop_token_ptr = null (); call cobol_make_type9$type2_3 (temp_rop_token_ptr, addr (dec_zero_token)); end; /* "Right" operand is the figurative constant ZERO. */ /* Determine the register [ (a or q) or index register] in which the computation is to be performed. */ if source_code > target_code then add_code = source_code; else add_code = target_code; /* Always pick the largest register required for the computation. */ if temp_lop_token_ptr -> data_name.type = rtc_numlit then do; /* "Left" operand is a numeric literal. */ /* Convert the numeric literal to a binary constant. */ work_token_ptr = temp_lop_token_ptr; temp_lop_token_ptr = null (); call cobol_make_bin_const (work_token_ptr, temp_lop_token_ptr, add_code); end; /* "Left" operand is a numeric literal. */ if temp_rop_token_ptr -> data_name.type = rtc_numlit then do; /* "Right" operand is a numeric literal. */ /* Convert the numeric literal to a binary constant. */ work_token_ptr = temp_rop_token_ptr; temp_rop_token_ptr = null (); call cobol_make_bin_const (work_token_ptr, temp_rop_token_ptr, add_code); end; /* "Right" operand is a numeric literal. */ if ose_flag then call cobol_fofl_mask$on; /* Generate code to turn on the fixed overflow mask bit in the indicator register. */ /* Generate code to do the add or subtract. */ result_token_ptr = null (); if add_code = 2 then call cobol_add2_binary_long (temp_lop_token_ptr, temp_rop_token_ptr, result_token_ptr, operation_code); else call cobol_add2_binary_short (temp_lop_token_ptr, temp_rop_token_ptr, result_token_ptr, operation_code); if ose_flag then do; /* On size error clause was present. */ /* Generate code to test for overflow and transfer to the imperative statement if overflow occurred. */ 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 was present. */ /* The result of the add or subtract is now in a hardware register. Now we generate code to store the result into each of the receiving fields, first into all long binary receiving fields, and then into all short binary receiving fields. */ skipped_some = "0"b; do ix = 4 to in_token.n - 1; /* Try storing into equal size receiving fields. */ if (add_code = 2 /* Result is long binary */ & in_token.token_ptr (ix) -> data_name.bin_18 /* target is short bin */) then skipped_some = "1"b; else call cobol_store_binary (result_token_ptr, in_token.token_ptr (ix), call_again); end; /* Try storing into equal size receiving fields. */ if skipped_some then do; /* Must store the result into short binary receiving fields. */ do ix = 4 to in_token.n - 1; /* Scan the receiving field tokens. */ if in_token.token_ptr (ix) -> data_name.bin_18 then call cobol_store_binary (result_token_ptr, in_token.token_ptr (ix), call_again); if call_again then do; /* Result has been moved into a temp in an attempt to force overflow. */ if ose_flag then do; /* On size clause present. */ call cobol_emit (addr (tov_inst), null (), 1); call cobol_make_tagref (imperative_stmt_tag, cobol_$text_wd_off - 1, null ()) ; end; /* On size clause present. */ /* Generate code to move the temp into the receiving field. */ call cobol_store_binary (result_token_ptr, in_token.token_ptr (ix), call_again); end; /* Result has been moved into a temp in an attempt to force overflow. */ end; /* Scan the receiving field tokens. */ end; /* Must store the result into 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. */ exit_format2: return; end format2; /***..... 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 (20) int static init ("COBOL_ADD_BINARY_GEN");/**/ /***** 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_add_binary_gen;  cobol_add_gen.pl1 05/24/89 1040.3rew 05/24/89 0830.4 168723 /****^ *********************************************************** * * * 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_add_gen.pl1 Added Trace statements. END HISTORY COMMENTS */ /* Modified on 10/19/84 by FCH, [4.3-1], BUG563, new cobol_addr_tokens.incl.pl1 /* Modified on 08/31/83 by FCH, [5.2...], trace added */ /* 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_add_gen: proc (in_token_ptr, next_stmt_tag); /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME);/**/ /* The ADD statement generator: cobol_add_gen FUNCTION The function of this procedure is to generate code for the Cobol ADD statement. */ /* DECLARATION OF THE PARAMETERS */ /* dcl in_token_ptr ptr; */ /* DECLARED BELOW IN AN INCLUDE FILE */ dcl next_stmt_tag fixed bin; /* DECLARATION OF EXTERNAL ENTRIES */ 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_add3 ext entry (ptr, ptr, ptr, fixed bin); dcl cobol_add 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); dcl cobol_binary_check$add ext entry (ptr, bit (1), fixed bin, fixed bin); dcl cobol_add_binary_gen ext entry (ptr, fixed bin, fixed bin, fixed bin, fixed bin); /* DECLARATIONS OF BUILTIN FUNCTIONS */ dcl addr builtin; dcl fixed builtin; dcl null builtin; /* DECLARATION OF INTERNAL STATIC VARIABLES */ dcl first_meaningful_ptr_index fixed bin int static init (2); dcl add_code fixed bin int static init (182); /* Definition of an EOS token to be used in calls to the move generator */ dcl 1 move_eos int static, 2 size fixed bin (15) init (38), 2 line fixed bin (15) init (0), 2 column fixed bin (15) init (0), 2 txpe fixed bin (15) init (19), /* EOS */ 2 verb fixed bin (15) init (18), /* MOVE */ 2 e fixed bin (15) init (0), 2 h fixed bin (15) init (0), 2 i fixed bin (15) init (0), 2 j fixed bin (15) init (0), 2 a bit (16) init ("0"b); /* 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"); /* Declarations of initialized variables that define verb type codes in EOS token */ dcl add_vt fixed bin (15) int static init (2); dcl subtract_vt fixed bin (15) int static init (11); /* DECLARATION OF INTERNAL AUTOMATIC VARIABLES */ dcl ose_flag bit (1); dcl addend_count fixed bin; dcl receive_count fixed bin; dcl fmt1 bit (1); dcl lop_ptr ptr; dcl rop_ptr ptr; dcl resultant_operand_ptr ptr; dcl minuend_token_ptr ptr; dcl subtrahend_token_ptr ptr; dcl ix fixed bin; dcl iy fixed bin; dcl move_eos_ptr ptr; dcl mv_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 overflow_possible bit (1); dcl size_error_flag_defined bit (1); dcl temp_in_token (1:10) ptr; 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 add_gen_code fixed bin; dcl verb_type fixed bin; dcl temp_ptr ptr; 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; /***..... dcl cobol_gen_driver_$Tr_Beg entry(char(*));/**/ /***..... dcl cobol_gen_driver_$Tr_End entry(char(*));/**/ /***..... dcl Trace_Bit bit(1) static external;/**/ /***..... dcl Trace_Lev fixed bin static external;/**/ /***..... dcl Trace_Line char(36) static external;/**/ /***..... dcl ioa_ entry options(variable); /**/ /***..... dcl MY_NAME char (13) int static init ("COBOL_ADD_GEN"); /**/ /**************************************************/ /* START OF EXECUTION */ /* cobol_add_gen */ /**************************************************/ /* Get meaningful data from the EOS token. */ eos_ptr = in_token.token_ptr (in_token.n); /* Check to see if binary arithemtic and be done for this add/subtract statement */ call cobol_binary_check$add (in_token_ptr, binary_ok, target_code, source_code); if binary_ok then do; /* Binary arithmetic can be done. */ if end_stmt.verb = add_vt then add_gen_code = 1; else add_gen_code = 2; call cobol_add_binary_gen (in_token_ptr, next_stmt_tag, target_code, source_code, add_gen_code); return; end; /* Binary arithmetic can be done. */ /* ON SIZE ERROR flag */ ose_flag = end_stmt.b; /* Number of operands to be added */ addend_count = end_stmt.e; /* Number of receiving operands */ receive_count = end_stmt.h; /* Verb type */ verb_type = end_stmt.verb; /* Determine the ADD or SUBTRACT statement format */ if end_stmt.a = "000"b then fmt1 = "1"b; /* Format 1 ADD */ else fmt1 = "0"b; /* Format 2 ADD */ if ose_flag then do; /* Reserve a tag to be associated with the next Cobol statement */ next_stmt_tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; end; /* Reserve a tag to be associated with the next Cobol statement */ resultant_operand_ptr = in_token.token_ptr (first_meaningful_ptr_index); iy = first_meaningful_ptr_index; if addend_count > 1 then do; /* Generate code to add all of the operands together. */ do ix = 1 to addend_count - 1; /* Generate the add code. */ iy = iy + 1; /* subscript of next addend pointer */ lop_ptr = resultant_operand_ptr; rop_ptr = in_token.token_ptr (iy); /* Build resultant operand to hold the result of the addition */ call cobol_build_resop (lop_ptr, rop_ptr, add_code, resultant_operand_ptr, "0"b, rdmax_value, possible_ovfl_flag); /* Generate code to add the two operands */ call cobol_add3 (lop_ptr, rop_ptr, resultant_operand_ptr, 1 /*ADD*/); end; /* Generate the add code. */ end; /* Generate code to add all of the operands togenter. */ if resultant_operand_ptr -> data_name.type ^= rtc_dataname then do; /* A literal or fig constant ZERO is to be added in fmt 1 add */ if resultant_operand_ptr -> data_name.type = rtc_resword then temp_ptr = addr (num_lit_zero); /* Figurative constant ZERO is to be added. */ else temp_ptr = resultant_operand_ptr; /* A numeric literal is to be added. */ /* Pool the literal and make a type 9 token */ resultant_operand_ptr = null (); /* utility provides buffer for data name token */ call cobol_make_type9$type2_3 (resultant_operand_ptr, temp_ptr); end; /* A literal or fig constant ZERO is to be added in fmt 1 add */ /* At this point in processing, the following coonditions exist: 1. Code has been generated to add together all operands to the left of "TO" (for format 1 ADD) or to he left of "GIVING" ( for format 2 ADD). 2. The data name token that describes the sum of these operands is pointed at by the pointer resultant_operand_ptr. 3. The variable "iy" contains the subscript of the in_token array element that points to the last addend. ( i.e., iy + 1 is the subscript of the pointer to the first receiving token.) */ /* Now check to see if code is being generated for a format 2 subtract. */ if (verb_type = subtract_vt & ^fmt1) then do; /* Format 2 SUBTRACT, must generate code to subtract the sum calculated so far, from the minuend. */ /* Increment iy to become the subscript of the pointer to the minuend token. */ iy = iy + 1; subtrahend_token_ptr = resultant_operand_ptr; minuend_token_ptr = in_token.token_ptr (iy); call cobol_build_resop (minuend_token_ptr, subtrahend_token_ptr, add_code, resultant_operand_ptr, "0"b, rdmax_value, possible_ovfl_flag); /* At this point in processing: 1. minuend_token_ptr points to a token for the minuend. 2. subtrahend_token_ptr points to a token for the result of adding all operands to the left of "TO". 3. resultant_operand_ptr points to a token to receive the difference of the subtraction. */ call cobol_add3 (subtrahend_token_ptr, minuend_token_ptr, resultant_operand_ptr, 2 /*SUBTRACT*/); end; /* Format 2 SUBTRACT, must generate code to stubract the sum calculated so far, from the minuend. */ /* Now we will get the result into the receiving operands. */ overflow_code_generated = "0"b; size_error_flag_defined = "0"b; do ix = 1 to receive_count; /* Generate code to get the sum into receiving operands. */ mv_ptr = null (); overflow_possible = "0"b; receiving_is_not_stored = "0"b; iy = iy + 1; /* Get subscript of pointer to "next" receiving operand token. */ if ose_flag then do; /* ON SIZE CHECKING required, */ if fmt1 then overflow_possible = "1"b; /* Overflow always possible for format 1 add or subtract. */ else if (resultant_operand_ptr -> data_name.places_left > in_token.token_ptr (iy) -> data_name.places_left) then overflow_possible = "1"b; /* Format 2, result left digits > receiving left digits. */ else if resultant_operand_ptr -> data_name.sign_type = "111"b then overflow_possible = "1"b; /* Resultant operand is floating decimal. */ end; /* ON SIZE checking required */ if overflow_possible then do; /* Store the receiving field into a temporary */ overflow_code_generated = "1"b; if ^size_error_flag_defined then do; /* Define the size error fixed bin flag in the run-time stack. */ size_error_inst_ptr = addr (size_error_inst); call get_size_error_flag (size_error_token_ptr, size_error_inst_ptr); size_error_flag_defined = "1"b; end; /* Define the size error fixed bin flag in the run-time stack. */ /* Store the receiving field into a temporary. */ /* Note that if the receiving field is numeric edited, or overpunch sign, then it is not stored into a temporary. */ 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); /* 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 turn the overflow mask indicator bit ON */ call cobol_fofl_mask$on; end; /* Store the receiving field into a temporary */ if fmt1 then do; /* Add sum to or SUBTRACT sum from the receiving field. The result goes into the receiving field. */ if verb_type = add_vt then add_gen_code = 1; /* ADD */ else add_gen_code = 2; /* SUBTRACT */ if not_dec_operand (in_token.token_ptr (iy)) then do; /* The receiving operand is not decimal. Must convert to decimal before performing the add or subtract. */ op1_token_ptr = resultant_operand_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, add_code, temp_resultant_operand_ptr, "0"b, rdmax_value, possible_ovfl_flag); /* Generate code to add (or subtract) the two operands, and store the result into a temporary. */ call cobol_add3 (op1_token_ptr, op2_token_ptr, temp_resultant_operand_ptr, add_gen_code); /* Generate code to move the result of the add/subtract to the receiving field. */ move_eos_ptr = addr (move_eos); move_eos_ptr -> end_stmt.e = 1; mv_ptr = addr (temp_in_token (1)); mv_ptr -> in_token.n = 4; mv_ptr -> in_token.token_ptr (1) = null (); mv_ptr -> in_token.token_ptr (2) = temp_resultant_operand_ptr; mv_ptr -> in_token.token_ptr (3) = in_token.token_ptr (iy); mv_ptr -> in_token.token_ptr (4) = move_eos_ptr; call cobol_arith_move_gen (mv_ptr); if mv_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 add or subtract. */ else do; /* Receiving operand is decimal. */ if not_dec_operand (resultant_operand_ptr) then do; /* Left operand is not decimal--convert to decimal. */ op1_token_ptr = resultant_operand_ptr; resultant_operand_ptr = null (); call cobol_num_to_udts (op1_token_ptr, resultant_operand_ptr); end; /* Left operand is not decimal--convert to decimal. */ call cobol_add (resultant_operand_ptr, in_token.token_ptr (iy), add_gen_code); end; /* Receiving operand is decimal. */ end; /* Add sum or SUBTRACT sum from the receiving field. The result goes into the receiving field. */ else do; /* Generate code to MOVE the sum to the receiving field */ /* Set up an in_token structure for a move. */ move_eos_ptr = addr (move_eos); move_eos_ptr -> end_stmt.e = 1; /* Number of receiving operands. */ mv_ptr = addr (temp_in_token (1)); mv_ptr -> in_token.n = 4; mv_ptr -> in_token.token_ptr (1) = null (); mv_ptr -> in_token.token_ptr (first_meaningful_ptr_index) = resultant_operand_ptr; mv_ptr -> in_token.token_ptr (3) = in_token.token_ptr (iy); /* Receiving field */ mv_ptr -> in_token.token_ptr (4) = move_eos_ptr; /* Generate the move code */ if (ose_flag & overflow_possible = "0"b) then call cobol_move_gen (mv_ptr); /* OSE present, but result will fit into the receiving filed with no possibility of overflow. */ else call cobol_arith_move_gen (mv_ptr); if mv_ptr -> in_token.code ^= 0 then receiving_is_not_stored = "1"b; end; /* Generate code to MOVE the sum to the receiving field. */ if overflow_possible then do; /* Generate code to test for overflow, and restore the original value to the receiving field if overflow occurred. */ call test_for_overflow (no_overflow_tag, size_error_inst_ptr, mv_ptr); /* If the receiving field has been stored into a temporary, then resotre it. */ if ^receiving_is_not_stored then call receiving_field (in_token.token_ptr (iy), stored_token_ptr, 2); /* DEfine the no overflow tag at the instruction following the restore value code. */ 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 tst for overflow, and restore the original value to the receiving filed if overflow occurred. */ else if receiving_is_not_stored /* Receiving field is numeric edited, and the result has been stored into a temporary to see if overflow will occur. Now we must move the temporary into the numeric edited field. */ then call cobol_move_gen (mv_ptr); end; /* Generate code to get the sum into receiving operands. */ /* At this point in processing, code has been generated to 1. get the result into the receiving operands. 2. test for possible overflow. */ if ose_flag then do; /* Generate code to test the size error flag, and transfer over the imperative stmt if no size error 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, overflow_code_generated, not_bit); end; /* Generate code to test the size error flag, and transfer over the imperative stmt if no size error occurred. */ /***..... if Trace_Bit then call cobol_gen_driver_$Tr_End(MY_NAME);/**/ return; /**************************************************/ /* END OF EXECUTABLE STATEMENTS */ /* cobol_add_gen */ /**************************************************/ %include cobol_arith_util; /* INCLUDE FILES USED BY THIS PROCEDURE */ %include cobol_type9; %include cobol_in_token; %include cobol_type19; %include cobol_; %include cobol_addr_tokens; %include cobol_record_types; /**************************************************/ /* END OF EXTERNAL PROCEDURE */ /* cobol_add_gen */ /**************************************************/ end cobol_add_gen;  cobol_addr.pl1 05/24/89 1040.3rew 05/24/89 0830.4 602766 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * *********************************************************** */ /****^ 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_addr.pl1 Added Trace statements. 2) change(89-04-23,Zimmerman), approve(89-04-23,MCR8073), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8073 cobol_addr.pl1 Correct handling of arrays longer than 379 elements. 3) change(89-04-23,Zimmerman), approve(89-04-23,MCR8085), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8085 cobol_addr.pl1 Stop code generator from aborting in move statement. END HISTORY COMMENTS */ /* Modified on 11/26/84 by FCH, [5.3-3], BUG571(phx17008), release the PR */ /* Modified on 11/15/84 by FCH, [5.3-2], BUG566(phx17927), large arrays for type 7 entries */ /* Modified on 10/19/84 by FCH, [5.3-1], BUG563(phx18381), new cobol_addr_tokens.incl.pl1 */ /* Modified on 10/13/83 by FCH, [5.2-5], subscript bug, fixed by 5.3, phx13949(BUG541) */ /* Modified on 10/13/83 by FCH, [5.2-4], subscript bug, fixed by 5.3, phx13954(BUG540) */ /* Modified on 09/09/83 by FCH, [5.2-3], negative temp values correctly detected phx13533(BUG538) */ /* Modified on 09/04/83 by FCH, [5.2-2], aregs not allocated correctly, phx13951(BUG540) */ /* Modified on 08/14/83 by FCH, [5.2 ...], trace added */ /* Modified on 08/14/83 by FCH, [5.2-1], indexing of large arrays still fails, phx14746(BUG548) phx13949(BUG541) */ /* Modified on 11/04/81 by FCH, [5.1-1], indexing of large arrays fails, phx10955(BUG496) */ /* Modified on 04/06/81 by FCH, [4.4-2], large array bit not set correctly, phx09543(BUG474) */ /* Modified on 09/26/80 by FCH, [4.4-1], type 7 possibly generates incorrect code if subscripts used, BUG445 */ /* Modified on 04/03/80 by FCH, [4.2-1], fix out-of-range subscript detection BUG430(TR4533) */ /* Modified on 06/02/78 by FCH, [3.0-1], condition description put in automatic storage */ /* Modified since Version 3.0 */ /* format: style3 */ cobol_addr: proc (input_ptr, inst_ptr, reloc_ptr); /***..... dcl MY_NAME char (10) int static init ("COBOL_ADDR"); /**/ /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME);/**/ error_message.name = "cobol_addr"; error_message.length = 80; /* [3.0-1] */ /* unlock index, A, Q and temporary pointer registers */ reg_struc_ptr = addr (reg_struc); /*[5.2-1]*/ large_array = "0"b; if input_struc.lock = 2 then do; reg_struc.reg_num = "0011"b; call cobol_register$release (reg_struc_ptr); /*[5.2-2]*/ do rxi = 8 to 15; /*[5.2-2]*/ reg_num = substr (unspec (rxi), 33, 4); call cobol_register$release (reg_struc_ptr); 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); end; /* clean register and ptr used by addr array */ /*[5.2-2]*/ do rxi = 0 to 9; /*[5.2-2]*/ addr_reg (rxi) = 0; /*[5.2-2]*/ addr_ptr (rxi) = 0; end; struc_ptr = addr (ar_buff); t = input_struc.type; /*[5.2-3]*/ if t <= 0 | t > 8 then do; error_message.message = "Illegal type of addressing is specified. It must be 1<=i<=8."; call signal_ ("command_abort_", null (), addr (error_message)); call error_end_addr; return; end; inst_b1_ptr = addr (inst_b1); reloc_b1_ptr = addr (reloc_b1); /* Process variable lenth item: results are saved in var_reg */ do opr = 1 to 3; var_reg (opr) = "000"b; end; /* cobol_get_size is called to get PERFORM_GEN to perform the size paragraph */ do opr = 1 to input_struc.operand_no; if input_struc.operand.token_ptr (opr) ^= null () then if input_struc.operand.size_sw (opr) = 0 then do; dn_ptr = input_struc.operand.token_ptr (opr); if data_name.variable_length then do; call cobol_get_size (dn_ptr, 0, 0); /* The result in A is then loaded into an index register */ /*[5.2-2]*/ j = 5; call get_reg (5); var_reg (opr) = reg_no; /* store index register no */ /* EAXn: load A to index */ inst_b1.wd = "000000000000000000110010000000000101"b; substr (inst_b1.wd, 25, 3) = reg_no; call cobol_emit (inst_b1_ptr, null (), 1); end; end; end; aj_const_off (1), aj_const_off (2), aj_const_off (3) = 0; text_wd_off_save = cobol_$text_wd_off; desc_an_ptr = addr (inst_struc.desc_ext); desc_nn_ptr = addr (inst_struc.desc_ext); if t = 5 | t = 6 then do; index_array_i = 0; index_array_flag = 1; end; else index_array_flag = 0; /***..... if Trace_Bit then call ioa_("^a^a^d",substr(Trace_Line,Trace_Lev+1,1),MY_NAME||": ",t);/**/ go to type (t); /***** type(1) *****/ type (1): call type_1; if reloc_ptr ^= null () then call reloc; addr_done: call end_addr; /***..... if Trace_Bit then call cobol_gen_driver_$Tr_End(MY_NAME);/**/ return; /***** type(2) and type(3) *****/ type (2): type (3): call type_2; if reloc_ptr ^= null () then call reloc; go to addr_done; /***** type(4), type(5) and type(6) *****/ type (4): type (5): type (6): call type_4; go to addr_done; /***** type(7) *****/ type (7): call type_7; go to addr_done; type_1: proc; i = 0; inst_struc_basic.zero1 = "0"b; /* interupt inhibit */ inst_struc_basic.tm = "00"b; /* r type addr mod */ mseg_no = input_struc_basic.segno; /* test for constants */ if mseg_no = 3000 then do; inst_struc_basic.td = "0100"b; /* (R)=IC, y=y+c(ic) */ inst_struc_basic.pr_spec = "0"b; temp = -(cobol_$text_wd_off + binary (substr (unspec (input_struc_basic.char_offset), 1, 34))); string (inst_struc_basic.y) = substr (unspec (temp), 19, 18); return; end; if mseg_no < 0 & input_struc_basic.char_offset = 0 then do; inst_struc_basic.tm = "01"b; inst_struc_basic.td = "0000"b; /* RI */ temp = -(mseg_no); end; else do; inst_struc_basic.td = "0000"b; /* no mod y=y */ temp = binary (substr (unspec (input_struc_basic.char_offset), 17, 18)); end; inst_struc_basic.pr_spec = "1"b; call get_ar; inst_struc_basic.y.pr = ptr_no; inst_struc_basic.y.wd_offset = substr (unspec (temp), 22, 15); if mseg_no < 0 & input_struc_basic.char_offset ^= 0 then do; /* emit eppr pr4|n,* */ inst_b1.wd = "100000000000000000011101000001010000"b; call get_temp_ar; substr (inst_b1.wd, 19, 10) = eppr_op; temp = -mseg_no; substr (inst_b1.wd, 4, 15) = substr (unspec (temp), 22, 15); reloc_b1.r = "10100"b; reloc_b1.l = "10100"b; b1_count = 1; call cobol_emit (inst_b1_ptr, reloc_b1_ptr, b1_count); end; /* lock handling */ /* lock codes to be inserted */ end; type_2: proc; i = 0; if input_struc.operand.token_ptr (1) = null () then return; dn_ptr = input_struc.operand.token_ptr (1); /* Set interupt inhibit bit to 0 */ inst_struc_basic.zero1 = "0"b; /* R type address modification is used */ inst_struc_basic.tm = "00"b; mseg_no = data_name.seg_num; /* test for constants */ if mseg_no = 3000 then do; inst_struc_basic.td = "0100"b; inst_struc_basic.pr_spec = "0"b; temp = -(cobol_$text_wd_off + binary (substr (unspec (data_name.offset), 1, 34))); string (inst_struc_basic.y) = substr (unspec (temp), 19, 18); return; end; /* No register mod is assumed. This assumption can be negated later */ inst_struc_basic.td = "0000"b; /* none y=y */ inst_struc_basic.pr_spec = "1"b; temp = binary (substr (unspec (data_name.offset), 17, 18)); /* Subscripts processing */ /*[5.2-3]*/ large_array = "0"b; if data_name.subscripted then do; call subscripts; if subs_error = 1 then do; call error_end_addr; go to addr_done; end; if no_reg_flag = 0 then do; inst_struc_basic.td = "1000"b; substr (inst_struc_basic.td, 2, 3) = reg_no; end; temp = temp - aj_off; /* Ajust offset to 0 occurence */ if temp < 0 then do; inst_b1.wd = "000000000000000000001110000000000011"b; /* SBXN */ temp = -temp + 1; substr (inst_b1.wd, 1, 18) = substr (unspec (temp), 19, 18); temp = 1; substr (inst_b1.wd, 25, 3) = reg_no; call cobol_emit (inst_b1_ptr, null (), 1); end; end; call get_ar; inst_struc_basic.y.pr = ptr_no; inst_struc_basic.y.wd_offset = substr (unspec (temp), 22, 15); if large_array then if no_reg_flag = 0 then call ptr_adjust; end; type_4: proc; if input_struc.operand_no < 0 | input_struc.operand_no > 3 then do; error_message.message = "Illegal operand number is specified. It must be 1, 2, or 3."; call signal_ ("command_abort_", null (), addr (error_message)); call error_end_addr; return; end; /* set zero bits in wd 1 */ inst_struc.inst.zero1 = "00"b; inst_struc.inst.zero3 = "0"b; inst_struc.inst.zero5 = "0"b; /* Get reloc info for 1st word */ i = 0; mseg_no = 2; if reloc_ptr ^= null () then call reloc; /* To handle the modification for Type 4, Type 5 and Type 6 instruction. */ subs_error = 0; if input_struc.operand_no < 3 then string (inst_struc.inst.mf3) = "0000000"b; if input_struc.operand_no < 2 then string (inst_struc.inst.mf2) = "0000000"b; do i = 1 to input_struc.operand_no; if i = 1 then mf_ptr = addr (inst_struc.inst.mf1); else if i = 2 then mf_ptr = addr (inst_struc.inst.mf2); else mf_ptr = addr (inst_struc.inst.mf3); call mf; if subs_error = 1 then do; call error_end_addr; return; end; end; end; type_7: proc; i = 1; inst_struc_basic.y.wd_offset = "0"b; inst_struc_basic.zero1 = "0"b; inst_struc_basic.pr_spec = "1"b; inst_struc_basic.tm = "00"b; inst_struc_basic.td = "1000"b; dn_ptr = input_struc.operand.token_ptr (1); mseg_no = data_name.seg_num; if reloc_ptr ^= null () then call reloc; if ^data_name.subscripted then do; if substr (unspec (data_name.offset), 35, 2) = "00"b then return; /*[5.2-2]*/ j = 0; call get_reg (0); /* ldxn */ /*[4.4-1]*/ inst_b1.wd = "000000000000000000000000000000000011"b; /*[4.4-1]*/ substr (inst_b1.wd, 17, 2) = substr (unspec (data_name.offset), 35, 2); substr (inst_b1.wd, 19, 10) = "0100100000"b; end; else do; call subscripts; if subs_error = 1 then do; call error_end_addr; return; end; /* adxn */ /*[4.4-1]*/ inst_b1.wd = "000000000000000000000000000000000011"b; /*[4.4-1]*/ substr (inst_b1.wd, 17, 2) = substr (unspec (data_name.offset), 35, 2); substr (inst_b1.wd, 19, 10) = "0001100000"b; end; substr (inst_b1.wd, 25, 3) = reg_no; substr (inst_struc_basic.td, 2, 3) = reg_no; /*[5.3-2]*/ if substr (unspec (data_name.offset), 35, 2) ^= "00"b then call cobol_emit (inst_b1_ptr, null (), 1); /*[5.2-1]*/ if large_array then do; ptr_no = inst_struc_basic.y.pr; call ptr_adjust; end; end; error_end_addr: proc; error_message.message = "Error exit from cobol_addr is taken. Process is not completed."; call signal_ ("command_abort_", null (), addr (error_message)); end; end_addr: proc; /* unlock all index registers and pointer registers used */ /*[5.2-2]*/ if input_struc.lock ^= 1 /*[5.2-2]*/ then do; rxi = 8; if addr_reg (8) > 0 then call rr; /*[5.2-2]*/ rxi = 9; if addr_reg (9) > 0 then call rr; /*[5.2-2]*/ do rxi = 0 to 7; /*[5.2-2]*/ call rp; /*[5.2-2]*/ end; /*[5.2-2]*/ end; /*[5.2-2]*/ temp1 = cobol_$text_wd_off - text_wd_off_save; /*[5.2-2]*/ if temp1 ^= 0 /*[5.2-2]*/ then do p = 1 to 3; /*[5.2-2]*/ call md; /*[5.2-2]*/ end; /*[5.2-2]*/ return; rr: proc; /*[5.2-2]*/ do while (addr_reg (rxi) > 0); /*[5.2-2]*/ call release_reg (rxi); /*[5.2-2]*/ addr_reg (rxi) = addr_reg (rxi) - 1; /*[5.2-2]*/ end; end; rp: proc; /*[5.2-2]*/ if addr_reg (rxi) > 0 then call rr; /*[5.2-2]*/ if addr_reg (rxi) > 0 then call rpr; end; rpr: proc; /*[5.2-2]*/ do while (addr_ptr (rxi) > 0); /*[5.2-2]*/ call cobol_pointer_register$priority (2, 0, substr (unspec (rxi), 34, 3)); /*[5.2-2]*/ addr_ptr (rxi) = addr_ptr (rxi) - 1; /*[5.2-2]*/ end; end; md: proc; /*[5.2-2]*/ if aj_const_off (p) ^= 0 /*[5.2-2]*/ then do; temp = binary (string (desc_an.desc_f.y (p))); /*[5.2-2]*/ temp = temp - temp1; /*[5.2-2]*/ string (desc_an.desc_f.y (p)) = substr (unspec (temp), 19, 18); /*[5.2-2]*/ end; end; end; mf: proc; /***..... dcl MY_NAME char (2) int static init ("MF"); /**/ /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME);/**/ /* This procedure is called to set up The i'th modification field and operand */ if input_struc.operand.token_ptr (i) = null () then return; /* Set type 9 ptr */ dn_ptr = input_struc.operand.token_ptr (i); mseg_no = data_name.seg_num; /*[5.2-1]*/ large_array = "0"b; /* To process the special segment mseg_no is between 20000(octal) to 27777(octal) */ if mseg_no > 8191 & mseg_no < 12288 then do; special_bit = "1"b; /*[5.2-1]*/ reg_bit = substr (mseg_no_bit, 25, 1); /*[5.2-1]*/ disp_bit = substr (mseg_no_bit, 29, 1); mf_temp.pr_spec = "1"b; mf_temp.reg_or_length = reg_bit; if disp_bit then mf_temp.reg_mod = substr (mseg_no_bit, 29, 4); else mf_temp.reg_mod = "0000"b; end; else do; special_bit, reg_bit, disp_bit = "0"b; /* Process constants */ if mseg_no = 3000 then do; input_struc.operand.ic_mod (i) = 1; aj_const_off (i) = i; mf_temp.pr_spec = "0"b; mf_temp.reg_mod = "0100"b; /* y=y+c(ic) */ end; else do; mf_temp.pr_spec = "1"b; if ^data_name.subscripted then mf_temp.reg_mod = "0000"b; else do; /* Subscripts processing */ call subscripts; if subs_error = 1 then return; if no_reg_flag = 0 then do; mf_temp.reg_mod = "1000"b; substr (mf_temp.reg_mod, 2, 3) = reg_no; end; else mf_temp.reg_mod = "0000"b; end; end; /* Length is contained in register or instruction */ if input_struc.operand.size_sw (i) = 0 then do; if data_name.item_length > 4095 | data_name.variable_length then mf_temp.reg_or_length = "1"b; else mf_temp.reg_or_length = "0"b; end; end; mf_temp.zero2 = "0"b; /* To set up operand */ if (data_name.bin_36 | data_name.bin_18 | data_name.alphanum | data_name.alphabetic | data_name.alphanum_edited | data_name.alphabetic_edited | data_name.non_elementary | data_name.numeric_edited | data_name.usage_index) then do; call desc_anp; if large_array then if no_reg_flag = 0 then call ptr_adjust; end; else if data_name.numeric then do; call desc_nnp; if large_array then if no_reg_flag = 0 then call ptr_adjust; end; else do; error_message.message = "Illegal data type is specified for eis descriptor " || substr (desc_no_char, i, 1) || "."; call signal_ ("command_abort_", null (), addr (error_message)); end; end; desc_anp: proc; /***..... dcl MY_NAME char (8) int static init ("DESC_ANP"); /**/ /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME);/**/ /* Build alphanumeric descriptor */ desc_an.desc_f.zero1 (i) = "0"b; desc_an.desc_f.ta (i) = "00"b; /* 9 bit */ /* Process constants */ if mseg_no = 3000 then do; temp = -(text_wd_off_save + binary (substr (unspec (data_name.offset), 1, 34))); string (desc_an.desc_f.y (i)) = substr (unspec (temp), 19, 18); desc_an.desc_f.char_n (i) = "000"b; substr (desc_an.desc_f.char_n (i), 1, 2) = substr (unspec (data_name.offset), 35, 2); end; else if special_bit then do; desc_an.desc_f.y.pr (i) = substr (mseg_no_bit, 34, 3); desc_an.desc_f.y.wd_offset (i) = (15)"0"b; desc_an.desc_f.char_n (i) = "000"b; end; else do; temp = data_name.offset; if data_name.subscripted then temp = temp - aj_off; /* adjust offset to 0 occurence */ desc_an.desc_f.char_n (i) = "000"b; substr (desc_an.desc_f.char_n (i), 1, 2) = substr (unspec (temp), 35, 2); if temp < 0 then if mod (temp, 4) ^= 0 then temp = temp - 4; temp = divide (temp, 4, 35, 0); if data_name.subscripted then if (temp < 0 & ^data_name.linkage_section) then call offset_adjust; call get_ar; desc_an.desc_f.y.pr (i) = ptr_no; desc_an.desc_f.y.wd_offset (i) = substr (unspec (temp), 22, 15); end; /* Set length */ if special_bit & reg_bit then do; desc_an.desc_f.n (i) = "000000001000"b; substr (desc_an.desc_f.n (i), 10, 3) = substr (mseg_no_bit, 26, 3); end; else do; if input_struc.operand.size_sw (i) = 0 then do; if data_name.item_length < 4095 & ^data_name.variable_length then desc_an.desc_f.n (i) = substr (unspec (data_name.item_length), 25, 12); else do; desc_an.desc_f.n (i) = "000000001000"b; if data_name.variable_length then substr (desc_an.desc_f.n (i), 10, 3) = var_reg (i); else do; call get_length; substr (desc_an.desc_f.n (i), 10, 3) = reg_no; end; end; end; end; if reloc_ptr ^= null () then call reloc; /***..... if Trace_Bit then call cobol_gen_driver_$Tr_End(MY_NAME);/**/ end; desc_nnp: proc; /***..... dcl MY_NAME char (8) int static init ("DESC_NNP"); /**/ /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME);/**/ /* Build numeric descriptor */ /* 4 bit */ if data_name.ascii_packed_dec then desc_nn.desc_f.tn (i) = "1"b; else desc_nn.desc_f.tn (i) = "0"b; /* 9 bit */ /* Process constants */ if mseg_no = 3000 then do; temp = -(text_wd_off_save + binary (substr (unspec (data_name.offset), 1, 34))); string (desc_nn.desc_f.y (i)) = substr (unspec (temp), 19, 18); /* 4 bit */ if data_name.ascii_packed_dec then do; temp_p = data_name.places_left + data_name.places_right; if data_name.item_signed then temp_p = temp_p + 1; temp1 = 2 * binary (substr (unspec (data_name.offset), 35, 2)); if data_name.ascii_packed_dec_h then if bit_offset = "0101"b then temp1 = temp1 + 1; else ; else temp1 = temp1 + mod (temp_p, 2); desc_nn.desc_f.digit_n (i) = substr (unspec (temp1), 34, 3); end; else do; desc_nn.desc_f.digit_n (i) = "000"b; substr (desc_nn.desc_f.digit_n (i), 1, 2) = substr (unspec (data_name.offset), 35, 2); end; end; else if special_bit then do; desc_nn.desc_f.y.pr (i) = substr (mseg_no_bit, 34, 3); desc_nn.desc_f.y.wd_offset (i) = (15)"0"b; desc_nn.desc_f.digit_n (i) = "000"b; end; else do; temp = data_name.offset; temp_p = data_name.places_left + data_name.places_right; if data_name.item_signed then temp_p = temp_p + 1; if data_name.ascii_packed_dec then do; if data_name.subscripted then temp = temp * 2 - aj_off; else temp = temp * 2; if data_name.ascii_packed_dec_h then if bit_offset = "0101"b then temp = temp + 1; temp1 = binary (substr (unspec (temp), 34, 3)); if ^data_name.ascii_packed_dec_h then temp1 = temp1 + mod (temp_p, 2); desc_nn.desc_f.digit_n (i) = substr (unspec (temp1), 34, 3); if temp < 0 then if mod (temp, 8) ^= 0 then temp = temp - 8; temp = divide (temp, 8, 35, 0); end; else do; if data_name.subscripted then temp = temp - aj_off; desc_nn.desc_f.digit_n (i) = "000"b; substr (desc_nn.desc_f.digit_n (i), 1, 2) = substr (unspec (temp), 35, 2); if temp < 0 then if mod (temp, 4) ^= 0 then temp = temp - 4; temp = divide (temp, 4, 35, 0); end; /* Adjust the 0 occurrence 11/10/75 bc */ if data_name.subscripted then if (temp < 0 & ^(data_name.linkage_section)) then call offset_adjust; call get_ar; desc_nn.desc_f.y.pr (i) = ptr_no; desc_nn.desc_f.y.wd_offset (i) = substr (unspec (temp), 22, 15); end; /* If size_sw is on, the following is ignored */ if input_struc.operand.size_sw (i) = 0 then do; if data_name.variable_length then do; desc_nn.desc_f.n (i) = "001000"b; substr (desc_nn.desc_f.n (i), 4, 3) = var_reg (i); end; else if data_name.ascii_packed_dec then desc_nn.desc_f.n (i) = substr (unspec (temp_p), 31, 6); else desc_nn.desc_f.n (i) = substr (unspec (data_name.item_length), 31, 6); /* Set sign type */ if data_name.sign_type = "000"b then desc_nn.desc_f.sign_type (i) = "11"b; /* no sign */ if data_name.ascii_packed_dec & data_name.item_signed then do; if data_name.ascii_packed_dec_h then desc_nn.desc_f.sign_type (i) = "01"b; /* leading separate */ else desc_nn.desc_f.sign_type (i) = "10"b; /* trailing separate */ end; if data_name.sign_type = "011"b then desc_nn.desc_f.sign_type (i) = "10"b; /* Trailing separate. */ if data_name.sign_type = "100"b /* leading separate */ then desc_nn.desc_f.sign_type (i) = "01"b; /* sign_type "111"b : leading separate for floating decimal */ if data_name.sign_type = "111"b then desc_nn.desc_f.sign_type (i) = "00"b; /* trailing "001" and leading "010" sign types are not supported */ temp1 = -(data_name.places_right); desc_nn.desc_f.scal (i) = substr (unspec (temp1), 31, 6); end; if special_bit & reg_bit then do; substr (desc_nn.desc_f.n (i), 1, 2) = "00"b; substr (desc_nn.desc_f.n (i), 3, 4) = substr (mseg_no_bit, 25, 4); end; if reloc_ptr ^= null () then call reloc; /***..... if Trace_Bit then call cobol_gen_driver_$Tr_End(MY_NAME);/**/ end; offset_adjust: proc; /***..... dcl MY_NAME char(13) int static init ("OFFSET_ADJUST"); /**/ /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME);/**/ /*[5.2-1]*/ dcl (i, j, k, m, l) fixed bin (35); dcl offset_cmp (14) bit (18) static unaligned init ("000000000000000000"b, "001000000000000011"b, /* cmpxn temp,du */ "000000000000000100"b, "110000101000000100"b, /* tpl 4,ic */ "000000000000000000"b, "000110101000000011"b, /* adxn 2**j-mod(temp,2**j),du */ "000000000000000000"b, "000110101000000011"b, /* adxm -2*(divide(temp,2**j)+1),du */ "000000000000000011"b, "111001000000000100"b, /* tra 3,ic */ "000000000000000000"b, "001110000000000011"b, /* sbxn temp,du */ "000000000000000000"b, "000110101000000011"b); /* adxm -2*divide(temp,2**j),du */ temp = -temp + 1; if data_name.ascii_packed_dec then do; i = 16384; j = 15; end; else do; i = 32768; j = 16; end; l = 37 - j; if large_array then do; if temp > (i - 1) then do; k = -2 * divide (temp, i, 35, 0); temp = mod (temp, i); end; else k = 0; /*[5.2-1]*/ call st (1); substr (offset_cmp (2), 7, 3) = reg_no; substr (offset_cmp (6), 7, 3) = reg_no; substr (offset_cmp (12), 7, 3) = reg_no; substr (offset_cmp (8), 7, 3) = table_reg; substr (offset_cmp (14), 7, 3) = table_reg; /*[5.2-1]*/ call st (11); offset_cmp (13) = substr (unspec (k), 19, 18); m = k - 2; offset_cmp (7) = substr (unspec (m), 19, 18); temp = i - temp; /*[5.2-1]*/ call st (5); if m = 0 then do; offset_cmp (3) = "000000000000000011"b; call cobol_emit (addr (offset_cmp (1)), null (), 3); end; else do; offset_cmp (3) = "000000000000000100"b; call cobol_emit (addr (offset_cmp (1)), null (), 4); end; if k = 0 then do; offset_cmp (9) = "000000000000000010"b; call cobol_emit (addr (offset_cmp (9)), null (), 2); end; else do; offset_cmp (9) = "000000000000000011"b; call cobol_emit (addr (offset_cmp (9)), null (), 3); end; end; else if temp ^= 0 /*[5.2-1]*/ then do; call st (11); substr (offset_cmp (12), 7, 3) = reg_no; call cobol_emit (addr (offset_cmp (11)), null (), 1); end; temp = 1; return; st: proc (i); dcl i fixed bin; offset_cmp (i) = substr (unspec (temp), l); end; end offset_adjust; ptr_adjust: proc; /***..... dcl MY_NAME char(10) int static init ("PTR_ADJUST"); /**/ /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME);/**/ /* large arrays */ /* EAQ 0,xm */ inst_b1.wd = "000000000000000000110011110000001000"b; substr (inst_b1.wd, 34, 3) = table_reg; /* QLS 14 */ /*[5.2-1]*/ inst_b1.wd1 = "000000000000001110111011110000000000"b; /* QLS 13 for packed_dec */ /*[5.2-1]*/ if data_name.ascii_packed_dec then substr (inst_b1.wd1, 13, 6) = "001101"b; /* STQ pr6|table_ext_off */ if table_ext_off = 0 then call cobol_alloc$stack (4, 1, table_ext_off); inst_b1.wd2 = "110000000000000000111101110001000000"b; substr (inst_b1.wd2, 4, 15) = substr (unspec (table_ext_off), 22, 15); /* ADWPN pr6|table_ext_off */ inst_b1.wd3 = "110000000000000000000101000001000000"b; substr (inst_b1.wd3, 4, 15) = substr (inst_b1.wd2, 4, 15); if ptr_no = "100"b then substr (inst_b1.wd3, 25, 3) = ptr_no; else do; substr (inst_b1.wd3, 21, 1) = substr (ptr_no, 1, 1); substr (inst_b1.wd3, 26, 2) = substr (ptr_no, 2, 2); end; call cobol_emit (inst_b1_ptr, null (), 4); end; get_length: proc; /* Load length in to index register */ /* ldxn */ inst_b1.wd = "000000000000000000010010000000000011"b; substr (inst_b1.wd, 1, 18) = substr (unspec (data_name.item_length), 19, 18); /*[5.2-2]*/ j = 5; call get_reg (5); substr (inst_b1.wd, 25, 3) = reg_no; call cobol_emit (inst_b1_ptr, null (), 1); end; reloc: proc; if mseg_no = 3002 then do; reloc_struc.left_wd (i + 1) = "11001"b; reloc_struc.right_wd (i + 1) = "11001"b; end; else if mseg_no < 0 then do; reloc_struc.left_wd (i + 1) = "10100"b; reloc_struc.right_wd (i + 1) = "10100"b; end; else do; reloc_struc.left_wd (i + 1) = "00000"b; reloc_struc.right_wd (i + 1) = "00000"b; end; end; get_ar: proc; dcl ar_type fixed bin; /* When cobol_$ptr_assumption_ind=0 the assumptions made about the usage of the pointer registers are valid. The assumptions are: PR0 cobol operator entry (PR6^24) PR3 cobol data 16k (40000 octal) word offset (PR6^64) PR5 cobol data 48k (140000 octal) word offset (PR6^66) (If cobol data is less than 32k, PR5 is used as a temporary) PR4 multices linkage section PR6 stack frame PR1, PR2, PR7, and sometimes PR5 are temporary registers. The use of temporary registers must be requested. */ ar_type = 0; if mseg_no > 4999 & mseg_no < 5008 then ar_type = 1; else if mseg_no = 2 then do; if temp > 262143 then ar_type = 2; else if ^large_array then if temp < 32768 then ar_type = 3; else if temp >= 32768 & temp < 65536 then ar_type = 4; else ar_type = 5; else ar_type = 5; end; else if mseg_no = 4000 | mseg_no = 3 then ar_type = 6; else if mseg_no = 3002 then ar_type = 7; else if mseg_no = 1000 then ar_type = 8; else if mseg_no = 0 | mseg_no > 20000 then do; if input_struc.type ^= 1 & data_name.linkage_section then ar_type = 9; end; else if mseg_no < 0 then ar_type = 10; go to art (ar_type); /* special segment no 500n n=ptr_no */ art (1): ptr_no = substr (unspec (mseg_no), 34, 3); go to artx; art (2): error_message.message = "Illegal offset is specified. It must be <262143"; call signal_ ("command_abort_", null (), addr (error_message)); go to artx; art (3): temp = temp - 16384; ptr_no = "011"b; /* Check pointer register 3 status */ p = 3; /* pointer register 3 */ if ^(ptr_status.seg_num (p) = 2 & ptr_status.wd_offset (p) = 16384) then call reset; go to artx; art (4): temp = temp - 49152; ptr_no = "101"b; /* Check pointer register 5 is set */ p = 5; if ^(ptr_status.seg_num (p) = 2 & ptr_status.wd_offset (p) = 49152) then call reset; go to artx; /* Load temporary pointer register for data >65536 */ /* eppr pr6|156,* 7/9/76 */ art (5): inst_b1.wd = "110000000001101110000000000001010000"b; call get_temp_ar; substr (inst_b1.wd, 19, 10) = eppr_op; substr (inst_b1.wd1, 19, 10) = adwp_op; /* adwpr n,du */ substr (inst_b1.wd1, 29, 8) = "00000011"b; /* i = temp/32768; if i >= 2 then adwp_du = 16384 + i * 32768 */ /*[5.2-3]*/ adwp_du = divide (temp, 32768, 35, 0) * 32768 + 16384; temp = temp - adwp_du; adwp_du = adwp_du - 16384; substr (inst_b1.wd1, 1, 18) = substr (unspec (adwp_du), 19, 18); if adwp_du ^= 0 then call cobol_emit (inst_b1_ptr, null (), 2); else call cobol_emit (inst_b1_ptr, null (), 1); go to artx; art (6): ptr_no = "000"b; /* Check pointer register 0 status */ p = 0; if ^((ptr_status.seg_num (p) = 3 | ptr_status.seg_num (p) = 4000) & ptr_status.wd_offset (p) = 0) then call reset; go to artx; art (7): ptr_no = "100"b; /* Check pointer register 4 status */ p = 4; if ^(ptr_status.seg_num (p) = 3002 & ptr_status.wd_offset (p) = 0) then call reset; go to artx; art (8): ptr_no = "110"b; p = 6; if ^(ptr_status.seg_num (p) = 1000 & ptr_status.wd_offset (p) = 0) then call reset; go to artx; art (9): inst_b1.wd = "110000000000011010000000000001010000"b; /* epp6|26,* */ call get_temp_ar; substr (inst_b1.wd, 19, 10) = eppr_op; /* eppr prr|2*n,* */ substr (inst_b1.wd1, 1, 3) = ptr_no; temp1 = 2 * data_name.linkage; substr (inst_b1.wd1, 4, 15) = substr (unspec (temp1), 22, 15); substr (inst_b1.wd1, 19, 10) = eppr_op; substr (inst_b1.wd1, 29, 8) = "01010000"b; call cobol_emit (inst_b1_ptr, null (), 2); go to artx; art (10): /* eppr pr4|(-mseg_no),* */ inst_b1.wd = "100000000000000000000000000001010000"b; call get_temp_ar; substr (inst_b1.wd, 19, 10) = eppr_op; temp1 = -mseg_no; substr (inst_b1.wd, 4, 15) = substr (unspec (temp1), 22, 15); reloc_b1.r = "10100"b; reloc_b1.l = "10100"b; call cobol_emit (inst_b1_ptr, reloc_b1_ptr, 1); go to artx; /* Error */ art (0): error_message.message = "Segment number error."; call signal_ ("command_abort_", null (), addr (error_message)); artx: return; reset: proc; /* Reset pointer register */ call cobol_reset_r$pointer_register (ptr_no); error_message.message = "the pointer register is reset!"; call signal_ ("command_abort_", null (), addr (error_message)); end; end get_ar; get_temp_ar: proc; /* Get a temporary pointer register 1, 2, 7 or 5 and lock it */ ptr_no = "000"b; /*[5.2-2]*/ rxi = 1; if ptr_status.p_lock (1) = 0 then do; call tl; return; end; /*[5.2-2]*/ rxi = 2; if ptr_status.p_lock (2) = 0 then do; call tl; return; end; /*[5.2-2]*/ rxi = 7; if ptr_status.p_lock (7) = 0 then do; call tl; return; end; /*[5.2-2]*/ rxi = 1; if addr_ptr (1) = 0 then do; call tpr; return; end; /*[5.2-2]*/ rxi = 2; if addr_ptr (2) = 0 then do; call tpr; return; end; /*[5.2-2]*/ rxi = 7; if addr_ptr (7) = 0 then do; call tpr; return; end; /*[5.2-2]*/ rxi = 5; if addr_ptr (5) = 0 then do; call tpr; return; end; error_message.message = "Unable to get a temporary pointer register."; call signal_ ("command_abort_", null (), addr (error_message)); return; tl: proc; /*[5.2-2]*/ ptr_status.p_lock (rxi) = 1; addr_ptr (rxi) = 1; /*[5.2-2]*/ ptr_no = substr (unspec (rxi), 34, 3); call set_adwp; end; tpr: proc; /*[5.2-2]*/ structure.what_pointer = rxi; structure.lock = 1; structure.switch = 0; call cobol_pointer_register$get (struc_ptr); ptr_no = pointer_no; /*[5.2-2]*/ ptr_status.p_lock (rxi) = 1; /*[5.2-2]*/ addr_ptr (rxi) = 1; call set_adwp; end; set_adwp: proc; /*[5.2-2]*/ if rxi = 1 then do; eppr_op = "0111010011"b; adwp_op = "0001010010"b; /* 051(0) */ end; /*[5.2-2]*/ else if rxi = 2 then do; eppr_op = "0111010100"b; /* 352(0) */ adwp_op = "0001010100"b; /* 052(0) */ end; /*[5.2-2]*/ else if rxi = 7 then do; eppr_op = "0111110111"b; adwp_op = "0011010110"b; /* 153(0) */ end; /*[5.2-2]*/ else if rxi = 5 then do; eppr_op = "0111110011"b; adwp_op = "0011010010"b; /* 151(0) */ end; end; end get_temp_ar; get_reg: proc (reg); /* If the reg_assumption_ind is on, then the assumptions made about the usage of the index registers are valid. The use of A or Q register must be requested. The index register usage are: 0: return address cobol operator 1: temporary 2: address modification 3: address modification 4: address modification 5: eis operand length 6: eis operand length 7:eis operand length If the above suggested registers are not available other registers will be used. The registers are temporarily locked for cobol_addr. They will be unlocked at cobol_addr exit unless directed otherwise. */ /*[5.2-2]*/ dcl reg fixed bin; /*[5.2-2]*/ rx = reg; r_max = 7; do while ("1"b); if reg_status.r_lock (rx) = 0 & addr_reg (rx) = 0 then do; reg_status.r_lock (rx) = 1; reg_no = substr (unspec (rx), 34, 3); addr_reg (rx) = addr_reg (rx) + 1; return; end; else do; rx = rx + 1; if rx <= r_max then ; else if reg = 5 /*[5.2-2]*/ then do; rx, j = 1; r_max = 4; end; else if reg = 2 /*[5.2-2]*/ then do; rx, j = 1; r_max = 1; end; else do; do rx = 1 to 7; if addr_reg (rx) = 0 then do; reg_struc.what_reg = rx + 10; reg_struc.lock = 1; call cobol_register$load (reg_struc_ptr); reg_no = substr (reg_struc.reg_num, 2, 3); addr_reg (fixed (reg_no)) = addr_reg (fixed (reg_no)) + 1; return; end; end; error_message.message = "Unable to get an index register"; call signal_ ("command_abort_", null (), addr (error_message)); end; end; end; end; get_a_q: proc (reg); /*[5.2-2]*/ dcl reg fixed bin; /* Requested A or Q register */ /* rx=8 for A-reg. rx=9 for Q-reg. */ reg_struc.lock = 1; /*[5.2-2]*/ if reg ^= 10 /*[5.2-2]*/ then if reg_status.r_lock (reg) = 0 /*[5.2-2]*/ then do; reg_status.r_lock (reg) = 1; /*[5.2-2]*/ addr_reg (reg) = addr_reg (reg) + 1; /*[5.2-2]*/ if reg = 8 then reg_struc.reg_num = "0001"b; /*[5.2-2]*/ else if reg = 9 then reg_struc.reg_num = "0010"b; return; end; /*[5.2-2]*/ if reg = 10 then reg_struc.reg_num = "0011"b; reg_struc.what_reg = reg - 7; call cobol_register$load (reg_struc_ptr); reg_no = substr (reg_struc.reg_num, 2, 3); addr_reg (fixed (reg_no)) = addr_reg (fixed (reg_no)) + 1; end; release_reg: proc (reg); /*[5.2-2]*/ dcl (reg, r, ar) fixed bin; /*[5.2-2]*/ r = reg; /*[5.2-2]*/ if r ^= 10 /*[5.2-2]*/ then do; ar = addr_reg (r); /*[5.2-2]*/ if ar ^= 0 then addr_reg (r) = ar - 1; /*[5.2-2]*/ end; /*[5.2-2]*/ if r < 8 then r = r + 8; else r = r - 7; /*[5.2-2]*/ reg_struc.reg_num = substr (unspec (r), 33, 4); call cobol_register$release (reg_struc_ptr); end; subscripts: proc; /***..... dcl MY_NAME char (10) int static init ("SUBSCRIPTS"); /**/ /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME);/**/ dcl desc_nn_ptr_save ptr; dcl 1 token_temp based (temp_ptr), 2 filler4 char (12), 2 type fixed bin; dcl (a_lock_save, q_lock_save) fixed bin; dcl mpy_bit bit (1) static init ("0"b); dcl subs_token_ptr ptr based (subs_ptr); dcl (subs_no, l, n, index_temp, distance, stack_off, al_char, al_bd, index_temp_off, dtb_temp_off) fixed bin; dcl wd_count fixed bin; dcl packed_dec_bit bit (1) init ("0"b); dcl ind_count fixed bin init (0); dcl temp_save fixed bin; dcl (size_sw_save, i_save, mseg_no_save, occ_no) fixed bin; dcl (subs_ptr, dn_ptr_save, lit_ptr, temp_ptr, inst_buff_ptr, reloc_buff_ptr, reloc_ptr_save) pointer; dcl plus_sw bit (1); dcl subs_var fixed bin; /* Instruction buffer */ dcl 1 inst_buff aligned, 2 inst_wd (50) bit (36); dcl dtb_alloc fixed bin; /* move_ data */ dcl move_in_token (1:10) ptr int static; dcl temp_wk_ptr ptr; dcl move_data_init fixed bin int static init (0); dcl move_token_ptr ptr; dcl cobol_move_gen entry (ptr); dcl cobol_make_type9$long_bin entry (ptr, fixed bin, fixed bin); dcl 1 move_eos int static, 2 size fixed bin (15), 2 line fixed bin (15), 2 column fixed bin (15), 2 type fixed bin (15) init (19), 2 verb fixed bin (15) init (18), 2 e fixed bin (15) init (1); dcl index_array_i fixed bin, index_save_flag fixed bin, save_temp_ptr ptr, index_i fixed bin, index_opti_flag fixed bin; dcl 1 index_array (48), 2 max fixed bin, 2 min fixed bin, 2 struc_l fixed bin, 2 item_count fixed bin, 2 seg_num fixed bin, 2 offset fixed bin, 2 index_reg bit (3); /* Set occurs extension */ occurs_ptr = addrel (dn_ptr, substr (unspec (data_name.occurs_ptr), 17, 18)); /* Set subscripts token ptr */ /*[5.2-1]*/ subs_ptr = addrel (baseptr (S_T.subs_segno), S_T.subs_offset); /* Collect subscripts info */ subs_error = 0; subs_no = occurs.dimensions; if subs_no > 3 then do; error_message.message = "OCCURS dimension must not be greater then 3."; call signal_ ("command_abort_", null (), addr (error_message)); call subs_err; return; end; mpy_bit = "0"b; aj_off = 0; index_array_i = 0; table_ext_off = 0; table_length = 1; if data_name.ascii_packed_dec then packed_dec_bit = "1"b; do l = 1 to subs_no; if input_struc.type = 2 | input_struc.type = 3 then struc_l (l) = binary (substr (unspec (occurs.level.struc_length (l)), 1, 33)); else if packed_dec_bit then struc_l (l) = occurs.level.struc_length (l); else struc_l (l) = divide (occurs.level.struc_length (l), 2, 35, 0); aj_off = aj_off + struc_l (l); max (l) = occurs.level.max (l); /*[4.2-1]*/ min (l) = 1; /*[4.4-2]*/ /* table_length=table_length*max(l); */ end; /* Save dn_ptr of the cobol_addr caller. It must be restored at return.*/ /*[4.4-2]*/ table_length = struc_l (1) * max (1); large_array = "0"b; if table_length > 65536 then if packed_dec_bit | (table_length > 131072) then large_array = "1"b; if fixed_common.options.oc then do; retry_tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_define_tag_nc (retry_tag, cobol_$text_wd_off); end; dn_ptr_save = dn_ptr; temp_save = temp; mseg_no_save = mseg_no; reloc_ptr_save = reloc_ptr; reloc_ptr = null (); /* Initialize */ dtb_alloc = 0; l = 0; index_temp = 0; wd_count = 0; subs_var = 0; inst_buff_ptr = addr (inst_buff); reloc_buff_ptr = null (); /* Test for token type */ /* Set temp_ptr to point at 1st token */ temp_ptr = subs_token_ptr; go to subs_; do while ("1"b); next_subs_: /* Set temp_ptr to the next token */ subs_ptr = addrel (subs_ptr, -2); temp_ptr = subs_token_ptr; /* Subscripts processing */ subs_: l = l + 1; item_count (l) = 1; index_save_flag = 0; index_opti_flag = 0; if l > subs_no | temp_ptr = null () then do; call end_subs_proc; go to subx; end; /***..... if Trace_Bit then call ioa_("^a^a^d",substr(Trace_Line,Trace_Lev+1,1)," TYPE = ",token_temp.type);/**/ if token_temp.type = 10 then do; ind_count = ind_count + 1; call indexing; if err then call subs_err; go to subx; end; if token_temp.type = 2 then do; nlit_ptr = temp_ptr; plus_sw = "1"b; call subs_2; index_temp = index_temp + distance; if fixed_common.options.oc & (occ_no < 1 | occ_no > occurs.level.max (l)) then call cobol_gen_error$reg_reset (61, retry_tag); go to next_subs_; end; /* Process type 9 data name subscript */ if token_temp.type ^= 9 then do; call subs_err; go to subx; end; dn_ptr = temp_ptr; mseg_no = data_name.seg_num; subs_var = subs_var + 1; /* Allocate temp for object time dec_to_bin conversion */ dtb_alloc = dtb_alloc + 1; if dtb_alloc = 1 then do; al_char = 4; al_bd = 1; call cobol_alloc$stack (al_char, al_bd, stack_off); dtb_temp_off = stack_off; /* Allocate temp for index */ call cobol_alloc$stack (al_char, al_bd, stack_off); index_temp_off = stack_off; end; /* Call move_ for overpunch sign */ res = "1"b; if (data_name.item_signed) & (^data_name.sign_separate) & (^data_name.bin_36) & (^data_name.bin_18) then do; call cobol_emit (inst_buff_ptr, reloc_buff_ptr, wd_count); wd_count = 0; call move_; end; else do; if wd_count ^= 0 then call cobol_emit (inst_buff_ptr, reloc_buff_ptr, wd_count); /* DTB */ wd_count = 1; if data_name.bin_36 | data_name.bin_18 then do; /*[5.2-2]*/ rx = 9; call get_a_q (9); desc_nn_ptr_save = desc_an_ptr; desc_an_ptr = addr (inst_buff.inst_wd (wd_count)); i_save = i; size_sw_save = input_struc.operand.size_sw (i); input_struc.operand.size_sw (i) = 0; i = 1; large_array_save = large_array; large_array = "0"b; call desc_anp; large_array = large_array_save; desc_an_ptr = desc_nn_ptr_save; i = i_save; input_struc.operand.size_sw (i) = size_sw_save; if mseg_no = 3000 then substr (inst_buff.inst_wd (wd_count), 19, 18) = "010011110000000100"b; else substr (inst_buff.inst_wd (wd_count), 19, 18) = "010011110001000000"b; if data_name.bin_18 & (substr (unspec (data_name.offset), 35, 2) = "00"b) then do; wd_count = wd_count + 1; inst_buff.inst_wd (wd_count) = "000000000000010010111011010000000000"b; end; res = "0"b; end; else do; inst_buff.inst_wd (wd_count) = "000000000001000000011000101101000000"b; if mseg_no = 3000 then substr (inst_buff.inst_wd (wd_count), 12, 7) = "0000100"b; /* Get desc_nnp to build the nummeric descriptor for word 2 */ /* Save info of the current instruction of the caller */ wd_count = wd_count + 1; desc_nn_ptr_save = desc_nn_ptr; desc_nn_ptr = addr (inst_buff.inst_wd (wd_count)); i_save = i; large_array_save = large_array; large_array = "0"b; size_sw_save = input_struc.operand.size_sw (1); input_struc.operand.size_sw (1) = 0; i = 1; call desc_nnp; /* restore caller info */ large_array = large_array_save; desc_nn_ptr = desc_nn_ptr_save; i = i_save; input_struc.operand.size_sw (1) = size_sw_save; /* Build DTB word 3 */ wd_count = wd_count + 1; inst_buff.inst_wd (wd_count) = "110000000000000000000000000000000100"b; substr (inst_buff.inst_wd (wd_count), 4, 15) = substr (unspec (dtb_temp_off), 22, 15); /* If binary data is supported and the data name is binary then the above instruction is not needed */ end; /*[5.3-3]*/ call cobol_pointer_register$priority (2, 0, ptr_no); /*[5.3-3]*/ addr_ptr (fixed (ptr_no)) = 0; end; if res then do; if wd_count ^= 0 then call cobol_emit (inst_buff_ptr, reloc_buff_ptr, wd_count); /* Build LDQ instruction*/ /*[5.2-2]*/ rx = 9; call get_a_q (9); wd_count = 1; inst_buff.inst_wd (wd_count) = "110000000000000000010011110001000000"b; substr (inst_buff.inst_wd (wd_count), 4, 15) = substr (unspec (dtb_temp_off), 22, 15); end; /* The following block are for subscript check. 5/29/76 bc */ if fixed_common.options.oc then do; call cobol_emit (inst_buff_ptr, reloc_buff_ptr, wd_count); wd_count = 0; check_tag (1) = cobol_$next_tag; check_tag (2) = cobol_$next_tag + 1; cobol_$next_tag = cobol_$next_tag + 2; inst_seq (4) = "110000101000000100"b; occurs_limit_ptr = addr (min (l)); oci = 1; res = "1"b; do while (res); /*[5.2-1]*/ temp_24 = temp; call cobol_pool (occurs_limit, 1, temp_24); /*[5.2-1]*/ temp = -cobol_$text_wd_off - temp_24; substr (inst_seq (1), 1, 18) = substr (unspec (temp), 19, 18); if oci = 1 then do; call cobol_emit (addr (inst_seq (1)), null (), 2); call cobol_make_tagref (check_tag (oci), cobol_$text_wd_off - 1, null ()); call cobol_define_tag_nc (check_tag (2), cobol_$text_wd_off); call cobol_gen_error$reg_reset (61, retry_tag); oci = 2; occurs_limit_ptr = addr (occurs.level.max (l)); inst_seq (4) = "110000101100000100"b; /* tpnz */ call cobol_define_tag_nc (check_tag (1), cobol_$text_wd_off); end; else do; call cobol_emit (addr (inst_seq (1)), null (), 2); call cobol_make_tagref (check_tag (oci), cobol_$text_wd_off - 1, null ()); res = "0"b; end; end; end; /* Build MPY instruction */ temp = mod (struc_l (l), 262144); call mpy_; /* Build ASQ instruction */ wd_count = wd_count + 1; inst_buff.inst_wd (wd_count) = "110000000000000000000101110001000000"b; substr (inst_buff.inst_wd (wd_count), 4, 15) = substr (unspec (index_temp_off), 22, 15); if dtb_alloc = 1 then substr (inst_buff.inst_wd (wd_count), 19, 9) = "111101110"b; /* Use STQ 756 */ if large_array then if struc_l (l) >= 262144 then do; wd_count = wd_count + 1; inst_buff.inst_wd (wd_count) = "110000000000000000010011110001000000"b; /* LDQ */ substr (inst_buff.inst_wd (wd_count), 4, 15) = substr (unspec (dtb_temp_off), 22, 15); /* MPY or QLS */ temp = divide (struc_l (l), 262144, 35, 0); call mpy_; /*[5.2-2]*/ if mj = 0 then do; wd_count = wd_count + 1; inst_buff.inst_wd (wd_count) = "000000000000010010111011110000000000"b; end; /*[5.2-2]*/ else do; mj = mj + 18; /*[5.2-2]*/ substr (inst_buff.inst_wd (wd_count), 1, 18) = substr (unspec (mj), 19, 18); end; wd_count = wd_count + 1; /* ASQ pr */ inst_buff.inst_wd (wd_count) = inst_buff.inst_wd (wd_count - 3); substr (inst_buff.inst_wd (wd_count), 19, 6) = "000101"b; end; call cobol_emit (inst_buff_ptr, reloc_buff_ptr, wd_count); wd_count = 0; /*[5.2-2]*/ rx = 9; call release_reg (9); if mpy_bit then do; mpy_bit = "0"b; /*[5.2-2]*/ rx = 8; call release_reg (8); end; end; subs_err: proc; error_message.message = "Subscripts or index error is encountered"; call signal_ ("command_abort_", null (), addr (error_message)); subs_error = 1; call end_subscription; end; /*[5.2-2]*/ dcl mj fixed bin; mpy_: proc; /* Generate mpy instruction or qls instruction. */ /* passing temp as the constant to be multiplied.*/ /*[5.2-2]*/ dcl i fixed bin, bit_temp bit (18), bit_test (18) bit (1) defined (bit_temp); /*[5.2-2]*/ mj = 0; if temp = 1 then return; wd_count = wd_count + 1; if temp = 0 then do; inst_buff.inst_wd (wd_count) = "000000000000000000011111110000000111"b; return; end; bit_temp = substr (unspec (temp), 19, 18); do i = 1 to 18; if bit_test (i) then do; if substr (bit_temp, i + 1, 18 - i) then go to mpy_inst; /*[5.2-2]*/ else do; mj = 18 - i; go to qls_inst; end; end; end; mpy_inst: /*[5.2-2]*/ if mj = 0 then do; if ^(mpy_bit) then do; mpy_bit = "1"b; /*[5.2-2]*/ rx = 8; call get_a_q (8); end; /* mpy */ inst_buff.inst_wd (wd_count) = "000000000000000000100000010000000111"b; substr (inst_buff.inst_wd (wd_count), 1, 18) = substr (unspec (temp), 19, 18); return; end; qls_inst: /* qls */ inst_buff.inst_wd (wd_count) = "000000000000000000111011110000000000"b; /*[5.2-2]*/ substr (inst_buff.inst_wd (wd_count), 1, 18) = substr (unspec (mj), 19, 18); end; move_: proc; /* This procedure calls move_gen to move overpunch sign data to temp */ /* init */ move_token_ptr = addr (move_in_token (1)); if move_data_init ^= cobol_$compile_count then do; move_token_ptr -> in_token.token_ptr (1) = null (); move_token_ptr -> in_token.token_ptr (4) = addr (move_eos); move_token_ptr -> in_token.n = 4; move_data_init = cobol_$compile_count; end; temp_wk_ptr = null (); call cobol_make_type9$long_bin (temp_wk_ptr, 1000, dtb_temp_off * 4); move_token_ptr -> in_token.token_ptr (2) = dn_ptr;/* type 9 */ move_token_ptr -> in_token.token_ptr (3) = temp_wk_ptr; /* temp for result */ call cobol_move_gen (move_token_ptr); end; subs_2: proc; /* This procedure calculate the distance, i. e. the relative offset to 0 occurence */ nlit_ptr = temp_ptr; /* Convert numeric literal to binary */ occ_no = fixed (temp_ptr -> numeric_lit.literal); distance = struc_l (l) * occ_no; if ^plus_sw then distance = -distance; end; table_ext_: proc; /* This procedure is used to generate those codes which builds up the table register at the execution time */ wd_count = wd_count + 1; /*[5.2-2]*/ j = 5; call get_reg (5); table_reg = reg_no; /*[5.2-2]*/ j = 2; call get_reg (2); /*[5.0-1]*/ if ind then if ^packed_dec_bit /*[5.0-1]*/ then do; inst_buff.inst_wd (wd_count) = "00000000000000000111101101"b; /* QRS 1 */ /*[5.0-1]*/ wd_count = wd_count + 1; /*[5.0-1]*/ end; inst_buff.inst_wd (wd_count) = "000000000000000000110010000000000110"b; /* EAXN 0,ql */ substr (inst_buff.inst_wd (wd_count), 25, 3) = reg_no; wd_count = wd_count + 1; inst_buff.inst_wd (wd_count) = "00000000000000001011101111"b; /* QLS 2 */ wd_count = wd_count + 1; /* STQ pr6|table_ext_off */ if table_ext_off = 0 then call cobol_alloc$stack (4, 1, table_ext_off); inst_buff.inst_wd (wd_count) = "110000000000000000111101110001000000"b; substr (inst_buff.inst_wd (wd_count), 4, 15) = substr (unspec (table_ext_off), 22, 15); /* LDXM pr6|table_ext_off */ wd_count = wd_count + 1; inst_buff.inst_wd (wd_count) = "110000000000000000010010000001000000"b; substr (inst_buff.inst_wd (wd_count), 4, 15) = substr (inst_buff.inst_wd (wd_count - 1), 4, 15); substr (inst_buff.inst_wd (wd_count), 25, 3) = table_reg; wd_count = wd_count + 1; /* ANXN 177777,du */ inst_buff.inst_wd (wd_count) = "001111111111111111011110000000000011"b; substr (inst_buff.inst_wd (wd_count), 25, 3) = reg_no; end; end_subs_proc: proc; if subs_var > 0 /* load variable subscripts sum to index reg */ then do; no_reg_flag = 0; wd_count = wd_count + 1; if large_array then do; rx = 9; /*[5.2-2]*/ call get_a_q (9); inst_buff.inst_wd (wd_count) = "110000000000000000010011110001000000"b; /* LDQ pr6|n */ substr (inst_buff.inst_wd (wd_count), 4, 15) = substr (unspec (index_temp_off), 22, 15); /*[5.0-1]*/ ind = "0"b; call table_ext_; /*[5.2-2]*/ call release_reg (9); end; else do; inst_buff.inst_wd (wd_count) = "110000000000000000111010010001000000"b; /* LXLN pr6|n */ /*[5.2-2]*/ j = 2; call get_reg (2); substr (inst_buff.inst_wd (wd_count), 25, 3) = reg_no; substr (inst_buff.inst_wd (wd_count), 4, 15) = substr (unspec (index_temp_off), 22, 15); end; end; /* Add literal subscripts sum to index reg */ aj_off = aj_off - index_temp; if subs_var = 0 then no_reg_flag = 1; call emit; end; emit: proc; /* Fix the bug for literal subscript in type 7 addressing. 02-24-77 */ if t = 7 & index_temp ^= 0 then do; wd_count = wd_count + 1; if wd_count = 1 /*[5.2-2]*/ then do; j = 2; call get_reg (2); inst_buff.inst_wd (1) = "000000000000000000010010000000000011"b; end; else inst_buff.inst_wd (wd_count) = "000000000000000000000110000000000011"b; substr (inst_buff.inst_wd (wd_count), 1, 18) = substr (unspec (index_temp), 19, 18); substr (inst_buff.inst_wd (wd_count), 25, 3) = reg_no; end; /* Restore content of A & Q */ /* Emit instructions */ if wd_count ^= 0 then call cobol_emit (inst_buff_ptr, reloc_buff_ptr, wd_count); call end_subscription; end; indexing: proc; /***..... dcl MY_NAME char (8) int static init ("INDEXING"); /**/ /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME);/**/ err = "0"b; do while ("1"b); ind_ptr = temp_ptr; if token_temp.type ^= 10 then do; err = "1"b; go to indx; end; no_reg_flag = 0; if (index_array_flag ^= 0) & (^packed_dec_bit) & (item_count (l) = 1) & ^large_array & (subs_no = 1) then do; save_temp_ptr = addrel (subs_ptr, -2); if save_temp_ptr ^= null () then if save_temp_ptr -> token_temp.type ^= 1 then do; index_save_flag = 1; if index_array_i > 0 then do index_i = 1 to index_array_i; if (index_name.seg_num = index_array.seg_num (index_i)) & (index_name.offset = index_array.offset (index_i)) then do; index_opti_flag = 1; reg_no = index_array.index_reg (index_i); call end_index_proc; call emit; go to indx; end; end; wd_count = wd_count + 1; end; end; else wd_count = wd_count + 1; /* LDQ 236 */ inst_buff.inst_wd (wd_count) = "000000000000000000010011110001000000"b; temp = binary (substr (unspec (index_name.offset), 1, 34)); mseg_no = index_name.seg_num; call get_ar; substr (inst_buff.inst_wd (wd_count), 1, 3) = ptr_no; substr (inst_buff.inst_wd (wd_count), 4, 15) = substr (unspec (temp), 22, 15); if ind_count > 1 then substr (inst_buff.inst_wd (wd_count), 19, 9) = "000111110"b; /* ADQ 076 */ /* Release the temp pointer reg. for subscript. 1/20/76 bc */ call cobol_pointer_register$priority (2, 0, ptr_no); addr_ptr (fixed (ptr_no)) = 0; res = "1"b; /* Get next token */ do while (res); subs_ptr = addrel (subs_ptr, -2); temp_ptr = subs_token_ptr; if temp_ptr = null () then do; l = l + 1; call end_index_proc; call emit; go to indx; end; else if token_temp.type = 1 then do; item_count (l) = item_count (l) + 1; call indx_1; if err then go to indx; call subs_2; index_temp = index_temp + distance; end; else do; l = l + 1; if l > subs_no then do; call end_index_proc; call emit; go to indx; end; item_count (l) = 1; index_save_flag = 0; index_opti_flag = 0; if token_temp.type = 10 then do; ind_count = ind_count + 1; res = "0"b; end; else do; if token_temp.type = 2 then plus_sw = "1"b; else do; call indx_1; if err then go to indx; end; call subs_2; index_temp = index_temp + distance; end; end; end; end; indx: /***..... if Trace_Bit then call cobol_gen_driver_$Tr_End(MY_NAME);/**/ end; indx_1: proc; if token_temp.type = 1 then do; rw_ptr = temp_ptr; if reserved_word.key = 182 then plus_sw = "1"b; else plus_sw = "0"b; end; subs_ptr = addrel (subs_ptr, -2); temp_ptr = subs_token_ptr; if token_temp.type ^= 2 then err = "1"b; end; end_index_proc: proc; /* EAXn|0,QL */ /*[5.0-1]*/ if large_array /*[5.0-1]*/ then do; ind = "1"b; call table_ext_; end; else if index_opti_flag = 0 then do; if ^packed_dec_bit then do; wd_count = wd_count + 1; inst_buff.inst_wd (wd_count) = "000000000000000001111111010000000000"b; end; wd_count = wd_count + 1; inst_buff.inst_wd (wd_count) = "000000000000000000110010000000000110"b; /*[5.2-2]*/ j = 2; call get_reg (2); substr (inst_buff.inst_wd (wd_count), 25, 3) = reg_no; if index_save_flag = 1 then do; index_array_i = index_array_i + 1; index_array.seg_num (index_array_i) = index_name.seg_num; index_array.offset (index_array_i) = index_name.offset; index_array.index_reg (index_array_i) = reg_no; end; end; aj_off = aj_off - index_temp; end; end_subscription: proc; dn_ptr = dn_ptr_save; temp = temp_save; reloc_ptr = reloc_ptr_save; mseg_no = mseg_no_save; end; subx: /***..... if Trace_Bit then call cobol_gen_driver_$Tr_End(MY_NAME);/**/ end subscripts; dcl dn_ptr ptr; /* dn_ptr always points to the current type 9 token.*/ dcl err bit (1); /* temp struc to get subscripts token pointer */ dcl 1 S_T based (dn_ptr), /*[5.2-1*/ 2 filler1 char (16), 2 subs_segno bit (18) unaligned, 2 subs_offset bit (18) unaligned, 2 filler2 char (24); /* emit generator */ dcl cobol_emit entry (ptr, ptr, fixed bin); /* Error handler */ dcl signal_ entry (char (*), ptr, ptr); dcl 1 error_message, /* [3.0-1] */ 2 name char (32), /* [3.0-1] */ 2 length fixed bin, /* [3.0-1] */ 2 message char (80); /*[5.2-2]*/ dcl (i, j, rxi, mseg_no, t, temp1, dec_bin_temp, aj_off, temp_p) fixed bin init (0); /*[5.2-1]*/ dcl temp fixed bin (35) init (0), temp_24 fixed bin (24); dcl (ptr_no, reg_no) bit (3) init ("000"b); dcl mseg_no_bit bit (36) based (addr (mseg_no)), (special_bit, reg_bit, disp_bit) bit (1) init ("0"b), mf_ptr ptr, mf_bit bit (7) based (mf_ptr), 1 mf_temp based (mf_ptr), 2 pr_spec bit (1) unaligned, 2 reg_or_length bit (1) unaligned, 2 zero2 bit (1) unaligned, 2 reg_mod bit (4) unaligned; dcl desc_no_char char (3) init ("123"); /* For sign/unsign. */ /*dcl mvt_table char(128) static int init( /* "00000000000000000000000000000000000000000000000001234567890000000123456789123456789000000000000000000000000000000000000000000000"); /*dcl (mvt_rel_off,mvt_temp_off) fixed bin, /* mvt_init fixed bin(24) static int init(0); /*dcl mvt_off fixed bin(24) static int init(0); */ dcl 1 inst_b1 aligned, 2 wd bit (36), 2 wd1 bit (36), 2 wd2 bit (36), 2 wd3 bit (36), 2 wd4 bit (36); dcl cobol_reset_r$pointer_register entry (bit (3)); dcl eppr_op bit (10); dcl adwp_op bit (10); dcl res bit (1); dcl (rx, r_max) fixed bin; dcl adwp_du fixed bin (35); dcl addr_reg (0:9) fixed bin; dcl addr_ptr (0:9) fixed bin; dcl inst_b1_ptr ptr; dcl reloc_b1_ptr ptr; dcl 1 reloc_b1, 2 l bit (5) aligned, 2 r bit (5) aligned; dcl b1_count fixed bin; dcl p fixed bin; /* used by get_ar */ dcl index_array_flag fixed bin, index_array_i fixed bin; dcl ar_buff char (32); /* buffer for structure */ dcl subs_error fixed bin; /* If =1, subscripting error is encountered */ dcl aj_const_off (3) fixed bin; /* Ajust constant offset if cobol_addr emits codes */ dcl no_reg_flag fixed bin; dcl text_wd_off_save fixed bin; dcl large_array bit (1) init ("0"b), large_array_save bit (1), table_reg bit (3), table_para fixed bin (35) init (65536), table_range fixed bin, table_ext_off fixed bin, table_length fixed bin (35); dcl opr fixed bin, ind bit (1); /* subscript check. */ dcl retry_tag fixed bin, check_tag (2) fixed bin, occurs_limit_ptr ptr, occurs_limit char (4) based (occurs_limit_ptr), oci fixed bin, inst_seq (6) bit (18) static init ("000000000000000000"b, "001001110000000100"b, /* cmpq range,ic */ "000000000000000010"b, "110000101000000100"b, /* tpl good,ic */ "000000000000000000"b, "111001000000000100"b); /* tra error,ic */ /* Declaration for external entries. */ dcl cobol_get_size entry (ptr, fixed bin, fixed bin); dcl cobol_register$release entry (ptr); dcl cobol_register$load entry (ptr); dcl cobol_define_tag_nc entry (fixed bin, fixed bin); dcl cobol_make_tagref entry (fixed bin, fixed bin, ptr); dcl cobol_pool entry (char (*), fixed bin, fixed bin (24)) ext; dcl cobol_alloc$stack entry (fixed bin, fixed bin, fixed bin); dcl cobol_gen_error$reg_reset entry (fixed bin, fixed bin); dcl cobol_pointer_register$get entry (ptr); dcl cobol_pointer_register$priority entry (fixed bin, fixed bin, bit (3)); /* Pointer register manager */ /* This entry obtains a pointer register for the caller. */ dcl struc_ptr ptr; /* struc_ptr is a pointer to the following structure. (input) */ dcl 1 structure based (struc_ptr), 2 what_pointer fixed bin, 2 pointer_no bit (3), 2 lock fixed bin, 2 switch fixed bin, 2 segno fixed bin, 2 offset fixed bin (24), 2 reset fixed bin; /* what_pointer specifies the pointer register to be obtained. (input) 0-7 - get this pointer register. 10 - get any temporary pointer register. pointer_no is the register that is assigned, in the range 0-7. (output) lock can have the following values. (input) 0 - did not change the lock or unlock status of this pointer. 1 - lock the pointer register. 2 - unlock all pointer registers. 3 - unlock all pointer registers and A register and Q register and all index registers. switch has the following values. (input) 0 - the register will not contain a value that is meaningful for register optimization. Segment number and offset are meaningless. 1 - a segment number and word offset are supplied. 2 - a segment number and character offset are supplied segno is the segment number. (input) values recognized are: 2 - cobol data. 1000 - stack. 3000 - constants. 3002 - multics linkage. 4000 - cobol operators. 2nnnn - cobol linkage. -n - link in multics linkage. offset is the word or character offset (depending on switch). Any case when the offset is meaningless a 0 value must be used. If a character offset is provided only the word portion is meaningful. (input) reset specifies that the caller has requested a register that must have a preset value. For example a preset register to cobol data or the pointer to pl/1 operators (likely). This is only of interest to callers who request a specific register (what_pointer = 0-7) Such callers should test reset. If it is 1, a call to cobol_reset_r should be made in order to emit instructions to reload the register to its proper value. Notes: 1. If switch has a non zero value and the pointer register did not contain the specified segno and offset this utility will emit instructions to load the pointer register. 2. (a) Generally a register should not be locked. (b) Exceptions would be the case when (1) several calls must be make to this utility and the caller did not wish to obtain the same register (2) Calls to this utility are interspurced with calls to the addressability utilities and the user did not wish to obtain the same register. 3. There is no need to call to get pointer register 6 (the stack frame). We can always assume this is set. 4. If the caller requests a specific pointer register who's priority was lock a compile time error will occur. This may change if we need more sophisticated pointer register handling. */ /***..... dcl 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); /**/ /* The followings are for the register structure */ dcl reg_struc_ptr ptr, /* reg_struc_ptr is a pointer to the following structure (input) */ 1 reg_struc, 2 what_reg fixed bin, 2 reg_num bit (4), 2 lock fixed bin, 2 already_there fixed bin, 2 contains fixed bin, 2 pointer ptr, 2 literal bit (36); /* what_reg specifies the register to be obtained. (input) 0 - A or Q or any index register. 1 - A register. 2 - Q register. 3 - A and Q registers. 4 - A or Q register. 5 - any index register. 1n - index register n. reg_num is the register that is assigned. (output). 1 - A register. 2 - Q register. 3 - A and Q registers. 1n - index register n. lock can have the following values. (input). 0 - do not change the lock or unlock status of the register. 1 - lock this register. 2 - unlock all index registers and the A and Q registers. 3 - unlock all index registers and the A and Q registers and all pointer registers. already_there has the followoutg values. (output). 0 - the register must be loaded. 1 - the specified contents are already in the register and it does not need to loaded. contains specifies the form of the contents of the register. (input). 0 - the register will not contain a value that is meaningful for register optimatization. pointer and literal are not meaningful. 1 - the register will contain a data item. pointer must have a meaningful value. 2 - the register will contain the value specified in "literal". 3 - the register will contain a computed subscript, pointer must have a meaningful value. 4 - the register will contain a computed index, pointer must have a meaningful value. 5 - the register will contain a modified computed index, pointer must have a meaningful value. Note: The values 3, 4 and 5 are intended for the use by the addressibility handler and should not be of interest to the most generators. pointer is one of the following: (a) - A pointer to a type 9 token. In this case "contains" is 1 (data item). (b) - A pointer to a structure (to be defined) for index or subscript computations. In this case, "contains" is 3 (subscript), 4 (index) or 5 (modified index). literal is the literal value that will be in the register. */ dcl var_reg (3) bit (3); /***** Declaration for builtin function *****/ dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index, divide) builtin; /***** End of declaration for builtin function *****/ %include cobol_addr_tokens; %include cobol_type9; %include cobol_occurs_ext; %include cobol_; dcl 1 ptr_status (0:7) based (cobol_$ptr_status_ptr) aligned, %include cobol_ptr_status; dcl 1 reg_status (0:9) based (cobol_$reg_status_ptr) aligned, %include cobol_reg_status; %include cobol_type10; %include cobol_type1; %include cobol_type2; %include cobol_in_token; %include cobol_type18; %include cobol_fixed_common; %include cobol_ext_; end cobol_addr;  cobol_alloc.pl1 05/24/89 1040.3rew 05/24/89 0830.4 42615 /****^ *********************************************************** * * * 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_alloc.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_alloc: proc; /* the procedure is not a valid entry point */ /*}*/ /*************************************/ /*{*/ stack: entry (num_char, boundry, offset); /* allocate space in the object time stack */ dcl num_char fixed bin; dcl boundry fixed bin; dcl offset fixed bin; /* num_char is the number of characters to be allocated (input) boundry specifies the allocation of the letmost character (input) 0 word boundry, return character offset 1 word boundry, return word offset 2 even word boundry, return wd offset 3 odd word boundry, return word offset offset is the word or character offset of the leftmost character relative to the base of the stack frame (output */ /*}*/ dcl utemp fixed bin; dcl words fixed bin; dcl 1 stack_err static, 2 name char (32) init ("cobol_alloc$stack"), 2 message_len fixed bin (35) init (42), 2 message char (42) init ("The object time stack exceeds 16,384 words"); dcl signal_ entry (char (*), ptr, ptr); start_stack: utemp = num_char + 3; words = fixed (substr (unspec (utemp), 1, 34)); if boundry > 1 then do; if substr (unspec (cobol_$stack_off), 36, 1) = "1"b then do; if boundry = 2 then cobol_$stack_off = cobol_$stack_off + 1; end; else do; if boundry = 3 then cobol_$stack_off = cobol_$stack_off + 1; end; end; if (words + cobol_$stack_off) > 16384 then do; cobol_$stack_off = cobol_$init_stack_off; call signal_ ("command_abort_", null (), addr (stack_err)); return; end; else if boundry ^= 0 then offset = cobol_$stack_off; else offset = 4 * cobol_$stack_off; cobol_$stack_off = cobol_$stack_off + words; exit_stack: return; /*************************************/ /*{*/ cobol_data: entry (cd_num_char, cd_boundry, cd_offset); /* allocate space in cobol data */ dcl cd_num_char fixed bin (24); dcl cd_boundry fixed bin; dcl cd_offset fixed bin (24); /* cd_num_char is the number of characters to be allocated. (input) cd_boundry specifies the allocation of the leftmost character. (input) 0 word boundry, return character offset 1 word boundry, return word offset 2 even word boundry, return word offset 3 odd word boundry, return word offset cd_offset is the word or character offset of the leftmost character relative to the base of the stack frame. (output) */ /*}*/ dcl 1 cobol_data_err static, 2 name char (32) init ("cobol_alloc$cobol_data"), 2 message_len fixed bin (35) init (44), 2 message char (44) init ("the cobol data segment exceeds 262,144 words"); start_cobol_data: utemp = cd_num_char + 3; words = fixed (substr (unspec (utemp), 1, 34)); if cd_boundry > 1 then do; if substr (unspec (cobol_$cobol_data_wd_off), 36, 1) = "1"b then do; if boundry = 2 then cobol_$cobol_data_wd_off = cobol_$cobol_data_wd_off + 1; end; else do; if boundry = 3 then cobol_$cobol_data_wd_off = cobol_$cobol_data_wd_off + 1; end; end; if (words + cobol_$cobol_data_wd_off) > 262144 then do; call signal_ ("command_abort_", null (), addr (cobol_data_err)); cobol_$cobol_data_wd_off = 0; return; end; else if cd_boundry ^= 0 then cd_offset = cobol_$cobol_data_wd_off; else cd_offset = 4 * cobol_$cobol_data_wd_off; cobol_$cobol_data_wd_off = cobol_$cobol_data_wd_off + words; exit_cobol_data: 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_alloc;  cobol_alter_gen.pl1 05/24/89 1040.3rew 05/24/89 0830.4 75897 /****^ *********************************************************** * * * 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_alter_gen.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /*{*/ /* format: style3 */ cobol_alter_gen: proc (in_token_ptr); /* The procedure cobol_alter_gen generates the code necessary to imple- ment ALTER statements of the following format; A_L_T_E_R_ procedure-name-1 T_O_ [P_R_O_C_E_E_D__T_O_] procedure-name-2 ALTER statements in the source program which are not in this format are modified by PD Syntax to conform. For example, the statement, ALTER a1 TO b1, a2 TO b2, is changed into the two statements, ALTER a1 TO b1 ALTER a2 TO b2. U__s_a_g_e:_ declare cobol_alter_gen(ptr); call cobol_alter_gen(in_token_ptr); */ %include cobol_in_token; /* G__e_n_e_r_a_t_e_d_C__o_d_e:_ Code Sequence 1, below, is generated if the COBOL segment con- taining procedure-name-2 does not require initialization before control is transferred to procedure-name-2. Code Sequence 2, be- low, is generated if initialization is required. Initialization is not required if procedure-name-1 and procedure-name-2 are in the same COBOL segment, if procedure-name-2 is in a fixed COBOL segment, or if procedure-name-2 is in an independent COBOL seg- ment which contains no alterable GO's. The term "alterable GO" is used here to designate a GO that is referenced by an ALTER statement. Sequence 1 eax2 pn2_relp,ic sxl2 target_a_pn1 Sequence 2 eax2 s(pn2)_init_relp,ic sxl2 target_a_pn1 eax2 pn2_relp,ic stx2 target_a_pn1 where: pn2_relp is the offset, relative to the instruction in which it appears, of the first instruction of procedure-name-2. target_a_pn1 is a 36-bit variable, allocated in COBOL data on a word boundary and uniquely associated with procedure-name-1 (see alter_list), which con- tains transfer address data. s(pn2)_init_relp is the offset, relative to the instruction in which it appears, of the first instruction of a code sequence provided to initialize the alter- able GO's in the segment containing procedure- name-2. R__e_l_o_c_a_t_i_o_n_I__n_f_o_r_m_a_t_i_o_n:_ All instructions directly generated by procedure cobol_alter_gen (as opposed to being generated by a utility called by cobol_alter_gen) are non-relocatable. D__a_t_a:_ % include cobol_; Items in cobol_$incl.pl1 used (u) and/or set (s) by cobol_alter_gen: cobol_ptr (u) alter_list_ptr (u) seg_init_list_ptr (u) text_wd_off (u) */ %include cobol_alter_list; %include cobol_seg_init_list; %include cobol_type18; /* 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. */ /* Input structure for cobol_register$load */ declare 1 register_request aligned static, 2 requested_reg fixed bin aligned init (12), 2 assigned_reg bit (4) aligned, 2 lock fixed bin aligned init (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 pl1 compiler will allocate structures containing pointers and all pointers therein on even word boundaries leaving "gaps" where necessary. content_ptr not applicable for use_code = 0. literal_content not applicable for use_code = 0. */ dcl inst_seq (8) bit (18) unaligned static init ("000000000000000000"b, "110010010000000100"b, /* eax2 0,ic */ "000000000000000000"b, "100100010001000000"b, /* sxl2 pr0|0 */ "000000000000000000"b, "110010010000000100"b, /* eax2 0,ic */ "000000000000000000"b, "111100010001000000"b); /* stx2 pr0|0 */ declare pn1_num fixed bin, /* Procedure no (tag) of procedure-name-1. */ pn2_num fixed bin, /* procedure no (tag) of procedure-name-2. */ pn2_pri fixed bin, /* COBOL segment no of procedure-name-1. */ index fixed bin, /* Do loop index. */ no_inst fixed bin; /* No of instructions generated. */ /* P__r_o_c_e_d_u_r_e_s_C__a_l_l_e_d:_ */ dcl cobol_addr entry (ptr, ptr, ptr), cobol_emit entry (ptr, ptr, fixed bin), cobol_make_tagref entry (fixed bin, fixed bin, ptr), cobol_register$load entry (ptr); /* B__u_i_l_t-__i_n_F__u_n_c_t_i_o_n_s_U__s_e_d:_ */ dcl addr builtin, binary builtin, null builtin, unspec builtin; /*}*/ %include cobol_; start: pn1_num = in_token.token_ptr (2) -> proc_ref.proc_num; pn2_num = in_token.token_ptr (3) -> proc_ref.proc_num; pn2_pri = binary (unspec (in_token.token_ptr (3) -> proc_ref.priority), 17); do index = 1 to alter_list.n; if pn1_num = alter_list.goto.proc_num (index) then do; target.segno = alter_list.goto.target_a_segno (index); target.char_offset = alter_list.goto.target_a_offset (index); goto found; end; end; found: call cobol_addr (addr (target), addr (inst_seq (3)), null); call cobol_register$load (addr (register_request)); if pn2_pri ^= binary (unspec (in_token.token_ptr (2) -> proc_ref.priority), 17) then if pn2_pri > 49 then do index = 1 to seg_init_list.n; if seg_init_list.seg.priority (index) = pn2_pri then do; inst_seq (7) = inst_seq (3); call cobol_make_tagref (seg_init_list.seg.int_tag_no (index), cobol_$text_wd_off, addr (inst_seq)); no_inst = 4; goto emit; end; end; no_inst = 2; emit: call cobol_emit (addr (inst_seq), null, no_inst); call cobol_make_tagref (pn2_num, cobol_$text_wd_off - 2, null); return; end cobol_alter_gen;  cobol_alter_perform.pl1 05/24/89 1040.3rew 05/24/89 0830.4 126648 /****^ *********************************************************** * * * 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_alter_perform.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_alter_perform: proc (space_ptr, space_max); /* The procedure cobol_alter_perform is called by cobol_gen_driver only if there are alter/perform records in variable common. It constructs alter_list, perform_list, and seg_init_list, utilizing data taken from these records, and sets seg_init_flag to one if there are any perform records or any alterable GO's in the fixed portion of the program. If neither of these conditions is met, seg_init_flag is set to 0. The first of the alter_perform records is located by the variable perf_alter_info contained in fixed_common and/or the variable size_perform_info, also in fixed_common. The re- cords located by the perf_alter_info "pointer" contain informa- tion about perform and alter statements in the source program and those located by the size_perform_info "pointer" contain informa- tion on performable procedures created by ddalloc for computing the "size" of data declared with "depending on" clauses. Alter_ list, perform_list, and seg_init_list are described below in the Data Section. U__s_a_g_e:_ declare cobol_alter_perform entry (ptr, fixed bin); call cobol_alter_perform(space_ptr, space_max); */ dcl space_ptr ptr, space_max fixed bin; /* space_ptr is a pointer to the next free location in the segment in which alter_list, perform_list, and seg_init_list are to be or have been located. (Input/Output) space_max is the maximum number of words available in the segment pointed to by space_ptr. (Input) D__a_t_a:_ % include cobol_; Items in cobol_ include file used (u) and/or set (s) by cobol_alter_perform: cobol_ptr (u) com_ptr (u) alter_list_ptr (s) cobol_data_wd_off (u/s) next_tag (u/s) perform_list_ptr (s) seg_init_list_ptr (s) seg_init_flag (s) % include fixed_common; Items in fixed_common include file used (u) and/or(s) by cobol_alter_perform: perf_alter_info (u) size_perform_info (u) */ %include cobol_alter_list; %include cobol_perform_list; %include cobol_seg_init_list; dcl alt_per_recd_ptr ptr; dcl 1 alt_per_recd (100) aligned based (alt_per_recd_ptr), 2 filler fixed bin, 2 record_len fixed bin aligned, 2 proc_no fixed bin aligned, 2 code fixed bin aligned, 2 next_entry fixed bin aligned, 2 extra (2) fixed bin aligned, 2 priority fixed bin aligned, 2 extra1 fixed bin aligned; dcl wds_left fixed bin, index fixed bin, jndex fixed bin, make_even fixed bin, no_fix_gos fixed bin, num_alt_recds fixed bin, num_recds fixed bin, temp_min fixed bin, temp_num fixed bin, temp_pri fixed bin; dcl 1 seg_ovfl_error aligned static, 2 my_name char (32) init ("cobol_alter_perform"), 2 message_len fixed bin init (36), 2 seg_name char (12), 2 message char (24) init ("Segment length exceeded!"); /* where: alt_per_recd_ptr is a pointer to the first alter/perform record in variable common. record_len is the length, in characters, of the record. The length of all alter/perform records is, in fact, fixed and is 32 characters. proc_no is the tag number of the procedure to be altered or of the procedure at the end of a perform range. code is 1 if the information in the record pertains to an ALTER statement, 0 if it pertains to an explicit PERFORM statement, and 2 if it pertains to a PERFORM statement created by PD_Syntax to implement a SORT statement. next_entry is a locator of the next alter_perform record in variable common. It contains the character string "0000" if the record is the last record. extra is unused by MCOBOL. priority is the COBOL segment number assocoated with the procedure identified by proc_no. extra1 is unused by MCOBOL. wds_left is the number of free words remaining in the segment pointed to by space_ptr. index is a do loop index. jndex is a do loop index. make_even is a variable used to adjust space_ptr such that seg_init_list begins on an even word boundary. no_fix_gos is the number of alterable GO's in fixed COBOL segments. num_alt_recds is the number of ALTER records in the chain of alter_perform records located in variable common. num_recds is the total number of records in the chain of alter/perform records located in variable common. temp_min is used to hold the current minimun value of procedure number in sorting alter_list and perform_list on the basis of prodecure name. temp_num is the index in alter_list or perform_list of temp_min. temp_pri is the COBOL segment number associated with temp_min or is used to hold the priority number of the member of alter_list being examined during the construction of seg_init_list. */ /* P__r_o_c_e_d_u_r_e_s_C__a_l_l_e_d:_ */ dcl cobol_read_rand entry (fixed bin, char (5), ptr), signal_ entry (char (*), ptr, ptr); /* B__u_i_l_t-__i_n_F__u_n_c_t_i_o_n_s_U__s_e_d:_ */ dcl addr builtin, addrel builtin, binary builtin, null builtin, rel builtin, substr builtin, unspec builtin; /*}*/ %include cobol_; %include cobol_fixed_common; %include cobol_ext_; /*************************************/ start: cobol_$seg_init_flag = 0; wds_left = space_max - binary (rel (space_ptr), 17); /* PROCESS PERFORM INFORMATION */ cobol_$perform_list_ptr = space_ptr; perform_list.n = 0; num_alt_recds = 0; num_recds = 0; if fixed_common.size_perform_info ^= "00000" then do; call cobol_read_rand (1, fixed_common.size_perform_info, alt_per_recd_ptr); alt_per_recd_ptr = addrel (alt_per_recd_ptr, -2); do index = 1 by 1; if wds_left >= 5 then do; perform_list.n = perform_list.n + 1; perform_list.perf.proc_num (perform_list.n) = alt_per_recd.proc_no (index); perform_list.perf.priority (perform_list.n) = alt_per_recd.priority (index); wds_left = wds_left - 5; end; else goto signal_altr_prform_ovfl; if unspec (alt_per_recd.next_entry (index)) = (4)"000110000"b then goto eof_size_perform; end; eof_size_perform: end; if fixed_common.perf_alter_info ^= "00000" then do; call cobol_read_rand (1, fixed_common.perf_alter_info, alt_per_recd_ptr); alt_per_recd_ptr = addrel (alt_per_recd_ptr, -2); /* PUT PERFORMS, IF ANY, IN perform_list */ do index = 1 by 1; if alt_per_recd.code (index) ^= 1 then if wds_left >= 5 then do; perform_list.n = perform_list.n + 1; perform_list.perf.proc_num (perform_list.n) = alt_per_recd.proc_no (index); perform_list.perf.priority (perform_list.n) = alt_per_recd.priority (index); wds_left = wds_left - 5; end; else goto signal_altr_prform_ovfl; else num_alt_recds = num_alt_recds + 1; /* ORN */ if unspec (alt_per_recd.next_entry (index)) = (4)"000110000"b then do; num_recds = index; goto end_of_list; end; end; end_of_list: end; if perform_list.n ^= 0 then /* SORT perform_list ON proc_num */ do; cobol_$seg_init_flag = 1; if perform_list.n > 262144 - cobol_$cobol_data_wd_off then goto signal_data_ovfl; do index = 1 to perform_list.n; temp_min = perform_list.perf.proc_num (index); temp_num = index; do jndex = index + 1 to perform_list.n; if perform_list.perf.proc_num (jndex) < temp_min then do; temp_min = perform_list.perf.proc_num (jndex); temp_num = jndex; end; end; if temp_num ^= index then do; temp_pri = perform_list.perf.priority (temp_num); perform_list.perf.proc_num (temp_num) = perform_list.perf.proc_num (index); perform_list.perf.priority (temp_num) = perform_list.perf.priority (index); perform_list.perf.proc_num (index) = temp_min; perform_list.perf.priority (index) = temp_pri; end; perform_list.perf.target_a_segno (index) = 2; perform_list.perf.target_a_offset (index) = binary (unspec (cobol_$cobol_data_wd_off) || "00"b, 17); cobol_$cobol_data_wd_off = cobol_$cobol_data_wd_off + 1; perform_list.perf.int_tag_no (index) = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; end; cobol_$seg_init_flag = 1; if wds_left < 1 then goto signal_altr_prform_ovfl; wds_left = wds_left - 1; space_ptr = addrel (space_ptr, binary (unspec (perform_list.n) || "00"b, 17) + perform_list.n + 1); end; else perform_list_ptr = null; /* PROCESSING OF PERFORM INFORMATION COMPLETE */ /* PROCESS ALTER INFORNATION */ if num_alt_recds ^= 0 then do; cobol_$alter_list_ptr = space_ptr; alter_list.n = 0; no_fix_gos = 0; do index = 1 to num_recds; if alt_per_recd.code (index) = 1 then if wds_left >= 4 then do; alter_list.n = alter_list.n + 1; alter_list.goto.proc_num (alter_list.n) = alt_per_recd.proc_no (index); alter_list.goto.priority (alter_list.n) = alt_per_recd.priority (index); if alter_list.goto.priority (alter_list.n) < 50 then no_fix_gos = no_fix_gos + 1; wds_left = wds_left - 4; end; else goto signal_altr_prform_ovfl; end; if alter_list.n > 262144 - cobol_$cobol_data_wd_off then goto signal_data_ovfl; /* SORT alter_list ON proc_num */ do index = 1 to alter_list.n; temp_min = alter_list.goto.proc_num (index); temp_num = index; do jndex = index + 1 to alter_list.n; if alter_list.goto.proc_num (jndex) < temp_min then do; temp_min = alter_list.goto.proc_num (jndex); temp_num = jndex; end; end; if temp_num ^= index then do; temp_pri = alter_list.goto.priority (temp_num); alter_list.goto.proc_num (temp_num) = alter_list.goto.proc_num (index); alter_list.goto.priority (temp_num) = alter_list.goto.priority (index); alter_list.goto.proc_num (index) = temp_min; alter_list.goto.priority (index) = temp_pri; end; alter_list.goto.target_a_segno (index) = 2; alter_list.goto.target_a_offset (index) = binary (unspec (cobol_$cobol_data_wd_off) || "00"b, 17); cobol_$cobol_data_wd_off = cobol_$cobol_data_wd_off + 1; end; /* CONSTRUCT seg_init_list */ wds_left = wds_left - binary (unspec (alter_list.n) || "0"b, 17) - alter_list.n - 1; if wds_left < 8 then goto signal_altr_prform_ovfl; if substr (rel (space_ptr), 18, 1) = "1"b /* odd */ then make_even = 1; else make_even = 2; space_ptr = addrel (space_ptr, binary (unspec (alter_list.n) || "00"b, 17) + make_even); cobol_$seg_init_list_ptr = space_ptr; if no_fix_gos ^= 0 then do; cobol_$seg_init_flag = 1; seg_init_list.n = 1; seg_init_list.seg.priority (1) = 0; seg_init_list.seg.int_tag_no (1) = 0; seg_init_list.seg.no_gos (1) = no_fix_gos; seg_init_list.seg.next_init_no (1) = 0; wds_left = wds_left - make_even - 6; end; else seg_init_list.n = 0; if no_fix_gos ^= alter_list.n then do index = 1 to alter_list.n; temp_pri = alter_list.goto.priority (index); if temp_pri > 49 then do; do jndex = 1 to seg_init_list.n; if temp_pri = seg_init_list.seg.priority (jndex) then do; seg_init_list.seg.no_gos (jndex) = seg_init_list.seg.no_gos (jndex) + 1; goto counted; end; end; if wds_left < 6 then goto signal_altr_prform_ovfl; seg_init_list.n = seg_init_list.n + 1; seg_init_list.seg.priority (seg_init_list.n) = temp_pri; seg_init_list.seg.int_tag_no (seg_init_list.n) = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; seg_init_list.seg.no_gos (seg_init_list.n) = 1; seg_init_list.seg.next_init_no (seg_init_list.n) = 0; wds_left = wds_left - 6; end; counted: end; space_ptr = addrel (space_ptr, 6 * seg_init_list.n + 2); do index = 1 to seg_init_list.n; seg_init_list.seg.init_ptr (index) = space_ptr; space_ptr = addrel (space_ptr, binary (unspec (seg_init_list.seg.no_gos (index)) || "0"b, 17) + seg_init_list.seg.no_gos (index)); end; end; else alter_list_ptr = null; /* PROCESSING OF ALTER INFORMATION COMPLETE */ exit: return; /*************************************/ /* ERROR LOOPS */ signal_altr_prform_ovfl: seg_ovfl_error.seg_name = "ALTR/PRFORM "; call signal_ ("command_abort_", null, addr (seg_ovfl_error)); return; signal_data_ovfl: seg_ovfl_error.seg_name = "COBOL data "; call signal_ ("command_abort_", null, addr (seg_ovfl_error)); return; end cobol_alter_perform;  cobol_arg_descriptor.pl1 05/24/89 1040.3rew 05/24/89 0830.4 81504 /****^ *********************************************************** * * * 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_arg_descriptor.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 08/25/83 by FCH, [5.2-2], phx15769(BUG555),incorrect descriptors formed for COMP-5,7,8 data */ /* Modified on 03/03/83 by FCH, [5.2-1], phx14746(BUG547), multipliers incorrectly formed */ /* Modified on 01/03/80 by FCH, [3.0-3], scale entered into descriptor */ /* Modified on 01/03/79 by FCH, [3.0-2], set packed bit */ /* Modified on 12/28/78 by FCH, [3.0-1], fix redef bug */ /* Modified since Version 3.0 */ /* format: style3 */ cobol_arg_descriptor: proc (in_word, out_word, out_conoff); dcl in_word bit (36); dcl out_word bit (36); dcl out_conoff fixed bin; dcl 01 data_based based, 02 filler char (24), 02 offset fixed bin; dcl my_ptr ptr; dcl utemp fixed bin; dcl prec_len fixed bin; dcl my_count fixed bin (24); dcl my_word bit (36); dcl con (0:1) bit (36) aligned based (my_ptr); dcl dn_ptr ptr; dcl (desc_cnt, main_level, prev_level, i, redef_level) fixed bin, (cont_flag, found, con_bit) bit (1), desc_wd (0:8000) bit (36), desc_char char (32000) based (addr (desc_wd (0))); /*************************************/ my_word = in_word; my_ptr = addrel (cobol_$con_end_ptr, 0); my_count = 1; con_bit = "1"b; do while (con_bit); if my_count >= cobol_$con_wd_off then do; /* the word is not in the pool, put it there*/ if (cobol_$text_wd_off + cobol_$con_wd_off) <= 262144 then do; con (0) = my_word; cobol_$con_wd_off = cobol_$con_wd_off + 1; call set_out; end; /* text plus constants exceed segment size */ else call signal_ ("command_abort_", null (), addr (con_err)); return; end; if con (0) ^= my_word then do; my_count = my_count + 1; my_ptr = addrel (my_ptr, -1); end; else con_bit = "0"b; end; call set_out; return; set_out: proc; utemp = -(my_count + cobol_$text_wd_off); substr (out_word, 1, 18) = substr (unspec (utemp), 19, 18); end; type9: entry (token_ptr, out_word, out_conoff); dcl token_ptr ptr; /* the following assumes a data type of character string and not packed */ dn_ptr = token_ptr; if data_name.elementary then do; desc_cnt = 0; call set_descriptor; end; else if fixed_common.descriptor = "01"b then call SD; else do; desc_cnt = 1; if data_name.level = 1 | data_name.level = 77 then desc_wd (1) = "10101010"b; else desc_wd (1) = "10101011"b; substr (desc_wd (1), 13, 24) = substr (unspec (data_name.item_length), 13, 24); end; desc_wd (0) = substr (unspec (desc_cnt), 1, 36); call cobol_pool (substr (desc_char, 1, (desc_cnt + 1) * 4), 2, out_conoff); out_conoff = out_conoff - 1; utemp = -out_conoff - cobol_$text_wd_off; substr (out_word, 1, 18) = substr (unspec (utemp), 19, 18); return; /* set_descriptor */ set_descriptor: proc; if data_name.bin_18 /*[5.2-2]*/ then if data_name.sync /*[5.2-2]*/ then my_word = "100000100000000000000000000000010001"b; /* comp-7 sync -- 1 */ /*[5.2-2]*/ else my_word = "100000110000000000000000000000010001"b; /* comp-7 -- 1 */ else if data_name.bin_36 /* comp-6 -- 1 */ /*[5.2-2]*/ then my_word = "100000100000000000000000000000100011"b; else do; /*[5.2-2]*/ /*my_word = "101010110000"b;*/ prec_len = data_name.item_length; if data_name.display & data_name.numeric then do; if data_name.sign_type = "000"b /* unsigned--35 */ /*[5.2-1]*/ then my_word = "11000111"b; else if data_name.sign_separate = "0"b then do; /* leading overpunch--29 */ /*[3.0-2]*/ if data_name.sign_type = "010"b then my_word = "10111011"b; /* trailing overpunch--30 */ /*[3.0-2]*/ else if data_name.sign_type = "001"b then my_word = "10111101"b; end; /* leading separate sign--9 */ else if data_name.sign_type = "100"b then do; /*[3.0-2]*/ my_word = "10010011"b; prec_len = prec_len - 1; end; /* trailing separate sign--36 */ else if data_name.sign_type = "011"b then do; /*[3.0-2]*/ my_word = "11001001"b; prec_len = prec_len - 1; end; end; else if data_name.ascii_packed_dec /* comp or comp-8 */ then do; if data_name.item_signed then do; /*[3.0-2]*/ if data_name.ascii_packed_dec_h /*[3.0-2]*/ then if data_name.sync /*[5.2-2]*/ then my_word = "11010111"b; /* comp-8 signed synch -- 43 */ /*[3.0-2]*/ else my_word = "11010011"b; /* comp-8 signed non-synch -- 41 */ /* comp-5 signed--39 */ /*[3.0-2]*/ else my_word = "11001111"b; end; /*[5.2-2]*/ else if data_name.ascii_packed_dec_h /* comp-8 */ /*[5.2-2]*/ then if data_name.sync /*[5.2-2]*/ then my_word = "11010001"b; /* comp-8 unsigned sync -- 40 */ /*[5.2-2]*/ else my_word = "11001101"b; /* comp-8 unsigned -- 38 */ /*[5.2-2]*/ else my_word = "11010001"b; /* comp-5 unsigned -- 40 */ prec_len = data_name.places_left + data_name.places_right; end; /*[5.2-2]*/ else my_word = "10101011"b; /* non-numeric -- 21 */ /*[4.0-3]*/ substr (my_word, 13, 24) = /*[4.0-3]*/ substr (unspec (data_name.places_right), 25, 12) /*[4.0-3]*/ || /*[4.0-3]*/ substr (unspec (prec_len), 25, 12); end; desc_cnt = desc_cnt + 1; desc_wd (desc_cnt) = my_word; /*[5.2-1]*/ if data_name.subscripted then call sub_handler (addr (desc_wd (desc_cnt))); end; SD: proc; main_level = data_name.level; prev_level = main_level; desc_cnt = 1; /* structure -- 17 */ if main_level = 1 | main_level = 77 then desc_wd (1) = "10100010000000000000"b || data_name.son_cnt; else desc_wd (1) = "10100011000000000000"b || data_name.son_cnt; dn_ptr = pointer (cobol_ntfp, dn_ptr -> data_based.offset); cont_flag = "1"b; /*[5.2-1]*/ if data_name.subscripted then call sub_handler (addr (desc_wd (1))); do while (cont_flag); dn_ptr = addrel (dn_ptr, divide (data_name.size + 11, 8, 35, 0) * 2); if data_name.size = 0 then return; do while (data_name.exp_redefining); redef_level = data_name.level; found = "0"b; /*[3.0-1]*/ dn_ptr = addrel (dn_ptr, divide (data_name.size + 11, 8, 35, 0) * 2); do while (^found); if data_name.level = 77 | data_name.level <= redef_level then found = "1"b; /*[3.0-1]*/ else dn_ptr = addrel (dn_ptr, divide (data_name.size + 11, 8, 35, 0) * 2); end; if data_name.level = 77 | data_name.level <= main_level then return; end; if data_name.non_elementary then do; if data_name.level <= main_level then return; else do; prev_level = data_name.level; desc_cnt = desc_cnt + 1; /* structure -- 17 */ desc_wd (desc_cnt) = "10100011000000000000"b || data_name.son_cnt; /*[5.2-1]*/ if data_name.subscripted then call sub_handler (addr (desc_wd (desc_cnt))); end; end; else do; if data_name.level < 50 then do; if data_name.level <= prev_level then if data_name.level <= main_level then return; call set_descriptor; end; else if data_name.level = 77 then return; end; end; end; sub_handler: proc (desc_loc); /*[5.2-1]*/ dcl desc_loc ptr; /*[5.2-1]*/ dcl desc bit (36) based (desc_loc); occurs_ptr = addrel (dn_ptr, substr (unspec (data_name.occurs_ptr), 17, 18)); substr (desc_wd (desc_cnt), 10, 3) = substr (unspec (occurs.dimensions), 34, 3); do i = occurs.dimensions to 1 by -1; desc_cnt = desc_cnt + 3; desc_wd (desc_cnt - 2) = "000000000000000000000000000000000001"b; desc_wd (desc_cnt - 1) = unspec (occurs.level.max (i)); /*[5.2-1]*/ if substr (desc, 8, 1) = "1"b then desc_wd (desc_cnt) = bit (fixed (divide (occurs.level.struc_length (i), 2, 35, 0) * 9, 36)); else desc_wd (desc_cnt) = bit (fixed (divide (occurs.level.struc_length (i), 8, 35, 0), 36)); end; end; %include cobol_arg_descr_data; end;  cobol_arith_move_gen.pl1 05/24/89 1040.3rew 05/24/89 0830.0 147780 /****^ *********************************************************** * * * 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_arith_move_gen.pl1 Added Trace statements. END HISTORY COMMENTS */ /* Modified on 11/16/84 by FCH, [5.3...], trace added */ /* Modified on 10/19/84 by FCH, [5.3-1], BUG563(phx18381), new cobol_addr_tokens.incl.pl1 */ /* Modified on 10/21/82 by FCH, [5.1-1], missing end statement added */ /* Modified on 05/09/79 by FCH, [4.0-1], alloc more space for temp subscr btd conv */ /* Modified since Version 4.0 */ /* format: style3 */ cobol_arith_move_gen: proc (in_token_ptr); /* This procedure generates code that moves the result of an arithmetic computation into one or more receiving variables. This procedure is necessary because the generator for the Cobol MOVE statement generates truncated moves (as required by the semantics of the MOVE statement), while what is required for moving the result of a computation to a receiving variable is a non-truncated move, so that overflow conditions can occur. */ /* DECLARATION OF THE PARAMETER */ /* dcl in_token_ptr ptr; */ /* This parameter is declared in an include file that follows the executable statements of the procedure. */ /* DESCRIPTION OF THE PARAMETER */ /* PARAMETER DESCRIPTION in_token_ptr Pointer to a structure that contains information used for generating code to move the result of a computation to one or more receiving fields. (input) See INPUT DETAILs below for a complete description of the structure. */ /* INPUT DETAILS */ /* The input to this prcedure is a pointer that points to a structure with a format defined by the following declaration: dcl 1 in_token aligned based (in_token_ptr), 2 n fixed bin aligned, 2 code fixed bin aligned, 2 token_ptr (0 refer(in_token.n)) ptr; The contents of this structure that are meaningful to this procedure are the value in "n", and the pointers in the "token_ptr" array. 1. in_token.n contains the number of pointers in the token pointer array. This value will have a range equal to or greater than 3. 2. token_ptr is an array of pointers to tokens that describe the operands for which move code is to be generated, or to a special token that contains specific information concerning the move. token_ptr(1) is not used by this procedure. token_ptr(2) points to the token that describes the result of a computation. Code to store this value is to be generated by this procedure. tokn_ptr(n) points to an EOS token. This token is described by an include file that follows the executable statements of this procedure. Only one entry in the EOS token is meaningful to this procedure: end_stmt.e contains the number of receiving fields into whcih the result of the computation is to be stored. token_ptr(3) through token_ptr(n-1) point to data name (type 9) tokens that describe the receiving variables into which the result is to be stored. The type of code generated depends on the receiving variable: 2. For any other type of receiving variable, the code that is generated is an EIS move numeric. The execution of the move numeric will result in conversion from one sign type to another, but will not result in any truncation. If the result value is too large to fit into the receiving variable, then the fixedoverflow condition will be raised when the code is executed. */ /* DECLARATION OF EXTERNAL ENTRIES */ dcl cobol_addr ext entry (ptr, ptr, ptr); dcl cobol_emit ext entry (ptr, ptr, fixed bin); dcl cobol_make_type9$type2_3 ext entry (ptr, ptr); dcl cobol_make_type9$copy ext entry (ptr, ptr); dcl cobol_make_type9$decimal_9bit ext entry (ptr, fixed bin, fixed bin (24), fixed bin, fixed bin); dcl cobol_get_num_code ext entry (ptr, fixed bin); dcl cobol_num_to_udts ext entry (ptr, ptr); dcl cobol_alloc$stack ext entry (fixed bin, fixed bin, fixed bin); /*}*/ /* DECLARATION OF INTERNAL STATIC VARIABLES */ /* Declaration of internal static variables that contains the MVN opcode */ dcl mvn_op bit (10) int static init ("0110000001"b /*300(1)*/); dcl dtb_op bit (10) int static init ("0110001011"b /*305(1)*/); dcl first_ix fixed bin int static init (2); /* 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"); /* Definition of a static flag that tells whether numeric zero has been allocated for this compilation. */ dcl zero_allocated fixed bin int static init (0); /* Definition of a pointer used to point to the data name token for the numeric zero data name token. */ dcl zero_type9_ptr ptr int static; /* Definition of an internal static buffer to contain the data name token for numeric zero. */ dcl zero_type9_buff (1:40) fixed bin int static; /* 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; dcl ix fixed bin; dcl iy fixed bin; dcl dest_ptr ptr; dcl source_ptr ptr; dcl work_places_left fixed bin; dcl ret_offset fixed bin; dcl work_token_ptr ptr; dcl dest_code fixed bin; /**************************************************/ /* START OF EXECUTION */ /* cobol_arith_move_gen */ /**************************************************/ /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(camg);/**/ in_token.code = 0; /* 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)); eos_ptr = in_token.token_ptr (in_token.n); /* 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 locks */ if in_token.token_ptr (first_ix) -> data_name.type ^= rtc_dataname then do; /* Source token is not a data name token. */ if in_token.token_ptr (first_ix) -> data_name.type ^= rtc_resword then do; /* Not a reserved word, assume a numeric literal */ source_ptr = null (); /* make_type9 supplies buffer for data name token */ call cobol_make_type9$type2_3 (source_ptr, in_token.token_ptr (first_ix)); end; /* Not a reserved word, assume a numeric literal */ else do; /* ASSUME FIGURATIVE CONSTANT ZERO */ if zero_allocated ^= cobol_$compile_count then do; /* Allocate numeric literal zero and make data name token. */ zero_type9_ptr = addr (zero_type9_buff (1)); call cobol_make_type9$type2_3 (zero_type9_ptr, addr (num_lit_zero)); zero_allocated = cobol_$compile_count; end; /* Allocate numeric literal zero and make data name token. */ source_ptr = zero_type9_ptr; end; /* Assume FIGURATIVE CONSTATN ZERO */ end; /* Source token is not a data name token. */ else if in_token.token_ptr (first_ix) -> data_name.bin_18 | in_token.token_ptr (first_ix) -> data_name.bin_36 | (in_token.token_ptr (first_ix) -> data_name.item_signed & in_token.token_ptr (first_ix) -> data_name.sign_separate = "0"b) then do; /* Source is fixed binary or overpunch sign data. */ /* Convert the source to unpacked decimal, trailing sign. */ source_ptr = null (); call cobol_num_to_udts (in_token.token_ptr (first_ix), source_ptr); end; /* Source is not display, must be fixed binary or overpunch sign data. */ else source_ptr = in_token.token_ptr (first_ix); input_struc.operand.token_ptr (1) = source_ptr; input_struc.operand.send_receive (1) = 0; /* sending */ input_struc.operand.size_sw (1) = 0; /* utility worries about size */ input_struc.operand.send_receive (2) = 0; /* sending */ input_struc.operand.size_sw (2) = 0; iy = first_ix + 1; dest_ptr = in_token.token_ptr (first_ix + 1); if dest_ptr -> data_name.numeric_edited then do; /* Destination is numeric edited. */ /* Generate code to move the source to a numeric temporary of length and scale factor of the numeric edited receiving field, in an attempt to force overflow. */ /* Allocate space on the stack equal to the size of the receiving numeric edited field. */ /*[4.0-1]*/ call cobol_alloc$stack (fixed (dest_ptr -> data_name.item_length, 17) + 1, 0, ret_offset); /* Make a data name token for the temporary just allocated. */ work_token_ptr = null (); call cobol_make_type9$decimal_9bit (work_token_ptr, 1000 /*stack*/, fixed (ret_offset, 24), fixed (dest_ptr -> data_name.places_left, 17), fixed (dest_ptr -> data_name.places_right, 17)); input_struc.operand.token_ptr (2) = work_token_ptr; call cobol_addr (input_ptr, inst_ptr, reloc_ptr); /* Insert opcode and rounding bit if necessary. */ inst_struc.fill1_op = mvn_op; if in_token.token_ptr (iy) -> data_name.rounded then inst_struc.zero3 = "01"b; /*rounding */ call cobol_emit (inst_ptr, reloc_ptr, 3); /* Set the in_token_structure to indicate an additional move is necessary in the calling procedure. */ in_token.code = 1; /* Set the source entry pointer in the in_token structure to point to the temporary that has just received the numeric value. */ in_token.token_ptr (first_ix) = work_token_ptr; end; /* Destination is numeric edited. */ else do; /* Destination is scaled decimal,fixed binary, or overpunch sign. */ call cobol_get_num_code (dest_ptr, dest_code); goto destination_sequence (dest_code); destination_sequence (1): /* DESTINATION IS UNPACKED SCALED DECIMAL */ destination_sequence (2): /* DESTINATION IS PACKED SCALED DECIMAL */ /* Generate brute force numeric move. */ input_struc.operand.token_ptr (2) = dest_ptr; call cobol_addr (input_ptr, inst_ptr, reloc_ptr); /* Insert opcode and rounding bit if needed. */ inst_struc.fill1_op = mvn_op; if in_token.token_ptr (iy) -> data_name.rounded then inst_struc.zero3 = "01"b; /* rounding bit on */ if dest_ptr -> data_name.item_signed then inst_struc.inst.zero1 = "10"b; /* Turn on the P bit so that the target sign will be set to octal 13. */ call cobol_emit (inst_ptr, reloc_ptr, 3); goto brute_force_exit; destination_sequence (3): /* DESTINATION IS SHORT FIXED BINARY */ destination_sequence (4): /* DESTINATION IS LONG FIXED BINARY */ if (source_ptr -> data_name.sign_type = "111"b | source_ptr -> data_name.places_right ^= 0) then do; /* Source is floating decimal or scaled decimal with fractional part. */ if source_ptr -> data_name.sign_type = "111"b then work_places_left = 62; /* Floating is converted to scaled decimal with precision (63,0) with leading separate sign */ else work_places_left = source_ptr -> data_name.places_left; /* Allocate space in the stack to receive the integer scaled decimal value. */ call cobol_alloc$stack (work_places_left + 1, 0, ret_offset); /* Make a data name token for the integer scaled decimal. */ work_token_ptr = null (); call cobol_make_type9$decimal_9bit (work_token_ptr, 1000 /*stack*/, fixed (ret_offset, 24), work_places_left, 0); /* Establish addressability to the source, and fixed decimal temp. */ input_struc.operand.token_ptr (2) = work_token_ptr; call cobol_addr (input_ptr, inst_ptr, reloc_ptr); /* Make and emit code to move floating decimal to integer scaled decimal */ inst_struc.fill1_op = mvn_op; if in_token.token_ptr (iy) -> data_name.rounded then inst_struc.zero3 = "01"b; call cobol_emit (inst_ptr, reloc_ptr, 3); input_struc.operand.token_ptr (1) = work_token_ptr; /* integer scaled decimal */ end; /* Source is floating decimal or scaled decimall with fractional part. */ /* At this point if the source was floating decimal, it has been converted to integer scaled decimal. Now, we generate code to convert the scaled decimal to fixed binary. */ input_struc.operand.token_ptr (2) = dest_ptr; call cobol_addr (input_ptr, inst_ptr, reloc_ptr); inst_struc.fill1_op = dtb_op; call cobol_emit (inst_ptr, reloc_ptr, 3); goto brute_force_exit; destination_sequence (5): /* DESTINATION IS OVERPUNCH SIGN DATA */ /* Destination is overpunch sign. */ /* Generate code to move the source to a numeric temporary of length and scale factor of the overpunch sign receiving field, in an attempt to force overflow. */ /* Allocate space on the stack equal to the size of the receiving numeric edited field. */ call cobol_alloc$stack (fixed (dest_ptr -> data_name.item_length + 1, 17), 0, ret_offset); /* Make a data name token for the temporary just allocated. */ work_token_ptr = null (); call cobol_make_type9$decimal_9bit (work_token_ptr, 1000 /*stack*/, fixed (ret_offset, 24), fixed (dest_ptr -> data_name.places_left, 17), fixed (dest_ptr -> data_name.places_right, 17)); /* Change the sign type to trailing separate. */ work_token_ptr -> data_name.sign_type = "011"b; /* trailing separate */ input_struc.operand.token_ptr (2) = work_token_ptr; call cobol_addr (input_ptr, inst_ptr, reloc_ptr); /* Insert opcode and rounding bit if necessary. */ inst_struc.fill1_op = mvn_op; if in_token.token_ptr (iy) -> data_name.rounded then inst_struc.zero3 = "01"b; /*rounding */ call cobol_emit (inst_ptr, reloc_ptr, 3); /* Set the in_token_structure to indicate an additional move is necessary in the calling procedure. */ in_token.code = 1; /* Set the source entry pointer in the in_token structure to point to the temporary that has just received the numeric value. */ in_token.token_ptr (first_ix) = work_token_ptr; goto brute_force_exit; brute_force_exit: /***..... if Trace_Bit then call cobol_gen_driver_$Tr_End(camg);/**/ /***..... dcl camg char(20) init("COBOL_ARITH_MOVE_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); /**/ end; /* [5.1-1] */ /* 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_type19; %include cobol_in_token; %include cobol_record_types; %include cobol_; /**************************************************/ /* END OF PROCEDDURE */ /* cobol_arith_move_gen */ /*************************************************/ end cobol_arith_move_gen;  cobol_arithop_gen.pl1 05/24/89 1040.3rew 05/24/89 0830.3 96426 /****^ *********************************************************** * * * 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_arithop_gen.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* format: style3 */ %; /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /*{*/ cobol_arithop_gen: proc (in_token_ptr); /* The Arithmetic Operation Generator: cobol_arithop_gen FUNCTION The arithmetic operation generator is called to generate code for the following arithmetic operations: 1. negation of one operand 2. addition of two operands 3. subtraction of one operand from another 4. multiplication of one operand by another 5. division of one operand by another 6. raising one operand to a power specified by another operand. INPUT The input to this procedure is a pointer that points to a structure with a format defined by the follwoing declaration: (NOTE: The actual declaration is done by an include file following the executable statements of this procedure.) dcl 1 in_token aligned based (in_token_ptr), 2 n fixed bin aligned, 2 code fixed bin aligned, 2 token_ptr ( 0 refer(in_token.n)) ptr aligned; The pointers in the array in_token.token_ptr point to tokens that provide information required to generate code. The last two or three entries in this array are of interest to cobol_arithop_gen. 1. The last pointer (token_ptr(n)) points to an EOS token (type 19) that defines the type of arithmetic operation for which code is to be generated. The entry "end_stmt.e" in the EOS token contains a value that defines the arithmetic operator. (The declaration of the EOS token appears as an include file following the executable statements of this procedure.) The possible values of "end_stmt.e" and their meanings are given in the following table: end_stmt.e value | meaning ___________________________________________________ 182 | + (binary addition) 183 | - (binary subtraction) 184 | * (multiplication) 185 | / (division) 186 | ** (exponentiation) 187 | unary minus (negation) 2. If the EOS indicates a negation operation, then only in_token.token_ptr(n-1) is meaningful, and it points to the token to be negated. Otherwise in_token.token_ptr(n-2) and in_token.token_ptr(n-1) point to the two tokens that are to be used in a binary operation. The pointer in in_token.token_ptr(n-2) points to a token that appears to the left of the operator, and the pointer in in_token.token_ptr(n-1) points to a token that appears to the right of the operator in the source program. OUTPUT The execution of this procedure results in the generation of code that performs the arithmetic operation, and the building of a data name (type 9) token that describes the resultant operand. A pointer to this resultant operand token is returned to the calling procedure in the input in_token structure. For a negation operation, the return pointer is returned in in_token.token_ptr(n-1). For any other operation, the return pointer is returned in in_token.token_ptr(n-2). The calling procedure also must know how many entries in the in_token structure must be saved for subsequent calls to cobol_arithop_gen or other generators. This information is returned to the caller in the entry in_token.code, and is the value of the subscript of the entry in array token_ptr that points to the resultant operand token. Therefore, for a negation operation,in_token.code is set to n-1, and for any other operation, in_token.code is set to n-2. */ /*}*/ /* DECLARATION OF EXTERNAL ENTRIES */ dcl cobol_make_type9$type2_3 ext entry (ptr, ptr); dcl cobol_build_resop ext entry (ptr, ptr, fixed bin, ptr, bit (1), fixed bin, bit (1)); dcl cobol_add3 ext entry (ptr, ptr, ptr, fixed bin); dcl cobol_mpy3 ext entry (ptr, ptr, ptr, fixed bin); dcl cobol_exp3 ext entry (ptr, ptr, ptr, fixed bin); /* DECLARATION OF INTERNAL STATIC VARIABLES */ /* Variables required for pooling of decimal minus one */ dcl minus_one_pooled fixed bin int static init (0); /* Buffer in which data name (tyype 9) token for minus one is saved */ dcl minus_one_buff (1:40) fixed bin int static; /* Pointer used to point to the minus one data name (type 9) token */ dcl minus_one_ptr ptr int static; /* Definition of a minus one numeric literal */ dcl 1 minus_one_literal 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), /* INTEGER */ 2 floating bit (1) init ("0"b), 2 filler1 bit (5) init ("0"b), 2 subscrript bit (1) init ("0"b), 2 sign char (1) init ("-"), 2 exp_sign char (1) init (" "), 2 exp_places fixed bin (15) init (0), 2 places_left fixed bin (15) init (1), 2 places_right fixed bin (15) init (0), 2 places fixed bin (15) init (1), 2 literal char (1) init ("1"); /* Declarations of variables used to define values that can appear in the EOS field "end_stmt.e" */ dcl eos_plus fixed bin (15) int static init (182); dcl eos_minus fixed bin (15) int static init (183); dcl eos_multiply fixed bin (15) int static init (184); dcl eos_divide fixed bin (15) int static init (185); dcl eos_exponentiate fixed bin (15) int static init (186); dcl eos_unary_minus fixed bin (15) int static init (187); /* DECLARATION OF INTERNAL ATOMATIC VARIABLES */ dcl arithop fixed bin; dcl return_index fixed bin; dcl lop_ptr ptr; dcl rop_ptr ptr; dcl resultant_operand_ptr ptr; dcl possible_overflow_flag bit (1); dcl gen_code fixed bin; /**************************************************/ /* START OF EXECUTION */ /* cobol_arithop_gen */ /**************************************************/ /* Base EOS template on the EOS token */ eos_ptr = in_token.token_ptr (in_token.n); if end_stmt.e = eos_unary_minus then do; /* unary minus */ if minus_one_pooled ^= cobol_$compile_count then do; /* Must pool minus one literal */ minus_one_ptr = addr (minus_one_buff (1)); /* Pool the minus one literal and make a data name token */ call cobol_make_type9$type2_3 (minus_one_ptr, addr (minus_one_literal)); minus_one_pooled = cobol_$compile_count; end; /* Must pool minus one literal */ /* Set left op and right op pointers, and set arithop code to multiply */ return_index = in_token.n - 1; /* Subscript of array element in which pointer to resultant operand is returned */ lop_ptr = in_token.token_ptr (return_index); rop_ptr = minus_one_ptr; arithop = eos_multiply; end; /* unary minus */ else do; /* A binary operator */ return_index = in_token.n - 2; /* Subscript of token_ptr array element in which pointer to resultant operand is returned */ lop_ptr = in_token.token_ptr (return_index); rop_ptr = in_token.token_ptr (return_index + 1); arithop = end_stmt.e; end; /* A binary operator */ /* At this point, we have the following conditions: 1. lop_ptr points to the left operand token. 2. rop_ptr points to the right operand token. (-1 literal for negation) 3. arithop contains the operator code from end_stmt.e. ( or "multiply" for negation) */ /* Build the operand for the result of the arithmetic operation */ call cobol_build_resop (lop_ptr, rop_ptr, arithop, resultant_operand_ptr, "0"b /* no RDMAX*/, 0, possible_overflow_flag); /* Call the appropriate arithmetic generator to generate code */ if (arithop = eos_plus | arithop = eos_minus) then do; /* Add or subtract */ if arithop = eos_plus then gen_code = 1; /* add */ else gen_code = 2; /* subtract */ /* Reverse operands because for subtraction rop_ptr must appear first, and addition is commutative, so order of the operands is irrelevant. */ call cobol_add3 (rop_ptr, lop_ptr, resultant_operand_ptr, gen_code); end; /* Add or subtract */ else if (arithop = eos_multiply | arithop = eos_divide) then do; /* Multiply or divide */ if arithop = eos_multiply then gen_code = 1; /* Multiply */ else gen_code = 2; /* Divide */ /* Reverse order of operands, because for divison, rop_ptr must appear first. Multiplication is commutative, so the order of the operands is irrelevant. */ call cobol_mpy3 (rop_ptr, lop_ptr, resultant_operand_ptr, gen_code); end; /* Multiply or divide */ else /* ASSUME EXPONENTIATION */ call cobol_exp3 (lop_ptr, rop_ptr, resultant_operand_ptr, 0); /* At this point, code has been generated to effect the arithmetic operation, and the pointer resultant_operand_ptr points to a data name (type 9) token that describes the result of the operation */ /* Set appropriate entry in the token_ptr array to point to the resultant operand */ in_token.token_ptr (return_index) = resultant_operand_ptr; /* Set in_token.code to tell the caller how many elements of the token_ptr array are to be "saved" */ in_token.code = return_index; /**************************************************/ /* END OF EXECUTABLE STATEMENTS */ /* cobol_arithop_gen */ /**************************************************/ /* 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_in_token; %include cobol_; %include cobol_type19; %include cobol_mcdb; /**************************************************/ /* END OF PROCEDURE */ /* cobol_arithop_gen */ /**************************************************/ end cobol_arithop_gen;  cobol_bin_const_ck.pl1 05/24/89 1040.3rew 05/24/89 0830.3 38340 /****^ *********************************************************** * * * 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_bin_const_ck.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /*{*/ /* format: style3 */ cobol_bin_const_ck: proc (token_ptr, give_up, constant_code); /* This procedure determines whether a numeric literal constant can be contained in either a half-word or full word fixed binary datum. */ /* DECLARATIONS OF THE PARAMETERS */ dcl token_ptr ptr; dcl give_up bit (1); dcl constant_code fixed bin; /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION token_ptr Pointer to the numeric literal token whose literal value is to be checked. (input) give_up A flag which is set to "1"b to indicate that the numeric literal cannot be contained in either a long or short fixed binary datum. (output) constant_code A code that indicates whether the constant can be contained in a short or long fixed binary datum. (output) This code can take on two values, and is meaningful only if the output parameter give_up is set to "1"b. constant_code | meaning ------------------------------------------- 1 | constant is short binary 2 | constant is long binary --------------------------------------------- */ /* DECLARATION OF BUILTIN FUNCTIONS */ dcl addr builtin; /*}*/ /* DECLARATIONS OF INTERNAL STATIC VARIABLES */ dcl smallest_short_bin fixed dec (6, 0) int static init (-131072); dcl largest_short_bin fixed dec (6, 0) int static init (131071); dcl smallest_long_bin fixed dec (11, 0) int static init (-34359738368); dcl largest_long_bin fixed dec (11, 0) int static init (34359738367); /* DECLARATIONS OF INTERNAL VARIABLES */ dcl work_fdec fixed dec (11, 0) aligned; dcl work_ptr ptr; dcl work_fdec_string char (12) based (work_ptr); /**************************************************/ /* START OF EXECUTION */ /**************************************************/ nlit_ptr = token_ptr; give_up = "1"b; if numeric_lit.places_left <= 0 then do; /* No places left, must definitely fit into a short binary. */ give_up = "1"b; constant_code = 1; /* short binary constant. */ end; /* No places left, must definitely fit into a short binary. */ else if numeric_lit.places_left <= 11 then do; /* Places left within range, check the value itself. */ work_fdec = 0; work_ptr = addr (work_fdec); /* Build a fixed decimal number from the numeric literal token. */ /* Insert sign. */ if numeric_lit.sign = " " then substr (work_fdec_string, 1, 1) = "+"; else substr (work_fdec_string, 1, 1) = numeric_lit.sign; /* Insert the integer part of the numeric literal */ substr (work_fdec_string, 13 - numeric_lit.places_left, numeric_lit.places_left) = substr (numeric_lit.literal, 1, numeric_lit.places_left); if (smallest_short_bin <= work_fdec & work_fdec <= largest_short_bin) then do; /* Short binary constant */ give_up = "0"b; constant_code = 1; end; /* Short binary constant */ else if (smallest_long_bin <= work_fdec & work_fdec <= largest_long_bin) then do; /* Long binary constant */ give_up = "0"b; constant_code = 2; end; /* Long binary constatn */ end; /* Places left within range, check the value itself. */ /* INCLUDE FILES USED BY THIS PROCEDURE */ %include cobol_type2; end cobol_bin_const_ck;  cobol_binary_check.pl1 05/24/89 1040.3rew 05/24/89 0830.3 286794 /****^ *********************************************************** * * * 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_binary_check.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 9/12/76 by Bob Chang to fix the bug for binary check for addend. */ /*{*/ /* format: style3 */ cobol_binary_check: proc (in_token_ptr, binary_ok, target_code, source_code); /* This procedure scans the input token for an arithmetic statement, and determines whether the receiving variables (targets) and the operands in the expression to be evaluated are of the proper type and number so that the computation may be done in the hardware registers (A, Q, and index registers) rather than by using EIS instructions. For this implementation, arithmetic computations will be done in the registers only if the following conditions are true: 1. all target variables are fixed binary. (long or short) 2. the number of operands in the expression is less than or equal to 2. 3. all operands in the expression are fixed binary, figurative constant zero, or constants that can be contained in a binary datum. 4. none of the short binary targets or operands appearing in the statement are elements of arrays. 5. none of the receiving variables has the "rounded" bit on. Since the input token for the arithmetic statements is different for each type of statement, there is one entry point in this procedure for each arithmetic statement for which binary arithmetic could be performed. The entry points are listed here: 1. compute 2. add (also subtract) 3. multiply 4. divide */ /* DECLARATION OF THE PARAMETERS */ /* dcl in_token_ptr ptr; */ /* Declared below in an include file */ dcl binary_ok bit (1); dcl target_code fixed bin; dcl source_code fixed bin; /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION in_token_ptr Pointer to an input token that contains a description of the statement. (input) See each entry point within this procedure for precise details of the contents of the input token structure. binary_ok A flag that is set to "1"b by this procedure if all of the criteria for performing arithmetic in the registers are met. (output) target_code source_code Codes that indicate the type of the largest target and source variable respectively. (output) Possible values are: value | meaning =================================================== 1 | largest variable is short binary 2 | largest variable is long binary ========================================= */ /* DECLARATIONS OF EXTERNAL ENTRIES */ dcl cobol_bin_const_ck ext entry (ptr, bit (1), fixed bin); /* DECLARATIONS OF COMMON INTERNAL VARIABLES */ dcl give_up bit (1); dcl divide_flag bit (1); dcl rounded_flag bit (1); dcl temp_target_code fixed bin; dcl temp_source_code fixed bin; dcl ix fixed bin; dcl iy fixed bin; dcl eos_flag bit (1); dcl source_op_count fixed bin; dcl dn_ptr ptr; /*************************************************/ /* ENTRY POINT: compute */ /**************************************************/ compute: entry (in_token_ptr, binary_ok, target_code, source_code); /* 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 COMPUTE. This pointer is not used by this procedure. token_ptr(n) contains a pointer to an EOS (type 19) token. The type 19 token contains some information that is very meaningful to this procedure. 1. end_stmt.verb contains the code for the reserved word COMPUTE. 2. end_stmt.e contains a count of the number of data items that are to receive the result of the computation. 3. end_stmt.b is set to "1"b if the compute statement contained an ON SIZE ERROR clause. token_ptr(2) through token_ptr(n-1) point to tokens that describe: 1. the data items that are to receive the result of the computation. (all are data name (type 9) tokens) 2. the tokens for the operands to be used in evaluating the arithmetic expression. These tokens can be data name (type 9) tokens, numeric literal (type 2) tokens, or the figurative constant ZERO (type 1) token. 3. the tokens that describe the arithmetic operators to be used in evaluating the arithmetic expression. These tokens are EOS tokens (type 19). The contents of the field end_stme.e in these type 19 tokens specifies the operator. end_stmt.e | operator --------------------------------------------- 182 | + (binary plus) 183 | - (binary minus) 184 | * (multiply) 185 | / (divide) 186 | ** (exponentiate) 187 | - (unary minus) The data name tokens, and EOS tokens that specify operators, are arranged in trailing polish notation in the token_ptr array. That is, each operator follows the operand (for unary operators) or the two operands (for binary operators) to which it applies. OUTPUT The second parameter passed to cobol_compute_gen is an output para- meter. A value is returned to the calling program (cobol_gen_driver_) only for those compute statements that have on size error clauses. If an on size error clause is specified, then, in addition to the code that evaluates the arithmetic expression, and assigns it to the receiving data items, cobol_compute_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 COMPUTE statement is executed, otherwise the imperative statement is skipped. The cobol_compute_gen generator, however, when generating code to skip over the imperative statmeent to the next statement, does not know anything about the next statement. This situation is handled as follows: 1. cobol_compute_gen reserves a tag for the next Cobol statement. 2. any transfers to the next statement reference the tag reserved by cobol_compute_gen. This tag is not yet defined. (associated with an instruction location in the text segment) 3. after generation of code for a compute statement is completed, cobol_compute_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_compute_gen, is defined. */ /**************************************************/ /* START OF EXECUTION */ /* ENTRY POINT: compute */ /**************************************************/ give_up = "0"b; target_code = 0; temp_source_code = 0; temp_target_code = 0; eos_ptr = in_token.token_ptr (in_token.n); divide_flag = "0"b; rounded_flag = "0"b; /* Check to see if all receiving variables are long or short binary. */ do ix = 1 to end_stmt.e while (give_up = "0"b); /* Check targets */ if in_token.token_ptr (1 + ix) -> data_name.rounded then rounded_flag = "1"b; if in_token.token_ptr (1 + ix) -> data_name.bin_36 then temp_target_code = 2; else if in_token.token_ptr (1 + ix) -> data_name.bin_18 & in_token.token_ptr (1 + ix) -> data_name.subscripted = "0"b then temp_target_code = 1; else give_up = "1"b; /* Target not either long or short binary. */ if give_up = "0"b then if temp_target_code > target_code then target_code = temp_target_code; end; /* Check targets */ /* Now check to see whether: 1. There are two or less operands in the expression. 2. Each operand is a long or short binary, the fig constant aero, or a constant that can be contained in a fixed binary datum. 3. The only operators are unary minus, binary plus, and binary minus (this implementation) */ if give_up = "0"b then do; /* All targets are fixed binary, check the expression. */ source_code = 0; source_op_count = 0; do iy = ix + 1 to in_token.n - 1 while (give_up = "0"b); /* Look at the expression */ eos_flag = "0"b; if in_token.token_ptr (iy) -> data_name.type = rtc_resword then temp_source_code = 1; else if in_token.token_ptr (iy) -> data_name.type = rtc_numlit then call cobol_bin_const_ck (in_token.token_ptr (iy), give_up, temp_source_code); else if in_token.token_ptr (iy) -> data_name.type = rtc_eos then do; /* EOS TOKEN, must check the operator */ eos_flag = "1"b; if in_token.token_ptr (iy) -> end_stmt.e = 186 /* exponentiate */ then give_up = "1"b; if in_token.token_ptr (iy) -> end_stmt.e = 185 then divide_flag = "1"b; end; /* EOS TOKEN, must check the operator */ else if in_token.token_ptr (iy) -> data_name.type = rtc_dataname then do; /* Check to see if fixed binary */ if in_token.token_ptr (iy) -> data_name.bin_36 then temp_source_code = 2; else if (in_token.token_ptr (iy) -> data_name.bin_18 & in_token.token_ptr (iy) -> data_name.subscripted = "0"b) then temp_source_code = 1; else give_up = "1"b; end; /* Check to see if fixed binary */ if (give_up = "0"b & eos_flag = "0"b) then do; /* Current token ok, check operand count. */ if source_op_count = 2 then give_up = "1"b; /* Two operands already. */ else do; /* Increment operand count */ source_op_count = source_op_count + 1; if temp_source_code > source_code then source_code = temp_source_code; end; /* Increment the sount of the operands in the expression */ end; /* Current token OK, Check operand count. */ end; /* Look at expression. */ /* If the operation was divide, and any of the receiving fields had the rounding bit on, then we don't want to do arithmetic in the hardware registers. Instead we want to do decimal (EIS) arithmetic, with rounding. */ if divide_flag & rounded_flag then give_up = "1"b; end; /* All targets fixed binary, check the expression. */ binary_ok = ^give_up; return; add: entry (in_token_ptr, binary_ok, target_code, source_code); /* This entry point scans the input token for add and subtract statements, and determines whether the add or subtract can be done in the hardware registers, rather than by using EIS instructions. */ /* 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 ADD. 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 contians the code for the reserved word ADD. 2. end_stmt.a defines the format of the ADD statement: value of end_stmt.a | Add stmt format ---------------------------------------- "000"b | format 1 "001"b | format 2 3. end_stmt.b is "1"b if this ADD statement had an ON SIZE ERROR clause 4. end_stmt.e contans the count of the number of operands to the LEFT of "TO" for format 1 ADD statements, or to the LEFT of "GIVING" for format 2 ADD statements. 5, end_stmt.h contians the count of the number of operands to the RIGHT of "TO" for format 1 ADD statements, or to the RIGHT of "GIVING" for format 2 ADD statements. 6. end_stmt.i contains the composite count of the digits to the left of the decimal pint. (???) 7. end_stmt.j contians the composite count of the digits to the right of the decimal point. (???) token_ptr(2) through token_ptr(n-1) point th tokens that describe: 1. the data items to be added together. These tokens can be data name (type 9) tokens numeric literal (type 2) tokens, or the figurative constant ZERO (type 1) token. 2. the data items to receive the result of the addition. These tokens are always data name (type 9) tokens. OUTPUT The second parameter passed to cobol_add_gen is an output parameter. A value is returned to the calling procedure, cobol_gee_driver_, only for those add astatments that have on size error clauses. If an on size error clause is specified, then, in addition to the code that evaluates the sum, and assigns it to the receiving data items, cobol_add_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 ADD statment is executed, otherwise the imperative statement is skipped. The cobol_add_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_add_gen reserves a tag for the next COBOL statement. 2. any transfers to the next statement reference the tag reserved by cobol_add_gen. This tag is not yet defined. (associated with an instruction location in the text segment) 3. after generation of code for an add statement is completed, cobol_add_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_add_gen, is defined. */ /**************************************************/ /* START OF EXECUTION */ /* ENTRY POINT: */ /* add */ /**************************************************/ eos_ptr = in_token.token_ptr (in_token.n); give_up = "0"b; if end_stmt.a = "000"b then do; /* A format 1 add or subtract statement. */ /* Check to see that there is only one addend, and that that addend is either long or short binry, the fig. constant ZERO, or a numeric literal that can be contained in a fixed binary. */ if end_stmt.e ^= 1 then give_up = "1"b; else if in_token.token_ptr (2) -> data_name.type = rtc_resword then source_code = 1; else if in_token.token_ptr (2) -> data_name.type = rtc_numlit then call cobol_bin_const_ck (in_token.token_ptr (2), give_up, source_code); else if (in_token.token_ptr (2) -> data_name.bin_18 & in_token.token_ptr (2) -> data_name.subscripted = "0"b) then source_code = 1; else if in_token.token_ptr (2) -> data_name.bin_36 then source_code = 2; else give_up = "1"b; if give_up = "0"b then do; /* Addend ok, check all augends (minuends) */ /* All must be long or short binary. */ target_code = 0; do ix = 3 to in_token.n - 1 while (give_up = "0"b); if (in_token.token_ptr (ix) -> data_name.bin_18 = "0"b) & (in_token.token_ptr (ix) -> data_name.bin_36 = "0"b) then give_up = "1"b; else if in_token.token_ptr (ix) -> data_name.bin_18 & (in_token.token_ptr (ix) -> data_name.subscripted) then give_up = "1"b; end; end; /* Addend ok, check all augends (minuends) */ end; /* A format 1 add or subtract statement. */ else do; /* A format 2 add or subtract statement. */ /* In order to do arithmetic in the registers, the follwoing conditions must be true: 1. Exactly 2 operands to be added. 2. All operands to be added or long or short fixed binary, fig. constant ZERO, or a numlit that can be contained in a fixed binary. 3. All receiving fields must be fixed binary. */ if (end_stmt.verb = 2 /*add*/ & end_stmt.e ^= 2) | (end_stmt.verb = 11 /*subtract*/ & end_stmt.e ^= 1) then give_up = "1"b; else do; /* 2 operands, check them. */ source_code = 0; do ix = 2, 3 while (give_up = "0"b); if in_token.token_ptr (ix) -> data_name.type = rtc_resword then temp_source_code = 1; else if in_token.token_ptr (ix) -> data_name.type = rtc_numlit then call cobol_bin_const_ck (in_token.token_ptr (ix), give_up, temp_source_code); else if (in_token.token_ptr (ix) -> data_name.bin_18 & in_token.token_ptr (ix) -> data_name.subscripted = "0"b) then temp_source_code = 1; else if in_token.token_ptr (ix) -> data_name.bin_36 then temp_source_code = 2; else give_up = "1"b; if give_up = "0"b then if temp_source_code > source_code then source_code = temp_source_code; end; end; /* 2 operands, check them. */ if give_up = "0"b then do; /* All addends ok, check the receiving fields. */ /* All receiving fields must be long or short binary cobol data items. */ target_code = 0; do ix = 4 to in_token.n - 1 while (give_up = "0"b); if in_token.token_ptr (ix) -> data_name.bin_18 & in_token.token_ptr (ix) -> data_name.subscripted = "0"b then temp_target_code = 1; else if in_token.token_ptr (ix) -> data_name.bin_36 then temp_target_code = 2; else give_up = "1"b; if give_up = "0"b then if temp_target_code > target_code then target_code = temp_target_code; end; end; /* All addends ok, check the receiving fields. */ end; /* A format 2 add or subtract statement. */ binary_ok = ^give_up; /**************************************************/ /* RETURN POINT */ /* add */ /**************************************************/ return; /**************************************************/ /* ENTRY POINT: divide */ /**************************************************/ divide: entry (in_token_ptr, binary_ok, target_code, source_code); /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION in_token_ptr Points to the in_token structure, which contains information describing the DIVIDE 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 DIVIDE 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 DIVIDE. 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 DIVIDE. 2. end_stmt.a defines the format of the DIVIDE statement: value of end_stmt.a | divide stmt format ---------------------------------------- "000"b | format 1 "001"b | format 2 "010"b | format 3 "011"b | format 4 "100"b | format 5 3. end_stmt.b is "1"b if this DIVIDE statement had an ON SIZE ERROR clause 4. end_stmt.e contains the count of the number of operands to the RIGHT of "INTO" for format 1 DIVIDE statements. 5, end_stmt.h contians the count of the number of operands to the RIGHT of "GIVING" for format 2 and format 3 DIVIDE 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 addition. These tokens are always data name (type 9) tokens. dcl temp_code fixed bin; /**************************************************/ /* START OF EXECUTION */ /* ENTRY POINT: divide */ /**************************************************/ give_up = "0"b; target_code = 2; /* divide uses long binary arithmetic (A and Q) always. */ source_code = 2; eos_ptr = in_token.token_ptr (in_token.n); if end_stmt.a = "000"b then do; /* Format 1 divide */ call div_operand_check (in_token.token_ptr (2), give_up); if give_up = "0"b then do; /* Divisor ok, check the receiving fields. */ do ix = 3 to in_token.n - 1 while (give_up = "0"b); call div_target_check (in_token.token_ptr (ix), give_up, 2); end; end; /* Divisor ok, check the receiving fields. */ end; /* Format 1 divide. */ else if (end_stmt.a = "001"b | end_stmt.a = "010"b) then do; /* Format 2 or Format 3 divide. */ /* Check divisor or dividend first. */ /* Note that it makes no difference whether we check the divisor first (Format 2) or dividend first (Format 3). */ call div_operand_check (in_token.token_ptr (2), give_up); if give_up = "0"b then do; /* Check other operand, and the targets. */ call div_operand_check (in_token.token_ptr (3), give_up); if give_up = "0"b then do; /* Check the targets. */ do ix = 4 to in_token.n - 1 while (give_up = "0"b); call div_target_check (in_token.token_ptr (ix), give_up, 2); end; end; /* Check the targets. */ end; /* Check other operand, and the targets. */ end; /* Format 2 or Format 3 divide. */ else do; /* Must be a Format 4 or Format 5 divide. */ /* Check the dividend and divisor first. */ /* Note that it makes no difference whether we check divisor or dividend first. */ call div_operand_check (in_token.token_ptr (2), give_up); if give_up = "0"b then call div_operand_check (in_token.token_ptr (3), give_up); /* Now check the receiving field. */ if give_up = "0"b then call div_target_check (in_token.token_ptr (4), give_up, 2); /* Now check the remainder field. */ if give_up = "0"b then call div_target_check (in_token.token_ptr (5), give_up, 2); end; /* Must be Format 4 or Format 5 divide. */ binary_ok = ^give_up; return; /*************************************************/ /* ENTRY POINT: multiply */ /**************************************************/ multiply: entry (in_token_ptr, binary_ok, target_code, source_code); /* 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. /**************************************************/ /* START OF EXECUTION */ /* ENTRY POINT: multiply */ /**************************************************/ give_up = "0"b; source_code = 2; /* Multiplication is always done in the A and Q. (long fixed bin operands) */ target_code = 2; eos_ptr = in_token.token_ptr (in_token.n); if end_stmt.a = "000"b then do; /* Format 1 multiply. */ /* Check the multiplicand. */ call div_operand_check (in_token.token_ptr (2), give_up); if give_up = "0"b then do; /* Check all targets. */ do ix = 3 to in_token.n - 1 while (give_up = "0"b); call div_target_check (in_token.token_ptr (ix), give_up, 1); end; end; /* Check all targets. */ end; /* Format 1 multiply. */ else do; /* Format 2 multiply. */ /* Check multiplicand. */ call div_operand_check (in_token.token_ptr (2), give_up); if give_up = "0"b then do; /* Multiplicand ok, check multiplier and targets. */ /* Check multiplier. */ call div_operand_check (in_token.token_ptr (3), give_up); if give_up = "0"b then do; /* Multiplier ok, check targets. */ do ix = 4 to in_token.n - 1 while (give_up = "0"b); call div_target_check (in_token.token_ptr (ix), give_up, 1); end; end; /* Multiplier ok, check targets. */ end; /* Multiplicand ok, check multiplier and targets. */ end; /* Format 2 multiply. */ binary_ok = ^give_up; return; div_operand_check: proc (operand_token_ptr, give_up_flag); /* This internal procedure tests an operand of a divide or multiply statement to determine whether the operand is of the proper type and size so that the divide or multiply can be done in the hardware registers. (A and Q) */ /* DECLARATION OF THE PARAMETERS */ dcl operand_token_ptr ptr; dcl give_up_flag bit (1); /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION operand_token_ptr Pointer to the token that describes the operand to be checked. (input) This token can 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. give_up_flag A flag that is set to "1"b by this procedure if the operand does not allow code to be generated in the hardware registers. (output) */ dcl temp_code fixed bin; give_up_flag = "0"b; if operand_token_ptr -> data_name.type = rtc_dataname then do; /* Operand token is a data name token. */ /* Operand must be long or short binary. If short binary cannot be an element of an array. */ if (operand_token_ptr -> data_name.bin_36 = "0"b & operand_token_ptr -> data_name.bin_18 = "0"b) then give_up_flag = "1"b; else if (operand_token_ptr -> data_name.bin_18 & operand_token_ptr -> data_name.subscripted) then give_up_flag = "1"b; end; /* Operand token is a data name token. */ else if operand_token_ptr -> data_name.type = rtc_numlit then call cobol_bin_const_ck (operand_token_ptr, give_up_flag, temp_code); /* Note that if the input operand is figurative constant ZERO, we fall thru, and give_up_flag is "0"b, indicating ok. */ end div_operand_check; div_target_check: proc (target_token_ptr, give_up_flag, operation_code); /* This internal procedure tests a target (receiving field) of a divide or multiply statement, and determines whether the target is of the size and type so that the operation can be performed in the hardware registers. (A and Q) In order to allow the operation to be performed in the A and Q, the target must satisfy the followint criteria: 1. Target must be long or short binary. 2. Target , if short binary cannot be an element of an array. 3. For divide, the target cannot have the rounded option specified for it. */ /* DECLARATION OF THE PARAMETERS> */ dcl target_token_ptr ptr; dcl give_up_flag bit (1); dcl operation_code fixed bin; /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION target_token_ptr Pointer to a data name token that describes the target (receiving field) of a divide or multiply. (input) give_up_flag A flag that is set to "1"b by this procedure if the operand does not allow code to be generated in the hardware registers.(output) operation_code A code that indicates whether the target is a target for a divide or multiply statement. (input) This code is defined in the follwoing table: operation code | statement ========================================= 1 | multiply 2 | divide ========================================= */ give_up_flag = "0"b; if (operation_code = 2 /*divide*/ & target_token_ptr -> data_name.rounded) then give_up_flag = "1"b; else if (target_token_ptr -> data_name.bin_18 = "0"b & target_token_ptr -> data_name.bin_36 = "0"b) then give_up_flag = "1"b; else if (target_token_ptr -> data_name.bin_18 & target_token_ptr -> data_name.subscripted) then give_up_flag = "1"b; end div_target_check; /* NEWSTUFF HERE */ /* 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_type19; %include cobol_record_types; %include cobol_in_token; /**************************************************/ /* END OF EXTERNAL PROCEDURE */ /**************************************************/ end cobol_binary_check;  cobol_build_resop.pl1 05/24/89 1040.3rew 05/24/89 0830.3 186129 /****^ *********************************************************** * * * 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_build_resop.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* format: style3 */ %; /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* Modified on 7/1/76 by Bob Chang to put default maximun temporary size. */ /*{*/ cobol_build_resop: proc (input_lop_ptr, input_rop_ptr, operator_code, resultant_operand_ptr, rdmax_flag, rdmax_value, possible_ovfl_flag); /* FUNCTION This procedure has several functions: 1. Builds a data name token (type 9) that describes the temporary that is to hold the result of an arithmetic computation. 2. allocates temporary space on the run time stack to hold the result of the arithmetic computation. The following assumptions are made: 1. input_lop_ptr and input_rop_ptr point to tokens that are either data name (type 9) tokens, numeric literal (type 2) tokens, or the reserved word token (type 1) for the figurative constant ZERO. 2. If either of the two above pointers do not point to data name (type 9) tokens the literal or figurative constant pointed to is pooled and a data name token is created. */ /* IMPLEMENTATION DETAILS */ /* This procedure builds a resultant operand that maintains the maximum significance of the result of a computation involving two operands. The maximum significance is defined by the number of decimal digits allowed tohold the result of the computation. By looking at the two operands and the operation to be performed, it is possible to determine whether the result will fit into a scaled decimal number, without losing any significance. If it is not possible for the result to fit into a scaled decimal, then the result must be stored into a decimal floating point number. In the discussion that follows, the following definitions will be used: DEFINITIONS MAX_TEMP_SIZE The maximum number of non-zero digits allowed in a temporary. LOP The token that describes the left operand of an arithmetic computation. ROP The token that describes the right operand of an arithmetic computation. LD The number of digits to the left of the decimal point of an operand of an arithmetic computation. RD The number of digits to the right of the decimal point of an operand of an arithmetic computation. For example, LOP(LD) is the number of digits to the left of the decimal point in the token that describes the left operand of an arithmetic computation, and LOP(RD) is the number of digits to the right of the decimal point. ROP(LD) and ROP(RD) are the analagous values for the token that describes the right operand. THE ALGORITHM USED The resultant operand built by this procedure is built according to the following algorithm. 1. If either LOP or ROP describes a decimal floating point operand, then the resultant operand built will be a decimal floating point operand. 2. If the arithmetic operation is divide or exponentiate, then the resultant operand built will be a decimal floating point operand. 3. Otherwise, temporary vallues TLD and TRD, for the number of digits to the left of the decimal point and right of the decimal point, respectively, are calculated. The algorithm used for these calculations depends on the type of arithmetec operation being performed on the two operands. a. ADD or SUBTRACT TLD = max(LOP(LD),ROP(LD)) + 1 TRD = max(LOP(RD),ROP(RD)) b. MULTIPLY TLD = LOP(LD) + ROP(LD) TRD = LOP(RD) + ROP(RD) After TLD and TRD are calculated, the sum of TLD and TRD is compared to MAX_TEMP_SIZE. If TLD + TRD < MAX_TEMP_SIZE, then the resultant operand built is a scaled decimal, with places_left = TLD, places_right = TRD. Otherwise, the resultnat operand is a decimal floating point operand, with length = MAX_TEMP_SIZE + 2. (The two additional bytes are necessary to provide space in the number for one byte of leading sign, and one byte for trailing exponent.) */ /* DECLARATION OF THE PARAMETERS */ dcl input_lop_ptr ptr; dcl input_rop_ptr ptr; dcl operator_code fixed bin; dcl resultant_operand_ptr ptr; dcl rdmax_flag bit (1); dcl rdmax_value fixed bin; dcl possible_ovfl_flag bit (1); /* input_lop_ptr Points to the token for the left operand of the expression for which a resultant operand token is to be built. (input) input_rop_ptr Points to the token for the right operand of the arithmetic expression for which a resultant operand token is to be built. (input) operator_code Code that identifies the binary operation being performed using the left and right operands. (input) This code can be one of the following values: code | meaning ---------------------------------- 182 | binary plus 183 | binary minus 184 | multiply 185 | divide 186 | exponentiate resultant_operand_ptr Points to the data name token (type 9) that describes the result of the arithmetic operation on the two input operands. (output) rdmax_flag A one bit flag that indicates whether an rdmax_value is input on this call. (see below for a definition of rdmax_value) This flag is set to "1"b if an rdmax_value is input, and meaningful, else it is set to "0"b. (input) rdmax_value A value that specifies the maximum number of decimal digits to be preserved to the right of the decimal point, if possible. This parameter is passed to this procedure by callers who are evaluating part of an expression whose result will eventually be moved to a receiving field. The rdmax_value is determined by the caller by taking the largest number of right digits in all of the receiving fields, and adding one to this value if rounding was specified for that receiving field. (input) possible_ovfl_flag A one bit flag that is set to "1"b on exit from this procedure, if the process of building the resultant operand token revealed a possible overflow out of the resultant operand by the execution of the arithmetic computation. (output) */ /* DECLARATION OF EXTERNAL ENTRIES */ dcl cobol_num_to_udts ext entry (ptr, ptr); dcl cobol_alloc$stack ext entry (fixed bin, fixed bin, fixed bin); dcl cobol_make_type9$decimal_9bit ext entry (ptr, fixed bin, fixed bin, fixed bin, fixed bin); dcl cobol_make_type9$type2_3 ext entry (ptr, ptr); dcl ioa_$ioa_stream ext entry options (variable); dcl print_image ext entry (ptr); /* DECLARATIONS OF INTERNAL STATIC VARIABLES */ /* Declaration of variables that contain values of the possible input operator codes */ dcl plus_op fixed bin (15) int static init (182); dcl minus_op fixed bin (15) int static init (183); dcl multiply_op fixed bin (15) int static init (184); dcl divide_op fixed bin (15) int static init (185); dcl exponentiate_op fixed bin (15) int static init (186); dcl codasyl_size fixed bin int static init (18); /* DECLARATION OF INTERNAL AUTOMATIC VARIABLES */ dcl dn_ptr ptr; dcl max_temp_size fixed bin; dcl work_ptr ptr; dcl prelim_ld fixed bin; dcl prelim_rd fixed bin; dcl total_size fixed bin; dcl ret_offset fixed bin; dcl lop_fixed_bin bit (1); dcl rop_fixed_bin bit (1); dcl lop_opch bit (1); dcl rop_opch bit (1); /**************************************************/ /* START OF EXECUTION */ /* cobol_build_resop */ /**************************************************/ /* SEt the maximum number of decimal digits to be allowed for a temporary operand. */ /* NOTE: Later, a field in fixed common will be defined to cntain the maximum number of digits to be allowed for a temporary operand. This field will either contain the Codasyl value (default??) or a value specified by the user in the environment division */ /* FOR NOW .... */ max_temp_size = fixed_common.default_temp; if (max_temp_size < 18) | (max_temp_size > 61) then max_temp_size = 30; lop_fixed_bin = "0"b; rop_fixed_bin = "0"b; lop_opch = "0"b; rop_opch = "0"b; /* Check to see if the input operand tokens are data name tokens, and convert them if necessary */ if input_lop_ptr -> data_name.type ^= rtc_dataname then do; /* Left operand needs conversion to a data name token */ call convert_to_dec (input_lop_ptr, work_ptr); input_lop_ptr = work_ptr; end; /* Left operand needs conversion to a data name token */ else if (input_lop_ptr -> data_name.bin_18 | input_lop_ptr -> data_name.bin_36) then lop_fixed_bin = "1"b; else if (input_lop_ptr -> data_name.item_signed & input_lop_ptr -> data_name.sign_separate = "0"b) then lop_opch = "1"b; /* Left operand is overpunch sign data. */ if input_rop_ptr -> data_name.type ^= rtc_dataname then do; /* Right operand needs conversion to a data name token */ call convert_to_dec (input_rop_ptr, work_ptr); input_rop_ptr = work_ptr; end; /* Right operand needs conversion to a data name token */ else if (input_rop_ptr -> data_name.bin_18 | input_rop_ptr -> data_name.bin_36) then rop_fixed_bin = "1"b; else if (input_rop_ptr -> data_name.item_signed & input_rop_ptr -> data_name.sign_separate = "0"b) then rop_opch = "1"b; /* Right operand overpunch sign data. */ if (lop_fixed_bin & rop_fixed_bin) then do; /* Both operands are fixed binary. */ /* LATER, we may develop a fixed binary resultant operand. For now, however, the fixed binary data will be converted to decimal, and a decimal resultant operand will be developed. */ work_ptr = null (); call cobol_num_to_udts (input_lop_ptr, work_ptr); input_lop_ptr = work_ptr; work_ptr = null (); call cobol_num_to_udts (input_rop_ptr, work_ptr); input_rop_ptr = work_ptr; lop_fixed_bin = "0"b; rop_fixed_bin = "0"b; end; /* Both operands are fixed binary. */ if lop_fixed_bin | lop_opch then do; /* The left operand is fixed binary or overpunch sign. */ work_ptr = null (); call cobol_num_to_udts (input_lop_ptr, work_ptr); input_lop_ptr = work_ptr; end; /* The left operand is fixed binary or opverpuch sign. */ if (rop_fixed_bin | rop_opch) then do; /* The right operand is fixed binary or overpunch sign */ work_ptr = null (); call cobol_num_to_udts (input_rop_ptr, work_ptr); input_rop_ptr = work_ptr; end; /* Only the right operand is fixed binary or overpunch sign. */ /* At this point, both input_lop_ptr and input_rop_ptr point to data name tokens, and both pointers may differ from their values on entry to this procedure */ if (input_lop_ptr -> data_name.sign_type = "111"b /* Left operand token is floating decimal */ | input_rop_ptr -> data_name.sign_type = "111"b /* Right operand token is floating decimal */ | operator_code = divide_op /* Operation is division */ | operator_code = exponentiate_op /* Operation is exponentiation. */) then call float_result (resultant_operand_ptr, max_temp_size); /* Result is a floating temp */ else do; /* Determine whether the result will fit into a fixed decimal temporary. */ /* Calculate the preliminary left and right digits for the temporary to be created. */ if (operator_code = plus_op | operator_code = minus_op) then do; /* Plus or minus operator */ if (input_lop_ptr -> data_name.places_left > input_rop_ptr -> data_name.places_left) then prelim_ld = input_lop_ptr -> data_name.places_left; /* left op places greater */ else prelim_ld = input_rop_ptr -> data_name.places_left; /* right op places greater */ prelim_ld = prelim_ld + 1; /* This is maximum integer part of the result */ if (input_lop_ptr -> data_name.places_right > input_rop_ptr -> data_name.places_right) then prelim_rd = input_lop_ptr -> data_name.places_right; /* left of rd greater */ else prelim_rd = input_rop_ptr -> data_name.places_right; /* right op rd greater */ end; /* Plus or minus operator */ else if operator_code = multiply_op then do; /* Multiply operator */ /* Calculate the number of left digits of the temporary */ prelim_ld = input_lop_ptr -> data_name.places_left + input_rop_ptr -> data_name.places_left; /* Calculate the number of right digits of the temporary */ prelim_rd = input_lop_ptr -> data_name.places_right + input_rop_ptr -> data_name.places_right; end; /* Multiply operator */ /* At this point, we have preliminary values for left and right digits. Now we must determine whether the total number of digits can be contained in the maximum number allowed for a temporary, and perform truncation (on the right) if necessary. */ if prelim_ld + prelim_rd > max_temp_size then call float_result (resultant_operand_ptr, max_temp_size); /* Left and right digits too large for a fixed decimal temporary. */ else do; /* Left and right digits will fit into a fixed decimal, make a fixed decimal temp. */ total_size = prelim_ld + prelim_rd; /* Total number of digits required to hold the maximum value temporary result */ /* Allocate space in the temporary token area for the data name token of the temproary */ call get_temp_token (work_ptr, 112); /* Allocate space in the run time stack to hold the temporary result */ call cobol_alloc$stack (total_size + 1, 0, ret_offset); /* Allocate one additioneal byte for sign */ /* Build the data name token in the temp token area */ call cobol_make_type9$decimal_9bit (work_ptr, 1000 /* stack */, ret_offset, prelim_ld, prelim_rd); resultant_operand_ptr = work_ptr; end; /* Left and right digits will fit into a fixed decimal, make a fixed decimal temp. */ end; /* Determine whether the result will fit into a fixed decimal temporary. */ /**************************************************/ /* END OF EXECUTABLE STATEMENTS */ /* cobol_build_resop */ /**************************************************/ get_temp_token: proc (ret_token_ptr, token_size); /* This internal procedure gets space for a temporary token in the temporary token area. */ /* DECLARATION OF THE PARAMETERS */ dcl ret_token_ptr ptr; dcl token_size fixed bin; /* ret_token_ptr Points to the temporary token in the temporary token area "gotten" by this procedure. (output) token_size size, in bytes, of the temporary token to be "gotten" in the temporary token area. (input) */ /* When this procedure is entered, the field cobol_$temp_token_ptr points to the next avaulable word in the temporary token area. The value of this pointer is set into the output parameter temp_token_ptr. Then the value in the input parameter token_size is used to calculate the next available WORD in the temporary token area, and cobol_$temp_token_ptr is updated to point to this next available word. */ /*************************************************/ /* START OF EXECUTION */ /* get_temp_token */ /**************************************************/ ret_token_ptr = cobol_$temp_token_ptr; cobol_$temp_token_ptr = addrel (cobol_$temp_token_ptr, divide (token_size + 3, 4, 17, 0)); end get_temp_token; /*{*/ convert_to_dec: proc (input_token_ptr, output_token_ptr); /* This internal procedure converts a numeric literal token (type 2) or the figurative constant ZERO token (type 1) to a data name (type 9) token. It does this by: 1. pooling the constant in the constant section 2. creating a data name token (type 9) for the pooled constant. */ /* DECLARATION OF THE PARAMETERS */ dcl input_token_ptr ptr; dcl output_token_ptr ptr; /* input_token_ptr Points to the input token to be converted to a data name token. (input) output_token_ptr Points to the data name token built by this procedure. This data name token is created in the temp token area. (output) */ /* DECLARATIONS OF BUILTIN FUNCTIONS */ dcl addr builtin; dcl addrel builtin; dcl divide builtin; dcl null builtin; /* DECLARATION OF INTERNAL STATIC VARIABLES */ /* 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 lit_ptr ptr; /**************************************************/ /* START OF EXECUTION */ /* convert_to_dec */ /**************************************************/ if input_token_ptr -> data_name.type = rtc_resword then lit_ptr = addr (num_lit_zero); /* ASSUME FIGURATIVE CONSTANT ZERO */ else lit_ptr = input_token_ptr; /* ASSUME A NUMERIC LITERAL TOKEN */ /* Allocate space in the temporary token area for the data name token to be built */ call get_temp_token (output_token_ptr, 112); /* Make a data name token from the numeric literal */ call cobol_make_type9$type2_3 (output_token_ptr, lit_ptr); end convert_to_dec; /*************************************************/ /* START OF INTERNAL PROCEDURE */ /* float_result */ /*************************************************/ float_result: proc (result_ptr, float_size); /* This internal procedure allocates space in the run-time stack for a floating decimal temporary, and builds a data name temporary token (type 9) that describes the temporary in the stack. */ /* DECLARATION OF THE PARAMETERS */ dcl result_ptr ptr; dcl float_size fixed bin; /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION result_ptr Points to the floating decimal temporary token built by this procedure. (output) float_size Contains the number of decimal digits to be contained in the floating decimal temporary allocated in the run-time stack by this procedure. (input) */ dcl ret_offset fixed bin; dcl dbuff (1:28) fixed bin based; dcl ix fixed bin; /*************************************************:/ /* START OF EXECUTION */ /* INTERNaL PROCEDURE float_result */ /*********************************************/ /* Allocate space in the temporary token area for the floating decimal temporary token. */ call get_temp_token (dn_ptr, 112); /* Allocate space on the run-time stack for the temporary. */ call cobol_alloc$stack (float_size + 2 /* add 2 for sign byte + exponent byte */, 0, ret_offset); /* Build the floating decimal temporary token. */ /* Set zeroes into the data name token image */ do ix = 1 to 28; dn_ptr -> dbuff (ix) = 0; end; /* Type code */ data_name.type = rtc_dataname; /* Item length */ data_name.item_length = float_size + 2; /* Segment number */ data_name.seg_num = 1000; /* STACK */ /* Offset */ data_name.offset = ret_offset; /* from cobol_alloc$stack */ /* Sign type (TO SPECIAL FLOATING DECIMAL CODE!!!) */ data_name.sign_type = "111"b; /* numeric description bit */ data_name.numeric = "1"b; result_ptr = dn_ptr; end float_result; /* INCLUDE FILES USED BY THIS PROCEDURE */ %include cobol_record_types; %include cobol_ext_; %include cobol_fixed_common; %include cobol_type9; %include cobol_; %include cobol_mcdb; /**************************************************/ /* END OF PROCEDURE */ /* cobol_build_resop */ /**************************************************/ end cobol_build_resop;  cobol_call_gen.pl1 05/24/89 1040.3rew 05/24/89 0830.3 131760 /****^ *********************************************************** * * * 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_call_gen.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 04/01/81 by FCH, entries not made in fixup table for call data-name, [4.4-1], TR9244(BUG473) */ /* Modified on 03/28/79 by FCH, [4.0-1], fix reloc bits on call */ /* Modified since Version 4.0 */ /*{*/ /* format: style3 */ cobol_call_gen: proc (in_token_ptr); dcl inst_seq_1_2 (0:7) bit (36); /* Automatic data */ declare oprnd_ln (127) fixed bin aligned, /* Table of operand lengths. */ var_stack (127) fixed bin aligned, operands fixed bin, /* No of operands in USING phrase. */ oprnd_ptr ptr, /* Pointer to current operand token. */ new_oprnd_ptr ptr, link_flag fixed bin, /* 0 if no operands in COBOL Linkage */ /* Section; 1, otherwise. */ desc_code (128) bit (36), /* Storage space for code generated to */ /* put descriptor ptrs in arg list. */ stackoff fixed bin, /* Word offset in stack. */ temp fixed bin, /* Temporary used in unspec function. */ index fixed bin, /* Do loop index. */ retry_tag fixed bin, jndex fixed bin, /* Do loop index. */ no_wds fixed bin, /* No of wds of desc_code to emit. */ offset fixed bin, /* Word offset of entry point link. */ stack_wds fixed bin, /* No of words required in the stack. */ dn_ptr ptr, /* Ptr to type 9 token. */ num_wds fixed bin, /* No of words of code to be emitted. */ fst_inst_no fixed bin, /* Offset of first inst generated by */ /* cobol_call_gen. */ desc_off bit (36), /* Argument descriptor offset. */ prec_len fixed bin, tze_loc fixed bin; /* Location in Text of tze inst. */ /*}*/ /*************************************/ start: /* Common Functions */ /* Determine number of USING operands, if any, and words of */ /* stack required for parameter list. */ retry_tag = cobol_$next_tag; /* 5/27/76 */ cobol_$next_tag = cobol_$next_tag + 1; call cobol_define_tag (retry_tag); if in_token.token_ptr (in_token.n) -> end_stmt.a = "000"b then do; operands = 0; stack_wds = 0; end; else do; operands = in_token.token_ptr (in_token.n) -> end_stmt.e; stack_wds = 4 * operands + 2; end; if operands > 127 then call signal_ ("command_abort_", null, addr (oprnd_ovfl)); /* Reserve pointer registers 2 and 4 and initialize link_flag. */ link_flag = 0; /* Determine type of CALL and transfer to appropriate section */ /* of procedure for processing. */ if in_token.token_ptr (2) -> alphanum_lit.type = 3 then goto call_lit; else goto call_id; /* * * * * * * */ call_lit: alit_ptr = in_token.token_ptr (2); call cobol_make_link$type_4 (offset, alit_ptr -> alphanum_lit.string); if operands = 0 then do; inst_seq_3b (5) = "100000000000000000"b; substr (inst_seq_3b (5), 4, 15) = substr (unspec (offset), 22, 15); if fixed_common.options.profile then do; fixup_directive.location.offset = cobol_$text_wd_off + 2; call cobol_make_fixup (addr (fixup_directive)); end; call cobol_emit (addr (inst_seq_3b), addr (inst_seq_3rel), 4); end; else do; call cobol_alloc$stack (4 * stack_wds, 2, stackoff); call make_arg_list; /* 07-15-77 */ substr (inst_seq_3a (1), 4, 15) = substr (unspec (stackoff), 22, 15); substr (inst_seq_3a (3), 1, 7) = substr (unspec (operands), 30, 7); inst_seq_3a (5) = "100000000000000000"b; substr (inst_seq_3a (5), 4, 15) = substr (unspec (offset), 22, 15); if fixed_common.options.profile then do; fixup_directive.location.offset = cobol_$text_wd_off + 2; call cobol_make_fixup (addr (fixup_directive)); end; if fixed_common.descriptor ^= "00"b then call cobol_emit (addr (inst_seq_3a), addr (inst_seq_3rel), 4); /*[4.0-1]*/ else do; call cobol_emit (addr (inst_seq_3a (1)), addr (inst_seq_3rel (1)), 3); call cobol_emit (addr (inst_seq_3b (7)), null, 1); end; end; call cobol_reg_manager$after_op (0); return; call_id: stack_wds = stack_wds + 2; if stack_wds < 30 then stack_wds = 30; call cobol_alloc$stack (4 * stack_wds, 2, stackoff); if stackoff ^= 68 then do; substr (inst_seq_1_1 (9), 4, 15) = substr (unspec (stackoff), 22, 15); temp = stackoff + 2; substr (inst_seq_1_1 (3), 4, 15) = substr (unspec (temp), 22, 15); inst_seq_1_1 (5) = inst_seq_1_1 (3); temp = stackoff + 10; substr (inst_seq_1_1 (7), 4, 15) = substr (unspec (temp), 22, 15); temp = stackoff + 16; substr (inst_seq_1_1 (11), 4, 15) = substr (unspec (temp), 22, 15); temp = stackoff + 18; substr (inst_seq_1_1 (15), 4, 15) = substr (unspec (temp), 22, 15); temp = stackoff + 20; substr (inst_seq_1_1 (19), 4, 15) = substr (unspec (temp), 22, 15); temp = stackoff + 26; substr (inst_seq_1_1 (21), 4, 15) = substr (unspec (temp), 22, 15); temp = stackoff + 28; substr (inst_seq_1_1 (25), 4, 15) = substr (unspec (temp), 22, 15); temp = stackoff + 5; substr (inst_seq_1_3 (7), 4, 15) = substr (unspec (temp), 22, 15); inst_seq_1_3 (11) = inst_seq_1_3 (7); inst_seq_1_3 (17) = inst_seq_1_3 (7); temp = stackoff + 6; substr (inst_seq_1_3 (15), 4, 15) = substr (unspec (temp), 22, 15); inst_seq_1_3 (33) = inst_seq_1_3 (15); inst_seq_1_3 (47) = inst_seq_1_3 (15); inst_seq_1_3 (49) = inst_seq_1_3 (15); temp = stackoff + 7; substr (inst_seq_1_3 (31), 4, 15) = substr (unspec (temp), 22, 15); inst_seq_1_3 (37) = inst_seq_1_3 (31); temp = stackoff + 8; substr (inst_seq_1_3 (55), 4, 15) = substr (unspec (temp), 22, 15); temp = stackoff + 14; substr (inst_seq_1_3 (23), 4, 15) = substr (unspec (temp), 22, 15); inst_seq_1_3 (41) = inst_seq_1_3 (23); temp = stackoff + 22; substr (inst_seq_1_3 (35), 4, 15) = substr (unspec (temp), 22, 15); inst_seq_1_3 (51) = inst_seq_1_3 (35); temp = stackoff + 24; substr (inst_seq_1_3 (53), 4, 15) = substr (unspec (temp), 22, 15); end; call cobol_arg_descriptor ("100110100000000000000000000000000000"b, desc_off, temp); temp = binary (substr (desc_off, 1, 18), 17) - 8; inst_seq_1_1 (17) = substr (unspec (temp), 19, 18); call cobol_arg_descriptor ("100000100000000000000000000000010001"b, desc_off, temp); temp = binary (substr (desc_off, 1, 18), 17) - 11; inst_seq_1_1 (23) = substr (unspec (temp), 19, 18); call cobol_pool ("ÿÿ#", 2, offset); fst_inst_no = cobol_$text_wd_off; temp = -(offset + fst_inst_no); inst_seq_1_1 (1) = substr (unspec (temp), 19, 18); call cobol_emit (addr (inst_seq_1_1), null, 13); input_struc.token_ptr = in_token.token_ptr (2); call cobol_addr (addr (input_struc), addr (inst_seq_1_2), null); num_wds = 1; if substr (inst_seq_1_2 (0), 33, 4) ^= "0000"b then do; num_wds = num_wds + 1; inst_seq_1_2 (num_wds) = "010000000000000000101000000101000000"b; substr (inst_seq_1_2 (num_wds), 33, 4) = substr (inst_seq_1_2 (0), 33, 4); end; if substr (inst_seq_1_2 (1), 19, 2) ^= "00"b then do; num_wds = num_wds + 1; inst_seq_1_2 (num_wds) = "000000000000000000010011101000000111"b; substr (inst_seq_1_2 (num_wds), 17, 2) = substr (inst_seq_1_2 (1), 19, 2); num_wds = num_wds + 1; inst_seq_1_2 (num_wds) = "010000000000000000101000000101000101"b; end; num_wds = num_wds + 1; inst_seq_1_2 (num_wds) = "110000000000000000010101010001000000"b; temp = stackoff + 12; substr (inst_seq_1_2 (num_wds), 4, 15) = substr (unspec (temp), 22, 15); if substr (inst_seq_1_2 (0), 31, 1) = "0"b then do; substr (inst_seq_1_3 (2), 13, 1) = "0"b; inst_seq_1_3 (27) = substr (unspec (in_token.token_ptr (2) -> data_name.item_length), 19, 18); inst_seq_1_3 (43) = inst_seq_1_3 (27); substr (inst_seq_1_3 (4), 7, 12) = substr (inst_seq_1_3 (27), 7, 12); substr (inst_seq_1_3 (28), 10, 9) = "000000111"b; substr (inst_seq_1_3 (44), 10, 9) = "000000111"b; end; else do; substr (inst_seq_1_3 (2), 13, 1) = "1"b; inst_seq_1_3 (27) = "110000000000101010"b; inst_seq_1_3 (43) = "110000000000101010"b; substr (inst_seq_1_3 (4), 7, 12) = substr (inst_seq_1_2 (1), 25, 12); substr (inst_seq_1_3 (28), 10, 9) = "001000000"b; substr (inst_seq_1_3 (44), 10, 9) = "001000000"b; num_wds = num_wds + 1; inst_seq_1_2 (num_wds) = "110000000000101010100101000001000000"b; num_wds = num_wds + 1; inst_seq_1_2 (num_wds) = "110000000000101010100100000001000000"b; substr (inst_seq_1_2 (num_wds), 25, 3) = substr (inst_seq_1_2 (1), 34, 3); end; substr (inst_seq_1_2 (1), 19, 18) = "011101010001000000"b; call cobol_emit (addr (inst_seq_1_2 (1)), null, num_wds); call cobol_make_link$type_4 (offset, "hcs_$make_ptr"); substr (inst_seq_1_3 (59), 4, 15) = substr (unspec (offset), 22, 15); if fixed_common.options.profile then do; fixup_directive.location.offset = cobol_$text_wd_off + 29; call cobol_make_fixup (addr (fixup_directive)); end; call cobol_emit (addr (inst_seq_1_3), addr (rel_seq_1_3), 30); call cobol_call_op (5, 0); tze_loc = text_wd_off + 1; call cobol_emit (addr (inst_seq_2_0), null, 2); call cobol_gen_error (57, retry_tag); call cobol_define_tag_nc (cobol_$next_tag, cobol_$text_wd_off); call cobol_make_tagref (cobol_$next_tag, tze_loc, null); cobol_$next_tag = cobol_$next_tag + 1; if operands = 0 then do; inst_seq_3b (5) = "110000000000000000"b; substr (inst_seq_3b (5), 4, 15) = substr (unspec (stackoff), 22, 15); /*[4.4-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;*/ /*[4.4-1]*/ call cobol_emit (addr (inst_seq_3b), addr (inst_seq_3rel), 4); /*[4.0-1]*/ end; else do; inst_seq_3a (5) = "110000000000000000"b; substr (inst_seq_3a (5), 4, 15) = substr (unspec (stackoff), 22, 15); stackoff = stackoff + 2; call make_arg_list; /* 07-15-77 */ substr (inst_seq_3a (1), 4, 15) = substr (unspec (stackoff), 22, 15); substr (inst_seq_3a (3), 1, 7) = substr (unspec (operands), 30, 7); /*[4.4-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;*/ /*[4.4-1]*/ if fixed_common.descriptor ^= "00"b then call cobol_emit (addr (inst_seq_3a), addr (inst_seq_3rel), 4); /*[4.0-1]*/ else do; call cobol_emit (addr (inst_seq_3a (1)), addr (inst_seq_3rel), 3); /*[4.0-1]*/ call cobol_emit (addr (inst_seq_3b (7)), null, 1); end; end; call cobol_reg_manager$after_op (0); exit: return; /* * * * * * * */ make_arg_list: proc; start_make_arg_list: do index = 1 to operands; oprnd_ptr = in_token.token_ptr (index + 2); if oprnd_ptr -> data_name.linkage_section = "0"b | oprnd_ptr -> data_name.type = 2 | oprnd_ptr -> data_name.type = 3 then do; if oprnd_ptr -> data_name.type = 2 | oprnd_ptr -> data_name.type = 3 then do; new_oprnd_ptr = null (); call cobol_make_type9$type2_3 (new_oprnd_ptr, oprnd_ptr); oprnd_ptr = new_oprnd_ptr; end; oprnd_z.segno = oprnd_ptr -> data_name.seg_num; oprnd_z.char_offset = oprnd_ptr -> data_name.offset; call cobol_addr (addr (oprnd_z), addr (inst_seq_1a), null); temp = stackoff + 2 * index; substr (inst_seq_1a (3), 4, 15) = substr (unspec (temp), 22, 15); call cobol_emit (addr (inst_seq_1a), null, 2); end; else /* Operand is in COBOL Linkage Section */ do; if link_flag = 0 then do; link_flag = 1; call cobol_pointer_register$get (addr (register_request)); call cobol_emit (addr (inst_seq_1b), null, 1); end; temp = 2 * oprnd_ptr -> data_name.linkage; substr (inst_seq_1b (3), 4, 15) = substr (unspec (temp), 22, 15); temp = stackoff + 2 * index; substr (inst_seq_1b (5), 4, 15) = substr (unspec (temp), 22, 15); call cobol_emit (addr (inst_seq_1b (3)), null, 2); end; if fixed_common.descriptor = "00"b then goto next_arg; /* 07-15-77 */ if oprnd_ptr -> data_name.variable_length = "0"b | fixed_common.descriptor = "01"b then do; call cobol_arg_descriptor$type9 (oprnd_ptr, ch_desc, oprnd_ln (index)); end; else do; call cobol_alloc$stack (4, 1, var_stack (index)); call cobol_get_size (oprnd_ptr, 0, 0); if oprnd_ptr -> data_name.level = 1 | oprnd_ptr -> data_name.level = 77 then var_inst (1) = "101010100000000000"b; else var_inst (1) = "101010110000000000"b; substr (var_inst (3), 4, 15) = substr (unspec (var_stack (index)), 22, 15); call cobol_emit (addr (var_inst), null (), 2); ch_desc = "111111111111111111111111111111111111"b; oprnd_ln (index) = fixed (ch_desc); end; next_arg: end; if fixed_common.descriptor = "00"b then return; /* 07-15-77 */ desc_code (2) = inst_seq_2 (2); do index = 1 to operands; if oprnd_ln (index) = -1 then do; desc_code (1) = "110000000000000000011101010001000000"b; substr (desc_code (1), 4, 15) = substr (unspec (var_stack (index)), 22, 15); end; else do; desc_code (1) = inst_seq_2 (1); oprnd_ln (index) = -oprnd_ln (index) - cobol_$text_wd_off; substr (desc_code (1), 1, 18) = substr (unspec (oprnd_ln (index)), 19, 18); end; temp = stackoff + 2 * (operands + index); substr (desc_code (2), 4, 15) = substr (unspec (temp), 22, 15); no_wds = 2; call cobol_emit (addr (desc_code), null, no_wds); end; exit_make_arg_list: return; end make_arg_list; %include cobol_call_gen_info; %include cobol_call_gen_data; end cobol_call_gen;  cobol_call_op.pl1 05/24/89 1040.3rew 05/24/89 0830.3 24165 /****^ *********************************************************** * * * 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_call_op.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 12/18/78 by FCH, [3.0-1], entry skip added */ /* Modified since Version 3.0. */ /* format: style3 */ cobol_call_op: proc (op_num, tagno); dcl (tagno, tag1) fixed bin, /* tag number for no error. */ op_num fixed bin; /* operator number for the call. */ /* [3.0-1] */ declare tag_1 fixed bin; dcl temp fixed bin; dcl inst_seq (4) bit (18) init ("000000000000000000"b, "111000000001000000"b, /* tsx0 pr0|op_num */ "000000000000000000"b, "111001000000000100"b); /* tra 0,ic */ /***********************************/ /* [3.0-1] */ tag_1 = 0; start: if first_time ^= cobol_$compile_count then do; first_time = cobol_$compile_count; op_bit = (200)"0"b; end; temp = op_num; if temp < 200 then substr (op_bit, temp + 1, 1) = "1"b; call cobol_reg_manager$before_op (temp); substr (inst_seq (1), 4, 15) = substr (unspec (op_num), 22, 15); call cobol_emit (addr (inst_seq), null (), 1); if tagno = 0 then do; call cobol_reg_manager$after_op (temp); end; else do; call cobol_emit (addr (inst_seq (3)), null (), 1); call cobol_make_tagref (tagno, cobol_$text_wd_off - 1, null ()); /* [3.0-1] */ if tag_1 ^= 0 /* [3.0-1] */ then do; call cobol_emit (addr (inst_seq (3)), null (), 1); /* [3.0-1] */ call cobol_make_tagref (tag_1, cobol_$text_wd_off - 1, null ()); /* [3.0-1] */ end; end; return; get_op: entry (operator_struc_ptr); dcl operator_struc_ptr ptr; operator_struc_ptr = addr (op_bit); return; skip: entry (op_num, tagno, tag1); /* [3.0-1] */ tag_1 = tag1; go to start; %include cobol_call_op_info; %include cobol_call_op_data; end cobol_call_op;  cobol_cancel_gen.pl1 05/24/89 1040.3rew 05/24/89 0830.3 33327 /****^ *********************************************************** * * * 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_cancel_gen.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 7/16/76 by Bob Chang to delete the call for the link to cobol_control_$cancel. */ /* Modified on 03/26/76 by ORN to generate call to cobol_cancel_ instaed of cobol_control_$cancel. Change made in conjunction with cobol_control_ modification. */ /* format: style3 */ cobol_cancel_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 */ 2 pt2 ptr, /* pts to type9 or type3 token */ 2 pt3 ptr; /* pts to meaningless type19 token */ dcl 1 mpout, 2 n fixed bin, 2 pt1 ptr, 2 pt2 ptr, 2 pt3 ptr, 2 pt4 ptr; dcl 1 type9, 2 alignment ptr, /* so as to double word align the space */ 2 rest char (140); 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 (5), /* CALL */ 2 e fixed bin init (1), /* one operand after USING */ 2 hij (3) fixed bin init (0, 0, 0), 2 a bit (3) init ("001"b), /* USING operands exist */ 2 bcdfgk bit (13) init (""b); dcl 1 type3 static, 2 size fixed bin init (45), 2 line fixed bin init (0), 2 column fixed bin init (0), 2 type fixed bin init (3), 2 bits bit (8) init (""b), 2 lit_size fixed bin init (13), 2 lit char (13) init ("cobol_cancel_"); dcl 1 pr3_struct static, 2 pr3 fixed bin init (3), 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 dn_ptr ptr; dcl offset fixed bin, temp fixed bin, cobol_emit entry (ptr, ptr, fixed bin), cobol_call_op entry (fixed bin, fixed bin), cobol_get_size$omit_sign entry (ptr, fixed bin, fixed bin), cobol_set_pr entry (ptr, ptr), cobol_make_type9$type2_3 entry (ptr, ptr); dcl inst_seq (4) bit (18) static init ("000000000000000000"b, "011101011100000100"b, /* epp3 name_loc,ic */ "000000000000000000"b, "010011101000000111"b); /* lda name_len,dl */ /*************************************/ start: mpout.pt1 = mp.pt1; mpout.pt2 = addr (type3); dn_ptr = mp.pt2; if data_name.type ^= 9 then do; dn_ptr = addr (type9); call cobol_make_type9$type2_3 (dn_ptr, mp.pt2); end; call cobol_set_pr (addr (pr3_struct), dn_ptr); call cobol_get_size$omit_sign (dn_ptr, 0, 0); call cobol_call_op (49, 0); 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_type9; %include cobol_; end cobol_cancel_gen;  cobol_close_gen.pl1 05/24/89 1040.3rew 05/24/89 0830.3 34542 /****^ *********************************************************** * * * 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_close_gen.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 11/14/78 by FCH, [3.0-1], alt_rec_keys added */ /* Modified since Version 3.0 */ /* format: style3 */ cobol_close_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 CLOSE */ 2 pt2 ptr, /* pts to type12 token for the file */ 2 pt3 ptr; /* pts to type19 token */ /* CLOSE fn EOS b 0 = no REEL unit present 1 = REEL unit present c 0 = REWIND 1 = NO REWIND f 00 = NO LOCK present 01 = LOCK present */ dcl good_tag fixed bin; dcl argb (5) bit (216) based (addr (args.arg (1))); dcl arg_ptr ptr; dcl ioerror_ptr ptr; dcl ft_ptr ptr; dcl basic_ptr ptr; dcl name_ptr ptr; dcl aloff fixed bin; dcl stoff fixed bin; /*************************************/ /*************************************/ /* INITIALIZATION */ start: eos_ptr = mp.pt3; ioerror.retry_tag = cobol_$next_tag; ioerror.ns_tag = cobol_$next_tag + 1; good_tag = cobol_$next_tag + 2; cobol_$next_tag = cobol_$next_tag + 3; ioerror_ptr = addr (ioerror); ioerror.type1_ptr = mp.pt1; ioerror.is_tag = 0; /* initialize to zero */ ioerror.mode = 0; call cobol_read_ft (mp.pt2 -> fd_token.file_no, ft_ptr); if end_stmt.b then if file_table.device ^= 5 then return; call cobol_alloc$stack (0, 2, aloff); /* for max arglist */ /*************************************/ /* START CODE GENERATION */ start_codegen: call cobol_ioop_util$set_stz; call cobol_define_tag (ioerror.retry_tag); call cobol_set_fsbptr (ft_ptr); /* generates epp1 pr4|102,* */ /* CLOSE FILE and DETACH cobol_operators_ */ if end_stmt.b then do; call cobol_alloc$stack (80, 2, stoff); substr (epp2 (1), 4, 15) = substr (unspec (stoff), 22, 15); call cobol_emit (addr (epp2 (1)), null, 2); /* OPERATOR 76: close reel */ call cobol_call_op (76, good_tag); end; else if ^file_table.detach then /* OPERATOR 27: close_file */ call cobol_call_op (27, good_tag); /* close_op */ /* OPERATOR 38: close_file_only */ else call cobol_call_op (38, good_tag); /* close_only_op */ ioerror.cobol_code = 0; call cobol_gen_ioerror (ft_ptr, ioerror_ptr); call cobol_define_tag (good_tag); /* [3.0-1] */ if file_table.organization = 3 /* ind */ /* [3.0-1] */ & /* [3.0-1] */ file_table.alternate_keys ^= 0 /* [3.0-1] */ then do; call cobol_io_util$file_desc (file_table.file_desc_1_offset); /* [3.0-1] */ call cobol_set_fsbptr (ft_ptr); /* [3.0-1] */ call cobol_call_op (89, 0); /* [3.0-1] */ end; if end_stmt.f = "01"b then call cobol_ioop_util$set_lock; call cobol_reg_manager$after_op (4095 + ioerror.cobol_code); call cobol_gen_ioerror$finish_up (ft_ptr, ioerror_ptr); return; %include cobol_close_gen_info; %include cobol_close_gen_data; end cobol_close_gen;  cobol_compare_gen.pl1 05/24/89 1040.3rew 05/24/89 0830.3 869049 /****^ *********************************************************** * * * 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_compare_gen.pl1 Added Trace statements. 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 04/17/80 by FCH, [4.2-2], fix routine which compares type 2 tokens */ /* Modified on 03/27/80 by FCH, [4.2-1], BUG427(TR3251), FW const used for neg comp-6 numbers */ /* Modified on 02/23/77 by Bob Chang to fix the bug for initialization of auto data. */ /* Modified on 1/19/77 by Bob Chang to improve the codes generated for index and binary comparsion. */ /* Modified on 1/11/77 by Bob Chang to improve the codes generated for comp-6 and comp-7 comparison. */ /* Modified on 12/30/76 by Bob Chang to handle numeric test for opch data with unsigned value in storage. */ /* Modified since Version 2.0. */ /* format: style3 */ cobol_compare_gen: proc (in_token_ptr, sort_prog_coll_seq_ptr); sort_pcs_ptr = null (); /* not call from sort with collating seq. */ goto start; sort: entry (in_token_ptr, sort_prog_coll_seq_ptr); sort_pcs_ptr = sort_prog_coll_seq_ptr; /* The above entry is the compare routine called from sort_gen. */ /* The Compare Generator: cobol_compare_gen FUNCTION The compare generator is called to generate code for: 1. relational conditions 2. class conditions 3. sign conditions 4. unconditional branches INPUT The input to this procedure is a pointer that points to a struc- ture with a format defined by the following declaration: dcl 1 in_token aligned based (in_token_ptr), 2 n fixed bin aligned, 2 code fixed bin aligned, 2 token_ptr (0 refer(in_token.n)) ptr aligned; The pointers in the array in_token.token_ptr point to tokens that provide information about the type of code to be generated. This array will contain from one to three pointers of interest to cobol_compare_gen, depending on the code to be generated. code to be generated | number of pointers of | interest ______________________________________________________ | unconditional branch | 1 _______________________________________________________ | class condition | 2 sign condition | abbreviated relational | condition | _______________________________________________________ relational condition | 3 _______________________________________________________ In all cases for which cobol_compare_gen is called, in_token.token_ptr(n) points to an EOS token. The pointers of interest in the token_ptr array are described in the following table. if cobol_compare gen is | pointers of interest in token_ptr called for |__________________________________ | number | description _________________________________________________________________ | | unconditional branch | 1 | token_ptr(n)->EOS token | _________________________________________________________________ | | class condition | 2 | token_ptr(n)->EOS token | | token_ptr(n-1)-> dataname | | token whose class is to be | | determined | | _________________________________________________________________ | | sign condition | 2 | token_ptr(n)->EOS token | | token_ptr(n-1)->dataname | | token whose sign is to be | | determined | | _________________________________________________________________ | | abbreviated relational | 2 | token_ptr(n)->EOS token condition | | token_ptr(n-1)->right | | operand of the abbreviated | | relation | | _________________________________________________________________ | | relational condition | 3 | token_ptr(n)->EOS token | | token_ptr(n-1)->right operand | | operand of relation | | token_ptr(n-2)->left | | operand of relation _________________________________________________________________ THE EOS TOKEN The EOS token contains information that defines the type of code to be generated. The format of this token is defined by a declaration of the form: dcl 1 end_stmt based (eos_ptr), 2 size fixed bin (15), 2 line fixed bin (15), 2 column fixed bin (15), 2 type fixed bin (15), 2 e fixed bin (15), 2 h fixed bin (15), 2 i fixed bin (15), 2 j fixed bin (15), 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); Only certain fields of the EOS token are relevant to cobol_compare_gen. The relevant fields are: 1. end_stmt.e This fixed binary field contains either a. a code that identifies the type of compare for which code is to be generated. b. a code that indicates that code for an unconditional branch is to be generated. The values which this field will contain, and the meaning associated with each are given in the following table: value in end_stmt.e | code is to be generated for _______________________________________________________ 63 | unconditional branch 102 | equal compare 113 | greater compare 123 | less compare 171 | unequal compare 131 | numeric class condition 74 | alphabetic class condition 141 | positive sign condition 127 | negative sign condition 180 | zero sign condition ________________________________________________________ 2. end_stmt.h This fixed binary field contains a compiler generated tag (label) number to which a transfer is to be done depending on the results of the compare. 3. end_stmt.i This fixed binary field is used as a bit (36) field. Only two bits have any significance: a. bit 2 If "1"b, then a transfer to te label in end_stmt.h is to be executed if the result of the compare specified in end_stmt.e is NOT true. b. bit 3 If "1"b, then this is an EOS for an abbreviated compare. Only token_ptr(n-1) is meaningful the token_ptr array, and it points to the right operand of the relational condition. OUTPUT One output value is passed back to the generator driver under certain conditions. When cobol_compare_gen is called to generate code for an unabbreviated relation condition, the field "in_token.code" is set to 1 before returning to the generator driver. This reuurned value tells the driver to save the current in_token structure. This saved in_token structure will be the source of the left operand if the next call to cobol_compare_gen is an abbreviated compare. Note that it is the responsibility of cobol_compare_gen to save a pointer to the input_structure saved by the generator driver. */ /*}*/ /* DECLARATIONS OF EXTERNAL ENTRIES */ dcl cobol_make_tagref ext entry (fixed bin, fixed bin, ptr); dcl cobol_make_type9$type2_3 ext entry (ptr, ptr); dcl cobol_addr ext entry (ptr, ptr, ptr); dcl cobol_emit ext entry (ptr, ptr, fixed bin); dcl cobol_trans_alphabet entry (ptr, ptr, fixed bin, fixed bin, ptr, char (1)); dcl cobol_register$load entry (ptr); dcl cobol_register$release entry (ptr); dcl cobol_make_type9$long_bin entry (ptr, fixed bin, fixed bin); dcl cobol_alloc$stack ext entry (fixed bin, fixed bin, fixed bin); dcl cobol_move_gen ext entry (ptr); dcl cobol_make_type9$copy ext entry (ptr, ptr); dcl cobol_pool$search_op entry (char (*), fixed bin, fixed bin, fixed bin); dcl cobol_define_tag ext entry (fixed bin); dcl cobol_get_index_value ext entry (fixed bin, ptr, ptr); dcl cobol_num_to_udts ext entry (ptr, ptr); /* DEFINITIONS OF CONSTANTS THAT COULD APPEAR IN THE EOS TOKENS */ dcl rwkey_numeric fixed bin int static init (131); dcl rwkey_alphabetic fixed bin int static init (74); dcl rwkey_positive fixed bin int static init (141); dcl rwkey_negative fixed bin int static init (127); dcl rwkey_zero fixed bin int static init (180); dcl rwkey_equal fixed bin int static init (102); dcl rwkey_greater fixed bin int static init (113); dcl rwkey_less fixed bin int static init (123); dcl rwkey_unequal fixed bin int static init (171); dcl rwkey_space fixed bin int static init (192); dcl rwkey_quote fixed bin int static init (235); dcl rwkey_highval fixed bin int static init (221); dcl rwkey_lowval fixed bin int static init (229); dcl uncond_branch fixed bin int static init (63); /* DEFINITIONS OF CONSTANTS THAT REPRESENT OPCODES USED IN THIS GENERATOR */ dcl tmi_op bit (10) int static init ("1100001000"b /* 604(0) */); dcl tpl_op bit (10) int static init ("1100001010"b /* 605(0) */); dcl trc_op bit (10) int static init ("1100000110"b /* 603(0) */); dcl tnc_op bit (10) int static init ("1100000100"b /* 602(0) */); dcl tmoz_op bit (10) int static init ("1100001001"b /* 604(1) */); dcl tpnz_op bit (10) int static init ("1100001011"b /* 605(1) */); dcl tnz_op bit (10) int static init ("1100000010"b /* 601(0) */); dcl tze_op bit (10) int static init ("1100000000"b /* 600(0) */); dcl ttf_op bit (10) int static init ("1100001110"b /* 607(0) */); dcl ttn_op bit (10) int static init ("1100001101"b /* 606(1) */); dcl tra_op bit (10) int static init ("1110010000"b /* 710(0) */); dcl nop_op bit (10) int static init ("0000010010"b /* 011(0) */); dcl cmpn_op bit (10) int static init ("0110000111"b /* 303(1) */); dcl cmpc_op bit (10) int static init ("0010001101"b /* 106(1) */); dcl tct_op bit (10) int static init ("0011101001"b /* 164(1) */); dcl mvt_op bit (10) int static init ("0011100001"b /* 160(1) */); /* DECLARATION OF AN IMAGE OF A NUMERIC LITERAL ZERO */ dcl 1 numeric_zero internal 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 ("00000"b), 2 sign char (1) init (" "), 2 exp_sign char (1) init (" "), 2 exp_places fixed bin (15) init (0), 2 places_left fixed bin (15) init (1), 2 places_right fixed bin (15) init (0), 2 places fixed bin (15) init (1), 2 literal char (1) init ("0"); /* INTERNAL STATIC BUFFERS USED TO HOLD OPERANDS THAT ARE BUILT ONLY ONCE PER COMPILATION */ dcl type9_zero (1:35) fixed bin internal static; dcl type9_zero_ptr ptr internal static; dcl type9_numeric_tct (1:40) fixed bin int static; dcl type9_numeric_tct_ptr ptr internal static; dcl type9_alpha_tct (1:40) fixed bin int static; dcl type9_alpha_tct_ptr ptr internal static; dcl type9_opch_tct (1:40) fixed bin int static; dcl type9_opch_tct_ptr ptr int static; /* DECLARATION OF STATIC WORK BUFFERS */ dcl minus_type9 (1:40) fixed bin int static; /* Used to contain type 9 for minus sign */ dcl plus_type9 (1:40) fixed bin int static; /* Used to contain type 9 for plus sign */ /* DECLARATION OF INTERNAL STATIC VARIABLES USED AS "FIRST TIME" SWITCHES FOR THINGS TO BE DONE ONCE PER COMPILATION */ dcl zero_allocated fixed bin int static init (0); dcl ascii_to_ebcdic_table_allocated fixed bin int static init (0); dcl numeric_tct_table_allocated fixed bin int static init (0); dcl alpha_tct_table_allocated fixed bin int static init (0); dcl opch_tct_table_allocated fixed bin int static init (0); /* DEFINITION OF A TRANSLATION TABLE THAT CONTAINS ZERO FOR LOWER CASE ALPHABETICS, UPPER CASE ALPHABETICS, AND SPACE. */ dcl alpha_tct_table (0:511) bit (9) int static init ( /* | 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 |*/ /*----------------------------------------------------------------------------------------*/ /* 00 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 01 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 02 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 03 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 04 */ "0"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 05 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 06 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 07 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 10 */ "1"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, /* 11 */ "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, /* 12 */ "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, /* 13 */ "0"b, "0"b, "0"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 14 */ "1"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, /* 15 */ "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, /* 16 */ "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, /* 17 */ "0"b, "0"b, "0"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 20 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 21 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 22 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 23 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 24 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 25 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 26 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 27 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 30 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 31 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 32 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 33 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 34 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 35 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 36 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 37 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 40 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 41 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 42 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 43 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 44 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 45 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 46 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 47 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 50 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 51 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 52 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 53 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 54 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 55 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 56 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 57 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 60 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 61 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 62 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 63 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 64 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 65 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 66 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 67 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 70 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 71 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 72 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 73 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 74 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 75 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 76 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 77 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b); /* DEFINITION OF A TRANSLATION TABLE THAT CONTAINS ZERO FOR NUMERICS ONLY */ dcl numeric_tct_table (0:511) bit (9) int static init ( /* | 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 |*/ /*----------------------------------------------------------------------------------------*/ /* 00 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 01 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 02 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 03 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 04 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 05 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 06 */ "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, /* 07 */ "0"b, "0"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 10 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 11 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 12 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 13 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 14 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 15 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 16 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 17 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 20 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 21 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 22 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 23 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 24 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 25 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 26 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 27 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 30 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 31 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 32 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 33 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 34 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 35 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 36 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 37 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 40 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 41 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 42 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 43 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 44 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 45 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 46 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 47 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 50 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 51 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 52 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 53 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 54 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 55 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 56 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 57 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 60 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 61 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 62 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 63 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 64 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 65 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 66 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 67 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 70 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 71 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 72 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 73 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 74 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 75 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 76 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 77 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b); /* DEFINITION OF A TRANSLATION TABLE THAT CONTAINS ZERO FOR OVERPUNCH SIGN CHARACTERS ONLY */ dcl opch_tct_table (0:511) bit (9) int static init ( /* | 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 |*/ /*----------------------------------------------------------------------------------------*/ /* 00 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 01 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 02 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 03 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 04 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 05 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 06 */ "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, /* 07 */ "0"b, "0"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 10 */ "1"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, /* 11 */ "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, /* 12 */ "0"b, "0"b, "0"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 13 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 14 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 15 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 16 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 17 */ "1"b, "1"b, "1"b, "0"b, "1"b, "0"b, "1"b, "1"b, /* 20 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 21 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 22 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 23 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 24 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 25 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 26 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 27 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 30 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 31 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 32 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 33 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 34 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 35 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 36 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 37 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 40 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 41 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 42 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 43 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 44 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 45 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 46 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 47 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 50 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 51 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 52 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 53 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 54 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 55 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 56 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 57 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 60 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 61 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 62 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 63 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 64 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 65 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 66 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 67 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 70 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 71 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 72 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 73 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 74 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 75 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 76 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, /* 77 */ "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b); /* Static variables used for processing of separate sign for class condition */ dcl separate_signs_pooled fixed bin int static init (0); /* Declaration of an alphanumeric literal used to develop allocated constants for plus (+) and minus (-) in processing for class condition. */ dcl 1 separate_sign_literal int static, 2 size fixed bin (15) init (25), 2 line fixed bin (15) init (0), 2 column fixed bin (15) init (0), 2 type fixed bin (15) init (3), 2 lit_type bit (1) init ("0"b), 2 all_lit bit (1) init ("0"b), 2 filler1 bit (1), 2 lit_size fixed bin (15) init (1), 2 literal_string char (1); /* Definition of eis fill character */ dcl 1 eis_fill_def int static, 2 space char (1) init (" "), 2 zero char (1) init ("0"), 2 quote char (1) init (""""), 2 high_value char (1) init (""), /* INIT TO OCTAL 177. */ 2 low_value char (1) init (""); /* INIT TO OCTAL 000. */ /* DECLARATIONS OF VARIABLES USED IN BUILDING NON-EIS INSTRUCTIONS */ dcl non_eis_ptr ptr; dcl 1 non_eis_inst aligned based (non_eis_ptr), 2 y bit (18) unaligned, 2 op_code bit (9) unaligned, 2 zeroes bit (3) unaligned, 2 tm bit (2) unaligned, 2 td bit (4) unaligned; dcl non_eis_word bit (36); /* DECLARATIONS OF VARIABLES USED IN BUILDING EIS INSTRUCTIONS */ dcl eis_ptr ptr; dcl 1 eis_inst aligned based (eis_ptr), 2 unused bit (18) unaligned, 2 opcode bit (10) unaligned; /* DECLARATIONS OF WORK BUFFERS */ /* WORK BUFFER IN WHICH INPUT TO THE ADDRESSABILITY UTILITY IS BUILT */ dcl wkbuff1 (1:20) fixed bin; /* WORK BUFFER IN WHICH THE OUTPUT FROM THE ADDRESSABILITY UTILITY IS RETURNED */ dcl wkbuff2 (1:5) fixed bin; /* WORK BUFFER IN WHICH RELOCATION INFORMATION IS PLACED BY THE ADDRESSABILITY UTILITY */ dcl wkbuff3 (1:10) fixed bin; /* VARIABLES USED TO ACESS "end_stmt.i" as a bit string */ dcl i_ptr ptr; dcl 1 ibit based (i_ptr), 2 unused1 bit (1), 2 not bit (1), 2 abbreviated bit (1); /* OTHER WORK VARIABLES */ dcl save_locno fixed bin; dcl topcode bit (10); dcl descrip_ptr ptr; dcl in_op fixed bin; dcl descrip bit (72) based (descrip_ptr); dcl alpha_flag bit (1); dcl work_in_token_ptr ptr; dcl 1 work_in_token, 2 n fixed bin, 2 code fixed bin, 2 token_ptr (1:3) ptr; dcl work_in_token1_ptr ptr; dcl 1 work_in_token1, 2 n fixed bin, 2 code fixed bin, 2 token_ptr (1:3) ptr; dcl sort_prog_coll_seq_ptr ptr; dcl dn_ptr ptr; dcl sort_pcs_ptr ptr; /**************************************************/ /* START OF EXECUTION */ /* cobol_compare_gen */ /**************************************************/ start: /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(ccg);/**/ /* Initialization of pointers used in addressability utility */ input_ptr = addr (wkbuff1 (1)); inst_ptr = addr (wkbuff2 (1)); reloc_ptr = addr (wkbuff3 (1)); eos_ptr = in_token.token_ptr (in_token.n); /* Point at EOS in input structure */ if sort_pcs_ptr ^= null () then do; alpha_name_ptr = sort_pcs_ptr; alpha_flag = "1"b; end; else if cobol_$main_pcs_ptr ^= null () then do; alpha_name_ptr = cobol_$main_pcs_ptr; alpha_flag = "1"b; end; else alpha_flag = "0"b; if end_stmt.e = uncond_branch then call ubranch; else if (end_stmt.e = rwkey_numeric | end_stmt.e = rwkey_alphabetic) then call class_condition; else if (end_stmt.e = rwkey_positive | end_stmt.e = rwkey_negative | end_stmt.e = rwkey_zero) then call sign_condition; else call relational_compare; /* assume relational compare */ /***..... if Trace_Bit then call cobol_gen_driver_$Tr_End(ccg);/**/ return; /*{*/ ubranch: proc; /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(ub);/**/ /* This internal procedure generates code for an unconditional branch. */ /*}*/ start_ubranch: /* Zero the instruction to be emitted */ non_eis_word = "0"b; non_eis_ptr = addr (non_eis_word); /* Set op code to unconditional transfer */ non_eis_inst.op_code = tra_op; /* Save the offset in the text section at which the instruction is to be emitted */ save_locno = cobol_$text_wd_off; /* Build the relocation bytes */ reloc_struc (1) = "0"b; reloc_struc (2) = "0"b; /* Emit the instruction */ call cobol_emit (non_eis_ptr, reloc_ptr, 1); /* Issue a reference to the tag in "end_stmt.h" */ call cobol_make_tagref (fixed (end_stmt.h, 17), save_locno, null ()); exit_ubranch: /***..... if Trace_Bit then call cobol_gen_driver_$Tr_End(ub);/**/ return; end ubranch; /*{*/ sign_condition: proc; /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(sc);/**/ /* This internal procedure generates code for a Cobol sign condition. */ /*}*/ dcl out1_ptr ptr; start_sign_condition: /* Allocate a numeric constant of zero and make a type 9 for the constant, if it hasn't already been allocated during this compilation. */ if zero_allocated ^= cobol_$compile_count then do; /* Allocate numeric zero */ /* Point at buffer in which type 9 for zero is to be built */ type9_zero_ptr = addr (type9_zero (1)); call cobol_make_type9$type2_3 (type9_zero_ptr, addr (numeric_zero)); zero_allocated = cobol_$compile_count; end; /* Allocate the numeric zero; */ /* Establish addressability to the operand to be compared to zero, and the operand for numeric zero */ /* Build the input structure to the addressability utility. */ /* Base dataname token template on the operand */ dn_ptr = in_token.token_ptr (in_token.n - 1); if (data_name.type = rtc_dataname & (data_name.bin_18 | data_name.bin_36)) /* fixed binary data type */ | (data_name.type = rtc_dataname & data_name.item_signed & ^data_name.sign_separate) /* overpunch sign */ then do; /* Operand must be converted to decimal */ out1_ptr = null (); call convert_to_dec (dn_ptr, out1_ptr); dn_ptr = out1_ptr; end; /* Operand must be converted to decimal */ input_struc.type = 5; /* eis, 2 operands */ input_struc.operand_no = 2; input_struc.lock = 0; /* no locks requested */ input_struc.token_ptr (1) = dn_ptr; input_struc.size_sw (1) = 0; input_struc.send_receive (1) = 0; input_struc.token_ptr (2) = type9_zero_ptr; input_struc.send_receive (2) = 0; input_struc.size_sw (2) = 0; /* Call the addressability utility */ call cobol_addr (input_ptr, inst_ptr, reloc_ptr); /* Insert the CMPN opcode into the instruction just built */ eis_ptr = inst_ptr; eis_inst.opcode = cmpn_op; /* Emit the CMPN instruction */ call cobol_emit (eis_ptr, reloc_ptr, 3); /* Determine the type of transfer instruction to be generated */ i_ptr = addr (end_stmt.i); if end_stmt.e = rwkey_positive then do; /* POSITIVE OR NOT POSITIVE */ if ibit.not then topcode = tpl_op; /* NOT POSITIVE */ else topcode = tmi_op; /* POSITIVE */ end; /* POSITIVE OR NOT POSITIVE */ else if end_stmt.e = rwkey_negative then do; /* NEGATIVE OR NOT NEGATIVE */ if ibit.not then topcode = tmoz_op; /* NOT NEGATIVE */ else topcode = tpnz_op; /* NEGATIVE */ end; /* NEGATIVE OR NOT NEGATIVE */ else do; /* ASSUME ZERO OR NOT ZERO */ if ibit.not then topcode = tnz_op; /* NOT ZERO */ else topcode = tze_op; /* ZERO */ end; /* ASSUME ZERO OR NOT ZERO */ /* Build the transfer instruction */ non_eis_word = "0"b; non_eis_ptr = addr (non_eis_word); /* Set the op_code */ non_eis_ptr -> eis_inst.opcode = topcode; /* Save the offset in the text section at which the transfer is to be emitted */ save_locno = cobol_$text_wd_off; /* build the relocation bytes */ reloc_struc (1) = "0"b; reloc_struc (2) = "0"b; /* Emit the transfer instruction */ call cobol_emit (addr (non_eis_inst), reloc_ptr, 1); /* Issue a reference to the tag in "end_stmt.h" */ call cobol_make_tagref (fixed (end_stmt.h, 17), save_locno, null ()); exit_sign_condition: /***..... if Trace_Bit then call cobol_gen_driver_$Tr_End(sc);/**/ return; end sign_condition; /*{*/ relational_compare: proc; /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(rc);/**/ /* This internal procedure generates code for a relational comparison. */ /*}*/ dcl continue bit (1); dcl both_numeric bit (1); dcl lop_ptr ptr; dcl rop_ptr ptr; dcl saved_lop_ptr int static ptr; /*************************************************/ /* START OF EXECUTION */ /* relational_comparison */ /**************************************************/ start_relational_compare: eos_ptr = in_token.token_ptr (in_token.n); /* Determine whether the current compare is abbreviated or not */ i_ptr = addr (end_stmt.i); if ^ibit.abbreviated then do; /* Not an abbreviated compare */ lop_ptr = in_token.token_ptr (in_token.n - 2); /* Get left operand pointer */ saved_lop_ptr = lop_ptr; /* Save left operand pointer for use if next compare is abbreviated */ end; /* Not an abbreviated compare */ else lop_ptr = saved_lop_ptr; /* An abbreviated compare. Use the saved lop pointer. */ rop_ptr = in_token.token_ptr (in_token.n - 1); /* Determine whether the compare is numeric or alphanumeric */ both_numeric = "0"b; continue = "1"b; rw_ptr = lop_ptr; /* Check left operand first */ do while (continue); /* Check to see if both operands are numeric */ if (reserved_word.type = rtc_indexname | reserved_word.type = rtc_numlit /* numeric literal */ | (reserved_word.type = rtc_resword & reserved_word.key = rwkey_zero) /* ZERO */ | (reserved_word.type = rtc_dataname & (rw_ptr -> data_name.numeric | rw_ptr -> data_name.usage_index)) /* numeric type 9 or usage index */) then do; /* The current operand is numeric */ if rw_ptr = rop_ptr then do; /* Current operand is right operand, so both are numeric */ continue = "0"b; /* To exit from the loop */ both_numeric = "1"b; /* Both operands are numeric */ end; /* Current operand is right operand, so both are numeric */ else rw_ptr = rop_ptr; /* Must now check right operand */ end; /* The current operand is numeric */ else continue = "0"b; /* The current operand is not numeric */ end; /* Check to see if both operands are numeric */ if both_numeric then call numeric_compare (lop_ptr, rop_ptr); else call alpha_compare (lop_ptr, rop_ptr); exit_relational_compare: /***..... if Trace_Bit then call cobol_gen_driver_$Tr_End(rc);/**/ return; end relational_compare; /*{*/ numeric_compare: proc (lop_ptr, rop_ptr); /* This procedure generates code for a numeric relational comparison. */ /* DECLARATIONS OF THE PARAMETERS */ /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(nc);/**/ dcl lop_ptr ptr; dcl rop_ptr ptr; /* lop_ptr Points to the left operand of a numeric compare. (input) rop_ptr Points to the right operand of a numeric comparison. (input) */ /*}*/ dcl buff1 (1:40) fixed bin; dcl buff2 (1:40) fixed bin; dcl temp_lop_ptr ptr; dcl temp_buff char (150); dcl temp_rop_ptr ptr; dcl out1_ptr ptr; dcl out2_ptr ptr; dcl equal_flag fixed bin, less_flag fixed bin, greater_flag fixed bin; dcl 1 move_bin_18 static, 2 n fixed bin init (4), 2 code fixed bin init (0), 2 pt1 ptr init (null), 2 pt2 ptr, 2 pt3 ptr, 2 pt4 ptr; dcl 1 bin_36_rop 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 ("000000100100001001000000000000000000"b), 3 flags2 bit (36) init (""b), 3 seg fixed bin init (1000), 3 offset fixed bin, 2 fill2 (7) fixed bin init (0, 0, 0, 0, 0, 0, 0); dcl 1 bin_36_lop 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 ("000000100100001001000000000000000000"b), 3 flags2 bit (36) init (""b), 3 seg fixed bin init (1000), 3 offset fixed bin, 2 fill2 (7) fixed bin init (0, 0, 0, 0, 0, 0, 0); dcl 1 bin_18_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 ("000000100100010001000000000000000000"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 bin_18_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); /**************************************************/ /* START OF EXECUTION */ /* numeric_compare */ /**************************************************/ start_numeric_compare: /* Set pointers to the work buffers into which operands may be built by convert_to_dec procedure. */ out1_ptr = addr (buff1 (1)); out2_ptr = addr (buff2 (1)); less_flag = 0; greater_flag = 0; equal_flag = 2; if rop_ptr -> data_name.type = 10 | rop_ptr -> data_name.type = 2 | (rop_ptr -> data_name.type = 9 & (rop_ptr -> data_name.bin_36 | (rop_ptr -> data_name.bin_18 & ^rop_ptr -> data_name.subscripted))) then do; if lop_ptr -> data_name.type = 10 | lop_ptr -> data_name.type = 2 | (lop_ptr -> data_name.type = 9 & (lop_ptr -> data_name.bin_36 | (lop_ptr -> data_name.bin_18 & ^lop_ptr -> data_name.subscripted))) then do; if lop_ptr -> data_name.type = 10 then do; temp_lop_ptr = addr (bin_36_lop); bin_36_lop.seg = lop_ptr -> index_name.seg_num; bin_36_lop.offset = lop_ptr -> index_name.offset + 4; lop_ptr = temp_lop_ptr; end; if rop_ptr -> data_name.type = 10 then do; temp_rop_ptr = addr (bin_36_rop); bin_36_rop.seg = rop_ptr -> index_name.seg_num; bin_36_rop.offset = rop_ptr -> index_name.offset + 4; rop_ptr = temp_rop_ptr; end; if end_stmt.e = rwkey_greater then end_stmt.e = rwkey_less; else if end_stmt.e = rwkey_less then end_stmt.e = rwkey_greater; if lop_ptr -> data_name.type = 2 | rop_ptr -> data_name.type = 2 then do; call num_lit_comp (lop_ptr, rop_ptr, equal_flag, less_flag, greater_flag); goto tra_label; end; if rop_ptr -> data_name.bin_18 then do; if (substr (unspec (rop_ptr -> data_name.offset), 35, 2) = "10"b) & (lop_ptr -> data_name.bin_18 & substr (unspec (lop_ptr -> data_name.offset), 35, 2) = "10"b) then do; call cobol_alloc$stack (4, 0, bin_18_type9.off); move_bin_18.pt2 = rop_ptr; move_bin_18.pt3 = addr (bin_18_type9); move_bin_18.pt4 = addr (bin_18_type19); call cobol_move_gen (addr (move_bin_18)); call comp6_proc (lop_ptr, addr (bin_18_type9)); goto tra_label; end; else if substr (unspec (rop_ptr -> data_name.offset), 35, 2) = "10"b | (substr (unspec (rop_ptr -> data_name.offset), 35, 2) = "00"b & lop_ptr -> data_name.bin_36) then do; temp_lop_ptr = lop_ptr; lop_ptr = rop_ptr; rop_ptr = temp_lop_ptr; if end_stmt.e = rwkey_greater then end_stmt.e = rwkey_less; else if end_stmt.e = rwkey_less then end_stmt.e = rwkey_greater; end; end; call comp6_proc (lop_ptr, rop_ptr); goto tra_label; end; end; /* Base dataname token template on the left operand */ dn_ptr = lop_ptr; if data_name.type ^= rtc_dataname /* Must be a literal or fig. const. ZERO or index anme */ | (data_name.type = rtc_dataname & data_name.usage_index) /* usage index item */ | (data_name.type = rtc_dataname & (data_name.bin_18 | data_name.bin_36)) /* fixed binary data type */ | (data_name.type = rtc_dataname & data_name.item_signed & ^data_name.sign_separate) /* overpunch sign */ then do; /* Left operand must be converted to decimal */ call convert_to_dec (lop_ptr, out1_ptr); lop_ptr = out1_ptr; end; /* Left operand must be converted to decimal */ /* Base dataname template on the right operand */ dn_ptr = rop_ptr; if data_name.type ^= rtc_dataname /* Must be a literal or fig. const. ZERO or index anme */ | (data_name.type = rtc_dataname & data_name.usage_index) /* usage index item */ | (data_name.type = rtc_dataname & (data_name.bin_18 | data_name.bin_36)) /* fixed binary data type */ | (data_name.type = rtc_dataname & data_name.item_signed & ^data_name.sign_separate) /* overpunch sign */ then do; /* Right operand must be converted to decimal */ call convert_to_dec (rop_ptr, out2_ptr); rop_ptr = out2_ptr; end; /* Right operand must be converted to decimal */ /* Build the input structure to the addressability utility */ input_struc.type = 5; /* eis, 2 operands */ input_struc.operand_no = 2; input_struc.lock = 0; input_struc.token_ptr (1) = lop_ptr; input_struc.send_receive (1) = 0; input_struc.size_sw (1) = 0; input_struc.token_ptr (2) = rop_ptr; input_struc.send_receive (2) = 0; input_struc.size_sw (2) = 0; /* Call the addressability utility */ call cobol_addr (input_ptr, inst_ptr, reloc_ptr); /* Insert the cmpn opcode into the instruction just built */ eis_ptr = inst_ptr; eis_inst.opcode = cmpn_op; /* Emit the cmpn instruction */ call cobol_emit (eis_ptr, reloc_ptr, 3); tra_label: /* Determine the type of transfer instruction to be generated */ i_ptr = addr (end_stmt.i); if equal_flag = 0 | (less_flag = 1 & end_stmt.e = rwkey_greater) | (greater_flag = 1 & end_stmt.e = rwkey_less) then topcode = tra_op; else if equal_flag = 1 | (less_flag = 1 & end_stmt.e = rwkey_less) | (greater_flag = 1 & end_stmt.e = rwkey_greater) then topcode = nop_op; else if end_stmt.e = rwkey_greater then do; /* GREATER OR NOT GREATER */ if ibit.not then topcode = tpl_op; /* not greater */ else topcode = tmi_op; /* GREATER */ end; /* GREATER OR NOT GREATER */ else if end_stmt.e = rwkey_less then do; /* LESS OR NOT LESS */ if ibit.not then topcode = tmoz_op; /* NOT LESS */ else topcode = tpnz_op; /* LESS */ end; /* LESS OR NOT LESS */ else if end_stmt.e = rwkey_equal then do; /* EQUAL OR NOT EQUAL */ if ibit.not then topcode = tnz_op; /* NOT EQUAL */ else topcode = tze_op; /* EQUAL */ end; /* EQUAL OR NOT EQUAL */ else do; /* ASSUME UNEQUAL */ if ibit.not then topcode = tze_op; /* NOT UNEQUAL (EQUAL) */ else topcode = tnz_op; /* UNEQUAL */ end; /* ASSUME UNEQUAL */ /* Build the transfer instruction */ non_eis_word = "0"b; /* Zero the instruction word */ non_eis_ptr = addr (non_eis_word); non_eis_ptr -> eis_inst.opcode = topcode; /* Save the offset in the text section at which the transfer is to be inserted */ save_locno = cobol_$text_wd_off; /* Build the relocation bytes */ reloc_struc (1) = "0"b; reloc_struc (2) = "0"b; /* Emit the transfer instruction */ call cobol_emit (non_eis_ptr, reloc_ptr, 1); /* Issue a reference to the tag in "end_stmt.h" */ call cobol_make_tagref (fixed (end_stmt.h, 17), save_locno, null ()); exit_numeric_compare: /***..... if Trace_Bit then call cobol_gen_driver_$Tr_End(nc);/**/ return; end numeric_compare; /*{*/ convert_to_dec: proc (input_op_ptr, output_op_ptr); /* This procedure converts a non_numeric operand to a numeric operand. For the Release 1.5 of Multics Cobol, only the following operands are converted: 1. Numeric literal (type 2 token) 2. Figurative constant ZERO (type 1 token, reserved word key = 180 ) 3. Index name (type 10 token) 4. Index data item (type 9 token, usage index bit on) 5. Fixed binary data items (type 9 tokens, bin_18 or bin_36 bits on) 6. Overpunch sign data (type 9 token, sign_separate off item_signed on) */ /* DECLARATION OF THE PARAMETERS */ dcl input_op_ptr ptr; dcl output_op_ptr ptr; /* input_op_ptr Points to the operand for which a numeric operand (type 9) is to be constructed. (input) output_op_ptr Points to a buffer in which the numeric operand (type 9) is constructed. (input) If input_op_ptr points to the figurative constant ZERO, then output_op_ptr will point to a numeric operand (type 9) created for zero on output. The type 9 will not be moved to the buffer supplied by the user. */ /*}*/ dcl descrip_ptr ptr; dcl descrip bit (72) based (descrip_ptr); /**************************************************/ /* START OF EXECUTION */ /* convert_to_dec */ /**************************************************/ start_convert_to_dec: dn_ptr = input_op_ptr; /* Base dataname template on the input operand image */ if data_name.type = rtc_numlit /* Numeric literal */ then call cobol_make_type9$type2_3 (output_op_ptr, input_op_ptr); else if data_name.type = rtc_resword then do; /* ASSUME ZERO */ if zero_allocated ^= cobol_$compile_count then do; /* Allocate numeric zero */ type9_zero_ptr = addr (type9_zero (1)); call cobol_make_type9$type2_3 (type9_zero_ptr, addr (numeric_zero)); zero_allocated = cobol_$compile_count; end; /* Allocate numeric zero */ output_op_ptr = type9_zero_ptr; end; /* ASSUME ZERO */ else if (data_name.type = rtc_indexname | data_name.usage_index) then call cobol_get_index_value (2, input_op_ptr, output_op_ptr); /* Assume an index name */ else /* Assume fixed binary data item or overpunch sign data item. */ call cobol_num_to_udts (input_op_ptr, output_op_ptr); exit_convert_to_dec: return; end convert_to_dec; /* ******************** */ comp6_proc: proc (lop_ptr, rop_ptr); /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(c6);/**/ /* This procedure is used to generate non-eis instructions for the comparison of comp-6 and/or comp-7 data. */ /* load long or short bin */ dcl lop_ptr ptr, rop_ptr ptr; /* eaa 0,xn ars 18 */ dcl eaa_buff (2) bit (36) static init ("000000000000000000110011101000000000"b, "000000000000010010111011001000000000"b); dcl inst_code fixed bin static init (1); dcl inst_op (5) bit (10) static init ("0100111010"b, /* lda */ "0100100000"b, /* ldxn*/ "1110100000"b, /* lxln*/ "0010011010"b, /* cmpa */ "0010000000"b); /* cmpx */ /* 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_comp6_proc: input_struc.type = 2; input_struc.operand_no = 1; input_struc.lock = 0; input_struc.token_ptr (1) = lop_ptr; input_struc.size_sw (1) = 0; if lop_ptr -> data_name.bin_36 then do; reg_struc.what_reg = 1; inst_code = 1; end; else do; reg_struc.what_reg = 14; if substr (unspec (lop_ptr -> data_name.offset), 35, 2) = "10"b then inst_code = 3; else inst_code = 2; end; call cobol_addr (input_ptr, inst_ptr, reloc_ptr); call cobol_register$load (addr (reg_struc)); inst_struc.fill1_op = inst_op (inst_code); if inst_code ^= 1 then substr (inst_struc.fill1_op, 7, 3) = substr (reg_struc.reg_num, 2, 3); call cobol_emit (inst_ptr, reloc_ptr, 1); input_struc.type = 2; input_struc.operand_no = 1; input_struc.lock = 0; input_struc.token_ptr (1) = rop_ptr; input_struc.size_sw (1) = 0; if rop_ptr -> data_name.bin_36 then do; if inst_code ^= 1 then do; substr (eaa_buff (1), 33, 4) = reg_struc.reg_num; call cobol_emit (addr (eaa_buff (1)), null, 2); end; inst_code = 4; end; else inst_code = 5; inst_struc.fill1_op = inst_op (inst_code); if inst_code ^= 4 then substr (inst_struc.fill1_op, 7, 3) = substr (reg_struc.reg_num, 2, 3); call cobol_addr (input_ptr, inst_ptr, reloc_ptr); call cobol_emit (inst_ptr, reloc_ptr, 1); call cobol_register$release (addr (reg_struc)); exit_comp6_proc: /***..... if Trace_Bit then call cobol_gen_driver_$Tr_End(c6);/**/ return; end comp6_proc; num_lit_comp: proc (lop_ptr, rop_ptr, equal_flag, less_flag, greater_flag); /* This procedure is used to set the comparison for numerical literal in one or both operands. */ dcl lop_ptr ptr, rop_ptr ptr, temp_lop_ptr ptr, temp_token_ptr ptr, temp fixed bin, in_op fixed bin, l_win fixed bin, ic_flag fixed bin, nonzero_pr fixed bin, (i, j, k) fixed bin; dcl (equal_flag, less_flag, greater_flag) fixed bin; dcl bin_36_buff char (120); dcl inst_code fixed bin static init (1); dcl inst_op (4) bit (10) static init ("0100111010"b, /* lda */ "0100100000"b, /* ldxn*/ "1110100000"b, /* lxln*/ "0010011010"b); /* cmpa */ dcl compare_inst (2) bit (36) static init ("000000000000000000001001101000000111"b, /* cmpa n,dl */ "000000000000000000001000000000000011"b); /* cmpxn n,du */ /* 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); /* DECLARATION OF INTERNAL STATIC DATA */ dcl smallest_long_binary fixed dec (11, 0) init (-32359738368); dcl largest_long_binary fixed dec (11, 0) init (32359738357); 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 ZERO char (32) static init ((32)"0"); /* DECLARATION OF INTERNAL VARIABLES */ dcl work_fdec fixed dec (19, 0); dcl work_fdec_string char (20) based (work_fdec_ptr); dcl work_fdec_ptr ptr; dcl (LP, RP) ptr; dcl (LS, RS, LPL, RPL, SI, SO, SF) fixed bin; dcl ret_offset fixed bin; dcl long_bin_const fixed bin (35); dcl long_bin_ptr ptr; dcl long_bin_string char (4) based (long_bin_ptr); start_num_lit_comp: ic_flag = 0; greater_flag = 0; less_flag = 0; equal_flag = 2; if lop_ptr -> data_name.type = 2 then do; temp_lop_ptr = lop_ptr; lop_ptr = rop_ptr; rop_ptr = temp_lop_ptr; if end_stmt.e = rwkey_greater then end_stmt.e = rwkey_less; else if end_stmt.e = rwkey_less then end_stmt.e = rwkey_greater; if lop_ptr -> data_name.type = 2 then do; /*[4.2-2]*/ equal_flag = 0; if lop_ptr -> numeric_lit.sign = "-" | rop_ptr -> numeric_lit.sign = "-" then if lop_ptr -> numeric_lit.sign ^= rop_ptr -> numeric_lit.sign then do; /*[4.2-2]*/ equal_flag = 1; return; end; /*[4.2-2]*/ if lop_ptr -> numeric_lit.places_left >= rop_ptr -> numeric_lit.places_left /*[4.2-2]*/ then do; LP = lop_ptr; /* L precedes R */ /*[4.2-2]*/ RP = rop_ptr; /*[4.2-2]*/ end; /*[4.2-2]*/ else do; LP = rop_ptr; /*[4.2-2]*/ RP = lop_ptr; /*[4.2-2]*/ end; /*[4.2-2]*/ LS = LP -> numeric_lit.places;/* L size */ /*[4.2-2]*/ RS = RP -> numeric_lit.places;/* R size */ /*[4.2-2]*/ LPL = LP -> numeric_lit.places_left; /* L places left */ /*[4.2-2]*/ RPL = RP -> numeric_lit.places_left; /* R places left */ /*[4.2-2]*/ SI = LPL - RPL; /* initial size */ /*[4.2-2]*/ if SI ^= 0 /*[4.2-2]*/ then if substr (LP -> numeric_lit.literal, 1, SI) ^= ZERO /*[4.2-2]*/ then do; equal_flag = 1;/* initial string ^= 0 */ /*[4.2-2]*/ return; /*[4.2-2]*/ end; /*[4.2-2]*/ SO = min (LS - SI, RS); /* overlap size */ /*[4.2-2]*/ if SO = 0 /*[4.2-2]*/ then if substr (RP -> numeric_lit.literal, 1, RS) ^= ZERO /*[4.2-2]*/ then do; equal_flag = 1;/* final string ^= 0 */ /*[4.2-2]*/ return; /*[4.2-2]*/ end; /*[4.2-2]*/ else return; /* no overlap, both 0 */ /*[4.2-2]*/ if substr (LP -> numeric_lit.literal, SI + 1, SO) ^= substr (RP -> numeric_lit.literal, 1, SO) /*[4.2-2]*/ then do; equal_flag = 1; /* overlapping strings not equal */ /*[4.2-2]*/ return; /*[4.2-2]*/ end; /*[4.2-2]*/ if SO = RS /*[4.2-2]*/ then if SI + SO = LS /* L extends beyond R */ /*[4.2-2]*/ then return; /*[4.2-2]*/ else if substr (LP -> numeric_lit.literal, SI + SO + 1, LS - SI - SO) ^= ZERO /*[4.2-2]*/ then do; equal_flag = 1;/* final string ^= 0 */ /*[4.2-2]*/ return; /*[4.2-2]*/ end; /*[4.2-2]*/ else return; /*[4.2-2]*/ else if substr (RP -> numeric_lit.literal, SO + 1, RS - SO) ^= ZERO /*[4.2-2]*/ then do; equal_flag = 1; /* final string ^= 0 */ /*[4.2-2]*/ return; /*[4.2-2]*/ end; /*[4.2-2]*/ else return; end; end; nonzero_pr = 0; if rop_ptr -> numeric_lit.places_right ^= 0 then do k = 1 to rop_ptr -> numeric_lit.places_right while (nonzero_pr = 0); /*[4.2-2]*/ if substr (rop_ptr -> numeric_lit.literal, k + rop_ptr -> numeric_lit.places_left, 1) ^= "0" then nonzero_pr = 1; end; work_fdec = 0; work_fdec_ptr = addr (work_fdec); if rop_ptr -> numeric_lit.sign = "-" then substr (work_fdec_string, 1, 1) = "-"; else substr (work_fdec_string, 1, 1) = "+"; substr (work_fdec_string, 21 - rop_ptr -> numeric_lit.places_left, rop_ptr -> numeric_lit.places_left) = substr (rop_ptr -> numeric_lit.literal, 1, rop_ptr -> numeric_lit.places_left); if nonzero_pr = 1 then do; if end_stmt.e = rwkey_equal then do; if ibit.not then equal_flag = 1; else equal_flag = 0; return; end; if ibit.not then do; ibit.not = "0"b; if end_stmt.e = rwkey_greater then end_stmt.e = rwkey_less; else end_stmt.e = rwkey_greater; end; if end_stmt.e = rwkey_greater then if rop_ptr -> numeric_lit.sign = "-" then work_fdec = work_fdec - 1; else work_fdec = work_fdec + 1; end; if lop_ptr -> data_name.bin_36 then do; if work_fdec > largest_long_binary then less_flag = 1; else if work_fdec < smallest_long_binary then greater_flag = 1; /*[4.2-1]*/ else if work_fdec > largest_short_binary | substr (work_fdec_string, 1, 1) = "-" then ic_flag = 1; end; else do; if work_fdec > largest_short_binary then less_flag = 1; else if work_fdec < smallest_short_binary then greater_flag = 1; end; if less_flag = 1 | greater_flag = 1 then return; long_bin_const = binary (work_fdec); input_struc.type = 2; input_struc.operand_no = 1; input_struc.lock = 0; input_struc.token_ptr (1) = lop_ptr; input_struc.size_sw (1) = 0; if lop_ptr -> data_name.bin_36 then do; reg_struc.what_reg = 1; inst_code = 1; end; else do; reg_struc.what_reg = 14; if substr (unspec (lop_ptr -> data_name.offset), 35, 2) = "10"b then inst_code = 3; else inst_code = 2; end; call cobol_addr (input_ptr, inst_ptr, reloc_ptr); call cobol_register$load (addr (reg_struc)); inst_struc.fill1_op = inst_op (inst_code); if inst_code ^= 1 then substr (inst_struc.fill1_op, 7, 3) = substr (reg_struc.reg_num, 2, 3); call cobol_emit (inst_ptr, reloc_ptr, 1); if ic_flag = 1 then do; long_bin_ptr = addr (long_bin_const); call cobol_pool$search_op (long_bin_string, 0, ret_offset, in_op); if in_op = 1 then temp = 3; else temp = 3000; temp_token_ptr = addr (bin_36_buff); call cobol_make_type9$long_bin (temp_token_ptr, temp, ret_offset); input_struc.type = 2; input_struc.operand_no = 1; input_struc.lock = 0; input_struc.token_ptr (1) = temp_token_ptr; input_struc.size_sw (1) = 0; call cobol_addr (input_ptr, inst_ptr, reloc_ptr); inst_struc.fill1_op = inst_op (4); call cobol_emit (inst_ptr, reloc_ptr, 1); end; else do; if inst_code ^= 1 then do; inst_code = 2; substr (compare_inst (inst_code), 25, 3) = substr (reg_struc.reg_num, 2, 3); end; substr (compare_inst (inst_code), 1, 18) = substr (unspec (long_bin_const), 19, 18); call cobol_emit (addr (compare_inst (inst_code)), null, 1); end; call cobol_register$release (addr (reg_struc)); return; exit_num_lit_comp: return; end num_lit_comp; /*{*/ alpha_compare: proc (lop_ptr, rop_ptr); /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(ac);/**/ /* This procedure generates code for an alphanumeric comparison. */ /* DECLARATION OF THE PARAMETERS */ dcl lop_ptr ptr; dcl rop_ptr ptr; /* lop_ptr Points to the left operand of the alphanumeric comparison. (input) rop_ptr Points to the right operand of the alphanumeric comparison. (input) */ /*}*/ /* Work buffers in which the convert_to_alpha procedure can build dataname (type 9) operands */ dcl wkbuff1 (1:40) fixed bin; dcl wkbuff2 (1:40) fixed bin; dcl wkbuff1_ptr ptr; dcl wkbuff2_ptr ptr; /* Work buffers in which dataname (type 9) operands are built if code is to be generated to convert from ASCII to EBCDIC */ dcl wkbuff3 (1:40) fixed bin; dcl wkbuff4 (1:40) fixed bin; dcl wkbuff3_ptr ptr; dcl wkbuff4_ptr ptr; /* Variables in which the CMPC filler character and filler hierarchy are saved. */ dcl cmpc_filler char (1); dcl filler_hier fixed bin; /* Work variables */ dcl temp_cmpc_filler char (1); dcl temp_filler_hier fixed bin; dcl temp_op_ptr ptr; /**************************************************/ /* START OF EXECUTION */ /* alpha_compare */ /**************************************************/ start_alpha_compare: cmpc_filler = " "; filler_hier = 0; /* Check to see if the left operand needs conversion */ dn_ptr = lop_ptr; if (data_name.type ^= rtc_dataname | (^data_name.alphanum & ^data_name.alphanum_edited & ^data_name.numeric_edited /* NUMERIC EDITED IS ALPHANUMERIC!! */ & ^data_name.alphabetic & ^data_name.alphabetic_edited)) then do; /* Left operand needs conversion to alphanumeric data name */ wkbuff1_ptr = addr (wkbuff1 (1)); call convert_to_alpha (lop_ptr, rop_ptr, wkbuff1_ptr, temp_cmpc_filler, temp_filler_hier); lop_ptr = wkbuff1_ptr; if temp_filler_hier > filler_hier then do; /* Filler character returned must be used in the cmpc instruction */ cmpc_filler = temp_cmpc_filler; filler_hier = temp_filler_hier; end; /* Filler character returned must be used in the cmpc instruction */ end; /* Left operand needs conversson to alphanumeric data name */ /* Check to see if the right operand needs conversion */ dn_ptr = rop_ptr; if (data_name.type ^= rtc_dataname | (^data_name.alphanum & ^data_name.alphanum_edited & ^data_name.numeric_edited /* NUMERIC EDITED IS ALPHANUMERIC!! */ & ^data_name.alphabetic & ^data_name.alphabetic_edited)) then do; /* Right operand needs conversion to alphanumeric data name */ wkbuff2_ptr = addr (wkbuff2 (1)); call convert_to_alpha (rop_ptr, lop_ptr, wkbuff2_ptr, temp_cmpc_filler, temp_filler_hier); rop_ptr = wkbuff2_ptr; if temp_filler_hier > filler_hier then do; /* Filler character returned must be used in the cmpc instruction */ cmpc_filler = temp_cmpc_filler; filler_hier = temp_filler_hier; end; /* Filler character returned must be used in the cmpc instruction */ end; /* Right operand needs conversion to alphanumeric data name */ /* Determine the type of transfer instruction to be generated following the compare ( and reverse operands if necessary) */ /* Base EOS template on the EOS tokee */ eos_ptr = in_token.token_ptr (in_token.n); i_ptr = addr (end_stmt.i); if end_stmt.e = rwkey_greater then do; /* GREATER OR NOT GREATER */ /* REVERSE OPERANDS FOR THESE TWO RELATIONAL OPERATORS */ temp_op_ptr = lop_ptr; lop_ptr = rop_ptr; rop_ptr = temp_op_ptr; if ibit.not then topcode = trc_op; /* NOT GREATER */ else topcode = tnc_op; /* GREATER */ end; /* GREATER OR NOT GREATER */ else if end_stmt.e = rwkey_less then do; /* LESS OR NOT LESS */ if ibit.not then topcode = trc_op; /* NOT LESS */ else topcode = tnc_op; /* LESS */ end; /* LESS OR NOT LESS */ else if end_stmt.e = rwkey_equal then do; /* EQUAL OR NOT EQUAL */ if ibit.not then topcode = tnz_op; /* NOT EQUAL */ else topcode = tze_op; /* EQUAL */ end; /* EQUAL OR NOT EQUAL */ else do; /* ASSUME UNEQUAL */ if ibit.not then topcode = tze_op; /* NOT UNEQUAL (EQUAL) */ else topcode = tnz_op; /* UNEQUAL */ end; /* ASSUUME UNEQUAL */ /* HERE, TEST COLLATING SEQUENCE BY LOOKING AT FIXED COMMON, AND IF NECESSARY, GENERATE CODE TO CONVERT ASCII OPERANDS TO EBCDIE, PRIOR TO ESTABLISHINg addressability. also, THE FILLER CHAR MUST BE CONVERTED FROM ASCII TO EBCDIC. */ if cobol_$main_pcs_ptr ^= null () | sort_pcs_ptr ^= null () /* alphabet name */ then call cobol_trans_alphabet (lop_ptr, rop_ptr, 0, 0, sort_pcs_ptr, cmpc_filler); /* ESTABLISH ADDRESSABILITY TO THE TWO OPERANDS */ /* Build the input structure to the addressability utility */ input_struc.type = 5; /* eis, 2 operands */ input_struc.operand_no = 2; input_struc.lock = 0; /* no locks */ input_struc.token_ptr (1) = lop_ptr; input_struc.send_receive (1) = 0; input_struc.size_sw (1) = 0; input_struc.token_ptr (2) = rop_ptr; input_struc.send_receive (2) = 0; input_struc.size_sw (2) = 0; /* Call the addressabiliyt utility */ call cobol_addr (input_ptr, inst_ptr, reloc_ptr); /* Insert the cmpc opcode into the instruction */ eis_ptr = inst_ptr; eis_inst.opcode = cmpc_op; /* Insert the filler character into the instruction */ substr (eis_inst.unused, 1, 9) = unspec (cmpc_filler); /* Emit the cmpc instruction */ call cobol_emit (eis_ptr, reloc_ptr, 3); /* Build the transfer instruction */ non_eis_word = "0"b; non_eis_ptr = addr (non_eis_word); non_eis_ptr -> eis_inst.opcode = topcode; /* Save the offset in the text section at which the transfer is to be emitted */ save_locno = cobol_$text_wd_off; /* Build the relocation bytes */ reloc_struc (1) = "0"b; reloc_struc (2) = "0"b; /* Emit the transfer instruction */ call cobol_emit (non_eis_ptr, reloc_ptr, 1); /* Issue a reference to the tag in "end_stmt.h" */ call cobol_make_tagref (fixed (end_stmt.h, 17), save_locno, null ()); exit_alpha_compare: /***..... if Trace_Bit then call cobol_gen_driver_$Tr_End(ac);/**/ return; end alpha_compare; /*{*/ convert_to_alpha: proc (operand_ptr, other_operand_ptr, output_operand_ptr, eis_filler, filler_hier); /* This procedure converts an operand that is not an alphanumeric data name to an alphanumeric data name operand. For the first release of Multics Cobol, the following types of operands are converted: 1. alphanumeric literal (type 3 token) 2. figurative constants (type 1 token) 3. numeric literal (type 2 token) 4. numeric data name (type 9 token) 5. figurative constants of the form ALL "string" (type 3 token) */ /* DECLARATION OF THE PARAMETERS */ dcl operand_ptr ptr; dcl other_operand_ptr ptr; dcl output_operand_ptr ptr; dcl eis_filler char (1); dcl filler_hier fixed bin; /* operand_ptr Pointer to the operand to be converted. (input) other_operadn_ptr Pointer to the other operand (other than that pointed to by operand_ptr) in the alphanumeric compare. (input) output_operand_ptr Pointer to the user supplied buffer in which this procedure builds a token (type 9) for the output operand. (input) eis_filler One character that is to be inserted into the "fill" filed of the CMPC instruction. (output) filler_hier A code that indicates the "hierarchy" of the fill character returned by this procedurue. The hierarchy value is equal to 1 for the following input operands: a. Figurative constants ZERO, SPACE, QUOTE,HIGH-VALUE, and LOW-VALUE. b. Figurative constants of the form ALL "X". (i.e. only one character is specified in the literal string) The hierarchy value returned is 0 for all other input operands. */ /*}*/ /* Definition of input structure to the move generator */ dcl 1 move_token, 2 n fixed bin, 2 code fixed bin, 2 token_ptr (1:5) ptr; /* Temporary work buffers */ dcl eos_buff (1:10) fixed bin; dcl wkbuff1 (1:40) fixed bin; dcl alit_buffer (1:40) fixed bin; dcl temp_type9_token (1:40) fixed bin; /* Variables required to access the description bits of a data name token */ dcl descrip_ptr ptr; dcl descrip bit (72) based (descrip_ptr); /* Other work variables */ dcl s_length fixed bin; dcl s_offset fixed bin; dcl t_key fixed bin; dcl temp9_ptr ptr; dcl dn_buff (1:40) fixed bin based (output_operand_ptr); dcl ix fixed bin; dcl changed_descrip_bits bit (1); dcl save_dn_ptr ptr; /*************************************************/ /* START OF EXECUTION */ /* convert_to_alpha */ /**************************************************/ start_convert_to_alpha: dn_ptr = operand_ptr; eis_filler = eis_fill_def.space; filler_hier = 0; changed_descrip_bits = "0"b; if data_name.type = rtc_alphalit then do; /* Input operand is an alphanumeric literal */ alit_ptr = operand_ptr; if ^alphanum_lit.all_lit then call cobol_make_type9$type2_3 (output_operand_ptr, operand_ptr); /* Not al "ALL" literal */ else do; /* An "ALL" literal */ if alphanum_lit.lit_size = 1 then do; /* form is ALL "X" */ /* Build a data name token (type 9) */ call cobol_make_type9$type2_3 (output_operand_ptr, operand_ptr); /* Set the eis fill character */ eis_filler = alphanum_lit.string; filler_hier = 1; end; /* form is ALL "X" */ else do; /* form is ALL "XYZ..." */ /* Determine the length of the other operand in the comparison */ /* Here we assume that the other operand is a dataname (type 9), either numeric or alphanumeric. Must also handle index name (type 10) later */ s_length = other_operand_ptr -> data_name.item_length; if other_operand_ptr -> data_name.sign_separate then s_length = s_length - 1; /* Allocate space on the run-time stack equal to the length of the other operand */ call cobol_alloc$stack (s_length, 0, s_offset); /* Build a data name token that describes the stack entry just allocated */ dn_ptr = output_operand_ptr; /* Initialize the buffer to zeroes. */ do ix = 1 to 40; dn_buff (ix) = 0; end; data_name.seg_num = 1000; /* run-time stack */ data_name.offset = s_offset; data_name.type = rtc_dataname; descrip_ptr = addr (data_name.file_section); descrip = "0"b; data_name.elementary = "1"b; data_name.alphanum = "1"b; data_name.display = "1"b; data_name.item_length = s_length; data_name.places_left = s_length; data_name.places_right = 0; /* Generate code to move the figurative constant to the stack */ move_token.n = 4; move_token.token_ptr (1) = null (); move_token.token_ptr (2) = operand_ptr; /* Sending */ move_token.token_ptr (3) = output_operand_ptr; /* Receiving */ move_token.token_ptr (4) = addr (eos_buff (1)); move_token.token_ptr (4) -> end_stmt.verb = 18; /* MOVE */ move_token.token_ptr (4) -> end_stmt.e = 1; /* One operand to move. */ call cobol_move_gen (addr (move_token)); end; /* Form is ALL "XYZ..." */ end; /* AN "ALL" LITERAL */ end; /* Input operand is an alphanumeric literal */ else if (data_name.type = rtc_dataname | data_name.type = rtc_numlit | data_name.type = rtc_indexname) then do; /* Input operand is a dataname (type 9) or numeric literal (type 2) */ /* or index name (type 10) */ if data_name.type = rtc_numlit then do; /* A numeric literal */ /* Pool the literal and build a type 9 */ temp9_ptr = addr (wkbuff1 (1)); call cobol_make_type9$type2_3 (temp9_ptr, operand_ptr); operand_ptr = temp9_ptr; dn_ptr = temp9_ptr; end; /* a numeric literal */ if (data_name.type = rtc_dataname & data_name.usage_index) | data_name.type = rtc_indexname then do; /* index data item (type 9) token or index name (type 10) token */ /* Generate code to convert the index value from a 2 byte fixed bin to a decimal */ call cobol_get_index_value (2, operand_ptr, addr (temp_type9_token (1))); operand_ptr = addr (temp_type9_token (1)); s_length = 6; /* Maximum number of decimal digits. */ end; /* Index data item (type 9) token or index name (type 10) token */ if (data_name.type ^= rtc_indexname & data_name.sign_separate) then s_length = data_name.item_length - 1; else s_length = data_name.item_length; if data_name.bin_18 = "1"b then s_length = 6; else if data_name.bin_36 = "1"b then s_length = 11; else if data_name.ascii_packed_dec = "1"b then s_length = data_name.places_right + data_name.places_left; /* Allocate space in the run time stack to hold the alphanumeric representation of the numeric */ call cobol_alloc$stack (s_length, 0, s_offset); save_dn_ptr = dn_ptr; /* Build a dataname token for the space just allocated in the stack */ dn_ptr = output_operand_ptr; /* Zero the buffer in which data name token is built */ do ix = 1 to 40; dn_buff (ix) = 0; end; data_name.type = rtc_dataname; data_name.seg_num = 1000; /* Run time stack segment */ data_name.offset = s_offset; /* Offset returned by the allocate procedure */ descrip_ptr = addr (data_name.file_section); descrip = "0"b; data_name.alphanum = "1"b; data_name.display = "1"b; data_name.item_length = s_length; /* Build an EOS token for a MOVE */ eos_ptr = addr (eos_buff (1)); end_stmt.verb = 18; /* MOVE */ end_stmt.e = 1; /* One operand to move */ /* Build an input structure before calling the move generator */ move_token.n = 4; move_token.code = 0; move_token.token_ptr (1) = null (); move_token.token_ptr (2) = operand_ptr; /* Numeric data item */ move_token.token_ptr (3) = output_operand_ptr; /* Alphanumeric in the stack */ move_token.token_ptr (4) = eos_ptr; /* EOS token */ /* Call the move generator */ call cobol_move_gen (addr (move_token)); dn_ptr = save_dn_ptr; if changed_descrip_bits then do; /* Reset the description bits in the token of the operand being converted. */ data_name.numeric = "1"b; data_name.alphanum = "0"b; end; /* Reset the description bits in the token of the operand being comverted. */ end; /* INput operand is a dataname (type 9) or numeric literal (type2) */ else if data_name.type = rtc_resword then do; /* A reserved word, assume a figurative constant */ rw_ptr = dn_ptr; filler_hier = 1; t_key = reserved_word.key; if t_key = rwkey_zero then eis_filler = eis_fill_def.zero; /* ZERO */ else if t_key = rwkey_space then eis_filler = eis_fill_def.space; else if t_key = rwkey_quote then eis_filler = eis_fill_def.quote; else if alpha_flag then do; if t_key = rwkey_highval then eis_filler = alphabet_name.hival_char; else if t_key = rwkey_lowval then eis_filler = alphabet_name.loval_char; end; else do; if t_key = rwkey_highval then eis_filler = eis_fill_def.high_value; else if t_key = rwkey_lowval then eis_filler = eis_fill_def.low_value; end; /* Build an alphanumeric literal token for the figurative constant */ alit_ptr = addr (alit_buffer (1)); alphanum_lit.size = 25; alphanum_lit.line = 0; alphanum_lit.column = 0; alphanum_lit.type = rtc_alphalit; alphanum_lit.lit_type = "0"b; /* Character string */ alphanum_lit.all_lit = "0"b; alphanum_lit.lit_size = 1; alphanum_lit.string = eis_filler; /* Pool the alphanumeric literal, and build a data name token */ call cobol_make_type9$type2_3 (output_operand_ptr, alit_ptr); end; /* A reserved word assume a figurative constant */ exit_convert_to_alpha: return; end convert_to_alpha; /*{*/ class_condition: proc; /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(cc);/**/ /* This procedure generates code for the Cobol class condition. */ /*}*/ /* Buffer in which a data name token for separate sign operand is built */ dcl sep_sign_type9 (1:40) fixed bin; dcl sep_sign_ptr ptr; dcl separate_sign_processing_flag bit (1); /* Buffer in which a data name token for the TCT summary word (descriptor 3) is built. */ dcl summary_buff (1:40) fixed bin; dcl summary_op_ptr ptr; /* Other work variables */ dcl in_op_ptr ptr; dcl tct_table_ptr ptr; dcl original_in_op_ptr ptr; dcl st_offset fixed bin; dcl tct_ptr ptr; dcl summary_ptr ptr; dcl descrip_ptr ptr; dcl descrip bit (72) based (descrip_ptr); dcl work_binary fixed bin (35); dcl 1 work_inst based (inst_ptr), 2 left_half bit (18), 2 right_half bit (18); dcl ret_offset fixed bin; dcl eos_buff (1:10) fixed bin; dcl temp_eos_ptr ptr; dcl 1 move_token aligned, 2 count fixed bin, 2 code fixed bin, 2 token_ptr (1:5) ptr; /*************************************************/ /* START OF EXECUTION */ /* class_condition */ /**************************************************/ start_class_condition: separate_sign_processing_flag = "0"b; /* Used to indicate whether numeric is separate sign or overpunch */ /* Get a pointer to the operand to be tested for class condition */ in_op_ptr = in_token.token_ptr (in_token.n - 1); if end_stmt.e = rwkey_alphabetic then do; /* Alphabetic class condition */ if alpha_tct_table_allocated ^= cobol_$compile_count then do; /* Must build the alphabetic tct table in the constant section */ type9_alpha_tct_ptr = addr (type9_alpha_tct (1)); dn_ptr = type9_alpha_tct_ptr; tct_table_ptr = addr (alpha_tct_table); call tct_table_build; alpha_tct_table_allocated = cobol_$compile_count; end; /* Must build the alphabetic tct table in the constant section */ tct_ptr = type9_alpha_tct_ptr; end; /* Alphabetic class condition */ else do; /* Numeric class conditon */ if numeric_tct_table_allocated ^= cobol_$compile_count then do; /* Must build the numeric tct table in the constant section */ type9_numeric_tct_ptr = addr (type9_numeric_tct (1)); dn_ptr = type9_numeric_tct_ptr; tct_table_ptr = addr (numeric_tct_table); call tct_table_build; numeric_tct_table_allocated = cobol_$compile_count; end; /* Must build the numeric tct tble in the constant section */ tct_ptr = type9_numeric_tct_ptr; if in_op_ptr -> data_name.numeric then do; /* Operand being tested for NUMERIC class condition is a numeric ( as opposed to alphanumeric) */ /* Make a copy of the input operand token. */ sep_sign_ptr = null (); call copy_whole_token (sep_sign_ptr, in_op_ptr); original_in_op_ptr = in_op_ptr; in_op_ptr = sep_sign_ptr; if in_op_ptr -> data_name.sign_separate | (in_op_ptr -> data_name.item_signed & in_op_ptr -> data_name.sign_separate = "0"b) then do; /* The numeric operand has a separate sign or overpunch sign. */ if in_op_ptr -> data_name.subscripted then do; /* A subscripted separate sign or overpunch sign token. */ /* Make a copy of the copy of the token just made. */ sep_sign_ptr = null (); call copy_whole_token (sep_sign_ptr, in_op_ptr); /* Modify the copy so that it is not subscripted. */ sep_sign_ptr -> data_name.subscripted = "0"b; sep_sign_ptr -> data_name.variable_length = "0"b; sep_sign_ptr -> data_name.occurs_ptr = 0; /* Allocate space on the stack to receive the value contained in the subscripted variable. */ call cobol_alloc$stack ( fixed (sep_sign_ptr -> data_name.item_length, 17), 0, ret_offset); /* Modify the token so that it describes the stack space just allocated. */ sep_sign_ptr -> data_name.seg_num = 1000; /* stack */ sep_sign_ptr -> data_name.offset = ret_offset; /* Generate code to move the numeric value to the stack. */ temp_eos_ptr = addr (eos_buff (1)); temp_eos_ptr -> end_stmt.verb = 18; /* MOVE */ temp_eos_ptr -> end_stmt.e = 1; /* One receiving field */ /* Build an input structure for calling the MOVE generator. */ move_token.count = 4; move_token.code = 0; move_token.token_ptr (1) = null (); move_token.token_ptr (2) = in_op_ptr; /* SOURCE */ move_token.token_ptr (3) = sep_sign_ptr; /* DESTINATION */ move_token.token_ptr (4) = temp_eos_ptr; call cobol_move_gen (addr (move_token)); /* Point the original input operand pointer at the token that describes the numeric value in the stack. */ original_in_op_ptr = sep_sign_ptr; in_op_ptr = null (); /* Make a copy of the token that describes the stack value. */ call copy_whole_token (in_op_ptr, sep_sign_ptr); end; /* A suubscripted, separate sign reference. */ /* Modify the token so that the separate sign or overpunch sign is excluded. */ if in_op_ptr -> data_name.sign_type = "100"b | (in_op_ptr -> data_name.sign_type = "010"b) /* Leading overpunch */ then /* Leading separate sign or leading overpunch sign. */ /* Set offset to the byte following the sign byte. */ in_op_ptr -> data_name.offset = in_op_ptr -> data_name.offset + 1; in_op_ptr -> data_name.sign_type = "000"b; /* Unsigned */ /* Decrease the length of the numeric by one (because sign byte is being ignored ) */ in_op_ptr -> data_name.item_length = in_op_ptr -> data_name.item_length - 1; separate_sign_processing_flag = "1"b; end; /* The numeric operand has a separate sign. */ /* Modify the input operand token so that is no longer references a numeric */ in_op_ptr -> data_name.numeric = "0"b; in_op_ptr -> data_name.alphanum = "1"b; end; /* Operand being tested for NUMERIC class condition is a numeric ( as opposed to alphanumeric) */ end; /* Numeric class condition */ /* Allocate one 6180 word in the run-time stack to receive summary information */ call cobol_alloc$stack (4 /* bytes */, 0, st_offset); /* Build a data name token (type 9) for the stack entry */ dn_ptr = addr (summary_buff (1)); data_name.type = rtc_dataname; data_name.seg_num = 1000; /* stack segment */ data_name.offset = st_offset; /* Offset returned by the alloc procedure */ /* Zero the description bits */ 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; data_name.item_length = 4; /* Point at the operand for the summary operand just built */ summary_ptr = dn_ptr; /* At this point in execution we have three relevant pointers: 1. in_op_ptr points to the input operand 2. tct_ptr points to the operand for the tct table 3. summary_ptr points to the operand for the summary word allocated in the stack. */ call test_for_numeric; /* Emit the instruction(s) following the tct */ if ^separate_sign_processing_flag then do; /* Not separate sign operand, so emit a single transfer instruction */ i_ptr = addr (end_stmt.i); if ibit.not then topcode = ttf_op; /* NOT CLASS CONDITION */ else topcode = ttn_op; /* CLASS CONDITION */ /* Zero bits to instruction being built */ non_eis_word = "0"b; non_eis_ptr = addr (non_eis_word); /* Insert opcode into the instruction */ non_eis_ptr -> eis_inst.opcode = topcode; /* Build relocation information */ reloc_struc (1) = "0"b; reloc_struc (2) = "0"b; /* Save the text section offset at which the transfer is to be emitted */ save_locno = cobol_$text_wd_off; /* Emit the transfer instruction */ call cobol_emit (non_eis_ptr, reloc_ptr, 1); /* Issue a reference to the tag in end_stmt.h */ call cobol_make_tagref (fixed (end_stmt.h, 17), save_locno, null ()); end; /* Not separate sign operand, so emit a single transfer instruction */ else do; /* Separate sign operand, must generate code to isolate and test the sign */ call separate_sign_processing; end; /* Separate sign operand, must generate code to isolate and test the sign */ exit_class_condition: /***..... if Trace_Bit then call cobol_gen_driver_$Tr_End(cc);/**/ return; /*{*/ tct_table_build: proc; /* This internal procedure pools a tct table image in the constant section of the Cobol text segment, and then builds a data name token (type 9) that describes the table. */ /* Assertions at entry. 1. tct_table_ptr points to an iternal static initialized character string that is the tct table to be pooled. 2. dn_ptr points to a buffer in which the data name token (type 9) is to be built. */ /*}*/ dcl tct_table char (512) based (tct_table_ptr); dcl t_offset fixed bin; /**************************************************/ /* START OF EXECUTION */ /* tct_table_build */ /**************************************************/ start_tct_table_build: /* Pool the tct table in the constant section */ call cobol_pool$search_op (tct_table, 0, t_offset, in_op); /* Build a data name (type 9) token for the pooled constant */ data_name.type = rtc_dataname; if in_op = 1 then data_name.seg_num = 3; else data_name.seg_num = 3000; /* Constant section of the text segment */ data_name.offset = t_offset; /* Offset returned by the pool procedure */ /* Zero the description bits of the data name token being built */ descrip_ptr = addr (data_name.file_section); descrip = "0"b; data_name.alphanum = "1"b; data_name.display = "1"b; data_name.elementary = "1"b; data_name.item_length = 512; exit_tct_table_build: return; end tct_table_build; test_for_numeric: proc; /* This procedure generates a tct instruction that thest whether a data item is numeric. */ /* At this point in execution we have three relevant pointers: 1. in_op_ptr points to the input operand 2. tct_ptr points to the operand for the tct table 3. summary_ptr points to the operand for the summary word allocated in the stack. */ start_test_for_numeric: /* Now we must build the TCT instruction and descriptors */ /* Build the input structure for the instruction and first descriptor */ input_struc.type = 4; /* eis, 1 descriptor */ input_struc.operand_no = 1; input_struc.lock = 0; /* no locks */ input_struc.operand.token_ptr (1) = in_op_ptr; input_struc.operand.send_receive (1) = 0; input_struc.operand.size_sw (1) = 0; call cobol_addr (input_ptr, inst_ptr, reloc_ptr); /* Insert the tct opcode into the instruction */ eis_ptr = inst_ptr; eis_inst.opcode = tct_op; /* Emit the tct instruction and first descriptor */ call cobol_emit (inst_ptr, reloc_ptr, 2); /* Build the second descriptor */ input_struc.type = 3; /* eis, 1 operand, no descriptors */ input_struc.operand_no = 1; input_struc.lock = 0; /* no locks */ input_struc.operand.token_ptr (1) = tct_ptr; input_struc.operand.send_receive (1) = 0; input_struc.operand.size_sw (1) = 0; call cobol_addr (input_ptr, inst_ptr, reloc_ptr); /* Set the opcode in the returned eis instruction to zero bits */ inst_struc_basic.fill1_op = "0"b; /* Increment the address returned by cobol_addr, because cobol_addr generates the address relative to the IC of this instruction, when what we need is an IC address relative to the TCT instruction. */ work_binary = binary (work_inst.left_half, 18) + 2; work_inst.left_half = substr (unspec (work_binary), 19, 18); /* Emit the second descriptor */ call cobol_emit (inst_ptr, reloc_ptr, 1); /* Build the third descriptor */ input_struc.type = 3; /* eis, 1 operand, no descriptors */ input_struc.operand_no = 1; input_struc.lock = 0; input_struc.operand.token_ptr (1) = summary_ptr; input_struc.operand.send_receive (1) = 0; input_struc.operand.size_sw (1) = 0; call cobol_addr (input_ptr, inst_ptr, reloc_ptr); /* Set the opcode in the returned eis instruction to zero bits */ inst_struc_basic.fill1_op = "0"b; /* Emit the third descriptor */ call cobol_emit (inst_ptr, reloc_ptr, 1); exit_test_for_numeric: return; end test_for_numeric; /*{*/ separate_sign_processing: proc; /* This internal procedure generates code that tests to determine whether the separate sign byte of a numeric operand is plus or minus. */ /*}*/ /* Declaration of automatic work buffers */ dcl separate_sign_type9 (1:40) fixed bin; /* Used to contain type 9 for the sign byte */ dcl separate_sign_eos (1:10) fixed bin; /* Used to build EOS for recursive calls to cobol_compare_gen */ dcl separate_sign_input_token (1:15) fixed bin; /* Used to contain input token for recursive calls to mc cobol_compare_gen */ /* Other work variables */ dcl save_h fixed bin; dcl save_not bit (1); dcl fail_tag fixed bin; dcl temp_tag fixed bin; dcl temp_ptr ptr; /**************************************************/ /* START OF EXECUTION */ /* separate_sign */ /**************************************************/ start_separate_sign_processing: /* Build a data name token for the sign byte of the numeric data name token */ /* Make a copy of the original numeric data name token */ dn_ptr = addr (separate_sign_type9 (1)); call cobol_make_type9$copy (dn_ptr, original_in_op_ptr); /* Modify the copy of the numeric data name */ data_name.numeric = "0"b; data_name.alphanum = "1"b; data_name.places_left = 0; data_name.places_right = 0; if data_name.sign_type = "011"b /* Trailing separate */ | data_name.sign_type = "001"b /* trailing, but not separate */ | data_name.sign_type = "000"b /* Clause not specified, defaults to trailing overpunch. */ then /* Set offset to last character in the numeric data item */ data_name.offset = data_name.offset + data_name.item_length - 1; data_name.item_length = 1; /* Reserve a tag */ fail_tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; /* Save the location at which the ttf instruction is to be emitted */ save_locno = cobol_$text_wd_off; /* Build the ttf instruction */ non_eis_word = "0"b; non_eis_ptr = addr (non_eis_word); non_eis_ptr -> eis_inst.opcode = ttf_op; /* Build relocation bytes */ reloc_struc (1) = "0"b; reloc_struc (2) = "0"b; /* Emit the instruction */ call cobol_emit (non_eis_ptr, reloc_ptr, 1); i_ptr = addr (end_stmt.i); /* Save the tag from the input EOS */ save_h = end_stmt.h; /* Save the "not" bit from the input EOS */ save_not = ibit.not; /* Issue a reference to a tag at the instruction just emitted */ if ibit.not then temp_tag = end_stmt.h; else temp_tag = fail_tag; call cobol_make_tagref (temp_tag, save_locno, null ()); if (data_name.item_signed & data_name.sign_separate = "0"b) then do; /* Testing for leading or trailing overpunch sign. */ if opch_tct_table_allocated ^= cobol_$compile_count then do; /* Must build the overpunch sign tct table in the constant section. */ temp_ptr = dn_ptr; type9_opch_tct_ptr = addr (type9_opch_tct (1)); dn_ptr = type9_opch_tct_ptr; tct_table_ptr = addr (opch_tct_table); call tct_table_build; opch_tct_table_allocated = cobol_$compile_count; dn_ptr = temp_ptr; end; /* Must build the overpunch sign tct table in the constant section. */ tct_ptr = type9_opch_tct_ptr; in_op_ptr = dn_ptr; call test_for_numeric; if save_not = "0"b then do; /* test is "if X numeric". */ /* If sign is a valid overpunch sign, then we want to transfer to the tag specified in the EOS token. */ temp_tag = end_stmt.h; non_eis_ptr -> eis_inst.opcode = ttn_op; end; /* Test if "if X numeric". */ call cobol_emit (non_eis_ptr, reloc_ptr, 1); call cobol_make_tagref (temp_tag, cobol_$text_wd_off - 1, null ()); end; /* Testing for leading or trailing overpunch sign. */ else do; /* Testing for leading or trailing separate sign. */ /* Build an EOS to be used in recursive calls to cobol_compare_gen */ if separate_signs_pooled ^= cobol_$compile_count then do; /* Pool the signs, and build data name (type 9) tokens for each */ /* Pool plus and make a data name */ separate_sign_literal.literal_string = "+"; temp_ptr = addr (plus_type9 (1)); call cobol_make_type9$type2_3 (temp_ptr, addr (separate_sign_literal)); /* Pool minus and make data name */ separate_sign_literal.literal_string = "-"; temp_ptr = addr (minus_type9 (1)); call cobol_make_type9$type2_3 (temp_ptr, addr (separate_sign_literal)); separate_signs_pooled = cobol_$compile_count; end; /* Pool the signs, and build a data name token for each */ eos_ptr = addr (separate_sign_eos (1)); end_stmt.e = rwkey_equal; if save_not then end_stmt.h = fail_tag; else end_stmt.h = save_h; end_stmt.i = 0; /* Build the input structure to be used in recursive calls to cobol_compare_gen */ work_in_token_ptr = addr (work_in_token.n); work_in_token.n = 3; work_in_token.token_ptr (work_in_token.n) = eos_ptr; /* EOS token for EQUAL compare */ work_in_token.token_ptr (work_in_token.n - 1) = addr (plus_type9 (1)); /* Data name token for the plus sign */ work_in_token.token_ptr (work_in_token.n - 2) = dn_ptr; /* Data name token for the sign byte */ /* Build the input structure for the second recursive call (NECESSARY BECAUSE THE PRROGRAM BLOWS UP OTHERWISE!!!! ) */ work_in_token1_ptr = addr (work_in_token1.n); work_in_token1.n = 3; work_in_token1.token_ptr (work_in_token1.n) = eos_ptr; work_in_token1.token_ptr (work_in_token1.n - 1) = addr (minus_type9 (1)); work_in_token1.token_ptr (work_in_token1.n - 2) = dn_ptr; /* Call cobol_compare_gen recursively to generate code to test whether the sign is plus */ call cobol_compare_gen (work_in_token_ptr, null ()); /* Modify the input token for next recursive call to cobol_compare_gen */ /*!!!*/ if save_not then do; /* Branch on condition false, must change EOS */ end_stmt.e = rwkey_unequal; end_stmt.h = save_h; end; /* Branch on condition false, must change EOS */ /* Call cobol_compare_gen recursively to generate code to test whether the sign is minus */ call cobol_compare_gen (work_in_token1_ptr, null ()); end; /* Testing for leading or trailing separate sign. */ /* Define the label "fail_tag" at the next word in the text section */ call cobol_define_tag (fail_tag); exit_separate_sign_processing: return; end separate_sign_processing; copy_whole_token: proc (copied_token_ptr, source_token_ptr); /* This procedure makes a copy of the entire contents of a token. This procedure is necessary because cobol_make_type9$copy copies only the header of a token. */ /* DECLARATION OF THE PARAMETERS */ dcl copied_token_ptr ptr; dcl source_token_ptr ptr; /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION copied_token_ptr Pointer to the copy made by this procedure. (input/output) On input, if this pointer is null(), then this procedure allocates space for the copy of the token in the temporary token area, and returns a pointer to the temporary token in this parameter. If this pointer is not null() on input, then the copied token is made in the space pointed at the the input value of the pointer. source_token_ptr Pointer to the token to be copied. (input) */ dcl copy_string char (1000) based (copied_token_ptr); dcl source_string char (1000) based (source_token_ptr); start_copy_whole_token: if copied_token_ptr = null () then do; /* Allocate space for the token in the temporary token area. */ copied_token_ptr = cobol_$temp_token_ptr; cobol_$temp_token_ptr = addrel (cobol_$temp_token_ptr, fixed ((source_token_ptr -> data_name.size + 3) / 4, 18)); end; /* Allocate space for the token in the temmporary token aarea. */ /* Copy the token. */ substr (copy_string, 1, source_token_ptr -> data_name.size) = substr (source_string, 1); exit_copy_whole_token: return; end copy_whole_token; end class_condition; /***..... 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 cc char(15) init("CLASS_CONDITION");/**/ /***..... dcl ac char(13) init("ALPHA_COMPARE");/**/ /***..... dcl c6 char(10) init("COMP6_PROC");/**/ /***..... dcl nc char(15) init("NUMERIC_COMPARE");/**/ /***..... dcl rc char(18) init("RELATIONAL_COMPARE");/**/ /***..... dcl sc char(14) init("SIGN_CONDITION");/**/ /***..... dcl ub char(7) init("UBRANCH");/**/ /***..... dcl ccg char(17) init("COBOL_COMPARE_GEN");/**/ /* INCLUDE FILES USED BY THIS PROCEDURE */ /***** Declaration for builtin function *****/ dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index) builtin; dcl (max, min) builtin; /***** End of declaration for builtin function *****/ %include cobol_; %include cobol_type40; %include cobol_type1; %include cobol_type2; %include cobol_type3; %include cobol_type9; %include cobol_type10; %include cobol_type19; %include cobol_mcdb; %include cobol_record_types; %include cobol_in_token; %include cobol_addr_tokens; %include cobol_fixed_common; %include cobol_ext_; end cobol_compare_gen;  cobol_compute_bin_gen.pl1 05/24/89 1040.3rew 05/24/89 0830.2 136467 /****^ *********************************************************** * * * 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_compute_bin_gen.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 06/29/79 by FCH, [4.0-1], not option added for debug */ /* Modified since Version 4.0 */ /*{*/ /* format: style3 */ cobol_compute_bin_gen: proc (in_token_ptr, next_stmt_tag, target_code, source_code); /* This procedure generates code to evaluate a compute statement by doing computation in the hardware registers. */ /* DECLARATION OF THE PARAMETERS */ /* dcl in_token_ptr ptr; */ /* Declared below in an include file. */ dcl next_stmt_tag fixed bin; dcl target_code fixed bin; dcl source_code fixed bin; /* DECLARATION OF EXTERNAL ENTRIES */ dcl cobol_add2_binary_long ext entry (ptr, ptr, ptr, fixed bin); dcl cobol_add2_binary_short ext entry (ptr, ptr, ptr, fixed bin); dcl cobol_multiply2_binary ext entry (ptr, ptr, ptr, fixed bin); dcl cobol_store_binary ext entry (ptr, ptr, bit (1)); dcl cobol_make_tagref ext entry (fixed bin, fixed bin, ptr); dcl cobol_define_tag ext entry (fixed bin); 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_make_type9$type2_3 ext entry (ptr, ptr); dcl cobol_register$release ext entry (ptr); dcl cobol_make_bin_const ext entry (ptr, ptr, fixed bin); /* DECLARATION OF INTERNAL STATIC DATA */ 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"); dcl plus_op fixed bin int static init (182); dcl minus_op fixed bin int static init (183); dcl multiply_op fixed bin int static init (184); dcl divide_op fixed bin int static init (185); dcl unary_minus_op fixed bin int static init (187); dcl tov_inst bit (36) int static init ("000000000000000000110001111000000000"b); /* TOV */ dcl tra_inst bit (36) int static init ("000000000000000000111001000000000000"b); /* TRA */ /* DECLARATTION OF INTERNAL VARIABLES */ dcl receive_count fixed bin; dcl ose_flag bit (1); dcl imperative_stmt_tag fixed bin; dcl ix fixed bin; dcl result_token_ptr ptr; dcl top fixed bin; dcl operand_stack (1:256) ptr; dcl compute_code fixed bin; dcl skipped_some bit (1); dcl call_again bit (1); dcl temp_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 dn_ptr ptr; /**************************************************/ /* START OF EXECUTION */ /* cobol_compute_bin_gen */ /**************************************************/ start: /* Determine whether the computation should be done in the A-Q or in index registers. */ if target_code = source_code then compute_code = target_code; else compute_code = 2; /* source and target of different lengths, do the compute in the longest length registers. */ /* Determine the number of receiving operands. */ eos_ptr = in_token.token_ptr (in_token.n); receive_count = end_stmt.e; 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 = cobol_$next_tag + 1; cobol_$next_tag = cobol_$next_tag + 2; /* Generate code to turn on the fixed overflow mask indicator bit */ call cobol_fofl_mask$on; end; /* reserve two tags for on size error processing. */ top = 0; do ix = 2 to in_token.n - 1; /* Generate code to evaluate the expression. */ eos_ptr = in_token.token_ptr (ix); if end_stmt.type ^= rtc_eos then do; /* Not an EOS, must be an operand. */ if end_stmt.type = rtc_resword then do; /* A reserved_word, must be fig constant ZERO */ eos_ptr = null (); /* Make a data name token for decimal zero. */ call cobol_make_type9$type2_3 (eos_ptr, addr (dec_zero_token)); end; /* A reserved word, must be fig constant ZERO */ top = top + 1; operand_stack (top) = eos_ptr; end; /* Not an EOS, must be an operand. */ else do; /* An operator, perform a computation */ result_token_ptr = null (); if end_stmt.e = unary_minus_op then do; /* Unary minus operation */ eos_ptr = null (); call cobol_make_bin_const (addr (dec_zero_token), eos_ptr, compute_code); if compute_code = 2 /* long binary computation */ then call cobol_add2_binary_long (eos_ptr, operand_stack (top), result_token_ptr, 2); else call cobol_add2_binary_short (eos_ptr, operand_stack (top), result_token_ptr, 2); /* Replace the top entry of the operand stack with the resulting negated token. */ operand_stack (top) = result_token_ptr; end; /* unary minus operation */ else do; /* Binary operation */ if end_stmt.e = plus_op then do; /* Binary addition */ if compute_code = 2 /* long binary arithmetic */ then call cobol_add2_binary_long (operand_stack (top - 1), operand_stack (top), result_token_ptr, 1); else call cobol_add2_binary_short (operand_stack (top - 1), operand_stack (top), result_token_ptr, 1); end; /* Binary addition */ else if end_stmt.e = minus_op then do; /* Binary subtraction */ if compute_code = 2 then call cobol_add2_binary_long (operand_stack (top - 1), operand_stack (top), result_token_ptr, 2); else call cobol_add2_binary_short (operand_stack (top - 1), operand_stack (top), result_token_ptr, 2); end; /* Binary subtraction */ else if end_stmt.e = multiply_op then do; /* Multiply operation. */ /* Set compute code to long binary, because multiplication is done in the 36 bit registers. */ compute_code = 2; call cobol_multiply2_binary (operand_stack (top - 1), operand_stack (top), result_token_ptr, 1); end; /* Multiply operation. */ else if end_stmt.e = divide_op then do; /* Divide operation. */ /* Set compute code to long binary, because division is done in 36 bit registers. */ compute_code = 2; call cobol_multiply2_binary (operand_stack (top - 1), operand_stack (top), result_token_ptr, 2); /* Release the A register, (which is locked by the multiply procedure.) */ register_struc.reg_no = "0001"b; /* A */ call cobol_register$release (addr (register_struc)); end; /* Divide operation. */ top = top - 1; operand_stack (top) = result_token_ptr; end; /* Binary operation */ if ose_flag & (end_stmt.e = plus_op | end_stmt.e = minus_op) then do; /* On size error clause present, must test for overflow */ /* Note that overflow can occur during the execution of the computation only for addition and subtraction. */ call cobol_emit (addr (tov_inst), null (), 1); /* Make a reference to imperative_stmt_tag at the TOV just emitted */ call cobol_make_tagref (imperative_stmt_tag, cobol_$text_wd_off - 1, null ()); end; /* On size error clause present, must test for overflow */ end; /* An operator, perform a computation */ end; /* Generate code to evaluate the expression. */ /* At this point in processing, code has been generated to compute the expression. operand_stack(top) contains a pointer to a token that describes the result of the computation */ if operand_stack (top) ^= null then if operand_stack (top) -> data_name.type = rtc_numlit then do; /* Result is a numeric literal constant. */ /* Convert the numeric literal to fixed binary. */ temp_ptr = null (); call cobol_make_bin_const (operand_stack (top), temp_ptr, compute_code); operand_stack (top) = temp_ptr; end; /* Result is a numeric literal constant. */ if end_stmt.e ^= multiply_op then do; /* Operation was add, subtract, or divide */ /* For add, subtract, or divide, the result will always fit into a 36 bit register. Here, we store the result, first into all long binary receiving fields, and then into any short binary receiving fields. */ skipped_some = "0"b; do ix = 1 to receive_count; /* Store result into targets that will hold the result */ if (compute_code = 2 & operand_stack (ix) -> data_name.bin_18) then skipped_some = "1"b; else if operand_stack (top) ^= null then call cobol_store_binary (operand_stack (top), operand_stack (ix), call_again); end; /* Store result into targets that will hold the result. */ if skipped_some then do; /* Must move the result into targets that may be too small */ do ix = 1 to receive_count; /* scan for unfilled targets */ if operand_stack (ix) -> data_name.bin_18 then call cobol_store_binary (operand_stack (top), operand_stack (ix), call_again); if call_again then do; /* Result moved to temp, must now move temp to target */ if ose_flag then do; call cobol_emit (addr (tov_inst), null (), 1); call cobol_make_tagref (imperative_stmt_tag, cobol_$text_wd_off - 1, null ()); end; call cobol_store_binary (operand_stack (top), operand_stack (ix), call_again) ; end; /* Result moved to teep, must now move temp to target. */ end; /* scan for unfilled targets */ end; /* Move the result into targets that may be too small */ end; /* Operation was add, subtract, or divide. */ else do; /* Operation was multiply */ /* The result of a fixed binary multiplication is in the A and Q registers, and could potentially overflow both long and short binary targets. */ /* Store the result, first into all long binary receiving fields. */ skipped_some = "0"b; do ix = 1 to receive_count; /* Store into all long binary targets. */ if operand_stack (ix) -> data_name.bin_18 then skipped_some = "1"b; else do; /* Target is long binary. */ call cobol_store_binary (operand_stack (top), operand_stack (ix), call_again); if call_again then do; /* Result moved to temp in an attempt to force overflow. */ if ose_flag then do; /* Must generate code to 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; /* Must generate code to test for overflow. */ call cobol_store_binary (operand_stack (top), operand_stack (ix), call_again) ; end; /* Result moved to temp in an attempt to force overflow. */ end; /* Target is long binary. */ end; /* Store into all long binary targets. */ if skipped_some then do; /* Move result into short binary targets. */ do ix = 1 to receive_count; /* Scan for unfilled targets. */ if operand_stack (ix) -> data_name.bin_18 then do; /* A short binary target. */ call cobol_store_binary (operand_stack (top), operand_stack (ix), call_again) ; if call_again then do; /* Result moved to temp in attempt to force ovflow. */ if ose_flag then do; /* Generate code to 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; /* Generate code to test for overflow. */ /* Now must store the temp into the target. */ call cobol_store_binary (operand_stack (top), operand_stack (ix), call_again); end; /* Result moved to temp in attempt to force ovflow */ end; /* A short binary target. */ end; /* Scan for unfilled targets. */ end; /* Move result into short binary targets. */ end; /* Operation was multiply */ if ose_flag then do; /* Emit code to transfer over the imperative stmt. */ /* Turn off the fixed overflow mask indicator 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. */ call cobol_emit (addr (tra_inst), null (), 1); /* Make a reference to the next stmt at the transfer instruction just emitted */ call cobol_make_tagref (next_stmt_tag, cobol_$text_wd_off - 1, null ()); /* Define the imperative statement tag at the NEXT instruction */ call cobol_define_tag (imperative_stmt_tag); /*[4.0-1]*/ end; /* Generate code to turn off the overflow mask indicator bit. */ call cobol_fofl_mask$off; end; /* Emit code to transfer over the imperative statement. */ if operand_stack (top) ^= null then if operand_stack (top) -> data_name.type = rtc_register then do; /* Source is in a register, and has been stored into all targets. Release the register now. */ register_struc.reg_no = operand_stack (top) -> cobol_type100.register; call cobol_register$release (addr (register_struc)); end; /* Source is in a register, and has been stored into all targets. Release the register now. */ 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_type9; %include cobol_type19; %include cobol_record_types; %include cobol_type100; %include cobol_in_token; %include cobol_; end cobol_compute_bin_gen;  cobol_compute_gen.pl1 05/24/89 1040.3rew 05/24/89 0830.2 291321 /****^ *********************************************************** * * * 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_compute_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 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_compute_gen: proc (in_token_ptr, next_stmt_tag); /* The compute generator: cobol_compute_gen FUNCTION The function of this procedure is to generate code that 1. performs the of the arithmetic expression to be computed. 2. assigns the result of the computation into the data items to receive the result. 3. checks for size errors during the evaluation of the arithmetic expression. 4. checks for size errors during the assigning of the result to the receiving data items. */ /* DEFINITION OF THE PARAMETERS */ /* dcl in_token_ptr ptr; */ 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 compute statement for which code is to be generated. (input) See description below under INPUT for details. NOTE: This parameter is actually 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 with the Cobol statement following the compute statement for which this procedure was called. (output) See discussion below under OUTPUT for 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 COMPUTE. This pointer is not used by this procedure. token_ptr(n) contains a pointer to an EOS (type 19) token. The type 19 token contains some information that is very meaningful to this procedure. 1. end_stmt.verb contains the code for the reserved word COMPUTE. 2. end_stmt.e contains a count of the number of data items that are to receive the result of the computation. 3. end_stmt.b is set to "1"b if the compute statement contained an ON SIZE ERROR clause. token_ptr(2) through token_ptr(n-1) point to tokens that describe: 1. the data items that are to receive the result of the computation. (all are data name (type 9) tokens) 2. the tokens for the operands to be used in evaluating the arithmetic expression. These tokens can be data name (type 9) tokens, numeric literal (type 2) tokens, or the figurative constant ZERO (type 1) token. 3. the tokens that describe the arithmetic operators to be used in evaluating the arithmetic expression. These tokens are EOS tokens (type 19). The contents of the field end_stme.e in these type 19 tokens specifies the operator. end_stmt.e | operator --------------------------------------------- 182 | + (binary plus) 183 | - (binary minus) 184 | * (multiply) 185 | / (divide) 186 | ** (exponentiate) 187 | - (unary minus) The data name tokens, and EOS tokens that specify operators, are arranged in trailing polish notation in the token_ptr array. That is, each operator follows the operand (for unary operators) or the two operands (for binary operators) to which it applies. OUTPUT The second parameter passed to cobol_compute_gen is an output para- meter. A value is returned to the calling program (cobol_gen_driver_) only for those compute statements that have on size error clauses. If an on size error clause is specified, then, in addition to the code that evaluates the arithmetic expression, and assigns it to the receiving data items, cobol_compute_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 COMPUTE statement is executed, otherwise the imperative statement is skipped. The cobol_compute_gen generator, however, when generating code to skip over the imperative statmeent to the next statement, does not know anything about the next statement. This situation is handled as follows: 1. cobol_compute_gen reserves a tag for the next Cobol statement. 2. any transfers to the next statement reference the tag reserved by cobol_compute_gen. This tag is not yet defined. (associated with an instruction location in the text segment) 3. after generation of code for a compute statement is completed, cobol_compute_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_compute_gen, is defined. IMPLEMENTATION DETAILS 1. Computing the Result of the Arithmetic Expression The input structure contains, in its array of pointers, pointers to tokens that represent the compute statement. The first meaningful pointer is contained in token_ptr(2) (because token_ptr(1) points to the reserved word token for compute), and the last meaningful pointer is contained in token_ptr(n-1) (because token_ptr(n) points to an EOS token). Processing to evaluate the result of the expression is done as follows. 1. Starting at the token pointed at by token_ptr(2) , and proceeding through token_ptr(n-1), the tokens pointed at are scanned. 2. Each token that is not an EOS token has a pointer to it pushed into a LIFO stack, referred to here as the operand stack. 3. Each time an EOS token is detected, it is an operator, and code is generated. The type of processing done to generate code depends on the operator: a. For a unary operator, the code is generated to perform the operation using the token pointed at by the top entry of the operand stack. A pointer to the data name token that describes the result of the operation replaces the top entry of the operand stack. b. For a binary operator, code is generated to perform the operation on the two tokens pointed at by the two top entries on the operand stack. The top entry on the operand stack is then removed (popped!), and a pointer to the data name token that describes the result of the operation replaces the current top entry of the operand stack. Generation of code is accomplished by calls to arithmetic subgenerators. The subgenerators called for each operation are given in the following table: ---------------------------------------------- operation | subgenerator called --------------------------------------------- unary minus | cobol_arithop_gen addition | cobol_add3 subtraction | cobol_add3 multiplication | cobol_mpy3 division | cobol_mpy3 exponentiation | cobol_exp3 At the completion of the scan of all of the tokens, the top entry on the operand stack points to a token that describes the result of the evaluation of the expression. The other entries in the operand stack point to the tokens that describe the receiving data items. 2. Assigning the Result of the Computation to the Receiving Data Items. If no on size error checking was requested, then the move generator is called to move the result to the receiving data items. If on size error checking was requested, processing is more complicated. The data name (type 9) token for the result of the computation contains the following information about the resultant value: 1. total length of the result, in digits. 2 number of places to the left of the decimal point. 3. number of places to the right of the decimal point. The data name tokens for the receiving data items contain the same information. Therefore, it is possible , at compilation time, to determine whether an overflow condition could occur when assigning a result to a receiving data item. Processing for assigning the result when on size error checking was requested consists of the following sequence: 1. determine which receiving fields can contain the result with no possibility of a size error. 2. call the move generator to move the result to all receiving fields for which no on size error can occur. 3. for each receiving field for which an on size error could occur, the follwoing processing is done: a. generate code to move the current contents of the receiving field to temporary storage by calling the move generator. b. generate code to move the result to the receiving field. c. generate code to test for an overflow d. generate code which is executed only if an overflow occurs. This code restores the original value to the receiving field, and sets a size error flag that indicates that an overflow occurred. 4. After all code to move the result to receiving fields has been generated, and if any overflow checking code was generated, then generate a test of the size error flag to determine if an overflow occurred, and generate a transfer to the next cobol statement if the size error flag is off. */ /* DECLARATION OF EXTERNAL ENTRIES */ dcl cobol_fofl_mask$on ext entry; dcl cobol_fofl_mask$off ext entry; dcl cobol_alloc$stack ext entry (fixed bin, fixed bin, fixed bin); dcl cobol_emit ext entry (ptr, ptr, fixed bin); dcl cobol_addr ext entry (ptr, ptr, ptr); dcl cobol_make_type9$copy ext entry (ptr, ptr); dcl cobol_make_tagref ext entry (fixed bin, fixed bin, ptr); dcl cobol_define_tag ext entry (fixed bin); dcl ioa_$ioa_stream ext entry options (variable); dcl cobol_add3 ext entry (ptr, ptr, ptr, fixed bin); dcl cobol_mpy3 ext entry (ptr, ptr, ptr, fixed bin); dcl cobol_exp3 ext entry (ptr, ptr, ptr, fixed bin); dcl cobol_build_resop ext entry (ptr, ptr, fixed bin, ptr, bit (1), fixed bin, bit (1)); dcl cobol_arithop_gen ext entry (ptr); dcl cobol_arith_move_gen ext entry (ptr); dcl cobol_move_gen ext entry (ptr); dcl cobol_compare_gen ext entry (ptr); dcl cobol_register$load ext entry (ptr); dcl cobol_make_type9$fixed_bin_35 ext entry (ptr, fixed bin, fixed bin); dcl cobol_binary_check$compute ext entry (ptr, bit (1), fixed bin, fixed bin); dcl cobol_compute_bin_gen ext entry (ptr, fixed bin, fixed bin, fixed bin); /* DECLARATION OF INTERNAL STATIC VARIABLES */ /* Declaration of internal static initialized variables that define opcodes used in code generated by this proc */ dcl stz_op bit (10) int static init ("1001010000"b /*450(0)*/); dcl tov_op bit (10) int static init ("1100011110"b /*617(0)*/); dcl tra_op bit (10) int static init ("1110010000"b /*710(0)*/); dcl aos_op bit (10) int static init ("0001011000"b /*054(0)*/); 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 tze_op bit (10) int static init ("1100000000"b /*600(0)*/); /* Internal static variables used to define codes for operators that appear in the EOS tokens. */ dcl plus_op fixed bin int static init (182); dcl minus_op fixed bin int static init (183); dcl multiply_op fixed bin int static init (184); dcl divide_op fixed bin int static init (185); dcl exponentiate_op fixed bin int static init (186); dcl unary_minus_op fixed bin int static init (187); /* Declaration of an initialized variable that defines the first meaningful subscript of the in_token.token_ptr array from the point of view of this procedure. */ dcl first_meaningful_ptr_index fixed bin int static init (2); /* Declaration of an EOS token used in calls to the move generator */ dcl 1 move_eos int static, 2 size fixed bin (15) init (38), 2 line fixed bin (15) init (0), 2 column fixed bin init (0), 2 type fixed bin (15) init (19), 2 verb fixed bin (15) init (18), /* MOVE */ 2 e fixed bin (15) init (0), 2 h fixed bin (15) init (0), 2 i fixed bin (15) init (0), 2 j fixed bin (15) init (0), 2 a bit (16) init ("0"b); /* DECLARATION OF AN IMAGE OF A NUMERIC LITERAL ZERO */ dcl 1 numeric_zero internal 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 ("00000"b), 2 sign char (1) init (" "), 2 exp_sign char (1) init (" "), 2 exp_places fixed bin (15) init (0), 2 places_left fixed bin (15) init (1), 2 places_right fixed bin (15) init (0), 2 places fixed bin (15) init (1), 2 literal char (1) init ("0"); /* Declaration of an EOS token used in calls to the compare generator */ dcl 1 compare_eos int static, 2 size fixed bin (15) init (38), 2 line fixed bin (15) init (0), 2 column fixed bin (15) init (0), 2 type fixed bin (15) init (19), /* EOS */ 2 verb fixed bin (15) init (0), 2 e fixed bin (15) init (102), /* EQUAL COMPARE */ 2 h fixed bin (15) init (0), 2 i fixed bin (15) init (0), 2 j fixed bin (15) init (0), 2 a bit (16) init ("0"b); /* DECLARATION OF INTERNAL AUTOMATIC VARIABLES */ /* Structure used to communicate with the cobol_register 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); dcl operand_stack (1:100) ptr; /* the operand stack */ dcl move_eos_ptr ptr; dcl compare_eos_ptr ptr; dcl top fixed bin; dcl work_buff (1:100) ptr; dcl work_ptr ptr; dcl ix fixed bin; dcl operand1_ptr ptr; dcl operand2_ptr ptr; dcl rdmax_flag bit (1); dcl rdmax_value fixed bin; dcl possible_ovfl_flag bit (1); dcl gen_code fixed bin; dcl resultant_operand_ptr ptr; dcl move_in_token (1:100) ptr; dcl receive_count fixed bin; dcl ose_flag bit (1); dcl rdtemp fixed bin; dcl iy fixed bin; dcl save_in_token_ptr ptr; dcl imperative_stmt_tag fixed bin; dcl resod_ld fixed bin; dcl multiple_move_count fixed bin; dcl ret_offset fixed bin; dcl size_error_inst_word bit (36); dcl size_error_inst_ptr ptr; dcl size_error_flag_ptr ptr; dcl temp_save_ptr ptr; dcl temp_inst_word bit (36); dcl temp_inst_ptr ptr; dcl no_overflow_tag fixed bin; dcl input_buffer (1:20) fixed bin; dcl reloc_buffer (1:10) bit (10) aligned; dcl inst_buffer (1:10) fixed bin; dcl overflow_possible bit (1); dcl save_locno fixed bin; dcl size_error_inst bit (36); dcl size_error_token_ptr ptr; dcl stored_token_ptr ptr; dcl receiving_is_not_stored bit (1); dcl (binary_ok, not_bit) bit (1); dcl target_code fixed bin; dcl source_code fixed bin; dcl dn_ptr ptr; /*}*/ /**************************************************/ start: /* Check to see if binary arithmetic can be done for this compute statement. */ call cobol_binary_check$compute (in_token_ptr, binary_ok, target_code, source_code); /* This code is used only to clean the warning message */ if "0"b then if not_dec_operand (null ()) then ; if binary_ok then do; /* Binary airthmetic can be done. */ call cobol_compute_bin_gen (in_token_ptr, next_stmt_tag, target_code, source_code); return; end; /* Binary arithmetic can be done. */ /* Save the input pointer */ save_in_token_ptr = in_token_ptr; top = 0; work_ptr = addr (work_buff (1)); /* Determine the number of receiving operands */ eos_ptr = in_token.token_ptr (in_token.n); receive_count = end_stmt.e; /* Get the on size error flag */ 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 = cobol_$next_tag + 1; cobol_$next_tag = cobol_$next_tag + 2; end; /* Reserve two tags for on size error processing */ else imperative_stmt_tag = 0; /* No on size error clause present in the compute statement. */ /* Determine the maximum number of right digits required for any receiving operand */ rdmax_value = 0; rdmax_flag = "1"b; do ix = first_meaningful_ptr_index to first_meaningful_ptr_index + receive_count - 1; rdtemp = in_token.token_ptr (ix) -> data_name.places_right; if in_token.token_ptr (ix) -> data_name.rounded then rdtemp = rdtemp + 1; /* ROUNDED */ if rdtemp > rdmax_value then rdmax_value = rdtemp; end; /* Get maximum rdmax value */ do ix = first_meaningful_ptr_index to in_token.n - 1; /* compute the result */ eos_ptr = in_token.token_ptr (ix); if end_stmt.type ^= rtc_eos then do; /* Not an operator, must be an operand */ /* Stack the pointer to the operand in the operand stack */ top = top + 1; operand_stack (top) = eos_ptr; end; /* Not an operator, must be an operand */ else do; /* An operator, perform a computation */ if end_stmt.e = unary_minus_op then do; /* Unary minus */ work_ptr -> in_token.n = 2; work_ptr -> in_token.code = 0; work_ptr -> in_token.token_ptr (1) = operand_stack (top); /* operand */ work_ptr -> in_token.token_ptr (2) = eos_ptr; /* Unary minus */ call cobol_arithop_gen (work_ptr); /* Perform negation */ /* Replace the top operand entry on the operand stack with the resultant operand */ operand_stack (top) = work_ptr -> in_token.token_ptr (work_ptr -> in_token.code); end; /* Unary minus */ else do; /* Binary operator */ operand1_ptr = operand_stack (top - 1); /* left operand */ operand2_ptr = operand_stack (top); /* right operand */ /* Build the resultant operand for the computation */ call cobol_build_resop (operand1_ptr, operand2_ptr, bin (end_stmt.e, 17), resultant_operand_ptr, rdmax_flag, rdmax_value, possible_ovfl_flag); top = top - 1; /* Set subscript of resultant operand after computation */ if end_stmt.e = plus_op | end_stmt.e = minus_op then do; /* plus or minus operator */ if end_stmt.e = plus_op then call cobol_add3 (operand1_ptr, operand2_ptr, resultant_operand_ptr, 1 /*add*/); else call cobol_add3 (operand2_ptr, operand1_ptr, resultant_operand_ptr, 2 /*subtract*/); end; /* plus or minus operator */ else if end_stmt.e = multiply_op | end_stmt.e = divide_op then do; /* multiply or divide operator */ if end_stmt.e = multiply_op then gen_code = 1; /* multiply */ else do; /* divide */ gen_code = 2; if ose_flag then call divide_check; /* generate code to test whether divisor is zero */ end; /* divide */ /* Here, reverse the operands, since for division, operand2_ptr points to the divisor, and operand1_ptr points to the dividend. Reversing the operands for multiplication has no effect, since multiplication is commutative. */ call cobol_mpy3 (operand2_ptr, operand1_ptr, resultant_operand_ptr, gen_code) ; end; /* multiply or divide operator */ else /* ASSUME EXPONENTIATE */ call cobol_exp3 (operand1_ptr, operand2_ptr, resultant_operand_ptr, imperative_stmt_tag); /* Replace the top operand entry on the operand stack with the resultant operand */ operand_stack (top) = resultant_operand_ptr; end; /* Binary operator */ end; /* An operator, perform a computation */ end; /* compute the result */ /* At this point, the following coonditions are true: 1. The top entry in the operand stack points to a token that describes the result of the computation. 2. All other entries in the operand stack point to tokens for receiving fields, into which the result must be moved. 3. The field end_stmt.e of the EOS token for compute (end_stmt.verb = 40) contains the number of receiving field. */ if ^ose_flag then do; /* No on size error checking, generate code to move the result to the receiving field(s). */ /* Base in_token template on the move in_token buffer */ in_token_ptr = addr (move_in_token); /* Set in_token.token_ptr(1) to point to the type 1 token for COMPUTE. This is necessary to provide line number and column number for the compute stmt to the MOVE generator procedure. */ in_token.token_ptr (1) = save_in_token_ptr -> in_token.token_ptr (1); in_token.n = 4; /* Set the number of receiving fields into the move EOS. */ move_eos_ptr = addr (move_eos); move_eos_ptr -> end_stmt.e = 1; in_token.token_ptr (4) = move_eos_ptr; iy = 1; do ix = 1 to receive_count; /* Generate code to move the result to each receiving field. */ in_token.token_ptr (2) = operand_stack (top); /* Result of computation. */ in_token.token_ptr (3) = operand_stack (iy); iy = iy + 1; /* Call the arithmetic move generator to do a brute force move in an attempt to force fixedoverflow. */ call cobol_arith_move_gen (in_token_ptr); /* On return from cobol_arith_move_gen, if the receiving field was a numeric edited, then the result has been stored into a numeric in an attempt to force fixedoverflow, and the in_token structure has been modified so that if cobol_move_gen is now called, the temp value will be moved into the numeric edited field. */ if in_token.code ^= 0 /* Receiving field is numeric edited. */ then call cobol_move_gen (in_token_ptr); end; /* Generate code to move the result to each receiving field. */ end; /* no on size error checking, generate code to move the result to the receiving field(s) */ else do; /* On size error checking requested, do it and move result to receiving */ resultant_operand_ptr = operand_stack (top); overflow_possible = "0"b; in_token_ptr = addr (move_in_token); in_token.n = first_meaningful_ptr_index + receive_count + 1; /* Set in_token.token_ptr(1) to point to the type 1 token for COMPUTE. This is necessary to provide line number and column number for the compute stmt to the MOVE generator procedure. */ in_token.token_ptr (1) = save_in_token_ptr -> in_token.token_ptr (1); multiple_move_count = 0; iy = first_meaningful_ptr_index + 1; /* Subscript of the element of in_token.token_ptr array to receive the pointer to first receiving field */ if (resultant_operand_ptr -> data_name.type ^= rtc_dataname) | (resultant_operand_ptr -> data_name.type = rtc_dataname & resultant_operand_ptr -> data_name.sign_type ^= "111"b /* FLOATING DECIMAL */) then do; /* Result is not dataname (must be constant or ZERO) or if dataname is not floating decimal. (If floating decimal, then must unconditionally check for overflow!!) */ /* That means that we must check to see if overflow can occur for any of the receiving fields. */ if resultant_operand_ptr -> data_name.type = rtc_dataname then resod_ld = resultant_operand_ptr -> data_name.places_left; else if resultant_operand_ptr -> data_name.type = rtc_numlit then resod_ld = resultant_operand_ptr -> numeric_lit.places_left; else resod_ld = 1; /* Result is fig const ZERO */ do ix = 1 to receive_count; /* Check to see if on size error checking is necessary for any receiving fields. */ if operand_stack (ix) -> data_name.places_left >= resod_ld then do; /* Receving field can hold the result of the computation with no possibility of overflow. */ multiple_move_count = multiple_move_count + 1; /* Move pointer to the receivnig field into in_token array */ in_token.token_ptr (iy) = operand_stack (ix); iy = iy + 1; /* set operand stack entry to null(), to indicate that it needs no on size error checking */ operand_stack (ix) = null (); end; /* Receiving field can hold the result of the computation with no possibility of overflow. */ end; /* Check to see if on size error checking is necessary for any receiving fields. */ if multiple_move_count ^= 0 then do; /* A move with no on size error checking can be generated */ /* Set pointer to receiving operand into the in_token structure. */ in_token.token_ptr (first_meaningful_ptr_index) = resultant_operand_ptr; /* Adjust in_token.n to its correct value for the (possibly multiple moves. */ in_token.n = first_meaningful_ptr_index + multiple_move_count + 1; /* Set the number of receiving fields into the move EOS */ move_eos_ptr = addr (move_eos); move_eos_ptr -> end_stmt.e = multiple_move_count; /* Set the last entry in the move in_token structure to point to the move EOS token */ in_token.token_ptr (in_token.n) = move_eos_ptr; /* Call the move generator to generate (possibly multiple) moves to those receiving fields for which no overflow can occur. */ call cobol_move_gen (in_token_ptr); end; /* A move with no on size error checking can be generated. */ end; /* Result is not dataname or if dataname, is not floating decimal. */ /* At this point in processing, move code has been generated to move the result to all recieving fields which can hold the result of the computation without possibility of overflow. Now we must generate code to move the result to those receiving fields for which the possibility of overflow does exist. The following conditions are now true: 1. receive_count contains the number of receiving fields. 2. operand_stack(1) through operand_stack(receive_count) contain pointers to the receiving fields for which the possibility of overflow exists, or the null() pointer value. (null() was set into those operand_stack entries for which no possibility of overflow existed, above.) 3. multiple_move_count contains the count of the receiving fields for which moves without on size error checking have been generated. */ if multiple_move_count ^= receive_count then do; /* On size error checking must be done for some receiving fields */ overflow_possible = "1"b; /* Generate code to enable the Cobol fixedoverflow handler. */ /* Allocate 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); do ix = 1 to receive_count; /* Generate moves with test for on size errors */ if operand_stack (ix) ^= null () then do; /* This receiving operand could possibly overflow */ receiving_is_not_stored = "0"b; /* Store the receiving field in a temporary, if the receiving field is not numeric edated. */ if operand_stack (ix) -> data_name.numeric_edited /* Receiving is numeric edited. */ | (operand_stack (ix) -> data_name.display & operand_stack (ix) -> data_name.item_signed & operand_stack (ix) -> data_name.sign_separate = "0"b) /* overpunch sign */ then receiving_is_not_stored = "1"b; else call receiving_field (operand_stack (ix), stored_token_ptr, 1); /* Store receiving */ /* Reserve a tag to which to transfer if no overflow occurs. */ no_overflow_tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_fofl_mask$on; /* Generate code to move the result of the computation to the receiving field. */ /* Set up the in_token structure for the move generator. */ in_token.n = 4; in_token.token_ptr (1) = null (); in_token.token_ptr (2) = resultant_operand_ptr; /* result */ in_token.token_ptr (3) = operand_stack (ix); /* Receiving field */ move_eos_ptr = addr (move_eos); move_eos_ptr -> end_stmt.e = 1; /* One receiving field. */ in_token.token_ptr (4) = move_eos_ptr; call cobol_arith_move_gen (in_token_ptr); /* Generate code to test for overflow, */ call test_for_overflow (no_overflow_tag, size_error_inst_ptr, in_token_ptr); /* If the receiving field has been stored in a temporary, then restore it. */ if receiving_is_not_stored = "0"b then call receiving_field (operand_stack (ix), stored_token_ptr, 2 /*RESTORE*/); /* Define the no_overflow_tag at the next instruction location. */ call cobol_define_tag (no_overflow_tag); /* Generate code to turn OFF the overflow mask indicator bit. */ call cobol_fofl_mask$off; end; /* This operand could possibly overflow */ end; /* Generate moves with test for on size errors */ /* At this point in processing, one or more moves with checking for on size error have been generated */ end; /* On size error checking must be done for some receiving fields */ /* Generate code to test the size error flag (if on ssize error checking was necessary) or to transfer unconditionally to the next statement (if no overflow checking was done). */ /*[4.0-1]*/ if end_stmt.f = "01"b then not_bit = "1"b; else not_bit = "0"b; /*[4.0-1]*/ call test_size_error (size_error_token_ptr, size_error_inst_ptr, next_stmt_tag, overflow_possible, not_bit); end; /* On size error checking requested, do it and move result to receiving */ /* Define the imperative statement at the next available word in the text segment. */ if ose_flag then call cobol_define_tag (imperative_stmt_tag); /* NOTE: The imperative stmt tag is defined whether it is referenced or not in the code generated for the compute statement. */ /* Restore in_token_ptr */ in_token_ptr = save_in_token_ptr; exit: return; /*************************************/ divide_check: proc; /* This internal procedure generates code that compares the divisor of a division operation to zero, and transfers to the imperative statement (on size error ...) if the divisor is in fact, zero. */ /* Set the imperative statement tag into the EOS for compare */ compare_eos_ptr = addr (compare_eos); compare_eos_ptr -> end_stmt.h = imperative_stmt_tag; /* Build an in_token structure to pass to cobol_compare_gen */ work_ptr = addr (work_buff (1)); work_ptr -> in_token.n = 3; work_ptr -> in_token.code = 0; work_ptr -> in_token.token_ptr (1) = operand2_ptr;/* divisor */ work_ptr -> in_token.token_ptr (2) = addr (numeric_zero); /* numeric zero token */ work_ptr -> in_token.token_ptr (3) = compare_eos_ptr; /* Call cobol_compare_gen to perform the code generation */ call cobol_compare_gen (work_ptr); end divide_check; /***** 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 FILES USED BY THIS PROCEDURE */ %include cobol_arith_util; %include cobol_type9; %include cobol_record_types; %include cobol_in_token; %include cobol_type19; %include cobol_; %include cobol_addr_tokens; %include cobol_type2; end cobol_compute_gen;  cobol_decl_gen.pl1 05/24/89 1040.3rew 05/24/89 0830.2 31779 /****^ *********************************************************** * * * 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_decl_gen.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /*{*/ /* format: style3 */ cobol_decl_gen: proc (fxs_tag); /* The procedure cobol_decl_gen is called by cobol_gen_driver_ only if the program being processed contains DECLARATIVES and requires neither data nor fixed segment initialization. When called it; 1. Reserves a tag, fxs_tag, to be associated by cobol_end_gen with the first instruction of the first statement of the first non_Dedclarative Section of the program. 2. Generates the instruction and necessary fix-up directive to achieve unconditional transfer of control to the instruction to be associated with fxs_tag. U__s_a_g_e:_ declare cobol_decl_gen entry (fixed bin); call cobol_decl_gen (fxs_tag); */ declare fxs_tag fixed bin; /*}*/ /* fxs_tag is the number of the tag associated with the first in- struction of the first executable statement of the pro- gram (first statement of the first non-Declarative Sec- tion). This variable is initially set by cobol_pologue_gen to zero if no initialization (either data or segment) is required or to the next available tag number if initiali- zation is required. (Input/Output) */ /* G__e_n_e_r_a_t_e_d_C__o_d_e:_ The following code is generated by cobol_decl_gen only if fxs_tag is zero. If fxs_tag is non_zero , no code is generated. tra fxs_relp,ic where: fxs_relp is the offset, relative to the instruction in which it appears, of the first instruction of the first execut- able statement of the program (first statement of the first non_Declarative Section). */ /* D__a_t_a:_ % include cobol_; Items in cobol_$incl.pl1 used (u) and/or set (s) by cobol_decl_gen: cobol_ptr (u) next_tag (u/s) text_wd_off (u) */ dcl tra_inst bit (36) static init ("000000000000000000111001000000000100"b); /* where: tra_inst is an unconditional transfer instruction. */ /* P__r_o_c_e_d_u_r_e_s_C__a_l_l_e_d:_ */ dcl cobol_emit entry (ptr, ptr, fixed bin), cobol_make_tagref entry (fixed bin, fixed bin, ptr); /* B__u_i_l_t-__i_n_F__u_n_c_t_i_o_n_s_U__s_e_d:_ */ dcl addr builtin, null builtin; %include cobol_; start: fxs_tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_emit (addr (tra_inst), null, 1); call cobol_make_tagref (fxs_tag, text_wd_off - 1, null); return; end cobol_decl_gen;  cobol_def_init.pl1 05/24/89 1040.3rew 05/24/89 0830.2 57510 /****^ *********************************************************** * * * 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_def_init.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_def_init: proc; /* The procedure cobol_def_init initializes the Definition Section and outputs corresponding relocation information. In particular it: 1. Initializes all items in the header and inserts a word of zeros following the header. 2. Creates a class-3 definition for the object segment. 3. Creates a class-2 definition for the symbol-table. 4. Creates an acc string for "symbol_table". 5. Creates an acc string for the object segment name. These entities are positioned in the Definition Section in the order given. cobol_def_init is called once per compilation, prior to code generation. Note: The class-0 definition for the entry point must immediately follow the acc string for the object segment name; i.e. it must be located at def_wd_off as it exists upon return from cobol_def_init. U___s_a_g_e:_ declare cobol_def_init entry; call cobol_def_init; D__a_t_a:_ % include cobol_; Items in cobol_ include file used (u) and/or set (s) by cobol_def_init: cobol_ptr (u) com_ptr (u) def_base_ptr (u) def_wd_off (s) def_max (u) obj_seg_name (u) */ %include cobol_definitions; dcl 1 error_s aligned static, 2 my_name char (32) init ("cobol_def_init"), 2 message_len fixed bin init (35), 2 message char (168) init ("Definition Section length exceeded!"); dcl zeros aligned bit (36) aligned based (def_ptr); dcl len_segname_acc_str fixed bin; dcl wd_len fixed bin; dcl temp fixed bin; dcl 1 acc aligned based (def_ptr), 2 length_of_string fixed bin (8) unaligned, 2 string char (0 refer (acc.length_of_string)) unaligned; dcl reloc_info (44) bit (5) aligned static init ("10101"b, "00000"b, /* for */ "00000"b, "00000"b, /* header */ "00000"b, "00000"b, /* for wd of zeros */ "10101"b, "10101"b, /* for */ "10101"b, "00000"b, /* class-3 */ "10101"b, "10101"b, /* definition */ "10101"b, "10101"b, /* for */ "10110"b, "00000"b, /* class-2 */ "10101"b, "10101"b, /* definition */ "00000"b, "00000"b, /* for */ "00000"b, "00000"b, /* symbol_table */ "00000"b, "00000"b, /* acc */ "00000"b, "00000"b, /* string */ "00000"b, "00000"b, /* for */ "00000"b, "00000"b, /* object segment */ "00000"b, "00000"b, /* name */ "00000"b, "00000"b, /* acc string */ "00000"b, "00000"b, /* allows */ "00000"b, "00000"b, /* for */ "00000"b, "00000"b, /* 32_character */ "00000"b, "00000"b, /* max name */ "00000"b, "00000"b); /* length */ /* 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 null builtin; dcl fixed builtin; dcl substr builtin; dcl unspec builtin; dcl search builtin; dcl string builtin; dcl addrel builtin; dcl addr builtin; /*}*/ %include cobol_; %include cobol_fixed_common; %include cobol_ext_; /*************************************/ start: /* COMPUTE LENGTH OF ACC STRING FOR OBJECT SEGMENT NAME */ len_segname_acc_str = search (obj_seg_name, " "); if len_segname_acc_str = 0 then do; len_segname_acc_str = 33; wd_len = 9; end; else do; temp = len_segname_acc_str + 3; wd_len = fixed (substr (unspec (temp), 1, 34)); end; /* UPDATE def_wd_off AND TEST AGAINST def_max */ def_wd_off = wd_len + 13; if def_wd_off > def_max then do; call signal_ ("command_abort_", null, addr (error_s)); return; end; /* INITIALIZE HEADER */ def_list_relp = "000000000000000011"b; def_header.unused = (36)"0"b; def_header.flags.new_format = "1"b; def_header.flags.ignore = "1"b; def_header.flags.unused = (16)"0"b; /* INSERT WORD OF ZEROS AFTER HEADER */ def_ptr = addrel (def_base_ptr, 2); zeros = (36)"0"b; /* CREATE CLASS-3 DEFINITION FOR THE OBJECT SEGMENT */ def_ptr = addrel (def_ptr, 1); segname.forward_thread = "000000000000000110"b; segname.backward_thread = "000000000000000010"b; segname.segname_thread = "000000000000000010"b; segname.flags = "100000000000000"b; segname.class = "011"b; segname.symbol_relp = "000000000000001101"b; segname.first_relp = "000000000000000110"b; /* CREATE CLASS-2 DEFINITION FOR THE SYMBOL_TABLE */ def_ptr = addrel (def_ptr, 3); definition.forward_thread = "000000000000000010"b; definition.backward_thread = "000000000000000011"b; definition.value = (18)"0"b; string (definition.flags) = "100000000000000"b; definition.class = "010"b; definition.symbol_relp = "000000000000001001"b; definition.segname_relp = "000000000000000011"b; /* CREATE ACC STRING FOR "symbol_table" */ def_ptr = addrel (def_ptr, 3); length_of_string = 12; acc.string = "symbol_table"; /* CTEATE ACC STRING FOR OBJECT SEGMENT NAME */ def_ptr = addrel (def_ptr, 4); length_of_string = len_segname_acc_str - 1; acc.string = obj_seg_name; /* OUTPUT RELOCATION INFORMATIION */ call cobol_reloc (addr (reloc_info), def_wd_off + def_wd_off, 3003); /* INITIALIZATION COMPLETE */ exit: return; end cobol_def_init;  cobol_def_util.pl1 05/24/89 1040.3rew 05/24/89 0830.2 64881 /****^ *********************************************************** * * * 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_def_util.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 01/22/82 by FCH, [5.1-1], cobol_arg_descriptor$type9 called with wrong number of args */ /* Modified since Version 5.1 */ /* format: style3 */ cobol_def_util: proc (n_args, object_name, object_name_len, text_ptr, flag, descriptor_ptr, in_token_ptr); parm_desc_ptr = addr (work_spaces); if n_args > 127 then do; opd_of: call signal_ ("command_abort_", null, addr (oprnd_ovfl)); goto opd_of; end; class0_def_len = binary (substr (unspec (n_args), 18, 18)) + 4; if substr (object_name, 1, 32) = cobol_$obj_seg_name then do; ep_acc_wd_len = 0; ep_acc_relp = 13; end; else do; ep_acc_wd_len = binary (substr (unspec (object_name_len), 17, 18)) + 1; ep_acc_relp = cobol_$def_wd_off + class0_def_len; end; /* Enter cobol_$def_wd_off in entry code sequence before updating */ def_ptr = addrel (cobol_$def_base_ptr, def_list_relp); temp_ptr = addrel (cobol_$def_base_ptr, definition.forward_thread); do while (temp_ptr -> a_word ^= 0); temp_thread = definition.forward_thread; def_ptr = temp_ptr; temp_ptr = addrel (cobol_$def_base_ptr, definition.forward_thread); end; if definition.forward_thread ^= "000000000000000010"b then do while (definition.forward_thread ^= "000000000000000010"b); temp_thread = definition.forward_thread; def_ptr = addrel (cobol_$def_base_ptr, definition.forward_thread); end; definition.forward_thread = substr (unspec (def_wd_off), 19, 18); def_ptr = addrel (cobol_$def_base_ptr, cobol_$def_wd_off); entry_seq.def_relp = substr (unspec (cobol_$def_wd_off), 19, 18); cobol_$def_wd_off = cobol_$def_wd_off + class0_def_len + ep_acc_wd_len; def_error_loop: if cobol_$def_wd_off > cobol_$def_max then do; call signal_ ("command_abort_", null, addr (def_ovfl_error)); goto def_error_loop; end; definition.forward_thread = "000000000000000010"b; definition.backward_thread = temp_thread; temp = cobol_$text_wd_off + 2; definition.value = substr (unspec (temp), 19, 18); string (definition.flags) = "101100000000000"b; string (entry_seq.flags) = "010000000000000000"b; definition.class = "000"b; definition.symbol_relp = substr (unspec (ep_acc_relp), 19, 18); definition.segname_relp = "000000000000000011"b; call cobol_reloc (addr (reloc_cl0_def_fixed), 6, 3003); if n_args ^= 0 & fixed_common.descriptor ^= "00"b then do; parm_desc.n_args = n_args; entry_seq.flags.has_descriptors = "1"b; arg_reloc_code (0) = "00000"b; do i = 1 to n_args; if flag = 0 then substr (arg_desc_off, 1, 18) = substr (desc_off (i), 19, 18); /*[5.1.1]*/ else call cobol_arg_descriptor$type9 (in_token.token_ptr (i + 1), arg_desc_off, LOC); parm_desc.descriptor_relp (i) = substr (arg_desc_off, 1, 18); arg_reloc_code (i) = "10000"b; end; call cobol_reloc (addr (arg_reloc_code (0)), n_args + 1, 3003); temp = 2 + 2 * n_args; call cobol_pool (substr (work_spaces, 1, temp), 2, temp1); temp1 = -temp1; entry_seq.descr_relp_offset = substr (unspec (temp1), 19, 18); end; if ep_acc_wd_len ^= 0 then do; def_ptr = addrel (def_ptr, class0_def_len); acc.length_of_string = object_name_len; acc.string = substr (object_name, 1, object_name_len); call cobol_reloc (null, ep_acc_wd_len + ep_acc_wd_len, 3003); end; if flag = 1 then do; entry_seq.eax7 = "000000000000000000110010111000000000"b; entry_seq.epp2 = "111000000000101000011101010001010000"b; entry_seq.tsp2 = "010000000000000110010111010001010000"b; end; return; dcl n_args fixed bin, /* No of operands in USING phrase*/ flag fixed bin, /* initialization for eax7 etc. If flag = 1 : eax7 etx and descriptor offset are set here. Else eax7 not set and descriptor offset passed from descriptor_ptr. */ descriptor_ptr ptr, desc_off (n_args) bit (36) based (descriptor_ptr), object_name char (32), object_name_len fixed bin, LOC fixed bin, arg_reloc_code (0:256) bit (5) aligned, /* Relocation code for class-0 */ class0_def_len fixed bin, /* Length of class-0 definition */ ep_acc_wd_len fixed bin, /* Length in words of acc string */ ep_acc_relp fixed bin, /* Offset, relative to base of */ arg_desc_off bit (36), /* Offset of argument descriptor */ i fixed bin, /* Do loop index */ offset fixed bin, /* Offset as returned by various */ n_con fixed bin, /* No of conditions */ n_off fixed bin, /* Offset of 1st wd of stack */ name (2) char (32), /* Array of condition names */ ln_nm (2) fixed bin, /* Array of condition name lngths*/ temp_ptr ptr, /* Temporary pointer used in */ temp_thread bit (18), work_spaces char (256) static init (" "), temp fixed bin, temp1 fixed bin, a_word fixed bin based; /* A word used in creating */ /* acc string definition */ dcl 1 acc aligned based (def_ptr), 2 length_of_string fixed bin (8) unaligned, 2 string char (0 refer (acc.length_of_string)) unaligned; /* Relocation information for fixed part of Class-0 definition */ /* for program's entry point */ dcl reloc_cl0_def_fixed (6) bit (5) aligned static init ("10101"b, "10101"b, "10000"b, "00000"b, "10101"b, "10101"b); /* procedure called. */ dcl cobol_arg_descriptor$type9 entry (ptr, bit (36), fixed bin), cobol_pool entry (char (*), fixed bin, fixed bin), cobol_reloc entry (ptr, fixed bin, fixed bin), signal_ entry (char (*), ptr, ptr); dcl 1 def_ovfl_error aligned static, 2 my_name char (32) init ("cobol_def_util"), 2 message_len fixed bin init (35), 2 message char (35) init ("Definition Section length exceeded!"); declare 1 oprnd_ovfl static aligned, 2 gen_name char (32) init ("cobol_def_util"), 2 message_len fixed bin aligned init (26), 2 message char (26) aligned init ("USING operands exceed 127!"); /***** 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_entry_seq; %include cobol_in_token; %include cobol_; %include cobol_definitions; %include cobol_fixed_common; %include cobol_ext_; end cobol_def_util;  cobol_delete_gen.pl1 05/24/89 1040.3rew 05/24/89 0830.2 80217 /****^ *********************************************************** * * * 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_delete_gen.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 03/18/81 by FCH, [4.4-1], set pr1 to loc of key */ /* Modified on 06/27/79 by FCH, [4.0-1], not option added for debug */ /* Modified on 11/13/78 by FCH, [3.0-1], alt rec keys added */ /* Modified since Version 3.0 */ /* format: style3 */ cobol_delete_gen: proc (mp_ptr, passed_tag); dcl passed_tag fixed bin; /* for in-line error handling */ dcl ptag fixed bin; dcl mp_ptr ptr; dcl 1 mp based (mp_ptr), 2 n fixed bin, /* always 3 */ 2 pt1 ptr, /* pts to type1 token for DELETE */ 2 pt2 ptr, /* pts to type12 token for the file */ 2 pt3 ptr; /* pts to type19 token (eos) */ dcl 1 args, 2 entryno fixed bin, 2 arglist_off fixed bin, 2 stacktemp_off fixed bin, 2 n fixed bin, 2 arg (4), 3 pt ptr, 3 type fixed bin, 3 off1 fixed bin, 3 off2 fixed bin, 3 value bit (18) unal, 3 indirect bit (1) unal, 3 overlay bit (1) unal, 3 repeat_nogen bit (1) unal, 3 regsw bit (1) unal, 3 regno bit (3) unal; dcl argb (4) bit (216) based (addr (args.arg (1))); dcl text (0:100000) bit (36) based (cobol_$text_base_ptr); dcl ft_ptr ptr; dcl fkey_ptr ptr; dcl name_ptr ptr; dcl arg_ptr ptr; dcl ioerror_ptr ptr; /* [3.0-1] */ declare alt_sw bit (1); dcl delete_tag fixed bin; dcl unopen_error_tag fixed bin; dcl stoff fixed bin; dcl aloff fixed bin; dcl size fixed bin; dcl reclen_off fixed bin; dcl buf_off fixed bin; dcl ntag fixed bin; /*************************************/ /*************************************/ /* INITIALIZATION */ start: rw_ptr = mp.pt1; eos_ptr = mp.pt3; ioerror_ptr = addr (ioerror); ioerror.cobol_code = 0; ioerror.type1_ptr = mp.pt1; ioerror.is_tag = 0; ioerror.mode = 0; if end_stmt.b = "1"b then do; /* in-line error coding follows */ ioerror.is_tag = cobol_$next_tag; /* to be defined at end of generated code for WRITE */ ptag, passed_tag = cobol_$next_tag + 1; /* to be defined by gen driver at end of in-line coding */ ioerror.ns_tag = ptag; cobol_$next_tag = cobol_$next_tag + 2; end; else do; ioerror.is_tag = 0; ptag = 0; ioerror.ns_tag = cobol_$next_tag; /* to be defined at end of generated code */ cobol_$next_tag = cobol_$next_tag + 1; end; arg_ptr = addr (args); call cobol_read_ft (mp.pt2 -> fd_token.file_no, ft_ptr); call cobol_alloc$stack (52, 2, aloff); /* enough for 13 words - aloff is a wd offset */ args.arglist_off = aloff; reclen_off = aloff + 12; /*************************************/ /* START CODE GENERATION */ start_codegen: /* MAKE SURE FILE IS OPEN */ ioerror.retry_tag = cobol_$next_tag; unopen_error_tag = cobol_$next_tag + 1; cobol_$next_tag = cobol_$next_tag + 2; call cobol_define_tag (ioerror.retry_tag); call cobol_set_fsbptr (ft_ptr); /* OPERATOR56(init_delete) */ call cobol_call_op (56, unopen_error_tag); /* INT_DELETE_OP */ call cobol_gen_ioerror (ft_ptr, ioerror_ptr); call cobol_define_tag (unopen_error_tag); /* [3.0-1] */ alt_sw = file_table.organization = 3 /* ind */ /* [3.0-1] */ & /* [3.0-1] */ file_table.alternate_keys ^= 0; if file_table.access < 2 then do; /* sequential access */ ntag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_io_util$bypass_seqerror (ntag); call cobol_ioop_util$set_x5 (delete_seq_errno); /* OPERATOR54(delete_error) */ call cobol_call_op (54, ntag); /* ERROR_OP */ call cobol_gen_ioerror (ft_ptr, ioerror_ptr); call cobol_define_tag (ntag); call cobol_io_util$move_direct ("001"b, fsb_keylen_sw, 4, 1, ""b); /* zero the switch */ call cobol_set_fsbptr (ft_ptr); call del_op; end; else do; /* random or dynamic access */ call cobol_read_rand (1, file_table.r_key_info, fkey_ptr); addr (fkey_type9.file_key_info) -> file_key_desc = file_key.desc; mpout.pt1 = mp.pt1; mpout.pt2 = addr (fkey_type9); if file_table.organization = 2 then do; /* relative */ mpout.pt3 = addr (num_type9); size, num_type9.size, num_type9.places_left = 16; num_type9.seg = 5001; /* from PR1 */ num_type9.off = file_table.fsb.off + fsb_key; end; else do; /* indexed */ if file_table.access = 3 & (file_table.external | file_table.open_out) then do; ntag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_io_util$bypass_mode_error (ntag, "11"b); /* must prevent deletes in output mode */ call cobol_ioop_util$set_x5 (output_errno); /* OPERATOR54(delete_error) */ call cobol_call_op (54, ntag); /* ERROR_OP */ call cobol_gen_ioerror (ft_ptr, ioerror_ptr); call cobol_define_tag (ntag); call cobol_set_fsbptr (ft_ptr); end; mpout.pt3 = addr (alpha_type9); size, alpha_type9.size = fkey_type9.size; alpha_type9.seg = 5001; /* from pr1 */ alpha_type9.off = file_table.fsb.off + fsb_key; end; /* read key */ if ^alt_sw & file_table.access = 3 & file_table.read_next then do; call cobol_alloc$stack (260, 2, stoff); /* area known as TEMP read key area */ call cobol_ioop_util$lda_du (stoff); ntag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_call_op (55, ntag);/* OPERATOR55(read_key) */ call cobol_gen_ioerror (ft_ptr, ioerror_ptr); call cobol_define_tag (ntag); mpout.pt4 = addr (type19); call cobol_set_fsbptr (ft_ptr); call cobol_move_gen (addr (mpout)); call cobol_io_util$move_direct ("001"b, fsb_keylen_sw, 4, 1, substr (unspec (size), 19, 18)) ; ntag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_ioop_util$lda_du (stoff); call cobol_ioop_util$set_icode; call cobol_call_op (57, ntag);/* OPERATOR57(special_delete) */ call cobol_gen_ioerror (ft_ptr, ioerror_ptr); call cobol_define_tag (ntag); end; else do; ntag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; mpout.pt4 = addr (type19); call cobol_set_fsbptr (ft_ptr); call cobol_move_gen (addr (mpout)); call cobol_io_util$move_direct ("001"b, fsb_keylen_sw, 4, 1, substr (unspec (size), 19, 18)) ; /* [3.0-1] */ if alt_sw /*[4.4-1]*/ then do; call cobol_io_util$fsb_key_loc (6); /* epp1 pr1|6 */ /* [3.0-1] */ call cobol_io_util$file_desc (file_table.file_desc_1_offset); /* [3.0-1] */ call cobol_call_op (85, 0); /* OPERATOR85(alt_special_delete) */ /* [3.0-1] */ call cobol_set_fsbptr (ft_ptr); /* [3.01] */ end; call cobol_ioop_util$set_icode; call cobol_call_op (41, ntag);/* OPERATOR41(seek_key) */ call cobol_gen_ioerror (ft_ptr, ioerror_ptr); call cobol_define_tag (ntag); call del_op; end; end; /* DELETE THE RECORD */ call cobol_reg_manager$after_op (4095 + ioerror.cobol_code); /*[4.0-1]*/ if end_stmt.f = "01"b /*[4.0-1]*/ then passed_tag = ioerror.is_tag; /*[4.0-1]*/ else call cobol_gen_ioerror$finish_up (ft_ptr, ioerror_ptr); return; del_op: proc; /* [3.0-1] */ if alt_sw /* [3.0-1] */ then do; ntag = cobol_$next_tag; /* [3.0-1] */ cobol_$next_tag = cobol_$next_tag + 1; /* [3.0-1] */ call cobol_call_op (87, ntag); /* OPERATOR87(alt_rew_del,ntag) */ /* [3.0-1] */ call cobol_gen_ioerror (ft_ptr, ioerror_ptr); /* [3.0-1] */ call cobol_define_tag (ntag); /* [3.0-1] */ call cobol_set_fsbptr (ft_ptr); /* [3.0-1] */ end; delete_tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_set_fsbptr (ft_ptr); call cobol_call_op (53, delete_tag); /* OPERATOR53(delete) */ call cobol_gen_ioerror (ft_ptr, ioerror_ptr); call cobol_define_tag (delete_tag); /* [3.0-1] */ if alt_sw then call cobol_call_op (86, 0); /* OPERTATOR86(alt_delete) */ end; %include cobol_delete_gen_info; %include cobol_delete_gen_data; end cobol_delete_gen;  cobol_disable_gen.pl1 05/24/89 1040.3rew 05/24/89 0830.2 50472 /****^ *********************************************************** * * * 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_disable_gen.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 10/02/77 by Bob Chang to fix the bug for mcs_icdp. */ /* Modified on 03/25/77 by Bob Chang to implement communication disable verb. */ /* Created as a stub on 11/18/76 by ORN */ /* format: style3 */ cobol_disable_gen: proc (in_token_ptr); /* Declaration for static data. */ dcl 1 pr_struc static, 2 what_ptr fixed bin init (2), 2 pointer_no bit (3), 2 lock fixed bin init (0), 2 switch fixed bin init (0); dcl 1 alpha_type9 static, 2 header (4) fixed bin init (112, 0, 0, 9), 2 repl_ptr (2) ptr init ((2) null ()), 2 fill1 bit (108) init (""b), 2 file_key_info, 3 fb1 (3) fixed bin init (0, 0, 0), 3 size fixed bin init (0), 3 fb2 (2) fixed bin init (0, 0), 3 flags1 bit (36) init ("000000100100000000010000000100000000"b), 3 flags2 bit (36) init (""b), 3 seg fixed bin init (0), 3 off fixed bin, 2 fill2 (7) fixed bin init (0, 0, 0, 0, 0, 0, 0); dcl inst_seq (12) bit (18) unaligned static init ("110000000000000000"b, "010101010001000000"b, /* spri2 pr6|offset */ "000000000000000000"b, "010011101000000111"b, /* lda 0,dl */ "110000000000000000"b, "111101101001000000"b, /* sta pr6|offset */ "110000000000000000"b, "100101000001000000"b, /* stz pr6|offset */ "110000000000000000"b, "010011100001000000"b, /* szn pr6|offset */ "000000000000000000"b, "110000000000000100"b); /* tze 0,ic */ /* Automatic data */ dcl conoff fixed bin, /* PARAMETER for NO DATA statement */ stoff fixed bin, dn_ptr ptr, temp fixed bin; /* External procedure */ dcl cobol_call_op entry (fixed bin, fixed bin), cobol_pool entry (char (*), fixed bin, fixed bin), cobol_pointer_register$priority entry (fixed bin, fixed bin, bit (3)), cobol_emit entry (ptr, ptr, fixed bin), cobol_define_tag entry (fixed bin), cobol_make_tagref entry (fixed bin, fixed bin, ptr), cobol_set_pr entry (ptr, ptr), cobol_reg_manager$after_op entry (fixed bin), cobol_get_size entry (ptr, fixed bin, fixed bin); start: /* Generate epp2 instruction for communication token. */ cdtoken_ptr = in_token.token_ptr (2); alpha_type9.seg = cdtoken.cd_seg; eos_ptr = in_token.token_ptr (in_token.n); if ^end_stmt.b then alpha_type9.off = cdtoken.cd_off - 60; else alpha_type9.off = cdtoken.cd_off - 20; call cobol_set_pr (addr (pr_struc), addr (alpha_type9)); /* Allocate 12 words in stack frame for parameters */ stoff = 74; /* Communication stack frame from pr6|74 */ /* Store cd_token address. */ substr (inst_seq (1), 4, 15) = substr (unspec (stoff), 22, 15); call cobol_emit (addr (inst_seq (1)), null, 1); /* Set up parameter for message type. */ eos_ptr = in_token.token_ptr (in_token.n); if end_stmt.b | end_stmt.c then do; inst_seq (3) = "000000000000000001"b; call cobol_emit (addr (inst_seq (3)), null, 1); end; temp = stoff + 5; if end_stmt.b then do; substr (inst_seq (5), 4, 15) = substr (unspec (temp), 22, 15); call cobol_emit (addr (inst_seq (5)), null, 1); end; else do; substr (inst_seq (7), 4, 15) = substr (unspec (temp), 22, 15); call cobol_emit (addr (inst_seq (7)), null, 1); end; temp = stoff + 6; if end_stmt.c then do; substr (inst_seq (5), 4, 15) = substr (unspec (temp), 22, 15); call cobol_emit (addr (inst_seq (5)), null, 1); end; else do; substr (inst_seq (7), 4, 15) = substr (unspec (temp), 22, 15); call cobol_emit (addr (inst_seq (7)), null, 1); end; /* Generate epp2 instruction for receiving data item. */ dn_ptr = in_token.token_ptr (3); if data_name.type = 3 then do; alit_ptr = dn_ptr; alpha_type9.seg = 3000; alpha_type9.size = alphanum_lit.lit_size; call cobol_pool (alphanum_lit.string, 1, conoff); alpha_type9.off = conoff * 4; dn_ptr = addr (alpha_type9); end; call cobol_set_pr (addr (pr_struc), dn_ptr); /* Store into stack frame. */ temp = stoff + 2; substr (inst_seq (1), 4, 15) = substr (unspec (temp), 22, 15); call cobol_emit (addr (inst_seq (1)), null, 1); /* Set up the size of the data token. */ temp = stoff + 4; call cobol_get_size (dn_ptr, temp, 0); /* Call cobol_operators_ */ call cobol_call_op (75, 0); call cobol_reg_manager$after_op (75); exit: return; /***** Declaration for builtin function *****/ dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index) builtin; /***** End of declaration for builtin function *****/ %include cobol_in_token; %include cobol_; %include cobol_type19; %include cobol_type9; %include cobol_type13; %include cobol_type3; end cobol_disable_gen;  cobol_display_gen.pl1 05/24/89 1040.3rew 05/24/89 0830.2 64197 /****^ *********************************************************** * * * 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_display_gen.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 5/18/76 by George Mercuri for changes to error interface. */ /* Modified on 5/10/76 by George Mercuri for changes to error handling. */ /* Modified on 5/5/76 by George Mercuri for error handling techniques. */ /* Modified on 4/28/76 by G. Mercuri change code for new cobol_operators_. */ /* format: style3 */ cobol_display_gen: proc (mp_ptr); dcl stoff fixed bin init (0); dcl mp_ptr ptr; dcl 1 mp based (mp_ptr), 2 n fixed bin, 2 pt (0 refer (mp.n)) ptr; dcl 1 args static, 2 entryno fixed bin init (6), /* put_chars */ 2 arglist_off fixed bin, 2 stacktemp_off fixed bin init (44), 2 n fixed bin init (4), 2 arg1, 3 pt ptr init (null ()), /* not meaningful */ 3 type fixed bin init (4), /* entry variable */ 3 seg fixed bin, /* set to lp|off of link to iox_$user_output or $error_output*/ 3 off fixed bin init (0), 3 value bit (18) unaligned, /* not meaningful */ 3 indirect bit (1) unaligned init ("0"b), 3 overlay bit (1) unaligned init ("0"b), 3 repeat_nogen bit (1) unaligned init ("0"b), 2 arg2, 3 pt ptr, /* set to pt to type 9 token or varying literal string */ 3 type fixed bin init (5), /* variable */ 3 seg fixed bin init (0), 3 off fixed bin init (42), /* allocate pointer to data at sp|42 */ 3 value bit (18) unaligned, /* set to immed value when type = 2 */ 3 indirect bit (1) unaligned init ("1"b),/* pass a ptr to the data rather than the data */ 3 overlay bit (1) unaligned init ("0"b), 3 repeat_nogen bit (1) unaligned init ("0"b), 2 arg3, 3 pt ptr init (null ()), /* not meaningful */ 3 type fixed bin init (3), 3 seg fixed bin init (80), /* allocate length at sp|80 */ 3 off fixed bin, /* not meaningful */ 3 value bit (18) unaligned, /* not meaningful */ 3 indirect bit (1) unaligned init ("0"b), 3 overlay bit (1) unaligned init ("0"b), 3 repeat_nogen bit (1) unaligned init ("0"b), 2 arg4, 3 pt ptr init (null ()), /* not meaningful */ 3 type fixed bin init (3), 3 seg fixed bin init (40), /* allocate multics code at sp|40 */ 3 off fixed bin, /* not meaningful */ 3 value bit (18) unaligned, /* not meaningful */ 3 indirect bit (1) unaligned init ("0"b), 3 overlay bit (1) unaligned init ("0"b), 3 repeat_nogen bit (1) unaligned init ("0"b); dcl 1 s auto, 2 n fixed bin, 2 tag fixed bin, 2 rtp ptr, 2 ptp ptr, 2 str (2:257), 3 stp ptr, 3 dtp ptr; dcl 1 nl_token static, 2 size fixed bin init (25), 2 line fixed bin init (0), 2 column fixed bin init (0), 2 type fixed bin init (3), 2 lit_type bit (1) init ("0"b), 2 all_lit bit (1) init ("0"b), 2 filler1 bit (6) init (""b), 2 lit_size fixed bin init (1), 2 string char (1) init (" "); dcl 1 rtype9 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 ("010000100100000000010000000100000000"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 stream char (20); dcl i fixed bin; dcl tflen fixed bin; dcl tvlen fixed bin; dcl errorno fixed bin; dcl lineno fixed bin; dcl tagno fixed bin; dcl tagno1 fixed bin; dcl argptr ptr static; dcl dn_ptr ptr; dcl cobol_call_op entry (fixed bin, fixed bin); dcl cobol_reg_manager$after_op entry (fixed bin); dcl cobol_make_tagref entry (fixed bin, fixed bin, ptr); dcl cobol_define_tag entry (fixed bin); dcl cobol_ioop_util entry (fixed bin); dcl cobol_string entry (ptr); dcl cobol_io_util$move_direct entry (bit (3) aligned, fixed bin, fixed bin, fixed bin, bit (18) aligned); dcl cobol_alloc$stack entry (fixed bin, fixed bin, fixed bin); dcl cobol_emit entry (ptr, ptr, fixed bin); /*************************************/ start: tagno = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_define_tag (tagno); rtype9.size = 0; /* signal of no limit to cobol_string */ if mp.pt (mp.n) -> end_stmt.a = "000"b then do; /* iox_$error_output */ errorno = 4; end; else do; /* iox_$user_output */ errorno = 3; end; lineno = mp.pt (1) -> reserved_word.line; s.n = mp.n - 1; s.tag = 0; s.rtp = addr (rtype9); s.ptp = null (); tflen, tvlen = 0; do i = 2 to mp.n - 1; dn_ptr = mp.pt (i); if data_name.type = 9 then do; if data_name.variable_length then tvlen = tvlen + data_name.item_length; else tflen = tflen + data_name.item_length; end; else if data_name.type = 2 then tflen = tflen + dn_ptr -> numeric_lit.places; else if data_name.type = 3 then tflen = tflen + dn_ptr -> alphanum_lit.lit_size; else tflen = tflen + 1; /* figurative constant (type 1) */ s.stp (i) = dn_ptr; s.dtp (i) = null (); end; s.stp (mp.n) = addr (nl_token); s.dtp (mp.n) = null (); tflen = tflen + 1; call cobol_io_util$move_direct ("110"b, 320, 4, 1, substr (unspec (tflen), 19, 18)); call cobol_alloc$stack (tflen + tvlen, 2, stoff); /* for arg list + combined max item length */ rtype9.off = stoff * 4; /* next available location (will be reserved later) */ call cobol_string (addr (s)); arg2.pt = addr (rtype9); call cobol_ioop_util (stoff); if errorno = 3 then call cobol_call_op (26, tagno); /*5/18/76*/ else call cobol_call_op (28, tagno); /*5/18/76*/ call cobol_reg_manager$after_op (4095 + errorno); return; /*************************************/ /***** Declaration for builtin function *****/ dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index) builtin; /***** End of declaration for builtin function *****/ %include cobol_type1; %include cobol_type2; %include cobol_type3; %include cobol_type9; %include cobol_type19; %include cobol_; end cobol_display_gen;  cobol_display_text.pl1 05/24/89 1040.3rew 05/24/89 0830.1 159237 /****^ *********************************************************** * * * 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_display_text.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 08/18/83 by FCH, [5.2-1], entry trace added */ /* Modified since Version 5.0 */ /* Program to display output text produced by pl/1 and Fortran. A reduced version of display_text. Numbers in the disassembled instruction are decimal. The offset and the instruction as it apears in core are in octal. The numbers are really in octal, despite comment. Modified by JRDavis 19 Mar 80 to not call binoct (which was transfer vector to pl1 compiler lang_util_ MCR 4422 */ /* format: style3 */ cobol_display_text: proc (t_pt, arg_number, output_switch); dcl t_pt ptr, /* points at text base */ arg_number fixed bin, /* max. no. of words to print */ output_switch char (*) aligned, /* switch name for printing disassembled line */ arg_offset fixed bin (18); /* real offset to be printed instead of t_pt */ dcl number fixed bin; /* no. of words to print */ dcl desc_type fixed bin; /* descriptor type: 0 = alpha, 1 = bit, 2 = numeric */ dcl comment char (50) var; dcl op_name char (32) aligned; dcl (p, pt) ptr, (no_to_print, j, k, m, op_index, irand, nrands, ndesc) fixed bin, (fract_offset, offset, scale) fixed bin (18), (double, eis, eis_desc, need_comma, ext_base, has_ic, decimal) bit (1), ht char (1) int static aligned init (" "), /* tab */ htht char (2) int static aligned init (" "), /* two tabs */ cstring char (12), op_code char (5), tag char (3), line char (256), buff char (12) varying, pl1_operators_$operator_table fixed bin ext; dcl repeat_inst bit (1); /* ON for rpd, rpt, rpl */ dcl print_instr bit (1); /* 1= print instr; 0= return formatted string */ dcl real_offset_entry bit (1) unal; /* ON if instruction ptr is different from text location */ dcl real_offset fixed bin (18); /* used with $format, $offset entries */ dcl ioa_$ioa_stream ext entry options (variable); dcl ioa_$rsnnl ext entry options (variable); dcl ioa_ entry options (variable); dcl find_operator_name_ entry (char (*) aligned, ptr, char (32) aligned); dcl (addr, addrel, fixed, length, rel, string, substr) builtin; dcl 1 op_mnemonic_$op_mnemonic (0:1023) ext static aligned, 2 opcode char (6) unal, 2 dtype fixed bin (2) unal, /* 0 = alpha, 1 = bit, 2 = numeric */ 2 num_desc fixed bin (5) unal, 2 num_words fixed bin (8) unal; dcl digit (0:9) char (1) aligned int static init ("0", "1", "2", "3", "4", "5", "6", "7", "8", "9"); /*[5.2-1]*/ dcl instr char (128) varying; dcl base (0:7) char (4) aligned int static init ("pr0|", "pr1|", "pr2|", "pr3|", "pr4|", "pr5|", "pr6|", "pr7|"); dcl modifier (0:63) char (3) aligned int static init (" ", "au", "qu", "du", "ic", "al", "ql", "dl", "0", "1", "2", "3", "4", "5", "6", "7", "*", "au*", "qu*", "...", "ic*", "al*", "ql*", "...", "0*", "1*", "2*", "3*", "4*", "5*", "6*", "7*", "f", "itp", "...", "its", "sd", "scr", "f2", "f3", "ci", "i", "sc", "ad", "di", "dic", "id", "idc", "*n", "*au", "*qu", "*du", "*ic", "*al", "*ql", "*dl", "*0", "*1", "*2", "*3", "*4", "*5", "*6", "*7"); dcl word (0:1) bit (36) aligned based (p); dcl 1 instruction based (p) aligned, 2 base unaligned bit (3), 2 offset unaligned bit (15), 2 op_code unaligned bit (10), 2 inhibit unaligned bit (1), 2 ext_base unaligned bit (1), 2 tag unaligned bit (6); dcl 1 half based (p) aligned, 2 left unaligned bit (18), 2 right unaligned bit (18); dcl 1 mod_factor aligned, 2 ext_base bit (1) unal, 2 length_in_reg bit (1) unal, 2 indirect_descriptor bit (1) unal, 2 tag bit (4) unal; dcl mf (3) fixed bin (6) int static init (30, 12, 3); /* location of modification factor fields in EIS inst */ dcl 1 packed_ptr_st based aligned, 2 packed_ptr ptr unal; dcl (ebase, len_reg, ic) (3) bit (1) aligned; dcl desc_word char (8) varying; dcl desc_op (0:3) char (8) varying int static init ("desc9a", "descb", "desc9fl", "desc9ls"); dcl eis_modifier (0:15) char (3) aligned int static init ("n", "au", "qu", "du", "ic", "al", "ql", "...", "x0", "x1", "x2", "x3", "x4", "x5", "x6", "x7"); dcl bool_word (0:15) char (6) aligned int static varying init ("clear", "and", "andnot", "move", "", "", "xor", "or", "", "", "", "", "invert", "", "nand", "set"); dcl 1 descriptor based aligned, /* EIS descriptor */ 2 address bit (18) unal, 2 char bit (2) unal, 2 bit bit (4) unal, 2 length bit (12) unal; /* */ number = arg_number; print_instr = "1"b; real_offset_entry = "0"b; p = t_pt; begin: substr (line, 11, 3) = " "; eis = "0"b; irand = 0; do no_to_print = 1 to number; comment = ""; tag = " "; substr (line, 7, 2) = " "; cstring = binoct (p -> word (0)); if eis then op_index = 0; else do; op_index = fixed (p -> instruction.op_code, 10); op_code = opcode (op_index); end; if num_words (op_index) > 1 then call eis_instruction; else do; has_ic, double, repeat_inst = "0"b; eis_desc = eis & desc_word ^= "arg"; if eis_desc then call eis_descriptor; else do; substr (line, 13, 2) = " "; substr (line, 15, 6) = substr (cstring, 2, 5); substr (line, 21, 5) = substr (cstring, 7, 4); substr (line, 26, 8) = substr (cstring, 11, 2) || ht || op_code; k = 34; ext_base = p -> instruction.ext_base; if op_code = "rpd " | op_code = "rpt " | op_code = "rpl " then do; repeat_inst = "1"b; call ioa_$rsnnl ("^d", tag, j, fixed (p -> instruction.tag, 6)); offset = fixed (substr (p -> half.left, 1, 8), 8); substr (line, 14, 1) = cstring; call ioa_$rsnnl (" ^d", buff, j, offset); substr (line, k, j) = buff; k = k + j; end; else do; if num_desc (op_index) ^= 0 then tag = substr (binoct ((p -> instruction.tag)), 1, 2); else do; if p -> instruction.tag then tag = modifier (fixed (p -> instruction.tag, 6)); double = substr (op_code, 1, 2) = "df" | substr (op_code, 3, 2) = "aq" | substr (op_code, 4, 2) = "aq"; has_ic = p -> instruction.tag = "000100"b; /* IC */ end; call address; end; call set_tag; end; /* Print data referred to by self relative address: (tab) (tab) data offset = contents */ /*[5.2-1]*/ if print_instr & has_ic then do; if real_offset_entry then pt = ptr (p, real_offset + offset - irand); else pt = addrel (p, offset - irand); substr (line, k, 8) = htht || binoct (rel (pt)); k = k + 8; if substr (op_code, 1, 1) ^= "t" then do; comment = " = " || binoct (pt -> word (0)); if double then comment = comment || " " || binoct (pt -> word (1)); end; end; else if ext_base & (p -> instruction.base = "000"b) then do; /* info for pr0 only */ if op_code = "xec " then do; pt = addrel (addr (pl1_operators_$operator_table), offset); op_index = fixed (pt -> instruction.op_code, 10); if num_words (op_index) > 1 then do; /* we are executing an EIS instruction in pl1_operators_ */ call init_eis; do j = 1 to ndesc; ebase (j) = "1"b; len_reg (j) = ^decimal; ic (j) = "0"b; end; end; end; if tag ^= " " then do; call find_operator_name_ ("pl1_operators_", p, op_name); if op_name ^= " " then do; substr (line, k, 34) = htht || op_name; k = k + 34; end; end; end; if ^eis_desc & ^repeat_inst & p -> instruction.inhibit then comment = comment || " interrupt inhibit"; end; if comment ^= "" then do; j = length (comment); substr (line, k, j) = comment; k = k + j; end; if print_instr then call ioa_$ioa_stream (output_switch, "^6o ^a", fixed (rel (p), 17), substr (line, 11, k - 11)); else do; /* return string for one line only */ j = k - 11; /* save length of strjng */ k = 1; call bin_to_oct (real_offset); instr = substr (line, 1, k - 1) || substr (line, 11, j); /*[5.2-1]*/ call ioa_ ("^40x^a", instr); end; if eis then do; irand = irand + 1; if irand > nrands then do; eis = "0"b; irand = 0; end; else if irand > ndesc then op_code, desc_word = "arg"; end; p = addrel (p, 1); end; return; /* */ /* Entry point to return a formatted string with the disassembled instruction. The real offset is returned in the string. */ trace: entry (t_pt, arg_number); p = t_pt; /*[5.2-1]*/ real_offset = 0; /*[5.2-1]*/ number = arg_number; /* process one word only */ print_instr = "0"b; /* return string instead */ real_offset_entry = "1"b; go to begin; bin_to_oct: proc (number); dcl (m, number) fixed bin (18); call ioa_$rsnnl ("^d", buff, m, number); substr (line, k, m) = buff; k = k + m; end bin_to_oct; init_eis: proc; eis = "1"b; nrands = num_words (op_index) - 1; ndesc = num_desc (op_index); decimal = dtype (op_index) = 2; desc_word = desc_op (dtype (op_index)); desc_type = dtype (op_index); irand = 0; end init_eis; /* */ eis_instruction: proc; call init_eis; substr (line, 13, 4) = substr (cstring, 1, 3); substr (line, 17, 4) = substr (cstring, 4, 3); substr (line, 21, 4) = substr (cstring, 7, 3); substr (line, 25, 3) = substr (cstring, 10, 3); substr (line, 28, 1) = ht; substr (line, 29, 5) = op_code; substr (line, 34, 1) = ht; k = 35; do j = 1 to ndesc; string (mod_factor) = substr (p -> word (0), mf (j), 7); ebase (j) = mod_factor.ext_base; len_reg (j) = mod_factor.length_in_reg; substr (line, k, 1) = "("; k = k + 1; need_comma = "0"b; if ebase (j) then do; substr (line, k, 2) = "pr"; k = k + 2; need_comma = "1"b; end; if len_reg (j) then do; if need_comma then do; substr (line, k, 1) = ","; k = k + 1; end; substr (line, k, 2) = "rl"; k = k + 2; need_comma = "1"b; end; if mod_factor.tag then do; if need_comma then do; substr (line, k, 1) = ","; k = k + 1; end; ic (j) = mod_factor.tag = "0100"b; /* IC */ substr (line, k, 2) = eis_modifier (fixed (mod_factor.tag, 4)); k = k + 2; end; else ic (j) = "0"b; substr (line, k, 2) = "),"; k = k + 2; end; if substr (p -> word (0), 10, 1) then do; substr (line, k, 12) = "enablefault,"; k = k + 12; end; if desc_word = "desc9a" then if ndesc < 3 then do; if substr (op_code, 1, 2) ^= "sc" then substr (line, k, 5) = "fill("; else substr (line, k, 5) = "mask("; k = k + 5; substr (line, k, 3) = substr (cstring, 1, 3); k = k + 3; substr (line, k, 1) = ")"; k = k + 1; end; else k = k - 1; else if desc_word = "descb" then do; substr (line, k, 7) = "fill(" || digit (fixed (substr (p -> word (0), 1, 1), 1)) || ")"; /* fill(N) */ k = k + 7; if op_code ^= "cmpb " then do; substr (line, k, 6) = ",bool("; k = k + 6; j = fixed (substr (p -> word (0), 6, 4), 4); m = length (bool_word (j)); if m > 0 then do; substr (line, k, m) = bool_word (j); k = k + m; end; else do; substr (line, k, 1) = digit (fixed (substr (p -> word (0), 6, 1), 1)); substr (line, k + 1, 1) = digit (fixed (substr (p -> word (0), 7, 3), 3)); k = k + 2; end; substr (line, k, 1) = ")"; k = k + 1; end; end; else if substr (p -> word (0), 11, 1) then do; substr (line, k, 5) = "round"; k = k + 5; end; else k = k - 1; return; end eis_instruction; /* */ eis_descriptor: proc; dcl len fixed bin (18); dcl type fixed bin; /* descriptor type */ dcl 1 n_desc aligned based (p), 2 y bit (18) unal, /* address field */ 2 CN bit (3) unal, /* character position */ 2 TN bit (1) unal, /* type 0 = 9bit; 1 = 4 bit */ 2 S bit (2) unal, /* sign type 0 = fl, 1 = ls, 2 = ts, 3 = ns */ 2 SF bit (6) unal, /* scale factor */ 2 N bit (6) unal; /* length */ dcl 1 b_desc aligned based (p), /* bit descriptor */ 2 y bit (18) unal, /* address field */ 2 c bit (2) unal, /* 9 bit offset */ 2 b bit (4) unal, /* bit offset */ 2 N bit (12) unal; /* length */ dcl 1 a_desc aligned based (p), /* alpha-numeric descriptor */ 2 y bit (18) unal, /* address field */ 2 CN bit (3) unal, /* character offset */ 2 TA bit (2) unal, 2 pad bit (1) unal, /* always zero */ 2 N bit (12) unal; /* length */ dcl table_n_S (0:3) char (2) int static init ("fl", "ls", "ts", "ns"); dcl table_a_TA (0:3) char (1) int static init ("9", "6", "4", "?"); substr (line, 13, 2) = " "; substr (line, 15, 6) = substr (cstring, 2, 5); substr (line, 21, 3) = substr (cstring, 7, 2); substr (line, 24, 4) = substr (cstring, 9, 4); substr (line, 28, 1) = ht; ext_base = ebase (irand); has_ic = ic (irand); type = desc_type; if op_code = "btd" & irand = 1 then type = 0; else if op_code = "dtb" | op_code = "mvne" then if irand > 1 then type = 0; if type = 0 then do; /* alpha-nummeric descriptor */ desc_word = "desc" || table_a_TA (fixed (a_desc.TA, 2)) || "a"; if a_desc.TA = "00"b then fract_offset = fixed (substr (a_desc.CN, 1, 2), 2); else fract_offset = fixed (a_desc.CN, 3); len = fixed (a_desc.N, 12); end; else if type = 1 then do; /* bit descriptor */ desc_word = "descb"; len = fixed (b_desc.N, 12); fract_offset = fixed (b_desc.c, 2) * 9 + fixed (b_desc.b, 4); end; else do; /* numeric descriptor */ if n_desc.TN then do; desc_word = "desc4"; fract_offset = fixed (n_desc.CN, 3); end; else do; desc_word = "desc9"; fract_offset = fixed (substr (n_desc.CN, 1, 2), 2); end; desc_word = desc_word || table_n_S (fixed (n_desc.S, 2)); len = fixed (n_desc.N, 6); if n_desc.S then do; /* for S = 00 there is no scale factor */ scale = fixed (n_desc.SF, 6); if scale > 32 then scale = scale - 64; end; end; /* desc_word address(fract_offset),tag,length,scale */ k = length (desc_word); substr (line, 29, k) = desc_word; k = k + 29; call address; if fract_offset ^= 0 then do; call ioa_$rsnnl ("(^d)", buff, j, fract_offset); substr (line, k, j) = buff; k = k + j; end; if len_reg (irand) then do; /* print register which contains length */ tag = eis_modifier (fixed (substr (p -> descriptor.length, 9, 4), 4)); call set_tag; end; else do; /* print length as given */ substr (line, k, 1) = ","; k = k + 1; call bin_to_oct (len); end; if type = 2 then if n_desc.S then do; /* scale factor for numeric only */ substr (line, k, 1) = ","; k = k + 1; call bin_to_oct (scale); end; return; end eis_descriptor; /* */ /* This procedure disassembles the address portion. It adds: tab [prN|] offset It also sets the first octal digit so a blank will separate the register from the rest of the address field. cstring The octal representation of the word. ext_base ON if the address uses a register. */ address: proc; substr (line, k, 1) = ht; k = k + 1; if ext_base then do; substr (line, k, 4) = base (fixed (p -> instruction.base, 3)); offset = fixed (p -> instruction.offset, 15); if offset > 16384 then offset = offset - 32768; k = k + 4; substr (line, 13, 1) = cstring; end; else do; offset = fixed (p -> half.left, 18); if offset > 131072 then if tag ^= "du " & tag ^= "dl " then offset = offset - 262144; /* 2's comp */ substr (line, 14, 1) = cstring; end; call bin_to_oct (offset); end address; /* This procedure sets the tag in the instruction line. */ set_tag: proc; if tag ^= " " then do; substr (line, k, 4) = "," || tag; k = k + 2; if substr (line, k, 1) ^= " " then k = k + 1; if substr (line, k, 1) ^= " " then k = k + 1; end; return; end set_tag; binoct: proc (bits) returns (char (12) aligned); dcl bits bit (*) aligned parameter; dcl c12 char (12) aligned; call ioa_$rsnnl ("^12.3b", c12, j, bits); return (c12); end binoct; end;  cobol_display_util.pl1 05/24/89 1040.3rew 05/24/89 0830.2 22869 /****^ *********************************************************** * * * 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_display_util.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 10/21/82 by FCH, [5.1-1], incorrect dimension changed */ /* 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_display_util: proc (erroroff, stoff); disp: entry (erroroff, stoff); dcl erroroff fixed bin; /* erroroff 10 =user_output, 11 =error_output. */ dcl stoff fixed bin; /* [5.1-1] */ dcl disp_instr (2) bit (36) static init ("110000000000000000011111001101000000"b, /* epp5 pr6| */ "100000000000110000011101001101000000"b); /* epp1 pr4|offset=60,62 */ dcl disp_reloc (4) bit (5) aligned static init (""b, ""b, ""b, ""b); dcl stz_instr (1) bit (36) static init ("110000000000101100100101000001000000"b); /* stz pr6|54 */ dcl cobol_emit entry (ptr, ptr, fixed bin); /***************************************/ start: substr (disp_instr (1), 4, 15) = substr (unspec (stoff), 22, 15); substr (disp_instr (2), 4, 15) = substr (unspec (erroroff), 22, 15); call cobol_emit (addr (disp_instr), addr (disp_reloc), 2); return; /***************************************/ set_stz: entry; call cobol_emit (addr (stz_instr), null (), 1); 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 *****/ end cobol_display_util;  cobol_divide_bin_gen.pl1 05/24/89 1040.3rew 05/24/89 0830.2 158544 /****^ *********************************************************** * * * 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_divide_bin_gen.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 06/29/79 by FCH, [4.0-1], not option added for debug */ /* Modified since Version 4.0 */ /*{*/ /* format: style3 */ cobol_divide_bin_gen: proc (in_token_ptr, next_stmt_tag); /* This procedure generates code for the divide 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 divide 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_make_bin_const ext entry (ptr, ptr, fixed bin); dcl cobol_short_to_longbin$register ext entry (ptr, ptr); dcl cobol_load_register ext entry (ptr, ptr); 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); dcl cobol_make_reg_token ext entry (ptr, bit (4)); /* 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 tze_inst bit (36) int static init ("000000000000000000110000000000000000"b); /* tze 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 divisor_token_ptr ptr; dcl dividend_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; dcl last_target_index fixed bin; /*************************************/ start: /* 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_divide; else call format2_5_divide; /*************************************/ format1_divide: proc; /* This internal procedure generates code using the hardware registers ( A and Q ) for format 1 divide statements. */ receive_count = end_stmt.e; divisor_token_ptr = in_token.token_ptr (2); /* Check for zero divisor if on size clause was present in the divide stmt. */ if ose_flag then call zero_divide_check (divisor_token_ptr, imperative_stmt_tag); if (divisor_token_ptr -> data_name.type = rtc_dataname & divisor_token_ptr -> data_name.bin_18) then do; /* Divisor is short binary. */ /* Convert from short binary to long binary into a temp. */ temp_ptr = null (); call cobol_short_to_longbin$temp (divisor_token_ptr, temp_ptr); divisor_token_ptr = temp_ptr; end; /* Divisior is a short binary. */ else if (divisor_token_ptr -> data_name.type = rtc_dataname & receive_count > 1) then do; /* Divisor is long binary, and more than one dividend/receiving field. */ /* Generate code to store the divisor into a temp, because if one of the dividends is the divisor (i.e. DIVIDE A INTO A B C) then the original divisor 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 divisor into the temporary. */ call cobol_store_binary (divisor_token_ptr, temp_ptr, call_again); /* Release the register that was used in storing the divisor. */ register_struc.reg_no = divisor_token_ptr -> cobol_type100.register; call cobol_register$release (addr (register_struc)); divisor_token_ptr = temp_ptr; end; /* Divisor is long binary, and move than one dividend/receiving field. */ /* Generate code to divide the divisor into each dividend/receiving field. */ do ix = 3 to in_token.n - 1; /* Do all the divides. */ call cobol_multiply2_binary (in_token.token_ptr (ix), divisor_token_ptr, result_token_ptr, 2); /* Make a register token that describes the result of the divide. */ result_token_ptr = null (); call cobol_make_reg_token (result_token_ptr, "0010"b /* Q */); 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. */ 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. */ /* Release the register that contains the result of the divide. */ register_struc.reg_no = result_token_ptr -> cobol_type100.register; call cobol_register$release (addr (register_struc)); /* Release the A register, which is locked by the multiply2 procedure. */ register_struc.reg_no = "0001"b; /* A */ call cobol_register$release (addr (register_struc)); end; /* Do all the divides. */ if ose_flag then do; /* On size error clause was present. */ /*[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_divide; /*************************************/ format2_5_divide: proc; /* This internal procedure generates code using the hardware registers (A and Q) for format 2,3,4, and 5 divide statements. */ if (end_stmt.a = "001"b | end_stmt.a = "011"b) then do; /* Format 2 or Format 4 divide. */ divisor_token_ptr = in_token.token_ptr (2); dividend_token_ptr = in_token.token_ptr (3); end; /* Format 2 or Format 4 divide. */ else do; /* Must be Format 3 or Format 5 divide. */ divisor_token_ptr = in_token.token_ptr (3); dividend_token_ptr = in_token.token_ptr (2); end; /* Must be Format 3 or Format 5 divide. */ /* Check for zero divisor if on size clause was present. */ if ose_flag then call zero_divide_check (divisor_token_ptr, imperative_stmt_tag); /* Generate code to do the division. */ call cobol_multiply2_binary (dividend_token_ptr, divisor_token_ptr, result_token_ptr, 2 /*divide */); if (end_stmt.a = "001"b | end_stmt.a = "010"b) then do; /* Format 2 or Format 3 divide. */ /* Release the A register (which is locked during the divide) */ register_struc.reg_no = "0001"b; /* A */ call cobol_register$release (addr (register_struc)); last_target_index = in_token.n - 1; end; /* Format 2 or Format 3 divide. */ else do; /* Format 4 or Format 5 divide. */ /* Build a register token for the A register, which contains the remainder. */ remainder_token_ptr = null (); call cobol_make_reg_token (remainder_token_ptr, "0001"b /*A*/); last_target_index = in_token.n - 2; end; /* Format 4 or Format 5 divide. */ /* Generate code to store the quotient 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; do ix = 4 to last_target_index; /* Store quotient into all long binary targets. */ if in_token.token_ptr (ix) -> data_name.bin_18 then skipped_some = "1"b; else call cobol_store_binary (result_token_ptr, in_token.token_ptr (ix), call_again); end; /* Store quotient into all long binary targets. */ if skipped_some then do; /* Store the quotient into all short binary receiving fields. */ if ose_flag then call cobol_fofl_mask$on; do ix = 4 to last_target_index; /* 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 quotient into all short binary receiving fields. */ if (end_stmt.a = "011"b | end_stmt.a = "100"b) then do; /* Format 4 or Format 5 divide */ /* Store the remainder (now in the a register) into the cobol target. */ if ose_flag & in_token.token_ptr (in_token.n - 1) -> data_name.bin_18 then call cobol_fofl_mask$on; /* Turn on the fixed overflow mask. */ call cobol_store_binary (remainder_token_ptr, in_token.token_ptr (in_token.n - 1), call_again); if call_again then do; /* Remainder has been stored into a temp in an attempt to force overflow. */ if ose_flag then do; /* On size clause was present. */ /* 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 clause was present. */ /* Generate code to store the temp into the target. */ call cobol_store_binary (remainder_token_ptr, in_token.token_ptr (in_token.n - 1), call_again); end; /* Remainder has been stored inot a temp in an attempt to force overflow. */ if remainder_token_ptr -> data_name.type = rtc_register then do; /* Remainder token describes a register. */ /* Release the register, since the value there has been stored . */ register_struc.reg_no = remainder_token_ptr -> cobol_type100.register; call cobol_register$release (addr (register_struc)); end; /* Remainder token describes a register. */ end; /* Format 4 or Format 5 divide. */ 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_5_divide; /*************************************/ zero_divide_check: proc (divisor_token_ptr, imperative_stmt_tag); /* This internal procedure generates code to a. test whether the divisor is zero b. and transfer immediately to the imperative statement if the divisor is zero. */ /* DECLARATION OF THE PARAMETERS */ dcl divisor_token_ptr ptr; dcl imperative_stmt_tag fixed bin; /* DECLARATION OF INTERNAL VARIABLES */ dcl work_token_ptr ptr; /* Generate code to load the divisor into the A or Q */ work_token_ptr = null (); if divisor_token_ptr -> data_name.type = rtc_resword then divisor_token_ptr = addr (dec_zero_token); if divisor_token_ptr -> data_name.type = rtc_numlit then do; /* Divisor is a numeric literal token. */ call cobol_make_bin_const (divisor_token_ptr, work_token_ptr, 2); divisor_token_ptr = work_token_ptr; work_token_ptr = null (); end; /* Divisor is a numeric literal token. */ if divisor_token_ptr -> data_name.type = rtc_dataname & divisor_token_ptr -> data_name.bin_18 /* divisor is short binary */ then call cobol_short_to_longbin$register (divisor_token_ptr, work_token_ptr); else call cobol_load_register (divisor_token_ptr, work_token_ptr); /* Emit a TZE instruction. */ call cobol_emit (addr (tze_inst), null (), 1); call cobol_make_tagref (imperative_stmt_tag, cobol_$text_wd_off - 1, null ()); /* Release the register which has been loaded with the divisor. */ register_struc.reg_no = work_token_ptr -> cobol_type100.register; call cobol_register$release (addr (register_struc)); end zero_divide_check; /* 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_divide_bin_gen;  cobol_divide_gen.pl1 05/24/89 1040.3rew 05/24/89 0830.2 411615 /****^ *********************************************************** * * * 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_divide_gen.pl1 Added Trace statements. 2) change(89-04-23,Zimmerman), approve(89-04-23,MCR8074), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8074 cobol_divide_gen.pl1 Fix remainder bug in divide verb. END HISTORY COMMENTS */ /* Modified on 11/19/84 by FCH, [5.3-2], BUG568(phx16554), if format 4,5 then save isor,idend in temps */ /* Modified on 11/16/84 by FCH, [5.3...], trace added */ /* Modified on 10/19/84 by FCH, [5.3-1], BUG563(phs18381), 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_divide_gen: proc (in_token_ptr, next_stmt_tag); /* The DIVIDE statement generator: cobol_divide_gen FUNCTION The function of this procedure is to generate code for the Cobol DIVIDE 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 DIVIDE 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 DIVIDE 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 DIVIDE. 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 DIVIDE. 2. end_stmt.a defines the format of the DIVIDE statement: value of end_stmt.a | divide stmt format ---------------------------------------- "000"b | format 1 "001"b | format 2 "010"b | format 3 "011"b | format 4 "100"b | format 5 3. end_stmt.b is "1"b if this DIVIDE statement had an ON SIZE ERROR clause 4. end_stmt.e contains the count of the number of operands to the RIGHT of "INTO" for format 1 DIVIDE statements. 5, end_stmt.h contians the count of the number of operands to the RIGHT of "GIVING" for format 2 and format 3 DIVIDE 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 addition. These tokens are always data name (type 9) tokens. OUTPUT The second parameter passed to cobol_divide_gen is an output parameter. A value is returned to the calling procedure, cobol_gen_driver_, only for those divide statments 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_divide_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 DIVIDE statment is executed, otherwise the imperative statement is skipped. The cobol_divide_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_divide_gen reserves a tag for the next COBOL statement. 2. any transfers to the next statement reference the tag reserved by cobol_divide_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_divide_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_divide_gen, is defined. */ /* DECLARATION OF EXTERNAL ENTRIES */ dcl cobol_binary_check$divide ext entry (ptr, bit (1), fixed bin, fixed bin); dcl cobol_divide_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_add3 ext entry (ptr, 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_move_gen ext entry (ptr); dcl cobol_arith_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); dcl cobol_compare_gen ext entry (ptr); /* DECLARATIONS OF BUILTIN FUNCTIONSS */ dcl addr builtin; dcl fixed builtin; dcl null builtin; /* DECLARATION OF INTERNAL STATIC VARIABLES */ dcl first_ix fixed bin int static init (2); dcl div_code fixed bin int static init (185); dcl mpy_code fixed bin int static init (184); dcl subtract_code fixed bin int static init (183); /* 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 temp_in_token_buffer (1:10) ptr int static; dcl move_data_init fixed bin int static init (0); dcl 1 numeric_lit_zero int static, 2 size fixed bin (15) init (36), 2 line fixed bin (15) init (0), 2 column fixed bin (15) init (0), 2 type fixed bin (15) init (2), /* NUMERIC LITERAL */ 2 integral bit (1) init ("1"b), 2 floating bit (1) init ("0"b), 2 filler1 bit (5) init ("00000"b), 2 subscript bit (1) init ("0"b), 2 sign char (1) init (" "), 2 exp_sign char (1) init (" "), 2 exp_places fixed bin (15) init (0), 2 places_left fixed bin (15) init (1), 2 places_right fixed bin (15) init (0), 2 places fixed bin (15) init (1), 2 literal char (1) init ("0"); dcl 1 compare_eos_token int static, 2 size fixed bin (15) init (38), 2 line fixed bin (15) init (0), 2 column fixed bin (15) init (0), 2 type fixed bin (15) init (19), /* EOS */ 2 verb fixed bin (15) init (13), /* BRANCH */ 2 e fixed bin (15) init (102), /* EQUAL */ 2 h fixed bin (15) init (0), 2 i bit (36) init ("000"b); /* TRANSFER IF CONDITION TRUE */ /* DECLARATION OF INTERNAL AUTOMATIC VARIABLES */ dcl ose_flag bit (1); dcl receive_count fixed bin; /*[5.3-2]*/ dcl (fmt1, abit) bit (1); dcl remainder_present bit (1); dcl ix fixed bin; dcl iy fixed bin; dcl move_eos_ptr ptr; dcl move_in_token_ptr ptr; dcl divisor_token_ptr ptr; dcl dividend_token_ptr ptr; dcl resultant_operand_ptr ptr; dcl saved_ptr ptr; dcl product_token_ptr ptr; dcl difference_token_ptr ptr; dcl quotient_token_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 imperative_stmt_tag fixed bin; dcl remainder_code_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 rounded_flag bit (1); dcl ret_offset fixed bin; dcl temp_save_ptr ptr; dcl dn_ptr ptr; /**************************************************/ start: /***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(cdg);/**/ /* Check to see if binary arithmetic (using A and Q) can be done for this divide statement. */ call cobol_binary_check$divide (in_token_ptr, binary_ok, target_code, source_code); if binary_ok then do; /* Binary arithmetic can be done. */ call cobol_divide_bin_gen (in_token_ptr, next_stmt_tag); go to dvx; end; /* Binary arithmetic can be done. */ /* Extract information from the EOS token. */ eos_ptr = in_token.token_ptr (in_token.n); /* ON SIZE ERROR flag */ ose_flag = end_stmt.b; /* Determine divide statement format. */ /*[5.3-2]*/ fmt1, abit = "0"b; remainder_present = "0"b; if end_stmt.a = "000"b then do; /* FORMAT 1 divide */ fmt1 = "1"b; divisor_token_ptr = in_token.token_ptr (first_ix); dividend_token_ptr = in_token.token_ptr (first_ix + 1); receive_count = end_stmt.e; /*[5.3-2]*/ call lit_test (divisor_token_ptr); end; /* FORMAT 1 divide */ /*[5.3-2]*/ else /*[5.3-2]*/ if end_stmt.a = "001"b /* format 2 */ /*[5.3-2]*/ then call f23 (first_ix, first_ix + 1); /*[5.3-2]*/ else /*[5.3-2]*/ if end_stmt.a = "010"b /* format 3 */ /*[5.3-2]*/ then call f23 (first_ix + 1, first_ix); /*[5.3-2]*/ else /*[5.3-2]*/ if end_stmt.a = "011"b /* format 4 */ /*[5.3-2]*/ then call f45 (first_ix, first_ix + 1); /*[5.3-2]*/ else call f45 (first_ix + 1, first_ix); /* format 5 */ /*[5.3-2]*/ abit = "1"b; if ose_flag /* On size error clause was present, do processing common to all format divides. */ then do; /* Reserve a tag to be associated (by the cobol generator driver) with the next cobol statement. */ next_stmt_tag = cobol_$next_tag; /* Reserve a tag to be associated with the imperative statement for the on size error. */ imperative_stmt_tag = next_stmt_tag + 1; cobol_$next_tag = cobol_$next_tag + 2; /* Get a size error flag in the stack, and initialize it to zero. */ /* Generate code to compare the divisor to zero. */ saved_ptr = in_token_ptr; in_token_ptr = addr (temp_in_token_buffer (1)); in_token.n = 3; in_token.token_ptr (1) = divisor_token_ptr; in_token.token_ptr (2) = addr (numeric_lit_zero); in_token.token_ptr (3) = addr (compare_eos_token); /* Transfer to the imperative statement if divisor is zero. */ compare_eos_token.h = imperative_stmt_tag; call cobol_compare_gen (in_token_ptr); in_token_ptr = saved_ptr; 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 all format divides. */ if ^fmt1 then do; /* NOT FORMAT 1 divide, divide the two operands and store the result in a temporary. */ /* Build a resultant operand for the quotient. */ call cobol_build_resop (divisor_token_ptr, dividend_token_ptr, div_code, resultant_operand_ptr, "0"b, rdmax_value, possible_ovfl_flag); /* Generate code to perform the division. */ call cobol_mpy3 (divisor_token_ptr, dividend_token_ptr, resultant_operand_ptr, 2 /* DIVIDE */); 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; /* NOT format 1 divide, divide the two operrands and store the result in a temp. */ /* Get subscript of pointer in the in_token array that points to first receiving field. */ if remainder_present then iy = in_token.n - 2; else iy = in_token.n - receive_count; do ix = 1 to receive_count; /* Generate code to get the quotient into the receiving field(s). */ receiving_is_not_stored = "0"b; rounded_flag = "0"b; /* Generate code to store the contents of the receiving field into a temporary. Note that if the receiving field is numeric edited or overpunch sign then it is not stored. */ call srf (in_token.token_ptr (iy)); /* Generate code to turn the overflow mask indicator bit ON */ if ose_flag then call cobol_fofl_mask$on; if fmt1 /* Generate code to divide the first operand into 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 division. */ op1_token_ptr = divisor_token_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, div_code, temp_resultant_operand_ptr, "0"b, rdmax_value, possible_ovfl_flag); /* Generate code to divide the two operands, and store the result into a temporary. */ call cobol_mpy3 (op1_token_ptr, op2_token_ptr, temp_resultant_operand_ptr, 2); /* Generate code to move the result of the add/subtract 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 divide. */ else do; /* Receiving operand is decimal. */ if not_dec_operand (divisor_token_ptr) then do; /* Left operand is not decimal--convert to decimal. */ op1_token_ptr = divisor_token_ptr; divisor_token_ptr = null (); call cobol_num_to_udts (op1_token_ptr, divisor_token_ptr); end; /* Left operand is not decimal--convert to decimal. */ call cobol_mpy (divisor_token_ptr, in_token.token_ptr (iy), 2); end; /* Receiving operand is decimal. */ end; /* Generate code to divide the first operand into the receiving field value, and store the result into the receiving field. */ else do; /* Generate code to move the quotient 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); /* save a pointer to the token to receive the quotient. */ quotient_token_ptr = in_token.token_ptr (iy); rounded_flag = quotient_token_ptr -> data_name.rounded; 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 divide/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 saved receiving field. Note that if the receiving field is numeric edited, no restoring is necessary. */ if receiving_is_not_stored = "0"b then call receiving_field (in_token.token_ptr (iy), stored_token_ptr, 2 /* RESTORE*/); /* Otherwise, the receiving field is numeric edited, and the numeric representation of the quotient must be pointed at by quotient_token_ptr in case a remainder clause is present. */ else quotient_token_ptr = move_in_token_ptr -> in_token.token_ptr (2); /* 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 /* Receiving field is numeric edited. The result has already been moved into a temporary in an attempt to force overflow. Now generate code to move the temp result into the numeric edited field. */ then do; /* Move temp to numeric edited. */ call cobol_move_gen (move_in_token_ptr); /* set the quotient pointer to point to the temp that contains the numeric representation of the quotient. */ quotient_token_ptr = move_in_token_ptr -> in_token.token_ptr (2); end; /* Move temp to numeric edited. */ /* Increment the subscript to the next receiving field. */ iy = iy + 1; end; /* Generate code to get the quotient into the receiving field(s). */ if remainder_present then do; /* REMAINDER CLAUSE appeared in the divide statement. */ /* At this point in execution, the following conditions are true: 1. quotient_token_ptr points to a token for the numeric representation of the quotient. (If the receiving field was numeric edited, this pointer differs from the pointer to the tgken that receives the numeric edited representation of the quotient. ) 2. divisor_token_ptr points to a token for the divisor. 3. dividend_token_ptr points to the token for the dividend. */ if ose_flag then do; /* ON SIZE ERROR clause was present. Generate code to test to see if overflow occurred during the divide. If overflow did not occur, then transfer to the code that calculates the remainder , otherwise transfer to the imperative_stmt_tag. */ /* Reserve a tag to be defined at the first instruction of the code to be generated to calculate the remainder. */ remainder_code_tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; /* Generate code to a. Load the size error flag into A or Q. b. Transfer if zero to the remainder_code_tag. */ call test_size_error (size_error_token_ptr, size_error_inst_ptr, remainder_code_tag, "1"b, "0"b); /* Generate code to transfer to the imperative statement. (The statement contained in the ON SIZE ERROR clause) */ call test_size_error (size_error_token_ptr, size_error_inst_ptr, imperative_stmt_tag, "0"b, "0"b); /* Define the remainder_code_tag. */ call cobol_define_tag (remainder_code_tag); end; /* ON SIZE ERROR clause was present. Generate code to see if overfllow occurred... */ receiving_is_not_stored = "0"b; /* Calculate the product of the quotient (moved to the receiving field) and divisor. */ if rounded_flag then do; /* Quotient had ROUNDED specified. */ /* Must get a truncated quotient, rather than a ROUNDED quotient, before calculating the remainder. */ /* Make a copy of the quotient token. */ temp_save_ptr = quotient_token_ptr; quotient_token_ptr = null (); call cobol_make_type9$copy (quotient_token_ptr, temp_save_ptr); /* Allocate space on the stack to receive the truncated quotient. */ call cobol_alloc$stack (fixed (quotient_token_ptr -> data_name.item_length, 17), 0, ret_offset); /* Update the new quotient token. */ quotient_token_ptr -> data_name.seg_num = 1000; /* Stack */ quotient_token_ptr -> data_name.offset = ret_offset; quotient_token_ptr -> data_name.subscripted = "0"b; quotient_token_ptr -> data_name.variable_length = "0"b; quotient_token_ptr -> data_name.occurs_ptr = 0; quotient_token_ptr -> data_name.rounded = "0"b; /* NO ROUNDING */ /* Call the arithmetic move generator to move the result of the division into the temporary quotient field, without rounding. */ move_in_token_ptr -> in_token.token_ptr (2) = resultant_operand_ptr; move_in_token_ptr -> in_token.token_ptr (3) = quotient_token_ptr; call cobol_arith_move_gen (move_in_token_ptr); end; /* Quotient variable had RRUNDED specified. */ /* Build a token for the resulting product. */ call cobol_build_resop (divisor_token_ptr, quotient_token_ptr, mpy_code, product_token_ptr, "0"b, rdmax_value, possible_ovfl_flag); /* Generate code to perform the multiplication. */ call cobol_mpy3 (divisor_token_ptr, quotient_token_ptr, product_token_ptr, 1 /*MPY*/); /* Calculate the difference between the dividend and the product. */ /* Build a token for the resulting difference. */ call cobol_build_resop (dividend_token_ptr, product_token_ptr, subtract_code, difference_token_ptr, "0"b, rdmax_value, possible_ovfl_flag); /* Generate code to perform the subtraction. */ call cobol_add3 (product_token_ptr, dividend_token_ptr, difference_token_ptr, 2 /*SUBTRACT*/); /* Move the difference into the remainder variable. */ /* Set up the in token structure for a call to the move generator. */ move_in_token_ptr -> in_token.token_ptr (move_in_token_ptr -> in_token.n - 1) = in_token.token_ptr (in_token.n - 1); /* Receiving field */ move_in_token_ptr -> in_token.token_ptr (move_in_token_ptr -> in_token.n - 2) = difference_token_ptr; /* Remainder to be moved. */ /* Generate code to store the contents of the receiving field into a temporary. Note that if the receiving field is numeric edited, no storing is necessary. */ if ose_flag then call srf (in_token.token_ptr (in_token.n - 1)); /* Generate code to turn the overflow mask enable bit ON */ if ose_flag then call cobol_fofl_mask$on; /* Generate code to move the remainder into the receiving field. */ 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; if ose_flag then do; /* Generate code to test for overflow resulting from the move. */ /* Reserve a tag to which to transfer if no overflow occurred. */ 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 to the receiving field. */ if receiving_is_not_stored = "0"b then call receiving_field (in_token.token_ptr (in_token.n - 1), 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 move. */ else if receiving_is_not_stored then /* The receiving field is a numeric edited, and the result has been moved to a temp in an attempt to force overflow. Now generate code to move the temp to the numeric edited field. */ call cobol_move_gen (move_in_token_ptr); end; /* REMAINDER CLAUSE appeared in the divide statement. */ 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); /* Define the imperative_stmt_tag at the next instruction location. */ call cobol_define_tag (imperative_stmt_tag); end; /* Generate code that tests whether overflow occurred, and jumps over the imperative stmt if on overflow occurred. */ dvx: /***..... if Trace_Bit then call cobol_gen_driver_$Tr_End(cdg);/**/ return; srf: proc (p); dcl p ptr; if p -> data_name.numeric_edited | (p -> data_name.display & p -> data_name.item_signed & ^(p -> data_name.sign_separate)) then receiving_is_not_stored = "1"b; else call receiving_field (p, stored_token_ptr, 1); end; /***..... dcl cdg char(16) init("COBOL_DIVIDE_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); /**/ /**************************************************/ /* INTERNAL PROCEDURE */ /* get_size_error_flag */ /**************************************************/ get_size_error_flag: proc (size_error_token_ptr, size_error_inst_ptr); /* FUNCTION The function of this procedure is to: 1. allocate a fixed bin (35) variable in the COBOL program's run-time stack. 2. build a data name token for the fixed binary variable. 3. Emit code that stores zero into the fixed binary. 4. Return a pointer to the data name token for the fixed binary variable. 5. Return a 36 bit non-eis instruction word that contains the address of the fixed binary variable. */ /* DECLARATION OF THE PARAMETERS */ dcl size_error_token_ptr ptr; dcl size_error_inst_ptr ptr; /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION size_error_token_ptr Points to the data name token that describes the fixed binary in the stack. (output) size_error_inst_ptr Points to a 36 bit field in which the non-eix address is constructed. (output) */ /* DECLARATION OF INTERNAL STATIC VARIABLES */ dcl stz_op bit (10) int static init ("1001010000"b /*450(0)*/); /* DECLARATION OF INTERNAL VARIABLES */ dcl ret_offset fixed bin; dcl size_error_inst_word bit (36) based (size_error_inst_ptr); dcl input_buffer (1:10) fixed bin; dcl reloc_buffer (1:10) bit (5) aligned; /*************************************************/ /* START OF EXECUTION */ /* INTERNAL PROCEDURE get_size_error_flag */ /**************************************************/ /* Allocate a 4 byte fixed binary number on a word boundary in the stack */ call cobol_alloc$stack (4, 0, ret_offset); /* Make a data name token for the fixed binary number. */ size_error_token_ptr = null (); /* The utility will provide the buffer. */ call cobol_make_type9$fixed_bin_35 (size_error_token_ptr, 1000 /*STACK*/, ret_offset); /* Generate code to store zero in the stack temporary */ input_ptr = addr (input_buffer (1)); reloc_ptr = addr (reloc_buffer (1)); 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; /* From cobol_alloc$stack */ size_error_inst_word = "0"b; /* Get the non-eis instruction */ call cobol_addr (input_ptr, size_error_inst_ptr, reloc_ptr); /* Set the STZ opcode into the instruction word */ size_error_inst_ptr -> inst_struc_basic.fill1_op = stz_op; /* Emit the stz instruction */ call cobol_emit (size_error_inst_ptr, reloc_ptr, 1); /* Set the opcode in the non-eis instruction to "0"b */ size_error_inst_ptr -> inst_struc_basic.fill1_op = "0"b; end get_size_error_flag; /**************************************************/ /* INTERNAL PROCEDURE */ /* receiving_field */ /**************************************************/ receiving_field: proc (receiving_token_ptr, stored_token_ptr, function_code); /* THIS IS NOT A VALID ENTRY POINT */ /* DECLARATION OF THE PARAMETERS */ dcl receiving_token_ptr ptr; dcl stored_token_ptr ptr; dcl function_code fixed bin; /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION receiving_token_ptr Points to the data name token of the receiving operand to be stored. (input) stored_token_ptr Points to the data name token of the temporary in which the receiving operand is to be stored. (output) function_code Code that indicates the function to perform value | function ============================= 1 | store 2 | restore */ /* DECLARATION OF INTERNAL STATIC VARIABLES */ /* Definition of an EOS token used in calls to cobol_arith_move_gen */ dcl 1 move_eos int static, 2 size fixed bin (15) init (32), 2 line fixed bin (15) init (0), 2 column fixed bin (15) init (0), 2 type fixed bin (15) init (19), /* EOS */ 2 verb fixed bin (15) init (18), /* MOVE */ 2 e fixed bin (15) init (0), 2 h fixed bin (15) init (0), 2 i fixed bin (15) init (0), 2 j fixed bin (15) init (0), 2 a bit (16) init ("0"b); dcl always_an bit (1) static init ("0"b); /* DECLARATIONS OF INTERNAL AUTOMATIC VARIABLES */ dcl temp_in_token (1:10) ptr; dcl move_eos_ptr ptr; dcl tin_ptr ptr; dcl temp_save_ptr ptr; dcl ret_offset fixed bin; if function_code = 1 then call store; else call restore; return; /*************************************************/ /* STORE ENTRY POINT */ /***************************************************/ store: proc; /* This entry point is used to generate code that stores the contents of a receiving operand into a temporary. */ /* Modify the token for the receiving variable that is being stored, so that it looks like an alphanumeric instead of a numeric. This is done so that the move generator generates an alphanumeric (MLR) move to store the data. */ /*[5.3-2]*/ if abit & ^(receiving_token_ptr -> data_name.ascii_packed_dec_h) then do; receiving_token_ptr -> data_name.numeric = "0"b; receiving_token_ptr -> data_name.alphanum = "1"b; end; else always_an = "1"b; temp_save_ptr = null (); /* Utility will provide the buffer for data name token */ call cobol_make_type9$copy (temp_save_ptr, receiving_token_ptr); /* Allocate space on the stack to hold the contents of the receiving field */ call cobol_alloc$stack (fixed (temp_save_ptr -> data_name.item_length, 17), 0, ret_offset); /* Update the data name for the temporary */ temp_save_ptr -> data_name.seg_num = 1000; /* Stack */ temp_save_ptr -> data_name.offset = ret_offset; /* From cobol_alloc$stack */ temp_save_ptr -> data_name.subscripted = "0"b; temp_save_ptr -> data_name.variable_length = "0"b; temp_save_ptr -> data_name.occurs_ptr = 0; /* Build the in_token structure for calling the move generator */ tin_ptr = addr (temp_in_token (1)); move_eos_ptr = addr (move_eos); stored_token_ptr = temp_save_ptr; tin_ptr -> in_token.n = 4; tin_ptr -> in_token.token_ptr (1) = null (); tin_ptr -> in_token.token_ptr (2) = receiving_token_ptr; /* operand to be stored */ tin_ptr -> in_token.token_ptr (3) = stored_token_ptr; /* Temp in which to store */ tin_ptr -> in_token.token_ptr (4) = move_eos_ptr; if always_an = "1"b then move_eos_ptr -> end_stmt.e = 10001; else move_eos_ptr -> end_stmt.e = 1; /* Set the number of receiving operands into the EOS */ /* Call the move generator to move the contents */ call cobol_move_gen (tin_ptr); /* Reset the token for the variable being stored. */ receiving_token_ptr -> data_name.numeric = "1"b; receiving_token_ptr -> data_name.alphanum = "0"b; always_an = "0"b; end store; /**************************************************/ /* RESTORE ENTRY POIENT */ /**************************************************/ restore: proc; /* This entry point is used to restore the contents of a receiving operand from the contents of a temporary. */ /* Set up the in_token structure for calling the move generator */ tin_ptr = addr (temp_in_token (1)); move_eos_ptr = addr (move_eos); tin_ptr -> in_token.n = 4; tin_ptr -> in_token.token_ptr (1) = null (); tin_ptr -> in_token.token_ptr (2) = stored_token_ptr; /* source */ tin_ptr -> in_token.token_ptr (3) = receiving_token_ptr; /* Receiving field */ tin_ptr -> in_token.token_ptr (4) = move_eos_ptr; /* move EOS token */ /* Set the number of receiving fields into the move EOS */ move_eos_ptr -> end_stmt.e = 1; /* Modify the token for the receiving variable that is being stored, so that it looks like an alphanumeric instead of a numeric. This is done so that the move generator generates an alphanumeric (MLR) move to store the data. */ if receiving_token_ptr -> data_name.ascii_packed_dec_h = "0"b then do; receiving_token_ptr -> data_name.numeric = "0"b; receiving_token_ptr -> data_name.alphanum = "1"b; end; /* Call the move generator */ call cobol_move_gen (tin_ptr); /* Reset the token for the variable being stored. */ receiving_token_ptr -> data_name.numeric = "1"b; receiving_token_ptr -> data_name.alphanum = "0"b; end restore; end receiving_field; /**************************************************/ /* INTERNAL PROCEDURE */ /* test_for_overflow */ /**************************************************/ test_for_overflow: proc (no_overflow_tag, size_error_inst_ptr, move_in_token_ptr); /* FUNCTION The function of this procedure is to generate the following sequence of code: tov 2,ic tra no_overflow_tag aos size_error_flag */ /* DECLARATION OF THE PARAMETERS */ dcl no_overflow_tag fixed bin; dcl size_error_inst_ptr ptr; dcl move_in_token_ptr ptr; /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION no_overflow_tag Contains the compiler generated tag to which to transfer if there is no overflow. (input) size_error_inst_ptr Points to a 36 bit field that contains a non-eis instruction, which contains the address of the size error flag. (input) */ /* DECLARATIONS OF INTERNAL STATIC VARIABLES */ dcl tov_op bit (10) int static init ("1100011110"b /*617(0)*/); dcl tra_op bit (10) int static init ("1110010000"b /*710(0)*/); dcl aos_op bit (10) int static init ("0001011000"b /*054(0)*/); /* DECLARATIONS OF INTERNAL AUTOMATIC VARIABLES. */ dcl temp_inst_word bit (36); dcl temp_inst_ptr ptr; dcl reloc_buffer (1:10) bit (5) aligned; dcl reloc_ptr ptr; dcl save_locno fixed bin; dcl overflow_tag fixed bin; /**************************************************/ /* START OF EXECUTION */ /* test_for_overflow */ /**************************************************/ temp_inst_word = "0"b; temp_inst_ptr = addr (temp_inst_word); /* Insert tov opcode */ temp_inst_ptr -> inst_struc_basic.fill1_op = tov_op; /* Reserve a tag to which to transfer if overflow occurs. */ overflow_tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; reloc_ptr = addr (reloc_buffer (1)); reloc_buffer (1) = "0"b; reloc_buffer (2) = "0"b; /* Emit the instruction */ call cobol_emit (temp_inst_ptr, reloc_ptr, 1); /* Make a tagref to the overflow tag at the instruction just emitted. */ call cobol_make_tagref (overflow_tag, cobol_$text_wd_off - 1, null ()); if move_in_token_ptr ^= null () then if move_in_token_ptr -> in_token.code ^= 0 then call cobol_move_gen (move_in_token_ptr);/* Move a temp result into a numeric edited. */ /* Generate the tra to no_overflow_tag */ temp_inst_word = "0"b; temp_inst_ptr -> inst_struc_basic.fill1_op = tra_op; save_locno = cobol_$text_wd_off; /* Emit the tra instruction */ call cobol_emit (temp_inst_ptr, reloc_ptr, 1); /* Make a tagref to the no_overflow_tag at the tra instruction just emitted. */ call cobol_make_tagref (no_overflow_tag, save_locno, null ()); /* Generate aos instruction which increments the size error flag */ /* Define the overflow_tag at the aos instruction */ call cobol_define_tag (overflow_tag); size_error_inst_ptr -> inst_struc_basic.fill1_op = aos_op; /* Emit the instruction */ call cobol_emit (size_error_inst_ptr, reloc_ptr, 1); /* Reset the opcode field of the non-eis instruction */ size_error_inst_ptr -> inst_struc_basic.fill1_op = "0"b; end test_for_overflow; /**************************************************/ /* INTERNAL PROCEDURE */ /* test_size_error */ /**************************************************/ test_size_error: proc (size_error_token_ptr, size_error_inst_ptr, next_stmt_tag, overflow_code_generated, not_bit); /* FUNCTION This internal procedure performs the following functions: If the overflow_code generated flag is "1"b then the following functions are performed: 1. Gets the A of Q register 2. Generates two instructions. a. LDA or LDQ with the contents of the size error flag b. TZE to the next_stmt_tag If the overflow_code_generated flag is "0"b, then the following instruction is generated: TRA to the next_stmt_tag */ /* DECLARATION OF THE PARAMETERS */ dcl size_error_token_ptr ptr; dcl size_error_inst_ptr ptr; dcl next_stmt_tag fixed bin; dcl (overflow_code_generated, not_bit) bit (1); /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION size_error_token_ptr Points to a data name token for the size error flag. (input) size_error_inst_ptr Points to a 36 bit field that contains the non-eis address of the size error flag in the run-time stack. (input) next_stmt_tag Contains a compiler generated tag to be associated with the next Cobol statement. (input) overflow_code_generated Contains a one bit indicator that is "1"b if overflow testing code was generated for this statement. (input) not_bit "1"b if NOT option follows */ /* DECLARATION OF INTERNAL STATIC VARIABLES. */ 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 tze_op bit (10) int static init ("1100000000"b /*600(0)*/); dcl tnz_op bit (10) int static init ("1100000010"b /*601(0)*/); /*[4.0-1]*/ dcl tra_op bit (10) int static init ("1110010000"b /*710(0)*/); /* DECLARATIONS OF INTERNAL AUTOMATIC VARIABLES */ /* 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); dcl temp_inst_word bit (36); dcl temp_inst_ptr ptr; dcl save_locno fixed bin; dcl reloc_buffer (1:10) bit (5) aligned; dcl reloc_ptr ptr; dcl size_error_inst bit (36) based (size_error_inst_ptr); /**************************************************/ /* START OF EXECUTION */ /* test_size_error */ /**************************************************/ reloc_ptr = addr (reloc_buffer (1)); reloc_buffer (1) = "0"b; reloc_buffer (2) = "0"b; if overflow_code_generated then do; /* overflow code was generated, must load the size error flag and test it */ size_error_inst_ptr = addr (size_error_inst); /* Get the A or Q register */ register_struc.what_reg = 0; /* A or Q */ register_struc.lock = 0; /* No change to locks */ register_struc.contains = 1; /* Register will contain a data item */ register_struc.dname_ptr = size_error_token_ptr; call cobol_register$load (addr (register_struc)); /* Build the LDA or LDQ instruction */ if register_struc.reg_no = "0001"b then size_error_inst_ptr -> inst_struc_basic.fill1_op = lda_op; /* A reg */ else size_error_inst_ptr -> inst_struc_basic.fill1_op = ldq_op; /* Q reg */ /* Emit the LDA or LDQ instruction */ call cobol_emit (size_error_inst_ptr, reloc_ptr, 1); end; /* overflow code was generated, must load the size error flag and test it */ /* Generate a TZE or TRA instruction */ temp_inst_word = "0"b; temp_inst_ptr = addr (temp_inst_word); if overflow_code_generated /*[4.2-1]*/ then if not_bit /*[4.2-1]*/ then temp_inst_ptr -> inst_struc_basic.fill1_op = tnz_op; /*[4.2-1]*/ else temp_inst_ptr -> inst_struc_basic.fill1_op = tze_op; else temp_inst_ptr -> inst_struc_basic.fill1_op = tra_op; /* Save the text word offset at which the tze is to be emitted */ save_locno = cobol_$text_wd_off; /* Emit the instruction */ call cobol_emit (temp_inst_ptr, reloc_ptr, 1); /* Generate a tagref to the next cobol statement at the TZE or TRA just emitted */ call cobol_make_tagref (next_stmt_tag, save_locno, null ()); end test_size_error; not_dec_operand: proc (token_ptr) returns (bit (1)); /* This function procedure determines whether an input data name token represents a data item that is not decimal, namely short fixed binary, long fixed binary, or overpunch sign. If the token represents a fixed binary or overpunch sign data item, then "1"b is returned. Otherwise "0"b is returned. */ dcl token_ptr ptr; if token_ptr -> data_name.bin_18 | token_ptr -> data_name.bin_36 | token_ptr -> data_name.sign_type = "010"b /* leading not separate */ | token_ptr -> data_name.sign_type = "001"b /* trailing, not separate */ | (token_ptr -> data_name.display & token_ptr -> data_name.item_signed & token_ptr -> data_name.sign_separate = "0"b) /* Default overpunch. */ then return ("1"b); else return ("0"b); end not_dec_operand; /*************************************/ 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; rf: proc (p, q); /*[5.3-2]*/ dcl (p, q) ptr; /*[5.3-2]*/ call receiving_field (p, q, 1); /*[5.3-2]*/ q -> data_name.numeric = "1"b; /*[5.3-2]*/ q -> data_name.alphanum = "0"b; end; lit_test: proc (p); /*[5.3-2]*/ dcl p ptr; /*[5.3-2]*/ if p -> data_name.type ^= rtc_dataname /*[5.3-2]*/ then do; saved_ptr = p; /*[5.3-2]*/ p = null (); /*[5.3-2]*/ call cobol_make_type9$type2_3 (p, saved_ptr); /*[5.3-2]*/ end; end; f23: proc (isor, idend); /*[5.3-2]*/ dcl (isor, idend) fixed bin; /*[5.3-2]*/ divisor_token_ptr = in_token.token_ptr (isor); /*[5.3-2]*/ dividend_token_ptr = in_token.token_ptr (idend); /*[5.3-2]*/ receive_count = end_stmt.h; end; f45: proc (isor, idend); /*[5.3-2]*/ dcl (isor, idend) fixed bin; /*[5.3-2]*/ dcl (temp_divisor_token_ptr, temp_dividend_token_ptr) ptr; /*[5.3-2]*/ temp_divisor_token_ptr = in_token.token_ptr (isor); /*[5.3-2]*/ temp_dividend_token_ptr = in_token.token_ptr (idend); /*[5.3-2]*/ call lit_test (temp_divisor_token_ptr); /*[5.3-2]*/ call lit_test (temp_dividend_token_ptr); /*[5.3-2]*/ call rf (temp_divisor_token_ptr, divisor_token_ptr); /*[5.3-2]*/ call rf (temp_dividend_token_ptr, dividend_token_ptr); /*[5.3-2]*/ receive_count = 1; remainder_present = "1"b; end; /**************************************************/ /* INCLUDE FILES USED BY THIS PROCEDURE */ /**************************************************/ %include cobol_type9; %include cobol_in_token; %include cobol_type19; %include cobol_; %include cobol_addr_tokens; %include cobol_record_types; end cobol_divide_gen;  cobol_enable_gen.pl1 05/24/89 1040.3rew 05/24/89 0830.2 50040 /****^ *********************************************************** * * * 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_enable_gen.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 10/02/77 by Bob Chang to fix the bug for mcs_icdp. */ /* Modified on 03/25/77 by Bob Chang to implement communication enable verb. */ /* Created as a stub on 11/18/76 by ORN */ /* format: style3 */ cobol_enable_gen: proc (in_token_ptr); /* Declaration for static data. */ dcl 1 pr_struc static, 2 what_ptr fixed bin init (2), 2 pointer_no bit (3), 2 lock fixed bin init (0), 2 switch fixed bin init (0); dcl 1 alpha_type9 static, 2 header (4) fixed bin init (112, 0, 0, 9), 2 repl_ptr (2) ptr init ((2) null ()), 2 fill1 bit (108) init (""b), 2 file_key_info, 3 fb1 (3) fixed bin init (0, 0, 0), 3 size fixed bin init (0), 3 fb2 (2) fixed bin init (0, 0), 3 flags1 bit (36) init ("000000100100000000010000000100000000"b), 3 flags2 bit (36) init (""b), 3 seg fixed bin init (0), 3 off fixed bin, 2 fill2 (7) fixed bin init (0, 0, 0, 0, 0, 0, 0); dcl inst_seq (12) bit (18) unaligned static init ("110000000000000000"b, "010101010001000000"b, /* spri2 pr6|offset */ "000000000000000000"b, "010011101000000111"b, /* lda 0,dl */ "110000000000000000"b, "111101101001000000"b, /* sta pr6|offset */ "110000000000000000"b, "100101000001000000"b, /* stz pr6|offset */ "110000000000000000"b, "010011100001000000"b, /* szn pr6|offset */ "000000000000000000"b, "110000000000000100"b); /* tze 0,ic */ /* Automatic data */ dcl conoff fixed bin, /* PARAMETER for NO DATA statement */ stoff fixed bin, dn_ptr ptr, temp fixed bin; /* External procedure */ dcl cobol_call_op entry (fixed bin, fixed bin), cobol_pool entry (char (*), fixed bin, fixed bin), cobol_pointer_register$priority entry (fixed bin, fixed bin, bit (3)), cobol_emit entry (ptr, ptr, fixed bin), cobol_define_tag entry (fixed bin), cobol_make_tagref entry (fixed bin, fixed bin, ptr), cobol_set_pr entry (ptr, ptr), cobol_reg_manager$after_op entry (fixed bin), cobol_get_size entry (ptr, fixed bin, fixed bin); start: /* Generate epp2 instruction for communication token. */ cdtoken_ptr = in_token.token_ptr (2); eos_ptr = in_token.token_ptr (in_token.n); alpha_type9.seg = cdtoken.cd_seg; if ^end_stmt.b then alpha_type9.off = cdtoken.cd_off - 60; else alpha_type9.off = cdtoken.cd_off - 20; call cobol_set_pr (addr (pr_struc), addr (alpha_type9)); /* Allocate 12 words in stack frame for parameters */ stoff = 74; /* Communication stack frame from pr6|74 */ /* Store cd_token address. */ substr (inst_seq (1), 4, 15) = substr (unspec (stoff), 22, 15); call cobol_emit (addr (inst_seq (1)), null, 1); /* Set up parameter for message type. */ if end_stmt.b | end_stmt.c then do; inst_seq (3) = "000000000000000001"b; call cobol_emit (addr (inst_seq (3)), null, 1); end; temp = stoff + 5; if end_stmt.b then do; substr (inst_seq (5), 4, 15) = substr (unspec (temp), 22, 15); call cobol_emit (addr (inst_seq (5)), null, 1); end; else do; substr (inst_seq (7), 4, 15) = substr (unspec (temp), 22, 15); call cobol_emit (addr (inst_seq (7)), null, 1); end; temp = stoff + 6; if end_stmt.c then do; substr (inst_seq (5), 4, 15) = substr (unspec (temp), 22, 15); call cobol_emit (addr (inst_seq (5)), null, 1); end; else do; substr (inst_seq (7), 4, 15) = substr (unspec (temp), 22, 15); call cobol_emit (addr (inst_seq (7)), null, 1); end; /* Generate epp2 instruction for receiving data item. */ dn_ptr = in_token.token_ptr (3); if data_name.type = 3 then do; alit_ptr = dn_ptr; alpha_type9.seg = 3000; alpha_type9.size = alphanum_lit.lit_size; call cobol_pool (alphanum_lit.string, 1, conoff); alpha_type9.off = conoff * 4; dn_ptr = addr (alpha_type9); end; call cobol_set_pr (addr (pr_struc), dn_ptr); /* Store into stack frame. */ temp = stoff + 2; substr (inst_seq (1), 4, 15) = substr (unspec (temp), 22, 15); call cobol_emit (addr (inst_seq (1)), null, 1); /* Set up the size of the data token. */ temp = stoff + 4; call cobol_get_size (dn_ptr, temp, 0); /* Call cobol_operators_ */ call cobol_call_op (74, 0); call cobol_reg_manager$after_op (74); exit: return; /***** Declaration for builtin function *****/ dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index) builtin; /***** End of declaration for builtin function *****/ %include cobol_in_token; %include cobol_; %include cobol_type19; %include cobol_type9; %include cobol_type13; %include cobol_type3; end cobol_enable_gen;  cobol_end_gen.pl1 05/24/89 1040.3rew 05/24/89 0830.1 97380 /****^ *********************************************************** * * * 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_end_gen.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /*{*/ /* format: style3 */ cobol_end_gen: proc (in_token_ptr, fxs_locno, fxs_tag, last_decl_proc, end_flag); /* The procedure cobol_end_gen implements the END statement which may be of the form: END DECLARATIVES (standard COBOL) or END COBOL (non-standard COBOL) For the form END DECLARATIVES, the procedure - 1. Generates an end-of-perform range alterable GO and incre- ments perform_para_index by 1 if the paragraph being ter- minated is at the end of a perform range as determined by examining para_eop_flag (1, it is; 0, it is not). 2. Generates an end-of-perform range alterable GO for the final section of the Declarative portion of the program. It should be noted that every section within the DECLARA- TIVES is considered to be individually performable and therefore requires the generation of an implicit alterable GO at its end. 3. Generates code to signal the error "Improperly executed DECLARATIVES" to which control is transferred by the alter- able GO's inserted at the end of each Declarative Section when they are not otherwise set by the execution of a COBOL control statement. This prevents the implicit transfer of control between Declarative Sections and between the last Declarative Section and the first non-Declarative Section. 4. Sets sect_eop_flag and para_eop_flag to zero. 5. Stores the procedure number of the last Declarative Section in last_decl_proc. 6. Stores the compile time offset of the instruction following the last instruction generated by cobol_end_gen in fxs_locno (this will be the offset of the first instruction generated to implement the first executable statement of the COBOL program) and associates fxs_tag with fxs_locno. For the form END COBOL, the procedure - 1. Generates an end-of-perform range alterable GO and incre- ments perform_para_index by 1 if the paragraph being ter- minated is at the end of a perform range as determined by examining para_eop_flag ((1, it is; 0, it is not). 2. Generates the number of end-of-perform range alterable GO's dictated by the value of sect_eop_flag; 0, 1, or 2. 3. Enters the value of cobol_$text_wd_off in cobol_$non_source_ offset if end_flag is zero. 4. Generates a call to cobol_process_error to signal an improper- ly ended program error if the code is executed (which it will not be if the program was properly terminated) and sets end_flag to one if end_flag is zero. End_flag is in- itiated to zero by cobol_gen_driver_. The first END COBOL statement encountered indicates the end of the source code. The second, if any, indicates the end of code generated by ddalloc for size routines. U__s_a_g_e:_ declare cobol_end_gen entry (ptr, fixed bin, fixed bin, fixed bin); call cobol_end_gen (in_token_ptr, fxs_locno, fxs_tag, last_decl_proc); */ %include cobol_in_token; declare fxs_locno fixed bin, fxs_tag fixed bin, last_decl_proc fixed bin, end_flag fixed bin; /* fxs_locno is the compile time offset of the first instruc- tion generated to implement the first executable statement of the program i.e. the first instruc- tion following the Declarative portion of the pro- gram. (Output) fxs_tag is the number of the tag associated with the in- struction at fxs_locno. (Input/output) last_decl_proc is the procedure (tag) number of the last section of the dECLARATIVES. (Output) end_flag is a flag used to determine if the END COBOL state- ment being processed is the first such statement encountered (0, it is; 1, it is not). (Input/output) */ /* G__e_n_e_r_a_t_e_d_C__o_d_e:_ For END DECLARATIVES: 1) An alterable GO couplet is generated if the last paragraph of the last section of the Declaratives is the subject of a PERFORM statement. 2) An alterable GO couplet is generated for the section since all Declarative Sections are performable. 3) A call to signal the error "Improperly executed Declaratives" is generated following the end of section alterable GO in order to prevent drop through to the non-Declarative portion of the program if the Declaratives are entered by other than legal means. The code generated is as follows: Alterable GO couplet lda target_An tra 0,al where: target_An is a 36-bit variable allocated in the program's COBOL data segment. Each target_An, for n = 1, 2, 3, ..., is uniquely associated with the procedure at whose end these instructions are generated. Call to signal error x [Code generated by cobol_process_error to signal the error] [IMPROPERLY EXECUTED DECLARATIVES ] tra x_relp,ic where: x_relp is the offset, relative to the instruction in which it appears, of the first instruction generated by the procedure cobol_process_error. The following code is generated for END COBOL: x [Code generated by cobol_process_error to signal the error] [IMPROPERLY ENDED PROGRAM ] tra y_relp,ic where: y_relp is the offset, relative to the instruction in which it appears, of the first instruction generated by the procedure cobol_process_error. D__a_t_a:_ % include cobol_; Items in cobol_$incl.pl1 used (u) and/or set (s) by cobol_end_gen; cobol_ptr (u) non_source_offset (s) para_eop_flag (u/s) perform_list_ptr (u) perform_para_index (u/s) perform_sect_index (u) sect_eop_flag (s) text_wd_off (u) */ %include cobol_perform_altgo; %include cobol_perform_list; %include cobol_type19; dcl index fixed bin, saved_text_wd_off fixed bin, tra_inst (2) bit (18) unaligned static init ("000000000000000000"b, "111001000000000100"b); /* where: index is a do loop index. saved_text_wd_off is the value of text_wd_off before cobol_process_ error is called. tra_inst is an unconditional transfer instruction. */ /* P__r_o_c_e_d_u_r_e_s_C__a_l_l_e_d:_ */ dcl cobol_addr entry (ptr, ptr, ptr), cobol_define_tag entry (fixed bin), cobol_emit entry (ptr, ptr, fixed bin), cobol_process_error entry (fixed bin, fixed bin, fixed bin), cobol_register$load entry (ptr); /* B__u_i_l_t-__i_n_F__u_n_c_t_i_o_n_s_U__s_e_d:_ */ dcl addr builtin, addrel builtin, null builtin, substr builtin, unspec builtin; /*}*/ %include cobol_; /* Process end_of_perform range paragraph */ if cobol_$para_eop_flag ^= 0 then do; call cobol_register$load (addr (register_request)); input_struc_basic.segno = perform_list.perf.target_a_segno (cobol_$perform_para_index); input_struc_basic.char_offset = perform_list.perf.target_a_offset (cobol_$perform_para_index); call cobol_addr (addr (input_struc_basic), addr (prfrm_altgo_inst_pr), null); call cobol_emit (addr (prfrm_altgo_inst_pr), null, 2); call cobol_define_tag (perform_list.perf.int_tag_no (cobol_$perform_para_index)); cobol_$para_eop_flag = 0; cobol_$perform_para_index = cobol_$perform_para_index + 1; end; /* DETERMINE FORM OF END STATEMENT AND GO TO APPROPRIATE PART */ /* OF PROCEDURE FOR ADDITIONAL PROCESSING */ if in_token.token_ptr (in_token.n) -> end_stmt.b = "0"b then goto end_cobol; else goto end_declaratives; /* IMPLEMENTATION OF END COBOL STATEMENT */ end_cobol: /* Section terminated at end-of-perform range? */ do index = 1 to cobol_$sect_eop_flag; call cobol_register$load (addr (register_request)); input_struc_basic.segno = perform_list.perf.target_a_segno (cobol_$perform_sect_index); input_struc_basic.char_offset = perform_list.perf.target_a_offset (cobol_$perform_sect_index); call cobol_addr (addr (input_struc_basic), addr (prfrm_altgo_inst_pr), null); call cobol_emit (addr (prfrm_altgo_inst_pr), null, 2); call cobol_define_tag (perform_list.perf.int_tag_no (cobol_$perform_sect_index)); cobol_$perform_sect_index = cobol_$perform_sect_index + 1; end; cobol_$sect_eop_flag = 0; /* Generate call to cobol_process_error if end_flag is zero. */ if end_flag = 0 then do; saved_text_wd_off = cobol_$text_wd_off; cobol_$non_source_offset = saved_text_wd_off; call cobol_process_error (2, 0, 0); saved_text_wd_off = saved_text_wd_off - cobol_$text_wd_off; tra_inst (1) = substr (unspec (saved_text_wd_off), 19, 18); call cobol_emit (addr (tra_inst), null, 1); end_flag = 1; end; return; /* IMPLEMENTATION OF END DECLARATIVES STATEMENT */ end_declaratives: /* Process end_of_perform range for last section of */ /* DECLARATIVES */ call cobol_register$load (addr (register_request)); last_decl_proc = perform_list.perf.proc_num (cobol_$perform_sect_index); input_struc_basic.segno = perform_list.perf.target_a_segno (cobol_$perform_sect_index); input_struc_basic.char_offset = perform_list.perf.target_a_offset (cobol_$perform_sect_index); call cobol_addr (addr (input_struc_basic), addr (prfrm_altgo_inst_pr), null); call cobol_emit (addr (prfrm_altgo_inst_pr), null, 2); call cobol_define_tag (perform_list.perf.int_tag_no (cobol_$perform_sect_index)); saved_text_wd_off = cobol_$text_wd_off; call cobol_process_error (5, 0, 0); saved_text_wd_off = saved_text_wd_off - cobol_$text_wd_off; tra_inst (1) = substr (unspec (saved_text_wd_off), 19, 18); call cobol_emit (addr (tra_inst), null, 1); fxs_locno = cobol_$text_wd_off; call cobol_define_tag (fxs_tag); cobol_$sect_eop_flag = 0; return; end cobol_end_gen;  cobol_exit_gen.pl1 05/24/89 1040.3rew 05/24/89 0830.1 59283 /****^ *********************************************************** * * * 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_exit_gen.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 3/19/76 by Bob Chang to interface with the cobol_operators_. */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* Modified on 03/14/77 by Bob Chang to fix the bug for register management. */ /* Modified since Version 2.0 */ /*{*/ /* format: style3 */ cobol_exit_gen: proc (in_token_ptr); /* The procedure cobol_exit_gen generates code to implement the COBOL EXIT statement. The format of this statement is as follows: E_X_I_T_ [P_R_O_G_R_A_M_] The EXIT statement without the optional word PROGRAM serves only to enable the user to assign a procedure name to a given point in a program. Such an EXIT statement has no other effect on the compilation or execution of the program. Therefore, no code is generated for this version of the EXIT statement. The EXIT PROGRAM version of the EXIT statement causes control to be returned to the calling program but only if the program in which the EXIT PROGRAM statement appears is a called program as defined by COBOL standards. The procedure cobol_exit_gen also outputs relocation information for the code which it generates. U__s_a_g_e:_ declare cobol_exit_gen entry (ptr); call cobol_exit_gen(in_token_ptr); */ %include cobol_in_token; /* G__e_n_e_r_a_t_e_d_C__o_d_e:_ The following code is generated for the EXIT PROGRAM version of the EXIT statement: lda pr4|sw_off stat.main_prog_sw tnz 2,ic tra pr0|return_ where: return_ is the location, relative to the label operator_table in cobol_operators_, of an unconditional transfer to the first instruction of the operator return_mac. The current value of return_ is 409. sw_off is the offset, relative to the base of the linkage sec- tion, of stat.main_prog_sw. Stat.main_prog_sw is de- fined in fixed_static.incl.pl1. */ /* 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_exit_gen (as opposed to being generated by a utility called by cobol_exit_gen) are non-relocatable with the exception of the left hand (address) half of the instruction "lda pr4|sw_off". The relocation code generated for the address half of this instruction is "10100"b. The relocation code generated for all other half words is "00000"b. */ /* D__a_t_a:_ % include cobol_; Items in cobol_.incl.pl1 used (u) and/or set (s) by cobol_exit_gen; link_base_ptr (u) */ %include cobol_fixed_static; %include cobol_type19; /* Input structure for cobol_register$load */ declare 1 register_request aligned static, 2 requested_reg fixed bin aligned init (1), 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 pl1 compiler will allocate structures containing pointers and all pointers therein on even word boundaries leaving "gaps" where necessary. content_ptr not applicable for use_code = 0. literal_content not applicable for use_code = 0. */ dcl inst_seq (6) bit (18) unaligned static init ("100000000000000000"b, "010011101001000000"b, /* lda pr4|0 */ "000000000000000010"b, "110000001000000100"b, /* tnz 2,ic */ "000000000000000011"b, "111001000001000000"b); /* tra pr0|3 */ dcl rel_seq (6) bit (5) aligned static init ("11001"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b); dcl temp fixed bin; /* P__r_o_c_e_d_u_r_e_s__c_a_l_l_e_d:_ */ dcl cobol_emit entry (ptr, ptr, fixed bin), cobol_reset_r$in_line entry, cobol_pointer_register$call entry, cobol_register$load entry (ptr); /* B__u_i_l_t-__i_n_F__u_n_c_t_i_o_n_s_U__s_e_d:_ */ dcl addr builtin, null builtin, rel builtin; /*}*/ %include cobol_; start: /* EMIT CODE AND RELOCATION INFORMATION AS REQUIRED */ if in_token.token_ptr (in_token.n) -> end_stmt.b = "0"b then ; else do; call cobol_pointer_register$call; call cobol_register$load (addr (register_request)); temp = 40; /* stat_main_prog_sw_off+8 */ substr (inst_seq (1), 4, 15) = substr (unspec (temp), 22, 15); call cobol_emit (addr (inst_seq), addr (rel_seq), 3); call cobol_reset_r$in_line; end; exit: return; end cobol_exit_gen;  cobol_exp3.pl1 05/24/89 1040.3rew 05/24/89 0830.1 507825 /****^ *********************************************************** * * * 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_exp3.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 10/21/82 by FCH, [5.1-1], incorrect dimensions corrected */ /* Modified on 01/25/77 by Bob Chang to implement profile option. */ /* Modified on 1/17/77 by Bob Chang to change offset for real_to_real operator. */ /* Modified since Version 2.0. */ /* format: style3 */ cobol_exp3: proc (lop_ptr, rop_ptr, result_ptr, imperative_stmt_tag); /* This procedure is called to generate code to perform the exponentiation of one numeric variable by another. Certain conversions are performed by calling PL1 operator routines. The exponentiation, itself, is done by an internal procedure which is emitted into the Cobol object program. */ /* DECLARATION OF THE PARAMETERS */ dcl lop_ptr ptr; dcl rop_ptr ptr; dcl result_ptr ptr; dcl imperative_stmt_tag fixed bin; /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION lop_ptr Pointer to the data name token (type 9) that describes the numeric variable to be exponentiated. (input) This token can describe one of the following types of numeric variables. 1. floating decimal 2. numeric decimal, unsigned 3. numeric decimal,leading sign 4. numeric decimal, trailing sign rop_ptr Pointer to the data name token (type 9) that describes the numeric variable to be used as the exponent. (input) This token can be one of the types described above for lop_ptr. result_ptr Pointer to a data name token (type 9) that describes the temporary numeric variable into whhich the result of the exponentation is to be stored. (output) This token always describes a floating decimal temporary. imperative_stmt_tag a tag (label) number defined by the calling procedure (cobol_compute_gen) and which will be defined at the imperative statement of the COMPUTE statement containing exponent- iation, if the COMPUTE statement has an ON SIZE ERROR clause. If no ON SIZE ERROR clause appeared in the compute statement, then this parameter is zero. (input) */ /* IMPLEMENTATION DETAILS The following sequence of code is generated by this procedure. 1. If either of the tokens pointed at by lop_ptr or rop_ptr describes a numeric variable that is unsigned, or has trailing sign, then code is generated to convert the numeric to a numeric with leading sign. This is done because the PL1 operator conversion routine used requires that fixed decimal data have the following format: 1. 9 bit representation 2. leading sign 2. Code is generated to convert the numeric variable to be exponentiated to a double precision, real floating binary value. This is done by a call to the PL1 operator procedure "real_to_real_rd". 3. Code is generated to convert the numeric variable serving as the exponent to a double precision, real floating binary value. This is also done by calling the PL1 operator procedure "real_to_real_rd". 4. Code is generated to perform the exponentation. The exponentation is preformed by the internal procedure emitted into the Cobol object program. The result of the exponentation is returned in the EAQ register, as a double precision floating binary value. 5. Code is generated to store the EAQ into a temporary variable. 6. Code is generated to convert the result of the exponentiation to a floating decimal, and store the converted value into the variable described by the token pointed at by the parameter "result_ptr". */ /* DECLARATIONS OF EXTERNAL ENTRIES */ dcl cobol_move_gen ext entry (ptr); dcl cobol_call_op entry (fixed bin, fixed bin); dcl cobol_reset_r$after_call ext entry; dcl cobol_make_type9$copy ext entry (ptr, ptr); dcl cobol_pool ext entry (char (*), fixed bin, fixed bin); dcl cobol_make_fixup entry (ptr); dcl cobol_emit ext entry (ptr, ptr, fixed bin); dcl cobol_register$load ext entry (ptr); dcl cobol_addr ext entry (ptr, ptr, ptr); dcl cobol_alloc$stack ext entry (fixed bin, fixed bin, fixed bin); dcl cobol_process_error ext entry (fixed bin, fixed bin, fixed bin); dcl cobol_make_link$type_4 ext entry (fixed bin, char (*)); dcl cobol_define_tag_nc ext entry (fixed bin, fixed bin); dcl cobol_define_tag ext entry (fixed bin); dcl cobol_make_tagref ext entry (fixed bin, fixed bin, ptr); /* DECLARATIONS OF INTERNAL STATIC DATA */ /* Definitions of internal static variables that define 6180 opcodes needed to generate code. */ dcl ldq_op bit (10) int static init ("0100111100"b /* 236(0) */); dcl lxl7_op bit (10) int static init ("1110101110"b /*727(0) */); dcl lda_op bit (10) int static init ("0100111010"b /* 235(0) */); dcl lxl6_op bit (10) int static init ("1110101100"b /* 726(0) */); dcl tsx0_op bit (10) int static init ("1110000000"b /* 700(0) */); dcl dfld_op bit (10) int static init ("1000110110"b /* 433(0) */); dcl tsp3_op bit (10) int static init ("0101110110"b /* 273(0) */); dcl dfst_op bit (10) int static init ("1001011110"b /* 457(0) */); /* Definitions of static code sequences. */ dcl lda_63_dl bit (36) int static init ("000000000000111111010011101000000111"b); /* LDA 63,DL */ /* Definition of static variables that contain offset values into PL! operator segment */ dcl cobol_op_real_to_real_rd fixed bin (15) int static init (15); dcl pl1_op_dbl_p_dbl fixed bin (15) int static init (741); dcl exp_proc_emitted fixed bin int static init (0); dcl exp_proc_tag fixed bin int static; /* fixup directive for link, used when profile options is specified. */ dcl 1 fixup_directive aligned static, 2 operation bit (1) unal init ("0"b), 2 type bit (4) unal init ("1111"b), 2 reserved bit (9) unal init ("000000000"b), 2 location unal, 3 half bit (1) unal init ("0"b), 3 base bit (3) unal init ("001"b), 3 offset fixed bin unal, 2 tag_number fixed bin aligned; /* DECLARATION OF INTERNAL VARIABLES */ dcl dn_ptr ptr; /* Structure used to communicate with the pointer register routines. */ dcl 1 pr_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 pr_struc_ptr ptr; /* Structure used to communicate with the A,Q, and XR register routines. */ dcl 1 reg_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 reg_struc_ptr ptr; dcl work_lop_ptr ptr; dcl work_rop_ptr ptr; dcl restore_pointer_regs bit (1); dcl lop_seg fixed bin; dcl lop_offset fixed bin (24); dcl rop_seg fixed bin; dcl rop_offset fixed bin (24); dcl result_seg fixed bin; dcl result_offset fixed bin (24); dcl restart_tag fixed bin; /* Buffers used to communicate with the addressability utility */ dcl inst_buff (1:10) fixed bin; dcl reloc_buff (1:10) fixed bin; dcl input_buff (1:10) fixed bin; /**************************************************/ /* START OF EXECUTION */ /* EXTERNAL PROCEDURE cobol_exp3 */ /**************************************************/ start: if exp_proc_emitted ^= cobol_$compile_count then do; /* Emit the internal procedure that performs exponentiation. */ call emit_exp_proc (exp_proc_tag); exp_proc_emitted = cobol_$compile_count; end; /* Emit the internal procedure that performs the exponentiation. */ /* If no ON SIZE ERROR clause was present in the statement, then define the tag at which to restart the execution of the exponentiation code if an execution time error is detected, and the user hits "start" */ if imperative_stmt_tag = 0 then do; /* No OSE clause present, define the restart tag. */ restart_tag = cobol_$next_tag; call cobol_define_tag (restart_tag); cobol_$next_tag = cobol_$next_tag + 1; end; /* NO OSE clause present, define the restart tagl */ /* Determine whether the value to be exponentiated needs to be 1. converted to float dec or fixed dec, leading sign, or 2. moved to a temporary on a word boundary. */ dn_ptr = lop_ptr; if (data_name.sign_type = "000"b /* UNSIGNED */ | data_name.sign_type = "011"b /* TRAILING SEPARATE SIGN */ | data_name.occurs_ptr ^= 0 /* member of an array */ | mod (data_name.offset, 4) ^= 0 /* Not aligned on a word boundary. */ | data_name.ascii_packed_dec /* packed decimal data */) then call convert_or_move (lop_ptr, work_lop_ptr);/* Move or convert the value */ else work_lop_ptr = lop_ptr; /* No move or convert necessary. :/ /* Determine whether the exponent value needs to be 1. converted to floating decimal or fixed decimal, leading sign 2. or moved to a temporary on an even word boundary. */ dn_ptr = rop_ptr; restore_pointer_regs = "0"b; if (data_name.sign_type = "000"b /* UNSIGNED */ | data_name.sign_type = "011"b /* TRAILING SEPARATE SIGN */ | data_name.occurs_ptr ^= 0 /* member of an array */ | mod (data_name.offset, 4) ^= 0 /* Not aligned on a word boundary. */ | data_name.ascii_packed_dec /* packed decimal data */) then call convert_or_move (rop_ptr, work_rop_ptr); else do; /* No move or convert necessary for the exponent */ work_rop_ptr = rop_ptr; restore_pointer_regs = "1"b; end; /* No move or convert necessary for exponent. */ /* Generate code to convert the value being exponentiated to double precision floating binary. */ call con_to_float_bin (work_lop_ptr, lop_seg, lop_offset); /* If the exponent was not converted or moved, that means that it was properly signed and aligned so that the conversion routine could handle it. However, the call to convert the value being exponentiated has resulted in the setting of PR3 and PR5 to unknown values, and to properly access the exponent, which is in the cobol data segment, we must now restore PR3 and PR5 so that the exponent will be accessed correctly. */ if restore_pointer_regs then call cobol_reset_r$after_call; /* Restore pointer register (especially pointer registers 3 and 5. */ /* Generate code to convert the exponent to double precision floating binary. */ call con_to_float_bin (work_rop_ptr, rop_seg, rop_offset); /* Generate code to perform the exponentation of the two floating binary values. */ call do_exponentiation (lop_seg, lop_offset, rop_seg, rop_offset, result_seg, result_offset, imperative_stmt_tag, exp_proc_tag, restart_tag); /* Generate code to move and convert the floating binary result to the resultant operand. */ call con_from_float_bin (result_seg, result_offset, result_ptr); /* Restore the pointer registers */ call cobol_reset_r$after_call; exit: return; /**************************************************/ /* INTERNAL PROCEDURE */ /* emit_exp_proc */ /**************************************************/ emit_exp_proc: proc (exp_proc_tag); /* This internal procedure emits the "internal" procedure that performs exponentiation, into the cobol object segment. */ /* DECLARATION OF THE PARAMETERS */ dcl exp_proc_tag fixed bin; /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION exp_proc_tag A tag (label) number reserved by this procedure and defined by this procedure at the "entry point" instruction of the internal procedure which performs exponentiation. (output) */ /* DECLARATION OF INTERNAL STATIC VARIABLES */ /* DEFINITION OF THE "INTERNAL" PROCEDURE THAT PERFORMS EXPONENTIATION. */ /* NOTE: This internal procedure was derived from the Multics system routine power_. */ /* The code sequence defined by this declaration is described by three headings. 1. "Raw" binary instruction is the bit (36) representation of the instruction. 2. Meaning of raw instruction gives the opcode, address, etc of the instruction. 3. "Final" instruction gives the interpretation of those instructions that are modified from the contents of the declaration. There are two types of modification that are made to the raw instructions: a. instructions are fixed up for forward references. b. instructions are modified to reference type 4 links to external procedures. */ /* 5.2-1 */ dcl code1_instr (0:29) bit (36) static init ( /* "RAW" binary instruction Meaning "FINAL" instruction */ "000000000000000000111001000000000000"b, /* tra 0 */ /* tra over the internal procedure. */ "000000000000000011111000101000000100"b, /* tsx5 3,ic */ "001000000000000000100110011001000000"b, /* dfmp 1|0 */ "001000000000000000100011011001000000"b, /* dfld 1|0 */ "100000000000000000101001101000000011"b, /* fcmp =0.0,du */ "000000000000010101110000000000000100"b, /* tze 25,ic */ "010000000000000000100101111001000000"b, /* dfst 2|0 */ "000000000000000001111001110000001101"b, /* xec 1,5 */ "000000000000010000110000000000000100"b, /* tze 20,ic */ "000111000100000000100010101000000011"b, /* fcmg 28*1024+256,du */ "000000000000000110110000101000000100"b, /* tpl 6,ic */ "001000110000000000100011101000000011"b, /* ufa =35b25,du */ "000000000000000000001001110000000111"b, /* cmpq 0,dl */ "000000000000000011110000001000000100"b, /* tnz 3,ic */ "000000000000000000001001101000000111"b, /* cmpa 0,dl */ "100000000000000000111001000001010000"b, /* tra 0 */ /* power_integer_$power_integer_ */ "010000000000000000100011011001000000"b, /* dfld 2|0 */ "000000000000000000110000100000000000"b, /* tmi 0 */ /* tra to (neg)**(non-integer) code */ "010000000000000010011101010001000000"b, /* epp2 2|2 */ "010111111111111110010101011101000000"b, /* spri3 2|-2 */ "100000000000000000010111011001010000"b, /* tsp3 0 */ /* double_logarithm_$double_log_base_e_ */ "000000000000000000111001110000001101"b, /* xec 0,5 */ "010111111111111110011101011101010000"b, /* epp3 2|-2,* */ "100000000000000000111001000001010000"b, /* tra 0 */ /* double_exponential_$double_exponential_ */ "000000010100000000100011001000000011"b, /* fld =1.0,du */ "011000000000000000111001000001000000"b, /* tra 3|0 */ "001000000000000000100011000001000000"b, /* fszn 1|0 */ "000000000000000000110000000000000000"b, /* tze 0 */ /* tra to (zero)**(zero) code */ "011000000000000000110000101001000000"b, /* tpl 3|0 */ "000000000000000000111001000000000000"b); /* tra 0 */ /* tra to (zero)**(negative) code */ /* 5.2-1 */ dcl rel_code1 (0:59) bit (5) static aligned 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, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "10100"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "10100"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "10100"b, "00000"b, "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 code2_instr (2) bit (36) static init ("000000000000000001001000111000000011"b, /* cmpx7 1,du */ "011000000000000001110000000001000000"b); /* tze 3|1 */ dcl err_ret_inst bit (36) int static init ("010000000000000001111001000001000000"b); /* tra 2|1 */ dcl epp2_inst bit (36) int static init ("011000000000000000011101010001000000"b); /* epp2 3|0 */ dcl neg_non_int_code fixed bin int static init (47); /* (negative) ** (non-integer) object-time error code */ dcl zero_zero_code fixed bin int static init (48); /* (zero) ** (zero) object time error code. */ dcl zero_neg_code fixed bin int static init (49); /* (zero) ** (negative) object time error code. */ dcl neg_non_int_offset fixed bin int static init (17); /* Offset from the first word of code1_inst of the instruction that transfers to the (negative) ** (non_integer) error code, and which must be fixed up to reference this error code. */ dcl zero_zero_offset fixed bin int static init (27); dcl zero_neg_offset fixed bin int static init (29); dcl SPRP3 bit (10) int static init ("1011000110"b); /* 543(0) */ dcl LPRP2 bit (10) int static init ("1111100100"b); /* 762(0) */ /* DECLARATION OF INTERNAL AUTOMATIC VARIABLES */ dcl temp_ptr ptr; dcl temp_tag fixed bin; dcl save_offset fixed bin; dcl linkoff fixed bin; dcl ret_offset fixed bin; dcl pr3_save_load_inst bit (36) init ("0"b); dcl inst_index fixed bin; /**************************************************/ /* START OF EXECUTION */ /* emit_exp_proc */ /**************************************************/ start_exit_emit_exp_proc: /* Make a type 4 link to "power_integer_$power_integer_" */ call cobol_make_link$type_4 (linkoff, "power_integer_$power_integer_"); temp_ptr = addr (code1_instr (15)); /* Insert the link offset into the instruction in the internal procedure to be emitted. */ temp_ptr -> inst_struc_basic.wd_offset = bit (fixed (linkoff, 15)); /* Make a type 4 link to "double_logarithm_$double_log_base_e_" */ call cobol_make_link$type_4 (linkoff, "double_logarithm_$double_log_base_e_"); temp_ptr = addr (code1_instr (20)); /* Insert the link offset into the instruction in the internal procedure to be emitted. */ temp_ptr -> inst_struc_basic.wd_offset = bit (fixed (linkoff, 15)); /* Make a type 4 link to "double_exponential_$double_exponential_" */ call cobol_make_link$type_4 (linkoff, "double_exponential_$double_exponential_"); temp_ptr = addr (code1_instr (23)); /* Insert the link offset into the instruction in the internal procedure. */ temp_ptr -> inst_struc_basic.wd_offset = bit (fixed (linkoff, 15)); /* Define the exp_proc_tag at the 2nd instruction in the internal procedure. ( The first instruction is an unconditional transfer over the internal procedure. */ save_offset = cobol_$text_wd_off; /* Reserve a tag. */ exp_proc_tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; /* Define the tag */ call cobol_define_tag_nc (exp_proc_tag, save_offset + 1); /* Emit the first stream of code. */ if fixed_common.options.profile then do inst_index = 15, 20, 23; fixup_directive.location.offset = cobol_$text_wd_off + inst_index; call cobol_make_fixup (addr (fixup_directive)); end; call cobol_emit (addr (code1_instr (0)), addr (rel_code1 (0)), 30); /* Allocate 4 bytes of storage in the stack to receive PR3. (which is the pointer to the return location from this procedure. ) */ call cobol_alloc$stack (4, 0, ret_offset); /* Establish basic addressability to the temporary. */ inst_ptr = addr (pr3_save_load_inst); input_ptr = addr (input_buff (1)); reloc_ptr = addr (reloc_buff (1)); 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); /* EMIT error code for handling (negative) ** (non-integer) errors. */ /* Reserve a tag. */ temp_tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; /* Define this tag at the next instruction location. */ call cobol_define_tag (temp_tag); /* Make a reference to this tag in the code1 stream already emitted. */ call cobol_make_tagref (temp_tag, save_offset + neg_non_int_offset, null ()); /* Emit two instructions of pre-packaged code. The instructions are: cmpx7 1,du tze 3|1 */ call cobol_emit (addr (code2_instr (1)), null (), 2); /* Emit an instruction to store PR3 into the stack. This is necessary because the execution time error routine resets pr3 to point to cobol data. */ inst_ptr -> inst_struc_basic.fill1_op = SPRP3; call cobol_emit (inst_ptr, reloc_ptr, 1); /* Emit code to signal an object time error. */ call cobol_process_error (neg_non_int_code, 0, 0); /* Emit an instruction to load PR3 from the stack temporary. */ inst_ptr -> inst_struc_basic.fill1_op = LPRP2; call cobol_emit (inst_ptr, reloc_ptr, 1); /* Emit an instruction to return to the error return instruction of the calling code. (This instruction is executed only if the user hits restart after an execution time error is detected) */ call cobol_emit (addr (err_ret_inst), null (), 1);/* tra 2|1 */ /* Emit error code for handling (zero) ** (zero) error. */ temp_tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_define_tag (temp_tag); call cobol_make_tagref (temp_tag, save_offset + zero_zero_offset, null ()); call cobol_emit (addr (code2_instr (1)), null (), 2); /* Emit code to store PR3 into the stack temporary. */ inst_ptr -> inst_struc_basic.fill1_op = SPRP3; call cobol_emit (inst_ptr, reloc_ptr, 1); call cobol_process_error (zero_zero_code, 0, 0); inst_ptr -> inst_struc_basic.fill1_op = LPRP2; call cobol_emit (inst_ptr, reloc_ptr, 1); /* Emit an instruction to return to the error return instruction of the calling code. (This instruction is executed only if the user hits restart after an execution time error is detected) */ call cobol_emit (addr (err_ret_inst), null (), 1);/* tra 2|1 */ /* Emit code for handling (zero) ** (negative) error. */ temp_tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_define_tag (temp_tag); call cobol_make_tagref (temp_tag, save_offset + zero_neg_offset, null ()); call cobol_emit (addr (code2_instr (1)), null (), 2); /* Emit code to store PR3 into the stack temporary. */ inst_ptr -> inst_struc_basic.fill1_op = SPRP3; call cobol_emit (inst_ptr, reloc_ptr, 1); call cobol_process_error (zero_neg_code, 0, 0); /* Emit code to load PR3 from the stack temporary. */ inst_ptr -> inst_struc_basic.fill1_op = LPRP2; call cobol_emit (inst_ptr, reloc_ptr, 1); /* Emit an instruction to return to the error return instruction of the calling code. (This instruction is executed only if the user hits restart after an execution time error is detected) */ call cobol_emit (addr (err_ret_inst), null (), 1);/* tra 2|1 */ /* Define a tag at the next instruction location, and make a reference to it at the first instruction of the code stream generated so far. ( The transfer over the code. ) */ temp_tag = cobol_$next_tag; cobol_$next_tag = cobol_$next_tag + 1; call cobol_define_tag (temp_tag); call cobol_make_tagref (temp_tag, save_offset, null ()); exit_emit_exp_proc: return; end emit_exp_proc; /*{*/ convert_or_move: proc (source_token_ptr, dest_token_ptr); /* This internal procedure generates code to either 1. convert an unsigned decimal or trailing sign decimal value to a leading sign decimal value, and store the converted result in a word-aligned temporary, or 2. move a leading signed decimal or a floating decimal value from a byte-aligned address to a word- aligned temporary. */ /* DECLARATION OF THE PARAMETERS */ dcl source_token_ptr ptr; dcl dest_token_ptr ptr; /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION source_token_ptr Pointer to a data name (type 9) token that describes the value to be converted or moved. (input) dest_token_ptr Pointer to a data name (type 9) token that describes the value that has been converted or moved. (output) */ /*}*/ /* DECLARATION OF INTERNAL STATIC VARIABLES */ dcl 1 move_eos_token int static, 2 size fixed bin (15) init (40), 2 line fixed bin (15) init (0), 2 column fixed bin (15) init (0), 2 type fixed bin (15) init (19), /* EOS TOKEN */ 2 verb fixed bin (15) init (18), /* MOVE */ 2 e fixed bin (15) init (1); /* number of receiving operands */ /* DECLARATION OF INTERNAL VARIABLES */ dcl ret_offset fixed bin; dcl token_buff (1:10) ptr; /**************************************************/ /* START OF EXECUTION */ /* INTERNAL PROCEDURE: */ /* convert_or_move */ /**************************************************/ start_convert_or_move: dest_token_ptr = null (); /* Utility (make type 9) will provide buffer for the destination token */ /* Make a token for the destination field */ /* Make a copy of the source data name token. */ call cobol_make_type9$copy (dest_token_ptr, source_token_ptr); dn_ptr = dest_token_ptr; data_name.occurs_ptr = 0; data_name.edit_ptr = 0; data_name.ascii_packed_dec = "0"b; data_name.subscripted = "0"b; data_name.display = "1"b; if (data_name.sign_type = "000"b /* UNSIGNED */ | data_name.sign_type = "011"b /* TRAILING SEPERATE SIGN */) then do; /* Sign type not acceptable to pl1 operator routine. */ if data_name.sign_type = "000"b /* UNSIGNED */ then data_name.item_length = data_name.item_length + 1; /* Add one byte to hold sign */ data_name.sign_type = "100"b; /* Change sign type to leading separate. */ end; /* Sign type not acceptable to pl1 operator routine. */ /* Allocate space on the run-time stack, on a word boundary, into which the move and/or convert the source value. */ call cobol_alloc$stack (fixed (data_name.item_length, 35), 0 /* Word boundary, return char offset */, ret_offset); /* Update the destination token to address the stack temporary. */ data_name.seg_num = 1000; /* STACK */ data_name.offset = ret_offset; /* From cobol_alloc$stack */ /* Build the input token structure to pass to cobol_move_gen. */ in_token_ptr = addr (token_buff (1)); in_token.n = 4; in_token.token_ptr (in_token.n) = addr (move_eos_token); in_token.token_ptr (1) = null (); in_token.token_ptr (2) = source_token_ptr; /* Source for the move */ in_token.token_ptr (3) = dest_token_ptr; /* Destination of the move */ /* Call the move generator to generate code to move/convert */ call cobol_move_gen (in_token_ptr); exit_convert_or_move: return; end convert_or_move; /*{*/ con_to_float_bin: proc (source_token_ptr, result_seg, result_offset); /* This internal procedure generates code to convert a scaled, leading sign decimal value, or a floating decimal value to a double precision floating binary value. The code that is generated, builds a "calling sequence" and then "calls" the PL1 operator "real_to_real_rd". The "calling sequence" is described in the paragraphs following the declaration and description of the parameters. */ /* DECLARATION OF THE PARAMETERS */ dcl source_token_ptr ptr; dcl result_seg fixed bin; dcl result_offset fixed bin (24); /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION source_token_ptr Pointer to a data name token that describes the value to be converted to double precision floating binary. (input) This value is assumed to be aligned on a word boundary, and to be either a leading sign scaled or floating decimal value. result_seg Segment number of the segment in which the floating binary result of the conversion is stored by the code generated by this procedure. (output) result_offset Word offset, within the segment specified by result_seg, of the result of the conversion. This procedure allocates space for the result such that the result_offset value is always aligned on a double word boundary. (output) */ /* ENTRY CONDITIONS for PL1 Operators Procedure "real_to_real_rd" 1. PR3 points to the value to be converted. 2. PR1 points to storage into which the result of the conversion is to be placed. If the result of the conversion is to be a double-precision, floating binary value, then the pointer register MUST point to a pair of 6180 words, aligned on a double-word boundary. 3. PR5 points to a block of work storage to be used by the conversion routine. In this implementation, PR5 will always point to the top of the run-time stack. 4. Q-register contains the precision of the value to be converted. (source of conversion) See details below. 5. X7 contains a code that identifies the type of the value to be converted. See details below. 6. A-register contains the precision to which the value is to be converted. (destination of conversion) See details below. 7. X6 contains a code that identifies the type to which the value is to be converted. See details below. DETAILS CONCERNING THE PRECISION AND TYPE CODES. The precision of the source and destination of the conversion is specified in the Q and A registers, respectively. The precision that may appear in this implementation are specified as follows: 1. If the source or destination of the conversion is a numeric decimal, leading sign value, then bits 0-17 of the Q or A contain the scale factor (in two's complement format if negative) and bits 18-35 contain the precision. These values are obtained from the data name token (type 9) of the source or destination of conversion. a. scale factor is equal to the contents of data_name.places_right. b. precision is equal to data_name.item_length minus one. (one must be subtracted because the value of item_length includes one byte to hold the leading sign.) 2. If the source or destination of the conversion is floating decimal, then the Q or A register contains the precision, right justified. The precision is obtained from the data name token as follows: precision = data_name.item_length - 2 Two must be subtracted because item_length contains one byte for sign, and one byte for the exponent. 3. The codes that are specified in the index register 6 or 7 for this implementation can be any of the following: ------------------------------------------------- code | meaning -------------------------------------------------- 8 | real, floating binary, double precision 18 | real fixed decimal (leading sign) 20 | real floating decimal -------------------------------------------------- */ /*}*/ /* DECLARATION OF INTERNAL STATIC VARIABLES */ dcl lda_63_dl_const bit (36) int static init ("000000000000111111010011101000000111"b); /* LDA 63,DL */ /* DECLARATION OF INTERNAL VARIABLES */ dcl 1 precision aligned, 2 scale_factor bit (18) unaligned, 2 precision bit (18) unaligned; dcl precision_constant_ptr ptr; dcl precision_constant char (4) based (precision_constant_ptr); dcl precision_offset fixed bin; dcl source_type fixed bin; dcl ret_offset fixed bin; /**************************************************/ /* START OF EXECUTION */ /* INTERNAL PROCEDURE */ /* con_to_float_bin */ /**************************************************/ /* Initialize pointers used in calls to the addressability utility */ inst_ptr = addr (inst_buff (1)); reloc_ptr = addr (reloc_buff (1)); input_ptr = addr (input_buff (1)); start_con_to_float_bin: /* Initialize pointers used in calls to the register handling procedures */ pr_struc_ptr = addr (pr_struc); reg_struc_ptr = addr (reg_struc); /* Generate code to load PR3 with the address of the value being converted to floating binary. */ pr_struc.what_pointer = 3; /* PR3 */ pr_struc.lock = 0; /* Don't change locks */ pr_struc.switch = 2; /* Segment number and character offset supplied. */ pr_struc.segno = source_token_ptr -> data_name.seg_num; /* Segment number of source. */ pr_struc.offset = source_token_ptr -> data_name.offset; /* Offset of source (in characters) */ call pointer_register_load (pr_struc_ptr); /* Code is generated by this call */ /* Get the Q register. */ reg_struc.what_reg = 2; /* Q register */ reg_struc.lock = 0; /* No locks */ reg_struc.contains = 0; /* No meaningful data passed to register utility. */ call cobol_register$load (reg_struc_ptr); /* Generate code to load the Q register with the precision of the value being converted. */ inst_buff (1) = 0; if source_token_ptr -> data_name.sign_type ^= "111"b then do; /* Not floating decimal, must be scaled decimal. */ /* Build a constant containing the scale factor and precision. */ precision_constant_ptr = addr (precision.scale_factor); precision.scale_factor = bit (fixed (source_token_ptr -> data_name.places_right, 18, 0)); precision.precision = bit (fixed (source_token_ptr -> data_name.item_length - 1, 18, 0)); /* Pool the constant */ call cobol_pool (precision_constant, 0 /* Word boundary, return character offset */, precision_offset); /* Set up 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; /* Sending */ /* Get the address of the pooled constant. */ call cobol_addr (input_ptr, inst_ptr, reloc_ptr); source_type = 18; /* Real, scaled decimal */ end; /* Not floating decimal, must be scaled decimal. */ else do; /* Input value is floating decimal. */ inst_struc_basic.wd_offset = bit (fixed (source_token_ptr -> data_name.item_length - 2, 15, 0)); inst_struc_basic.td = "0111"b; /* dl */ source_type = 20; /* Real, floating decimal */ end; /* Input value is floating decimal. */ /* Insert the LDQ opcode into the instruction */ inst_struc_basic.fill1_op = ldq_op; /* Emit the LDQ instruction. */ call cobol_emit (inst_ptr, reloc_ptr, 1); /* Generate code to load index register 7 with a code that identifies the type of the value being converted. */ /* Get index register 7 */ reg_struc.what_reg = 17; /* Index register 7 */ reg_struc.lock = 0; reg_struc.contains = 0; call cobol_register$load (reg_struc_ptr); /* Complete the instruction */ inst_buff (1) = 0; inst_struc_basic.fill1_op = lxl7_op; inst_struc_basic.td = "0111"b; /* dl */ inst_struc_basic.wd_offset = bit (fixed (source_type, 15)); /* Code that identifies the type of the value being converted. */ /* Emit the lxl7 instruction */ reloc_buff (1) = 0; reloc_buff (2) = 0; call cobol_emit (inst_ptr, reloc_ptr, 1); /* Generate code to load the A register with the precision to which the value is to be conveerted. */ /* Get the A register. */ reg_struc.what_reg = 1; /* A register. */ reg_struc.lock = 0; reg_struc.contains = 0; /* Register contents not meaningful for optimization. */ call cobol_register$load (reg_struc_ptr); reloc_buff (1) = 0; reloc_buff (2) = 0; /* Since we're always converting to double precision floating binary, the LDA instruction to be emitted is a constant. */ call cobol_emit (addr (lda_63_dl_const), reloc_ptr, 1); /* Get index register 6 */ reg_struc.what_reg = 16; /* Index register 6 */ call cobol_register$load (reg_struc_ptr); /* Build the instruction. */ inst_buff (1) = 0; inst_struc_basic.fill1_op = lxl6_op; inst_struc_basic.td = "0111"b; /* dl */ inst_struc_basic.wd_offset = bit (fixed (binary (8), 15)); /* Double precision, real floating binary code. */ /* Emit the instruction. */ call cobol_emit (inst_ptr, reloc_ptr, 1); /* Generate code to load PR1 with the address of the variable to receive the converted value. */ /* Get a temporary to receive the converted value. Note that the temporary must be aligned on a double_word boundary. */ call cobol_alloc$stack (8, 2, ret_offset); result_offset = ret_offset; result_seg = 1000; /* STACK */ /* Generate code to load PR1. */ pr_struc.what_pointer = 1; /* PR1 */ pr_struc.switch = 1; /* Segment number and word offset suppolied. */ pr_struc.segno = result_seg; pr_struc.offset = result_offset; call pointer_register_load (pr_struc_ptr); /* This called procedure generates the code. */ /* Generate code to load PR 5 with a pointer to some work space (at the top of the run-time stack) for the PL1 operator procedure's use. Note that the temporary space must be aligned on a double word boundary. */ /* Allocate some space on an even-word boundary. */ call cobol_alloc$stack (8, 2, ret_offset); /* Generate code to load PR5. */ pr_struc.what_pointer = 5; /* PR5 */ pr_struc.switch = 1; /* Segment number and word offset supplied. */ pr_struc.segno = 1000; /* Stack */ pr_struc.offset = ret_offset; /* From cobol_alloc$stack */ call pointer_register_load (pr_struc_ptr); /* This call generates code. */ reloc_buff (1) = 0; reloc_buff (2) = 0; /* Generate code to transfer to the PL1 operator "real_to_real_rd" */ inst_buff (1) = 0; inst_struc_basic.fill1_op = tsx0_op; inst_struc_basic.wd_offset = bit (fixed (cobol_op_real_to_real_rd, 15, 0)); inst_struc_basic.pr_spec = "1"b; /* Pointer register specified in the instruction */ /* Emit the tsx0 instruction. */ call cobol_emit (inst_ptr, reloc_ptr, 1); exit_con_to_float_bin: return; end con_to_float_bin; /*{*/ do_exponentiation: proc (lop_seg, lop_offset, rop_seg, rop_offset, result_seg, result_offset, imperative_stmt_tag, exp_proc_tag, restart_tag); /* This procedure generates code that does the exponentiation of a value. The exponentiation is performed by the PL1 operators procedure "dbl_p_dbl". A description of the calling sequence and returned results of "dbl_p_dbl" follows the declaration and description of the parameters . */ /* DECLARATION OF THE PARAMETERS */ dcl lop_seg fixed bin; dcl lop_offset fixed bin (24); dcl rop_seg fixed bin; dcl rop_offset fixed bin (24); dcl result_seg fixed bin; dcl result_offset fixed bin (24); dcl imperative_stmt_tag fixed bin; dcl exp_proc_tag fixed bin; dcl restart_tag fixed bin; /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION lop_seg Contains the segment number of the double precision floating binary value to be exponentiated. (input) lop_offset Contains the word offset of the value to be exponentiated. (input) rop_seg Contains the segment number of the double precision floating binary value of the exponent. (input) rop_offset Contains the word offset of the exopnent in the segment specified by rop_seg. (input) result_seg Contains the segment number of a double-word aligned temporary into which the result of the exponentiation is stored. (output) result_offset Contains the word offset, in the segment specified by result_seg, of the result of the exponentiation. (output) imperative_stmt_tag A tag (label) number reserved and defined by the calling procedure at the imperative statement, if an ON SIZE ERROR clause was present in the source statement. (input) If this input value is zero, then no ON SIZE ERROR clause was present in the source statement being processed. exp_proc_tag a tag (label) defined at the "entry" inst- ruction of the internal procedure that does the exponentiation. (input) restart_tag A tag (label) defined at the first instruction of the code sequence that does the exponentiation. This tag , if not zero, is the tag to which to transfer if an execution time error is detected, and the user chooses to restart. (input) */ /*}*/ /* DECLARATION OF INTERNAL STATIC VARIABLES */ dcl tra_insts (2) bit (36) int static init ("000000000000000010111001000000000100"b, /* tra 2,ic */ "000000000000000000111001000000000000"b); /* tra 0 */ /* DECLARATION OF INTERNAL VARIABLES */ dcl temp_offset fixed bin; dcl temp_seg fixed bin; dcl temp_tag fixed bin; /**************************************************/ /* START OF EXECUTION */ /* INTERNAL PROCEDURE */ /* do_exponentiation */ /**************************************************/ start_do_exponentiation: /* Initialize pointers used in calls to the addressability utility */ inst_ptr = addr (inst_buff (1)); input_ptr = addr (input_buff (1)); reloc_ptr = addr (reloc_buff (1)); /* Generate code to load the value being exponentiated into the EAQ registers. */ /* Get the A and Q registers. */ reg_struc.what_reg = 3; /* A and Q */ reg_struc.lock = 0; reg_struc.contains = 0; /* No register optimization possible. */ call cobol_register$load (reg_struc_ptr); /* Build the DFLD instruction */ inst_buff (1) = 0; input_struc_basic.type = 1; input_struc_basic.operand_no = 0; input_struc_basic.lock = 0; input_struc_basic.segno = lop_seg; input_struc_basic.char_offset = lop_offset * 4; /* Get the address of the value being exponentiated. */ call cobol_addr (input_ptr, inst_ptr, reloc_ptr); /* Insert the dfld opcode */ inst_struc_basic.fill1_op = dfld_op; /* Emit the instruction */ call cobol_emit (inst_ptr, reloc_ptr, 1); /* Generate code to load PR1 with the address of the exponent. */ pr_struc.what_pointer = 1; /* PR1 */ pr_struc.lock = 0; pr_struc.switch = 1; /* Segment number and word offset supplied. */ pr_struc.segno = rop_seg; pr_struc.offset = rop_offset; call pointer_register_load (pr_struc_ptr); /* This procedure generates code to load the pr1 */ /* Generate code to load PR2 with the address of some temporary storage for use by the PL1 operator procedure. The temporary storage must be aligned on a double word boundary. */ /* Get some space on a double word boundary. */ call cobol_alloc$stack (8, 2, temp_offset); temp_seg = 1000; /* STACK */ /* Set up the input structure to the pointer register routine. */ pr_struc.what_pointer = 2; /* PR2 */ pr_struc.segno = temp_seg; /* STACK, remember. */ pr_struc.offset = temp_offset; /* From cobol_alloc$stack */ call pointer_register_load (pr_struc_ptr); /* Generate code to load X7 with 0 if no OSE was present, and with 1 if OSE was present. */ inst_buff (1) = 0; inst_struc_basic.fill1_op = lxl7_op; inst_struc_basic.td = "0111"b; /* dl */ if imperative_stmt_tag = 0 then inst_struc_basic.wd_offset = "0"b; /* lxl7 0,dl NO OSE PRESENT */ else inst_struc_basic.wd_offset = bit (fixed (binary (1), 15)); /* lxl7 binary(1),dl OSE WAS PRESENT */ call cobol_emit (inst_ptr, null (), 1); /* Generate code to transfer to the PL1 operator procedure "dbl_p_dbl". */ /* Generate code to transfer to the PL1 operator procedure "dbl_p_dbl". */ inst_buff (1) = 0; inst_struc_basic.fill1_op = tsp3_op; inst_struc_basic.pr_spec = "0"b; /* No PR specified in this instruction */ inst_struc_basic.wd_offset = "0"b; reloc_buff (1) = 0; reloc_buff (2) = 0; /* Emit the TSP3 instruction */ call cobol_emit (inst_ptr, reloc_ptr, 1); /* Make a refernece to exp_proc_tag at the instruction just emitted. */ call cobol_make_tagref (exp_proc_tag, cobol_$text_wd_off - 1, null ()); /* Emit the error return instruction. The error return instruction is always a transfer instruction, that transfers to one of two places: 1. If an ON SIZE ERROR clause was present, then the transfer instruction transfers to the on size clause. 2. If no OSE clause was present, then control will be returned to this instruction only if an execution time exponentiation error is detected, and the user hits restart. (hopefully after using debug to fix the cause of the execution time_error). Under these conditions, the transfer instruction returns to the first instruction of the code sequence that performs the exponentiation. */ call cobol_emit (addr (tra_insts), null (), 2); if imperative_stmt_tag ^= 0 then temp_tag = imperative_stmt_tag; /* ON SIZE ERROR clause was present. */ else temp_tag = restart_tag; /* no OSE clause present in the source statement. */ /* Fixup the transfer instruction just emitted to reference the proper tag. */ call cobol_make_tagref (temp_tag, cobol_$text_wd_off - 1, null ()); /* On returning from "dbl_p_dbl", the result of the exponentiation is contained as a double precision floating binnary value in the EAQ. Now we generate code to store the EAQ into a temporary. */ /* Allocate some space to receive the result. Note that the temporary must be aligned on a double word boundary. */ call cobol_alloc$stack (8, 2, temp_offset); result_offset = temp_offset; result_seg = 1000; /* STACK */ inst_buff (1) = 0; inst_struc_basic.fill1_op = dfst_op; inst_struc_basic.pr_spec = "1"b; inst_struc_basic.pr = "110"b; /* PR6 */ inst_struc_basic.wd_offset = bit (fixed (result_offset, 15, 0)); reloc_buff (1) = 0; reloc_buff (2) = 0; call cobol_emit (inst_ptr, reloc_ptr, 1); exit_do_exponentiation: return; end do_exponentiation; /*{*/ con_from_float_bin: proc (source_seg, source_offset, result_ptr); /* This procedure generates code to convert a value from double precision floating binary to floating decimal. The actual conversion is performed by the PL1 operators procedure "real_to_real_rd". A description of the "calling sequence" to this PL1 operators procedure follows the declaration and description of the parameters. */ /* DECLARATION OF THE PARAMETERS */ dcl source_seg fixed bin; dcl source_offset fixed bin (24); dcl result_ptr ptr; /* DESCRIPTION OF THE PARAMETERS */ /* PARAMETER DESCRIPTION source_seg Segment number of the double precision floating binary value to be converted. (input) source_offset Word offset of the value, within the segment specified by result_seg, of the value to be converted. (input) result_ptr Pointer to a data name token (type 9) that describes where the converted value is to be stored. (input) */ /* ENTRY CONDITIONS for PL1 Operators Procedure "real_to_real_rd" 1. PR3 points to the value to be converted. 2. PR1 points to storage into which the result of the conversion is to be placed. If the result of the conversion is to be a double-precision, floating binary value, then the pointer register MUST point to a pair of 6180 words, aligned on a double-word boundary. 3. PR5 points to a block of work storage to be used by the conversion routine. In this implementation, PR5 will always point to the top of the run-time stack. 4. Q-register contains the precision of the value to be converted. (source of conversion) See details below. 5. X7 contains a code that identifies the type of the value to be converted. See details below. 6. A-register contains the precision to which the value is to be converted. (destination of conversion) See details below. 7. X6 contains a code that identifies the type to which the value is to be converted. See details below. DETAILS CONCERNING THE PRECISION AND TYPE CODES. The precision of the source and destination of the conversion is specified in the Q and A registers, respectively. The precision that may appear in this implementation are specified as follows: 1. If the source or destination of the conversion is a numeric decimal, leading sign value, then bits 0-17 of the Q or A contain the scale factor (in two's complement format if negative) and bits 18-35 contain the precision. These values are obtained from the data name token (type 9) of the source or destination of conversion. a. scale factor is equal to the contents of data_name.places_right. b. precision is equal to data_name.item_length minus one. (one must be subtracted because the value of item_length includes one byte to hold the leading sign.) 2. If the source or destination of the conversion is floating decimal, then the Q or A register contains the precision, right justified. The precision is obtained from the data name token as follows: precision = data_name.item_length - 2 Two must be subtracted because item_length contains one byte for sign, and one byte for the exponent. 3. The codes that are specified in the index register 6 or 7 for this implementation can be any of the following: ------------------------------------------------- code | meaning -------------------------------------------------- 8 | real, floating binary, double precision 18 | real fixed decimal (leading sign) 20 | real floating decimal -------------------------------------------------- */ /*}*/ /* DECLARATIONS OF INTERNAL STATIC VARIABLES */ dcl a_and_x7 (2) bit (36) int static init ("000000000000111111010011110000000111"b, /* LDQ 63,DL */ "000000000000001000111010111000000111"b /* LXL7 8,DL */); dcl lxl6_20_dl bit (36) int static init ("000000000000010100111010110000000111"b /* LXL6 20,DL */); /* DECLARATION OF INTERNAL VARIABLES */ dcl ret_offset fixed bin; /**************************************************/ /* START OF EXECUTION */ /* INTERNAL PROCEDURE */ /* con_from_float_bin */ /**************************************************/ start_con_from_float_bin: /* Initialize pointers used to communicate with the addressability utility */ input_ptr = addr (input_buff (1)); inst_ptr = addr (inst_buff (1)); reloc_ptr = addr (reloc_buff (1)); /* Generate code to load the address of the value to be converted into PR3. */ pr_struc.what_pointer = 3; /* PR3 */ pr_struc.lock = 0; pr_struc.switch = 1; /* Segment number and word offset are supplied. */ pr_struc.segno = source_seg; pr_struc.offset = source_offset; call pointer_register_load (pr_struc_ptr); /* Generate code to load the Q register with the precision of the value being converted, and index register 7 with a code that identifies the type code of the value being converted. Since this procedure always converts from double precision floating binary, both values are known, and are always constants. Q is always loaded with 63 (decimal). x7 is always loaded with 8. */ inst_ptr = addr (a_and_x7 (1)); reloc_buff (1) = 0; reloc_buff (2) = 0; reloc_buff (3) = 0; reloc_buff (4) = 0; call cobol_emit (inst_ptr, reloc_ptr, 2); /* Generate code to load PR1 with the address of the variable to receive the converted value. */ pr_struc.what_pointer = 1; pr_struc.switch = 2; pr_struc.segno = result_ptr -> data_name.seg_num; pr_struc.offset = result_ptr -> data_name.offset; call pointer_register_load (pr_struc_ptr); /* This procedure generates the code. */ /* Generate code to load the A register with the precision of the receiving field. */ inst_ptr = addr (inst_buff (1)); inst_buff (1) = 0; inst_struc_basic.wd_offset = bit (fixed (result_ptr -> data_name.item_length - 2, 15, 0)); inst_struc_basic.fill1_op = lda_op; inst_struc_basic.td = "0111"b; /* dl */ inst_buff (2) = fixed (lxl6_20_dl, 35); call cobol_emit (inst_ptr, reloc_ptr, 2); /* Generate code to load PR5 with the address of some temporary space for use the the PL1 operator procedure. Note that the temporary must be aligned on a double word boundary. */ /* Get some temporary */ call cobol_alloc$stack (8, 2, ret_offset); pr_struc.what_pointer = 5; pr_struc.lock = 0; pr_struc.switch = 1; /* Segment number and word offset supplied */ pr_struc.segno = 1000; /* STACK */ pr_struc.offset = ret_offset; /* From cobol_alloc$stack */ /* Generate the code */ call pointer_register_load (pr_struc_ptr); /* Generate code to transfer to the PL1 operator procedure "real_to_real_rd" */ call cobol_call_op (15, 0); exit_con_from_float_bin: return; end con_from_float_bin; pointer_register_load: proc (pr_struc_ptr); /* This internal procedure generates code to load a pointer register with the addrress of a word aligned value. This procedure is necessary because the code generated to perform exponentation uses the Cobol "reserved" pointer registers 3 and 5 to communicate with the PL1 operator procedures that do the necessary conversion and exponentiation. The cobol pointer register handler routine, cobol_pointer_register$get, is not adequate for use here, because of the way it marks registers as being loaded, for possible optimization or error checking. */ /* DECLARATION OF THE PARAMETER */ dcl pr_struc_ptr ptr; /* DESCRIPTION OF THE PARAMETER */ /* pr_struc_ptr Pointer to a structure that provides input information to this procedure. (input) This structure is described and declared below. */ /* DECLARATION OF INTERNAL STATIC VARIABLES */ /* Declaration of the opcodes for the EPP instructions */ dcl epp_opcode (0:7) bit (10) aligned int static init ("0111010000"b, /* EPP0 */ "0111010011"b, /* EPP1 */ "0111010100"b, /* EPP2 */ "0111010111"b, /* EPP3 */ "0111110000"b, /* EPP4 */ "0111110011"b, /* EPP5 */ "0111110100"b, /* EPP6 */ "0111110111"b /* EPP7 */); /* DECLARATION OF INTERNAL VARIABLES */ dcl 1 pr_struc based (pr_struc_ptr), 2 what_pointer fixed bin, 2 pointer_no bit (3), 2 lock fixed bin, 2 switch fixed bin, 2 segno fixed bin, 2 offset fixed bin (24), 2 reset fixed bin; /* what_pointer specifies the pointer register to be obtained. (input) 0-7 - get this pointer register. pointer_no Not used by this procedure. lock Not used by this procedure. switch has the following values. (input) 1 - a segment number and word offset are supplied. 2 - a segment number and character offset are supplied segno is the segment number. (input) values recognized are: 2 - cobol data. 1000 - stack. 3000 - constants. 3002 - multics linkage. 4000 - cobol operators. 2nnnn - cobol linkage. -n - link in multics linkage. offset is the word or character offset (depending on switch). If a character offset is provided only the word portion is meaningful. (input) reset Not used by this procedure. */ dcl tchar_offset fixed bin; /**************************************************/ /* START OF EXECUTION */ /* INTERNAL PROCEDURE */ /* pointer_register_load */ /**************************************************/ start_pointer_register_load: /* Initialize pointers used in calls to the addressability utility. */ inst_ptr = addr (inst_buff (1)); input_ptr = addr (input_buff (1)); reloc_ptr = addr (reloc_buff (1)); if pr_struc.switch = 1 then tchar_offset = pr_struc.offset * 4; /* Convert from word to char offset */ else tchar_offset = pr_struc.offset; /* 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; /* No locks */ input_struc_basic.segno = pr_struc.segno; input_struc_basic.char_offset = tchar_offset; input_struc_basic.send_receive = 0; /* sending */ /* Call the addressability utility */ call cobol_addr (input_ptr, inst_ptr, reloc_ptr); /* Insert the appropriate EPP opcode into the instruction. */ inst_struc_basic.fill1_op = epp_opcode (pr_struc.what_pointer); /* Emit the EPP instruction */ call cobol_emit (inst_ptr, reloc_ptr, 1); exit_pointer_register_load: return; end pointer_register_load; /***** 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_in_token; %include cobol_; %include cobol_fixed_common; %include cobol_ext_; end cobol_exp3; */ ----------------------------------------------------------- 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 */