



		    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|<stoff> */
			"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

*/
