



		    cobol_file_util.pl1             05/24/89  1041.5rew 05/24/89  0832.1       23814



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_file_util.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 8/11/76 by George Mercuri to add code for linage initialize. */
/* Modified on 4/27/76 by G. Mercuri  change code for new cobol_operators_. */
/* Modified on 4/21/76 by g. Mercuri to fix sxl5 in open_instr from 453 to 451. */
/* format: style3 */
cobol_file_util:
     proc (name_ptr, linage);

open:
     entry (name_ptr, linage);

dcl	name_ptr		ptr;			/* pts to type 12 token */
dcl	linage		fixed bin;		/* 0= no linage, 1= linage*/

dcl	open_instr	(4) bit (36) static init ("000000000000000000111010101000000111"b,
						/* lxl5 <2*no_of_files>,du */
			"000000000000000000111010110000000111"b,
						/* lxl6 <2*fd_token.file_no>,du */
			"000000000000011000111000000001000000"b,
						/* tsx0 pr0|30 */
			"000000000000011001111000000001000000"b);
						/* tsx0 pr0|31 */


dcl	temp		fixed bin;
dcl	cobol_emit	entry (ptr, ptr, fixed bin);


/*************************************/
start:
	temp = 2 * fixed_common.file_count;
	substr (open_instr (1), 1, 18) = substr (unspec (temp), 19, 18);
	temp = 2 * fd_token.file_no;
	substr (open_instr (2), 1, 18) = substr (unspec (temp), 19, 18);

	call cobol_emit (addr (open_instr), null (), 2);
	if linage = 1
	then call cobol_emit (addr (open_instr (3)), null (), 1);
	else call cobol_emit (addr (open_instr (4)), null (), 1);
	return;


/*************************************/

/*****	Declaration for builtin function	*****/

dcl	(substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index)
			builtin;

/*****	End of declaration for builtin function	*****/

%include cobol_type12;
%include cobol_fixed_common;
%include cobol_ext_;
%include cobol_;
     end cobol_file_util;




		    cobol_fix_driver_.pl1           05/24/89  1041.5rew 05/24/89  0832.1       52470



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_fix_driver_.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 04/01/81 by FCH, fix decl for map_data_table, [4.4-1], BUG472(TR8869,8970) */
/* Modified on 07/18/78 by RAL, [3.0-1], cobol_linkage_header.incl.pl1 changed */
/* Modified since Version 3.0.	*/
/*{*/
/* format: style3 */
cobol_fix_driver_:
     proc;

/*  This is the driver for the fixup phase of  the Multics
COBOL compiler.  It is called by the cobol driver and requires
no arguments.  It calls the following modules:  */

dcl	cobol_make_object_map
			entry;
dcl	cobol_mst		entry;
dcl	cobol_fixup	entry (ptr);
dcl	cobol_patch	entry (ptr);
dcl	cobol_paste	entry (ptr);

/* The pointer passed to each of these is to
an array containing values pertinent to the
structure of the components of the object segment.  */
/*}*/


dcl	value_ptr		ptr;
dcl	no_stmts_2	fixed bin;
dcl	1 map_data_table	aligned based (cobol_$map_data_ptr),
	  2 no_source_stmts fixed bin aligned,
	  2 data		(0 refer (map_data_table.no_source_stmts)),
	    3 line_no	fixed bin unaligned,
	    3 text_addr	fixed bin unaligned,	/*[4.4-1]*/
	    3 col		fixed bin unal,		/*[4.4-1]*/
	    3 label	bit unal;

dcl	1 value		aligned,
	  2 con_len	fixed bin aligned,
	  2 code_len	fixed bin aligned,
	  2 text_len	fixed bin aligned,
	  2 def_len	fixed bin aligned,
	  2 link_len	fixed bin aligned,
	  2 sym_len	fixed bin aligned,
	  2 int_storage_len fixed bin aligned,
	  2 exec_off	fixed bin aligned;		/* set by cobol_patch to wd before entry */

dcl	psb_ptr		ptr,
	psb_off		fixed bin;
dcl	(old_link, new_link, temp_relp, i, old_reloc, new_reloc, no_links)
			fixed bin,
	(cmp_cnt, cmp_bit, cmp_rest)
			fixed bin,
	(new_link_ptr, old_link_ptr)
			ptr;

dcl	1 link_temp	(no_links) aligned based,
	  2 header	bit (18) unal,
	  2 rest		bit (54) unal;

start:
	value.con_len = cobol_$constant_offset;

	if fixed_common.options.st
	then call cobol_mst;
	value.code_len = cobol_$text_wd_off;
	value.text_len = value.con_len + value.code_len;
	value.def_len = cobol_$def_wd_off;
	value.sym_len = cobol_$sym_wd_off;

	if fixed_common.options.profile
	then do;

		no_stmts_2 = map_data_table.no_source_stmts * 2 + 2;
		value.int_storage_len = fixed_static_length + no_stmts_2;
		sym_ptr = sym_base_ptr;
		psb_off = fixed (symbol_block_header.area_relp, 18);
		psb_ptr = addrel (sym_ptr, psb_off);
		psb_ptr -> pl1_symbol_block.profile = linkage_header.links_relp;
		psb_ptr -> pl1_symbol_block.flags.profile = "1"b;
		value.link_len = cobol_$link_wd_off + no_stmts_2;
		old_link = fixed (linkage_header.links_relp);
		new_link = old_link + no_stmts_2;
		old_link_ptr = addrel (link_base_ptr, old_link);
		new_link_ptr = addrel (link_base_ptr, new_link);
		no_links = cobol_$link_wd_off - 8 - fixed_static_length;
		no_links = divide (no_links, 2, 17, 0);

		if no_links > 0
		then do;

			old_reloc = old_link * 10 - 19;
			new_reloc = new_link * 10 - 19;
			relptr = cobol_$reloc_link_base_ptr;
			i = no_stmts_2 * 2;
			cmp_cnt = divide (i, 1023, 17, 0);
			cmp_rest = mod (i, 1023);
			cmp_bit = 15 * (cmp_cnt + 1);
			n_bits = n_bits + cmp_bit;

/* The 23rd bit of relbits are the first link.	*/

			substr (relbits, 23 + cmp_bit, no_links * 12) = substr (relbits, 23, no_links * 12);

			if cmp_cnt ^= 0
			then do i = 1 to cmp_cnt;

				substr (relbits, 8 + i * 15) = "111101111111111"b;

			     end;

			substr (relbits, 23 + cmp_cnt * 15, 5) = "11110"b;
			substr (relbits, 28 + cmp_cnt * 15, 10) = substr (unspec (cmp_rest), 27, 10);
			linkage_header.links_relp = substr (unspec (new_link), 19, 18);

			cobol_$link_wd_off = cobol_$link_wd_off + no_stmts_2;

			do i = no_links to 1 by -1;

			     temp_relp = fixed (old_link_ptr -> link_temp.header (i)) - no_stmts_2;
			     new_link_ptr -> link_temp.rest (i) = old_link_ptr -> link_temp.rest (i);
			     new_link_ptr -> link_temp.header (i) = substr (unspec (temp_relp), 19, 18);

			end;

			do i = 1 to (map_data_table.no_source_stmts + 1);

			     temp_relp = (i - 1) * 2;
			     old_link_ptr -> link_temp.header (i) = substr (unspec (temp_relp), 19, 18);
			     old_link_ptr -> link_temp.rest (i) = (54)"0"b;

			end;
		     end;
	     end;
	else do;

		value.int_storage_len = fixed_static_length;
		value.link_len = cobol_$link_wd_off;

	     end;

	value_ptr = addr (value);

	if fixed_common.options.m_map
	then call cobol_make_object_map;

	call cobol_fixup (value_ptr);
	call cobol_patch (value_ptr);
	call cobol_paste (value_ptr);

exit:
	return;


/*****	Declaration for builtin function	*****/

dcl	(substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index)
			builtin;

/*****	End of declaration for builtin function	*****/

%include cobol_fixed_static;
%include cobol_;
%include cobol_fixed_common;
%include cobol_ext_;
%include cobol_linkage_header;
/* [3.0-1] */
%include pl1_symbol_block;
%include cobol_sbh;
%include cobol_relinfo;
     end cobol_fix_driver_;




		    cobol_fixup.pl1                 05/24/89  1041.5rew 05/24/89  0832.1       70254



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_fixup.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 04/01/81 by FCH, fix decl for map_data_table, [4.4-1], BUG472(TR8869,8970) */
/* Modified on 5/16/80 by FCH, [4.2-1], compute size of DEF table */
/* Modified on 11/07/78 by FCH, [3.0-1], type31 evaluation */
/* Modified since Version 3.0 */

/* format: style3 */
cobol_fixup:
     proc (value_ptr);

dcl	val		(7) fixed bin aligned based (value_ptr);
dcl	segptr		(4) ptr;

dcl	wptr		ptr;			/* points to word to be set in cobol_text */
dcl	halfword		(0:1) bit (18) based (wptr);
dcl	1 instr		based (wptr) aligned,
	  2 address	bit (18) unaligned,
	  2 fill		bit (14) unaligned,
	  2 reg		bit (4) unaligned;


dcl	bytes		char (8) based;

dcl	(i, j, k)		fixed bin;
dcl	utemp		fixed bin;
dcl	1 map_data_table	aligned based (cobol_$map_data_ptr),
	  2 no_source_stmts fixed bin aligned,
	  2 data		(0 refer (map_data_table.no_source_stmts)),
	    3 line_no	fixed bin unaligned,
	    3 text_addr	fixed bin unaligned,	/*[4.4-1]*/
	    3 col		fixed bin unal,		/*[4.4-1]*/
	    3 label	bit unal;


/*************************************/
start_fixup:					/* [3.0-1] */
	call eval_equate;

	segptr (1) = cobol_$text_base_ptr;
	segptr (2) = cobol_$def_base_ptr;
	segptr (3) = cobol_$link_base_ptr;
	segptr (4) = cobol_$sym_base_ptr;

	if fixup_table.count > 0
	then do i = 1 to fixup_table.count;

		if table.type (i) = (4)"0"b
		then do;				/* tag type fixup */

			wptr = addrel (cobol_$text_base_ptr, table.offset (i));
			j = table.tag_number (i);	/* [3.0-1]
		if TAG.tag_table(j) < 0 then do while(TAG.tag_table(j) < 0);
		     j = -TAG.tag_table(j);
		end;
*/
			k = TAG.tag_table (j);	/* the real offset in cobol_text_seg */

			if k = 0
			then go to fixup_error;

			utemp = fixed (instr.address, 18) + k;
			instr.address = substr (unspec (utemp), 19, 18);

		     end;
		else do;				/* general "section-related" fixup */

			j = fixed (table.location.half (i), 1);
			k = fixed (table.type (i), 4);
			wptr = addrel (segptr (fixed (table.base (i), 3)), table.offset (i));
			utemp = fixed (halfword (j), 18);

			if k ^= 15
			then do;
				if table.operation (i)
				then utemp = utemp - val (k);
				else utemp = utemp + val (k);
			     end;
			else utemp = utemp + map_data_table.no_source_stmts * 2 + 2;

			halfword (j) = substr (unspec (utemp), 19, 18);
		     end;

fix_cont:
	     end;

	return;

/* [3.0-1] */

eval_equate:
     proc;

/**/
declare	(i, new, old, tt, tn, val)
			fixed bin;		/**/
						/**/
	if DEF.tag_max = 0
	then return;				/**/
						/**/
	do while ("1"b);				/**/
						/**/
	     new, old = 0;				/**/
						/**/
	     do i = 1 by 1 to DEF.tag_max;		/**/
						/**/
		tt = TAG.tag_table (i);		/**/
		tn = TAG.tag_no (i);		/**/
						/**/
		if tt = 0				/**/
		then if tn ^= 0			/**/
		     then do;
			     val = TAG.tag_table (tn);/**/
						/**/
						/**/
			     if val ^= 0		/**/
			     then do;
				     TAG.tag_table (i) = val;
						/**/
				     new = 1;	/**/
				end;		/**/
			end;			/**/
		old = 1;				/**/
	     end;					/**/
						/**/
	     if new = 0 | old = 0
	     then return;				/**/
						/**/
	end;
     end;

/* [3.0-1] */

/*************************************/

cobol_define_tag:
     entry (tagno);

/* dcl tagno fixed bin;	/* internal tag number (input) */

start_define_tag:					/*[3.0-1]*/
	if tagno = 0
	then return;

	if TAG.tag_table (tagno) > 0
	then go to define_error;

	TAG.tag_table (tagno) = cobol_$text_wd_off;
	call cobol_reset_r$in_line;

/*[4.2-1]*/
	DEF.tag_max = max (DEF.tag_max, tagno);

	return;


/*************************************/

cobol_define_tag_nc:
     entry (tagno, locno);

dcl	tagno		fixed bin;		/* internal tag number (input) */
dcl	locno		fixed bin;		/* wd offset in cobol_text_seg (input) */

start_define_tag_nc:				/*[3.0-1]*/
	if tagno = 0
	then return;

	if TAG.tag_table (tagno) > 0
	then go to define_error;
	TAG.tag_table (tagno) = locno;

/*[4.2-1]*/
	DEF.tag_max = max (DEF.tag_max, tagno);

	return;


/*************************************/

cobol_equate_tag:
     entry (token31_ptr);

dcl	token31_ptr	ptr;			/* ptr to a type 31 token (input)*/


dcl	1 token31		based (token31_ptr),
	  2 header,
	    3 size	fixed bin (15),
	    3 line	fixed bin (15),
	    3 column	fixed bin (7),
	    3 type	fixed bin (7),
	  2 body,
	    3 verb	fixed bin (15),
	    3 tagno1	fixed bin (15),
	    3 tagno2	fixed bin (15);

start_equate_tag:					/* [3.0-1] */
	if TAG.tag_table (token31.tagno1) = 0		/* [3.0-1] */
	then TAG.tag_table (token31.tagno1) = TAG.tag_table (token31.tagno2);

/* [3.0-1] */
	TAG.tag_no (token31.tagno1) = token31.tagno2;

/*[4.2-1]*/
	DEF.tag_max = max (DEF.tag_max, token31.tagno1, token31.tagno2);

	return;


/*************************************/

cobol_make_tagref:
     entry (tagno, locno, instr_ptr);

/* dcl tagno fixed bin;	/* internal tag number (input) */
/* dcl locno fixed bin;	/* wd offset in cobol_text_seg (input) */
dcl	instr_ptr		ptr;			/* ptr to instr wd if non-null (input) */

start_make_tagref:
	if instr_ptr = null ()
	then wptr = addrel (cobol_$text_base_ptr, locno);
	else wptr = instr_ptr;
	instr.reg = "0100"b;			/* IC modification */

	if TAG.tag_table (tagno) > 0
	then do;
		utemp = TAG.tag_table (tagno) - locno;
		instr.address = substr (unspec (utemp), 19, 18);
	     end;
	else do;					/* tag not yet defined - make fixup */
		fixdef.wd1 = locno;
		fixdef.wd2 = tagno;
		utemp = -locno;
		instr.address = substr (unspec (utemp), 19, 18);
		i = fixup_table.count * 8 + 5;
		substr (cobol_$fixup_ptr -> bytes, i, 8) = substr (addr (fixdef) -> bytes, 1, 8);
		fixup_table.count = fixup_table.count + 1;
	     end;

/*[4.2-1]*/
	DEF.tag_max = max (DEF.tag_max, tagno);
	return;


/*************************************/
cobol_make_fixup:
     entry (fix_ptr);

dcl	fix_ptr		ptr;			/* pointer to fixup directive (input) */

start_make_fixup:
	i = fixup_table.count * 8 + 5;
	substr (cobol_$fixup_ptr -> bytes, i, 8) = substr (fix_ptr -> bytes, 1, 8);
	fixup_table.count = fixup_table.count + 1;
	return;


/*************************************/
fixup_error:
	error_info.name = "cobol_fixup";
	call ioa_$rsnnl ("Inconsistency in fixup table entry^d->^d at location ^o (before fixup)", message, message_len,
	     i, j, table.offset (i));
	call signal_ ("command_abort_", null (), addr (error_info));
	go to fix_cont;

define_error:
	error_info.name = "cobol_define_tag";
	call ioa_$rsnnl ("Attempt to multiply define tag #^d", message, message_len, tagno);
	go to error;

equate_error:
	error_info.name = "cobol_equate_error";
	call ioa_$rsnnl ("Inconsistency in Type 31 token -  setting ^d = ^d", message, message_len, token31.tagno1,
	     token31.tagno2);
	go to error;

error:
	call signal_ ("command_abort_", null (), addr (error_info));

/*************************************/
%include cobol_fixup_info;
%include cobol_fixup_data;
     end cobol_fixup;




		    cobol_fofl_mask.pl1             05/24/89  1041.5rew 05/24/89  0832.1       35802



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_fofl_mask.pl1 Added Trace statements.
                                                   END HISTORY COMMENTS */


/* Modified on 10/19/85 by FCH, [5.3-1], BUG563(phx18381), new cobol_addr_tokens.incl.pl1 */
/* Modified on 05/12/77 by Bob Chang to implement continue option.	*/
/*{*/

/* format: style3 */
cobol_fofl_mask:
     proc;

/*
This procedure generates code to disable and enable the overflow
fault trap.  The fault trap is disabled by turning ON the
overflow mask indicator bit in the machine indicator register,
and is enabled by turning this bit OFF.  */

/*}*/


/*  DECLARATION OF EXTERNAL ENTRIES  */

dcl	cobol_addr	ext entry (ptr, ptr, ptr);
dcl	cobol_pool	ext entry (char (*), fixed bin, fixed bin (24));
dcl	cobol_emit	ext entry (ptr, ptr, fixed bin);

/*  DECLARATIONS OF INTERNAL STATIC VARIABLES  */

dcl	ldi_masks_pooled	fixed bin int static init (0);

dcl	oflo_mask_on	bit (36) int static init ("000000000000000000000000100000000000"b);
						/*  overflow mask indicator bit ON  */

dcl	oflo_mask_off	bit (36) int static init ("0"b);

dcl	on_mask_inst	bit (36) int static;
dcl	on_mask_reloc	(1:5) bit (5) aligned;

dcl	ldi_inst		bit (36) static init ("110000000001110100110011100001000000"b);
						/* ldi	pr6|164	*/

dcl	LDI		bit (10) int static init ("1100111000"b);
						/*  634(0)  */

dcl	on_ret_offset	fixed bin (24) int static;
dcl	off_ret_offset	fixed bin (24) int static;


/*  DECLARATIONS OF INTERNAL VARIABLES  */

dcl	mask_ptr		ptr;
dcl	mask_string	char (4) based (mask_ptr);
dcl	input_buffer	(1:10) char (4);

/*  ON ENTRY POINT  */

on:
     entry;

	if ldi_masks_pooled ^= cobol_$compile_count
	then do;					/*  Pool the LDI masks  */

/*  Pool the overflow mask indicator ON constant  */
		mask_ptr = addr (oflo_mask_on);
		call cobol_pool (mask_string, 0, on_ret_offset);


/*  Pool the overflow mask indicator OFF constant.  */
		mask_ptr = addr (oflo_mask_off);
		call cobol_pool (mask_string, 0, off_ret_offset);


		ldi_masks_pooled = cobol_$compile_count;

	     end;					/*  Pool the LDI masks and establish basic addressability to them.  */


/*  Get the basic address of the overflow mask indicator ON constant.  */
	input_ptr = addr (input_buffer);
	input_struc_basic.type = 1;
	input_struc_basic.operand_no = 0;
	input_struc_basic.lock = 0;
	input_struc_basic.char_offset = on_ret_offset;
	input_struc_basic.segno = 3000;		/*  constant segment  */

	call cobol_addr (input_ptr, addr (on_mask_inst), addr (on_mask_reloc));

	inst_ptr = addr (on_mask_inst);
	inst_ptr -> inst_struc_basic.fill1_op = LDI;	/*  Emit an LDI instruction to turn on the mask indicator bit.  */
	call cobol_emit (addr (on_mask_inst), addr (on_mask_reloc), 1);

	return;

/*  OFF ENTRY POINT  */

off:
     entry;
	call cobol_emit (addr (ldi_inst), null, 1);
	return;


/*  INCLUDE FILES USED BY THIS PROCEDURE  */


/*****	Declaration for builtin function	*****/

dcl	(substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index)
			builtin;

/*****	End of declaration for builtin function	*****/

%include cobol_addr_tokens;


%include cobol_;

     end cobol_fofl_mask;




		    cobol_gen_driver_.pl1           05/24/89  1041.5rew 05/24/89  0832.1      271512



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_gen_driver_.pl1 Added Trace statements.
  2) change(89-04-23,Zimmerman), approve(89-04-23,MCR8082),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8082 cobol_gen_driver_.pl1 Fix wild array subscript.
                                                   END HISTORY COMMENTS */


/* Modified on 02/01/85 by FCH, [5.3-2], BUG561, cond statements revised */
/* Modified on 10/19/84 by FCH, [5.3-1], BUG563(phx18381), new cobol_addr_tokens.incl.pl1 */
/* Modified on 09/03/83 by FCH, [5.2...], trace added */
/* Modified on 01/20/81 by FCH, [4.4-1], BUG461, statement map incorrect if statement follows para at end of perf range */
/* Modified on 05/16/80 by FCH, [4.2-5], decl for tag_addr corrected */
/* Modified on 04/18/80 by FCH, [4.2-4], tag stack added */
/* Modified on 04/08/80 by FCH, [4.2-3], subscripts lost if abbrev compare BUG428(TR3271) */
/* Modified on 10/20/79 by PRP, [4.1-2], recognize paragraph names for statement map */
/* Modified on 10/20/79 by PRP, [4.1-1], add to map_data_table for statement map */
/* Modified on 06/27/79 by FCH, [4.0-1], not option added for debug */
/* Modified since Version 4.0 */
/* format: style3 */
cobol_gen_driver_:
     proc;

dcl	on_err_tag	fixed bin,
	subscript_flag	fixed bin,
	binit_tag		fixed bin,
	decl_flag		fixed bin,
	last_decl_proc	fixed bin,
	fxs_tag		fixed bin,
	fxs_locno		fixed bin,
	index		fixed bin,
	pc_flag		fixed bin,
	search_flag	fixed bin,
	temp		fixed bin,
	token_type	fixed bin,
	sub_token_index	fixed bin,
	space_ptr		ptr,
	subscript_ptr	ptr,
	record_ptr	ptr,
	current_token_ptr	ptr static int,
	temp_prev_ptr	ptr,
	bypass_flag	bit (1),
	temp_ptr		ptr,
	decl_sw		fixed bin,
	(end_flag, off)	fixed bin;		/*[4.2-4]*/
declare	tag_stack_loc	fixed bin;		/*[4.2-4]*/
declare	tag_stack		(512) fixed bin;



dcl	dn_ptr		ptr,
	h_no		fixed bin;


dcl	seq_file_hdr	(8) fixed bin aligned based (cobol_$minpral5_ptr);

dcl	1 shdr		based (cobol_$minpral5_ptr) aligned,
						/* header of working file */
	  2 x1		char (12),
	  2 next		fixed bin,		/* offset of next token */
	  2 code		fixed bin,		/* 10 for sequential file */
	  2 x3		char (4),			/* unused */
	  2 next_file	ptr,
	  2 prev_file	ptr,			/* points to previous file */
	  2 fc		char (4),			/* file code for each different kind of file */
	  2 file_no	fixed bin,		/* file count for each working file */
	  2 x2		char (12),		/* unused */
	  2 first		fixed bin;		/* first token */


dcl	1 record		aligned based (record_ptr),
	  2 prev_rcd_ln	fixed bin aligned,
	  2 this_rcd_ln	fixed bin aligned;

dcl	1 token_hdr	aligned based (in_token.token_ptr (in_token.n)),
	  2 size		fixed bin (15) aligned,
	  2 line		fixed bin (15) aligned,
	  2 column	fixed bin (15) aligned,
	  2 type		fixed bin (15) aligned,
	  2 sub_ptr	ptr unal;

dcl	1 sub_token	aligned based (in_token_ptr),
	  2 pad1		fixed bin aligned,
	  2 pad2		fixed bin aligned,
	  2 sub_token_ptr	(511) ptr aligned;

dcl	1 map_data_table	aligned based (cobol_$map_data_ptr),
	  2 no_source_stmts fixed bin aligned,
	  2 data		(0 refer (map_data_table.no_source_stmts)),
	    3 line_no	fixed bin unaligned,
	    3 text_addr	fixed bin unaligned,
	    3 col		fixed bin unaligned,
	    3 label	bit unaligned;

/*[4.2-5]*/
declare	1 DEF		aligned based (cobol_$tag_table_ptr),
						/*[4.2-5]*/
	  2 tag_max	fixed bin,		/*[4.2-5]*/
	  2 TAG		(32767),			/*[4.2-5]*/
	    3 tag_addr	fixed bin (17) unal,	/*[4.2-5]*/
	    3 tag_no	fixed bin (17) unal;


/*************************************/
start:	/***..... Trace_Bit="0"b;/**/
	/***..... Trace_Lev=0;/**/
	/***..... Trace_Line="0123456789ABCDEFGHIJKLMOOPQRSTUVWXYZ";/**/
						/*  PROCESS ALTER/PERFORM INFORMATION  */
	space_ptr = cobol_$misc_end_ptr;

	if fixed_common.perf_alter_info ^= "00000" | fixed_common.size_perform_info ^= "00000"
	then call cobol_alter_perform (space_ptr, cobol_$misc_max);

	else do;
		cobol_$alter_list_ptr = null;
		cobol_$perform_list_ptr = null;
		cobol_$seg_init_list_ptr = null;
		seg_init_flag = 0;
	     end;

comp_token_area:
	cobol_$temp_token_max = cobol_$misc_max - binary (rel (space_ptr), 17) + binary (rel (cobol_$misc_end_ptr), 17);

	if cobol_$temp_token_max < 28
	then do;

		error_info.message = "Temporary token area overflow";
		error_info.message_len = 29;

		call signal_ ("command_abort_", null, addr (error_info));

		goto comp_token_area;

	     end;

	cobol_$temp_token_area_ptr = space_ptr;
	cobol_$temp_token_ptr = space_ptr;
	cobol_$misc_end_ptr = null;



	bypass_flag = "0"b;
	cobol_$sect_eop_flag = 0;
	cobol_$para_eop_flag = 0;
	cobol_$alter_flag = 0;
	cobol_$alter_index = 1;
	cobol_$perform_para_index = 1;
	cobol_$perform_sect_index = 0;
	cobol_$priority_no = 0;
	decl_flag = 0;
	end_flag = 0;
	last_decl_proc = 0;
	on_err_tag = 0;				/*[4.2-4]*/
	tag_stack_loc = 0;
	pc_flag = 0;
	search_flag = 0;
	subscript_flag = 0;
	cobol_$init_stack_off = 68;
	cobol_$stack_off = cobol_$init_stack_off;
	cobol_$max_stack_off = cobol_$init_stack_off;
	in_token_ptr = cobol_$token_block1_ptr;
	in_token.n = 0;
	sub_token_index = 511;
	in_token.code = 0;
	map_data_table.no_source_stmts = 0;

	if fixed_common.prog_coll_seq ^= 0
	then do;

		index = fixed_common.prog_coll_seq;

		call cobol_read_rand$fixed_bin (2, index, alpha_name_ptr);

		cobol_$main_pcs_ptr = alpha_name_ptr;

		if alphabet_name.iw_key = 0
		then do;
			call cobol_pool (alphabet_name.table, 2, alphabet_name.offset);
			alphabet_name.offset = alphabet_name.offset * 4;
			alphabet_name.segno = 3000;
		     end;

		if alphabet_name.iw_key = 11
		then alpha_name_ptr = null ();	/* ascii */

	     end;
	else cobol_$main_pcs_ptr = null ();

	temp_prev_ptr = shdr.prev_file;

	if temp_prev_ptr ^= null ()
	then do while (temp_prev_ptr ^= null ());
		cobol_$minpral5_ptr = temp_prev_ptr;
		temp_prev_ptr = cobol_$minpral5_ptr -> shdr.prev_file;
	     end;

	record_ptr = addrel (cobol_$minpral5_ptr, seq_file_hdr (5) + 4);

	goto eof_test;

/*  .......  GET TOKENS COMPRISING "STATEMENT"  .......	  */

get_tokens:
	if on_err_tag < 0
	then do;
		on_err_tag = 0;
		bypass_flag = "1"b;
	     end;

	if in_token.code > 0
	then in_token.n = in_token.code;
	else do;

		if search_flag = 0
		then do;
			if cobol_$stack_off > cobol_$max_stack_off
			then cobol_$max_stack_off = cobol_$stack_off;
			cobol_$stack_off = cobol_$init_stack_off;
		     end;
		cobol_$temp_token_ptr = cobol_$temp_token_area_ptr;

		if in_token.code = -1
		then if in_token_ptr = cobol_$token_block1_ptr
		     then in_token_ptr = cobol_$token_block2_ptr;
		     else in_token_ptr = cobol_$token_block1_ptr;
		in_token.n = 0;

	     end;

	in_token.code = 0;				/*[4.2-3]*/
	if h_no ^= 13
	then sub_token_index = 511;

get_next_token:
	temp = record.this_rcd_ln + 7;
	record_ptr = addrel (record_ptr, substr (unspec (temp), 17, 18));


eof_test:
	if record.this_rcd_ln <= 0
	then do;

		if shdr.next_file = null ()
		then go to data_and_seg_init;
		else do;

			cobol_$minpral5_ptr = shdr.next_file;
			record_ptr = addrel (cobol_$minpral5_ptr, seq_file_hdr (5) + 4);

			if record.this_rcd_ln <= 0
			then go to data_and_seg_init;
		     end;
	     end;

type_tests:
	in_token.n = in_token.n + 1;

token_block_ovfl_test:
	if in_token.n > sub_token_index
	then do;

		error_info.message = "Token block overflow";
		error_info.message_len = 20;
		call signal_ ("command_abort_", null, addr (error_info));

		goto token_block_ovfl_test;

	     end;

	in_token.token_ptr (in_token.n) = addrel (record_ptr, 2);
	current_token_ptr = addrel (record_ptr, 2);
	token_type = token_hdr.type;

	/***.....	if Trace_Bit/**/
	/***.....	then call ioa_("^30x^a^d^x^a^d^x^a^p^x^a^d",/**/
	/***.....			"TOKEN: LINE= ",token_hdr.line,"COL= ",token_hdr.column,"LOC= ",record_ptr,/**/
	/***.....			"TYPE= ",token_type);/**/


	if token_type = 7				/*[4.1-2]*/
	then do;

/*[4.4-1]*/
		off = cobol_$text_wd_off;		/*[4.4-1]*/
		if cobol_$para_eop_flag ^= 0
		then off = off + 2;			/* last para was end of perform */


		map_data_table.no_source_stmts = map_data_table.no_source_stmts + 1;
		map_data_table.data.line_no (map_data_table.no_source_stmts) = current_token_ptr -> proc_def.line;
		map_data_table.data.text_addr (map_data_table.no_source_stmts) = off;
		map_data_table.col (map_data_table.no_source_stmts) = current_token_ptr -> proc_def.column;
						/*[4.1-1]*/
		map_data_table.label (map_data_table.no_source_stmts) = "1"b;

	     end;

	if token_type = reserved_wd
	then do;

		if subscript_flag ^= 0
		then do;

			sub_token.sub_token_ptr (sub_token_index) = current_token_ptr;
			in_token.n = in_token.n - 1;
			sub_token_index = sub_token_index - 1;

			goto get_next_token;


		     end;

		if current_token_ptr -> reserved_word.end_cobol
						/*[4.1-1]*/
		then do;

			if current_token_ptr -> reserved_word.column ^= 9999
			then do;

				map_data_table.no_source_stmts = map_data_table.no_source_stmts + 1;
				map_data_table.data.line_no (map_data_table.no_source_stmts) =
				     current_token_ptr -> reserved_word.line;
				map_data_table.data.text_addr (map_data_table.no_source_stmts) =
				     cobol_$text_wd_off;
				map_data_table.col (map_data_table.no_source_stmts) =
				     current_token_ptr -> reserved_word.column;
				map_data_table.label (map_data_table.no_source_stmts) = "0"b;
				map_data_table.data.line_no (map_data_table.no_source_stmts + 1) =
				     current_token_ptr -> reserved_word.line + 1;

			     end;

			else map_data_table.data.line_no (map_data_table.no_source_stmts + 1) =
				current_token_ptr -> reserved_word.line;

		     end;

		if current_token_ptr -> reserved_word.verb = "1"b
		then do;

			if pd_map_sw = 1 & end_flag = 0
			then do;

test1_map_data_ovfl:
				if map_data_table.no_source_stmts + 2 > cobol_$map_data_max
				then do;

					error_info.message = "Object map overflow";
					error_info.message_len = 19;

					call signal_ ("command_abort_", null, addr (error_info));

					goto test1_map_data_ovfl;

				     end;

				map_data_table.no_source_stmts = map_data_table.no_source_stmts + 1;

				map_data_table.data.line_no (map_data_table.no_source_stmts) =
				     current_token_ptr -> reserved_word.line;

				map_data_table.data.text_addr (map_data_table.no_source_stmts) =
				     cobol_$text_wd_off;
				map_data_table.col (map_data_table.no_source_stmts) =
				     current_token_ptr -> reserved_word.column;
				map_data_table.label (map_data_table.no_source_stmts) = "0"b;

				call cobol_reset_r$in_line;

				if fixed_common.options.profile
				then call cobol_profile;

			     end;

			if current_token_ptr -> reserved_word.key = perform
			     | current_token_ptr -> reserved_word.key = compute
			then pc_flag = 1;

		     end;

		goto get_next_token;

	     end;

	if token_type > 31
	then go to get_next_token;
	else go to TOK (token_type);

TOK (2):						/* numeric literal */
	if current_token_ptr -> numeric_lit.subscript = "1"b
	then call stack_sub;

	goto get_next_token;

TOK (31):						/* tag equivalence */
	call cobol_equate_tag (current_token_ptr);

	in_token.n = in_token.n - 1;

	goto get_next_token;

TOK (9):						/* data name */
	if current_token_ptr -> data_name.used_as_sub = "1"b
	then call stack_sub;

	else if subscript_flag = 1
	then if current_token_ptr -> data_name.subscripted = "1"b
	     then do;

		     token_hdr.sub_ptr = subscript_ptr;

		     sub_token.sub_token_ptr (sub_token_index) = null;
		     sub_token_index = sub_token_index - 1;
		     subscript_flag = 0;

		end;

	goto get_next_token;

TOK (10):						/* index name */
	if current_token_ptr -> index_name.subscript = "1"b
	then do;

		call stack_sub;

	     end;

	goto get_next_token;

TOK (30):						/* tag definition */
	if pc_flag ^= 0
	then goto get_next_token;

	if search_flag ^= 0 & current_token_ptr -> int_tag.true_path = "0"b
	then goto get_next_token;

	call cobol_define_tag_nc (binary (current_token_ptr -> int_tag.proc_num, 17), cobol_$text_wd_off);

	in_token.n = in_token.n - 1;
	goto get_next_token;

TOK (19):						/* eos */
	if bypass_flag
	then do;

		if current_token_ptr -> end_stmt.verb = 3
		then bypass_flag = "0"b;		/* end of imperative statement */

		go to get_tokens;

	     end;

	h_no = current_token_ptr -> end_stmt.verb;
	/***.....if Trace_Bit then call ioa_("^a^d^a^d","*****HANDLER= ",h_no,"TAG= ",on_err_tag);/**/
	go to handler (h_no);

TOK (1):
TOK (3):
TOK (4):
TOK (5):
TOK (6):
TOK (7):
TOK (8):
TOK (11):
TOK (12):
TOK (13):
TOK (14):
TOK (15):
TOK (16):
TOK (17):
TOK (18):
TOK (20):
TOK (21):
TOK (22):
TOK (23):
TOK (24):
TOK (25):
TOK (26):
TOK (27):
TOK (28):
TOK (29):
	go to get_next_token;

stack_sub:
     proc;

	sub_token.sub_token_ptr (sub_token_index) = current_token_ptr;

	if subscript_flag = 0
	then do;

		subscript_flag = 1;
		subscript_ptr = addr (sub_token.sub_token_ptr (sub_token_index));

	     end;

	in_token.n = in_token.n - 1;
	sub_token_index = sub_token_index - 1;
     end;

push:
     proc;

/*[4.2-4]*/
	if current_token_ptr -> end_stmt.b		/*[4.2-4]*/
	then do;
		tag_stack_loc = tag_stack_loc + 1;	/*[4.2-4]*/
		tag_stack (tag_stack_loc) = on_err_tag; /*[4.2-4]*/
		on_err_tag = 0;			/*[4.2-4]*/
	     end;

     end;

push1:
     proc;					/* Used by READ */
						/*[4.2-4]*/
	if current_token_ptr -> end_stmt.a ^= "0"b	/*[4.2-4]*/
	then do;
		tag_stack_loc = tag_stack_loc + 1;	/*[4.2-4]*/
		tag_stack (tag_stack_loc) = on_err_tag; /*[4.2-4]*/
		on_err_tag = 0;			/*[4.2-4]*/
	     end;

     end;

pop:
     proc;

/*[4.2-4]*/
	on_err_tag = tag_stack (tag_stack_loc);		/*[4.2-4]*/
	tag_stack_loc = tag_stack_loc - 1;

     end;

/*    .......  HANDLERS  .......			  */

handler (1):
	call cobol_accept_gen (in_token_ptr);
	goto get_tokens;

handler (2):					/*[4.2-4]*/
	call push;
	call cobol_add_gen (in_token_ptr, on_err_tag);
	goto get_tokens;

handler (3):					/*[4.0-1]*/
	if current_token_ptr -> end_stmt.b		/*[4.0-1]*/
	then do;
		if on_err_tag ^= 0
		then call cobol_gen_ioerror$finish_up_not (on_err_tag);
						/*[4.0-1]*/
	     end;					/*[4.0-1]*/
	else do;
		if on_err_tag ^= 0
		then call cobol_define_tag (on_err_tag);/*[4.2-4]*/
		call pop;				/*[4.0-1]*/
	     end;

	go to get_tokens;

handler (4):
	call cobol_alter_gen (in_token_ptr);
	goto get_tokens;

handler (5):
	call cobol_call_gen (in_token_ptr);
	goto get_tokens;

handler (6):
	error_info.message = "Unassigned verb number in EOS";
	error_info.message_len = 29;

	call signal_ ("command_abort_", null, addr (error_info));
	goto get_tokens;

handler (7):
	call cobol_cancel_gen (in_token_ptr);
	go to get_tokens;

handler (8):
	call cobol_close_gen (in_token_ptr);
	goto get_tokens;

handler (9):					/*[4.2-4]*/
	call push;
	call cobol_divide_gen (in_token_ptr, on_err_tag);
	goto get_tokens;

handler (10):					/*[4.2-4]*/
	call push;
	call cobol_multiply_gen (in_token_ptr, on_err_tag);
	goto get_tokens;

handler (11):					/*[4.2-4]*/
	call push;
	call cobol_subtract_gen (in_token_ptr, on_err_tag);
	goto get_tokens;

handler (12):
	call cobol_exit_gen (in_token_ptr);
	goto get_tokens;

handler (13):
	if pc_flag ^= 0
	then goto get_next_token;
	call cobol_compare_gen (in_token_ptr);
	goto get_tokens;

handler (14):
	call cobol_go_gen (in_token_ptr);
	goto get_tokens;

handler (15):
	call cobol_merge_gen (in_token_ptr);
	goto get_tokens;

handler (16):
	error_info.message = "Verb not supported in this release";
	error_info.message_len = 34;
	call signal_ ("command_abort_", null, addr (error_info));
	goto get_tokens;

handler (17):
	call cobol_inspect_gen (in_token_ptr);
	goto get_tokens;

handler (18):
	call cobol_move_gen (in_token_ptr);
	goto get_tokens;

handler (19):
	call cobol_open_gen (in_token_ptr);
	goto get_tokens;

handler (20):
	call cobol_perform_gen (in_token_ptr);
	pc_flag = 0;
	goto get_tokens;

handler (21):					/*[4.2-4]*/
	call push1;
	call cobol_read_gen (in_token_ptr, on_err_tag);
	goto get_tokens;

handler (22):					/*[4.2-4]*/
	call push;
	call cobol_delete_gen (in_token_ptr, on_err_tag);
	goto get_tokens;

handler (23):					/*[4.2-4]*/
	call push;
	call cobol_receive_gen (in_token_ptr, on_err_tag);
	goto get_tokens;

handler (24):
	call cobol_release_gen (in_token_ptr);
	goto get_tokens;

handler (25):					/*[4.2-4]*/
	call push;
	call cobol_return_gen (in_token_ptr, on_err_tag);
	goto get_tokens;

handler (26):
	call cobol_search_gen (in_token_ptr, search_flag);
	goto get_tokens;

handler (27):					/*[5.3-2]*/
	call push;
	call cobol_rewrite_gen (in_token_ptr, on_err_tag);
	goto get_tokens;

handler (28):
	if pc_flag ^= 0
	then goto get_next_token;
	call cobol_arithop_gen (in_token_ptr);
	goto get_tokens;

handler (29):
	goto handler (6);				/*  for now  */

handler (30):
	call cobol_send_gen (in_token_ptr);
	goto get_tokens;

handler (31):
	call cobol_set_gen (in_token_ptr);
	goto get_tokens;

handler (32):
	goto handler (6);				/*  for now  */

handler (33):
	call cobol_stop_gen (in_token_ptr);
	goto get_tokens;

handler (34):					/*[4.2-4]*/
	call push;
	call cobol_string_gen (in_token_ptr, on_err_tag);
	goto get_tokens;

handler (35):
	goto handler (6);				/* 06-30-77  */

handler (36):
	goto handler (6);				/* 06-30-77  */

handler (37):					/*[4.2-4]*/
	call push;
	call cobol_unstring_gen (in_token_ptr, on_err_tag);
	goto get_tokens;

handler (38):					/*[4.2-4]*/
	call push;
	call cobol_write_gen (in_token_ptr, on_err_tag);
	goto get_tokens;

handler (39):
	goto get_tokens;

handler (40):					/*[4.2-4]*/
	call push;
	call cobol_compute_gen (in_token_ptr, on_err_tag);
	pc_flag = 0;
	goto get_tokens;

handler (41):
	call cobol_disable_gen (in_token_ptr);
	goto get_tokens;

handler (42):
	call cobol_display_gen (in_token_ptr);
	goto get_tokens;

handler (43):
	call cobol_enable_gen (in_token_ptr);
	goto get_tokens;

handler (44):
	goto handler (6);				/* 06-30-77  */

handler (45):
	goto handler (6);				/* 06-30-77  */

handler (46):
	goto handler (6);				/* 06-30-77  */

handler (47):
	goto handler (6);				/*  for now  */

handler (48):
	goto handler (6);				/* 06-30-77  */

handler (49):
	call cobol_sort_gen (in_token_ptr);
	goto get_tokens;

handler (50):
	error_info.message = "Verb not supported in this release";
	error_info.message_len = 34;
	call signal_ ("command_abort_", null, addr (error_info));
	goto get_tokens;

handler (51):
	error_info.message = "Verb not supported in this release";
	error_info.message_len = 34;
	call signal_ ("command_abort_", null, addr (error_info));
	goto get_tokens;

handler (52):
	if pd_map_sw = 1 & end_flag = 0
	then do;

test2_map_data_ovfl:
		if map_data_table.no_source_stmts + 2 > cobol_$map_data_max
		then do;

			error_info.message = "Object map overflow";
			error_info.message_len = 19;

			call signal_ ("command_abort_", null, addr (error_info));

			goto test2_map_data_ovfl;

		     end;

		map_data_table.no_source_stmts = map_data_table.no_source_stmts + 1;
		map_data_table.data.line_no (map_data_table.no_source_stmts) =
		     in_token.token_ptr (1) -> reserved_word.line;
		map_data_table.data.text_addr (map_data_table.no_source_stmts) = cobol_$text_wd_off;
		map_data_table.col (map_data_table.no_source_stmts) = in_token.token_ptr (1) -> reserved_word.column;
		map_data_table.label (map_data_table.no_source_stmts) = "0"b;

	     end;

	decl_sw = 0;
	temp = record.this_rcd_ln + 7;
	temp_ptr = addrel (record_ptr, substr (unspec (temp), 17, 18));

	if temp_ptr -> record.this_rcd_ln > 0
	then do;
		temp_ptr = addrel (temp_ptr, 2);
		if temp_ptr -> token_hdr.type = reserved_wd
		then if temp_ptr -> reserved_word.key = 89
		     then decl_sw = 1;		/* DECLARATIVES */
	     end;

	call cobol_prologue_gen (in_token_ptr, binit_tag, fxs_tag, fxs_locno, decl_sw);

/* Stack space used by cobol_prologue_gen is not returnable  */

	cobol_$init_stack_off = cobol_$stack_off;

	goto get_tokens;

handler (53):
	decl_flag = 1;
	if fxs_tag = 0
	then call cobol_decl_gen (fxs_tag);

	goto get_tokens;

handler (54):
	call cobol_section_gen (in_token_ptr);
	goto get_tokens;

handler (55):
	call cobol_paragraph_gen (in_token_ptr);
	goto get_tokens;

handler (56):					/*[4.2-4]*/
	call push;
	call cobol_start_gen (in_token_ptr, on_err_tag);
	goto get_tokens;

handler (57):
	goto handler (6);				/* 06-30-77  */

handler (58):
	call cobol_purge_gen (in_token_ptr);
	goto get_tokens;

handler (59):
handler (60):
handler (61):
handler (62):
handler (63):
handler (64):
handler (65):
handler (66):
handler (67):
handler (68):
handler (69):
handler (70):
handler (71):
handler (72):
handler (73):
handler (74):
handler (75):
handler (76):
handler (77):
handler (78):
handler (79):
handler (80):
handler (81):
handler (82):
handler (83):
handler (84):
handler (85):
handler (86):
handler (87):
handler (88):
handler (89):
handler (90):
handler (91):
handler (92):
handler (93):
handler (94):
handler (95):
handler (96):
handler (97):
	goto handler (6);				/*  for now  */

handler (98):
	call cobol_end_gen (in_token_ptr, fxs_locno, fxs_tag, last_decl_proc, end_flag);

	if end_flag = 1
	then cobol_$init_stack_off = cobol_$max_stack_off;

	goto get_tokens;

data_and_seg_init:
	/***.....	Trace_Bit="0"b;/**/
	if binit_tag ^= 0
	then do;

		call cobol_define_tag (binit_tag);

/* Data initialization */

		if data_init_flag ^= 0
		then do;

			record_ptr = addrel (initval_base_ptr, seq_file_hdr (5) + 4);
			cobol_$stack_off = cobol_$init_stack_off;

			do while (record.this_rcd_ln > 0);

			     do index = 1 to 4;

				in_token.token_ptr (index) = addrel (record_ptr, 2);
				temp = record.this_rcd_ln + 7;
				record_ptr = addrel (record_ptr, substr (unspec (temp), 17, 18));

			     end;

			     in_token.n = 4;

			     call cobol_move_gen (in_token_ptr);

			     if cobol_$stack_off > cobol_$max_stack_off
			     then cobol_$max_stack_off = cobol_$stack_off;

			     cobol_$stack_off = cobol_$init_stack_off;

			     cobol_$temp_token_ptr = cobol_$temp_token_area_ptr;

			end;

		     end;

/* Segment initialization */

		call cobol_seginit_gen (fxs_locno, last_decl_proc);

		if decl_flag = 0 & fxs_tag ^= 0
		then /*-11/30/76-*/
		     call cobol_define_tag_nc (fxs_tag, fxs_locno);

	     end;

exit:
	return;


	/***.....Tr_Beg: entry(str);/**/
	/***.....	Trace_Lev=Trace_Lev+1;/**/
	/***.....	call ioa_("^a^a",substr(Trace_Line,Trace_Lev,1)," "||str);/**/
	/***.....return;/**/

	/***.....Tr_End: entry(str);/**/
	/***.....	call ioa_("^a^a",substr(Trace_Line,Trace_Lev,1)," END:"||str);/**/
	/***.....	Trace_Lev=Trace_Lev-1;/**/
	/***.....return;/**/


	/***.....	dcl Trace_Bit bit(1) static external;/**/
	/***.....	dcl Trace_Lev fixed bin static external;/**/
	/***.....	dcl Trace_Line char(36) static external;/**/
	/***.....	dcl ioa_ entry options(variable); /**/
	/***.....	dcl str char(*);/**/



/*
The function of cobol_gen_driver_ is to direct the generation of the
object code necessary to implement the source code comprising a
given COBOL program.  The primary input to cobol_gen_driver_ is the
file Minpral5.  This file comprises a sequence of tokens which
are, in effect, a coded version of the source program.  These
tokens are grouped, by PD Syntax, into logical sets for process-
ing by the insertion of type-19 End of "Statement" (EOS) tokens.
cobol_gen_driver_ creates a structure (in_token) consisting primarily
of pointers to each token comprising a "statement", as delimited
by EOS tokens, and passes a pointer to this structure to the
appropriate generator.  In addition, cobol_gen_driver_ performs a
number of auxiliary functions, such as;

  1.  Initialization of a number of variables to pre-code-gener-
      ation values.

  2.  Initialization of the definition and linkage sections.

  3.  Deallocation of the stack and determination of maximum re-
      quired stack size.

  4.  Deallocation of the area (temp_token_area) in which tokens
      to temporaries are built.

  5.  Tabulation of data for the construction of the procedure
      division map.

  6.  Resolution of internal tag definition and tag equivalence
      tokens not bracketed within EOS tokens.


U__s_a_g_e:_

     declare cobol_gen_driver_ entry;

     call cobol_gen_driver_;


D__a_t_a:_

      include cobol_;

	Items in cobol_ include file used (u) and/or set (s) by
	cobol_gen_driver_:

	     cobol_ptr (u)
	     com_ptr (u)
	     alter_flag (s)
	     alter_index (s)
	     alter_list_ptr (s)
	     init_stack_off (s)
	     map_data_ptr (u)
	     map_data_max (u)
	     max_stack_off (s)
	     minpral5_ptr (u)
	     misc_end_ptr (u)
	     misc_max (u)
	     para_eop_flag (s)
	     perform_list_ptr (u/s)
	     perform_para_index (s)
	     perform_sect_index (s)
	     priority_no (s)
	     sect_eop_flag (s)
	     seg_init_list_ptr (s)
	     stack_off (u/s)
	     temp_token_area_ptr (s)
	     temp_token_ptr (s)
	     temp_token_max (s)
	     token_block1_ptr (u)
	     token_block2_ptr (u)
	     text_wd_off (u)

      include fixed_common;

	Items in fixed_common include file used (u) and/or set (s) by
	cobol_gen_driver_:

	     perf_alter_info (u)
	     size_perform_info (u)

Conditional Statements:

	end_stmt.b="1"b if code for an option follows
	end_stmt.f="01"b if it is a NOT option

	end_stmt.a(3)b(1)c(1)d(2)f(2)

(1) STATEMENT OPTION

	(a) cobol_pdout_

		STATEMENT
		type19(vt = CODE, b = 1, f = 00)
		OPTION
		type19(vt = 3, b = 0)

	(b) generated code

			STATEMENT -> (L1)
			OPTION
		L1:

(2) STATEMENT OPTION NOT OPTION

	(a) cobol_pdout_

		STATEMENT
		type19(vt = CODE, b = 1, f = 00)
		OPTION
		type19(vt  = 3, b = 1, f = 01)
		NOT OPTION
		type19(vt = 3, b = 0)

	(b) generated code

			STATEMENT -> (L1)
			OPTION
			TRA L3
		L1:
			NOT OPTION
		L2:

(3) STATEMENT NOT OPTION OPTION

	(a) cobol_pdout_

		STATEMENT
		type19(vt = CODE, b = 1, f = 01)
		NOT OPTION
		type19(vt = 3, b = 1, f = 00)
		OPTION
		type19(vt = 3, b = 0)

	(b) generated code

			STATEMENT -> (L1)
			NOT OPTION
			TRA L2
		L1:
			OPTION
		L2:

(4) STATEMENT NOT OPTION

	(a) cobol_pdout_

		STATEMENT
		type19(vt = CODE, b = 1, f = 01)
		NOT OPTION
		type19(vt = 3, b = 0)

	(b) generated code

			STATEMENT -> (L1)
			NOT-OPTION
		L1:
						  */


dcl	1 error_info	static aligned,
	  2 name		char (32) aligned init ("cobol_gen_driver_"),
	  2 message_len	fixed bin aligned,
	  2 message	char (36) aligned;

dcl	reserved_wd	fixed bin internal static init (1),
	numeric_lit_token	fixed bin internal static init (2),
	type_9		fixed bin internal static init (9),
	index_name_token	fixed bin internal static init (10),
	eos		fixed bin internal static init (19),
	internal_tag	fixed bin internal static init (30),
	tag_equivalence	fixed bin internal static init (31),
	perform		fixed bin internal static init (20),
	compute		fixed bin internal static init (40);



/*
P__r_o_c_e_d_u_r_e_s_C__a_l_l_e_d:_
						  */

dcl	cobol_alter_perform entry (ptr, fixed bin),
	cobol_reset_r$in_line
			entry,
	signal_		entry (char (*), ptr, ptr),
	cobol_equate_tag	entry (ptr),
	cobol_define_tag	entry (fixed bin),
	cobol_define_tag_nc entry (fixed bin, fixed bin),
	cobol_accept_gen	entry (ptr),
	cobol_add_gen	entry (ptr, fixed bin),
	cobol_alter_gen	entry (ptr),
	cobol_call_gen	entry (ptr),
	cobol_cancel_gen	entry (ptr),
	cobol_close_gen	entry (ptr),
	cobol_divide_gen	entry (ptr, fixed bin),
	cobol_multiply_gen	entry (ptr, fixed bin),
	cobol_subtract_gen	entry (ptr, fixed bin),
	cobol_exit_gen	entry (ptr),
	cobol_compare_gen	entry (ptr),
	cobol_go_gen	entry (ptr),
	cobol_move_gen	entry (ptr),
	cobol_open_gen	entry (ptr),
	cobol_perform_gen	entry (ptr),
	cobol_read_gen	entry (ptr, fixed bin),
	cobol_gen_ioerror$finish_up_not
			entry (fixed bin),
	cobol_delete_gen	entry (ptr, fixed bin),
	cobol_receive_gen	entry (ptr, fixed bin),
	cobol_release_gen	entry (ptr),
	cobol_return_gen	entry (ptr, fixed bin),
	cobol_rewrite_gen	entry (ptr, fixed bin),
	cobol_arithop_gen	entry (ptr),
	cobol_send_gen	entry (ptr),
	cobol_set_gen	entry (ptr),
	cobol_stop_gen	entry (ptr),
	cobol_write_gen	entry (ptr, fixed bin),
	cobol_compute_gen	entry (ptr, fixed bin),
	cobol_disable_gen	entry (ptr),
	cobol_display_gen	entry (ptr),
	cobol_enable_gen	entry (ptr),
	cobol_sort_gen	entry (ptr),
	cobol_merge_gen	entry (ptr),
	cobol_profile	entry,
	cobol_prologue_gen	entry (ptr, fixed bin, fixed bin, fixed bin, fixed bin),
	cobol_decl_gen	entry (fixed bin),
	cobol_section_gen	entry (ptr),
	cobol_paragraph_gen entry (ptr),
	cobol_start_gen	entry (ptr, fixed bin),
	cobol_pool	entry (char (*), fixed bin, fixed bin),
	cobol_read_rand$fixed_bin
			entry (fixed bin, fixed bin, ptr),
	cobol_seginit_gen	entry (fixed bin, fixed bin),
	cobol_search_gen	entry (ptr, fixed bin),
	cobol_inspect_gen	entry (ptr),
	cobol_string_gen	entry (ptr, fixed bin),
	cobol_unstring_gen	entry (ptr, fixed bin),
	cobol_purge_gen	entry (ptr),
	cobol_end_gen	entry (ptr, fixed bin, fixed bin, fixed bin, fixed bin);


/*
B__u_i_l_t-__i_n_F__u_n_c_t_i_o_n_s_U__s_e_d:_
						  */

dcl	(addr, size)	builtin,
	addrel		builtin,
	baseno		builtin,
	binary		builtin,
	null		builtin,
	rel		builtin,
	substr		builtin,
	unspec		builtin;

%include cobol_in_token;
%include cobol_type1;
%include cobol_type2;
%include cobol_type9;
%include cobol_type10;
%include cobol_type19;
%include cobol_type30;
%include cobol_;
%include cobol_fixed_common;
%include cobol_ext_;
%include cobol_op_con;
%include cobol_type40;
%include cobol_type7;
/*[4.1-2]*/
     end cobol_gen_driver_;




		    cobol_gen_error.pl1             05/24/89  1041.5rew 05/24/89  0831.4       65907



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_gen_error.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 7/7/76 by George Mercuri to correct use entry when error code ^= 0. */
/* Modified on 6/2/76 by Bob Chang to implement the reg_reset entry. */
/* Modified on 5/18/76 by Bob Chang to fix the aos instruction. */
/* Modified on 5/16/76 by Bob Chang to take out set_pr5 statment.	*/
/* Modified on 5/12/76 by George Mercuri to add pr0| to tsx0 instruction. */
/* Modified on 5/12/76 by George Mercuri for additional feature on cobol_error_code. */
/* Modified on 5/10/76 by George Mercuri for error handling. */
/* Created  on 05/05/76 by Bob Chang to interface with cobol_reg_manager. */
/*{*/
/* format: style3 */
cobol_gen_error:
     proc (cobol_error_code, tagno);

/* This sub-generator produces code to generate an
object time error message via the run-time support routine
cobol_error_. */

dcl	cobol_error_code	fixed bin;
dcl	tagno		fixed bin;
dcl	tt		fixed bin;

/*
     cobol_error_code  a fixed bin number indicating the "COBOL
               error number" (see below).  If 0, then it is
	     assumed that the appropriate cobol_operators_ has
	     set the cobol_error_code value in X1.

This program will set up a call to a run-time error
routine cobol_error_.  Run-time support routines encountering
errors will also call cobol_error_.  Thus all error messages will
be funnelled through one run-time routine.

The interface is as follows:

  call cobol_error_ (cobol_code,multics_code,line_no1,
                                   line_no2,progname,error_ptr);

     cobol_code  corresponds to cobol_error_code described above.

     multics_code  a fixed bin corresponding to the location
               identified by sp|error_code_relp described above.

     line_no1  a fixed bin containing the line number on
               which the error occurred.  This is derived from
               the internal line number given in line_no
               described above.  If it is 0, no line number is
               applicable to this error and no such indication
               will be given in the error message.

     line_no2  a fixed bin containing the additional line
               number.  This is derived from the internal line
               number line_no described above.  If it is 0, then
               only a one-part line number is given.

     progname  a varying char field containing the name of the
               program which produced the error.  The
               cobol_gen_error sub-generator will always set it
               to the name of the program for which code is being
               generated.  Run-time support routines may identify
               the program which called them or themselves,
               depending on the error.

     error_ptr  a pointer to the location at which the error was
               discovered or to the location at which
               cobol_control_ is called from.  The
               cobol_gen_error sub-generator will always set it
               to the latter.


The following message(s) will be output to the "error_output"
stream:

     ["progname": Multics message (from com_err_)]
     ["progname": COBOL error message]
     Error occurred at "segno|offset"
          [in "progname" [on line ["line_no2"] "line_no1"]]

The first line is printed only if multics_code is non-zero.  The
second line is printed only if cobol_code is non-zero.  The third
line is always printed.  The progname portion of it is not
present if progname is null; the line_no2 portion of it is not
present is line_no2 is zero;  the line_no1 portion of it is not
present if line_no1 is zero.  If progname is null and the first
and/or the second line is present, the the string "cobol_error"
is used in place of it.
}*/

dcl	add_use_code	bit (36) static init ("110000000001001001000101100001000000"b);
						/* aos	pr6|73	*/
						/* -5-18-76 - */


dcl	temp		fixed bin;
dcl	inst_seq		(6) bit (18) static init ("000000000000000000"b, "111000000001000000"b,
						/* tsx0	pr0|op_num	*/
			"000000000000000000"b, "111001000000000100"b,
						/* tra	0,ic	*/
			"000000111111111111"b, "111000000001001001"b);
						/* tsx0 pr0|4095,1	*/

/*
Procedures Called		*/

dcl	cobol_emit	entry (ptr, ptr, fixed bin),
	cobol_define_tag	entry (fixed bin),
	cobol_reg_manager$before_op
			entry (fixed bin),
	cobol_reg_manager$after_op
			entry (fixed bin),
	cobol_make_tagref	entry (fixed bin, fixed bin, ptr);



/***********************************/

start:
	if tagno = 0
	then do;
		tt = cobol_$next_tag;
		cobol_$next_tag = cobol_$next_tag + 1;
		call cobol_define_tag (tt);
	     end;
	else tt = tagno;

	if cobol_error_code = 0
	then /*5/12/76*/
	     call cobol_emit (addr (inst_seq (5)), null (), 1);
	else do;
		temp = 4095 + cobol_error_code;
		substr (inst_seq (1), 4, 15) = substr (unspec (temp), 22, 15);
		call cobol_emit (addr (inst_seq (1)), null (), 1);
	     end;
	call cobol_emit (addr (inst_seq (3)), null (), 1);
	call cobol_make_tagref (tt, cobol_$text_wd_off - 1, null ());
	return;


/***********************************/

reg_reset:
     entry (cobol_error_code, tagno);

	if tagno = 0
	then do;
		tt = cobol_$next_tag;
		cobol_$next_tag = cobol_$next_tag + 1;
		call cobol_define_tag (tt);
	     end;
	else tt = tagno;

	call cobol_reg_manager$before_op (0);
	if cobol_error_code = 0
	then /*5/12/76*/
	     call cobol_emit (addr (inst_seq (5)), null (), 1);
	else do;
		temp = 4095 + cobol_error_code;
		substr (inst_seq (1), 4, 15) = substr (unspec (temp), 22, 15);
		call cobol_emit (addr (inst_seq (1)), null (), 1);
	     end;
	call cobol_reg_manager$after_op (0);
	call cobol_emit (addr (inst_seq (3)), null (), 1);
	call cobol_make_tagref (tt, cobol_$text_wd_off - 1, null ());
	return;



/*************************************/


use:
     entry (cobol_error_code);			/*5/12/76*/
	call cobol_emit (addr (add_use_code), null (), 1);

	if cobol_error_code = 0
	then call cobol_emit (addr (inst_seq (5)), null (), 1);
	else do;
		temp = 4095 + cobol_error_code;
		substr (inst_seq (1), 4, 15) = substr (unspec (temp), 22, 15);
		call cobol_emit (addr (inst_seq (1)), null (), 1);
	     end;

	return;




/*****	Declaration for builtin function	*****/

dcl	(substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index)
			builtin;

/*****	End of declaration for builtin function	*****/

%include cobol_;

     end cobol_gen_error;




		    cobol_gen_ioerror.pl1           05/24/89  1041.5rew 05/24/89  0831.4       83493



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_gen_ioerror.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 06/27/79 by FCH, [4.0-1], entry finish_up_not added for debug */
/* Modified since Version 4.0 */

/* format: style3 */
cobol_gen_ioerror:
     proc (ft_ptr, ioerror_ptr);

dcl	ft_ptr		ptr;			/* ptr to the file table */
dcl	ioerror_ptr	ptr;			/* ptr to additional error information */

/*[4.0-1]*/
declare	passed_tag	fixed bin;

dcl	1 ioerror		based (ioerror_ptr),
	  2 cobol_code	fixed bin,
	  2 retry_tag	fixed bin,		/* tagno of retry address; 0 means just reissue error */
	  2 is_tag	fixed bin,		/* tagno of imperative statement; 0 if none */
	  2 ns_tag	fixed bin,		/* tagno of next statement; always reserved by caller */
						/* defined by finish_up if is_tag=0; else by gen driver */
	  2 type1_ptr	ptr,			/* pts to reserved word token for the verb of caller */
	  2 mode		fixed bin;		/* -1 = file unopen at time of error - no categorical use procs apply
				   2 = file is being opened extend	0>m>21
				   3 = file is being opened input	20>m>41
				   4 = file is being opened i-o	40>m>61
				   5 = file is being opened output	60>m 	*/

dcl	file_key_desc	char (40) based;		/* a template for fkey_type9.file_key_info */


dcl	retry_tag		fixed bin;
dcl	ntag		fixed bin;
dcl	mode_count	fixed bin;
dcl	temp_error_exit	fixed bin;

dcl	fkey_ptr		ptr;

dcl	lda_sw		bit (1);
dcl	fsbptr_sw		bit (1);
dcl	perform_mode_sw	bit (1);
dcl	io_sw		bit (1);			/*[4.0-1]*/
declare	new_tag		fixed bin;

/*************************************/
start:
	if file_table.file_status
	then call set_status (addr (skey12_type9), addr (skey3_type9));
	if ioerror.is_tag > 0
	then do;					/* an imperative statement follows */
		call cobol_emit (addr (check_is_instr), null (), 2);
		call cobol_make_tagref (ioerror.is_tag, cobol_$text_wd_off - 1, null ());
	     end;
	perform_mode_sw = "0"b;			/*-07/07/76-*/
	temp_error_exit = file_table.error_exit;
	if file_table.error_exit ^= 0
	then call perform_use (temp_error_exit);	/* specific use proc */
	else do;					/* check for categorical use procs */
		mode_count = 0;
		if ^file_table.external
		then do;				/* can skip check for int file opened in only 1 mode */
			if file_table.open_ext
			then mode_count = mode_count + 1;
			if file_table.open_in
			then mode_count = mode_count + 1;
			if file_table.open_out
			then mode_count = mode_count + 1;
			if file_table.open_io
			then mode_count = mode_count + 1;
		     end;
		lda_sw, fsbptr_sw, io_sw = "0"b;
		if ioerror.mode = 0
		then do;
			if fixed_common.extend_error_exit ^= 0
			then /* possible to be opened EXTEND? */
			     if (^file_table.external & file_table.open_ext)
				| (file_table.external & file_table.organization = 1
				& (file_table.write | file_table.close | file_table.open_ext))
			     then call perform_mode (fixed_common.extend_error_exit, extend_mode);
			if fixed_common.input_error_exit ^= 0
			then /* possible to be opened INPUT? */
			     if (^file_table.external & file_table.open_in)
				| (file_table.external
				& (file_table.read | file_table.start | file_table.close | file_table.open_in))
			     then call perform_mode (fixed_common.input_error_exit, input_mode);
			if fixed_common.output_error_exit ^= 0
			then /* possible to be opened OUTPUT? */
			     if (^file_table.external & file_table.open_out)
				| (file_table.external
				& (file_table.write | file_table.close | file_table.open_out))
			     then call perform_mode (fixed_common.output_error_exit, output_mode);
			if fixed_common.i_o_error_exit ^= 0
			then /* possible to be opened I-O? */
			     if (^file_table.external & file_table.open_io)
				| (file_table.external
				& (file_table.read | file_table.rewrite | file_table.start | file_table.delete
				| file_table.close | file_table.open_io))
			     then do;
				     io_sw = "1"b;
				     call perform_mode (fixed_common.i_o_error_exit, i_o_mode);
				end;
		     end;
		else if ioerror.mode > 0
		then do;
			mode_count = 1;
			if ioerror.mode > 48
			then if fixed_common.output_error_exit ^= 0
			     then call perform_mode (fixed_common.output_error_exit, output_mode);
			     else ;
			else if ioerror.mode > 32
			then if fixed_common.i_o_error_exit ^= 0
			     then call perform_mode (fixed_common.i_o_error_exit, i_o_mode);
			     else ;
			else if ioerror.mode > 16
			then if fixed_common.input_error_exit ^= 0
			     then call perform_mode (fixed_common.input_error_exit, input_mode);
			     else ;
			else if fixed_common.extend_error_exit ^= 0
			then call perform_mode (fixed_common.extend_error_exit, extend_mode);
		     end;

		if (mode_count ^= 1 & mode_count ^= 4) | ^perform_mode_sw
		then do;				/* must provide fall-thru */
			retry_tag = ioerror.retry_tag;
			if retry_tag = 0
			then do;
				retry_tag = cobol_$next_tag;
				cobol_$next_tag = cobol_$next_tag + 1;
				call cobol_define_tag (retry_tag);
			     end;
			call cobol_gen_error (ioerror.cobol_code, retry_tag);
		     end;
	     end;
	return;


/*************************************/
/* SUBROUTINES */
/*************************************/

perform_mode:
     proc (procno, mode);
dcl	procno		fixed bin;
dcl	mode		fixed bin;

	if mode_count ^= 1
	then do;
		ntag = cobol_$next_tag;
		cobol_$next_tag = cobol_$next_tag + 1;
		if ^fsbptr_sw
		then do;
			call cobol_set_fsbptr (ft_ptr);
			fsbptr_sw = "1"b;
		     end;
		if ^lda_sw
		then do;
			call cobol_emit (addr (set_mode_instr), null (), 2);
			lda_sw = "1"b;
		     end;
		if ^(mode_count = 4 & io_sw)
		then do;				/* no need to compare - can just fall in */
			substr (cmpa_dl_instr, 1, 18) = substr (unspec (mode), 19, 18);
			call cobol_emit (addr (cmpa_dl_instr), null (), 1);
			call cobol_emit (addr (tnz_instr), null (), 1);
			call cobol_make_tagref (ntag, cobol_$text_wd_off - 1, null ());
		     end;
	     end;
	call perform_use (procno);
	perform_mode_sw = "1"b;			/* if not at least once, then must provide fall-thru */
	if mode_count ^= 1
	then call cobol_define_tag (ntag);
	return;
     end perform_mode;


perform_use:
     proc (procno);
dcl	procno		fixed bin;

	if ^perform_mode_sw
	then call cobol_gen_error$use (ioerror.cobol_code);
						/* record error (once) */
	mpout.pt1 = ioerror.type1_ptr;
	type7.proc_num = procno;
	mpout.pt2, mpout.pt3 = addr (type7);
	mpout.pt4 = addr (perform_type19);
	call cobol_perform_gen (addr (mpout));
	call cobol_emit (addr (tra_instr), null (), 1);	/* and go to next statement */
	call cobol_make_tagref (ioerror.ns_tag, cobol_$text_wd_off - 1, null ());
	return;
     end perform_use;


set_status:
     proc (skey12_ptr, skey3_ptr);
dcl	skey12_ptr	ptr;
dcl	skey3_ptr		ptr;

	call cobol_read_rand (1, file_table.file_status_info, fkey_ptr);
	addr (fkey_type9.file_key_info) -> file_key_desc = file_key.desc;
	mpout.pt1 = ioerror.type1_ptr;
	mpout.pt2 = skey12_ptr;
	mpout.pt3 = addr (fkey_type9);
	mpout.pt4 = addr (perform_type19);
	call cobol_move_gen (addr (mpout));
	if file_table.extra_status
	then do;
		call cobol_read_rand (1, file_table.extra_status_info, fkey_ptr);
		addr (fkey_type9.file_key_info) -> file_key_desc = file_key.desc;
		mpout.pt2 = skey3_ptr;
		call cobol_move_gen (addr (mpout));
	     end;
	return;
     end set_status;


/*************************************/
/*************************************/
finish_up:
     entry (ft_ptr, ioerror_ptr);

	if file_table.file_status
	then call set_status (addr (zero_type1), addr (zero_type1));
	if ioerror.is_tag = 0
	then call cobol_define_tag (ioerror.ns_tag);
	else do;					/* an imperative statement follows */
		call cobol_emit (addr (tra_instr), null (), 1);
						/* transfer around the imperative statement */
		call cobol_make_tagref (ioerror.ns_tag, cobol_$text_wd_off - 1, null ());
						/* gen driver will define this */
		call cobol_define_tag (ioerror.is_tag);
		call cobol_reg_manager$set_pr5;	/* must do now since we have come directly here */
	     end;
	return;


finish_up_not:
     entry (passed_tag);

/*[4.0-1]*/
	new_tag = cobol_$next_tag;			/*[4.0-1]*/
	cobol_$next_tag = cobol_$next_tag + 1;

/*[4.0-1]*/
	call cobol_emit (addr (tra_instr), null (), 1);	/*[4.0-1]*/
	call cobol_make_tagref (new_tag, cobol_$text_wd_off - 1, null ());

/*[4.0-1]*/
	call cobol_define_tag (passed_tag);

/*[4.0-1]*/
	passed_tag = new_tag;

/*[4.0-1]*/
	return;

%include cobol_gen_ioerror_data;
     end cobol_gen_ioerror;




		    cobol_get_index_value.pl1       05/24/89  1041.5rew 05/24/89  0831.3      131994



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_get_index_value.pl1 Added Trace statements.
                                                   END HISTORY COMMENTS */


/* format: style3 */
%;
/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */

/* Modified on 10/19/85 by FCH, [5.3-1], bug563(phx18381), new cobol_addr_tokens.incl.pl1 */
/* Modified since Version 2.0 */

/*{*/
cobol_get_index_value:
     proc (return_value_code, input_token_ptr, output_token_ptr);

/*
This procedure generates code to convert the value of an index
(which is stored as a fixed binary number in two bytes of storage)
to a decimal format operand in a temporary in the run-time stack.
*/

/*  DECLARATION OF THE PARAMETERS  */

dcl	return_value_code	fixed bin;
dcl	input_token_ptr	ptr;
dcl	output_token_ptr	ptr;

/*
return_value_code	a code that indicates whether the
		index occurrence number is to be returned as
		a fixed bin (35) or decimal value. (input)
		This code can have the following values:

		return_value_code	meaning
		1		return fixed bin
		2 return decimal
input_token_ptr	points to the input token: data name
		(type 9, usage is index), or index name (type 10)
		to be converted to decimal. (input)
output_token_ptr	points to a buffer in the caller's program
		in which the dataname (type 9) token,
		describing the resultant converted decimal
		value is built by this procedure.  (input)

*/


/*  Declaration of external entries  */

dcl	cobol_addr	ext entry (ptr, ptr, ptr);
dcl	cobol_emit	ext entry (ptr, ptr, fixed bin);
dcl	cobol_alloc$stack	ext entry (fixed bin, fixed bin, fixed bin);
dcl	cobol_make_type9$copy
			ext entry (ptr, ptr);
dcl	cobol_register$load ext entry (ptr);
dcl	cobol_register$release
			ext entry (ptr);

/*  DECLARATION OF BUILTIN FUNCTIONS  */

dcl	addr		builtin;
dcl	binary		builtin;
dcl	bit		builtin;
dcl	fixed		builtin;

/*  Definition of internal static variables that contain op codes  */

dcl	btd_op		bit (10) int static init ("0110000011"b /* 301(1) */);
dcl	mlr_op		bit (10) int static init ("0010000001"b /* 100(1) */);
dcl	lda_op		bit (10) int static init ("0100111010"b /* 235(0) */);
dcl	ldq_op		bit (10) int static init ("0100111100"b /* 236(0) */);

dcl	ldaq_op		bit (10) int static init ("0100111110"b /*237(0)*/);
dcl	lls_op		bit (10) int static init ("1110111110"b /*737(0)*/);
dcl	lrs_op		bit (10) int static init ("1110110110"b /*733(0)*/);
dcl	ars_op		bit (10) int static init ("1110110010"b /*731(0)*/);
dcl	stq_op		bit (10) int static init ("1111011100"b /*756(0)*/);

/*  Buffer in which instructions and/or descriptors are returned by the addressability utility  */

dcl	inst_buff		(1:5) fixed bin;

/*  Buffer in which relocation information is returned by the addressability utility  */

dcl	reloc_buff	(1:10) fixed bin;

/*  Buffer in which input to the addressabiliyt utility is built  */

dcl	input_buff	(1:30) ptr;

/*  Work buffer in which a data name token (type 9) for the index value is built  */

dcl	wkbuff1		(1:40) fixed bin;
dcl	wkbuff1_ptr	ptr;

/*  work buffer in which a data name token (type 9) for the occurence number in the stack is built  */

dcl	wkbuff2		(1:40) fixed bin;
dcl	wkbuff2_ptr	ptr;

dcl	dn_ptr		ptr;
dcl	byte_offset	bit (2);
dcl	shift_val		fixed bin;
dcl	return_decimal_value
			bit (1);


/*  Variables used to zero the descripiton bits of a data name token  */

dcl	descrip_ptr	ptr;
dcl	descrip		bit (72) based (descrip_ptr);

dcl	t_offset		fixed bin;


/*  Structure used to communicate with the register$load procedure.  */

dcl	1 register_struc,
	  2 what_reg	fixed bin,
	  2 reg_no	bit (4),
	  2 lock		fixed bin,
	  2 already_there	fixed bin,
	  2 contains	fixed bin,
	  2 dname_ptr	ptr,
	  2 literal	bit (36);

/**************************************************/
/*	START OF EXECUTION			*/
/*	cobol_get_index_value			*/
/**************************************************/

start:
	if return_value_code = 1			/*  return fixed binary  */
	then return_decimal_value = "0"b;
	else return_decimal_value = "1"b;


/*  Set work pointers to point at the work buffers  */

	inst_ptr = addr (inst_buff (1));
	reloc_ptr = addr (reloc_buff (1));
	input_ptr = addr (input_buff (1));
	wkbuff1_ptr = addr (wkbuff1 (1));

	if return_decimal_value
	then dn_ptr = wkbuff1_ptr;			/*  build temporary output token  */
	else dn_ptr = output_token_ptr;		/*  Build output token in the user's work buffer  */



	if input_token_ptr -> data_name.type = rtc_dataname
	then do;					/*  Input token is a dataname token (type 9) with usage index bit set  */

		wkbuff2_ptr = addr (wkbuff2 (1));

/*  Allocate  four bytes on a word boundary in the stack, to receive
		the fixed binary occurrence number  */
		call cobol_alloc$stack (4, 0, t_offset);

/*  Make a data name token that describes the stack temporary to receive the
			occurrence number  */
		data_name.type = rtc_dataname;
		data_name.seg_num = 1000;		/*  Stack  */
		data_name.offset = t_offset;		/*  Offset returned by alloc$stack  */

/*  Update the two data name tokens so that alphanumeric eis descriptors will
		be built for them by the addressability utility.  */
		input_token_ptr -> data_name.alphanum = "1"b;
		input_token_ptr -> data_name.usage_index = "0"b;
		wkbuff2_ptr -> data_name.alphanum = "1"b;
		wkbuff2_ptr -> data_name.usage_index = "0"b;


/*  Allocate six bytes on an even word boundary in the stack
		to receive the six byte index data item.  */

		call cobol_alloc$stack (6, 2, t_offset);

/*  Convert the offset value from a word offset to a byte offset.  */
		t_offset = t_offset * 4;

/*  Make a copy of the input data name token.  */

		call cobol_make_type9$copy (wkbuff2_ptr, input_token_ptr);

/*  Modify the copy so that it describes the six byte temporary in the stack.  */
		wkbuff2_ptr -> data_name.seg_num = 1000;/*  stack  */
		wkbuff2_ptr -> data_name.offset = t_offset;
						/*  Turn off the subscripted bit in the token that describes the temporary.  */
		wkbuff2_ptr -> data_name.subscripted = "0"b;

/*  Generate code to move the index data item to the 6 byte temporary in the stack.  */

/*  Build the input structure to the addressability utility.  */

		input_struc.type = 5;		/*  EIS,2 input operands, instruction and 2 descriptors returned.  */

		input_struc.operand_no = 2;
		input_struc.lock = 0;
		input_struc.operand.token_ptr (1) = input_token_ptr;
		input_struc.operand.send_receive (1) = 0;
						/*  sending  */
		input_struc.operand.size_sw (1) = 0;

		input_struc.operand.token_ptr (2) = wkbuff2_ptr;
		input_struc.operand.send_receive (2) = 1;
						/*  receiving  */
		input_struc.operand.size_sw (2) = 0;



/*  Call the addressability utility.  */

		call cobol_addr (input_ptr, inst_ptr, reloc_ptr);


/*  Set the MLR opcode into the instruction  */
		inst_struc.inst.fill1_op = mlr_op;

/*  Emit the instruction and two descriptors.  */
		call cobol_emit (inst_ptr, reloc_ptr, 3);

/*  Get the basic address of the WORD containing the first byte of the index occurrence
			number  */


		input_struc_basic.type = 1;		/*  basic, non-eis  */
		input_struc_basic.operand_no = 0;
		input_struc_basic.segno = wkbuff2_ptr -> data_name.seg_num;
		input_struc_basic.char_offset = wkbuff2_ptr -> data_name.offset + 4;

		call cobol_addr (input_ptr, inst_ptr, reloc_ptr);
						/*  Get the A and Q registers.  */

		register_struc.what_reg = 3;		/*  Get the A and Q registers, please.  */
		register_struc.lock = 0;		/*  No change to locks.  */
		register_struc.contains = 0;		/*  Contents of A and Q are not meaningful
			for register optimization .  ( because they will be shifted once they
			are in the A-Q)  */

		call cobol_register$load (addr (register_struc));


/*  Build ldq instruction referencing the address of the WORD containing
			the first byte of the index occurrence number  */

		inst_struc_basic.fill1_op = ldq_op;

/*  Emit the ldaq instruction  */
		call cobol_emit (inst_ptr, reloc_ptr, 1);

/*  At this point, code has been generated to get the two bytes containing
		the index data item occurrence number into the two most significant bytes
		of the Q- register.  */

/*  Build an instruction to load zero into the A register.  */

		inst_buff (1) = 0;
		inst_struc_basic.fill1_op = lda_op;
		inst_struc_basic.tm = "00"b;		/*  ir modivication  */
		inst_struc_basic.td = "0011"b;	/*  DU  */

/*  Set relocation bytes  */
		reloc_buff (1) = 0;
		reloc_buff (2) = 0;			/*  Emit the lda 0,du instruction  */
		call cobol_emit (inst_ptr, reloc_ptr, 1);

/*  Build a LLS instruction to get rid of the junk bit in the middle of the two 8 bit
			pieces of meaningful data  */

		inst_buff (1) = 0;
		inst_struc_basic.fill1_op = lls_op;
		inst_struc_basic.wd_offset = bit (binary (10, 15));
						/*  Insert the shift value into the
		instruction  */

/*  Set relocation bytes  */
		reloc_buff (1) = 0;
		reloc_buff (2) = 0;			/*  Emit the lls instruction  */
		call cobol_emit (inst_ptr, reloc_ptr, 1);



/*  Build ars instruction  */
		inst_buff (1) = 0;
		inst_struc_basic.fill1_op = ars_op;
		inst_struc_basic.wd_offset = bit (binary (1, 15));

/*  Emit the ars instruction  */
		call cobol_emit (inst_ptr, reloc_ptr, 1);

/*  Build the lrs instruction  */
		inst_buff (1) = 0;
		inst_struc_basic.fill1_op = lrs_op;
		inst_struc_basic.wd_offset = bit (binary (28, 15));

/*  Emit the lrs instruction  */
		call cobol_emit (inst_ptr, reloc_ptr, 1);

/*  Get the basic address of the temporary in the stack which is to receive the
			occurrence number  */

		input_struc_basic.type = 1;
		input_struc_basic.operand_no = 0;
		input_struc_basic.segno = data_name.seg_num;
		input_struc_basic.char_offset = data_name.offset;

		call cobol_addr (input_ptr, inst_ptr, reloc_ptr);

/*  Emit the stq instruction  */
		inst_struc_basic.fill1_op = stq_op;
		call cobol_emit (inst_ptr, reloc_ptr, 1);

/*  Set wkbuff1_ptr to point to the token for the temporary in the stack  */
		wkbuff1_ptr = dn_ptr;		/*  Release the A and Q registers.  */
		call cobol_register$release (addr (register_struc));


	     end;					/*  Input token is data name (type 9) with usage index bit set  */

	else do;					/*  an index name token (type 10)  */
		data_name.type = rtc_dataname;
		ind_ptr = input_token_ptr;
		data_name.seg_num = index_name.seg_num; /*  set segment number of index name item  */
		data_name.offset = index_name.offset + 4;
						/*  set offset from index name item  */
	     end;					/*  an index name token (type 10)  */


/*  Complete the data name token in the work buffer  */
	data_name.item_length = 4;
	data_name.places_left = 4;
	data_name.places_right = 0;

/*  Zero the description bits in the data name token being built  */
	descrip_ptr = addr (data_name.file_section);
	descrip = "0"b;

/*  Set description bits  */
	data_name.display = "1"b;
	data_name.numeric = "1"b;
	data_name.elementary = "1"b;

	if return_decimal_value
	then do;					/*  convert the fixed binary occurrence value to decimal  */
						/*  Allocate space on the stack to receive the decimal representation
		of the binary index value  */
		call cobol_alloc$stack (5, 0, t_offset);/*  5 bytes will hold maximum value that
		can be held in two bytes of fixed binary information  */

/*  Save the pointer to the token that describes the fixed binary occurrence number  */
		wkbuff1_ptr = dn_ptr;

/*  Build a data name token for the stack temporary just allocated  */
		dn_ptr = output_token_ptr;
		data_name.size = 116;		/*	12/24/75	bc	*/
		data_name.type = rtc_dataname;
		data_name.item_length = 5;
		data_name.places_left = 5;
		data_name.places_right = 0;
		data_name.seg_num = 1000;		/*  stack  */
		data_name.offset = t_offset;		/*  offset just returned by alloc$stack  */

		descrip_ptr = addr (data_name.file_section);
		descrip = "0"b;
		data_name.numeric = "1"b;
		data_name.elementary = "1"b;
		data_name.display = "1"b;


/*  Build the input to the addressability utility  */

		input_struc.type = 5;		/*  eis, 2 operands input, instruction and 2 descriptors returned  */

		input_struc.operand_no = 2;
		input_struc.lock = 0;
		input_struc.operand.token_ptr (1) = wkbuff1_ptr;
		input_struc.operand.send_receive (1) = 0;
						/*  sending  */
		input_struc.operand.size_sw (1) = 0;

		input_struc.token_ptr (2) = output_token_ptr;
						/*  token for decimal representation to which
		the fixed binary is converted  */
		input_struc.operand.send_receive (2) = 1;
						/*  receiving  */
		input_struc.operand.size_sw (2) = 0;

		call cobol_addr (input_ptr, inst_ptr, reloc_ptr);


/*  Set the binary to decimal op code into the opcode field of the instruction  */
		inst_struc.inst.fill1_op = btd_op;
		desc_nn_ptr = addr (inst_buff (2));

/*  Zero the MBZ bits in the first descriptor  */
		desc_nn.desc_f.tn (1) = "0"b;		/*  type code bit  */
		desc_nn.sign_type (1) = "0"b;		/*  sign type bits  */
		desc_nn.scal (1) = "0"b;		/*  scale factor  */

/*  Zero MBZ bits in the second descriptor  */
		desc_nn.scal (2) = "0"b;		/*  scale factor  */


/*  Emit the instruction and two descriptors  */
		call cobol_emit (inst_ptr, reloc_ptr, 3);

	     end;					/*  cconvert the fixed binary occurrence value to decimal  */

/**************************************************/
/*	END OF EXECUTABLE STATEMENTS	*/
/*	cobol_get_index_value			*/
/**************************************************/


/*  INCLUDE FILES USED BY THIS PROCEDURE  */

%include cobol_type9;

%include cobol_type10;

%include cobol_addr_tokens;

%include cobol_record_types;

/************************************************/
/*	END OF OUTERMOST PROCEDURE		*/
/*	cobol_get_index_value		*/
/**************************************************/



     end cobol_get_index_value;




		    cobol_get_num_code.pl1          05/24/89  1041.5rew 05/24/89  0831.2       25623



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_get_num_code.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/*{*/
/* format: style3 */
cobol_get_num_code:
     proc (token_ptr, token_typecode);

/*
This procedure maps a data name tokne for a numeric data
item into a code, according to the following table:

numeric data type	| type code (returned)
---------------------------------------------
unpacked decimal	|  1
packed decimal	|  2
short binary	|  3
long binary	|  4
overpunch decimal	|  5
---------------------------------------------

*/

/*  DECLARATION OF THE PARAMETERS  */

dcl	token_ptr		ptr;
dcl	token_typecode	fixed bin;

/*  DESCRIPTION OF THE PARAMETERS  */

/*
PARAMETER		DESCRIPTION
token_ptr		Pointer to the numeric data name token
		which is to be mapped into a type code.(input)
token_typecode	Variable in which the typecode is
		returned.  (output)  The output value
		is described above.
*/
/*}*/


/*  DECLARATIONS OF INTERNAL VARIABLES  */

dcl	dn_ptr		ptr;			/*  referenced in type9 include file, but not declared there!!!  */

start:
	if token_ptr -> data_name.sign_separate
	     | (token_ptr -> data_name.numeric & token_ptr -> data_name.display
	     & token_ptr -> data_name.sign_type = "000"b /* not specified */
	     & token_ptr -> data_name.item_signed = "0"b) /*  Probably an unsigned, pooled constant  */
	then token_typecode = 1;			/*  unpacked decimal  */

	else if token_ptr -> data_name.ascii_packed_dec
	then token_typecode = 2;

	else if token_ptr -> data_name.bin_18
	then token_typecode = 3;

	else if token_ptr -> data_name.bin_36
	then token_typecode = 4;

	else token_typecode = 5;			/*  MUST BE OVERPUNCH!!  */


/*  INCLUDE FILES USED BY THIS PROCEDURE  */


/*****	Declaration for builtin function	*****/

dcl	(substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index)
			builtin;

/*****	End of declaration for builtin function	*****/

%include cobol_type9;


     end cobol_get_num_code;




		    cobol_get_size.pl1              05/24/89  1041.5rew 05/24/89  0831.2       52488



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_get_size.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/*{*/

/* format: style3 */
cobol_get_size:
     proc (dn_ptr, stoff, lineno);


/* This procedure is used to generate the instructions which will load the
	   A register with the item_length of a type 9 token.
	   If the input stoff is not equal to 0, the A register is stored into the memory
	   location pr6|stoff.				*/


dcl	dn_ptr		ptr;
dcl	stoff		fixed bin;
dcl	lineno		fixed bin;

dcl	1 size_basic_struct static,
	  2 type		fixed bin init (1),
	  2 operand_no	fixed bin init (0),
	  2 lock		fixed bin init (0),
	  2 seg		fixed bin,
	  2 offset	fixed bin,
	  2 send_receive	fixed bin init (0);

dcl	1 mpout		static,
	  2 n		init (4),
	  2 pt1		ptr,
	  2 pt2		ptr,
	  2 pt3		ptr,
	  2 pt4		ptr;

dcl	1 type1		static,			/* reserve word */
	  2 size		fixed bin init (28),
	  2 line		fixed bin,		/* line number */
	  2 column	fixed bin init (0),
	  2 type		fixed bin init (1),
	  2 key		fixed bin init (20),	/* perform */
	  2 bits		bit (36) init ("1"b),
	  2 jump_index	fixed bin init (0);

dcl	1 type7		static,			/*  procedure definition */
	  2 size		fixed bin init (52),
	  2 line		fixed bin init (0),
	  2 column	fixed bin init (0),
	  2 type		fixed bin init (7),
	  2 string_ptr	ptr init (null ()),
	  2 prev_rec	ptr init (null ()),
	  2 bits1		bit (4) init (""b),
	  2 section_name	bit (1) init ("0"b),
	  2 declarative_proc
			bit (1) init ("0"b),
	  2 bits2		bit (3) init (""b),
	  2 priority	char (2) init ("00"),
	  2 bits3		bit (9) init (""b),
	  2 section_num	fixed bin init (0),
	  2 proc_num	fixed bin init (0),
	  2 def_line	fixed bin init (0),
	  2 name_size	fixed bin init (0);

dcl	1 type19		static,			/*  eos */
	  2 size		fixed bin init (38),
	  2 line		fixed bin init (0),
	  2 column	fixed bin init (0),
	  2 type		fixed bin init (19),
	  2 verb		fixed bin init (20),	/* verb number */
	  2 e		fixed bin init (0),
	  2 h		fixed bin init (0),
	  2 i		fixed bin init (0),
	  2 j		fixed bin init (0),
	  2 a		bit (3) init ("111"b),
	  2 b		bit (1) init (""b),
	  2 c		bit (1) init (""b),
	  2 d		bit (2) init (""b),
	  2 f		bit (2) init (""b),
	  2 g		bit (2) init (""b),
	  2 k		bit (5) init (""b);

dcl	instr		(3) bit (36);

dcl	instr_ptr		ptr;
dcl	input_ptr		ptr static;
dcl	mpout_ptr		ptr static;

dcl	ic		fixed bin;
dcl	temp		fixed bin;

dcl	firsttime		bit (1) static init ("1"b);
dcl	omit_sign		bit (1);

dcl	sta		bit (12) static init ("111101101001"b);
dcl	lda_dlmod		bit (18) static init ("010011101000000111"b);
dcl	ada_dlmod		bit (18) static init ("000111101000000111"b);
dcl	full_lca_		bit (36) static init ("000000000000000000011011101000000000"b);
dcl	full_lda_		bit (36) static init ("000000000000000000010011101000000000"b);

dcl	cobol_perform_gen	entry (ptr);
dcl	cobol_addr	entry (ptr, ptr, ptr);
dcl	cobol_emit	entry (ptr, ptr, fixed bin);


/*}*/

/*************************************/
	omit_sign = "0"b;
	go to start;
omit_sign:
     entry (dn_ptr, stoff, lineno);
	omit_sign = "1"b;
start:
	instr_ptr = addr (instr);
	ic = 2;
	if data_name.variable_length
	then do;
		if data_name.size_rtn = -1
		then do;				/* special - varying char string */
			size_basic_struct.seg = data_name.seg_num;
			size_basic_struct.offset = data_name.offset - 4;
						/* word alignment assumed */
			instr (1) = full_lda_;
			call cobol_addr (addr (size_basic_struct), instr_ptr, null ());
			ic = 2;
		     end;
		else do;
			if firsttime
			then do;
				mpout_ptr = addr (mpout);
				mpout.pt1 = addr (type1);
				mpout.pt2, mpout.pt3 = addr (type7);
				mpout.pt4 = addr (type19);
				input_ptr = addr (size_basic_struct);
				firsttime = "0"b;
			     end;
			mpout.pt1 -> reserved_word.line = lineno;
			mpout.pt2 -> proc_def.proc_num = data_name.size_rtn;
			call cobol_perform_gen (mpout_ptr);
			size_basic_struct.seg = fixed_common.size_seg;
			size_basic_struct.offset = fixed_common.size_offset;
			instr (1) = full_lca_;
			call cobol_addr (input_ptr, instr_ptr, null ());
			instr (2) = substr (unspec (data_name.item_length), 19, 18) || ada_dlmod;
			ic = 3;
		     end;
	     end;
	else do;
		temp = data_name.item_length;
		if omit_sign
		then if data_name.sign_separate
		     then temp = temp - 1;		/* may be changed for release 1.5 */
		instr (1) = substr (unspec (temp), 19, 18) || lda_dlmod;
	     end;
	if stoff = 0
	then ic = ic - 1;				/* don't store value in memory */
	else instr (ic) = "110"b || substr (unspec (stoff), 22, 15) || sta;
	call cobol_emit (instr_ptr, null (), ic);
	return;


/*************************************/

/*****	Declaration for builtin function	*****/

dcl	(substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index)
			builtin;

/*****	End of declaration for builtin function	*****/

%include cobol_type1;
%include cobol_type7;
%include cobol_type9;
%include cobol_fixed_common;
%include cobol_ext_;
%include cobol_;

     end cobol_get_size;




		    cobol_go_gen.pl1                05/24/89  1041.5rew 05/24/89  0831.0      203166



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_go_gen.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 01/14/77 by ORN to signal command_abort rather than cobol_compiler_error */
/* Modified since Version 2.0 */

/*{*/
/* format: style3 */
cobol_go_gen:
     proc (in_token_ptr);				/*
The procedure cobol_go_gen generates the code necessary to implement
the COBOL GO statement and, in the case of alterable GO's, pro-
duces the data structures from which initialization code may be
subsequently generated.  The format of the GO statement is:

Format 1  -

  G_O_ TO [procedure-name-1]

Format 2  -

  G_O_ TO procedure-name-1 [,procedure-name-2]..., procedure-name-n

        D_E_P_E_N_D_I_N_G_ ON identifier

The implementation of a GO statement depends upon whether or not
it is the object of an  ALTER statement.  A Format 1 GO statement 
with optional procedure-name-1 present may be modified by an 
ALTER statement; a Format 1 GO statement without optional proce-
dure-name-1 present must be modified by an ALTER statement; and a 
Format 2 GO statement may not be modified by an ALTER statement.
The determination of whether or not the GO statement being pro-
cessed is the object of an ALTER statement is made by examining
the variable cobol_$alter_flag.  A value of 1 indicates that the GO
statement is the object of an ALTER statement and a value of 0,
that it is not.  cobol_$alter_flag is set by cobol_paragraph_gen.

The implementation of a GO statement which is not the object of
an ALTER statement is also dependent upon whether or not the
COBOL segment containing the procedure to which control is to be
transferred must first be initialized.  Segment initialization is
not required if the procedure to which control is to be transfer-
red is in the same COBOL segment as the GO statement being imple-
mented, is in a fixed COBOL segment, or is in an independent
COBOL segment which contains no alterable GO's.  The term alter- 
able GO, as used here, refers to a GO statement that is the ob-
ject of an ALTER statement.

U__s_a_g_e:_

     declare cobol_go_gen entry (ptr);

     call cobol_go_gen (in_token_ptr);

						  */
%include cobol_in_token;

/*
G__e_n_e_r_a_t_e_d_C__o_d_e:_

Format 1  -

The following code is generated for Format 1 GO statements which
are alterable:

  lda    target_a
  tra    0,al

where:

target_a is a 36-bit variable, allocated in COBOL data on a word
         boundary and uniquely associated with the alterable GO 
         being implemented (see alter_list), which contains 
         transfer address data.  For information on the setting 
         of target_a, see cobol_initgo_gen.

If the optional procedure-name-1 is not present, the above two
instructions are followed by an execution time call to cobol_
error_ generated by a compile time call to cobol_process_error.
This call will be executed only in the event that the GO state-
ment is executed prior to the execution of an ALTER statement re-
ferring to this GO statement.  This is accomplished by initializ-
ing target_a such that control is passed to the first instruction
of the call to cobol_error_.  Target_a is otherwise initialized
to pass control to the first instruction of procedure-name-1.
See cobol_seginit_gen for details on initialization.

If it is found that a Format 1 GO statement without the optional
procedure-name-1 present is not the subject of an ALTER statement
then a compile time warning to this effect is issued to the user
via system subroutine signal_ and an execution time call to
cobol_error_ is generated by a call to cobol_process_error to signal
this error to the user at execution time and to prevent further
execution of the program in the event that this GO statement is
executed in the course of executing the program.

In the case of non-alterable Format 1 GO statements, code se-
quence 1, below, is used if no segment initialization is required
and sequence 2, if segment initialization is requierd.

     Sequence 1

  tra    pn_relp,ic

     Sequence 2

  eaa    pn_relp,ic
  tra    s_init_relp,ic

where:

pn_relp     is the offset, relative to the instruction in which
	  it appears, of the first instruction of the procedure
	  to the transfer is being made.

s_init_relp is the offset, relative to the instruction in which
	  it appears, of the first instruction of the code se-
	  quence provided to initialize the alterable GO's in
	  the segment containing the procedure to which the 
	  transfer is being made.

Format 2  -

The code generated to implement Format 2 GO statements is as
follows:

  stz    ident_bin
  dtb    (pr),(pr)
  ndsc9  ident
  ndsc9  ident_bin
  lda    1,du
  ldq    nt,du
  dwl    ident_bin
  tnz    nt+2mt+3,ic
  eax2   ident_bin,*ic
  tra    1,2
  tra    relp1,ic
  tra    relp2,ic
   .       .   .
   .       .   .
   .       .   .
  tra    relpn,ic
  eaa    pn1_relp,ic
  tra    s(pn1)_init_relp,ic
  eaa    pn2_relp,ic
  tra    s(pn2)_init_relp,ic
   .        .    .    .   .
   .        .    .    .   .
   .        .    .    .   .
  eaa    pnm_relp,ic
  tra    s(pnm)_init_relp,ic

where:

ident_bin	       is a fixed bin quantity allocated in the stack.
	       Its function is to contain the binary represen-
	       tation of the value of ident times 2**18.

ident	       is the operand of the DEPENDING ON phrase of the
	       Format 2 GO statement.  It is allocated in COBOL
	       data.

nt	       is the number of procedure names given as oper-
	       ands of the Format 2 GO statement.

mt	       is the number of procedure names given as oper-
	       ands of the Format 2 GO statement which are con-
	       tained in segments that must be initialized be-
	       fore the required transfer of control is made.
	       mt is less than or equal to nt.

relpn	       for n = 1, 2, 3, ... nt is a constant whose
	       value is either:
	       1) The offset, relative to the instruction in
	          which relpn appears, of the first instruction 
	          of procedure pnn (procedure-name-n), if the
	          segment containing procedure pnn does not
	          have to be initialized before control is
	          transferred to the procedure.
	       2) nt-n+2m-1 for n = 1, 2, 3, ... nt and m = 1,
	          2, 3, ...mt if the segment containing proce-
	          dure pnn requires initialization before con-
	          trol is transferred to the procedure.

pnm_relp	       for m = 1, 2, 3, ... mt is the offset, relative
	       to the instruction in which pnm_relp appears, of
	       the first instruction of procedure pnm where 
	       procedure pnm is in a segment requiring initial-
	       ization before control is transferred to it.

s(pnm)_init_relp for m = 1, 2, 3, ... mt is the offset, relative
	       to the instruction in which s(pnm)_init_relp ap-
	       pears, of the first instruction of the sequence
	       provided to initialize the segment containing
	       procedure pnn.

R__e_l_o_c_a_t_i_o_n_I__n_f_o_r_m_a_t_i_o_n:_

All instructions generated directly by procedure cobol_go_gen (as 
opposed to being generated by a utility called by cobol_go_gen) are 
non-relocatable.

						   */
/*
D__a_t_a:_

     % include cobol_;

	Items in cobol_ include file1 used (u) and/or set(s) by
	cobol_go_gen:

	     cobol_ptr (u)
	     alter_flag (u)
	     alter_index (u/s)
	     alter_list_ptr (u)
	     next_tag (u/s)
	     text_wd_off (u)
	     priority_no (u)
	     seg_init_list_ptr (u)

						   */

%include cobol_alter_list;
%include cobol_seg_init_list;
%include cobol_type9;
dcl	dn_ptr		ptr;
%include cobol_type18;
%include cobol_type19;

/*  Input structure for cobol_register$load		   */

declare	1 register_request	aligned static,
	  2 requested_reg	fixed bin aligned,
	  2 assigned_reg	bit (4) aligned,
	  2 lock		fixed bin aligned init (0),
	  2 reg_set_now	fixed bin aligned,
	  2 use_code	fixed bin aligned init (0),
	  2 adjust_ptr_addr fixed bin aligned init (0),
	  2 content_ptr	ptr aligned init (null),
	  2 literal_content bit (36) aligned init ((36)"0"b);

/*
requested_reg   is a code designating the register requested;
		0  - a- or q- or any index-register
		1  - a-register
		2  - q-register
		3  - a- and q-register
		4  - a- or q-register
		5  - any index-register
		1n - index-register n

assigned_reg    is a code designating the register assigned.  It
	      has no significance if a specific register is
	      requested.

lock	      indicates locking requirements; 0 requests that
	      no change be made in register status.

reg_set_now     not applicable for use_code = 0.

use_code 	      specifies how the register is to be used by the
	      requester; 0 signifies that such information is
	      not meaningful for register optimization.

adjust_ptr_addr inserted to make evident that since all pointers
	      must be allocated on even word boundaries, the
	      PLI compiler will allocate structures containing
	      pointers and all pointers therein on even word  
	      boundaries leaving "gaps" where necessary.

content_ptr     not applicable for use_code = 0.

literal_content not applicable for use_code = 0.
						   */


/*  Input structures for cobol_addr			   */

declare	1 target		aligned static,
	  2 type		fixed bin aligned init (1),
	  2 operand_no	fixed bin aligned init (0),
	  2 lock		fixed bin aligned init (0),
	  2 segno		fixed bin aligned,
	  2 char_offset	fixed bin (24) aligned,
	  2 send_receive	fixed bin aligned init (0);

/*
type	   indicates type of addressing requested.  Type 1
	   indicates basic; i.e., data to be addressed is
	   specified by segno and char_offset.

operand_no   not applicable to type 1.

lock	   indicates lock requirements for registers used in
	   addressing;
	     0 - do not lock registers used.
	     1 - lock registers used.

segno	   is the compiler designation of the segment in which
	   the data to be addressed is located.

char_offset  is the character offset within segno of the data to
	   be addressed.

send_receive indicates whether the data being addressed is a
	   sending or receiving field for the instruction whose
	   address field is being set; 0 indicates sending.
						   */

declare	1 input_struc	aligned static,
	  2 type		fixed bin aligned init (4),
	  2 operand_no	fixed bin aligned init (1),
	  2 lock		fixed bin aligned init (0),
	  2 operand,
	    3 token_ptr	ptr aligned init (null),
	    3 send_receive	fixed bin aligned init (0),
	    3 ic_mod	fixed bin aligned,
	    3 size_sw	fixed bin aligned init (0);

/*
type	   indicates type of addressing requested.  
		1  -  no operand, 1 wd, basic
		2  -  1 operand, 1 wd, non-EIS
		3  -  1 operand, 1 wd, EIS
		4  -  1 operand, 1 desc, 2wd, EIS
		5  -  2 operands, 2 desc, 3 wd, EIS
		6  -  3 operands, 3 desc, 4 wd, EIS

operand_no   number of operands associated with requested type.

lock	   indicates lock requirements for registers used in
	   addressing.
		0  -  do not lock registers used
		1  -  lock registers used
		2  -  unlock all registers

token_ptr	   is a pointer to the operand token.

send_receive indicates whether the operand being addressed is a
	   sending or receiving field for the instruction. 
		0  -  sending operand
		1  -  receiving operand

ic_mod	   indicates whether ic modification is specified in
	   the mf field of this operand (set by cobol_addr).
		0  -  no ic modification
		1  -  ic modification

size_sw	   indicates size (length) handlhlng requirements to
	   cobol_addr.
		0  -  cobol_addr may store the operand size in a
		      register or in the instruction
		1  -  cobol_addr need not be concerned with size
						   */

/*  Error message structure.				   */

declare	1 error_info	static aligned,
	  2 name		char (32) aligned init ("cobol_go_gen"),
	  2 message_len	fixed bin aligned,
	  2 message	char (168) aligned;

dcl	1 comp7_type9	static,
	  2 header	(4) fixed bin init (112, 0, 0, 9),
	  2 repl_ptr	(2) ptr init ((2) null ()),
	  2 fill1		bit (108) init (""b),
	  2 file_key_info,
	    3 fb1		(3) fixed bin init (0, 0, 0),
	    3 size	fixed bin init (2),
	    3 fb2		(2) fixed bin init (6, 0),
	    3 flags1	bit (36) init ("000000100100010001000000010000000000"b),
	    3 flags2	bit (36) init (""b),
	    3 seg		fixed bin init (1000),
	    3 off		fixed bin init (160),
	  2 fill2		(7) fixed bin init (0, 0, 0, 0, 0, 0, 0);

dcl	1 type19		static,
	  2 header	(4) fixed bin init (38, 0, 0, 19),
	  2 verb		fixed bin init (0),
	  2 e		fixed bin init (1),
	  2 h		fixed bin init (0),
	  2 ij		(2) fixed bin init (0, 0),
	  2 abcdfgk	bit (16) init ("0000000000000000"b);

dcl	1 mpout		static,
	  2 n		fixed bin init (4),
	  2 pt1		ptr,
	  2 pt2		ptr,
	  2 pt3		ptr,
	  2 pt4		ptr;

dcl	seq_f1_a		(4) bit (18) unaligned static init ("000000000000000000"b, "010011101001001101"b,
						/*  lda    target_a	*/
			"000000000000000000"b, "111001000000000101"b);
						/*  tra    0,al		*/

dcl	seq_f1_b		(2) bit (18) unaligned static init ("000000000000000000"b, "111001000000000100"b);
						/*  tra    0,ic		*/

dcl	seq_f1_c		(4) bit (18) unaligned static init ("000000000000000000"b, "110011101000000100"b,
						/*  eaa    pn_relp,ic	*/
			"000000000000000000"b, "111001000000000100"b);
						/*  tra    s_init_relp,ic	*/

dcl	seq_f2_1		(14) bit (18) unaligned static init ("110000000000101000"b, "100101000001000000"b,
						/*  stz    pr6|40	*/
			"000000000000000001"b, "010011101000000011"b,
						/*  lda    1,du		*/
			"000000000000000000"b, "010011110000000011"b,
						/*  ldq    nt,du	*/
			"110000000000101000"b, "001001001001000000"b,
						/*  cwl    pr6|40	*/
			"000000000000000000"b, "110000001000000100"b,
						/*  tnz    nt+2mt+3,ic	*/
			"110000000000101000"b, "110010010001110100"b,
						/*  eax2   pr6|40,*ic	*/
			"000000000000000001"b, "111001000000001010"b);
						/*  tra    1,2		*/

dcl	trans		(768) bit (36);		/*  Automatic data					   */

declare	s_text_wd		fixed bin,		/* Saved value of cobol_$text_wd_off.	   */
	temp		fixed bin,		/* Temporary used in unspec function. */
	init_req_flag	fixed bin,		/* 1 if seg initialization is not	   */
						/* required; 2 if it is.		   */
	pnn_priority	fixed bin,		/* COBOL seg no of seg containing	   */
						/* procedure-name-n.		   */
	cnt_pri		fixed bin,		/* Priority of current procedure.	   */
	init_tag		fixed bin,		/* Tag associated with 1st inst. of   */
						/* code generated to initialize alter-*/
						/* able GO's in COBOL seg containing  */
						/* procedure-name-n.		   */
	pnn_num		fixed bin,		/* Procedure no (tag) of procedure-   */
						/* name-n.			   */
	index		fixed bin,		/* Do loop index.		   */
	jndex		fixed bin,		/* Do loop index.		   */
	init_ptr		ptr,			/* Ptr to location in seg_init_list   */
						/* where initialization data is to be */
						/* placed.			   */
	nt		fixed bin,		/* Number of procedure names given as */
						/* operands in Format 2 GO statement. */
	sum		fixed bin;		/* nt+2m where m is the current count */
						/* of procedure names given as oper-  */
						/* ands in a Format 2 GO statement    */
						/* that are in segments requiring 	   */
						/* initialization.		   */

/*  Based structure used in placing initialization data in     */
/*  seg_init_list.					   */

declare	1 init_data	aligned based (init_ptr),
	  2 target_a_segno	fixed bin aligned,
	  2 target_a_offset fixed bin aligned,
	  2 pn1		fixed bin unaligned,
	  2 init		fixed bin unaligned;

/*
P__r_o_c_e_d_u_r_e_s_C__a_l_l_e_d:_
						   */

dcl	cobol_addr	entry (ptr, ptr, ptr),
	cobol_define_tag_nc entry (fixed bin, fixed bin),
	cobol_emit	entry (ptr, ptr, fixed bin),
	cobol_make_tagref	entry (fixed bin, fixed bin, ptr),
	cobol_process_error entry (fixed bin, fixed bin, fixed bin),
	cobol_move_gen	entry (ptr),
	cobol_register$load entry (ptr),
	ioa_$rsnnl	entry options (variable),
	signal_		entry (char (*), ptr, ptr);

/*
B__u_i_l_t-__i_n_F__u_n_c_t_i_o_n_s_U__s_e_d:_
						   */

dcl	addr		builtin,
	addrel		builtin,
	binary		builtin,
	null		builtin,
	substr		builtin,
	unspec		builtin;

/*}*/

%include cobol_;


/*************************************/
start:
	if in_token.token_ptr (in_token.n) -> end_stmt.a = "000"b
	then go to format1;
	else go to format2;

/*************************************/
format1:
	proc_ref_ptr = in_token.token_ptr (in_token.n - 1);
	pnn_num = proc_ref.proc_num;
	pnn_priority = binary (unspec (proc_ref.priority), 17);
	if cobol_$alter_flag = 0
	then /*  GO statement is not object of ALTER statement.	   */
	     do;
		if pnn_num = 0
		then /*  Program is in erroor.			   */
		     do;				/* This statement must be revised when two part line */
						/* becomes available.			   */
			call ioa_$rsnnl ("Line no. ^d: GO TO ?", error_info.message, error_info.message_len,
			     in_token.token_ptr (1) -> proc_ref.line);
			call signal_ ("command_error", null, addr (error_info));
			s_text_wd = cobol_$text_wd_off;
			call cobol_process_error (20, in_token.token_ptr (1) -> proc_ref.line, 0);
			temp = s_text_wd - cobol_$text_wd_off;
			seq_f1_b (1) = substr (unspec (temp), 19, 18);
			call cobol_emit (addr (seq_f1_b), null, 1);
		     end;

		else do;
			if cobol_$seg_init_list_ptr = null
			then init_req_flag = 1;

			else call is_init_req;

			if init_req_flag = 1
			then call cobol_emit (addr (seq_f1_b), null, 1);

			else do;
				register_request.requested_reg = 1;
				call cobol_register$load (addr (register_request));
				call cobol_emit (addr (seq_f1_c), null, 2);
				call cobol_make_tagref (init_tag, cobol_$text_wd_off - 1, null);
			     end;

			call cobol_make_tagref (pnn_num, cobol_$text_wd_off - init_req_flag, null);
		     end;

	     end;

	else /*  GO statement is object of ALTER statement.	   */
	     do;
		s_text_wd = cobol_$text_wd_off;
		target.segno = alter_list.goto.target_a_segno (cobol_$alter_index);
		target.char_offset = alter_list.goto.target_a_offset (cobol_$alter_index);
		cobol_$alter_index = cobol_$alter_index + 1;
		call cobol_addr (addr (target), addr (seq_f1_a), null);
		register_request.requested_reg = 1;
		call cobol_register$load (addr (register_request));
		call cobol_emit (addr (seq_f1_a), null, 2);

/*  Store initialization data.			   */

		cnt_pri = cobol_$priority_no;
		if cnt_pri < 50
		then cnt_pri = 0;

		do jndex = 1 to seg_init_list.n;
		     if seg_init_list.seg.priority (jndex) = cnt_pri
		     then do;
			     init_ptr =
				addrel (seg_init_list.seg.init_ptr (jndex),
				3 * seg_init_list.seg.next_init_no (jndex));
			     seg_init_list.seg.next_init_no (jndex) = seg_init_list.seg.next_init_no (jndex) + 1;
			     init_data.target_a_segno = target.segno;
			     init_data.target_a_offset = target.char_offset;
			     init_data.pn1 = pnn_num;
			     call is_init_req;
			     if init_req_flag = 1
			     then init_data.init = 0;

			     else init_data.init = init_tag;

			     goto next_step;
			end;

		end;

next_step:
		if pnn_num = 0
		then do;
			init_data.pn1 = cobol_$next_tag;
			call cobol_define_tag_nc (cobol_$next_tag, cobol_$text_wd_off);
			cobol_$next_tag = cobol_$next_tag + 1;
			call cobol_process_error (20, in_token.token_ptr (1) -> proc_ref.line, 0);
			temp = s_text_wd - cobol_$text_wd_off;
			seq_f1_b (1) = substr (unspec (temp), 19, 18);
			call cobol_emit (addr (seq_f1_b), null, 1);
		     end;

	     end;

	return;


/*************************************/
format2:
	nt = in_token.token_ptr (in_token.n) -> end_stmt.e;
	sum = nt;
	call cobol_emit (addr (seq_f2_1 (1)), null, 1);
	mpout.pt1 = null ();
	mpout.pt2 = in_token.token_ptr (nt + 2);
	comp7_type9.flags1 = "000000100100010001000000010000000000"b;
	mpout.pt3 = addr (comp7_type9);
	mpout.pt4 = addr (type19);
	call cobol_move_gen (addr (mpout));
	seq_f2_1 (5) = substr (unspec (nt), 19, 18);
	if cobol_$seg_init_list_ptr = null
	then do jndex = 1 to nt;
		trans (jndex) = "000000000000000000111001000000000100"b;
		pnn_num = in_token.token_ptr (in_token.n + jndex - nt - 2) -> proc_ref.proc_num;
		call cobol_make_tagref (pnn_num, cobol_$text_wd_off + jndex + 5, addr (trans (jndex)));
	     end;

	else do jndex = 1 to nt;
		trans (jndex) = "000000000000000000111001000000000100"b;
		proc_ref_ptr = in_token.token_ptr (in_token.n + jndex - nt - 2);
		pnn_num = proc_ref.proc_num;
		pnn_priority = binary (unspec (proc_ref.priority), 17);
		call is_init_req;
		if init_req_flag = 1
		then call cobol_make_tagref (pnn_num, cobol_$text_wd_off + jndex + 5, addr (trans (jndex)));

		else do;
			sum = sum + 1;
			temp = sum - jndex;
			substr (trans (jndex), 1, 18) = substr (unspec (temp), 19, 18);
			trans (sum) = "000000000000000000110011101000000100"b;
			call cobol_make_tagref (pnn_num, cobol_$text_wd_off + sum + 5, addr (trans (sum)));
			sum = sum + 1;
			trans (sum) = "000000000000000000111001000000000100"b;
			call cobol_make_tagref (init_tag, cobol_$text_wd_off + sum + 5, addr (trans (sum)));
		     end;

	     end;

	temp = sum + 3;
	seq_f2_1 (9) = substr (unspec (temp), 19, 18);
	register_request.requested_reg = 1;
	call cobol_register$load (addr (register_request));
	register_request.requested_reg = 12;
	call cobol_register$load (addr (register_request));
	call cobol_emit (addr (seq_f2_1 (3)), null, 6);
	call cobol_emit (addr (trans), null, sum);

	return;


is_init_req:
     proc;

	if cobol_$priority_no ^= pnn_priority
	then if pnn_priority > 49
	     then do index = 1 to seg_init_list.n;
		     if seg_init_list.seg.priority (index) = pnn_priority
		     then do;
			     init_req_flag = 2;
			     init_tag = seg_init_list.seg.int_tag_no (index);
			     goto finis;
			end;

		end;
	init_req_flag = 1;

finis:
	return;

     end is_init_req;

     end cobol_go_gen;




		    cobol_init_.pl1                 05/24/89  1041.5rew 05/24/89  0830.9       63162



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_init_.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 04/27/78 by FCH, [3.0-1], symbol section(source module path name) */
/* Modified since Version 3.0.	*/

/* format: style3 */
cobol_init_:
     proc (fpath, rtbuff_ptr);

dcl	fpath		char (168),
	tpath		char (168) aligned;		/*[3.0-1] */
dcl	rtbuff_ptr	ptr;			/* for use by replacement */

dcl	segname		char (32);
dcl	path		char (168);
dcl	segptr		ptr;
dcl	mcode		fixed bin (35);

dcl	evar		entry auto;
dcl	bptr		ptr based (addr (evar));

dcl	cobol_def_init	entry;
dcl	cobol_link_init	entry;
dcl	cobol_sym_init	entry (char (168) aligned);	/* [3.0-1] */
dcl	com_err_		entry options (variable);
dcl	hcs_$make_seg	entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl	hcs_$make_ptr	entry (ptr, char (*), char (*), ptr, fixed bin (35));
dcl	hcs_$initiate	entry (char (*) aligned, char (*), char (*), fixed bin (1), fixed bin (2), ptr,
			fixed bin (35));
dcl	hcs_$truncate_seg	entry (ptr, fixed bin, fixed bin (35));


/*************************************/
start:
	evar = cobol_init_;
	cobol_$scratch_dir = fpath;

	segname = "cobol_seg1_";
	call hcs_$make_seg (fpath, segname, "", 01011b, segptr, mcode);

	if segptr = null ()
	then go to merror1;

	if mcode ^= 0
	then do;
		call hcs_$truncate_seg (segptr, 0, mcode);
		if mcode ^= 0
		then go to merror1;
	     end;

	cobol_$misc_base_ptr, cobol_$misc_end_ptr = segptr;
	cobol_$misc_max = 32767;
	cobol_$pd_map_ptr = pointer (segptr, 32768);
	cobol_$pd_map_max = 32767;
	cobol_$pd_map_index = 0;
	cobol_$map_data_ptr = pointer (segptr, 65536);
	cobol_$map_data_max = 32767;
	cobol_$tag_table_ptr = pointer (segptr, 98304);
	cobol_$tag_table_max = 32767;
	cobol_$fixup_ptr = pointer (segptr, 131072);
	cobol_$fixup_max = 32767;
	cobol_$token_block1_ptr = pointer (segptr, 172032);
	cobol_$token_block2_ptr = pointer (segptr, 173056);
	cobol_$include_info_ptr = pointer (segptr, 174080);
	cobol_$allo1_max = 86000;
	cobol_$allo1_ptr = pointer (segptr, 176080);

	segname = "cobol_seg2_";
	call hcs_$make_seg (fpath, segname, "", 01011b, segptr, mcode);

	if segptr = null ()
	then go to merror1;

	if mcode ^= 0
	then do;
		call hcs_$truncate_seg (segptr, 0, mcode);
		if mcode ^= 0
		then go to merror1;
	     end;

	cobol_$text_base_ptr = segptr;
	cobol_$text_wd_off = 0;
	cobol_$con_end_ptr = pointer (segptr, 131071);
	cobol_$con_wd_off = 1;
	cobol_$link_base_ptr = pointer (segptr, 131072);
	cobol_$link_max = 12287;
	cobol_$link_wd_off = 0;
	cobol_$def_base_ptr = pointer (segptr, 155648);
	cobol_$def_max = 32767;
	cobol_$def_wd_off = 0;
	cobol_$reloc_text_base_ptr = pointer (segptr, 188416);
	cobol_$reloc_text_max = 147429;
	cobol_$reloc_def_base_ptr = pointer (segptr, 192512);
	cobol_$reloc_def_max = 73692;
	cobol_$reloc_link_base_ptr = pointer (segptr, 194560);
	cobol_$reloc_link_max = 147429;
	cobol_$reloc_sym_base_ptr = pointer (segptr, 198656);
	cobol_$reloc_sym_max = 147429;
	cobol_$reloc_work_base_ptr = pointer (segptr, 202752);
	cobol_$reloc_work_max = 221148;
	cobol_$sym_base_ptr = pointer (segptr, 208896);
	cobol_$sym_max = 65535;
	cobol_$sym_wd_off = 0;

	cobol_$perform_list_ptr, cobol_$alter_list_ptr, cobol_$seg_init_list_ptr, cobol_$temp_token_area_ptr,
	     cobol_$temp_token_ptr, cobol_$ptr_status_ptr, cobol_$reg_status_ptr = null ();

	segname = "cobol_seg3_";
	call hcs_$make_seg (fpath, segname, "", 01011b, segptr, mcode);

	if segptr = null ()
	then go to merror1;

	if mcode ^= 0
	then do;
		call hcs_$truncate_seg (segptr, 0, mcode);
		if mcode ^= 0
		then go to merror1;
	     end;

	cobol_$eln_ptr = pointer (segptr, 0);
	cobol_$eln_max = 65535;
	cobol_$statement_info_ptr = pointer (segptr, 65536);
	cobol_$xref_token_ptr = pointer (segptr, 131072);
	cobol_$xref_chain_ptr = pointer (segptr, 196608);

	segname = "cobol_ntbuff_";
	call hcs_$make_seg (fpath, segname, "", 01011b, segptr, mcode);

	if segptr = null ()
	then go to merror1;

	if mcode ^= 0
	then do;
		call hcs_$truncate_seg (segptr, 0, mcode);
		if mcode ^= 0
		then go to merror1;
	     end;

	rtbuff_ptr = segptr;
	cobol_$ntbuf_ptr = segptr;

	cobol_$cobol_data_wd_off, cobol_$debug_enable, cobol_$data_init_flag, cobol_$include_cnt, cobol_$fs_charcnt,
	     cobol_$ws_charcnt, cobol_$coms_charcnt, cobol_$ls_charcnt, cobol_$cons_charcnt, cobol_$value_cnt,
	     cobol_$cd_cnt, cobol_$fs_wdoff, cobol_$ws_wdoff, cobol_$coms_wdoff = 0;
	cobol_$same_sort_merge_proc = "0"b;

	segname = "cobol_diag_table_";
	call hcs_$make_ptr (bptr, segname, segname, cobol_$diag_ptr, mcode);

	if cobol_$diag_ptr = null ()
	then go to merror3;

	segname = "cobol_reswd_table_";
	call hcs_$make_ptr (bptr, segname, segname, cobol_$reswd_ptr, mcode);

	if cobol_$reswd_ptr = null ()
	then go to merror3;

	segname = "cobol_operators_";
	call hcs_$make_ptr (bptr, segname, segname, cobol_$op_con_ptr, mcode);

	if cobol_$op_con_ptr = null ()
	then go to merror3;
	cobol_$op_con_ptr = addrel (cobol_$op_con_ptr, 2048);

	return;


/*************************************/
segs:
     entry (code, tpath);				/* [3.0-1] */

dcl	code		fixed bin (35);

start_segs:
	call cobol_def_init;
	call cobol_link_init;
	call cobol_sym_init (tpath);			/* [3.0-1] */

	cobol_$initval_flag = 0;
	segname = "cobol_initval_";

	call hcs_$initiate (cobol_$scratch_dir, segname, "", 0b, 00b, cobol_$initval_base_ptr, mcode);

	if cobol_$initval_base_ptr = null ()
	then go to merror2;

	code = 0;
	return;


/*************************************/
merror1:
	path = fpath;
	rtbuff_ptr = null ();			/* signal to driver */
	go to merror;

merror2:
	path = cobol_$scratch_dir;
	code = mcode;				/* signal to driver */

merror:
	call com_err_ (mcode, "cobol", " ^a>^a", path, segname);
	return;
merror3:
	rtbuff_ptr = null ();

	call com_err_ (mcode, "cobol", " ^a$^a", segname, segname);

	return;

/*************************************/

/*****	Declaration for builtin function	*****/

dcl	(substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index)
			builtin;

/*****	End of declaration for builtin function	*****/

%include cobol_;

     end cobol_init_;




		    cobol_inspect_gen.pl1           05/24/89  1041.5rew 05/24/89  0830.0      367479



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_inspect_gen.pl1 Added Trace statements.
                                                   END HISTORY COMMENTS */


/*  Modified on 10/19/84 by FCH, [4.3-1], BUG563(phx18381), new cobol_addr_tokens.incl.pl1 */
/* Modified on 02/13/81 by FCH, cobol_add_gen called with wrong arg count, [4.4-1], BUG463(TR9151) */
/* Modified on 10/10/77 by Bob Chnag to fix the table of substitution. */
/* Modified on 10/06/77 by Bob Chang to fix the bug for replacing optimatization. */
/* Modified on 06/06/77 by Bob Chang to implement further optimization. */
/* Modified on 04/21/77 by Bob Chang to implement optimization for simple cases.	*/
/* Modified on 03/31/77 by Bob Chang to fix the bug for overpunch data.	*/
/* Modified on 03/24/77 by ORN to allocate enough stack for tally and replace structures */
/* Modified since Version 2.0 */

/* format: style3 */
cobol_inspect_gen:
     proc (mp_ptr);

dcl	mp_ptr		ptr;

dcl	1 mp		based (mp_ptr),
	  2 n		fixed bin,
	  2 pt		(0 refer (mp.n)) ptr;

dcl	1 args,
	  2 entryno	fixed bin,
	  2 arglist_off	fixed bin,
	  2 stacktemp_off	fixed bin,
	  2 n		fixed bin,
	  2 arg		(3),
	    3 pt		ptr,
	    3 type	fixed bin,
	    3 off1	fixed bin,
	    3 off2	fixed bin,
	    3 value	bit (18) unal,
	    3 indirect	bit (1) unal,
	    3 overlay	bit (1) unal,
	    3 repeat_nogen	bit (1) unal;
dcl	1 name_arg	static,
	  2 pt		ptr init (null ()),		/* set each time to pt to varying char string containing name of program to be called */
	  2 type		fixed bin init (6),
	  2 zeros		bit (108) init (""b);
dcl	1 ptr_arg		static,
	  2 pt		ptr init (null ()),		/* always null */
	  2 type		fixed bin init (3),
	  2 off1		fixed bin init (50),
	  2 zeros		bit (72) init (""b);
dcl	1 tally_arg	static,
	  2 pt		ptr init (null ()),		/* always null */
	  2 type		fixed bin init (3),
	  2 off1		fixed bin,		/* set each time to allocated stack location */
	  2 zeros		bit (72) init (""b);

dcl	epp2_instr	bit (36) static init ("110000000000000000011101010001000000"b);
						/* epp2	 pr6|-			*/
dcl	spri2_instr	bit (36) static init ("110000000000000000010101010001000000"b);
						/* spri2	pr6|-			*/

dcl	1 pr2_struct	static,
	  2 pr		fixed bin init (2),
	  2 pointer_no	bit (3),
	  2 lock		fixed bin init (0),
	  2 switch	fixed bin init (0),
	  2 segno		fixed bin,
	  2 offset	fixed bin,
	  2 reset		fixed bin;
dcl	1 pr1_struct	static,
	  2 pr		fixed bin init (1),
	  2 pointer_no	bit (3),
	  2 lock		fixed bin init (1),
	  2 switch	fixed bin init (0),
	  2 segno		fixed bin,
	  2 offset	fixed bin,
	  2 reset		fixed bin;
dcl	1 reg_struct	static,
	  2 what_reg	fixed bin init (1),		/* A */
	  2 reg_no	bit (4),
	  2 lock		fixed bin init (0),
	  2 already_there	fixed bin,
	  2 contains	fixed bin init (0),
	  2 pointer	ptr init (null ()),
	  2 literal	bit (36) init (""b);
dcl	1 reg1_struct	static,
	  2 what_reg	fixed bin init (11),	/* x1 */
	  2 reg_no	bit (4),
	  2 lock		fixed bin init (1),
	  2 already_there	fixed bin,
	  2 contains	fixed bin init (0),
	  2 pointer	ptr init (null ()),
	  2 literal	bit (36) init (""b);

dcl	1 mpout		static,
	  2 n		fixed bin init (4),
	  2 pt1		ptr,
	  2 pt2		ptr,
	  2 pt3		ptr,
	  2 pt4		ptr;
dcl	1 type19_move	static,
	  2 header	(4) fixed bin init (38, 0, 0, 19),
	  2 verb		fixed bin init (0),
	  2 e		fixed bin init (1),
	  2 h		fixed bin init (0),
	  2 ij		(2) fixed bin init (0, 0),
	  2 abcdfgk	bit (16) init ("0000000000000000"b);
dcl	1 alpha_type9	static,
	  2 header	(4) fixed bin init (112, 0, 0, 9),
	  2 repl_ptr	(2) ptr init ((2) null ()),
	  2 fill1		bit (108) init (""b),
	  2 file_key_info,
	    3 fb1		(3) fixed bin init (0, 0, 0),
	    3 size	fixed bin init (0),
	    3 fb2		(2) fixed bin init (0, 0),
	    3 flags1	bit (36) init ("000000100100000000010000000100000000"b),
	    3 flags2	bit (36) init (""b),
	    3 seg		fixed bin init (1000),
	    3 off		fixed bin,
	  2 fill2		(7) fixed bin init (0, 0, 0, 0, 0, 0, 0);
dcl	1 type2_static	static,
	  2 header	(4) fixed bin init (40, 0, 0, 2),
	  2 flags		bit (9) init ("000000000"b),
	  2 signs		char (2) init ("  "),
	  2 places	(4) fixed bin init (0, 1, 0, 1),
	  2 lits		char (1) init ("1");
dcl	1 type3,
	  2 alignment	ptr,			/* so as to double word align the space */
	  2 rest		char (26);
dcl	alpha_char	char (112) based (addr (alpha_type9));
dcl	type9		char (112);
dcl	1 addpout		static,
	  2 n		fixed bin init (4),
	  2 pt1		ptr,
	  2 pt2		ptr,
	  2 pt3		ptr,
	  2 pt4		ptr;
dcl	1 type19_add	static,
	  2 header	(4) fixed bin init (38, 0, 0, 19),
	  2 verb		fixed bin init (2),
	  2 e		fixed bin init (1),
	  2 h		fixed bin init (1),
	  2 ij		(2) fixed bin init (0, 0),
	  2 abcdfgk	bit (16) init ("0000000000000000"b);
dcl	1 fb35_type9	static,
	  2 header	(4) fixed bin init (112, 0, 0, 9),
	  2 repl_ptr	(2) ptr init ((2) null ()),
	  2 fill1		bit (108) init (""b),
	  2 file_key_info,
	    3 fb1		(3) fixed bin init (0, 0, 0),
	    3 size	fixed bin init (4),
	    3 places_left	fixed bin init (4),
	    3 places_right	fixed bin init (0),
	    3 flags1	bit (36) init ("000000100100001001000000000000000000"b),
	    3 flags2	bit (36) init (""b),
	    3 seg		fixed bin init (1000),
	    3 off		fixed bin,
	  2 fill2		(7) fixed bin init (0, 0, 0, 0, 0, 0, 0);
dcl	lead_inst		(4) bit (18) static init ("110000000000000000"b, "010011100001000000"b,
						/* szn	pr6	cnt_off	*/
			"000000000000000000"b, "110000001000000100"b);
						/* tnz	exit_tag	*/
dcl	lxl3_inst		(6) bit (18) static init ("110000000000000000"b, "111010011001000000"b,
						/* lxl3	pr6|cnt_off	*/
			"000000000000000001"b, "000110011000000011"b,
						/* adx3	1,du		*/
			"110000000000000000"b, "111100011001000000"b);
						/* stx3	pr6|temp_off	*/
dcl	cmpx_inst		(10) bit (18) static init ("110000000000000000"b, "001000001001000000"b,
						/* cmpx1	pr6|temp_off	*/
			"000000000000000000"b, "110000100100000100"b,
						/* tmoz	exit_tag,ic	*/
			"110000000000000000"b, "001110001001000000"b,
						/* sbx1	pr6|temp_off	*/
			"110000000000000000"b, "000110010001000000"b,
						/* sbx2	pr6|temp_of	*/
			"000000000000000000"b, "111001000000000100"b);
						/* tra	scan_tag,ic	*/
dcl	(scan_tag, exit_tag, length_off, cnt_off)
			fixed bin;
dcl	ttn		bit (36) static init ("000000000000000000110000110100000100"b);
						/* ttn	exit,ic	*/
dcl	scm		(8) bit (18) static init ("000000000000000000"b, "001010100101101010"b,
						/* scm (pr,x2,rl),()	*/
			"001000000000000000"b, "000000000000001001"b,
						/* pr1|0,x1		*/
			"000000000000000000"b, "000000000000000000"b,
						/* sacn chars or offset	*/
			"110000000000000000"b, "000000000001000000"b);
						/* pr6|tally_count_off	*/
dcl	scd		(8) bit (18) static init ("000000000000000000"b, "001010000101101010"b,
						/* scd (pr,x2,rl),()	*/
			"001000000000000000"b, "000000000000001001"b,
						/* pr1|0,x1		*/
			"000000000000000000"b, "000000000000000000"b,
						/* sacn chars or offset	*/
			"110000000000000000"b, "000000000001000000"b);
						/* pr6|tally_count_off	*/

dcl	lxl_inst		(4) bit (18) static init ("110000000000000000"b, "111010001001000000"b,
						/* lxl1	pr6|length_off	*/
			"000000000000000000"b, "010010010000000011"b);
						/* ldx2	0,du	*/
dcl	lda_inst		(8) bit (18) static init ("110000000000000000"b, "010011101001000000"b,
						/* lda	pr6|length_off	*/
			"000000000000000000"b, "001111101000000111"b,
						/* sba	item_len,dl	*/
			"110000000000000000"b, "001111101001000000"b,
						/* sba	pr6|cnt_off	*/
			"110000000000000000"b, "111101101001000000"b);
						/* sta	pr6|cnt_off	*/
dcl	lca_inst		(8) bit (18) static init ("110000000000000000"b, "011011101001000000"b,
						/* lca	pr6|cnt_off	*/
			"000000000000000000"b, "001111101000000111"b,
						/* sba	item_len`sght,dl	*/
			"001000000000000000"b, "101010000101000101"b,
						/* s9bd	pr1|0,al	*/
			"110000000000000000"b, "000101101001000000"b);
						/* asa	pr6|length_off	*/
dcl	before_option	fixed bin,
	after_flag	bit (1);
dcl	(data_len, full_len, prev_scan)
			fixed bin;

dcl	ptr_off		fixed bin static init (50);
dcl	all_key		fixed bin static init (73);
dcl	characters_key	fixed bin static init (83);
dcl	leading_key	fixed bin static init (122);
dcl	before_key	fixed bin static init (80);
dcl	after_key		fixed bin static init (72);
dcl	first_key		fixed bin static init (109);
dcl	replacing_key	fixed bin static init (152);
dcl	mvt_table		char (128);
dcl	mvt_table_static	char (128) static init ("	
 !""#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~");
dcl	mvt		(4) bit (36);
dcl	mrl		(3) bit (36);
dcl	mlr		(3) bit (36);
dcl	mlr_tab		(3) bit (36) static
			init ("000000000001000000001000000100000100"b, "000000000000000000000000000010000000"b,
			"110000000000000000000000000010000000"b);
dcl	ldx1_inst		bit (36) static init ("000000000000000000010010001000000011"b);
dcl	lxl1_inst		bit (36) static init ("110000000000000000111010001001000000"b);
dcl	argb		(3) bit (216) based (addr (args.arg (1)));

dcl	code		bit (18) aligned;
dcl	save_code		bit (18) aligned;
dcl	found		bit (1);
dcl	done		bit (1);
dcl	char1		char (1);
dcl	char1_bit		bit (9) based (addr (char1));
dcl	char1_index	fixed bin;
dcl	rn_opt		bit (1);
dcl	tn_opt		bit (1);
dcl	stack_flag	fixed bin;
dcl	opch_flag		fixed bin;
dcl	con_flag		fixed bin;
dcl	conoff		fixed bin;
dcl	i		fixed bin;
dcl	tn		fixed bin;
dcl	rn		fixed bin;
dcl	j		fixed bin;
dcl	tind		fixed bin;
dcl	toutoff		fixed bin;
dcl	temp		fixed bin;
dcl	stoff		fixed bin;
dcl	aloff		fixed bin;
dcl	dn_ptr		ptr;
dcl	input_area	char (24);
dcl	reloc_area	char (10);
dcl	pr2_struct_ptr	ptr;
dcl	arg_ptr		ptr;
dcl	ttp		(512) ptr;

dcl	cobol_alloc$stack	entry (fixed bin, fixed bin, fixed bin);
dcl	cobol_pointer_register$priority
			entry (fixed bin, fixed bin, bit (3));
dcl	cobol_make_tagref	entry (fixed bin, fixed bin, ptr);
dcl	cobol_define_tag_nc entry (fixed bin, fixed bin); /*[4.4-1]*/
dcl	cobol_add_gen	entry (ptr, fixed bin);
dcl	cobol_emit	entry (ptr, ptr, fixed bin);
dcl	cobol_get_size$omit_sign
			entry (ptr, fixed bin, fixed bin);
dcl	cobol_move_gen	entry (ptr);
dcl	cobol_set_pr$omit_sign
			entry (ptr, ptr);
dcl	cobol_addr	entry (ptr, ptr, ptr);
dcl	cobol_pool	entry (char (*), fixed bin, fixed bin);
dcl	cobol_register$release
			entry (ptr);
dcl	cobol_make_type3$type1
			entry (ptr, ptr);
dcl	cobol_call_op	entry (fixed bin, fixed bin);
dcl	cobol_make_type9$type2_3
			entry (ptr, ptr);
dcl	cobol_io_util$bin_to_t9dec
			entry (bit (3) aligned, fixed bin, ptr);
dcl	cobol_io_util$t9dec_to_bin
			entry (bit (3) aligned, fixed bin, ptr);
dcl	cobol_io_util$move_direct
			entry (bit (3), fixed bin, fixed bin, fixed bin, bit (18) aligned);
dcl	cobol_reset_r$in_line
			entry;
dcl	cobol_register$load entry (ptr);

/*************************************/
start:
	call cobol_register$load (addr (reg_struct));
	arg_ptr = addr (args);
	pr2_struct_ptr = addr (pr2_struct);
	mpout.pt1 = mp.pt (1);
	mpout.pt4 = addr (type19_move);

	call cobol_alloc$stack (16, 2, stoff);
	eos_ptr = mp.pt (mp.n);
	i = 4;
	if end_stmt.a = "000"b
	then /* Format 1 */
	     call tally;
	else if end_stmt.a = "001"b
	then do;
		call replace;
	     end;
	else do;
		if end_stmt.b = "0"b | end_stmt.a = "010"b
		then do;				/* BEFORE REPLACING */
			call tally;
			i = i + 1;
			if end_stmt.a = "011"b
			then i = i + 1;
			call replace;
		     end;
		else do;				/* AFTER REPLACING */
			found = "0"b;
			do i = 7 to mp.n - 1 while (^found);
			     if mp.pt (i) -> data_name.type = 1
			     then if mp.pt (i) -> reserved_word.key = replacing_key
				then do;
					found = "1"b;
					i = i + 1;
					call replace;
					i = 4;
					call tally;
				     end;
			end;
		     end;
	     end;

	call cobol_reset_r$in_line;
	return;


/*************************************/
/* SUBROUTINES */
/*************************************/

tally:
     proc;
	call tally_stack_count;
	if tn_opt
	then do;
		call tally_opt;
		return;
	     end;
	tind = 1;
	tn = 0;
	ttp (1) = mp.pt (i);
	call cobol_io_util$t9dec_to_bin ("110"b, toutoff, ttp (1));
						/* 7/18/76*/

/* BUILD THE FOLLOWING  STRUCTURE:
/*		dcl 1 t,
/*		     2 ssp ptr,
/*		     2 slen fixed bin,
/*		     2 n fixed bin,
/*		     2 tally (0 refer(t.n)),
/*			3 ccode fixed bin,		/* 0=CHARACTERS, 1=LEADING, 2=ALL */
/*			3 lcode fixed bin,		/* 0=unspecified, 1=BEFORE, 2=AFTER */
/*			3 lpos fixed bin,		/* char pos to enable after's or disable before's */
/*			3 llen fixed bin,		/* length of BEFORE/AFTER string */
/*			3 lsp ptr,		/* ptr to BEFORE/AFTER string (if lcode ^= 0) */
/*			3 csp ptr,		/* ptr to LEADING/ALL string (if ccode > 0) */
/*			3 clen fixed bin,		/* length of LEADING/ALL string */
/*			3 ind fixed bin;		tally index		*/
/**/
restart:
	done = "0"b;
	i = i + 1;
	do while (^done);
	     tn = tn + 1;
	     if mp.pt (i) -> reserved_word.key = characters_key
	     then code = ""b;
	     else do;
		     if mp.pt (i) -> reserved_word.key = leading_key
		     then code = "000000000000000001"b;
		     else code = "000000000000000010"b; /* ALL */
		     i = i + 1;
		     dn_ptr = mp.pt (i);
		     if data_name.type ^= 9
		     then call get_type9;
		     call store_pr (dn_ptr, 10 + 10 * (tn - 1));
						/* t.csp(tn) */
		     call cobol_get_size$omit_sign (dn_ptr, stoff + 12 + 10 * (tn - 1), 0);
						/* t.clen(tn) */
		end;
	     call cobol_io_util$move_direct ("110"b, 4 * (stoff + 4 + 10 * (tn - 1)), 4, 1, code);
						/* t.ccode(tn) */
	     i = i + 1;
	     code = ""b;
	     if mp.pt (i) -> data_name.type = 1
	     then do;
		     if mp.pt (i) -> reserved_word.key = before_key | mp.pt (i) -> reserved_word.key = after_key
		     then do;
			     if mp.pt (i + 1) -> data_name.type = 1
			     then if mp.pt (i + 1) -> reserved_word.key = replacing_key
				then go to forget_it;
			     if mp.pt (i) -> reserved_word.key = before_key
			     then code = "000000000000000001"b;
			     else code = "000000000000000010"b;
			     i = i + 1;
			     dn_ptr = mp.pt (i);
			     if data_name.type ^= 9
			     then call get_type9;
			     call store_pr (dn_ptr, 8 + 10 * (tn - 1));
						/* t.lsp(tn) */
			     call cobol_get_size$omit_sign (dn_ptr, stoff + 7 + 10 * (tn - 1), 0);
						/* t.llen(tn) */
			     i = i + 1;
			end;
		end;
forget_it:
	     call cobol_io_util$move_direct ("110"b, 4 * (stoff + 5 + 10 * (tn - 1)), 4, 1, code);
						/* t.lcode(tn) */
	     code = substr (unspec (tind), 19, 18);
	     call cobol_io_util$move_direct ("110"b, 4 * (stoff + 13 + 10 * (tn - 1)), 4, 1, code);
						/* t.lcode(tn) */
	     dn_ptr = mp.pt (i);
	     if data_name.type ^= 1
	     then done = "1"b;
	     else do;
		     temp = dn_ptr -> reserved_word.key;
		     if temp ^= all_key & temp ^= leading_key & temp ^= characters_key
		     then done = "1"b;
		end;
	end;
	if mp.n > i & mp.pt (i) -> data_name.type = 9
	then do;
		tind = tind + 1;
		ttp (tind) = mp.pt (i);
		call cobol_io_util$t9dec_to_bin ("110"b, toutoff + (tind - 1) * 4, ttp (tind));
		goto restart;
	     end;
	call store_pr (mp.pt (2), 0);			/* t.ssp */
	call cobol_get_size$omit_sign (mp.pt (2), stoff + 2, 0);
						/* t.slen */
	substr (epp2_instr, 4, 15) = substr (unspec (stoff), 22, 15);
	code = substr (unspec (tn), 19, 18);
	call cobol_io_util$move_direct ("110"b, 4 * (stoff + 3), 4, 1, code);
						/* t.n */
	call cobol_emit (addr (epp2_instr), null (), 1);
	call cobol_call_op (50, 0);
	do j = 1 to tind;
	     call cobol_io_util$bin_to_t9dec ("110"b, toutoff + (j - 1) * 4, ttp (j));
	end;
exit_tally:
	return;

/*	Calculate the stack needed for tallying.	*/
tally_stack_count:
     proc;

dcl	j		fixed bin;
dcl	done		bit (1);
dcl	off		fixed bin;
dcl	tn		fixed bin;
	tind = 1;
	tn = 0;
	j = i + 1;
	;
	tn_opt = "1"b;
try_again:
	done = "0"b;
	do while (^done);
	     tn = tn + 1;
	     if tn > 1
	     then tn_opt = "0"b;
	     if mp.pt (j) -> reserved_word.key ^= characters_key
	     then j = j + 1;
	     if tn_opt
	     then do;
		     if mp.pt (j) -> data_name.type ^= 1
		     then do;
			     if mp.pt (j) -> data_name.type = 3
			     then if mp.pt (j) -> alphanum_lit.lit_size > 2
				then tn_opt = "0"b;
				else ;
			     else if mp.pt (j) -> data_name.type = 9
			     then do;
				     if mp.pt (j) -> data_name.variable_length
					| mp.pt (j) -> data_name.item_length > 2
				     then tn_opt = "0"b;
				end;
			     else tn_opt = "0"b;
			end;
		     if mp.pt (j + 1) -> data_name.type = 1
			& (mp.pt (j + 1) -> reserved_word.key = after_key
			| mp.pt (j + 1) -> reserved_word.key = before_key)
		     then do;
			     if mp.pt (j + 2) -> data_name.type = 1
				& mp.pt (j + 2) -> reserved_word.key = replacing_key
			     then tn_opt = "0"b;
			     else if mp.pt (j + 2) -> data_name.type = 3
			     then if mp.pt (j + 2) -> alphanum_lit.lit_size > 2
				then tn_opt = "0"b;
				else ;
			     else if mp.pt (j + 2) -> data_name.type = 9
			     then do;
				     if mp.pt (j + 2) -> data_name.variable_length
					| mp.pt (j + 2) -> data_name.item_length > 2
				     then tn_opt = "0"b;
				end;
			     else tn_opt = "0"b;
			end;
		end;
	     j = j + 1;
	     if mp.pt (j) -> data_name.type = 1
	     then do;
		     if mp.pt (j) -> reserved_word.key = before_key | mp.pt (j) -> reserved_word.key = after_key
		     then do;
			     if mp.pt (j + 1) -> data_name.type ^= 1
				| mp.pt (j + 1) -> reserved_word.key ^= replacing_key
			     then j = j + 2;
			end;
		end;
	     if mp.pt (j) -> data_name.type ^= 1
		| (mp.pt (j) -> reserved_word.key ^= all_key & mp.pt (j) -> reserved_word.key ^= characters_key
		& mp.pt (j) -> reserved_word.key ^= leading_key)
	     then done = "1"b;
	end;
	if mp.pt (j) -> data_name.type = 9 & j < mp.n
	then do;
		j = j + 1;
		tind = tind + 1;
		goto try_again;
	     end;
	off = (tind + tn * 10) * 4;
	toutoff = (stoff + tn * 10 + 4) * 4;
	if tn > 1
	then tn_opt = "0"b;
	if tn_opt
	then return;
	call cobol_alloc$stack (off, 2, j);

exit_tally_stack_count:
	return;
     end tally_stack_count;

/*************************************/
tally_opt:
     proc;


	addpout.pt1 = mp.pt (1);
	addpout.pt4 = addr (type19_add);
	if mp.pt (i + 1) -> reserved_word.key = characters_key
	then do;
		full_len = 0;
		if mp.pt (i + 2) -> data_name.type ^= 1
		then full_len = 1;
		else if mp.pt (i + 2) -> reserved_word.key ^= after_key
		     & mp.pt (i + 2) -> reserved_word.key ^= before_key
		then full_len = 1;
		else if mp.pt (i + 3) -> reserved_word.type = 1
		then if mp.pt (i + 3) -> reserved_word.key = replacing_key
		     then full_len = 1;
		if full_len = 1
		then do;
			dn_ptr = mp.pt (2);
			call cobol_alloc$stack (4, 1, length_off);
			call cobol_get_size$omit_sign (dn_ptr, length_off, 0);
			fb35_type9.off = length_off * 4;
			addpout.pt2 = addr (fb35_type9);
			addpout.pt3 = mp.pt (i);	/*[4.4-1]*/
			call cobol_add_gen (addr (addpout), 0);
		     end;
		else do;
			if mp.pt (i + 2) -> reserved_word.key = after_key
			then after_flag = "1"b;
			else after_flag = "0"b;
			call scan_opt_common (i + 3, data_len, "0"b, "1"b, "1"b, "1"b, "0"b, "0"b, "0"b, after_flag)
			     ;
			if mp.pt (i + 2) -> reserved_word.key = after_key
			then do;
				substr (lda_inst (1), 4, 15) = substr (unspec (length_off), 22, 15);
				substr (lda_inst (3), 1, 18) = substr (unspec (data_len), 19, 18);
				substr (lda_inst (5), 4, 15) = substr (unspec (cnt_off), 22, 15);
				substr (lda_inst (7), 4, 15) = substr (unspec (cnt_off), 22, 15);
				call cobol_emit (addr (lda_inst (1)), null, 4);
			     end;
			fb35_type9.off = cnt_off * 4;
			addpout.pt2 = addr (fb35_type9);
			addpout.pt3 = mp.pt (i);	/*[4.4-1]*/
			call cobol_add_gen (addr (addpout), 0);
			call cobol_define_tag_nc (exit_tag, cobol_$text_wd_off);
			call cobol_register$release (addr (reg1_struct));
			reg1_struct.reg_no = "1010"b;
			call cobol_register$release (addr (reg1_struct));
		     end;
		if full_len = 1
		then i = i + 2;
		else i = i + 4;
		return;
	     end;
	else do;
		prev_scan = 1;
		rw_ptr = mp.pt (i + 3);
		if reserved_word.type ^= 1
		then prev_scan = 0;
		else if reserved_word.key ^= before_key & reserved_word.key ^= after_key
		then prev_scan = 0;
		else if mp.pt (i + 4) -> reserved_word.type ^= 1
		then if mp.pt (i + 4) -> reserved_word.key = replacing_key
		     then prev_scan = 0;
		if prev_scan = 0
		then call scan_opt_common (i + 2, data_len, "1"b, "1"b, "1"b, "1"b, "1"b, "0"b, "0"b, "1"b);
		else do;
			if mp.pt (i + 3) -> reserved_word.key = after_key
			then after_flag = "1"b;
			else after_flag = "0"b;
			call scan_opt_common (i + 4, data_len, "0"b, "1"b, "1"b, "1"b, "0"b, after_flag, "1"b,
			     after_flag);
			call scan_opt_common (i + 2, data_len, "1"b, "0"b, "0"b, "0"b, "1"b, "0"b, "0"b, "1"b);
		     end;
	     end;
	if mp.pt (i + 1) -> reserved_word.key = leading_key
	then do;
		substr (lead_inst (1), 4, 15) = substr (unspec (cnt_off), 22, 15);
		call cobol_emit (addr (lead_inst (1)), null, 2);
		call cobol_make_tagref (exit_tag, cobol_$text_wd_off - 1, null);
	     end;
	addpout.pt2 = addr (type2_static);
	addpout.pt3 = mp.pt (i);			/*[4.4-1]*/
	call cobol_add_gen (addr (addpout), 0);
	reg_struct.what_reg = 13;
	call cobol_register$load (addr (reg_struct));
	temp = cnt_off + 1;
	substr (lxl3_inst (1), 4, 15) = substr (unspec (cnt_off), 22, 15);
	substr (lxl3_inst (5), 4, 15) = substr (unspec (temp), 22, 15);
	call cobol_emit (addr (lxl3_inst (1)), null, 3);
	call cobol_register$release (addr (reg_struct));
	reg_struct.what_reg = 1;

	substr (cmpx_inst (1), 4, 15) = substr (unspec (temp), 22, 15);
	substr (cmpx_inst (5), 4, 15) = substr (unspec (temp), 22, 15);
	substr (cmpx_inst (7), 4, 15) = substr (unspec (temp), 22, 15);
	call cobol_emit (addr (cmpx_inst (1)), null, 5);
	call cobol_make_tagref (exit_tag, cobol_$text_wd_off - 4, null);
	call cobol_make_tagref (scan_tag, cobol_$text_wd_off - 1, null);
	call cobol_register$release (addr (reg1_struct));
	reg1_struct.reg_no = "1001"b;
	call cobol_register$release (addr (reg1_struct));
	call cobol_define_tag_nc (exit_tag, cobol_$text_wd_off);
	call cobol_pointer_register$priority (2, 0, "001"b);
	if prev_scan = 1
	then i = i + 5;
	else i = i + 3;
exit_tally_opt:
	return;



     end tally_opt;
/******************************/



     end tally;




/*	scan_opt_common	*/
/****************************************/
scan_opt_common:
     proc (j, data_len, x2_flag, pr1_flag, len_flag, exit_flag, scan_flag, after_flag, x1_flag, ttn_flag);

dcl	j		fixed bin,
	data_len		fixed bin,
	(x2_flag, pr1_flag, len_flag, after_flag, x1_flag, ttn_flag, exit_flag, scan_flag)
			bit (1);

	dn_ptr = mp.pt (2);
	if pr1_flag
	then do;
		if data_name.numeric & data_name.item_signed & ^data_name.sign_separate
		then call opch_move (dn_ptr);
		call cobol_set_pr$omit_sign (addr (pr1_struct), dn_ptr);
	     end;
	if len_flag
	then do;
		call cobol_alloc$stack (20, 1, length_off);
		cnt_off = length_off + 1;
		call cobol_get_size$omit_sign (dn_ptr, length_off, 0);
		call cobol_register$load (addr (reg1_struct));
		reg1_struct.what_reg = 12;
		call cobol_register$load (addr (reg1_struct));
		reg1_struct.what_reg = 11;
		substr (lxl_inst (1), 4, 15) = substr (unspec (length_off), 22, 15);
		call cobol_emit (addr (lxl_inst (1)), null, 1);
	     end;
	if x2_flag
	then do;
		call cobol_emit (addr (lxl_inst (3)), null, 1);
		substr (scm (2), 15, 4) = "1010"b;
		substr (scd (2), 15, 4) = "1010"b;
	     end;
	else do;
		substr (scm (2), 15, 4) = "0000"b;
		substr (scd (2), 15, 4) = "0000"b;
	     end;
	if exit_flag
	then do;
		exit_tag = cobol_$next_tag;
		cobol_$next_tag = cobol_$next_tag + 1;
	     end;
	dn_ptr = mp.pt (j);
	if data_name.type = 1
	then do;
		call cobol_make_type3$type1 (addr (type3), dn_ptr);
		dn_ptr = addr (type3);
	     end;
	if data_name.type = 3
	then do;
		alit_ptr = dn_ptr;
		if scan_flag
		then do;
			scan_tag = cobol_$next_tag;
			cobol_$next_tag = cobol_$next_tag + 1;
			call cobol_define_tag_nc (scan_tag, cobol_$text_wd_off);
		     end;
		if alphanum_lit.lit_size = 1
		then do;
			data_len = 1;
			substr (lxl3_inst (3), 17, 2) = "01"b;
			substr (scm (7), 4, 15) = substr (unspec (cnt_off), 22, 15);
			substr (scm (5), 1, 9) = substr (unspec (alphanum_lit.string), 1, 9);
			substr (scm (5), 10, 9) = "000000000"b;
			substr (scm (1), 12, 7) = "0000011"b;
			call cobol_emit (addr (scm (1)), null, 4);
		     end;
		else do;
			data_len = 2;
			substr (lxl3_inst (3), 17, 2) = "10"b;
			substr (scd (7), 4, 15) = substr (unspec (cnt_off), 22, 15);
			substr (scd (1), 12, 7) = "0000011"b;
			substr (scd (5), 1, 18) = substr (unspec (alphanum_lit.string), 1, 18);
			call cobol_emit (addr (scd (1)), null, 4);
		     end;
	     end;
	else do;
		if data_name.numeric & data_name.item_signed & ^data_name.sign_separate
		then call opch_move (dn_ptr);
		mpout.pt2 = dn_ptr;
		mpout.pt3 = addr (alpha_type9);
		alpha_type9.off = 4 * length_off + 16;
		alpha_type9.size = data_name.item_length;
		call cobol_move_gen (addr (mpout));
		alpha_type9.flags1 = "000000100100000000010000000100000000"b;
		temp = length_off + 4;
		if scan_flag
		then do;
			scan_tag = cobol_$next_tag;
			cobol_$next_tag = cobol_$next_tag + 1;
			call cobol_define_tag_nc (scan_tag, cobol_$text_wd_off);
		     end;
		if data_name.item_length = 1
		then do;
			data_len = 1;
			substr (lxl3_inst (3), 17, 2) = "01"b;
			substr (scm (5), 1, 3) = "110"b;
			substr (scm (5), 4, 15) = substr (unspec (temp), 22, 15);
			substr (scm (7), 4, 15) = substr (unspec (cnt_off), 22, 15);
			substr (scm (1), 12, 7) = "100000"b;
			call cobol_emit (addr (scm (1)), null, 4);
		     end;
		else do;
			data_len = 2;
			substr (lxl3_inst (3), 17, 2) = "10"b;
			substr (scd (5), 1, 3) = "110"b;
			substr (scd (5), 4, 15) = substr (unspec (temp), 22, 15);
			substr (scd (7), 4, 15) = substr (unspec (cnt_off), 22, 15);
			substr (scd (1), 12, 7) = "100000"b;
			call cobol_emit (addr (scd (1)), null, 4);
		     end;
	     end;
	if ttn_flag
	then do;
		call cobol_emit (addr (ttn), null, 1);
		call cobol_make_tagref (exit_tag, cobol_$text_wd_off - 1, null);
	     end;

	if after_flag
	then do;
		substr (lca_inst (1), 4, 15) = substr (unspec (cnt_off), 22, 15);
		substr (lca_inst (3), 1, 18) = substr (unspec (data_len), 19, 18);
		substr (lca_inst (7), 4, 15) = substr (unspec (length_off), 22, 15);
		call cobol_emit (addr (lca_inst (1)), null, 4);
		substr (lxl_inst (1), 4, 15) = substr (unspec (length_off), 22, 15);
	     end;
	else substr (lxl_inst (1), 4, 15) = substr (unspec (cnt_off), 22, 15);
	if x1_flag
	then call cobol_emit (addr (lxl_inst (1)), null, 1);

exit_scan_opt_common:
	return;
     end scan_opt_common;
/****************************************/



/*************************************/
replace:
     proc;					/* BUILD THE FOLLOWING STRUCTURE:
/*		dcl 1 r,
/*		     2 ssp ptr,
/*		     2 slen fixed bin,
/*		     2 n fixed bin,
/*		     2 repl(0 refer(r.n)),
/*			3 ccode fixed bin,		/* 3=FIRST */
						/*			3 lcode fixed bin,
/*			3 lpos fixed bin,
/*			3 llen fixed bin,
/*			3 lsp ptr,
/*			3 csp ptr,
/*			3 clen fixed bin,
/*			3 bsp ptr;		/* ptr to BY string (length must = clen) */
						/**/
	rn = 0;
	save_code = ""b;
	call replacing_stack_count;
	if rn_opt
	then do;
		call repl_opt;
		return;
	     end;
	do while (mp.pt (i) -> data_name.type ^= 19);
	     rn = rn + 1;
	     dn_ptr = mp.pt (i);
	     if data_name.type = 1
	     then do;				/* may be key-word or a fig-con */
		     rw_ptr = dn_ptr;
		     if reserved_word.key = characters_key
		     then save_code = ""b;
		     else do;
			     if reserved_word.key = leading_key
			     then save_code = "000000000000000001"b;
			     else if reserved_word.key = all_key
			     then save_code = "000000000000000010"b;
			     else if reserved_word.key = first_key
			     then save_code = "000000000000000011"b;
			     else i = i - 1;	/* fig-con, save_code will have been set */
			     i = i + 1;
			     dn_ptr = mp.pt (i);
			     if data_name.type ^= 9
			     then call get_type9;
			     call store_pr (dn_ptr, 10 + 12 * (rn - 1));
						/* r.csp(rn) */
			     call cobol_get_size$omit_sign (dn_ptr, stoff + 12 + 12 * (rn - 1), 0);
						/* r.clen(rn) */
			end;
		end;
	     else do;
		     if data_name.type ^= 9
		     then call get_type9;
		     call store_pr (dn_ptr, 10 + 12 * (rn - 1));
						/*r.csp(rn) */
		     call cobol_get_size$omit_sign (dn_ptr, stoff + 12 + 12 * (rn - 1), 0);
						/* r.clen(rn) */
		end;
	     call cobol_io_util$move_direct ("110"b, 4 * (stoff + 4 + 12 * (rn - 1)), 4, 1, save_code);
						/* r.ccode(rn) */
	     i = i + 1;
	     dn_ptr = mp.pt (i);
	     if data_name.type ^= 9
	     then call get_type9;
	     call store_pr (dn_ptr, 14 + 12 * (rn - 1));	/* r.bsp(rn) */
	     i = i + 1;
	     code = ""b;
	     if mp.pt (i) -> data_name.type = 1
	     then do;
		     if mp.pt (i) -> reserved_word.key = before_key | mp.pt (i) -> reserved_word.key = after_key
		     then do;
			     if mp.pt (i) -> reserved_word.key = before_key
			     then code = "000000000000000001"b;
			     else code = "000000000000000010"b;
			     i = i + 1;
			     dn_ptr = mp.pt (i);
			     if data_name.type ^= 9
			     then call get_type9;
			     call store_pr (dn_ptr, 8 + 12 * (rn - 1));
						/* r.lsp(rn) */
			     call cobol_get_size$omit_sign (dn_ptr, stoff + 7 + 12 * (rn - 1), 0);
						/* r.llen(rn) */
			     i = i + 1;
			end;
		end;
	     call cobol_io_util$move_direct ("110"b, 4 * (stoff + 5 + 12 * (rn - 1)), 4, 1, code);
						/* r.lcode(rn) */
	end;
	dn_ptr = mp.pt (2);
	call store_pr (dn_ptr, 0);
	call cobol_get_size$omit_sign (mp.pt (2), stoff + 2, 0);
						/* r.slen */
	code = substr (unspec (rn), 19, 18);
	call cobol_io_util$move_direct ("110"b, 4 * (stoff + 3), 4, 1, code);
						/* r.n */
	substr (epp2_instr, 4, 15) = substr (unspec (stoff), 22, 15);
	call cobol_emit (addr (epp2_instr), null (), 1);
	call cobol_call_op (51, 0);
	if mp.pt (2) -> data_name.numeric & mp.pt (2) -> data_name.item_signed & ^mp.pt (2) -> data_name.sign_separate
	then do;
		mpout.pt2 = addr (alpha_type9);
		mpout.pt3 = mp.pt (2);
		call cobol_move_gen (addr (mpout));
	     end;
	return;


/*	Calculate replacing stack frame requirement.	*/
replacing_stack_count:
     proc;

dcl	j		fixed bin;
dcl	(all_option, leading_option)
			fixed bin;
dcl	k		fixed bin;
dcl	rn		fixed bin;

	all_option, leading_option, before_option = 0;
	rn = 0;
	rn_opt = "1"b;
	con_flag = 1;
	j = i;
	do while (mp.pt (j) -> data_name.type ^= 19);
	     rn = rn + 1;
	     if mp.pt (j) -> data_name.type = 1
	     then do;
		     if mp.pt (j) -> reserved_word.key = leading_key | mp.pt (j) -> reserved_word.key = first_key
			| mp.pt (j) -> reserved_word.key = characters_key
		     then leading_option = leading_option + 1;
		     else if mp.pt (j) -> reserved_word.key = all_key
		     then all_option = all_option + 1;
		     if mp.pt (j) -> reserved_word.key ^= characters_key
		     then do;
			     if mp.pt (j) -> reserved_word.key = leading_key
				| mp.pt (j) -> reserved_word.key = all_key
				| mp.pt (j) -> reserved_word.key = first_key
			     then j = j + 1;
			end;
		end;
	     do k = 1 to 2;
		if mp.pt (j) -> data_name.type = 3
		then if mp.pt (j) -> alphanum_lit.lit_size ^= 1
		     then rn_opt = "0"b;
		     else ;
		else if mp.pt (j) -> data_name.type = 9
		then if (mp.pt (j) -> data_name.item_length ^= 1 | mp.pt (j) -> data_name.variable_length = "1"b)
		     then rn_opt = "0"b;
		if rn_opt
		then if mp.pt (j) -> data_name.type = 9
		     then con_flag = 0;
		j = j + 1;
	     end;
	     if mp.pt (j) -> data_name.type = 1
	     then do;
		     if mp.pt (j) -> reserved_word.key = before_key | mp.pt (j) -> reserved_word.key = after_key
		     then do;
			     if mp.pt (j + 1) -> data_name.type = 3
			     then if mp.pt (j + 1) -> alphanum_lit.lit_size > 2
				then rn_opt = "0"b;
				else ;
			     else if mp.pt (j + 1) -> data_name.type = 9
			     then if (mp.pt (j + 1) -> data_name.item_length > 2
				     | mp.pt (j + 1) -> data_name.variable_length = "1"b)
				then rn_opt = "0"b;
				else rn_opt = "0"b;
			     j = j + 2;
			     before_option = before_option + 1;
			end;
		end;
	end;
	if rn_opt
	then do;
		if (leading_option ^= 0 | (before_option ^= 0 & all_option > 1))
		then rn_opt = "0"b;
		else if (before_option ^= 0 & rn > 1)
		then rn_opt = "0"b;
		else return;
	     end;
	call cobol_alloc$stack (48 * rn, 2, j);
exit_replacing_stack_count:
	return;
     end replacing_stack_count;


/* Generate on line instructions for optimatization of replacing single cahracter.	*/
repl_opt:
     proc;

dcl	j		fixed bin;
dcl	length_off	fixed bin;
dcl	k		fixed bin;

	i = i + 1;
	mvt_table = mvt_table_static;
	input_ptr = addr (input_area);
	reloc_ptr = addr (reloc_area);
	input_struc.type = 5;
	input_struc.operand_no = 2;
	input_struc.lock = 0;
	input_struc.size_sw (1) = 0;
	input_struc.size_sw (2) = 0;
	if before_option ^= 0
	then k = mp.n - 3;
	else k = mp.n - 1;
	if con_flag = 1
	then do;
		stack_flag = 0;
		do j = k to i by -1;
		     if mp.pt (j) -> reserved_word.key = all_key
		     then j = j - 1;
		     j = j - 1;
		     alit_ptr = mp.pt (j);
		     if alphanum_lit.type = 1
		     then do;
			     call cobol_make_type3$type1 (addr (type3), alit_ptr);
			     alit_ptr = addr (type3);
			end;
		     char1 = substr (alphanum_lit.string, 1, 1);
		     char1_index = fixed (char1_bit) + 1;
		     alit_ptr = mp.pt (j + 1);
		     if alphanum_lit.type = 1
		     then do;
			     call cobol_make_type3$type1 (addr (type3), alit_ptr);
			     alit_ptr = addr (type3);
			end;
		     substr (mvt_table, char1_index, 1) = substr (alphanum_lit.string, 1, 1);
		end;
		call cobol_pool (mvt_table, 2, conoff);
		substr (mvt (4), 19, 18) = "000000000000000100"b;
	     end;
	else do;
		stack_flag = 1;
		call cobol_alloc$stack (132, 2, length_off);
		call cobol_register$load (addr (reg1_struct));
		call cobol_pool (mvt_table_static, 2, conoff);
		temp = -conoff - cobol_$text_wd_off;
		substr (mlr_tab (2), 1, 18) = substr (unspec (temp), 19, 18);
		substr (mlr_tab (3), 4, 15) = substr (unspec (length_off), 22, 15);
		call cobol_emit (addr (mlr_tab (1)), null, 3);
		do j = k to i by -1;
		     if mp.pt (j) -> reserved_word.key = all_key
		     then j = j - 1;
		     j = j - 1;
		     if mp.pt (j) -> data_name.type ^= 9
		     then do;
			     alit_ptr = mp.pt (j);
			     if alphanum_lit.type = 1
			     then do;
				     call cobol_make_type3$type1 (addr (type3), alit_ptr);
				     alit_ptr = addr (type3);
				end;
			     substr (ldx1_inst, 10, 9) = substr (unspec (alphanum_lit.string), 1, 9);
			     call cobol_emit (addr (ldx1_inst), null, 1);
			end;
		     else do;
			     input_struc.token_ptr (1) = mp.pt (j);
			     if mp.pt (j) -> data_name.item_signed
			     then call opch_move (input_struc.token_ptr (1));
			     alpha_type9.off = length_off * 4 + 130;
			     alpha_type9.size = 2;
			     input_struc.token_ptr (2) = addr (alpha_type9);
			     call cobol_addr (input_ptr, addr (mrl (1)), reloc_ptr);
			     substr (mrl (1), 19, 10) = "0010000011"b;
			     substr (mrl (2), 21, 8) = "00000000"b;
			     substr (mrl (3), 21, 12) = "0000000000"b;
			     call cobol_emit (addr (mrl (1)), reloc_ptr, 3);
			     temp = length_off + 32;
			     substr (lxl1_inst, 4, 15) = substr (unspec (temp), 22, 15);
			     call cobol_emit (addr (lxl1_inst), null, 1);
			end;
		     if mp.pt (j + 1) -> data_name.type ^= 9
		     then do;
			     dn_ptr = mp.pt (j + 1);
			     if mp.pt (j + 1) -> data_name.type = 1
			     then do;
				     call cobol_make_type3$type1 (addr (type3), dn_ptr);
				     dn_ptr = addr (type3);
				end;
			     call cobol_make_type9$type2_3 (addr (type9), dn_ptr);
			     input_struc.token_ptr (1) = addr (type9);
			end;
		     else input_struc.token_ptr (1) = mp.pt (j + 1);
		     if mp.pt (j + 1) -> data_name.item_signed
		     then call opch_move (input_struc.token_ptr (1));
		     input_struc.token_ptr (2) = addr (alpha_type9);
		     alpha_type9.off = length_off * 4;
		     alpha_type9.size = 1;
		     substr (mlr (1), 19, 10) = "0010000001"b;
		     call cobol_addr (input_ptr, addr (mlr (1)), reloc_ptr);
		     substr (mlr (1), 15, 4) = "1001"b;
		     substr (mlr (2), 21, 8) = "00000000"b;
		     call cobol_emit (addr (mlr (1)), reloc_ptr, 3);
		end;
		substr (mvt (4), 4, 15) = substr (unspec (length_off), 22, 15);
		substr (mvt (4), 1, 3) = "110"b;
		substr (mvt (4), 19, 18) = "000000000001000000"b;
		reg1_struct.lock = 0;
		call cobol_register$release (addr (reg1_struct));
		reg1_struct.lock = 1;
	     end;
	substr (mvt (1), 19, 10) = "0011100001"b;
	if before_option ^= 0
	then do;
		if mp.pt (mp.n - 2) -> reserved_word.key = before_key
		then after_flag = "0"b;
		else after_flag = "1"b;
		call scan_opt_common (mp.n - 1, k, "0"b, "1"b, "1"b, "1"b, "0"b, after_flag, "1"b, after_flag);
		mvt (1) = "000000000001100000001110000101100000"b;
		mvt (2) = "001000000000000000000000000000001001"b;
		mvt (3) = "001000000000000000000000000000001001"b;
		if stack_flag = 0
		then do;
			temp = -conoff - cobol_$text_wd_off;
			substr (mvt (4), 1, 18) = substr (unspec (temp), 19, 18);
		     end;
		call cobol_emit (addr (mvt (1)), null, 4);
		if mp.pt (2) -> data_name.numeric & mp.pt (2) -> data_name.item_signed
		     & ^mp.pt (2) -> data_name.sign_separate
		then do;
			alpha_type9.seg = 5001;
			alpha_type9.off = 0;
			mpout.pt2 = addr (alpha_type9);
			mpout.pt3 = mp.pt (2);
			call cobol_move_gen (addr (mpout));
		     end;
		call cobol_define_tag_nc (exit_tag, cobol_$text_wd_off);
	     end;
	else do;
		input_struc.token_ptr (1) = mp.pt (2);
		if mp.pt (2) -> data_name.numeric & mp.pt (2) -> data_name.item_signed
		     & ^mp.pt (2) -> data_name.sign_separate
		then do;
			call opch_move (input_struc.token_ptr (1));
			opch_flag = 1;
		     end;
		else opch_flag = 0;
		if input_struc.token_ptr (1) -> data_name.numeric
		then input_struc.token_ptr (1) -> data_name.alphanum = "1"b;
		input_struc.token_ptr (2) = input_struc.token_ptr (1);
		call cobol_addr (input_ptr, addr (mvt (1)), reloc_ptr);
		if stack_flag = 0
		then do;
			temp = -conoff - cobol_$text_wd_off;
			substr (mvt (4), 1, 18) = substr (unspec (temp), 19, 18);
		     end;
		call cobol_emit (addr (mvt (1)), reloc_ptr, 4);
		if input_struc.token_ptr (1) -> data_name.numeric
		then input_struc.token_ptr (1) -> data_name.alphanum = "0"b;
		if opch_flag = 1
		then do;
			mpout.pt2 = input_struc.token_ptr (1);
			mpout.pt3 = mp.pt (2);
			call cobol_move_gen (addr (mpout));
		     end;
	     end;
exit_repl_opt:
	return;
     end repl_opt;



     end replace;


/*************************************/
store_pr:
     proc (t9ptr, off);
dcl	i		fixed bin;
dcl	t9ptr		ptr;
dcl	off		fixed bin;

	if t9ptr -> data_name.numeric & t9ptr -> data_name.item_signed & ^t9ptr -> data_name.sign_separate
	then call opch_move (t9ptr);
	call cobol_set_pr$omit_sign (pr2_struct_ptr, t9ptr);
	temp = stoff + off;
	substr (spri2_instr, 4, 15) = substr (unspec (temp), 22, 15);
	call cobol_emit (addr (spri2_instr), null (), 1);
	return;
     end store_pr;

/************************************/
opch_move:
     proc (t9ptr);
dcl	t9ptr		ptr;
dcl	i		fixed bin;
	mpout.pt2 = t9ptr;
	mpout.pt3 = addr (alpha_type9);
	alpha_type9.size = t9ptr -> data_name.item_length;
	call cobol_alloc$stack (alpha_type9.size, 1, i);
	alpha_type9.off = i * 4;
	call cobol_move_gen (addr (mpout));
	type9 = alpha_char;
	t9ptr = addr (type9);
	alpha_type9.flags1 = "000000100100000000010000000100000000"b;
	return;
     end opch_move;



/*************************************/
get_type9:
     proc;
	if data_name.type = 1
	then do;
		call cobol_make_type3$type1 (addr (type3), dn_ptr);
		dn_ptr = addr (type3);
	     end;
	if data_name.type ^= 9
	then do;
		call cobol_make_type9$type2_3 (addr (type9), dn_ptr);
		dn_ptr = addr (type9);
	     end;
	return;
     end get_type9;


/*************************************/
%include cobol_type1;
%include cobol_type2;
%include cobol_type3;
%include cobol_type9;
%include cobol_type19;
%include cobol_;
%include cobol_addr_tokens;
     end cobol_inspect_gen;




		    cobol_io_util.pl1               05/24/89  1041.5rew 05/24/89  0830.8      235800



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_io_util.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 3/18/81 by FCH, [4.4-1], entries set_fsb_loc and  fsb_key_loc added, BUG470 */
/* Modified on 11/17/78 by FCH, [3.0-1], entry file_desc added */
/*Modified since Version 3.0 */



/* format: style3 */
cobol_io_util:
     proc;

dcl	treg		bit (3) aligned;		/* register for target field */
dcl	toff		fixed bin;		/* char offset from treg of target field */
dcl	tlen		fixed bin;		/* number of characters of target */

/*[3.0-1]*/
dcl	desc_off		fixed bin (24),
	keynum		fixed bin;		/*[3.0-1]*/
dcl	(mode, offset)	fixed bin;

/*[4.4-1]*/
declare	1 op_codes	static internal,		/*[4.4-1]*/
	  2 epp1		bit (18) init ("011101001101000000"b),
						/*[4.4-1]*/
	  2 spri1		bit (18) init ("010101001101000000"b);

dcl	1 move_tokens	static,
	  2 n		fixed bin init (4),
	  2 fill		fixed bin,
	  2 move_token_ptr	(4) ptr init ((4) null ());
dcl	1 type19		static,
	  2 size		fixed bin init (38),
	  2 line		fixed bin init (0),
	  2 column	fixed bin init (0),
	  2 type		fixed bin init (19),
	  2 verb		fixed bin init (18),	/* MOVE */
	  2 e		fixed bin init (1),
	  2 h		fixed bin,
	  2 j		fixed bin,
	  2 a		bit (3),
	  2 b		bit (1),
	  2 c		bit (1),
	  2 d		bit (2),
	  2 f		bit (2),
	  2 g		bit (2),
	  2 k		bit (5);
dcl	1 type9		static,
	  2 header	(4) fixed bin init (112, 0, 0, 9),
	  2 repl_ptr	(2) ptr init ((2) null ()),
	  2 fill1		bit (108) init (""b),
	  2 file_key_info,
	    3 fb		(6) fixed bin init (0, 0, 0, 4, 0, 0),
	    3 flags1	bit (36) init (""b),
	    3 flags2	bit (36) init (""b),
	    3 seg		fixed bin init (1000),
	    3 off		fixed bin,
	  2 fill2		(7) fixed bin init (0, 0, 0, 0, 0, 0, 0);

dcl	1 btd_struct	static,
	  2 type		fixed bin init (4),
	  2 operand_no	fixed bin init (2),
	  2 lock		fixed bin init (0),
	  2 operand1,
	    3 token_ptr	ptr init (null ()),
	    3 send_receive	fixed bin init (0),
	    3 ic_mod	fixed bin,
	    3 size_sw	fixed bin init (0),
	  2 operand2,
	    3 token_ptr	ptr,
	    3 send_receive	fixed bin init (1),
	    3 ic_mod	fixed bin,
	    3 size_sw	fixed bin init (0);
dcl	1 dtb_struct	static,
	  2 type		fixed bin init (4),
	  2 operand_no	fixed bin init (2),
	  2 lock		fixed bin init (0),
	  2 operand1,
	    3 token_ptr	ptr,
	    3 send_receive	fixed bin init (0),
	    3 ic_mod	fixed bin,
	    3 size_sw	fixed bin init (0),
	  2 operand2,
	    3 token_ptr	ptr init (null ()),
	    3 send_receive	fixed bin init (0),
	    3 ic_mod	fixed bin,
	    3 size_sw	fixed bin init (0);
dcl	instr		(32) bit (36);

/*[3.0-1]*/
dcl	descoff		fixed bin;		/*[3.0-1]*/
dcl	ndx		bit (3),
	addrs		bit (15);
dcl	litlen		fixed bin;		/* char length of sending literal */
dcl	litoff		fixed bin;		/* word offset from current instr to literal */
dcl	swdoff		fixed bin;		/* word offset in stack of sending field */
dcl	twdoff		fixed bin;		/* word offset in stack of target field */
dcl	tmodoff		fixed bin;		/* char offset from twdoff */
dcl	smodoff		fixed bin;		/* char offset from swdoff */
dcl	dmodoff		fixed bin;		/* delta smodoff and tmodoff */
dcl	sal		fixed bin;		/* 0 = sending field even word aligned */
dcl	tal		fixed bin;		/* 0 = target field even word aligned */
dcl	modlen		fixed bin;
dcl	i		fixed bin;
dcl	off		fixed bin;
dcl	ic		fixed bin;
dcl	lensw		fixed bin;
dcl	(tlensw, slensw)	fixed bin;
dcl	fromsw		fixed bin;
dcl	adjustsw		fixed bin;
dcl	boundary		fixed bin;
dcl	temp		fixed bin;
dcl	temp_off		fixed bin;
dcl	ttlen		fixed bin;		/* target length used by move_unaligned subtrn */
dcl	regsw		fixed bin;		/* 0=sending field has IC modification; 1=sreg or ssreg contains sending register */
dcl	curlen		fixed bin;
dcl	adj		fixed bin;
dcl	init_count	fixed bin static init (0);

dcl	ssreg		bit (3) aligned;		/* sending register used by move_aligned and move_unaligned subrtns */
dcl	talsw		bit (1);
dcl	give_up		bit (1);
dcl	temp_tag		bit (6);
dcl	temp_instr	bit (12);

dcl	instr_ptr		ptr;

dcl	nothing		char (3) static options (constant) init ("");

/*************************************/
move_direct:
     entry (treg, toff, tlen, dudl, dval);

dcl	dudl		fixed bin;		/* 0=du; 1=dl */
dcl	dval		bit (18) aligned;		/* direct value */

start_move_direct:
	twdoff = divide (toff, 4, 17, 0);
	tmodoff = mod (toff, 4);

	if tlen + tmodoff > 4
	then return;				/* error */

	if tlen = 4 & dval = ""b & tmodoff = 0
	then do;

		instr (1) = treg || substr (unspec (twdoff), 22, 15) || stz_;
		ic = 1;
	     end;
	else do;

		instr (1) = dval || lda || dmod (dudl);
		instr (2) = treg || substr (unspec (twdoff), 22, 15);

		if tlen = 4 & tmodoff = 0
		then substr (instr (2), 19, 18) = sta_;
		else substr (instr (2), 19, 18) = stba_ || tagarray (tmodoff, tlen);
		ic = 2;
	     end;

	call cobol_reloc$cobol_emit (addr (instr), null (), ic);

	return;


/*************************************/
move_lit:
     entry (treg, toff, tlen, lit);

dcl	lit		char (*);			/* sending literal */

start_move_lit:
	ic = 0;
	litlen = length (lit);
	twdoff = divide (toff, 4, 17, 0);
	tal = mod (twdoff, 2);
	smodoff, tmodoff = mod (toff, 4);

	if litlen > tlen
	then litlen = tlen;				/* take care of truncation */
						/*-05/15/76-*/

	if tlen = litlen & tlen <= 2
	then do;

		ic = 2;
		fromsw = divide (tmodoff, 2, 17, 0);	/* fix bug */
						/*-05/15/76-*/
		adjustsw = mod (tmodoff, 2);
		instr (1) = unspec (lit);
		substr (instr (1), 19, 18) = lda || dmod (fromsw);

		if tlen = 1
		then if adjustsw ^= 0
		     then substr (instr (1), 1, 18) = (9)"0"b || unspec (lit);
		     else ;
		else if adjustsw ^= 0
		then do;

			instr (2) = "000000000000001001"b || rs (fromsw);
			ic = 3;
		     end;

		instr (ic) = treg || substr (unspec (twdoff), 22, 15) || stba_ || tagarray (tmodoff, tlen);

		if fromsw = 1 & adjustsw = 1 & tlen = 2
		then do;

			ic = ic + 1;
			temp = twdoff + 1;
			instr (ic) = treg || substr (unspec (temp), 22, 15) || stbq_ || "100000"b;

		     end;
	     end;
	else if tmodoff = 0 & tlen = 4 & lit = ""
	then do;

		ic = 1;
		instr (1) = treg || substr (unspec (twdoff), 22, 15) || stz_;
	     end;
	else do;

		if tlen = litlen & tlen + tmodoff <= max_noshift_chars (tal)
		then do;

			temp = tlen + tmodoff;
			if temp > 8
			then do;
				sal = tal;
				boundary = 2 + tal;
			     end;
			else if temp > 4
			then do;
				sal = 0;
				boundary = 2;
			     end;
			else do;
				sal = 1;
				boundary = 1;
			     end;

			call cobol_pool$search_op_byte (lit, boundary, litoff, regsw, smodoff);

			if regsw = 0
			then litoff = cobol_$text_wd_off + litoff;
			else do;
				ssreg = "000"b;
				swdoff = litoff;	/*-06/17/76-*/
			     end;

			call move_aligned;

		     end;
		else do;

			call cobol_pool$search_op (lit, 4, litoff, regsw);

			if regsw = 0
			then do;			/* IC modification */

				temp = mod (litoff, 4);
				litoff = -(cobol_$text_wd_off + divide (litoff, 4, 17, 0));
				instr (1) = mlr_ic_to_reg;
				instr (2) =
				     substr (unspec (litoff), 19, 18) || substr (unspec (temp), 35, 2)
				     || substr (unspec (litlen), 21, 16);
			     end;
			else do;			/* PR0 Register modification */
				instr (1) = mlr_reg_to_reg;
				instr (2) =
				     "000"b || substr (unspec (litoff), 20, 17)
				     || substr (unspec (litlen), 21, 16);
			     end;
			instr (3) =
			     treg || substr (unspec (twdoff), 22, 15) || substr (unspec (tmodoff), 35, 2)
			     || substr (unspec (tlen), 21, 16);
			ic = 3;

		     end;
	     end;

	call cobol_reloc$cobol_emit (addr (instr), null (), ic);

	return;


/*************************************/
move:
     entry (treg, toff, tlen, sreg, soff, slen);

dcl	sreg		bit (3) aligned;		/* register for sending field */
dcl	soff		fixed bin;		/* char offset from sreg of sending field */
dcl	slen		fixed bin;		/* char length of sending field */

start_move:
	ic = 0;
	swdoff = divide (soff, 4, 17, 0);
	sal = mod (swdoff, 2);
	smodoff = mod (soff, 4);
	twdoff = divide (toff, 4, 17, 0);
	tal = mod (twdoff, 2);
	tmodoff = mod (toff, 4);

	if slen > tlen
	then slen = tlen;				/* take care of truncation */
						/*-05/15/76-*/

	give_up = "1"b;				/* be pessimistic */

	if tlen = slen
	then do;

		regsw = 1;
		ssreg = sreg;
		temp = tal + sal;			/* 0=both even word aligned;2=both odd word aligned */

		if tmodoff = smodoff
		then do;				/* no shift required */

			if tlen + tmodoff <= max_noshift_chars (temp)
			then do;
				give_up = "0"b;
				call move_aligned;

			     end;

		     end;
		else if tlen + max (tmodoff, smodoff) <= max_shift_chars (temp)
		then do;

			give_up = "0"b;
			curlen = tlen;

			do while (curlen > 0);
			     temp_off = max (smodoff, tmodoff);
			     temp = 8 - temp_off;
			     if sal ^= 0
			     then if curlen > temp
				then temp = 4 - temp_off;
			     ttlen = min (temp, curlen);
			     call move_unaligned;
			     temp = smodoff + ttlen;
			     swdoff = swdoff + divide (temp, 4, 17, 0);
			     sal = mod (swdoff, 2);
			     smodoff = mod (temp, 4);
			     temp = tmodoff + ttlen;
			     twdoff = twdoff + divide (temp, 4, 17, 0);
			     tal = mod (twdoff, 2);
			     tmodoff = mod (temp, 4);
			     curlen = curlen - ttlen;

			end;
		     end;
	     end;

	if give_up
	then do;					/* oh well */
		instr (1) = mlr_reg_to_reg;
		instr (2) =
		     sreg || substr (unspec (swdoff), 22, 15) || substr (unspec (smodoff), 35, 2)
		     || substr (unspec (slen), 21, 16);
		instr (3) =
		     treg || substr (unspec (twdoff), 22, 15) || substr (unspec (tmodoff), 35, 2)
		     || substr (unspec (tlen), 21, 16);
		ic = 3;
	     end;

	call cobol_reloc$cobol_emit (addr (instr), null (), ic);

	return;


/*************************************/
fixed_add:
     entry (treg, toff, tlen, sreg, soff);

	if tlen ^= 0
	then do;					/* tlen contains value */
		temp = abs (tlen);
		instr (1) = substr (unspec (temp), 19, 18) || lda || dmod (1);
	     end;
	else do;					/* value to be added is at sreg|soff */
		temp = soff * 4;
		instr (1) = sreg || substr (unspec (temp), 22, 15) || ld_ (0);
	     end;

	if tlen < 0
	then instr (2) = treg || substr (unspec (toff), 20, 15) || ssa_;
	else instr (2) = treg || substr (unspec (toff), 20, 15) || asa_;

	call cobol_reloc$cobol_emit (addr (instr), null (), 2);

	return;


/*************************************/
dec_add:
     entry (treg, toff, tlen, lit);

	litlen = length (lit);

	call cobol_pool (lit, 2, litoff);

	litoff = -(cobol_$text_wd_off + litoff);
	instr (1) = ad2d_ic_to_reg;
	instr (2) = substr (unspec (litoff), 19, 18) || "000011000000"b || substr (unspec (litlen), 31, 6);
	instr (3) = treg || substr (unspec (toff), 20, 17) || "0011000000"b || substr (unspec (tlen), 31, 6);

	call cobol_reloc$cobol_emit (addr (instr), null (), 3);

	return;


/*************************************/
dec_to_bin:
     entry (treg, toff, tlen, sreg, soff, slen);

	instr (1) = dtb_instr;
	instr (2) = sreg || substr (unspec (soff), 20, 17) || "0011000000"b || substr (unspec (slen), 31, 6);
	instr (3) = treg || substr (unspec (toff), 20, 27) || (10)"0"b || substr (unspec (tlen), 31, 6);

	call cobol_reloc$cobol_emit (addr (instr), null (), 3);

	return;


/*************************************/
bin_to_dec:
     entry (treg, toff, tlen, sreg, soff, slen);

	instr (1) = btd_instr;
	instr (2) = sreg || substr (unspec (soff), 20, 17) || (10)"0"b || substr (unspec (slen), 31, 6);
	instr (3) = treg || substr (unspec (toff), 20, 17) || "0011000000"b || substr (unspec (tlen), 31, 6);

	call cobol_reloc$cobol_emit (addr (instr), null (), 3);

	return;


/*************************************/
t9dec_to_bin:
     entry (breg, boff, dptr);

dcl	breg		bit (3) aligned;		/* register of the binary 4 byte data */
dcl	boff		fixed bin aligned;		/* character offset of the binary data */
dcl	dptr		ptr;			/* pts to type 9 token for unsigned decimal data */

/*	instr(1) = dtb_instr;
/*	instr(2) = (20)"0"b||"0011000000"b||(6)"0"b;	/* to be filled by cobol_addr */
/*	instr(3) = breg||substr(unspec(boff),20,17)||"0000000000000100"b;
/*	dtb_struct.operand1.token_ptr = dptr;
/*	instr_ptr = addr(instr);
/*	call cobol_addr(addr(dtb_struct),instr_ptr,null());
/*	call cobol_reloc$cobol_emit(instr_ptr,null(),3);
*/
	if init_count ^= cobol_$compile_count
	then do;
		move_token_ptr (4) = addr (type19);
		call cobol_make_type9$long_bin (addr (type9), 0, 0);
						/* segno and offset filled in later */
		init_count = cobol_$compile_count;
	     end;

	type9.seg = 5000 + fixed (breg, 3);
	type9.off = boff;
	move_token_ptr (2) = dptr;
	move_token_ptr (3) = addr (type9);

	call cobol_move_gen (addr (move_tokens));

	return;


/*************************************/
bin_to_t9dec:
     entry (breg, boff, dptr);

/*	instr(1) = btd_instr;
/*	instr(2) = breg||substr(unspec(boff),20,27)||"000100"b;
/*	instr(3) = (20)"0"b||"0011000000"b||(6)"0"b;	/* to be filled by cobol_addr */
/*	btd_struct.operand2.token_ptr = dptr;
/*	instr_ptr = addr(instr);
/*	call cobol_addr(addr(btd_struct),instr_ptr,null());
/*	call cobol_reloc$cobol_emit(instr_ptr,null(),3);
*/

	if init_count ^= cobol_$compile_count
	then do;
		move_token_ptr (4) = addr (type19);

		call cobol_make_type9$long_bin (addr (type9), 0, 0);
						/* segno and offset filled in later */

		init_count = cobol_$compile_count;
	     end;

	type9.seg = 5000 + fixed (breg, 3);
	type9.off = boff;
	move_token_ptr (2) = addr (type9);
	move_token_ptr (3) = dptr;

	call cobol_move_gen (addr (move_tokens));

	return;


/*************************************/
bypass_error:
     entry (tra_tag, def_tag);

dcl	tra_tag		fixed bin;		/* tagno which to transfer to */
dcl	def_tag		fixed bin;		/* tagno which to define */

	call cobol_reloc$cobol_emit (addr (tra), null (), 1);

	call cobol_define_tag (def_tag);

	call cobol_make_tagref (tra_tag, cobol_$text_wd_off - 1, null ());

	return;


/*************************************/
bypass_readkey:
     entry (tra_tag);

	call cobol_reloc$cobol_emit (addr (bypass_readkey_instr), null (), 4);

	call cobol_make_tagref (tra_tag, cobol_$text_wd_off - 1, null ());

	return;


/*************************************/
bypass_seqerror:
     entry (tra_tag);

	call cobol_reloc$cobol_emit (addr (bypass_seqerror_instr), null (), 2);

	call cobol_make_tagref (tra_tag, cobol_$text_wd_off - 1, null ());

	return;


/*************************************/
bypass_mode_error:
     entry (tra_tag, mode_bits);

dcl	mode_bits		bit (2) aligned;

	substr (bypass_mode_error_instr (3), 13, 2) = mode_bits;

	call cobol_reloc$cobol_emit (addr (bypass_mode_error_instr), null (), 4);

	call cobol_make_tagref (tra_tag, cobol_$text_wd_off - 1, null ());

	return;


/*************************************/
compare_word:
     entry (tra_tag, creg1, coff1, creg2, coff2, eqne);

dcl	creg1		bit (3) aligned;
dcl	coff1		fixed bin;
dcl	creg2		bit (3) aligned;
dcl	coff2		fixed bin;
dcl	eqne		fixed bin;		/* 0 - tra on equal; 1 - tra on ^equal */

	instr (1) = creg1 || substr (unspec (coff1), 20, 15) || lda_;
	instr (2) = creg2 || substr (unspec (coff2), 20, 15) || cmpa_;
	instr (3) = tze_tnz (eqne);
	call cobol_reloc$cobol_emit (addr (instr), null (), 3);

	call cobol_make_tagref (tra_tag, cobol_$text_wd_off - 1, null ());

	return;


/****************************************/
compare_zero_word:
     entry (tra_tag, creg1, coff1, creg2, coff2, eqne);

/* creg2 and coff2 are not used - compare made to a single word equal to zero */

	instr (1) = creg1 || substr (unspec (coff1), 20, 15) || szn_;
	instr (2) = tze_tnz (eqne);

	call cobol_reloc$cobol_emit (addr (instr), null (), 2);

	call cobol_make_tagref (tra_tag, cobol_$text_wd_off - 1, null ());

	return;


/*************************************/
compare_varying:
     entry (tra_tag, creg1, coff1, creg2, coff2, eqne);

	temp = divide (coff1, 4, 17, 0) - 1;
	instr (1) = creg1 || substr (unspec (temp), 22, 15) || lda_;
	temp = divide (coff2, 4, 17, 0) - 1;
	instr (2) = creg2 || substr (unspec (temp), 22, 15) || ldq_;
	instr (3) = cmpc_instr;
	instr (4) = creg1 || substr (unspec (coff1), 20, 17) || "0000000000000101"b;
	instr (5) = creg2 || substr (unspec (coff2), 20, 17) || "0000000000000110"b;
	instr (6) = tze_tnz (eqne);

	call cobol_reloc$cobol_emit (addr (instr), null (), 6);

	call cobol_make_tagref (tra_tag, cobol_$text_wd_off - 1, null ());

	return;


/*************************************/
compare_key:
     entry (tra_tag, sptr);

dcl	sptr		ptr;			/* ptr to type9 token for alpha-numeric data */

	instr (1) = "001000000000000110"b || lda_;
	instr_ptr = addr (instr);

	call cobol_reloc$cobol_emit (instr_ptr, null (), 1);

	instr (1) = cmpc_instr;
	instr (2) = ""b;
	instr (3) = "001000000000000111000000000000000101"b;
	instr (4) = tze_tnz (0);
	dtb_struct.operand1.token_ptr = sptr;

	call cobol_addr (addr (dtb_struct), instr_ptr, null ());

	substr (instr (1), 1, 9) = "001111111"b;	/* pad character */

	call cobol_reloc$cobol_emit (instr_ptr, null (), 4);

	call cobol_make_tagref (tra_tag, cobol_$text_wd_off - 1, null ());

	return;


/*************************************/
move_from_varlen:
     entry (lreg, loff, dptr, sreg, soff);

dcl	lreg		bit (3) aligned;		/* register for length */
dcl	loff		fixed bin;		/* wd offset for length (fixed bin) */

	instr (1) = lreg || substr (unspec (loff), 20, 15) || lda_;
	instr (2) = "000000000000000001"b || sba_dlmod;
	instr (3) = mlr_reg_to_reg;
	instr (4) = sreg || substr (unspec (soff), 20, 17) || "0000000000000101"b;
	instr (5) = ""b;
	btd_struct.operand2.token_ptr = dptr;

	call cobol_addr (addr (btd_struct), addr (instr (3)), null ());

	substr (instr (3), 1, 9) = "000100000"b;	/* blank fill */
	substr (instr (3), 31, 1) = "1"b;		/* length in a reg */

	call cobol_reloc$cobol_emit (addr (instr), null (), 5);

	return;

/****************************************/

/*[3.0-1]*/

file_desc:
     entry (desc_off);				/*[3.0-1]*/
						/* epp7 OFFSET,ic,du */

/*[3.0-1]*/
	descoff = -(cobol_$text_wd_off + desc_off);

/*[3.0-1]*/
	ic = 1;					/*[3.0-1]*/
	instr (1) = substr (unspec (descoff), 19, 18) || epp7_ic_du;

/*[3.0-1]*/
	call cobol_reloc$cobol_emit (addr (instr), null (), ic);

/*[3.0-1]*/
	return;

set_fsb_loc:
     entry;

/*[4.4-1]*/
	ndx = "110"b;				/*[4.4-1]*/
	addrs = "000000001010110"b;

/*[4.4-1]*/
	call emit_instr (op_codes.spri1);		/* spri1 pr6|86 */

/*[4.4-1]*/
	return;

key_num:
     entry (keynum);				/* epp2 KEY_NUMBER,du */

/*[3.0-1]*/
	ic = 1;					/*[3.0-1]*/
	instr (1) = substr (unspec (keynum), 19, 18) || lda_dl;

/*[3.0-1]*/
	call cobol_reloc$cobol_emit (addr (instr), null (), ic);

/*[3.0-1]*/
	return;

fsb_key_loc:
     entry (offset);

/*[4.4-1]*/
	ndx = "001"b;				/*[4.4-1]*/
	addrs = substr (unspec (offset), 22, 15);

/*[4.4-1]*/
	call emit_instr (op_codes.epp1);		/* epp1 pr1|offset */

/*[4.4-1]*/
	return;


key_loc:
     entry (mode, offset);

/*[3.1-1]*/
	if mode = 1				/*[3.0-1]*/
	then do;
		ndx = "110"b;			/* epp1 p6|offset */
						/*[3.0-1]*/
		addrs = substr (unspec (offset), 22, 15);
						/*[3.0-1]*/
	     end;					/*[3.0-1]*/
	else do;
		ndx = "001"b;			/* epp1 pr1|6 */
						/*[3.0-1]*/
		addrs = "000000000000110"b;		/*[3.0-1]*/
	     end;

/*[4.4-1]*/
	call emit_instr (op_codes.epp1);

/*[4.4-1]*/
	return;

emit_instr:
     proc (op);

/*[4.4-1]*/
declare	op		bit (18);

/*[3.0-1]*/
	ic = 1;					/*[3.0-1]*/
	instr (1) = ndx || addrs || op;		/*[3.0-1]*/
	call cobol_reloc$cobol_emit (addr (instr), null (), ic);

/*[4.4-1]*/
     end;


/*************************************/
/* INTERNAL PROCEDURES */
/*************************************/
move_aligned:
     proc;					/* move x words where both operands start at same byte offset */

	adj = 0;

	if tmodoff > 0
	then do;					/* not word aligned */
		talsw = "0"b;
		temp = 8 - tmodoff;

		if tal ^= 0
		then if tlen > temp
		     then if tlen + tmodoff >= 8
			then do;
				temp = 4 - tmodoff;
				talsw = "1"b;
			     end;

		ttlen = min (temp, tlen);

		call move_unaligned;

		if talsw
		then do;
			tal = 0;
			if sal = 0
			then sal = 1;
			else sal = 0;
		     end;


		adj = adj + ttlen;
	     end;

	if tlen - adj >= 4 & tal ^= 0
	then do;					/* get started on an even word boundary */
		off = divide (adj + 3, 4, 17, 0);
		tal = 0;

		if sal = 0
		then sal = 1;
		else sal = 0;

		ic = ic + 1;

		if regsw = 0
		then do;
			temp = -litoff + off - ic + 1;
			instr (ic) = substr (unspec (temp), 19, 18) || lda_icmod;
		     end;

		else do;
			temp = swdoff + off;
			instr (ic) = ssreg || substr (unspec (temp), 22, 15) || lda_;
		     end;

		ic = ic + 1;
		temp = twdoff + off;
		instr (ic) = treg || substr (unspec (temp), 22, 15) || sta_;
		adj = adj + 4;
	     end;

	do i = 0 to tlen - adj - 8 by 8;
	     ic = ic + 1;
	     off = divide (i + tmodoff + adj, 4, 17, 0);

	     if regsw = 0
	     then do;
		     temp = -litoff + off - ic + 1;
		     substr (instr (ic), 1, 18) = substr (unspec (temp), 19, 18);

		     if sal = 0
		     then substr (instr (ic), 19, 18) = ldaq_icmod;
		     else do;			/* shouldn't happen (in the current implementation) */
			     substr (instr (ic), 19, 18) = lda_icmod;
			     ic = ic + 1;
			     instr (ic) = substr (unspec (temp), 19, 18) || ldq_icmod;
			end;
		end;
	     else do;
		     temp = swdoff + off;

		     if sal = 0
		     then instr (ic) = ssreg || substr (unspec (temp), 22, 15) || ldaq_;
		     else do;
			     instr (ic) = ssreg || substr (unspec (temp), 22, 15) || lda_;
			     ic = ic + 1;
			     temp = temp + 1;
			     instr (ic) = ssreg || substr (unspec (temp), 22, 15) || ldq_;
			end;
		end;

	     ic = ic + 1;
	     temp = twdoff + off;

	     if tal = 0
	     then instr (ic) = treg || substr (unspec (temp), 22, 15) || staq_;
	     else do;
		     instr (ic) = treg || substr (unspec (temp), 22, 15) || sta_;
		     ic = ic + 1;
		     temp = temp + 1;
		     instr (ic) = treg || substr (unspec (temp), 22, 15) || stq_;
		end;
	end;

	off = divide (tlen - adj, 8, 17, 0) * 2 + divide (adj + 3, 4, 17, 0);
	modlen = mod (tlen - adj, 8);

	if modlen > 0
	then do;
		ic = ic + 1;

		if modlen > 4
		then lensw = 1;
		else lensw = 0;

		if regsw = 0
		then do;
			temp = -litoff + off - ic + 1;
			substr (instr (ic), 1, 18) = substr (unspec (temp), 19, 18);

			if sal = 0
			then substr (instr (ic), 19, 18) = ld_icmod (lensw);
			else do;
				substr (instr (ic), 19, 18) = lda_icmod;
				if lensw ^= 0
				then do;
					ic = ic + 1;
					instr (ic) = substr (unspec (temp), 19, 18) || ldq_icmod;
				     end;
			     end;
		     end;
		else do;
			temp = swdoff + off;
			instr (ic) = ssreg || substr (unspec (temp), 22, 15);

			if sal = 0
			then substr (instr (ic), 19, 18) = ld_ (lensw);
			else do;
				substr (instr (ic), 19, 18) = lda_;

				if lensw ^= 0
				then do;
					ic = ic + 1;
					temp = temp + 1;
					instr (ic) = ssreg || substr (unspec (temp), 22, 15) || ldq_;
				     end;
			     end;
		     end;

		ic = ic + 1;
		temp = twdoff + off;
		instr (ic) = treg || substr (unspec (temp), 22, 15);

		if modlen = 4
		then substr (instr (ic), 19, 18) = sta_;
		else do;

			if modlen < 4
			then substr (instr (ic), 19, 18) = stba_ || tagarray (0, modlen);
			else do;
				substr (instr (ic), 19, 18) = sta_;
				ic = ic + 1;
				temp = temp + 1;
				instr (ic) =
				     treg || substr (unspec (temp), 22, 15) || stbq_ || tagarray (0, modlen - 4);
			     end;
		     end;
	     end;
     end move_aligned;


move_unaligned:
     proc;					/* move up to one word where operands do not start at same byte offset */

	if ttlen <= 4 - smodoff
	then slensw = 0;				/* fix bug */
						/*-05/15/76-*/
	else slensw = 1;

	if ttlen <= 4 - tmodoff
	then tlensw = 0;
	else tlensw = 1;

	if slensw = 1 | tlensw = 1
	then lensw = 1;
	else lensw = 0;

	ic = ic + 1;

	if regsw = 0
	then do;
		temp = -litoff - ic + 1;
		substr (instr (ic), 1, 18) = substr (unspec (temp), 19, 18);

		if sal = 0
		then substr (instr (ic), 19, 18) = ld_icmod (slensw);
		else do;
			substr (instr (ic), 19, 18) = lda_icmod;
			if slensw ^= 0
			then do;
				ic = ic + 1;
				instr (ic) = substr (unspec (temp), 19, 18) || ldq_icmod;
			     end;
		     end;
	     end;
	else do;
		substr (instr (ic), 1, 18) = ssreg || substr (unspec (swdoff), 22, 15);

		if sal = 0
		then substr (instr (ic), 19, 18) = ld_ (slensw);
		else do;
			substr (instr (ic), 19, 18) = lda_;

			if slensw ^= 0
			then do;
				ic = ic + 1;
				temp = swdoff + 1;
				instr (ic) = ssreg || substr (unspec (temp), 22, 15) || ldq_;
			     end;
		     end;
	     end;
	dmodoff = tmodoff - smodoff;

	if dmodoff ^= 0
	then do;
		ic = ic + 1;
		if dmodoff > 0
		then do;
			temp = 9 * dmodoff;
			instr (ic) = substr (unspec (temp), 19, 18) || rs (lensw);
		     end;
		else do;
			temp = -9 * dmodoff;
			instr (ic) = substr (unspec (temp), 19, 18) || ls (lensw);
		     end;
	     end;
	ic = ic + 1;
	temp_tag = tagarray (tmodoff, ttlen);

	if temp_tag = ""b
	then temp_instr = sta_;
	else temp_instr = stba_;

	instr (ic) = treg || substr (unspec (twdoff), 22, 15) || temp_instr || temp_tag;

	if tlensw ^= 0
	then do;
		ic = ic + 1;
		i = ttlen + tmodoff - 4;
		temp = twdoff + 1;
		instr (ic) = treg || substr (unspec (temp), 22, 15);
		if i = 4
		then substr (instr (ic), 19, 18) = stq_;
		else substr (instr (ic), 19, 18) = stbq_ || tagarray (0, i);
	     end;

	return;
     end move_unaligned;


%include cobol_io_util_info;
%include cobol_io_util_data;
     end cobol_io_util;




		    cobol_iocall.pl1                05/24/89  1041.5rew 05/24/89  0830.8      142767



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_iocall.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 02/22/77 by Bob Chang to fix the bug for reloc bit.	*/
/* Modified on 01/31/77 by Bob Chang to implement profile option.	*/
/* Modified since Version 2.0.	*/

/* format: style3 */
cobol_iocall:
     proc (argptr, descptr);

dcl	argptr		ptr;
dcl	descptr		ptr;

/* fixup directive for link, used when profile options is specified.	*/
dcl	1 fixup_directive	aligned static,
	  2 operation	bit (1) unal init ("0"b),
	  2 type		bit (4) unal init ("1111"b),
	  2 reserved	bit (9) unal init ("000000000"b),
	  2 location	unal,
	    3 half	bit (1) unal init ("0"b),
	    3 base	bit (3) unal init ("001"b),
	    3 offset	fixed bin unal,
	  2 tag_number	fixed bin aligned;
dcl	1 args		based (argptr),
	  2 entryno	fixed bin,
	  2 arglist_off	fixed bin,
	  2 stacktemp_off	fixed bin,
	  2 n		fixed bin,
	  2 arg		(0 refer (args.n)),
	    3 pt		ptr,
	    3 type	fixed bin,
	    3 seg		fixed bin,
	    3 off		fixed bin,
	    3 value	bit (18) unaligned,
	    3 indirect	bit (1) unaligned,
	    3 overlay	bit (1) unaligned,
	    3 repeat_nogen	bit (1) unaligned,
	    3 reg_sw	bit (1) unaligned,
	    3 reg		bit (3) unaligned;
dcl	desc		(20) bit (36) based (descptr);

dcl	type9		char (144) static aligned;	/* enough to hold 36 words */
dcl	1 data_name	based,
	  2 size		fixed bin (15),
	  2 line		fixed bin (15),
	  2 column	fixed bin (15),
	  2 type		fixed bin (15);

dcl	1 addr_struct	static,
	  2 type		fixed bin init (2),
	  2 operand_no	fixed bin init (1),
	  2 lock		fixed bin init (0),
	  2 operand,
	    3 token_ptr	ptr,
	    3 send_receive	fixed bin init (0),
	    3 ic_mod	fixed bin,
	    3 size_sw	fixed bin init (1);

dcl	1 basic_struct	based,
	  2 type		fixed bin,
	  2 count		fixed bin,
	  2 lock		fixed bin,
	  2 seg		fixed bin,
	  2 offset	fixed bin,
	  2 sr		fixed bin;

dcl	evad		(16) bit (18) static init ("010000000000010110"b,
						/* (1)  detach_iocb */
			"010000000000011010"b,	/* (2)  open */
			"010000000000011110"b,	/* (3)  close */
			"010000000000100010"b,	/* (4)  get_line */
			"010000000000100110"b,	/* (5)  get_chars */
			"010000000000101010"b,	/* (6)  put_chars */
			"010000000000101110"b,	/* (7)  modes */
			"010000000000110010"b,	/* (8)  position */
			"010000000000110110"b,	/* (9)  control */
			"010000000000111010"b,	/* (10) read_record */
			"010000000000111110"b,	/* (11) write_record */
			"010000000001000010"b,	/* (12) rewrite_record */
			"010000000001000110"b,	/* (13) delete_record */
			"010000000001001010"b,	/* (14) seek_key */
			"010000000001001110"b,	/* (15) read_key */
			"010000000001010010"b);	/* (16) read_length */

/* THE FOLLOWING DECLARATION TO TEMPORARILY CALL iox_$name */
dcl	ename		(16) char (20) static
			init ("iox_$detach_iocb", "iox_$open", "iox_$close", "iox_$get_line", "iox_$get_chars",
			"iox_$put_chars", "iox_$modes", "iox_$position", "iox_$control", "iox_$read_record",
			"iox_$write_record", "iox_$rewrite_record", "iox_$delete_record", "iox_$seek_key",
			"iox_$read_key", "iox_$read_length");

/* Change to interface the cobol operators_ */
/*-04/05/76-*/
dcl	entry_op		(4) bit (18) static
			init ("000000000000000000"b, "000000000000000001"b, "000000000000000101"b,
			"000000000000000110"b);

dcl	icmod		bit (6) static init ("000100"b);
dcl	indmod		bit (6) static init ("010000"b);
dcl	dlmod		bit (6) static init ("000111"b);
dcl	dmod		(2) bit (6) static init ("000111"b, "000011"b);

dcl	stz		bit (12) static init ("100101000001"b);
dcl	fld_		bit (12) static init ("100011001000"b);
dcl	tsx0		bit (12) static init ("111000000001"b);
dcl	eax1		bit (12) static init ("110010001001"b);
dcl	epp2		bit (12) static init ("011101010001"b);
dcl	epp2_		bit (12) static init ("011101010000"b);
dcl	spri2		bit (12) static init ("010101010001"b);
dcl	st		(2) bit (12) static init ("111101101001"b, "111101110001"b);
dcl	ld_		(2) bit (12) static init ("010011101000"b, "010011110000"b);
dcl	full_epp2		bit (36) static init ("000000000000000000011101010000000000"b);

dcl	instr		(8) bit (36) static aligned;
dcl	reloc		(12) bit (5) aligned static
			init ("00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b,
			"00000"b, "00000"b, "00000"b, "00000"b);

dcl	1 pr0_struct	static,
	  2 pr0		fixed bin init (0),
	  2 pointer_no	bit (3),
	  2 lock		fixed bin init (0),
	  2 switch	fixed bin init (1),
	  2 segno		fixed bin init (4000),
	  2 offset	fixed bin init (0),
	  2 reset		fixed bin;
dcl	1 pr2_struct	static,
	  2 pr2		fixed bin init (2),
	  2 pointer_no	bit (3),
	  2 lock		fixed bin init (0),
	  2 switch	fixed bin init (0),
	  2 segno		fixed bin,
	  2 offset	fixed bin,
	  2 reset		fixed bin;
dcl	1 pr4_struct	static,
	  2 pr4		fixed bin init (4),
	  2 pointer_no	bit (3),
	  2 lock		fixed bin init (0),
	  2 switch	fixed bin init (1),
	  2 segno		fixed bin init (3002),
	  2 offset	fixed bin init (0),
	  2 reset		fixed bin;

dcl	1 reg_struct	static,
	  2 either_a_or_q	fixed bin init (4),
	  2 reg_no	bit (4),
	  2 lock		fixed bin init (0),
	  2 already_there	fixed bin,
	  2 contains	fixed bin init (0),
	  2 null_ptr	ptr init (null ()),
	  2 fill		bit (18) unaligned init ((18)"0"b),
	  2 literal	bit (18) unaligned;

dcl	char4b		char (4) based;
dcl	linkstring	char (65);
dcl	varstring		char (65) varying based (arg.pt (1));

dcl	(i, j)		fixed bin;
dcl	k		fixed bin;
dcl	conoff		fixed bin;
dcl	aloff		fixed bin;
dcl	stoff		fixed bin;
dcl	a_or_q		fixed bin;
dcl	ic		fixed bin;
dcl	opno		fixed bin;
dcl	linkoff		fixed bin;
dcl	seg		fixed bin;
dcl	off		fixed bin;
dcl	utemp		fixed bin;

dcl	linksw		bit (1);
dcl	firsttime		bit (1) static init ("1"b);
dcl	loc		bit (18) aligned;
dcl	reg		bit (3) aligned;

dcl	instr_ptr		ptr static;
dcl	instr3_ptr	ptr static;
dcl	reloc_ptr		ptr static;
dcl	reloc5_ptr	ptr static;
dcl	pr0_struct_ptr	ptr static;
dcl	pr2_struct_ptr	ptr static;
dcl	pr4_struct_ptr	ptr static;
dcl	reg_struct_ptr	ptr static;
dcl	type9_ptr		ptr static;
dcl	addr_struct_ptr	static ptr;

dcl	cobol_reset_r$after_call
			entry;
dcl	cobol_pool	entry (char (*), fixed bin, fixed bin);
dcl	cobol_make_link$type_4
			entry (fixed bin, char (*));
dcl	cobol_make_fixup	entry (ptr);
dcl	cobol_alloc$stack	entry (fixed bin, fixed bin, fixed bin);
dcl	cobol_register$load entry (ptr);
dcl	cobol_emit	entry (ptr, ptr, fixed bin);
dcl	cobol_pointer_register$get
			entry (ptr);
dcl	cobol_pointer_register$call
			entry;
dcl	cobol_addr	entry (ptr, ptr, ptr);
dcl	cobol_make_type9$type2_3
			entry (ptr, ptr);
dcl	cobol_set_pr	entry (ptr, ptr);


/*************************************/
start:
	if firsttime
	then do;
		instr_ptr = addr (instr);
		instr3_ptr = addr (instr (3));
		reloc_ptr = addr (reloc);
		reloc5_ptr = addr (reloc (5));
		pr0_struct_ptr = addr (pr0_struct);
		pr2_struct_ptr = addr (pr2_struct);
		pr4_struct_ptr = addr (pr4_struct);
		reg_struct_ptr = addr (reg_struct);
		type9_ptr = addr (type9);
		addr_struct_ptr = addr (addr_struct);
		firsttime = "0"b;
	     end;

	if args.entryno = 0
	then k = 1;
	else k = 0;				/* 0=iocall; 1=other */
	if args.arglist_off <= 0
	then do;
		i = 8 * (args.n + 1 - k);
		if descptr ^= null ()
		then i = 2 * i;
		call cobol_alloc$stack (i, 2, aloff);
	     end;
	else aloff = args.arglist_off;
	call cobol_pointer_register$get (pr2_struct_ptr);
	stoff = args.stacktemp_off;
	do j = 1 to 11 by 2;
	     reloc (j) = "00000"b;
	end;
	ic = 1;

	if args.n > k
	then do i = 2 to args.n;			/* set up argument list */
		if arg.type (i) = 0
		then do;				/* arg.pt points to basic structure */
			instr (1) = full_epp2;
			call cobol_addr (arg.pt (i), instr_ptr, reloc_ptr);
			call cobol_pointer_register$get (pr2_struct_ptr);
			ic = 2;
		     end;
		else if arg.type (i) < 4
		then do;				/* direct lower (1) or upper (2) in in arg.value(i) */
			if arg.reg_sw (i)
			then reg = arg.reg (i);
			else reg = "110"b;		/* use stack by default */
			if arg.seg (i) = 0
			then do;
				loc = reg || substr (unspec (stoff), 22, 15);
				if arg.overlay (i)
				then arg.seg (i) = stoff;
				stoff = stoff + 1;
			     end;
			else loc = reg || substr (unspec (arg.seg (i)), 22, 15);
			if arg.type (i) < 3
			then do;
				if arg.value (i) = (18)"0"b
				then instr (1) = loc || stz;
				else do;
					reg_struct.literal = arg.value (i);
					call cobol_register$load (reg_struct_ptr);
					a_or_q = fixed (reg_struct.reg_no, 4);
					if reg_struct.already_there = 0
					then do;
						instr (1) =
						     arg.value (i) || ld_ (a_or_q) || dmod (arg.type (i));
						ic = ic + 1;
					     end;
					instr (ic) = loc || st (a_or_q);
				     end;
				ic = ic + 1;
			     end;
			instr (ic) = loc || epp2;
			ic = ic + 1;
		     end;
		else if arg.type (i) = 4
		then do;				/* link in seg|off */
			call cobol_pointer_register$get (pr4_struct_ptr);
			instr (1) = "100"b || substr (unspec (arg.seg (i)), 22, 15) || epp2 || indmod;
			reloc (1) = "10100"b;
			if fixed_common.options.profile
			then do;
				fixup_directive.location.offset = cobol_$text_wd_off;
				call cobol_make_fixup (addr (fixup_directive));
			     end;
			if arg.off (i) ^= 0
			then do;
				instr (2) = "010"b || substr (unspec (arg.off (i)), 22, 15) || epp2;
				ic = 3;
			     end;
			else ic = 2;
		     end;
		else if arg.type (i) = 5
		then do;				/* arg.pt points to a token */
			if arg.pt (i) -> data_name.type = 9
			then type9_ptr = arg.pt (i);
			else call cobol_make_type9$type2_3 (type9_ptr, arg.pt (i));
			if arg.indirect (i) | args.arglist_off <= 0 | ^arg.repeat_nogen (i)
			then call cobol_set_pr (pr2_struct_ptr, type9_ptr);
		     end;
		else if arg.type (i) = 6
		then do;
			call cobol_pool (substr (arg.pt (i) -> varstring, 1, length (arg.pt (i) -> varstring)), 1,
			     conoff);
			utemp = -(conoff + cobol_$text_wd_off);
			instr (1) = substr (unspec (utemp), 19, 18) || epp2_ || icmod;
			ic = 2;
		     end;

		if arg.indirect (i)
		then do;				/* not legal for type 4 */
			if arg.off (i) = 0
			then do;
				if mod (stoff, 2) = 1
				then stoff = stoff + 1;
				loc = "110"b || substr (unspec (stoff), 22, 15);
				if arg.overlay (i)
				then arg.off (i) = stoff;
				stoff = stoff + 2;
			     end;
			else loc = "110"b || substr (unspec (arg.off (i)), 22, 15);
			instr (ic) = loc || spri2;
			instr (ic + 1) = loc || epp2;
			ic = ic + 2;
		     end;

		utemp = aloff + 2 * (i - k);
		instr (ic) = "110"b || substr (unspec (utemp), 22, 15) || spri2;

		if args.arglist_off > 0
		then if arg.repeat_nogen (i)
		     then ic = ic - 2;		/* arglist already loaded */
		if ic > 0
		then call cobol_emit (instr_ptr, reloc_ptr, ic);
		do j = 1 to 11 by 2;
		     reloc (j) = "00000"b;
		end;
		ic = 1;
	     end;


	if descptr ^= null
	then do;
		ic = 1;
		j = aloff + 2 * (args.n + 1 - 2 * k);
		do i = k + 1 to args.n;
		     call cobol_pool (addr (desc (i)) -> char4b, 1, off);
		     utemp = -cobol_$text_wd_off - off - ic + 1;
		     instr (ic) = substr (unspec (utemp), 19, 18) || epp2_ || icmod;
						/* THE FOLLOWING LINE (FOR PLACEMENT OF ARGUMENT DESCRIPTORS):
		utemp = j+2*(i-k);
   IS TEMPORARILY CHANGED (TO NEVER ALLOW FOR THE "OPTIONAL POINTER" FOR ENTRY VARIABLE CALLS) BY: */
		     utemp = j + 2 * i - 2;		/*-04/02/76-*/
		     instr (ic + 1) = "110"b || substr (unspec (utemp), 22, 15) || spri2;
		     ic = ic + 2;
		end;
		call cobol_emit (instr_ptr, null (), ic - 1);
	     end;


	call cobol_pointer_register$call;
	instr (1) = "110"b || substr (unspec (aloff), 22, 15) || eax1;
	utemp = args.n - k;
	instr (2) = substr (unspec (utemp), 30, 7) || (11)"0"b || fld_ || dlmod;

	if k = 1
	then do;					/* non-io call */
		if arg.type (1) = 6
		then call cobol_make_link$type_4 (linkoff, substr (varstring, 1, length (varstring)));
		else linkoff = arg.seg (1);
		if fixed_common.options.profile
		then do;
			fixup_directive.location.offset = cobol_$text_wd_off + 2;
			call cobol_make_fixup (addr (fixup_directive));
		     end;
		instr (3) = "100"b || substr (unspec (linkoff), 22, 15) || epp2 || indmod;
		reloc (5) = "10100"b;
		ic = 4;
		opno = 3;
	     end;
	else do;					/* call to an iocb entry variable */
		linksw = "0"b;
		if arg.type (1) = 4
		then do;
			seg = arg.seg (1);
			off = arg.off (1);
			linksw = "1"b;
		     end;
		else if arg.pt (1) -> basic_struct.seg < 0
		then do;
			seg = -arg.pt (1) -> basic_struct.seg;
			off = -arg.pt (1) -> basic_struct.offset;
			linksw = "1"b;
		     end;
		if linksw
		then do;				/* external file - link to fsb */
						/* THE FOLLOWING LINES TEMPORARILY DELETED (TO CALL iox_$name) */
						/*		instr(3) = "100"b||substr(unspec(seg),22,15)||epp2||indmod;
/*		reloc(5) = "10100"b;
*/
			if args.arglist_off <= 0 | ^arg.repeat_nogen (1)
			then do;			/* THE FOLLOWING LINES TEMPORARILY ADDED (TO CALL iox_$name) */
						/**/
				instr (3) = "100"b || substr (unspec (seg), 22, 15) || epp2 || indmod;
						/**/
				reloc (5) = "10100"b;
				if fixed_common.options.profile
				then do;
					fixup_directive.location.offset = cobol_$text_wd_off + 2;
					call cobol_make_fixup (addr (fixup_directive));
				     end;
				utemp = aloff + 2;
				instr (4) = "110"b || substr (unspec (utemp), 22, 15) || spri2;
				ic = 5;
			     end;			/*		else ic = 4;
*/
						/**/
			else ic = 3;		/* THE FOLLOWING LINES TEMPORARILY DELETED (TO CALL iox_$name) */
						/*		instr(ic) = "010"b||substr(unspec(off),22,15)||epp2||indmod;
/*		ic = ic+1;
*/
		     end;
		else do;				/* internal file - fsb in cobol data segment */
			instr (3) = full_epp2;
			call cobol_addr (arg.pt (1), instr3_ptr, reloc5_ptr);
			if args.arglist_off <= 0 | ^arg.repeat_nogen (1)
			then do;
				utemp = aloff + 2;
				instr (4) = "110"b || substr (unspec (utemp), 22, 15) || spri2;
				ic = 5;
			     end;
			else ic = 4;
		     end;				/* THE FOLLOWING LINES (FOR TRANSFERRING THROUGH THE ENTRY VARIABLE) */
						/*	     instr(ic) = evad(args.entryno)||epp2;
/*	     opno = 1;
/* ARE TEMPORARILY REPLACED (TO CALL iox_$name) BY: */
						/**/
		call cobol_make_link$type_4 (linkoff, ename (args.entryno));
		if fixed_common.options.profile
		then do;
			fixup_directive.location.offset = cobol_$text_wd_off + ic - 1;
			call cobol_make_fixup (addr (fixup_directive));
		     end;				/**/
		instr (ic) = "100"b || substr (unspec (linkoff), 22, 15) || epp2 || indmod;
		j = i * 2 - 1;			/**/
		reloc (j) = "10100"b;		/**/
		opno = 3;
		ic = ic + 1;
	     end;

	if descptr = null ()
	then opno = opno + 1;
	instr (ic) = entry_op (opno) || tsx0;

	call cobol_emit (instr_ptr, reloc_ptr, ic);
	call cobol_reset_r$after_call;
	if args.arglist_off < 0
	then arglist_off = aloff;			/* special meaning (for reuse of stack space) */
	return;


/*************************************/

/*****	Declaration for builtin function	*****/

dcl	(substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index)
			builtin;

/*****	End of declaration for builtin function	*****/

%include cobol_;
%include cobol_fixed_common;
%include cobol_ext_;

     end cobol_iocall;




		    cobol_ioerror.pl1               05/24/89  1041.5rew 05/24/89  0830.8      173988



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_ioerror.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 01/31/77 by Bob Chang to implement profile option.	*/
/* Modified since Version 2.0.	*/
/* format: style3 */
cobol_ioerror:
     proc (ft_ptr, cobol_code, mcode_off, ioerror_ptr);

dcl	ft_ptr		ptr;			/* ptr to the file table */
dcl	cobol_code	fixed bin;		/* cobol error code */
dcl	mcode_off		fixed bin;		/* wd offset in stack of multics status code or 0 if none */
dcl	ioerror_ptr	ptr;			/* ptr to additional error information */

/* fixup directive for link, used when profile options is specified.	*/
dcl	1 fixup_directive	aligned static,
	  2 operation	bit (1) unal init ("0"b),
	  2 type		bit (4) unal init ("1111"b),
	  2 reserved	bit (9) unal init ("000000000"b),
	  2 location	unal,
	    3 half	bit (1) unal init ("0"b),
	    3 base	bit (3) unal init ("001"b),
	    3 offset	fixed bin unal,
	  2 tag_number	fixed bin aligned;
dcl	1 ioerror		based (ioerror_ptr),
	  2 lineno	fixed bin,
	  2 restartad	fixed bin,
	  2 forward_tag	fixed bin,
	  2 no_error_tag	fixed bin,
	  2 no_error_ptr	ptr,
	  2 unopen	fixed bin,
	  2 special_tag	fixed bin,
	  2 special_ptr	ptr,
	  2 error_ptr	ptr;
dcl	1 s		based,
	  2 n		fixed bin,
	  2 link		(0 refer (s.n)),
	    3 name	char (32),
	    3 status2	char (4) aligned,
	    3 status1	char (2);

dcl	1 mpout		static,
	  2 n		fixed bin init (0),
	  2 pt1		ptr,
	  2 pt2		ptr,
	  2 pt3		ptr,
	  2 pt4		ptr;
dcl	file_key_desc	char (40) based;
dcl	1 fkey_type9	static,
	  2 header	(4) fixed bin init (112, 0, 0, 9),
	  2 repl_ptr	(2) ptr init ((2) null ()),
	  2 fill1		bit (108) init (""b),
	  2 file_key_info,
	    3 fb		(6) fixed bin init (0, 0, 0, 0, 0, 0),
	    3 flags1	bit (36) init (""b),
	    3 flags2	bit (36) init (""b),
	    3 seg		fixed bin,
	    3 off		fixed bin,
	  2 fill2		(7) fixed bin init (0, 0, 0, 0, 0, 0, 0);
dcl	1 type1		static,
	  2 size		fixed bin init (28),
	  2 line		fixed bin,		/* line number */
	  2 column	fixed bin init (0),
	  2 type		fixed bin init (1),
	  2 key		fixed bin init (0),		/* verb number */
	  2 bits		bit (36) init ("1"b),
	  2 jump_index	fixed bin init (0);
dcl	1 type19		static,
	  2 size		fixed bin init (38),
	  2 line		fixed bin init (0),
	  2 column	fixed bin init (0),
	  2 type		fixed bin init (19),
	  2 verb		fixed bin init (0),		/* verb number */
	  2 e		fixed bin init (1),		/* for both perform and move */
	  2 h		fixed bin init (0),
	  2 i		fixed bin init (0),
	  2 j		fixed bin init (0),
	  2 a		bit (3) init (""b),
	  2 b		bit (1) init (""b),
	  2 c		bit (1) init (""b),
	  2 d		bit (2) init (""b),
	  2 f		bit (2) init (""b),
	  2 g		bit (2) init (""b),
	  2 k		bit (5) init (""b);
dcl	1 type3		static,
	  2 size		fixed bin init (28),
	  2 line		fixed bin init (0),
	  2 column	fixed bin init (0),
	  2 type		fixed bin init (3),
	  2 lit_type	bit (1) init ("0"b),	/* character string */
	  2 all_lit	bit (1) init ("0"b),	/* not ALL lit */
	  2 lit_size	fixed bin init (4),
	  2 string	char (4) init ("");
dcl	1 type7		static,
	  2 size		fixed bin init (52),
	  2 line		fixed bin init (0),
	  2 column	fixed bin init (0),
	  2 type		fixed bin init (7),
	  2 string_ptr	ptr init (null ()),
	  2 prev_rec	ptr init (null ()),
	  2 bits1		bit (4) init (""b),
	  2 section_name	bit (1) init ("1"b),
	  2 declarative_proc
			bit (1) init ("1"b),
	  2 bits2		bit (3) init (""b),
	  2 priority	char (2) init ("00"),
	  2 bits3		bit (9) init (""b),
	  2 section_num	fixed bin init (0),
	  2 proc_num	fixed bin init (0),
	  2 def_line	fixed bin init (0),
	  2 name_size	fixed bin init (0);

dcl	1 default_error_status
			static,
	  2 n		fixed bin init (1),
	  2 link,
	    3 name	char (32) init (""),
	    3 status2	char (4) init ("0030"),
	    3 status1	char (2) init ("30");
dcl	1 no_error_status	static,
	  2 n		fixed bin init (1),
	  2 link,
	    3 name	char (32) init (""),
	    3 status2	char (4) init ("0000"),
	    3 status1	char (2) init ("00");
dcl	tra_instr		bit (36) static init ("000000000000000000111001000000000100"b);
dcl	tze_instr		bit (36) static init ("000000000000000000110000000000000100"b);
dcl	tnz_instr		bit (36) static init ("000000000000000000110000001000000100"b);
dcl	cmpa_dl_instr	bit (36) static init ("000000000000000000001001101000000111"b);
dcl	cmpa_ind_instr	bit (36) static init ("100000000000000000001001101001010000"b);
dcl	lda_instr		bit (36) static init ("110000000000000000010011101001000000"b);
dcl	lda_mode		(2) bit (36) static
			init ("001000000000000010010011101001000000"b, "000000000000110000011111101000000111"b);

dcl	link_reloc	(2) bit (5) aligned static init ("10100"b, "00000"b);

dcl	preset_sw		bit (1);			/* used to comm between set_status and preset entry. */
dcl	restart_ic	fixed bin;
dcl	perform_ic	fixed bin;
dcl	tag		fixed bin;
dcl	next_instr_tag	fixed bin;
dcl	ntag		fixed bin;
dcl	pntag		fixed bin;
dcl	temp		fixed bin;
dcl	i		fixed bin;
dcl	mode_count	fixed bin;
dcl	off		fixed bin;
dcl	line_no		fixed bin;

dcl	fkey_ptr		ptr;

dcl	lda_sw		bit (1);
dcl	fsbptr_sw		bit (1);
dcl	perform_mode_sw	bit (1);
dcl	io_sw		bit (1);
dcl	s1set		bit (1);
dcl	s2set		bit (2);
dcl	s1default		char (2);
dcl	s1		char (2);

dcl	cobol_emit	entry (ptr, ptr, fixed bin);
dcl	cobol_read_rand	entry (fixed bin, char (5), ptr);
dcl	cobol_make_tagref	entry (fixed bin, fixed bin, ptr);
dcl	cobol_make_link$type_4
			entry (fixed bin, char (*));
dcl	cobol_make_fixup	entry (ptr);
dcl	cobol_define_tag	entry (fixed bin);		/* sub-generators */
dcl	cobol_process_error entry (fixed bin, fixed bin, fixed bin);
dcl	cobol_process_error$use
			entry (fixed bin, fixed bin, fixed bin);
dcl	cobol_perform_gen	entry (ptr);
dcl	cobol_move_gen	entry (ptr);
dcl	cobol_set_fsbptr	entry (ptr);


/*************************************/
start:
	preset_sw = "0"b;				/* set to zero unless preset entry is used. */
	s1default = "**";
	s1set, s2set = "0"b;
	line_no = ioerror.lineno;
	perform_ic = 0;
	next_instr_tag = cobol_$next_tag;
	cobol_$next_tag = cobol_$next_tag + 1;

	if mcode_off = 0
	then do;					/* an error exists - no checking necessary */
		if ioerror.special_ptr ^= null ()
		then do;				/* info assumed at ioerror.special_ptr->s.link(1) */
			call set_status (ioerror.special_ptr, 1);
			if ioerror.special_tag ^= 0
			then do;			/* in-line errror coding specified */
				call cobol_emit (addr (tra_instr), null (), 1);
				call cobol_make_tagref (ioerror.special_tag, cobol_$text_wd_off - 1, null ());
			     end;
			else call produce_error;
		     end;
		else if ioerror.error_ptr ^= null ()
		then do;				/* info assumed at ioerror.error_ptr->s.link(1) */
			call set_status (ioerror.error_ptr, 1);
			call produce_error;
		     end;
		else do;
			call set_status (addr (default_error_status), 1);
			call produce_error;
		     end;
	     end;

	else do;					/* must do error checking */
		if ioerror.unopen = 2
		then call set_status (addr (no_error_status), 1);
						/* a misnomer , means set 0 */
		substr (lda_instr, 4, 15) = substr (unspec (mcode_off), 22, 15);
		call cobol_emit (addr (lda_instr), null (), 1);
		if ioerror.no_error_tag ^= 0
		then tag = ioerror.no_error_tag;
		else tag = next_instr_tag;
		if ioerror.no_error_ptr = null ()
		then do;				/* only 0 signifies non-error code */
			call cobol_emit (addr (tze_instr), null (), 1);
			call cobol_make_tagref (tag, cobol_$text_wd_off - 1, null ());
		     end;
		else do i = 1 to ioerror.no_error_ptr -> s.n;
			if ioerror.no_error_ptr -> s.link.name (i) = ""
			then do;			/* indicates zero code */
				substr (cmpa_dl_instr, 1, 18) = ""b;
				call cobol_emit (addr (cmpa_dl_instr), null (), 1);
			     end;
			else do;			/* must compare code to error_table_ value */
				call cobol_make_link$type_4 (off,
				     "error_table_$" || ioerror.no_error_ptr -> s.link.name (i));
				if fixed_common.options.profile
				then do;
					fixup_directive.location.offset = cobol_$text_wd_off;
					call cobol_make_fixup (addr (fixup_directive));
				     end;
				substr (cmpa_ind_instr, 4, 15) = substr (unspec (off), 22, 15);
				call cobol_emit (addr (cmpa_ind_instr), addr (link_reloc (1)), 1);
			     end;
			s1set = ^file_table.file_status | ioerror.no_error_ptr -> s.link.status1 (i) = "00";
			s2set = ^file_table.extra_status | ioerror.no_error_ptr -> s.link.status2 (i) = "0000";
			if s1set & s2set
			then do;			/* status already set, so transfer out */
				call cobol_emit (addr (tze_instr), null (), 1);
				call cobol_make_tagref (tag, cobol_$text_wd_off - 1, null ());
			     end;
			else do;
				ntag = cobol_$next_tag;
				cobol_$next_tag = cobol_$next_tag + 1;
				call cobol_emit (addr (tnz_instr), null (), 1);
				call cobol_make_tagref (ntag, cobol_$text_wd_off - 1, null ());
				call set_status (ioerror.no_error_ptr, i);
				call cobol_emit (addr (tra_instr), null (), 1);
				call cobol_make_tagref (tag, cobol_$text_wd_off - 1, null ());
				call cobol_define_tag (ntag);
			     end;
		     end;
		s1set, s2set = "0"b;
		if file_table.file_status | ioerror.special_tag ^= 0
		then do;
			s2set = "1"b;		/* not really, just don't bother setting it now */
			call set_status (addr (default_error_status), 1);
			s2set = "0"b;
			s1default = default_error_status.link.status1;
			if ioerror.special_ptr ^= null ()
			then do i = 1 to ioerror.special_ptr -> s.n;
				ntag = cobol_$next_tag;
				cobol_$next_tag = cobol_$next_tag + 1;
				if ioerror.special_ptr -> s.link.name (i) = ""
				then do;
					substr (cmpa_dl_instr, 1, 18) = ""b;
					call cobol_emit (addr (cmpa_dl_instr), null (), 1);
				     end;
				else do;
					call cobol_make_link$type_4 (off,
					     "error_table_$" || ioerror.special_ptr -> s.link.name (i));
					if fixed_common.options.profile
					then do;
						fixup_directive.location.offset = cobol_$text_wd_off;
						call cobol_make_fixup (addr (fixup_directive));
					     end;
					substr (cmpa_ind_instr, 4, 15) = substr (unspec (off), 22, 15);
					call cobol_emit (addr (cmpa_ind_instr), addr (link_reloc (1)), 1);
				     end;
				call cobol_emit (addr (tnz_instr), null (), 1);
				call cobol_make_tagref (ntag, cobol_$text_wd_off - 1, null ());
				call set_status (ioerror.special_ptr, i);
				if ioerror.special_tag ^= 0
				then do;
					call cobol_emit (addr (tra_instr), null (), 1);
					call cobol_make_tagref (special_tag, cobol_$text_wd_off - 1, null ());
				     end;
				else call produce_error;
				call cobol_define_tag (ntag);
			     end;
			if file_table.extra_status
			then do;
				if ioerror.error_ptr ^= null ()
				then do i = 1 to ioerror.error_ptr -> s.n;
					ntag = cobol_$next_tag;
					cobol_$next_tag = cobol_$next_tag + 1;
					if ioerror.error_ptr -> s.link.name (i) ^= ""
					then do;	/* otherwise the default */
						call cobol_make_link$type_4 (off,
						     "error_table_$" || ioerror.error_ptr -> s.link.name (i));
						substr (cmpa_ind_instr, 4, 15) =
						     substr (unspec (off), 22, 15);
						if fixed_common.options.profile
						then do;
							fixup_directive.location.offset =
							     cobol_$text_wd_off;
							call cobol_make_fixup (addr (fixup_directive));
						     end;
						call cobol_emit (addr (cmpa_ind_instr), addr (link_reloc (1)),
						     1);
						call cobol_emit (addr (tnz_instr), null (), 1);
						call cobol_make_tagref (ntag, cobol_$text_wd_off - 1, null ())
						     ;
					     end;
					call set_status (ioerror.error_ptr, i);
					call produce_error;
					call cobol_define_tag (ntag);
				     end;
				else do;		/* shouldn't be necessary */
					call set_status (addr (default_error_status), 1);
					call produce_error;
				     end;
			     end;
			else if ioerror.special_ptr = null () | ioerror.special_tag ^= 0
			then do;
				call set_status (addr (default_error_status), 1);
				call produce_error; /* will have been done id special_ptr ^= null */
			     end;
		     end;
		else call produce_error;
	     end;

	call cobol_define_tag (next_instr_tag);
	return;


/*************************************/
/* SUBROUTINES */
/*************************************/

produce_error:
     proc;
	if perform_ic ^= 0
	then do;
		temp = perform_ic - cobol_$text_wd_off;
		substr (tra_instr, 1, 18) = substr (unspec (temp), 19, 18);
		call cobol_emit (addr (tra_instr), null (), 1);
	     end;
	else do;
		perform_ic = cobol_$text_wd_off;
		if file_table.error_exit ^= 0
		then call perform_use (file_table.error_exit);
						/* specific use proc */
		else do;
			mode_count = 0;
			if ^file_table.external
			then do;			/* can skip check for int file opened in only 1 mode */
				if file_table.open_ext
				then mode_count = mode_count + 1;
				if file_table.open_in
				then mode_count = mode_count + 1;
				if file_table.open_out
				then mode_count = mode_count + 1;
				if file_table.open_io
				then mode_count = mode_count + 1;
			     end;
			lda_sw, fsbptr_sw, perform_mode_sw, io_sw = "0"b;
			if fixed_common.extend_error_exit ^= 0 & ioerror.unopen ^= 1
			then if (^file_table.external & file_table.open_ext)
				| (file_table.external & file_table.organization = 1
				& (file_table.write | file_table.close | file_table.open_ext))
			     then call perform_mode (fixed_common.extend_error_exit, 0);
			if fixed_common.input_error_exit ^= 0 & ioerror.unopen ^= 1
			then if (^file_table.external & file_table.open_in)
				| (file_table.external
				& (file_table.read | file_table.start | file_table.close | file_table.open_in))
			     then call perform_mode (fixed_common.input_error_exit, 16);
			if fixed_common.output_error_exit ^= 0 & ioerror.unopen ^= 1
			then if (^file_table.external & file_table.open_out)
				| (file_table.external
				& (file_table.write | file_table.close | file_table.open_out))
			     then call perform_mode (fixed_common.output_error_exit, 48);
			if fixed_common.i_o_error_exit ^= 0 & ioerror.unopen ^= 1
			then if (^file_table.external & file_table.open_io)
				| (file_table.external
				& (file_table.read | file_table.rewrite | file_table.start | file_table.delete
				| file_table.close | file_table.open_io))
			     then do;
				     io_sw = "1"b;
				     call perform_mode (fixed_common.i_o_error_exit, 32);
				end;

			if (mode_count ^= 1 & mode_count ^= 4) | ^perform_mode_sw
			then do;			/* must provide fall-thru */
				if ioerror.restartad ^= 0
				then restart_ic = ioerror.restartad;
				else restart_ic = cobol_$text_wd_off;
				call cobol_process_error (cobol_code, line_no, mcode_off);
				temp = restart_ic - cobol_$text_wd_off;
				substr (tra_instr, 1, 18) = substr (unspec (temp), 19, 18);
				call cobol_emit (addr (tra_instr), null (), 1);
			     end;
		     end;
	     end;
	return;

perform_mode:
     proc (procno, mode);
dcl	procno		fixed bin (17);
dcl	mode		fixed bin;

	perform_mode_sw = "1"b;			/* if not at least once, then must provide fall-thru */
	if mode_count ^= 1
	then do;
		pntag = cobol_$next_tag;
		cobol_$next_tag = cobol_$next_tag + 1;
		if mcode_off ^= 0 & ^fsbptr_sw
		then do;
			call cobol_set_fsbptr (ft_ptr);
			fsbptr_sw = "1"b;
		     end;
		if ^lda_sw
		then do;
			call cobol_emit (addr (lda_mode), null (), 2);
			lda_sw = "1"b;
		     end;
		if ^(mode_count = 4 & io_sw)
		then do;				/* no need to compare - can just fall in */
			substr (cmpa_dl_instr, 1, 18) = substr (unspec (mode), 19, 18);
			call cobol_emit (addr (cmpa_dl_instr), null (), 1);
			call cobol_emit (addr (tnz_instr), null (), 1);
			call cobol_make_tagref (pntag, cobol_$text_wd_off - 1, null ());
		     end;
	     end;
	call perform_use (procno);
	if mode_count ^= 1
	then call cobol_define_tag (pntag);
	return;
     end perform_mode;


perform_use:
     proc (procno);
dcl	procno		fixed bin;

	call cobol_process_error$use (cobol_code, line_no, mcode_off);
						/* record error message */
	mpout.n = 4;
	mpout.pt1 = addr (type1);
	mpout.pt2, mpout.pt3 = addr (type7);
	mpout.pt4 = addr (type19);
	mpout.pt1 -> reserved_word.line = line_no;
	mpout.pt2 -> proc_def.proc_num = procno;
	mpout.pt3 -> end_stmt.verb = 20;		/* perform */
	call cobol_perform_gen (addr (mpout));
	call cobol_emit (addr (tra_instr), null (), 1);
	if ioerror.forward_tag ^= 0
	then tag = ioerror.forward_tag;
	else tag = next_instr_tag;
	call cobol_make_tagref (tag, cobol_$text_wd_off - 1, null ());
	return;
     end perform_use;

     end produce_error;


set_status:
     proc (type_ptr, eno);
dcl	type_ptr		ptr;
dcl	eno		fixed bin;

	if ^file_table.file_status
	then return;
	call cobol_read_rand (1, file_table.file_status_info, fkey_ptr);
	addr (fkey_type9.file_key_info) -> file_key_desc = file_key.desc;
	mpout.n = 4;
	mpout.pt1 = addr (type1);
	mpout.pt2 = addr (type3);
	mpout.pt3 = addr (fkey_type9);
	mpout.pt4 = addr (type19);
	mpout.pt1 -> reserved_word.line = line_no;
	mpout.pt2 -> alphanum_lit.size = 26;
	mpout.pt2 -> alphanum_lit.line = line_no;
	mpout.pt2 -> alphanum_lit.lit_size = 2;
	s1 = type_ptr -> s.link.status1 (eno);
	substr (mpout.pt2 -> alphanum_lit.string, 1, 2) = s1;
	mpout.pt4 -> end_stmt.verb = 18;		/* move */
	if ^s1set & s1default ^= s1
	then call cobol_move_gen (addr (mpout));
	if ^file_table.extra_status | s2set
	then goto end_set_status;
	call cobol_read_rand (1, file_table.extra_status_info, fkey_ptr);
	addr (fkey_type9.file_key_info) -> file_key_desc = file_key.desc;
	mpout.pt2 -> alphanum_lit.size = 28;
	mpout.pt2 -> alphanum_lit.lit_size = 4;
	substr (mpout.pt2 -> alphanum_lit.string, 1, 4) = type_ptr -> s.link.status2 (eno);
	call cobol_move_gen (addr (mpout));		/*set status entered by preset entry don't execute next two instr's. */
end_set_status:
	if ^preset_sw
	then do;
		substr (lda_instr, 4, 15) = substr (unspec (mcode_off), 22, 15);
		call cobol_emit (addr (lda_instr), null (), 1);
	     end;
	return;
     end set_status;


/*************************************/
preset:
     entry (ft_ptr);

	preset_sw = "1"b;				/* set to signal set_status to skip two instr's. */
	s1set, s2set = "0"b;
	s1default = "**";
	line_no = 0;
	call set_status (addr (no_error_status), 1);
	return;


/*************************************/

/*****	Declaration for builtin function	*****/

dcl	(substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index)
			builtin;

/*****	End of declaration for builtin function	*****/

%include cobol_file_table;
%include cobol_file_key;
%include cobol_type1;
%include cobol_type3;
%include cobol_type7;
%include cobol_type19;
%include cobol_;
%include cobol_ext_;
%include cobol_fixed_common;
     end cobol_ioerror;




		    cobol_ioerror_abort.pl1         05/24/89  1041.5rew 05/24/89  0830.7       45288



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_ioerror_abort.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 02/10/81 by FCH, [4.4-1], tra instr not emitted in certain cases, [4.4-1], BUG462(TR8970) */

/* format: style3 */
cobol_ioerror_abort:
     proc (mesno, lineno, stoff, restartad, exlink);

dcl	mesno		fixed bin;		/* number of cobol error message */
dcl	lineno		fixed bin;		/* line on which error occurred */
dcl	stoff		fixed bin;		/* word offset in stack of code */
dcl	restartad		fixed bin;		/* restartad for restart transfer */
dcl	exlink		fixed bin;		/* extra error code to check */

dcl	1 pr4_struct	static,
	  2 pr4		fixed bin init (4),
	  2 pointer_no	bit (3),
	  2 lock		fixed bin init (0),
	  2 switch	fixed bin init (1),
	  2 segno		fixed bin init (3002),
	  2 offset	fixed bin init (0),
	  2 reset		fixed bin;

dcl	1 areg_struct	static,
	  2 areg		fixed bin init (1),
	  2 reg_no	bit (4),
	  2 lock		fixed bin init (0),
	  2 already_there	fixed bin,
	  2 contains	fixed bin init (0),
	  2 null_ptr	ptr init (null ()),
	  2 lit		fixed bin;

dcl	instr		(3) bit (36);
dcl	reloc		(6) bit (5) aligned static
			init ("10100"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b);

dcl	szn		bit (12) static init ("010011100001"b);
dcl	cmpa		bit (12) static init ("001001101001"b);
dcl	lda		bit (12) static init ("010011101001"b);
dcl	tra_icmod		bit (18) static init ("111001000000000100"b);
dcl	tnz_icmod		bit (18) static init ("110000001000000100"b);
dcl	full_tze_icmod	bit (36) static init ("000000000000000100110000000000000100"b);
dcl	indmod		bit (6) static init ("010000"b);

dcl	utemp		fixed bin;
dcl	hold_ic		fixed bin static init (0);
dcl	hold_addr		bit (18) based;
dcl	instr_ptr		ptr;

dcl	cobol_process_error entry (fixed bin, fixed bin, fixed bin);
dcl	cobol_emit	entry (ptr, ptr, fixed bin);
dcl	cobol_pointer_register$get
			entry (ptr);
dcl	cobol_register$load entry (ptr);


/*************************************/
start:
	instr_ptr = addr (instr);
	instr (1) = "110"b || substr (unspec (stoff), 22, 15) || szn;
	if restartad = 0
	then do;
		if exlink > 0
		then instr (2) = full_tze_icmod;
		else do;
			utemp = hold_ic - cobol_$text_wd_off;
			instr (2) = substr (unspec (utemp), 19, 18) || tnz_icmod;
		     end;
		if stoff > 0
		then call cobol_emit (instr_ptr, null (), 2);
		if exlink > 0
		then do;
			call cobol_pointer_register$get (addr (pr4_struct));
			call cobol_register$load (addr (areg_struct));
			instr (2) = substr (instr (1), 1, 18) || cmpa;
			instr (1) = "100"b || substr (unspec (exlink), 22, 15) || lda || indmod;
			utemp = hold_ic + 2 - cobol_$text_wd_off;
			instr (3) = substr (unspec (utemp), 19, 18) || tnz_icmod;
			call cobol_emit (instr_ptr, addr (reloc), 3);
		     end;
	     end;
	else do;
		if stoff > 0
		then do;
			instr (2) = full_tze_icmod;
			hold_ic = cobol_$text_wd_off + 1;
			call cobol_emit (instr_ptr, null (), 2);
			if exlink > 0
			then do;
				call cobol_pointer_register$get (addr (pr4_struct));
				call cobol_register$load (addr (areg_struct));
				instr (2) = substr (instr (1), 1, 18) || cmpa;
				instr (1) = "100"b || substr (unspec (exlink), 22, 15) || lda || indmod;
				instr (3) = full_tze_icmod;
				call cobol_emit (instr_ptr, addr (reloc), 3);
			     end;
		     end;
		call cobol_process_error (mesno, lineno, stoff);
		utemp = restartad - cobol_$text_wd_off;
		instr (1) = substr (unspec (utemp), 19, 18) || tra_icmod;
						/*[4.4-1]*/
		if stoff ^= 0 | exlink ^= 0
		then call cobol_emit (instr_ptr, null (), 1);
		if stoff > 0
		then do;
			utemp = cobol_$text_wd_off - hold_ic;
			addrel (cobol_$text_base_ptr, hold_ic) -> hold_addr = substr (unspec (utemp), 19, 18);
			utemp = utemp - 3;
			if exlink > 0
			then addrel (cobol_$text_base_ptr, hold_ic + 3) -> hold_addr =
				substr (unspec (utemp), 19, 18);
		     end;
	     end;
	return;


/*************************************/

/*****	Declaration for builtin function	*****/

dcl	(substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index)
			builtin;

/*****	End of declaration for builtin function	*****/

%include cobol_;

     end cobol_ioerror_abort;




		    cobol_iomode.pl1                05/24/89  1041.5rew 05/24/89  0830.7       52398



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_iomode.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 04/02/77 by GM to check for device 2 and set organization to 4 */
/* Modified on 01/14/77 by ORN to signal command_abort_ rather than cobol_compiler_error */
/* modified since Version 2.0 */

/* format: style3 */
cobol_iomode:
     proc (ft_ptr, eos_ptr, cobol_mode, multics_mode, extend_sw);

dcl	cobol_mode	fixed bin;
dcl	multics_mode	fixed bin;
dcl	extend_sw		bit (1) aligned;

/***********************************************/
/*	SEQUENTIAL	RANDOM		DYNAMIC
STREAM
 Input	21,1,1st_byte
 Output	61,2,eof
 Extend	01,2,eof(*)

SEQUENTIAL
 Input	25,4,1st_rec
 Output	65,5,eof
 I-O	45,7,1st_rec
 Extend	05,6,eof(*,**)

RELATIVE
 Input	31,8,1st_rec	32,11,-		33,8,1st_rec
 Output	71,9,eof		72,12,-		73,10,1st_rec(**,***)
 I-O	51,10,1st_rec	52,13,-		53,10,1st_rec

INDEXED
 Input	35,8,1st_rec	36,11,-		37,8,1st_rec
 Output	75,9,eof		76,12,-		77,10,1st_rec(**,***)
 I-O	55,10,1st_rec	56,13,-		57,10,1st_rec

*   extend_sw = "1"b
**  reads are prevented by run-time check
*** positioned to eof by special action at open

/***********************************************/

/*
KEY TO cobol_mode:
	"MMOOAA"b

MM (mode):	00 extend
		01 input
		10 i/o
		11 output

OO (organization):	00 stream
		01 sequential
		10 relative
		11 indexed

AA (access method):	00 invalid
		01 sequential
		10 random
		11 dynamic

MEANINGFUL cobol_modes:
1	01,2
5	05,6
17	21,1
21	25,4
25	31,8
26	32,11
27	33,8
29	35,8
30	36,11
31	37,8
37	45,7
41	51,10
42	52,13
43	53,10
45	55,10
46	56,13
47	57,10
49	61,2
53	65,5
57	71,9
58	72,12
59	73,10
61	75,9
62	76,12
63	77,10
*/

dcl	mode		(3 /*access*/, 4 /*organization*/, 0:3 /*mode*/, 2 /*cobol_mode,multics_mode*/) fixed
			bin static
			init (/* access: (1)sequential, (2)random, (3)dynamic
   organization: (1)sequential, (2)relative, (3)indexed, (4)stream
   mode: (0)input, (1)output, (2)i/o, (3)extend  */
			/* INPUT	OUTPUT	I/O	EXTEND */ /* SEQUENTIAL SEQUENTIAL */ 21, 4, 53, 5, 37, 7, 5,
			6,			/**/
						/* SEQUENTIAL RELATIVE */
			25, 8, 57, 9, 41, 10, 0, 0,	/* SEQUENTIAL INDEXED */
			29, 8, 61, 9, 45, 10, 0, 0,	/* SEQUENTIAL STREAM */
			17, 1, 49, 2, 0, 0, 1, 2,	/**/
						/* RANDOM SEQUENTIAL */
			0, 0, 0, 0, 0, 0, 0, 0,	/* RANDOM RELATIVE */
			26, 11, 58, 12, 42, 13, 0, 0, /* RANDOM INDEXED */
			30, 11, 62, 12, 46, 13, 0, 0, /* RANDOM STREAM */
			0, 0, 0, 0, 0, 0, 0, 0,	/* DYNAMIC SEQUENTIAL */
			0, 0, 0, 0, 0, 0, 0, 0,	/* DYNAMIC RELATIVE */
			27, 8, 59, 10, 43, 10, 0, 0,	/* DYNAMIC INDEXED */
			31, 8, 63, 10, 47, 10, 0, 0,	/* DYNAMIC STREAM */
			0, 0, 0, 0, 0, 0, 0, 0);

dcl	1 error_info,
	  2 name		char (32),
	  2 meslen	fixed bin,
	  2 mes		char (120);
dcl	ioa_$rsnnl	entry options (variable);
dcl	signal_		entry (char (*), ptr, ptr);
dcl	access_con	(3) char (10) static init ("sequential", "random", "dynamic");
dcl	org_con		(4) char (10) static init ("sequential", "relative", "indexed", "stream");
dcl	mode_con		(0:3) char (6) static init ("input", "output", "i-o", "extend");

dcl	access		fixed bin;
dcl	org		fixed bin;
dcl	open_mode		fixed bin;

dcl	ft_ptr		ptr;


/*************************************/
start:
	if file_table.organization = 5
	then file_table.organization = 4;		/* temporary */
	open_mode = fixed (end_stmt.d, 2);
	if file_table.device = 2
	then file_table.organization = 4;
	if (file_table.device = 1 | file_table.device = 3) & file_table.organization = 1
	then org = 4;
	else org = file_table.organization;
	access = file_table.access;
	if access = 0
	then access = 1;

	cobol_mode = mode (access, org, open_mode, 1);
	multics_mode = mode (access, org, open_mode, 2);
	if cobol_mode = 0
	then go to error;
	if cobol_mode < 6
	then extend_sw = "1"b;
	else extend_sw = "0"b;
	return;


/*************************************/
error:
	error_info.name = "cobol_iomode";
	call ioa_$rsnnl ("Attempt to open file ^a in inconsistent mode - access: ^a; organization: ^a; mode: ^a",
	     error_info.mes, error_info.meslen, file_table.ifn, access_con (access), org_con (org),
	     mode_con (open_mode));
	call signal_ ("command_abort_", null (), addr (error_info));
	return;


/*************************************/
translate:
     entry (inmode, outmode, outbit);

dcl	inmode		fixed bin;
dcl	outmode		fixed bin;
dcl	outbit		bit (1) aligned;

start_translate:
	open_mode = fixed (substr (unspec (inmode), 31, 2), 2);
	org = fixed (substr (unspec (inmode), 33, 2), 2);
	access = fixed (substr (unspec (inmode), 35, 2), 2);
	outmode = mode (access, org, open_mode, 2);
	if outmode < 6
	then outbit = "1"b;
	else outbit = "0"b;
	return;


/*************************************/

/*****	Declaration for builtin function	*****/

dcl	(substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index)
			builtin;

/*****	End of declaration for builtin function	*****/

%include cobol_type19;
%include cobol_file_table;
     end cobol_iomode;




		    cobol_ioop_util.pl1             05/24/89  1041.5rew 05/24/89  0830.7       76500



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_ioop_util.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 12/17/80 by FCH, [4.4-1], dimension of array changed from 3 to 1 to prevent severity 3 error */
/* Modified on 04/28/77 by GM to implement LOCK entry */
/* Modified on 11/13/76 by GM to fix LINAGE problems. */
/* Modified on 10/2/76 by GM to  fix bug on LINAGE. */
/* Modified on 7/28/76 by George Mercuri to add set_x5 entry */
/* Modified on 7/9/76 by George Mercuri to add set_icode entry */
/* Modified on 6/14/76 by George Mercuri for change to access of stack offset in open_gen.*/
/* Modified on 6/3/76 by George Mercuri for multics_mode code.*/
/* Modified on 5/24/76 by George Mercuri for addition of lda generation. */
/* Modified on 5/18/76 by George Mercuri for error interface. */
/* Modified on 5/10/76 by George Mercuri for change to error handling. */
/* Modified on 5/5/76 by George Mercuri for  error handling techniques. */
/* Created on 4/29/76 by George Mercuri for the call to DISPLAY operators. */
/* format: style3 */
cobol_ioop_util:
     proc (stoff);

disp:
     entry (stoff);

dcl	tag_off		fixed bin;
dcl	aloff		fixed bin;
dcl	stoff		fixed bin;
dcl	temp		fixed bin;
dcl	cobol_mode	fixed bin;
dcl	multics_mode	fixed bin;
dcl	ft_ptr		ptr;

/*[4.4-1]*/
dcl	disp_instr	(1) bit (36) static init ("110000000000000000011111001101000000"b);
						/* epp5 pr6|<stoff> */
dcl	disp_reloc	(2) bit (5) aligned static init (""b, ""b);
dcl	stz_instr		(1) bit (36) static init ("110000000000101100100101000001000000"b);
						/* stz pr6|54 */
dcl	ldaldx5_instr	(2) bit (36) static init ("000000000000000000010011101000000111"b,
						/* lda <ioname_len>,dl	*/
			"000000000000000000010010101000000011"b);
						/* ldx5 <stack_offset>,dl	*/
dcl	fsb_open_mode_instr (3) bit (36) static init ("000000000000000000010011101000000111"b,
						/* lda	[cobol_mode],dl	*/
			"000000000000000000010011110000000011"b,
						/* ldq	[optional/opened/how,du] */
			"000000000000000000111010101000000111"b);
						/* lxl5	[multics_code],dl	*/
dcl	lda_instr		(1) bit (36) static init ("000000000000000000010011101000000111"b);
						/* lda <cobol_mode>,dl	*/
dcl	lda_du_instr	(1) bit (36) static init ("000000000000000000010011101000000011"b);
						/* lda offset,du	*/
dcl	tra_instr		(1) bit (36) static init ("000000000000000000111001000000000100"b);
						/* tra ioerror.ns_tag,ic	*/
dcl	set_icode_instr	(1) bit (36) static init ("110000000000101001000101100001000000"b);
						/* aos	pr6|icode(51) 	*/
dcl	set_value_instr	(2) bit (36) static init ("000000000000000000010011101000000111"b,
						/* lda	advancing_value,dl	*/
			"110000000000101111111101101001000000"b);
						/* sta	pr6|57	*/
dcl	set_var_adv_instr	(1) bit (36) static init ("110000000000101111111101110001000000"b);
						/* stq	pr6|57	*/
dcl	set_fsb_instr	(2) bit (36) static init ("000000000000000000010011101000000111"b,
						/* lda 	linage_type,dl	*/
			"001000000000000000111101101001000000"b);
						/* sta 	pr1|fsb_offset	*/
dcl	set_x5_instr	(1) bit (36) static init ("000000000000000000010010101000000011"b);
						/* ldx5	io_error_no,dl	*/
dcl	bypass_reset	(2) bit (36) static init ("000000000000000001001000011000000011"b,
						/* cmpx3 1,du	*/
			"000000000000000000110000001000000100"b);
						/* tra <skip_tag>,ic 	*/
dcl	ldalock		(2) bit (36) static init ("000000000000000000010011101000000100"b,
						/* lda 0,ic	*/
			"001000000001011010010101101001000000"b);
						/* orsa pr1|90	*/


dcl	cobol_emit	entry (ptr, ptr, fixed bin);


/***************************************/
start:
	substr (disp_instr (1), 4, 15) = substr (unspec (stoff), 22, 15);

	call cobol_emit (addr (disp_instr), addr (disp_reloc), 1);

	return;


/***************************************/

set_stz:
     entry;


	call cobol_emit (addr (stz_instr), null (), 1);

	return;


/****************************************/

ldaldx5:
     entry (ioname_len, aloff);

dcl	ioname_len	fixed bin;

	substr (ldaldx5_instr (1), 4, 15) = substr (unspec (ioname_len), 22, 15);
	substr (ldaldx5_instr (2), 4, 15) = substr (unspec (aloff), 22, 15);

	call cobol_emit (addr (ldaldx5_instr), null (), 2);

	return;



/****************************************/

open_clean_up:
     entry (ft_ptr, cobol_mode, multics_mode);

	substr (fsb_open_mode_instr (1), 1, 18) = substr (unspec (cobol_mode), 19, 18);
	if file_table.optional & file_table.external
	then temp = 81920;
	else if file_table.optional & ^file_table.external
	then temp = 98304;
	else if file_table.external
	then temp = 32768;
	else temp = 49152;

	substr (fsb_open_mode_instr (2), 1, 18) = substr (unspec (temp), 19, 18);
	substr (fsb_open_mode_instr (3), 1, 18) = substr (unspec (multics_mode), 19, 18);
	call cobol_emit (addr (fsb_open_mode_instr), null (), 3);

	return;


/****************************************/

lda:
     entry (cobol_mode);

	substr (lda_instr (1), 4, 15) = substr (unspec (cobol_mode), 22, 15);

	call cobol_emit (addr (lda_instr), null (), 1);

	return;


/****************************************/
lda_du:
     entry (stoff);

	substr (lda_du_instr (1), 1, 18) = substr (unspec (stoff), 19, 18);
	call cobol_emit (addr (lda_du_instr), null (), 1);
	return;



/****************************************/

tra:
     entry (tag_off);

	substr (tra_instr (1), 1, 18) = substr (unspec (tag_off), 19, 18);

	call cobol_emit (addr (tra_instr), null (), 1);

	return;



/****************************************/

set_icode:
     entry;

	call cobol_emit (addr (set_icode_instr), null (), 1);
	return;


/****************************************/

set_value:
     entry (advancing_value);

dcl	advancing_value	fixed bin;

	substr (set_value_instr (1), 1, 18) = substr (unspec (advancing_value), 19, 18);
	call cobol_emit (addr (set_value_instr), null (), 2);
	return;



/****************************************/

set_fsb:
     entry (linage_type, fsb_offset);


dcl	linage_type	fixed bin;
dcl	fsb_offset	fixed bin;

	substr (set_fsb_instr (1), 1, 18) = substr (unspec (linage_type), 19, 18);
	substr (set_fsb_instr (2), 4, 15) = substr (unspec (fsb_offset), 22, 15);
	call cobol_emit (addr (set_fsb_instr), null (), 2);
	return;



/****************************************/

set_var_adv:
     entry;

	call cobol_emit (addr (set_var_adv_instr), null (), 1);
	return;





/****************************************/

set_x5:
     entry (io_error_no);

dcl	io_error_no	fixed bin;

	substr (set_x5_instr (1), 1, 18) = substr (unspec (io_error_no), 19, 18);
	call cobol_emit (addr (set_x5_instr), null (), 1);
	return;



/***************************************/

bypass_reset:
     entry (skip_tag);

dcl	skip_tag		fixed bin;
dcl	cobol_make_tagref	entry (fixed bin, fixed bin, ptr);

	call cobol_emit (addr (bypass_reset), null (), 2);
	call cobol_make_tagref (skip_tag, cobol_$text_wd_off - 1, null ());
	return;


/***************************************/

set_lock:
     entry;

dcl	lock_bit		bit (36) static init ("000010000000000000000000000000000000"b);
dcl	lock_char		char (4) based (addr (lock_bit));
dcl	cobol_pool	entry (char (*), fixed bin, fixed bin);
dcl	con_off		fixed bin;



	call cobol_pool (lock_char, 1, con_off);
	temp = -cobol_$text_wd_off - con_off;
	substr (ldalock (1), 1, 18) = substr (unspec (temp), 19, 18);
	call cobol_emit (addr (ldalock), null (), 2);
	return;


/****** Declaration for Builtin function	*****/

dcl	(substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index)
			builtin;

/***** End of declaration dor builtin function 	*****/

%include cobol_file_table;
%include cobol_;
     end cobol_ioop_util;




		    cobol_linage.pl1                05/24/89  1041.5rew 05/24/89  0830.7      181980



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_linage.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 02/10/81 by FCH, cobol_abort_error changed not to emit tra instr, [4.4-1], BUG462(TR8970) */
/* Modified on 08/23/80 by FCH, [4.3-1], after advancing data-name with linage clause generates bad code, BUG441(SQ431) */
/* Modified since Version 4.3 */

/* format: style3 */
cobol_linage:
     proc (ft_ptr, mp_ptr, buflen_off, buf_off, ioerror_ptr);

dcl	page_sw		bit (1) init ("0"b);
dcl	ioerror_ptr	ptr;
dcl	pr5_struct_ptr	ptr;
dcl	ft_ptr		ptr;
dcl	mp_ptr		ptr;
dcl	good_tag		fixed bin;
dcl	advancing_count	fixed bin;
dcl	buflen_off	fixed bin;		/* stack offset in words (input) */
dcl	buf_off		fixed bin;		/* stack offset in words (output) */

dcl	1 mp		based (mp_ptr),
	  2 n		fixed bin,
	  2 pt		(0 refer (mp.n)) ptr;

dcl	linage_before	bit (1);
dcl	mrl		bit (36) static init ("000000000000000000001000001100000000"b);
dcl	mlr		bit (36) static init ("000000000000000000001000000100000000"b);
dcl	mlr_q		bit (36) static init ("000001101001000110001000000100000000"b);
dcl	szn		bit (12) static init ("010011100001"b);
dcl	aos		bit (12) static init ("000101100001"b);
dcl	lxl5		bit (12) static init ("111010101001"b);
dcl	adq		bit (12) static init ("000111110001"b);
dcl	stq		bit (12) static init ("111101110001"b);
dcl	lda		bit (12) static init ("010011101001"b);
dcl	ldq		bit (12) static init ("010011110001"b);
dcl	sbq		bit (12) static init ("001111110001"b);
dcl	adq_dlmod		bit (18) static init ("000111110000000111"b);
dcl	ldq_dlmod		bit (18) static init ("010011110000000111"b);
dcl	ldq_dumod		bit (18) static init ("010011110000000011"b);
dcl	tra_icmod		bit (18) static init ("111001000000000100"b);
dcl	tnz_icmod		bit (18) static init ("110000001000000100"b);
dcl	num_check_instr	(4) bit (36) static init ("110000000001010000010011101001000000"b,
						/* lda	pr6|120	*/
			"110000000000110001010011110001000000"b,
						/* ldq	pr6|lenoff	*/
			"000000000001111001001001110000000111"b,
						/* cmpq	171,dl		*/
			"000000000000000000110000100000000100"b);
						/* tmi	[bypass_error]);ic	*/


dcl	1 ioerror		based (ioerror_ptr),
	  2 cobol_code	fixed bin,
	  2 retry_tag	fixed bin,
	  2 is_tag	fixed bin,
	  2 ns_tag	fixed bin,
	  2 type1_ptr	ptr,
	  2 mode		fixed bin;

dcl	1 pr5_struct	static,
	  2 pr5		fixed bin init (5),
	  2 pointer_no	bit (3),
	  2 lock		fixed bin init (0),
	  2 switch	fixed bin init (0),
	  2 segno		fixed bin init (0),
	  2 offset	fixed bin init (0),
	  2 reset		fixed bin;
dcl	1 mlr_struct,
	  2 type		fixed bin init (5),
	  2 operand_no	fixed bin init (2),
	  2 lock		fixed bin init (0),
	  2 operand1,
	    3 token_ptr	ptr,			/* always set */
	    3 send_receive	fixed bin init (0),
	    3 ic_mod	fixed bin,
	    3 size_sw	fixed bin init (1),
	  2 operand2,
	    3 token_ptr	ptr init (null ()),
	    3 send_receive	fixed bin,
	    3 ic_mod	fixed bin,
	    3 size_sw	fixed bin;

dcl	1 zero_token	static,			/*06-16-77*/
	  2 size		fixed bin init (40),	/*06-16-77*/
	  2 line		fixed bin init (0),		/*06-16-77*/
	  2 column	fixed bin init (0),		/*06-16-77*/
	  2 type		fixed bin init (2),		/*06-16-77*/
	  2 integral	bit (1) init ("0"b),	/*06-16-77*/
	  2 floating	bit (1) init ("0"b),	/*06-16-77*/
	  2 seg_range	bit (1) init ("0"b),	/*06-16-77*/
	  2 filler1	bit (4) init ("0"b),	/*06-16-77*/
	  2 subscript	bit (1) init ("0"b),	/*06-16-77*/
	  2 sign		char (1) init ("0"),	/*06-16-77*/
	  2 exp_sign	char (1) init ("0"),	/*06-16-77*/
	  2 exp_places	fixed bin init (0),		/*06-16-77*/
	  2 places_left	fixed bin init (0),		/*06-16-77*/
	  2 places_right	fixed bin init (0),		/*06-16-77*/
	  2 places	fixed bin init (1),		/*06-16-77*/
	  2 literal	char (1) init ("0");
dcl	instr		(6) bit (36);
dcl	text		(0:100000) bit (36) based (cobol_$text_base_ptr);

/* slew characters.	03-02-77	*/
dcl	pr_ctl		char (5) static int init ("c  ");
dcl	chan_no		fixed bin;
dcl	convert_no	(10:16) char (2) static int init ("10", "11", "12", "13", "14", "15", "16");
dcl	convert_no1	(9) char (1) static int init ("1", "2", "3", "4", "5", "6", "7", "8", "9");

dcl	nls		char (120) static init ((120)"
");
dcl	advancing_error	fixed bin static init (23);
dcl	len_off		fixed bin static init (49);

dcl	dn_ptr		ptr;
dcl	name_ptr		ptr;
dcl	dn_ptr_linage	ptr;
dcl	instr_ptr		ptr;
dcl	mlr_struct_ptr	ptr;

dcl	bnum		fixed bin;
dcl	anum		fixed bin;
dcl	ba_sw		fixed bin;
dcl	bvalue		bit (18) aligned;
dcl	avalue		bit (18) aligned;
dcl	temp		fixed bin;
dcl	utemp		fixed bin;
dcl	restartad		fixed bin;
dcl	patch_ic		fixed bin;

dcl	cobol_define_tag	entry (fixed bin);
dcl	cobol_pool	entry (char (*), fixed bin, fixed bin);
dcl	cobol_set_pr	entry (ptr, ptr);
dcl	cobol_call_op	entry (fixed bin, fixed bin);
dcl	cobol_gen_ioerror	entry (ptr, ptr);
dcl	cobol_ioop_util$set_var_adv
			entry;
dcl	cobol_ioop_util$set_value
			entry (fixed bin);
dcl	signal_		entry (char (*), ptr, ptr);
dcl	cobol_alloc$stack	entry (fixed bin, fixed bin, fixed bin);
dcl	cobol_emit	entry (ptr, ptr, fixed bin);
dcl	cobol_addr	entry (ptr, ptr, ptr);
dcl	ioa_$rsnnl	entry options (variable);	/* sub-generators */
dcl	cobol_io_util$move_direct
			entry (bit (3) aligned, fixed bin, fixed bin, fixed bin, bit (18) aligned);
dcl	cobol_io_util$fixed_add
			entry (bit (3) aligned, fixed bin, fixed bin, bit (3) aligned, fixed bin);
dcl	cobol_io_util$move_lit
			entry (bit (3) aligned, fixed bin, fixed bin, char (*));
dcl	cobol_io_util$t9dec_to_bin
			entry (bit (3) aligned, fixed bin, ptr);
dcl	cobol_ioerror_abort entry (fixed bin, fixed bin, fixed bin, fixed bin, fixed bin);


/*************************************/
/* Note: code is generated under the assumption that the A register
   is set with the length of the sending  field unless the item has
   variable length.  */

start:
	linage_before = "0"b;
	dn_ptr = mp.pt (mp.n - 1);
	dn_ptr_linage = mp.pt (mp.n - 2);
	eos_ptr = mp.pt (mp.n);
	mlr_struct.operand1.token_ptr = mp.pt (2);

	if ^file_table.variable
	then mp.pt (2) -> data_name.variable_length = "0"b;

	instr_ptr = addr (instr);
	mlr_struct_ptr = addr (mlr_struct);
	pr5_struct_ptr = addr (pr5_struct);
	good_tag = cobol_$next_tag;
	cobol_$next_tag = cobol_$next_tag + 1;


	if data_name.type = 17
	then call cobol_alloc$stack (121, 2, buf_off);	/* allocate 121 only*/
	else call cobol_alloc$stack (data_name.item_length + 120, 2, buf_off);
						/* allow up to 120 new-lines */

start_codegen:
	anum, bnum = 0;

	if buflen_off = 0
	then do;					/* special call from cobol_open_gen to output first TOP skips for linage. */

		call move_buf_con;
		return;

	     end;

	if data_name.type = 1
	then /*06-16-77*/
	     if dn_ptr -> reserved_word.key = reswd_ZERO
	     then /*06-16-77*/
		dn_ptr = addr (zero_token);		/*06-16-77*/

	if end_stmt.d = "00"b
	then do;					/* no ADVANCING clause - same as AFTER 1 */

		dn_ptr_linage = mp.pt (mp.n - 1);

		if file_table.device = 1
		then do;				/* COBOL rules - after advancing 1 */

			bvalue = "000001010000001010"b;
			bnum = 1;

		     end;
		else do;				/* MULTICS rules - before advancing 1 */

			avalue = "000001010000001010"b;
			anum = 1;

		     end;

		call move_buf_con;
	     end;

	else if end_stmt.d = "10"b
	then do;					/* AFTER ADVANCING ... specified */

		if data_name.type = 2
		then do;				/* AFTER ADVANCING literal */

			bnum = fixed (dn_ptr -> numeric_lit.literal, 17);

			if bnum > 120
			then go to litsize_error;

			bvalue = "000001010000001010"b;

			call move_buf_con;

		     end;
		else if data_name.type = 9
		then do;				/* AFTER ADVANCING data-name */

			ba_sw = 0;

			call move_buf_var;

		     end;
		else if data_name.type = 1 | data_name.type = 17
		then do;				/* AFTER ADVANCING PAGE or mnemonic-name */

			if data_name.type = 17 | (data_name.type = 1 & ^file_table.linage)
			then do;

				chan_no = dn_ptr -> mnemonic_name.iw_key - 210;

				if chan_no < 17 & chan_no > 9
				then do;
					bnum = 5;
					substr (pr_ctl, 3, 2) = convert_no (chan_no);
				     end;
				else if chan_no > 0 & chan_no < 10
				then do;
					bnum = 4;
					substr (pr_ctl, 3, 2) = convert_no1 (chan_no) || "";
				     end;
				else do;
					bvalue = "000001100"b;
					bnum = 1;
				     end;

				call move_buf_con;

			     end;
			else if file_table.linage
			then do;

				bvalue = "000001010"b;
				bnum = 1;
				page_sw = "1"b;

				call move_buf_con;

			     end;
		     end;
	     end;
	else do;					/* BEFORE ADVANCING ... specified */

		linage_before = "1"b;

		if data_name.type = 2
		then do;				/* BEFORE ADVANCING literal */

			avalue = "000001010"b;

			anum = fixed (dn_ptr -> numeric_lit.literal, 17);

			if anum > 120
			then go to litsize_error;

			call move_buf_con;

		     end;
		else if data_name.type = 9
		then do;				/* BEFORE ADVANCING data-name */

			ba_sw = 1;

			call move_buf_var;

		     end;
		else if data_name.type = 1 | data_name.type = 17
		then do;				/* BEFORE ADVANCING PAGE or mnemonic-name */

			if data_name.type = 17 | (data_name.type = 1 & ^file_table.linage)
			then do;

				chan_no = dn_ptr -> mnemonic_name.iw_key - 210;

				if chan_no < 17 & chan_no > 9
				then do;
					anum = 5;
					substr (pr_ctl, 3, 2) = convert_no (chan_no);
				     end;
				else if chan_no > 0 & chan_no < 10
				then do;
					anum = 4;
					substr (pr_ctl, 3, 2) = convert_no1 (chan_no) || "";
				     end;
				else do;
					avalue = "000001100"b;
					anum = 1;
				     end;

				call move_buf_con;

			     end;
			else if file_table.linage
			then do;

				avalue = "000001010"b;
				anum = 1;
				page_sw = "1"b;

				call move_buf_con;

			     end;
		     end;
	     end;
exit:
	return;


/*************************************/
/* SUBROUTINES */
/*************************************/

move_buf_con:
     proc;					/* LINAGE CODE FOLLOWS */

	if file_table.linage & buflen_off ^= 0
	then do;

		call cobol_set_pr (pr5_struct_ptr, dn_ptr_linage);

		if page_sw
		then call cobol_ioop_util$set_value (1000);
						/* temp high value for PAGE */
		else call cobol_ioop_util$set_value (bnum + anum);

		call cobol_call_op (52, good_tag);	/* LINAGE_OP */
		call cobol_gen_ioerror (ft_ptr, ioerror_ptr);
		call cobol_define_tag (good_tag);

	     end;

/* 	else call cobol_ioop_util$set_value(0); */
/* no linage clause specified */

	if bnum > 0
	then do;

		if bnum < 3
		then call cobol_io_util$move_direct ("110"b, buf_off * 4, 4, 0, bvalue);
		else if data_name.type = 17
		then call cobol_io_util$move_lit ("110"b, buf_off * 4, bnum, substr (pr_ctl, 1, bnum));
		else call cobol_io_util$move_lit ("110"b, buf_off * 4, bnum, substr (nls, 1, bnum));

		instr (1) = "110"b || substr (unspec (buflen_off), 22, 15) || lda;

		call cobol_emit (instr_ptr, null (), 1);

	     end;
	else if file_table.rec_do
	then do;					/* in this case A will not be already set */

		instr (1) = "110"b || substr (unspec (buflen_off), 22, 15) || lda;

		call cobol_emit (instr_ptr, null (), 1);
	     end;

	if anum = 0
	then if file_table.device = 1
	     then do;				/*print file - append CR if necessary */

		     anum = 1;

		     if file_table.linage
		     then avalue = "000001010"b;	/* octal 012 top bottom */
		     else avalue = "000001101"b;	/* octal 015 = Carriage Return */

		end;
	if anum > 0
	then do;

		if file_table.linage
		then do;

			if bnum = 0
			then do;
				temp = 5130;
				instr (1) = substr (unspec (temp), 19, 18) || ldq_dumod;
				temp = buf_off * 4 + 1;
				instr (2) = "110"b || substr (unspec (temp), 22, 15) || stq;

				call cobol_emit (instr_ptr, null (), 2);

			     end;
			temp = buflen_off + 1;
			instr (1) = "110"b || substr (unspec (temp), 22, 15) || ldq;

			call cobol_emit (instr_ptr, null (), 1);

		     end;
		else if data_name.type ^= 17 | anum = 1
		then do;

			instr (1) = substr (unspec (anum), 19, 18) || ldq_dlmod;
			instr (2) = "110"b || substr (unspec (buflen_off), 22, 15) || adq;

			call cobol_emit (instr_ptr, null (), 2);

		     end;
	     end;

	if file_table.linage & ^linage_before
	then do;
		instr (1) = mrl;
		temp = buf_off * 4;
	     end;
	else do;
		instr (1) = mlr;
		temp = buf_off * 4 + bnum;
	     end;

	call cobol_addr (mlr_struct_ptr, instr_ptr, null ());

	substr (instr (3), 1, 20) = "110"b || substr (unspec (temp), 20, 17);
	substr (instr (2), 21, 16) = "0000000000000101"b; /* sending length in A */
	substr (instr (1), 12, 2) = "11"b;		/* length of receiving in A or Q */
	substr (instr (1), 31, 1) = "1"b;		/* length of sending in A */

	if anum = 0
	then substr (instr (3), 21, 16) = substr (instr (2), 21, 16);
	else do;

		substr (instr (1), 1, 9) = avalue;
		substr (instr (3), 21, 16) = "0000000000000110"b;

	     end;

	if data_name.type = 17 & anum > 1
	then do;

		substr (instr (1), 1, 9) = "000000000"b;
		substr (instr (3), 21, 16) = "0000000000000101"b;

		call cobol_emit (addr (instr (1)), null (), 3);
		call cobol_pool (substr (pr_ctl, 1, anum), 1, temp);

		substr (instr (1), 12, 7) = "1000101"b;
		substr (instr (1), 30, 7) = "0000100"b;
		temp = -cobol_$text_wd_off - temp;
		substr (instr (2), 1, 18) = substr (unspec (temp), 19, 18);
		substr (instr (2), 19, 18) = substr (unspec (anum), 19, 18);
		substr (instr (3), 21, 16) = substr (unspec (anum), 21, 16);

	     end;

	call cobol_emit (addr (instr (1)), null (), 3);

	if file_table.linage & ^linage_before
	then do;

		instr (1) = mlr_q;
		instr (2) = (36)"0"b;
		substr (instr (3), 33, 4) = "0001"b;

		call cobol_emit (addr (instr (1)), null (), 3);

		instr (1) = "000000000000000001000111110000000111"b;

		call cobol_emit (addr (instr (1)), null (), 1);

	     end;

	temp = anum + bnum;

	if ^file_table.linage & temp > 0
	then call cobol_io_util$fixed_add ("110"b, buflen_off * 4, temp, "000"b, 0);

	else if temp > 0
	then do;

		instr (1) = "110"b || substr (unspec (buflen_off), 22, 15) || stq;

		instr (2) = "110"b || substr (unspec (buflen_off), 22, 15) || lda;

		call cobol_emit (addr (instr), null (), 2);

	     end;

	return;
     end move_buf_con;


move_buf_var:
     proc;

	restartad = cobol_$text_wd_off;

	call cobol_io_util$t9dec_to_bin ("110"b, len_off * 4, mp.pt (mp.n - 1));

	patch_ic = cobol_$text_wd_off + 3;

	call cobol_emit (addr (num_check_instr), null (), 4);
	call cobol_ioerror_abort (advancing_error, mp.pt (1) -> reserved_word.line, 0, restartad, 0);

/*[4.4-1]*/
/*cobol_$text_wd_off = cobol_$text_wd_off-1;*/
/* erase the transfer */
	instr (1) = "110"b || substr (unspec (buflen_off), 22, 15) || lda;
	utemp = restartad - (cobol_$text_wd_off + 1);
	instr (2) = substr (unspec (utemp), 19, 18) || tra_icmod;

	call cobol_emit (instr_ptr, null (), 2);

	utemp = cobol_$text_wd_off - patch_ic;
	substr (text (patch_ic), 1, 18) = substr (unspec (utemp), 19, 18);

	if file_table.rec_do
	then do;					/* in this case, A will not be already set */

/*	     instr(1) = "110"b||substr(unspec(buflen_off),22,15)||lda;  */
/* already done */

		call cobol_emit (instr_ptr, null (), 1);
	     end;

	if file_table.linage & buflen_off ^= 0
	then do;

		call cobol_set_pr (pr5_struct_ptr, dn_ptr_linage);
		call cobol_ioop_util$set_var_adv;

		call cobol_call_op (52, good_tag);	/* LINAGE_OP */
		call cobol_gen_ioerror (ft_ptr, ioerror_ptr);
		call cobol_define_tag (good_tag);

	     end;

	if ba_sw = 0
	then do;					/* AFTER specified */

/*[4.3-1]*/
		if file_table.linage		/*[4.3-1]*/
		then do;

/*[4.3-1]*/
			temp = buflen_off + 1;

/*[4.3-1]*/
			instr (1) = "110"b || substr (unspec (temp), 22, 15) || ldq;
						/*[4.3-1]*/
			instr (2) = "110"b || substr (unspec (buflen_off), 22, 15) || sbq;

/*[4.3-1]*/
			call cobol_emit (instr_ptr, null (), 2);

/*[4.3-1]*/
		     end;

		instr (1) = mlr;
		instr (2) = ""b;
		instr (3) = "110"b || substr (unspec (buf_off), 22, 15) || "000000000000000110"b;
						/* len in Q reg */

		substr (instr (1), 1, 18) = "000001010001100000"b;

		call cobol_emit (instr_ptr, null (), 3);

		if file_table.device = 1		/* print file - append carriage return */
		then do;

			instr (1) = "110"b || substr (unspec (buflen_off), 22, 15) || aos;
			instr (2) = substr (instr (1), 1, 18) || lxl5;
						/* and load it in X5 */

			call cobol_emit (instr_ptr, null (), 2);

		     end;

		instr (1) = mlr;

		call cobol_addr (mlr_struct_ptr, addr (instr (1)), null ());

		substr (instr (1), 1, 18) = "000001101"b || "00"b || "1100110"b;
						/* CR fill, var length, indexed by Q */
		substr (instr (2), 21, 16) = "0000000000000101"b;
						/* sending length in A */
		instr (3) = "110"b || substr (unspec (buf_off), 22, 15);

		if file_table.device = 1
		then substr (instr (3), 19, 18) = "000000000000001101"b;
						/* length in X5 */
		else substr (instr (3), 19, 18) = "000000000000000101"b;
						/* length in A */

		substr (instr (1), 31, 1) = "1"b;
		instr (4) = "110"b || substr (unspec (buflen_off), 22, 15) || adq;
		instr (5) = substr (instr (4), 1, 18) || stq;

		call cobol_emit (instr_ptr, null (), 5);

	     end;
	else do;

		if file_table.linage
		then do;
			utemp = buflen_off + 1;
			instr (1) = "110"b || substr (unspec (utemp), 22, 15) || ldq;
		     end;
		else do;
			utemp = buflen_off;
			instr (1) = "110"b || substr (unspec (utemp), 22, 15) || adq;
		     end;

		instr (2) = mlr;

		call cobol_addr (mlr_struct_ptr, addr (instr (2)), null ());

		substr (instr (3), 21, 16) = "0000000000000101"b;
		instr (4) = "110"b || substr (unspec (buf_off), 22, 15) || "000000000000000110"b;
		substr (instr (2), 1, 18) = "000001010001100000"b;
		substr (instr (2), 31, 1) = "1"b;
		instr (5) = "110"b || substr (unspec (buflen_off), 22, 15) || stq;

		call cobol_emit (instr_ptr, null (), 5);

		if file_table.device = 1
		then do;				/* print file - assure carriage return */

			instr (1) = "110"b || substr (unspec (len_off), 22, 15) || szn;
			instr (2) = "000000000000000101"b || tnz_icmod;
						/* OK if at least one NL */
			instr (3) = mlr;		/* otherwise append CR */
			substr (instr (3), 1, 18) = "000001101"b || "00"b || "100"b || "0110"b;
						/* CR fill at offset in Q */
			instr (4) = ""b;		/* for fill only */
			instr (5) = "110"b || substr (unspec (buf_off), 22, 15) || "000000000000000001"b;
			instr (6) = "110"b || substr (unspec (buflen_off), 22, 15) || aos;
						/* increment length field */

			call cobol_emit (instr_ptr, null (), 6);

		     end;
	     end;
	return;
     end move_buf_var;


/*************************************/
nyi_error:
	call ioa_$rsnnl ("""ADVANCING mnemonic-name"" clause specified on line ^d not yet implemented", message,
	     message_len, mp.pt (1) -> reserved_word.line);
	go to error;

litsize_error:
	call ioa_$rsnnl ("Literal specified in ""ADVANCING"" clause on line ^d is too large - ^a", message, message_len,
	     mp.pt (1) -> reserved_word.line, dn_ptr -> numeric_lit.literal);
	go to error;

error:
	error_info.name = "cobol_linage";
	call signal_ ("command_abort_", null (), addr (error_info));
	return;


/*************************************/

/*****	Declaration for builtin function	*****/

dcl	(substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index)
			builtin;

/*****	End of declaration for builtin function	*****/

%include cobol_error_info;
%include cobol_type1;
%include cobol_type2;
%include cobol_type9;
%include cobol_type19;
%include cobol_file_table;
%include cobol_;
%include cobol_type17;
%include cobol_reswd_values;

     end cobol_linage;




		    cobol_link_init.pl1             05/24/89  1041.5rew 05/24/89  0830.6       47655



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_link_init.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 07/18/78 by RAL, [3.0-1], changed cobol_linkage_header.incl.pl1 */
/* Modified since Version 3.0	*/

/* format: style3 */
cobol_link_init:
     proc;					/*
The procedure cobol_link_init initializes the Linkage Section and  
outputs corresponding relocation information.  In particular it:

     1.  Initializes all items in the header with the exception 
         of def_section_relp and linkage_section_length.

     2.  Initializes all fixed internal static data (stat and
         trace_control_word) with the exception of stat.data_len.

cobol_link_init is called once per compilation, prior to code
generation.


U__s_a_g_e:_

     declare cobol_link_init entry;

     call cobol_link_init;

D__a_t_a:_

     % include cobol_;

	Items in cobol include file used (u) and/or set(s) by
	cobol_link_init:

               cobol_ptr (u)
	     com_ptr (u)
               link_base_ptr (u)
               link_wd_off (s)
	     link_max (u)


     % include fixed_common;

          Items in fixed_common include file used (u) and/or set (s)
	by cobol_link_init:

	     prog_name (u)				  */

%include cobol_linkage_header;
/* [3.0-1] */

%include cobol_fixed_static;

dcl	1 error_s		aligned static,
	  2 my_name	char (32) init ("cobol_link_init"),
	  2 message_len	fixed bin init (32),
	  2 message	char (168) init ("Linkage Section length exceeded!");

dcl	reloc_info	(4) bit (5) aligned static init ("00000"b, "00000"b, "10000"b, "00000"b);

dcl	no_wds		fixed bin;		/* Number of words in header and */
						/* stat structure incremented by */
						/* 1, if necessary, to be even.  */

/*
P__r_o_c_e_d_u_r_e_s_C__a_l_l_e_d:_
						  */

dcl	signal_		entry (char (*), ptr, ptr);
dcl	cobol_reloc	entry (ptr, fixed bin, fixed bin);


/*
_B_u_i_l_t-__i_n_F__u_n_c_t_i_o_n_s_U__s_e_d:_
						  */

dcl	addr		builtin;
dcl	addrel		builtin;
dcl	binary		builtin;
dcl	null		builtin;
dcl	rel		builtin;
dcl	search		builtin;
dcl	substr		builtin;
dcl	unspec		builtin;			/*}*/

%include cobol_;
%include cobol_fixed_common;
%include cobol_ext_;


/*************************************/
start:						/*  UPDATE link_wd_off AND TEST AGAINST link_max  */
						/*  Number of words occupied by header plus static data is 8   */
						/*  plus number of words in stat.  If the trace_control_word   */
						/*  falls on an even word boundary (no_wds odd), no_wds is in- */
						/*  creased by 1 so that links which follow will be on even    */
						/*  word boundaries, as required.			   */
	stat_ptr = addrel (link_base_ptr, 8);		/* Modified to interface with cobol run time package. */
						/*     no_wds=binary(rel(addr(stat.reserved(16))),17)+1;
/*     no_wds = no_wds-binary(rel(cobol_$link_base_ptr),17);
/*     if substr(unspec(no_wds),36,1) = "1"b
/*	then
/*	     no_wds = no_wds+1;
/**/
	no_wds = fixed_static_length + 8;
	link_wd_off = no_wds;			/*	if link_wd_off > link_max
/*	then do;
/*		call signal_("command_abort_",null(),addr(error_s));
/*		return;
/*	    end;
/**/

/*  INITIALIZE LINKAGE SECTION HEADER  */

	pad = (36)"0"b;

/* def_section_relp not initialized by cobol_link_init */

	first_reference_relp = (18)"0"b;

	unspec (obsolete_ptr) = (36)"0"b;		/* [3.0-1] */

	unspec (original_linkage_ptr) = (36)"0"b;	/* [3.0-1] */

	links_relp = substr (unspec (no_wds), 19, 18);

/* linkage_section_length not initialized by cobol_link_init */

	object_seg = (18)"0"b;

	obsolete_length = (18)"0"b;


/*  INITIALIZE FIXED INTERNAL STATIC DATA  */


	stat.data_ptr = null ();

	stat.control_ptr = null ();

	stat.file_info_ptr = null ();

	stat.call_cnt = -1;

/* data_len not initialized by cobol_link_init */

	stat.entry_pt_ptr = null ();

	stat.prog_id_len = search (fixed_common.prog_name, " ") - 1;

	if stat.prog_id_len = -1
	then stat.prog_id_len = 30;

	stat.prog_id = fixed_common.prog_name;

	stat.line_no (1), stat.line_no (2) = 0;

	stat.fo_flag = 0;

	stat.fo_disp = 0;

	stat.main_prog_sw = 0;


	trace_control_word = 0;


/*  OUTPUT RELOCATION INFORMATION  */

/* First Two Words of Header */

	call cobol_reloc (addr (reloc_info), 4, 3002);

/* Remainder of Header and Fixed Internal Static Data */

	call cobol_reloc (null (), no_wds * 2 - 4, 3002);


/*  INITIALIZATION COMPLETE  */


exit:
	return;

     end cobol_link_init;




		    cobol_load_register.pl1         05/24/89  1041.5rew 05/24/89  0830.5       57447



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_load_register.pl1 Added Trace statements.
                                                   END HISTORY COMMENTS */


/* Modified on 10/19/85 by FCH, [5.3-1], BUG563(phx18381), new cobol_addr_tokens.incl.pl1 */
/* Modified on 01/17/77 by ORN to call cobol_make_reg_token instead of cobol_make_register_token */
/* Modified since Version 2.0 */

/*{*/
/* format: style3 */
cobol_load_register:
     proc (operand_token_ptr, register_token_ptr);

/*
This procedure generates code to load a value into either the A
or Q register.
*/

/*  DECLARATION OF THE PARAMETERS  */

dcl	operand_token_ptr	ptr;
dcl	register_token_ptr	ptr;

/*  DESCRIPTION OF THE PARAMETERS  */

/*
PaRaMETER		DEsCRIPTION

operand_token_ptr	Pointer to a token that describes the operand
		to be loaded into the register.  This token
		can be on of the following types:
		  1.  data name token (type 9) for a short
		   or long binary data item.
		  2. immediate constant token (type 102)
register_token_ptr	Pointer to a register token (type 100) that
		describes the register into which the operand
		is loaded.  If this pointer is null() on
		entry, then space for the token is provided
		to the user, and the value is
		loaded into either the A or Q register.
		(whichever is available)  If this pointer is not
		null, it must point to a register token
		(type 100) whose entry cobol_type100.register
		specifies the register which is to be loaded.
*/



/*}*/

/*  DECLARATION OF EXTERNAL ENTRIES  */

dcl	cobol_register$load ext entry (ptr);
dcl	cobol_make_reg_token
			ext entry (ptr, bit (4));
dcl	cobol_short_to_longbin$register
			ext entry (ptr, ptr);
dcl	cobol_addr	ext entry (ptr, ptr, ptr);
dcl	cobol_emit	ext entry (ptr, ptr, fixed bin);



/*  DECLARATION OF INTERNAL STATIC DATA  */

dcl	LDA		bit (10) int static init ("0100111010"b);
						/*  LDA  */
dcl	LDQ		bit (10) int static init ("0100111100"b);
						/*  LDQ  */
dcl	direct_lower_inst	bit (36) int static init ("000000000000000000000000000000000111"b);
						/*  zero,dl  */


/*  DECLARATION OF INTERNAL VARIABLES  */

dcl	1 input_buff	aligned,
	  2 buff		(1:10) ptr;

dcl	1 inst_buff	aligned,
	  2 buff		(1:2) fixed bin;

dcl	1 reloc_buff	aligned,
	  2 buff		(1:10) bit (5) aligned;

dcl	dn_ptr		ptr;


dcl	1 register_struc,
	  2 what_reg	fixed bin,
	  2 reg_no	bit (4),
	  2 lock		fixed bin,
	  2 already_there	fixed bin,
	  2 contains	fixed bin,
	  2 tok_ptr	ptr,
	  2 literal	bit (36);


/**************************************************/
start:
	if operand_token_ptr -> data_name.type = rtc_dataname
	then do;					/*  Operand to be loaded is long or short binary cobol data item.  */
		if operand_token_ptr -> data_name.bin_18
		then /*  Operand to be loaded is short binary.  */
		     call cobol_short_to_longbin$register (operand_token_ptr, register_token_ptr);

		else do;				/*  Operand to be loaded is a long binary data item.  */
						/*  Establish addressability to the operand.  */
			input_ptr = addr (input_buff);
			inst_ptr = addr (inst_buff);
			reloc_ptr = addr (reloc_buff);
			input_struc.type = 2;
			input_struc.operand_no = 1;
			input_struc.lock = 0;
			input_struc.operand.size_sw (1) = 0;
			input_struc.operand.token_ptr (1) = operand_token_ptr;
			call cobol_addr (input_ptr, inst_ptr, reloc_ptr);

			if register_token_ptr = null ()
			then register_struc.what_reg = 4;
						/*  A or Q  */
			else if register_token_ptr -> cobol_type100.register = "0001"b
			then register_struc.what_reg = 1;
						/*  A  */
			else register_struc.what_reg = 2;
						/*  Q  */

			register_struc.lock = 1;	/*  lock it  */
			register_struc.contains = 0;

			call cobol_register$load (addr (register_struc));

			if register_struc.reg_no = "0001"b
						/*  A  */
			then inst_struc_basic.fill1_op = LDA;
			else inst_struc_basic.fill1_op = LDQ;
			call cobol_emit (inst_ptr, reloc_ptr, 1);

			if register_token_ptr = null ()
			then call cobol_make_reg_token (register_token_ptr, register_struc.reg_no);
		     end;				/*  Operand to be loaded is a long binary data item.  */


	     end;					/*  Operand to be loaded is long or short binary cobol data item.  */

	else do;					/*  Operand to be loaded is an immediate constant.  */
		if register_token_ptr = null ()
		then register_struc.what_reg = 4;	/*  A or Q  */
		else if register_token_ptr -> cobol_type100.register = "0001"b
		then register_struc.what_reg = 1;	/*  A  */
		else register_struc.what_reg = 2;	/*  Q  */

		register_struc.lock = 1;
		register_struc.contains = 0;
		call cobol_register$load (addr (register_struc));

		if register_struc.reg_no = "0001"b	/*  A  */
		then substr (direct_lower_inst, 19, 10) = LDA;
		else substr (direct_lower_inst, 19, 10) = LDQ;
						/*  Insert the immediate value into the instruction  */
		substr (direct_lower_inst, 1, 18) =
		     substr (unspec (operand_token_ptr -> immed_const.const_value), 19, 18);
		call cobol_emit (addr (direct_lower_inst), null (), 1);

		if register_token_ptr = null ()
		then call cobol_make_reg_token (register_token_ptr, register_struc.reg_no);

	     end;					/*  Operand to be loaded is an immediate constant.  */

/*  INCLUDE FILES USED BY THIS PROCEDURE  */


/*****	Declaration for builtin function	*****/

dcl	(substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index)
			builtin;

/*****	End of declaration for builtin function	*****/

%include cobol_type9;
%include cobol_addr_tokens;
%include cobol_type102;
%include cobol_record_types;
%include cobol_type100;

     end cobol_load_register;




		    cobol_make_bin_const.pl1        05/24/89  1041.5rew 05/24/89  0830.5       80469



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_make_bin_const.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 02/11/77 by Bob Chang to fix the bug for numeric literal to comp-7 move.	*/
/* Modified on 1/14/77 by Bob Chang to search operator when pooling constant. */
/* Modified since Version 2.0.	*/
/*{*/

/* format: style3 */
cobol_make_bin_const:
     proc (nlit_ptr, return_token_ptr, target_code);

/*
This procedure converts the decimal representation of a numeric
literal into a fixed binary representation.  The fixed binary
value is either pooled in the constant section of a cobol
program, or returned in the output token from this procedure.
See DISCUSSION below for more details.
*/

/*  DECLARATION OF THE PARAMETERS  */

/*dcl nlit_ptr ptr;  */
/*  Declared below in an include file.  */
dcl	return_token_ptr	ptr;
dcl	target_code	fixed bin;

/*  DESCRIPTION OF THE PARAMETERS  */

/*
PARAMETER		DESCRIPTION

nlit_ptr		Pointer to the numeric literal token (type2)
		whose constant is to be converted to a binary
		constant. (input)

return_token_ptr	Pointer to a token that describes the
		converted binary constant.  If this pointer
		is null() on entry to this procedure,
		then the token spaxe will be provided by
		this procedure.  Otherwise this parameter
		must point to some work space in which the
		token will be built.
target_code	A code that specifies the type of arithemtic
		that is being done when this constant is
		being made.  (input)  This code has the
		following values:

		  target code	|  meaning
		==========================================
		   1		| short binary arithmetic
				| is being performed
		  2		| long binary arithmetic
				| is being performed
		    3		| short bin const pooled
		    4		| long bin const pooled
		===========================================
*/

/*  DISCUSSION

If the constant can be contained in a short fixed binary variable
(half-word), then the token built by and returned by this
procedure is an "immediate constant" token.  This token is
defined by the following declaration:

	dcl	1 immed_constant,
			2 size fixed bin(15),
			2 line fixed bin (15),
			2 column fixed bin (15),
			2 type fixed bin (15),  NOTE: type = 102
			2 constant_value fixed bin (35);

The binary representation of the numeric literal is returned
in the field "constant_value" of this token.
If the constant cannot be contained in a half-word, then the
binary representation is pooled into the constant section, and a long
fixed binary data name token (type 9) is returned.

*/

/*  DECLARATION OF EXTERNAL ENTRIES  */

dcl	cobol_pool$search_op
			ext entry (char (*), fixed bin, fixed bin (24), fixed bin);
dcl	cobol_make_type9$long_bin
			ext entry (ptr, fixed bin, fixed bin (24));
dcl	cobol_make_type9$short_bin
			ext entry (ptr, fixed bin, fixed bin (24));

/*  DECLARATION OF INTERNAL STATIC DATA  */

dcl	smallest_short_binary
			fixed dec (6, 0) int static init (-131072);
dcl	largest_short_binary
			fixed dec (6, 0) int static init (131071);
dcl	smallest_long_binary
			fixed dec (11, 0) int static init (-32359738358);
dcl	largest_long_binary fixed dec (11, 0) int static init (32359738357);


/*  DECLARATION OF INTERNAL VARIABLES  */

dcl	work_fdec		fixed dec (19, 0);
dcl	work_fdec_string	char (20) based (work_fdec_ptr);
dcl	double_binary	fixed bin (71);
dcl	temp		fixed bin,
	in_op		fixed bin;
dcl	work_fdec_ptr	ptr;

dcl	ret_offset	fixed bin (24);
dcl	long_bin_const	fixed bin (35);
dcl	long_bin_ptr	ptr;
dcl	long_bin_string	char (4) based (long_bin_ptr);
dcl	short_bin_const	fixed bin (35);
dcl	short_bin_ptr	ptr;
dcl	short_bin_const_bit bit (18);
dcl	short_bin_string	char (2) based (short_bin_ptr);


/**************************************************/
/*	START OF EXECUTION			*/
/*	cobol_make_bin_const  		*/
/**************************************************/

start:
	work_fdec = 0;

	if numeric_lit.places_left > 0
	then do;					/*  Numeric literal  has an integer part  */

		work_fdec_ptr = addr (work_fdec);
		if numeric_lit.sign = " "
		then substr (work_fdec_string, 1, 1) = "+";
		else substr (work_fdec_string, 1, 1) = numeric_lit.sign;

		substr (work_fdec_string, 21 - numeric_lit.places_left, numeric_lit.places_left) =
		     substr (numeric_lit.literal, 1, numeric_lit.places_left);
	     end;					/*  Numeric literal has an integer part.  */

	double_binary = binary (work_fdec);
	if target_code = 4
	then do;					/*  constant must be pooled into a long fixed bnary in the constant section  */
		if double_binary > largest_short_binary | double_binary < smallest_short_binary
		then do;
			substr (work_fdec_string, 2, 13) = (13)"0";
			double_binary = binary (work_fdec);
			if double_binary > largest_short_binary | double_binary < smallest_short_binary
			then do;
				substr (work_fdec_string, 15, 1) = "0";
				double_binary = binary (work_fdec);
			     end;
		     end;

		long_bin_const = binary (work_fdec);
		long_bin_ptr = addr (long_bin_const);
		call cobol_pool$search_op (long_bin_string, 0, ret_offset, in_op);
		if in_op = 0
		then temp = 3000;
		else temp = 3;

/*  Make a data name token for the long binary constant just pooled.  */
		call cobol_make_type9$long_bin (return_token_ptr, temp, ret_offset);

	     end;					/*  constant must be pooled into a fixed binary in the constant section  */
	else do;
		if double_binary > largest_long_binary | double_binary < smallest_long_binary
		then do;
			substr (work_fdec_string, 2, 8) = (8)"0";
			double_binary = binary (work_fdec);
			if double_binary > largest_long_binary | double_binary < smallest_long_binary
			then do;
				substr (work_fdec_string, 10, 1) = "0";
				double_binary = binary (work_fdec);
			     end;
		     end;
		if target_code = 3
		then do;

			short_bin_const = binary (work_fdec);
			short_bin_const_bit = substr (unspec (short_bin_const), 19, 18);
			short_bin_ptr = addr (short_bin_const_bit);
			call cobol_pool$search_op (short_bin_string, 0, ret_offset, in_op);
			if in_op = 0
			then temp = 3000;
			else temp = 3;

/*  Make a data name token for the short binary constant just pooled.  */
			call cobol_make_type9$short_bin (return_token_ptr, temp, ret_offset);

		     end;				/*  constant must be pooled into a fixed binary in the constant section  */
		else if (smallest_short_binary <= work_fdec & work_fdec <= largest_short_binary) & target_code = 1
		then do;				/*  Constant can be contained in a short fixed binary  */
						/*  AND target is short binary, OR the constant is positive or zero.  NOTE:  negative
		immediate constants cannot be used in long binary computations.  */

			if return_token_ptr = null ()
			then do;			/*  Make space for the token  */
				return_token_ptr = cobol_$temp_token_ptr;
				cobol_$temp_token_ptr = addrel (cobol_$temp_token_ptr, 5);
			     end;			/*  Make space for the token  */

			return_token_ptr -> immed_const.const_value = binary (work_fdec);
			return_token_ptr -> immed_const.type = 102;
		     end;				/*  Constant can be contained in a short fixed binary  */

		else do;				/*  constant must be pooled into a long fixed bnary in the constant section  */

			long_bin_const = binary (work_fdec);
			long_bin_ptr = addr (long_bin_const);
			call cobol_pool$search_op (long_bin_string, 0, ret_offset, in_op);
			if in_op = 0
			then temp = 3000;
			else temp = 3;

/*  Make a data name token for the long binary constant just pooled.  */
			call cobol_make_type9$long_bin (return_token_ptr, temp, ret_offset);

		     end;				/*  constant must be pooled into a fixed binary in the constant section  */
	     end;
exit:
	return;




/*****	Declaration for builtin function	*****/

dcl	(substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index)
			builtin;

/*****	End of declaration for builtin function	*****/

%include cobol_type2;

%include cobol_type102;

%include cobol_;


/**************************************************/
/*	END OF EXTERNAL PROCEDURE		*/
/*	cobol_make_bin_const		*/
/**************************************************/

     end cobol_make_bin_const;




		    cobol_make_fsb_link.pl1         05/24/89  1041.5rew 05/24/89  0830.5       33813



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8090),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8090 cobol_make_fsb_link.pl1 Disallow duplicate prime keys in Indexed
     Sequential files.
                                                   END HISTORY COMMENTS */


/* Modified on 12/14/84 by FCH, [5.3-1],  BUG573(phx16343), cobol_fsb_type_1.incl.pl1 changed */
/* Modified on 07/03/79 by FCH, [4.0-1], multiple sizes allowed for FSBs */
/* Modified on 01/11/79 by FCH, [3.0-1], size of FSB computed */
/* Modified since Version 3.0 */

/* format: style3 */
cobol_make_fsb_link_:
cobol_make_fsb_link:
     proc (ft_ptr);


declare	linkoff		fixed bin,
	ft_ptr		ptr;


	if first_call ^= cobol_$compile_count
	then do;
		alloc_space = 0;
		first_call = cobol_$compile_count;
	     end;


/*[4.0-1]*/
	if file_table.alternate_keys > 0 & file_table.organization = 3
	then fsb_init.n_words = size (fsb);
	else fsb_init.n_words = 155;

	call cobol_make_link$type_5 (linkoff, file_table.id, addr (fsb_init), alloc_space);

	file_table.fsb.seg = -linkoff;
	file_table.fsb.off = 0;

	return;


/*
	This procedure defines a type-5 link for a file state block. If an indexed
file having alternate record keys is being considered then the size of the link is
computed using the size builtin function.
*/


/* STATIC DECLARATIONS */

dcl	1 fsb_init	aligned static,
	  2 n_words	fixed bin (35) init (0),
	  2 code		fixed bin (35) init (3),
	  2 iocb_ptr	ptr init (null ()),
	  2 open_mode	fixed bin (35) init (0),
	  2 max_cra_size	fixed bin (35) init (0),
	  2 relkeylen	fixed bin (35) init (0),
	  2 relkey	fixed bin (35) init (0),
	  2 keylen_sw	fixed bin (35) init (0),
	  2 key		char (256) init (""),
	  2 open_close_name char (65) unal init (" "),	/*[5.3-1]*/
	  2 attach_flag	bit (27) unal init ("0"b),
	  2 linage_counter	char (8) aligned init ((8)"0"),
						/*[5.3-1]*/
	  2 indicators,				/*[5.3-1]*/
	    3 optional	bit (36) init ("0"b),	/*[5.3-1]*/
	    3 opened	bit (36) init ("0"b),	/*[5.3-1]*/
	    3 internal	bit (36) init ("001"b),	/*[5.3-1]*/
	  2 vfile_open_mode fixed bin (35) init (0),	/*[5.3-1]*/
	  2 file_desc_ptr	ptr init (null ()),		/*[5.3-1]*/
	  2 cobol_open_mode fixed bin (35) init (0),	/*[5.3-1]*/
	  2 last_cobol_op	fixed bin (35) init (0),	/*[5.3-1]*/
	  2 fsb_code	fixed bin (35) init (0),	/*[5.3-1]*/
	  2 key_of_ref	fixed bin (35) init (0),	/*[5.3-1]*/
	  2 prime_key	char (256) varying init (""), /*[5.3-1]*/
	  2 alt_key	char (256) varying init (""), /*[5.3-1]*/
	  2 descriptor	fixed bin (35) init (0),	/*[5.3-1]*/
	  2 last_key_read	char (256) varying init ("");

declare	(alloc_space, first_call)
			fixed bin static;

/* EXTERNAL ENTRY NAMES */

dcl	cobol_make_link$type_5
			entry (fixed bin, char (*), ptr, fixed bin);

/* BUILTIN FUNCTIONS */

dcl	(substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index, size)
			builtin;



%include cobol_fsb_type_1;
%include cobol_fsbskel;
%include cobol_file_table;
%include cobol_;
     end cobol_make_fsb_link;




		    cobol_make_link.pl1             05/24/89  1041.5rew 05/24/89  0830.5      109008



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_make_link.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 07/02/79 by FCH, [4.0-1], more than one size allowed for FSBs */
/* Modified on 12/29/78 by FCH, [3.0-2], size check for initialization data */
/* Modified on 07/18/78 by RAL, [3.0-1], changed linkage_header */
/* Modified since Version 3.0	*/

/* format: style3 */
cobol_make_link:
     proc;

/* this is an improper entry point */

	type = 0;
	module_name = "cobol_make_link";
	reset_loc = def_wd_off;
	call error (msg_9);
	return;

dcl	1 acc_string	aligned based (ds_wrk_ptr),
	  2 nam_lnth	bit (9) unaligned,
	  2 char_string	char (32) unaligned;

dcl	ds_strng		char (ds_lnth) based (def_base_ptr);
dcl	nam_strng		char (32) based (ds_wrk_ptr);

dcl	1 type_pair	aligned based (ds_wrk_ptr),
	  2 link_type	bit (18) unaligned,
	  2 trap_relp	bit (18) unaligned,
	  2 seg_name_relp	bit (18) unaligned,
	  2 ent_name_relp	bit (18) unaligned;

dcl	typ_pr_strng	char (8) based (ds_wrk_ptr);

dcl	1 expression_word	aligned based (ds_wrk_ptr),
	  2 type_pair_relp	bit (18) unaligned,
	  2 expression	bit (18) unaligned;

dcl	1 link		aligned based (ls_wrk_ptr),
	  2 header_relp	bit (18) unaligned,
	  2 ignore_1	bit (12) unaligned,
	  2 tag		bit (6) unaligned,
	  2 expr_word_relp	bit (18) unaligned,
	  2 ignore_2	bit (12) unaligned,
	  2 modifier	bit (6) unaligned;

dcl	1 linkage_header	aligned based (ls_wrk_ptr),
	  2 pad		bit (36),
	  2 def_sect_relp	bit (18) unaligned,
	  2 first_ref_relp	bit (18) unaligned,
	  2 obsolete_ptr	ptr unal,			/* [3.0-1] */
	  2 original_linkage_ptr
			ptr unal,			/* [3.0-1] */
	  2 unused	bit (72),			/* [3.0-1] */
	  2 links_relp	bit (18) unaligned,
	  2 link_sect_lgth	bit (18) unaligned,
	  2 object_seg	bit (18) unaligned,
	  2 obsolete_length bit (18) unaligned;

dcl	1 initialization_info
			aligned based (init_ptr),
	  2 n_words	fixed bin,
	  2 code		fixed bin,
	  2 info		(0 refer (n_words)) aligned bit (36);

dcl	init_info		char (262144) aligned based;

dcl	1 error_info	aligned,
	  2 module_name	char (32),
	  2 err_msg_lnth	fixed bin,
	  2 error_msg	char (168);

dcl	err_sw		fixed bin init (-1);

/*[4.0-1]*/
declare	1 init_areas	static internal,		/*[4.0-1]*/
	  2 size		fixed bin,		/* table size */
						/*[4.0-1]*/
	  2 entry		(16),			/*[4.0-1]*/
	    3 nwords	fixed bin,		/* area size */
						/*[4.0-1]*/
	    3 def_off	fixed bin;		/* offset in def section */

/*[4.0-1]*/
declare	res		fixed bin;

dcl	(ds_wrk_ptr, ls_wrk_ptr, init_ptr, type_pr_reloc_ptr)
			ptr;
dcl	(init_info_loc, seg_name_loc, ent_name_loc)
			fixed bin;
dcl	(lnk_typ, reset_loc, est_init_info_loc, express_loc)
			fixed bin;
dcl	(type_pair_loc, expr_word_loc, linkoff)
			fixed bin;
dcl	(i, j, type, x, segl, first, seg_code)
			fixed bin;
dcl	(nl, nwrds, next_loc, nchar, entl, name_sw)
			fixed bin;
dcl	(beg_link_loc, cur_link_loc, end_link_loc)
			fixed bin;
dcl	(exp_wd_loc, typ_pr_loc, name_loc, ds_lnth)
			fixed bin;
dcl	(n_lnks, n_args, code)
			fixed bin;
dcl	(ds_srch_ptr, ls_srch_ptr)
			ptr;
dcl	save_name_loc	fixed bin;
dcl	(lnk_offset, ln_lnth)
			fixed bin init (0);
dcl	name		char (*);
dcl	(linkoff_char, num_links_char)
			char (6);
dcl	(lo_lnth, nl_lnth)	fixed bin;
dcl	lo_char		char (lo_lnth) based (lo_ptr);
dcl	nl_char		char (nl_lnth) based (nl_ptr);
dcl	(lo_ptr, nl_ptr)	ptr;
dcl	ck_name		char (64);
dcl	link_name		char (ln_lnth) based (addr (ck_name));
dcl	temp		fixed bin;

type_5:
     entry (linkoff, name, init_ptr, est_init_info_loc);

	type = 5;
	module_name = "cobol_make_link$type_5 ";
	reset_loc = def_wd_off;			/* ck if space for type-5 link already established */
						/*[4.0-1]*/
	res = 1;					/*[4.0-1]*/
	nwrds = initialization_info.n_words;

/*[4.0-1]*/
	if est_init_info_loc = 0			/*[4.0-1]*/
	then do;
		est_init_info_loc = 1;		/*[4.0-1]*/
		init_areas.size = 0;		/*[4.0-1]*/
	     end;					/*[4.0-1]*/
	else do i = 1 by 1 to init_areas.size while (res = 1);

/*[4.0-1]*/
		if nwrds = init_areas.entry.nwords (i)
		then res = 0;

/*[4.0-1]*/
	     end;

/*[4.0-1]*/
	if res = 1				/*[4.0-1]*/
	then do;
		init_areas.size = init_areas.size + 1;	/*[4.0-1]*/
		init_areas.entry.nwords (init_areas.size) = nwrds;
						/*[4.0-1]*/
		init_areas.entry.def_off (init_areas.size) = def_wd_off;
						/*[4.0-1]*/
		init_info_loc = def_wd_off;		/*[4.0-1]*/
	     end;					/*[4.0-1]*/
	else init_info_loc = init_areas.entry.def_off (i - 1);

/*[4.0-1]*/
	ds_wrk_ptr = addrel (def_base_ptr, init_info_loc);

/*[4.0-1]*/
	nwrds = nwrds + 2;

	call ds_size_ck (nwrds);
	if (err_sw = 0)
	then return;

	nchar = fixed (substr (unspec (nwrds), 3, 36), 36);
	substr (ds_wrk_ptr -> init_info, 1, nchar) = substr (init_ptr -> init_info, 1, nchar);
						/* ck if init_info structure is being posted */
	if (init_info_loc = def_wd_off)
	then do;					/* yes, update def_wd_off and emit relocation info */
		def_wd_off = def_wd_off + nwrds;
		call cobol_reloc (null (), (2 * nwrds), 3003);
	     end;

	type_pr_reloc_ptr = addr (type_pr6_reloc);

	call create_acc_string;

	return;

type_4:
     entry (linkoff, name);

	type = 4;
	module_name = "cobol_make_link$type_4";
	reset_loc = def_wd_off;
	init_info_loc = 0;
	type_pr_reloc_ptr = addr (type_pr4_reloc);

	call create_acc_string;

	return;

create_acc_string:
     proc;

	if type = 5
	then seg_name_loc = 5;
	else seg_name_loc = def_wd_off;
	save_name_loc = def_wd_off;

	nl = index (name, " ") - 1;

	if (nl < 0)
	then nl = length (name);
	i = index (name, "$");

	if (i = 0)
	then do;
		entl = 0;
		segl = nl;
	     end;
	else do;
		entl = nl - i;
		segl = i - 1;
	     end;

	name_sw = 0;
	nchar = segl;
	first = 1;

	do while ("1"b);

	     ds_wrk_ptr = addrel (def_base_ptr, def_wd_off);
	     nam_lnth = substr (unspec (nchar), 28, 9);
	     nwrds = 1 + fixed (substr (unspec (nchar), 1, 34), 36);
						/* = 1+(nchar/4) */

	     call ds_size_ck (nwrds);
	     if (err_sw = 0)
	     then return;

	     substr (char_string, 1, nchar) = substr (name, first, nchar);
						/* before posting acc string, search def section to see
						   if an acc string for this "name" already exists  */
	     ds_lnth = def_wd_off * 4;
	     name_loc = index (ds_strng, substr (nam_strng, 1, nchar + 1)) - 1;

	     if (name_loc > -1)
	     then do;				/* acc strng for this name found,
						   ck whether seg_name or ent_name */
		     name_loc = divide (name_loc, 4, 17, 0);

		     if (name_sw = 0)
		     then if type ^= 5
			then seg_name_loc = name_loc;
			else do;
				seg_name_loc = 5;
				save_name_loc = name_loc;
			     end;
		     else ent_name_loc = name_loc;

		end;
	     else do;
		     def_wd_off = def_wd_off + nwrds;
		     call cobol_reloc (null (), (2 * nwrds), 3003);
		end;

	     if name_sw ^= 0
	     then do;
		     call create_type_pair;
		     return;
		end;

	     if (entl = 0)
	     then do;				/* link requested contains segment name only */
		     if type = 5
		     then ent_name_loc = save_name_loc;
		     else ent_name_loc = seg_name_loc;

		     call create_type_pair;

		     return;
		end;				/* link requested contains entry name,
						   reset parameters for entry name processing */
	     name_sw = 1;
	     nchar = entl;
	     first = i + 1;
	     ent_name_loc = def_wd_off;

	end;

     end;

type_1:
     entry (linkoff, seg_code);

	type = 1;
	module_name = "cobol_make_link$type_1";
	reset_loc = def_wd_off;
	seg_name_loc = seg_code;
	ent_name_loc, init_info_loc = 0;
	type_pr_reloc_ptr = addr (type_pr1_reloc);

	call create_type_pair;
	return;

create_type_pair:
     proc;

/*   The following operations are common to ALL link types    */

	ds_wrk_ptr = addrel (def_base_ptr, def_wd_off);
	type_pair_loc = def_wd_off;

	call ds_size_ck (3);
	if (err_sw = 0)
	then return;

	link_type = substr (unspec (type), 19, 18);
	trap_relp = substr (unspec (init_info_loc), 19, 18);
	seg_name_relp = substr (unspec (seg_name_loc), 19, 18);
	ent_name_relp = substr (unspec (ent_name_loc), 19, 18);
						/* before posting type-pair and expression word to
						   def section, check to see if a type 4 or 5 link
						   has already been made for this "name" */
	ds_lnth = def_wd_off * 4;
	typ_pr_loc = index (ds_strng, typ_pr_strng) - 1;

	if (typ_pr_loc > -1)
	then do;					/* type-pair for this link-type and "name" found,
						   calculate expr wrd loc for this type-pair
						   search link section to find link to this expr word
						   return offset of this already made link */
		typ_pr_loc = divide (typ_pr_loc, 4, 17, 0);
		exp_wd_loc = typ_pr_loc + 2;
		ls_wrk_ptr = link_base_ptr;
		beg_link_loc, cur_link_loc = fixed (substr (links_relp, 1, 18), 36);
		end_link_loc = beg_link_loc + fixed (substr (link_sect_lgth, 1, 18), 36);

/* bypass search until AFTER 1st link has been made */

		if ^(link_wd_off = beg_link_loc)
		then do;

srch_lp:
			ls_srch_ptr = addrel (link_base_ptr, cur_link_loc);
			expr_word_loc = fixed (substr (ls_srch_ptr -> expr_word_relp, 1, 18), 36);

			if (exp_wd_loc = expr_word_loc)
			then do;			/* link found, return offset to this link */
				linkoff = cur_link_loc;
				return;
			     end;

			cur_link_loc = cur_link_loc + 2;

			if (cur_link_loc < end_link_loc)
			then goto srch_lp;

		     end;
	     end;

/* link not found, post type-pair, update def_wd_off
				   and emit relocation information for this link type */
	def_wd_off = def_wd_off + 2;
	call cobol_reloc (type_pr_reloc_ptr, 4, 3003);

	ds_wrk_ptr = addrel (def_base_ptr, def_wd_off);
	expr_word_loc = def_wd_off;
	type_pair_relp = substr (unspec (type_pair_loc), 19, 18);
	expression = (18)"0"b;
	def_wd_off = def_wd_off + 1;

	call cobol_reloc (addr (expr_word_reloc), 2, 3003);


	ls_wrk_ptr = link_base_ptr;
	if (link_sect_lgth = "0"b)
	then link_sect_lgth = links_relp;

	ls_wrk_ptr = addrel (link_base_ptr, link_wd_off);

	linkoff = link_wd_off;

	call ls_size_ck (2);
	if (err_sw = 0)
	then return;

	string (link) = "000000000000000000000000000000100110"b;
	temp = -link_wd_off;
	header_relp = substr (unspec (temp), 19, 18);
	expr_word_relp = substr (unspec (expr_word_loc), 19, 18);
	link_wd_off = link_wd_off + 2;
	ls_wrk_ptr = link_base_ptr;
	temp = fixed (link_sect_lgth, 18) + 2;
	link_sect_lgth = substr (unspec (temp), 19, 18);

	call cobol_reloc (addr (link_reloc), 4, 3002);

     end;

size_ck:
     proc;
dcl	(ds_size_ck, ls_size_ck)
			entry;
dcl	block_size	fixed bin;

ds_size_ck:
     entry (block_size);

	next_loc = def_wd_off + block_size;

	if (next_loc > def_max)
	then do;
		call error (msg_5);
		return;
	     end;
	return;

ls_size_ck:
     entry (block_size);

	next_loc = link_wd_off + block_size;

	if (next_loc > link_max)
	then do;
		call error (msg_6);
		return;
	     end;
     end size_ck;

error:
     proc (err_msg);

dcl	err_msg		char (*);
dcl	l_name		char (68);

	if (type = 1)
	then l_name = "type-1";
	else if ((type = 4) | (type = 5))
	then l_name = name;
	else if (type = 0)
	then l_name = "";

	call ioa_$rsnnl ("^a ABORTING type ^o link -> ""^a""", error_msg, err_msg_lnth, err_msg, type, l_name);
	call signal_ ("command_error", null, addr (error_info));

	linkoff = 0;
	err_sw = 0;
	def_wd_off = reset_loc;
     end error;

%include cobol_make_link_info;
%include cobol_make_link_data;

     end cobol_make_link;




		    cobol_make_list.pl1             05/24/89  1041.5rew 05/24/89  0830.5       84024



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_make_list.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 06/26/81 by FCH, [4.4-1], print_text_ replaced by cobol_display_text */
/* Modified on 05/16/80 by FCH, [4.2-2], decl for  tag_addr corrected */
/* Modified on 02/28/79 by PRP, [4.2-1], size of input programs increased */
/* Modified on 10/25/79 by PRP, [4.1-1],  statement output modified */
/* Modified on 08/05/79 by FCH, [4.0-1], debug statement */
/* Modified since Version 4.0 */

/* format: style3 */
cobol_make_list:
     proc (code_ptr, code_length);

dcl	code_ptr		ptr;
dcl	(p, q)		ptr;
dcl	len_ptr		ptr;
dcl	code_length	fixed bin (24);
dcl	word_count	fixed bin (24);
dcl	instr_word_num	fixed bin;
dcl	line_length	fixed bin (24);
dcl	obj_off		fixed bin (18);
dcl	last_word_off	fixed bin (35);
dcl	stmt_no		fixed bin;
dcl	file_num		fixed bin (35);
dcl	line_num		fixed bin (35);
dcl	prev_file_num	fixed bin (35);
dcl	prev_line_num	fixed bin (35);
dcl	fl_length		fixed bin;
dcl	source_stmt_count	fixed bin;
dcl	(i, j, k1, k2, k3, n)
			fixed bin (24);
dcl	(k4, k5)		fixed bin (24);
dcl	(s1, s2, number)	fixed bin (35);
dcl	token_type	fixed bin;
dcl	text_off		fixed bin (24);
dcl	label_off		fixed bin (24);
dcl	label_count	fixed bin;
dcl	mcode		fixed bin (35);
dcl	char7		char (7);
dcl	char9		char (9);
dcl	segname		char (37);
dcl	output_switch	char (10) aligned;
dcl	len		fixed bin based (len_ptr);
dcl	c1		char (4) based (p);
dcl	c2		char (4) based (q);
dcl	source		char (256) based (cobol_sfp);
dcl	print_line	char (256) varying aligned;
dcl	1 map_data_table	aligned based (cobol_$map_data_ptr),
	  2 no_source_stmts fixed bin aligned,
	  2 data		(0 refer (map_data_table.no_source_stmts)),
	    3 line_no	fixed bin unaligned,
	    3 text_addr	fixed bin unaligned,
	    3 col		fixed bin unaligned,
	    3 label	bit unaligned;		/*[4.2-2]*/
declare	1 DEF		aligned based (cobol_$tag_table_ptr),
						/*[4.2-2]*/
	  2 tag_max	fixed bin,		/*[4.2-2]*/
	  2 TAG		(32767),			/*[4.2-2]*/
	    3 tag_addr	fixed bin (17) unal,	/*[4.2-2]*/
	    3 tag_no	fixed bin (17) unal;

dcl	list_iocb_ptr	ptr static init (null ());

dcl	cobol_display_text	entry (ptr, fixed bin, char (*) aligned);
dcl	ioa_$ioa_stream	entry options (variable);
dcl	com_err_		entry options (variable);
dcl	iox_$attach_ioname	entry (char (*), ptr, char (*), fixed bin (35));
dcl	iox_$open		entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
dcl	iox_$close	entry (ptr, fixed bin (35));
dcl	iox_$detach_iocb	entry (ptr, fixed bin (35));

dcl	cleanup		condition;

dcl	addr		builtin;
dcl	addrel		builtin;
dcl	divide		builtin;
dcl	fixed		builtin;
dcl	index		builtin;
dcl	mod		builtin;
dcl	null		builtin;
dcl	pointer		builtin;
dcl	rel		builtin;
dcl	substr		builtin;

	call cleanup_proc;
	on cleanup call cleanup_proc;

	segname = substr (cobol_$obj_seg_name, 1, index (cobol_$obj_seg_name, " ") - 1) || ".list";
	call iox_$attach_ioname ("cobol_out_", list_iocb_ptr, "vfile_ " || segname || " -extend", mcode);

	if mcode ^= 0
	then go to error;

	call iox_$open (list_iocb_ptr, 2, "1"b, mcode);

	if mcode ^= 0
	then do;
error:
		call cleanup_proc;
		revert cleanup;
		call com_err_ (mcode, "cobol");
		return;
	     end;

	output_switch = "cobol_out_";
	p = addr (s1);
	q = addr (s2);

	call ioa_$ioa_stream (output_switch, "^|^a^/", "OBJECT CODE");

	word_count = 1;
	obj_off = fixed (rel (code_ptr), 18) - cobol_$constant_offset;
	last_word_off = obj_off + code_length;
	stmt_no = 1;
	prev_line_num = 0;
	prev_file_num = 0;
	source_stmt_count = 1;
	text_off = text_addr (1);
	label_count = 0;
	label_off = -1;

	if fixed_common.proc_counter > 0
	then do;

		len_ptr = pointer (cobol_ntfp, 8);
		proc_def_ptr = pointer (cobol_ntfp, 8);
		token_type = proc_def.type;

		do while (token_type ^= 18 & len > 0);

		     len_ptr = addrel (proc_def_ptr, divide (len + 11, 8, 17, 0) * 2);
		     proc_def_ptr = len_ptr;
		     token_type = proc_def.type;
		end;

		if len > 0
		then label_off = cobol_$tag_table_ptr -> tag_addr (proc_def.proc_num);
	     end;

	do while (word_count <= code_length);
	     if obj_off = cobol_$non_source_offset
	     then do;

		     call ioa_$ioa_stream (output_switch, "^/^a^/", "ADDITIONAL CODE");
		     text_off = last_word_off;

		end;
	     else do;

		     do while (obj_off = label_off);

			if proc_def.type = 18
			then do;

				if ^proc_def.section_name
				then call ioa_$ioa_stream (output_switch, "^a.",
					substr (proc_def.name, 1, proc_def.name_size));
				else call ioa_$ioa_stream (output_switch, "^a section.",
					substr (proc_def.name, 1, proc_def.name_size));

			     end;

			label_count = label_count + 1;

			if label_count <= fixed_common.proc_counter
			then do;

				token_type = 0;

				do while (token_type ^= 18 & len > 0);

				     len_ptr = addrel (proc_def_ptr, divide (len + 11, 8, 17, 0) * 2);
				     proc_def_ptr = len_ptr;
				     token_type = proc_def.type;

				end;

				if len > 0
				then label_off = cobol_$tag_table_ptr -> tag_addr (proc_def.proc_num);

			     end;
			else label_off = -1;
		     end;

		     do while (obj_off = text_off);

			eln_index = line_no (source_stmt_count);

			if eln_index > 0
			then do;
				file_num = eln_tab.fno (eln_index);
				line_num = eln_tab.lno (eln_index);

				if file_num = prev_file_num & line_num = prev_line_num
				then stmt_no = stmt_no + 1;
				else do;

					stmt_no = 1;
					prev_file_num = file_num;
					prev_line_num = line_num;

				     end;

				s1 = mod (stmt_no, 10) + 48;
				fl_length = 0;

				if file_num > 0
				then do;

					number = file_num;

					do i = 2 to 1 by -1 while (number > 0);

					     s2 = mod (number, 10) + 48;
					     substr (char7, i, 1) = substr (c2, 4, 1);
					     number = divide (number, 10, 35, 0);
					     j = i;

					end;

					fl_length = 3 - j;
					char9 = substr (char7, j, fl_length);
					fl_length = fl_length + 1;
					substr (char9, fl_length, 1) = "-";

				     end;

				number = line_num;

				do i = 7 to 1 by -1 while (number > 0);

				     s2 = mod (number, 10) + 48;
				     substr (char7, i, 1) = substr (c2, 4, 1);
				     number = divide (number, 10, 35, 0);
				     j = i;

				end;

				substr (char9, fl_length + 1, 8 - j) = substr (char7, j, 8 - j);
				fl_length = fl_length + 8 - j;
				print_line =
				     "STATEMENT " || substr (c1, 4, 1) || " ON LINE "
				     || substr (char9, 1, fl_length);

				call ioa_$ioa_stream (output_switch, "^7-^a", print_line);

				if file_num = 0
				then if stmt_no = 1
				     then do;	/* Print the actual source line. */

					     if source_stmt_count = 1
					     then do;
						     print_line = "PROCEDURE DIVISION.";
						     call ioa_$ioa_stream (output_switch, "^a", print_line);

						end;
					     else do;


/*[4.1-1]*/
						     k1 = statement_info.start (eln_index);
						     k2 = 0;
						     k3 = map_data_table.line_no (source_stmt_count + 1);
						     k5 = k3 - eln_index;

						     if k5 > 1
						     then do;

							     do k4 = 1 to k5
								while (file_num
								= eln_tab.fno (eln_index + k4));
								k2 = k2
								     + statement_info
								     .length (eln_index + k4 - 1) + 1;
							     end;
							end;

						     else k2 = statement_info.length (eln_index) + 1;
						     print_line = substr (source, k1, k2);

						     call ioa_$ioa_stream (output_switch, "^4x^a", print_line)
							;


						end;
					end;
			     end;

			if source_stmt_count < no_source_stmts
			then do;

				source_stmt_count = source_stmt_count + 1;
				text_off = text_addr (source_stmt_count);

			     end;
			else text_off = cobol_$non_source_offset;
		     end;
		end;

	     instr_word_num = text_off - obj_off;

/*[4.4-1]*/
	     call cobol_display_text (code_ptr, instr_word_num, output_switch);
	     call ioa_$ioa_stream (output_switch, "");

	     code_ptr = addrel (code_ptr, instr_word_num);
	     word_count = word_count + instr_word_num;
	     obj_off = obj_off + instr_word_num;

	end;

	call ioa_$ioa_stream (output_switch, "^/^a", "END OBJECT CODE");

	call cleanup_proc;
	revert cleanup;

cleanup_proc:
     proc;

	if list_iocb_ptr ^= null ()
	then do;

		call iox_$close (list_iocb_ptr, mcode);
		call iox_$detach_iocb (list_iocb_ptr, mcode);

		list_iocb_ptr = null ();

	     end;

     end cleanup_proc;


%include cobol_;
%include cobol_eln_table;

%include cobol_fixed_common;

%include cobol_ext_;

%include cobol_type7;

     end cobol_make_list;




		    cobol_make_merge_file.pl1       05/24/89  1041.5rew 05/24/89  0830.5       61758



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8082),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8082 cobol_make_merge_file.pl1 Fix wild array subscript.
                                                   END HISTORY COMMENTS */


/* Modified on 02/22/85 by FCH, [5.3-1], dont clobber fixed common, BUG561 */
/* Modified on 02/20/85 by FCH, [5.3...], Trace added */
/* Modified on 11/23/76 by Bob Chang to change the external bit of merge file table.	*/
/* Created on 11/17/76 by Bob Chang to set up the temporary merge file.	*/





/* format: style3 */
cobol_make_merge_file:
     proc (name_ptr, file_ptr, type12_ptr, type9_ptr);

dcl	name_ptr		ptr,
	dn_ptr		ptr,
	ft_ptr_save	(20) ptr static,
	first_call	fixed bin static init (0),
	merge_count	fixed bin static,
	ft_ptr		ptr;
dcl	stop_bit		bit (1),
	temp_id		char (5),
	temp_no		fixed bin,
	status_code	fixed bin (35),
	(i, j)		fixed bin,
	rec_id		char (5);
dcl	1 temp_type9	static,
	  2 header	(4) fixed bin init (112, 0, 0, 9),
	  2 repl_ptr	(2) ptr init ((2) null ()),
	  2 fill1		bit (108) init (""b),
	  2 file_key_info,
	    3 fb1		(3) fixed bin init (0, 0, 0),
	    3 size	fixed bin init (0),
	    3 fb2		(2) fixed bin init (0, 0),
	    3 flags1	bit (36) init ("000000100100000000010000000100000000"b),
	    3 flags2	bit (36) init (""b),
	    3 seg		fixed bin init (0),
	    3 off		fixed bin,
	  2 fill2		(7) fixed bin init (0, 0, 0, 0, 0, 0, 0);
dcl	temp_type12	char (60),
	(merge_ft_ptr, merge_file_ptr)
			ptr,
	temp_file_ptr	(20) ptr static,
	temp_type12_ptr	(20) ptr static,
	(file_ptr, type12_ptr, type9_ptr)
			ptr,
	temp_based	char (1024) based,
	temp_file		char (1024),
	temp_type9_ptr	(20) ptr static;

dcl	cobol_read_rand	entry (fixed bin, char (5), ptr),
	cobol_read_ft	entry (fixed bin, ptr),
	cobol_alloc$stack	entry (fixed bin, fixed bin, fixed bin),
	cobol_io_$cobol_vdwf_sput
			entry (ptr, fixed bin (35), ptr, fixed bin, char (5)),
	cobol_make_fsb_link entry (ptr);

start:	/***.....	if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME);/**/
						/*[5.3-1]*/
	merge_file_ptr = addrel (cobol_com_ptr, 8 + size (fixed_common));
	if first_call = cobol_$compile_count
	then do i = 1 to merge_count;
		if ft_ptr_save (i) -> file_table.max_cra_size = temp_file_ptr (i) -> file_table.max_cra_size
		then do;
			file_ptr = temp_file_ptr (i);
			type9_ptr = temp_type9_ptr (i);
			type12_ptr = temp_type12_ptr (i);
			go to mfex;
		     end;
	     end;
	else do;
		merge_count = 0;
		first_call = cobol_$compile_count;
	     end;

	merge_count = merge_count + 1;
	i = fd_token.file_no;
	call cobol_read_ft (i, ft_ptr_save (merge_count));

	temp_type12_ptr (merge_count) = addr (temp_type12);
	temp_file_ptr (merge_count) = addr (temp_file);
	temp_type9_ptr (merge_count) = addr (temp_type9);
	rec_id = fixed_common.filedescr_offsets (1);
	stop_bit = "0"b;

	do while (^stop_bit);
	     call cobol_read_rand (1, rec_id, ft_ptr);
	     rec_id = file_table.next;
	     if rec_id = "00000"
	     then stop_bit = "1"b;
	end;

	substr (temp_type12, 1, 60) = substr (name_ptr -> temp_based, 1, 60);
	temp_no = file_table.file_no + 1;
	temp_type12_ptr (merge_count) -> fd_token.file_no = temp_no;
	i = fd_token.file_no;
	call cobol_read_ft (i, merge_ft_ptr);

	substr (temp_file, 1, 1024) = substr (merge_ft_ptr -> temp_based, 1, 1024);
						/*[5.3-1]*/
	call cobol_io_$cobol_vdwf_sput (merge_file_ptr, status_code, addr (temp_file), 1024, temp_id);

	file_table.next = temp_id;
	if temp_no <= 20
	then fixed_common.filedescr_offsets (temp_no) = temp_id;
	call cobol_read_rand (1, temp_id, ft_ptr);

/*	setup temporary file table.	*/
	file_table.temp = "1"b;
	file_table.ao_len = 0;
	file_table.cat_nm = "cobol_temp_merge_file_";
	file_table.id = "cobol_temp_merge_switch_";
	file_table.device = 6;
	file_table.catalogued = 0;
	file_table.ifn = "cobol_merge_ifn_";
	file_table.external = "1"b;
	file_table.file_status = "0"b;
	file_table.extra_status = "0"b;
	file_table.cra_seg = 1000;
	i = file_table.max_cra_size;
	file_table.file_no = temp_no;
	file_table.max_cra_size = ft_ptr_save (merge_count) -> file_table.max_cra_size;
	file_table.rec_do = ft_ptr_save (merge_count) -> file_table.rec_do;
	call cobol_alloc$stack (i, 2, j);

	file_table.cra_offset = j * 4;
	cobol_$init_stack_off = cobol_$stack_off;

	call cobol_make_fsb_link (ft_ptr);

	temp_file_ptr (merge_count) = ft_ptr;
	temp_type12_ptr (merge_count) -> fd_token.type = 12;
	temp_type9_ptr (merge_count) -> data_name.seg_num = file_table.cra_seg;
	temp_type9_ptr (merge_count) -> data_name.offset = file_table.cra_offset;
	temp_type9_ptr (merge_count) -> data_name.file_num = file_table.file_no;
	temp_type9_ptr (merge_count) -> data_name.item_length = file_table.max_cra_size;

/*[5.3-1]*/
	call cobol_io_$cobol_vdwf_sput (merge_file_ptr, status_code, temp_type9_ptr (merge_count), 112, temp_id);
	call cobol_read_rand (1, temp_id, temp_type9_ptr (merge_count));
						/*[5.3-1]*/
	call cobol_io_$cobol_vdwf_sput (merge_file_ptr, status_code, temp_type12_ptr (merge_count), 60, temp_id);
	call cobol_read_rand (1, temp_id, temp_type12_ptr (merge_count));

	file_ptr = temp_file_ptr (merge_count);
	type12_ptr = temp_type12_ptr (merge_count);
	type9_ptr = temp_type9_ptr (merge_count);

mfex:	/***.....	if Trace_Bit then call cobol_gen_driver_$Tr_End(MY_NAME);/**/
	return;

	/***.....	dcl cobol_gen_driver_$Tr_Beg entry(char(*));/**/
	/***.....	dcl cobol_gen_driver_$Tr_End entry(char(*));/**/

	/***.....	dcl Trace_Bit bit(1) static external;/**/
	/***.....	dcl Trace_Lev fixed bin static external;/**/
	/***.....	dcl Trace_Line char(36) static external;/**/
	/***.....	dcl ioa_ entry options(variable); /**/
	/***..... dcl MY_NAME char (21) int static init ("COBOL_MAKE_MERGE_FILE");/**/

/*****	Declaration for builtin function	*****/

dcl	(substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, size, index)
			builtin;

/*****	End of declaration for builtin function	*****/


%include cobol_fixed_common;

%include cobol_file_table;

%include cobol_type12;

%include cobol_type9;

%include cobol_ext_;
%include cobol_;


     end cobol_make_merge_file;




		    cobol_make_object_map.pl1       05/24/89  1041.5rew 05/24/89  0830.5       44595



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */





/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_make_object_map.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 04/01/81 by FCH, fix decl for map_data_table, [4.4-1], BUG472(TR8869,8970) */
/* Modified since Version 4.4 */

/* format: style3 */
cobol_make_object_map:
     proc;

/* Produces an Object Map in the List segment when "map" option is specified. */

dcl	p		ptr;
dcl	q		ptr;
dcl	(ff, nl)		char (1);
dcl	c		char (4) based (addr (s));
dcl	bit9		bit (9) based;
dcl	(i, j, t)		fixed bin;
dcl	char_off		fixed bin (21);
dcl	number		fixed bin (35);
dcl	s		fixed bin (35);
dcl	mcode		fixed bin (35);
dcl	char_string	char (1048576) based (cobol_$list_ptr);
dcl	print_line	char (120) unaligned based;

dcl	1 map_line	unaligned based,
	  2 map_field	(7) unaligned,
	    3 line_field	char (7),
	    3 sp1		char (1),
	    3 loc_field	char (6),
	    3 sp2		char (3),
	  2 new_line_char	char (1) unaligned;

dcl	1 file_line	unaligned based (q),
	  2 file_fld	char (2),
	  2 sp1		char (1),
	  2 line_fld	char (4);

dcl	1 header_line	unaligned based,
	  2 form_feed_char	char (1),
	  2 new_line_char1	char (1),
	  2 header_field	char (119),
	  2 new_line_char2	char (1);

dcl	1 map_data_table	aligned based (cobol_$map_data_ptr),
	  2 no_source_stmts fixed bin aligned,
	  2 data		(0 refer (map_data_table.no_source_stmts)),
	    3 line_no	fixed bin unaligned,
	    3 text_addr	fixed bin unaligned,	/*[4.4-1]*/
	    3 col		fixed bin unal,		/*[4.4-1]*/
	    3 label	bit unal;

dcl	hcs_$set_bc_seg	entry (ptr, fixed bin (24), fixed bin (35));

dcl	addr		builtin;
dcl	divide		builtin;
dcl	mod		builtin;
dcl	substr		builtin;

	addr (ff) -> bit9 = "000001100"b;		/* form feed char */
	addr (nl) -> bit9 = "000001010"b;		/* new line char */
	char_off = cobol_$list_off;

	p = addr (substr (char_string, char_off, 1));
	p -> header_line.form_feed_char = ff;
	p -> header_line.new_line_char1 = nl;
	p -> header_line.header_field = (7)"   LINE    LOC   ";
	p -> header_line.new_line_char2 = nl;
	char_off = char_off + 122;
	p = addr (substr (char_string, char_off, 1));
	p -> print_line = " ";
	j = 1;

	do i = 1 to no_source_stmts;
	     eln_index = line_no (i);
	     if eln_index > 0
	     then do;
		     number = eln_tab.fno (eln_index);

		     if number > 0
		     then do;			/* copy file */

			     q = addr (p -> line_field (j));

			     do t = 2 to 1 by -1 while (number > 0);

				s = mod (number, 10) + 48;
						/* "0" = 48(decimal) */
				substr (file_fld, t, 1) = substr (c, 4, 1);
				number = divide (number, 10, 35, 0);
			     end;
			     number = eln_tab.lno (eln_index);
			     do t = 4 to 1 by -1 while (number > 0);
				s = mod (number, 10) + 48;
						/* "0" = 48(decimal) */
				substr (line_fld, t, 1) = substr (c, 4, 1);
				number = divide (number, 10, 35, 0);

			     end;
			end;
		     else do;			/* normal source */

			     number = eln_tab.lno (eln_index);

			     do t = 6 to 1 by -1 while (number > 0);

				s = mod (number, 10) + 48;
						/* "0" = 48(decimal) */
				substr (p -> line_field (j), t, 1) = substr (c, 4, 1);
				number = divide (number, 10, 35, 0);

			     end;
			end;

/* Fill location field. */

		     number = text_addr (i) + cobol_$constant_offset;
		     p -> loc_field (j) = "000000";

		     do t = 6 to 1 by -1 while (number > 0);

			s = mod (number, 8) + 48;	/* "0" = 48(decimal) */
			substr (p -> loc_field (j), t, 1) = substr (c, 4, 1);
			number = divide (number, 8, 35, 0);
		     end;
		     if j = 7
		     then do;
			     p -> map_line.new_line_char = nl;
			     char_off = char_off + 120;
			     j = 1;
			     p = addr (substr (char_string, char_off, 1));
			     p -> print_line = " ";

			end;

		     else j = j + 1;

		end;

	end;

	if j > 1
	then do;					/* print last partial line */

		number = 17 * (j - 1) + 1;
		substr (p -> char_string, number, 1) = nl;
		char_off = char_off + number;

	     end;

	cobol_$list_off = char_off;

	call hcs_$set_bc_seg (cobol_$list_ptr, 9 * (cobol_$list_off - 1), mcode);

%include cobol_;
%include cobol_eln_table;

     end cobol_make_object_map;




		    cobol_make_reg_token.pl1        05/24/89  1041.5rew 05/24/89  0830.5       30645



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_make_reg_token.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Renamed on 01/17/77 by ORN from cobol_make_register_token to cobol_make_reg_token */
/* Modified on 01/14/77 by ORN to signal command_error rather than cobol_compiler_error */
/* Modified since Version 2.0 */

/*{*/
/* format: style3 */
cobol_make_reg_token:
     proc (token_ptr, reg_no);

/* create a token (type 100) for registers */
dcl	token_ptr		ptr;
dcl	reg_no		bit (4);			/*
 token_ptr  is a pointer to the token (input/output)
	(a) if not null the caller will provide the space
	to hold the token.
	(b) if null this utility will provide the space
	and will return the address of the token
	in this parameter.
 reg_no	is the register number (input)
		"0001"b - A register.
		"0010"b - Q register.
		"0011"b - A and Q register.
		"1nnn"b - index register nnn.
 notes:
 1. The token will have the following description.
   (a) A standard token header, (type of 100, size set,
       and the remainder zeros).
 2. A field defined as bit (4).

*/
						/*}*/

dcl	1 token_overflow	static,
	  2 name		char (32) init ("cobol_make_reg_token"),
	  2 message_len	fixed bin (35) init (58),
	  2 message	char (58) init ("The temporary token area has run over the end of a segment");
dcl	signal_		entry (char (*), ptr, ptr);
dcl	1 clear_token	aligned based (cobol_type100_ptr),
	  2 clear_token_wd	(token_wd_size) fixed bin;
dcl	token_wd_size	fixed bin init (5);		/* size of token in words */
dcl	i		fixed bin;


/*************************************/
start:						/* get space for token (if not provided) */
	if token_ptr = null ()
	then do;
		if (binary (rel (cobol_$temp_token_ptr)) + token_wd_size) > 262143
		then do;				/* token will not fit in temp token area */
			call signal_ ("command_error", null (), addr (token_overflow));
			return;
		     end;
		token_ptr = cobol_$temp_token_ptr;
		cobol_$temp_token_ptr = addrel (cobol_$temp_token_ptr, token_wd_size);
	     end;

/* setup token */

	cobol_type100_ptr = token_ptr;		/* clear token to zeros */
	do i = 1 to token_wd_size;
	     clear_token_wd (i) = 0;
	end;
	cobol_type100.type = 100;
	cobol_type100.size = 4 * (token_wd_size);
	cobol_type100.register = reg_no;
	return;

/*****	Declaration for builtin function	*****/

dcl	(substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index)
			builtin;

/*****	End of declaration for builtin function	*****/

%include cobol_type100;
%include cobol_;

     end cobol_make_reg_token;




		    cobol_make_type3.pl1            05/24/89  1041.5rew 05/24/89  0830.5       23022



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_make_type3.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/*{*/

/* Modified on 1/22/76 by Bob Chang to put comments	*/

/* format: style3 */
cobol_make_type3:
     proc (alit_ptr, rw_ptr);
type1:
     entry (alit_ptr, rw_ptr);

/* Create a type 3 token (alphanumeric literal) using a type 1 token
	   (reserve word) as a model. It is used for the reserve words quote,
	   space, zero, high value, low-value.				*/

dcl	lit		char (1);
dcl	alit_chars	char (24) based (alit_ptr);
dcl	alit_init_chars	char (24) based (addr (alit_init));
dcl	1 alit_init	static,
	  2 size		fixed bin init (29),
	  2 line		fixed bin,
	  2 column	fixed bin,
	  2 type		fixed bin init (3),
	  2 lit_type	bit (1) init ("0"b),
	  2 all_lit	bit (1) init ("0"b),
	  2 filler1	bit (6),
	  2 lit_size	fixed bin init (1);



/*}*/
/*************************************/
start:
	if reserved_word.key = 192
	then lit = " ";				/* space */
	else if reserved_word.key = 180
	then lit = "0";				/* zero */
	else if reserved_word.key = 235
	then lit = """";				/* quote */
	else if reserved_word.key = 229
	then lit = "";				/* low-value */
	else lit = "";				/* high-value */
	alit_chars = alit_init_chars;
	alphanum_lit.line = reserved_word.line;
	alphanum_lit.column = reserved_word.column;
	substr (alphanum_lit.string, 1, 1) = lit;
	return;


/*************************************/

/*****	Declaration for builtin function	*****/

dcl	(substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index)
			builtin;

/*****	End of declaration for builtin function	*****/

%include cobol_type1;
%include cobol_type3;
     end cobol_make_type3;




		    cobol_make_type9.pl1            05/24/89  1041.5rew 05/24/89  0830.5      108954



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_make_type9.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 04/20/77 by Bob Chang to add new entry copy_sub.	*/
/* Modified on 01/14/77 by ORN to signal command_abort_ rather than cobol_compiler_error */
/* Modified since Version 2.0 */

/*{*/
/* format: style3 */
cobol_make_type9:
     proc (new9_ptr, ptr2_3);				/* the procedure is not a valid entry point*/
						/*}*/
						/*  DECLARATIONS OF BUILTIN FUNCTIONS  */

dcl	addr		builtin;
dcl	addrel		builtin;
dcl	binary		builtin;
dcl	null		builtin;
dcl	rel		builtin;
dcl	substr		builtin;



/*{*/

/* TYPE2_3 ENTRY */

type2_3:
     entry (new9_ptr, ptr2_3);			/*
create a type 9 token, using a type 2 token (numeric literal)
or a type3 token (alphanumeric literal) as a model. Pool the
literal in the type 2 or type 3 token.
*/
dcl	new9_ptr		ptr;
dcl	old9_ptr		ptr;
dcl	ptr2_3		ptr;			/*
 new9_ptr	is a pointer to the type 9 token. (input/output)
	(a) If not null the caller will provide the space
	    to hold the token.
	(b) If null this utility will provide the space and
	    will return the address of the
	    token in this parameter.
 ptr2_3	is a pointer to a type 2 or a type 3 token. (input)
*/
						/*}*/
dcl	1 token_overflow	static,
	  2 name		char (32) init ("cobol_make_type9"),
	  2 message_len	fixed bin (35) init (58),
	  2 message	char (58) init ("The temporary token area has run over the end of a segment");
dcl	1 con_overflow	static,
	  2 name		char (32) init ("cobol_make_type9"),
	  2 message_len	fixed bin (35) init (60),
	  2 message	char (60) init ("object time instructions plus constants exceed 262,144 words");
dcl	cobol_pool$search_op
			entry (char (*), fixed bin, fixed bin (24), fixed bin);
dcl	signal_		entry (char (*), ptr, ptr);
dcl	1 clear_t9	aligned based (dn_ptr),
	  2 clear_t9_wd	(t9_wd_size) fixed bin;
dcl	1 clear_t9_sub	aligned based (dn_ptr),
	  2 clear_t9_sub_wd (t9_sub_wd_size) fixed bin;
dcl	t9_string		char (t9_char_size) based;
dcl	t9_sub_string	char (t9_sub_char_size) based;
dcl	hold_lit		char (4096);
dcl	lit_size		fixed bin;
dcl	lit_wds		fixed bin;
dcl	t9_char_size	static fixed bin init (112);	/* size of type 9 token in chars */
dcl	t9_sub_char_size	static fixed bin init (176);	/* size of type 9 token in chars */
dcl	t9_wd_size	static fixed bin init (28);	/* size of type 9 token in words */
dcl	t9_sub_wd_size	static fixed bin init (44);	/* size of type 9 token in words */
dcl	dn_ptr		ptr;
dcl	i		fixed bin;
/**** change to 1048576 when get release 1.0  ***/
dcl	pool		char (262144) based (pool_ptr);
dcl	pool_ptr		ptr;
dcl	pool_index	fixed bin (24);
dcl	pool_remainder	fixed bin (24);
dcl	index_result	fixed bin (24);
dcl	temp		fixed bin (24);
dcl	in_op		fixed bin;

/* get space for type 9 token (if not provided) */
	call get_token9_space;

/* put information in the token */

/* setup basic information in the token */
	call basic_info;
	data_name.display = "1"b;
	alit_ptr = ptr2_3;
	nlit_ptr = ptr2_3;
	data_name.seg_num = 3000;			/* constants */
	if numeric_lit.type = 2
	then do;					/* numeric literal (type 2) */
		data_name.places_left = numeric_lit.places_left;
		data_name.places_right = numeric_lit.places_right;
		data_name.numeric = "1"b;
		if numeric_lit.sign ^= " "
		then do;				/* signed literal */
			data_name.item_signed = "1"b;
			data_name.sign_separate = "1"b;
			data_name.sign_type = "100"b;
			lit_size = numeric_lit.places + 1;
			hold_lit = numeric_lit.sign || numeric_lit.literal;
		     end;
		else do;
			lit_size = numeric_lit.places;
			hold_lit = numeric_lit.literal;
		     end;
		data_name.item_length = lit_size;
	     end;
	else do;					/* alphanumeric literal (type 3) */
		lit_size = alphanum_lit.lit_size;
		hold_lit = alphanum_lit.string;
		data_name.alphanum = "1"b;
		data_name.item_length = alphanum_lit.lit_size;
	     end;

	call cobol_pool$search_op (substr (hold_lit, 1, lit_size), 0, temp, in_op);
						/*6/10/76*/
	if in_op = 1
	then data_name.seg_num = 3;
	data_name.offset = temp;
	return;					/*{*/

/* COPY ENTRY*/

copy:
     entry (new9_ptr, old9_ptr);			/*
This entry creates a type 9 token by copying another
type 9 token.
*/
						/*
 new9_ptr	is a pointer to the new type 9 token.
	See cobol_make_type9$type2_3 for additional
	details. (input/output)
 old9_ptr	is a pointer to the original type 9
	token. (input)
*/
						/*}*/

/* get space for type 9 token (if not provided) */
	call get_token9_space;			/* copy the token */
	substr (new9_ptr -> t9_string, 1, t9_char_size) = substr (old9_ptr -> t9_string, 1, t9_char_size);
	return;


copy_sub:
     entry (new9_ptr, old9_ptr);			/*
This entry creates a type 9 token by copying another
type 9 token.
*/
						/*
 new9_ptr	is a pointer to the new type 9 token.
	See cobol_make_type9$type2_3 for additional
	details. (input/output)
 old9_ptr	is a pointer to the original type 9
	token. (input)
*/
						/*}*/

/* get space for type 9 token (if not provided) */
	call get_token9_sub_space;			/* copy the token */
	substr (new9_ptr -> t9_sub_string, 1, t9_sub_char_size) =
	     substr (old9_ptr -> t9_sub_string, 1, t9_sub_char_size);
	return;					/*{*/

/* ALPHANUMERIC ENTRY*/

alphanumeric:
     entry (new9_ptr, segno, char_offset, size);		/* create a type 9 token for an alphanumeric data item. */

dcl	segno		fixed bin;
dcl	char_offset	fixed bin (24);
dcl	size		fixed bin (24);

/*
 new9_ptr	is a pointer to the type 9 token.
	See cobol_make_type9$type2_3 for additional details.
	(input/output)
 segno	is the artificial internal segment number, that can
	represent cobol data, stack, constant, multics linkage
	section. (including an offset from the link),
	definition section, symbol section, cobol linkage
	section.
	(input)
 char_offset is the character offset. If segno represents a
	constant, then char_offset represents the
	offset from the end of the constants.
	(input)
 size	is the size, in characters. (input)

 Notes:	the token will be cleared to zeros initially.
 */
/*}*/

/* get space for type 9 token (if not provided) */
	call get_token9_space;			/* set up basic information in the token */
	call basic_info;
	data_name.display = "1"b;
	data_name.seg_num = segno;
	data_name.offset = char_offset;
	data_name.alphanum = "1"b;
	data_name.item_length = size;
	return;					/*{*/

/* DECIMAL_9BIT ENTRY */

decimal_9bit:
     entry (new9_ptr, segno, char_offset, places_left, places_right);
						/* create a type 9 token for a 9 bit decimal data item */

/*dcl	segno fixed bin; */
/*dcl	char_offset fixed bin (24); */
dcl	places_left	fixed bin;
dcl	places_right	fixed bin;		/*
 new9_ptr	see "cobol_make_type9$alphanumeric",
	(input/output)
 segno	is the artificial internal segment number,
	that can represent cobol data, stack,constant,
	cobol linkage section. (input)
 char_offset  See "cobol_make_type9$alphanumeric".
	(input)
 places_left is the number of digits left of the decimal point.
	Does not include sign.
	(input)
 places_right is the number of digits right of the
	decimal point. (input)

 Notes:
 1. The sign is assumed to be leading and seperate.
   the size of the data item is assumed to be
   places_left + places_right + 1.
   The caller can modify this if the need arises.
 2. The token will be cleared to zeros initially.
 */
						/*}*/

/* get space for type 9 token (if not provided) */
	call get_token9_space;			/* set up basic information in the token */
	call basic_info;
	data_name.display = "1"b;
	data_name.seg_num = segno;
	data_name.offset = char_offset;
	data_name.places_left = places_left;
	data_name.places_right = places_right;
	data_name.item_length = places_left + places_right + 1;
	data_name.numeric = "1"b;
	data_name.item_signed = "1"b;
	data_name.sign_separate = "1"b;
	data_name.sign_type = "100"b;			/*  leading separate  */
	return;					/*{*/

/*FIXED_BIN_35 ENTRY */

fixed_bin_35:
     entry (new9_ptr, segno, char_offset);		/* create a type 9 token for  a fixed bin 35 data item */

/*dcl	segno fixed bin; */
/*dcl	char_offset fixed bin (24); */

/*
See "cobol_make_type9$decimal_9bit" for definitions of
the above.

 Notes:
 The token will be cleared to zeros initially.

*/
/*}*/

/* get space for a type 9 token (if not provided) */
	call get_token9_space;			/* set up basic information in the token */
	call basic_info;
	data_name.seg_num = segno;
	data_name.offset = char_offset;

/****** Note, need to set data_name.comp_8 ****/

	return;


/* the following is used as a non local go to */

non_local:
	return;



/*{*/

/*  SHORT BINARY ENTRY  */

short_bin:
     entry (new9_ptr, segno, char_offset);

/*  Create a type 9 token for a short binary (18 bit) data item.  */


/*  new9_ptr,segno, and char_offset are the same as for all
other entry points in this procedure.  */

/*}*/

/*  Get space for type 9 token (if requested)  */
	if new9_ptr = null ()
	then call get_token9_space;

/*  Set up basic information in the token.  */
	call basic_info;

/*  Set up particular information in the token.  */
	data_name.numeric = "1"b;
	data_name.bin_18 = "1"b;
	data_name.half_word = "1"b;
	data_name.seg_num = segno;
	data_name.offset = char_offset;
	data_name.item_length = 2;
	data_name.places_left = 6;

	return;

/*{*/

/*  LONG BINARY ENTRY  */

long_bin:
     entry (new9_ptr, segno, char_offset);

/*  Create a type 9 token for a long binary (36 bit) data item.  */


/*  Get space for type 9 token (if requested.)  */
	if new9_ptr = null ()
	then call get_token9_space;

/*  Set up basic information in the token.  */
	call basic_info;

/*  Set up particular information in the token.  */
	data_name.numeric = "1"b;
	data_name.bin_36 = "1"b;
	data_name.word = "1"b;
	data_name.seg_num = segno;
	data_name.offset = char_offset;
	data_name.item_length = 4;
	data_name.places_left = 11;

	return;

/* GET_TOKEN9_SPACE PROC */

get_token9_space:
     proc;

/* get space for type 9 token (if not provided) */

	if new9_ptr = null ()
	then do;
		if (binary (rel (cobol_$temp_token_ptr)) + t9_wd_size) > 262143
		then do;				/* token will not fit in temp token area */
			call signal_ ("command_abort_", null (), addr (token_overflow));
			go to non_local;
		     end;
		new9_ptr = cobol_$temp_token_ptr;
		cobol_$temp_token_ptr = addrel (cobol_$temp_token_ptr, t9_wd_size);
	     end;
	return;
     end get_token9_space;
get_token9_sub_space:
     proc;

/* get space for type 9 token (if not provided) */

	if new9_ptr = null ()
	then do;
		if (binary (rel (cobol_$temp_token_ptr)) + t9_sub_wd_size) > 262143
		then do;				/* token will not fit in temp token area */
			call signal_ ("command_abort_", null (), addr (token_overflow));
			go to non_local;
		     end;
		new9_ptr = cobol_$temp_token_ptr;
		cobol_$temp_token_ptr = addrel (cobol_$temp_token_ptr, t9_sub_wd_size);
	     end;
	return;
     end get_token9_sub_space;

/* BASIC_INFO PROC */

basic_info:
     proc;					/* setp basic information in type 9 token */
	dn_ptr = new9_ptr;				/* clear  token to zeros */
	do i = 1 to t9_wd_size;
	     clear_t9_wd (i) = 0;
	end;
	data_name.type = 9;
	data_name.elementary = "1"b;
	data_name.size = t9_char_size;
	return;
     end basic_info;
%include cobol_type2;
%include cobol_type3;
%include cobol_;
%include cobol_type9;
     end cobol_make_type9;




		    cobol_make_xref_.pl1            05/24/89  1041.5rew 05/24/89  0830.5      200025



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_make_xref_.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 11/03/81 by FCH, char6 replaced by char8, [5.1-1], phx10955(BUG496) */
/* Modified on 05/16/80 by FCH, [4.2-1], decl for tag_addr corrected */
/* Modified on 07/08/77 by GM to fix  binary output on cross ref. */
/* Modified on 02/10/77 by ORN to include cd-name info and misc changes */
/* Modified on 01/19/77 by ORN to give occurs info and full class description */
/* Modified since Version 2.0 */

/* format: style3 */
cobol_make_xref_:
     proc;

/* Produces an Cross-Reference Listing in the List segment when "symbols" option is specified. */

dcl	(p, q)		ptr;
dcl	line_ptr		ptr;
dcl	dn_ptr		ptr;
dcl	name_ptr		ptr;
dcl	ft_ptr		ptr;
dcl	(ff, nl)		char (1);			/*[5.1-1]*/
dcl	char8		char (8);
dcl	char9		char (9);
dcl	p_type		char (1);
dcl	picture_string	char (15);
dcl	noxref		char (35);
dcl	c		char (4) based (q);
dcl	name_string	char (30) varying;
dcl	bit9		bit (9) based;
dcl	bit36		bit (36) based (addr (number));
dcl	(i, n, t)		fixed bin;
dcl	char_off		fixed bin (21);
dcl	char_offset	fixed bin;
dcl	c_off		fixed bin;
dcl	cv_length		fixed bin;
dcl	fl_length		fixed bin;
dcl	cv_off		fixed bin;
dcl	name_length	fixed bin;
dcl	left		fixed bin;
dcl	tag_loc		fixed bin;
dcl	number		fixed bin (35);
dcl	s		fixed bin (35);
dcl	mcode		fixed bin (35);		/*[4.2-1]*/
declare	1 DEF		aligned based (cobol_$tag_table_ptr),
						/*[4.2-1]*/
	  2 tag_max	fixed bin,		/*[4.2-1]*/
	  2 TAG		(32767),			/*[4.2-1]*/
	    3 tag_addr	fixed bin (17) unal,	/*[4.2-1]*/
	    3 tag_no	fixed bin (17) unal;
dcl	code_generated	bit (1);
dcl	alpha		bit (1);
dcl	numeric		bit (1);
dcl	edited		bit (1);
dcl	varying		bit (1);
dcl	fixed_binary	bit (1);
dcl	char_string	char (1048576) based (cobol_$list_ptr);
dcl	line		char (120) based (line_ptr);
dcl	maxlen_id		char (23) based (line_ptr);
dcl	1 print_line	unaligned based (line_ptr),
	  2 identifier	char (18),
	  2 filler1	char (2),
	  2 level_no	char (2),
	  2 filler2	char (2),
	  2 type		char (4),
	  2 filler3	char (2),
	  2 offset	char (6),
	  2 bit_offset	char (4),
	  2 redef		char (1),
	  2 filler4	char (1),
	  2 usage		char (15),
	  2 filler5	char (1),
	  2 occ		char (2),
	  2 filler6	char (2),
	  2 pic_string	char (15),
	  2 filler7	char (2);
dcl	def_ref		char (100) based (line_ptr);
dcl	1 header_line	unaligned based (line_ptr),
	  2 form_feed_char	char (1),
	  2 new_line_char1	char (1),
	  2 header_field	char (82),
	  2 new_line_char2	char (1),
	  2 new_line_char3	char (1);
dcl	1 token		based,
	  2 size		fixed bin (15),
	  2 line		fixed bin (15),
	  2 column	fixed bin (15),
	  2 type		fixed bin (15);
dcl	1 c_n		based (p),
	  2 size		fixed bin (15),
	  2 line		fixed bin (15),
	  2 column	fixed bin (7),
	  2 type		fixed bin (7),		/* type = 11 */
	  2 string_ptr	ptr,
	  2 prev_rec	ptr,
	  2 info		bit (8),
	  2 def_line	fixed bin (15),
	  2 level		fixed bin (7),
	  2 num_lits	fixed bin (15),
	  2 name_size	fixed bin (7),
	  2 name		char (c_n.name_size);

dcl	display_sign	(0:4) char (6) static init ("eric", " trovr", " ldovr", " trsep", " ldsep");

dcl	hcs_$set_bc_seg	entry (ptr, fixed bin (24), fixed bin (35));
dcl	cobol_read_ft	entry (fixed bin, ptr);
dcl	ioa_		entry options (variable);

dcl	addr		builtin;
dcl	addrel		builtin;
dcl	divide		builtin;
dcl	fixed		builtin;
dcl	length		builtin;
dcl	mod		builtin;
dcl	substr		builtin;

dcl	dn		(1000) char (1) based (dn_ptr);
						/* used for calculating type 9 extension offsets */



/*************************************/
start:
	call sort_tokens;

	addr (ff) -> bit9 = "000001100"b;		/* form feed char */
	addr (nl) -> bit9 = "000001010"b;		/* new line char */
	q = addr (s);
	code_generated = fixed_common.fatal_no = 0;
	char_off = cobol_$list_off;
	line_ptr = addr (substr (char_string, char_off, 1));
	if cobol_$xref_bypass
	then do;
		noxref = "NO CROSS-REFERENCE LISTING PRODUCED";
		line = nl || noxref || nl;
		char_off = char_off + 37;
		go to finish_up;
	     end;
	header_line.form_feed_char = ff;
	header_line.new_line_char1 = nl;
	header_line.header_field =
	     "IDENTIFIER	LN  TYPE  OFFSET	  USAGE/CLASS     DM  PICTURE          DEF. REF. LINES";
	header_line.new_line_char2 = nl;
	header_line.new_line_char3 = nl;
	char_off = char_off + 86;
	line_ptr = addr (substr (char_string, char_off, 1));
	line = " ";
	do i = 1 to token_count;
	     p = token_ptr (i);
	     go to token_type (p -> token.type);

token_type (7):					/* Procedure Definition (label) */
token_type (18):					/* Procedure Reference (label reference) */
	     proc_def_ptr = p;
	     name_string = proc_def.name;
	     call fill_identifier (23);
	     print_line.type = "TEXT";
	     if code_generated
	     then do;
		     tag_loc = cobol_$tag_table_ptr -> tag_addr (proc_def.proc_num);
		     do while (tag_loc < 0);
			tag_loc = cobol_$tag_table_ptr -> tag_addr (-tag_loc);
		     end;
		     number = cobol_$constant_offset + tag_loc;
		     call convert_word_offset;
		end;
	     if proc_def.section_name
	     then print_line.usage = "section-name";
	     else print_line.usage = "paragraph-name";
	     eln_index = proc_def.def_line;
	     go to next;

token_type (9):					/* Data-Name */
	     dn_ptr = p;
	     if data_name.name = "FILLER"
	     then go to token_type (0);
	     if data_name.name = "SYSTEM-STATUS" | data_name.name = "TALLY" | data_name.name = "LINAGE-COUNTER"
	     then go to token_type (0);
	     fixed_binary = "0"b;
	     name_string = data_name.name;
	     call fill_identifier (19);
	     number = data_name.level;
	     call convert10;			/*[5.1-1]*/
	     print_line.level_no = substr (char8, 7, 2);
	     if data_name.working_storage
	     then do;
		     print_line.type = "DATA";
		     number = data_name.offset;
		     call convert_offset;
		end;
	     else if data_name.constant_section
	     then do;
		     print_line.type = "CNST";
		     if code_generated
		     then do;
			     number = data_name.offset;
			     char_offset = fixed (substr (bit36, 35, 2), 17);
			     number = cobol_$constant_offset - fixed (substr (bit36, 1, 34), 35);
			     call convert_word_offset;
			     call convert_bit_offset;
			end;
		end;
	     else if data_name.file_section
	     then do;
		     print_line.type = "FREC";
		     number = data_name.offset;
		     call convert_offset;
		end;
	     else if data_name.communication_section
	     then do;
		     print_line.type = "CREC";
		     number = data_name.offset;
		     call convert_offset;
		end;
	     else if data_name.linkage_section
	     then do;
		     print_line.type = "PARM";
		     number = data_name.offset;
		     call convert_offset;
		     number = data_name.linkage;
		     call convert10;
		     if data_name.level = 01 | data_name.level = 77
		     then do;
			     print_line.bit_offset = "";
			     print_line.offset = substr (char8, cv_off, cv_length);
			end;
		     else if substr (print_line.offset, 1, cv_length + 1) = substr ("000000", 1, cv_length + 1)
		     then substr (print_line.offset, 1, cv_length + 1) = substr (char8, cv_off, cv_length) || "/";
		     else do;
			     print_line.bit_offset = "";
			     print_line.offset = substr (char8, cv_off, cv_length) || "/.....";
			end;
		end;
	     if data_name.display
	     then do;
		     if data_name.numeric
		     then print_line.usage = "DSPLY num" || display_sign (fixed (data_name.sign_type, 17));
		     else if data_name.alphanum
		     then print_line.usage = "DSPLY alphanum";
		     else if data_name.numeric_edited
		     then print_line.usage = "DSPLY num-edit";
		     else if data_name.alphabetic
		     then print_line.usage = "DSPLY alphabet";
		     else print_line.usage = "DSPLY alph-edit";
		end;
	     else if data_name.non_elementary
	     then print_line.usage = "GROUP alphanum";
	     else if data_name.usage_index
	     then print_line.usage = "INDEX";
	     else if data_name.ascii_packed_dec_h
	     then print_line.usage = "COMP8 numeric";
	     else if data_name.ascii_packed_dec
	     then print_line.usage = "COMP5 numeric";
	     else if data_name.bin_18
	     then do;
		     print_line.usage = "COMP7 numeric";
		     print_line.pic_string = "S9(6)  bin(17)";
		     fixed_binary = "1"b;
		end;
	     else if data_name.bin_36
	     then do;
		     print_line.usage = "COMP6 numeric";
		     print_line.pic_string = "S9(11)  bin(35)";
		     fixed_binary = "1"b;
		end;
	     else if data_name.ebcdic_packed_dec
	     then print_line.usage = "COMP3 numeric";
	     else if data_name.bin_16
	     then do;
		     print_line.usage = "COMP1 numeric";
		     print_line.pic_string = "S9(5)  bin(15)";
		     fixed_binary = "1"b;
		end;
	     else if data_name.bin_32
	     then do;
		     print_line.usage = "COMP2 numeric";
		     print_line.pic_string = "S9(9)  bin(31)";
		     fixed_binary = "1"b;
		end;
	     if data_name.occurs_ptr ^= 0
	     then do;
		     occurs_ptr = addr (dn (data_name.occurs_ptr));
		     if occurs.dimensions = 1
		     then print_line.occ = " 1";
		     else if occurs.dimensions = 2
		     then print_line.occ = " 2";
		     else print_line.occ = " 3";
		     if data_name.occurs_do
		     then substr (print_line.occ, 1, 1) = "*";
		end;
	     else print_line.occ = "";

	     if data_name.s_of_rdf
	     then print_line.redef = "r";
	     else print_line.redef = "";

	     if ^fixed_binary
	     then do;
		     edited = data_name.alphanum_edited | data_name.alphabetic_edited | data_name.numeric_edited;
		     varying = data_name.pic_has_l | data_name.pic_is_do;
		     if edited & varying
		     then print_line.pic_string = "EDITED,VARYING";
		     else do;
			     alpha = "0"b;
			     numeric = "0"b;
			     if data_name.alphanum | data_name.alphanum_edited | data_name.non_elementary
			     then do;
				     alpha = "1"b;
				     picture_string = "X(";
				     c_off = 3;
				end;
			     else if data_name.alphabetic | data_name.alphabetic_edited
			     then do;
				     alpha = "1"b;
				     picture_string = "A(";
				     c_off = 3;
				end;
			     else do;
				     numeric = data_name.numeric | data_name.numeric_edited;
				     picture_string = " ";
				     c_off = 1;
				end;
			     if alpha
			     then do;
				     number = data_name.item_length;
				     call convert10;
				     substr (picture_string, c_off, cv_length + 1) =
					substr (char8, cv_off, cv_length) || ")";
				     c_off = c_off + cv_length + 1;
				end;
			     else if numeric
			     then do;
				     left = data_name.places_left;
				     if data_name.numeric
				     then if data_name.item_signed
					then if data_name.display | data_name.ascii_packed_dec
						| data_name.ascii_packed_dec_h
					     then do;
						     substr (picture_string, c_off, 1) = "S";
						     c_off = 2;
						end;
				     if left < 0
				     then do;
					     p_type = "P";
					     number = -left;
					     call fill_pic_field;
					end;
				     else if left > 0 & data_name.places_right > 0
				     then do;
					     p_type = "9";
					     number = left;
					     call fill_pic_field;
					     left = 0;
					end;
				     if left = 0
				     then do;
					     substr (picture_string, c_off, 1) = "V";
					     c_off = c_off + 1;
					end;
				     p_type = "9";
				     number = left + data_name.places_right;
				     call fill_pic_field;
				     if data_name.places_right < 0
				     then do;
					     p_type = "P";
					     number = -data_name.places_right;
					     call fill_pic_field;
					end;
				end;
			     if edited
			     then if c_off > 12
				then picture_string = "EDITED";
				else if c_off > 10
				then substr (picture_string, c_off) = "EDIT";
				else substr (picture_string, c_off) = "EDITED";
			     else if varying
			     then if c_off > 13
				then picture_string = "VARYING";
				else if c_off > 9
				then substr (picture_string, c_off) = "VAR";
				else substr (picture_string, c_off) = "VARYING";
			     print_line.pic_string = picture_string;
			end;
		end;
	     eln_index = data_name.def_line;
	     go to next;


token_type (10):					/* Index-Name */
	     ind_ptr = p;
	     name_string = substr (index_name.name, 1, index_name.name_size);
	     call fill_identifier (23);
	     print_line.type = "DATA";
	     number = index_name.offset;
	     call convert_offset;
	     print_line.usage = "index-name";
	     eln_index = index_name.def_line;
	     go to next;

token_type (11):					/* Condition Name */
	     name_string = c_n.name;
	     call fill_identifier (19);
	     print_line.level_no = "88";
	     print_line.usage = "CONDITION NAME";
	     eln_index = c_n.def_line;
	     go to next;

token_type (12):					/* File Name */
	     print_line.level_no = "FD";
join_file:
	     name_ptr = p;
	     name_string = fd_token.name;
	     call fill_identifier (19);
	     call cobol_read_ft (fd_token.file_no, ft_ptr);
	     print_line.type = "FILE";
	     number = file_table.cra_offset;
	     call convert_offset;
	     if p -> token.type = 16
	     then print_line.usage = "SORT";
	     else do;				/* Fill in file organization and access. */
		     go to org (file_table.organization);
org (0):
org (1):
		     print_line.usage = "SEQ";
		     go to fill_access;
org (2):
		     print_line.usage = "REL";
		     go to fill_access;
org (3):
		     print_line.usage = "INX";
		     go to fill_access;
org (4):
org (5):
		     print_line.usage = "STR";
		     go to fill_access;
fill_access:
		     go to acc (file_table.access);
acc (0):
acc (1):
		     substr (print_line.usage, 4, 4) = "/SEQ";
		     go to fill_device;
acc (2):
		     substr (print_line.usage, 4, 4) = "/RND";
		     go to fill_device;
acc (3):
		     substr (print_line.usage, 4, 4) = "/DYN";
		     go to fill_device;
fill_device:
		     go to dev (file_table.device);
dev (0):
dev (6):
		     substr (print_line.usage, 8, 8) = " virtual";
		     go to end_fd;
dev (1):
		     substr (print_line.usage, 8, 8) = " printer";
		     go to end_fd;
dev (2):
		     substr (print_line.usage, 8, 8) = " cardrdr";
		     go to end_fd;
dev (3):
		     substr (print_line.usage, 8, 8) = " cardpch";
		     go to end_fd;
dev (4):
		     substr (print_line.usage, 8, 8) = " disk";
		     go to end_fd;
dev (5):
		     substr (print_line.usage, 8, 8) = " tape";
		     go to end_fd;
dev (7):
dev (8):
dev (9):
dev (10):
end_fd:
		     if file_table.external
		     then substr (print_line.usage, 14, 3) = "ext";
		     picture_string = "X(";
		     c_off = 3;
		     number = file_table.max_cra_size;
		     call convert10;
		     substr (picture_string, c_off, cv_length + 1) = substr (char8, cv_off, cv_length) || ")";
		     c_off = c_off + cv_length + 1;
		     print_line.pic_string = picture_string;
		end;
	     eln_index = fd_token.def_line;
	     go to next;

token_type (13):
	     cdtoken_ptr = p;
	     print_line.level_no = "CD";
	     name_string = cdtoken.name;
	     call fill_identifier (19);
	     print_line.type = "COMM";
	     if cdtoken.options.input
	     then print_line.usage = "cd-name(input)";
	     else print_line.usage = "cd-name(output)";
	     eln_index = cdtoken.def_line;
	     go to next;
token_type (16):
	     print_line.level_no = "SD";
	     go to join_file;

token_type (17):
	     name_ptr = p;
	     name_string = mnemonic_name.name;
	     call fill_identifier (23);
	     print_line.type = "SYS";
	     print_line.usage = "mnemonic-name";
	     eln_index = mnemonic_name.def_line;
	     go to next;

token_type (40):
	     alpha_name_ptr = p;
	     name_string = alphabet_name.name;
	     call fill_identifier (23);
	     if alphabet_name.iw_key ^= 0
	     then print_line.type = "SYS";
	     else print_line.type = "CNST";
	     print_line.usage = "alphabet-name";
	     eln_index = alphabet_name.def_line;
	     go to next;


next:
	     call fill_def_ref;
	     line_ptr = addr (substr (char_string, char_off, 1));
	     line = " ";

token_type (0):
token_type (1):
token_type (2):
token_type (3):
token_type (4):
token_type (5):
token_type (6):
token_type (8):
token_type (14):
token_type (15):
token_type (19):
token_type (20):
	end;

finish_up:
	cobol_$list_off = char_off;
	call hcs_$set_bc_seg (cobol_$list_ptr, 9 * (cobol_$list_off - 1), mcode);
exit:
	return;



/*************************************/
fill_def_ref:
     proc;

	char_off = char_off + 79;
	line_ptr = addr (substr (char_string, char_off, 1));
	substr (def_ref, 1, 4) = "def ";
	call file_line;
	substr (def_ref, 5, fl_length) = substr (char9, 1, fl_length);
	c_off = fl_length + 6;
	n = addrel (p, divide (p -> token.size + 3, 4, 17, 0)) -> xref_chain.first;
	if n = 0
	then do;
		substr (def_ref, c_off, 5) = "NOREF";
		c_off = c_off + 5;
	     end;
	else do;
		substr (def_ref, c_off, 3) = "ref";
		c_off = c_off + 3;
		do while (n > 0);
		     eln_index = ref_line (n);
		     call file_line;
		     if c_off + fl_length > 39
		     then do;			/* close this line and start new line */
			     substr (def_ref, c_off, 1) = nl;
			     char_off = char_off + c_off;
			     substr (char_string, char_off, 16) = (7)"	" || (9)" ";
						/* 7 tabs + 9 spaces */
			     char_off = char_off + 16;
			     line_ptr = addr (substr (char_string, char_off, 1));
			     def_ref = " ";
			     c_off = 1;
			end;
		     else c_off = c_off + 1;		/* insert space between def-ref line nos */
		     substr (def_ref, c_off, fl_length) = substr (char9, 1, fl_length);
		     c_off = c_off + fl_length;
		     n = chain_area.next (n);
		end;
	     end;
	substr (def_ref, c_off, 1) = nl;
	char_off = char_off + c_off;

     end fill_def_ref;

file_line:
     proc;

	fl_length = 0;
	if eln_index ^= 0
	then number = eln_tab.fno (eln_index);
	else number = 0;
	if number > 0
	then do;
		call convert10;
		substr (char9, 1, cv_length) = substr (char8, cv_off, cv_length);
		fl_length = cv_length + 1;
		substr (char9, fl_length, 1) = "-";
	     end;
	if eln_index ^= 0
	then number = eln_tab.lno (eln_index);
	else number = 1;
	call convert10;
	substr (char9, fl_length + 1, cv_length) = substr (char8, cv_off, cv_length);
	fl_length = fl_length + cv_length;

     end file_line;

fill_pic_field:
     proc;

	substr (picture_string, c_off, 1) = p_type;
	c_off = c_off + 1;
	substr (picture_string, c_off, 1) = "(";
	c_off = c_off + 1;
	call convert10;
	substr (picture_string, c_off, cv_length) = substr (char8, cv_off, cv_length);
	c_off = c_off + cv_length;
	substr (picture_string, c_off, 1) = ")";
	c_off = c_off + 1;

     end fill_pic_field;

fill_identifier:
     proc (max);
dcl	max		fixed bin parameter;

	name_length = length (name_string);
	if name_length > max
	then do;
		line = name_string || nl;
		char_off = char_off + name_length + 1;
		line_ptr = addr (substr (char_string, char_off, 1));
		line = " ";
	     end;
	else substr (maxlen_id, 1, max) = name_string;

     end fill_identifier;

convert_offset:
     proc;

	char_offset = fixed (substr (bit36, 35, 2), 17);
	number = fixed (substr (bit36, 1, 34), 35);
	call convert_word_offset;

convert_bit_offset:
     entry;
	if p -> data_name.type = 9
	then if data_name.bit_offset ^= ""b
	     then go to half_byte_off (char_offset);
	go to byte_off (char_offset);
byte_off (1):
	print_line.bit_offset = "(9)";
	return;
half_byte_off (1):
	print_line.bit_offset = "(14)";
	return;
byte_off (2):
	print_line.bit_offset = "(18)";
	return;
half_byte_off (2):
	print_line.bit_offset = "(23)";
	return;
byte_off (3):
	print_line.bit_offset = "(27)";
	return;
half_byte_off (3):
	print_line.bit_offset = "(32)";
	return;
byte_off (0):
	return;
half_byte_off (0):
	print_line.bit_offset = "(5)";
	return;

     end convert_offset;

convert_word_offset:
     proc;

	print_line.offset = "000000";
	do t = 6 to 1 by -1 while (number > 0);
	     s = fixed (substr (bit36, 34, 3), 35) + 48;
	     substr (print_line.offset, t, 1) = substr (c, 4, 1);
	     number = fixed (substr (bit36, 1, 33), 35);
	end;

     end convert_word_offset;

convert10:
     proc;

	char8 = (8)"0";				/*[5.1-1]*/
	do t = 8 to 1 by -1 while (number > 0);
	     s = mod (number, 10) + 48;
	     substr (char8, t, 1) = substr (c, 4, 1);
	     number = divide (number, 10, 35, 0);
	     cv_off = t;
	end;					/*[5.1-1]*/
	cv_length = 9 - cv_off;

     end convert10;

sort_tokens:
     proc;

/* This routine sorts the array of ptrs to Name-Table tokens.
		   It does a Shell sort alphabetizing on the name in the token. */

dcl	(d, i, j, k)	fixed bin;
dcl	(p, p1, p2)	ptr;
dcl	name_string	char (30) varying based;

	d = token_count;

down:
	d = 2 * divide (d, 4, 17, 0) + 1;

	do i = 1 to token_count - d;
	     k = i + d;
	     p2 = token_area.name_ptr (k);

up:
	     j = k - d;
	     p1 = token_area.name_ptr (j);

	     if p1 -> name_string > p2 -> name_string
	     then do;
		     token_area.name_ptr (k) = p1;
		     token_area.name_ptr (j) = p2;
		     p = token_ptr (k);
		     token_ptr (k) = token_ptr (j);
		     token_ptr (j) = p;

		     if j > d
		     then do;
			     k = j;
			     go to up;
			end;
		end;
	end;

	if d > 1
	then go to down;

     end sort_tokens;

%include cobol_;
%include cobol_ext_;
%include cobol_fixed_common;
%include cobol_xref;
%include cobol_eln_table;
%include cobol_type7;
%include cobol_type9;
%include cobol_type10;
%include cobol_type12;
%include cobol_file_table;
%include cobol_type13;
%include cobol_type17;
%include cobol_type40;
%include cobol_occurs_ext;

     end cobol_make_xref_;




		    cobol_merge_gen.pl1             05/24/89  1041.5rew 05/24/89  0830.5      235287



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_merge_gen.pl1 Added Trace statements.
                                                   END HISTORY COMMENTS */


/* Modified on 01/20/85 by FCH, [5.3...], trace added */
/* Modified on 10/19/84 by FCH, [5.3-1], BUG563(phx18381), new cobol_addr_tokens.incl.pl1 */
/* Modified on 11/20/76 by Bob Chang to cooperate with alphabet_name token.	*/
/* Modified on 11/15/76 by Bob Chang to cooperate with sort statement for setting static data.	*/
/* Created on 10/11/76 by Bob Chang for merge statemnet. */







/* format: style3 */
cobol_merge_gen:
     proc (in_token_ptr);				/*  Code and relocation sequences.		*/

dcl	1 pr_struc	static,
	  2 what_ptr	fixed bin,
	  2 pointer_no	bit (3),
	  2 lock		fixed bin init (1),
	  2 switch	fixed bin init (0);
dcl	1 alpha_type9	static,
	  2 header	(4) fixed bin init (112, 0, 0, 9),
	  2 repl_ptr	(2) ptr init ((2) null ()),
	  2 fill1		bit (108) init (""b),
	  2 file_key_info,
	    3 fb1		(3) fixed bin init (0, 0, 0),
	    3 size	fixed bin init (0),
	    3 fb2		(2) fixed bin init (0, 0),
	    3 flags1	bit (36) init ("000000100100000000010000000100000000"b),
	    3 flags2	bit (36) init (""b),
	    3 seg		fixed bin init (0),
	    3 off		fixed bin,
	  2 fill2		(7) fixed bin init (0, 0, 0, 0, 0, 0, 0);
dcl	an_type9_based	char (112) based (addr (an_type9));
dcl	an_type9_init_based char (112) based (addr (an_type9_init));
dcl	1 an_type9_init	static,
	  2 header	(4) fixed bin init (112, 0, 0, 9),
	  2 repl_ptr	(2) ptr init ((2) null ()),
	  2 fill1		bit (108) init (""b),
	  2 file_key_info,
	    3 fb1		(3) fixed bin init (0, 0, 0),
	    3 size	fixed bin init (0),
	    3 fb2		(2) fixed bin init (0, 0),
	    3 flags1	bit (36) init ("000000100100000000010000000100000000"b),
	    3 flags2	bit (36) init (""b),
	    3 seg		fixed bin init (0),
	    3 off		fixed bin,
	  2 fill2		(7) fixed bin init (0, 0, 0, 0, 0, 0, 0);
dcl	1 an_type9,
	  2 header	(4) fixed bin,
	  2 repl_ptr	(2) ptr,
	  2 fill1		bit (108),
	  2 file_key_info,
	    3 fb1		(3) fixed bin,
	    3 size	fixed bin,
	    3 fb2		(2) fixed bin,
	    3 flags1	bit (36),
	    3 flags2	bit (36),
	    3 seg		fixed bin,
	    3 off		fixed bin,
	  2 fill2		(7) fixed bin;
dcl	1 alpha_type9_based based,
	  2 header	(4) fixed bin,
	  2 repl_ptr	(2) ptr,
	  2 fill1		bit (108),
	  2 file_key_info,
	    3 fb1		(3) fixed bin,
	    3 size	fixed bin,
	    3 fb2		(2) fixed bin,
	    3 flags1	bit (36),
	    3 flags2	bit (36),
	    3 seg		fixed bin,
	    3 off		fixed bin,
	  2 fill2		(7) fixed bin;
dcl	1 type19_out	static,
	  2 header	(4) fixed bin init (38, 0, 0, 19),
	  2 verb		fixed bin init (0),
	  2 e		fixed bin init (0),
	  2 h		fixed bin init (0),
	  2 ij		(2) fixed bin init (0, 0),
	  2 abcdfgk	bit (16) init ("0000001000000000"b);
dcl	1 type19		static,
	  2 header	(4) fixed bin init (38, 0, 0, 19),
	  2 verb		fixed bin init (0),
	  2 e		fixed bin init (0),
	  2 h		fixed bin init (0),
	  2 ij		(2) fixed bin init (0, 0),
	  2 abcdfgk	bit (16) init ("0000000000000000"b);
dcl	1 return_type19	static,
	  2 header	(4) fixed bin init (38, 0, 0, 19),
	  2 verb		fixed bin init (0),
	  2 e		fixed bin init (0),
	  2 h		fixed bin init (0),
	  2 ij		(2) fixed bin init (0, 0),
	  2 abcdfgk	bit (16) init ("0000000000000000"b);
dcl	1 type19_read_into	static,
	  2 header	(4) fixed bin init (38, 0, 0, 19),
	  2 verb		fixed bin init (0),
	  2 e		fixed bin init (0),
	  2 h		fixed bin init (0),
	  2 ij		(2) fixed bin init (0, 0),
	  2 abcdfgk	bit (16) init ("0011000000000000"b);
dcl	1 type19_read	static,
	  2 header	(4) fixed bin init (38, 0, 0, 19),
	  2 verb		fixed bin init (0),
	  2 e		fixed bin init (0),
	  2 h		fixed bin init (0),
	  2 ij		(2) fixed bin init (0, 0),
	  2 abcdfgk	bit (16) init ("0010000000000000"b);
dcl	stz_inst		(2) bit (18) static init ("110000000000000000"b, "100101000001000000"b);
						/* stz	pr6|tree(i)	*/


dcl	spr		(2) bit (18) static init ("110000000000000000"b, "010101001101000000"b);
						/* spri1	pr6|record_ptr(i)	*/
dcl	tra_inst		(2) bit (18) static init ("000000000000000000"b, "111001000000000100"b);
						/* tra	0,ic	*/

dcl	instr_seq7	(14) bit (18) static init ("000000000000000000"b, "000000000000000000"b,
						/* descr_relp_offset. */
			"000000000000000000"b, "000000000000000000"b, "000000000000000000"b, "110010111000000000"b,
						/* eax7	0	*/
			"111000000000101000"b, "011101010001010000"b,
						/* epp2	pr7|40,* 	*/
			"010000000000000110"b, "011101010101010000"b,
						/* epbp2	pr2|6,*	*/
			"010000000000001010"b, "010111010001000000"b,
						/* tsp2	pr2|10	*/
			"000000000000000000"b, "000000000000000000"b);
						/* no symbol table for compare routine. */
dcl	rel_seq7		(14) bit (5) aligned static
			init ("10000"b, "00000"b, "10101"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b,
			"00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b);
dcl	instr_seq8	(2) bit (18) static init ("000000000000000011"b, "111001000001000000"b);
						/* tra	pr0|3	*/

dcl	epp_inst		(4) bit (18) static init ("000000000000000000"b, "011101010000000100"b,
						/* epp2	open_tag(i+1),ic	*/
			"110000000000000000"b, "010101010001000000"b);
						/* spri2	pr6|ret_off	*/
dcl	ret_inst		(2) bit (18) static init ("110000000000000000"b, "111001000001010000"b);
						/* tra	pr6|ret_off,*	*/
dcl	instr_seq11	(10) bit (18) static init ("000000000000000011"b, "110000010000000100"b,
						/* tnc 	3,ic	*/
			"000000100000010011"b, "010011110001000000"b,
						/* ldq pr0|2048+23 for -2 */
			"111000000000000110"b, "111101110001010000"b,
						/* stq	pr7|6,*	*/
			"111000000000000110"b, "000101100001010000"b,
						/* aos	pr7|6,*	*/
			"000000000000000000"b, "111001000000000100"b);
						/* tra	0,ic	*/
dcl	1 merge_in_token	static,
	  2 n		fixed bin init (3),
	  2 code		fixed bin init (0),
	  2 pt1		ptr,
	  2 pt2		ptr,
	  2 pt3		ptr;
dcl	1 read_in_token	static,
	  2 n		fixed bin init (3),
	  2 code		fixed bin init (0),
	  2 pt1		ptr,
	  2 pt2		ptr,
	  2 pt3		ptr;
dcl	1 read_into_token	static,
	  2 n		fixed bin init (4),
	  2 code		fixed bin init (0),
	  2 pt1		ptr,
	  2 pt2		ptr,
	  2 pt3		ptr,
	  2 pt4		ptr;
dcl	1 return_in_token	static,
	  2 n		fixed bin init (4),
	  2 code		fixed bin init (0),
	  2 pt1		ptr,
	  2 pt2		ptr,
	  2 pt3		ptr,
	  2 pt4		ptr;
dcl	1 close_in_token	static,
	  2 n		fixed bin init (3),
	  2 code		fixed bin init (0),
	  2 pt1		ptr,
	  2 pt2		ptr,
	  2 pt3		ptr;
dcl	1 open_in_token	static,
	  2 n		fixed bin init (3),
	  2 code		fixed bin init (0),
	  2 pt1		ptr,
	  2 pt2		ptr,
	  2 pt3		ptr;
dcl	1 open_out_token	static,
	  2 n		fixed bin init (3),
	  2 code		fixed bin init (0),
	  2 pt1		ptr,
	  2 pt2		ptr,
	  2 pt3		ptr;
dcl	1 write_in_token	static,
	  2 n		fixed bin init (3),
	  2 code		fixed bin init (0),
	  2 pt1		ptr,
	  2 pt2		ptr,
	  2 pt3		ptr;

dcl	file_ptr		(256) ptr,
	read_tag		(256) fixed bin,
	bgn_tag		fixed bin,
	open_tag		(256) fixed bin,
	end_tag		fixed bin,
	not_end_tag	fixed bin,
	file_n		fixed bin static,		/* no of using files */
	key_n		fixed bin static;		/* no of keys. */

dcl	mvt_ptr		ptr,
	mvt_table		char (512) based (mvt_ptr),
	to_offset		fixed bin;		/*
Automatic data		*/

dcl	workpt2		ptr,			/* work pointer */
	last_token	fixed bin,
	ft_ptr		ptr,			/* pointer to the type 12 token */
	merge_file_ptr	ptr,			/* pointer to the type 12 token */
	merge_gen_ptr	ptr,
	ret_off		fixed bin,
	line_temp		fixed bin,
	compare_hold_ic	fixed bin,
	hold_addr		bit (18) based,
	desc_off		(3) fixed bin,
	desc_ptr		ptr,
	object_name_len	fixed bin,
	name_ptr		ptr,
	object_name	char (32),
	first_call	fixed bin static init (0),
	merge_stack_off	fixed bin static init (0),	/* returned value of cobol_alloc$stack */
	temp		fixed bin,
	merge_gen_text_wd_off
			fixed bin,
	alphabet_flag	fixed bin,
	retry_tag		fixed bin,
	passed_tag	fixed bin,
	passed_tag1	fixed bin,
	k		fixed bin,
	i		fixed bin,		/* work variable */
	j		fixed bin,
	l		fixed bin,
	linkoff		fixed bin;		/* word offset of entry point link */
dcl	dn_ptr		ptr,			/* pointer to the type 9 token */
	alpha_ptr		ptr;
dcl	in_buff		char (24),		/*input struc buffer */
	inst_buff		char (8),			/* inst_struc buffer */
	reloc_buff	char (8);			/* reloc_struc bufer  */
dcl	bit18		bit (18) based;



dcl	temp_type12	char (60) static,
	temp_file_ptr	ptr static,
	temp_type12_ptr	ptr static,
	temp_type9_ptr	ptr static;




/*	Procedures Called		*/


dcl	cobol_compare_gen$sort
			entry (ptr, ptr),
	cobol_addr	entry (ptr, ptr, ptr),
	cobol_write_gen	entry (ptr, fixed bin),
	cobol_open_gen	entry (ptr),
	cobol_close_gen	entry (ptr),
	cobol_read_gen	entry (ptr, fixed bin),
	cobol_def_util	entry (fixed bin, char (32), fixed bin, ptr, fixed bin, ptr, ptr),
	cobol_sort_util	entry (ptr, ptr, char (32), fixed bin),
	cobol_emit	entry (ptr, ptr, fixed bin),
	cobol_alloc$stack	entry (fixed bin, fixed bin, fixed bin),
	cobol_pointer_register$priority
			ext entry (fixed bin, fixed bin, bit (3)),
	cobol_pointer_register$get
			ext entry (ptr),
	cobol_call_op	entry (fixed bin, fixed bin),
	cobol_define_tag	entry (fixed bin),
	cobol_reg_manager$after_op
			entry (fixed bin),
	cobol_pool	entry (char (*), fixed bin, fixed bin),
	cobol_define_tag_nc entry (fixed bin, fixed bin),
	cobol_make_tagref	entry (fixed bin, fixed bin, ptr),
	cobol_read_ft	entry (fixed bin, ptr),
	cobol_make_merge_file
			entry (ptr, ptr, ptr, ptr);

start:	/***.....	if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME);/**/
	eos_ptr = in_token.token_ptr (1);

	if end_stmt.type = 19
	then do;
		if end_stmt.h = 91
		then go to mex;
		else if end_stmt.h = 90
		then do;
			close_in_token.pt2 = temp_type12_ptr;
			call cobol_close_gen (addr (close_in_token));

			go to mex;
		     end;

		go to mex;
	     end;

	eos_ptr = in_token.token_ptr (in_token.n);

	if end_stmt.h = 92
	then do;
		call giving;
		go to mex;
	     end;

	merge_file_ptr = in_token.token_ptr (2);
	desc_ptr = addr (desc_off (1));
	file_n = end_stmt.i;
	key_n = end_stmt.e;

	if first_call ^= cobol_$compile_count
	then do;
		first_call = cobol_$compile_count;
		i = 16 * (file_n + 2);
		call cobol_alloc$stack (i, 2, merge_stack_off);
		cobol_$init_stack_off = cobol_$stack_off;
	     end;

	input_ptr = addr (in_buff);
	inst_ptr = addr (inst_buff);
	reloc_ptr = addr (reloc_buff);

	call initiate;
	alpha_name_ptr = null ();

	if end_stmt.d ^= "00"b
	then do;

		alphabet_flag = 1;
		alpha_name_ptr = in_token.token_ptr (key_n + 3);
		if alphabet_name.iw_key = 11
		then do;				/* ascii */
			alpha_name_ptr = null ();
			goto continue;
		     end;
		if alphabet_name.iw_key = 0
		then do;
			mvt_ptr = addr (alphabet_name.table);
			call cobol_pool (mvt_table, 2, to_offset);
			alphabet_name.offset = to_offset * 4;
			alphabet_name.segno = 3000;
		     end;
	     end;
	else alphabet_flag = 0;

/* CODE for internal procedure building  */

continue:
	dn_ptr = addr (alpha_type9);

	passed_tag = cobol_$next_tag;
	passed_tag1 = cobol_$next_tag + 1;
	cobol_$next_tag = cobol_$next_tag + 2;
	substr (instr_seq7 (3), 1, 18) = substr (cobol_$text_base_ptr -> bit18, 1, 18);
	call cobol_emit (addr (tra_inst), null (), 1);
	text_ptr = addrel (cobol_$text_base_ptr, cobol_$text_wd_off);

	call cobol_sort_util (merge_file_ptr, desc_ptr, object_name, object_name_len);
	call cobol_def_util (3, object_name, object_name_len, text_ptr, 0, desc_ptr, in_token_ptr);

	entry_seq.flags.function = "1"b;
	instr_seq7 (1) = entry_seq.descr_relp_offset;
	instr_seq7 (3) = entry_seq.def_relp;
	instr_seq7 (4) = string (entry_seq.flags);
	call cobol_emit (addr (instr_seq7 (1)), addr (rel_seq7 (1)), 7);

	merge_gen_text_wd_off = cobol_$text_wd_off - 5;
	call cobol_make_tagref (passed_tag, cobol_$text_wd_off - 8, null ());

	call cobol_call_op (19, 0);

/* Lock the pointer register 1 2 and 7	*/

	pr_struc.what_ptr = 7;
	call cobol_pointer_register$get (addr (pr_struc));

	pr_struc.what_ptr = 1;
	call cobol_pointer_register$get (addr (pr_struc));

	pr_struc.what_ptr = 2;
	call cobol_pointer_register$get (addr (pr_struc));

/*  INSERT compare code */

	last_token = key_n + 2;

	do i = 3 to last_token;

	     merge_in_token.pt1 = in_token.token_ptr (i);
	     merge_in_token.pt2 = addr (alpha_type9);
	     alpha_type9 = merge_in_token.pt1 -> alpha_type9_based;
	     merge_in_token.pt3 = addr (type19);
	     type19.e = 102;			/* EQUAL */
	     merge_in_token.pt2 -> data_name.seg_num = 5002;
	     merge_in_token.pt1 -> data_name.seg_num = 5001;

	     if data_name.numeric = "0"b
	     then do;				/* switch compare  operands around */
		     workpt2 = merge_in_token.pt2;
		     merge_in_token.pt2 = merge_in_token.pt1;
		     merge_in_token.pt1 = workpt2;
		end;

	     type19.h = cobol_$next_tag;
	     cobol_$next_tag = cobol_$next_tag + 1;

	     call cobol_compare_gen$sort (addr (merge_in_token), alpha_name_ptr);

	     if data_name.ad_bit = "0"b
	     then substr (instr_seq11 (2), 7, 3) = "011"b;/* make TRC */
	     if data_name.numeric = "1"b
	     then substr (instr_seq11 (2), 7, 3) = "100"b;/* make TMI */
	     if data_name.numeric = "1"b & data_name.ad_bit = "0"b
	     then substr (instr_seq11 (2), 7, 3) = "101"b;/* make TPL */

	     temp = fixed (op_con.zero_con, 18) - 2;
	     instr_seq11 (3) = substr (unspec (temp), 19, 18);

	     if i ^= last_token
	     then do;
		     call cobol_emit (addr (instr_seq11 (1)), null (), 5);
		     call cobol_make_tagref (passed_tag1, cobol_$text_wd_off - 1, null ());
		     call cobol_define_tag_nc (type19.h, cobol_$text_wd_off);
		end;
	     else call cobol_emit (addr (instr_seq11 (1)), null (), 4);

	     substr (instr_seq11 (2), 7, 3) = "010"b;	/* reset */
	end;

	call cobol_pointer_register$priority (2, 0, "001"b);
	call cobol_pointer_register$priority (2, 0, "010"b);
	call cobol_pointer_register$priority (2, 0, "111"b);

	call cobol_define_tag (type19.h);
	call cobol_define_tag (passed_tag1);
	call cobol_emit (addr (instr_seq8 (1)), null (), 1);

	temp = cobol_$stack_off + 16;
	substr (unspec (temp), 33, 4) = "0000"b;
	merge_gen_ptr = addrel (cobol_$text_base_ptr, merge_gen_text_wd_off);
	substr (merge_gen_ptr -> bit18, 1, 18) = substr (unspec (temp), 19, 18);
	call cobol_define_tag (passed_tag);

/*	open and read the using files */

	open_out_token.pt3 = addr (type19_out);
	open_out_token.pt1 = in_token.token_ptr (1);
	close_in_token.pt3 = addr (type19);
	close_in_token.pt1 = in_token.token_ptr (1);
	write_in_token.pt3 = addr (type19);
	write_in_token.pt1 = in_token.token_ptr (1);
	open_in_token.pt1 = in_token.token_ptr (1);
	open_in_token.pt3 = addr (type19);
	read_in_token.pt1 = in_token.token_ptr (1);
	return_in_token.pt1 = in_token.token_ptr (1);
	return_in_token.pt2 = in_token.token_ptr (2);
	return_in_token.pt4 = addr (return_type19);
	read_in_token.pt3 = addr (type19_read);
	read_into_token.pt4 = addr (type19_read_into);
	read_into_token.pt1 = in_token.token_ptr (1);

	if alphabet_flag = 0
	then k = key_n + 1;
	else k = key_n + 2;

	j = merge_stack_off + 2 * file_n - 1;

/*	set up return address for return statement. */

	open_tag (1) = cobol_$next_tag;
	cobol_$next_tag = cobol_$next_tag + 1;
	ret_off = merge_stack_off + 4 * file_n + 4;
	substr (epp_inst (3), 4, 15) = substr (unspec (ret_off), 22, 15);
	substr (ret_inst (1), 4, 15) = substr (unspec (ret_off), 22, 15);

	do i = 1 to file_n;

/* set return address for return statement */

	     open_tag (i + 1) = cobol_$next_tag;
	     read_tag (i) = cobol_$next_tag + 1;
	     passed_tag = cobol_$next_tag + 2;
	     cobol_$next_tag = cobol_$next_tag + 3;

	     call cobol_define_tag (open_tag (i));
	     call cobol_emit (addr (epp_inst (1)), null (), 2);
	     call cobol_make_tagref (open_tag (i + 1), cobol_$text_wd_off - 2, null ());

	     open_in_token.pt2 = in_token.token_ptr (i * 2 + k);
	     file_ptr (i) = open_in_token.pt2;
	     call cobol_open_gen (addr (open_in_token));

/*	read */

	     call cobol_define_tag (read_tag (i));
	     call cobol_read_ft (file_ptr (i) -> fd_token.file_no, ft_ptr);

	     an_type9_based = an_type9_init_based;
	     an_type9.seg = file_table.cra_seg;
	     an_type9.off = file_table.cra_offset;
	     an_type9.size = file_table.max_cra_size;

	     input_struc.type = 2;
	     input_struc.operand_no = 1;
	     input_struc.lock = 0;
	     input_struc.operand.token_ptr (1) = addr (an_type9);
	     input_struc.operand.size_sw (1) = 0;

	     call cobol_addr (input_ptr, inst_ptr, reloc_ptr);
	     inst_struc_basic.fill1_op = "0111010011"b;	/* epp1 */
	     call cobol_emit (inst_ptr, reloc_ptr, 1);

	     l = merge_stack_off + 2 * (i - 1);
	     substr (spr (1), 4, 15) = substr (unspec (l), 22, 15);
	     call cobol_emit (addr (spr (1)), null (), 1);

	     read_in_token.pt2 = file_ptr (i);
	     call cobol_read_gen (addr (read_in_token), passed_tag);

/* stz	pr6|tree(i)	*/

	     l = j + i;
	     substr (stz_inst (1), 4, 15) = substr (unspec (l), 22, 15);

	     call cobol_emit (addr (stz_inst (1)), null (), 1);
	     call cobol_define_tag (passed_tag);
	     call cobol_emit (addr (ret_inst (1)), null (), 1);
	end;


	call cobol_define_tag (open_tag (file_n + 1));

/* call compare routine through cobol_rts. */

	call cobol_call_op (61, 0);
	call cobol_make_merge_file (in_token.token_ptr (2), temp_file_ptr, temp_type12_ptr, temp_type9_ptr);
	call create_temp_file;

	do i = 1 to file_n;
	     close_in_token.pt2 = file_ptr (i);
	     call cobol_close_gen (addr (close_in_token));
	end;

mex:	/***.....	if Trace_Bit then call cobol_gen_driver_$Tr_End(MY_NAME);/**/
	return;

	/***.....	dcl cobol_gen_driver_$Tr_Beg entry(char(*));/**/
	/***.....	dcl cobol_gen_driver_$Tr_End entry(char(*));/**/

	/***.....	dcl Trace_Bit bit(1) static external;/**/
	/***.....	dcl Trace_Lev fixed bin static external;/**/
	/***.....	dcl Trace_Line char(36) static external;/**/
	/***.....	dcl ioa_ entry options(variable); /**/
	/***..... dcl MY_NAME char (15) int static init ("COBOL_MERGE_GEN");/**/








/*	BEGIN	create_temp_file	*/
create_temp_file:
     proc;

	open_out_token.pt2 = temp_type12_ptr;
	call cobol_open_gen (addr (open_out_token));

	return_in_token.pt3 = temp_type9_ptr;
	bgn_tag = cobol_$next_tag;
	end_tag = cobol_$next_tag + 1;
	cobol_$next_tag = cobol_$next_tag + 2;
	call cobol_define_tag (bgn_tag);
	call return_proc (not_end_tag);

	call cobol_emit (addr (tra_inst), null (), 1);
	call cobol_make_tagref (end_tag, cobol_$text_wd_off - 1, null ());
	call cobol_define_tag (not_end_tag);

	write_in_token.pt2 = temp_type9_ptr;
	call cobol_write_gen (addr (write_in_token), 0);
	call cobol_emit (addr (tra_inst), null (), 1);
	call cobol_make_tagref (bgn_tag, cobol_$text_wd_off - 1, null ());
	call cobol_define_tag (end_tag);

	close_in_token.pt2 = temp_type12_ptr;
	call cobol_close_gen (addr (close_in_token));

	open_in_token.pt2 = temp_type12_ptr;
	call cobol_open_gen (addr (open_in_token));

     end create_temp_file;				/*	END create_temp_file	*/









/*	BEGIN	giving	*/

giving:
     proc;

/*	open output giving file	*/

	open_out_token.pt2 = in_token.token_ptr (2);
	call cobol_open_gen (addr (open_out_token));
	end_tag = cobol_$next_tag;
	passed_tag = cobol_$next_tag + 1;
	passed_tag1 = cobol_$next_tag + 2;
	cobol_$next_tag = cobol_$next_tag + 3;
	call cobol_define_tag (passed_tag1);

/*	read	temp file	*/

	read_into_token.pt2 = temp_type12_ptr;
	read_into_token.pt3 = in_token.token_ptr (1);

	call cobol_read_gen (addr (read_into_token), passed_tag);
	call cobol_emit (addr (tra_inst), null (), 1);
	call cobol_make_tagref (end_tag, cobol_$text_wd_off - 1, null ());
	call cobol_define_tag (passed_tag);

/*	write giving file	*/

	write_in_token.pt2 = in_token.token_ptr (1);
	call cobol_write_gen (addr (write_in_token), 0);
	call cobol_emit (addr (tra_inst), null (), 1);
	call cobol_make_tagref (passed_tag1, cobol_$text_wd_off - 1, null ());
	call cobol_define_tag (end_tag);

/*	close output giving file	*/

	close_in_token.pt2 = in_token.token_ptr (2);
	call cobol_close_gen (addr (close_in_token));

     end giving;					/*	END	giving	*/

/*	BEGIN	return_proc	*/
return_proc:
     proc (passed_tag);


dcl	1 mlr_struct	static,
	  2 type		fixed bin init (5),
	  2 operand_no	fixed bin init (2),
	  2 lock		fixed bin init (0),
	  2 operand1,
	    3 token_ptr	ptr init (null ()),
	    3 sr		fixed bin init (0),
	    3 icmod	fixed bin init (0),
	    3 size_sw	fixed bin init (0),
	  2 operand2,
	    3 token_ptr	ptr,
	    3 sr		fixed bin init (1),
	    3 icmod	fixed bin,
	    3 size_sw	fixed bin init (0);

dcl	mlr_reg_to_reg	bit (36) init ("000100000001010000001000000101000000"b);

dcl	instr		(3) bit (36) unaligned static
			init ("000000000000000000000000000000000000"b, "000000000000000000000000000000000000"b,
			"000000000000000000000000000000000000"b);

dcl	ldq_inst		(16) bit (18) static init ("110000000000000000"b, "010011110001000000"b,
						/* ldq	pr6|tree(2n-1)	*/
			"000000000000000000"b, "110000000000000100"b,
						/* tze	end_tag,ic	*/
			"000000000000000001"b, "001111110000000111"b,
						/* sbq	1,dl	*/
			"000000000000000100"b, "100000010000000111"b,
						/* mpy	4,dl	*/
			"000000000000000000"b, "011101010000000100"b,
						/* epp2	def_tag,ic	*/
			"110000000000000000"b, "010101010001000000"b,
						/* spri2	pr6|ret_off	*/
			"000000000000000010"b, "011101010000000100"b,
						/* epp2	2,ic	*/
			"010000000000000000"b, "111001000001000110"b);
						/* tra	pr2|0,ql	*/

dcl	tra_read_inst	(2) bit (18) static init ("000000000000000000"b, "111001000000000100"b);
						/* tra	read_tag(i),ic	*/

dcl	inst_seq2		(2) bit (18) static init ("000000000000000000"b, "111001000000000100"b);
						/* tra	0,ic	*/
dcl	rel_seq2		(2) bit (5) aligned static init ("00000"b, "00000"b);

dcl	1 mpout		static,
	  2 n		fixed bin init (4),
	  2 pt1		ptr,
	  2 pt2		ptr,
	  2 pt3		ptr,
	  2 pt4		ptr;
dcl	file_key_desc	char (40) based;
dcl	eos_buff		(5) ptr;

dcl	passed_tag	fixed bin,
	def_tag		fixed bin,
	end_tag		fixed bin;
start:
	eos_ptr = addr (eos_buff);
	name_ptr = return_in_token.pt2;
	passed_tag = cobol_$next_tag;
	def_tag = cobol_$next_tag + 1;
	end_tag = cobol_$next_tag + 2;
	cobol_$next_tag = cobol_$next_tag + 3;

/*	check tree(2n-1)	*/
	i = merge_stack_off + 4 * file_n - 2;
	substr (ldq_inst (1), 4, 15) = substr (unspec (i), 22, 15);
	i = i + 6;
	substr (ldq_inst (11), 4, 15) = substr (unspec (i), 22, 15);
	call cobol_emit (addr (ldq_inst (1)), null (), 8);
	call cobol_make_tagref (def_tag, cobol_$text_wd_off - 4, null ());
	call cobol_make_tagref (end_tag, cobol_$text_wd_off - 7, null ());
						/*	set up mlr instruction for the move of record(i) to merge cra. */
	mlr_struct.operand2.token_ptr = return_in_token.pt3;
	instr (1) = mlr_reg_to_reg;
	instr (2) = ""b;
	instr (3) = ""b;

	an_type9_based = an_type9_init_based;
	do i = 1 to file_n;
	     call cobol_read_ft (file_ptr (i) -> fd_token.file_no, ft_ptr);
	     an_type9.seg = file_table.cra_seg;
	     an_type9.off = file_table.cra_offset;
	     an_type9.size = file_table.max_cra_size;
	     mlr_struct.operand1.token_ptr = addr (an_type9);
	     call cobol_addr (addr (mlr_struct), addr (instr (1)), null ());
	     call cobol_emit (addr (instr (1)), null (), 3);
	     call cobol_emit (addr (tra_read_inst (1)), null (), 1);
	     call cobol_make_tagref (read_tag (i), cobol_$text_wd_off - 1, null ());
	end;
	call cobol_define_tag (def_tag);



	call cobol_call_op (62, 0);
	call cobol_reg_manager$after_op (62);

	call cobol_emit (addr (inst_seq2 (1)), addr (rel_seq2), 1);

/* AT END processing		*/

	call cobol_make_tagref (passed_tag, cobol_$text_wd_off - 1, null ());

	call cobol_define_tag (end_tag);




     end return_proc;				/*	END	return_proc	*/





/* Interal procedure to generate codes to call merge_$initiate.
	The call is through the operator merge_initiate.	*/
initiate:
     proc;


dcl	inst_seq		(6) bit (18) init ("000000000000000000"b, "011101011100000100"b,
						/* epp3 compare,ic	*/
			"000000000000000000"b, "111010010000000111"b,
						/* lxl2 merge_stack_off,dl	*/
			"000000000000000000"b, "111010011000000111"b);
						/* lxl3 file_n,dl	*/
dcl	rel_seq		(6) bit (5) aligned init ("00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b);


/* merge_initiate */
	retry_tag = cobol_$next_tag;
	call cobol_define_tag_nc (retry_tag, cobol_$text_wd_off);
	cobol_$next_tag = cobol_$next_tag + 1;
	if cobol_$same_sort_merge_proc ^= "0"b
	then temp = -merge_stack_off;
	else temp = merge_stack_off;
	inst_seq (3) = substr (unspec (temp), 19, 18);
	inst_seq (5) = substr (unspec (file_n), 19, 18);
	call cobol_emit (addr (inst_seq), addr (rel_seq), 3);

	compare_hold_ic = cobol_$text_wd_off - 3;
	call cobol_call_op (60, 0);
	call cobol_reg_manager$after_op (60);

	temp = cobol_$text_wd_off + 3 - compare_hold_ic;
	addrel (cobol_$text_base_ptr, compare_hold_ic) -> hold_addr = substr (unspec (temp), 19, 18);

     end initiate;


/*****	Declaration for builtin function	*****/

dcl	(substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index)
			builtin;

/*****	End of declaration for builtin function	*****/

%include cobol_in_token;

%include cobol_addr_tokens;

%include cobol_entry_seq;
%include cobol_;
%include cobol_file_table;
%include cobol_type9;
%include cobol_type12;
%include cobol_type19;
%include cobol_type40;
%include cobol_alpha_def;
%include cobol_ext_;
%include cobol_fixed_common;
%include cobol_op_con;

     end cobol_merge_gen;




		    cobol_move_gen.pl1              05/24/89  1041.5rew 05/24/89  0830.5     1195749



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_move_gen.pl1 Added Trace statements.
  2) change(89-04-23,Zimmerman), approve(89-04-23,MCR8085),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8085 cobol_move_gen.pl1 Stop code generator from aborting in move
     statement.
                                                   END HISTORY COMMENTS */


/* Modified on 10/19/84 by FCH, [5.3-1], BUG563(phx18381), new cobol_addr_tokens.incl.pl1 */
/* Modified on 08/13/83 by FCH, [5.2 ...], trace added */
/* Modified on 11/03/81 by FCH, sending tokens sometimes clobbered, [5.1-1], phx11872(BUG518) */
/* Modified on 06/11/81 by FCH, [4.4-2], type 13 token allowed as move operand, BUG468 */
/* Modified on 04/08/81 by FCH, [4.4-1], move zzzpp to xxxxx gives 0 fill not space, BUG476 */
/* Modified on  09/20/80 by FCH, [4.3-2], MOVE constant to indexed comp-6 generates bad code (TR7611, BUG443) */
/* Modified on 08/29/80 by FCH, [4.3-1], MOVE subscripted comp-6 to comp-7 generated bad code (TR5709, BUG432) */
/* Modified on 04/25/80 by FCH, [4.2-2], use MVC for pic s999 lead sep to pic xxxx */
/* Modified on 03/25/80 by FCH, indent used, [4.2-1], set ix to comp-7 fails, BUG432(TR5709) */
/* Modified on 09/01/79 by FCH, [4.0-2], variable length receiving fields fixed */
/* Modified on 05/09/79 by FCH, [4.0-1], move all literal fixed */
/* Modified on 10/19/78 by FCH, [3.0-2], decimal to binary conversion fixed */
/* Modified on 04/10/78 by FCH, [3.0-1], double-word alignment not reqd for params */
/* Modified since Version 3.0	*/






/* format: style3 */
cobol_move_gen:
     proc (in_token_ptr);

dcl	MVE		bit (10) static init ("0000100001"b);
						/* 020(1) */
dcl	MVNE		bit (10) static init ("0000101001"b);
						/* 024(1) */
dcl	MLR		bit (10) static init ("0010000001"b);
						/* 100(1) */
dcl	MRL		bit (10) static init ("0010000011"b);
						/* 101(1) */
dcl	MVN		bit (10) static init ("0110000001"b);
						/* 300(1) */
dcl	CMPN		bit (10) static init ("0110000111"b);
						/* 303(1) */
dcl	LDA		bit (10) int static init ("0100111010"b);
						/* 235(0) */
dcl	LDQ		bit (10) int static init ("0100111100"b);
						/* 236(0) */
dcl	ALS		bit (10) int static init ("1110111010"b);
						/* 735(0) */
dcl	QLS		bit (10) int static init ("1110111100"b);
						/* 736(0) */
dcl	ARS		bit (10) int static init ("1110110010"b);
						/* 731(0) */
dcl	QRS		bit (10) int static init ("1110110100"b);
						/* 732(0) */
dcl	STA		bit (10) int static init ("1111011010"b);
						/* 755(0) */
dcl	STQ		bit (10) int static init ("1111011100"b);
						/* 756(0) */
dcl	ANA		bit (10) int static init ("0111111010"b);
						/* 375(0) */
dcl	ANQ		bit (10) int static init ("0111111100"b);
						/* 376(0) */
dcl	STBA		bit (10) int static init ("1011010010"b);
						/* 551(0) */
dcl	STBQ		bit (10) int static init ("1011010100"b);
						/* 552(0) */
dcl	ARL		bit (10) int static init ("1111110010"b);
						/* 771(0) */
dcl	ORSA		bit (10) int static init ("0101011010"b);
						/* 255(0) */
dcl	ORSQ		bit (10) int static init ("0101011100"b);
						/* 256(0) */
dcl	BTD		bit (10) int static init ("0110000011"b);
						/* 301(1) */
dcl	DTB		bit (10) int static init ("0110001011"b);
						/* 305(1) */
dcl	QRL		bit (10) int static init ("1111110100"b);
						/* 772(0)  */
dcl	LDAQ		bit (10) int static init ("0100111110"b);
						/*  237(0)  */
dcl	ANAQ		bit (10) int static init ("0111111110"b);
						/*  377(0)  */
dcl	STZ		bit (10) int static init ("1001010000"b);
						/*  450(0)  */
dcl	instr		bit (10);

dcl	ses00		bit (9) static init ("000110000"b);
dcl	ses01		bit (9) static init ("000110100"b);
dcl	ses10		bit (9) static init ("000111000"b);
dcl	ses11		bit (9) static init ("000111100"b);
dcl	lte_1		bit (9) static init ("100000001"b);
dcl	lte_3		bit (9) static init ("100000011"b);
dcl	lte_5		bit (9) static init ("100000101"b);
dcl	enf00		bit (9) static init ("000100000"b);
dcl	enf01		bit (9) static init ("000100100"b);
dcl	enf10		bit (9) static init ("000101000"b);
dcl	enf11		bit (9) static init ("000101100"b);
dcl	ign		bit (9) static init ("011000000"b);
dcl	mvc		bit (9) static init ("011010000"b);
dcl	insn_0		bit (9) static init ("010100000"b);
dcl	insn_4		bit (9) static init ("010100100"b);
dcl	insm		bit (9) static init ("000010000"b);
dcl	insa		bit (9) static init ("010010000"b);
dcl	insb		bit (9) static init ("010000000"b);
dcl	insp		bit (9) static init ("010110000"b);
dcl	mvza		bit (9) static init ("001010000"b);
dcl	mvzb		bit (9) static init ("001000000"b);
dcl	mflc		bit (9) static init ("001110000"b);
dcl	mfls		bit (9) static init ("001100000"b);

dcl	loval		char (1) static init ("");	/* =  */
dcl	space		char (1) static init (" ");
dcl	quote		char (1) static init ("""");
dcl	slash		char (1) static init ("/");
dcl	hival		char (1) static init ("");	/* = \177 */
dcl	zero		char (1) static init ("0");
dcl	DS		char (1) static init ("f");	/* P7 dig select char */

dcl	fc_zero		fixed bin static init (180);
dcl	fc_space		fixed bin static init (192);
dcl	fc_hival		fixed bin static init (221);
dcl	fc_loval		fixed bin static init (229);
dcl	fc_quote		fixed bin static init (235);

dcl	msg_1		char (24) static init ("illegal sending field   ");
dcl	msg_2		char (24) static init ("illegal receiving field ");

dcl	(save_sf_ptr, save_rf_ptr, const_ptr)
			ptr;
dcl	(m, n, n_rf, pl, pr, size, delta)
			fixed bin;
dcl	(lin, col)	fixed bin;
dcl	(spl, spr, rpl, rpr)
			fixed bin;
dcl	(fx, fl)		fixed bin;
dcl	(move_num, nc_move_num, ival_num, control_no)
			fixed bin static init (0);
dcl	(sf_ptr, rf_ptr)	ptr;
dcl	stk_offset	fixed bin;
dcl	cs_offset		fixed bin (24);
dcl	lit_str		char (256);
dcl	(lit_ln, idx)	fixed bin;
dcl	req_ln		fixed bin;
dcl	(sf_stack_sw, sf_category_sw)
			fixed bin;
dcl	snd_tkn		char (500) based;
dcl	rec_tkn		char (500) based;
dcl	ecm		(256) char (1);
dcl	ecm_str		char (256) based (ecm_ptr);
dcl	ecm_ptr		ptr;
dcl	ecm_lnth		fixed bin;
dcl	n_ecm		fixed bin;
dcl	mop		(256) bit (9);
dcl	mop_str		char (256) based (mop_ptr);
dcl	mop_ptr		ptr;
dcl	n_mop		fixed bin;
dcl	(bwz, awz, asterisk, sign)
			fixed bin;
dcl	tag		fixed bin;
dcl	obj_dec_pt_char	char (1);
dcl	currency_char	char (1);
dcl	(start_supp, max_supp, end_supp)
			fixed bin;
dcl	supp_char		char (1);
dcl	(es_status, bz_status)
			fixed bin;
dcl	insert_table_status char (8);
dcl	(no_chars, no_char2, no_char1, count, insert_char_no)
			fixed bin;
dcl	(micro_op, insrt_op)
			bit (9);
dcl	(end_fix, rf_st)	fixed bin;
dcl	(right_adjust, left_adjust, overlap)
			fixed bin;
dcl	(sf_places, rf_places, rf_length, rf_temp_sw)
			fixed bin;
dcl	(opnd_ln, ecm_limit)
			fixed bin;

dcl	1 set_ptr_struc	aligned,
	  2 what_pointer	fixed bin,
	  2 pointer_no	bit (3),
	  2 lock		fixed bin,
	  2 switch	fixed bin,
	  2 segno		fixed bin,
	  2 offset	fixed bin (24),
	  2 reset		fixed bin;

dcl	1 microp_bits	aligned,
	  2 mop		bit (5) unaligned,
	  2 if		bit (4) unaligned;

/*	inst buff	*/
dcl	eis_		(4) bit (36);

/*	input buff	*/
dcl	ips		(18) bit (36);

/*	reloc buff	*/
dcl	1 reloc_info	(4) aligned,
	  2 left_ri	bit (5) aligned,
	  2 right_ri	bit (5) aligned;


/*	type-9 token copies   */

dcl	new_sf_ptr	ptr;
dcl	new_sf_tkn	char (500);

dcl	ms_ptr		ptr;
dcl	ms_tkn		char (200);

dcl	sf_cpy_ptr	ptr;
dcl	sf_tkn_cpy	char (500);

dcl	rf_cpy_ptr	ptr;
dcl	rf_tkn_cpy	char (500);

dcl	temp_tkn_ptr	ptr;
dcl	temp_tkn		char (200);

/* Declaration for special fixed binary MOVE ZERO TO $.
   statement generated by ddalloc as part of "size routines". */
dcl	stz_inst		(2) bit (18) unaligned static init ("000000000000000000"b, "100101000001000000"b);
						/*  stz    pr0|0  */

dcl	dn_ptr		ptr;
dcl	numeric_source_proc (1:5) entry (ptr, ptr) int init (dec_source, dec_source, sb_source, lb_source, opch_source);

dcl	return_code	fixed bin;
dcl	work_sf_ptr	ptr;
dcl	ret_offset	fixed bin;
dcl	only_an		bit (1);
dcl	(move_special_bit, ne_bit)
			bit (1) static init ("0"b);
dcl	temp		fixed bin;
dcl	numeric_lit_flag	fixed bin;
dcl	in_op		fixed bin;

/*
   P__r_o_c_e_d_u_r_e_s_C__a_l_l_e_d:_
   */
dcl	ioa_$rsnnl	entry options (variable),
	cobol_addr	entry (ptr, ptr, ptr),
	cobol_alloc$stack	entry (fixed bin, fixed bin, fixed bin),
	cobol_define_tag	entry (fixed bin),
	cobol_emit	entry (ptr, ptr, fixed bin),
	cobol_make_tagref	entry (fixed bin, fixed bin, ptr),
	cobol_make_type9$alphanumeric
			entry (ptr, fixed bin, fixed bin (24), fixed bin),
	cobol_make_type9$decimal_9bit
			entry (ptr, fixed bin, fixed bin (24), fixed bin, fixed bin),
	cobol_make_type9$type2_3
			entry (ptr, ptr),
	cobol_pool$search_op
			entry (char (*), fixed bin, fixed bin (24), fixed bin),
	cobol_pool	entry (char (*), fixed bin, fixed bin (24)),
	cobol_set_pr	entry (ptr, ptr),
	cobol_get_num_code	ext entry (ptr, fixed bin),
	cobol_register$load ext entry (ptr),
	cobol_make_type9$long_bin
			ext entry (ptr, fixed bin, fixed bin),
	cobol_make_type9$short_bin
			ext entry (ptr, fixed bin, fixed bin),
	cobol_make_type9$copy
			ext entry (ptr, ptr),
	cobol_make_type9$copy_sub
			ext entry (ptr, ptr),
	cobol_io_util$move_lit
			entry (bit (3) aligned, fixed bin, fixed bin, char (*)),
	signal_		entry (char (*), ptr, ptr);

dcl	cobol_opch_op_call	ext entry (ptr, ptr);

dcl	cobol_make_bin_const
			entry (ptr, ptr, fixed bin);
dcl	cobol_register$release
			ext entry (ptr);

/*
   B__u_i_l_t-__i_n_F__u_n_c_t_i_o_n_s_U__s_e_d:_
   */

dcl	addr		builtin,
	addrel		builtin,
	(fixed, binary)	builtin,
	index		builtin,
	null		builtin,
	substr		builtin,
	unspec		builtin,
	verify		builtin;

/*	|*|	|*|	|*|	|*|	|*|	|*|	|*|	*/

/* capture ordinal # and location (in the source program)
				   of the move statement being generated		*/

	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME);/**/

	call move_init;

/*[5.1-1]*/
	go to begin;				/* Set hival according to collating sequence */

/*	|*|	|*|	|*|	|*|	|*|	|*|
			   main move loop
			
			   increment rf idx (m=m+1)
			   check for more (ie multiple) receiving fields
			   if not, return
			   if yes, set rf_ptr to in_token.token_ptr(m)
			   and restore sending field.
			   |*|	|*|	|*|	|*|	|*|	|*|	*/

	do while ("1"b);

	     m = m + 1;				/* wrap up */
						/* set rf_ptr to next token pointer in stack	*/

	     if sf_category_sw = 1			/* Category was changed from numeric to alphanumeric */
	     then do;

		     sf_ptr -> data_name.numeric = "1"b;
		     sf_ptr -> data_name.alphanum = "0"b;
		end;

	     if sf_category_sw = 2			/* Category was changed from alphanumeric to numeric */
	     then do;

		     sf_ptr -> data_name.alphanum = "1"b;
		     sf_ptr -> data_name.numeric = "0"b;
		end;

/*[5.1-1]*/
	     if m > n_rf
	     then go to move_done;

/*
			   If sending (sf) and receiving (rf) fields overlap or sf is sub-
			   scripted, and there are more than one receiving field,
			   the contents of the sending filed are copied into the
			   stack and this temporary is used as the sending field.  This is
			   done to insure that the original value if sf (as it existed at
			   the beginning of the MOVE operation) is moved to each rf.  If
			   sf is numeric with leading separate sign (sign_type - "100"b),
			   the temporary is defined as numeric with trailing separate sign
			   (sign_type = "011"b).  (Depending upon the rf, a change in sf
			   from leading to trailing sign may be required for implementa-
			   tion purposes.  The change is made here to eliminate the pos-
			   sibility of moving from one temp to another.)  In all other
			   cases, an alphanumeric (MLR) move is employed.
			   */
begin:						/*[5.1-1]*/
	     rf_ptr = in_token.token_ptr (m + 2);	/*[5.1-1]*/
	     sf_ptr = save_sf_ptr;

/*[4.4-2]*/
	     if sf_ptr -> data_name.type = 13
	     then call type_13_to_9 (sf_ptr, addr (SF_dn));

/* sending field is type 13 token */

/*[4.4-2]*/
	     if rf_ptr -> data_name.type = 13
	     then call type_13_to_9 (rf_ptr, addr (RF_dn));

/* receiving field is type 13 token */


	     if sf_stack_sw ^= 1
	     then call move_stack;

/*	|*|	|*|	|*|	|*|	|*|	|*|
			   check data type of sending field
			
			   ck sf = type-9 data name
			   if yes, goto move_4
			   if not,
			   ck sf = type-3 alphanumeric literal
			   if yes,
			   - pool literal and create type-9 token
			   for it (via cobol_make_type9$type2_3)
			   - set created token as sending field token
			   - ck literal preceeded by word "ALL"
			   if yes, goto move_fig_con_al
			   if not, goto move_4
			   if not,
			   ck sf = type-2 numeric literal
			   if yes, goto move_3
			   if not,
			   ck sf = type-1 figurative constant
			   if yes, goto fig_con_rw
			
			   if not, call error (illegal sending field)
			
			   |*|	|*|	|*|	|*|	|*|	|*|	*/

	     if (sf_ptr -> data_name.type = 9)
	     then call move_type9;

	     else if (sf_ptr -> data_name.type = 3)
	     then call move_type3;

	     else if sf_ptr -> data_name.type = 2
	     then call move_type2;
	     else if sf_ptr -> data_name.type = 1
	     then call move_fig_con_rw;
	     else do;
		     call error (msg_1);
		     go to move_done;
		end;

	end;

move_done:/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(MY_NAME);/**/
	return;

move_init:
     proc;

	if (control_no ^= cobol_$compile_count)
	then do;

		move_num = 0;
		control_no = cobol_$compile_count;
	     end;

	move_num = move_num + 1;

	if (in_token.token_ptr (1) ^= null)
	then do;

		rw_ptr = in_token.token_ptr (1);
		lin = reserved_word.line;
		col = reserved_word.column;

		if ((lin = 0) & (col = 0))
		then ival_num = ival_num + 1;
	     end;
	else do;

		sf_ptr = in_token.token_ptr (2);
		lin = sf_ptr -> data_name.line;
		col = sf_ptr -> data_name.column;
		move_num = move_num - 1;
		nc_move_num = nc_move_num + 1;
	     end;

/*	|*|	|*|	|*|	|*|	|*|	|*|	|*|	*/

/*	|*|	|*|	|*|	|*|	|*|	|*|
			   set sf_ptr = in_token.token_ptr(2)
			   set eos_ptr = in_token.token_ptr(n)
			   get # receiving fields from end_stmt.e
			   set receiving field idx (m) =0
			   set overlap switch = 0
			   set error_sw = 0;
			   create pointers to based data
			   |*|	|*|	|*|	|*|	|*|	|*|	*/

	sf_ptr, save_sf_ptr = in_token.token_ptr (2);
	eos_ptr = in_token.token_ptr (in_token.n);

	if end_stmt.e > 9999
	then do;

		end_stmt.e = end_stmt.e - 10000;
		only_an = "1"b;
	     end;
	else only_an = "0"b;

	n_rf = end_stmt.e;				/*[5.1-1]*/
	m = 1;
	input_ptr = addr (ips);
	inst_ptr = addr (eis_);
	reloc_ptr = addr (reloc_info);
	new_sf_ptr = addr (new_sf_tkn);
	ms_ptr = addr (ms_tkn);
	sf_cpy_ptr = addr (sf_tkn_cpy);
	rf_cpy_ptr = addr (rf_tkn_cpy);
	temp_tkn_ptr = addr (temp_tkn);
	sf_category_sw = 0;
	numeric_lit_flag = 0;
	sf_stack_sw = 0;

	if fixed_common.obj_dec_comma = "0"b
	then obj_dec_pt_char = ".";
	else obj_dec_pt_char = ",";

	currency_char = fixed_common.object_sign;

     end;


move_stack:
     proc;

	if (rf_ptr -> data_name.overlap & sf_ptr -> data_name.type = 9)
	     | (sf_ptr -> data_name.type = 9 & sf_ptr -> data_name.subscripted = "1"b & n_rf > 1)
	then do;

/* Allocate space on stack and create token for temp */
		sf_stack_sw = 1;
		size = sf_ptr -> data_name.item_length;

		call cobol_alloc$stack (size, 0, stk_offset);

		substr (new_sf_ptr -> rec_tkn, 1, sf_ptr -> data_name.size) =
		     substr (sf_ptr -> snd_tkn, 1, sf_ptr -> data_name.size);

		new_sf_ptr -> data_name.linkage_section = "0"b;
		new_sf_ptr -> data_name.subscripted = "0"b;
		new_sf_ptr -> data_name.seg_num = 1000;
		new_sf_ptr -> data_name.offset = stk_offset;

		if sf_ptr -> data_name.numeric
		then do;

			if sf_ptr -> data_name.sign_type = "100"b
			then new_sf_ptr -> data_name.sign_type = "011"b;

			call num_to_num (sf_ptr, new_sf_ptr);

		     end;
		else call gen_move_alpha (MLR, "000100000"b, sf_ptr, new_sf_ptr, "0"b);

		sf_ptr, save_sf_ptr = new_sf_ptr;
	     end;

     end;


move_type3:
     proc;/***..... dcl LOCAL_NAME char (10) int static init ("MOVE_TYPE3");/**/
	/***.....	if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/
	alit_ptr = sf_ptr;

	if (alphanum_lit.all_lit)
	then do;

/* sf token is type3, alphanumeric literal, with all_lit bit
				   set to 1.  Input was ALL literal, where literal is NOT one
				   of the other figurative constants.  Copy literal into
				   lit_str and set lit_ln to length of literal.	   */

		lit_ln = alphanum_lit.lit_size;
		substr (lit_str, 1, lit_ln) = substr (alphanum_lit.string, 1, lit_ln);

		call move_fig_con;

	     end;

	else if ^(rf_ptr -> data_name.alphanum_edited) & ^(rf_ptr -> data_name.numeric_edited)
	     & ^(rf_ptr -> data_name.numeric) & ^(rf_ptr -> data_name.alphabetic_edited)
	     & ^(rf_ptr -> data_name.variable_length) & ^(rf_ptr -> data_name.just_right)
	     & ^(rf_ptr -> data_name.subscripted)
	then do;

		lit_ln = alphanum_lit.lit_size;

		call gen_move_lit (alphanum_lit.string, lit_ln, rf_ptr);

	     end;
	else do;

		call cobol_make_type9$type2_3 (new_sf_ptr, sf_ptr);

		sf_ptr, save_sf_ptr = new_sf_ptr;

		call move_type9;

	     end;

	/***.....	if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/

     end;


/*	|*|	|*|	|*|	|*|	|*|	|*|
			   sending field = type-2 numeric literal
			   check receiving field = binary data
			   - if not, goto alloc_nl
			   - if yes, ck literal for fractional component
			   if yes, goto alloc_nl
			   if not, ck magnitude of literal value for pooling
			   if (lit val > (2**18)-1), then:
			   create binary equivalent of literal value
			   allocate this value as literal (alloc_nl)
			   if (lit val < or = (2**18)-1) then:
			   get (and LOCK) A (or Q) Register
			   generate LDA or LDQ - DIRECT (upper or lower)
			
			   - alloc_nl:
			   - allocate numeric literal
			   - create type-9 token for allocated literal
			   (via make_t9_from_t2)
			   - continue processing at move_4
			   |*|	|*|	|*|	|*|	|*|	|*|	*/

move_type2:
     proc;/***..... dcl LOCAL_NAME char (10) int static init ("MOVE_TYPE2");/**/
	/***.....	if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/
	nlit_ptr = sf_ptr;

/* allocate literal and create type-9 token
				   continue processing at move_4 */

	sf_ptr, save_sf_ptr = addr (new_sf_tkn);
	substr (new_sf_tkn, 1, 250) = (250)"";
	substr (new_sf_tkn, 251, 250) = (250)"";

	if rf_ptr -> data_name.bin_18
	then call cobol_make_bin_const (nlit_ptr, sf_ptr, 3);

	else if rf_ptr -> data_name.bin_36
	then call cobol_make_bin_const (nlit_ptr, sf_ptr, 4);

	else do;

		sf_ptr -> data_name.size = 112;
		sf_ptr -> data_name.line = numeric_lit.line;
		sf_ptr -> data_name.type = 9;
		sf_ptr -> data_name.elementary = "1"b;
		sf_ptr -> data_name.numeric = "1"b;
		sf_ptr -> data_name.display = "1"b;

		numeric_lit_flag = 1;

		if (numeric_lit.integral)
		then sf_ptr -> data_name.pic_integer = "1"b;

		sf_ptr -> data_name.places_left = numeric_lit.places_left;
		sf_ptr -> data_name.places_right = numeric_lit.places_right;

		lit_ln, sf_ptr -> data_name.item_length = numeric_lit.places;
		substr (lit_str, 1, lit_ln) = substr (numeric_lit.literal, 1, lit_ln);

		if (numeric_lit.sign ^= space)
		then do;

			sf_ptr -> data_name.sign_separate = "1"b;
			sf_ptr -> data_name.sign_type = "011"b;
			sf_ptr -> data_name.item_length = sf_ptr -> data_name.item_length + 1;
			substr (lit_str, lit_ln + 1, 1) = substr (numeric_lit.sign, 1, 1);
		     end;
		else do;

			sf_ptr -> data_name.sign_type = "000"b;
			substr (lit_str, lit_ln + 1, 1) = " ";
		     end;

		call cobol_pool$search_op (substr (lit_str, 1, sf_ptr -> data_name.item_length), 0, cs_offset, in_op);

		if in_op = 1
		then sf_ptr -> data_name.seg_num = 3;
		else sf_ptr -> data_name.seg_num = 3000;

		sf_ptr -> data_name.offset = cs_offset;

	     end;

	call move_type9;

	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/

     end;

/*	|*|	|*|	|*|	|*|	|*|	|*|
			   sending field = type-9 data name
			   check receiving field parameters

			   check rf = type-9 data name

			   - if not, call error (illegal receiving field)

			   check group-move (either sf or rf = non-elementary)
			   - if yes, goto move_alpha  (group-move = alpha data move)

			   check sf = numeric data type

			   - if not, then sf={a}|{an}; (where {an}:={an}|{ae}|{ane}|{n}|{ne})
			   ck rf = alphabetic or alphanumeric
			   if yes, {a or an -> a or an} goto move_alpha
			   if not, ck rf = alpha-ed or alphanum-ed
			   if yes, sf={a}|{an} -> rf={ae}|{ane} goto move_alpha_edit
			   if not, then, sf = {an} and rf = {n} or {ne}
			   copy sf token
			   set token_copy to numeric
			   set sf_ptr to token_copy
			   continue at sf = {n}
			   - if yes, then sf = {n}
			   ck rf = numeric
			   if yes, {n -> n} goto move_num
			   if not, ck rf = numeric_edited
			   if yes, {n} -> {ne} goto move_num_ed
			   if not, then sf = {n} and rf = {an}
			   continue at ck_n_an
			   |*|	|*|	|*|	|*|	|*|	|*|	*/

move_type9:
     proc;/***..... dcl LOCAL_NAME char (10) int static init ("MOVE_TYPE9");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/

/*[4.4-1]*/
	ne_bit = sf_ptr -> data_name.numeric;

	if (rf_ptr -> data_name.type ^= 9)
	then call error (msg_2);

	else if (rf_ptr -> data_name.non_elementary)
	then do;

		if sf_ptr -> data_name.non_elementary = "0"b
		then do;

			if sf_ptr -> data_name.numeric
			then do;

				if sf_ptr -> data_name.variable_length
				then do;

					move_special_bit = "1"b;
					call move_special;

				     end;

				else do;

					sf_category_sw = 1;
					sf_ptr -> data_name.numeric = "0"b;
					sf_ptr -> data_name.alphanum = "1"b;

					call move_alpha;

				     end;
			     end;

			else call move_alpha;

		     end;

		else call move_alpha;

	     end;

	else if sf_ptr -> data_name.non_elementary
	then do;					/*  Source is non-elementary.  */

		if rf_ptr -> data_name.non_elementary = "0"b
		then if rf_ptr -> data_name.numeric
		     then do;			/*  Target is numeric.  */
						/*  Change target token so that it looks like an alphanumeric.  */
			     rf_ptr -> data_name.numeric = "0"b;
			     rf_ptr -> data_name.alphanum = "1"b;

			end;			/*  Target is numeric.  */

		call move_alpha;

	     end;					/*  Source is non-elementary.  */

	else if (sf_ptr -> data_name.numeric)
	then call ck_n_ne;



	else do;

		if sf_ptr -> data_name.numeric_edited
		then do;

/* The only legal receiving items for ne sending items
						   are an and ane.  In moves involving such data as
						   receiving items, the sending items must be described
						   as alphanumeric.  Make one time change in sending
						   item.				       */
			sf_ptr -> data_name.numeric_edited = "0"b;
			sf_ptr -> data_name.alphanum = "1"b;
			sf_ptr -> data_name.places_left = sf_ptr -> data_name.item_length;

		     end;

/*	sf = {a}|{an}|{ae}|{ane} ck rf = {a}|{an}|{ae}|{ane})     */

		if rf_ptr -> data_name.alphanum | rf_ptr -> data_name.alphabetic
		then call move_alpha;

		else if rf_ptr -> data_name.alphanum_edited | rf_ptr -> data_name.alphabetic_edited
		then call move_alpha_edit;

		else call move_special;

	     end;

	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/

     end;

move_special:
     proc;/***..... dcl LOCAL_NAME char (12) int static init ("MOVE_SPECIAL");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/

	if (sf_ptr -> data_name.seg_num <= 5008 & sf_ptr -> data_name.seg_num >= 5000)
	     | (sf_ptr -> data_name.seg_num <= 12287 & sf_ptr -> data_name.seg_num >= 8192) | move_special_bit = "1"b
	then do;

/*  Length of the source is in a register, not in the data name token.  */
/*  NOTE:  Segment number 5000 thru 5008 and 8192 thru 12287 occur
				   only when the STRING/UNSTRING generator is attempting to STRING/UNSTRING
				   an alphanumeric into a numeric.  This is a VERY SPECIAL CASE
				   and is handled here, only for convenience of STRING/UNSTRING.  */

/*  Must move the source (an alphanumeric), into a temporary,
				   right justified, with leading decimal zeroes.  */

		call cobol_alloc$stack (32, 0, ret_offset);

/*  Make an alphanumeric token for the temporary.  */
		work_sf_ptr = null ();

		call cobol_make_type9$alphanumeric (work_sf_ptr, 1000, fixed (ret_offset, 24), 32);


/*  Move the source into the temporary.  */

		if move_special_bit
		then do;

			move_special_bit = "0"b;

			call gen_move_alpha (MLR, "000110000"b, sf_ptr, work_sf_ptr, "0"b);

		     end;

		else call gen_move_alpha (MRL, "000110000"b /* decimal zero  */, sf_ptr, work_sf_ptr, "0"b);

		sf_ptr = work_sf_ptr;

	     end;					/*  Length of the source is in a register, not in the data name token.  */

/*	sf = {an}; rf = {n} or {ne}
				   set numeric bit in token to "1"b
				   continue at ck_n_ne		*/

	sf_category_sw = 2;
	sf_ptr -> data_name.numeric = "1"b;
	sf_ptr -> data_name.alphanum = "0"b;
	sf_ptr -> data_name.places_left = sf_ptr -> data_name.item_length;
	sf_ptr -> data_name.display = "1"b;

	call ck_n_ne;

	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/

     end;

ck_n_ne:
     proc;/***..... dcl LOCAL_NAME char (7) int static init ("CK_N_NE");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/

	if rf_ptr -> data_name.numeric
	then call num_to_num (sf_ptr, rf_ptr);

	else if rf_ptr -> data_name.numeric_edited
	then call move_numer_ed;

/*	|*|	|*|	|*|	|*|	|*|	|*|
				   sf = {n}; rf = {an} or {ane}
				   Operational separate signs are not moved from n to an
				   or ane receiving fields, therefore -
				   - copy sf, set item_length to item_length-1, and sign
				   type to "000"b
				   - if sign type of sf is trailing separate, set sf_ptr
				   to point to new token
				   - if sign type is leading sign, generate MVN instruc-
				   tion to move sf to a stack temporary defined by new
				   token;  then set sf_ptr to point to new token
				   */

	else do;

		substr (sf_cpy_ptr -> rec_tkn, 1, sf_ptr -> data_name.size) =
		     substr (sf_ptr -> snd_tkn, 1, sf_ptr -> data_name.size);

/*[4.2-2]*/
		if sf_ptr -> data_name.display & sf_ptr -> data_name.sign_type = "100"b
						/*[4.2-2]*/
		then do;
			sf_ptr -> data_name.offset = sf_ptr -> data_name.offset + 1;
						/* lead sep sign */
						/*[4.2-2]*/
			sf_cpy_ptr = sf_ptr;	/*[4.2-2]*/
		     end;

/*[4.2-2]*/
		else if ^sf_ptr -> data_name.display /*[4.2-2]*/
		     |
		     /*[4.2-2]*/ (sf_ptr -> data_name.display /*[4.2-2]*/
		     & /*[4.2-2]*/ sf_ptr -> data_name.item_signed /*[4.2-2]*/
		     & /*[4.2-2]*/ ^sf_ptr -> data_name.sign_separate /*[4.2-2]*/)
		then do;


/*  Source variable is leading separate sign, overpunch, or not display (i.e. is packed dec or bin)  */
/*  Generate code to convert source to unpacked decimal trailing  sign  */

			call num_to_udts (sf_ptr, sf_cpy_ptr, return_code);

			if return_code ^= 0
			then go to ckx;

		     end;

/*  Source variable is leading separate sign, or not display (i.e. is packed dec or bin  */

		if sf_cpy_ptr -> data_name.sign_separate
		then sf_cpy_ptr -> data_name.item_length = sf_cpy_ptr -> data_name.item_length - 1;

		sf_ptr = sf_cpy_ptr;
		sf_ptr -> data_name.alphanum = "1"b;
		sf_ptr -> data_name.numeric = "0"b;


		if (rf_ptr -> data_name.alphanum)
		then call move_alpha;
		else call move_alpha_edit;

	     end;

ckx:	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/
     end;

/*	ALPHA MOVE (alphabetic and/or alphanumeric)   */

/*	|*|	|*|	|*|	|*|	|*|	|*|
				   sf and rf described by input (or created) type-9 tokens
				   ck rf = JUSTIFIED
				   if yes, instr = MRL
				   if not, instr = MLR
				   set FILL = SPACE
				   generate proper EIS alpha move instruction (via cobol_addr)
				   build DESCRIPTORS (for sf and rf)
				   emit instruction (via cobol_emit)
				   on completion, goto move_0
				   |*|	|*|	|*|	|*|	|*|	|*|	*/


move_alpha:
     proc;/***..... dcl LOCAL_NAME char (10) int static init ("MOVE_ALPHA");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/

	if (rf_ptr -> data_name.just_right)
	then instr = MRL;
	else instr = MLR;

/* [4.0-2] */
/*	if (rf_ptr -> data_name.non_elementary & rf_ptr -> data_name.variable_length) then rf_ptr ->
   data_name.variable_length = "0"b;	*/
/* [4.0-2] */

	call gen_move_alpha (instr, "000100000"b, sf_ptr, rf_ptr, "0"b);

	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/

     end;

/*	NUMERIC MOVE	*/

/*	|*|	|*|	|*|	|*|	|*|	|*|
				   sf and rf described by input (or created) type-9 tokens
				   ck sf = decimal
				   if yes, {sf = dec}
				   ck rf = decimal
				   if yes, {sf=dec; rf=dec} go to ck_sign
				   if not, {sf=dec; rf=bin}
				   ck sf = numeric integer (ni)
				   if yes, {sf=dec(ni); -> rf=bin}
				   - generate eis DTB instruction
				   - return
				   if not, {sf=dec(nni) -> rf=bin}
				   - allocate space on stack (= integer portion of sf)
				   - create type-9 token for temp_rf (on stack)
				   - set rounded bit if actual rf = rounded
				   - generate MVN {dec->dec} to move integer portion of
				   actual sf to temp_rf (on stack)
				   - establish temp_rf (on stack) as actual sf
				   - goto generate DTB (above) to move (and convert)
				   temp_rf (= integer portion of actual sf)
				   to actual rf
				   -return
				   if not, {sf = binary}
				   ck rf = decimal
				   if not, {sf=bin; rf=bin}
				   - get and LOCK A (or Q) register
				   - generate LDA (or LDQ) using instr_basic and input_basic
				   num_1: - generate STA (or STQ) using instr_basic and input_basic
				   - UNLOCK A (or Q) register
				   - return
				   if yes, {sf=bin; rf=dec}
				   ck rf = integer
				   if yes, {sf=bin -> dec(ni)}
				   - reset non_int_sw (=0)
				   - goto generate BTD (below)
				   if not, {sf=bin -> dec(nni)}
				   - set non_int_sw (=1)
				   - allocate space on stack(= integer portion of rf)
				   - create type-9 token for temp_rf (on stack)
				   - generate BTD move to move actual sf to temp_rf (on stack)
				   - establish temp_rf (on stack) as actual_sf
				   - ck non_integer_switch (=0?)
				   if yes, {complete 2nd part of non-integer bin->dec move}
				   - generate  MVN to move temp_rf (= converted
				   integer portion of bin sf (on stack) to actual_rf
				   - return
				   if not, {bin integer sf moved & converted to dec rf}
				   - return
				   |*|	|*|	|*|	|*|	|*|	|*|	*/

/*	FIGURATIVE CONSTANT MOVE	*/

/*	|*|	|*|	|*|	|*|	|*|	|*|
				   figurative constant moves come in two flavors:
				   |*|	|*|	|*|	|*|	|*|	|*|	|*|	*/

move_fig_con_rw:
     proc;					/* sf token is type1, reserved word.  Input was figurative
						   constant including ALL literal where literal IS one of the
						   other figurative constants.  (ALL ZEROS, for example has
						   been replaced by its equivalent, ZERO, by PD Syntax.      */
						/* Identify figurative constant from key, place corresponding
						   character in lit_str, and set lit_ln to 1.		   */

	/***..... dcl LOCAL_NAME char (15) int static init ("MOVE_FIG_CON_RW");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/

	rw_ptr = sf_ptr;
	lit_ln = 1;

	if reserved_word.key = fc_zero
	then do;

/* Special code included to process MOVE ZERO TO $.
				   statement generated by ddalloc as part of size
				   routine for OCCOUS ---- DEPENDING clauses.	        */

		if rf_ptr -> data_name.temporary
		     & substr (rf_ptr -> data_name.name, 1, rf_ptr -> data_name.name_size) = "$"
		then do;

			input_struc_basic.type = 1;
			input_struc_basic.operand_no = 0;
			input_struc_basic.lock = 0;
			input_struc_basic.segno = rf_ptr -> data_name.seg_num;
			input_struc_basic.char_offset = rf_ptr -> data_name.offset;
			input_struc_basic.send_receive = 1;

			call cobol_addr (input_ptr, addr (stz_inst), null);

			call cobol_emit (addr (stz_inst), null, 1);

		     end;

		else do;

			substr (lit_str, 1, 1) = zero;
			call move_fig_con;

		     end;
	     end;

	else if reserved_word.key = fc_space
	then do;

		substr (lit_str, 1, 1) = space;

		call move_fig_con;

	     end;

	else if reserved_word.key = fc_hival
	then do;

		if cobol_$main_pcs_ptr ^= null ()
		then substr (lit_str, 1, 1) = cobol_$main_pcs_ptr -> alphabet_name.hival_char;
		else substr (lit_str, 1, 1) = hival;

		call move_fig_con;

	     end;

	else if reserved_word.key = fc_loval
	then do;

		if cobol_$main_pcs_ptr ^= null ()
		then substr (lit_str, 1, 1) = cobol_$main_pcs_ptr -> alphabet_name.loval_char;
		else substr (lit_str, 1, 1) = loval;

		call move_fig_con;

	     end;

	else do;

		if reserved_word.key = fc_quote
		then substr (lit_str, 1, 1) = quote;

		call move_fig_con;

	     end;

	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/

     end;

move_fig_con:
     proc;					/* Proceed on basis of rf data category */
	/***..... dcl LOCAL_NAME char (12) int static init ("MOVE_FIG_COM");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/

	if rf_ptr -> data_name.alphanum | rf_ptr -> data_name.alphabetic = "1"b
	     | rf_ptr -> data_name.non_elementary = "1"b
	then do;

		if lit_ln = 1
		then do;

			call replicate;

			go to mfcx;
		     end;
		else do;

			pl = rf_ptr -> data_name.item_length;
						/* Compute minimum length string that must be created
						   and pooled.				   */
						/*[4.0-1]*/
			if pl > 128 & pl > lit_ln
			then do;

/*[4.0-1]*/
				req_ln = ((lit_ln + 127) / lit_ln) * lit_ln;
				if req_ln >= pl
				then req_ln = pl;
			     end;
			else req_ln = pl;

			call build_litstr;

			if (req_ln = pl) & (rf_ptr -> data_name.subscripted = "0"b)
			then do;

				call gen_move_lit (lit_str, req_ln, rf_ptr);

			     end;
			else do;

				call cobol_pool$search_op (substr (lit_str, 1, req_ln), 0, cs_offset, in_op);

				set_ptr_struc.what_pointer = 10;
				set_ptr_struc.lock = 0;
				set_ptr_struc.switch = 0;

				call cobol_set_pr (addr (set_ptr_struc), rf_ptr);

				if in_op = 1
				then eis_ (1) = "000100000001000000001000000101000000"b;
				else eis_ (1) = "000100000001000000001000000100000100"b;

				i = -(cs_offset / 4 + cobol_$text_wd_off);
				substr (inst_struc.desc.desc_od (1), 1, 18) = substr (unspec (i), 19, 18);
				substr (inst_struc.desc.desc_od (1), 19, 6) = "000000"b;
				substr (inst_struc.desc.desc_od (1), 25, 12) = substr (unspec (req_ln), 25, 12);
				substr (inst_struc.desc.desc_od (2), 1, 3) = set_ptr_struc.pointer_no;
				substr (inst_struc.desc.desc_od (2), 4, 15) = (15)"0"b;
				substr (inst_struc.desc.desc_od (2), 19, 18) =
				     substr (inst_struc.desc.desc_od (1), 19, 18);

				call cobol_emit (inst_ptr, null, 3);

				eis_ (1) = "000100000001000000001000000101000000"b;
				inst_struc.desc.desc_od (1) = inst_struc.desc.desc_od (2);

				substr (inst_struc.desc.desc_od (2), 4, 17) = substr (unspec (req_ln), 20, 17);

				i = pl - req_ln;

				substr (inst_struc.desc.desc_od (2), 25, 12) = substr (unspec (i), 25, 12);

				call cobol_emit (inst_ptr, null, 3);

			     end;
		     end;
		go to mfcx;
	     end;

	if rf_ptr -> data_name.alphanum_edited | rf_ptr -> data_name.alphabetic_edited = "1"b
	then do;

		req_ln = rf_ptr -> data_name.places_left;

		call build_litstr;

		call cobol_pool$search_op (substr (lit_str, 1, req_ln), 0, cs_offset, in_op);

		if in_op = 0
		then temp = 3000;
		else temp = 3;

		call cobol_make_type9$alphanumeric (new_sf_ptr, temp, cs_offset, req_ln);

		sf_ptr = new_sf_ptr;
		call move_alpha_edit;

		go to mfcx;
	     end;

	pl = rf_ptr -> data_name.places_left;
	pr = rf_ptr -> data_name.places_right;

	if rf_ptr -> data_name.numeric
	then do;

		if pl > 0
		then do;

			if pr > 0
			then do;

				req_ln = pl;
				pr = 0;
			     end;
			else req_ln = pl + pr;

			call build_litstr_right_just;

		     end;
		else do;

			substr (lit_str, 1, 1) = zero;
			pl = 1 - pr;
		     end;
	     end;
	else do;

		if pl > 0
		then do;

			if pr > 0
			then req_ln = pl;
			else req_ln = pl + pr;

			call build_litstr_right_just;

		     end;
		else req_ln = 0;
		if pr > 0
		then substr (lit_str, req_ln + 1, pl + pr - req_ln) = (30)"0";
	     end;

	call cobol_pool$search_op (substr (lit_str, 1, pl + pr), 0, cs_offset, in_op);

	if in_op = 0
	then temp = 3000;
	else temp = 3;

	call cobol_make_type9$decimal_9bit (new_sf_ptr, temp, cs_offset, pl, pr);

	sf_ptr = new_sf_ptr;
	sf_ptr -> data_name.sign_type = "000"b;
	sf_ptr -> data_name.item_signed = "0"b;
	sf_ptr -> data_name.sign_separate = "0"b;
	sf_ptr -> data_name.item_length = pl + pr;

	if rf_ptr -> data_name.numeric
	then call num_to_num (sf_ptr, rf_ptr);
	else call move_numer_ed;

mfcx:	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/
     end;

move_alpha_edit:
     proc;/***..... dcl LOCAL_NAME char (15) int static init ("MOVE_ALPHA_EDIT");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/

	ecm_ptr = addr (ecm);
	mop_ptr = addr (mop);
	delta = fixed (substr (unspec (rf_ptr -> data_name.edit_ptr), 1, 34), 36);
	edit_ptr = addrel (rf_ptr, delta);
	ecm_lnth = editor.ecm_size;
	substr (ecm_str, 1, ecm_lnth) = substr (editor.ecm, 1, ecm_lnth);

	sf_places = sf_ptr -> data_name.item_length;
	rf_places = rf_ptr -> data_name.places_left;
	rf_length = rf_ptr -> data_name.item_length;

	if rf_length > 63
	then if rf_ptr -> data_name.subscripted
	     then do;

		     rf_temp_sw = 1;

		     call cobol_alloc$stack (rf_length, 0, stk_offset);

		     substr (rf_cpy_ptr -> rec_tkn, 1, rf_ptr -> data_name.size) =
			substr (rf_ptr -> snd_tkn, 1, rf_ptr -> data_name.size);

		     save_rf_ptr = rf_ptr;
		     rf_ptr = rf_cpy_ptr;
		     rf_ptr -> data_name.linkage_section = "0"b;
		     rf_ptr -> data_name.subscripted = "0"b;
		     rf_ptr -> data_name.seg_num = 1000;
		     rf_ptr -> data_name.offset = stk_offset;
		end;

	if sf_places > 63
	then if sf_ptr = save_sf_ptr
	     then do;

		     substr (sf_cpy_ptr -> rec_tkn, 1, sf_ptr -> data_name.size) =
			substr (sf_ptr -> snd_tkn, 1, sf_ptr -> data_name.size);

		     sf_ptr = sf_cpy_ptr;
		end;

	if rf_places > sf_places
	then do;

		count = 0;
		no_chars = rf_places - sf_places;	/* Fix the move for scaled item. */
		if sf_ptr -> data_name.places_right < 0
		then no_char1 = -sf_ptr -> data_name.places_right;
		else no_char1 = 0;

		if rf_ptr -> data_name.just_right = "0"b
		then do n = ecm_lnth to 1 by -1 while (count < no_chars);
			if ecm (n) = DS
			then do;

				if count >= (no_chars - no_char1)
				then ecm (n) = "0";
				else ecm (n) = " ";
				count = count + 1;
			     end;
		     end;

		else do;

			no_chars = no_chars - no_char1;

			if no_chars > 0
			then do n = 1 to ecm_lnth by 1 while (count < no_chars);
				if ecm (n) = DS
				then do;

					ecm (n) = " ";
					count = count + 1;
				     end;
			     end;

			if no_char1 > 0
			then do;

				count = 0;
				do n = ecm_lnth to 1 by -1 while (count < no_char1);
				     if ecm (n) = DS
				     then do;

					     ecm (n) = "0";
					     count = count + 1;
					end;
				end;
			     end;
		     end;
		left_adjust = 0;
		right_adjust = 0;
	     end;

	else do;

		if rf_ptr -> data_name.just_right = "0"b
		then do;

			left_adjust = 0;
			right_adjust = sf_places - rf_places;
		     end;

		else do;

			left_adjust = sf_places - rf_places;
			right_adjust = 0;
		     end;

		if sf_places > 63
		then do;

			if left_adjust ^= 0
			then call calc_char_offset (left_adjust, sf_ptr);

			sf_ptr -> data_name.item_length = rf_places;
			sf_ptr -> data_name.places_left = rf_places;
			left_adjust = 0;
			right_adjust = 0;
		     end;
	     end;

/* For the move alphanumeric edited instruction, the maximum
				   allowable length of the sending operand, the micro opera-
				   tion, and the receiving operand is 63 characters.	   */

	opnd_ln = 0;
	n_mop = 1;
	rf_temp_sw = 0;

	do while (rf_length > 0);
	     insert_table_status = " *+-$,.0";
	     n_ecm = opnd_ln + 1;

	     if rf_length > 63
	     then opnd_ln = 63;
	     else opnd_ln = rf_length;

	     if left_adjust ^= 0
	     then do;

		     no_chars = left_adjust;
		     micro_op = ign;

		     call move_mult_micro_op;

		end;

	     ecm_limit = n_ecm + opnd_ln - 1;
	     do n = n_ecm to ecm_limit by 1;

		count = verify (substr (ecm_str, n, ecm_limit - n + 1), ecm (n));

		if count = 0
		then count = ecm_limit - n + 1;
		else count = count - 1;
		no_chars = count;

		if ecm (n) = DS
		then do;

			left_adjust = left_adjust + count;
			micro_op = mvc;

			call move_mult_micro_op;

		     end;

		else do;

			insrt_op = insp;

			call move_insert_chars;

		     end;

		n = n + count - 1;
	     end;

	     rf_length = rf_length - opnd_ln;

	     rf_ptr -> data_name.item_length = opnd_ln;
	     rf_ptr -> data_name.places_left = opnd_ln;
	     if sf_places > 63
	     then do;

		     sf_ptr -> data_name.item_length = left_adjust;
		     sf_ptr -> data_name.places_left = left_adjust;
		end;

	     else right_adjust = sf_places - left_adjust;

	     if right_adjust ^= 0
	     then do;

		     no_chars = right_adjust;
		     micro_op = ign;

		     call move_mult_micro_op;

		end;

	     if n_mop > 64
	     then do;

		     call error ("MOP string exceeds 63 char");

		     go to max;

		end;

	     call cobol_pool (substr (mop_str, 1, n_mop - 1), 0, cs_offset);

	     temp = 3000;

	     call cobol_make_type9$alphanumeric (ms_ptr, temp, cs_offset, n_mop - 1);

	     n_mop = 1;

	     call gen_move_edit (MVE, sf_ptr, rf_ptr, ms_ptr);

	     if rf_length ^= 0
	     then do;

		     call calc_char_offset (opnd_ln, rf_ptr);

		     if sf_places > 63
		     then do;

			     call calc_char_offset (left_adjust, sf_ptr);

			     sf_places = sf_places - left_adjust;
			     left_adjust = 0;
			end;
		end;

	end;

	if rf_temp_sw = 1
	then do;

		rf_ptr -> data_name.item_length = ecm_lnth;
		rf_ptr -> data_name.places_left = ecm_lnth;
		rf_ptr -> data_name.seg_num = 1000;
		rf_ptr -> data_name.offset = stk_offset;

		call gen_move_alpha (MLR, "000100000"b, rf_ptr, save_rf_ptr, "0"b);

	     end;

max:	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/
     end;

move_numer_ed:
     proc;/***..... dcl LOCAL_NAME char (13) int static init ("MOVE_NUMER_ED");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/

	if (sf_ptr -> data_name.display = "0"b)
	     | (sf_ptr -> data_name.display = "1"b & sf_ptr -> data_name.item_signed = "1"b
	     & sf_ptr -> data_name.sign_separate = "0"b)	/*  Must be overpunch sign  */
	then do;					/*  Sending field is not display, must convert it to display data.  */

		new_sf_ptr = null ();		/*  Utility provides space for the new token.  */

		call num_to_udts (sf_ptr, new_sf_ptr, return_code);

		sf_ptr = new_sf_ptr;
	     end;					/*  Sending field is not display, must convert it to display data.  */

	spl = sf_ptr -> data_name.places_left;
	spr = sf_ptr -> data_name.places_right;
	rpl = rf_ptr -> data_name.places_left;
	rpr = rf_ptr -> data_name.places_right;

	ecm_ptr = addr (ecm);
	mop_ptr = addr (mop);

	if rf_ptr -> data_name.edit_ptr ^= 0
	then do;

		delta = fixed (substr (unspec (rf_ptr -> data_name.edit_ptr), 1, 34), 36);
		edit_ptr = addrel (rf_ptr, delta);
		fx = editor.fixed_insert;
		fl = editor.float_insert;
		start_supp = editor.start_suppress;
		max_supp = editor.max_suppress;
		ecm_lnth = editor.ecm_size;
		substr (ecm_str, 1, ecm_lnth) = substr (editor.ecm, 1, ecm_lnth);
	     end;

	else do;

		ecm_lnth = rpl + rpr;
		rf_st = fixed (rf_ptr -> data_name.sign_type, 36);

		if rf_st = 4			/* Leading separate sign */
		then do;

			fx = 4;
			ecm (1) = "-";
			substr (ecm_str, 2, ecm_lnth) = (30)"f";
			ecm_lnth = ecm_lnth + 1;
		     end;

		else do;

			substr (ecm_str, 1, ecm_lnth) = (30)"f";

			if rf_st = 3		/* Trailing separate sign */
			then do;

				fx = 2;
				ecm_lnth = ecm_lnth + 1;
				ecm (ecm_lnth) = "-";
			     end;
			else fx = 0;
		     end;

		fl = 0;
		start_supp = 0;
		max_supp = 0;
	     end;

	end_supp = start_supp + max_supp - 1;

	left_adjust = spl - rpl;
	right_adjust = spr - rpr;
	if left_adjust >= 0
	then do;

		if right_adjust >= 0
		then overlap = rpl + rpr;
		else do;

			overlap = rpl + spr;

			if overlap < 0
			then do;

				overlap = 0;
				left_adjust = spl + spr;
				right_adjust = -(rpl + rpr);
			     end;
		     end;

	     end;

	else do;

		if right_adjust < 0
		then overlap = spl + spr;
		else do;

			overlap = spl + rpr;

			if overlap < 0
			then do;

				overlap = 0;
				left_adjust = -(rpl + rpr);
				right_adjust = spl + spr;
			     end;
		     end;
	     end;

	do n = 1 to ecm_lnth by 1 while (left_adjust < 0);

	     if ecm (n) = DS
	     then do;

		     ecm (n) = "0";
		     left_adjust = left_adjust + 1;
		end;

	end;

	do n = ecm_lnth to 1 by -1 while (right_adjust < 0);
	     if ecm (n) = DS
	     then do;

		     ecm (n) = "0";
		     right_adjust = right_adjust + 1;
		end;
	end;

	bwz = fixed (rf_ptr -> data_name.bwz, 36);
	awz = fixed (rf_ptr -> data_name.ast_when_zero, 36);
	asterisk = fixed (rf_ptr -> data_name.pic_has_ast, 36);
	sign = fixed (rf_ptr -> data_name.item_signed, 36);

/*  Treat awz = 1 as special case  */

	if awz = 1
	then do;

		if overlap ^= 0
		then call cmpn0_tnz;

		n = index (ecm_str, obj_dec_pt_char);

		if n = 0
		then do;

			substr (lit_str, 1, 1) = "*";

			call replicate;

		     end;
		else do;

			substr (lit_str, 1, 256) = (254)"*" || "**";
			substr (lit_str, n, 1) = obj_dec_pt_char;

			call cobol_pool (substr (lit_str, 1, n), 0, cs_offset);

			req_ln = n;

			call cobol_make_type9$alphanumeric (temp_tkn_ptr, 3000, cs_offset, req_ln);
			call gen_move_alpha (MLR, "000101010"b, temp_tkn_ptr, rf_ptr, "0"b);

		     end;

		if overlap = 0
		then go to mnx;
		else do;

			eis_ (1) = "000000000000000000111001000000000100"b /* tra	0,ic */;

			call cobol_emit (inst_ptr, null (), 1);
			call cobol_define_tag (tag);

			tag = cobol_$next_tag;
			cobol_$next_tag = cobol_$next_tag + 1;

			call cobol_make_tagref (tag, cobol_$text_wd_off - 1, null ());

		     end;
	     end;

/* Special cases of no overlap of sf and rf */

	if overlap = 0
	then do;

		if bwz = 1
		then do;

			substr (lit_str, 1, 1) = " ";

			call replicate;

			go to mnx;
		     end;

		if sign = 0			/* No fixed or floating sign insertion */
		then do;

			if asterisk = 1
			then supp_char = "*";
			else supp_char = " ";

			if start_supp ^= 0
			then do n = start_supp to end_supp by 1;

				ecm (n) = supp_char;

			     end;

			if fl = 1			/* Float currency suppression */
			then ecm (end_supp) = currency_char;

/*  Use ecm_str as sf */

			call cobol_pool$search_op (substr (ecm_str, 1, ecm_lnth), 0, cs_offset, in_op);

			if in_op = 0
			then temp = 3000;
			else temp = 3;

			req_ln = ecm_lnth;

			call cobol_make_type9$alphanumeric (temp_tkn_ptr, temp, cs_offset, req_ln);
			call gen_move_alpha (MLR, "000100000"b, temp_tkn_ptr, rf_ptr, "0"b);

			go to mnx;
		     end;
	     end;

/* End special cases */

	es_status = 0;				/* es off */
	bz_status = 0;				/* bz off */
	insert_table_status = " *+-$,.0";
	n_ecm = 1;
	n_mop = 1;

/* Take care of leading fixed sign insertion */

	if fx = 3
	then do;

		mop (1) = insn_4;
		n_mop = 2;
		n_ecm = 2;
	     end;

	if fx = 4
	then do;

		if bwz = 1
		then do;

			mop (1) = enf01;
			bz_status = 1;
		     end;
		else mop (1) = enf00;

		es_status = 1;
		n_mop = 2;
		n_ecm = 2;
	     end;

	if start_supp ^= 0
	then do;					/* Floating insertion or zero suppression specified */

		if n_ecm ^= start_supp
		then do;				/* Fixed insertion before float or zero suppress */

/* Set es on if not on and, if bwz = 1, set
				   bz on if not on.			   */

			call es_on_ck_bz;

			do n = n_ecm to start_supp - 1 by 1;

			     count = verify (substr (ecm_str, n, start_supp - n), ecm (n));

			     if count = 0
			     then count = start_supp - n;
			     else count = count - 1;

			     no_chars = count;
			     insrt_op = insb;

			     call move_insert_chars;

			     n = n + count - 1;
			end;

			n_ecm = start_supp;
		     end;

/* Ignore excess sf characters on left */

		if left_adjust ^= 0
		then do;

			no_chars = left_adjust;
			micro_op = ign;

			call move_mult_micro_op;

		     end;				/* Set es off if on;  bz on if not on and bwz = 1 */

		if bz_status = 0			/* off */
		then if bwz = 1
		     then do;

			     mop (n_mop) = ses01;
			     n_mop = n_mop + 1;
			     bz_status = 1;
			     es_status = 0;
			end;

		if es_status = 1			/* on */
		then do;

			mop (n_mop) = ses00;
			n_mop = n_mop + 1;
			es_status = 0;
		     end;

/* If insert table entry 1 is not /b, load with /b */

		if substr (insert_table_status, 1, 1) ^= " "
		then do;

			mop (n_mop) = lte_1;
			substr (mop_str, n_mop + 1, 1) = " ";
			substr (insert_table_status, 1, 1) = " ";
			n_mop = n_mop + 2;
		     end;

/* Treat zero suppression */

		if fl = 0
		then do;

			if asterisk = 1
			then do;

				micro_op = mvza;
				insrt_op = insa;
			     end;

			else do;

				micro_op = mvzb;
				insrt_op = insb;
			     end;

			call suppress;
			call es_on_ck_bz;
		     end;
		else do;

			n_ecm = n_ecm + 1;

			if fl = 1
			then do;

				if currency_char ^= "$"
				then do;

					mop (n_mop) = lte_5;
					substr (mop_str, n_mop + 1, 1) = currency_char;
					substr (insert_table_status, 5, 1) = currency_char;
					n_mop = n_mop + 2;
				     end;
				micro_op = mflc;
			     end;

			else do;

				if fl = 3
				then do;

					mop (n_mop) = lte_3;
					substr (mop_str, n_mop + 1, 1) = " ";
					substr (insert_table_status, 3, 1) = " ";
					n_mop = n_mop + 2;
				     end;
				micro_op = mfls;
			     end;

			insrt_op = insb;

			call suppress;

			if bz_status = 0		/* off */
			then if bwz = 1
			     then do;

				     if fl = 1
				     then mop (n_mop) = enf11;
				     else mop (n_mop) = enf01;

				     n_mop = n_mop + 1;
				     bz_status = 1;
				     es_status = 1;
				end;

			if es_status = 0
			then do;

				if fl = 1
				then mop (n_mop) = enf10;
				else mop (n_mop) = enf00;

				n_mop = n_mop + 1;
				es_status = 1;
			     end;
		     end;

		n_ecm = end_supp + 1;

/* Remainder of ecm string, if any, is processed as fixed
				   supression				   */

	     end;

	else do;					/* No float insertion or zero suppression */

/* Set es on if off; bz on if off and bwz = 1 */

		call es_on_ck_bz;

/* Ignore excess sf characters on left */

		if left_adjust ^= 0
		then do;

			no_chars = left_adjust;
			micro_op = ign;

			call move_mult_micro_op;

		     end;
	     end;

/* Set end of fixed insertion */

	if fx = 5
	then end_fix = ecm_lnth - 2;
	else if fx = 1 | fx = 2
	then end_fix = ecm_lnth - 1;
	else end_fix = ecm_lnth;

	do n = n_ecm to end_fix by 1;

	     count = verify (substr (ecm_str, n, end_fix - n + 1), ecm (n));
	     if count = 0
	     then count = end_fix - n + 1;
	     else count = count - 1;

	     no_chars = count;

	     if ecm (n) = DS
	     then do;

		     if bwz = 1
		     then do;

			     idx = index (substr (ecm_str, n + count, end_fix - (n + count - 1)), DS);

			     if idx = 0
			     then if substr (insert_table_status, 1, 1) ^= " "
				then do;

					mop (n_mop) = lte_1;
					substr (mop_str, n_mop + 1, 1) = " ";
					substr (insert_table_status, 1, 1) = " ";
					n_mop = n_mop + 2;
				     end;
			end;

		     micro_op = mvc;

		     call move_mult_micro_op;
		end;
	     else do;

		     insrt_op = insb;

		     call move_insert_chars;
		end;

	     n = n + count - 1;
	end;

/*  If bwz = 1, insure that insert table 1 is a /b */

	if bwz = 1
	then if substr (insert_table_status, 1, 1) ^= " "
	     then do;

		     mop (n_mop) = lte_1;
		     substr (mop_str, n_mop + 1, 1) = " ";
		     substr (insert_table_status, 1, 1) = " ";
		     n_mop = n_mop + 2;

		     if right_adjust = 0
		     then do;

			     sf_ptr -> data_name.item_length = sf_ptr -> data_name.item_length + 1;
			     sf_ptr -> data_name.places_right = sf_ptr -> data_name.places_right + 1;
			     right_adjust = 1;
			end;
		end;

/* Take care of trailing sign insertion */

	if fx = 5
	then do;

		mop (n_mop) = lte_1;
		substr (insert_table_status, 1, 1) = " ";
		substr (mop_str, n_mop + 1, 1) = " ";
		n_mop = n_mop + 2;

		do n = ecm_lnth - 1 to ecm_lnth by 1;
		     mop (n_mop) = insn_0;
		     substr (mop_str, n_mop + 1, 1) = ecm (n);
		     n_mop = n_mop + 2;
		end;
	     end;

	if fx = 1
	then do;

		mop (n_mop) = insn_4;
		n_mop = n_mop + 1;
	     end;

	if fx = 2
	then do;

		if es_status = 1
		then do;

			mop (n_mop) = ses00;
			n_mop = n_mop + 1;
		     end;

		mop (n_mop) = enf00;
		n_mop = n_mop + 1;
	     end;

/* Ignore excess trailing sf characters */

	if right_adjust ^= 0
	then do;

		no_chars = right_adjust;
		micro_op = ign;

		call move_mult_micro_op;
	     end;

/* Move */

	if n_mop > 64
	then call error ("MOP string exceeds 63 char");

	call cobol_pool (substr (mop_str, 1, n_mop - 1), 0, cs_offset);
	call cobol_make_type9$alphanumeric (ms_ptr, 3000, cs_offset, n_mop - 1);
	call gen_move_edit (MVNE, sf_ptr, rf_ptr, ms_ptr);

	if awz = 1
	then call cobol_define_tag (tag);

mnx:	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/
     end;

gen_move_edit:
     proc (instr, sf_tkn_ptr, rf_tkn_ptr, ms_tkn_ptr);
	/***..... dcl LOCAL_NAME char (13) int static init ("GEN_MOVE_EDIT");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/

dcl	instr		bit (10);
dcl	(sf_tkn_ptr, rf_tkn_ptr, ms_tkn_ptr)
			ptr;

	eis_ (1) = (36)"0"b;
	inst_struc.inst.fill1_op = instr;

	call set_ips_type5_6 (6, sf_tkn_ptr, rf_tkn_ptr, ms_tkn_ptr);

	call cobol_addr (input_ptr, inst_ptr, reloc_ptr);

	call cobol_emit (inst_ptr, reloc_ptr, 4);

	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/

     end gen_move_edit;

dec_zero:
     proc (temp_tkn_ptr);
	/***..... dcl LOCAL_NAME char (8) int static init ("DEC_ZERO");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/

/* This procedure causes an unsigned decimal"0"to be pooled
   in the constant section and creates a token for it in
   a buffer pointed to by temp_tkn_ptr.		   */
dcl	temp_tkn_ptr	ptr;
dcl	cs_offset		fixed bin (24);
dcl	temp_tkn		char (200) based (temp_tkn_ptr);

	call cobol_pool$search_op ("0", 0, cs_offset, in_op);

	if in_op = 0
	then temp = 3000;
	else temp = 3;
	substr (temp_tkn, 1, 200) = (200)"";
	temp_tkn_ptr -> data_name.type = 9;
	temp_tkn_ptr -> data_name.numeric = "1"b;
	temp_tkn_ptr -> data_name.display = "1"b;
	temp_tkn_ptr -> data_name.seg_num = temp;
	temp_tkn_ptr -> data_name.offset = cs_offset;
	temp_tkn_ptr -> data_name.places_left = 1;
	temp_tkn_ptr -> data_name.places_right = 0;
	temp_tkn_ptr -> data_name.item_length = 1;
	temp_tkn_ptr -> data_name.sign_type = "000"b;
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/

     end dec_zero;

cmpn0_tnz:
     proc;/***..... dcl LOCAL_NAME char (9) int static init ("CMPN0_TNZ");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/

/* This procedure generates instructions to compare a numeric
   sending field to decimal "0" and transfer if sending field
   is not zero. It also reserves a tag for the transfer instruction,
   makes a reference for it, and updates cobol_$next_tag.		*/

	call dec_zero (temp_tkn_ptr);

	eis_ (1) = (36)"0"b;
	inst_struc.inst.fill1_op = CMPN;

	call set_ips_type5_6 (5, sf_ptr, temp_tkn_ptr, null);

	call cobol_addr (input_ptr, inst_ptr, null);

	tag = cobol_$next_tag;
	cobol_$next_tag = cobol_$next_tag + 1;
	inst_struc.desc.desc_od (3) = "000000000000000000110000001000000100"b;

	call cobol_emit (inst_ptr, null, 4);

	call cobol_make_tagref (tag, cobol_$text_wd_off - 1, null);

	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/

     end cmpn0_tnz;

move_mult_micro_op:
     proc;/***..... dcl LOCAL_NAME char (19) int static init ("MOVE_MULTI_MICRO_OP");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/

/* This procedure generates in "mop_str" (or "mop"), starting
   at character number "n_mop", a sufficient number of "micro_op"
   micro operations to move "no_chars" characters.	   */

	do while (no_chars > 0);

	     if no_chars >= 16
	     then substr (micro_op, 6, 4) = "0000"b;
	     else substr (micro_op, 6, 4) = substr (unspec (no_chars), 33, 4);

	     no_chars = no_chars - 16;
	     mop (n_mop) = micro_op;
	     n_mop = n_mop + 1;

	end;

	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/

     end move_mult_micro_op;

move_insert_chars:
     proc;/***..... dcl LOCAL_NAME char (17) int static init ("MOVE_INSERT_CHARS");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/

/* This procedure generates in "mop_str" (or "mop"), starting
   at character number "n_mop", a sufficient number of micro
   operations to move "no_chars" insertion characters defined
   by "ecm(n)" without suppression.  "insm" is used if "no_chars"
   > 3 and the micro op contained in "insrt_op" if "no_chars" <= 3.
   */

	if no_chars > 3
	then do;

		if substr (insert_table_status, 1, 1) ^= ecm (n)
		then do;

			mop (n_mop) = lte_1;
			substr (mop_str, n_mop + 1, 1) = ecm (n);
			substr (insert_table_status, 1, 1) = ecm (n);
			n_mop = n_mop + 2;

		     end;

		micro_op = insm;

		call move_mult_micro_op;

	     end;

	else do;

		insert_char_no = index (insert_table_status, ecm (n));

		if insert_char_no = 0
		then if ecm (n) = " "
		     then do;

			     mop (n_mop) = lte_1;
			     substr (mop_str, n_mop + 1, 1) = " ";
			     substr (insert_table_status, 1, 1) = " ";
			     insert_char_no = 1;
			     n_mop = n_mop + 2;

			end;

		do idx = 1 to no_chars by 1;

		     substr (insrt_op, 6, 4) = substr (unspec (insert_char_no), 33, 4);
		     mop (n_mop) = insrt_op;
		     n_mop = n_mop + 1;

		     if insert_char_no = 0
		     then do;

			     substr (mop_str, n_mop, 1) = ecm (n);
			     n_mop = n_mop + 1;

			end;
		end;
	     end;

	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/

     end move_insert_chars;

es_on_ck_bz:
     proc;/***..... dcl LOCAL_NAME char (11) int static init ("ES_ON_CK_BZ");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/

/* This procedure generates a "ses" micro op in "mop_str" (or
   "mop"), at character number "n_mop", to set the es flag on
   if it is not already on and bwz = 0 or bwz = 1 and the bz
   flag is already on or to set both the es and bz flags on if
   bwz = 1 and bz is not already on.			   */

	if bz_status = 0				/* off */
	then if bwz = 1
	     then do;

		     mop (n_mop) = ses11;
		     n_mop = n_mop + 1;
		     bz_status = 1;
		     es_status = 1;

		end;

	if es_status = 0				/* off */
	then do;

		mop (n_mop) = ses10;
		n_mop = n_mop + 1;
		es_status = 1;

	     end;


	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/

     end es_on_ck_bz;

suppress:
     proc;/***..... dcl LOCAL_NAME char (8) int static init ("SUPPRESS");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/

/* This procedure generates the micro operations in "mop_str"
   (or "mpo"), starting at character number "n_mop" for the
   supression portion of an edit numeric move.  Processing of
   "ecm_str" (or "ecm") commences at character number "n_ecm"
   and ends with character number "end_supp".  The micro oper-
   ation contained in "micro_op" is used to move digit charact-
   ers and that in "insrt_op" to move insertion characters.  */

	do n = n_ecm to end_supp by 1;

	     count = verify (substr (ecm_str, n, end_supp - n + 1), ecm (n));

	     if count = 0
	     then count = end_supp - n + 1;
	     else count = count - 1;

	     no_chars = count;

	     if ecm (n) = DS
	     then call move_mult_micro_op;

	     else do;

		     insert_char_no = index (insert_table_status, ecm (n));

		     do idx = 1 to no_chars by 1;

			substr (insrt_op, 6, 4) = substr (unspec (insert_char_no), 33, 4);
			mop (n_mop) = insrt_op;
			n_mop = n_mop + 1;

			if insert_char_no = 0
			then do;

				substr (mop_str, n_mop, 1) = ecm (n);
				n_mop = n_mop + 1;

			     end;
		     end;
		end;

	     n = n + count - 1;
	end;

	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/

     end suppress;

error:
     proc (err_msg);

dcl	1 error_info	aligned,
	  2 module_name	char (32),
	  2 err_msg_lnth	fixed bin,
	  2 error_msg	char (168);

dcl	err_msg		char (*);
dcl	ioa_str		char (44) init ("move # ^d {on line(^d) col(^d)} contains ^a");

/* utilize cobol_ system error handling */

	module_name = "cobol_move_gen";

	call ioa_$rsnnl (ioa_str, error_msg, err_msg_lnth, move_num, lin, col, err_msg);

	call signal_ ("command_abort_", null, addr (error_info));

     end error;

gen_move_alpha:
     proc (op_code, fill, sf_tkn_ptr, rf_tkn_ptr, no_emit);

	/***..... dcl LOCAL_NAME char (14) int static init ("GEN_MOVE_ALPHA");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/

/* This procedure "generates" an eis {an} move instruction
   (the contents of `op_code' determines whether an MLR
   or an MRL eis instruction is generated. The contents
   of `fill' is used to set the FILL character of the instr

   This procedure calls on `set_ips_type5_6' to set up a
   type-5 instruction in input_strucure (input to cobol_addr)
   using the type-9 tokens pointed to by sf_tkn_ptr and
   rf_tkn_ptr as sending and receiving field tokens.
   After setting the FILL character, it calls `cobol_emit'
   to emit the instruction (and operand descriptors) built	*/

dcl	op_code		bit (10);
dcl	len		fixed bin;
dcl	fill		bit (9);
dcl	(sf_tkn_ptr, rf_tkn_ptr)
			ptr;
dcl	no_emit		bit (1);
dcl	cobol_io_util$move	entry (bit (3) aligned, fixed bin, fixed bin, bit (3) aligned, fixed bin, fixed bin);

	eis_ (1) = (36)"0"b;
	inst_struc.inst.fill1_op = op_code;

	call set_ips_type5_6 (5, sf_tkn_ptr, rf_tkn_ptr, null);

	call cobol_addr (input_ptr, inst_ptr, reloc_ptr);

	if op_code = MLR & fill = "000100000"b & ^no_emit
	then do;					/* try to optimize */
						/* -05/15/76- */

		if (sf_tkn_ptr -> data_name.pic_has_p = "0"b) & (sf_tkn_ptr -> data_name.places_left >= 0)
		     & (sf_tkn_ptr -> data_name.places_right >= 0)
		then /* 6/14/76 */
		     if inst_struc.mf1.pr_spec & ^inst_struc.mf1.reg_or_length & inst_struc.mf1.reg_mod = ""b
			& inst_struc.mf2.pr_spec & ^inst_struc.mf2.reg_or_length & inst_struc.mf2.reg_mod = ""b
		     then if ^sf_tkn_ptr -> data_name.linkage_section /* [3.0-1] */
			     & /* [3.0-1] */ ^rf_tkn_ptr -> data_name.linkage_section
						/* [3.0-1] */
			then do;


				call cobol_io_util$move (substr (inst_struc.desc_od (2), 1, 3),
				     fixed (substr (inst_struc.desc_od (2), 4, 17)),
				     fixed (substr (inst_struc.desc_od (2), 25, 12)),
				     substr (inst_struc.desc_od (1), 1, 3),
				     fixed (substr (inst_struc.desc_od (1), 4, 17)),
				     fixed (substr (inst_struc.desc_od (1), 25, 12)));

				go to gmx;

			     end;

	     end;					/* try to optimize */
						/* -05/15/76- */

	substr (eis_ (1), 1, 9) = fill;

	if (sf_tkn_ptr -> data_name.pic_has_p) & (fill ^= "000110000"b)
	     & (sf_tkn_ptr -> data_name.places_left < 0 | sf_tkn_ptr -> data_name.places_right < 0)
	then do;

/*[4.4-1]*/
		if ne_bit
		then substr (eis_ (1), 1, 9) = "000110000"b;
						/* "0" */

		call cobol_emit (inst_ptr, reloc_ptr, 3);

		if sf_tkn_ptr -> data_name.places_left < 0
		then len = sf_tkn_ptr -> data_name.item_length - sf_tkn_ptr -> data_name.places_left;
		else len = sf_tkn_ptr -> data_name.item_length - sf_tkn_ptr -> data_name.places_right;

		if rf_tkn_ptr -> data_name.variable_length = "0"b
		then if len >= rf_tkn_ptr -> data_name.item_length
		     then return;

		inst_struc.inst.mf1 = inst_struc.mf2;
		inst_struc.inst.mf1.reg_or_length = "0"b;
		inst_struc.desc.desc_od (1) = inst_struc.desc.desc_od (2);
		substr (inst_struc.desc.desc_od (1), 25, 12) = substr (unspec (len), 25, 12);
		substr (eis_ (1), 1, 9) = fill;

	     end;

	if ^no_emit
	then call cobol_emit (inst_ptr, reloc_ptr, 3);	/* 6/3/76 */

gmx:	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/
     end gen_move_alpha;

gen_move_lit:
     proc (lit_str, lit_ln, rf_ptr);
	/***..... dcl LOCAL_NAME char (12) int static init ("GEN_MOVE_LIT");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/

/*	This procedure is used to interface with the entry cobol_io_util$move_lit.
   The input to this procedure are:
   lit_str:	The sending alphanum literal string.
   lit_ln:	The  length of the sending alphanum literal string.
   rf_ptr:	The pointer  to the receiving field.
*/

dcl	lit_str		char (*),
	lit_ln		fixed bin,
	rf_ptr		ptr;

	eis_ (1) = (36)"0"b;

	call set_ips_type5_6 (5, null, rf_ptr, null);

	call cobol_addr (input_ptr, inst_ptr, null);

	call cobol_io_util$move_lit (substr (inst_struc.desc_od (2), 1, 3),
	     fixed (substr (inst_struc.desc_od (2), 4, 17)), fixed (substr (inst_struc.desc_od (2), 25, 12)),
	     substr (lit_str, 1, lit_ln));

	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/

     end gen_move_lit;

gen_move_dec_numer:
     proc (sf_tkn_ptr, rf_tkn_ptr);
	/***..... dcl LOCAL_NAME char (19) int static init ("GEN_MOVE_DEC_NUMBER");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/

/* This procedure "generates" an eis {n} move instruction
   It uses the type-9 tokens pointed to by sf_tkn_ptr and
   rf_tkn_ptr as the sending and receiving fields of the MVN
   If the sending field is unsigned and the receiving
   field is signed, the `P-BIT' is set "ON" (thereby forcing
   a + sign in the signed receiving field.
   If the receiving field is stipulated as having the ROUNDED
   option applied, the `RD' bit is set "ON" (meaning that
   rounding will take place as a result of this move.	*/

dcl	(sf_tkn_ptr, rf_tkn_ptr)
			ptr;

	eis_ (1) = (36)"0"b;
	inst_struc.inst.fill1_op = MVN;

	call set_ips_type5_6 (5, sf_tkn_ptr, rf_tkn_ptr, null);

	call cobol_addr (input_ptr, inst_ptr, reloc_ptr);

	if (rf_tkn_ptr -> data_name.rounded)
	then substr (eis_ (1), 11, 1) = "1"b;

	if ((sf_tkn_ptr -> data_name.sign_type = "000"b) & (rf_tkn_ptr -> data_name.sign_type ^= "000"b))
	then substr (eis_ (1), 1, 1) = "1"b;

	if rf_tkn_ptr -> data_name.item_signed
	then substr (eis_ (1), 1, 1) = "1"b;

	if (only_an = "1"b)
	then do;

		substr (eis_ (1), 19, 10) = "0010000001"b;
		substr (eis_ (1), 1, 11) = "11000000000"b;
		substr (eis_ (2), 23, 8) = "00000000"b;
		substr (eis_ (3), 23, 8) = "00000000"b;
	     end;

	call cobol_emit (inst_ptr, reloc_ptr, 3);

	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/

     end gen_move_dec_numer;

set_ips_type5_6:
     proc (ips_typ, sf_tkn_ptr, rf_tkn_ptr, ms_tkn_ptr);
	/***..... dcl LOCAL_NAME char (15) int static init ("SET_IPS_TYPE5_6");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/

/* This procedure sets up the input structure (ips_) used by
   cobol_addr to create addressability to the data fields in the
   eis MOVE instruction.
   - type-5 (ips_typ=5) eis instr w/ 2 operand descriptors
   op-descr(1) = sending field = token <- sf_tkn_ptr
   op-descr(2) = receiving fld = token <- rf_tkn_ptr
   - type-6 (ips_typ=6) eis instr w/ 3 operand descriptors
   op-descr(1) = sending field = token <- sf_tkn_ptr
   op-descr(2) = microp string = token <- ms_tkn_ptr
   op-descr(3) = receiving fld = token <- rf_tkn_ptr	*/
dcl	(sf_tkn_ptr, rf_tkn_ptr, ms_tkn_ptr)
			ptr;
dcl	ips_typ		fixed bin;

	if (ips_typ = 5)
	then do;

		input_struc.type = 5;
		input_struc.operand_no = 2;
		input_struc.lock = 0;

		input_struc.token_ptr (1) = sf_tkn_ptr;
		input_struc.send_receive (1) = 0;
		input_struc.ic_mod (1) = 0;
		input_struc.size_sw (1) = 0;

		input_struc.token_ptr (2) = rf_tkn_ptr;
		input_struc.send_receive (2) = 1;
		input_struc.ic_mod (2) = 0;
		input_struc.size_sw (2) = 0;

		go to setx;
	     end;

	if (ips_typ = 6)
	then do;

		input_struc.type = 6;
		input_struc.operand_no = 3;
		input_struc.lock = 0;

		input_struc.token_ptr (1) = sf_tkn_ptr;
		input_struc.send_receive (1) = 0;
		input_struc.ic_mod (1) = 0;
		input_struc.size_sw = 0;

		input_struc.token_ptr (2) = ms_tkn_ptr;
		input_struc.send_receive (2) = 0;
		input_struc.ic_mod (2) = 0;
		input_struc.size_sw (2) = 0;

		input_struc.token_ptr (3) = rf_tkn_ptr;
		input_struc.send_receive (3) = 1;
		input_struc.ic_mod (3) = 0;
		input_struc.size_sw (3) = 0;

	     end;

setx:	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/
     end set_ips_type5_6;

calc_char_offset:
     proc (delta, dn_ptr);
	/***..... dcl LOCAL_NAME char (16) int static init ("CALC_CHAR_OFFSET");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/

/* This procedure calculates a new character offset for
   a data field whenever any adjustments have to be made.
   Normally, the new offset = old offset + delta. There is
   a distinct problem, however, with data fields in the
   COBOL constant section. Since the constants are stored
   in a backwards manner (ie from the END of the constant
   portion of the text section) any character adjustments
   must use a special algorithm to calculate the new offset.

   The byte numbering of the data in the constant section
   is shown in the following diagram:

   ---------------------
   | 16 | 17 |....|....|
   ---------------------
   | 12 | 13 | 14 | 15 |
   ---------------------
   |  8 |  9 | 10 | 11 |
   ---------------------
   |  4 |  5 |  6 |  7 |
   ---------------------
   */

dcl	(curr_char_off, new_char_off, nword, nchar, delta)
			fixed bin;
dcl	dn_ptr		ptr;
dcl	tlength		fixed bin;

/*  If data item is packed decimal, calculate the byte delta from the half-byte delta supplied.  */

	if dn_ptr -> data_name.ascii_packed_dec_h
	then do;

		if mod (delta, 2) = 0
		then delta = divide (delta, 2, 35, 0);
		else if dn_ptr -> data_name.bit_offset = "0000"b
		then do;

			delta = divide (delta, 2, 35, 0);
			dn_ptr -> data_name.bit_offset = "0101"b;
		     end;
		else do;

			delta = divide (delta, 2, 35, 0) + 1;
			dn_ptr -> data_name.bit_offset = "0000"b;
		     end;
	     end;

	else if dn_ptr -> data_name.ascii_packed_dec
	then do;

/*  Calculate the meaningful number of halfbytes in the data item.  */

		tlength = dn_ptr -> data_name.places_left + dn_ptr -> data_name.places_right;

		if dn_ptr -> data_name.item_signed
		then tlength = tlength + 1;

/*  If the number of half bytes is odd, then the leftmost halfbyte is fill.
						   We must bump past the fill halfbyte, so add 1 to delta.  */

		if mod (tlength, 2) ^= 0
		then delta = delta + 1;

		delta = divide (delta, 2, 35);

	     end;

/* ck for COBOL constant data */

	if (dn_ptr -> data_name.seg_num = 3000)
	then do;

		nword = divide (dn_ptr -> data_name.offset, 4, 35)
		     - divide (mod (dn_ptr -> data_name.offset, 4) + delta, 4, 35);

		curr_char_off = mod (dn_ptr -> data_name.offset + delta, 4);
		dn_ptr -> data_name.offset = nword * 4 + curr_char_off;

	     end;

	else dn_ptr -> data_name.offset = dn_ptr -> data_name.offset + delta;

	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/

     end calc_char_offset;

build_litstr:
     proc;/***..... dcl LOCAL_NAME char (12) int static init ("BUILD_LITSTR");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/

/* This procedure builds a left_justified string of "req_ln"
   characters in the string "lit_str" utilizing the left-
   most "lit_ln" characters in "lit_str".  The "lit_str"
   characters are replicated or truncated as necessary to
   achieve the required string length.                      */

	if lit_ln < req_ln
	then do;

		do idx = lit_ln by lit_ln while (req_ln - idx >= lit_ln);

		     substr (lit_str, idx + 1, lit_ln) = substr (lit_str, 1, lit_ln);

		end;

		if req_ln - idx < lit_ln
		then substr (lit_str, idx + 1, req_ln - idx) = substr (lit_str, 1, req_ln - idx);
	     end;

	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/

     end build_litstr;

replicate:
     proc;/***..... dcl LOCAL_NAME char (9) int static init ("REPLICATE");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/

/* This procedure replicates a one-character pattern by causing
   the generation of a simple move from a zero-length string
   with the desired character as the fill character to the
   receiving field.  The character to be replicated is assumed
   to be the first character of lit_str.		        */

	eis_ (1) = (36)"0"b;

	call set_ips_type5_6 (5, null, rf_ptr, null);

	call cobol_addr (input_ptr, inst_ptr, null);

	inst_struc.inst.fill1_op = MLR;
	substr (eis_ (1), 1, 9) = substr (unspec (lit_str), 1, 9);
	substr (eis_ (1), 30, 7) = "0000100"b;
	inst_struc.desc.desc_od (1) = "111111111111111111000000000000000000"b;

	call cobol_emit (inst_ptr, null, 3);

	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/

     end replicate;

build_litstr_right_just:
     proc;/***..... dcl LOCAL_NAME char (23) int static init ("BUILD_LISTR_RIGHT_JUST");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/

/*
   This procedure builds a literal , right justified in the leftmost
   character positions of a work string.  The literal is built for
   an "all" literal.
   The input to this procedure is  contained in the following
   variables that are global to this procedure:
   lit_str  this character string contains the "all" literal
   lit_ln  this is the length of the "all" literal.
   req_ln  this is the required length of the string to be
   built by this procedure.
   The literal string built by this procedure is returned right justified, in
   the leftmost "lit_ln" characters of lit_str.
*/

/*  Declarations of internal variables.  */

dcl	work_string	char (40);
dcl	whole_string_count	fixed bin;
dcl	remainder_count	fixed bin;
dcl	curr_char		fixed bin;
dcl	ix		fixed bin;

/*  calculate the number of whole literal strings to be inserted into the works string.  */

	whole_string_count = req_ln / lit_ln;

/*  calculate the number of characters in a partial move of the literal string to the work string.  */

	remainder_count = mod (req_ln, lit_ln);

	curr_char = 1;

	if remainder_count ^= 0
	then do;					/*  Move partial string into the work string  */

		substr (work_string, curr_char, remainder_count) =
		     substr (lit_str, curr_char + lit_ln - remainder_count, remainder_count);
		curr_char = curr_char + remainder_count;

	     end;					/*  Move partial string into the work string  */

	if whole_string_count ^= 0
	then do;					/*  Move the whole  input string into the work string (one  or more times)   */

		do ix = 1 to whole_string_count;

		     substr (work_string, curr_char, lit_ln) = substr (lit_str, 1, lit_ln);
		     curr_char = curr_char + lit_ln;

		end;

	     end;					/*  Move the whole input string into the work string (one or more times)  */

/*  Move the work string into the input string.  */

	substr (lit_str, 1, req_ln) = substr (work_string, 1, req_ln);

	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/

     end build_litstr_right_just;

/* { */
num_to_num:
     proc (sf_ptr, rf_ptr);
	/***..... dcl LOCAL_NAME char (10) int static init ("NUM_TO_NUM");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/

/*
   This procedure is called to generate code to move any numeric
   variable to any other numeric variable.  The move is accomplished
   in the Cobol MOVE verb sense, i.e., point alignment and
   truncation on the right and left are done, and overflow is avoided.
*/

/*  Declarations of the Parameters  */

dcl	sf_ptr		ptr;
dcl	rf_ptr		ptr;

/* } */

dcl	sf_code		fixed bin;

/*  Get the numeric type code of the source variable   */

	call cobol_get_num_code (sf_ptr, sf_code);

/*  Call a move code generation procedure based on the type of the source variable.  */

	call numeric_source_proc (sf_code) (sf_ptr, rf_ptr);

	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/

     end num_to_num;

/* { */
dec_source:
     proc (sf_ptr, rf_ptr);
	/***..... dcl LOCAL_NAME char (10) int static init ("DEC_SOURCE");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/

/*
   This internal procedure generates code to convert any decimal
   source variable to any other type of numeric variable.
*/

/*  Declaration of the Parameters  */

dcl	sf_ptr		ptr;
dcl	rf_ptr		ptr;

/* } */

/*  Declaration of Internal Variables  */

dcl	work_sf_ptr	ptr;
dcl	work_rf_ptr	ptr;
dcl	rf_code		fixed bin;

	work_sf_ptr = sf_ptr;
	work_rf_ptr = rf_ptr;

	call cobol_get_num_code (rf_ptr, rf_code);

	goto target_1 (rf_code);

target_1 (1):					/*  TARGET IS UNPACKED DECIMAL  */
	call dec_dec (work_sf_ptr, work_rf_ptr);

	go to tgx;
target_1 (2):					/*  TARGET IS PACKED DECIMAL  */
	call dec_dec (work_sf_ptr, work_rf_ptr);

	go to tgx;

target_1 (3):					/*  TARGET IS SHORT FIXED BINARY  */
	call dec_sb (work_sf_ptr, work_rf_ptr);

	go to tgx;

target_1 (4):					/*  TARGET IS LONG FIXED BINARY  */
	call dec_lb (work_sf_ptr, work_rf_ptr);

	go to tgx;

target_1 (5):					/*  TARGET IS OVERPUNCH SIGN DATA  */
	call non_opch_to_opch (work_sf_ptr, work_rf_ptr);

tgx:	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/
     end dec_source;

/* { */
sb_source:
     proc (sf_ptr, rf_ptr);
	/***..... dcl LOCAL_NAME char (9) int static init ("SB_SOURCE");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/

/*
   This internal procedure generates code to convert a short
   binary source variable to any type numeric variable.  */

/*  Declarations of the Parameters  */

dcl	sf_ptr		ptr;
dcl	rf_ptr		ptr;

/*  DECLARATIONS OF INTERNAL VARIABLES  */

dcl	work_sf_ptr	ptr;
dcl	work_rf_ptr	ptr;
dcl	rf_code		fixed bin;

	work_sf_ptr = sf_ptr;
	work_rf_ptr = rf_ptr;

/*  Get a type code for the receiving variable.  */

	call cobol_get_num_code (rf_ptr, rf_code);

/*  Goto a conversion routine based on the type of the receiving field.  */

	goto target_2 (rf_code);

target_2 (1):					/*  TARGET IS UNPACKED DECIMAL  */
target_2 (2):					/*  TARGET IS PACKED DECIMAL  */
						/*  NOTE THAT UNPACKED AND PACKED DECIMAL ARE CONVERTED IDENTICALLY.  */
	call any_bin_dec (work_sf_ptr, work_rf_ptr);

	go to tgx;

target_2 (3):					/*  TARGET IS SHORT BINARY  */
	call bin_same_bin (work_sf_ptr, work_rf_ptr);

	go to tgx;

target_2 (4):					/*  TARGET IS LONG BINARY  */
	call sb_lb (work_sf_ptr, work_rf_ptr);

	go to tgx;

target_2 (5):					/*  TARGET IS OVERPUNCH SIGN  */
	call non_opch_to_opch (work_sf_ptr, work_rf_ptr);

tgx:	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/
     end sb_source;

/* { */
lb_source:
     proc (sf_ptr, rf_ptr);
	/***..... dcl LOCAL_NAME char (9) int static init ("LB_SOURCE");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/

/*
   This internal procedure generates code to convert a long
   binary source variable to any numeric variable.  */

/*  DECLARATIONS OF THE PARAMETERS  */

dcl	sf_ptr		ptr;
dcl	rf_ptr		ptr;

/*  DECLARATION OF INTERNAL VARIABLES  */

dcl	work_sf_ptr	ptr;
dcl	work_rf_ptr	ptr;
dcl	rf_code		fixed bin;

	work_sf_ptr = sf_ptr;
	work_rf_ptr = rf_ptr;

/*  Get a type code for the receiving variable.  */

	call cobol_get_num_code (rf_ptr, rf_code);

/*  Goto a conversion code sequence based on the type of the receiving variable.  */

	goto target_3 (rf_code);

target_3 (1):					/*  TARGET IS UNPACKED DECIMAL  */
target_3 (2):					/*  TARGET IS PACKED DECIMAL  */
						/*  NOTE THAT UNPACKED AND PACKED DECIMAL RECEIVING FIELDS ARE CONVERTED IDENTICALLY.  */
	call any_bin_dec (work_sf_ptr, work_rf_ptr);

	go to tgx;

target_3 (3):					/*  TARGET IS SHORT BINARY  */
	call lb_sb (work_sf_ptr, work_rf_ptr);

	go to tgx;

target_3 (4):					/*  TARGET IS LONG BINARY  */
	call bin_same_bin (work_sf_ptr, work_rf_ptr);

	go to tgx;

target_3 (5):					/*  TARGET IS OVERPUNCH SIGN DATA  */
	call non_opch_to_opch (work_sf_ptr, work_rf_ptr);

tgx:	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/
     end lb_source;

/* { */
opch_source:
     proc (sf_ptr, rf_ptr);
	/***..... dcl LOCAL_NAME char (11) int static init ("OPCH_SOURCE");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/

/*  This internal procedure generates code to convert an overpunch
   sign variable to any type of numeric variable.  */

/*  Declaration of the parameters.  */

dcl	sf_ptr		ptr;
dcl	rf_ptr		ptr;			/* } */

/*  Declaration of Internal Variables.  */

dcl	work_sf_ptr	ptr;
dcl	work_rf_ptr	ptr;
dcl	rf_code		fixed bin;

/* ************************************************ */
/*	START OF EXECUTION			*/
/* 	internal procedure			*/
/*		opch_source		*/
/* ************************************************ */

	work_sf_ptr = sf_ptr;
	work_rf_ptr = rf_ptr;

/*  Get a numeric type code for the receiving variable.  */

	call cobol_get_num_code (rf_ptr, rf_code);

/*  Goto a conversiion routine, based on the type of the receiving variable.  */
	goto target_4 (rf_code);

target_4 (1):					/*  TARGET IS UNPACKED DECIMAL  */
target_4 (2):					/*  TARGET IS PACKED DECIMAL  */
target_4 (3):					/*  TARGET IS SHORT BINARY  */
target_4 (4):					/*  TARGET IS LONG BINARY  */
						/*  NOTE THAT ALL NON-OVERPUNCH DATA TYPES CALL THE SAME ROUTINE.  */
	call opch_to_non_opch (work_sf_ptr, work_rf_ptr);

	go to opx;

target_4 (5):					/*  TARGET IS OVERPUNCH SIGN  */
	call opch_to_opch (work_sf_ptr, work_rf_ptr);

opx:	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/
     end opch_source;				/* { */

dec_dec:
     proc (sf_ptr, rf_ptr);
	/***..... dcl LOCAL_NAME char (7) int static init ("DEC_DEC");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/

/*
   This internal procedure generates code to move a decimal
   variable (packed or unpacked) to a decimal variable (packed
   or unpacked).
*/

/*  DECLARATION OF THE PARAMETERS  */

dcl	sf_ptr		ptr;
dcl	rf_ptr		ptr;

/*  DESCRIPTION OF THE PARAMETERS  */
/*
   PARAMETER		DESCRIPTION
   sf_ptr		Pointer to a data name token (type 9) that
   describes the sending field.  (input)
   rf_ptr		Pointer to a data name token that
   describes the receiving field.  (input)

*/

start_dec_dec:
	spl = sf_ptr -> data_name.places_left;
	spr = sf_ptr -> data_name.places_right;
	rpl = rf_ptr -> data_name.places_left;
	rpr = rf_ptr -> data_name.places_right;

	if spl < 0
	then do;					/*  No places left bytes in the sending field  */

		if rpr > 0
		then call gen_move_dec_numer (sf_ptr, rf_ptr);

		else do;				/*  No places right bytes in the receiving field.  */

			call dec_zero (temp_tkn_ptr);

			call gen_move_dec_numer (temp_tkn_ptr, rf_ptr);

		     end;				/*  No places right bytes in the receiving field.  */

	     end;					/*  No places left bytes in the sending field.  */

	else do;					/*  Receiving field does have places left.  */

		if rpl >= spl			/*  receiving field can hold sending field completely.  */
		then call gen_move_dec_numer (sf_ptr, rf_ptr);

		else do;				/*  Receiving field not big enough to hold the sending field.  */

			if rpl + spr <= 0
			then do;			/*  Move zero to the receiving field  */

				call dec_zero (temp_tkn_ptr);

				call gen_move_dec_numer (temp_tkn_ptr, rf_ptr);

			     end;			/*  Move zero to the receiving field  */

			else do;			/*  Move source field to receiving field, doing point alignment
						   and truncation if necessary.  */

				if sf_ptr -> data_name.sign_type = "100"b
				then do;		/*  leading separate sign sending field  */
						/*  copy the sending field to temp as trailing separate sign.  */
					sf_stack_sw = 1;

					call cobol_alloc$stack (fixed (sf_ptr -> data_name.item_length, 17), 0,
					     stk_offset);

					substr (new_sf_ptr -> rec_tkn, 1, sf_ptr -> data_name.size) =
					     substr (sf_ptr -> rec_tkn, 1, sf_ptr -> data_name.size);

					new_sf_ptr -> data_name.linkage_section = "0"b;
					new_sf_ptr -> data_name.sign_type = "011"b;
						/*  trailing sep  */
					new_sf_ptr -> data_name.seg_num = 1000;
						/*  stack  */
					new_sf_ptr -> data_name.subscripted = "0"b;
					new_sf_ptr -> data_name.offset = stk_offset;

/*  Generate code to move the leading sign variable to trailing
   sign variable.  */

					call gen_move_dec_numer (sf_ptr, new_sf_ptr);

					sf_ptr, save_sf_ptr = new_sf_ptr;

				     end;		/*  leading separate sign sending field  */

/*  Make a copy of the sending data name token  */

				substr (sf_cpy_ptr -> rec_tkn, 1, sf_ptr -> data_name.size) =
				     substr (sf_ptr -> rec_tkn, 1, sf_ptr -> data_name.size);

				sf_ptr = sf_cpy_ptr;

/*  Must call calc_char_offset before item_length is adjusted.  */

				call calc_char_offset (spl - rpl, sf_ptr);

				sf_ptr -> data_name.places_left = rpl;
				sf_ptr -> data_name.item_length = rpl + spr;

				if sf_ptr -> data_name.sign_separate
				then sf_ptr -> data_name.item_length = sf_ptr -> data_name.item_length + 1;

				call gen_move_dec_numer (sf_ptr, rf_ptr);

			     end;			/*  Move source field to receiving field, doing point alignment
						   and truncation if necessary.  */

		     end;				/*  Receiving field not big enough to hold the sending field.  */
	     end;					/*  Receiving field does have places left.  */

	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/

     end dec_dec;

/* { */
num_to_udts:
     proc (sf_ptr, rf_ptr, return_code);
	/***..... dcl LOCAL_NAME  char (11) int static init ("NUM_TO_UDTS");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/

/*
   This procedure is called to generate code to convert any
   numeric data item to an unpacked decimal, trailing separate
   sign value.
   NOTE:  If the source variable is already an unpacked separate
   trailing sign decimal variable, then no code is generated.
   Instead, a copy of the input data name token is made.
*/

/*  DECLARATION OF THE PARAMETERS  */

dcl	sf_ptr		ptr;
dcl	rf_ptr		ptr;
dcl	return_code	fixed bin;

/*  DESCRIPTION OF THE PARAMETERS  */

/*
   PARAMETER		DESCRIPTION
   sf_ptr		Pointer to the data name token for the
   variable to be converted .  (input)
   rf_ptr		Pointer to a buffer in which the data name
   token for the unpacked decimal trailing
   separate sign variable is built by this
   procedure.  (input)
   return_code	A code that indicates whether an error
   was detected by this procedure during
   the generation of the code.  A non-zero
   return code value indicates an error.  (output)
*/

/* } */

/*  DECLARATION OF INTERNAL VARIABLES  */

dcl	ret_offset	fixed bin;
dcl	dum_buff		char (500) based;


	return_code = 0;

/*  if rf_ptr is null(), then create a buffer into which the token is built.  */

	if rf_ptr = null ()
	then call cobol_make_type9$decimal_9bit (rf_ptr, 1000, 0, 0, 0);


/*  Make a copy of the data name token of the data item to be converted.  */

	substr (rf_ptr -> dum_buff, 1, sf_ptr -> data_name.size) =
	     substr (sf_ptr -> dum_buff, 1, sf_ptr -> data_name.size);

/*  Make the copy reference an unsubscripted trailing separate sign value.  */

	rf_ptr -> data_name.subscripted = "0"b;
	rf_ptr -> data_name.linkage_section = "0"b;
	rf_ptr -> data_name.sign_separate = "1"b;
	rf_ptr -> data_name.display = "1"b;
	rf_ptr -> data_name.sign_type = "011"b;		/*  trailing separate sign  */

/*  Zero bits to the usage is "COMP" bits  */

	rf_ptr -> data_name.ascii_packed_dec = "0"b;
	rf_ptr -> data_name.bin_18 = "0"b;
	rf_ptr -> data_name.bin_36 = "0"b;

/*  Determine the length and scale factor of the receiving item.  */

	if sf_ptr -> data_name.bin_18
	then do;					/*  bin_18 source field  */

		rf_ptr -> data_name.places_left = 6;
		rf_ptr -> data_name.places_right = 0;
		rf_ptr -> data_name.item_length = 7;	/*  6 places left + 1 byte for sign  */
	     end;					/*  bin_18 source field.  */

	else if sf_ptr -> data_name.bin_36
	then do;					/*  bin_36 source field  */

		rf_ptr -> data_name.places_left = 11;
		rf_ptr -> data_name.places_right = 0;
		rf_ptr -> data_name.item_length = 12;	/*  includes 1 byte for sign  */
	     end;					/*  bin_36 source field  */

	else /*  source field is unpacked decimal, packed decimal, or overpunch sign.  */
	     rf_ptr -> data_name.item_length = sf_ptr -> data_name.places_right + sf_ptr -> data_name.places_left + 1;
						/*  includes 1 byte for sign  */

	if (^sf_ptr -> data_name.display /*  NOT DISPLAY  */
	     | sf_ptr -> data_name.sign_type ^= "011"b /*  or NOT trailing sign  */
	     | sf_ptr -> data_name.subscripted /*  or subscripted  */)
	then do;					/*  Generate code to move the source to the unpacked trailing sign decimal  */

/*  Allocate space on the stack  */

		call cobol_alloc$stack (fixed (rf_ptr -> data_name.item_length, 17), 0, ret_offset);

		rf_ptr -> data_name.offset = ret_offset;
		rf_ptr -> data_name.seg_num = 1000;	/* stack  */

/*  Call internal procedure to generate the code.  */

		call num_to_num (sf_ptr, rf_ptr);

	     end;					/*  Generate code to move the source to the unpackde trailing sign decimal.  */

	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/

     end num_to_udts;

/* { */
sb_lb:
     proc (sf_ptr, rf_ptr);
	/***..... dcl LOCAL_NAME char (5) int static init ("SB_LB");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/

/*
   This procedure generates code that moves a short fixed binary
   variable (18 bits) to a long fixed binary value.  */

/*  DECLARATION OF THE PARAMETERS  */

dcl	sf_ptr		ptr;
dcl	rf_ptr		ptr;

/*  DESCRIPTION OF THE PARAMETERS  */

/*
   PARAMETER		DESCRIPTION
   sf_ptr		Pointer to the data name token for the
   source variable.  (input)
   rf_ptr		Pointer to the data name token for the
   receiving variable.  (input)
*/

/*  DECLARATION OF INTERNAL STATIC DATA  */

dcl	shift_inst	bit (36) int static init ("000000000000010010000000000000000000"b);
						/* arg 18 */

/*  DECLARATIONS OF INTERNAL VARIABLES  */

dcl	source_reloc	bit (36);

dcl	ret_offset	fixed bin;
dcl	temp_ptr		ptr;

dcl	1 reg_load_struc,
	  2 what_reg	fixed bin,
	  2 reg_no	bit (4),
	  2 lock		fixed bin,
	  2 already_there	fixed bin,
	  2 contains	fixed bin,
	  2 pointer	ptr,
	  2 literal	bit (36);

/*[4.3-1]*/
	if sf_ptr -> data_name.subscripted | rf_ptr -> data_name.subscripted
						/*[4.3-1]*/
	then do;
		call bin_move_bin (sf_ptr, rf_ptr);	/*[4.3-1]*/
		go to sbx;			/*[4.3-1]*/
	     end;


/*  Get the address of the source variable.  */

	eis_ (1) = (36)"0"b;
	source_reloc = "0"b;

	input_struc.type = 2;
	input_struc.operand_no = 1;
	input_struc.lock = 0;
	input_struc.operand.token_ptr (1) = sf_ptr;
	input_struc.operand.size_sw (1) = 0;

	call cobol_addr (input_ptr, inst_ptr, addr (source_reloc));

/*  Get the A or Q register  */

	reg_load_struc.what_reg = 4;			/*  A or Q  */
	reg_load_struc.lock = 1;
	reg_load_struc.contains = 0;

	call cobol_register$load (addr (reg_load_struc));

/*  Build LDA or LDQ instruction to load the short binary variable  */

	if reg_load_struc.reg_no = "0001"b
	then inst_struc_basic.fill1_op = LDA;
	else inst_struc_basic.fill1_op = LDQ;

	call cobol_emit (inst_ptr, addr (source_reloc), 1);

	if substr (unspec (sf_ptr -> data_name.offset), 35, 2) = "10"b
	then do;					/*  Source variable is aligned on a half-word boundary, and thus was loaded
						   into the lower half of the A or Q.  */

/*  Emit code to shift value to upper half of A or Q.  */

		if reg_load_struc.reg_no = "0001"b
		then substr (shift_inst, 19, 10) = ALS;
		else substr (shift_inst, 19, 10) = QLS;

		call cobol_emit (addr (shift_inst), null (), 1);

	     end;					/*  Source variable is aligned on a half word boundary.  */

/*  Emit code to shift A or Q right 18, to extend the sign bit.  */

	if reg_load_struc.reg_no = "0001"b
	then substr (shift_inst, 19, 10) = ARS;
	else substr (shift_inst, 19, 10) = QRS;

	call cobol_emit (addr (shift_inst), null (), 1);


/*  Emit code to store the A or Q into the receiving long fixed binary.  */

	input_struc.operand.token_ptr (1) = rf_ptr;

	call cobol_addr (input_ptr, inst_ptr, addr (source_reloc));


	if reg_load_struc.reg_no = "0001"b
	then inst_struc_basic.fill1_op = STA;
	else inst_struc_basic.fill1_op = STQ;

	call cobol_emit (inst_ptr, addr (source_reloc), 1);

/*  Unlock the A or Q register  */

	call cobol_register$release (addr (reg_load_struc));

sbx:	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/
     end sb_lb;

/* { */
dec_lb:
     proc (sf_ptr, rf_ptr);
	/***..... dcl LOCAL_NAME char (6) int static init ("DEC_LB");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/

/*
   This procedure generates code to convert a decimal variable
   (packed or unpacked, signed or unsigned) to long (36 bit) fixed
   binary.
*/

/*  DECLARATION OF THE PARAMETERS  */

dcl	sf_ptr		ptr;
dcl	rf_ptr		ptr;

/*  DESCRIPTION OF THE PARAMETERS  */

/*
   PARAMETER		DESCRIPTION
   sf_ptr		Pointer to the data name token of the
   sending decimal variable.  (input)
   rf_ptr		Pointer to the data name token of the
   receiving long binary variable.  (input)

*/


/*  DECLARATION OF INTERNAL STATIC DATA  */

dcl	long_binary_mask	bit (72) int static
			init
			/* octal = 400000000000377777777777  */ (
			"100000000000000000000000000000000000011111111111111111111111111111111111"b);

/*  DECLARATION OF INTERNAL VARIABLES  */

dcl	bump		fixed bin;
dcl	ret_offset	fixed bin;

dcl	1 reg_load_struc,
	  2 what_reg	fixed bin,
	  2 reg_no	bit (4),
	  2 lock		fixed bin,
	  2 already_there	fixed bin,
	  2 contains	fixed bin,
	  2 pointer	ptr,
	  2 literal	bit (36);

dcl	temp_inst		bit (36);
dcl	temp_inst_ptr	ptr;
dcl	temp_reloc	(1:2) bit (5) aligned;
dcl	long_bin_limit	fixed bin;
dcl	temp_reloc_ptr	ptr;
dcl	mask_ptr		ptr;
dcl	const_offset	fixed bin (24);
dcl	bin_tkn_ptr	ptr;
dcl	binary_mask_string	char (8) based (mask_ptr);

	spl = sf_ptr -> data_name.places_left;
	spr = sf_ptr -> data_name.places_right;

	if spl <= 0
	then do;					/*  Sending field less than zero.  Move zero to the receiving field.  */

		call dec_zero (temp_tkn_ptr);

		call set_ips_type5_6 (5, temp_tkn_ptr, rf_ptr, null ());

		call cobol_addr (input_ptr, inst_ptr, reloc_ptr);

		inst_struc.fill1_op = DTB;

		call cobol_emit (inst_ptr, reloc_ptr, 3);

	     end;					/*  Sending field less than zero.  Move zero to the receiving field.  */

	else do;					/*  Sending field has an integer part.  */

		if (sf_ptr -> data_name.places_right ^= 0
		     | (sf_ptr -> data_name.sign_type = "100"b /* leading separate */
		     & sf_ptr -> data_name.places_left > rf_ptr -> data_name.places_left))
		then call dec_dec_fix (sf_ptr, temp_tkn_ptr);
						/*  fix the decimal variable.  */

		else temp_tkn_ptr = sf_ptr;		/*  Sending variable already an integer
						   with no sign, or a trailing separate sign.  */

/*  At this point, if the sending decimal value was not an integer, or if it had
   a leading separate sign, code has been generated to convert the decimal value to an
   integer value with trailing separate sign.  Next code is generated to convert
   the decimal integer value to long fixed binary.  The code sequence generated is:

   dtb		convert fixed decimal to fixed binary
   desc9ts	source,12,0
   desc9a	temp1,8
   ldaq	temp1
   anaq	=o400000000000377777777777
   stq	temp1
   orsa	temp1
   mlr
   desc9a	temp1,4
   desc9a	final,4

*/

		if temp_tkn_ptr -> data_name.bin_32
		then long_bin_limit = 10;
		else long_bin_limit = 11;

		if temp_tkn_ptr -> data_name.places_left > long_bin_limit
		then do;				/*  Modify the token so the least significant long_bin_limit digits are converted to binary.  */

			if temp_tkn_ptr = sf_ptr
			then do;			/*  Make a copy of the token.  The token copy will be modified.  */


				temp_tkn_ptr = null ();
				if sf_ptr -> data_name.subscripted
				then call cobol_make_type9$copy_sub (temp_tkn_ptr, sf_ptr);

				else call cobol_make_type9$copy (temp_tkn_ptr, sf_ptr);

			     end;			/*  Make a copy of the token.  */

			bump = temp_tkn_ptr -> data_name.places_left - long_bin_limit;

			call calc_char_offset (bump, temp_tkn_ptr);

			temp_tkn_ptr -> data_name.places_left = long_bin_limit;

			if temp_tkn_ptr -> data_name.sign_type = "011"b
						/*  trailing separate  */
			then temp_tkn_ptr -> data_name.item_length = long_bin_limit + 1;
			else temp_tkn_ptr -> data_name.item_length = long_bin_limit;

		     end;				/*  Modify token so least significant long_bin_limit digits are converted to binary.  */

		if temp_tkn_ptr -> data_name.places_left > (long_bin_limit - 1)
		then do;				/*  Sending field could possibly overflow one word (36 bits).  Must convert into
						   a double word, and then truncate on the left.  */
						/*  Allocate 8 bytes of even word aligned storage on the stack.  */

			call cobol_alloc$stack (8, 2 /*  even word boundary */, ret_offset);

			ret_offset = ret_offset * 4;	/*  convert word offset to char offset  */

/*  Make a long fixed binary data name token for the temporary.  */
			bin_tkn_ptr = null ();

			call cobol_make_type9$long_bin (bin_tkn_ptr, 1000, ret_offset);

/*  Set item length in the token to 8 bytes (make_type9 sets it to 4)  */
			bin_tkn_ptr -> data_name.item_length = 8;

		     end;				/*  Sending field could possibly overflow one word.  Must convert into a bouble
						   word.  */

		else bin_tkn_ptr = rf_ptr;		/*  Can convert directly into the receiving field.  */

/*  Generate EIS instruction and descriptors for the DTB instruction.  */

		call set_ips_type5_6 (5, temp_tkn_ptr, bin_tkn_ptr, null ());

		call cobol_addr (input_ptr, inst_ptr, reloc_ptr);

		inst_struc.fill1_op = DTB;

		call cobol_emit (inst_ptr, reloc_ptr, 3);

		if bin_tkn_ptr ^= rf_ptr
		then do;				/*  Sending field was not converted directly into the receiving field.  */

/*  Pool the long binary mask  */
			mask_ptr = addr (long_binary_mask);
						/*  Note that the mask must be pooled on an even word boundary, because it is going
						   to be used in a double register instruction.  */

			call cobol_pool$search_op (binary_mask_string, 2, const_offset, in_op);

/*  Convert the returned word offset to character offset.  */
			const_offset = const_offset * 4;

/*  Get the address of the temporary double word that contains the fixed binary value.  */
			temp_inst_ptr = addr (temp_inst);
			temp_reloc_ptr = addr (temp_reloc (1));
			input_struc_basic.type = 1;
			input_struc_basic.operand_no = 0;
			input_struc_basic.segno = bin_tkn_ptr -> data_name.seg_num;
			input_struc_basic.char_offset = bin_tkn_ptr -> data_name.offset;
			input_struc_basic.send_receive = 1;
						/*  sending  */

			call cobol_addr (input_ptr, temp_inst_ptr, temp_reloc_ptr);

/*  Get the A and Q registers  */
			reg_load_struc.what_reg = 3;	/*  A and Q  */
			reg_load_struc.lock = 0;
			reg_load_struc.contains = 0;

			call cobol_register$load (addr (reg_load_struc));

/*  Build and emit LDAQ "temp" instruction  */
			substr (temp_inst, 19, 10) = LDAQ;

			call cobol_emit (temp_inst_ptr, temp_reloc_ptr, 1);

/*  Get basic address of the long binary mask  */

			if in_op = 1
			then input_struc_basic.segno = 3;
			else input_struc_basic.segno = 3000;

			input_struc_basic.char_offset = const_offset;

			call cobol_addr (input_ptr, inst_ptr, reloc_ptr);

/*  Build and emit ANAQ "long bin mask" instruction.  */
			inst_struc_basic.fill1_op = ANAQ;

			call cobol_emit (inst_ptr, reloc_ptr, 1);

/*  Build and emit STQ "temp" instruction.  */
			substr (temp_inst, 19, 10) = STQ;

			call cobol_emit (temp_inst_ptr, temp_reloc_ptr, 1);

/*  Build and emit ORSA "temp" instruction.  */
			substr (temp_inst, 19, 10) = ORSA;

			call cobol_emit (temp_inst_ptr, temp_reloc_ptr, 1);

/*  Generate code to move the value in the stack temporary to the receiving field.  */

			bin_tkn_ptr -> data_name.item_length = 4;
			bin_tkn_ptr -> data_name.numeric = "0"b;
			bin_tkn_ptr -> data_name.alphanum = "1"b;
			rf_ptr -> data_name.numeric = "0"b;
			rf_ptr -> data_name.alphanum = "1"b;

			call set_ips_type5_6 (5, bin_tkn_ptr, rf_ptr, null ());

			call cobol_addr (input_ptr, inst_ptr, reloc_ptr);

			inst_struc.fill1_op = MLR;

			call cobol_emit (inst_ptr, reloc_ptr, 3);

/*  Reset the receiving field token.  */

			rf_ptr -> data_name.numeric = "1"b;
			rf_ptr -> data_name.alphanum = "0"b;

		     end;				/*  Sending field was not converted directly into the receiving field.  */

/*  Restore the A and Q  */

		call cobol_register$release (addr (reg_load_struc));

	     end;					/*  Sending field has an integer part.  */

	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/

     end dec_lb;

/* { */
lb_sb:
     proc (sf_ptr, rf_ptr);
	/***..... dcl LOCAL_NAME char (5) int static init ("LB_SB");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/

/*
   This procedure generates code to move a long fixed binary (36 bit)
   variable to a short fixed binary (18 bit) variable.
*/

/*  DECLARATION OF THE PARAMETERS  */

dcl	sf_ptr		ptr;
dcl	rf_ptr		ptr;
dcl	j		fixed bin;

/*  DESCRIPTION OF THE PARAMETERS  */

/*
   PARAMETER		DESCRIPTION
   sf_ptr		Pointer to the data name token for the
   source variable.  (input)
   rf_ptr		Pointer to the data name tokne for the
   receiving variable.  (input)
*/

	if rf_ptr -> data_name.subscripted = "0"b
	then do;

		call load_bin (sf_ptr, 3);

		if substr (unspec (rf_ptr -> data_name.offset), 35, 2) = "10"b
		then j = 7;
		else j = 6;

		call load_bin (rf_ptr, j);

	     end;
	else do;

		call bin_move_bin (sf_ptr, rf_ptr);

	     end;

	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/

     end lb_sb;

/* { */
bin_same_bin:
     proc (sf_ptr, rf_ptr);
	/***..... dcl LOCAL_NAME char (12) int static init ("BIN_SAME_BIN");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/

/*
   This procedure generates code to move a binary variable
   to a binary variable of the same length, that is,
   1. short binary to short binary
   2. long binary to long binary
*/

/*  DECLARATION OF THE PARAMETERS  */

dcl	sf_ptr		ptr;
dcl	rf_ptr		ptr;
dcl	j		fixed bin;

/*  DESCRIPTION OF THE PARAMETERS  */
/*
   PARAMETER		DESCRIPTION
   sf_ptr		Pointer to the data name token for the
   source variable.  (input)
   rf_ptr		Pointer to the data name token for the
   receiving variable.  (input)

*/

/*[4.3-2]*/
	if sf_ptr -> data_name.subscripted | rf_ptr -> data_name.subscripted
						/*[4.3-2]*/
	then do;
		call bin_move_bin (sf_ptr, rf_ptr);	/*[4.3-2]*/
		go to binx;			/*[4.3-2]*/
	     end;

	if sf_ptr -> data_name.bin_36
	then do;

		call load_bin (sf_ptr, 1);

		call load_bin (rf_ptr, 4);

	     end;
	else do;

		if sf_ptr -> data_name.subscripted = "0"b & rf_ptr -> data_name.subscripted = "0"b
		then do;

			if substr (unspec (sf_ptr -> data_name.offset), 35, 2) = "10"b
			then j = 3;
			else j = 2;

			call load_bin (sf_ptr, j);

			if substr (unspec (rf_ptr -> data_name.offset), 35, 2) = "10"b
			then j = 7;
			else j = 6;

			call load_bin (rf_ptr, j);

		     end;
		else do;

			call bin_move_bin (sf_ptr, rf_ptr);

		     end;
	     end;

binx:	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/
     end bin_same_bin;

load_bin:
     proc (temp_ptr, code);
	/***..... dcl LOCAL_NAME char (8) int static init ("LOAD_BIN");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/
						/* load long or short bin */

dcl	temp_ptr		ptr;
dcl	code		fixed bin;
dcl	inst_op		(7) bit (10) static init ("0100111010"b,
						/* lda */
			"0100100000"b,		/* ldxn */
			"1110100000"b,		/* lxln */
			"1111011010"b,		/* sta */
			"1011010010"b,		/* stba */
			"1111000000"b,		/* stxn */
			"1001000000"b);		/* sxln */

/*	The followings are for the register structure	*/
/* reg_struc_ptr is a pointer to the following structure (input) */

dcl	1 reg_struc	static,
	  2 what_reg	fixed bin,
	  2 reg_num	bit (4),
	  2 lock		fixed bin init (1),
	  2 already_there	fixed bin,
	  2 contains	fixed bin,
	  2 pointer	ptr,
	  2 literal	bit (36);

start:
	input_struc.type = 2;
	input_struc.operand_no = 1;
	input_struc.lock = 0;
	input_struc.token_ptr (1) = temp_ptr;
	input_struc.size_sw (1) = 0;

	call cobol_addr (input_ptr, inst_ptr, reloc_ptr);

	if code = 1
	then reg_struc.what_reg = 1;
	else if code = 2 | code = 3
	then reg_struc.what_reg = 14;

	inst_struc.fill1_op = inst_op (code);

	if code <= 3
	then do;

		call cobol_register$load (addr (reg_struc));

		if code = 2 | code = 3
		then substr (inst_struc.fill1_op, 7, 3) = substr (reg_struc.reg_num, 2, 3);

		call cobol_emit (inst_ptr, reloc_ptr, 1);

	     end;
	else do;

		if code = 6 | code = 7
		then substr (inst_struc.fill1_op, 7, 3) = substr (reg_struc.reg_num, 2, 3);

		call cobol_emit (inst_ptr, reloc_ptr, 1);

		call cobol_register$release (addr (reg_struc));

	     end;

	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/

     end load_bin;

bin_move_bin:
     proc (sf_ptr, rf_ptr);
	/***..... dcl LOCAL_NAME char (12) int static init ("BIN_MOVE_BIN");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/

/*	This procedure generate code to move binary data to binary data
   through eis instruction. Because of subscripted bin_18 data is
   not expected for its alignment, non-eis instructions are not
   applicable.							*/

dcl	(sf_ptr, rf_ptr)	ptr;

	sf_ptr -> data_name.numeric = "0"b;
	sf_ptr -> data_name.alphanum = "1"b;
	rf_ptr -> data_name.numeric = "1"b;
	rf_ptr -> data_name.alphanum = "1"b;

/*  Build input to the addressability utility  */

	call set_ips_type5_6 (5, sf_ptr, rf_ptr, null ());

/*  Call the addressability utility to build instruction and two descriptors.  */

	call cobol_addr (input_ptr, inst_ptr, reloc_ptr);

/*  Set the MLR opcode into the instruction.  */

/* [4.2-1] */
	inst_struc.fill1_op = MRL;

/*  Emit the instruction to move source to receiving.  */

	call cobol_emit (inst_ptr, reloc_ptr, 3);


	sf_ptr -> data_name.alphanum = "0"b;
	sf_ptr -> data_name.numeric = "1"b;
	rf_ptr -> data_name.alphanum = "0"b;
	rf_ptr -> data_name.numeric = "1"b;

	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/

     end bin_move_bin;

/* { */
any_bin_dec:
     proc (sf_ptr, rf_ptr);
	/***..... dcl LOCAL_NAME char (11) int static init ("ANY_BIN_DEC");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/

/*
   This procedure generates code to move any fixed binary
   variable to an unpacked or packed decimal variable.  */

/*  DECLARATION OF THE PARAMETERS  */

dcl	sf_ptr		ptr;
dcl	rf_ptr		ptr;

/*  DESCRIPTION OF THE PARAMETERS  */

/*
   PARAMETER		DESCRIPTION
   sf_ptr		Pointer to the data name token for the
   fixed binary source variable. (input)
   rf_ptr		Pointer to the data name token for the
   decimal (packed or unpackde) receiving
   variable. (input)

*/

/*  DECLARATIONS OF INTERNAL VARIABLES  */

dcl	dec_temp_size	fixed bin;
dcl	ret_offset	fixed bin;
dcl	dec_tkn_ptr	ptr;
dcl	temp_result	bit (1);

	temp_result = "0"b;

/*  Determine the size of the temporary required to hold the decimal representation
   of the fixed binary.  */

	if sf_ptr -> data_name.bin_18
	then dec_temp_size = 6;			/*  includes 1 byte for sign  */
	else dec_temp_size = 11;

	if (rf_ptr -> data_name.places_left < dec_temp_size | rf_ptr -> data_name.places_right ^= 0)
	then do;					/*  Convert the binary value into a temporary on the stack.  */
						/*  Allocate space on the stack for the temporary.  */

		call cobol_alloc$stack (dec_temp_size + 1, 0, ret_offset);

/*  Make a data name token for the decimal temporary.  */

		dec_tkn_ptr = null ();

		call cobol_make_type9$decimal_9bit (dec_tkn_ptr, 1000 /* stack */, fixed (ret_offset, 24),
		     dec_temp_size, 0);

/*  change sign type from leading separate to trailing separate.  */

		dec_tkn_ptr -> data_name.sign_type = "011"b;
						/*  trailing separate  */
		temp_result = "1"b;

	     end;					/*  Convert the binary value into a temporary on the stack.  */

	else dec_tkn_ptr = rf_ptr;

/*  Build input to the addressability utility  */

	call set_ips_type5_6 (5, sf_ptr, dec_tkn_ptr, null ());

/*  Build the EIS instruction and descriptors.  */

	call cobol_addr (input_ptr, inst_ptr, reloc_ptr);

/*  Insert BTD opcode.  */

	inst_struc.fill1_op = BTD;

/*  Emit the code.  */

	call cobol_emit (inst_ptr, reloc_ptr, 3);

/*  At this point, if code has been generated to convert the short or long binary value into
   a trailing separate sign value in the stack, it is now necessary to move the decimal temporary
   to the decimal receiving field.  */

	if temp_result
	then call dec_dec (dec_tkn_ptr, rf_ptr);


	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/

     end any_bin_dec;

/* { */
dec_sb:
     proc (sf_ptr, rf_ptr);
	/***..... dcl LOCAL_NAME char (6) int static init ("DEC_SB");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/

/*
   This internal procedure generates code to convert a decimal
   value (packed or unpacked, unsigned or separate sign) to
   short fixed binary.  */

/*  DECLARATION OF THE PARAMETERS  */

dcl	sf_ptr		ptr;
dcl	rf_ptr		ptr;

/*  DESCRIPTION OF THE PARAMETERS  */

/*

   PARAMETER		DESCRIPTION
   sf_ptr		Pointer to the data name token of the
   sending decimal field.
   rf_ptr		Pointer to the data name token of the
   short binary receiving field.
*/

/*  DECLARATION OF INTERNAL STATIC VARAIBLES  */

dcl	arl_18_inst	bit (36) int static init ("000000000000010010000000000000000000"b);
						/*  arg 18  */

dcl	short_binary_mask	bit (36) int static init ("100000000000000000011111111111111111"b);

/*  DECLARATIONS OF INTERNAL VARIABLES  */

dcl	temp_inst		bit (36);
dcl	temp_inst_ptr	ptr;
dcl	temp_reloc	(1:5) bit (5) aligned;
dcl	temp_reloc_ptr	ptr;
dcl	short_bin_limit	fixed bin;
dcl	shift_inst_ptr	ptr;

dcl	1 reg_load_struc,
	  2 what_reg	fixed bin,
	  2 reg_no	bit (4),
	  2 lock		fixed bin,
	  2 already_there	fixed bin,
	  2 contains	fixed bin;

dcl	ret_offset	fixed bin;
dcl	const_offset	fixed bin (24);
dcl	mask_ptr		ptr;
dcl	binary_mask_string	char (4) based (mask_ptr);
dcl	bin_tkn_ptr	ptr;
dcl	bump		fixed bin;

start_dec_sb:
	spl = sf_ptr -> data_name.places_left;
	spr = sf_ptr -> data_name.places_right;

	if spl <= 0
	then do;					/*  Sending field less than zero, move zero to the receiving field.  */

		call dec_zero (temp_tkn_ptr);

		call set_ips_type5_6 (5, temp_tkn_ptr, rf_ptr, null ());

		call cobol_addr (input_ptr, inst_ptr, reloc_ptr);

		inst_struc.fill1_op = DTB;

		call cobol_emit (inst_ptr, reloc_ptr, 3);

	     end;					/*  Sending field less than zero, move zero to the receiving field.  */

	else do;					/*  Sending field has an integer part.  */

		if (sf_ptr -> data_name.places_right ^= 0
		     | sf_ptr -> data_name.sign_type = "100"b /*  leading separate */)
		then call dec_dec_fix (sf_ptr, temp_tkn_ptr);

		else temp_tkn_ptr = sf_ptr;

/*  At this point, code has been generated to convert the decimal variable to an
   integer decimal value.  (no places to the right of the decimal point)
   Now we generate code to convert the fixed decimal to short fixed binary.  The
   code sequence to be generated is:

   dtb		convert fixed decimal to fixed binary
   desc9ts	source,7,0
   desc9a	temp1,4
   lda	temp1
   ana	=o400000377777
   sta	temp1
   alr	18
   orsa	temp1
   mlr
   desc9a	temp1(2),2
   desc9a	final_result,2

   */

		if temp_tkn_ptr -> data_name.bin_16
		then short_bin_limit = 5;
		else short_bin_limit = 6;

		if temp_tkn_ptr -> data_name.places_left > short_bin_limit
		then do;				/*  Modify the token so the short_bin_limit least significant digits
						   of data are converted.  */

			if temp_tkn_ptr = sf_ptr
			then do;			/*  Make a copy of the source token .  */

				temp_tkn_ptr = null ();

				if sf_ptr -> data_name.subscripted
				then call cobol_make_type9$copy_sub (temp_tkn_ptr, sf_ptr);

				else call cobol_make_type9$copy (temp_tkn_ptr, sf_ptr);

			     end;			/*  Make a copy of the source token.  */

			bump = temp_tkn_ptr -> data_name.places_left - short_bin_limit;

			call calc_char_offset (bump, temp_tkn_ptr);

			temp_tkn_ptr -> data_name.places_left = short_bin_limit;

			if temp_tkn_ptr -> data_name.sign_type = "011"b
						/*  trailing separate */
			then temp_tkn_ptr -> data_name.item_length = short_bin_limit + 1;
			else temp_tkn_ptr -> data_name.item_length = short_bin_limit;

		     end;				/*  Modify the token so the short_bin_limit least significant digits
						   of data are converted.  */

		if temp_tkn_ptr -> data_name.places_left > (short_bin_limit - 1)
		then do;				/*  Sending field could possibly overflow  one half word.  Must convert it into a
				   full word, and then truncate on the left.  */
						/*  Allocate 4 bytes of word aligned storage on the stack.  */


			call cobol_alloc$stack (4, 0, ret_offset);

/*  Make a long fixed binary data name token for the temporary storage  */

			bin_tkn_ptr = null ();

			call cobol_make_type9$long_bin (bin_tkn_ptr, 1000 /* stack */, ret_offset);

		     end;				/*  Sending field could possibly overflow one half word..  */

		else bin_tkn_ptr = rf_ptr;		/*  Can convert directly into the receiving field.  */

/*  Generate EIS instruction and two descriptors for a DTB instruction  */

		call set_ips_type5_6 (5, temp_tkn_ptr, bin_tkn_ptr, null ());

		call cobol_addr (input_ptr, inst_ptr, reloc_ptr);

		inst_struc.fill1_op = DTB;

		call cobol_emit (inst_ptr, reloc_ptr, 3);


		if bin_tkn_ptr ^= rf_ptr
		then do;				/*  Sending field was not converted directly into the receiving field.  */

/*  Pool the short binary mask  */

			mask_ptr = addr (short_binary_mask);

			call cobol_pool$search_op (binary_mask_string, 0, const_offset, in_op);

			if in_op = 0
			then temp = 3000;
			else temp = 3;

/*  Make a data name token for the mask  */

			mask_ptr = null ();

			call cobol_make_type9$alphanumeric (mask_ptr, temp /* constant section */, const_offset, 4);

/*  Get the address of the temporary word that contains the fixed binary value.  */

			temp_inst_ptr = addr (temp_inst);
			temp_reloc_ptr = addr (temp_reloc (1));

			input_struc_basic.type = 1;
			input_struc_basic.operand_no = 0;
			input_struc_basic.lock = 0;
			input_struc_basic.segno = bin_tkn_ptr -> data_name.seg_num;
			input_struc_basic.char_offset = bin_tkn_ptr -> data_name.offset;
			input_struc_basic.send_receive = 1;
						/*  sending  */

			call cobol_addr (input_ptr, temp_inst_ptr, temp_reloc_ptr);

/*  Get the A or Q  */

			reg_load_struc.what_reg = 4;	/*  A or Q  */
			reg_load_struc.lock = 0;
			reg_load_struc.contains = 0;

			call cobol_register$load (addr (reg_load_struc));

/*  Build LDA or LDQ instruction  */

			if reg_load_struc.reg_no = "0001"b
			then substr (temp_inst, 19, 10) = LDA;
			else substr (temp_inst, 19, 10) = LDQ;

			call cobol_emit (temp_inst_ptr, temp_reloc_ptr, 1);

/*  Build the basic address of the short binary mask  */

			input_struc_basic.segno = mask_ptr -> data_name.seg_num;
			input_struc_basic.char_offset = mask_ptr -> data_name.offset;

			call cobol_addr (input_ptr, inst_ptr, reloc_ptr);

			if reg_load_struc.reg_no = "0001"b
			then inst_struc_basic.fill1_op = ANA;
			else inst_struc_basic.fill1_op = ANQ;

			call cobol_emit (inst_ptr, reloc_ptr, 1);


/*  Emit code to store the A or Q  */

			if reg_load_struc.reg_no = "0001"b
			then substr (temp_inst, 19, 10) = STA;
			else substr (temp_inst, 19, 10) = STQ;

			call cobol_emit (temp_inst_ptr, temp_reloc_ptr, 1);

/*  Emit "arl 18"  or "qrl 18" instruction  */

			shift_inst_ptr = addr (arl_18_inst);

			if reg_load_struc.reg_no = "0001"b
			then substr (arl_18_inst, 19, 10) = ARL;
			else substr (arl_18_inst, 19, 10) = QRL;

			call cobol_emit (shift_inst_ptr, null (), 1);

/*  Emit code to OR the A or Q to the temp value.  */

			if reg_load_struc.reg_no = "0001"b
			then substr (temp_inst, 19, 10) = ORSA;
			else substr (temp_inst, 19, 10) = ORSQ;

			call cobol_emit (temp_inst_ptr, temp_reloc_ptr, 1);

/*  Generate code to move the two least significant bytes of the fixed binary temporary
				   into the receiving field.  */
/*  Update the character offset in the token that describes the fixed bin temp.  */

			bin_tkn_ptr -> data_name.offset = bin_tkn_ptr -> data_name.offset + 2;

			bin_tkn_ptr -> data_name.item_length = 2;
			bin_tkn_ptr -> data_name.numeric = "0"b;
			bin_tkn_ptr -> data_name.alphanum = "1"b;

			rf_ptr -> data_name.numeric = "0"b;
			rf_ptr -> data_name.alphanum = "1"b;

			call set_ips_type5_6 (5, bin_tkn_ptr, rf_ptr, null ());

			call cobol_addr (input_ptr, inst_ptr, reloc_ptr);

			inst_struc_basic.fill1_op = MLR;

			call cobol_emit (inst_ptr, reloc_ptr, 3);

			rf_ptr -> data_name.numeric = "1"b;
			rf_ptr -> data_name.alphanum = "0"b;

		     end;				/*  Sending field was not converted directly into the receiving field.  */

	     end;					/*  Sending field has an integer part.  */

	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/

     end dec_sb;

/* { */
dec_dec_fix:
     proc (sf_ptr, fixed_sf_ptr);
	/***..... dcl LOCAL_NAME char (11) int static init ("DEC_DEC_FIX");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/

/*
   This procedure generates code to fix (truncate places to the
   right of the decimal point) a packed or unpacked decimal value.  */

/*  DECLARATION OF THE PARAMETERS  */

dcl	sf_ptr		ptr;
dcl	fixed_sf_ptr	ptr;

/*  DESCRIPTION OF THE PARAMETERS  */

/*
   PARAMETER		DESCRIPTION
   sf_ptr		Pointer to the data name token for the decimal
   variable to be fixed.  (input)
   fixed_sf_ptr	Pointer to a buffer in which the data name
   token for the fixed value is built. (input)

*/

dcl	ret_offset	fixed bin;
dcl	temp_tok		char (500) based;

/*  Allocate space on the stack for the fixed value.  */

	call cobol_alloc$stack (sf_ptr -> data_name.places_left + 1, 0, ret_offset);

/*  Copy the source token into the user-supplied buffer.  */

	substr (fixed_sf_ptr -> temp_tok, 1, sf_ptr -> data_name.size) =
	     substr (sf_ptr -> temp_tok, 1, sf_ptr -> data_name.size);

/*  Modify the token copy to describe the fixed value on the stack.  */

	fixed_sf_ptr -> data_name.linkage_section = "0"b;
	fixed_sf_ptr -> data_name.item_length = fixed_sf_ptr -> data_name.places_left + 1;
	fixed_sf_ptr -> data_name.places_right = 0;
	fixed_sf_ptr -> data_name.sign_type = "011"b;	/*  trailing separate  */
	fixed_sf_ptr -> data_name.seg_num = 1000;	/*  stack  */
	fixed_sf_ptr -> data_name.offset = ret_offset;

/*  Generate code to move the sending filed to the stack temporary.  */

	call gen_move_dec_numer (sf_ptr, fixed_sf_ptr);

	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/

     end dec_dec_fix;

/* { */
non_opch_to_opch:
     proc (sf_ptr, rf_ptr);
	/***..... dcl LOCAL_NAME char (16) int static init ("NON_OPCH_TO_OPCH");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/

/*
   This internal procedure generates code to move a non-overpunch
   sign variable to an overpunch sign receiving field.  */

/*  DECLARATION OF THE PARAMETERS  */

dcl	sf_ptr		ptr;
dcl	rf_ptr		ptr;

/*  DECLARATION OF INTERNAL VARIABLES  */

dcl	temp_sf_ptr	ptr;
dcl	return_code	fixed bin;
dcl	udts_token_ptr	ptr;

/* The following declaration are used for numerical literal to opch. 6/1/76 bc. */

dcl	temp_rf_ptr	ptr,
	move_char		char (1),
	temp_len		fixed bin,
	temp_ptr		ptr,
	temp_space	char (250),
	temp_sign_type	bit (3),
	move_digit	fixed bin,
	an_ptr		ptr,
	conv_plus		(0:9) char (1) static init ("{", "A", "B", "C", "D", "E", "F", "G", "H", "I"),
	conv_minus	(0:9) char (1) static init ("}", "J", "K", "L", "M", "N", "O", "P", "Q", "R");

dcl	1 al_lit,
	  2 size		fixed bin,
	  2 line		fixed bin,
	  2 column	fixed bin,
	  2 type		fixed bin,
	  2 lit_type	bit (1),
	  2 all_lit	bit (1),
	  2 filler1	bit (6),
	  2 lit_size	fixed bin,
	  2 string	char (1);

/* ************************************************ */
/*	START OF EXECUTION			*/
/*	non_opch_to_opch			*/
/* ************************************************ */

	temp_sf_ptr = sf_ptr;

/* Handle the numeric to opch data. 6/1/76 by bc. */

	if numeric_lit_flag = 1 & rf_ptr -> data_name.elementary
	then do;

		numeric_lit_flag = 0;
		temp_rf_ptr = rf_ptr;
		temp_rf_ptr -> data_name.item_signed = "0"b;
		temp_sign_type = temp_rf_ptr -> data_name.sign_type;
		temp_rf_ptr -> data_name.sign_type = "000"b;

		call dec_dec (temp_sf_ptr, temp_rf_ptr);

		move_char = "0";

		if temp_sign_type = "010"b
		then do;

			if sf_ptr -> data_name.places_left >= temp_rf_ptr -> data_name.places_left
			then if (sf_ptr -> data_name.places_left - temp_rf_ptr -> data_name.places_left + 1 > 0)
			     then move_char =
				     substr (lit_str,
				     sf_ptr -> data_name.places_left - temp_rf_ptr -> data_name.places_left + 1,
				     1);

		     end;
		else do;


			if sf_ptr -> data_name.places_right >= temp_rf_ptr -> data_name.places_right
			then if (sf_ptr -> data_name.places_left + temp_rf_ptr -> data_name.places_right > 0)
			     then move_char =
				     substr (lit_str,
				     sf_ptr -> data_name.places_left + temp_rf_ptr -> data_name.places_right, 1);

		     end;

		move_digit = binary (move_char, 35);	/* [3.0-2] */

		if substr (lit_str, lit_ln + 1, 1) ^= "-"
		then move_char = conv_plus (move_digit);
		else move_char = conv_minus (move_digit);

		al_lit.type = 3;
		al_lit.size = 29;
		al_lit.all_lit = "0"b;
		al_lit.lit_type = "0"b;
		al_lit.lit_size = 1;
		al_lit.line = lin;
		al_lit.column = col;
		al_lit.string = move_char;
		an_ptr = addr (al_lit);
		temp_ptr = addr (temp_space);

		call cobol_make_type9$type2_3 (temp_ptr, an_ptr);

		temp_rf_ptr -> data_name.numeric = "0"b;
		temp_rf_ptr -> data_name.alphanum = "1"b;

		call gen_move_alpha (MLR, "000110000"b, temp_ptr, temp_rf_ptr, "1"b);

		if temp_sign_type = "001"b
		then do;

			temp_len =
			     fixed (substr (inst_struc.desc_od (2), 25, 12), 12)
			     + fixed (substr (inst_struc.desc_od (2), 4, 17), 17) - 1;

			substr (inst_struc.desc_od (2), 4, 17) = substr (unspec (temp_len), 20, 17);

		     end;

		substr (inst_struc.desc_od (2), 25, 12) = "000000000001"b;

		call cobol_emit (inst_ptr, reloc_ptr, 3);

		temp_rf_ptr -> data_name.numeric = "1"b;
		temp_rf_ptr -> data_name.alphanum = "0"b;
		temp_rf_ptr -> data_name.item_signed = "1"b;
		temp_rf_ptr -> data_name.sign_type = temp_sign_type;

	     end;
	else do;

/*  Check to see if zero should be moved to the rrceiving field, rather than the sending
   variable.  */

		call check_zero_move (temp_sf_ptr, rf_ptr);

		if temp_sf_ptr = sf_ptr
		then do;				/*  Sending variable should be moved.  */

			udts_token_ptr = null ();

/*  Convert the sending field to numeric decimal, trailing separate sign data if necessary.  */

			call num_to_udts (temp_sf_ptr, udts_token_ptr, return_code);

		     end;				/*  Sending variable should be moved.  */

		else udts_token_ptr = temp_sf_ptr;

		call cobol_opch_op_call (udts_token_ptr, rf_ptr);

	     end;

	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/

     end non_opch_to_opch;

/* { */
opch_to_opch:
     proc (sf_ptr, rf_ptr);
	/***..... dcl LOCAL_NAME char (12) int static init ("OPCH_TO_OPCH");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/
						/*
				   This internal procedure generates code that moves an overpunch sign
				   variable to an overpunch sign variable.  */

/*  DECLARATION OF THE PARAMETERS  */

dcl	sf_ptr		ptr;
dcl	rf_ptr		ptr;

/*  DECLARATION OF INTERNAL VARIABLES  */

dcl	temp_sf_ptr	ptr;

/* ************************************************ */
/*	START OF EXECUTION			*/
/*	opch_to_opch			*/
/* ************************************************ */

	temp_sf_ptr = sf_ptr;

/*  Check to see whether zero should be moved to the receiving field, rather than
   the sending variable.  */

	call check_zero_move (temp_sf_ptr, rf_ptr);


	call cobol_opch_op_call (temp_sf_ptr, rf_ptr);

	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/

     end opch_to_opch;

/* { */
opch_to_non_opch:
     proc (sf_ptr, rf_ptr);
	/***..... dcl LOCAL_NAME char (16) int static init ("OPCH_TO_NON_OPCH");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/

/*
   This internal procedure generates code to move an overpunch
   sign sending variable  to any non-overpunch receiving variable.  */

/*  Declaration of the Parameters  */

dcl	sf_ptr		ptr;
dcl	rf_ptr		ptr;

/*  Declarations of Internal Variables.  */

dcl	char_offset	fixed bin;
dcl	temp_sf_ptr	ptr;
dcl	temp_rf_ptr	ptr;			/* ************************************************ */
						/*	START OF EXECUTION			*/
						/*	INTERNAL PROCEDURE		*/
						/*		opch_to_non_opch		*/
						/* ************************************************ */

/*  Check to see whether zero should be moved to the receiving field, rather
   than the sending variable.  */

	temp_sf_ptr = sf_ptr;

	call check_zero_move (temp_sf_ptr, rf_ptr);

	if temp_sf_ptr ^= sf_ptr			/*  Move zero, instead of the sending variable.  */
	then call num_to_num (temp_sf_ptr, rf_ptr);

	else do;					/*  Move the overpunch sign data to the receiving field.  */

		if (rf_ptr -> data_name.display = "0"b /* NOT display  */
		     | rf_ptr -> data_name.sign_type ^= "011"b /* NOT trailing separate sign  */)
		then do;				/*  Must build a temporary, unpacked decimal, trailing
				   separate sign data item, and move the overpunch sign data into it.  */

/*  NOTE:  The temporary is the length of the receiving field.  */

			call cobol_alloc$stack (rf_ptr -> data_name.places_left + rf_ptr -> data_name.places_right
			     + 1, 0, char_offset);

			temp_rf_ptr = null ();

			call cobol_make_type9$decimal_9bit (temp_rf_ptr, 1000 /* stack */, fixed (char_offset, 24),
			     fixed (rf_ptr -> data_name.places_left, 17),
			     fixed (rf_ptr -> data_name.places_right, 17));

/*  Change sign type in the temporary to trailing separate.  */

			temp_rf_ptr -> data_name.sign_type = "011"b;

		     end;				/*  Must build a temporary, unpacked decimal, trailing separate sign data item.  */

		else temp_rf_ptr = rf_ptr;


		call cobol_opch_op_call (sf_ptr, temp_rf_ptr);


		if temp_rf_ptr ^= rf_ptr
		then call num_to_num (temp_rf_ptr, rf_ptr);

	     end;					/*  Move the overpunch sign data to the receiving field.  */

	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/

     end opch_to_non_opch;

/* { */
check_zero_move:
     proc (sf_ptr, rf_ptr);
	/***..... dcl LOCAL_NAME char (15) int static init ("CHECK_ZERO_MOVE");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(LOCAL_NAME);/**/

/*
   This internal procedure determines whether any part of a sending
   variable will fit into a receiving variable, based on the places
   to the left and right of the decimal point contained in the data
   name tokens.  If no part of the sending variable will fit into the receiving
   field, then a representation of a constant equal to zero
   is allocated, a data name token is created for the constant,
   and the parameter sf_ptr is set to the token for the zero
   constant.
*/

/*  DECLARATION OF THE PARAMETERS  */

dcl	sf_ptr		ptr;
dcl	rf_ptr		ptr;

/*  DECLARATION OF INTERNAL STATIC DATA  */

dcl	bin_zero		fixed bin (35) int static init (0);

dcl	dec_zero		char (2) int static init ("0+");

/*  DECLARATIONS OF INTERNAL VARIABLES  */

dcl	const_ptr		ptr;
dcl	const_offset	fixed bin (24);
dcl	bin_zero_const	char (4) based (const_ptr);
dcl	dec_zero_const	char (2) based (const_ptr);
dcl	const_length	fixed bin;
dcl	temp_ptr		ptr;

/* ****************************************** */
/*	START OF EXECUTION			*/
/*	check_zero_move			*/
/* ************************************************ */

	if (rf_ptr -> data_name.places_left + sf_ptr -> data_name.places_right) <= 0
	     | (rf_ptr -> data_name.places_right + sf_ptr -> data_name.places_left) <= 0
	then do;					/*  Move zero to the receiving field, insstead of the source variable.  */

		if (rf_ptr -> data_name.bin_18 | rf_ptr -> data_name.bin_36)
		then do;				/*  Receiving is fixed binary.  Allocate a fixed binary zero constant.  */

			const_ptr = addr (bin_zero);

			if rf_ptr -> data_name.bin_18
			then const_length = 2;
			else const_length = 4;

			call cobol_pool$search_op (substr (bin_zero_const, 1, const_length), 0, const_offset, in_op)
			     ;

			if in_op = 0
			then temp = 3000;
			else temp = 3;

			temp_ptr = null ();

			if rf_ptr -> data_name.bin_18
			then call cobol_make_type9$short_bin (temp_ptr, temp, fixed (const_offset, 17));


			else call cobol_make_type9$long_bin (temp_ptr, temp, fixed (const_offset, 17));

			sf_ptr = temp_ptr;

		     end;				/*  Receiving is fixed binary.  Allocate a fixed binary zero constant.  */

		else do;				/*  Allocate a decimal, separate trailing sign plus zero constant.  */

			const_ptr = addr (dec_zero);

			call cobol_pool$search_op (dec_zero_const, 0, const_offset, in_op);

			if in_op = 0
			then temp = 3000;
			else temp = 3;

/*  Make a data name token for the constant.  */

			temp_ptr = null ();

			call cobol_make_type9$decimal_9bit (temp_ptr, temp, const_offset,
			     fixed (rf_ptr -> data_name.places_left, 17), 1 - rf_ptr -> data_name.places_left);

/*  Change the sign type to trailing separate.  */

			temp_ptr -> data_name.sign_type = "011"b;
			sf_ptr = temp_ptr;

		     end;				/*  Allocate a decimal, separate trailing sign, plus zero constant.  */

	     end;					/*  Move zero to the receiving field, instead of the source variable.  */

	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(LOCAL_NAME);/**/

     end check_zero_move;


/*[4.4-2]*/

declare	(SF_dn, RF_dn)	char (144);


type_13_to_9:
     proc (p, q);

/* convert type 13 token to type 9 token */

declare	(p, q)		ptr,
	length		fixed bin,
	dn		bit (1296) based (q);

	if p -> cdtoken.options.input
	then length = 87;
	else length = 10 + 13 * p -> cdtoken.mdest;

	dn = "0"b;

	q -> data_name.size = 112 + p -> cdtoken.name_size;
	q -> data_name.line = p -> cdtoken.line;
	q -> data_name.column = p -> data_name.column;
	q -> data_name.type = 9;

	q -> data_name.item_length = length;
	q -> data_name.places_left = length;
	q -> data_name.places_right = 0;

	q -> data_name.communication_section = "1"b;
	q -> data_name.level_01 = "1"b;
	q -> data_name.non_elementary = "1"b;
	q -> data_name.alphanum = "1"b;

	q -> data_name.seg_num = p -> cdtoken.cd_seg;
	q -> data_name.offset = p -> cdtoken.cd_off;

	length = p -> cdtoken.name_size;

	q -> data_name.name_size = length;
	substr (q -> data_name.name, 1, length) = substr (p -> cdtoken.name, 1, length);

	p = q;

     end;

/*[4.4-2]*/

/*  INCLUDE FILES USED BY THIS PROCEDURE  */

%include cobol_in_token;
%include cobol_type40;
%include cobol_type1;
%include cobol_type2;
%include cobol_type3;
%include cobol_type9;

	/***.....	dcl cobol_gen_driver_$Tr_Beg entry(char(*));/**/
	/***.....	dcl cobol_gen_driver_$Tr_End entry(char(*));/**/

	/***.....	dcl Trace_Bit bit(1) static external;/**/
	/***.....	dcl Trace_Lev fixed bin static external;/**/
	/***.....	dcl Trace_Line char(36) static external;/**/
	/***.....	dcl ioa_ entry options(variable); /**/
	/***..... dcl MY_NAME char (14) int static init ("COBOL_MOVE_GEN");/**/

declare	1 cdtoken		based (dn_ptr),
%include cobol_TYPE13;

%include cobol_type19;
%include cobol_edit_ext;
%include cobol_;
%include cobol_fixed_common;
%include cobol_ext_;
%include cobol_addr_tokens;

     end cobol_move_gen;




		    cobol_mpy.pl1                   05/24/89  1041.5rew 05/24/89  0830.5       52029



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_mpy.pl1 Added Trace statements.
                                                   END HISTORY COMMENTS */


/* Modified on 11/16/84 by FCH, [5.3...], trace added */
/* Modified on 10/19/84 by FCH, [4.3-1], BUG563(phx18381), new cobol_addr_tokens.incl.pl1 */
/* Modified on 2/25/76 by Bob Chang to fix plus sign for 1011 and 1100 . */
/* Modified on 2/24/76 by Bob Chang to handle signed/unsigned. */




/* format: style3 */
%;
cobol_mpy:
     proc (operand_ptr, result_ptr, opcode_code);

/*
This proceudre generates code for the follwoing types of
Cobol constructs:

	1. MULTIPLY A BY B.
	2. DIVIDE A INTO B.

This procedure assumes that the tokens pointed at by operand_ptr
and result_ptr are data name (type 9) tokens.  That is, any
conversion of the operands from numeric literal or figurative
constant has already been done before this procedure is called.

*/


/*  DECLARATION OF THE PARAMETERS  */

dcl	operand_ptr	ptr;
dcl	result_ptr	ptr;
dcl	opcode_code	fixed bin (35);

/*
operand_ptr	Points to the token for the multiplicand or divisor
		depending on whether code is to be generated for multiplication or
		division, respectively. (input)
result_ptr	Points to the token that serves as both
			1. multiplier and product  or
			2. dividend and qoutient
		depending on whether code is to be generated
		for multiplication or division, respectively. (input)
opcode_code	a code that indicates whether code is to be
		generated for multiplication or division. (input)

			opcode_code  meaning
			---------------------------------
			     1        | multiplication
			     2        | division

*/

/*  DECLARATION OF EXTERNAL ENTRIES  */

dcl	cobol_addr	ext entry (ptr, ptr, ptr);
dcl	cobol_emit	ext entry (ptr, ptr, fixed bin);

/*}*/

/*  DECLARATION OF INTERNAL STATIC VARIABLES  */

/*  Declaration of internal static variables that contain ADD2 and SUBTRACT2 opcodes  */

dcl	mp2d_op		bit (10) int static init ("0100001101"b /*206(1)*/);
dcl	dv2d_op		bit (10) int static init ("0100001111"b /*207(1)*/);

/*  DECLARATION OF INTERNAL AUTOMATIC VARIABLES  */

/*  Declaration of buffers used by the addressability utility  */

/*  Relocation info buffer  */
dcl	reloc_buffer	(1:10) fixed bin;

/*  Instruction/description buffer  */
dcl	addr_inst_buffer	(1:10) fixed bin;

/*  Addressability input buffer  */
dcl	addr_input_buffer	(1:30) fixed bin;


dcl	dn_ptr		ptr;

/**************************************************/
/*	START OF EXECUTION			*/
/*	cobol_mpy				*/
/**************************************************/


/*  Point pointers at the buffers used to establish addressability  */

	/***.....	if Trace_Bit then call cobol_gen_driver_$Tr_Beg(cmp);/**/

	reloc_ptr = addr (reloc_buffer (1));
	input_ptr = addr (addr_input_buffer (1));
	inst_ptr = addr (addr_inst_buffer (1));

/*  Build the input structure to the addressability utility  */
	input_struc.type = 5;			/*  eis, 2 input operands, instruction word and 2 descriptors returned  */
	input_struc.operand_no = 2;
	input_struc.lock = 0;			/*  no lock  */

	input_struc.operand.token_ptr (1) = operand_ptr;
	input_struc.operand.send_receive (1) = 0;	/*  sending  */
	input_struc.operand.size_sw (1) = 0;

	input_struc.operand.token_ptr (2) = result_ptr;
	input_struc.operand.send_receive (2) = 1;	/*  receiving  */
	input_struc.operand.size_sw (2) = 0;

/*  Set the proper opcode into the eis instruction  */
	if opcode_code = 1				/*  multiply  */
	then inst_struc.fill1_op = mp2d_op;
	else inst_struc.fill1_op = dv2d_op;

/*  Establish addressability  */
	call cobol_addr (input_ptr, inst_ptr, reloc_ptr);

/*  Set the rounding bit in the eis instruction, if necessary  */

	if result_ptr -> data_name.rounded
	then inst_struc.zero3 = "01"b;		/*  truncation off, rounding on  */
	if result_ptr -> data_name.ascii_packed_dec = "1"b & result_ptr -> data_name.seg_num = 2
	then inst_struc.inst.zero1 = "10"b;

/*  Emit the eis instruction and 2 descriptors  */
	call cobol_emit (inst_ptr, reloc_ptr, 3);

	/***.....	if Trace_Bit then call cobol_gen_driver_$Tr_End(cmp);/**/

	return;

	/***.....	dcl cmp char(9) init("COBOL_MPY");/**/

	/***.....	dcl cobol_gen_driver_$Tr_Beg entry(char(*));/**/
	/***.....	dcl cobol_gen_driver_$Tr_End entry(char(*));/**/

	/***.....	dcl Trace_Bit bit(1) static external;/**/
	/***.....	dcl Trace_Lev fixed bin static external;/**/
	/***.....	dcl Trace_Line char(36) static external;/**/
	/***.....	dcl ioa_ entry options(variable); /**/


/*  INCLUDE FILES USED BY THIS PROCEDURE  */


/*****	Declaration for builtin function	*****/

dcl	(substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index)
			builtin;

/*****	End of declaration for builtin function	*****/

%include cobol_type9;


%include cobol_addr_tokens;


/**************************************************/
/*	END OF PROCEDURE			*/
/*	cobol_mpy			*/
/**************************************************/

     end cobol_mpy;




		    cobol_mpy3.pl1                  05/24/89  1041.5rew 05/24/89  0830.4       57438



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_mpy3.pl1 Added Trace statements.
                                                   END HISTORY COMMENTS */


/* format: style3 */
%;
/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */

/* Modified on 11/16/84 by FCH, [5.3...], trace added */
/* Modified on 10/19/84 by FCH, [4.3-1], BUG563(phx18381), new cobol_addr_tokens.incl.pl1 */
/* Modified since Version 2.0 */





/*{*/
cobol_mpy3:
     proc (operand1_ptr, operand2_ptr, result_ptr, opcode_code);

/*
This procedure generates code for the following types of Cobol constructs:

	1. MULTIPLY A BY B GIVING C.
	2. DIVIDE A BY B GIVING C.

This procedure makes one important assumption about the 
input operands:  The operands to be multiplied (or divided) are
both represented by data name (type 9) tokens.  That is, any
conversion of the operands from numeric literal or figurative
constant has already been done before this procedure is called.

*/

/* Note that if the "rounded" bit is on in the token pointed at 
by result_ptr, then the code generated will perform
multiplication/division with rounding.  */

/*  DECLARATION OF THE PARAMETERS  */

dcl	operand1_ptr	ptr;
dcl	operand2_ptr	ptr;
dcl	result_ptr	ptr;
dcl	opcode_code	fixed bin (35);

/*
operand1_ptr	Points to the token for the multiplicand or
		dividend, depending on whether code is to
		be generated for multiplication or division,
		respectively. (input)
operand2_ptr	Points to the token for the multiplier or
		divisor, depending on whether code is to be
		generated for addition or subtraction,
		respectively.  (input)
result_ptr	Points to the token to receive the product
		or quotient, depending on whether code it to
		be generated for multiplication or division,
		respectively.  (input)
opcode_code	A code that indicates whether code is to be generated
		for an multiplication or division.  (input)

			opcode_code	| meaning
			-------------------------------------
				1	| multilplication
				2	| division

*/

/*  DECLARATION OF EXTERNAL ENTRIES  */

dcl	cobol_addr	ext entry (ptr, ptr, ptr);
dcl	cobol_emit	ext entry (ptr, ptr, fixed bin);


/*  DECLARATION OF INTERNAL STATIC VARIABLES  */

/*  Declaration of internal static variables that contain
	MP3D and DV3D opcodes  */

dcl	mp3d_op		bit (10) int static init ("0100101101"b /*226(1)*/);
dcl	dv3d_op		bit (10) int static init ("0100101111"b /*227(1)*/);


/*  DECLARATION OF INTERNAL AUTOMATIC VARIABLES  */

/*  Declaration of buffers used by the addressability utility  */

/*  Relocation info buffer  */
dcl	reloc_buffer	(1:10) fixed bin;

/*  instruction/descriptor buffer  */
dcl	addr_inst_buffer	(1:10) fixed bin;

/*  addressability input buffer  */
dcl	addr_input_buffer	(1:30) fixed bin;
dcl	dn_ptr		ptr;


/**************************************************/
/*	START OF EXECUTION			*/
/*	cobol_mpy3				*/
/**************************************************/

	/***.....	if Trace_Bit then call cobol_gen_driver_$Tr_Beg(cm3);/**/


/*  Point pointers at the buffers used to establish addressability  */

	reloc_ptr = addr (reloc_buffer (1));
	input_ptr = addr (addr_input_buffer (1));
	inst_ptr = addr (addr_inst_buffer (1));

/*  Build the input structure to the addressability utility  */

	input_struc.type = 6;			/*  eis, 3 input operands, instruction word and 3 descriptors returned  */
	input_struc.operand_no = 3;
	input_struc.lock = 0;			/*  no locks  */

	input_struc.operand.token_ptr (1) = operand1_ptr;
	input_struc.operand.send_receive (1) = 0;	/*  sending  */
	input_struc.operand.size_sw (1) = 0;		/*  utility worries about size  */

	input_struc.operand.token_ptr (2) = operand2_ptr;
	input_struc.operand.send_receive (2) = 0;	/*  sending  */
	input_struc.operand.size_sw (2) = 0;

	input_struc.operand.token_ptr (3) = result_ptr;
	input_struc.operand.send_receive (3) = 1;	/*  receiving  */
	input_struc.operand.size_sw (3) = 0;

/*  Set the proper opcode into the eis instruction  */
	if opcode_code = 1				/*  mpy  */
	then inst_struc.fill1_op = mp3d_op;
	else inst_struc.fill1_op = dv3d_op;

/*  Establish the addresses  */

	call cobol_addr (input_ptr, inst_ptr, reloc_ptr);

/*  Set the rounding bit in the eis instruction if necessary  */
	if result_ptr -> data_name.rounded
	then inst_struc.zero3 = "01"b;		/*  TRUNCATION OFF, ROUNDING ON  */

/*  Emit the eis instruction and 3 descriptors  */

	call cobol_emit (inst_ptr, reloc_ptr, 4);

	/***.....	if Trace_Bit then call cobol_gen_driver_$Tr_End(cm3);/**/

	return;

	/***.....	dcl cm3 char(10) init("COBOL_MPY3");/**/

	/***.....	dcl cobol_gen_driver_$Tr_Beg entry(char(*));/**/
	/***.....	dcl cobol_gen_driver_$Tr_End entry(char(*));/**/

	/***.....	dcl Trace_Bit bit(1) static external;/**/
	/***.....	dcl Trace_Lev fixed bin static external;/**/
	/***.....	dcl Trace_Line char(36) static external;/**/
	/***.....	dcl ioa_ entry options(variable); /**/


/*  INCLUDE FILES USED BY THIS PROCEDURE  */


/*****	Declaration for builtin function	*****/

dcl	(substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index)
			builtin;

/*****	End of declaration for builtin function	*****/

%include cobol_type9;


%include cobol_addr_tokens;

/**************************************************/
/*	 END OF PROCEDDURE			*/
/*	cobol_add3				*/
/*************************************************/

     end cobol_mpy3;




		    cobol_mst.pl1                   05/24/89  1041.5rew 05/24/89  0830.4      324819



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_mst.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 09/07/83 by FCH, [5.2-1], fix errors in runtime symbol table, phx15769(BUG555) */
/* Modified on 10/27/82 by FCH, [5.1-2], get last line num from fix comm, BUG543(phx13643) */
/* Modified on 11/24/81 by FCH, [5.1-1], statement table was a shambles, BUG519(phx11818) */
/* Modified on 05/16/80 by FCH, [4.2-1], decl for tag_addr corrected */
/* modified on 10/20/79 by PRP [4.1-2], communicate data types to symbol table */
/* Modified on 10/20/79 by PRP [4.1-1], fix statement map */
/* Modified on 06/28/78 by RAL [3.0-1] Allow for multiple lines for each statement */
/* Modified on 03/01/78 by Richard A. Barnes to thread runtime_symbol.next in negative direction only
	and to use a hash table to eliminate duplicate runtime tokens */
/* Modified since Version 3.0 */





/* format: style3 */
cobol_mst:
     proc;

/* Builds Runtime Symbol Table for interfacing with debug.
	   Called when "-table" option specified.
	   Assumptions:

		1)	sym_base_ptr points to start of Symbol_Block_Header.
		2)	sym_wd_off is offset of 1st word after PL1_Symbol_Block. */

/* Initialization */

	sbh_ptr = sym_base_ptr;			/* get ptr to Symbol_Block_Header */
	sbh_off = fixed (rel (sbh_ptr), 18);
	psb_off = fixed (sbh_ptr -> symbol_block_header.area_relp, 18);
	psb_ptr = addrel (sbh_ptr, psb_off);		/* get ptr to PL1_Symbol_Block */
	psb_ptr -> pl1_symbol_block.flags.table = "1"b;
	token_count = 0;
	label_count = 0;
	starting_wd_off = sym_wd_off;			/* save offset of 1st word we will generate */
	sect_off = 0;
	translate_it = "0"b;
	hash_table (*) = 0;

/* Build Root Block */

	root_off = sym_wd_off;
	psb_ptr -> pl1_symbol_block.root = bit (root_off, 18);
	root_blk_ptr = gen_runtime_block (0);

/* Generate token node and symbol node for prog name */

	name_string = fixed_common.prog_name;
	name_length = index (name_string, " ") - 1;

	call gen_runtime_nodes;

	root_blk_ptr -> runtime_block.start = bit (fixed (symb_off - root_off, 18), 18);
	ext_ent_ptr = s_ptr;			/* save ptr to symbol of program name */

	s_ptr -> runtime_symbol.type = "011010"b;	/* external entry constant */
	s_ptr -> runtime_symbol.father = bit (fixed (262144 + root_off - symb_off, 18), 18);
	s_ptr -> runtime_symbol.address.location = bit (fixed (cobol_$constant_offset + 1, 18), 18);
	s_ptr -> runtime_symbol.address.class = "1100"b;	/* text reference */

	sym_wd_off = sym_wd_off + symbol_size;

	if name_length > 1
	then do;					/* fill in chain of root block to point to procname */

		token_size = 16;
		j = 4;

		do while (name_length < token_size);

		     j = j - 1;
		     token_size = divide (token_size, 2, 18, 0);
		end;

		root_blk_ptr -> runtime_block.chain (j) = root_blk_ptr -> runtime_block.start;
	     end;

/* Build Main Block */

	main_off = sym_wd_off;
	text_ptr = cobol_$text_base_ptr;
	block_relp = bit (main_off, 18);
	main_blk_ptr = gen_runtime_block (root_off);

/* Build "COBOL" token and symbol - this is data_ptr on which all data is based. */

	name_string = "COBOL";
	name_length = 5;

	call gen_runtime_nodes;

	data_ptr_off = symb_off;
	s_ptr -> runtime_symbol.location = "000000000000001000"b;
						/* 8 bytes */
	s_ptr -> runtime_symbol.type = "001101"b;	/* pointer */
	s_ptr -> runtime_symbol.class = "0100"b;	/* internal static */
	s_ptr -> runtime_symbol.father = bit (fixed (262144 + main_off - data_ptr_off, 18), 18);

	sym_wd_off = sym_wd_off + symbol_size;

/* Process Name-Table */

	translate_it = "1"b;
	len_ptr = pointer (cobol_ntfp, 8);

	do while (len > 0);

	     p = len_ptr;
	     go to token_type (p -> name_table_entry.type);

token_type (7):					/* PROCEDURE DEFINITION (Label) */
token_type (18):
	     proc_def_ptr = p;

	     if label_count < fixed_common.proc_counter
	     then do;				/* do not process compiler generated labels */

		     name_string = proc_def_ptr -> proc_def.name;
		     name_length = proc_def_ptr -> proc_def.name_size;

		     call gen_runtime_nodes;

		     s_ptr -> runtime_symbol.simple = "1"b;
		     symbol_size = 4;		/* no "size" field for labels */

		     tag_loc = cobol_$tag_table_ptr -> tag_addr (proc_def.proc_num);

		     do while (tag_loc < 0);

			tag_loc = cobol_$tag_table_ptr -> tag_addr (-tag_loc);
		     end;

		     if tag_loc = 0
		     then do;			/* ERROR - undefined label */

			     call ioa_ ("Procedure Definition ^a is undefined", proc_def.name);
			     call ioa_ ("and will not appear in the Runtime Symbol Table");

			     token_count = token_count - 1;

			end;
		     else do;

			     s_ptr -> runtime_symbol.location =
				bit (fixed (tag_loc + cobol_$constant_offset, 18), 18);

			     if proc_def_ptr -> proc_def.section_name
			     then do;

				     s_ptr -> runtime_symbol.level = "000001"b;
				     s_ptr -> runtime_symbol.father =
					bit (fixed (262144 + main_off - symb_off, 18), 18);

				     sect_off = symb_off;
				     sect_ptr = s_ptr;
				     prev_p = null ();

				end;
			     else if sect_off = 0
			     then s_ptr -> runtime_symbol.father =
				     bit (fixed (262144 + main_off - symb_off, 18), 18);
			     else do;

				     s_ptr -> runtime_symbol.level = "000010"b;
				     s_ptr -> runtime_symbol.father =
					bit (fixed (262144 + sect_off - symb_off, 18), 18);

				     if prev_p = null ()
				     then sect_ptr -> runtime_symbol.son =
					     bit (fixed (symb_off - sect_off, 18), 18);
				     else prev_p -> runtime_symbol.brother =
					     bit (fixed (symb_off - prev_poff, 18), 18);

				     prev_p = s_ptr;

				     prev_poff = symb_off;

				end;

			     s_ptr -> runtime_symbol.type = "011000"b;
						/* label constant */
			     s_ptr -> runtime_symbol.class = "1100"b;
						/* text-reference */

			     sym_wd_off = sym_wd_off + symbol_size;

			end;

		     label_count = label_count + 1;

		end;

	     go to token_type (0);

token_type (9):					/* data-name */
	     dn_ptr = p;				/* establish data-name ptr */
	     name_string = dn_ptr -> data_name.name;

	     if name_string = "SYSTEM_STATUS" | name_string = "TALLY"
	     then go to token_type (0);

	     name_length = dn_ptr -> data_name.name_size;

	     call gen_runtime_nodes;

	     symbol_size = symbol_size + 1;		/* add 1 for offset field */

	     if dn_ptr -> data_name.display | dn_ptr -> data_name.non_elementary
	     then do;				/* non_elementary = structure - make char string so full structure can be printed */

/* [4.1-2] */
		     if data_name.numeric | data_name.numeric_edited
		     then do;

/*[5.2-1]*/
			     if data_name.numeric	/*[5.2-1]*/
			     then do;


				     if data_name.sign_type = "000"b
				     then s_ptr -> runtime_symbol.type = "100011"b;
				     else if data_name.sign_type = "100"b
				     then s_ptr -> runtime_symbol.type = "001001"b;
				     else if data_name.sign_type = "011"b
				     then s_ptr -> runtime_symbol.type = "100100"b;
				     else if data_name.sign_type = "010"b
				     then s_ptr -> runtime_symbol.type = "011101"b;
				     else if data_name.sign_type = "001"b
				     then s_ptr -> runtime_symbol.type = "011110"b;
				     else /* do nothing */
					;

/*[5.2-1]*/
				end;		/*[5.2-1]*/
			     else s_ptr -> runtime_symbol.type = "010101"b;

			     s_ptr -> runtime_symbol.size = data_name.places_left + data_name.places_right;

			     temp_scale = data_name.places_right;
			     s_ptr -> runtime_symbol.scale = unspec (temp_scale);

			end;

		     else do;

			     s_ptr -> runtime_symbol.type = "010101"b;
			     s_ptr -> runtime_symbol.size = dn_ptr -> data_name.item_length;

			end;

/*[5.2-1]*/
		     s_ptr -> runtime_symbol.aligned = "0"b;
						/*[5.2-1]*/
		     s_ptr -> runtime_symbol.packed = "1"b;

		     s_ptr -> runtime_symbol.offset = dn_ptr -> data_name.offset;

		end;
	     else if dn_ptr -> data_name.usage_index
	     then do;

		     s_ptr -> runtime_symbol.aligned = "0"b;
		     s_ptr -> runtime_symbol.packed = "1"b;
		     s_ptr -> runtime_symbol.type = "000001"b;
						/* fixed bin */
		     s_ptr -> runtime_symbol.size = 17; /* precision = 17 */
		     s_ptr -> runtime_symbol.offset = dn_ptr -> data_name.offset + 4;

		end;

/*	/*  next two blocks are redundant in that both support comp-5 and comp-8.
/*	    With the current arrangement, comp-8 is described as packed decimal
/*	    and comp-5 as bit string.  For both bitstring, eliminate the following block;
/*	    for both packed decimal, change following test to ascii_packed_dec
/*	    instead of ascii_packed_dec_h and elminate second block;  similarly
/*	    change array_units test.		*/
/*		else	if dn_ptr->data_name.ascii_packed_dec_h  /* COMP-8 */
/*			then do;
/*				s_ptr->runtime_symbol.aligned = "0"b;
/*				s_ptr->runtime_symbol.packed = "1"b;
/*				s_ptr->runtime_symbol.units = "11"b;		/* half */
/*				s_ptr->runtime_symbol.type = "011111"b;		/* packed decimal */
/*				packed_dec_size = dn_ptr->data_name.places_left
/*						+ dn_ptr->data_name.places_right;
/*				if dn_ptr->data_name.item_signed
/*				then packed_dec_size = packed_dec_size + 1;
/*				temp_off = 9*data_name.offset+1;
/*				if data_name.ascii_packed_dec_h then do;  /* COMP-8 */
/*					if data_name.bit_offset ^= ""b then do;
/*					s_ptr->runtime_symbol.offset = temp_off+4;
/*					s_ptr->runtime_symbol.size = packed_dec_size;
/*					end;
/*					else do;
/*					s_ptr->runtime_symbol.offset = temp_off;
/*					s_ptr->runtime_symbol.size = packed_dec_size;
/*					end;
/*				end;
/*				else do;		/* COMP-5 */
/*					if temp_mod = 0 then do;
/*					s_ptr->runtime_symbol.offset = temp_off;
/*					s_ptr->runtime_symbol.size = packed_dec_size;
/*				    end;
/*					else do;		/* odd length */
/*					s_ptr->runtime_symbol.offset = temp_off+4;
/*					s_ptr->runtime_symbol.size = packed_dec_size;
/*				    end;
/*				end;
/*			    end;
/*		else	if dn_ptr->data_name.ascii_packed_dec  /* COMP-5 */
/*			then do;
/*				s_ptr->runtime_symbol.aligned = "0"b;
/*				s_ptr->runtime_symbol.packed = "1"b;
/*				s_ptr->runtime_symbol.units = "01"b;		/* bits */
/*				s_ptr->runtime_symbol.type = "010011"b;		/* bit string */
/*				packed_dec_size = dn_ptr->data_name.places_left
/*						+ dn_ptr->data_name.places_right;
/*				if dn_ptr->data_name.item_signed
/*				then packed_dec_size = packed_dec_size + 1;
/*				temp_off = 9*data_name.offset+1;
/*				temp_size = 9*divide(packed_dec_size,2,35,0);
/*				temp_mod = mod(packed_dec_size,2);
/*				if data_name.ascii_packed_dec_h then do;  /* COMP-8 */
/*					temp_size = temp_size+temp_mod*4;
/*					if data_name.bit_offset ^= ""b then do;
/*					s_ptr->runtime_symbol.offset = temp_off+4;
/*					s_ptr->runtime_symbol.size = temp_size;
/*					end;
/*					else do;
/*					s_ptr->runtime_symbol.offset = temp_off;
/*					if temp_mod = 0 then s_ptr->runtime_symbol.size = temp_size-1;
/*					else s_ptr->runtime_symbol.size = temp_size;
/*					end;
/*				end;
/*				else do;		/* COMP-5 */
/*					if temp_mod = 0 then do;
/*					s_ptr->runtime_symbol.offset = temp_off;
/*					s_ptr->runtime_symbol.size = temp_size-1;
/*				    end;
/*					else do;		/* odd length */
/*					s_ptr->runtime_symbol.offset = temp_off+4;
/*					s_ptr->runtime_symbol.size = temp_size+4;
/*				    end;
/*				end;
/*			    end;
/**/
	     else if dn_ptr -> data_name.ascii_packed_dec
	     then do;				/* packed decimal */

		     temp_scale = data_name.places_right;
		     s_ptr -> runtime_symbol.scale = unspec (temp_scale);

		     s_ptr -> runtime_symbol.aligned = "0"b;
		     s_ptr -> runtime_symbol.packed = "1"b;
		     s_ptr -> runtime_symbol.use_digit = "1"b;
		     s_ptr -> runtime_symbol.units = "11"b;

		     if data_name.item_signed
		     then do;

			     if data_name.ascii_packed_dec_h
						/*[5.2-1]*/
			     then if dn_ptr -> data_name.sync
						/*[5.2-1]*/
				then s_ptr -> runtime_symbol.type = "101011"b;
						/* 43 */
						/*[5.2-1]*/
				else s_ptr -> runtime_symbol.type = "101001"b;
						/* 41 */
			     else s_ptr -> runtime_symbol.type = "100111"b;

			end;
		     else if data_name.ascii_packed_dec_h
						/*[5.2-1]*/
		     then if dn_ptr -> data_name.sync	/*[5.2-1]*/
			then s_ptr -> runtime_symbol.type = "101000"b;
						/* 40 */
						/*[5.21]*/
			else s_ptr -> runtime_symbol.type = "100110"b;
						/* 38 */
		     else s_ptr -> runtime_symbol.type = "101000"b;
						/* New data type 40*/

		     s_ptr -> runtime_symbol.size = data_name.places_left + data_name.places_right;
		     s_ptr -> runtime_symbol.offset = 2 * data_name.offset;
						/* in half-bytes */

		     if ^data_name.ascii_packed_dec_h
		     then do;			/* COMP-5 */

			     if mod (s_ptr -> runtime_symbol.size, 2) = 1
			     then if ^data_name.item_signed
				then s_ptr -> runtime_symbol.offset = s_ptr -> runtime_symbol.offset + 1;
				else ;
			     else if data_name.item_signed
			     then s_ptr -> runtime_symbol.offset = s_ptr -> runtime_symbol.offset + 1;

			end;
		     else if data_name.bit_offset ^= ""b
		     then s_ptr -> runtime_symbol.offset = s_ptr -> runtime_symbol.offset + 1;
		end;
	     else if dn_ptr -> data_name.bin_18
	     then do;

		     s_ptr -> runtime_symbol.aligned = "0"b;
						/*[5.2-1]*/
		     if dn_ptr -> data_name.sync	/*[5.2-1]*/
		     then s_ptr -> runtime_symbol.packed = "0"b;
						/*[5.2-1]*/
		     else s_ptr -> runtime_symbol.packed = "1"b;
		     s_ptr -> runtime_symbol.type = "000001"b;
						/* fixed bin */
		     s_ptr -> runtime_symbol.size = 17; /* precision = 17 */
		     s_ptr -> runtime_symbol.offset = dn_ptr -> data_name.offset;

		end;
	     else if dn_ptr -> data_name.bin_36
	     then do;

		     s_ptr -> runtime_symbol.aligned = "1"b;
		     s_ptr -> runtime_symbol.packed = "0"b;
		     s_ptr -> runtime_symbol.type = "000001"b;
						/* fixed bin */
		     s_ptr -> runtime_symbol.size = 35; /* precision = 35 */
		     s_ptr -> runtime_symbol.offset = dn_ptr -> data_name.offset;

		end;

	     if dn_ptr -> data_name.working_storage | dn_ptr -> data_name.file_section
		| dn_ptr -> data_name.communication_section
						/* 10/01/77 */
	     then do;

		     s_ptr -> runtime_symbol.class = "0011"b;
						/* based */
		     s_ptr -> runtime_symbol.location = bit (fixed (262144 + data_ptr_off - symb_off, 18), 18);

		end;
	     else if dn_ptr -> data_name.constant_section
	     then do;

		     s_ptr -> runtime_symbol.class = "1100"b;
						/* text reference */
		     s_ptr -> runtime_symbol.location =
			bit (fixed (cobol_$constant_offset - divide (dn_ptr -> data_name.offset + 3, 4, 18, 0), 18),
			18);
		     s_ptr -> runtime_symbol.offset = mod (dn_ptr -> data_name.offset, 4);

		end;
	     else if dn_ptr -> data_name.linkage_section
	     then do;				/* parameter */

		     s_ptr -> runtime_symbol.class = "1001"b;
						/* parameter */
		     s_ptr -> runtime_symbol.location = bit (fixed (dn_ptr -> data_name.linkage, 18), 18);

		end;

	     if dn_ptr -> data_name.level_77 | dn_ptr -> data_name.level = 66
		| (dn_ptr -> data_name.level_01 & dn_ptr -> data_name.elementary)
	     then s_ptr -> runtime_symbol.level = (6)"0"b;
	     else s_ptr -> runtime_symbol.level = bit (fixed (dn_ptr -> data_name.level, 6), 6);

	     if fixed (s_ptr -> runtime_symbol.level, 7) <= 1
	     then s_ptr -> runtime_symbol.father = bit (fixed (262144 + main_off - symb_off, 18), 18);

	     if dn_ptr -> data_name.occurs_ptr = 0
	     then s_ptr -> runtime_symbol.ndims = "0"b;
	     else do;				/* process array info */

		     occurs_ptr = addrel (dn_ptr, divide (dn_ptr -> data_name.occurs_ptr, 4, 15, 0));

		     s_ptr -> runtime_symbol.ndims = bit (fixed (occurs_ptr -> occurs.dimensions, 6), 6);
		     s_ptr -> runtime_symbol.virtual_org = 0;

		     do j = 1 to occurs_ptr -> occurs.dimensions;

			s_ptr -> runtime_symbol.bounds.lower (j) = max (occurs_ptr -> occurs.level.min (j), 1);
			s_ptr -> runtime_symbol.bounds.upper (j) = occurs_ptr -> occurs.level.max (j);

			if dn_ptr -> data_name.ascii_packed_dec
			then do;			/* packed decimal */

				s_ptr -> runtime_symbol.bounds.multiplier (j) =
				     occurs_ptr -> occurs.level.struc_length (j);
				s_ptr -> runtime_symbol.array_units = s_ptr -> runtime_symbol.units;
			     end;
			else s_ptr -> runtime_symbol.bounds.multiplier (j) =
				divide (occurs_ptr -> occurs.level.struc_length (j) + 1, 2, 35, 0);

			s_ptr -> runtime_symbol.virtual_org =
			     s_ptr -> runtime_symbol.virtual_org + s_ptr -> runtime_symbol.bounds.multiplier (j);
		     end;

		     symbol_size = symbol_size + 1 + 3 * (occurs_ptr -> occurs.dimensions);

		end;

	     if dn_ptr -> data_name.non_elementary | (dn_ptr -> data_name.level > 1 & dn_ptr -> data_name.level <= 49)
	     then do;				/* structure or structure-member */

/* For each structure or structure-member, we will set the
				   father,son and brother fields of the runtime_symbol node. */

		     if dn_ptr -> data_name.level_01
		     then do;			/* structure */

			     prev_s = s_ptr;
			     prev_level = 1;

			end;

		     else do;			/* structure-member */

/* Backup chain to prev brother if level < prev_level */

			     do while (fixed (s_ptr -> runtime_symbol.level, 17) < prev_level);

				prev_soff = prev_soff + fixed (prev_s -> runtime_symbol.father, 18) - 262144;
				prev_s = addrel (prev_s, prev_s -> runtime_symbol.father);
				prev_level = fixed (prev_s -> runtime_symbol.level, 18);
			     end;

			     if fixed (s_ptr -> runtime_symbol.level, 17) > prev_level
			     then do;		/* processing a son */

				     prev_s -> runtime_symbol.son = bit (fixed (symb_off - prev_soff, 18), 18);
				     s_ptr -> runtime_symbol.father =
					bit (fixed (262144 + prev_soff - symb_off, 18), 18);
				     prev_level = fixed (s_ptr -> runtime_symbol.level, 18);

				end;
			     else do;		/* level = prev_level, processing a brother */

				     prev_s -> runtime_symbol.brother =
					bit (fixed (symb_off - prev_soff, 18), 18);
				     s_ptr -> runtime_symbol.father =
					bit (
					fixed (262144 + fixed (prev_s -> runtime_symbol.father, 18)
					+ prev_soff - symb_off, 18), 18);

				end;

			     prev_s = s_ptr;

			end;

		     prev_soff = symb_off;

		end;

	     sym_wd_off = sym_wd_off + symbol_size;

	     go to token_type (0);

token_type (10):					/* Index-Name */
	     ind_ptr = p;
	     name_string = ind_ptr -> index_name.name;
	     name_length = ind_ptr -> index_name.name_size;

	     call gen_runtime_nodes;

	     symbol_size = symbol_size + 1;
	     s_ptr -> runtime_symbol.offset = ind_ptr -> index_name.offset + 4;
						/* use ocur. no. only */
	     s_ptr -> runtime_symbol.class = "0011"b;	/* based */
	     s_ptr -> runtime_symbol.type = "000001"b;	/* fixed bin */
	     s_ptr -> runtime_symbol.size = 35;		/* precision = 35 */
	     s_ptr -> runtime_symbol.location = bit (fixed (262144 + data_ptr_off - symb_off, 18), 18);
	     s_ptr -> runtime_symbol.father = bit (fixed (262144 + main_off - symb_off, 18), 18);
	     sym_wd_off = sym_wd_off + symbol_size;

	     go to token_type (0);

token_type (0):
token_type (1):
token_type (2):
token_type (3):
token_type (4):
token_type (5):
token_type (6):
token_type (8):
token_type (11):
token_type (12):
token_type (13):
token_type (14):
token_type (15):
token_type (16):
token_type (17):
token_type (19):
token_type (20):
token_type (40):
	     len_ptr = addrel (p, divide (len + 11, 8, 35, 0) * 2);

	end;

/* Sort tokens alphabeticly by size and form token and symbol chains for blocks */


	call sort_tokens;

	first = 1;
	token_size = 2;
	finished = "0"b;
	prev_s = null;

	do i = 0 to 5 while (^finished);

	     prev_t = null ();

	     if i < 5
	     then first_symbol = "1"b;

	     do j = first to token_count while (fixed (token_list (j) -> runtime_token.size, 9) < token_size);

		t_ptr = token_list (j);
		t_off = fixed (rel (t_ptr), 18) - sbh_off;

		if prev_t = null ()
		then do;				/* first token of this size...set block.token to point to it */


			next_off = t_off - main_off;

			if next_off > 0
			then main_blk_ptr -> runtime_block.token (i) = bit (next_off, 18);
			else main_blk_ptr -> runtime_block.token (i) = bit (fixed (262144 + next_off, 18), 18);

			root_blk_ptr -> runtime_block.token (i) = bit (fixed (t_off - root_off, 18), 18);

		     end;

		else do;				/* set token.next of prev token to point to this token */

			next_off = t_off - prev_toff;

			if next_off > 0
			then prev_t -> runtime_token.next = bit (next_off, 18);
			else prev_t -> runtime_token.next = bit (fixed (262144 + next_off, 18), 18);
		     end;

		prev_t = t_ptr;
		prev_toff = t_off;

		s_ptr = t_ptr;
		next_offset = fixed (t_ptr -> runtime_token.dcl, 18);

/* the following loop examines all symbols with the same name */


		do while (next_offset ^= 0);

		     s_ptr = addrel (s_ptr, next_offset);

		     if fixed (s_ptr -> runtime_symbol.level, 7) <= 1 & s_ptr ^= ext_ent_ptr
		     then do;			/* link all level 0 & 1 symbols */

			     symb_off = fixed (rel (s_ptr), 18) - sbh_off;

			     if first_symbol
			     then do;

/* this is the first symbol of this size, so have
				   runtime_block.chain(i) point to this symbol.
				   Also, if this is the very first symbol processed, have
				   runtime_block.start point to the symbol.	*/

				     first_symbol = "0"b;

				     next_off = symb_off - main_off;

				     if main_blk_ptr -> runtime_block.start = "0"b
				     then if next_off > 0
					then main_blk_ptr -> runtime_block.start = bit (next_off, 18);
					else main_blk_ptr -> runtime_block.start =
						bit (fixed (262144 + next_off, 18), 18);

				     if i > 0 & i < 5
				     then do;	/* set main_block.chain to point to this symbol */

					     if next_off > 0
					     then main_blk_ptr -> runtime_block.chain (i) = bit (next_off, 18);
					     else main_blk_ptr -> runtime_block.chain (i) =
						     bit (fixed (262144 + next_off, 18), 18);

					end;
				end;

			     if prev_s ^= null
			     then do;		/* set prev symbol.brother to point to this symbol */

/* chain this level 1 symbol to other level 1 symbols in this block */

				     next_off = symb_off - prev_soff;

				     if next_off > 0
				     then prev_s -> runtime_symbol.brother = bit (next_off, 18);
				     else prev_s -> runtime_symbol.brother =
					     bit (fixed (262144 + next_off, 18), 18);

				end;

			     prev_s = s_ptr;
			     prev_soff = symb_off;

			end;

/* get the next symbol, or exzit the loop */

		     if s_ptr -> runtime_symbol.next
		     then next_offset = fixed (s_ptr -> runtime_symbol.next, 14) - 16384;
		     else next_offset = 0;

		end;

	     end;

	     if prev_t ^= null
	     then prev_t -> runtime_token.next = (18)"0"b;/* finish the list */

	     token_size = 2 * token_size;
	     finished = j > token_count;
	     first = j;
	end;


/* Generate relocation bits for runtime symbol table */

	call cobol_reloc (null (), 2 * (sym_wd_off - starting_wd_off), 4);

/* Build Statement Map */

	psb_ptr -> pl1_symbol_block.flags.map = "1"b;
	psb_ptr -> pl1_symbol_block.map.first = bit (fixed (sym_wd_off, 18), 18);
	root_blk_ptr -> runtime_block.map.first = bit (fixed (sym_wd_off - root_off, 18), 18);
	main_blk_ptr -> runtime_block.map.first = bit (fixed (sym_wd_off - main_off, 18), 18);

	prev_line_num = 0;
	prev_file_num = 0;

/*[5.1-1]*/
	statement_no = 1;

/*[5.1-1]*/
	do i = 1 by 1 to map_data_table.no_source_stmts;

/*[5.1-1]*/
	     if map_data_table.label (i)		/*[5.1-1]*/
	     then do;
		     statement_no = 1;

/*[5.2-1]*/
		     eln_index = map_data_table.line_no (i);
						/*[5.2-1]*/
		     if eln_index > 0
		     then line_num = eln_tab.lno (eln_index);

/*[5.1-1]*/
		     do while (map_data_table.label (i));

/*[5.1-1]*/
			i = i + 1;

/*[5.1-1]*/
		     end;				/*[5.1-1]*/
		end;				/*[5.2-1]*/
	     else do;
		     eln_index = map_data_table.line_no (i);
						/*[5.2-1]*/
		     if eln_index > 0
		     then line_num = eln_tab.lno (eln_index);
						/*[5.2-1]*/
		end;

/*[5.1-1]*/
	     if i <= map_data_table.no_source_stmts	/*[5.2-1]*/
	     then do;				/*eln_index = map_data_table.line_no(i);*/

/*[5.1-1]*/
		     if eln_index > 0		/*[5.1-1]*/
		     then do;

/*[5.2-1]*/
/*line_num = eln_tab.lno(eln_index);*/
/*[5.1-1]*/
			     file_num = eln_tab.fno (eln_index);

/*[5.1-1]*/
			     p = addrel (sym_base_ptr, sym_wd_off);

/*[5.1-1]*/
			     p -> statement_map.location =
				/*[5.1-1]*/
				bit (fixed (map_data_table.text_addr (i) + cobol_$constant_offset, 18), 18);

/*[5.1-1]*/
			     p -> statement_map.file = bit (file_num, 8);
						/*[5.1-1]*/
			     p -> statement_map.line = bit (line_num, 14);
						/*[5.1-1]*/
			     p -> statement_map.statement = bit (statement_no, 5);

/*[5.1-1]*/
			     p -> statement_map.start =
				bit (fixed (statement_info.start (eln_index) + map_data_table.col (i) - 1, 18),
				18);

/*[5.1-1]*/
			     if i = map_data_table.no_source_stmts
						/*[5.1-2]*/
			     then do;
				     span = fixed_common.cobol_cln - eln_index;
						/*[5.1-1]*/
				     next_eln_index = 0;
						/*[5.1-1]*/
				end;		/*[5.1-1]*/
			     else do;
				     next_eln_index = map_data_table.line_no (i + 1);

/*[5.1-1]*/
				     do j = eln_index by 1 to next_eln_index - 1 /*[5.1-1]*/
					while (eln_tab.fno (j) = file_num);
						/*[5.1-1]*/
				     end;

/*[5.1-1]*/
				     span = j - eln_index;
						/*[5.1-1]*/
				end;

/*[5.1-1]*/
			     if span = 0		/*[5.1-1]*/
			     then do;
				     statement_no = statement_no + 1;
						/*[5.1-1]*/
				     new_length = map_data_table.col (i + 1) - map_data_table.col (i);
						/*[5.1-1]*/
				end;		/*[5.1-1]*/
			     else do;
				     statement_no = 1;


/*[5.1-1]*/
				     new_length = statement_info.length (eln_index) - map_data_table.col (i) + 1;

/*[5.1-1]*/
				     if span > 1	/*[5.1-1]*/
				     then do j = eln_index + 1 by 1 to eln_index + span - 1;

/*[5.1-1]*/
					     new_length = new_length + statement_info.length (j) + 1;

/*[5.1-1]*/
					end;

/*[5.1-1]*/
				     if next_eln_index > 0
						/*[5.1-1]*/
				     then if eln_index + span = next_eln_index
						/*[5.1-1]*/
					then if file_num = eln_tab.fno (next_eln_index)
						/*[5.1-1]*/
					     then new_length = new_length + map_data_table.col (i + 1);

/*[5.1-1]*/
				end;

/*[5.1-1]*/
			     p -> statement_map.length = bit (fixed (new_length, 9), 9);

/*[5.1-1]*/
			     call cobol_reloc (addr (stmt_map_reloc_bits), 4, 4);

/*[5.1-1]*/
			     sym_wd_off = sym_wd_off + 2;

/*[5.1-1]*/
			end;

/*[5.1-1]*/
		end;

/*[5.1-1]*/
	end;

	main_blk_ptr -> runtime_block.map.last = bit (fixed (sym_wd_off - main_off, 18), 18);

/* Build dummy last statement-map entry */

	p = addrel (sym_base_ptr, sym_wd_off);
	p -> statement_map.location = bit (fixed (cobol_$non_source_offset + cobol_$constant_offset, 18), 18);
	string (p -> statement_map.source_id) = (27)"1"b;
	string (p -> statement_map.source_info) = (26)"0"b;

	call cobol_reloc (addr (stmt_map_reloc_bits), 4, 4);

	sym_wd_off = sym_wd_off + 2;
	psb_ptr -> pl1_symbol_block.map.last = bit (fixed (sym_wd_off, 18), 18);
	root_blk_ptr -> runtime_block.map.last = bit (fixed (sym_wd_off - root_off, 18), 18);

/* Finish Up */

	sbh_ptr -> symbol_block_header.default_truncate = bit (fixed (sym_wd_off, 18), 18);

	return;

/**/
gen_runtime_block:
     proc (father_off) returns (ptr);

dcl	father_off	fixed bin (18);
dcl	p		ptr;

	p = addrel (sym_base_ptr, sym_wd_off);		/* get ptr for runtime_block area */
	substr (p -> bits, 1, 360) = "0"b;		/* clear runtime_block area */
	p -> runtime_block.flag = "1"b;
	p -> runtime_block.standard = "1"b;
	p -> runtime_block.type = "000011"b;
	p -> runtime_block.father = bit (fixed (262144 + father_off - sym_wd_off, 18), 18);
	p -> runtime_block.header = bit (fixed (262144 - sym_wd_off, 18), 18);

	if father_off ^= 0
	then do;					/* Main Block */

		p -> runtime_block.name = bit (fixed (262144 + name_off - sym_wd_off, 18), 18);
		root_blk_ptr -> runtime_block.son = bit (fixed (sym_wd_off - root_off, 18), 18);
	     end;
	sym_wd_off = sym_wd_off + 10;

	return (p);

     end gen_runtime_block;


gen_runtime_nodes:
     proc;

dcl	found		bit (1) aligned;
dcl	name		char (32) aligned based (addr (name_array));
dcl	name_array	(8) bit (36) aligned;
dcl	tok_offset	fixed bin;
dcl	mask		(3) bit (36) aligned static init ("777000000000"b3, "777777000000"b3, "777777777000"b3);
dcl	hash_index	fixed bin;
dcl	mod_2_sum		bit (36) aligned;
dcl	(j, k)		fixed bin;

/* find or generate runtime token node */

/* copy the name for hashing, translating if necessary */

	if translate_it
	then substr (name, 1, name_length) = translate (substr (name_string, 1, name_length), "_", "-");
	else substr (name, 1, name_length) = substr (name_string, 1, name_length);

/* develop the hash_index */

	if name_length = 0
	then hash_index = 0;

	else if name_length = 1
	then hash_index = binary (unspec (substr (name, 1, 1)) & "177"b3, 9);

	else do;
		mod_2_sum = "0"b;

		j = divide (name_length, 4, 17, 0);
		k = name_length - 4 * j;

		if k ^= 0
		then do;
			j = j + 1;
			name_array (j) = name_array (j) & mask (k);
		     end;

		do i = 1 to j;

		     mod_2_sum = bool (mod_2_sum, name_array (i), "0110"b);
						/* XOR */
		end;

		hash_index = mod (binary (mod_2_sum, 35), dim (hash_table, 1));

	     end;

/* search for the runtime_token */

	tok_offset = hash_table (hash_index);
	found = "0"b;

	do while (^found & tok_offset > 0);

	     t_ptr = addrel (sym_base_ptr, tok_offset);

	     if fixed (t_ptr -> runtime_token.size, 9) = name_length
		& t_ptr -> runtime_token.string = substr (name, 1, name_length)
	     then found = "1"b;
	     else tok_offset = fixed (t_ptr -> runtime_token.next, 18);
	end;

	if found
	then name_off = tok_offset + 1;

	else do;

/* generate the node */

		tok_offset = sym_wd_off;
		t_ptr = addrel (sym_base_ptr, tok_offset);
		token_count = token_count + 1;
		token_list (token_count) = t_ptr;
		name_off = tok_offset + 1;
		token_size = 2 + divide (name_length, 4, 18, 0);
		substr (t_ptr -> bits, 1, 36 * token_size) = "0"b;
						/* clear token */
		t_ptr -> runtime_token.size = bin (name_length, 9);
		t_ptr -> runtime_token.string = substr (name, 1, name_length);
		sym_wd_off = sym_wd_off + token_size;
		t_ptr -> runtime_token.next = bit (hash_table (hash_index), 18);
		hash_table (hash_index) = tok_offset;

	     end;

/* start generating runtime symbol node...node will be completed by caller */

	s_ptr = addrel (sym_base_ptr, sym_wd_off);
	symb_off = sym_wd_off;
	substr (s_ptr -> bits, 1, 180) = simple_symbol;
	s_ptr -> runtime_symbol.simple = ^translate_it;
	s_ptr -> runtime_symbol.name = bit (fixed (262144 + name_off - symb_off, 18), 18);

/* if this token already has a symbol, chain the new symbol to the old one */

	if t_ptr -> runtime_token.dcl
	then s_ptr -> runtime_symbol.next =
		bit (fixed (tok_offset + fixed (t_ptr -> runtime_token.dcl, 18) - symb_off + 16384, 14), 14);

	t_ptr -> runtime_token.dcl = bit (fixed (symb_off - tok_offset, 18), 18);

	symbol_size = 5;

     end gen_runtime_nodes;

sort_tokens:
     proc;

/* This routine sorts the array of ptrs to runtime_tokens. It does a Shell sort alphabetizing
   by size on the basis of the string in the token. */

dcl	(d, i, j, k)	fixed bin;
dcl	(p, p1, p2)	ptr;

	d = token_count;

down:
	d = 2 * divide (d, 4, 15, 0) + 1;

	do i = 1 to token_count - d;

	     k = i + d;
	     p2 = token_list (k);

up:
	     j = k - d;
	     p1 = token_list (j);

	     if p1 -> runtime_token.size > p2 -> runtime_token.size
	     then go to interchange;

	     if p1 -> runtime_token.size < p2 -> runtime_token.size
	     then go to ok;

	     if p1 -> runtime_token.string <= p2 -> runtime_token.string
	     then go to ok;

interchange:
	     p = token_list (j);
	     token_list (j) = token_list (k);
	     token_list (k) = p;

	     if j > d
	     then do;
		     k = j;
		     go to up;
		end;
ok:
	end;

	if d > 1
	then go to down;

     end sort_tokens;



/* temp dcls */
dcl	span		fixed bin;
dcl	temp_scale	fixed bin (7) unal;
dcl	prev_stmt_length	fixed bin;
dcl	(k, next_eln_index, new_length)
			fixed bin;
dcl	(temp_off, temp_size, temp_mod)
			fixed bin;

dcl	p		ptr;
dcl	sbh_ptr		ptr defined (sym_ptr);
dcl	psb_ptr		ptr;
dcl	root_blk_ptr	ptr;
dcl	main_blk_ptr	ptr;
dcl	s_ptr		ptr;
dcl	t_ptr		ptr;
dcl	sect_ptr		ptr;
dcl	prev_p		ptr;
dcl	prev_s		ptr;
dcl	prev_t		ptr;
dcl	dn_ptr		ptr;
dcl	len_ptr		ptr;
dcl	ext_ent_ptr	ptr;
dcl	token_list	(3000) ptr;

dcl	hash_table	(0:210) fixed bin (18);

dcl	next_offset	fixed bin (18);
dcl	starting_wd_off	fixed bin;
dcl	token_count	fixed bin;
dcl	(i, j)		fixed bin;
dcl	name_length	fixed bin (9);
dcl	token_size	fixed bin (18);
dcl	symbol_size	fixed bin;
dcl	name_off		fixed bin (18);
dcl	segname_off	fixed bin (18);
dcl	sbh_off		fixed bin (18);
dcl	psb_off		fixed bin (18);
dcl	root_off		fixed bin (18);
dcl	main_off		fixed bin (18);
dcl	data_ptr_off	fixed bin (18);
dcl	p_off		fixed bin (18);
dcl	symb_off		fixed bin (18);
dcl	next_off		fixed bin (18);
dcl	sect_off		fixed bin (18);
dcl	prev_poff		fixed bin (18);
dcl	t_off		fixed bin;
dcl	prev_soff		fixed bin (18);
dcl	prev_toff		fixed bin;
dcl	first		fixed bin;
dcl	prev_level	fixed bin;
dcl	prev_line_num	fixed bin (14);
dcl	line_num		fixed bin (14);
dcl	file_num		fixed bin (8);
dcl	prev_file_num	fixed bin (8);
dcl	statement_no	fixed bin (5);
dcl	label_count	fixed bin;
dcl	tag_loc		fixed bin;
dcl	packed_dec_size	fixed bin;

dcl	first_symbol	bit (1) aligned;
dcl	translate_it	bit (1);
dcl	finished		bit (1);
dcl	name_string	char (32);

dcl	len		fixed bin based (len_ptr);
dcl	ident_sw		bit (1);
dcl	prev_ident_s	ptr;
dcl	charn		char (n) based;
dcl	bits		bit (3600) based;

dcl	1 name_table_entry	based,
	  2 size		fixed bin (15),
	  2 line		fixed bin (15),
	  2 column	fixed bin (15),
	  2 type		fixed bin (15);

dcl	1 map_data_table	aligned based (map_data_ptr),
	  2 no_source_stmts fixed bin aligned,
	  2 data		(0 refer (map_data_table.no_source_stmts)),
	    3 line_no	fixed bin unaligned,
	    3 text_addr	fixed bin unaligned,
	    3 col		fixed bin unaligned,
	    3 label	bit unaligned;

/*[4.2-1]*/
declare	1 DEF		aligned based (cobol_$tag_table_ptr),
						/*[4.2-1]*/
	  2 tag_max	fixed bin,		/*[4.2-1]*/
	  2 TAG		(32767),			/*[4.2-1]*/
	    3 tag_addr	fixed bin (17) unal,	/*[4.2-1]*/
	    3 tag_no	fixed bin (17) unal;

dcl	stmt_map_reloc_bits (4) bit (5) static aligned init ("10000"b, ""b, ""b, ""b);
dcl	simple_symbol	bit (36) static aligned init ("101010000000000000000000101000000000"b);

dcl	cobol_reloc	entry (ptr, fixed bin, fixed bin);
dcl	ioa_		entry options (variable);

dcl	addr		builtin;
dcl	addrel		builtin;
dcl	bit		builtin;
dcl	binary		builtin;
dcl	bool		builtin;
dcl	dim		builtin;
dcl	divide		builtin;
dcl	fixed		builtin;
dcl	index		builtin;
dcl	max		builtin;
dcl	mod		builtin;
dcl	null		builtin;
dcl	pointer		builtin;
dcl	rel		builtin;
dcl	string		builtin;
dcl	substr		builtin;
dcl	translate		builtin;
dcl	unspec		builtin;


%include runtime_symbol;
%include cobol_entry_seq;
%include statement_map;
%include cobol_eln_table;
%include cobol_;
%include cobol_fixed_common;
%include cobol_sbh;
%include pl1_symbol_block;
%include cobol_ext_;
%include cobol_type7;
%include cobol_type9;
%include cobol_type10;
%include cobol_occurs_ext;

     end cobol_mst;




		    cobol_multiply2_binary.pl1      05/24/89  1041.5rew 05/24/89  0834.8       78084



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_multiply2_binary.pl1 Added Trace statements.
                                                   END HISTORY COMMENTS */


/* Modified on 11/16/84 by FCH, [5.3...], trace added */
/* Modified on 10/19/84 by FCH, [4.3-1], BUG563(phx18381), new cobol_addr_tokens.incl.pl1 */
/* Modified on 01/17/77 by ORN to call cobol_make_reg_token instead of cobol_make_register_token */
/* Modified since Version 2.0 */





/*{*/
/* format: style3 */
cobol_multiply2_binary:
     proc (lop_token_ptr, rop_token_ptr, result_token_ptr, operation_code);
						/*
This procedure generates code to multiply or divide two fixed
binary data items in the hardware registers (A and Q).
*/

/*  DECLARATIONS OF THE PARAMETERS  */

dcl	lop_token_ptr	ptr;
dcl	rop_token_ptr	ptr;
dcl	result_token_ptr	ptr;
dcl	operation_code	fixed bin;

/*  DESCRIPTION OF THE PARAMETERS  */

/*
PARAMETER		DESCRIPTION

lop_token_ptr	Pointer to a token that describes the
		multiplicand (for multiplication) or the
		dividend (for division).  This token may
		be a data name token (type 9) , a numeric
		literal token (type 2) or a toekn for the
		reserved word  ZERO.  (input)
rop_token_ptr	Pointer to a token that describes the
		multiplier (for multiplication) or the
		divisor (for division).  This token may be
		a data name token (type 9), a numeric
		literal token (type 2), or a reserved
		word token (type 1) for the figurative
		constant ZERO.  (input)
result_token_ptr	Pointer to a register token (type  100) that
		describes the register containing the
		result of the computation.  (output)
operation_code	A code that identifies the operation for
		which code is to be generated.  This code is
		defined in the following table:
		code value	|  operation
		=========================================
		   1		|   multiplication
		   2		|   division
		========================================

*/

/*  DECLARATION OF EXTERNAL ENTRIES  */

dcl	cobol_register$load ext entry (ptr);
dcl	cobol_make_bin_const
			ext entry (ptr, ptr, fixed bin);
dcl	cobol_make_reg_token
			ext entry (ptr, bit (4));
dcl	cobol_load_register ext entry (ptr, ptr);
dcl	cobol_short_to_longbin$temp
			ext entry (ptr, ptr);
dcl	cobol_addr	ext entry (ptr, ptr, ptr);
dcl	cobol_emit	ext entry (ptr, ptr, fixed bin);

/*  Declaration of Internal Static Variables.  */

dcl	MPY		bit (10) int static init ("1000000100"b);
						/*  402(0)  */
dcl	DIV		bit (10) int static init ("1010001100"b);
						/*  506(0)  */

dcl	direct_lower_inst	bit (36) int static init ("000000000000000000000000000000000111"b);
						/*  zero,dl  */



dcl	1 dec_zero_token	int static,
	  2 size		fixed bin (15),
	  2 line		fixed bin (15),
	  2 column	fixed bin (15),
	  2 type		fixed bin (15) init (2),
	  2 integral	bit (1) init ("1"b),
	  2 floating	bit (1) bit (1) init ("0"b),
	  2 filler1	bit (5),
	  2 subscript	bit (1) init ("0"b),
	  2 sign		char (1) init (" "),
	  2 exp_sign	char (1) init (" "),
	  2 exp_places	fixed bin (15),
	  2 places_left	fixed bin (15) init (1),
	  2 places_right	fixed bin (15) init (0),
	  2 places	fixed bin (15) init (1),
	  2 literal	char (1) init ("0");

/*  DECLARATION OF INTERNAL VARIABLES  */


/*  DECLARATION OF INTERNAL VARIABLES  */

dcl	1 input_buff	aligned,
	  2 buff		(1:10) ptr;

dcl	1 inst_buff	aligned,
	  2 buff		(1:2) fixed bin;

dcl	1 reloc_buff	aligned,
	  2 buff		(1:10) bit (5) aligned;

dcl	dn_ptr		ptr;


dcl	1 register_struc,
	  2 what_reg	fixed bin,
	  2 reg_no	bit (4),
	  2 lock		fixed bin,
	  2 already_there	fixed bin,
	  2 contains	fixed bin,
	  2 tok_ptr	ptr,
	  2 literal	bit (36);


dcl	temp_ptr		ptr;
dcl	reg_temp		bit (4);


/**************************************************/
start:	/***.....	if Trace_Bit then call cobol_gen_driver_$Tr_Beg(cmb);/**/
	if lop_token_ptr -> data_name.type = rtc_resword
	then lop_token_ptr = addr (dec_zero_token);
	if rop_token_ptr -> data_name.type = rtc_resword	/*  Right operand token is fig const ZERO  */
	then rop_token_ptr = addr (dec_zero_token);

	if lop_token_ptr -> data_name.type = rtc_numlit
	then do;					/*  Left operand is a numeric literal  */
						/*  Make a binary constant for the numeric literal.  */
		temp_ptr = null ();
		call cobol_make_bin_const (lop_token_ptr, temp_ptr, 2);
		lop_token_ptr = temp_ptr;
	     end;					/*  Left operand is a numeric literal.  */

	if rop_token_ptr -> data_name.type = rtc_numlit
	then do;					/*  Right operand is a numeric literal.  */
						/*  Make a binary constant from the numeric literal token.  */
		temp_ptr = null ();
		call cobol_make_bin_const (rop_token_ptr, temp_ptr, 2);
		rop_token_ptr = temp_ptr;
	     end;					/*  Right operand is a numeric literal.  */

	if (rop_token_ptr -> data_name.type = rtc_dataname & rop_token_ptr -> data_name.bin_18)
	then do;					/*  Right operand is a short binary.  */
						/*  Convert from short to long binary into a temporary.  */
		temp_ptr = null ();
		call cobol_short_to_longbin$temp (rop_token_ptr, temp_ptr);
		rop_token_ptr = temp_ptr;
	     end;					/*  Right operand is a short binary.  */

/*  Make a register token that references the Q register.  */
	temp_ptr = null ();
	call cobol_make_reg_token (temp_ptr, "0010"b);	/*  Generate code to load the left operand into the Q register.  */
	call cobol_load_register (lop_token_ptr, temp_ptr);


	if rop_token_ptr -> data_name.type = rtc_dataname
	then do;					/*  Right operand is a data name.  */
						/*  Establish addressability to the data name.  */
		input_ptr = addr (input_buff);
		inst_ptr = addr (inst_buff);
		reloc_ptr = addr (reloc_buff);
		input_struc.type = 2;
		input_struc.operand_no = 1;
		input_struc.lock = 0;
		input_struc.operand.size_sw (1) = 0;
		input_struc.operand.token_ptr (1) = rop_token_ptr;
		call cobol_addr (input_ptr, inst_ptr, reloc_ptr);
	     end;					/*  Right operand is a data name.  */

	else do;					/*  Right operand is an immediate constant.  */
						/*  Insert the immediate value into the instruction.  */
		substr (direct_lower_inst, 1, 18) =
		     substr (unspec (rop_token_ptr -> immed_const.const_value), 19, 18);
		inst_ptr = addr (direct_lower_inst);
		reloc_ptr = null ();
	     end;					/*  Right operand is an immediate constant.  */

	if operation_code = 1
	then inst_struc_basic.fill1_op = MPY;
	else inst_struc_basic.fill1_op = DIV;

/*  Lock the A register, because multiplication or division uses the A for
	the computation.  */
	register_struc.what_reg = 1;			/*  A  */
	register_struc.lock = 1;
	register_struc.contains = 0;
	call cobol_register$load (addr (register_struc));

/*  Emit the MPY or DIV instruction.  */
	call cobol_emit (inst_ptr, reloc_ptr, 1);

/*  Make a register token that describes the result of the multiply or divide.  */
	if operation_code = 1			/*  MPY  */
	then reg_temp = "0011"b;			/*  Product of multiply is in A and Q  */
	else reg_temp = "0010"b;			/*  Quotient of divide is in Q. (remainder is in A )  */
	call cobol_make_reg_token (result_token_ptr, reg_temp);

	/***.....	if Trace_Bit then call cobol_gen_driver_$Tr_End(cmb);/**/

	return;

	/***.....	dcl cmb char(22) init("COBOL_MULTIPLY2_BINARY");/**/

	/***.....	dcl cobol_gen_driver_$Tr_Beg entry(char(*));/**/
	/***.....	dcl cobol_gen_driver_$Tr_End entry(char(*));/**/

	/***.....	dcl Trace_Bit bit(1) static external;/**/
	/***.....	dcl Trace_Lev fixed bin static external;/**/
	/***.....	dcl Trace_Line char(36) static external;/**/
	/***.....	dcl ioa_ entry options(variable); /**/


/*  INCLUDE FILES USED BY THIS PROCEDURE  */

/*****	Declaration for builtin function	*****/

dcl	(substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index)
			builtin;

/*****	End of declaration for builtin function	*****/

%include cobol_type9;
%include cobol_record_types;
%include cobol_addr_tokens;
%include cobol_type102;

     end cobol_multiply2_binary;




		    cobol_multiply_bin_gen.pl1      05/24/89  1041.5rew 05/24/89  0834.8      156249



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_multiply_bin_gen.pl1 Added Trace statements.
                                                   END HISTORY COMMENTS */


/* Modified on 11/22/84 by FCH, [5.3...], trace added */
/* Modified on 10/19/84 by FCH, [4.3-1],  BUG563(phx18381), new cobol_addr_tokens.incl.pl1 */
/* Modified on 06/29/79 by FCH, [4.0-1], not option added for debug */
/* Modified since Version 4.0 */

/*{*/
/* format: style3 */
cobol_multiply_bin_gen:
     proc (in_token_ptr, next_stmt_tag);

/*
This procedure generates code for the multiply statement
which uses the hardware registers ( A and Q ) instead
of using EIS instructions.  */

/*  DECLARATION OF THE PARAMETERS  */

/* dcl in_token_ptr ptr;  */
/*  Declared below in an include file.  */
dcl	next_stmt_tag	fixed bin;

/*  DESCRIPTION OF THE PARAMETERS  */

/*
PARAMETER		DESCRIPTION

in_token_ptr	Pointer to a structurre that contains data
		and pointers that describes the multiply
		statement for which code is to be
		implemented.  (input)  See description
		below for more details.
next_stmt_tag	A tag that is to be defined at the next
		cobol statement by cobol_gen_driver_.
		(output)  See below for details.
*/


/*  DECLARATION OF EXTERNAL ENTRIES  */

dcl	cobol_short_to_longbin$temp
			ext entry (ptr, ptr);
dcl	cobol_alloc$stack	ext entry (fixed bin, fixed bin, fixed bin (24));
dcl	cobol_make_type9$long_bin
			ext entry (ptr, fixed bin, fixed bin (24));
dcl	cobol_store_binary	ext entry (ptr, ptr, bit (1));
dcl	cobol_register$release
			ext entry (ptr);
dcl	cobol_addr	ext entry (ptr, ptr, ptr);
dcl	cobol_emit	ext entry (ptr, ptr, fixed bin);
dcl	cobol_fofl_mask$on	ext entry;
dcl	cobol_fofl_mask$off ext entry;
dcl	cobol_multiply2_binary
			ext entry (ptr, ptr, ptr, fixed bin);
dcl	cobol_make_tagref	ext entry (fixed bin, fixed bin, ptr);
dcl	cobol_define_tag	ext entry (fixed bin);
dcl	cobol_register$load ext entry (ptr);

/*  DECLARATION OF INTERNAL STATIC DATA  */

dcl	STZ		bit (10) int static init ("1001010000"b);
						/*  450(0)  */
dcl	AOS		bit (10) int static init ("0001011000"b);
						/*  054(0)  */
dcl	LDA		bit (10) int static init ("0100111010"b);
						/*  235(0)  */
dcl	LDQ		bit (10) int static init ("0100111100"b);
						/*  236	(0)  */

dcl	tov_inst		bit (36) int static init ("000000000000000000110001111000000000"b);
	;					/*  tov 0  */

dcl	tra_inst		bit (36) int static init ("000000000000000000111001000000000000"b);
						/*  tra 0  */

dcl	tnz_inst		bit (36) int static init ("000000000000000000110000001000000000"b);
						/*  tnz 0  */


dcl	1 dec_zero_token	int static,
	  2 size		fixed bin (15),
	  2 line		fixed bin (15),
	  2 column	fixed bin (15),
	  2 type		fixed bin (15) init (2),
	  2 integral	bit (1) init ("1"b),
	  2 floating	bit (1) bit (1) init ("0"b),
	  2 filler1	bit (5),
	  2 subscript	bit (1) init ("0"b),
	  2 sign		char (1) init (" "),
	  2 exp_sign	char (1) init (" "),
	  2 exp_places	fixed bin (15),
	  2 places_left	fixed bin (15) init (1),
	  2 places_right	fixed bin (15) init (0),
	  2 places	fixed bin (15) init (1),
	  2 literal	char (1) init ("0");

/*  DECLARATION OF INTERNAL VARIABLES  */

dcl	1 input_buff,
	  2 buff		(1:10) fixed bin;

dcl	1 reloc_buff,
	  2 buff		(1:10) bit (5) aligned;



dcl	1 register_struc,
	  2 what_reg	fixed bin,
	  2 reg_no	bit (4),
	  2 lock		fixed bin,
	  2 already_there	fixed bin,
	  2 contains	fixed bin,
	  2 tok_ptr	ptr,
	  2 literal	bit (36);
dcl	result_token_ptr	ptr;
dcl	work_token_ptr	ptr;
dcl	addend_token_ptr	ptr;
dcl	receive_count	fixed bin;
dcl	ret_offset	fixed bin (24);
dcl	ovflo_flag_inst	bit (36);
dcl	ovflo_tag		fixed bin;
dcl	no_ovflo_tag	fixed bin;
dcl	imperative_stmt_tag fixed bin;
dcl	ix		fixed bin;
dcl	temp_target_code	fixed bin;
dcl	multiplier_token_ptr
			ptr;
dcl	multiplicand_token_ptr
			ptr;
dcl	remainder_token_ptr ptr;
dcl	ose_flag		bit (1);
dcl	tlength		fixed bin;
dcl	temp_ptr		ptr;
dcl	skipped_some	bit (1);
dcl	temp_lop_token_ptr	ptr;
dcl	temp_rop_token_ptr	ptr;


dcl	call_again	bit (1);


dcl	dn_ptr		ptr;


/*************************************/
start:	/***.....	if Trace_Bit then call cobol_gen_driver_$Tr_Beg(cmbg);/**/
						/*  Extract useful information from the EOS token.  */
	eos_ptr = in_token.token_ptr (in_token.n);
	ose_flag = end_stmt.b;

	if ose_flag
	then do;					/*  Reserve two tags for on size error processing.  */
		imperative_stmt_tag = cobol_$next_tag;
		next_stmt_tag = imperative_stmt_tag + 1;
		cobol_$next_tag = cobol_$next_tag + 2;
	     end;					/*  Reserve two tags for on size error processing.  */
	result_token_ptr = null ();

	if end_stmt.a = "000"b
	then call format1_multiply;
	else call format2_multiply;

	/***.....	if Trace_Bit then call cobol_gen_driver_$Tr_End(cmbg);/**/

	return;


/*************************************/
format1_multiply:
     proc;

	/***.....	if Trace_Bit then call ioa_("^a^a",substr(Trace_Line,Trace_Lev+1,1),"FORMAT1_MULTIPLY");/**/

/*
This internal procedure generates code using the hardware
registers ( A and Q ) for format 1 multiply statements.  */

	receive_count = end_stmt.e;
	multiplier_token_ptr = in_token.token_ptr (2);


	if (multiplier_token_ptr -> data_name.type = rtc_dataname & receive_count > 1)
	then do;					/*  Divisor is long binary, and more than one multiplynd/receiving field.  */
						/*  Generate code to store the multiplier into a temp, because if one of
		the multiplynds is the multiplier (i.e. MULTIPLY A BY A B C) then the original
		multiplier value will be destroyed.  */

/*  Allocate space for the temporary in the stack.  */
		call cobol_alloc$stack (4, 0, ret_offset);
		temp_ptr = null ();			/*  Make a data name token for the temp.  */
		call cobol_make_type9$long_bin (temp_ptr, 1000, ret_offset);
						/*  Store the multiplier into the temporary.  */
		call cobol_store_binary (multiplier_token_ptr, temp_ptr, call_again);
						/*  Release the register that was used in storing the multiplier.  */
		register_struc.reg_no = multiplier_token_ptr -> cobol_type100.register;
		call cobol_register$release (addr (register_struc));
		multiplier_token_ptr = temp_ptr;
	     end;					/*  Divisor is long binary, and move than one multiplynd/receiving field.  */

	if ose_flag
	then do;					/*  On size error clause was present.  */
		if receive_count > 1
		then do;				/*  Multiple multiplynd/receiving fields.  */
						/*  Allocate space on the stack for an overflow flag,
			and emit code to initialize it to zero.  */
			call cobol_alloc$stack (4, 0, ret_offset);

			input_ptr = addr (input_buff);
			reloc_ptr = addr (reloc_buff);
			inst_ptr = addr (ovflo_flag_inst);

			input_struc_basic.type = 1;
			input_struc_basic.operand_no = 0;
			input_struc_basic.lock = 0;
			input_struc_basic.segno = 1000;
						/*  stack  */
			input_struc_basic.char_offset = ret_offset;

			call cobol_addr (input_ptr, inst_ptr, reloc_ptr);
			inst_struc_basic.fill1_op = STZ;
			call cobol_emit (inst_ptr, reloc_ptr, 1);

/*  Define some tags to be used in the overflow testing  */
			ovflo_tag = cobol_$next_tag;
			no_ovflo_tag = ovflo_tag + 1;
			cobol_$next_tag = cobol_$next_tag + 2;

		     end;				/*  Multiple multiplynd/receiving fields.  */

		else ovflo_tag = imperative_stmt_tag;


/*  Generate code to turn on the fixed overflow mask in the indicator register.  */
		call cobol_fofl_mask$on;
	     end;					/*  On size error clause was present.  */


/*  Generate code to multiply the multiplier into each multiplynd/receiving field.  */
	do ix = 3 to in_token.n - 1;			/*  Do all the multiplys.  */

	     call cobol_multiply2_binary (in_token.token_ptr (ix), multiplier_token_ptr, result_token_ptr, 1);


	     call cobol_store_binary (result_token_ptr, in_token.token_ptr (ix), call_again);
	     if call_again
	     then do;				/*  Must call the store procedure again to get the results stored.  */
		     if ose_flag
		     then do;			/*  Must test for overflow again.  */
			     call cobol_emit (addr (tov_inst), null (), 1);
			     call cobol_make_tagref (ovflo_tag, cobol_$text_wd_off - 1, null ());
			end;			/*  Must test for overflow again.  */


		     call cobol_store_binary (result_token_ptr, in_token.token_ptr (ix), call_again);
		end;				/*  Must call the store procedure again to get the results stored.  */
	     if result_token_ptr -> data_name.type = rtc_register
	     then do;				/*  Release the register containing the result just stored.  */
		     register_struc.reg_no = result_token_ptr -> cobol_type100.register;
		     call cobol_register$release (addr (register_struc));
		end;				/*  Release the register containing the result just stored.  */

	     if ose_flag & receive_count ^= 1
	     then do;				/*  On size error and multiple multiplynds.  */
						/*  Emit code to transfer to the next multiply sequence.  */
		     call cobol_emit (addr (tra_inst), null (), 1);
		     call cobol_make_tagref (no_ovflo_tag, cobol_$text_wd_off - 1, null ());

/*  Define the ovflo_tag at the next instructiin location.  */
		     call cobol_define_tag (ovflo_tag); /*  Emit code to increment the overflow flag.  */
		     inst_struc_basic.fill1_op = AOS;
		     call cobol_emit (inst_ptr, reloc_ptr, 1);

/*  Define the no_ovflo_tag at the next instruction location.  */
		     call cobol_define_tag (no_ovflo_tag);


		     if ix ^= in_token.n - 1
		     then do;			/*  Not the last multiply, define new ovflo and no_ovflo tags.  */
			     ovflo_tag = cobol_$next_tag;
			     no_ovflo_tag = ovflo_tag + 1;
			     cobol_$next_tag = cobol_$next_tag + 2;
			end;			/*  Not the last multiply, define new ovflo, no_ovflo tags  */

		end;				/*  On size error and multiple multiplynds.  */

	end;					/*  Do all the multiplys.  */

	if ose_flag
	then do;					/*  On size error clause was present.  */

/*  Generate code to turn off the fixed overflow mask in the indicator registers.  */
		call cobol_fofl_mask$off;
		if receive_count > 1
		then do;				/*  More that one multiplynd/receiving field.  */
						/*  Generate code to load the overflow flag, and test it for zero.  */
			register_struc.what_reg = 4;	/*  A or Q  */
			register_struc.lock = 0;
			register_struc.contains = 0;
			call cobol_register$load (addr (register_struc));

			if register_struc.reg_no = "0001"b
			then inst_struc_basic.fill1_op = LDA;
			else inst_struc_basic.fill1_op = LDQ;
			call cobol_emit (inst_ptr, reloc_ptr, 1);

/*  Generate code to test for non-zero, and transfer to the imperative statement tag
				if not zero.  */
			call cobol_emit (addr (tnz_inst), null (), 1);
			call cobol_make_tagref (imperative_stmt_tag, cobol_$text_wd_off - 1, null ());

		     end;				/*  More than one multiplynd/receiving field.  */

/*[4.0-1*/
		if end_stmt.f = "01"b		/*[4.0-1*/
		then next_stmt_tag = imperative_stmt_tag;
						/*[4.0-1*/
		else do;

/*  Generate code to transfer to the next cobol statement ( the one
			following the imperative statement. )  */
			call cobol_emit (addr (tra_inst), null (), 1);
			call cobol_make_tagref (next_stmt_tag, cobol_$text_wd_off - 1, null ());

/*  Define the imperative statement tag at the next instruction location.  */
			call cobol_define_tag (imperative_stmt_tag);

/*[4.0-1*/
		     end;

	     end;					/*  On size error clause was present.  */

     end format1_multiply;


/*************************************/
format2_multiply:
     proc;

	/***.....	if Trace_Bit then call ioa_("^a^a",substr(Trace_Line,Trace_Lev+1,1),"FORMAT2_MULTIPLY");/**/

/*
This internal procedure generates code using the hardware
registers (A and Q) for format 2,3,4, and 5 multiply statements.  */
	multiplicand_token_ptr = in_token.token_ptr (2);
	multiplier_token_ptr = in_token.token_ptr (3);


/*  Generate code to do the division.  */
	call cobol_multiply2_binary (multiplicand_token_ptr, multiplier_token_ptr, result_token_ptr, 1 /*multiply */);


/*  Generate code to store the product into all long binary receiving fields.  */
/*  Note that there is no possibliity of overflow, since result is long binary, and so are targets.  */
	skipped_some = "0"b;
	if ose_flag
	then call cobol_fofl_mask$on;			/*  Generate code to turn on the fixed overflow
		mask bit in the indicator register.  */

	do ix = 4 to in_token.n - 1;			/*  Store product into all long binary targets.  */

	     if in_token.token_ptr (ix) -> data_name.bin_18
	     then skipped_some = "1"b;
	     else do;				/*  Long binary target.  */
		     call cobol_store_binary (result_token_ptr, in_token.token_ptr (ix), call_again);
		     if call_again
		     then do;			/*  REsult has been moved to a temp in an attempt to force
			overflow.  */

			     if ose_flag
			     then do;		/*  On size error clause present.  */
						/*  Must test for overflow.  */
				     call cobol_emit (addr (tov_inst), null (), 1);
				     call cobol_make_tagref (imperative_stmt_tag, cobol_$text_wd_off - 1, null ())
					;
				end;		/*  On size error clause present.  */

/*  Generate code to store the temp into the target.  */
			     call cobol_store_binary (result_token_ptr, in_token.token_ptr (ix), call_again);
			end;			/*  Result has been moved to a temp in an attempt to force
				overflow.  */
		end;				/*  Long binary target.  */
	end;					/*  Store product into all long binary targets.  */



	if skipped_some
	then do;					/*  Store the product into all short binary receiving fields.  */

		do ix = 4 to in_token.n - 1;		/*  Scan the targets.  */

		     if in_token.token_ptr (ix) -> data_name.bin_18
		     then do;			/*  Short binary target.  */
			     call cobol_store_binary (result_token_ptr, in_token.token_ptr (ix), call_again);
			     if call_again
			     then do;		/*  REsult has been moved to a temp in an attempt to force
				overflow.  */

				     if ose_flag
				     then do;	/*  On size error clause present.  */
						/*  Must test for overflow.  */
					     call cobol_emit (addr (tov_inst), null (), 1);
					     call cobol_make_tagref (imperative_stmt_tag,
						cobol_$text_wd_off - 1, null ());
					end;	/*  On size error clause present.  */

/*  Generate code to store the temp into the target.  */
				     call cobol_store_binary (result_token_ptr, in_token.token_ptr (ix),
					call_again);
				end;		/*  Result has been moved to a temp in an attempt to force
					overflow.  */

			end;			/*  Short binary target.  */
		end;				/*  Scan the targets.  */

	     end;					/*  Store the product into all short binary receiving fields.  */


	if ose_flag
	then do;					/*  On size error clause was present.  */
						/*  Generate code to turn off the fixed overflow mask bit.  */
		call cobol_fofl_mask$off;

/*[4.0-1*/
		if end_stmt.f = "01"b		/*[4.0-1*/
		then next_stmt_tag = imperative_stmt_tag;
						/*[4.0-1*/
		else do;

/*  Emit code to transfer to the next cobol statement.  (The statement
		following the imperative statement.)  */
			call cobol_emit (addr (tra_inst), null (), 1);
			call cobol_make_tagref (next_stmt_tag, cobol_$text_wd_off - 1, null ());
						/*  Define the imperative statement tag at the next instruction location.  */
			call cobol_define_tag (imperative_stmt_tag);

/*[4.0-1*/
		     end;

/*  Generate code to turn off the fixed overflow mask bit  */
		call cobol_fofl_mask$off;
	     end;					/*  On size error clause was present.  */

	if result_token_ptr -> data_name.type = rtc_register
	then do;					/*  Result token describes a register.  */
						/*  Release the register, since the value there has been stored into all receiving fields. */
		register_struc.reg_no = result_token_ptr -> cobol_type100.register;
		call cobol_register$release (addr (register_struc));
	     end;					/*  Result token describes a register.  */

     end format2_multiply;

	/***.....	dcl cmbg char(22) init("COBOL_MULTIPLY_BIN_GEN");/**/

	/***.....	dcl cobol_gen_driver_$Tr_Beg entry(char(*));/**/
	/***.....	dcl cobol_gen_driver_$Tr_End entry(char(*));/**/

	/***.....	dcl Trace_Bit bit(1) static external;/**/
	/***.....	dcl Trace_Lev fixed bin static external;/**/
	/***.....	dcl Trace_Line char(36) static external;/**/
	/***.....	dcl ioa_ entry options(variable); /**/


/*  INCLUDE FILES USED IN THIS PROCEDURE  */


/*****	Declaration for builtin function	*****/

dcl	(substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index)
			builtin;

/*****	End of declaration for builtin function	*****/

%include cobol_type9;
%include cobol_addr_tokens;
%include cobol_;
%include cobol_in_token;
%include cobol_record_types;
%include cobol_type100;
%include cobol_type19;

     end cobol_multiply_bin_gen;




		    cobol_multiply_gen.pl1          05/24/89  1041.5rew 05/24/89  0830.4      173133



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_multiply_gen.pl1 Added Trace statements.
                                                   END HISTORY COMMENTS */


/* Modified on 11/22/84 by FCH, [5.3...], trace added */
/* Modified on 10/19/84 by FCH, [4.3-1], BUG563(phx18381), new cobol_addr_tokens.incl.pl1 */
/* Modified on 04/18/80 by FCH, new include file cobol_arith_util, fix not option */
/* Modified on 06/28/79 by FCH, [4.0-1], not option added for debug */
/* Modified since Version 4.0 */

/* format: style3 */
cobol_multiply_gen:
     proc (in_token_ptr, next_stmt_tag);

/*
The MULTIPLY statement generator: cobol_multiply_gen

FUNCTION

The function of this procedure is to generate code for the
Cobol MULTIPLY statement.

*/

/*  DECLARATION OF THE PARAMETERS  */

/* dcl in_token_ptr ptr;  */
/*  DECLARED BELOW IN AN INCLUDE FILE  */
dcl	next_stmt_tag	fixed bin;


/*  DESCRIPTION OF THE PARAMETERS  */
/*

PARAMETER		DESCRIPTION

in_token_ptr	Points to the in_token structure, which
		contains information describing the MULTIPLY
		statement for which code is to be
		generated. (input)  See the description
		below under INPUT for the exact contents of
		the input structure.
		NOTE: This parameter is declared in an include
		file following the executable statements
		of this procedure.
next_stmt_tag	Contains a compiler generated tag number
		(label) to be associated by the code
		generator driver with the Cobol statement
		that follows the MULTIPLY statement for which this
		procedure was called.  (output)  See
		the discussion below under OUTPUT
		for more details.
*/
/*

INPUT

The input to this procedure is a structure, which is defined by a
declaration of the following format:

dcl	1 in_token based (in_token_ptr),
		2 n fixed bin,
		2 code fixed bin
		2 token_ptr ( 0 refer (in_token.n)) ptr;

	where:

	in_token.n contains the number of entries in the
	token_ptr array.

	token_ptr(1) contains a pointer to a reserved word token
	(type 1) for the reserved word MULTIPLY.  This pointer is
	not used by this procedure.

	token_ptr(n) contains a pointer to an EOS (type 19) token.
	A declaration that describes the contents of the EOS
	token is given following the executable statements
	of this procedure in an include file.  The type 19
	token contains the following information that is
	used by this procedure.

		1. end_stmt.verb contains the code for the
		reserved word MULTIPLY.
		2. end_stmt.a defines the format of the MULTIPLY
		statement:

		value of end_stmt.a	| Mpy stmt format
		----------------------------------------
		  "000"b		| format 1
		  "001"b		| format 2

		3. end_stmt.b is "1"b if this MULTIPLY statement
		had an ON SIZE ERROR clause
		4. end_stmt.e contains the count of the
		number of operands to the RIGHT of "BY" for
		format 1 MULTIPLY statements.
		5, end_stmt.h contians the count of the number
		of operands to the RIGHT of "GIVING" for 
		format 2 MULTIPLY statements.

	token_ptr(2) through token_ptr(n-1) point to tokens
	that describe:

		1. the data items to be multiplied together.
		These tokens can be data name (type 9) tokens
		numeric literal (type 2) tokens.
		2. the data items to receive the result of
		the multiplication.  These tokens are always data
		name (type 9) tokens.


OUTPUT

The second parameter passed to cobol_multiply_gen is an output parameter.
A value is returned to the calling procedure, cobol_gen_driver_,
only for those multiply staatments that have  on size error clauses.
If an on size error clause is specified, then, in addition to
the code that evaluates the product, and assigns it to the receiving
data items, cobol_multiply_gen must also generate code that checks for
size error conditions.  If a size error is detected by the execution
of the generated code, then the imperative statement in the MULTIPLY
statment is executed, otherwise the imperative statement is
skipped.  The cobol_multiply_gen generator, however, when generating
code to skip over the imperative statement to the next statement,
does not know anything about the next statement.  This situation
is handled as follows:

	1. cobol_multiply_gen reserves a tag for the next COBOL
	statement.
	2. any transfers to the next statement reference the
	tag reserved by cobol_multiply_gen.  This tag is not yet
	defined. (associated with an instruction location in
	the text segment)
	3. after generation of code for an multiply statement is
	completed, cobol_multiply_gen passes the next statement tag
	back to its caller, cobol_gen_driver_, in the second
	parameter.
	4. when cobol_gen_driver_ detects the end of the imperative
	statement, the tag, reserved by cobol_multiply_gen, is
	defined.
*/

/*  DECLARATION OF EXTERNAL ENTRIES  */

dcl	cobol_binary_check$multiply
			ext entry (ptr, bit (1), fixed bin, fixed bin);
dcl	cobol_multiply_bin_gen
			ext entry (ptr, fixed bin);
dcl	cobol_num_to_udts	ext entry (ptr, ptr);
dcl	cobol_fofl_mask$on	ext entry;
dcl	cobol_fofl_mask$off ext entry;
dcl	cobol_build_resop	ext entry (ptr, ptr, fixed bin, ptr, bit (1), fixed bin, bit (1));
dcl	cobol_mpy3	ext entry (ptr, ptr, ptr, fixed bin);
dcl	cobol_mpy		ext entry (ptr, ptr, fixed bin);
dcl	cobol_define_tag	ext entry (fixed bin);
dcl	cobol_alloc$stack	ext entry (fixed bin, fixed bin, fixed bin);
dcl	cobol_addr	ext entry (ptr, ptr, ptr);
dcl	cobol_emit	ext entry (ptr, ptr, fixed bin);
dcl	cobol_arith_move_gen
			ext entry (ptr);
dcl	cobol_move_gen	ext entry (ptr);
dcl	cobol_make_type9$copy
			ext entry (ptr, ptr);
dcl	cobol_make_tagref	ext entry (fixed bin, fixed bin, ptr);
dcl	cobol_register$load ext entry (ptr);
dcl	cobol_make_type9$fixed_bin_35
			ext entry (ptr, fixed bin, fixed bin);
dcl	cobol_make_type9$type2_3
			ext entry (ptr, ptr);



/*  DECLARATIONS OF BUILTIN FUNCTIONS  */

dcl	addr		builtin;
dcl	fixed		builtin;
dcl	null		builtin;

/*  DECLARATION OF INTERNAL STATIC VARIABLES  */

dcl	first_ix		fixed bin int static init (2);

dcl	mpy_code		fixed bin int static init (184);

/*  Definition of an internal static buffer in which an EOS token is built for calls to the MOVE gen.  */

dcl	move_eos_buffer	(1:10) ptr int static;

/*  Definition of an internal static buffer in which an in_token is built for calls to the MOVE gen.  */

dcl	move_in_token_buffer
			(1:10) ptr int static;

dcl	move_data_init	fixed bin int static init (0);



/*  Definition of a numeric literal zero  */

dcl	1 num_lit_zero	int static,
	  2 size		fixed bin (15) init (37),
	  2 line		fixed bin (15) init (0),
	  2 column	fixed bin (15) init (0),
	  2 type		fixed bin (15) init (2),
	  2 integral	bit (1) init ("1"b),
	  2 floating	bit (1) init ("0"b),
	  2 filler1	bit (5) init ("0"b),
	  2 subscript	bit (1) init ("0"b),
	  2 sign		char (1) init (" "),
	  2 exp_sign	char (1) init (" "),
	  2 exp_places	fixed bin (15) init (0),
	  2 places_left	fixed bin (15) init (1),
	  2 places_right	fixed bin (15) init (0),
	  2 places	fixed bin (15) init (1),
	  2 lit_val	char (1) init ("0");


/*  DECLARATION OF INTERNAL AUTOMATIC VARIABLES  */

dcl	ose_flag		bit (1);
dcl	receive_count	fixed bin;

dcl	fmt1		bit (1);



dcl	ix		fixed bin;
dcl	iy		fixed bin;
dcl	move_eos_ptr	ptr;
dcl	move_in_token_ptr	ptr;
dcl	multiplicand_ptr	ptr;
dcl	multiplier_ptr	ptr;
dcl	resultant_operand_ptr
			ptr;
dcl	saved_ptr		ptr;

dcl	rdmax_value	fixed bin;
dcl	overflow_code_generated
			bit (1);
dcl	possible_ovfl_flag	bit (1);
dcl	receiving_is_not_stored
			bit (1);
dcl	size_error_inst	bit (36);
dcl	size_error_inst_ptr ptr;
dcl	size_error_token_ptr
			ptr;
dcl	stored_token_ptr	ptr;
dcl	no_overflow_tag	fixed bin;
dcl	op1_token_ptr	ptr;
dcl	op2_token_ptr	ptr;
dcl	temp_resultant_operand_ptr
			ptr;
dcl	(binary_ok, not_bit)
			bit (1);
dcl	source_code	fixed bin;
dcl	target_code	fixed bin;

dcl	dn_ptr		ptr;

/**************************************************/
start:	/***.....	if Trace_Bit then call cobol_gen_driver_$Tr_Beg(cmg);/**/
						/*  Check to see if binary arithmetic (using A and Q registers) can be done.  */
	call cobol_binary_check$multiply (in_token_ptr, binary_ok, target_code, source_code);
	if binary_ok
	then do;					/*  Binary arithmetic can be done.  */
		call cobol_multiply_bin_gen (in_token_ptr, next_stmt_tag);
		return;
	     end;					/*  Binary arithmetic can be done.  */


	move_in_token_ptr = null ();

/*   Get meaningful data from the EOS token.  */
	eos_ptr = in_token.token_ptr (in_token.n);

/*  ON SIZE ERROR flag  */
	ose_flag = end_stmt.b;

/*  Determine the number of receiving operands.  */
	if end_stmt.a = "000"b
	then do;					/*  format 1 multiply.  */
		fmt1 = "1"b;
		receive_count = end_stmt.e;
		multiplicand_ptr = in_token.token_ptr (first_ix);

		if multiplicand_ptr -> data_name.type ^= rtc_dataname
		then do;				/*  Multiplicand not dataname,  must be numeric literal or ZERO.  */

			if multiplicand_ptr -> data_name.type = rtc_numlit
			then saved_ptr = multiplicand_ptr;
						/*  numeric literal  */
			else saved_ptr = addr (num_lit_zero);
						/*  Assume multiplicand is figurative constant ZERO.  */
			multiplicand_ptr = null ();	/*  Utility provides buffer for dataname token.  */

/*  Pool the literal and get a dataname token for it.  */
			call cobol_make_type9$type2_3 (multiplicand_ptr, saved_ptr);

		     end;				/*  Multiplicand not dataname, must be numeric literal or ZERO.  */
	     end;					/*  format 1 multiply  */


	else do;					/*  fmt 2 multiply  */
		fmt1 = "0"b;
		receive_count = end_stmt.h;
	     end;					/*  fmt 2 multiply  */

	if ose_flag				/*  On size error clause was present, do processing common to both format multiplies.  */
	then do;

/*  Reserve a tag to be associated (by the cobol generator driver) with the next
			cobol statement.  */
		next_stmt_tag = cobol_$next_tag;
		cobol_$next_tag = cobol_$next_tag + 1;


/*  Get a size error flag in the stack, and initialize it to zero.  */
		size_error_inst_ptr = addr (size_error_inst);
		call get_size_error_flag (size_error_token_ptr, size_error_inst_ptr);

	     end;					/*  On size error clause was present, do processing common to both format multiplies.  */

	if ^fmt1
	then do;					/*  FORMAT 2 multiply, multiply the first two operands and store the result in a temporary.  */

/*  Build a resultant operand for the product.  */
		multiplicand_ptr = in_token.token_ptr (first_ix);
		multiplier_ptr = in_token.token_ptr (first_ix + 1);

		call cobol_build_resop (multiplicand_ptr, multiplier_ptr, mpy_code, resultant_operand_ptr, "0"b,
		     rdmax_value, possible_ovfl_flag);

/*  Generate code to perform the multiplication.  */
		call cobol_mpy3 (multiplicand_ptr, multiplier_ptr, resultant_operand_ptr, 1 /*  MPY  */);

		move_in_token_ptr = addr (move_in_token_buffer (1));
		move_eos_ptr = addr (move_eos_buffer (1));

		if move_data_init ^= cobol_$compile_count
		then call init_move_data;
	     end;					/*  FORMAT2 multiply, multiply the first two operrands and store the result in a temp.  */


/*  Get subscript of pointer in the in_token array that points to first receiving field.  */

	iy = in_token.n - receive_count;

	do ix = 1 to receive_count;			/*  Generate code to get the prdouct into the receiving field(s).  */
	     receiving_is_not_stored = "0"b;		/*  Generate code to store the receiving field into a temporary, if the on size
		error flag is on, and the receiving field is NOT a numeric edited item.  */

	     if ose_flag
	     then if in_token.token_ptr (iy) -> data_name.numeric_edited /*  Receiving is numeric edited.  */
		     | (in_token.token_ptr (iy) -> data_name.display
		     & in_token.token_ptr (iy) -> data_name.item_signed
		     & in_token.token_ptr (iy) -> data_name.sign_separate = "0"b)
						/*  overpunch sign  */
		then receiving_is_not_stored = "1"b;
		else call receiving_field (in_token.token_ptr (iy), stored_token_ptr, 1);


/*  Generate code to turn the overflow mask indicator bit ON  */
	     if ose_flag
	     then call cobol_fofl_mask$on;

	     if fmt1				/*  Generate code to multiply the first operand by the receiving field value,
			and store the result into the receiving field.  */
	     then do;


		     move_in_token_ptr = null ();
		     if not_dec_operand (in_token.token_ptr (iy))
		     then do;			/*  The receiving operand is not decimal.  Must convert to decimal
			before performing the multiplication.  */

			     op1_token_ptr = multiplicand_ptr;
			     op2_token_ptr = in_token.token_ptr (iy);

/*  Convert the non-decimal operand(s) , and build a temporary
				into which to store the result of the computation.  */

			     call cobol_build_resop (op1_token_ptr, op2_token_ptr, mpy_code,
				temp_resultant_operand_ptr, "0"b, rdmax_value, possible_ovfl_flag);

/*  Generate code to multiply the two operands, and
				store the result into a temporary.  */
			     call cobol_mpy3 (op1_token_ptr, op2_token_ptr, temp_resultant_operand_ptr, 1);

/*  Generate code to move the result of the multiply to
				the receiving field.  */

			     move_in_token_ptr = addr (move_in_token_buffer (1));
			     move_eos_ptr = addr (move_eos_buffer (1));

			     if move_data_init ^= cobol_$compile_count
			     then call init_move_data;

			     move_in_token_ptr -> in_token.token_ptr (2) = temp_resultant_operand_ptr;
			     move_in_token_ptr -> in_token.token_ptr (3) = in_token.token_ptr (iy);

			     call cobol_arith_move_gen (move_in_token_ptr);
			     if move_in_token_ptr -> in_token.code ^= 0
			     then receiving_is_not_stored = "1"b;


			end;			/*  The receiving operand is not decimal.  Must convert
				to decimal before performing the multiply.  */

		     else do;			/*  Receiving operand is decimal.  */

			     if not_dec_operand (multiplicand_ptr)
			     then do;		/*  Left operand is not decimal--convert to decimal.  */
				     op1_token_ptr = multiplicand_ptr;
				     multiplicand_ptr = null ();
				     call cobol_num_to_udts (op1_token_ptr, multiplicand_ptr);


				end;		/*  Left operand is not decimal--convert to decimal.  */

			     call cobol_mpy (multiplicand_ptr, in_token.token_ptr (iy), 1);

			end;			/*  Receiving operand is decimal.  */

		end;				/*  Generate code to multiply the first operand by the receiving field value,
				and store the result into the recieving field.  */

	     else do;				/*  Generate code to move the product already calculated into the receiving field.  */

		     move_in_token_ptr -> in_token.token_ptr (move_in_token_ptr -> in_token.n - 2) =
			resultant_operand_ptr;
		     move_in_token_ptr -> in_token.token_ptr (move_in_token_ptr -> in_token.n - 1) =
			in_token.token_ptr (iy);

		     call cobol_arith_move_gen (move_in_token_ptr);
		     if move_in_token_ptr -> in_token.code ^= 0
		     then receiving_is_not_stored = "1"b;
		end;				/*  Generate code to move the product already calculated into the receiving
				fields.  */

	     if ose_flag
	     then do;				/*  Generate code to test for overflow resulting from the multiply/store
				or move.  */

/*  Reserve a tag to which to transfer if no overflow occurs.  */
		     no_overflow_tag = cobol_$next_tag;
		     cobol_$next_tag = cobol_$next_tag + 1;

/*  Generate code to test for overflow.  */
		     call test_for_overflow (no_overflow_tag, size_error_inst_ptr, move_in_token_ptr);

/*  Generate code to restore the stored value back into the receiving
					field.  */
/*  The value is restored only if the receiving field was not numeric edited.  If
			the receiving field was numeric edited, the result of the multiplication
			has been moved into a temporary, and
			the receiving field has not been modified at all.  */
		     if receiving_is_not_stored = "0"b
		     then call receiving_field (in_token.token_ptr (iy), stored_token_ptr, 2 /* RESTORE*/);

/*  Define the no_overflow_tag at the next instruction in the text segment.  */
		     call cobol_define_tag (no_overflow_tag);

/*  Generate code to turn the overflow mask indicator bit OFF  */
		     call cobol_fofl_mask$off;

		end;				/*  Generate code to test for overflow resulting from the multiply/store
				or move.  */
	     else if receiving_is_not_stored
	     then call cobol_move_gen (move_in_token_ptr);/*  Call cobol_move_gen to move the temp result
			into a numeric edited receiving field  */



/*  Increment the subscript to the next receiving field.  */
	     iy = iy + 1;

	end;					/*  Get the product into the receiving field(s).  */

	if ose_flag
	then do;					/*  Generate code that tests whether overflow occurred, and jumps over the
			imperative stmt if no overflow occurred.  */


/*[4.0-1]*/
		if end_stmt.f = "01"b
		then not_bit = "1"b;
		else not_bit = "0"b;
		call test_size_error (size_error_token_ptr, size_error_inst_ptr, next_stmt_tag, "1"b, not_bit);

	     end;					/*  Generate code that tests whether overflow occurred, and jumps over the
			imperative stmt if no overflow occurrred.  */

	/***.....	if Trace_Bit then call cobol_gen_driver_$Tr_End(cmg);/**/

	return;

/*************************************/
init_move_data:
     proc;

/*  This internal procedure initializes the input token
and EOS token used in calls to the cobol move generators.  */

/*  Initialize in_token structure and EOS token structure
	used in calls to the MOVE generator.  */

	saved_ptr = in_token_ptr;
	in_token_ptr = move_in_token_ptr;

	in_token.n = 4;
	in_token.code = 0;
	in_token.token_ptr (1) = null ();
	in_token.token_ptr (in_token.n) = move_eos_ptr;
	in_token_ptr = saved_ptr;

	saved_ptr = eos_ptr;
	eos_ptr = move_eos_ptr;

	end_stmt.verb = 18;				/*  MOVE  */
	end_stmt.e = 1;				/*  COUNT of the receiving fields  */
	end_stmt.type = rtc_eos;
	eos_ptr = saved_ptr;

	move_data_init = cobol_$compile_count;

     end init_move_data;

	/***.....	dcl cmg char(18) init("COBOL_MULTIPLY_GEN");/**/

	/***.....	dcl cobol_gen_driver_$Tr_Beg entry(char(*));/**/
	/***.....	dcl cobol_gen_driver_$Tr_End entry(char(*));/**/

	/***.....	dcl Trace_Bit bit(1) static external;/**/
	/***.....	dcl Trace_Lev fixed bin static external;/**/
	/***.....	dcl Trace_Line char(36) static external;/**/
	/***.....	dcl ioa_ entry options(variable); /**/




/**************************************************/
/*	INCLUDE FILES USED BY THIS PROCEDURE    */
/**************************************************/

%include cobol_arith_util;
%include cobol_type9;
%include cobol_in_token;
%include cobol_type19;
%include cobol_;
%include cobol_addr_tokens;
%include cobol_record_types;

     end cobol_multiply_gen;




		    cobol_num_to_udts.pl1           05/24/89  1041.5rew 05/24/89  0830.4       38052



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_num_to_udts.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/*{*/

/* format: style3 */
cobol_num_to_udts:
     proc (sf_ptr, rf_ptr);

/*
This procedure is called to generate code to convert any
numeric data item to an unpacked decimal, trailing separate
sign value.
*/

/*  DECLARATION OF THE PARAMETERS  */

dcl	sf_ptr		ptr;
dcl	rf_ptr		ptr;

/*  DESCRIPTION OF THE PARAMETERS  */

/*
PARAMETER		DESCRIPTION
sf_ptr		Pointer to the data name token for the
		variable to be converted .  (input)
rf_ptr		Pointer to a buffer in which the data name
		token for the unpacked decimal trailing
		separate sign variable is built by this
		procedure.  If rf_ptr is null() on input,
		then this procedure provides the buffer for
		the token.  (input)
*/

/*}*/

/*  DECLARATION OF INTERNAL VARIABLES  */



/*  DECLARATIONS OF EXTERNAL ENTRIES  */

dcl	cobol_move_gen	ext entry (ptr);
dcl	cobol_make_type9$decimal_9bit
			ext entry (ptr, fixed bin, fixed bin (24), fixed bin, fixed bin);
dcl	cobol_alloc$stack	ext entry (fixed bin, fixed bin, fixed bin);

/*  DECLARATIONS OF INTERNAL STATIC VARIABLES  */

/*  Definition of an EOS token used in calls to the MOVE genarator.  */

dcl	1 move_eos_token	int static,
	  2 size		fixed bin (15),
	  2 line		fixed bin (15),
	  2 column	fixed bin (15),
	  2 type		fixed bin (15),
	  2 verb		fixed bin (15) init (18),	/*  MOVE  */
	  2 e		fixed bin (15) init (1);	/*  One receiving field in the move  */

/*  DECLARATIONS OF INTERNAL VARIABLES  */

dcl	work_item_length	fixed bin;
dcl	dn_ptr		ptr;
dcl	ret_offset	fixed bin;
dcl	dum_buff		(1:10) ptr;


/**************************************************/
/*	START OF EXECUTION			*/
/*	external procedure cobol_num_to_udts	*/
/**************************************************/


	if sf_ptr -> data_name.bin_18
	then work_item_length = 7;
	else if sf_ptr -> data_name.bin_36
	then work_item_length = 12;
	else work_item_length = sf_ptr -> data_name.places_left + sf_ptr -> data_name.places_right + 1;
						/*  Add one for sign byte  */

/*  Allocate space on the stack to receive the unpacked decimal value.  */
	call cobol_alloc$stack (work_item_length, 0, ret_offset);

/*  Make a data name token for the decimal value just allocated on the stack.  */
	call cobol_make_type9$decimal_9bit (rf_ptr, 1000 /*STACK*/, fixed (ret_offset, 24),
	     fixed (sf_ptr -> data_name.places_left, 15), fixed (sf_ptr -> data_name.places_right, 15));

/*  Change the sign type in the token just built to trailing separate.  */
	rf_ptr -> data_name.sign_type = "011"b;

/*  Set up the input token for calling the move generator.  */
	in_token_ptr = addr (dum_buff);

	in_token.n = 4;
	in_token.code = 0;
	in_token.token_ptr (1) = null ();
	in_token.token_ptr (2) = sf_ptr;
	in_token.token_ptr (3) = rf_ptr;
	in_token.token_ptr (4) = addr (move_eos_token);

/*  Call the MOVE generator to generate code to move the data (and convert it to unpacked deciaml)  */

	call cobol_move_gen (in_token_ptr);


/*  INCLUDE FILES USED BY THIS PROCEDURE  */


/*****	Declaration for builtin function	*****/

dcl	(substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index)
			builtin;

/*****	End of declaration for builtin function	*****/

%include cobol_type9;


%include cobol_in_token;

     end cobol_num_to_udts;




		    cobol_opch_op_call.pl1          05/24/89  1041.5rew 05/24/89  0830.4      104598



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_opch_op_call.pl1 Added Trace statements.
                                                   END HISTORY COMMENTS */


/* Modified on 10/19/84 by FCH, [4.3-1], BUG563(phx18381), new cobol_addr_tokens.incl.pl1 */
/* Modified on 08/15/83 by FCH, [5.2 ...], trace added */
/* Renamed on 01/17/77 by ORN from cobol_opch_operator_call to cobol_opch_op_call */
/* Modified since Version 2.0 */

/*{*/
/* format: style3 */
cobol_opch_op_call:
     proc (sf_ptr, rf_ptr);

/*
This procedure generates code that "calls" the overpunch
conversion "cobol operator".  The "call" to the overpunch conversion
operator is effected by a tsp3 instruction.  Data is passed
to the conversion routine in hardware registers, and not in a
parameter list.  The data is passed as follows:

1. pr1 points to the target of the conversion.

2. pr2 points to the source of the conversion.

3. pr5 points to a block of work space, at the top of the
stack.  This work space must be aligned on a double word
boundary.

4. Q register contains the scale and precision of the source of
conversion.

	a. bits 0-17 of the Q register contains the scale.
	Scale is obtained from data_name.places_right of a
	data name token.

	b. Bits 18-36 of the Q contain precision.
	Precision is obtained from data_name.item_length of a
	data name token.

5. A register contains the scale and precision of the target
of conversion.  Bits 0-17 contain the scale,
bits 18-36 contain the precision.  Scale and precision are obtained
as for the source of conversion.

6. X7 contains a code that identifies the data type of the
source of conversion.  This code is defined in the following
table:

	x7 contents	| type of source
	__________________________________________
	     1		| overpunch,leading sign
	     2		| overpunch, trailing sign
	     3		| unpacked decimal, trailing sign

7. X6 contains a code that identifies the data type of the
target of conversion.  This code is the same as that described
above for X7.

8. pr3 is used to store the location to which the cobol
overpunch conversion operator is to reutrn.

*/

/*  DECLARATION OF THE PARAMETERS  */

dcl	sf_ptr		ptr;

dcl	rf_ptr		ptr;

/*  DESCRIPTION OF THE PARAMETERS>  */

/*
PARAMETER		DESCRIPTION

sf_ptr		Pointer to a data name token that describes
		the source of the conversion.  This token
		will ALWAYS describe  an unpacked
		decimal trailing sign data item, or an
		overpunch sign data item.

rf_ptr		Pointer to a data name token that describes
		the target of the conversion.  This token
		describes the same type of data items as
		sf_ptr.  (see above).  (input)

*/

/*  DECLARATION OF EXXTERNAL ENTRIES  */

dcl	cobol_register$load ext entry (ptr);
dcl	cobol_pointer_register$get
			ext entry (ptr);
dcl	cobol_set_pr	ext entry (ptr, ptr);
dcl	cobol_alloc$stack	ext entry (fixed bin, fixed bin, fixed bin);
dcl	cobol_emit	ext entry (ptr, ptr, fixed bin);
dcl	cobol_pool	ext entry (char (*), fixed bin, fixed bin (24));
dcl	cobol_make_link$type_4
			ext entry (fixed bin, char (*));
dcl	cobol_addr	ext entry (ptr, ptr, ptr);
dcl	cobol_reset_r$after_operator
			ext entry;
dcl	cobol_reg_manager$before_op
			entry (fixed bin);

/*}*/

/*  DECLARATIONS OF INTERNAL STATIC DATA  */

dcl	ldx7_inst		bit (36) int static init ("000000000000000000010010111000000011"b);
						/* ldx7  0,du  */

dcl	ldx6_inst		bit (36) int static init ("000000000000000000010010110000000011"b);
						/*  ldx6 0,du  */

dcl	ldq_inst		bit (36) int static init ("000000000000000000010011110000000000"b);
						/*  LDQ 0  */

dcl	lda_inst		bit (36) int static init ("000000000000000000010011101000000000"b);
						/*  LDA 0  */

dcl	tsp3_inst		bit (36) int static init ("000000000000000111010111011001000000"b);
						/* tsp3 pr0|7 */

dcl	epp5_inst		bit (36) int static init ("000000000000000000011111001101000000"b);
						/*  epp5  */
						/*  DECLARATION OF INTERNAL DATA  */

dcl	1 reg_load_struc,
	  2 what_reg	fixed bin,
	  2 reg_no	bit (4),
	  2 lock		fixed bin,
	  2 already_there	fixed bin,
	  2 contains	fixed bin,
	  2 wk_ptr	ptr,
	  2 literal	bit (36);

dcl	1 pointer_reg_struc,
	  2 what_pointer	fixed bin,
	  2 pointer_no	bit (3),
	  2 lock		fixed bin,
	  2 switch	fixed bin,
	  2 segno		fixed bin,
	  2 offset	fixed bin (24),
	  2 reset		fixed bin;


	/***.....	dcl cobol_gen_driver_$Tr_Beg entry(char(*));/**/
	/***.....	dcl cobol_gen_driver_$Tr_End entry(char(*));/**/

	/***.....	dcl Trace_Bit bit(1) static external;/**/
	/***.....	dcl Trace_Lev fixed bin static external;/**/
	/***.....	dcl Trace_Line char(36) static external;/**/
	/***.....	dcl ioa_ entry options(variable); /**/
	/***..... dcl MY_NAME char (18) int static init ("COBOL_OPCH_OP_CALL");/**/


dcl	precision_constant_ptr
			ptr;

dcl	1 precision	aligned,
	  2 scale		fixed bin (17) unaligned,
	  2 precision	fixed bin (17) unaligned;
dcl	precision_offset	fixed bin (24);
dcl	precision_char_constant
			char (4) based (precision_constant_ptr);

dcl	input_buffer	(1:10) ptr;
dcl	reloc_buffer	(1:10) bit (5);
dcl	inst_buffer	(1:10) ptr;

dcl	linkoff		fixed bin;

dcl	ret_offset	fixed bin;
dcl	tcode		fixed bin;

dcl	inst_word		(1:2) bit (36) init ("0"b, "0"b);



dcl	1 treloc_buffer	(1:2) aligned,
	  2 reloc1	bit (5) aligned,
	  2 reloc2	bit (5) aligned;

dcl	dn_ptr		ptr;


/**************************************************/
start:	/***.....	if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME);/**/
						/*  Store all locked registers, before generating any code to call the overpunch operator.  */
	call cobol_reg_manager$before_op (0);

	pointer_reg_struc.lock = 1;
	pointer_reg_struc.switch = 0;

/*  Load the pointer registers  */

/*  Load pr2 to point to the source of conversion.  */

	pointer_reg_struc.what_pointer = 2;
	call cobol_set_pr (addr (pointer_reg_struc), sf_ptr);

/*  Load pr1 to point to the target.  */

	pointer_reg_struc.what_pointer = 1;
	call cobol_set_pr (addr (pointer_reg_struc), rf_ptr);


/*  Allocate some work space on an even word boundary   */
	call cobol_alloc$stack (40, 2, ret_offset);


/*  First, must get and lock the index registers needed to pass data to the operator.  */
	reg_load_struc.lock = 1;			/*  lock it  */
	reg_load_struc.contains = 0;

/*  Get x6  */
	reg_load_struc.what_reg = 16;			/*  x6  */
	call cobol_register$load (addr (reg_load_struc));

/*  Get x7  */
	reg_load_struc.what_reg = 17;
	call cobol_register$load (addr (reg_load_struc));

/*  Load x7 with a code that identifies the source type  */
	if sf_ptr -> data_name.sign_type = "010"b	/*  leading, not separate  */
	then tcode = 1;
	else if sf_ptr -> data_name.sign_type = "001"b	/*  trailing, not separate  */
	then tcode = 2;
	else if (sf_ptr -> data_name.item_signed & sf_ptr -> data_name.sign_separate = "0"b)
	then tcode = 2;				/*  Default is trailing overpunch.  */
	else tcode = 3;				/*  ASSUME unpacked decimal, trailing sign  */

	inst_ptr = addr (ldx7_inst);
	inst_struc_basic.wd_offset = bit (fixed (tcode, 15));
	call cobol_emit (inst_ptr, null (), 1);

/*  Load x6 with a code that identifies the target of conversion.  */

	if rf_ptr -> data_name.sign_type = "010"b	/*  leading, not separate  */
	then tcode = 1;
	else if rf_ptr -> data_name.sign_type = "001"b	/*  trailing, not separate  */
	then tcode = 2;
	else if (rf_ptr -> data_name.item_signed & rf_ptr -> data_name.sign_separate = "0"b)
	then tcode = 2;				/*  Default is trailing overpunch.  */
	else tcode = 3;				/*  ASSUME unpacked, decimal, trailing sign  */

	inst_ptr = addr (ldx6_inst);
	inst_struc_basic.wd_offset = bit (fixed (tcode, 15));
	call cobol_emit (inst_ptr, null (), 1);

/*  Generate code to load the Q register with the scale and precision
	of the source of conversion.  */
/*  First, get and lock the A and Q registers.  */
	reg_load_struc.what_reg = 3;			/*  A and Q  */
	call cobol_register$load (addr (reg_load_struc));


	precision_constant_ptr = addr (precision.scale);
	precision.scale = sf_ptr -> data_name.places_right;

	precision.precision = sf_ptr -> data_name.item_length;

/*  Pool the constant that contains scale and precision.  */
	call cobol_pool (precision_char_constant, 0,	/*word boundary, return char offset */
	     precision_offset);

	input_ptr = addr (input_buffer (1));
	reloc_ptr = addr (reloc_buffer (1));
	inst_ptr = addr (ldq_inst);

/*  Set up the input structure to the addressability utility.  */
	input_struc_basic.type = 1;
	input_struc_basic.operand_no = 0;
	input_struc_basic.lock = 0;
	input_struc_basic.segno = 3000;		/*  constant section.  */
	input_struc_basic.char_offset = precision_offset;
	input_struc_basic.send_receive = 0;

/*  Get the address of the pooled constant.  */
	call cobol_addr (input_ptr, inst_ptr, reloc_ptr);

/*  Emit the LDQ instruction  */
	call cobol_emit (inst_ptr, null (), 1);

/*  Generate code to load the A register with the scale and precision of the target.  */

	precision.scale = rf_ptr -> data_name.places_right;
	precision.precision = rf_ptr -> data_name.item_length;

/*  Pool the constant  */
	call cobol_pool (precision_char_constant, 0, precision_offset);

	input_struc_basic.char_offset = precision_offset;

/*  Get the address of the constant to be loaded into the A register.  */
	inst_ptr = addr (lda_inst);
	call cobol_addr (input_ptr, inst_ptr, reloc_ptr);

/*  Emit the LDA instruction  */
	call cobol_emit (inst_ptr, null (), 1);		/*  Emit code to load pr5 with the address of the work space.  */

	substr (epp5_inst, 1, 3) = "110"b;		/* pr6 = stack  */
	substr (epp5_inst, 4, 15) = bit (fixed (ret_offset, 15), 15);
	call cobol_emit (addr (epp5_inst), null (), 1);

/*  NOTE  pr3 and pr5 are used here, even though they are always supposed to point at cobol data.
	However, these pointer registers are needed here to communicate with the cobol operator, and are loaded
	to values other than pointers to cobol data immediately prior to calling the overpunch operator, so
	no addressability to cobol data is lost.  Immediately upon returning from the operator, pointer
	registers 3,4, and 5 are reloaded to their expected values.  */


/*  Emit an instruction to transfer to the cobol overpunch operator  */
	call cobol_emit (addr (tsp3_inst), null (), 1);

/*  Reset all registers after the call to the cobol operator  */
	call cobol_reset_r$after_operator;

	/***.....	if Trace_Bit then call cobol_gen_driver_$Tr_End(MY_NAME);/**/



/**************************************************/
/*	INCLUDE FILES USED BY THIS PROCEDURE	*/
/**************************************************/


/*****	Declaration for builtin function	*****/

dcl	(substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index)
			builtin;

/*****	End of declaration for builtin function	*****/

%include cobol_type9;
%include cobol_addr_tokens;

     end cobol_opch_op_call;




		    cobol_open_gen.pl1              05/24/89  1041.5rew 05/24/89  0830.4      285345



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8091),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8091 cobol_open_gen.pl1 Stop VALUE OF FILE-ID and VALUE OF RETENTION
     from being ignored.
                                                   END HISTORY COMMENTS */


/* Modified on 12/10/84 by FCH, [5.3-1], BUG574(phx18559), VALUE OF FILE-ID and RETENTION */
/* Modified on 11/28/84 by FCH, [5.3...], trace added */
/* Modified on 10/28/82 by FCH, [5.1-1], length of attach options string incorrect, BUG544(phx12991) */
/* Modified on 09/30/80 by FCH, [4.4-1], density is 6250 supported, BUG447(TR7681) */
/* Modified on 09/08/79 by FCH, [4.0-2], implement apply attach-options are data-name */
/* Modified on 03/12/79 by FCH, [4.0-1], fix preattach for internal files */
/* Modified on 10/31/78 by witches and hobgoblins, [3.0-3], alt rec keys */
/* Modified on 12/15/77 by FCH, [3.0-2], ioa_ used in NUMS */
/* Modified on 12/13/77 by FCH, [3.0-1], org is ibm-(os,dos) implemented */
/* Modified since version 3.0 */




/* format: style3 */
cobol_open_gen:
     proc (mp_ptr);

dcl	mp_ptr		ptr;

dcl	1 mp		based (mp_ptr),
	  2 n		fixed bin,		/* always 3 */
	  2 pt1		ptr,			/* pts to type1 token for OPEN */
	  2 pt2		ptr,			/* pts to type12 token for the file */
	  2 pt3		ptr;			/* pts to type19 token */

dcl	1 args,
	  2 entryno	fixed bin,
	  2 arglist_off	fixed bin,
	  2 stacktemp_off	fixed bin,
	  2 n		fixed bin,
	  2 arg		(5),
	    3 pt		ptr,
	    3 type	fixed bin,
	    3 off1	fixed bin,
	    3 off2	fixed bin,
	    3 value	bit (18) unal,
	    3 indirecy	bit (1) unal,
	    3 overlay	bit (1) unal,
	    3 repeat_nogen	bit (1) unal;


dcl	1 mpout,
	  2 n		fixed bin,
	  2 pt1		ptr,
	  2 pt2		ptr,
	  2 pt3		ptr,
	  2 pt4		ptr;

dcl	file_key_desc	char (40) based;
dcl	atd_string	char (150) varying init ((150)" ");
dcl	buf_off		fixed bin;
dcl	ft_max_cra_size	fixed bin;
dcl	ft_work		char (6) init ((6)" ");
dcl	ft_format		char (4) var init (" fb ");
dcl	ft_protect	char (5) var init ((5)" ");
dcl	ft_retain		char (11) var init (" -ret none ");
dcl	ft_force		char (5) var init ((5)" ");
dcl	ft_output_mode	char (17) var init ((17)" ");
dcl	ft_density_num	fixed bin init (800);
dcl	ft_position_num	fixed bin init (1);
dcl	ft_block_num	fixed bin init (1);
dcl	ft_device_num	fixed bin init (1);
dcl	ft_extend		char (8) var init ((8)" ");
dcl	mcode_off		fixed bin static init (40);
dcl	good_tag		fixed bin;
dcl	iocb_tag		fixed bin;
dcl	attach_tag	fixed bin;
dcl	open_tag		fixed bin;
dcl	open_tag1		fixed bin;
dcl	open_tag2		fixed bin;
dcl	stream_tag	fixed bin;
dcl	ioname_off	fixed bin static init (46);
dcl	ubits_off		fixed bin static init (42);
dcl	uchars_off	fixed bin static init (44);
dcl	len_off		fixed bin static init (52);

/*[5.3-1]*/
dcl	ft_expire		char (9) var init ((9)" ");	/*[5.3-1]*/
dcl	handler		char (12) init ((12)" ");	/*[6.3-1]*/
dcl	om		char (6) var init ((6)" ");

dcl	argb		(5) bit (216) based (addr (args.arg (1)));
dcl	instr		(0:10000) bit (36) based (cobol_$text_base_ptr);
dcl	char4b		char (4) based;
dcl	char8b		char (8) based;

dcl	(extend_sw, alt_sw, alt_output)
			bit (1) aligned;

dcl	arg_ptr		ptr;
dcl	linage_ptr	ptr;
dcl	com2_ptr		ptr;
dcl	ioerror_ptr	ptr;
dcl	ft_ptr		ptr;
dcl	fkey_ptr		ptr;
dcl	basic_ptr		ptr;
dcl	name_ptr		ptr;
dcl	dn_ptr		ptr;

dcl	segname		char (36) init ("");
declare	append_size	fixed bin,
	append_string	char (16) var init ((16)" ");

dcl	namelen		fixed bin;
dcl	atd_len		fixed bin;
dcl	atd_off		fixed bin;
dcl	atd_charoff	fixed bin;
dcl	aloff		fixed bin;
dcl	buflen_off	fixed bin;
dcl	define_detach	fixed bin;
dcl	ioname_len	fixed bin;
dcl	cobol_mode	fixed bin;
dcl	multics_mode	fixed bin;
dcl	file_id		char (17) var init ((17)" ");
dcl	cata_name		char (200) var init ((200)" ");
dcl	key_sz		fixed bin;
dcl	temp		fixed bin;
dcl	utemp		fixed bin;
dcl	(i, typ)		fixed bin;

/*[5.3-1]*/
dcl	clock_		entry returns (fixed bin (71));
						/*[5.3-1]*/
dcl	date_time_	entry (fixed bin (71), char (*));

/*[5.3-1]*/
dcl	f_ifn		char (16) var;		/*[5.3-1]*/
dcl	f_nm		char (32) var;		/*[5.3-1]*/
dcl	fc_nm		char (30) var;		/*[5.3-1]*/
dcl	vf		char (12) init ("vfile_");	/*[5.3-1]*/
dcl	(cata_name_loc, atd_string_loc, append_string_loc)
			ptr;


/*************************************/
/* INITIALIZATION */

start:						/* set up  return tags. */
	/***.....	if Trace_Bit then call cobol_gen_driver_$Tr_Beg(cog);/**/
						/*[5.3-1]*/
	cata_name_loc = addr (cata_name);
	atd_string_loc = addr (atd_string);
	append_string_loc = addr (append_string);
	ioerror.retry_tag = cobol_$next_tag;
	ioerror.ns_tag = cobol_$next_tag + 1;
	good_tag = cobol_$next_tag + 2;
	iocb_tag = cobol_$next_tag + 3;
	attach_tag = cobol_$next_tag + 4;
	open_tag = cobol_$next_tag + 5;
	open_tag1 = cobol_$next_tag + 6;
	open_tag2 = cobol_$next_tag + 7;
	cobol_$next_tag = cobol_$next_tag + 8;		/* initialize ioerror structure for cobol_gen_ioerror. */
	ioerror_ptr = addr (ioerror);
	ioerror.cobol_code = 0;
	ioerror.type1_ptr = mp.pt1;
	ioerror.is_tag = 0;
	ioerror.mode = 0;
	basic_ptr, basic_arg.pt = addr (basic_struct);

	call cobol_read_ft (mp.pt2 -> fd_token.file_no, ft_ptr);

	basic_struct.seg = file_table.fsb.seg;
	basic_struct.offset = file_table.fsb.off;

	call cobol_iomode (ft_ptr, mp.pt3, cobol_mode, multics_mode, extend_sw);

	call cobol_alloc$stack (500, 2, aloff);		/* for both max arglist and atd */

	atd_off = aloff;
	atd_len = 0;
	ioname_off = aloff;
	buflen_off = 80;

/*[5.3-1]*/
	call cv (addr (file_table.ifn), 16, addr (f_ifn));/*[5.3-1]*/
	call cv (addr (fixed_common.prog_name), 30, addr (fc_nm));
						/*[5.3-1]*/
	call cv (addr (file_table.cat_nm), 200, addr (cata_name));

/*[5.3-1]*/
	f_nm = substr (file_table.name, 1, file_table.name_size);

/*[5.3-1]*/
	if file_table.catalogued = 2
	then call test_cata_name;


/*************************************/
/* START CODE GENERATION */

start_codegen:					/* CHECK CURRENT FILE STATUS */
						/* [3.0-3] */
	alt_sw = file_table.organization = 3 /* ind */ /* [3.0-3] */ & /* [3.0-3] */ file_table.alternate_keys ^= 0;
						/* [3.0-3] */
	alt_output = alt_sw /* [3.0-3] */ & /* [3.0-3] */ cobol_mode = 61;

	call cobol_define_tag (ioerror.retry_tag);
	call cobol_set_fsbptr (ft_ptr);		/* generates  epp1  pr4|54,*  */

	if file_table.external			/* EXT_OPEN_OP */
	then do;
		call cobol_ioop_util$lda (cobol_mode);	/* OPERATOR 30: open_ext_file */
		call cobol_call_op (30, good_tag);
		call cobol_ioop_util$tra (ioerror.ns_tag);
		call cobol_make_tagref (ioerror.ns_tag, cobol_$text_wd_off - 1, null ());

	     end;					/* OPERATOR 31: open_int_file */
	else call cobol_call_op (31, good_tag);

	call cobol_gen_ioerror (ft_ptr, ioerror_ptr);
	call cobol_define_tag (good_tag);

	ioname_len = index (file_table.id, " ") - 1;
	if ioname_len < 0
	then ioname_len = 16;

	temp = divide (ioname_len + 3, 4, 17, 0) * 4;	/* make it easy for cobol_io_util */
	call ML (4 * (ioname_off + 4), temp, addr (file_table.id));
	call cobol_ioop_util$ldaldx5 (ioname_len, ioname_off);
						/* generates  lda/ldx5 ioname_len/stack_offset  */

/* LOCATE OR CREATE IOCB VIA iox_$find_iocb */
/* OPERATOR 32: find_iocb */

	call cobol_call_op (32, iocb_tag);
	call cobol_gen_ioerror (ft_ptr, ioerror_ptr);	/* cobol code=7 unable to establish IOCb */
	call cobol_define_tag (iocb_tag);

/* CHECK CURRENT ATTACHMENT OF IO-SWITCH */
/* Operator 33: check_attach */

/*[4.0-1]*/
	call cobol_call_op (33, attach_tag);


/* GENERATE ERROR FOR "DEVICE IS UNATTACHED" */

	if file_table.device = 7
	then do;
		ioerror.cobol_code = 10;		/* error if not attached */
		call cobol_gen_ioerror (ft_ptr, ioerror_ptr);
		call opfin;
		go to cogx;
	     end;					/* PREPARE FOR ATTACHING IO-SWITCH */

	atd_charoff = 4 * atd_off;

	if file_table.ao_len > 0
	then typ = 1;
	else if file_table.attach_options_info ^= "00000"
	then typ = 2;
	else typ = 3;

	go to op (typ);


op (1):
	atd_len = file_table.ao_len;
	call ML (atd_charoff + 16, atd_len, addr (file_table.ao_string));

	go to opx;

op (2):						/*[4.0-2]*/
	call MOVE (file_table.attach_options_info, 16);	/*[4.0-2]*/
	atd_len = key_sz;

	go to opx;

op (3):						/* BUILD ATTACH DESCRIPTION - "vfile_  <name> [-extend]" */
	if file_table.catalogued < 2 & file_table.device ^= 5
						/* no pathname given */
	then do;
		segname = fc_nm || "." || f_ifn;
		namelen = length (fc_nm) + length (f_ifn) + 1;

		if file_table.temp & file_table.device ^= 1 & file_table.device ^= 3
		then do;
			temp = 4 * divide (namelen + 4, 4, 35, 0);

			call cobol_alloc$stack (80, 2, len_off);

			uchars_off = len_off + 2;
			call ML (uchars_off * 4, temp, addr (segname));

/* USE CURRENT PROCESS DIRECTORY || ">" || UNIQUE_SEGNAME */

			args.entryno = 0;		/* entry constant */
			args.arglist_off = uchars_off + 8;
			argb (1) = unspec (name_arg);
			argb (2) = unspec (temp_arg);
			args.n = 2;
			arg.pt (1) = addr (get_pdir_vstring);
			arg.off1 (2) = atd_off + 7;
			arg.repeat_nogen (2) = "0"b;

			call cobol_iocall (addr (args), null ());
			call cobol_set_fsbptr (ft_ptr);
			call cobol_open_util$make_pdir_path (atd_off + 7, len_off, uchars_off, namelen);

			atd_len = 202;

		     end;
		else do;

/* USE UNIQUE_SEGNAME ONLY (vfile_ will expand it at execution) */

			atd_len = namelen;
			call ML (atd_charoff + 28, atd_len, addr (segname));

		     end;
	     end;
	else do;					/* cat name specified */
						/* USE PATHNAME GIVEN */

		if file_table.catalogued = 2		/* given as a literal */
		then do;
			atd_len = 4 * divide (length (cata_name) + 3, 4, 35, 0);

			call ML (atd_charoff + 28, atd_len, addr (cata_name_loc -> vch.ch));

		     end;
		else if file_table.catalogued = 3
		then do;				/* given as a data_name */

			if file_table.device = 5
			then do;
				atd_type9.file_key_info.fb (4) = 6;
				atd_len = 6;
			     end;
			else atd_len = 200;


/*[4.0-2]*/
			call MOVE (file_table.cat_id_info, 28);

		     end;

	     end;

	if file_table.device = 5
	then do;
		atd_len = atd_len + 12;

		if file_table.catalogued < 2 | file_table.temp
		then ft_work = "work  ";
		if multics_mode = 5
		then ft_output_mode = " -cr ";

		ft_max_cra_size = file_table.max_cra_size;

		if file_table.block_desc = 1
		then ft_block_num = divide (file_table.block_max, ft_max_cra_size, 17, 0);
		if file_table.spanned_recs
		then do;
			ft_format = " s  ";
			ft_max_cra_size = ft_max_cra_size + 5;
		     end;
		else if file_table.variable
		then do;
			ft_format = " d  ";
			ft_max_cra_size = ft_max_cra_size + 4;
		     end;
		else ft_format = " f  ";

		if file_table.block_desc ^= 0
		then substr (ft_format, 3, 1) = "b";

		if file_table.open_out | file_table.open_ext | multics_mode = 5
		then ft_protect = " -rg ";
		if file_table.tape.protect
		then ft_protect = "";

		if file_table.tape.retain
		then ft_retain = " -ret all ";
		if file_table.tape.force
		then ft_force = " -fc ";

		if file_table.tape.density
		then ft_density_num = 1600;		/*[4.4-1]*/
		else if file_table.tape.den_6250
		then ft_density_num = 6250;

		if file_table.mult_position_no > 0
		then ft_position_num = file_table.mult_position_no;

		if file_table.block_desc = 0
		then ft_block_num = ft_max_cra_size;
		else if file_table.block_desc = 1
		then if file_table.spanned_recs
		     then ft_block_num = file_table.block_max;
		     else ft_block_num = ft_block_num * ft_max_cra_size;
		else ft_block_num = file_table.block_max * ft_max_cra_size;

		if file_table.output_mode < 5
		then do;
			go to o_m (file_table.output_mode);

o_m (1):
			om = " -gen ";		/* generation */
			go to omx;

o_m (2):
			om = " -mod ";		/* modification */
			go to omx;

o_m (3):
o_m (4):						/* replacement */
			call set_replacement_info;
			go to omx;

o_m (0):
omx:
		     end;

		if file_table.tape_device > 0
		then if file_table.tape_device = 1
		     then ft_device_num = file_table.tape_device_num;
		     else ;
		else ft_device_num = 1;

		if extend_sw
		then do;
			ft_extend = " -extend";
			ft_output_mode = "";	/* extend and create don't mix. */
		     end;

/*[5.3-1]*/
		if file_table.retention_info ^= "00000"
		then call set_retention_info;

/*[5.3-1]*/
		if file_table.catalogued = 2		/*[5.3-1]*/
		then if file_id = ""		/*[5.3-1]*/
		     then call set_file_id;		/*[5.3-1]*/
		     else ;			/*[5.3-1]*/
		else call set_file_id;

/*[5.3-1]*/
		atd_string = ft_work;

/*[5.3-1]*/
		if file_table.label_format = 1
		then call set_atd1;
		else call set_atd2;			/*[5.3-1]*/
		temp = length (atd_string);
		call ML (atd_charoff + 16 + atd_len, temp, addr (atd_string_loc -> vch.ch));
						/*[5.3-1]*/
		if file_table.org_qual ^= 5 & file_table.org_qual ^= 7 & file_table.label_format = 1
						/*[5.3-1]*/
		then handler = "tape_ansi_  ";	/*[5.3-1]*/
		else handler = "tape_ibm_  ";

/*[5.3-1]*/
		call ML (atd_charoff + 16, 12, addr (handler));
						/*[5.3-1]*/
		atd_len = atd_len + length (atd_string);

	     end;
	else do;

/*[3.0-3]*/
		if file_table.dupl_alt | extend_sw	/*[3.0-3]*/
		then do;
			if file_table.dupl_alt & extend_sw
						/*[3.0-3]*/
			then append_string = " -extend -dup_ok";
						/*[3.0-3]*/
			else /*[3.0-3]*/
			     if extend_sw		/*[3.0-3]*/
			then append_string = " -extend";
						/*[3.0-3]*/
			else append_string = " -dup_ok";
						/*[3.0-3]*/
						/*[3.0-3]*/
			append_size = length (append_string);
						/*[3.0-3]*/
			atd_len = atd_len + append_size;
						/*[3.0-3]*/
						/*[3.0-3]*/
			call ML (atd_charoff + atd_len + 20, append_size, addr (append_string_loc -> vch.ch));

/**/
		     end;

		call ML (atd_charoff + 16, 12, addr (vf));
		atd_len = atd_len + 12;

	     end;

	go to opx;





opx:						/* ATTACH THE IO-SWITCH VIA iox_$attach_iocb */
	temp = divide (atd_charoff, 4, 17, 0);
	call cobol_ioop_util$ldaldx5 (atd_len, temp);

	if file_table.ao_len > 0
	then temp = 14;				/* Unable to attach I/O switch with specified options */
	else if file_table.catalogued < 2
	then temp = 13;				/* Unable to attach I/O switch */
	else temp = 51;				/* - possible invalid catalogue-name */

	call opfin;
	go to cogx;

opfin:
     proc;

/* operator 34: attach_iocb */
	call cobol_call_op (34, attach_tag);		/*ATTACH_IOCB_OP*/

	ioerror.cobol_code = temp;
	call cobol_gen_ioerror (ft_ptr, ioerror_ptr);
	call cobol_define_tag (attach_tag);		/* OPEN THE FILE VIA iox_$open */
						/* OPERATOR37(check_file) */

	call cobol_call_op (37, open_tag1);		/*CHECK_NONCOBOL_OP*/

	if alt_output | cobol_mode = 59 | cobol_mode = 63 /* open output; close; then open update */
	then do;					/* OPERATOR36(open_close_file) */

		call cobol_call_op (36, open_tag2);	/*OPEN_OP output*/
		call cobol_gen_ioerror (ft_ptr, ioerror_ptr);


	     end;

	call cobol_define_tag (open_tag2);
	call cobol_set_fsbptr (ft_ptr);

	if (multics_mode = 6 & extend_sw = "1"b & file_table.device = 5)
	then multics_mode = 5;			/* [3.0-3] */
	if alt_output
	then multics_mode = 10;

	call cobol_ioop_util$open_clean_up (ft_ptr, cobol_mode, multics_mode);
						/* operator 35: open_file */
	call cobol_call_op (35, open_tag1);

	if alt_output | multics_mode = 10 | (multics_mode = 13 & cobol_mode < 48) | multics_mode = 7
	then do;					/* OPEN FILE VIA iox_$open FOR INDEXED_SEQUENTIAL_OUTPUT or DIRECT OUTPUT */

		temp = multics_mode - 1;
		if temp = 6
		then temp = 5;

/* CLOSE FILE VIA iox_$close */

		call cobol_ioop_util$set_stz;
		call cobol_set_fsbptr (ft_ptr);
		call cobol_ioop_util$open_clean_up (ft_ptr, cobol_mode, temp);

/* OPERATOR 29: close_op_file */

		call cobol_call_op (29, open_tag2);

	     end;

	call cobol_gen_ioerror (ft_ptr, ioerror_ptr);
	call cobol_define_tag (open_tag1);

/* [3.0-3] */
	if alt_sw					/* [3.0-3] */
	then do;
		call cobol_io_util$file_desc (file_table.file_desc_1_offset);

/* [3.0-3] */
		call cobol_call_op (78, 0);		/* [3.0-3] */
		call cobol_set_fsbptr (ft_ptr);	/* [3.0-3] */
	     end;

/* RECORD OPENING IN FSB RUN_UNIT CONTROL_SEG */

	if file_table.linage			/* LINAGE initialization */
	then do;
		call cobol_set_fsbptr (ft_ptr);
		call cobol_read_rand (1, file_table.linage_info, linage_ptr);

		stream_tag = cobol_$next_tag;
		cobol_$next_tag = cobol_$next_tag + 1;

		if linage_rec.body > 0
		then if linage_rec.body ^= 5
		     then call linage_init (linage_rec.body, 92 * 4);
		     else call cobol_ioop_util$set_fsb (linage_rec.body_int, 92);
		else do;
			linage_rec.body_int = 66;	/* default  should no reach this point. */
			linage_rec.body = 5;
			call cobol_ioop_util$set_fsb (linage_rec.body_int, 92);
		     end;

		if linage_rec.footing > 0
		then if linage_rec.footing ^= 5
		     then call linage_init (linage_rec.footing, 93 * 4);
		     else if linage_rec.footing_int = 0
		     then call cobol_ioop_util$set_fsb (linage_rec.body_int, 135);
		     else call cobol_ioop_util$set_fsb (linage_rec.footing_int, 93);
		else if linage_rec.body ^= 5
		then call linage_init (linage_rec.body, 93 * 4);
		else call cobol_ioop_util$set_fsb (linage_rec.body_int, 93);

		if linage_rec.top > 0
		then do;
			if linage_rec.top ^= 5
			then call linage_init (linage_rec.top, 94 * 4);
			else call cobol_ioop_util$set_fsb (linage_rec.top_int, 94);

			call cobol_alloc$stack (120, 2, buf_off);
			call cobol_ioop_util$disp (buf_off);
		     end;
		else call cobol_ioop_util$set_fsb (0, 94);

		if linage_rec.bottom > 0
		then if linage_rec.bottom ^= 5
		     then call linage_init (linage_rec.bottom, 95 * 4);
		     else call cobol_ioop_util$set_fsb (linage_rec.bottom_int, 95);
		else call cobol_ioop_util$set_fsb (0, 95);
						/* OPERATOR24(set_line_file_status) */
		call cobol_file_util$open (mp.pt2, 1);

	     end;					/* OPERATOR25(set_file_status) */
	else call cobol_file_util$open (mp.pt2, 0);

	call cobol_reg_manager$after_op (4095 + ioerror.cobol_code);
	call cobol_gen_ioerror$finish_up (ft_ptr, ioerror_ptr);

     end;

cogx:	/***.....	if Trace_Bit then call cobol_gen_driver_$Tr_End(cog);/**/
	return;


set_atd1:
     proc;					/* STANDARD LABELS */

/*[5.3-1]*/
	atd_string = atd_string || " -nm " || file_id;	/*[5.3-1]*/
	atd_string = atd_string || om;		/*[5.3-1]*/
	atd_string = atd_string || ft_retain || ft_force || ft_extend;
						/*[5.3-1]*/
	atd_string = atd_string || " -rec " || NUMS (ft_max_cra_size);
						/*[5.3-1]*/
	atd_string = atd_string || ft_output_mode;

/*[5.3-1]*/
	call set_atd;

     end;



set_atd2:
     proc;					/* NO LABELS */

/*[5.3-1]*/
	ft_format = " u ";				/*[5.3-1]*/
	call set_atd;

     end;



set_atd:
     proc;					/* initialize attach descr */

/*[5.3-1]*/
	if ft_expire ^= ""
	then atd_string = atd_string || " -exp " || ft_expire;

/*[5.3-1]*/
	atd_string = atd_string || " -fmt " || ft_format;

/*[5.3-1]*/
	if ft_protect ^= ""
	then atd_string = atd_string || ft_protect;

/*[5.3-1]*/
	atd_string = atd_string || " -den " || NUMS (ft_density_num);
						/*[5.3-1]*/
	atd_string = atd_string || " -nb " || NUMS (ft_position_num);
						/*[5.3-1]*/
	atd_string = atd_string || " -bk " || NUMS (ft_block_num);
						/*[5.3-1]*/
	atd_string = atd_string || " -dv " || NUMS (ft_device_num);

/*[5.3-1]*/
	if file_table.org_qual = 5
	then atd_string = atd_string || " -dos ";

     end;

ML:
     proc (off, len, str_loc);

/*[5.3-1]*/
dcl	(off, len)	fixed bin,
	str_loc		ptr;

/*[5.3-1]*/
dcl	str		char (1024) based (str_loc);

/*[5.3-1]*/
	call cobol_io_util$move_lit ("110"b, off, len, substr (str, 1, len));

     end;


get_info:
     proc (ch5);

/*[5.3-1]*/
dcl	ch5		char (5);

/*[5.3-1]*/
	call cobol_read_rand (1, ch5, fkey_ptr);

     end;

set_file_id:
     proc;					/* FILE-ID clause */

/*[5.3-1]*/
	if file_table.file_id_info = "00000"		/* not present */
						/*[5.3-1]*/
	then do;
		if file_table.mult_position_no = 0	/*[5.3-1]*/
		then file_id = f_ifn;		/*[5.3-1]*/
		else file_id = f_nm;

/*[5.3-1]*/
		return;				/*[5.3-1]*/
	     end;

/*[5.3-1]*/
	call get_info (file_table.file_id_info);

/*[5.3-1]*/
	if file_key.key_type = 113			/* literal */
						/*[5.3-1]*/
	then do;
		file_id = substr (file_key.name, 1, file_key.name_size);

/*[5.3-1]*/
		return;				/*[5.3-1]*/
	     end;

     end;

set_retention_info:
     proc;					/* RETENTION cluse */

/*[5.3-1]*/
dcl	tm		fixed bin (71);		/*[5.3-1]*/
dcl	dt		char (32);

/*[5.3-1]*/
	call get_info (file_table.retention_info);

/*[5.3-1]*/
	if file_key.key_type = 114			/* literal */
						/*[5.3-1]*/
	then do;
		tm = clock_ ();

/*[5.3-1]*/
		tm = tm + 24 * 3600 * 1000000 * fixed (substr (file_key.name, 1, file_key.name_size));

/*[5.3-1]*/
		call date_time_ (tm, dt);		/*[5.3-1]*/
		ft_expire = substr (dt, 1, 9);	/*[5.3-1]*/
	     end;

     end;

set_replacement_info:
     proc;					/* REPLACEMENT phrase */

/*[5.3-1]*/
	om = " -rpl ";

/*[5.3-1]*/
	if file_table.replacement_info = "00000"	/* no phrase */
						/*[5.3-1]*/
	then do;
		ft_output_mode = f_ifn;		/*[5.3-1]*/
		return;				/*[5.3-1]*/
	     end;

/*[5.3-1]*/
	call get_info (file_table.replacement_info);

/*[5.3-1]*/
	if file_key.key_type = 109			/* literal */
						/*[5.3-1]*/
	then do;
		ft_output_mode = substr (file_key.name, 1, file_key.name_size);
						/*[5.3-1]*/
		return;				/*[5.3-1]*/
	     end;

     end;

cv:
     proc (fch_loc, sz, vch_loc);			/* convert to char varying */

/*[5.3-1]*/
dcl	(fch_loc, vch_loc)	ptr,
	(i, sz)		fixed bin;

/*[5.3-1]*/
dcl	fch		char (2048) based (fch_loc);	/*[5.3-1]*/
dcl	vch		char (2048) varying based (vch_loc);

/*[5.3-1]*/
	do i = sz by -1 to 1;

/*[5.3-1]*/
	     if substr (fch, i, 1) ^= " "		/*[5.3-1]*/
	     then do;
		     vch = substr (fch, 1, i);	/*[5.3-1]*/
		     return;			/*[5.3-1]*/
		end;

/*[5.3-1]*/
	end;

/*[5.3-1]*/
	vch = "";

     end;

test_cata_name:
     proc;					/* test for ` in cata name (obsolete) */

/*[5.3-1]*/
dcl	(l, i)		fixed bin;

/*[5.3-1]*/
	l = length (cata_name);
	if l = 0
	then return;				/*[5.3-1]*/
	i = index (cata_name, "`");
	if i = 0
	then return;

/*[5.3-1]*/
	if i = l					/*[5.3-1]*/
	then do;
		if l = 1				/*[5.3-1]*/
		then cata_name = "";		/*[5.3-1]*/
		else cata_name = substr (cata_name, 1, l - 1);

/*[5.3-1]*/
		return;				/*[5.3-1]*/
	     end;

/*[5.3-1]*/
	if i = 1					/*[5.3-1]*/
	then do;
		file_id = substr (cata_name, 2);	/*[5.3-1]*/
		cata_name = "";

/*[5.3-1]*/
		return;				/*[5.3-1]*/
	     end;

/*[5.3-1]*/
	file_id = substr (cata_name, i + 1);		/*[5.3-1]*/
	cata_name = substr (cata_name, 1, i - 1);

     end;

linage_init:
     proc (index_value, fsb_offset);

dcl	index_value	fixed bin (15);
dcl	fsb_offset	fixed bin;

	addr (fkey_type9.file_key_info) -> file_key_desc = linage_rec.name_desc (index_value);

	mpout.n = 4;
	mpout.pt1 = mp.pt1;
	mpout.pt2 = addr (fkey_type9);
	mpout.pt3 = addr (comp6_type9);

	comp6_type9.size, comp6_type9.places_left = 4;
	comp6_type9.seg = 5001;			/* TO PR1 */
	comp6_type9.off = file_table.fsb.off + fsb_offset;

	mpout.pt4 = addr (type19);

	call cobol_move_gen (addr (mpout));
	return;

     end linage_init;

MOVE:
     proc (ch5, offset);

/*[4.0-2]*/
declare	ch5		char (5),
	offset		fixed bin;		/*[4.0-2]*/
declare	p		ptr;

/*[4.0-2]*/
declare	1 desc		based (p),		/*[4.0-2]*/
	  2 linkage	fixed bin,		/*[4.0-2]*/
	  2 file_num	fixed bin,		/*[4.0-2]*/
	  2 size_rtn	fixed bin,		/*[4.0-2]*/
	  2 item_length	fixed bin (24),		/*[4.0-2]*/
	  2 places_left	fixed bin,		/*[4.0-2]*/
	  2 places_right	fixed bin;

/*[4.0-2]*/
	call cobol_read_rand (1, ch5, fkey_ptr);

/*[4.0-2]*/
	mpout.n = 4;				/*[4.0-2]*/
	mpout.pt1 = mp.pt1;				/*[4.0-2]*/
	mpout.pt2 = addr (catid_type9);		/*[4.0-2]*/
	mpout.pt3 = addr (atd_type9);			/*[4.0-2]*/
	mpout.pt4 = addr (type19);

/*[4.0-2]*/
	unspec (catid_type9.file_key_info) = unspec (file_key.desc);
						/*[4.0-2]*/
	mpout.pt3 -> data_name.offset = atd_charoff + offset;

/*[4.0-2]*/
	call cobol_move_gen (addr (mpout));

/*[4.0-2]*/
	p = addr (file_key.desc);			/*[5.1-1]*/
	key_sz = desc.item_length;

     end;

NUMS:
     proc (v) returns (char (13) var);

declare	v		fixed bin;		/*[3.0-2]*/
declare	ioa_$rsnnl	entry options (variable);	/*[3.0-2]*/
declare	S		char (13) varying,
	len		fixed bin;		/*[3.0-2]*/

	call ioa_$rsnnl ("^d", S, len, v);		/*[3.0-2]*/

	return (substr (S, 1, len));			/*[3.0-2]*/

     end;

/*[5.3-1]*/
dcl	1 vch		based,			/*[5.3-1]*/
	  2 sz		fixed bin (35),		/*[5.3-1]*/
	  2 ch		char (1);

	/***.....	dcl cog char(14) init("COBOL_OPEN_GEN");/**/

	/***.....	dcl cobol_gen_driver_$Tr_Beg entry(char(*));/**/
	/***.....	dcl cobol_gen_driver_$Tr_End entry(char(*));/**/

	/***.....	dcl Trace_Bit bit(1) static external;/**/
	/***.....	dcl Trace_Lev fixed bin static external;/**/
	/***.....	dcl Trace_Line char(36) static external;/**/
	/***.....	dcl ioa_ entry options(variable); /**/




/* STATIC DECLARATIONS */

dcl	1 basic_arg	static,
	  2 pt		ptr init (null ()),		/* initialized to address of basic structure */
	  2 zeros		bit (144) init (""b);
dcl	1 name_arg	static,
	  2 pt		ptr init (null ()),		/* set each time to pt to varying char string containing name of program to be called */
	  2 type		fixed bin init (6),
	  2 zeros		bit (108) init (""b);
dcl	1 temp_arg	static,
	  2 pt		ptr init (null ()),		/* always null */
	  2 type		fixed bin init (3),
	  2 zeros		bit (108) init (""b);
dcl	1 value_arg	static,
	  2 pt		ptr init (null ()),		/* always null */
	  2 type		fixed bin init (1),
	  2 zeros		bit (108) init (""b);
dcl	1 upper_value_arg	static,
	  2 pt		ptr init (null ()),		/* always null */
	  2 type		fixed bin init (2),
	  2 zeros		bit (108) init (""b);
dcl	1 status_arg	static,
	  2 pt		ptr init (null ()),		/* always null */
	  2 type		fixed bin init (3),
	  2 off1		fixed bin init (40),
	  2 zeros		bit (72) init (""b);

dcl	1 pr1_struct	static,
	  2 pr1		fixed bin init (1),
	  2 pointer_no	bit (3),
	  2 lock		fixed bin init (0),
	  2 switch	fixed bin init (0),
	  2 segno		fixed bin,
	  2 offset	fixed bin,
	  2 reset		fixed bin;
dcl	1 x5_struct	static,
	  2 x5		fixed bin init (15),
	  2 reg_no	bit (4),
	  2 lock		fixed bin init (0),
	  2 already_there	fixed bin,
	  2 contains	fixed bin init (0),
	  2 null_ptr	ptr init (null ()),
	  2 fill		bit (18) unaligned init ((18)"0"b),
	  2 literal	bit (18) unaligned;
dcl	1 aq_struct	static,
	  2 aq		fixed bin init (3),
	  2 reg_no	bit (4),
	  2 lock		fixed bin init (0),
	  2 already_there	fixed bin,
	  2 contains	fixed bin init (0),
	  2 null_ptr	ptr init (null ()),
	  2 fill		bit (18) unaligned init ((18)"0"b),
	  2 literal	bit (18) unaligned;

dcl	1 basic_struct	static,
	  2 type		fixed bin init (1),
	  2 operand_no	fixed bin init (0),
	  2 lock		fixed bin init (0),
	  2 seg		fixed bin,
	  2 offset	fixed bin,
	  2 send_receive	fixed bin init (0);
dcl	1 atd_type9	static,
	  2 header	(4) fixed bin init (112, 0, 0, 9),
	  2 repl_ptr	(2) ptr init ((2) null ()),
	  2 fill1		bit (108) init (""b),
	  2 file_key_info,
	    3 fb		(6) fixed bin init (0, 0, 0, 200, 0, 0),
	    3 flags1	bit (36) init ("000000100100000000010000000100000000"b),
	    3 flags2	bit (36) init (""b),
	    3 seg		fixed bin init (1000),
	    3 off		fixed bin,
	  2 fill2		(7) fixed bin init (0, 0, 0, 0, 0, 0, 0);
dcl	1 catid_type9	static,
	  2 header	(4) fixed bin init (112, 0, 0, 9),
	  2 repl_ptr	(2) ptr init ((2) null ()),
	  2 fill1		bit (108) init (""b),
	  2 file_key_info,
	    3 fb		(6) fixed bin init (0, 0, 0, 0, 0, 0),
	    3 flags1	bit (36) init (""b),
	    3 flags2	bit (36) init (""b),
	    3 seg		fixed bin,
	    3 off		fixed bin,
	  2 fill2		(7) fixed bin init (0, 0, 0, 0, 0, 0, 0);
dcl	1 comp6_type9	static,
	  2 header	(4) fixed bin init (112, 0, 0, 9),
	  2 repl_ptr	(2) ptr init ((2) null ()),
	  2 fill1		bit (108) init (""b),
	  2 file_key_info,
	    3 fb1		(3) fixed bin init (0, 0, 0),
	    3 size	fixed bin init (0),
	    3 places_left	fixed bin,
	    3 places_right	fixed bin init (0),
	    3 flags1	bit (36) init ("010000100100001001000000000000000000"b),
	    3 flags2	bit (36) init (""b),
	    3 seg		fixed bin init (0),
	    3 off		fixed bin,
	  2 fill2		(7) fixed bin init (0, 0, 0, 0, 0, 0, 0);
dcl	1 fkey_type9	static,
	  2 header	(4) fixed bin init (112, 0, 0, 9),
	  2 repl_ptr	(2) ptr init ((2) null ()),
	  2 fill1		bit (108) init (""b),
	  2 file_key_info,
	    3 fb1		(3) fixed bin init (0, 0, 0),
	    3 size	fixed bin init (0),
	    3 fb2		(2) fixed bin init (0, 0),
	    3 flags1	bit (36) init (""b),
	    3 flags2	bit (36) init (""b),
	    3 seg		fixed bin,
	    3 off		fixed bin,
	  2 fill2		(7) fixed bin init (0, 0, 0, 0, 0, 0, 0);
dcl	1 type19		static,
	  2 wd0		fixed bin init (38),
	  2 wd1		fixed bin init (0),
	  2 wd2		fixed bin init (0),
	  2 wd3		fixed bin init (19),
	  2 wd4		fixed bin init (18),	/* verb number */
	  2 e		fixed bin init (1),		/* one operand after TO */
	  2 h		fixed bin,
	  2 j		fixed bin,
	  2 a		bit (3),
	  2 b		bit (1),
	  2 c		bit (1),
	  2 d		bit (2),
	  2 f		bit (2),
	  2 g		bit (2),
	  2 k		bit (5);

dcl	1 ioerror		static,
	  2 cobol_code	fixed bin,
	  2 retry_tag	fixed bin,
	  2 is_tag	fixed bin,
	  2 ns_tag	fixed bin,
	  2 type1_ptr	ptr,
	  2 mode		fixed bin;

dcl	unique_bits_vstring char (12) varying static init ("unique_bits_");
dcl	unique_chars_vstring
			char (13) varying static init ("unique_chars_");
dcl	get_pdir_vstring	char (9) varying static init ("get_pdir_");


/* EXTERNAL ENTRY NAMES */

dcl	cobol_ioop_util$set_stz
			entry;
dcl	cobol_make_tagref	entry (fixed bin, fixed bin, ptr);
dcl	cobol_ioop_util$disp
			entry (fixed bin);
dcl	cobol_ioop_util$lda entry (fixed bin);
dcl	cobol_ioop_util$tra entry (fixed bin);
dcl	cobol_ioop_util$open_clean_up
			entry (ptr, fixed bin, fixed bin);
dcl	cobol_ioop_util$ldaldx5
			entry (fixed bin, fixed bin);
dcl	cobol_ioop_util$set_fsb
			entry (fixed bin (31), fixed bin);
dcl	cobol_gen_ioerror	entry (ptr, ptr);
dcl	cobol_gen_ioerror$finish_up
			entry (ptr, ptr);
dcl	cobol_call_op	entry (fixed bin, fixed bin);
dcl	cobol_reg_manager$after_op
			entry (fixed bin);
dcl	cobol_set_fsbptr	entry (ptr);
dcl	cobol_alloc$stack	entry (fixed bin, fixed bin, fixed bin);
dcl	cobol_read_ft	entry (fixed bin, ptr);
dcl	cobol_read_rand	entry (fixed bin, char (5), ptr);
dcl	cobol_define_tag	entry (fixed bin);
dcl	cobol_iomode	entry (ptr, ptr, fixed bin, fixed bin, bit (1) aligned);

/* sub-generators */
dcl	cobol_move_gen	entry (ptr);
dcl	cobol_file_util$open
			entry (ptr, fixed bin);
dcl	cobol_io_util$move_lit
			entry (bit (3) aligned, fixed bin, fixed bin, char (*));
dcl	cobol_iocall	entry (ptr, ptr);
dcl	cobol_io_util$move	entry (bit (3) aligned, fixed bin, fixed bin, bit (3) aligned, fixed bin, fixed bin);
dcl	cobol_io_util$file_desc
			entry (fixed bin (24));
dcl	cobol_open_util$make_pdir_path
			entry (fixed bin, fixed bin, fixed bin, fixed bin);

/* BUILTIN FUNCTIONS */

/*****	Declaration for builtin function	*****/

dcl	(substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index)
			builtin;





%include cobol_file_table;
%include cobol_file_key;
%include cobol_linage_rec;
%include cobol_type1;
%include cobol_type9;
%include cobol_type12;
%include cobol_type19;
%include cobol_fixed_common;
%include cobol_ext_;
%include cobol_;

     end cobol_open_gen;




		    cobol_open_util.pl1             05/24/89  1041.5rew 05/24/89  0830.4      168534



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_open_util.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 01/29/77 by Bob Chang to implement profile option.	*/
/* Modified on 11/11/76 by Bob Chang to change mft into file_table.	*/
/* Modified since Version 2.0.	*/
/* format: style3 */
cobol_open_util:
     proc;

dcl	1 ioerror		based (ioerror_ptr),
	  2 lineno	fixed bin,
	  2 restartad	fixed bin,
	  2 forward_tag	fixed bin,
	  2 no_error_tag	fixed bin,
	  2 no_error_ptr	ptr,
	  2 unopen	fixed bin,
	  2 special_tag	fixed bin,
	  2 special_ptr	ptr,
	  2 error_ptr	ptr;

dcl	check_noncobol_instr
			(7) bit (36) static init ("010000000000010000010011111001000000"b,
						/* ldaq	pr2|20	(iocb.open_descrip_ptr)*/
			"000000000000000000110111111000000100"b,
						/* eraq	[nullptr],ic		*/
			"000000000000000000011111111000000100"b,
						/* anaq	[ptrmask],ic		*/
			"000000000000000100110000000000000100"b,
						/* tze	4,ic	(goto open)	*/
			"111111111111111111010011101000000011"b,
						/* lda	-1,du	(noncobol open status) */
			"001000000000000010111101101001000000"b,
						/* sta	pr1|2	(fsb.open_mode)	*/
			"000000000000000000111001000000000100"b);
						/* tra	<NEXT STATEMENT via fixup>	*/

dcl	ext_open_instr	(4) bit (36) static init ("001000000000000010010011101001000000"b,
						/* lda	pr1|2	(fsb.open_mode)	*/
			"000000000000000000110000100100000100"b,
						/* tmoz	[bypass_error],ic		*/
			"000000000000000000001001101000000111"b,
						/* cmpa	[cobol_mode],dl		*/
			"000000000000000000110000000000000000"b);
						/* tze	<NEXT STATEMENT via fixup>	*/

dcl	int_open_instr	(2) bit (36) static init ("001000000000000010010011100001000000"b,
						/* szn	pr1|2	(fsb.open_mode)	*/
			"000000000000000000110000000000000100"b);
						/* tze	[bypass_error],ic		*/

dcl	ext_close_instr	(2) bit (36) static init ("001000000000000010010011100001000000"b,
						/* szn	pr1|2	(fsb.open_mode)	*/
			"000000000000000000110000100100000100"b);
						/* tmoz	<NEXT STATEMENT via fixup>	*/

dcl	int_close_instr	(2) bit (36) static init ("001000000000000010010011100001000000"b,
						/* szn	pr1|2	(fsb.open_mode)	*/
			"000000000000000000110000001000000100"b);
						/* tnz	[bypass_error],ic		*/

dcl	check_attach_instr	(5) bit (36) static init ("001000000000000000011101010001010000"b,
						/* epp2	pr1|0,*	(fsb.iocb_ptr)	*/
			"010000000000001100010011111001000000"b,
						/* ldaq	pr2|14	(iocb.attach_descrip_ptr)*/
			"000000000000000000110111111000000100"b,
						/* eraq	[nullptr],ic		*/
			"000000000000000000011111111000000100"b,
						/* anaq	[ptrmask],ic		*/
			"000000000000000000110000001000000100"b);
						/* tnz	<open file>,ic		*/

dcl	check_reattach_instr
			(9) bit (36) static init ("001000000000000000011101010001010000"b,
						/* epp2	pr1|0,*	(fsb.iocb_ptr)	*/
			"010000000000001100010011111001000000"b,
						/* ldaq	pr2|14	(iocb.attach_descrip_ptr)*/
			"000000000000000000110111111000000100"b,
						/* eraq	[nullptr],ic		*/
			"000000000000000000011111111000000100"b,
						/* anaq	[ptrmask],ic		*/
			"000000000000000000110000000000000100"b,
						/* tze	<attach file>,ic		*/
			"010000000000010000010011111001000000"b,
						/* ldaq	pr2|20	(iocb.open_descrip_ptr)*/
			"000000000000000000110111111000000100"b,
						/* eraq	[nullptr],ic		*/
			"000000000000000000011111111000000100"b,
						/* anaq	[ptrmask],ic		*/
			"000000000000000000110000000000000100"b);
						/* tze	<detach file>,ic		*/

dcl	pdir_path_instr	(15) bit (36) static init ("000000000000111110010011101000000111"b,
						/* lda	076,dl	(">")		*/
			"110000000000000000111101101001000000"b,
						/* sta	pr6|[uchars_off-1]		*/
			"000000000000000011001010100101000000"b,
						/* scm	(with zero mask)		*/
			"110000000000000000000000000010101000"b,
						/* desc1	pr6|[pname_off](0)->168	*/
			"000100000000100000000000000000000000"b,
						/* desc2	"/b/b"			*/
			"110000000000000000000000000001000000"b,
						/* desc3	pr6|[len_off]		*/
			"000000000000000011110000111000000100"b,
						/* ttf	3,ic			*/
			"000000000010100000010011101000000111"b,
						/* lda	240,dl	(168, pname length)	*/
			"110000000000000000111101101001000000"b,
						/* sta	pr6|[len_off]		*/
			"110000000000000000111010101001000000"b,
						/* lxl5	pr6|[len_off]		*/
			"000000000011001010010011101000000111"b,
						/* lda	312,dl	(202, atd max len)	*/
			"110000000000000000001111101001000000"b,
						/* sba	pr6|[len_off]		*/
			"000100000001101101001000000101000000"b,
						/* mlr	(with blank fill)		*/
			"110000000000000000110000000000000000"b,
						/* desc1	pr6|[uchars_off-1](3)->[namelen+1]	*/
			"110000000000000000000000000000000101"b);
						/* desc2	pr6|[pname_off](X5)->AL	*/

dcl	fsb_open_mode_instr (2) bit (36) static init ("000000000000000000010011101000000111"b,
						/* lda	[cobol_mode],dl		*/
			"001000000000000010111101101001000000"b);
						/* sta	pr1|2	(fsb.open_mode)	*/
dcl	fsb_close_mode_instr
			bit (36) static init ("001000000000000010100101000001000000"b);
						/* stz	pr1|2	(fsb.open_mode)	*/
dcl	fsb_name_instr	(4) bit (36) static init ("100000000000010010111010101001000000"b,
						/* lxl5	pr4|22	(stat.id_len)	*/
			"000100000001000000001000000101100000"b,
						/* mlr	(with blank fill)		*/
			"100000000000010011000000000000001101"b,
						/* desc1	pr4|23(0)->X5	(stat.id)	*/
			"001000000001000111000000000001000001"b);
						/* desc2	pr1|107(0)->65	(fsb.open_name)*/
dcl	fsb_name_reloc	(8) bit (5) aligned static init ("11001"b, ""b, ""b, ""b, "11001"b, ""b, ""b, ""b);
dcl	fsb_relkey_instr	bit (36) static init ("001000000000000101100101000001000000"b);
						/* stz	pr1|5	(fsb.relkey)	*/
dcl	fsb_keylen_instr	bit (36) static init ("001000000000000110100101000001000000"b);
						/* stz	pr1|6	(fsb.keylen_sw)	*/
dcl	fsb_linage_counter_instr
			(2) bit (36) static init ("000000000000000000010011111000000100"b,
						/* ldaq	["00000001"],ic		*/
			"001000000001011000010011111001000000"b);
						/* staq	pr1|130	(fsb.linage_counter)*/
dcl	fsb_optional_instr	(2) bit (36) static init ("001111111111111111010010101000000011"b,
						/* ldx5	177777,du			*/
			"001000000001011010011100101001000000"b);
						/* ansx5	pr1|132	(fsb.optional)	*/
dcl	fsb_opened_ext_instr
			(2) bit (36) static init ("001000000000000000010010101000000011"b,
						/* ldx5	100000,du			*/
			"001000000001011010010100101001000000"b);
						/* orsx5	pr1|132	(fsb.opened)	*/
dcl	fsb_opened_int_instr
			(2) bit (36) static init ("001100000000000000010010101000000011"b,
						/* ldx5	140000,du			*/
			"001000000001011010010100101001000000"b);
						/* orsx5	pr1|132	(fsb.opened,internal) */

dcl	noentry_instr	(4) bit (36) static init ("110000000000000000010011101001000000"b,
						/* lda	pr6|mcode_off		*/
			"000000000000000000110000000000000100"b,
						/* tze	[bypass_error],ic		*/
			"100000000000000000001001101001010000"b,
						/* cmpa	pr4|error_table_$noentry],*	*/
			"000000000000000000110000000000000100"b);
						/* tze	[open_output],ic		*/
						/* fixup directive for link, used when profile options is specified.	*/
dcl	1 fixup_directive	aligned static,
	  2 operation	bit (1) unal init ("0"b),
	  2 type		bit (4) unal init ("1111"b),
	  2 reserved	bit (9) unal init ("000000000"b),
	  2 location	unal,
	    3 half	bit (1) unal init ("0"b),
	    3 base	bit (3) unal init ("001"b),
	    3 offset	fixed bin unal,
	  2 tag_number	fixed bin aligned;
dcl	noentry_reloc	(8) bit (5) aligned static init (""b, ""b, ""b, ""b, "10100"b, ""b, ""b, ""b);

dcl	tra_instr		bit (36) static init ("000000000000000000111001000000000100"b);
						/* tra	[somewhere],ic		*/

dcl	text		(0:100000) bit (36) based (cobol_$text_base_ptr);

dcl	temp		fixed bin;
dcl	utemp		fixed bin;
dcl	off		fixed bin;
dcl	i		fixed bin;
dcl	ic		fixed bin;
dcl	patch_ic		fixed bin;
dcl	nulloff		fixed bin;
dcl	maskoff		fixed bin;

dcl	save_ic		fixed bin static;
dcl	save_retry	fixed bin static;

dcl	sp_uchars		bit (18) aligned;
dcl	sp_pname		bit (18) aligned;
dcl	sp_len		bit (18) aligned;

dcl	cobol_set_fsbptr	entry (ptr);
dcl	cobol_pool	entry (char (*), fixed bin, fixed bin);
dcl	cobol_make_tagref	entry (fixed bin, fixed bin, ptr);
dcl	cobol_make_fixup	entry (ptr);
dcl	cobol_emit	entry (ptr, ptr, fixed bin);
dcl	cobol_make_link$type_4
			entry (fixed bin, char (*));

dcl	cobol_ioerror	entry (ptr, fixed bin, fixed bin, ptr);
dcl	cobol_ioerror$preset
			entry (ptr);
dcl	cobol_process_error entry (fixed bin, fixed bin, fixed bin);
dcl	cobol_io_util$move_lit
			entry (bit (3) aligned, fixed bin, fixed bin, char (*));


start:
/*************************************/
check_noncobol:
     entry (ft_ptr, define_open, ioerror_ptr, ft_ptr);

start_check_noncobol:
	temp = cobol_$text_wd_off - define_open;
	if file_table.external | file_table.ao_len > 0
	then do;
		if file_table.ao_len ^> 0
		then do;				/* an ext file with no attach-options; if attach made
						   here, can bypass noncobol open check */
			temp = temp + 1;
			substr (tra_instr, 1, 18) = "000000000000001000"b;
			call cobol_emit (addr (tra_instr), null (), 1);
		     end;
		else do;				/* an int or ext file with attach-options; must
						   reset pr1 and pr2 in case attach made here */
			call cobol_set_fsbptr (ft_ptr);
			call cobol_emit (addr (check_attach_instr (1)), null (), 1);
		     end;
		call pool_nullptr;
		utemp = nulloff - 1;
		substr (check_noncobol_instr (2), 1, 18) = substr (unspec (utemp), 19, 18);
		utemp = maskoff - 2;
		substr (check_noncobol_instr (3), 1, 18) = substr (unspec (utemp), 19, 18);
		call cobol_make_tagref (ioerror.forward_tag, cobol_$text_wd_off + 6, addr (check_noncobol_instr (7)));
		call cobol_emit (addr (check_noncobol_instr), null (), 7);
	     end;
	if define_open ^= 0
	then substr (text (define_open), 1, 18) = substr (unspec (temp), 19, 18);
exit_chexk_nonocobol:
	return;


/*************************************/
check_open:
     entry (ft_ptr, cobol_mode, ioerror_ptr);

dcl	ft_ptr		ptr;			/* pointer to the file_table */
dcl	ioerror_ptr	ptr;			/* ptr to ioerror structure */
dcl	cobol_mode	fixed bin;		/* cobol open mode */

start_check_open:
	call cobol_ioerror$preset (ft_ptr);
	call cobol_set_fsbptr (ft_ptr);
	patch_ic = cobol_$text_wd_off + 1;
	if cobol_mode = 0
	then do;					/* check for close */
		if file_table.external
		then do;
			call cobol_make_tagref (ioerror.forward_tag, cobol_$text_wd_off + 1,
			     addr (ext_close_instr (2)));
			call cobol_emit (addr (ext_close_instr), null (), 2);
			i = 0;
		     end;
		else do;
			call cobol_emit (addr (int_close_instr), null (), 2);
			i = 17;
		     end;
	     end;
	else if cobol_mode > 0
	then do;					/* check for open request */
		if file_table.external
		then do;
			substr (ext_open_instr (3), 1, 18) = substr (unspec (cobol_mode), 19, 18);
			call cobol_make_tagref (ioerror.forward_tag, cobol_$text_wd_off + 3,
			     addr (ext_open_instr (4)));
			call cobol_emit (addr (ext_open_instr), null (), 4);
			i = 8;
		     end;
		else do;
			call cobol_emit (addr (int_open_instr), null (), 2);
			i = 9;
		     end;
	     end;
	else do;					/* check for other io request */
		call cobol_emit (addr (int_close_instr), null (), 2);
		i = 24;
	     end;
	if i ^= 0
	then do;
		utemp = ioerror.unopen;
		if i = 24
		then ioerror.unopen = 1;
		call cobol_ioerror (ft_ptr, i, 0, ioerror_ptr);
		ioerror.unopen = utemp;
		utemp = cobol_$text_wd_off - patch_ic;
		substr (text (patch_ic), 1, 18) = substr (unspec (utemp), 19, 18);
	     end;
exit_chexk_open:
	return;


/*************************************/
check_attach:
     entry (ft_ptr, define_open);

dcl	define_open	fixed bin;		/* instr loc of "tra if attached" */

start_check_attach:
	call cobol_set_fsbptr (ft_ptr);
	call pool_nullptr;
	utemp = nulloff - 2;
	substr (check_attach_instr (3), 1, 18) = substr (unspec (utemp), 19, 18);
	utemp = maskoff - 3;
	substr (check_attach_instr (4), 1, 18) = substr (unspec (utemp), 19, 18);
	define_open = cobol_$text_wd_off + 4;
	call cobol_emit (addr (check_attach_instr), null (), 5);
exit_check_attach:
	return;


/*************************************/
check_reattach:
     entry (ft_ptr, define_attach, define_detach);

dcl	define_attach	fixed bin;		/* instr loc of "tra if not attached" */
dcl	define_detach	fixed bin;		/* instr loc of "tra if not open" */

start_check_reattach:
	call cobol_set_fsbptr (ft_ptr);
	call pool_nullptr;
	utemp = nulloff - 2;
	substr (check_reattach_instr (3), 1, 18) = substr (unspec (utemp), 19, 18);
	utemp = maskoff - 3;
	substr (check_reattach_instr (4), 1, 18) = substr (unspec (utemp), 19, 18);
	utemp = nulloff - 6;
	substr (check_reattach_instr (7), 1, 18) = substr (unspec (utemp), 19, 18);
	utemp = maskoff - 7;
	substr (check_reattach_instr (8), 1, 18) = substr (unspec (utemp), 19, 18);
	define_attach = cobol_$text_wd_off + 4;
	define_detach = cobol_$text_wd_off + 8;
	call cobol_emit (addr (check_reattach_instr), null (), 9);
exit_check_reattach:
	return;


/*************************************/
make_pdir_path:
     entry (pname_off, len_off, uchars_off, namelen);

dcl	pname_off		fixed bin;		/* wd offset in stack of space for pname */
dcl	len_off		fixed bin;		/* wd offset in stack of space for pname length */
dcl	uchars_off	fixed bin;		/* wd offset in stack of location of uchars char(25) */
						/* preceding word from uchars_off must be available */
dcl	namelen		fixed bin;		/* length of segment portion of name */

start_make_pdir_path:
	utemp = uchars_off - 1;
	sp_uchars = "110"b || substr (unspec (utemp), 22, 15);
	sp_pname = "110"b || substr (unspec (pname_off), 22, 15);
	sp_len = "110"b || substr (unspec (len_off), 22, 15);

	substr (pdir_path_instr (2), 1, 18) = sp_uchars;
	substr (pdir_path_instr (4), 1, 18) = sp_pname;
	substr (pdir_path_instr (6), 1, 18) = sp_len;
	substr (pdir_path_instr (9), 1, 18) = sp_len;
	substr (pdir_path_instr (10), 1, 18) = sp_len;
	substr (pdir_path_instr (12), 1, 18) = sp_len;
	substr (pdir_path_instr (14), 1, 18) = sp_uchars;
	utemp = namelen + 1;			/* for the leading > */
	substr (pdir_path_instr (14), 28, 9) = substr (unspec (utemp), 28, 9);
	substr (pdir_path_instr (15), 1, 18) = sp_pname;
	call cobol_emit (addr (pdir_path_instr), null (), 15);
exit_make_pdir_path:
	return;


/*************************************/
check_noentry1:
     entry (ft_ptr, cobol_code, ioerror_ptr, mcode_off);

dcl	cobol_code	fixed bin;
dcl	mcode_off		fixed bin;

	save_retry = ioerror.restartad;
	save_ic = cobol_$text_wd_off + 1;
	patch_ic = cobol_$text_wd_off + 3;
	substr (noentry_instr (1), 4, 15) = substr (unspec (mcode_off), 22, 15);
	call cobol_make_link$type_4 (off, "error_table_$noentry");
	if fixed_common.options.profile
	then do;
		fixup_directive.location.offset = cobol_$text_wd_off;
		call cobol_make_fixup (addr (fixup_directive));
	     end;
	substr (noentry_instr (3), 4, 15) = substr (unspec (off), 22, 15);
	call cobol_emit (addr (noentry_instr), addr (noentry_reloc), 4);
	call cobol_ioerror (ft_ptr, cobol_code, mcode_off, ioerror_ptr);
	call cobol_emit (addr (tra_instr), null (), 1);
	utemp = cobol_$text_wd_off - patch_ic;
	substr (text (patch_ic), 1, 18) = substr (unspec (utemp), 19, 18);
exit_check_noentry1:
	return;
check_noentry2:
     entry;
	utemp = save_retry - cobol_$text_wd_off;
	substr (tra_instr, 1, 18) = substr (unspec (utemp), 19, 18);
	call cobol_emit (addr (tra_instr), null (), 1);
	utemp = cobol_$text_wd_off - save_ic;
	substr (text (save_ic), 1, 18) = substr (unspec (utemp), 19, 18);
exit_chexk_noentry2:
	return;


/*************************************/
set_fsb:
     entry (ft_ptr, cobol_mode);

start_set_fsb:
	call cobol_set_fsbptr (ft_ptr);
	if cobol_mode = 0
	then do;					/* closing file */
		call cobol_emit (addr (fsb_close_mode_instr), null (), 1);
		if file_table.external
		then call cobol_emit (addr (fsb_name_instr), addr (fsb_name_reloc), 4);
	     end;
	else do;
		substr (fsb_open_mode_instr (1), 1, 18) = substr (unspec (cobol_mode), 19, 18);
		call cobol_emit (addr (fsb_open_mode_instr), null (), 2);
		call cobol_emit (addr (fsb_name_instr), addr (fsb_name_reloc), 4);
		if file_table.organization = 2
		then call cobol_emit (addr (fsb_relkey_instr), null (), 1);
		else if file_table.organization = 3
		then call cobol_emit (addr (fsb_keylen_instr), null (), 1);
		else if file_table.organization = 1 & file_table.device = 1
		then do;
			call cobol_pool ("00000001", 2, off);
			utemp = -off - cobol_$text_wd_off;
			substr (fsb_linage_counter_instr (1), 1, 18) = substr (unspec (utemp), 19, 18);
			call cobol_emit (addr (fsb_linage_counter_instr), null (), 2);
		     end;
		call cobol_emit (addr (fsb_optional_instr), null (), 2);
		if file_table.external
		then call cobol_emit (addr (fsb_opened_ext_instr), null (), 2);
		else call cobol_emit (addr (fsb_opened_int_instr), null (), 2);
	     end;
exit_set_fsb:
	return;


/*************************************/
/* SUBROUTINES */
/*************************************/

/*************************************/
pool_nullptr:
     proc;

dcl	nullcon		bit (72) aligned static
			init ("111111111111111111000000000000100011000000000000000001000000000000000000"b);
dcl	maskcon		bit (72) aligned static
			init ("000111111111111111000000000000111111111111111111111111000111111000111111"b);
dcl	char8b		char (8) based;

	call cobol_pool (addr (nullcon) -> char8b, 2, off);
	nulloff = -off - cobol_$text_wd_off;
	call cobol_pool (addr (maskcon) -> char8b, 2, off);
	maskoff = -off - cobol_$text_wd_off;
exit_pool_nullptr:
	return;
     end pool_nullptr;

exit:
	return;

/*************************************/

/*****	Declaration for builtin function	*****/

dcl	(substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index)
			builtin;

/*****	End of declaration for builtin function	*****/

%include cobol_file_table;
%include cobol_;
%include cobol_fixed_common;
%include cobol_ext_;
     end cobol_open_util;



*/
                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull
and Bull HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato. Users consider that Multics provided the best software architecture for 
managing computer hardware properly and for executing programs. Many subsequent operating systems 
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by Bull HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved

*/
