/* BEGIN INCLUDE FILE ... cobol_arith_util.incl.pl1 */ /* <<< LAST MODIFIED ON 9-08-76 by bc >>> */ /* <<< LAST MODIFIED ON 9-23-75 by tlf >>> */ /* <<< NAME OF INCLUDE FILE: cobol_arith_util.incl.pl1 >>> */ /**************************************************/ /* 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; /*************************************************/ /* 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. */ 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; 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; /* END INCLUDE FILE ... cobol_arith_util.incl.pl1 */ */ ----------------------------------------------------------- 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 */