



		    cobol_paragraph_gen.pl1         05/24/89  1042.8rew 05/24/89  0832.7       47349



/****^  ***********************************************************
        *                                                         *
        * 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_paragraph_gen.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/*{*/
/* format: style3 */
cobol_paragraph_gen:
     proc (in_token_ptr);				/*
The procedure cobol_paragraph_gen performs the following functions;

  1.  Generates an end-of-perform range alterable GO and incre-
      ments perform_para_index by 1 if the paragraph being ter-
      minated is at the end of a perform range as determined by
      examining para_eop_flag (1, it is; 0, it is not).

  2.  Determines if the paragraph being entered is at the end of
      a perform range by examining perform_list.perf.proc_num
      (perform_para_index) and if it is sets para_eop_flag to 1.
      If it is not, para_eop_flag is set to 0.

  3.  Determines if the paragraph being entered is alterable by
      examining alter_list.goto.proc_num(alter_index).  If it is,
      alter_flag is set to 1.  If it is not, alter_flag is set to
      0.

  4.  Associates the paragraph's procedure number with the text
      location into which the first instruction emitted by the
      next generator called will be placed (this is the first
      free text location following the code, if any, emitted by
      cobol_paragraph_gen).


U__s_a_g_e:_

     declare cobol_paragraph_gen entry (ptr);

     call cobol_paragraph_gen(in_token_ptr);

						   */
%include cobol_in_token;

/*
G__e_n_e_r_a_t_e_d_C__o_d_e:_

The following code is generated by cobol_paragraph_gen if the para-
graph just processed is at the end of a perform range i.e. if
para_eop_flag is 0 upon entry;

     lda  target_An
     tra  0,al

where:
target_An is a 36-bit variable allocated in the program's COBOL
	data segment.  Each target_An, for n = 1, 2, 3, ..., is
	uniquely associated with the procedure at whose end
	these instructions are generated.
						   */

/*
D__a_t_a:_

     % include cobol_;
	Items in cobol_$incl.pl1 used (u) and/or (s) by
	cobol_paragraph_gen;

	     cobol_ptr (u)
	     alter_flag (s)
	     alter_index (s)
	     alter_list_ptr (u)
	     para_eop_flag (u/s)
	     perform_list_ptr (u)
	     perform_para_index (u/s)
						   */

%include cobol_alter_list;
%include cobol_perform_list;
%include cobol_perform_altgo;
%include cobol_type7;

dcl	proc_no		fixed bin;		/* Tag number of  paragraph being
			   entered.		   */

/*
P__r_o_c_e_d_u_r_e_s_C__a_l_l_e_d:_
						   */
dcl	cobol_addr	entry (ptr, ptr, ptr),
	cobol_emit	entry (ptr, ptr, fixed bin),
	cobol_define_tag	entry (fixed bin),
	cobol_register$load entry (ptr);

/*
B__u_i_l_t-__i_n_F__u_n_c_t_i_o_n_s_U__s_e_d:_
						   */

dcl	addr		builtin,
	null		builtin;

/*}*/
%include cobol_;

start:						/*  Get procedure (tag) number of paragraph being entered. 	   */
	proc_no = in_token.token_ptr (1) -> proc_def.proc_num;

/*		Paragraph alterable?		   */

	if cobol_$alter_list_ptr ^= null
	then do;
		if cobol_$alter_index <= alter_list.n
		then if alter_list.goto.proc_num (cobol_$alter_index) = proc_no
		     then cobol_$alter_flag = 1;

		     else cobol_$alter_flag = 0;

		else cobol_$alter_flag = 0;
	     end;

/*       	     Paragraph at end-of-perform range?              */

	if cobol_$perform_list_ptr ^= null
	then do;					/*  Paragraph being terminated.  */
		if cobol_$para_eop_flag ^= 0
		then /*  Insert alterable GO  */
		     do;
			call cobol_register$load (addr (register_request));
			input_struc_basic.segno = perform_list.perf.target_a_segno (cobol_$perform_para_index);
			input_struc_basic.char_offset =
			     perform_list.perf.target_a_offset (cobol_$perform_para_index);
			call cobol_addr (addr (input_struc_basic), addr (prfrm_altgo_inst_pr), null);
			call cobol_emit (addr (prfrm_altgo_inst_pr), null, 2);
			call cobol_define_tag (perform_list.perf.int_tag_no (cobol_$perform_para_index));
			cobol_$para_eop_flag = 0;
			cobol_$perform_para_index = cobol_$perform_para_index + 1;
		     end;

/*  Paragraph being entered.  */
		if cobol_$perform_para_index <= perform_list.n
		then if proc_no = perform_list.perf.proc_num (cobol_$perform_para_index)
		     then cobol_$para_eop_flag = 1;

		     else cobol_$para_eop_flag = 0;

		else cobol_$para_eop_flag = 0;

	     end;

/*    Associate procedure number with next location in text.   */

	call cobol_define_tag (proc_no);

	return;

     end cobol_paragraph_gen;




		    cobol_paste.pl1                 05/24/89  1042.8rew 05/24/89  0830.0      146097



/****^  ***********************************************************
        *                                                         *
        * 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_paste.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 04/08/81 by FCH, [4.4-2], COMMUNICATION mispelled, BUG481(TR9775) */
/* Modified on 04/01/81 by FCH, fix decl for map_data_table, [4.4-1], BUG472(TR8896,8970) */
/* Modified on 07/21/78 by RAL, [3.0-2], fix bad call to ioa_$rs */
/* Modified on 07/14/78 by FCH, [3.0-1], cobol_object_map.incl.pl1 changed */
/* Modified since Version 3.0 */

/*{*/
/* format: style3 */
cobol_paste:
     proc (value_ptr);

/* This is the final procedure called in the
fixup phase.  It provides for the creation of the
object segment and produces the object map.
When this routine returns, the object segment
is complete and in the user's working directory
with proper access set.  */


/* DECLARATIONS */

dcl	relseg_ptr	ptr;
dcl	temp		fixed bin (35);
dcl	1 relseg		(4) based (relseg_ptr),
	  2 pt		ptr,
	  2 maxoff	fixed bin,
	  2 abscnt	fixed bin;
dcl	block_relp	(4) bit (18);

dcl	bytes		char (262144) based (bptr);
dcl	seg		char (262144) based (segptr);
dcl	long_mes		char (100) aligned;
dcl	short_mes		char (8) aligned;

dcl	(bptr, segptr)	ptr;
dcl	aclinfop		ptr;

dcl	i		fixed bin;
dcl	bc		fixed bin (24);
dcl	code		fixed bin (35);
dcl	woff		fixed bin;
dcl	(bpos, blen)	fixed bin (21);
dcl	(wlen, tlen)	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	cobol_make_list	entry (ptr, fixed bin);
dcl	ioa_$rs		entry options (variable);
dcl	ioa_$rsnnl	options (variable);
dcl	hcs_$set_bc_seg	entry (ptr, fixed bin (24), fixed bin (35));
dcl	cobol_call_op$get_op
			entry (ptr);
dcl	cobol_reloc$constants
			entry (fixed bin, ptr);
dcl	get_wdir_		entry returns (char (168) aligned);
dcl	tssi_$get_segment	entry (char (*), char (*) aligned, ptr, ptr, fixed bin (35));
dcl	tssi_$finish_segment
			entry (ptr, fixed bin (24), bit (36) aligned, ptr, fixed bin (35));
dcl	tssi_$clean_up_segment
			entry (ptr);
dcl	convert_status_code_
			entry (fixed bin (35), char (8) aligned, char (100) aligned);
dcl	signal_		entry (char (*), ptr, ptr);
dcl	cleanup		condition;


/*************************************/
start:
	aclinfop = null;
	on cleanup call CL;
	call tssi_$get_segment (get_wdir_ (), cobol_$obj_seg_name, segptr, aclinfop, code);
	if code ^= 0
	then go to multics_error;

	call cobol_reloc$constants (value.con_len, relseg_ptr);

	object_map.text_relp = (18)"0"b;
	bptr = addrel (cobol_$con_end_ptr, -value.con_len + 1);
	blen = 4 * value.con_len;
	substr (seg, 1, blen) = substr (bytes, 1, blen);
	bpos = blen + 1;
	blen = 4 * value.code_len;
	substr (seg, bpos, blen) = substr (cobol_$text_base_ptr -> bytes, 1, blen);
	object_map.text_length = substr (unspec (value.text_len), 19, 18);
	bpos = bpos + blen;
	woff = value.text_len;

	object_map.def_relp = substr (unspec (woff), 19, 18);
	blen = 4 * value.def_len;
	substr (seg, bpos, blen) = substr (cobol_$def_base_ptr -> bytes, 1, blen);
	object_map.def_length = substr (unspec (value.def_len), 19, 18);
	bpos = bpos + blen;
	woff = woff + value.def_len;

	if mod (woff, 2) = 1
	then do;					/* link section must begin on even word */

		substr (seg, bpos, 4) = (4)"";	/* "\000" */
		bpos = bpos + 4;
		woff = woff + 1;

	     end;

	object_map.link_relp = substr (unspec (woff), 19, 18);
	temp = fixed (object_map.link_relp) + 8;	/* [3.0-1] */
	object_map.static_relp = substr (unspec (temp), 19, 18);
						/* [3.0-1] */
	temp = fixed (linkage_header.links_relp) - 8;	/* [3.0-1] */
	object_map.static_length = substr (unspec (temp), 19, 18);
						/* [3.0-1] */
	blen = 4 * value.link_len;
	substr (seg, bpos, blen) = substr (cobol_$link_base_ptr -> bytes, 1, blen);
	object_map.link_length = substr (unspec (value.link_len), 19, 18);
	bpos = bpos + blen;
	woff = woff + value.link_len;
	sym_ptr = addrel (segptr, woff);

	object_map.symb_relp = substr (unspec (woff), 19, 18);
	blen = 4 * value.sym_len;
	substr (seg, bpos, blen) = substr (cobol_$sym_base_ptr -> bytes, 1, blen);
	bpos = bpos + blen;
	woff = woff + value.sym_len;
	tlen = value.sym_len;

	do i = 1 to 4;				/* append relocation blocks */

	     relptr = relseg.pt (i);
	     relinfo.decl_vers = 1;			/*[3.0-1]*/
	     wlen = 3 + divide (n_bits - 1, 36, 17, 0);
	     blen = 4 * wlen;
	     substr (seg, bpos, blen) = substr (relptr -> bytes, 1, blen);
	     block_relp (i) = substr (unspec (tlen), 19, 18);
	     bpos = bpos + blen;
	     woff = woff + wlen;
	     tlen = tlen + wlen;

	end;

	symbol_block_header.text_relocation_relp = block_relp (1);
	symbol_block_header.def_relocation_relp = block_relp (2);
	symbol_block_header.link_relocation_relp = block_relp (3);
	symbol_block_header.symbol_relocation_relp = block_relp (4);
	object_map.symb_length = substr (unspec (tlen), 19, 18);
	symbol_block_header.block_size = object_map.symb_length;

	object_map.last_word.object_map_relp = substr (unspec (woff), 19, 18);
	substr (seg, bpos, 48) = substr (addr (object_map) -> bytes, 1, 48);
						/* [3.0-1] */
	bc = 36 * (woff + 12);			/* [3.0-1] */

	if fixed_common.options.xrn
	then call print_map;

	if fixed_common.options.obj
	then call cobol_make_list (addrel (segptr, value.exec_off + value.con_len), value.code_len - value.exec_off);

	call tssi_$finish_segment (segptr, bc, "1100"b, aclinfop, code);

	if code ^= 0
	then go to multics_error;

	revert cleanup;

exit:
	return;

CL:
     proc;

	call tssi_$clean_up_segment (aclinfop);

     end CL;

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

/*	print_map	*/
print_map:
     proc;
dcl	char_off		fixed bin (24),
	char_string	char (1048576) based (cobol_$list_ptr),
	p		ptr,
	nl		char (1),
	print_line	char (600) unal based;

dcl	line_len		fixed bin;


dcl	1 acc		aligned based,
	  2 length	fixed bin (8) unal,
	  2 string	char (0 refer (acc.length)) unal;

dcl	1 type_pair	aligned based,
	  2 type		bit (18) unal,
	  2 trap_relp	bit (18) unal,
	  2 segname_relp	bit (18) unal,
	  2 offset_relp	bit (18) unal;

dcl	1 exp_word	aligned based,
	  2 type_pair_relp	bit (18) unal,
	  2 expression	bit (18) unal;

dcl	auto_len		fixed bin;

dcl	operator_struc_ptr	ptr;
dcl	1 operator_struc	aligned based,
	  2 op_bits	bit (200);
dcl	op_space		char (115);
dcl	oper_name		char (nsize) based (nptr) aligned;
dcl	nsize		fixed bin;
dcl	nptr		ptr;
dcl	(i, j, k, l)	fixed bin;
dcl	cobol_operator_names_$cobol_operator_names_
			ext;

dcl	1 operator_names	based (addr (cobol_operator_names_$cobol_operator_names_)),
	  2 first		fixed bin,
	  2 last		fixed bin,
	  2 first_special	fixed bin,
	  2 last_special	fixed bin,
	  2 no_special	fixed bin,
	  2 name		(0 refer (first):1 refer (last)),
	    3 namep	bit (18),
	    3 len		bit (18);

dcl	mcode		fixed bin (35);

dcl	1 link		aligned based,
	  2 header	bit (18) unal,
	  2 not_used	bit (18) unal,
	  2 expr_relp	bit (18) unal,
	  2 not_used1	char (18) unal;

dcl	(str1, str2, str3, str4, str5)
			char (132),
	strlen		fixed bin;

dcl	no_links		fixed bin,
	fill		char (1),
	(object_len, text_len, def_len, link_len, symb_len, static_len)
			fixed bin,
	temp_ptr		ptr,
	seg_ptr		ptr,
	temp_name		char (65),
	link_ptr		ptr;

start_print_map:
	nl = "
";
	char_off = cobol_$list_off;
	p = addr (substr (char_string, char_off, 1));
	p -> print_line =
	     nl || "STORAGE REQUIREMENTS FOR THIS PROGRAM." || nl || nl
	     || "	Object	  Text	  Defs	  Link	  Symb	Static" || nl;
	char_off = char_off + 84;
	p = addr (substr (char_string, char_off, 1));
	auto_len = fixed (object_map.link_relp) + 8;
	text_len = fixed (object_map.text_relp);
	def_len = fixed (object_map.def_relp);
	link_len = fixed (object_map.link_relp);
	symb_len = fixed (object_map.symb_relp);
	static_len = fixed (object_map.link_relp) + 8;
	call ioa_$rs ("Start^-^6o^-^6o^-^6o^-^6o^-^6o^-^6o", p -> print_line, line_len, text_len, text_len, def_len,
	     link_len, symb_len, static_len);
	char_off = char_off + line_len;
	p = addr (substr (char_string, char_off, 1));
	object_len = fixed (object_map_relp) + 10;
	text_len = fixed (object_map.text_length);
	def_len = fixed (object_map.def_length);
	link_len = fixed (object_map.link_length);
	symb_len = fixed (object_map.symb_length);
	call ioa_$rs ("Length^-^6o^-^6o^-^6o^-^6o^-^6o^-^6o", p -> print_line, line_len, object_len, text_len, def_len,
	     link_len, symb_len, value.int_storage_len);
	char_off = char_off + line_len;
	p = addr (substr (char_string, char_off, 1));
	text_ptr = cobol_$text_base_ptr;
	auto_len = fixed (substr (entry_seq.eax7, 1, 18));
	stat_ptr = addrel (cobol_$link_base_ptr, 8);

	if cobol_$fs_charcnt = 0
	then str1 = "  FILE SECTION:		No files defined" || nl;
	else do;
		if fixed_common.file_count ^= 1
		then fill = "s";
		else fill = " ";
		call ioa_$rs ("  FILE SECTION:^-^-^d characters for record storage for ^d file^a    (DATA:0->^o)",
		     str1, strlen, cobol_$fs_charcnt, fixed_common.file_count, fill, cobol_$fs_wdoff,
		     (cobol_$ws_wdoff - 1));
	     end;

	if cobol_$ws_charcnt = 0
	then str2 = "  WORKING-STORAGE SECTION:	No data defined" || nl;
	else do;
		if cobol_$value_cnt ^= 1
		then fill = "s";
		else fill = " ";
		call ioa_$rs (
		     "  WORKING-STORAGE SECTION:^-^d characters for general storage with ^d item^a initialized    (DATA:^o->^o)",
		     str2, strlen, cobol_$ws_charcnt, cobol_$value_cnt, fill, cobol_$ws_wdoff,
		     (cobol_$coms_wdoff - 1));
	     end;

	if cobol_$coms_charcnt = 0
	then str3 = "  COMMUNICATION SECTION:	No data defined" || nl;
						/*[4.4-2]*/
	else do;
		if cobol_$cd_cnt ^= 1
		then fill = "s";
		else fill = " ";
		call ioa_$rs (
		     "  COMMUNICATION SECTION:^-^d characters for cd-area storage for ^d cd-name^a    (DATA:^o->^o)",
		     str3, strlen, cobol_$coms_charcnt, cobol_$cd_cnt, fill, cobol_$coms_wdoff, stat.data_len);
	     end;

	if cobol_$ls_charcnt = 0
	then str4 = "  LINKAGE SECTION:		No parameters defined" || nl;
	else do;
		if fixed_common.number_of_ls_pointers ^= 1
		then fill = "s";
		else fill = " ";
		call ioa_$rs (
		     "  LINKAGE SECTION:^-^-^d character^a for argument storage for ^d parameter^a    (allocated by caller)",
		     str4, strlen, cobol_$ls_charcnt, fill, fixed_common.number_of_ls_pointers, fill);
						/* [3.0-2] */
	     end;

	if cobol_$cons_charcnt = 0
	then call ioa_$rs (
		"  CONSTANT SECTION:^-^-No constants defined explicitly; ^d words for constant storage    (TEXT:0->^o)",
		str5, strlen, value.con_len, value.con_len - 1);
	else do;
		call ioa_$rs (
		     "  CONSTANT SECTION:^-^-^d characters for explicit constants; ^d words for constant storage    (TEXT:0->^o)",
		     str5, strlen, cobol_$cons_charcnt, value.con_len, value.con_len - 1);
	     end;

	call ioa_$rs (
	     "^/External procedure ^a uses ^d words of temporary storage^/^a^a^a^a^aTotal allocation required for cobol data is ^d words",
	     p -> print_line, line_len, fixed_common.prog_name, auto_len, str1, str2, str3, str4, str5, stat.data_len);
	char_off = char_off + line_len;
	p = addr (substr (char_string, char_off, 1));

	call cobol_call_op$get_op (operator_struc_ptr);

	if substr (operator_struc_ptr -> op_bits, 1, operator_names.last + 1)
	then ;
	else do;
		p -> print_line = nl || "THERE IS NO EXTERNAL OPERATOR CALLED BY THIS PROGRAM." || nl;
		char_off = char_off + 55;
		p = addr (substr (char_string, char_off, 1));
		goto ext_entry_label;
	     end;

	p -> print_line = nl || "THE FOLLOWING EXTERNAL OPERATORS ARE CALLED BY THIS PROGRAM." || nl;
	char_off = char_off + 62;
	p = addr (substr (char_string, char_off, 1));
	j = 0;
	op_space = (115)" ";

	do i = operator_names.first to operator_names.last;

	     if substr (operator_struc_ptr -> op_bits, i + 1, 1) = "1"b
	     then do;

		     nptr = pointer (addr (operator_names.first), operator_names.namep (i));
		     nsize = fixed (operator_names.len (i));
		     substr (op_space, j * 23 + 1, nsize) = oper_name;
		     j = j + 1;

		     if j = 5
		     then do;

			     j = 0;
			     p -> print_line = substr (op_space, 1, 115) || nl;
			     char_off = char_off + 116;
			     p = addr (substr (char_string, char_off, 1));
			     op_space = (115)" ";

			end;
		end;
	end;

	if j ^= 0
	then do;

		p -> print_line = substr (op_space, 1, j * 23) || nl;
		char_off = char_off + j * 23 + 1;
		p = addr (substr (char_string, char_off, 1));

	     end;

ext_entry_label:
	p -> print_line = nl || "THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM." || nl;
	char_off = char_off + 60;
	p = addr (substr (char_string, char_off, 1));
	no_links = cobol_$link_wd_off - 8 - value.int_storage_len;
	no_links = divide (no_links, 2, 17, 0);
	link_ptr = addrel (cobol_$link_base_ptr, linkage_header.links_relp);
	j = 0;
	op_space = (115)" ";

	do i = 1 to no_links;

	     temp_ptr = addrel (cobol_$def_base_ptr, link_ptr -> link.expr_relp);
	     temp_ptr = addrel (cobol_$def_base_ptr, temp_ptr -> exp_word.type_pair_relp);
	     if temp_ptr -> type_pair.type = "000000000000000100"b
	     then do;
		     seg_ptr = addrel (cobol_$def_base_ptr, temp_ptr -> type_pair.segname_relp);
		     temp_ptr = addrel (cobol_$def_base_ptr, temp_ptr -> type_pair.offset_relp);
		     temp_name = (64)" ";
		     temp_name = temp_ptr -> acc.string || temp_name;
		     if temp_ptr ^= seg_ptr
		     then temp_name = seg_ptr -> acc.string || "$" || temp_name;
		     k = index (temp_name, " ") - 1;
		     l = divide (k, 23, 17, 0) + 1;

		     if (j + l > 5)
		     then do;

			     p -> print_line = substr (op_space, 1, j * 23) || nl;
			     char_off = char_off + j * 23 + 1;
			     p = addr (substr (char_string, char_off, 1));
			     op_space = (115)" ";
			     j = 0;

			end;

		     substr (op_space, j * 23 + 1, l * 23) = substr (temp_name, 1, l * 23);
		     j = j + l;

		     if j = 5
		     then do;

			     j = 0;
			     p -> print_line = op_space || nl;
			     char_off = char_off + 116;
			     p = addr (substr (char_string, char_off, 1));
			     op_space = (115)" ";

			end;

		end;

	     link_ptr = addrel (link_ptr, 2);

	end;

	if j ^= 0
	then do;
		p -> print_line = substr (op_space, 1, j * 23) || nl;
		char_off = char_off + j * 23 + 1;

	     end;

	cobol_$list_off = char_off;

	call hcs_$set_bc_seg (cobol_$list_ptr, 9 * (cobol_$list_off - 1), mcode);

exit_print_map:
	return;

     end print_map;



/*************************************/
multics_error:
	error_info.name = "cobol_paste";
	call convert_status_code_ (code, short_mes, long_mes);
	call ioa_$rsnnl ("^a  Can't create object segment ^a in directory ^a", error_info.message,
	     error_info.message_len, long_mes, cobol_$obj_seg_name, get_wdir_ ());
	call signal_ ("command_abort_", null, addr (error_info));

abort:
	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_object_map;
/* [3.0-1] */
%include cobol_fixup_value;
%include cobol_relinfo;
%include cobol_sbh;
%include cobol_error_info;
%include cobol_;
%include cobol_fixed_common;
%include cobol_ext_;

%include cobol_entry_seq;
%include cobol_linkage_header;
%include cobol_fixed_static;
     end cobol_paste;




		    cobol_patch.pl1                 05/24/89  1042.8rew 05/24/89  0832.7       38232



/****^  ***********************************************************
        *                                                         *
        * 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_patch.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 3.0 */
/*{*/
/* format: style3 */
cobol_patch:
     proc (value_ptr);

/* This procedure is called by cobol_fixup_driver_
to perform all fixed patches to the object segment.
These are as follows:

  In the text section:

     1) set instruction address field (offset 1, lower half)
        to maximum stack size used modulo 16.


     In the definition section:

     1) add to the value field in the Type 0 definition the
        word length of the constants.

     2) if flags.descr_sw = "1"b in the Type 0 definition,
        add to each descriptor relp the word length of the
        constants.


  In the linkage section:

     1) In the header, set def_section_relp to the word length
        of the constants plus the word length of the text section.

     2) In the header, set linkage_section_length to the word
        length of then linkage section.

     3) In the static data area, set stat.data_len to the word
        length of the cobol data used modulo 4.
/*}*/
dcl	utemp		fixed bin;
dcl	(i, temp)		fixed bin;


/*************************************/
start:
	utemp = cobol_$max_stack_off + 15;		/*6/14/76*/
	text_ptr = cobol_$text_base_ptr;
	substr (entry_seq.eax7, 1, 18) = substr (unspec (utemp), 19, 14) || "0000"b;
						/* modulo 16 */

	def_ptr = addrel (cobol_$def_base_ptr, fixed (def_header.def_list_relp, 18));
	do while (definition.class ^= "000"b);
	     def_ptr = addrel (cobol_$def_base_ptr, fixed (definition.forward_thread, 18));
	end;
	do while (definition.class = "000"b);
	     text_ptr = addrel (cobol_$text_base_ptr, fixed (definition.value, 28) - 2);
	     value.exec_off = fixed (definition.value, 28) - 2;
	     utemp = fixed (definition.value, 18) + value.con_len;
	     definition.value = substr (unspec (utemp), 19, 18);
	     if entry_seq.flags.has_descriptors
	     then do;
		     utemp = fixed (entry_seq.descr_relp_offset, 18) + 1;
		     parm_desc_ptr = addrel (cobol_$con_end_ptr, utemp);
		     do i = 1 to parm_desc.n_args;
			utemp = fixed (parm_desc.descriptor_relp (i), 18) + value.con_len;
			parm_desc.descriptor_relp (i) = substr (unspec (utemp), 19, 18);
		     end;
		     utemp = fixed (entry_seq.descr_relp_offset, 18) + value.con_len;
		     entry_seq.descr_relp_offset = substr (unspec (utemp), 19, 18);
		end;
	     def_ptr = addrel (cobol_$def_base_ptr, fixed (definition.forward_thread, 18));
	end;

	linkage_header.def_section_relp = substr (unspec (value.text_len), 19, 18);
	linkage_header.linkage_section_length = substr (unspec (value.link_len), 19, 18);
	stat_ptr = addrel (cobol_$link_base_ptr, 8);
	utemp = cobol_$cobol_data_wd_off + 3;		/*08-26-77*/
	stat.data_len = fixed (substr (unspec (utemp), 17, 18), 18) * 4;
						/* modulo 4 */

	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_fixup_value;

%include cobol_entry_seq;
%include cobol_definitions;
%include cobol_linkage_header;
/* [3.0-1] */
%include cobol_fixed_static;
%include cobol_;
     end cobol_patch;




		    cobol_perform_gen.pl1           05/24/89  1042.8rew 05/24/89  0832.7      230436



/****^  ***********************************************************
        *                                                         *
        * 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_perform_gen.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 06/20/80 by FCH, [4.2-1], dont call cobol_addr if in-line perform */
/* Modified on 06/20/79 by FCH, [4.0-1], in-line performs added for debug */
/* Modified since Version 4.0 */

/* format: style3 */
cobol_perform_gen:
     proc (in_token_ptr);


declare	bit_18		bit (18) based,		/* 18-bit temp used to address id_10_fb*/
	code_ptr		ptr,			/* Working pointer used to locate 	   */
						/* appropriate position in code seq.   */
	con_tag		(3) fixed bin,		/* Tags associated with first inst of  */
						/* Format 4 condition code sequences.  */
	eop_proc_no	fixed bin,		/* Procedure no of procedure at end of */
						/* perform range.		   */
	er_loc		fixed bin,		/* Location of first inst of call to   */
						/* cobol_error_.		   */
	false_tag		fixed bin,		/* Tag associated with condition false.*/
	format_no		fixed bin,		/* Format no of PERFORM statement being*/
						/* processed.			   */
	i_tag		fixed bin,		/* Tag to be associated with loc_i in  */
						/* Formats 3 and 4.		   */
	id_tok_no		(4) fixed bin,		/* Token no of Format 4 varying ids.   */
						/* id_tok_no(varying_ids) containg no  */
						/* of tokens in perform statement + 1. */
	index		fixed bin,		/* Do loop index.		   */
	init_req_flag	fixed bin,		/* Set to 1 if seg initialization not  */
						/* required; to 2, if it is.	   */
	init_tag		fixed bin,		/* Tag associated with first instruc-  */
						/* tion of code generated to initial-  */
						/* ize alterable GO's in COBOL segment */
						/* containing procedure-name-1.	   */
	integer		fixed bin,		/* If non-zero, fixed bin value of	   */
						/* integer-1.			   */
	jndex		fixed bin,		/* Do loop index.		   */
	lit_ptr		ptr,			/* Working ptr used in determining     */
						/* value of integer-1.	 	   */
	lit_str		(30) bit (9) /* Bit string array used in determin-  */ unaligned based,
						/* ing value of integer-1.	   */
	lo_lim		fixed bin,		/* From - to limits of do loop index   */
	hi_lim		fixed bin,		/* used in processing conditions.	   */
	next_stmt_tag	fixed bin,		/* Tag associated with next executable */
						/* statement following procedure at    */
						/* end of perform range.		   */
	no_inst		fixed bin,		/* No instructions to be emitted.	   */
	no_tokens		fixed bin,		/* No of tokens in statement.	   */
	p_token_ptr	ptr,			/* Pointer to area currently being used*/
						/* for building in_token structure     */
						/* passed to cobol_arithop_gen and/or     */
						/* cobol_compare_gen.		   */
	p1_token_ptr	ptr,			/* Pointers to areas reserved for      */
	p2_token_ptr	ptr,			/* building in_token structure passed  */
						/* to cobol_arithop_gen and/or 	   */
						/* to cobol_compare_gen.		   */
	s_tag		fixed bin,		/* Utility tag.		   	   */
	space_req		fixed bin,		/* Approximate space required for      */
						/* in_token structure containing input */
						/* for cobol_arithop_gen and/or	   */
						/* cobol_compare_gen.		   */
	stackoff		fixed bin,		/* Offset of wd allocated in stack.	   */
	temp		fixed bin,		/* Temporary used for calculations.    */
	pn1_no		fixed bin,		/* Procedure no of procedure at 	   */
						/* beginning of perform range.	   */
	pn1_priority	fixed bin,		/* COBOL segment no of seg containing  */
						/* procedure-name-1.		   */
	temp_chars	fixed bin (24),		/* Number of characters in COBOL data  */
						/* segment required for temporaries.   */
	type		fixed bin,		/* Token type.			   */
	varying_ids	fixed bin,		/* No of identifiers varied in Format 4*/
	wk_ptr		ptr;			/* Ptr to token of current interest.   */

dcl	temp_wk_ptr	ptr;
dcl	move_token_ptr	ptr;
dcl	dn_ptr		ptr;
dcl	keep_scanning	bit (1);			/*[4.0-1]*/
declare	(L1, L2, L3)	fixed bin,
	out_line		bit (1);


/*  Functions common to all formats			   */

/*  Determine format number of statement being processed.	   */

start:
	no_tokens = in_token.n;			/*[4.0-1]*/
	eos_ptr = in_token.token_ptr (no_tokens);	/*[4.0-1]*/
	format_no = binary (eos_ptr -> end_stmt.a, 17) + 1;

/*[4.0-1]*/
	if end_stmt.d = "00"b
	then out_line = "1"b;
	else out_line = "0"b;

/*  Is segment initialization required?			   */

	init_req_flag = 1;

/*[4.0-1]*/
	if out_line				/*[4.0-1]*/
	then do;
		if cobol_$seg_init_list_ptr ^= null ()
		then do;
			pn1_priority = binary (unspec (in_token.token_ptr (2) -> proc_ref.priority), 17);
			if cobol_$priority_no ^= pn1_priority
			then if pn1_priority > 49
			     then do index = 1 to seg_init_list.n;
				     if seg_init_list.seg.priority (index) = pn1_priority
				     then do;
					     init_req_flag = 2;
					     init_tag = seg_init_list.seg.int_tag_no (index);
					     goto next_step;
					end;

				end;

		     end;

/*[4.0-1]*/
	     end;

next_step:					/*  Extract beginning-of-perform range procedure number from   */
						/*  second token.					   */
						/*[4.0-1]*/
	L1, pn1_no = in_token.token_ptr (2) -> proc_ref.proc_num;

/*  Extract end_of_perform range procedure number from third   */
/*  token, locate this procedure number in perform_list and    */
/*  extract target_a_PN2 segno and char offset, and the tag    */
/*  associated with the "next executable statement".	   */

/*[4.0-1]*/
	L3, eop_proc_no = in_token.token_ptr (3) -> proc_ref.proc_num;

/*[4.0-1]*/
	if out_line				/*[4.0-1]*/
	then do index = 1 to perform_list.n;
		if perform_list.perf.proc_num (index) = eop_proc_no
		then do;
			if in_token.token_ptr (no_tokens) -> end_stmt.h = 1
			then if perform_list.perf.proc_num (index + 1) = eop_proc_no
			     then index = index + 1;

			target.segno = perform_list.perf.target_a_segno (index);
			target.char_offset = perform_list.perf.target_a_offset (index);
			next_stmt_tag = abs (perform_list.perf.int_tag_no (index));
			goto format (format_no);
		     end;

	     end;

/*[4.0-1]*/
	else go to format (format_no);

/*  		End of Common Functions		   */

/*  Process Format 1 PERFORM statements			   */

format (1):					/*[4.0-1]*/
	if ^out_line
	then return;

	call cobol_register$load (addr (register_request));

	if init_req_flag = 1
	then code_ptr = addr (seq2 (3));

	else code_ptr = addr (seq2i (3));

/*[4.2-1]*/
	if out_line
	then call cobol_addr (addr (target), addrel (code_ptr, 1), null ());
	call cobol_emit (code_ptr, null (), init_req_flag + 2);
	call cobol_make_tagref (pn1_no, cobol_$text_wd_off - init_req_flag, null ());

	if init_req_flag = 2
	then call cobol_make_tagref (init_tag, cobol_$text_wd_off - 1, null ());

	call cobol_reset_r$in_line;
	call cobol_register$load (addr (register_request));
						/*[4.2-1]*/
	if out_line
	then call cobol_addr (addr (target), addr (seq3 (13)), null ());
	call cobol_emit (addr (seq3 (11)), null (), 2);
	call cobol_make_tagref (next_stmt_tag, cobol_$text_wd_off - 2, null ());
	call cobol_reset_r$in_line;

	return;

/*  Process Format 2 PERFORM statements		   */

format (2):
	if in_token.token_ptr (4) -> numeric_lit.type = 2
	then do;
		integer = 0;
		lit_ptr = addr (in_token.token_ptr (4) -> numeric_lit.literal);

		do index = 1 to in_token.token_ptr (4) -> numeric_lit.places while (integer < 131072);
		     integer = integer * 10 + binary (substr (lit_ptr -> lit_str (index), 6, 4), 17);
		end;

		temp_chars = 4;
	     end;

	else temp_chars = 8;

	call cobol_alloc$cobol_data (temp_chars, 2, count.char_offset);
	call cobol_register$load (addr (register_request));

	if init_req_flag = 1
	then code_ptr = addr (seq2);

	else code_ptr = addr (seq2i);

	count.char_offset = count.char_offset * 4;

	call cobol_addr (addr (count), code_ptr, null ());/*[4.2-1]*/
	if out_line
	then call cobol_addr (addr (target), addrel (code_ptr, 2), null ());

	if temp_chars = 8
	then do;
		if (in_token.token_ptr (4) -> data_name.bin_36 | in_token.token_ptr (4) -> data_name.bin_18)
		then do;				/*  Identifier specifying number of times to PERFORM is long or short binary.  */

/*  Make a data name token for the temporary to receive the long or short binary.  */
			temp_wk_ptr = null ();
			call cobol_make_type9$long_bin (temp_wk_ptr, 2 /*cobol data */, count.char_offset + 4);

			move_token_ptr = addr (move_in_token (1));

			if move_data_init ^= cobol_$compile_count
			then do;			/*  Initialize structure used in calls to the move generator.  */

				move_token_ptr -> in_token.token_ptr (1) = null ();
				move_token_ptr -> in_token.token_ptr (4) = addr (move_eos);
				move_token_ptr -> in_token.n = 4;
				move_data_init = cobol_$compile_count;
			     end;			/*  Initialize structure used in calls to the move geerator.  */

			move_token_ptr -> in_token.token_ptr (2) = in_token.token_ptr (4);
						/*  long or short bin item  */
			move_token_ptr -> in_token.token_ptr (3) = temp_wk_ptr;
						/*  temporary in cobol data  */

			call cobol_move_gen (move_token_ptr);

/*  Emit code to set indicators from storage (the value just moved to cobol data)
			and transfer to error routine if zero or negative.  */

			szn_seq (1) = code_ptr -> bit_18;
			temp = binary (substr (szn_seq (1), 4, 15)) + 1;
						/*  address portion  */
			substr (szn_seq (1), 4, 15) = substr (unspec (temp), 22, 15);
			call cobol_emit (addr (szn_seq (1)), null (), 1);
						/*  SZN from temp  */

			call cobol_emit (addr (seq1 (7)), null (), 1);
						/*  tmoz  */

			seq3 (7) = szn_seq (1);

		     end;				/*  Identifier specifying the number of times to perform is long or short binary.  */

		else do;				/*  Identifier is unpacked or packed decimal, or overpunch sign data  */

			if (in_token.token_ptr (4) -> data_name.item_signed
			     & in_token.token_ptr (4) -> data_name.sign_separate = "0"b)
			then do;			/*  Overpunch sign data.  */

				input_struc.token_ptr = null ();
				call cobol_num_to_udts (in_token.token_ptr (4), input_struc.token_ptr);

			     end;			/*  Overpunch sign data.  */

			else input_struc.token_ptr = in_token.token_ptr (4);

			call cobol_addr (addr (input_struc), addr (seq1), null ());
			seq1 (1) = "000000000001000000"b;
			seq1 (5) = code_ptr -> bit_18;
			temp = binary (substr (seq1 (5), 4, 15), 17) + 1;
			substr (seq1 (5), 4, 15) = substr (unspec (temp), 22, 15);

			call cobol_emit (addr (seq1), null (), 4);

			seq3 (7) = seq1 (5);

		     end;				/*  Identifier is unpacked or packed decimal, or overpunch sign data.  */

		seq3 (8) = cmpq_id_10;

/*[4.0-1]*/
		if out_line			/*[4.0-1]*/
		then call cobol_make_tagref (cobol_$next_tag, cobol_$text_wd_off - 1, null ());
						/*[4.0-1]*/
		else call cobol_make_tagref (eop_proc_no, cobol_$text_wd_off - 1, null ());

	     end;

	else do;
		seq3 (7) = substr (unspec (integer), 19, 18);
		seq3 (8) = cmpq_int_1;
	     end;

/*[4.0-1]*/
	if out_line				/*[4.0-1]*/
	then do;

		call cobol_emit (code_ptr, null (), init_req_flag + 3);
		call cobol_make_tagref (pn1_no, cobol_$text_wd_off - init_req_flag, null ());

/*[4.0-1]*/
	     end;					/*[4.0-1]*/
	else do;
		L2 = cobol_$next_tag;		/*[4.0-1]*/
		cobol_$next_tag = cobol_$next_tag + 1;

/*[4.0-1]*/
		call cobol_emit (addr (seq2 (1)), null (), 1);
						/*[4.0-1]*/
		call cobol_emit (addr (seq2 (7)), null (), 1);
						/*[4.0-1]*/
		call cobol_make_tagref (L2, cobol_$text_wd_off - 1, null ());
						/*[4.0-1]*/
		call cobol_define_tag_nc (L1, cobol_$text_wd_off);
						/*[4.0-1]*/
	     end;

	if init_req_flag = 2
	then call cobol_make_tagref (init_tag, cobol_$text_wd_off - 1, null ());

	call cobol_reset_r$in_line;
	call cobol_register$load (addr (register_request));
	call cobol_addr (addr (count), addr (seq3 (1)), null ());
	seq3 (5) = seq3 (1);			/*[4.2-1]*/
	if out_line
	then call cobol_addr (addr (target), addr (seq3 (13)), null ());

/*[4.0-1]*/
	if out_line				/*[4.0-1]*/
	then do;

		call cobol_emit (addr (seq3), null (), 7);
		call cobol_make_tagref (pn1_no, cobol_$text_wd_off - 3, null ());
		call cobol_make_tagref (next_stmt_tag, cobol_$text_wd_off - 2, null ());

/*[4.0-1]*/
	     end;					/*[4.0-1]*/
	else do;
		call cobol_emit (addr (seq3), null (), 5);
		call cobol_make_tagref (L2, cobol_$text_wd_off - 1, null ());
						/*[4.0-1]*/
		call def_L2;			/*[4.0-1]*/
	     end;

	call cobol_reset_r$in_line;

	if temp_chars = 8
	then /*[4.0-1]*/
	     if out_line
	     then do;
		     call cobol_define_tag_nc (cobol_$next_tag, cobol_$text_wd_off);
		     cobol_$next_tag = cobol_$next_tag + 1;
		end;

	return;

set_false_tag:
     proc;

/*[4.0-1]*/
	if out_line				/*[4.0-1]*/
	then false_tag = pn1_no;			/*[4.0-1]*/
	else do;
		false_tag, L2 = cobol_$next_tag;	/*[4.0-1]*/
		cobol_$next_tag = cobol_$next_tag + 1;	/*[4.0-1]*/
	     end;

     end;

format (3):					/*  Set alterable GO at end of PN2.  */
	seq4 (3) = "000000000000000010"b;
	call cobol_register$load (addr (register_request));
	if init_req_flag = 1
	then do;
		code_ptr = addr (seq4 (3));

/*[4.0-1]*/
		call set_false_tag;

	     end;

	else do;
		code_ptr = addr (seq4);
		i_tag = cobol_$next_tag;
		false_tag = i_tag;
		cobol_$next_tag = cobol_$next_tag + 1;
		call cobol_alloc$cobol_data (4, 2, count.char_offset);
		count.char_offset = count.char_offset * 4;

		call cobol_addr (addr (count), code_ptr, null ());

	     end;

/*[4.2-1]*/
	if out_line
	then call cobol_addr (addr (target), addr (seq4 (5)), null ());

/*[4.0-1]*/
	if out_line				/*[4.0-1]*/
	then call cobol_emit (code_ptr, null (), init_req_flag + 1);
						/*[4.0-1]*/
	else call cobol_define_tag_nc (L1, cobol_$text_wd_off);

	call cobol_reset_r$in_line;

/*  Get space for token structure.  */

	space_req = no_tokens * 2 - 6;
	call get_token_space;

/*  Process condition-1.  */

	lo_lim = 4;
	hi_lim = no_tokens - 1;

	call process_condition;

/*  Reset alterable GO at end of PN2.  */

	call reset_f_3_4;

/*[4.0-1]*/
	if ^out_line
	then call def_L2;

	return;

def_L2:
     proc;

/*[4.0-1]*/
	call cobol_emit (addr (seq2 (7)), null (), 1);	/*[4.0-1]*/
	call cobol_make_tagref (L3, cobol_$text_wd_off - 1, null ());
						/*[4.0-1]*/
	call cobol_define_tag_nc (L2, cobol_$text_wd_off);

     end;
format (4):					/*  Get token numbers of pointers to varying identifiers and */
						/*  compute space required for token structure to be passed  */
						/*  to generators.				   */
	varying_ids = in_token.token_ptr (no_tokens) -> end_stmt.e;


	index = 1;
	jndex = 4;
	id_tok_no (index) = jndex;
	if index = varying_ids
	then keep_scanning = "0"b;
	else do;
		keep_scanning = "1"b;
		index = index + 1;
		jndex = jndex + 3;
	     end;

	do while (keep_scanning);			/*  Scan to find all varying identifiers.  */
	     if (in_token.token_ptr (jndex) -> end_stmt.type = 1
		& in_token.token_ptr (jndex) -> reserved_word.key = 72 /* AFTER */)
	     then do;				/*  Found reserved word AFTER.  */
						/*  Next token is the VARYING identifier.  */
		     id_tok_no (index) = jndex + 1;
		     if index = varying_ids
		     then keep_scanning = "0"b;
		     else do;
			     index = index + 1;
			     jndex = jndex + 3;
			end;
		end;				/*  Found reserved word AFTER.  */
	     else jndex = jndex + 1;
	end;					/*  Scan to find all varying identifiers.  */

	id_tok_no (varying_ids + 1) = no_tokens + 1;
	space_req = 0;

	do index = varying_ids to 1 by -1;
	     if (id_tok_no (index + 1) - id_tok_no (index)) * 2 - 6 > space_req
	     then space_req = (id_tok_no (index + 1) - id_tok_no (index)) * 2 - 6;

	end;

	call get_token_space;

/*  Generate call to cobol_error.			   */

	do index = 1 to varying_ids;
	     if in_token.token_ptr (id_tok_no (index) + 2) -> end_stmt.type = 9
	     then do;
		     call cobol_alloc$stack (4, 1, stackoff);
		     substr (ret_inst (1), 4, 15) = substr (unspec (stackoff), 22, 15);
		     tra_inst (3) = ret_inst (1);
		     s_tag = cobol_$next_tag;
		     cobol_$next_tag = cobol_$next_tag + 1;

		     call cobol_pointer_register$get (addr (ptr_register_request));
		     call cobol_emit (addr (tra_inst), null (), 3);
		     call cobol_make_tagref (s_tag, cobol_$text_wd_off - 1, null ());

		     er_loc = cobol_$text_wd_off;

		     call cobol_process_error (44, in_token.token_ptr (1) -> end_stmt.line, 0);
		     call cobol_emit (addr (ret_inst), null (), 1);
		     call cobol_define_tag (s_tag);

		     goto end_loop;
		end;

	end;

end_loop:						/*  Initialize varying identifiers.			   */
	p_token_ptr -> in_token.n = 4;
	p_token_ptr -> in_token.code = 0;
	p_token_ptr -> in_token.token_ptr (1) = in_token.token_ptr (1);
	p_token_ptr -> in_token.token_ptr (4) = addr (eos_token);
	eos_token.e = 1;

	do index = 1 to varying_ids;
	     call init_var_id;
	end;

/*  Get tags to be associated with first instruction of	   */
/*  condition code sequences.			   */

	do index = 1 to varying_ids;
	     con_tag (index) = cobol_$next_tag;
	     cobol_$next_tag = cobol_$next_tag + 1;
	end;

/*  Set alterable GO at end of PN2.			   */

	seq4 (3) = "000000000000000011"b;
	call cobol_register$load (addr (register_request));
	if init_req_flag = 1
	then do;
		code_ptr = addr (seq4 (3));

/*[4.0-1]*/
		call set_false_tag;

	     end;

	else do;
		code_ptr = addr (seq4);
		i_tag = cobol_$next_tag;
		false_tag = i_tag;
		cobol_$next_tag = cobol_$next_tag + 1;
		call cobol_alloc$cobol_data (4, 2, count.char_offset);
		count.char_offset = count.char_offset * 4;
		call cobol_addr (addr (count), code_ptr, null ());
	     end;

/*[4.2-1]*/
	if out_line
	then call cobol_addr (addr (target), addr (seq4 (5)), null ());

/*[4.0-1]*/
	if out_line				/*[4.0-1]*/
	then call cobol_emit (code_ptr, null (), init_req_flag + 2);
						/*[4.0-1]*/
	else call cobol_emit (addr (seq4 (7)), null (), 1);

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

/*[4.0-1]*/
	if ^out_line
	then call cobol_define_tag_nc (L1, cobol_$text_wd_off);

	call cobol_reset_r$in_line;

/*  BY identifier zero?				   */

	do index = varying_ids to 1 by -1;
	     if in_token.token_ptr (id_tok_no (index) + 2) -> end_stmt.type = 9
	     then do;
		     p_token_ptr -> in_token.n = 2;
		     p_token_ptr -> in_token.code = 0;
		     p_token_ptr -> in_token.token_ptr (1) = in_token.token_ptr (id_tok_no (index) + 2);
		     p_token_ptr -> in_token.token_ptr (2) = addr (eos_token);
		     s_tag = cobol_$next_tag;
		     eos_token.h = s_tag;
		     eos_token.verb = 13;
		     eos_token.e = 180;
		     unspec (eos_token.i) = "010000000000000000000000000000000000"b;
		     cobol_$next_tag = cobol_$next_tag + 1;

		     call cobol_compare_gen (p_token_ptr);

		     temp = stackoff + 1;
		     substr (seq6 (1), 4, 15) = substr (unspec (temp), 22, 15);
		     temp = er_loc - cobol_$text_wd_off - 1;
		     seq6 (3) = substr (unspec (temp), 19, 18);

		     call cobol_emit (addr (seq6), null (), 2);
		     call cobol_define_tag_nc (s_tag, cobol_$text_wd_off);

		end;

/*  Increment varying identifier.			   */

	     p_token_ptr -> in_token.n = 4;
	     p_token_ptr -> in_token.code = 0;
	     p_token_ptr -> in_token.token_ptr (1) = in_token.token_ptr (1);
	     p_token_ptr -> in_token.token_ptr (4) = addr (eos_token);
	     eos_token.e = 1;
	     eos_token.b = "0"b;
	     if in_token.token_ptr (id_tok_no (index)) -> end_stmt.type = 9
	     then do;
		     p_token_ptr -> in_token.token_ptr (2) = in_token.token_ptr (id_tok_no (index) + 2);
		     p_token_ptr -> in_token.token_ptr (3) = in_token.token_ptr (id_tok_no (index));
		     eos_token.a = "000"b;
		     eos_token.h = 1;
		     eos_token.verb = 2;

		     call cobol_add_gen (p_token_ptr, s_tag);

		end;

	     else do;
		     ind_ptr = in_token.token_ptr (id_tok_no (index));
		     p_token_ptr -> in_token.token_ptr (2) = ind_ptr;
		     index_name.max = index_name.max + 1;
		     p_token_ptr -> in_token.token_ptr (3) = in_token.token_ptr (id_tok_no (index) + 2);
		     eos_token.a = "001"b;
		     eos_token.verb = 31;

		     call cobol_set_gen (p_token_ptr);

		end;

/*  Process condition.				   */

	     call cobol_define_tag (con_tag (index));
	     lo_lim = id_tok_no (index) + 3;
	     hi_lim = id_tok_no (index + 1) - 2;

	     call process_condition;

/*  Set false tag for next pass and initialize varying id.   */

	     if index > 1
	     then do;
		     false_tag = con_tag (index);
		     p_token_ptr -> in_token.n = 4;
		     p_token_ptr -> in_token.code = 0;
		     p_token_ptr -> in_token.token_ptr (1) = in_token.token_ptr (1);
		     p_token_ptr -> in_token.token_ptr (4) = addr (eos_token);
		     eos_token.e = 1;

		     call init_var_id;

		end;

	end;

/*  Reset alterable GO at end of PN2.			   */

	call reset_f_3_4;

/*[4.0-1]*/
	if ^out_line
	then call def_L2;

	return;

format (7):					/*[4.0-1]*/
	call cobol_emit (addr (seq2 (7)), null (), 1);	/*[4.0-1]*/
	call cobol_make_tagref (end_stmt.e, cobol_$text_wd_off - 1, null ());
						/*[4.0-1]*/
	call cobol_define_tag_nc (end_stmt.h, cobol_$text_wd_off);

/*[4.0-1]*/
	return;

format (8):					/*[4.2-1]*/
	if out_line
	then call cobol_addr (addr (target), addr (seq8 (3)), null ());
	call cobol_emit (addr (seq8), null (), 3);
	call cobol_make_tagref (pn1_no, cobol_$text_wd_off - 1, null ());

	return;

get_token_space:
     proc;

	if binary (rel (temp_token_ptr), 17) + space_req * 2 > 262143
	then do;
signal_ovfl_error:
		call signal_ ("command_abort_", null (), addr (seg_ovfl_error));
		goto signal_ovfl_error;
	     end;

	if substr (rel (temp_token_ptr), 18, 1) = "1"b
	then temp_token_ptr = addrel (temp_token_ptr, 1);

	p1_token_ptr = temp_token_ptr;
	temp_token_ptr = addrel (temp_token_ptr, space_req);
	p2_token_ptr = temp_token_ptr;
	temp_token_ptr = addrel (temp_token_ptr, space_req);
	p_token_ptr = p1_token_ptr;

	return;

     end get_token_space;

init_var_id:
     proc;

	if in_token.token_ptr (id_tok_no (index)) -> end_stmt.type = 9
	     & in_token.token_ptr (id_tok_no (index) + 1) -> end_stmt.type ^= 10
	then do;
		p_token_ptr -> in_token.token_ptr (2) = in_token.token_ptr (id_tok_no (index) + 1);
		p_token_ptr -> in_token.token_ptr (3) = in_token.token_ptr (id_tok_no (index));
		eos_token.verb = 18;
		call cobol_move_gen (p_token_ptr);
	     end;

	else do;
		p_token_ptr -> in_token.token_ptr (2) = in_token.token_ptr (id_tok_no (index));
		p_token_ptr -> in_token.token_ptr (3) = in_token.token_ptr (id_tok_no (index) + 1);
		eos_token.verb = 31;
		eos_token.a = "000"b;
		call cobol_set_gen (p_token_ptr);
	     end;

	return;

     end init_var_id;

reset_f_3_4:
     proc;

	call cobol_register$load (addr (register_request));
	if init_req_flag = 1
	then no_inst = 2;

	else do;
		no_inst = 8;
		call cobol_addr (addr (count), addr (seq5 (7)), null ());
		seq5 (11) = seq5 (7);
	     end;

/*[4.2-1]*/
	if out_line				/*[4.2-1]*/
	then do;
		call cobol_addr (addr (target), addr (seq5 (3)), null ());
						/*[4.2-1]*/
		call cobol_emit (addr (seq5), null (), no_inst);




/*[4.2-1]*/
		call cobol_make_tagref (next_stmt_tag, cobol_$text_wd_off - no_inst, null ());
						/*[4.2-1]*/
	     end;

	if init_req_flag = 2
	then do;
		call cobol_make_tagref (pn1_no, cobol_$text_wd_off - 4, null ());
		call cobol_make_tagref (pn1_no, cobol_$text_wd_off - 2, null ());
		call cobol_make_tagref (init_tag, cobol_$text_wd_off - 1, null ());
		call cobol_define_tag_nc (i_tag, cobol_$text_wd_off - 5);
	     end;

	call cobol_pointer_register$priority (4, 4, "000"b);

	return;

     end reset_f_3_4;

process_condition:
     proc;

	p_token_ptr -> in_token.n = 0;
	p_token_ptr -> in_token.code = 0;

	do jndex = lo_lim to hi_lim;
	     wk_ptr = in_token.token_ptr (jndex);
	     type = wk_ptr -> end_stmt.type;
	     if type = 30
	     then if wk_ptr -> int_tag.perform_bit = "1"b & wk_ptr -> int_tag.true_path = "0"b
		then do;
			equate_tag.equated_tag = wk_ptr -> int_tag.proc_num;
			equate_tag.true_tag = false_tag;
			call cobol_equate_tag (addr (equate_tag));
		     end;

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

	     else do;
		     p_token_ptr -> in_token.n = p_token_ptr -> in_token.n + 1;
		     p_token_ptr -> in_token.token_ptr (p_token_ptr -> in_token.n) = wk_ptr;
		     if type = 19
		     then do;
			     if wk_ptr -> end_stmt.verb = 13
			     then call cobol_compare_gen (p_token_ptr);

			     else call cobol_arithop_gen (p_token_ptr);

			     if p_token_ptr -> in_token.code > 0
			     then p_token_ptr -> in_token.n = p_token_ptr -> in_token.code;

			     else do;
				     if p_token_ptr -> in_token.code = -1
				     then if p_token_ptr -> in_token.code = -1
					then if p_token_ptr = p1_token_ptr
					     then p_token_ptr = p2_token_ptr;

					     else p_token_ptr = p1_token_ptr;

				     p_token_ptr -> in_token.n = 0;
				end;

			     p_token_ptr -> in_token.code = 0;
			end;

		end;

	end;

	return;

     end process_condition;

%include cobol_perform_gen_info;
%include cobol_perform_gen_data;

     end cobol_perform_gen;




		    cobol_pointer_register.pl1      05/24/89  1042.8rew 05/24/89  0837.3      185616



/****^  ***********************************************************
        *                                                         *
        * 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_pointer_register.pl1 Added Trace statements.
                                                   END HISTORY COMMENTS */


/* Modified on 11/19/84 by FCH, [4.3-1}, BUG563(phx18381), new cobol_addr_tokens.incl.pl1 */
/* Modified on 09/08/83 by FCH, [5.2...], trace added */
/* Modified on 01/14/77 by ORN to signal command_abort rather than cobol_compiler_error */
/* Modified since Version 2.0 */

/*{*/
/* format: style3 */
cobol_pointer_register:
     proc;					/* the procedure is not a valid entry point */
						/*}*/
	return;


/*************************************/
/*{*/
call:
     entry;

/*
This entry is called immediately before a call is to be generated;
thus PR0 must point to cobol_operators, PR4 must point to linkage
section; and PR2 will be destroyed.
}*/
start_call:
	return;					/* for now */


/*************************************/
/*{*/
get:
     entry (struc_ptr);				/*
This entry obtains a pointer register for the caller.
	*/
dcl	struc_ptr		ptr;			/*
struc_ptr is a pointer to the following structure. (input)
 */

dcl	1 structure	based (struc_ptr),
	  2 what_pointer	fixed bin,
	  2 pointer_no	bit (3),
	  2 lock		fixed bin,
	  2 switch	fixed bin,
	  2 segno		fixed bin,
	  2 offset	fixed bin (24),
	  2 reset		fixed bin;

/*
 what_pointer specifies the pointer register to be obtained.
	(input)
	0-7 - get this pointer register.
	 10 - get any temporary pointer register.
 pointer_no is the register that is assigned, in the
	range 0-7. (output)
 lock	can have the following values. (input)
	0 - do not change the lock or unlock status
	    of this pointer.
	1 - lock the pointer register.
	2 - unlock all pointer registers.
	3 - unlock all pointer registers and A register
	    and Q register and all index registers.
 switch	has the following values. (input)
	0 - the register will not contain a value
	    that is meaningful for register optimization.
	    Segment number and offset are meaningless.
	1 - a segment number and word offset are supplied.
	2 - a segment number and character offset are supplied
 segno 	is the segment number. (input)
	values recognized are:
	    2 - cobol data.
	 1000 - stack.
	 3000 - constants.
	 3002 - multics linkage.
	 4000 - cobol operators.
	2nnnn - cobol linkage.
	   -n - link in multics linkage.
 offset	is the word or character offset (depending on switch).
	Any case when the offset is meaningless a 0 value
	must be used. 
	If a character offset is provided only the word
	portion is meaningful. (input)
 reset	specifies that the caller has requested a register
	that must have a preset value. For example a preset
	register to cobol data or the pointer to pl/1 operators
	(likely). This is only of interest to callers
	who request a specific register (what_pointer = 0-7)
	Such callers should test reset. If it is 1, a call to
	cobol_reset_r should be made in order
	to emit instructions to reload the register to
	its proper value.

 Notes:
 1. If switch has a non zero value and the pointer register
   does not contain the specified segno and offset this
   utility will emit instructions to load
   the pointer register.
 2. (a) Generally a register should not be locked.
   (b) Exceptions would be the case when  (1) several
	  calls must be make to this utility and the caller
	  does not wish to obtain the same register (2) Calls
	  to this utility are interspurced with calls to the
	  addressability utilities and the user does not wish to
	  obtain the same register.
 3. There is no need to call to get pointer register 6 (the
   stack frame). We can always assume this is set.
 4. If the caller requests a specific pointer register
   who's priority was lock a compile time error will occur.
   This may change if we need more sophisticated
   pointer register handling.
 */


/*}*/
dcl	1 reg_err		static,
	  2 name		char (32) init ("cobol_register$get"),
	  2 message_len	fixed bin (35) init (30),
	  2 message	char (30) init ("Unable to get a register");
dcl	1 ptr_err		static,
	  2 name		char (32) init ("cobol_register$get"),
	  2 message_len	fixed bin (35) init (30),
	  2 message	char (30) init ("unable to get pointer register");
dcl	1 contents_err	static,
	  2 name		char (32) init ("cobol_pointer_register$get"),
	  2 message_len	fixed bin init (53),
	  2 message	char (54) init ("Attempt to load invalid contents into pointer register");
dcl	(i, k, m)		fixed bin;
dcl	save_i		fixed bin;
dcl	best_yet		fixed bin;
dcl	best_current	fixed bin;
dcl	new_wd_off	fixed bin (24);
dcl	call_pr_num	bit (3);
dcl	reloc_ptr		ptr;
dcl	call_off		fixed bin (24);
dcl	1 inst		(10) aligned,
	  2 i_y		unaligned,
	    3 i_pr	bit (3) unaligned,
	    3 i_off	bit (15) unaligned,
	  2 i_op		bit (10) unaligned,
	  2 i_zero	bit (1) unaligned,
	  2 i_ar		bit (1) unaligned,
	  2 i_tm		bit (2) unaligned,
	  2 i_td		bit (4) unaligned;
dcl	1 reloc		(20) aligned,
	  2 r_left	bit (5) aligned,
	  2 r_right	bit (5) aligned;
dcl	cobol_emit	entry (ptr, ptr, fixed bin);	/*  DECLARATION OF EXTERNAL ENTRIES  */

dcl	cobol_register_util$restore_pointer
			ext entry (bit (4));
dcl	cobol_register_util$restore
			ext entry (bit (4));
dcl	cobol_register_util$save_pointer
			ext entry (bit (4));
dcl	cobol_register$load ext entry (ptr);

dcl	signal_		entry (char (*), ptr, ptr);
dcl	char_no		bit (2);
dcl	bit_4		bit (4);
dcl	temp_reg		fixed bin int static init (0);
dcl	r		fixed bin;
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 LOCAL_NAME char (4) int static init ("$GET");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME||LOCAL_NAME);/**/
	reset = 0;
	if switch = 1
	then new_wd_off = offset;
	else if switch = 2
	then do;
		new_wd_off = binary (substr (unspec (offset), 1, 34));
		char_no = substr (unspec (offset), 35, 2);
	     end;
	if what_pointer = 10
	then do;

/* get any temporary pointer register */

		best_yet = 0;
		do i = 0 to 7;
		     if usage (i) = 0
		     then do;			/* the current register is temporary pointer */
			     best_current = 0;
			     if switch = 0
			     then do;

/* a specific value was not supplied by caller */

				     if p_lock (i) = 0
				     then do;	/* register not locked */
					     if p_priority (i) = 0 & contents_sw (i) = 0
					     then go to specific_1;
					     if p_priority (i) = 0 & contents_sw (i) = 1
					     then best_current = 3;
					     else if p_priority (i) = 1 & contents_sw (i) = 0
					     then best_current = 2;
					     else best_current = 1;
					end;
				end;
			     else do;

/* a specific value has been supplied by caller */

				     if contents_sw (i) ^= 0 & seg_num (i) = segno & wd_offset (i) = new_wd_off
				     then go to specific_1;
						/* contents do not match */
				     if p_lock (i) = 0
				     then do;	/* register not locked*/
					     if p_priority (i) = 0 & contents_sw (i) = 0
					     then best_current = 4;
					     else if p_priority (i) = 0 & contents_sw (i) = 1
					     then best_current = 3;
					     else if p_priority (i) = 1 & contents_sw (i) = 0
					     then best_current = 2;
					     else best_current = 1;
					end;
				end;

/* has a better register been found */

			     if best_current > best_yet
			     then do;
				     best_yet = best_current;
				     save_i = i;
				end;
			end;
		end;
		i = save_i;
		if best_yet = 0
		then do;				/* unable to get any temporary register */
						/*  Pick a temporary pointer register, and save it.  */
			temp_reg = mod (temp_reg + 1, 7);
			if temp_reg > 2
			then temp_reg = 7;
			bit_4 = substr (unspec (temp_reg), 33, 4);
			call cobol_register_util$save_pointer (bit_4);
			i = temp_reg;
			ptr_status.p_priority (i) = 0;
			ptr_status.contents_sw (i) = 0;
			ptr_status.seg_num (i) = 0;
			ptr_status.wd_offset (i) = 0;
		     end;
		go to specific_1;
	     end;
	else do;

/* a specific pointer register was requested */

		i = what_pointer;
		if p_lock (i) = 1
		then do;				/* the pointer register is locked */
						/*  Save the current contents of the register, and unlock it.  */
			call cobol_register_util$save_pointer (substr (unspec (i), 33, 4));
			ptr_status.p_lock (i) = 0;
			ptr_status.contents_sw (i) = 0;
			ptr_status.seg_num (i) = 0;
			ptr_status.wd_offset (i) = 0;
		     end;

specific_1:
		structure.pointer_no = pointer_num (i);
		if (structure.lock = 1) | (ptr_status.save_stack_count (i) > 0)
		then p_lock (i) = 1;
		if switch = 0
		then do;				/* caller has not supplied contents */
			contents_sw (i) = 0;
			reset = p_reset (i);
		     end;
		else do;
			if contents_sw (i) = 0
			then do;
				go to load;
			     end;
			else if (^(seg_num (i) = segno & wd_offset (i) = new_wd_off))
			then do;

load:						/* emit instructions to load pointer registers*/
				m = 0;
				reloc_ptr = null ();

/* cobol data */

				if segno = 2
				then do;
					if new_wd_off > 262143
					then do;
cont_err:
						call signal_ ("command_abort_", null (), addr (contents_err));
						return;
					     end;

/* epbpr pr6|110,*    */
/* 7/9/76*/
					call make_inst ("110"b, 110, "0111010001"b, "1"b, "01"b, "0"b);

/* adwpr call_off,du     */
					call_off = new_wd_off - 16384;
					call make_inst ("0"b, call_off, "0001010000"b, "0"b, "00"b, "0011"b);
					go to emit;
				     end;

/*  stack  */

				if segno = 1000
				then do;
					if new_wd_off > 16383
					then go to cont_err;
						/*   eppr pr6|new_wd_off    */
					call make_inst ("110"b, new_wd_off, "0111010000"b, "1"b, "00"b, "0000"b)
					     ;
					go to emit;
				     end;

/* constant portion of text segment  */

				if segno = 3000
				then do;
					call_off = (-(cobol_$text_wd_off + new_wd_off));
						/*   eppr call_off,ic   */
					call make_inst ("0"b, call_off, "0111010000"b, "0"b, "00"b, "0100"b);
					go to emit;
				     end;

/* multics linkage section  */

				if segno = 3002
				then do;
					if new_wd_off > 16383
					then go to cont_err;
					reloc_ptr = addr (reloc (1));
					if contents_sw (4) = 1 & seg_num (4) = 3002 & wd_offset (4) = 0
					then do;	/* pr4 is set to the multics linkage section */
						/* eppr pr4|new_wd_off     */
						call make_inst ("100"b, new_wd_off, "0111010000"b, "1"b,
						     "00"b, "0000"b);
						r_left (m) = "11001"b;
						/* internal static 15 */
						r_right (m) = "0"b;
					     end;
					else do;
						call_pr_num = pointer_num (i);
						/* eppr pr6|36,*    */
						call make_inst ("110"b, 36, "0111010000"b, "1"b, "01"b,
						     "0000"b);
						r_left (m) = "0"b;
						r_right (m) = "0"b;
						/*  eppr prr | new_wd_off   */
						call make_inst (call_pr_num, new_wd_off, "0111010000"b, "1"b,
						     "00"b, "0000"b);
						r_left (m) = "11001"b;
						/* internal static 18  */
						r_right (m) = "0"b;
					     end;
					go to emit;
				     end;

/* cobol operators */

				if segno = 4000
				then do;		/* eppr pr6|24,*    */
					call make_inst ("110"b, 24, "0111010000"b, "1"b, "01"b, "0000"b);
					go to emit;
				     end;

/*  cobol linkage section  */

				if segno >= 20000
				then do;		/* sets pointer reg to argument list */
						/*  eppr pr6|26,*   */
					call make_inst ("110"b, 26, "0111010000"b, "1"b, "01"b, "0000"b);
					if segno > 20000
					then do;	/* sets pointer reg  to the argument  */
						/* eppr   prr|2nnnn,*  */
						call_pr_num = pointer_num (i);
						call_off = 2 * (segno - 20000);
						call make_inst (call_pr_num, call_off, "0111010000"b, "1"b,
						     "01"b, "0000"b);
					     end;
					go to emit;
				     end;

/* link in multics linkage section */

				if segno < 0
				then do;
					if segno < -16384
					then go to cont_err;
					if new_wd_off > 262143
					then go to cont_err;
					call_off = (-(segno));
					reloc_ptr = addr (reloc (1));
					if contents_sw (4) = 1 & seg_num (4) = 3002 & wd_offset (4) = 0
					then do;	/* pr4 is set to multics linkage section  */
						/*   eppr pr4|n,*     */
						/*  put link into the register  */
						call make_inst ("100"b, call_off, "0111010000"b, "1"b, "01"b,
						     "0000"b);
						r_left (m) = "10100"b;
						/* link 15  */
						r_right (m) = "0"b;
					     end;
					else do;	/*  eppr  pr6|36,*      */
						/*  set ponter register to linkage section base  */
						call make_inst ("110"b, 36, "0111010000"b, "1"b, "01"b,
						     "0000"b);
						r_left (m) = "0"b;
						r_right (m) = "0"b;
						/*   eppr prr|n,*    put link into the register      */
						call_pr_num = pointer_num (i);
						call make_inst (call_pr_num, call_off, "0111010000"b, "1"b,
						     "01"b, "0000"b);
						r_left (m) = "10100"b;
						/* link 15  */
						r_right (m) = "0"b;
					     end;
					if new_wd_off ^= 0
					then do;	/*   adwpr new_wd_off,du    */
						call make_inst ("0"b, new_wd_off, "0001010000"b, "0"b, "00"b,
						     "0011"b);
						r_left (m) = "0"b;
						r_right (m) = "0"b;
					     end;
					go to emit;
				     end;

/* invalid segment number  */

				go to cont_err;

/* emit the instructions */

emit:						/* acount char offset if needed */
				if char_no ^= "00"b & switch ^= 1
				then do;		/* get a register */
						/*  Set up a register request structure to get any index register.  */
					register_struc.what_reg = 5;
						/*  Any index.  */
					register_struc.lock = 0;
					register_struc.contains = 0;
					call cobol_register$load (addr (register_struc));

load_char:					/* ldxn : load char no into register */
					m = m + 1;
					r_left (m) = "0"b;
					r_right (m) = "0"b;
					string (inst (m)) = "000000000000000000010010000000000011"b;
					substr (inst.i_y.i_off (m), 14, 2) = char_no;
					substr (inst.i_op (m), 7, 3) = substr (register_struc.reg_no, 2, 3);
						/* a9bd */
					m = m + 1;
					r_left (m) = "0"b;
					r_right (m) = "0"b;
					string (inst (m)) = "000000000000000000101000000101101000"b;
					substr (inst.i_td (m), 2, 3) = substr (register_struc.reg_no, 2, 3);
					inst.i_y.i_pr (m) = pointer_num (i);
					contents_sw (i) = 0;
				     end;

				else do;
					seg_num (i) = segno;
					wd_offset (i) = new_wd_off;
					contents_sw (i) = 1;
				     end;

				call cobol_emit (addr (inst (1)), reloc_ptr, m);




			     end;

reset_test:
			if p_reset (i) ^= 0
			then do;
				if seg_num (i) = reset_seg_num (i) & wd_offset (i) = reset_wd_offset (i)
				then go to lock_test;
				else reset = 1;
			     end;
		     end;

lock_test:
		if structure.lock > 1
		then do k = 0 to 7;			/* unlock all pointer registers */

			p_lock (k) = 0;
		     end;
		if structure.lock > 2
		then do k = 0 to 9;			/* unlock A, Q and index registers */
			r_lock (k) = 0;
		     end;
	     end;

	go to prx;


/*************************************/
/*{*/
priority:
     entry (lock_value, priority, reg_no);

	/***..... dcl LOCAL_NAME2 char (9) int static init ("$PRIORITY");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME||LOCAL_NAME2);/**/
/*
set the priority and/or lock of one or more registers.
	*/

dcl	lock_value	fixed bin;
dcl	priority		fixed bin;
dcl	reg_no		bit (3);			/*
 lock_value can have the following values (input)
	0 - do not change the lock or unlock status.
	1 - lock this pointer register.
	2 - unlock this pointer register.
	3 - unlock all pointer registers.
	4 - unlock all pointer registers and all index
	    registers, and the A and Q registers.
 priority  can have the following values (input)
	0 - do not change register priority.
	1 - set this pointer register to normal priority
	2 - set this pointer register to high priority.
	    The register handler will attempt to preserve
	    the contents of this register as long as possible
	3 - set all pointer registers to normal priority.
	4 - set all pointer registers and all index registers,
	    and the A and Q registers to normal priority.
 reg_no	is the pointer register number. (input)
	*/
						/*}*/

/* manage lock */

	if lock_value ^= 0
	then do;
		if lock_value = 1
		then p_lock (fixed (reg_no)) = 1;
		else if lock_value = 2
		then do;
			k = fixed (reg_no);
			if ptr_status.save_stack_count (k) ^= 0
			then do;			/*  Restore the pointer register.  */
				call cobol_register_util$restore_pointer ("0"b || substr (unspec (k), 34, 3));
				ptr_status.p_lock (k) = 1;
			     end;			/*  Restore the pointer register.  */

			else p_lock (k) = 0;
		     end;
		else do;
			do k = 0 to 7;

			     if ptr_status.save_stack_count (k) ^= 0
			     then do;		/*  Restore the pointer register.  */
				     call cobol_register_util$restore_pointer ("0"b || substr (unspec (k), 34, 3))
					;
				     ptr_status.p_lock (k) = 1;
				end;		/*  Restore the pointer register.  */

			     else p_lock (k) = 0;
			end;
			if lock_value = 4
			then do k = 0 to 9;
				if reg_status.save_stack_count (k) ^= 0
				then do;		/*  Restore the register.  */
					call cobol_register_util$restore ((get_bit_code (k)));
					reg_status.r_lock (k) = 1;
				     end;		/*  Restore the register.  */

				else r_lock (k) = 0;
			     end;
		     end;
	     end;

/* manage priority */

	if priority ^= 0
	then do;
		if priority = 1
		then p_priority (fixed (reg_no)) = 0;
		else if priority = 2
		then p_priority (fixed (reg_no)) = 1;
		else do;
			do k = 0 to 7;
			     p_priority (k) = 0;
			end;
			if priority = 4
			then do k = 0 to 9;
				r_priority (k) = 0;
			     end;
		     end;
	     end;

prx:	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(MY_NAME);/**/
	return;

/* MAKE_INST PROC
	/* make an instruction */

make_inst:
     proc (pr, off, op, ar, tm, td);

dcl	pr		bit (3);
dcl	off		fixed bin (24);
dcl	op		bit (10);
dcl	ar		bit (1);
dcl	tm		bit (2);
dcl	td		bit (4);

/*  i must be set as index to ptr_status table */
/*  m must be set as index into inst table */
/*  op codes recognized are
	adwpr 050 (0)
	eppr 350 (0)
	epbpr 350 (1)
	*/


	m = m + 1;
	string (inst (m)) = "0"b;
	i_op (m) = op;
	i_ar (m) = ar;
	i_tm (m) = tm;
	i_td (m) = td;
	if ar = "0"b
	then string (i_y (m)) = substr (unspec (off), 19, 18);
	else do;
		i_pr (m) = pr;
		i_off (m) = substr (unspec (off), 22, 15);
	     end;
	if op = "0001010000"b
	then do;					/* adwpr */
		substr (i_op (m), 3, 1) = substr (pointer_num (i), 1, 1);
		substr (i_op (m), 8, 2) = substr (pointer_num (i), 2, 2);
	     end;
	else if op = "0111010000"b
	then do;					/* eppr */
		substr (i_op (m), 5, 1) = substr (pointer_num (i), 1, 1);
		substr (i_op (m), 8, 2) = substr (pointer_num (i), 2, 2);
		substr (i_op (m), 10, 1) = substr (pointer_num (i), 3, 1);
	     end;
	else if op = "0111010001"b
	then do;					/* epbpr */
		substr (i_op (m), 5, 1) = substr (pointer_num (i), 1, 1);
		substr (i_op (m), 8, 2) = substr (pointer_num (i), 2, 2);
		substr (i_op (m), 10, 1) = (^(substr (pointer_num (i), 3, 1)));
	     end;
	return;
     end make_inst;

get_bit_code:
     proc (fbin_code) returns (bit (4));

dcl	fbin_code		fixed bin;

dcl	bit_code		bit (4);

	if fbin_code = 9
	then bit_code = "0010"b;			/*  Q  */
	else if fbin_code = 8
	then bit_code = "0001"b;			/*  A  */
	else bit_code = "1"b || substr (unspec (fbin_code), 34, 3);

	return (bit_code);

     end get_bit_code;


	/***.....	dcl cobol_gen_driver_$Tr_Beg entry(char(*));/**/
	/***.....	dcl cobol_gen_driver_$Tr_End entry(char(*));/**/

	/***.....	dcl Trace_Bit bit(1) static external;/**/
	/***.....	dcl Trace_Lev fixed bin static external;/**/
	/***.....	dcl Trace_Line char(36) static external;/**/
	/***.....	dcl ioa_ entry options(variable); /**/
	/***..... dcl MY_NAME char (22) int static init ("COBOL_POINTER_REGISTER");/**/

dcl	1 ptr_status	(0:7) based (cobol_$ptr_status_ptr) aligned,
%include cobol_ptr_status;
dcl	1 reg_status	(0:9) based (cobol_$reg_status_ptr) aligned,
%include cobol_reg_status;
%include cobol_;

     end cobol_pointer_register;




		    cobol_pool.pl1                  05/24/89  1042.8rew 05/24/89  0832.7       78345



/****^  ***********************************************************
        *                                                         *
        * 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_pool.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 1/5/76 by Bob Chang to search operators only when nchar=8 or nchar<5. */
/* Modified since Version 2.0.	*/
/* format: style3 */
cobol_pool:
cobol_pool_:
     proc (constant, boundary, offset, in_op, byte_count);

/*}
function:	This procedure pools a constant in the constant portion
	of the cobol object text section.
	NOTE: NO conversion, blank or zero padding is performed.

usage:	dcl cobol_pool entry (char(*), fixed bin, fixed bin(24));

	call cobol_pool (constant, boundary, offset);

where:	constant (input):
	is the constant to be pooled 

	boundary (input):
	specifies the allocation of the left-most char of the constant
	= 0 :=  any word alloc; return offset in CHARS
	= 1 :=  any word alloc; return offset in WORDS
	= 2 := EVEN word alloc; return offset in WORDS
	= 3 :=  ODD word alloc; return offset in WORDS
	= 4 :=  any char alloc; return offset in CHARS
	NOTE: cobol_pool ALWAYS places the 1st char of the constant in 
	      the LEFT-MOST char position of the 1st word allocated

	offset (output):
	is the WORD or CHARACTER offset of the pooled constant
	relative to the END of the constant portion of the text
	section.
	NOTE: the CHARACTER offset refers to the 1st char in the 
	constant and the WORD offset refers to the word containing 
	the 1st character of the constant.
	(This offset  is in the same form as the offset 
	supplied by Data Division Allocation.)

	in_op output from the search_op entry .
	= 0 := the constant is not in cobol_operators_
	= 1 := the constant is in cobol_operators_. the output offset is
		based on the cobol_operators_.
	byte_count	 input to search_op_byte for the number of bytes
		which are neglected when searching.
}*/

/*	written by: Bob McDowell
	entered system:  7/29/74
	last modified:  12/06/74	*/

/*	note: still needs;

	n)		*/

dcl	(
	ioa_,
	ioa_$rsnnl,
	signal_
	)		entry options (variable);
dcl	(substr, unspec, fixed, rel, index)
			builtin;
dcl	(addr, addrel, length, null, string)
			builtin;

dcl	1 create_con_pool	aligned based (con_wrk_ptr),
	  2 next_const	char (no_char);

dcl	1 search_con_pool	aligned based (con_wrk_ptr),
	  2 all_consts	char (char_size);


dcl	1 op_con_base	based (op_con_ptr),
	  2 num		fixed bin,
	  2 filler	fixed bin,
	  2 op_con	char (0 refer (op_con_base.num));

dcl	1 error_info	aligned,
	  2 module_name	char (32) init ("cobol_pool"),
	  2 err_msg_lngth	fixed bin,
	  2 error_msg	char (168);

dcl	constant		char (*);
dcl	msg_1		char (32) init ("constant entered had 0 length;  ");
dcl	msg_2		char (44) init ("illegal boundary code value - [0<=code<=4]; ");
dcl	msg_3		char (40) init ("constant section overlaps text section; ");
dcl	msg_4		char (47) init ("illegal byte_count value - [0<=byte_count<=7]; ");
dcl	utemp		fixed bin;
dcl	(nchar, nword, word_size, char_size)
			fixed bin;
dcl	(boundary, end_loc, srch_loc, found_loc, reset_loc)
			fixed bin;
dcl	in_op		fixed bin;
dcl	byte_count	fixed bin;
dcl	no_char		fixed bin;
dcl	char_count	fixed bin;
dcl	start_loc		fixed bin;
dcl	(insert_loc, char_loc, bits35_36, bit_36)
			fixed bin;
dcl	offset		fixed bin (24);
dcl	(con_base_ptr, con_wrk_ptr)
			ptr;

start:
	reset_loc = con_wd_off;
	char_count = 0;
	nchar = length (constant);
	if (nchar > 0)
	then goto ck_bndry;
	call error (msg_1);
	return;

ck_bndry:
	if ((boundary >= 0) & (boundary <= 4))
	then goto begin;
	call error (msg_2);
	return;

begin:
	utemp = nchar + char_count + 3;
	nword = fixed (substr (unspec (utemp), 1, 34), 36);
	end_loc = fixed (rel (con_end_ptr), 18);
	con_base_ptr = addrel (con_end_ptr, -end_loc);

/*     search for this constant already in pool   */

	if (con_wd_off = 1)
	then srch_loc = end_loc - 1;
	else srch_loc = end_loc - (con_wd_off - 1) + 1;
search_1:
	con_wrk_ptr = addrel (con_base_ptr, srch_loc);
	word_size = end_loc - srch_loc;
	word_size = mod (word_size, 256);
	char_size = word_size * 4;
	start_loc = 1;
	char_loc = fixed (rel (con_wrk_ptr), 18);
	if (substr (unspec (char_loc), 36, 1) = "1"b & boundary = 2)
	     | (substr (unspec (char_loc), 36, 1) = "0"b & boundary = 3)
	then start_loc = 5;

loop:
	if substr (all_consts, start_loc + char_count, nchar) = constant
	then goto found;
	else if boundary = 0 | boundary = 1
	then start_loc = start_loc + 4;
	else if boundary = 4
	then start_loc = start_loc + 1;
	else start_loc = start_loc + 8;
	if start_loc + nchar - 1 <= char_size
	then goto loop;
	goto pool_it;

found:
	char_loc = start_loc - 1;
	offset = fixed (substr (unspec (char_loc), 1, 34), 36);
	found_loc = srch_loc + offset;
	offset = end_loc - found_loc + 1;
	if boundary = 0 | boundary = 4
	then offset = offset * 4;
	if boundary ^= 4
	then goto exit;
	char_loc = mod (char_loc, 4);
	if char_loc ^= 0
	then offset = offset + char_loc;
	return;

/*     pool constant after satisfying boundary conditions   */

pool_it:
	con_wd_off = con_wd_off + nword;
bump_it:
	offset = con_wd_off - 1;
	insert_loc = end_loc - offset + 1;
	if ((boundary = 0) | (boundary = 4) | (boundary = 1))
	then goto ck_fit;
	bit_36 = fixed (substr (unspec (insert_loc), 36, 1), 36);
						/* check current pool loc satisfies boundary conditions */
ck_bound:
	if ((boundary = 2) & (bit_36 = 0))
	then goto ck_fit;
	if ((boundary = 3) & (bit_36 = 1))
	then goto ck_fit;				/* boundary conditions unsatisfied; bump offset */
	con_wd_off = con_wd_off + 1;
	goto bump_it;				/* check if this constant will fit in constant pool */
ck_fit:
	if (insert_loc > text_wd_off)
	then goto insert;
	call error (msg_3);
	return;					/* insert this constant in the constant pool */
insert:
	con_wrk_ptr = addrel (con_base_ptr, insert_loc);
	no_char = nchar + char_count;
	if char_count ^= 0
	then substr (next_const, 1, char_count) = "";
	substr (next_const, char_count + 1, nchar) = substr (constant, 1, nchar);
	if boundary = 0 | boundary = 4
	then offset = offset * 4;
exit:
	return;




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


/*	The following entry are implemented to search the constant in cobol_operators_
	before the try on constant section in text segment.
	The fourth parameter in_op is the output explained on the main entry.
*/

search_op:
     entry (constant, boundary, offset, in_op, byte_count);

	char_count = 0;
	goto start_op;

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

/*	This procedure is for the search of cobol_operatorwith the leading null
	chars neglected. The word alignment is the same as usual.*/
search_op_byte:
     entry (constant, boundary, offset, in_op, byte_count);


	char_count = byte_count;
start_op:
	in_op = 0;
	if char_count < 0 | char_count > 7
	then call error (msg_4);
	nchar = length (constant);
	if (nchar > 0)
	then goto ck_bndry_op;
	call error (msg_1);
	return;

ck_bndry_op:
	if ((boundary >= 0) & (boundary <= 4))
	then goto begin_op;
	call error (msg_2);
	return;

begin_op:
	if (nchar > 4) & (nchar ^= 8)
	then goto begin;
	if boundary = 3
	then start_loc = 5;
	else start_loc = 1;
loop_op:
	if substr (op_con, start_loc + char_count, nchar) = constant
	then goto found_op;
	if boundary = 4
	then start_loc = start_loc + 1;
	else if boundary = 1 | boundary = 0
	then start_loc = start_loc + 4;
	else start_loc = start_loc + 8;
	if start_loc + nchar - 1 <= op_con_base.num
	then goto loop_op;
	goto begin;

found_op:
	offset = start_loc + 8199;
	if (boundary ^= 0) & (boundary ^= 4)
	then offset = fixed (substr (unspec (offset), 1, 34));
	in_op = 1;
	return;

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



error:
     proc (err_msg);

dcl	err_msg		char (*);

	call ioa_$rsnnl ("^a ABORTING const -> ""^a""", error_msg, err_msg_lngth, err_msg, constant);
	call signal_ ("command_abort_", null, addr (error_info));
	offset = 0;
	con_wd_off = reset_loc;

	return;

     end error;

%include cobol_;
     end cobol_pool;




		    cobol_process_error.pl1         05/24/89  1042.8rew 05/24/89  0832.7       51354



/****^  ***********************************************************
        *                                                         *
        * 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_process_error.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 5/18/76 by Bob Chang to fix the aos instruction.	*/
/* Modified on 05/05/76 by Bob Chang to interface with cobol_reg_manager. */
/* Modified on 4/24/76 by Bob Chang to interface with cobol_rts_. */
/* Modified on 4/19/76 by Bob Chang to interface with cobol operator. */
/* Modified on 4/2/76 by Bob Chang to interface with cobol operator. */
/*{*/
/* format: style3 */
cobol_process_error:
     proc (cobol_error_code, line_no, error_code_relp);

/* 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	line_no		fixed bin;
dcl	error_code_relp	fixed bin;

/*
     cobol_error_code  a fixed bin number indicating the "COBOL
               error number" (see below).  If 0, then there is no
               associated COBOL error number and no COBOL message
               is printed.

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_process_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_process_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	inst_seq		bit (36) static init ("000000000000000000111000000001000000"b);
						/* tsx0	pr0|4095+cobol_code	*/
dcl	add_use_code	bit (36) static init ("110000000001001001000101100001000000"b);
						/* aos	pr6|73	*/
						/* -5-18-76- */

dcl	sw		fixed bin;
dcl	temp		fixed bin;

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

/*************************************/
	sw = 1;
	go to start;
use:
     entry (cobol_error_code, line_no, error_code_relp);
	sw = 2;
start:
	if cobol_error_code = 0
	then cobol_error_code = 58;
	temp = 4095 + cobol_error_code;
	call cobol_reg_manager$before_op (temp);
	if sw = 2
	then call cobol_emit (addr (add_use_code), null (), 1);
	substr (inst_seq, 4, 15) = substr (unspec (temp), 22, 15);
	call cobol_emit (addr (inst_seq), null (), 1);
	call cobol_reg_manager$after_op (temp);
	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_process_error;




		    cobol_profile.pl1               05/24/89  1042.8rew 05/24/89  0832.7       18621



/****^  ***********************************************************
        *                                                         *
        * 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_profile.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Create on 1/21/77 by Bob Chang to implement profile option.	*/

/* format: style3 */
cobol_profile:
     proc;

/* This procedure is called to generate  a AOS instruction when profile option is
specified on cobol program compilation.*/

dcl	first_time	static fixed bin,
	link_offset	fixed bin static;

dcl	aos_inst		(2) bit (18) static init ("100000000000000000"b, "000101100001000000"b);
						/* aos	pr4|link_offset	*/

dcl	rel_aos		(2) bit (5) aligned static init ("11001"b, "00000"b);

dcl	cobol_emit	entry (ptr, ptr, fixed bin);
start:
	if first_time ^= cobol_$compile_count
	then do;
		first_time = cobol_$compile_count;
		link_offset = 65;
	     end;
	else link_offset = link_offset + 2;
	substr (aos_inst (1), 4, 15) = substr (unspec (link_offset), 22, 15);
	call cobol_emit (addr (aos_inst), addr (rel_aos), 1);

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_;
     end cobol_profile;




		    cobol_prologue_gen.pl1          05/24/89  1042.8rew 05/24/89  0832.7       73944



/****^  ***********************************************************
        *                                                         *
        * 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_prologue_gen.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified since Version 5.1 */

/* format: style3 */
cobol_prologue_gen:
     proc (in_token_ptr, binit_tag, fxs_tag, fxs_locno, decl_flag);

declare	(
	binit_tag		fixed bin,
	fxs_tag		fixed bin,
	fxs_locno		fixed bin,
	decl_flag		fixed bin
	)		parameter;

/*  CREATE CLASS-0 DEFINITION FOR PROGRAM'S ENTRY POINT AND    */
/*  RELOCATION INFORMATION FOR SAME			   */

	eos_ptr = in_token.token_ptr (in_token.n);

	if end_stmt.a = "000"b
	then n_args = 0;
	else n_args = end_stmt.e;

	object_name = (32)" ";
	substr (object_name, 1, 30) = fixed_common.prog_name;
	object_name_len = index (fixed_common.prog_name, " ") - 1;
	if object_name_len = -1
	then object_name_len = 30;

	text_ptr = cobol_$text_base_ptr;

	if fixed_common.init_cd
	then n_args = 1;

	call cobol_def_util (n_args, object_name, object_name_len, text_ptr, 1, null (), in_token_ptr);

/*  PREPARE AND EMIT ENTRY SEQUENCE CODE AND RELOCATION	   */
/*	 	INFORMATION			   */

	entry_seq.trace_cntrl_relp = "000000000000111111"b;

	if fixed_common.options.st = "1"b
	then do;
		call cobol_make_link$type_1 (offset, 2);

		if fixed_common.options.profile
		then do;
			fixup_directive.location.offset = cobol_$text_wd_off + 6;
			call cobol_make_fixup (addr (fixup_directive));
		     end;

		entry_seq.link_relp = substr (unspec (offset), 19, 18);
		entry_seq_reloc (13) = "10010"b;
		entry_seq_reloc (14) = "10110"b;
	     end;
	else do;
		entry_seq.link_relp = (18)"0"b;
		entry_seq.block_relp = (18)"0"b;
		entry_seq_reloc (13) = (5)"0"b;
		entry_seq_reloc (14) = (5)"0"b;
	     end;

	call cobol_emit (text_ptr, addr (entry_seq_reloc), 7);

/*  PREPARE AND EMIT INITIALIZATION CODE AND RELOCATION	   */
/*		    INFORMATION			   */

	fxs_tag = 0;				/*-11/30/76-*/

	if seg_init_flag ^= 0 | data_init_flag ^= 0
	then do;
		call cobol_r_initialize;

/* Reserve 80 words in stack for the run time package.	*/

		call cobol_alloc$stack (336, 2, offset);
		binit_tag = cobol_$next_tag;
		cobol_$next_tag = cobol_$next_tag + 1;
		call cobol_emit (addr (init_seq), null (), 1);
		call cobol_make_tagref (binit_tag, cobol_$text_wd_off - 1, null);
	     end;
	else do;
		binit_tag = 0;
		call cobol_emit (addr (aos_inst), addr (rel_aos), 1);
		call cobol_r_initialize;

/* Reserve 80 words in stack for the run time package.	*/

		call cobol_alloc$stack (336, 2, offset);

	     end;

	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 (inst_rts (1)), addr (rel_rts (1)), 1);
						/* Relocation info for cobol_rts_	*/

	if fixed_common.options.profile
	then call cobol_profile;

	if fixed_common.init_cd
	then do;
		alpha_type9.seg = fixed_common.init_cd_seg;
		alpha_type9.off = fixed_common.init_cd_offset;

		call cobol_set_pr (addr (pr_struc), addr (alpha_type9));
		call cobol_call_op (77, 0);
	     end;
	else if (fixed_common.options.oc & fixed_common.descriptor ^= "00"b)
	then call cobol_emit (addr (inst_oc), null (), 1);

	cobol_$init_stack_off = cobol_$stack_off;

	if decl_flag ^= 0
	then do;

		fxs_tag = cobol_$next_tag;
		cobol_$next_tag = cobol_$next_tag + 1;
		call cobol_emit (addr (init_seq1), null (), 1);

		fxs_locno = cobol_$text_wd_off;
		call cobol_make_tagref (fxs_tag, cobol_$text_wd_off - 1, null);

	     end;


	return;





dcl	n_args		fixed bin,		/* No of operands in USING phrase*/
	i		fixed bin,		/* Do loop index		   */
	object_name	char (32),
	object_name_len	fixed bin,
	offset		fixed bin,		/* Offset as returned by various */
						/* subroutines		   */
	n_con		fixed bin,		/* No of conditions		   */
	n_off		fixed bin,		/* Offset of 1st wd of stack     */
						/* allocation		   */
	name		(2) char (32),		/* Array of condition  names	   */
	ln_nm		(2) fixed bin,		/* Array of condition name lngths*/
	temp		fixed bin;



/* Entry sequence code				   */
dcl	entry_seq_reloc	(14) bit (5) aligned static
			init ("10000"b, "00000"b, "10000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b,
			"00000"b, "00000"b, "11001"b, "11000"b, "00000"b, "00000"b);



/* Initialization sequence code and relocation information     */

dcl	init_seq1		(2) bit (18) static init ("000000000000000000"b, "111001000000000100"b);
						/* tra	decl_loc,ic	*/

dcl	nop_instr		(2) bit (18) static init ("000000000000000000"b, "000001001000000000"b);
						/*	nop	*/

dcl	inst_oc		(2) bit (18) static init ("000000000000001100"b, "111000000001000000"b);
						/* tsx0 pr0|14 */
dcl	init_seq		(2) bit (18) unaligned static init ("000000000000000000"b, "111000000000000100"b);
						/* tsx0	init_data,ic	*/

dcl	aos_inst		(2) bit (18) static init ("100000000000001110"b, "000101100001000000"b);
						/* aos	pr4|16	*/
dcl	rel_aos		(2) bit (5) aligned static init ("11001"b, "00000"b);
dcl	inst_rts		(2) bit (18) static init ("000000000001000000"b, "000001001001000000"b);
						/* nop	100	*/
dcl	rel_rts		(2) bit (5) aligned static init ("10100"b, "00000"b);
						/* fixup directive for link, used when profile options is specified.	*/
dcl	1 fixup_directive	aligned static,
	  2 operation	bit (1) unal init ("0"b),
	  2 type		bit (4) unal init ("1111"b),
	  2 reserved	bit (9) unal init ("000000000"b),
	  2 location	unal,
	    3 half	bit (1) unal init ("0"b),
	    3 base	bit (3) unal init ("001"b),
	    3 offset	fixed bin unal,
	  2 tag_number	fixed bin aligned;

/* Declaration for static data.	*/
dcl	1 pr_struc	static,
	  2 what_ptr	fixed bin init (1),
	  2 pointer_no	bit (3),
	  2 lock		fixed bin init (0),
	  2 switch	fixed bin init (0);

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


/*
P__r_o_c_e_d_u_r_e_s_C__a_l_l_e_d:_
						   */

dcl	cobol_alloc$stack	entry (fixed bin, fixed bin, fixed bin),
	cobol_define_tag_nc entry (fixed bin, fixed bin),
	cobol_call_op	entry (fixed bin, fixed bin),
	cobol_set_pr	entry (ptr, ptr),
	cobol_profile	entry,
	cobol_emit	entry (ptr, ptr, fixed bin),
	cobol_make_link$type_1
			entry (fixed bin, fixed bin),
	cobol_make_link$type_4
			entry (fixed bin, char (*)),
	cobol_make_tagref	entry (fixed bin, fixed bin, ptr),
	cobol_make_fixup	entry (ptr),
	cobol_pool	entry (char (*), fixed bin, fixed bin),
	cobol_r_initialize	entry,
	cobol_reloc	entry (ptr, fixed bin, fixed bin),
	cobol_def_util	entry (fixed bin, char (32), fixed bin, ptr, fixed bin, ptr, ptr);




/*****	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_entry_seq;
%include cobol_fixed_common;
%include cobol_ext_;
%include cobol_fixed_static;
%include cobol_definitions;
%include cobol_type19;
%include cobol_in_token;

     end cobol_prologue_gen;




		    cobol_purge_gen.pl1             05/24/89  1042.8rew 05/24/89  0832.7       31401



/****^  ***********************************************************
        *                                                         *
        * 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_purge_gen.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 10/04/77 by Bob Chang to fix theb bug for mcs_ocdp. */
/* Modified on 03/23/77 by Bob Chang to implement purge verb.	*/
/* Created as a stub on 11/18/76 by ORN */

/*{*/
/* format: style3 */
cobol_purge_gen:
     proc (in_token_ptr);


/* Declaration for static data.	*/
dcl	1 pr_struc	static,
	  2 what_ptr	fixed bin init (2),
	  2 pointer_no	bit (3),
	  2 lock		fixed bin init (0),
	  2 switch	fixed bin init (0);

dcl	1 alpha_type9	static,
	  2 header	(4) fixed bin init (112, 0, 0, 9),
	  2 repl_ptr	(2) ptr init ((2) null ()),
	  2 fill1		bit (108) init (""b),
	  2 file_key_info,
	    3 fb1		(3) fixed bin init (0, 0, 0),
	    3 size	fixed bin init (0),
	    3 fb2		(2) fixed bin init (0, 0),
	    3 flags1	bit (36) init ("000000100100000000010000000100000000"b),
	    3 flags2	bit (36) init (""b),
	    3 seg		fixed bin init (0),
	    3 off		fixed bin,
	  2 fill2		(7) fixed bin init (0, 0, 0, 0, 0, 0, 0);
dcl	inst_seq		(6) bit (18) unaligned static init ("110000000000000000"b, "010101010001000000"b,
						/* spri2	pr6|offset	*/
			"110000000000000000"b, "010011100001000000"b,
						/* szn	pr6|offset	*/
			"000000000000000000"b, "110000000000000100"b);
						/* tze	0,ic		*/


/*	Automatic data	*/
dcl	dn_ptr		ptr,
	stoff		fixed bin,
	temp		fixed bin;

/* External procedure	*/
dcl	cobol_call_op	entry (fixed bin, fixed bin),
	cobol_define_tag	entry (fixed bin),
	cobol_make_tagref	entry (fixed bin, fixed bin, ptr),
	cobol_reg_manager$after_op
			entry (fixed bin),
	cobol_emit	entry (ptr, ptr, fixed bin),
	cobol_set_pr	entry (ptr, ptr);

start:						/* Generate epp2 instruction for communication token.	*/
	cdtoken_ptr = in_token.token_ptr (2);
	alpha_type9.seg = cdtoken.cd_seg;
	alpha_type9.off = cdtoken.cd_off - 20;
	call cobol_set_pr (addr (pr_struc), addr (alpha_type9));

/* Allocate 12 words in stack frame for parameters	*/
	stoff = 74;				/* Communication stack frame  from pr6|74	*/

/* Store cd_token address.	*/
	substr (inst_seq (1), 4, 15) = substr (unspec (stoff), 22, 15);
	call cobol_emit (addr (inst_seq (1)), null, 1);


/* Call cobol_operators_	*/
	call cobol_call_op (72, 0);

	call cobol_reg_manager$after_op (72);

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_;
%include cobol_type13;
%include cobol_type9;
%include cobol_in_token;
     end cobol_purge_gen;




		    cobol_r_initialize.pl1          05/24/89  1042.8rew 05/24/89  0832.7       63099



/****^  ***********************************************************
        *                                                         *
        * 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_r_initialize.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 04/08/76 by Bob Chnag to take out the preset of pr5. It is set in operator. */
/* Modified on 3/19/76 by Bob Chang to interface with the cobol_operators_. */
/*{*/

/* revised 09-07-74 by wko*/

/* format: style3 */
cobol_r_initialize:
     proc;					/*
 1. Initialize structures containing information about the object
   time A register,Q register, index registers and pointer
   registers.
 2. Emit instructions to load the preset pointer registers to
   cobol data. ie pr3 and pr5 (if more than 32k of cobol data).
 3. Emit instruction to store pr3 and pr5 (if needed) in the
   object time stack.



 POINTER REGISTER ASSIGNMENTS:


	the current assignment of object time pointer
registers follows. The intent is to be able to change
these assignments by making changes to only this utility and
other pointer register management utilities, and making
no changes to the main body of the generator


 PR0:
  function - permanently set to cobol  operators
  obtained - pr6 |24
  representation - segment 4000, offset 0.


 PR1:
  function - temporary register


 PR2:
  function - temporary register


 PR3:
  function - permanently set to location 16k (words)
             of cobol data.
  obtained - initially pr4 | 8 contains the base address
             of cobol data. Subsequent to its initial
             setting it is obtained from pr6 | 64
  representation - segment 2, offset 40000 (octal)


 PR4:
  function - permanently set to the multics linkage section.
  obtained - pr6 | 36
  representation - segment 3002, offset 0


 PR5:
  function -
  (a) If there is more than 32k (words) of cobol data
      permanently set to location 48k (words) of cobol data
  (b) otherwise a temporary register
  obtained - initially pr4 |8 contains the base address of
             cobol data. Subsequent to its initial setting it
             is obtained from pr6 | 66
  representation - segment 2, offset 140000 (octal)


 PR6:
  function - this is always set to the stack frame of the
             object program. All components of the generator can
             assume this. There is no need to use the pointer
             register management utilities, but it will not
             hurt if the are used.
  representation - segment 1000, offset 0


 PR7:
  function - temporary register.
*/
						/*}*/
dcl	i		fixed bin;
dcl	cobol_emit	entry (ptr, ptr, fixed bin) ext;
dcl	reloc		(6) bit (5) aligned init ("11001"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b);
						/* epp5 pr4|8,*     */
dcl	ld5		bit (36) aligned init ("100000000000001000011111001101010000"b);
						/* adwp5 49152,du    */
dcl	add5		bit (36) aligned init ("001100000000000000001101001000000011"b);
						/* spri5 pr6|66   */
dcl	st5		bit (36) aligned init ("110000000001000010110101001101000000"b);


dcl	save_stack_max_value
			fixed bin int static init (10);

	cobol_$ptr_status_ptr = addr (ptr_status (0));
	cobol_$reg_status_ptr = addr (reg_status (0));

/* clear pointer register structure */

	do i = 0 to 7;
	     usage (i) = 0;
	     contents_sw (i) = 0;
	     seg_num (i) = 0;
	     wd_offset (i) = 0;
	     p_lock (i) = 0;
	     p_priority (i) = 0;
	     p_reset (i) = 0;
	     reset_seg_num (i) = 0;
	     reset_wd_offset (i) = 0;
	     ptr_status.save_stack_max (i) = save_stack_max_value;
	     ptr_status.save_stack_count (i) = 0;
	end;

/* set up pr0 for cobol  operators */
/* the prologue generation process loads pr0 */

	i = 0;
	pointer_num (i) = "000"b;
	usage (i) = 1;
	contents_sw (i) = 1;
	seg_num (i) = 4000;
	p_reset (i) = 1;
	reset_seg_num (i) = seg_num (i);

/* set up pr1 as temporary register */

	i = i + 1;
	pointer_num (i) = "001"b;			/* set up pr2 as temporary register */

	i = i + 1;
	pointer_num (i) = "010"b;

/* set up pr3 to location 16k (words) of cobol data */

	i = i + 1;
	pointer_num (i) = "011"b;
	usage (i) = 1;
	contents_sw (i) = 1;
	seg_num (i) = 2;
	wd_offset (i) = 16384;
	p_reset (i) = 1;
	reset_seg_num (i) = seg_num (i);
	reset_wd_offset (i) = wd_offset (i);		/* emit instructions to load pr3 and save it */

/* set up pr4 as multics linkage */
/* the prologue generation process loads pr4 */

	i = i + 1;
	pointer_num (i) = "100"b;
	usage (i) = 1;
	contents_sw (i) = 1;
	seg_num (i) = 3002;
	p_reset (i) = 1;
	reset_seg_num (i) = seg_num (i);

/* set up pr5 to location 48k (words) of cobol data (if there is over 32k (words) of cobol data), or as a temporary register otherwise */
/* Commented out on cobol operator interface.	*/
/*-04/08/76-*/
	i = i + 1;
	pointer_num (i) = "101"b;
	if cobol_$cobol_data_wd_off > 32767
	then do;
		usage (i) = 1;
		contents_sw (i) = 1;
		seg_num (i) = 2;
		wd_offset (i) = 49152;
		p_reset (i) = 1;
		reset_seg_num (i) = seg_num (i);
		reset_wd_offset (i) = wd_offset (i);

/*
		call cobol_emit(addr(ld5),addr(reloc),3);
*/
	     end;

/* set up pr6 as stack frame */
/* the prologue generation process sets pr6 */

	i = i + 1;
	pointer_num (i) = "110"b;
	usage (i) = 1;
	contents_sw (i) = 1;
	seg_num (i) = 1000;

/* set up pr7 as temporary register */

	i = i + 1;
	pointer_num (i) = "111"b;


/* set up A,Q,index structure */


/*  Initialize register status structures for A,Q, and index registers 0 thru 7  */

	do i = 0 to 9;
	     reg_status.r_lock (i) = 0;
	     reg_status.r_priority (i) = 0;
	     reg_status.save_stack_max (i) = save_stack_max_value;
	     reg_status.save_stack_count (i) = 0;
	     if i < 8
	     then reg_status.register_num = "1"b || bit (fixed (i, 3), 3);
	     else if i < 9
	     then reg_status.register_num = "0001"b;	/*  A register  */
	     else reg_status.register_num = "0010"b;	/*  MUST BE Q  */
	end;



	return;
dcl	1 ptr_status	(0:7) static aligned,
%include cobol_ptr_status;

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

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

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

dcl	1 reg_status	(0:9) static aligned,
%include cobol_reg_status;
%include cobol_;
     end cobol_r_initialize;




		    cobol_read_ft.pl1               05/24/89  1042.8rew 05/24/89  0832.7       19548



/****^  ***********************************************************
        *                                                         *
        * 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_read_ft.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/*{*/
/* format: style3 */
cobol_read_ft:
     proc (file_no, ft_ptr);
cobol_read_ft_:
     entry (file_no, ft_ptr);

dcl	file_no		fixed bin;
dcl	ft_ptr		ptr;

/*
file_no		is the internal number assigned to the
		file and recorded in the Type 12 token
		(input).

ft_ptr		is a Multics ptr to the file_table for the
		corresponding file (output).
}*/

dcl	rec_id		char (5);
dcl	(i, j, code)	fixed bin;
dcl	cobol_read_rand	entry (fixed bin, char (5), ptr);


/*************************************/
start:
	if file_no < 21
	then rec_id = fixed_common.filedescr_offsets (file_no);
	else do;
		rec_id = fixed_common.filedescr_offsets (20);
		j = file_no - 20;
		do i = 1 to j;
		     call cobol_read_rand (1, rec_id, ft_ptr);
		     rec_id = file_table.next;
		end;
	     end;
	call cobol_read_rand (1, rec_id, ft_ptr);
	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_fixed_common;
%include cobol_ext_;
%include cobol_;
     end cobol_read_ft;




		    cobol_read_gen.pl1              05/24/89  1042.8rew 05/24/89  0832.7      132831



/****^  ***********************************************************
        *                                                         *
        * 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_read_gen.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 06/27/79 by FCH, [4.0-1], not option added for debug */
/* Modified on 11/11/78 at 1111 by FCH,[3.0-2], alt rec keys */
/* Modified on 06/08/78 by FCH,[3.0-1], open i-o(ext,ind-seq) fixed */
/* Modified since Version 3.0 */

/* format: style3 */
cobol_read_gen:
     proc (mp_ptr, passed_tag);

dcl	passed_tag	fixed bin;		/* for  in-line error handling */
dcl	ptag		fixed bin;
dcl	mp_ptr		ptr;
dcl	1 mp		based (mp_ptr),
	  2 n		fixed bin,		/* from 3 or 4 */
	  2 pt		(0 refer (mp.n)) ptr;	/* pt(1) pts to type1 token for READ */
						/* pt(2) pts to type12 token for file to be read */
						/* pt(3) pts to type9 token for INTO data IF eos.b = "1"b */
						/* pt(n) pts to type19 token (eos) */

dcl	1 args,
	  2 entryno	fixed bin,
	  2 arglist_off	fixed bin,
	  2 stacktemp_off	fixed bin,
	  2 n		fixed bin,
	  2 arg		(5),
	    3 pt		ptr,
	    3 type	fixed bin,
	    3 off1	fixed bin,
	    3 off2	fixed bin,
	    3 value	bit (18) unal,
	    3 indirect	bit (1) unal,
	    3 overlay	bit (1) unal,
	    3 repeat_nogen	bit (1) unal,
	    3 regsw	bit (1) unal,
	    3 regno	bit (3) unal;

dcl	file_key_desc	char (40) based;
dcl	output_errno	fixed bin init (40);	/* Invalid I/O operation.  Attempt to read a file opened as output */

dcl	text		(0:10000) bit (36) based (cobol_$text_base_ptr);
dcl	argb		(5) bit (216) based (addr (args.arg (1)));
dcl	ft_ptr		ptr;
dcl	fkey_ptr		ptr;
dcl	dn_ptr		ptr;
dcl	name_ptr		ptr;
dcl	arg_ptr		ptr;
dcl	ioerror_ptr	ptr;

dcl	stoff		fixed bin;
dcl	aloff		fixed bin;
dcl	sbuf_off		fixed bin;
dcl	size		fixed bin;
dcl	offset		fixed bin;
dcl	reclen_off	fixed bin;
dcl	buflen_off	fixed bin;
dcl	buf_off		fixed bin;
dcl	declen_off	fixed bin;
dcl	keylen_off	fixed bin;
dcl	temp		fixed bin;
dcl	ntag		fixed bin;
dcl	(iosw, alt_sw, read_next_sw)
			bit (1);			/*[3.0-2]*/
dcl	char5		char (5),
	key_ctr		fixed bin,
	skip_read_tag	fixed bin;

/*************************************/
/*************************************/
/* INITIALIZATION */
start:
	pr5_struct_ptr = addr (pr5_struct);
	rw_ptr = mp.pt (1);
	eos_ptr = mp.pt (mp.n);
	ioerror_ptr = addr (ioerror);
	ioerror.cobol_code = 0;
	ioerror.type1_ptr = mp.pt (1);
	ioerror.is_tag = 0;
	ioerror.mode = 0;

	if end_stmt.a ^= "000"b
	then do;					/* in-line error coding follows */

		ioerror.is_tag = cobol_$next_tag;	/* to be defined at end of generated code for WRITE */
		ptag, passed_tag = cobol_$next_tag + 1; /* to be defined by gen driver at end of in-line coding */
		ioerror.ns_tag = ptag;
		cobol_$next_tag = cobol_$next_tag + 2;

	     end;
	else do;

		ioerror.is_tag = 0;
		ptag = 0;
		ioerror.ns_tag = cobol_$next_tag;	/* to be defined at end of generated code */
		cobol_$next_tag = cobol_$next_tag + 1;

	     end;

	arg_ptr = addr (args);
	iocb_arg.pt = addr (iocb_basic_struct);
	cra_arg.pt = addr (cra_basic_struct);

	call cobol_read_ft (mp.pt (2) -> fd_token.file_no, ft_ptr);

/*[3.0-3]*/
	read_next_sw = file_table.access < 2 /* seq */ /*[3.0-3]*/ | /*[3.0-3]*/ end_stmt.d = "01"b;
						/* read_next */

/*[3.0-2]*/
	alt_sw = file_table.organization = 3 /* ind */ /*[3.0-2]*/ & /*[3.0-2]*/ file_table.alternate_keys ^= 0;

/*[3.0-2]*/
	if read_next_sw & alt_sw			/*[3.0-2]*/
	then do;
		skip_read_tag = cobol_$next_tag;	/*[3.0-2]*/
		cobol_$next_tag = cobol_$next_tag + 1;	/*[3.0-2]*/
	     end;


	if file_table.organization = 5
	then file_table.organization = 4;		/* temporary */

	if file_table.code_set_clause & file_table.code_set = 12
	then do;					/* 12 = ebcdic */

		call cobol_alloc$stack (file_table.max_cra_size + 1, 2, stoff);

		alpha_type9.seg, trans_type9.seg = 1000;/* stack */
		alpha_type9.off, trans_type9.off = stoff * 4;
		trans_type9.size = file_table.max_cra_size;

	     end;
	else do;

		alpha_type9.seg = file_table.cra_seg;
		alpha_type9.off = file_table.cra_offset;


	     end;

	alpha_type9.size = file_table.max_cra_size;

	call cobol_alloc$stack (80, 2, aloff);		/* enough for 20 words - aloff is a wd offset */

	args.arglist_off = aloff;
	argb (1) = unspec (iocb_arg);
	buflen_off = 80;
	reclen_off = 47;
	declen_off = aloff + 16;
	keylen_off = aloff + 19;


/*************************************/
/* START CODE GENERATION */
start_codegen:					/* MAKE SURE FILE IS OPEN */
	ntag = cobol_$next_tag;
	ioerror.retry_tag = cobol_$next_tag + 1;

	call cobol_define_tag (ioerror.retry_tag);

	cobol_$next_tag = cobol_$next_tag + 2;

	call cobol_set_fsbptr (ft_ptr);		/* OPERATOR63(init_read) */
	call cobol_call_op (63, ntag);		/* INT_READ_OP */

	if end_stmt.a = "000"b
	then do;

		call cobol_emit (addr (opt_text), null, 2);
		call cobol_make_tagref (ntag, cobol_$text_wd_off - 1, null);

	     end;

	call cobol_gen_ioerror (ft_ptr, ioerror_ptr);

	call cobol_define_tag (ntag);


/* ESTABLISH MAXIMUM CURRENT RECORD AREA SIZE */
	temp = file_table.max_cra_size;

	if file_table.organization = 4
	then temp = temp + 1;			/* allow for the nl character */

	call cobol_io_util$move_direct ("110"b, buflen_off * 4, 4, 1, substr (unspec (temp), 19, 18));

/* STREAM INPUT */
	if file_table.organization = 4
	then do;

		call cobol_alloc$stack (file_table.max_cra_size + 1, 1, sbuf_off);

		ntag = cobol_$next_tag;
		cobol_$next_tag = cobol_$next_tag + 1;
		alpha_type9.size = file_table.max_cra_size;
		alpha_type9.seg = 1000;
		alpha_type9.off = sbuf_off * 4;

		call cobol_set_pr (pr5_struct_ptr, addr (alpha_type9));

/* OPERATOR64(get_line) */
		call cobol_call_op (64, ntag);	/* iox_$get_line */

		call cobol_gen_ioerror (ft_ptr, ioerror_ptr);

		call cobol_define_tag (ntag);

		alpha_type9.seg = file_table.cra_seg;
		alpha_type9.off = file_table.cra_offset;

		call cobol_io_util$move_from_varlen ("110"b, reclen_off * 4, addr (alpha_type9), "110"b, sbuf_off * 4)
		     ;

	     end;
	else do;

		if file_table.access = 3 /* dynamic - must prevent reads for output opening */
		     & (file_table.external | file_table.open_ext)
		then do;

			ntag = cobol_$next_tag;
			cobol_$next_tag = cobol_$next_tag + 1;

			call cobol_io_util$bypass_mode_error (ntag, "11"b);

/* OPERATOR54(delete_error) */
			call cobol_call_op (54, ntag);/* ERROR_OP */

			call cobol_gen_ioerror (ft_ptr, ioerror_ptr);

			call cobol_define_tag (ntag);

		     end;

		iosw = (file_table.external | file_table.delete | file_table.rewrite) & file_table.access < 2;

		if read_next_sw			/* FORMAT 1 READ */
		then do;				/* READ NEXT */

			if (file_table.organization > 1 & iosw & file_table.access < 2)
			     /* to verify rewrite and delete */
			     | (file_table.organization = 2 & file_table.relative_key)
						/* to set relative_key */
			then do;			/* remember key of next rec - i.e. the rec to be read */

/* PROVIDE FOE BYPASSING READ KEY IF WORTHWHILE */
				ntag = cobol_$next_tag;
				cobol_$next_tag = cobol_$next_tag + 1;

				if (file_table.open_in | file_table.external) & file_table.organization = 3
				then do;
					call cobol_io_util$bypass_readkey (ntag);

				     end;		/* READ KEY OF NEXT RECORD */

				call cobol_alloc$stack (260, 2, stoff);
						/* area know as TEMP read key area */

				call cobol_ioop_util$lda_du (stoff);
						/*OPERATOR69(read_key_for_read) */
				call cobol_call_op (69, ntag);
						/* iox_$read_key */

				call cobol_gen_ioerror (ft_ptr, ioerror_ptr);

				call cobol_define_tag (ntag);
						/*[3.0-1]*/

				if iosw
				then do;

					call cobol_set_fsbptr (ft_ptr);
					call cobol_io_util$move ("110"b, keylen_off * 4, 4, "001"b,
					     fsb_keylen_sw, 4);
					call cobol_io_util$move_direct ("001"b, fsb_keylen_sw, 4, 1, ""b);
						/* until successful read */

				     end;

			     end;
			else do;

				if iosw
				then do;

					if file_table.organization ^= 1
					then call cobol_io_util$move ("110"b, keylen_off * 4, 4, "001"b,
						fsb_keylen_sw, 4);

					call cobol_io_util$move_direct ("001"b, fsb_keylen_sw, 4, 1, ""b);
						/* until sucessful read */

				     end;

/*[3.0-2]*/
				if alt_sw		/*[3.0-2]*/
				then do;
					ntag = cobol_$next_tag;
						/*[3.0-2]*/
					cobol_$next_tag = cobol_$next_tag + 1;

/*[3.0-2]*/
					call cobol_io_util$file_desc (file_table.file_desc_1_offset);
						/*[3.0-2]*/
					call cobol_call_op$skip (92, ntag, skip_read_tag);
						/* OPERATOR92(alt_find_rec) */
						/*[3.0-2]*/
					call cobol_define_tag (ntag);
						/*[3.0-2]*/
					call cobol_set_fsbptr (ft_ptr);
						/*[3.0-2]*/
				     end;

			     end;

		     end;

		else do;				/* FORMAT 2 READ */

/*[3.0-2]*/
			if alt_sw & end_stmt.e ^= 511 /*[3.0-2]*/
			then do;
				char5 = file_table.alt_key_info;
						/*[3.0-2]*/
						/*[3.0-2]*/
				do key_ctr = 1 by 1 to end_stmt.e;
						/*[3.0-2]*/
						/*[3.0-2]*/
				     call cobol_read_rand (1, char5, fkey_ptr);
						/*[3.0-2]*/
						/*[3.0-2]*/
				     char5 = file_key.next_alt;
						/*[3.0-2]*/
				end;		/*[3.0-2]*/
			     end;

			else call cobol_read_rand (1, file_table.r_key_info, fkey_ptr);

			addr (fkey_type9.file_key_info) -> file_key_desc = file_key.desc;
			mpout.pt1 = mp.pt (1);
			mpout.pt2 = addr (fkey_type9);

			if file_table.organization = 2
			then do;			/* relative */

				mpout.pt3 = addr (num_type9);
				size, num_type9.size, num_type9.places_left = 16;
				num_type9.seg = 5001;
						/* from PR1 */
				num_type9.off = file_table.fsb.off + fsb_key;

			     end;
			else do;			/* indexed */

				mpout.pt3 = addr (alpha_type9);
				size, alpha_type9.size = fkey_type9.size;
				alpha_type9.seg = 5001;
						/* from PR1 */
				alpha_type9.off = file_table.fsb.off + fsb_key;

			     end;

			mpout.pt4 = addr (type19);

			call cobol_move_gen (addr (mpout));

			call cobol_io_util$move_direct ("001"b, fsb_keylen_sw, 4, 1, substr (unspec (size), 19, 18))
			     ;

/*[3.0-2]*/
			if alt_sw			/*[3.0-1]*/
			then do;
				call cobol_io_util$key_loc (0, 0);
						/*[3.0-2]*/
				call cobol_io_util$file_desc (file_table.file_desc_1_offset);
						/*[3.0-2]*/
				call cobol_io_util$key_num (end_stmt.e);
						/*[3.0-2]*/
				call cobol_call_op (84, 0);
						/*[3.0-2]*/
				call cobol_set_fsbptr (ft_ptr);
						/*[3.0-2]*/
			     end;

			ntag = cobol_$next_tag;

			cobol_$next_tag = cobol_$next_tag + 1;
						/* OPERATOR67(read_seek_key) */
			call cobol_call_op (67, ntag);/* iox_$seek_key */

			call cobol_gen_ioerror (ft_ptr, ioerror_ptr);

			call cobol_define_tag (ntag);


		     end;

/* PERFORM READ */
		ntag = cobol_$next_tag;
		cobol_$next_tag = cobol_$next_tag + 1;

		alpha_type9.size = file_table.max_cra_size;
		alpha_type9.seg = file_table.cra_seg;
		alpha_type9.off = file_table.cra_offset;

		call cobol_set_pr (pr5_struct_ptr, addr (alpha_type9));


/*[3.0-2]*/
		if read_next_sw			/*[3.0-2]*/
		then do;
			call cobol_call_op (65, ntag);/* OPERATOR65(read_record) */

/*[3.0-2]*/
			if alt_sw
			then call cobol_define_tag (skip_read_tag);
						/*[3.0-2]*/
		     end;				/*[3.0-2]*/
		else call cobol_call_op (66, ntag);	/* OPERATOR66(nonseq_read_key) */

		call cobol_gen_ioerror (ft_ptr, ioerror_ptr);

		call cobol_define_tag (ntag);


/*[3.0-2]*/
		if alt_sw				/*[3.0-2]*/
		then do;
			call cobol_io_util$file_desc (file_table.file_desc_1_offset);
						/*[3.0-2]*/
			call cobol_set_fsbptr (ft_ptr);

/*[3.0-2]*/
			if read_next_sw		/*[3.0-2]*/
			then call cobol_call_op (80, 0);
						/* OPERATOR80(alt_read_next) */
						/*[3.0-2]*/
			else call cobol_call_op (81, 0);
						/* OPERATOR81(alt_read_key) */
		     end;

/* SET KEY IN FSB IF NECESSARY */
		if iosw
		then do;

			call cobol_set_fsbptr (ft_ptr);

			if file_table.organization = 1
			then call cobol_io_util$move_direct ("001"b, fsb_keylen_sw, 4, 1, (18)"1"b);

			else call cobol_io_util$move ("001"b, fsb_keylen_sw, 4, "110"b, keylen_off * 4, 4);

		     end;

	     end;

	if file_table.rec_do
	then do;					/* must set depending-on variable */

		if file_table.organization = 4
		then call cobol_io_util$fixed_add ("110"b, reclen_off * 4, -1, ""b, 0);
						/*for nl*/

		call cobol_io_util$bin_to_dec ("110"b, declen_off * 4, 12, "110"b, reclen_off * 4, 4);

		call cobol_read_rand (1, file_table.rec_do_info, fkey_ptr);

		addr (fkey_type9.file_key_info) -> file_key_desc = file_key.desc;
		mpout.pt1 = mp.pt (1);
		mpout.pt2 = addr (num_type9);
		num_type9.size, num_type9.places_left = 12;
		num_type9.seg = 1000;		/* in stack */
		num_type9.off = declen_off * 4;
		mpout.pt3 = addr (fkey_type9);
		mpout.pt4 = addr (type19);

		call cobol_move_gen (addr (mpout));

	     end;

	if file_table.code_set_clause & file_table.code_set = 12
	then do;					/* 12 = ebcdic */

		call cobol_trans_alphabet$io (addr (trans_type9), addr (alpha_type9), fixed (file_table.code_set), 1);

	     end;

	if end_stmt.b = "1"b
	then do;					/* move record INTO variable */

		mpout.pt1 = mp.pt (1);
		mpout.pt2 = addr (alpha_type9);
		mpout.pt3 = mp.pt (3);
		mpout.pt4 = addr (type19);

		call cobol_move_gen (addr (mpout));

	     end;

/* SET RELATIVE KEY IF NECESSARY */
	if file_table.organization = 2 & (file_table.access < 2 | end_stmt.d = "01"b) & file_table.relative_key
	then do;

		call cobol_read_rand (1, file_table.r_key_info, fkey_ptr);

		addr (fkey_type9.file_key_info) -> file_key_desc = file_key.desc;

		call cobol_set_fsbptr (ft_ptr);

		mpout.pt1 = mp.pt (1);
		mpout.pt2 = addr (num_type9);
		num_type9.size, num_type9.places_left = 16;
		num_type9.seg = 5001;
		num_type9.off = file_table.fsb.off + fsb_key;
		mpout.pt3 = addr (fkey_type9);
		mpout.pt4 = addr (type19);
		call cobol_move_gen (addr (mpout));

	     end;

	call cobol_reg_manager$after_op (4095 + ioerror.cobol_code);

/*[4.0-1]*/
	if end_stmt.f = "01"b			/*[4.0-1]*/
	then passed_tag = ioerror.is_tag;		/*[4.0-1]*/
	else call cobol_gen_ioerror$finish_up (ft_ptr, ioerror_ptr);

	return;



%include cobol_read_gen_info;
%include cobol_read_gen_data;
     end cobol_read_gen;




		    cobol_read_rand.pl1             05/24/89  1042.8rew 05/24/89  0832.7       20952



/****^  ***********************************************************
        *                                                         *
        * 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_read_rand.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 01/14/77 by ORN for new name_table handling */
/* Modified since Version 2.0 */

/*{*/
/* format: style3 */
cobol_read_rand:
cobol_read_rand_:
     proc (file_id, rec_id, file_ptr);

	arec_id = rec_id;
	goto start;

fixed_bin:
     entry (file_id, fb_rec_id, file_ptr);

	brec_id = fb_rec_id;

dcl	fb_rec_id		fixed bin;
dcl	file_id		fixed bin;
dcl	rec_id		char (5);
dcl	file_ptr		ptr;

/*
file_id		identifies the direct access file as
		follows:
		1	variable common
		2	name table
		3	name table buffer
		(input).

rec_id,fb_rec_id	identifies the record within the specified
		direct access file (input).

file_ptr		points to the record (output).
}*/


dcl	arec_id		char (5) aligned;
dcl	brec_id		fixed bin based (addr (arec_id));

dcl	inptr		ptr;

/*************************************/
start:
	if file_id = 3 | file_id = 2
	then do;
		inptr = cobol_ext_$cobol_ntfp;
		file_ptr = pointer (inptr, brec_id);
	     end;
	else do;
		inptr = cobol_ext_$cobol_cmfp;
		file_ptr = pointer (inptr, brec_id + 1);
	     end;
	return;


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

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

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

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

%include cobol_ext_;
     end cobol_read_rand;




		    cobol_receive_gen.pl1           05/24/89  1042.8rew 05/24/89  0832.7       47592



/****^  ***********************************************************
        *                                                         *
        * 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_receive_gen.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 10/02/77 by Bob Chang to fix the bug for mcs_icdp. */
/* Modified on 03/03/77 by Bob Chang to implement communication receive verb.	*/
/* Created as a stub on 11/18/76 by ORN */

/* format: style3 */
cobol_receive_gen:
     proc (in_token_ptr, next_stmt_tag);

/* Declaration for static data.	*/
dcl	1 pr_struc	static,
	  2 what_ptr	fixed bin init (2),
	  2 pointer_no	bit (3),
	  2 lock		fixed bin init (0),
	  2 switch	fixed bin init (0);

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

dcl	inst_seq		(12) bit (18) unaligned static init ("110000000000000000"b, "010101010001000000"b,
						/* spri2	pr6|offset	*/
			"000000000000000000"b, "010011101000000111"b,
						/* lda	0,dl		*/
			"110000000000000000"b, "111101101001000000"b,
						/* sta	pr6|offset	*/
			"110000000000000000"b, "100101000001000000"b,
						/* stz	pr6|offset	*/
			"110000000000000000"b, "010011100001000000"b,
						/* szn	pr6|offset	*/
			"000000000000000000"b, "110000000000000100"b);
						/* tze	0,ic		*/


/*	Automatic data	*/
dcl	next_stmt_tag	fixed bin,		/* PARAMETER for NO DATA statement	*/
	stoff		fixed bin,
	dn_ptr		ptr,
	temp		fixed bin;

/* External procedure	*/
dcl	cobol_call_op	entry (fixed bin, fixed bin),
	cobol_pointer_register$priority
			entry (fixed bin, fixed bin, bit (3)),
	cobol_emit	entry (ptr, ptr, fixed bin),
	cobol_define_tag	entry (fixed bin),
	cobol_make_tagref	entry (fixed bin, fixed bin, ptr),
	cobol_set_pr	entry (ptr, ptr),
	cobol_reg_manager$after_op
			entry (fixed bin),
	cobol_get_size	entry (ptr, fixed bin, fixed bin);

start:						/* Generate epp2 instruction for communication token.	*/
	cdtoken_ptr = in_token.token_ptr (2);
	alpha_type9.seg = cdtoken.cd_seg;
	eos_ptr = in_token.token_ptr (in_token.n);
	alpha_type9.off = cdtoken.cd_off - 60;
	call cobol_set_pr (addr (pr_struc), addr (alpha_type9));

/* Allocate 12 words in stack frame for parameters	*/
	stoff = 74;				/* Communication stack frame  from pr6|74	*/

/* Store cd_token address.	*/
	substr (inst_seq (1), 4, 15) = substr (unspec (stoff), 22, 15);
	call cobol_emit (addr (inst_seq (1)), null, 1);

/* Set up parameter for message type.	*/
	temp = stoff + 4;
	if end_stmt.b | end_stmt.c
	then do;
		if ^end_stmt.b
		then substr (inst_seq (3), 17, 2) = "01"b;
		else if end_stmt.c
		then substr (inst_seq (3), 17, 2) = "11"b;
		else substr (inst_seq (3), 17, 2) = "10"b;
		substr (inst_seq (5), 4, 15) = substr (unspec (temp), 22, 15);
		call cobol_emit (addr (inst_seq (3)), null, 2);
	     end;
	else do;
		substr (inst_seq (7), 4, 15) = substr (unspec (temp), 22, 15);
		call cobol_emit (addr (inst_seq (7)), null, 1);
	     end;

/* Generate epp2 instruction for receiving data item.	*/
	dn_ptr = in_token.token_ptr (3);
	call cobol_set_pr (addr (pr_struc), dn_ptr);

/* Store into stack frame.	*/
	temp = stoff + 2;
	substr (inst_seq (1), 4, 15) = substr (unspec (temp), 22, 15);
	call cobol_emit (addr (inst_seq (1)), null, 1);

/* Set up the size of the data token.	*/
	temp = stoff + 5;
	call cobol_get_size (dn_ptr, temp, 0);

/* Call cobol_operators_	*/
	call cobol_call_op (70, 0);

	call cobol_reg_manager$after_op (70);

/* Handle NO DATA statement.	*/
	if end_stmt.b
	then do;
		temp = stoff + 7;
		substr (inst_seq (9), 4, 15) = substr (unspec (temp), 22, 15);
		call cobol_emit (addr (inst_seq (9)), null, 2);
		next_stmt_tag = cobol_$next_tag;
		cobol_$next_tag = cobol_$next_tag + 1;
		call cobol_make_tagref (next_stmt_tag, cobol_$text_wd_off - 1, null);
	     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_in_token;
%include cobol_;
%include cobol_type19;
%include cobol_type9;
%include cobol_type13;
     end cobol_receive_gen;




		    cobol_reg_manager.pl1           05/24/89  1042.8rew 05/24/89  0832.7       52650



/****^  ***********************************************************
        *                                                         *
        * 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_reg_manager.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 12/17/79 by FCH, [4.3-1] illegal subscript ref deleted (TR4096) */
/* Modified since Version 4.3 */

/* format: style3 */
cobol_reg_manager:
     proc;

/*
This procedure is called by any procedure that generates
code to call a PL1 or Cobol operator.  This entry point must be called
before any code is generated to establish the interface with
the PL1 or Cobol operator. (i.e. before loading registers with
parameters to be passed to the operator).
This entry point:
	1.  genertaes code to save all locked registers.
	They must be restored after the return from the
	operator.  This can be done by a call to
	cobol_reset_r$after_operator.
	2.  unlocks all locked registers.
*/

/*  DECLARATION OF EXTERNAL ENTRIES  */

dcl	cobol_register_util$restore_pointer
			ext entry (bit (4));
dcl	cobol_register_util$restore
			ext entry (bit (4));

dcl	cobol_register_util$save
			ext entry (bit (4));
dcl	cobol_emit	ext entry (ptr, ptr, fixed bin);
dcl	cobol_reg_manager	entry (fixed bin);
dcl	cobol_reg_manager$set_pr5
			entry;
dcl	cobol_reg_manager$after_op
			entry (fixed bin);
dcl	cobol_register_util$save_pointer
			ext entry (bit (4));

/*  DECLARATION OF AUTOMATIC DATA.  */

dcl	i		fixed bin,
	temp		fixed bin,
	operator_num	fixed bin;		/*[4.3-1]*/
						/*	pointer_not_needed	(200) bit(8) static options(constant) init(
		(200)(1)"00000000"b),
	index_reg_not_needed	(200) bit(10) static options(constant) init(
		(200)(1)"0000000000"b); */
						/*[4.3-1]*/

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

before_op:
     entry (operator_num);

/*[4.3-1]*/
	if operator_num = 0 | operator_num >= 4096
	then temp = 1;
	else temp = operator_num;

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

/*  Save any register (A,Q or index) that is locked.  */

	do i = 0 to 9;				/*[4.3-1]*/
						/*	     if substr(index_reg_not_needed(temp),i,1)="0"b then do;*/
	     if reg_status.r_lock (i) ^= 0
	     then do;				/*  This register is locked.  */
		     call cobol_register_util$save ((get_bit_code (i)));
						/*  save the register.  */
		     reg_status.r_lock (i) = 0;	/*  Unlock it.  */
		end;				/*  This register is locked.  */
	end;					/*[4.3-1]*/
						/*	     end;*/

/*  Save any pointer register that is locked.  */

	do i = 0 to 7;				/*[4.3-1]*/
						/*	     if substr(pointer_not_needed(temp),i,1)="0"b then do;*/
	     if ptr_status.p_lock (i) ^= 0
	     then do;				/*  This pointer register is locked.  */
		     call cobol_register_util$save_pointer (substr (unspec (i), 33, 4));
		     ptr_status.p_lock (i) = 0;
		end;				/*  This pointer register is locked.  */
	end;					/*[4.3-1]*/
						/*	     end;*/





/**************************************
		entry for set_pr5
*****************************************/

set_pr5:
     entry;


	return;

/********************************************
	entry for after_op
**********************************************/

after_op:
     entry (operator_num);

/*[4.3-1]*/
	if operator_num = 0 | operator_num >= 4096
	then temp = 1;
	else temp = operator_num;

	do i = 0 to 9;				/*[4.3-1]*/
						/*	if substr(index_reg_not_needed(temp),i,1)="0"b then do;*/
	     reg_status.r_priority (i) = 0;
	     if reg_status.save_stack_count (i) ^= 0
	     then do;				/*  Must restore this register.  */
		     call cobol_register_util$restore ((get_bit_code (i)));
		     reg_status.r_lock (i) = 1;
		end;
	     else reg_status.r_lock (i) = 0;		/* ORN */
						/*

          reg_status.contents_sw(i)=0;
          */
						/*[4.3-1]*/
						/*	end;*/
	end;


	do i = 1, 2, 7;				/* 7/7/76 */
						/*[4.3-1]*/
						/*	     if substr(pointer_not_needed(temp),i,1)="0"b then do;*/
	     if ptr_status.save_stack_count (i) ^= 0
	     then do;
		     call cobol_register_util$restore_pointer (substr (unspec (i), 33, 4));
		     ptr_status.contents_sw (i) = 0;
		     ptr_status.p_priority (i) = 0;
		     ptr_status.p_lock (i) = 1;
		end;
	     else do;
		     ptr_status.p_lock (i) = 0;
		end;				/*[4.3-1]*/
						/*	     end;*/
	end;

	return;
get_bit_code:
     proc (fbin_code) returns (bit (4));

dcl	fbin_code		fixed bin,
	bit_code		bit (4);


	if fbin_code = 9
	then bit_code = "0010"b;			/*  Q  */
	else if fbin_code = 8
	then bit_code = "0001"b;			/*  A  */
	else bit_code = "1"b || substr (unspec (fbin_code), 34, 3);

	return (bit_code);

     end get_bit_code;

/* INCLUDE FILES USED BY THIS PROCEDUURE  */

dcl	1 ptr_status	(0:9) based (cobol_$ptr_status_ptr) aligned,
%include cobol_ptr_status;

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

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

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

dcl	1 reg_status	(0:9) based (cobol_$reg_status_ptr) aligned,
%include cobol_reg_status;


%include cobol_;

     end cobol_reg_manager;




		    cobol_register.pl1              05/24/89  1042.8rew 05/24/89  0832.7      167247



/****^  ***********************************************************
        *                                                         *
        * 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_register.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 09/03/83 by FCH, [4.1...], trace added */
/* Modified on 2/24/76 to cover the pl1 bit string handling */
/*	Last modified 1-21-76	by bc.	*/
/* format: style3 */
cobol_register:
     proc (reg_struc_ptr);				/* The procedure is not a valid entry point.	*/



dcl	reg_struc_ptr	ptr;			/* reg_struc_ptr is a pointer to the following structure (input) */

dcl	1 reg_struc	based (reg_struc_ptr),
	  2 what_reg	fixed bin,
	  2 reg_no	bit (4) unaligned,
	  2 filler1	bit (32) unaligned,		/* for bit string handling */
	  2 lock		fixed bin,
	  2 already_there	fixed bin,
	  2 contains	fixed bin,
	  2 pointer	ptr,
	  2 literal	bit (36);

/*
what_reg	specifies the register to be obtained.	(input)
	0 - A or Q or any index register.
	1 - A register.
	2 - Q register.
	3 - A and Q registers.
	4 - A or Q register.
	5 - any index register.
	1n - index register n.

reg_no	is the register that is assigned. (output).
	1 - A register.
	2 - Q register.
	3 - A and Q registers.
	1n - index register n.

lock	can have the following values. (input).
	0 - do not change the lock or unlock status of the register.
	1 - lock this register.
	2 - unlock all index registers and the A and Q registers.
	3 - unlock all index registers and the A and Q registers
	    and all pointer registers.
already_there	has the followoutg values. (output).
	0 - the register must be loaded.
	1 - the specified contents are already in the register
	    and it does not need to loaded.

contains	specifies the form of the contents of the register. (input).
	0 - the register will not contain a value that is meaningful
	    for register optimatization.
	    pointer and literal are not meaningful.
	1 - the register will contain a data item.
	    pointer must have a meaningful value.
	2 - the register will contain the value specified in "literal".
	3 - the register will contain a computed subscript, pointer must
	    have a meaningful value.
	4 - the register will contain a computed index,
	    pointer must have a meaningful value.
	5 - the register will contain a modified computed index,
	    pointer must have a meaningful value.

	Note:	The values 3, 4 and 5 are intended for  the use by
	    the addressibility handler and should not be of interest
	    to the most generators.

pointer	is one of the following:
	(a) - A pointer to a type 9 token. In this case "contains" is 1 (data item).
	(b) - A pointer to a structure (to be defined) for index or subscript
	    computations. In this case, "contains" is 3 (subscript), 4
	    (index) or 5 (modified index).

literal	is the literal value that will be in the register.

	*/

/*  DECLARATION OF EXTERNAL ENTRIES  */

dcl	ioa_$ioa_stream	entry options (variable);
dcl	cobol_register_util$save
			ext entry (bit (4));
dcl	cobol_register_util$restore
			ext entry (bit (4));
dcl	cobol_register_util$save_pointer
			ext entry (bit (4));
dcl	cobol_register_util$restore_pointer
			ext entry (bit (4));

dcl	signal_		entry (char (*), ptr, ptr);
dcl	1 error_message,
	  2 name		char (32) init ("cobol_register"),
	  2 length	fixed bin init (80),
	  2 message	char (80);
dcl	(i, max)		fixed bin;
dcl	temp_ptr		ptr;
dcl	zero_word		bit (36) based (temp_ptr);


/*}*/


/*{*/

load:
     entry (reg_struc_ptr);
	/***..... dcl LOCAL_NAME char (5) int static init ("$LOAD");/**/
	/***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME||LOCAL_NAME);/**/

/* This entry may be used for the following function:

	(a) - Obtain a register ( A, Q or an index register) for the caller.
	(b) - If the register is locked by someone already, save its content and make it
	      available to me.
	(c) - Make the contents of the register known to the utility.
	(d) - Inform the caller if the contents are already in the register.

	NOTE:	(c) and (d) are not implemented yet.


USAGE:	declare cobol_register$load entry(ptr);

	The declaration of reg_struc is described in the main entry point.

	call cobol_register$load(reg_struc_ptr);


	NOTE: (1) The caller is assured that the register he want will be available
		to him whatever it is locked or not.
	      (2) If the register is locked already, the content will be stored into
		some location and the address of that location will be saved on the
		top of register storage stack.
	      (3) Some instruction may be emitted to save the register content.
	      (4) Always remember to call the release entry to release the
		register when it is not needed anymore.

	*/

/*}*/
dcl	bit_reg_code	bit (4);



/**************************************************/
/*	START OF EXECUTION			*/
/*	ENTRY POINT:  load			*/
/**************************************************/



	reg_struc.already_there = 0;

/*  Unlock registers, if requested.  */
	if reg_struc.lock = 2 | reg_struc.lock = 3
	then do;					/*  Unlock was requested.  */

		do i = 0 to 9;			/*  Unlock A, Q, index registers.  */
		     if reg_status.save_stack_count (i) ^= 0
		     then do;			/*  Restore the register.  */
			     call cobol_register_util$restore ((reg_bit_code (i)));
			     reg_status.r_lock (i) = 1;
			end;			/*  Restore the register.  */
		     else reg_status.r_lock (i) = 0;
		end;				/*  UNlock A, Q, and index registers.  */

		if reg_struc.lock = 3
		then do;				/*  UNlock temporary pointer registers.  */

			if ptr_status.save_stack_count (1) ^= 0
			then do;			/*  Restore PR1  */
				call cobol_register_util$restore_pointer (substr (unspec (binary (1)), 33, 4));
				ptr_status.p_lock (1) = 1;
			     end;			/*  Restore PR1  */
			else ptr_status.p_lock (1) = 0;

			if ptr_status.save_stack_count (2) ^= 0
			then do;			/*  Restore PR2  */
				call cobol_register_util$restore_pointer (substr (unspec (binary (2)), 33, 4));
				ptr_status.p_lock (2) = 1;
			     end;			/*  Restore PR2  */
			else ptr_status.p_lock (2) = 0;

			if ptr_status.save_stack_count (7) ^= 0
			then do;			/*  Restore PR 7  */
				call cobol_register_util$restore_pointer (substr (unspec (binary (7)), 33, 4));
				ptr_status.p_lock (7) = 1;
			     end;			/*  Restore PR7  */
			else ptr_status.p_lock (7) = 0;

		     end;				/*  Unlock temporary pointer registers.  */

	     end;					/*  UNlock was requested.  */

	if (reg_struc.what_reg = 0 | reg_struc.what_reg = 4 | reg_struc.what_reg = 5)
	then call pick_a_register (reg_struc.what_reg, reg_struc.lock, reg_struc.reg_no);
	else call get_specific_reg (reg_struc.what_reg, reg_struc.lock, reg_struc.reg_no);
	reg_struc.filler1 = (32)"0"b;
/**************************************************/
						/*	RETURN POINT		*/
						/*	ENTRY: load			*/
/**************************************************/

	go to crx;


get_specific_reg:
     proc (reg_code, lock_code, return_bit_code);

/*
This internal procedure gets a specific register, locks it, if
requested, and returns the four bit code that describes the register.
*/

/*  DECLARATION OF THE PARAMETERS  */

dcl	reg_code		fixed bin;
dcl	lock_code		fixed bin;
dcl	return_bit_code	bit (4);

/*  DESCRIPTION OF THE PARAMETERS  */

/*
PARAMETER		DESCRIPTION

reg_code		A fixedd binary code that indicates the register
		to get.  (input)  This code is defined in
		the following table.

		 reg_code	|  register to get
		====================================
		  1	|  A
		  2	|  Q
		  3	|  A and Q
		 |n	|  index register "n"
		====================================

lock_code		A code that indicates whether the register
		is to be locked after it is gotten.  (input)
		This code is defined as follows:

		   0 - don't lock
		   1 - lock

return_bit_code	A bit code that identifies the register
		gotten.  (output)  This code is defined in
		the following table.

		  code	|  register
		==============================
		 "0001"b	|  A
		 "0010"b	|  Q
		 "0011"b	|  A and Q
		"1nnn"b	|  index register "n"

*/
dcl	work_reg_code	fixed bin;



/**************************************************/
/*	START OF EXECUTION			*/
/*	INTERNAL PROCEDURE get_specific_reg	*/
/**************************************************/

	if reg_code = 1
	then do;					/*  A register.  */
		work_reg_code = 8;
		return_bit_code = "0001"b;
	     end;					/*  A register.  */
	else if reg_code = 2
	then do;					/*  Q register.  */
		work_reg_code = 9;
		return_bit_code = "0010"b;
	     end;					/*  Q register.  */
	else if reg_code > 9
	then do;					/*  Index register.  */
		work_reg_code = reg_code - 10;
		return_bit_code = "1"b || substr (unspec (work_reg_code), 34, 3);
	     end;					/*  Index register.  */

	else do;					/*  Must be A and Q  */
		return_bit_code = "0011"b;
		if reg_status.r_lock (8) ^= 0
		then call cobol_register_util$save ("0001"b);
		reg_status.r_lock (8) = lock_code;
		return_bit_code = "0010"b;		/*  Q  */
		work_reg_code = 9;
	     end;					/*  Must be A and Q  */

	if reg_status.r_lock (work_reg_code) ^= 0
	then do;
		call cobol_register_util$save (return_bit_code);
		reg_status.r_lock (work_reg_code) = 1;
	     end;
	else reg_status.r_lock (work_reg_code) = lock_code;

	if reg_code = 3
	then return_bit_code = "0011"b;		/*  A and Q  */


     end get_specific_reg;


pick_a_register:
     proc (reg_code, lock_code, return_bit_code);

/*
This procedure picks a register from a set of registers specified
by the input parameter reg_code, locks it if specified, and
returns a four bit code that defines the register gotten.
*/

/*  DECLARATION OF THE PARAMETERS  */

dcl	reg_code		fixed bin;
dcl	lock_code		fixed bin;
dcl	return_bit_code	bit (4);

/*  DESCRIPTION OF THE  PARAMETERS  */

/*
PARAMETER		DESCRIPTION

reg_code		A code that indicates the set of registers
		from which one is to be gotten.  (inputt)
		This code is defined in the following table:

		  code	|  register set
		===================================
		  0	|  any register (A,Q, or index)
		  4	|  A or Q
		  5	|  any index register
		=====================================

lock_code	A code that indicates whether the register gotten
		is to be locked.  (input)

		  0 - no lock
		  1 - lock the register

return_bit_code	A code that identifies the register gotten
		by this procedure.  (output)

		 return_bit_code	|  register gotten
		=========================================
		  "0001"b		|  A
		  "0010"b		|  Q
		  "1nnn"b		|  index register "n"

*/

/**************************************************/
/*	START OF EXECUTION			*/
/*	INTERNAL PROCEDURE pick_a_register	*/
/**************************************************/

dcl	found_index	fixed bin;
dcl	i		fixed bin;
dcl	work_reg_code	fixed bin int static init (4);

	if (reg_code = 0 | reg_code = 5)
	then do;					/*  Any register.  */
						/*  Pick any index register.  */

		found_index = 0;
		do i = 0 to 7 while (found_index = 0);	/*  Scan for unlocked index register.  */
		     if reg_status.r_lock (i) = 0
		     then found_index = i;
		end;				/*  Scan for unlocked index register.  */

		if found_index = 0
		then do;				/*  All index registers are locked, pick one.  */
			work_reg_code = mod ((work_reg_code + 1), 7);
			return_bit_code = "1"b || substr (unspec (work_reg_code), 34, 3);
		     end;				/*  All index registers are locked, pick one.  */
		else do;				/*  Found an unlocked index register.  */
			work_reg_code = found_index;
			return_bit_code = "1"b || substr (unspec (found_index), 34, 3);
		     end;				/*  Found an unlocked index register.  */

	     end;					/*  Any register.  */

	else do;					/*  A or Q  */

		if reg_status.r_lock (8) = 0
		then do;				/*  A is not locked, use A.  */
			work_reg_code = 8;
			return_bit_code = "0001"b;
		     end;				/*  A is not locked, use A.  */

		else if reg_status.r_lock (9) = 0
		then do;				/*  Q is not locked, use Q  */
			work_reg_code = 9;
			return_bit_code = "0010"b;
		     end;				/*  Q is not locked, use Q  */
		else do;				/*  A and Q both locked.  */
						/*  PICK A !!!  */
			work_reg_code = 8;
			return_bit_code = "0001"b;
		     end;				/*  A and Q both locked.  */

	     end;					/*  A or Q  */

	if reg_status.r_lock (work_reg_code) ^= 0
	then call cobol_register_util$save (return_bit_code);
	reg_status.r_lock (work_reg_code) = lock_code;

     end pick_a_register;


reg_bit_code:
     proc (fixed_reg_code) returns (bit (4));

/*
This internal procedure maps a fixed binary register code into
a four bit code.
*/

dcl	fixed_reg_code	fixed bin;		/*  The fixed binary register code.  */

/*
This procedure maps a fixed binary register code into a four bit
code.  The following table defines the mapping.

fixed_reg_code	| meaning	|  mapped to bit code
========================================================

  0 - 7		|x0 - x7	|  "1nnn"b
  8		  A	|  "0001"b
  9		|  Q	|  "0010"b

*/

dcl	return_bit_code	bit (4);

	if fixed_reg_code = 8
	then return_bit_code = "0001"b;		/*  A  */
	else if fixed_reg_code = 9
	then return_bit_code = "0010"b;		/*  Q  */
	else return_bit_code = "1"b || substr (unspec (fixed_reg_code), 34, 3);

	return (return_bit_code);

     end reg_bit_code;


/*{*/

release:
     entry (reg_struc_ptr);
	/***..... dcl LOCAL_NAME2 char (8) int static init ("$RELEASE");/**/
	/***..... if  Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME||LOCAL_NAME2);/**/

/* This entry is used for the following function:
	(a) - Makes the register management aware that the contents of
	      the register (A, Q or index register) will be released.
	(b) - Restore the register from the top of the register saving
	      stack if there is something saved before.
	      Perform the register unlocking.
	(c) - Basically the caller is telling the utility:
	      "I plan to release the register which I have asked to get it
	       before. Please make it available to uture use again.".


	NOTE: (1) If the register stack is not empty, some instruction will be emitted
		to restore the register from the top of the stack.



USAGE:	declare cobol_register$release entry(ptr);

	The declaration of the register structure is the same as in the main entry point.
	However the meaning is  a little bit different.
what_reg	not used here.
reg_no	is the reg_no to be released. (input).
	1 - A register.
	2 - Q register.
	3 - A and Q registers.
	1n - index register n.
lock	same meaning as described in main entry point. (input).
already_there	not used.
contains	0 - the register will not contain a value that is meaningful for register optimatization.
	1 - the register will be stored into a data item. "pointer" must
	    have a meaningful value.
pointer	is a pointer to a type 9 token.
literal	not used.


	call cobol_register$release(reg_struc_ptr);

	*/


/*}*/
/**************************************************/
/*	START OF EXECUTION			*/
/*	ENTRY POINT:  release			*/
/**************************************************/


	if reg_struc.reg_no = "0001"b
	then do;					/*  Unlock A  */
		if reg_status.save_stack_count (8) ^= 0
		then do;				/*  Restore A  */
			call cobol_register_util$restore (reg_struc.reg_no);
			reg_status.r_lock (8) = 1;
		     end;				/*  Restore A  */
		else reg_status.r_lock (8) = 0;
	     end;					/*  Unlock A  */


	else if reg_struc.reg_no = "0010"b
	then do;					/*  Unlock Q  */
		if reg_status.save_stack_count (9) ^= 0
		then do;				/*  Restore Q  */
			call cobol_register_util$restore (reg_struc.reg_no);
			reg_status.r_lock (9) = 1;
		     end;				/*  Restore Q  */
		else reg_status.r_lock (9) = 0;
	     end;					/*  Unlock Q  */
	else if reg_struc.reg_no = "0011"b
	then do;					/*  Unlock A and Q  */

		if reg_status.save_stack_count (8) ^= 0
		then do;				/*  Restore A  */
			call cobol_register_util$restore ("0001"b);
			reg_status.r_lock (8) = 1;
		     end;				/*  Restore A  */
		else reg_status.r_lock (8) = 0;
		if reg_status.save_stack_count (9) ^= 0
		then do;				/*  Restore Q  */
			call cobol_register_util$restore ("0010"b);
			reg_status.r_lock (9) = 1;
		     end;				/*  Restore Q  */
		else reg_status.r_lock (9) = 0;
	     end;					/*  Unlock a and Q  */

	else do;					/*  Must be an index register.  */
		i = fixed (reg_struc.reg_no, 17, 0) - 8;
		if reg_status.save_stack_count (i) ^= 0
		then do;				/*  Restore the index.  */
			call cobol_register_util$restore (reg_struc.reg_no);
			reg_status.r_lock (i) = 1;
		     end;				/*  Restore the index.  */
		else reg_status.r_lock (i) = 0;
	     end;					/*  Must be an index register.  */



/**************************************************/
/*	RETURN POINT			*/
/*	ENTRY: release			*/
/**************************************************/
crx:	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(MY_NAME);/**/
	return;
priority:
     entry;
	call ioa_$ioa_stream ("error_output", "cobol_register$priority not yet implemented");
	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 (14) int static init ("COBOL_REGISTER");/**/

/*  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_ext_;

%include cobol_fixed_common;
%include cobol_;


dcl	1 ptr_status	(0:7) based (cobol_$ptr_status_ptr) aligned,
%include cobol_ptr_status;


dcl	1 reg_status	(0:9) based (cobol_$reg_status_ptr) aligned,
%include cobol_reg_status;
     end cobol_register;




		    cobol_register_util.pl1         05/24/89  1042.8rew 05/24/89  0832.7      142857



/****^  ***********************************************************
        *                                                         *
        * 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_register_util.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 09/03/83 by FCH, [5.2...], trace added */
/* Modified on 01/14/77 by ORN to signal command_abort_ rather than cobol_compiler_error */
/* Modified since Version 2.0 */

/* format: style3 */
cobol_register_util:
     proc (bit_reg_code);

/*
This procedure generates code to save and restore the arithmetic
registers, and pointer registers.  There are four entry points:
	1. save	- generates code to save A,Q,A and Q, or index.
	2. restore- generates code to restore A,Q,A and Q, or index
	3. save_pointer - generates code to save a pointer register.
	4. restore_pointer - generates code to restore a pointer
	register.
/*}*/

/*  DECLARATION OF THE PARAMETER  */

dcl	bit_reg_code	bit (4);

/*  DESCRIPTION OF THE PARAMETER  */

/*
PARAMETER		DESCRIPTION

bit_reg_code	A code that identifies the register to be
		saved or restored. The code is defined
		by the following tables:
		If this procedure is being called to save
		or restore A,Q, or index register:


		  code	|  register
		=======================================
		"0001"b	|  A
		"0010"b	|  Q
		"0011"b	|  A and Q
		"1nnn"b	|  index register nnn
		=========================================

		If this procedure is being called to save
		or restore a pointer register the code
		values are:

		  code	|  register
		========================================
		"0nnn"b	|  pointer register "nnn"b
		=========================================

*/

/*  DECLARATIONS OF EXTERNAL ENTRIES  */

dcl	signal_		ext entry (char (*), 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_addr	ext entry (ptr, ptr, ptr);	/*  DECLARATION OF INTERNAL STATIC DATA  */

dcl	STO		bit (7) int static init ("1111011"b);
						/*  Leftmost 7 bits of STA,STQ,STAQ opcodes.  */

dcl	STXN		bit (6) int static init ("111100"b);
						/*  Leftmost 6 bits of STXN opcode.  */

dcl	LOAD		bit (7) int static init ("0100111"b);
						/*  Leftmost 7 bits of LDA,LDQ,LDAQ opcodes.  */

dcl	LDXN		bit (6) int static init ("010010"b);
						/*  Leftmost 6 bits of LDXN opcode.  */

dcl	SPRPN		bit (6) int static init ("101100"b);
						/*  Leftmost 6 bits of SPRPn  */

dcl	LPRPN		bit (6) int static init ("111110"b);
						/*  Leftmost 6 bits of LPRPn  */


	/***.....
dcl       MY_NAME             char (19) int static init ("COBOL_REGISTER_UTIL");
dcl       SAVE_NAME           char (5) int static init ("$SAVE");
dcl       RESTORE_NAME        char (8) int static init ("$RESTORE");
dcl       SAVE_POINTER_NAME   char (13) int static init ("$SAVE_POINTER");
dcl       RESTORE_POINTER_NAME
                              char (16) int static init ("$RESTORE_POINTER");
/**/


dcl	1 error_message	int static,
	  2 name		char (32) init ("cobol_register_util"),
	  2 length	fixed bin init (80),
	  2 message	char (80);


/*  DECLARATIONS OF INTERNAL AUTOMATIC VARIABLES  */

dcl	work_reg_code	fixed bin;
dcl	work_opcode	bit (9);
dcl	fixed_reg_code	fixed bin;
dcl	temp_chars	fixed bin;
dcl	temp_offset	fixed bin;
dcl	binary_reg_code	fixed bin;

dcl	1 input_buff	aligned,
	  2 buffer	(1:10) fixed bin;



/*************************************/
save:
     entry (bit_reg_code);

/*
This entry point generates code to save a register (A,Q,A-Q, or index)
into temporary storage, and  saves the address and relocation information
in the register save_stack for the register being saved.
*/

	/***..... if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME||SAVE_NAME);/**/

/*  Map the bit register code into a fixed binary register code.  */

	fixed_reg_code = get_reg_code (bit_reg_code);

	if reg_status.save_stack_count (fixed_reg_code) = reg_status.save_stack_max (fixed_reg_code)
	then do;					/*  SAve stack is full, signal compile  time error.  */
		error_message.message = "save_stack overflow ($save entry)";
stack_overflow:
		call signal_ ("command_abort_", null (), addr (error_message));
		return;
	     end;					/*  Save stack is full, signal compile time error.  */

	if fixed_reg_code = 10
	then do;					/*  Saving A and Q.  */
		work_reg_code = 8;			/*  Save address of the temporary into which A-Q
		is stored into the save stack for the A register.  */
		temp_chars = 8;
	     end;					/*  Saving A and Q  */

	else do;
		work_reg_code = fixed_reg_code;
		temp_chars = 4;
	     end;

	call get_temp_storage (temp_chars, temp_offset);
	call establish_address (work_reg_code, temp_offset);

/*  Insert the proper opcode into the save_stack entry.  */
	if fixed_reg_code > 7
	then work_opcode = STO || substr (bit_reg_code, 3, 2);
						/*  Store A,Q,A-Q  */
	else work_opcode = STXN || substr (bit_reg_code, 2, 3);
						/*  Store index n  */

	temp_stack_count = reg_status.save_stack_count (fixed_reg_code);
	substr (reg_status.save_stack (fixed_reg_code, temp_stack_count), 19, 9) = work_opcode;

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

	go to exit_save;


/*************************************/
restore:
     entry (bit_reg_code);

/*
This entry point generates code to restore a register from a
saved value in the stack.
*/

	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME||RESTORE_NAME);/**/

/*  Map the bit code into a fixed binary code.  */

	work_reg_code = get_reg_code (bit_reg_code);

	if work_reg_code = 10			/*  A and Q  */
	then fixed_reg_code = 8;			/*  Address of the temp in which A and Q is stored is
		saved in the A register save_stack.  */
	else fixed_reg_code = work_reg_code;

	if reg_status.save_stack_count (fixed_reg_code) = 0
	then do;					/*  No register is saved..none can be restored.  */
		error_message.message = "save stack underflow ($restore entry)";
stack_underflow:
		call signal_ ("command_abort_", null (), addr (error_message));
		return;
	     end;					/*  No register is saved..non can be restored.  */

	temp_stack_count = reg_status.save_stack_count (fixed_reg_code);
	inst_ptr = addr (reg_status.save_stack (fixed_reg_code, temp_stack_count));

	reloc_ptr = addr (reg_status.reloc_stack (fixed_reg_code, temp_stack_count));


	if work_reg_code > 7
	then work_opcode = LOAD || substr (bit_reg_code, 3, 2);
						/*  Load A,Q or A-Q  */
	else work_opcode = LDXN || substr (bit_reg_code, 2, 3);
						/*  Load index n  */

	temp_stack_count = reg_status.save_stack_count (fixed_reg_code);
	substr (reg_status.save_stack (fixed_reg_code, temp_stack_count), 19, 9) = work_opcode;

/*  Decrement the top of stack pointer for the save_stack.  */
	reg_status.save_stack_count (fixed_reg_code) = reg_status.save_stack_count (fixed_reg_code) - 1;
	call cobol_emit (inst_ptr, reloc_ptr, 1);

exit_save:
exit_save_pointer:
exit_restore_pointer:
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(MY_NAME);/**/
	return;


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

save_pointer:
     entry (bit_reg_code);

/*
This entry point generates code to save a pointer register
into temporary storage, and saves the address at which the pointer
register is stored, and relocation information in the pointer register
save statck for the pointer register being saved.
*/

	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME||SAVE_POINTER_NAME);/**/

start_save_pointer:					/*  Convert the bit pointer register code to fixed binary.  */
	fixed_reg_code = fixed (bit_reg_code, 17);

	temp_stack_count = ptr_status.save_stack_max (fixed_reg_code);
	if ptr_status.save_stack_count (fixed_reg_code) = temp_stack_count
	then do;					/*  Pointer save stack for this pointer register is full.  */
		error_message.message = "save_stack overflow ($save_pointer entry)";
pointer_stack_overflow:
		call signal_ ("command_abort_", null (), addr (error_message));
		return;
	     end;					/*  Pointer save stack for this pointer register is full.  */

	call get_temp_storage (4 /*  number of bytes  */, temp_offset);
	call establish_address (fixed_reg_code + 10, temp_offset);

/*  Insert the opcode into the save stack entry.  */
	temp_stack_count = ptr_status.save_stack_count (fixed_reg_code);
	substr (ptr_status.save_stack (fixed_reg_code, temp_stack_count), 19, 9) = SPRPN || substr (bit_reg_code, 2, 3);

/*  Emit the instruction to store the pointer register into the temporary.  */
	call cobol_emit (inst_ptr, reloc_ptr, 1);

	go to exit_save_pointer;


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

restore_pointer:
     entry (bit_reg_code);

/*
This entry point generates code to restore a pointer register
from a saved value in a temporary (in the stack).
*/
	/***..... dcl RESTORE_POINTER char (15) int static init ("RESTORE_POINTER");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME||RESTORE_POINTER);/**/

start_restore_pointer:
	fixed_reg_code = fixed (bit_reg_code, 17);	/*  Check for stack underflow.  */
	if ptr_status.save_stack_count (fixed_reg_code) = 0
	then do;					/*  No pointer is saved...none can be restored.  */
		error_message.message = "save_stack underflow ($save_pointer entry)";
pointer_stack_underflow:
		call signal_ ("command_abort_", null (), addr (error_message));
		return;
	     end;					/*  No pointer is saved...none can be restored.  */

	temp_stack_count = ptr_status.save_stack_count (fixed_reg_code);
	inst_ptr = addr (ptr_status.save_stack (fixed_reg_code, temp_stack_count));
	temp_stack_count = ptr_status.save_stack_count (fixed_reg_code);
	reloc_ptr = addr (ptr_status.reloc_stack (fixed_reg_code, temp_stack_count));

	inst_struc_basic.fill1_op = LPRPN || substr (bit_reg_code, 2, 3);

/*  Emit the instruction to restore the pointer register from the saved value in temporary storage.  */
	call cobol_emit (inst_ptr, reloc_ptr, 1);

/*  Decrement the top of stack pointer (counter) for the save stack.  */
	ptr_status.save_stack_count (fixed_reg_code) = ptr_status.save_stack_count (fixed_reg_code) - 1;

	go to exit_restore_pointer;

get_reg_code:
     proc (reg_bit_code) returns (fixed bin);

/*
This internal procedure maps a four bit register code into a fixed binary
register code.
*/

dcl	reg_bit_code	bit (4);

dcl	binary_code	fixed bin;

	if reg_bit_code = "0001"b
	then binary_reg_code = 8;			/*  A  */
	else if reg_bit_code = "0010"b
	then binary_reg_code = 9;			/*  Q  */
	else if reg_bit_code = "0011"b
	then binary_reg_code = 10;			/*  A and Q  */
	else binary_reg_code = fixed (reg_bit_code, 17, 0) - 8;
						/*  Index register.  */

	return (binary_reg_code);

     end get_reg_code;

get_temp_storage:
     proc (byte_length, char_offset);

/*
This internal procedure allocates space on the stack for a temporary
in which a register is to be stored.
*/

/*  DECLARATION OF THE PARAMETERS  */

dcl	byte_length	fixed bin;
dcl	char_offset	fixed bin;

/*  DESCRIPTION OF THE  PARAMETERS  */

/*
PARAMETER		DESCRIPTION

byte_length	The number of bytes to allocate in the stack.
		This length will be 4 if the register being
		stored is A,Q,any index register or any
		pointer register, and 8 if the register being
		stored is the A-Q.  (input)
char_offset	The character offset of the leftmost character
		of the stack temporary.  (output)

*/

/*  Allocate space, aligned on a double word boundary.  */
	call cobol_alloc$stack (byte_length, 2, char_offset);

/*  Convert the returned word offset to a character offset.  */
	char_offset = char_offset * 4;

     end get_temp_storage;

establish_address:
     proc (binary_reg_code, temp_char_offset);

/*
This internal procedure establishes the address of the temporary
in the stack to receive a stored register.
*/

/*  DECLARATION OF THE PARAMETERS  */

dcl	binary_reg_code	fixed bin;
dcl	temp_char_offset	fixed bin;

/*  DESCRIPTION OF THE PARAMETERS  */

/*
PARAMETER		DESCRIPTION

binary_reg_code	A code that identifies the register being
		stored, and  that indicates
		the subscript of the register status structure
		entry in which the address is to be stored.
		This code specifies either a register (A,Q,
		or index) or a pointer register, as shown
		in the folllowing table:

		 code	|  register identified
		=========================================
		  0-7	|  index register 0-7
		  8	|  A
		  9	|  Q
		  10-17	|  pointer register 0-7
		==========================================


temp_char_offset	The character offset of the leftmost byte
		of the word in the stack into whichh the registe
		is to be stored.  (input)

*/

	if binary_reg_code < 10
	then do;					/*  Storing a register (A,Q,A-Q, or index)  */

		reg_status.save_stack_count (binary_reg_code) = reg_status.save_stack_count (binary_reg_code) + 1;
		temp_stack_count = reg_status.save_stack_count (binary_reg_code);
		inst_ptr = addr (reg_status.save_stack (binary_reg_code, temp_stack_count));

		temp_stack_count = reg_status.save_stack_count (binary_reg_code);
		reloc_ptr = addr (reg_status.reloc_stack (binary_reg_code, temp_stack_count));
	     end;					/*  Storing a register (A,Q,A-Q, or index)  */

	else do;					/*  Storing a pointer register.  */
		temp_stack_count = ptr_status.save_stack_count (binary_reg_code - 10);
		ptr_status.save_stack_count (binary_reg_code - 10) = temp_stack_count + 1;
		temp_stack_count = ptr_status.save_stack_count (binary_reg_code - 10);
		inst_ptr = addr (ptr_status.save_stack (binary_reg_code - 10, temp_stack_count));

		temp_stack_count = ptr_status.save_stack_count (binary_reg_code - 10);
		reloc_ptr = addr (ptr_status.reloc_stack (binary_reg_code - 10, temp_stack_count));
	     end;					/*  Storing a pointer register.  */

/*  Set up to call the addressability utility to establish the address
	of the stack temporary.  Note that the address and reloc information are stored into the
	proper save_stack for the register being stored.  */

	input_ptr = addr (input_buff);
	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 = temp_offset;

	call cobol_addr (input_ptr, inst_ptr, reloc_ptr);


     end establish_address;



	/***.....	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	temp_stack_count	fixed bin;

/*  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;
dcl	1 reg_status	(0:9) based (cobol_$reg_status_ptr) aligned,
%include cobol_reg_status;
dcl	1 ptr_status	(0:9) based (cobol_$ptr_status_ptr) aligned,
%include cobol_ptr_status;
%include cobol_;

     end cobol_register_util;




		    cobol_release_gen.pl1           05/24/89  1042.8rew 05/24/89  0832.7       82305



/****^  ***********************************************************
        *                                                         *
        * 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_release_gen.pl1 Added Trace statements.
  2) change(89-04-23,Zimmerman), approve(89-04-23,MCR8072),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8072 cobol_release_gen.pl1 Correct inverted sorts for some binary data
     types.
                                                   END HISTORY COMMENTS */


/* Modified on 10/23/84 by FCH, [5.3-2], BUG564(phx17268), SORT statement produces ipc fault at run time */
/* Modified on 10/19/84 by FCH, [5.3-1], BUG563(phx18381), new cobol_addr_tokens.inal.pl1 */
/* Modified on 5/16/76  by Bob Chang to implement the retry after error.	*/
/* Modified on 05/05/76 by Bob Chang to use call_op. */
/* Modified on 05/03/76 by Bob Chang to interface with cobol_rts_. */
/* Modified on 04/07/76 by Bob Chang to interface with multics sort package.	*/
/* Modified on 3/19/76 by Bob Chang to interface with the cobol_operators_. */
/* format: style3 */
cobol_release_gen:
     proc (in_token_ptr);

/*
The procedure cobol_release_gen generates the code necessary to
implement the COBOL RELEASE statement. The format of the RELEASE
statement is as follows:

R_E_L_E_A_S_E_ record-name  [F_R_O_M_  identifier ]

The execution of a RELEASE statement causes the record named by
record-name to be released to the initial phase of a sort operation.
If the FROM phrase is used, the contents of the identifier data
area are moved to the record-name, then the contents of record-name
aare released to the sort file. Moving takes place according to the
rules specified for the MOVE statement without the CORRESPONDING phrase.
The information in the record area is no longer available, but the
information in the data area associated with identifier is available.

After the execution of the RELEASE statement, the logical record is no
longer available in the record area unless the associated sort file
is named in a SAME RECORD AREA clause. The logical record is also
available to the program as a record of other files referenced in
the same SAME RECORD AREA clause as the associated sort file,
as well as to the file associated with record-name.
*/

/*  Code and relocation sequences.		*/

dcl	1 mpout		static,
	  2 n		fixed bin init (4),
	  2 pt1		ptr,
	  2 pt2		ptr,
	  2 pt3		ptr,
	  2 pt4		ptr;
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	1 num_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 ("000000100100000001000000000100000000"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 mlr_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 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 ("000100000001000000001000000101000000"b);
dcl	instr		(3) bit (36) unaligned static
			init ("000000000000000000000000000000000000"b, "000000000000000000000000000000000000"b,
			"000000000000000000000000000000000000"b);
dcl	rel_instr		(6) bit (5) aligned static
			init ("00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b);

dcl	inst_seq		(4) bit (18) unaligned static init ("000000000000000000"b, "011101011100010000"b,
						/* epp3 data_name	*/
			"000000000000000000"b, "010011110000000111"b);
						/* ldq length,dl	*/
						/*
Automatic data		*/

dcl	retry_tag		fixed bin,
	dn_ptr		ptr;			/* pointer to type 9 token		*/
dcl	buff1		(10) ptr,
	buff2		(10) ptr,
	buff3		(10) ptr;

/*
Procedures Called		*/

dcl	cobol_call_op	entry (fixed bin, fixed bin),
	cobol_define_tag	entry (fixed bin),
	cobol_reg_manager$after_op
			entry (fixed bin),
	cobol_addr	entry (ptr, ptr, ptr),
	cobol_emit	entry (ptr, ptr, fixed bin);

start:						/* reserve space for input structure. */
	input_ptr = addr (buff1);
	inst_ptr = addr (buff2);
	reloc_ptr = addr (buff3);

	retry_tag = cobol_$next_tag;
	call cobol_define_tag (retry_tag);
	cobol_$next_tag = cobol_$next_tag + 1;

	if in_token_ptr ^= null ()
	then do;					/* Extract the data_name item from second token. */

		if in_token.n = 4
		then do;
			mlr_struct.operand1.token_ptr = in_token.token_ptr (3);
			mlr_struct.operand2.token_ptr = in_token.token_ptr (2);

			instr (1) = mlr_reg_to_reg;
			instr (2) = "0"b;
			instr (3) = "0"b;

/*[5.3-2]*/
			dn_ptr = in_token.token_ptr (2);
						/*[5.3-2]*/
			call elem_to_non_elem;	/*[5.3-2]*/
			dn_ptr = in_token.token_ptr (3);
						/*[5.3-2]*/
			call elem_to_non_elem;

			call cobol_addr (addr (mlr_struct), addr (instr (1)), null ());
			substr (instr (1), 1, 9) = "000100000"b;
			call cobol_emit (addr (instr (1)), null (), 3);
		     end;
	     end;


	if in_token_ptr = null ()
	then do;
		call cobol_call_op (22, retry_tag);
		call cobol_reg_manager$after_op (22);
	     end;


	else do;					/* Set up link_off and rel_stack_off for inseq to call sort_$release.	     */
		substr (inst_seq (3), 4, 15) =
		     substr (unspec (in_token.token_ptr (2) -> data_name.item_length), 22, 15);
		input_struc.operand_no = 1;
		input_struc.type = 2;
		input_struc.token_ptr (1) = in_token.token_ptr (2);
		input_struc.lock = 0;
		call cobol_addr (input_ptr, addr (inst_seq (1)), reloc_ptr);
		call cobol_emit (addr (inst_seq), null (), 2);
		call cobol_call_op (11, retry_tag);
		call cobol_reg_manager$after_op (11);
	     end;

/* Reset the registers.	*/
	return;

elem_to_non_elem:
     proc;					/* elem token to non-elem token */

/*[5.3-2]*/
	if data_name.non_elementary
	then return;				/* non-elementary token */
						/*[5.3-2]*/
						/*[5.3-2]*/
	data_name.non_elementary = "1"b;		/*[5.3-2]*/
	data_name.elementary = "0"b;			/*[5.3-2]*/
						/*[5.3-2]*/
	if data_name.display
	then return;				/* display data */
						/*[5.3-2]*/
						/*[5.3-2]*/
	data_name.display = "1"b;			/*[5.3-2]*/
	data_name.comp = "0"b;			/*[5.3-2]*/
	data_name.places_right = 0;			/*[5.3-2]*/
						/*[5.3-2]*/
	if data_name.ascii_packed_dec_h | data_name.ascii_packed_dec
						/*[5.3-2]*/
	then do;
		data_name.ascii_packed_dec_h = "0"b;	/* comp or comp-8 */
						/*[5.3-2]*/
		data_name.ascii_packed_dec = "0"b;	/*[5.3-2]*/
	     end;					/*[5.3-2]*/
	else /*[5.3-2]*/
	     if data_name.bin_18			/* half word binary */
						/*[5.3-2]*/
	then do;
		data_name.bin_18 = "0"b;		/*[5.3-2]*/
						/*[5.3-2]*/
		if data_name.sync			/* sychronized */
						/*[5.3-2]*/
		then data_name.item_length = 4;	/*[5.3-2]*/
		else data_name.item_length = 2;	/*[5.3-2]*/
						/*[5.3-2]*/
		data_name.sync = "0"b;		/*[5.3-2]*/
	     end;					/*[5.3-2]*/
	else /*[5.3-2]*/
	     if data_name.bin_36			/* full word binary */
						/*[5.3-2]*/
	then do;
		data_name.item_length = 4;		/*[5.3-2]*/
		data_name.bin_36 = "0"b;		/*[5.3-2]*/
	     end;					/*[5.3-2]*/
	else /*[5.3-2]*/
	     if data_name.usage_index			/* indexed data item */
						/*[5.3-2]*/
	then do;
		data_name.item_length = 6;		/*[5.3-2]*/
		data_name.usage_index = "0"b;		/*[5.3-2]*/
	     end;					/*[5.3-2]*/
						/*[5.3-2]*/
	data_name.places_left = data_name.item_length;

     end;
/*****	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_;
%include cobol_type1;
%include cobol_type9;
%include cobol_type19;
     end cobol_release_gen;




		    cobol_reloc.pl1                 05/24/89  1042.8rew 05/24/89  0832.7       93501



/****^  ***********************************************************
        *                                                         *
        * 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_reloc.pl1 Added Trace statements.
                                                   END HISTORY COMMENTS */


/* Modified on 08/21/83 by FCH, [5.2 ...], trace added */
/* Modified on 01/14/77 by ORN to signal command_abort_ rather than cobol_compiler_error */
/* Modified since Version 2.0 */

/*{*/

/* format: style3 */
cobol_reloc:
     proc (reloc_ptr, count, code);

dcl	reloc_ptr		ptr;			/* pts to array of count bit(5)'s */
dcl	count		fixed bin;		/* number of half-words */
dcl	code		fixed bin;		/* internal segment code */

/*  This routine is called to append information to one of the
relocation blocks associated with either the text, linkage,
definition, or symbol section.  The argument code is the value
of the internal segment number of one of the above sections
(i.e. 3001, 3002, 3003, or 3004 respectively) or merely the
unit position digit (i.e. 1, 2, 3, or 4).

The relocation block for each of the four sections are declared
identically as follows:  */

%include cobol_relinfo;

/* If reloc_ptr is null then it is assumed that count half-words
of absolute relocation are to be added to the block.  Otherwise,
reloc_ptr points to the following array:  

dcl reloc (count) bit(5) aligned based(reloc_ptr);

Each bit(5) field contains the relocation code
for a half-word (with "00000"b indicating absolute relocation and
"11110"b invalid).  Compaction of absolute relocatable half-words
is handled automatically by cobol_reloc.   The relinfo.n_bits field in each
block is always kept up to date.  */

/*}*/
/*************************************/


dcl	creloc_ptr	ptr;
dcl	ccount		fixed bin;
dcl	reloc		(ccount) bit (5) aligned based (creloc_ptr);
						/* the real one */

dcl	1 seg		(4) static,
	  2 pt		ptr,
	  2 maxoff	fixed bin,
	  2 abscnt	fixed bin;

dcl	bits		bit (2359296) based;
dcl	bytes		char (262144) based;

dcl	(i, j, n)		fixed bin;
dcl	tcnt		fixed bin;
dcl	textbits		fixed bin;

dcl	null		builtin;
dcl	substr		builtin;
dcl	addr		builtin;

dcl	ioa_$rsnnl	entry options (variable);
dcl	signal_		entry (char (*), ptr, ptr);
dcl	bname		(4) char (10) init ("Text", "Definition", "Link", "Symbol");

/*************************************/
start:
start_reloc:
	creloc_ptr = reloc_ptr;
	ccount = count;

	if code > 3000
	then n = code - 3000;
	else n = code;

	if n = 2
	then n = 3;
	else if n = 3
	then n = 2;
join:						/* cobol_emit joins code here */
	if cobol_$reloc_sym_base_ptr -> relinfo.decl_vers ^= 2
	then do;					/* blocks truncated to zeros by cobol driver */
		seg.pt (1) = cobol_$reloc_text_base_ptr;
		seg.maxoff (1) = cobol_$reloc_text_max;
		seg.pt (2) = cobol_$reloc_def_base_ptr;
		seg.maxoff (2) = cobol_$reloc_def_max;
		seg.pt (3) = cobol_$reloc_link_base_ptr;
		seg.maxoff (3) = cobol_$reloc_link_max;
		seg.pt (4) = cobol_$reloc_sym_base_ptr;
		seg.maxoff (4) = cobol_$reloc_sym_max;
		do i = 1 to 4;
		     seg.abscnt (i) = 0;
		     seg.pt (i) -> relinfo.n_bits = 0;
		     seg.pt (i) -> relinfo.decl_vers = 2;
		end;
	     end;

	relptr = seg.pt (n);

	if creloc_ptr = null
	then do;					/* all absolute */
		if seg.abscnt (n) < 15
		then call start_abs (ccount);		/* no ongoing compaction */
		else call cont_abs (ccount);		/* increase compaction ccount */
	     end;

	else do i = 1 to ccount;			/* creloc_ptr is non-null */

		if reloc (i) ^= "00000"b
		then do;				/* relocation other than absolute */
			if n_bits + 5 > seg.maxoff (n)
			then go to overflow_error;
			substr (relbits, n_bits + 1, 5) = reloc (i);
			n_bits = n_bits + 5;
			seg.abscnt (n) = 0;
		     end;
		else do;
			do j = i + 1 to ccount while (reloc (j) = "00000"b);
			end;
			if seg.abscnt (n) < 15
			then call start_abs (j - i);
			else call cont_abs (j - i);
			i = j - 1;
		     end;
	     end;

	return;


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

start_abs:
     proc (pnum);

dcl	pnum		fixed bin parameter;

	tcnt = pnum + seg.abscnt (n);

	if tcnt < 15
	then call add_abs (pnum);			/* no sense compacting */
	else do;
		n_bits = n_bits - seg.abscnt (n);
		if tcnt > 1023
		then call fill_abs;			/* 1023 is max for one compaction record */
		if tcnt < 15
		then call add_abs (tcnt);
		else do;
			if n_bits + 15 > seg.maxoff (n)
			then go to overflow_error;
			substr (relbits, n_bits + 1, 5) = "11110"b;
						/* compaction code */
			substr (relbits, n_bits + 6, 10) = substr (unspec (tcnt), 27, 10);
			seg.abscnt (n) = tcnt;
			n_bits = n_bits + 15;
		     end;
	     end;
	return;
     end start_abs;

cont_abs:
     proc (pnum);

dcl	pnum		fixed bin parameter;

	tcnt = seg.abscnt (n) + pnum;

	if tcnt > 1023
	then do;
		n_bits = n_bits - 15;
		call fill_abs;
		if tcnt < 15
		then do;
			call add_abs (tcnt);
			return;
		     end;
		if n_bits + 15 > seg.maxoff (n)
		then go to overflow_error;
		substr (relbits, n_bits + 1, 5) = "11110"b;
		n_bits = n_bits + 15;
	     end;

	substr (relbits, n_bits - 9, 10) = substr (unspec (tcnt), 27, 10);
	seg.abscnt (n) = tcnt;
	return;

     end cont_abs;

add_abs:
     proc (pnum);

dcl	pnum		fixed bin parameter;

	if pnum + n_bits > seg.maxoff (n)
	then go to overflow_error;

	substr (relbits, n_bits + 1, pnum) = "0"b;
	n_bits = n_bits + pnum;
	seg.abscnt (n) = seg.abscnt (n) + pnum;
	return;

     end add_abs;

fill_abs:
     proc;

	do while (tcnt > 1023);
	     if n_bits + 15 > seg.maxoff (n)
	     then go to overflow_error;
	     substr (relbits, n_bits + 1, 15) = "111101111111111"b;
	     tcnt = tcnt - 1023;
	     seg.abscnt (n) = 0;
	     n_bits = n_bits + 15;
	end;
	return;

     end fill_abs;


/*************************************/
/*{*/
constants:
     entry (con_len, seg_ptr);

/* This is a special entry for use by cobol_paste in order to
create the relocation block for the constant portion of the
text section and insert it in front of the text relocation block. */

dcl	con_len		fixed bin;		/* number of words in constant section (input) */
dcl	seg_ptr		ptr;			/* set to addr of seg array (output) */
						/*}*/

start_constants:
	relptr = seg.pt (1);
	n = 1;
	textbits = n_bits;
	n_bits = 0;
	seg.abscnt (1) = 0;
	substr (cobol_$reloc_work_base_ptr -> bits, 1, textbits) = substr (seg.pt (1) -> bits, 73, textbits);

	call start_abs (con_len * 2);

	substr (seg.pt (1) -> bits, 73 + n_bits, textbits) = substr (cobol_$reloc_work_base_ptr -> bits, 1, textbits);
	n_bits = n_bits + textbits;
	seg_ptr = addr (seg);
	return;


/*************************************/
/*{*/

cobol_emit:
     entry (wd_ptr, text_reloc_ptr, numb_wds);

/* This procedure emits one or more words of information
(plus relocation code) into the executable portion of the
text section. */

dcl	wd_ptr		ptr;
dcl	text_reloc_ptr	ptr;
dcl	numb_wds		fixed bin;

/* dcl words (numb_wds) bit(36) based(wd_ptr);  */
/* dcl text_reloc (2*numb_wds) bit(5) aligned based(text_reloc_ptr);  */

/*
wd_ptr		is a pointer to an array of words (input).

text_reloc_ptr	is a pointer to an array of relocation
		codes "text_reloc" (input).  If this pointer
		is null, absolute relocation is assumed for
		the next numb_wds words.

numb_wds		is the number of words to be emmitted (input).
*/

/*}*/

start_emit:
	if cobol_$text_wd_off + cobol_$con_wd_off + numb_wds > 131072
	then go to emit_error;

	i = numb_wds * 4;

	/***.....	if Trace_Bit then call T1;/**/

	substr (addrel (cobol_$text_base_ptr, cobol_$text_wd_off) -> bytes, 1, i) = substr (wd_ptr -> bytes, 1, i);
	cobol_$text_wd_off = cobol_$text_wd_off + numb_wds;
	creloc_ptr = text_reloc_ptr;			/* set common ptr */
	ccount = 2 * numb_wds;			/* set common count */
	n = 1;					/* text relocation block */

	go to join;

	/***.....	dcl Trace_Bit bit(1) static external;/**/
	/***.....	dcl Trace_Lev fixed bin static external;/**/
	/***.....	dcl Trace_Line char(36) static external;/**/
	/***.....	dcl cobol_display_text$trace entry(ptr,fixed bin);/**/
	/***.....	dcl ioa_ entry options(variable);/**/

	/***.....	T1: proc;/**/
	/***.....		dcl (wd,wdc) fixed bin;/**/
	/***.....		dcl code(64) bit(36) based(wd_ptr);/**/
	/***.....		wdc=divide(i,4,31,0);/**/
	/***.....		call cobol_display_text$trace(addr(code(1)),wdc);/**/
	/***.....	end;/**/


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

emit_error:
	error_info.name = "cobol_emit";
	call ioa_$rsnnl ("Object instructions exceed 131072 words", message, message_len);
	go to error;

overflow_error:
	error_info.name = "cobol_reloc";
	call ioa_$rsnnl ("Overflow in ^a relocation block at ^d bits", message, message_len, bname (n), seg.maxoff (n));

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

%include cobol_error_info;
%include cobol_;

/*************************************/
/*{*/
/* display: entry;
/*
/* This is an entry to be used for debugging purposes.
It is called from command level and continues to prompt the
user for the internal segment number of the relocation block he is
interested in.  It informs him of the current number of
bits in that block and then prompts for a starting offset
from which it will display the rest of the block in 5-bit units. */
/*}*/
/*
/*dcl read_list_$prompt entry options(variable);
/*dcl ioa_ entry options(variable);
/*dcl ioa_$nnl entry options(variable);
/*dcl write_list_ entry options(variable);
/*
/*	call read_list_$prompt("Enter segment number:  ",n);
/*	call ioa_("relinfo.n_bits for ^a relocation block is ^d",bname(n),seg.pt(n)->n_bits);
/*	call read_list_$prompt("Enter starting offset:  ",j);
/*	do i = j to seg.pt(n)->n_bits by 5;
/*	     call ioa_$nnl("^3d	",i);
/*	     call write_list_(substr(seg.pt(n)->relinfo.relbits,i+1,5));
/*	end;
/**/

     end cobol_reloc;




		    cobol_reset_r.pl1               05/24/89  1042.8rew 05/24/89  0832.6       60939



/****^  ***********************************************************
        *                                                         *
        * 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_reset_r.pl1 Added Trace statements.
                                                   END HISTORY COMMENTS */


/* Modified on 09/23/83 by FCH, [5.2...], trace added */
/* Modified on 01/14/77 by ORN to signal command_abort_ rather than cobol_compiler_error */
/* Modified since Version 2.0 */

/* format: style3 */
cobol_reset_r:
     proc;

/*  DECLARATION OF EXTERNAL ENTRIES  */

dcl	cobol_register_util$restore_pointer
			ext entry (bit (4));
dcl	cobol_register_util$restore
			ext entry (bit (4));

dcl	signal_		entry (char (*), ptr, ptr);
dcl	1 error_message	static,
	  2 name		char (32) init ("cobol_reset_r"),
	  2 length	fixed bin init (24),
	  2 message	char (24);

dcl	reset_r_instr	(4) bit (36) static init ("110000000000011000011101000001010000"b,
						/* epp0	pr6|30,*		*/
			"110000000000100100011111000001010000"b,
						/* epp4	pr6|44,*		*/
			"110000000001101110011101011101010000"b,
						/* epp3	pr6|156,*		*/
			"110000000001110000011111001101010000"b);
						/* epp5	pr6|160,*		*/

dcl	cobol_emit	entry (ptr, ptr, fixed bin);
dcl	(i, j)		fixed bin;
dcl	k		fixed bin;
dcl	op_flag		fixed bin static init (1);
dcl	ptr_val		(1:4) fixed bin int static init (0, 4, 3, 5);

dcl	ptr_no		bit (3);

/*************************************/
pointer_register:
     entry (ptr_no);
start_pointer_register:
	/***..... dcl LOCAL_NAME char (17) int static init ("$POINTER_REGISTER");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME||LOCAL_NAME);/**/
	i = 0;
	if ptr_no = "000"b
	then i = 1;
	else if ptr_no = "011"b
	then i = 3;
	else if ptr_no = "100"b
	then i = 2;
	else if ptr_no = "101"b
	then i = 4;
	if i = 0
	then go to error_exit;
	if ptr_status.save_stack_count (ptr_val (i)) ^= 0
	then do;					/*  Must restore this pointer register.  */
		call cobol_register_util$restore_pointer ("0"b || ptr_no);
		ptr_status.contents_sw (i) = 0;
		ptr_status.p_lock (i) = 1;
	     end;					/*  Must restore this pointer register.  */
	else call cobol_emit (addr (reset_r_instr (i)), null (), 1);

	go to exit_pointer_register;

/*************************************/
after_call:
     entry;
start_after_call:
	/***..... dcl LOCAL_NAME4 char (11) int static init ("$AFTER_CALL");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME||LOCAL_NAME4);/**/
	i = 2;
	j = 4;

emit_:
	do k = i to j;
	     if ptr_status.save_stack_count (ptr_val (k)) > 0
	     then do;				/*  Register must be restored.  */
		     ptr_status.save_stack_count (ptr_val (k)) = ptr_status.save_stack_count (ptr_val (k)) - 1;
		     ptr_status.contents_sw (ptr_val (k)) = 0;
		     ptr_status.p_lock (ptr_val (k)) = 1;
		     ptr_status.p_priority (ptr_val (k)) = 0;
		end;				/*  Register must be restored.  */
	end;

reset:
	ptr_status.contents_sw (1) = 0;
	ptr_status.p_priority (1) = 0;
	if ptr_status.save_stack_count (1) ^= 0
	then do;
		call cobol_register_util$restore_pointer ("0001"b);
		ptr_status.p_lock (1) = 1;
	     end;
	else ptr_status.p_lock (1) = 0;
	ptr_status.contents_sw (2) = 0;
	ptr_status.p_priority (2) = 0;
	if ptr_status.save_stack_count (2) ^= 0
	then do;
		call cobol_register_util$restore_pointer ("0010"b);
		ptr_status.p_lock (2) = 1;
	     end;
	else ptr_status.p_lock (2) = 0;
	ptr_status.contents_sw (7) = 0;
	ptr_status.p_priority (7) = 0;
	if ptr_status.save_stack_count (7) ^= 0
	then do;
		call cobol_register_util$restore_pointer ("0111"b);
		ptr_status.p_lock (7) = 1;
	     end;
	else ptr_status.p_lock (7) = 0;


	do i = 0 to 9;
	     reg_status.r_priority (i) = 0;
	     if reg_status.save_stack_count (i) ^= 0
	     then do;				/*  Must restore this register.  */
		     call cobol_register_util$restore ((get_bit_code (i)));
		     reg_status.r_lock (i) = 1;
		end;
	     else reg_status.r_lock (i) = 0;		/* ORN */
						/*

          reg_status.contents_sw(i)=0;
          */
	end;
exit_pointer_register:
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(MY_NAME);/**/
	return;


/*************************************/
after_operator:
     entry;
start_after_operator:
	/***..... dcl LOCAL_NAME2 char (15) int static init ("$AFTER_OPERATOR");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME||LOCAL_NAME2);/**/
	i = 1;
	j = 4;
	go to emit_;


/*************************************/
in_line:
     entry;
start_in_line:
	/***..... dcl LOCAL_NAME3 char (8) int static init ("$IN_LINE");/**/
	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME||LOCAL_NAME3);/**/
	go to reset;



/*************************************/
error_exit:
	error_message.message = "Invalid PR specification";
	call signal_ ("command_abort_", null (), addr (error_message));
	return;


/*************************************/
get_bit_code:
     proc (fbin_code) returns (bit (4));

dcl	fbin_code		fixed bin;
dcl	bit_code		bit (4);

	if fbin_code = 9
	then bit_code = "0010"b;			/*  Q  */
	else if fbin_code = 8
	then bit_code = "0001"b;			/*  A  */
	else bit_code = "1"b || substr (unspec (fbin_code), 34, 3);

	return (bit_code);

     end get_bit_code;


	/***.....	dcl cobol_gen_driver_$Tr_Beg entry(char(*));/**/
	/***.....	dcl cobol_gen_driver_$Tr_End entry(char(*));/**/

	/***.....	dcl Trace_Bit bit(1) static external;/**/
	/***.....	dcl Trace_Lev fixed bin static external;/**/
	/***.....	dcl Trace_Line char(36) static external;/**/
	/***.....	dcl ioa_ entry options(variable); /**/
	/***..... dcl MY_NAME char (13) int static init ("COBOL_RESET_R");/**/

/*  INCLUDE FILES USED BY THIS PROCEDURE  */

dcl	1 ptr_status	(0:7) based (cobol_$ptr_status_ptr) aligned,
%include cobol_ptr_status;

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

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

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

dcl	1 reg_status	(0:9) based (cobol_$reg_status_ptr) aligned,
%include cobol_reg_status;
%include cobol_;

     end cobol_reset_r;




		    cobol_return_gen.pl1            05/24/89  1042.8rew 05/24/89  0832.6      108945



/****^  ***********************************************************
        *                                                         *
        * 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_return_gen.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 11/20/76 by Bob Chang to handle same_sort_merge  flag.	*/
/* Modified on 11/12/76 by Bob Chang to interface with merge_gen. */
/* Modified since Version 2.0	*/
/* format: style3 */
cobol_return_gen:
     proc (in_token_ptr, passed_tag);

/*
This procedure cobol_return generates the code necessary to
implement the COBOL RETURN statement. This format of the RETURN
staatement is as follows:

R_E_T_U_R_N_ file-name RECORD  [I_N_T_O_ identifier ];
		     AT E_N_D_ imperative-statement

The execution of the RETURN statement causes the next record,
in the order specified by the keys listed in the SORT statement,
to be made available for processing in the record areas
associated with the sort file.

If the INTO phrase is specified, the current record is moved
from the input area to the area specified by identifier according
to the rules for MOVE statement without the CORRESPONDING
phrase. The implied MOVE does not occur if there is an AT END
condition. Any subscripting or indexing associated with
identifier is evaluated after the record has been returned and
immediately before it is moved to the data item.

When the INTO phrase is used, the data is available in both
the input record area and the data area associated with identifier.

If no next logical record exist for the file at the time of the
execution of a RETURN statement, the AT END condition occurs. The
contents of the record area associated with the file when the
AT END condition occurs are undefined. After the execution
of the imperative-statement in the AT END phrase, no RETURN
statement may be executed as part of the current output
procedure.

NOTE:
The contents of any data items which lie beyound the range of the
current data record are undefined at the completion of the
execution of the RETURN statement.
*/

/*  Code and relocation sequences.		*/

dcl	1 read_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 mlr_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 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	rel_instr		(6) bit (5) aligned static
			init ("00000"b, "00000"b, "00000"b, "00000"b, "00000"b, "00000"b);

dcl	inst_seq1		(6) bit (18) static init ("110000000001001100"b, "010011101001000000"b,
						/* lda  pr6|76	*/
			"000000000000000000"b, "110000000000000100"b,
						/* tze	0,ic	*/
			"110000000001001010"b, "011101010001010000"b);
						/* epp2	pr6|74,*	*/
dcl	tra_inst		(2) bit (18) static init ("000000000000000000"b, "111001000000000100"b);
						/* tra	0,ic	*/

dcl	merge_check_inst	(4) bit (18) static init ("100000000000101001"b, "010011101001000000"b,
						/* lda	pr4|sort_merge_sw	*/
			"000000000000000000"b, "110000000000000100"b);
						/* tze	sort_tag	*/
dcl	rel_merge_check	(4) bit (5) aligned static init ("11001"b, "00000"b, "00000"b, "00000"b);

dcl	temp_type12	char (60) static,
	temp_file_ptr	ptr static,
	temp_type12_ptr	ptr static,
	temp_type9_ptr	ptr static;
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	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 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	fkey_ptr		ptr;
dcl	eos_buff		(5) ptr;

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 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	1 num_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 ("000000100100000001000000000100000000"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);
						/*
Automatic data		*/

dcl	retry_tag		fixed bin,
	sort_tag		fixed bin,
	exit_tag		fixed bin,
	dn_ptr		ptr,			/* pointer to type 9 token	*/
	ft_ptr		ptr,			/* pointer to the file table 	*/
	name_ptr		ptr,			/* pointer to type12 token */
	linkoff		fixed bin,		/* word offset of entry point link */
	passed_tag	fixed bin,
	def_tag		fixed bin,
	hold_addr		bit (18) based,
	return_error_code	fixed bin static init (53),
	merge_bit		bit (1) static init ("0"b),
	stackoff		fixed bin static init (0);	/* word offset in stack	*/

/*
Procedures Called		*/

dcl	cobol_read_rand	entry (fixed bin, char (5), ptr),
	cobol_read_gen	entry (ptr, fixed bin),
	cobol_io_util$bin_to_dec
			entry (bit (3) aligned, fixed bin, fixed bin, bit (3) aligned, fixed bin, fixed bin),
	cobol_move_gen	entry (ptr),
	cobol_addr	entry (ptr, ptr, ptr),
	cobol_call_op	entry (fixed bin, fixed bin),
	cobol_define_tag	entry (fixed bin),
	cobol_merge_return_gen
			entry (ptr, fixed bin),
	cobol_reg_manager$after_op
			entry (fixed bin),
	cobol_read_ft	entry (fixed bin, ptr),
	cobol_make_tagref	entry (fixed bin, fixed bin, ptr),
	cobol_make_merge_file
			entry (ptr, ptr, ptr, ptr),
	cobol_emit	entry (ptr, ptr, fixed bin);
start:
	eos_ptr = in_token.token_ptr (in_token.n);
	if end_stmt.f = "01"b | end_stmt.f = "00"b
	then do;
		passed_tag = cobol_$next_tag;
		cobol_$next_tag = cobol_$next_tag + 1;
		call sort;
		return;
	     end;
	else if end_stmt.f = "10"b
	then do;
		call merge;
		return;
	     end;
	else do;
		sort_tag = cobol_$next_tag;
		exit_tag = cobol_$next_tag + 1;
		cobol_$next_tag = cobol_$next_tag + 2;
		call cobol_emit (addr (merge_check_inst), addr (rel_merge_check), 2);
		call cobol_make_tagref (sort_tag, cobol_$text_wd_off - 1, null ());
		call merge;
		call cobol_emit (addr (tra_inst), null (), 1);
		call cobol_make_tagref (exit_tag, cobol_$text_wd_off - 1, null ());
		call cobol_define_tag (sort_tag);
		call sort;
		call cobol_define_tag (exit_tag);
		return;
	     end;

/*	BEGIN	sort	*/
sort:
     proc;

	retry_tag = cobol_$next_tag;
	call cobol_define_tag (retry_tag);
	cobol_$next_tag = cobol_$next_tag + 1;
	eos_ptr = addr (eos_buff);
	name_ptr = in_token.token_ptr (2);
	def_tag = cobol_$next_tag;
	cobol_$next_tag = cobol_$next_tag + 1;
	call cobol_call_op (13, retry_tag);
	call cobol_reg_manager$after_op (13);


	call cobol_read_ft (fd_token.file_no, ft_ptr);

/* Added to fix the bug for variable length item. 	*/
	if file_table.rec_do
	then do;
		call cobol_io_util$bin_to_dec ("110"b, 328, 12, "110"b, 304, 4);
		call cobol_read_rand (1, file_table.rec_do_info, fkey_ptr);
		addr (fkey_type9.file_key_info) -> file_key_desc = file_key.desc;
		mpout.pt1 = null ();
		mpout.pt2 = addr (num_type9);
		num_type9.size = 12;
		num_type9.places_left = 12;
		num_type9.seg = 1000;
		num_type9.off = 328;
		mpout.pt3 = addr (fkey_type9);
		mpout.pt4 = eos_ptr;
		end_stmt.e = 1;
		call cobol_move_gen (addr (mpout));
	     end;

	call cobol_emit (addr (inst_seq1 (1)), null (), 3);
	call cobol_make_tagref (def_tag, cobol_$text_wd_off - 2, null ());


	alpha_type9.size = file_table.max_cra_size;
	alpha_type9.seg = file_table.cra_seg;
	alpha_type9.off = file_table.cra_offset;
	dn_ptr = addr (alpha_type9);


	instr (1) = mlr_reg_to_reg;
	instr (2) = "010000000000000000000000"b || substr (unspec (file_table.max_cra_size), 25, 12);
	instr (3) = ""b;

	mlr_struct.operand2.token_ptr = dn_ptr;

	call cobol_addr (addr (mlr_struct), addr (instr (1)), null ());

	call cobol_emit (addr (instr (1)), null (), 3);
	if in_token.n >= 4
	then do;
		mlr_struct.operand2.token_ptr = in_token.token_ptr (3);
		in_token.token_ptr (3) -> data_name.numeric = "0"b;
		in_token.token_ptr (3) -> data_name.alphanum = "1"b;
		instr (1) = mlr_reg_to_reg;
		instr (2) = "010000000000000000000000"b || substr (unspec (file_table.max_cra_size), 25, 12);
		instr (3) = ""b;
		call cobol_addr (addr (mlr_struct), addr (instr (1)), null ());
		substr (instr (1), 1, 9) = "000100000"b;
		call cobol_emit (addr (instr (1)), null (), 3);
	     end;

	call cobol_emit (addr (tra_inst (1)), null (), 1);

/* AT END processing		*/

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

	call cobol_define_tag (def_tag);


	return;
     end sort;					/*	END	sort	*/

/*	BEGIN	merge	*/
merge:
     proc;
	call cobol_make_merge_file (in_token.token_ptr (2), temp_file_ptr, temp_type12_ptr, temp_type9_ptr);
	read_in_token.pt2 = temp_type12_ptr;
	read_in_token.pt3 = in_token.token_ptr (3);
	if in_token.n = 4
	then do;
		read_in_token.n = 4;
		read_in_token.pt4 = addr (type19_read_into);
	     end;
	else read_in_token.n = 3;
	call cobol_read_gen (addr (read_in_token), passed_tag);
	return;

     end merge;					/*	END merge	*/





/*****	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_file_key;
%include cobol_;
%include cobol_file_table;
%include cobol_type1;
%include cobol_type9;
%include cobol_type12;
%include cobol_type19;

     end cobol_return_gen;




		    cobol_rewrite_gen.pl1           05/24/89  1042.8rew 05/24/89  0832.6      106560



/****^  ***********************************************************
        *                                                         *
        * 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_rewrite_gen.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 03/18/81 by FCH, [4.4-2], rewrite with alt rec keys can cause abort, BUG470 */
/* Modified on 02/18/81,[4.4-1], operator  87 replaced by operator 93 */
/* Modified on 06/27/79 by FCH,[4.0-1], not option added for debug */
/* Modified on 11/13/78 by FCH,[3.0-1], alt rec_keys added */
/* Modified since Version 3.0 */

/* format: style3 */
cobol_rewrite_gen:
     proc (mp_ptr, passed_tag);

dcl	passed_tag	fixed bin;		/* for  in-line error handling */
dcl	ptag		fixed bin;
dcl	mp_ptr		ptr;
dcl	1 mp		based (mp_ptr),
	  2 n		fixed bin,		/* from 3 to 4 */
	  2 pt		(0 refer (mp.n)) ptr;	/* pt(1) pts to type1 token for REWRITE */
						/* pt(2) pts to type9 token for record to be rewritten */
						/* pt(3) pts to type9 token for FROM data IF end_stmt.c = "1"b */
						/* pt(n) pts to type19 token (eos) */

dcl	1 args,
	  2 entryno	fixed bin,
	  2 arglist_off	fixed bin,
	  2 stacktemp_off	fixed bin,
	  2 n		fixed bin,
	  2 arg		(4),
	    3 pt		ptr,
	    3 type	fixed bin,
	    3 off1	fixed bin,
	    3 off2	fixed bin,
	    3 value	bit (18) unal,
	    3 indirect	bit (1) unal,
	    3 overlay	bit (1) unal,
	    3 repeat_nogen	bit (1) unal,
	    3 regsw	bit (1) unal,
	    3 regno	bit (3) unal;

dcl	adjust_recptr_sw	bit (1);
dcl	argb		(4) bit (216) based (addr (args.arg (1)));
dcl	text		(0:100000) bit (36) based (cobol_$text_base_ptr);

dcl	ft_ptr		ptr;
dcl	fkey_ptr		ptr;
dcl	name_ptr		ptr;
dcl	dn_ptr		ptr;
dcl	arg_ptr		ptr;
dcl	ioerror_ptr	ptr;			/*[3.0-1]*/
declare	alt_sw		bit (1);
dcl	temp		fixed bin;
dcl	aloff		fixed bin;
dcl	size		fixed bin;
dcl	buflen_off	fixed bin;
dcl	buf_off		fixed bin;
dcl	ntag		fixed bin;
dcl	unopened_error_tag	fixed bin;
dcl	stoff		fixed bin;
dcl	hold_keylen_sw	fixed bin;
dcl	hold_key_wdoff	fixed bin;

/*************************************/
/*************************************/
/* INITIALIZATION */
start:
	pr5_struct_ptr = addr (pr5_struct);
	adjust_recptr_sw = "0"b;
	rw_ptr = mp.pt (1);
	dn_ptr = mp.pt (2);
	eos_ptr = mp.pt (mp.n);
	ioerror_ptr = addr (ioerror);
	ioerror.cobol_code = 0;
	ioerror.type1_ptr = mp.pt (1);
	ioerror.is_tag = 0;
	ioerror.mode = 0;

	if end_stmt.b = "1"b
	then do;					/* in-line error coding follows */

		ioerror.is_tag = cobol_$next_tag;	/* to be defined at end of generated code for WRITE */
		ptag, passed_tag = cobol_$next_tag + 1; /* to be defined by gen driver at end of in-line coding */
		ioerror.ns_tag = ptag;
		cobol_$next_tag = cobol_$next_tag + 2;

	     end;
	else do;

		ioerror.is_tag = 0;
		ptag = 0;
		ioerror.ns_tag = cobol_$next_tag;	/* to be defined at end of generated code */
		cobol_$next_tag = cobol_$next_tag + 1;

	     end;

	arg_ptr = addr (args);

	call cobol_read_ft (data_name.file_num, ft_ptr);

	call cobol_alloc$stack (316, 2, aloff);		/* enough for 79 words - aloff is a wd offset */

	args.arglist_off = aloff;
	buflen_off = 80;


/*************************************/
/* START CODE GENERATION */
start_codegen:					/* MAKE SURE FILE IS OPEN */
	ioerror.retry_tag = cobol_$next_tag;
	unopened_error_tag = cobol_$next_tag + 1;
	cobol_$next_tag = cobol_$next_tag + 2;

	call cobol_define_tag (ioerror.retry_tag);

	call cobol_set_fsbptr (ft_ptr);


/* MOVE FROM DATANAME TO BUFFER IF NECESSARY */

	if end_stmt.c = "1"b
	then do;					/* FROM specified */

		mpout.pt1 = mp.pt (1);
		mpout.pt2 = mp.pt (3);
		mpout.pt3 = mp.pt (2);
		mpout.pt4 = addr (type19);

		call cobol_move_gen (addr (mpout));

	     end;

/* ESTABLISH RECORD LENGTH */
	if ^file_table.variable
	then do;

		temp = file_table.max_cra_size;

		call cobol_io_util$move_direct ("110"b, buflen_off * 4, 4, 1, substr (unspec (temp), 19, 18));

	     end;
	else do;

		if ^file_table.rec_do
		then call cobol_get_size (dn_ptr, buflen_off, reserved_word.line);
		else do;

			call cobol_read_rand (1, file_table.rec_do_info, fkey_ptr);

			addr (fkey_type9.file_key_info) -> file_key_desc = file_key.desc;

			call cobol_io_util$t9dec_to_bin ("110"b, buflen_off * 4, addr (fkey_type9));

		     end;

	     end;

/* CONVERT IF CODE SET INDICATES SO */
	if file_table.code_set_clause
	then if file_table.code_set = 12
	     then do;				/* 12 = ebcdic */

		     call cobol_alloc$stack (data_name.size + 1, 2, stoff);
						/*-10/07/76-*/

		     trans_type9.seg = 1000;		/* in stack */
		     trans_type9.off = stoff * 4;	/*-10/07/76-*/
		     trans_type9.size = data_name.size;

		     call cobol_trans_alphabet$io (dn_ptr, addr (trans_type9), fixed (file_table.code_set), 0);

		     dn_ptr = addr (trans_type9);	/* set to converted record for remainder of this generator */

		end;

/*[3.0-1]*/
	alt_sw = file_table.organization = 3 /* ind */ /*[3.0-1]*/ & /*[3.0-1]*/ file_table.alternate_keys ^= 0;

	if file_table.access < 2
	then do;					/* sequential access */

		ntag = cobol_$next_tag;
		cobol_$next_tag = cobol_$next_tag + 1;

		call cobol_io_util$bypass_seqerror (ntag);

		call cobol_ioop_util$set_x5 (rewrite_seq_errno);
						/* OPERATOR54(delete_error) */
		call cobol_call_op (54, ntag);	/* ERROR_OP */

		call cobol_gen_ioerror (ft_ptr, ioerror_ptr);

		call cobol_define_tag (ntag);

		if file_table.organization = 3	/* indexed */
		then do;				/* make sure key matches - always will for relative */

			call cobol_read_rand (1, file_table.r_key_info, fkey_ptr);

			addr (fkey_type9.file_key_info) -> file_key_desc = file_key.desc;

			ntag = cobol_$next_tag;
			cobol_$next_tag = cobol_$next_tag + 1;

			call cobol_io_util$compare_key (ntag, addr (fkey_type9));

			call cobol_io_util$move_direct ("001"b, fsb_keylen_sw, 4, 1, ""b);
						/* zero the switch */

			call cobol_ioop_util$set_x5 (key_mismatch_errno);
						/* OPERATOR54(delete_error) */
			call cobol_call_op (54, ntag);/* ERROR_OP */

			call cobol_gen_ioerror (ft_ptr, ioerror_ptr);

			call cobol_define_tag (ntag);

		     end;

		call cobol_io_util$move_direct ("001"b, fsb_keylen_sw, 4, 1, ""b);
						/* zero the switch */

		call rew_rec;

	     end;

	else do;					/* random or dynamic access - use specified key */


		call cobol_read_rand (1, file_table.r_key_info, fkey_ptr);

		addr (fkey_type9.file_key_info) -> file_key_desc = file_key.desc;
		mpout.pt1 = mp.pt (1);
		mpout.pt2 = addr (fkey_type9);

		if file_table.organization = 2
		then do;				/*relative */

			mpout.pt3 = addr (num_type9);
			size, num_type9.size, num_type9.places_left = 16;
			num_type9.seg = 5001;	/* from PR1 */
			num_type9.off = file_table.fsb.off + fsb_key;

		     end;
		else do;				/* indexed */

			if file_table.access = 3 & (file_table.external | file_table.open_out)
			then do;

				ntag = cobol_$next_tag;
				cobol_$next_tag = cobol_$next_tag + 1;

				call cobol_io_util$bypass_mode_error (ntag, "11"b);
						/* must cause error if in output mode */

				call cobol_ioop_util$set_x5 (output_errno);
						/* OPERATOR54(delete_error) */
				call cobol_call_op (54, ntag);
						/* ERROR_OP */

				call cobol_gen_ioerror (ft_ptr, ioerror_ptr);

				call cobol_define_tag (ntag);

/*[4.4-2]*/
/* call cobol_set_fsbptr(ft_ptr); */

			     end;

			mpout.pt3 = addr (alpha_type9);
			size, alpha_type9.size = fkey_type9.size;
			alpha_type9.seg = 5001;	/* from PR1 */
			alpha_type9.off = file_table.fsb.off + fsb_key;

		     end;

/*[4.4-2]*/
		call cobol_set_fsbptr (ft_ptr);	/*[4.4-2]*/
		call cobol_io_util$set_fsb_loc;

		if ^alt_sw & file_table.access = 3 & file_table.read_next
		then do;

/* read key */
			call cobol_alloc$stack (260, 2, stoff);
						/* area known as TEMP read key area */

			call cobol_ioop_util$lda_du (stoff);

			call cobol_ioop_util$set_icode;

			ntag = cobol_$next_tag;
			cobol_$next_tag = cobol_$next_tag + 1;

			call cobol_call_op (55, ntag);/* OPERATOR55(read_key) */

			call cobol_gen_ioerror (ft_ptr, ioerror_ptr);


			call cobol_define_tag (ntag);

			call cobol_set_fsbptr (ft_ptr);

			mpout.pt4 = addr (type19);

			call cobol_move_gen (addr (mpout));

			call cobol_io_util$move_direct ("001"b, fsb_keylen_sw, 4, 1, substr (unspec (size), 19, 18))
			     ;

			ntag = cobol_$next_tag;
			cobol_$next_tag = cobol_$next_tag + 1;

			call cobol_ioop_util$lda_du (stoff);

			call cobol_ioop_util$set_icode;

			call cobol_set_pr (pr5_struct_ptr, dn_ptr);
						/* OPERATOR58(special_rewrite) */
			call cobol_call_op (58, ntag);/* seek_key BUFF,rewrite_record,seek_key TEMP,position if EOF*/

			call cobol_gen_ioerror (ft_ptr, ioerror_ptr);

			call cobol_define_tag (ntag);

		     end;
		else do;
			ntag = cobol_$next_tag;
			cobol_$next_tag = cobol_$next_tag + 1;

/*[4.4-2]*/
/* call cobol_set_fsbptr(ft_ptr); */

			mpout.pt4 = addr (type19);

			call cobol_move_gen (addr (mpout));

			call cobol_io_util$move_direct ("001"b, fsb_keylen_sw, 4, 1, substr (unspec (size), 19, 18))
			     ;

/*[3.0-1]*/
			if alt_sw			/*[4.4-2]*/
			then do;
				call cobol_io_util$fsb_key_loc (6);
						/* epp1 pr1|6 */
						/*[3.0-1]*/
				call cobol_io_util$file_desc (file_table.file_desc_1_offset);

/*[3.0-1]*/
				call cobol_call_op (85, 0);
						/* OPERATOR85(alt_special_delete) */
						/*[3.0-1]*/
				call cobol_set_fsbptr (ft_ptr);
						/*[3.0-1]*/
			     end;

			call cobol_ioop_util$set_icode;

			call cobol_call_op (41, ntag);/* OPERATOR41(seek_key) */

			call cobol_gen_ioerror (ft_ptr, ioerror_ptr);

			call cobol_define_tag (ntag);

			call rew_rec;

		     end;

	     end;

	call cobol_reg_manager$after_op (4095 + ioerror.cobol_code);

/*[4.0-1]*/
	if end_stmt.f = "01"b			/*[4.0-1]*/
	then passed_tag = ioerror.is_tag;		/*[4.0-1]*/
	else call cobol_gen_ioerror$finish_up (ft_ptr, ioerror_ptr);

	return;

rew_rec:
     proc;

/*[3.0-1]*/
	if alt_sw					/*[3.0-1]*/
	then do;
		ntag = cobol_$next_tag;		/*[3.0-1]*/
		cobol_$next_tag = cobol_$next_tag + 1;	/*[4.4-1]*/
		call cobol_set_pr (pr5_struct_ptr, dn_ptr);
						/*[4.4-1]*/
		call cobol_call_op (93, ntag);	/* OPERATOR93(alt_rewrite) */
						/*[3.0-1]*/
		call cobol_gen_ioerror (ft_ptr, ioerror_ptr);
						/*[3.0-1]*/
		call cobol_define_tag (ntag);		/*[3.0-1]*/
		call cobol_set_fsbptr (ft_ptr);	/*[3.0-1]*/
	     end;

	ntag = cobol_$next_tag;
	cobol_$next_tag = cobol_$next_tag + 1;

	call cobol_set_fsbptr (ft_ptr);

	call cobol_set_pr (pr5_struct_ptr, dn_ptr);

	call cobol_ioop_util$set_icode;

	call cobol_call_op (59, ntag);		/* OPERATOR59(rewrite) */

	call cobol_gen_ioerror (ft_ptr, ioerror_ptr);

	call cobol_define_tag (ntag);

/*[3.0-1]*/
	if alt_sw					/*[3.0-1]*/
	then do;
		ntag = cobol_$next_tag;		/*[3.0-1]*/
		cobol_$next_tag = cobol_$next_tag + 1;

/*[3.0-1]*/
		call cobol_call_op (88, ntag);	/* OPERATOR88(alt_rewrite_add) */
						/*[3.0-1]*/
		call cobol_gen_ioerror (ft_ptr, ioerror_ptr);
						/*[3.0-1]*/
		call cobol_define_tag (ntag);		/*[3.0-1]*/
	     end;

     end;

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

%include cobol_rewrite_gen_info;
%include cobol_rewrite_gen_data;
     end cobol_rewrite_gen;




		    cobol_search_gen.pl1            05/24/89  1042.8rew 05/24/89  0832.6      436932



/****^  ***********************************************************
        *                                                         *
        * 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_search_gen.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_search_gen.pl1 Fix wild array subscript.
                                                   END HISTORY COMMENTS */


/* Modified on 02/11/85 by FCH, [5.3-2], BUG561, search_flag=0 in fmt4_eos */
/* Modified on 10/19/84 by FCH, [5.3-1], BUG563(phx18381), new cobol_addr_tokens.incl.pl1 */
/* Modified on 09/11/81 by FCH, [5.0-1], set search_flag to 1 in fmt3_eos not fmt1_eos, BUG503(phx11385) */
/* Modified on 09/08/77 by Bob Chang to fix the bug for not setting numeric_lit.places_left. */
/* Modified on 7/18/76 by Bob Chang to handle  the varying length data. */








/* format: style3 */
cobol_search_gen:
     proc (in_token_ptr, search_flag);

/*
This procedure generates code for the Cobol Search statment.  */
/*  Because of the way the PD syntax phase parses the
SEARCH statement, cobol_search_gen will be called more than
once to generate code for a single SEARCH statement.  See
details below in the documentation for the separate internal
procedures used to implement the code generation.  */

/*
The current implemenattion generates code only for format 1
SEARCH statements.  If called to generate code for format 2
SEARCH statements, a diagnostic is issued, and unpredictable
code is generated.
*/

/*  DECLARATION OF THE PARAMETERS  */

/*  dcl in_token_ptr ptr;  */
/*  THIS PARAMETER IS DECLARED BELOW IN AN INCLUDE FILE  */
dcl	search_flag	fixed bin;

/*  DECLARATION OF EXTERNAL ENTRIES  */

dcl	cobol_register$load ext entry (ptr);
dcl	ioa_$ioa_stream	ext entry options (variable);
dcl	cobol_compare_gen	ext entry (ptr);
dcl	cobol_emit	ext entry (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_set_gen	ext entry (ptr);
dcl	cobol_add_gen	ext entry (ptr, fixed bin);
dcl	cobol_read_rand	entry (fixed bin, char (5), ptr);
dcl	cobol_make_type9$copy
			ext entry (ptr, ptr);
dcl	cobol_addr	ext entry (ptr, ptr, ptr);
dcl	cobol_process_error ext entry (fixed bin, fixed bin, fixed bin);
dcl	cobol_alloc$stack	ext entry (fixed bin, fixed bin, fixed bin);



/*}*/


/*************************************************/
/*	START OF EXECUTION			*/
/*	cobol_search_gen			*/
/**************************************************/

/*  Save the in_token_ptr.  */
	save_in_token_ptr = in_token_ptr;

	if in_token.token_ptr (in_token.n) -> end_stmt.a = "000"b
	then call format1_search;
	else call format2_search;			/*  Restore the in_token_ptr to its original value.  */
	in_token_ptr = save_in_token_ptr;







/*  DECLARATIONS OF INTERNAL STATIC VARIABLES  */

dcl	1 set_eos_token	int static,
	  2 size		fixed bin (15) init (38),
	  2 line		fixed bin (15) init (0),
	  2 column	fixed bin (15) init (0),
	  2 type		fixed bin (15) init (19),	/*  EOS  */
	  2 verb		fixed bin (15) init (31),	/*  SET  */
	  2 e		fixed bin (15),
	  2 h		fixed bin (15),
	  2 i		fixed bin (15),
	  2 j		fixed bin (15),
	  2 a		bit (3) init ("000"b),	/*  SET FOR EITHER FMT 1 OR FMT 2  */
	  2 b		bit (1) init ("0"b);	/*  SET FOR FMT 1 OR FMT 2   */


dcl	1 numeric_lit_1	int static,
	  2 size		fixed bin (15) init (36),
	  2 line		fixed bin (15) init (0),
	  2 column	fixed bin (15) init (0),
	  2 type		fixed bin (15) init (2),	/*  NUMERIC LITERAL  */
	  2 integral	bit (1) init ("1"b),
	  2 floating	bit (1) init ("0"b),
	  2 filler1	bit (5) init ("00000"b),
	  2 subscript	bit (1) init ("0"b),
	  2 sign		char (1) init (" "),
	  2 exp_sign	char (1) init (" "),
	  2 exp_places	fixed bin (15) init (0),
	  2 places_left	fixed bin (15) init (1),
	  2 places_right	fixed bin (15) init (0),
	  2 places	fixed bin (15) init (1),
	  2 literal	char (1) init ("1");



dcl	1 add_eos_token	int static,
	  2 size		fixed bin (15) init (38),
	  2 line		fixed bin (15) init (0),
	  2 column	fixed bin (15) init (0),
	  2 type		fixed bin (15) init (19),	/*  EOS  */
	  2 verb		fixed bin (15) init (2),	/*  ADD  */
	  2 e		fixed bin (15) init (1),	/*  left operands  */
	  2 h		fixed bin (15) init (1),	/*  right operands  */
	  2 i		fixed bin (15) init (0),
	  2 j		fixed bin (15) init (0),
	  2 a		bit (3) init ("000"b),	/*  FORMAT 1  */
	  2 b		bit (1) init ("0"b);	/*  NO OSE CLAUSE PRESENT  */


dcl	1 compare_eos_token int static,
	  2 size		fixed bin (15) init (38),
	  2 line		fixed bin (15) init (0),
	  2 column	fixed bin (15) init (0),
	  2 type		fixed bin (15) init (19),	/*  EOS  */
	  2 verb		fixed bin (15) init (13),	/*  BRANCH  */
	  2 e		fixed bin (15) init (0),	/*  SET TO GREATER OR EQUAL  */
	  2 h		fixed bin (15) init (0),
	  2 i		bit (36) init ("010"b);	/*  TRANSFER IF CONDITION NOT TRUE  */


dcl	1 work_numeric_lit	int static,
	  2 size		fixed bin (15) init (36),
	  2 line		fixed bin (15) init (0),
	  2 column	fixed bin (15) init (0),
	  2 type		fixed bin (15) init (2),	/*  NUMERIC LITERAL  */
	  2 integral	bit (1) init ("1"b),
	  2 floating	bit (1) init ("0"b),
	  2 filler1	bit (5) init ("00000"b),
	  2 subscript	bit (1) init ("0"b),
	  2 sign		char (1) init (" "),
	  2 exp_sign	char (1) init (" "),
	  2 exp_places	fixed bin (15) init (0),
	  2 places_left	fixed bin (15) init (0),
	  2 places_right	fixed bin (15) init (0),
	  2 places	fixed bin (15) init (0),
	  2 literal	char (20);

/*  Declaration of an unconditional transfer instruction  */

dcl	tra_inst		bit (36) int static init ("000000000000000000111001000000000000"b);


dcl	mlr_op		bit (10) int static init ("0010000011"b /*010(1)*/);
dcl	ldq_op		bit (10) int static init ("0100111100"b /*236(0)*/);
dcl	stq_op		bit (10) int static init ("1111011100"b /*756(0)*/);
dcl	lda_op		bit (10) int static init ("0100111010"b /*235(0)*/);
dcl	div_op		bit (10) int static init ("1010001100"b /*506(0)*/);
dcl	asa_op		bit (10) int static init ("0001011010"b /*055(0)*/);
dcl	aos_op		bit (10) int static init ("0001011000"b /* 054(0)*/);
dcl	sta_op		bit (10) int static init ("1111011010"b /*755(0)*/);

dcl	do_ptr		ptr,
	com2_ptr		ptr;
dcl	next_compare_tag	fixed bin static;
dcl	next_stmt_tag	fixed bin int static;
dcl	compare_code_tag	fixed bin int static;
dcl	increment_code_tag	fixed bin int static;
dcl	next_when_tag	fixed bin int static;
dcl	check_index_tag	fixed bin int static;
dcl	at_end_tag	fixed bin int static;

dcl	save_in_token_ptr	ptr;

dcl	work_in_token	(1:20) ptr;

/*  Structure used to communicate with the register handling routines.  */

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;

dcl	dn_ptr		ptr;
format1_search:
     proc;

/*  Declaration of an entry array  */

dcl	eos_proc		(1:4) entry init (fmt1_eos, fmt2_eos, fmt3_eos, fmt4_eos);


/*  DECLARATIONS OF INTERNAL VARIABLES  */

dcl	index_token_ptr	ptr;
dcl	varying_token_ptr	ptr;

dcl	add_next_stmt_tag	fixed bin;
dcl	work_string	char (20);
dcl	varying_done	bit (1);
dcl	ix		fixed bin;
dcl	iy		fixed bin;
dcl	offset_inst_word	bit (36);
dcl	occurrence_inst_word
			bit (36);
dcl	element_length_inst_word
			bit (36);

/**************************************************/
/*	START OF EXECUTION			*/
/*	INTERNAL PROCEDURE			*/
/*		format1_search		*/
/**************************************************/



	call eos_proc (in_token.token_ptr (in_token.n) -> end_stmt.e);


fmt1_eos:
     proc;

/*  Reserve a tag to be defined at the next Cobol statement (the statement
		following this SEARCH stetement)  */

	next_stmt_tag = cobol_$next_tag;

/*  Reserve a tag to be defined at the first instruction of the code generated to
		compare the index name value with the maximum size of the table.  */

	compare_code_tag = next_stmt_tag + 1;

/*  Reserve a tag to be defined at the next WHEN clause in the SEARCH statement.  */

	next_when_tag = next_stmt_tag + 2;

/*  Reserve a tag to be defined at the first instruction generated to increment the index name.  */

	next_compare_tag = cobol_$next_tag + 4;
	at_end_tag = cobol_$next_tag + 5;

	increment_code_tag = next_stmt_tag + 3;

/*  Update the next tag variable in the external data segment.  */

	cobol_$next_tag = cobol_$next_tag + 6;

	eos_ptr = in_token.token_ptr (in_token.n);

	dn_ptr = in_token.token_ptr (2);
	if data_name.occurs_do
	then do;
		call cobol_read_rand (1, data_name.do_rec, com2_ptr);
		call cobol_read_rand (3, odo_rec.descr, dn_ptr);
		do_ptr = dn_ptr;
	     end;
	else do_ptr = null ();
	if end_stmt.c = "1"b			/*  VARYING clause present.  */
	then if (in_token.token_ptr (in_token.n - 1) -> data_name.type = rtc_dataname
		& in_token.token_ptr (in_token.n - 1) -> data_name.usage_index)
	     then /*  VARYING variabble is an index data item.  */
		/*  Generate code to extract data from the index data item to be used
			in incrementing the index data item during the execution of the SEARCH.  */
		call get_index_item_data (in_token.token_ptr (in_token.n - 1), offset_inst_word, occurrence_inst_word,
		     element_length_inst_word);

/*  Generate an unconditional transfer to the compare_code_tag.  */

	call cobol_emit (addr (tra_inst), null (), 1);

/*  Make a tag reference to compare_code_tag at the instruction just emitted.  */

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

/*  Define the increment_code_tag at the next instruction location.  */
	call cobol_define_tag (increment_code_tag);

/*  Determine what index name should be used to search the table.  */


	if end_stmt.c = "0"b
	then do;					/*  No VARYING clause present.  */

		index_token_ptr = in_token.token_ptr (in_token.n - 1);
		dn_ptr = in_token.token_ptr (in_token.n - 2);
		occurs_ptr = addrel (dn_ptr, divide (data_name.occurs_ptr, 4, 35, 0));
		varying_token_ptr = null ();

	     end;					/*  No VARYING clause present.  */

	else do;					/*  VARYING present, determine whether the index name appearing in the
		VARYING clause should be used to search the table.  */

		dn_ptr = in_token.token_ptr (in_token.n - 3);

/*  Build a pointer to the occurs extension of the table being searched.  */
		occurs_ptr = addrel (dn_ptr, divide (data_name.occurs_ptr, 4, 35, 0));

		if in_token.token_ptr (in_token.n - 1) -> data_name.type = rtc_indexname
		then do;				/*  VARYING variable is an index name.  */

/*  Check to see if the index name in the VARYING clause appears in
			the INDEXED BY clause of the table being searched.  This index name
			appears in the INDEXED BY clause of the table if the index_no value in the
			index name token is equal to the index_no value in the occurs extension
			of the table.  */

			if occurs.level.index_no (occurs.dimensions)
			     = in_token.token_ptr (in_token.n - 1) -> index_name.index_no
			then do;			/*  It does appear in the INDEXED BY clause of the table.  */

/*  Use the index name in the VARYING clause for the SEARCH.  */
				index_token_ptr = in_token.token_ptr (in_token.n - 1);
				varying_token_ptr = null ();
						/*  no varying identifier to worry about.  */

			     end;			/*  It does appear in the INDEXED BY clause of the table.  */

			else do;			/*  Index name not associated with the table via INDEXED BY clause.  */

/*  The first index name token appears on cobol_pdout_ immediately
				following the data name token for the table.  */
				index_token_ptr = in_token.token_ptr (in_token.n - 2);

/*  The INDEX name in the varying clause is also incremented during
				the search.  */
				varying_token_ptr = in_token.token_ptr (in_token.n - 1);

			     end;			/*  The Index name not associated with the table via
					INDEXED BY clause.  */

		     end;				/*  VARYING variable is an index name.  */

		else do;				/*  VARYING VARIABLE is not an index name.  */

/*  Index used to search the table is the first index appearing in the
			INDEXED BY clause.  */
			index_token_ptr = in_token.token_ptr (in_token.n - 2);
			varying_token_ptr = in_token.token_ptr (in_token.n - 1);

		     end;				/*  VARYING variable is not an index name.  */

	     end;					/*  VARYING present, determine whether the index name appearing in the VARYING
		clause should be used to search the table.  */


/*  AT THIS POINT IN PROCESSING:

		1.  dn_ptr points to the data name token (type 9) for the
		table to be searched.
		2.  index_token_ptr points to the index name token (type 10) for the
		index to be used in the search.
		3.  varying_token_ptr points to the token appearing in the VARYING
		clause, to be incremented along with the index name used in the
		search.  If there was no VARYING clause, or if the variable
		referenced in the VARYING clause was the index name now being used
		in the search, then this pointer is null.

*/



/*  Generate code to increment the index name, and the variable referenced
		in the VARYING clause.  */


	varying_done = "0"b;
	in_token_ptr = addr (work_in_token (1));

	in_token.token_ptr (1) = save_in_token_ptr -> in_token.token_ptr (1);
	in_token.token_ptr (2) = index_token_ptr;



	if varying_token_ptr ^= null ()
	then do;					/*  VARYING variable is present.  */

		if varying_token_ptr -> data_name.type = rtc_indexname
		then do;				/*  VARYING variable is an index name.  */

/*  We will call the SET generator once to increment both index names.  */

			varying_done = "1"b;
			in_token.token_ptr (3) = varying_token_ptr;
			in_token.token_ptr (4) = addr (numeric_lit_1);
						/*  Numeric literal 1 is increment.  */
			in_token.token_ptr (5) = addr (set_eos_token);
			in_token.n = 5;
			in_token.token_ptr (5) -> end_stmt.e = 2;
						/*  Two operands to be SET.  */
			set_eos_token.a = "001"b;	/*  Format 2 set stmt.  */
			set_eos_token.b = "0"b;	/*  UP  */

		     end;				/*  VARYING variable is an index name.  */

		else if (varying_token_ptr -> data_name.type = rtc_dataname
		     & varying_token_ptr -> data_name.usage_index = "1"b)
		then do;				/*  VARYING variable is an index data item.  */

			call increment_index_data_item (varying_token_ptr, offset_inst_word, occurrence_inst_word,
			     element_length_inst_word);

		     end;				/*  VARYING variable is an index data item.  */

	     end;					/*  VARYING variable is present.  */

	if ^varying_done
	then do;					/*  VARYING not present, or if present, varying variable is not index name */

		in_token.token_ptr (3) = addr (numeric_lit_1);
						/*  Increment is literal 1.  */
		in_token.token_ptr (4) = addr (set_eos_token);
		in_token.n = 4;
		in_token.token_ptr (4) -> end_stmt.e = 1;
						/*  One operand to be set.  */
		set_eos_token.a = "001"b;		/*  Format 2 SET stmt.  */
		set_eos_token.b = "0"b;		/*  UP  */

	     end;					/*  VARYING not present, or if present, varying variable is not an index name.  */

/*  Call the SET generator to increment the index.  */

/*  Modify the maximum value field in the index name token so the SET generator will allow it to
		be set to one greater than the maximum size defined in the occurs clause.  */

	index_token_ptr -> index_name.max = index_token_ptr -> index_name.max + 1;

/*  Increment the same field in the varying token if it is also an index name.  */

	if varying_token_ptr ^= null ()
	then if varying_token_ptr -> data_name.type = rtc_indexname
	     then varying_token_ptr -> index_name.max =
		     varying_token_ptr -> index_name.max + index_token_ptr -> index_name.max - 1;

/*  Call the SET generator.  */
	call cobol_set_gen (in_token_ptr);


	if varying_token_ptr ^= null ()
	then if (varying_token_ptr -> data_name.type = rtc_dataname & varying_token_ptr -> data_name.usage_index = "0"b)
	     then do;				/*  VARYING present, and the varying variable is a dataname, but not usage index.  */

/*  Generate code to add one to the variable referenced in the VARYING clause.  */

		     in_token_ptr = addr (work_in_token (1));
		     in_token.token_ptr (1) = null ();
		     in_token.token_ptr (2) = addr (numeric_lit_1);
		     in_token.token_ptr (3) = varying_token_ptr;
		     in_token.token_ptr (4) = addr (add_eos_token);
		     in_token.n = 4;

		     call cobol_add_gen (in_token_ptr, add_next_stmt_tag);

		end;				/*  VARYING present, and the varying variable is a dataname, but not usage index.  */

/*  Define the compare_code_tag at the next instruction.  */

	call cobol_define_tag (compare_code_tag);

/*  Generate code to compare the index name being used to search the table, to its maximum size.  */

/*  Convert the maximum size of the table being searched (in fixed binary representation) to a
	character string.  */

	call bin_to_char (index_token_ptr -> index_name.max - 1,
						/*  Remember that we incremented "max"
		by 1 before calling the set generator.  */
	     work_numeric_lit.literal, work_numeric_lit.places);
	work_numeric_lit.places_left = work_numeric_lit.places;

	in_token.n = 3;
	in_token.token_ptr (3) = addr (compare_eos_token);
	in_token.token_ptr (1) = index_token_ptr;
	compare_eos_token.e = 113;			/*  GREATER  */
	compare_eos_token.i = "010"b;			/*  Transfer if not greater.  */

/*  Generate code to do the comparison.  */
	if do_ptr ^= null ()
	then do;
		in_token.token_ptr (2) = do_ptr;
		compare_eos_token.h = next_compare_tag;
		call cobol_compare_gen (in_token_ptr);
		call cobol_emit (addr (tra_inst), null (), 1);
		if end_stmt.b = "0"b
		then call cobol_make_tagref (next_stmt_tag, cobol_$text_wd_off - 1, null ());
		else call cobol_make_tagref (at_end_tag, cobol_$text_wd_off - 1, null ());
	     end;
	call cobol_define_tag (next_compare_tag);
	in_token.token_ptr (2) = addr (work_numeric_lit);
	compare_eos_token.h = next_when_tag;
	call cobol_compare_gen (in_token_ptr);		/*  Check to see if an AT END clause was not present, and generate a transfer to the next
		Cobol statement.  */

	if end_stmt.b ^= "1"b
	then do;					/*  AT END clause not present.  */
						/*  Emit a transfer to the next Cobol statement.  */
						/*  Make a tag reference at the instruction just emitted.  */
						/*  Define the next when tag at the next instruction to be generated.  */

/*[5.3-2]*/
		call TG (next_stmt_tag, next_when_tag);

	     end;					/*  AT END clause not present.  */

	call cobol_define_tag (at_end_tag);		/*  Set the output parameter to non_zero.  */
						/*[5.0-1]*/
						/* 	search_flag = 1; */

     end fmt1_eos;


fmt2_eos:
     proc;


	if in_token.token_ptr (in_token.n) -> end_stmt.b = "1"b
	then do;					/*  This EOS is the last EOS for the sEARCH statement.  */

/*  Generate code to transfer to  increment code tag.  */

		call cobol_emit (addr (tra_inst), null (), 1);
		call cobol_make_tagref (increment_code_tag, cobol_$text_wd_off - 1, null ());

/*  Define the next_stmt_tag.  */

/*[5.3-2]*/
		call TG (increment_code_tag, next_stmt_tag);

/*  Set the output parameter search_flag to zero.  */

		search_flag = 0;

	     end;					/*  This EOS is the last EOS for the SEaRCH statement.  */

	else do;					/*  This EOs is not the last EOS for the sEaRCH statement.  */

/*  Generate a transfer to the next Cobol statement.  */
/*  Make a reference to the next Cobol statement at the instruction just emitted.  */
/*  Define the next_when_tag.  */

/*[5.3-2]*/
		call TG (next_stmt_tag, next_when_tag);

	     end;					/*  This EOS is not the last EOS for the sEaRCH statement.  */


     end fmt2_eos;

TG:
     proc (T1, T2);

/*[5.3-2]*/
dcl	(T1, T2)		fixed bin;

/*[5.3-2]*/
	call cobol_emit (addr (tra_inst), null (), 1);	/*[5.3-2]*/
	call cobol_make_tagref (T1, cobol_$text_wd_off - 1, null ());
						/*[5.3-2]*/
	call cobol_define_tag (T2);

     end;

fmt3_eos:
     proc;

/*[5.0-1]*/
	search_flag = 1;

	return;

     end fmt3_eos;


fmt4_eos:
     proc;

/*  Save the internal tag defined in the internal tag token (type 30) as the next_when_tag.  */
	next_when_tag = in_token.token_ptr (in_token.n - 1) -> int_tag.proc_num;
						/*[5.3-2]*/
	search_flag = 0;
     end fmt4_eos;

     end format1_search;


/*************************************************/
/*	INTERNAL PROCEDURE			*/
/*	get_index_item_data		*/
/**************************************************/

get_index_item_data:
     proc (index_data_item_ptr, work_offset_inst, work_occurrence_inst, element_length_inst);

/*
This internal proceduure generates code to get the following information
for an index data item that is to be incremented during
the execution of a SEARCH statement:
	1. occurrence number
	2. byte offset of the item referenced by
	"occurrence number".
	3. element length of the item referenced by the index
	data item.  (this length is calculated by dividing
	"byte offset" by "occurrence number".)

An index data item in Multics cobol consists of six bytes of
data.  the first four bytes contain the byte offset, and the last
two bytes contain the occurrence number.  However, within each
byte, only the least significant 8 bits contain meaningful
data.  Therefore, to do any computation or incrementing of The
data in an index data item, it is necessary to squeeze out the
junk bits, and store the resulting data into temporary storage.
This procedure does That silly bit squeezing.
*/

/*  DECLARATION OF THE PARAMETERS  */

dcl	index_data_item_ptr ptr;
dcl	work_offset_inst	bit (36);
dcl	work_occurrence_inst
			bit (36);
dcl	element_length_inst bit (36);

/*  DESCRIPTION OF THE PARAMETERS  */

/*
PARAMETER		DESCRIPTION

index_data_item_ptr	Pointer to the index data item token
		(type 9) from which data is to be
		extracted by this procedure.  (input)
work_offset_inst	a word in which the basic, non-eis
		address of the word in wich the fixed
		binary offset value is stored by this
		procedure. (output)
work_occurrence_inst a word in which the basic, non-eis
		address of the word in which the fixed binary
		occurrence number is stored by this
		procedure.  (output)
element_length_inst	a word in which the basic, non-eis address
		of the word in which the fixed binary
		element length is stored by this procedure.
		(output)

*/


/*  DECLARATIONS OF INTERNAL STATIC VARIABLES  */

dcl	1 get_occurrence_no_code
			int static,
	  2 i1		bit (36) init ("000000000000000000010011101000000011"b),
						/*  lda 0,du */
	  2 i2		bit (36) init ("000000000000001010111011111000000000"b),
						/* lls 10  */
	  2 i3		bit (36) init ("000000000000000001111011001000000000"b),
						/* ars 1  */
	  2 i4		bit (36) init ("000000000000011100111011011000000000"b),
						/*  lrs 28  */
	  2 i5		bit (36) init ("000000000000000000110000001000000000"b);
						/*  tnz 0  */

dcl	1 get_offset_code	int static,
	  2 i1		bit (36) init ("000000000000001000111011011000000000"b),
						/*  lrs 8  */
	  2 i2		bit (36) init ("000000000000000001111011001000000000"b),
						/*  ars 1  */
	  2 i3		bit (36) init ("000000000000001000111011011000000000"b),
						/*  lrs 8  */
	  2 i4		bit (36) init ("000000000000000001111011001000000000"b),
						/*  ars 1  */
	  2 i5		bit (36) init ("000000000000001000111011011000000000"b),
						/*  lrs 8  */
	  2 i6		bit (36) init ("000000000000000001111011001000000000"b),
						/*  ars 1  */
	  2 i7		bit (36) init ("000000000000001100111011011000000000"b);
						/*  lrs 12  */

dcl	search_occurrence_error
			fixed bin int static init (46);


/*  DECLARATION OF INTERNAL VARIABLES  */

dcl	work_offset1	fixed bin;
dcl	work_offset2	fixed bin;
dcl	work_offset3	fixed bin;

dcl	work_ptr		ptr;

dcl	work_offset_inst_ptr
			ptr;
dcl	work_occurrence_inst_ptr
			ptr;
dcl	element_length_inst_ptr
			ptr;

dcl	buff1		(1:10) ptr;
dcl	buff2		(1:10) ptr;
dcl	buff3		(1:10) ptr;
dcl	occurrence_ok_tag	fixed bin;

	input_ptr = addr (buff1 (1));
	inst_ptr = addr (buff2 (1));
	reloc_ptr = addr (buff3 (1));

/*  allocate 3 words (12 bytes) on an even word boundary in the stack.  these
three words ar to be used to hold:
	1. first word-byte offset of the index data item.
	2. second occurrence number from the index data item
	3. element length of the array item described by the index data item.

*/

	call cobol_alloc$stack (12, 2, work_offset1);

/*  Convert the word offset returned by cobol_alloc$stack to a byte offset.  */
	work_offset1 = work_offset1 * 4;

/*  calculate the  byte offset of the word for the occurrence number from the index data item.  */
	work_offset2 = work_offset1 + 4;

/*  calculate the byte offset for the  word to contain the element length.  */
	work_offset3 = work_offset1 + 8;

/*  Make a copy of the input index data item token.  */
	work_ptr = null ();				/*  Utility provides buffer for the token.  */
	call cobol_make_type9$copy (work_ptr, index_data_item_ptr);

/*  Modify the token so that it describes the temporary space just allocated in the stack.  */
	work_ptr -> data_name.seg_num = 1000;		/*  stack  */
	work_ptr -> data_name.offset = work_offset1;
	work_ptr -> data_name.subscripted = "0"b;

/*  generate code to move the index data item ( 6 bytes long)  to the stack space.  */

	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) = index_data_item_ptr;
	input_struc.operand.send_receive (1) = 0;	/*  sending  */
	input_struc.operand.size_sw (1) = 0;

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

/*  call the addressability utility  */
	call cobol_addr (input_ptr, inst_ptr, reloc_ptr);

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

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

/*  get the basic addresses (6180 non-eis addresses of the offset, occurrence number, and element
	length words.  */

	work_offset_inst_ptr = addr (work_offset_inst);
	work_occurrence_inst_ptr = addr (work_occurrence_inst);
	element_length_inst_ptr = addr (element_length_inst);

	input_struc_basic.type = 1;			/*  basic, non-eis  */
	input_struc_basic.operand_no = 0;
	input_struc_basic.segno = 1000;

/*  get basic address of the offset word  */
	input_struc_basic.char_offset = work_offset1;
	call cobol_addr (input_ptr, work_offset_inst_ptr, reloc_ptr);

/*  get the basic address of the occurrence number wordl  */
	input_struc_basic.char_offset = work_offset2;
	call cobol_addr (input_ptr, work_occurrence_inst_ptr, reloc_ptr);

/*  get basic address of the element length word.  */
	input_struc_basic.char_offset = work_offset3;
	call cobol_addr (input_ptr, element_length_inst_ptr, reloc_ptr);

/*  get the a and q registera  */

	register_struc.what_reg = 3;			/*  A and Q  */
	register_struc.lock = 0;			/*  no change to locks.  */
	register_struc.contains = 0;			/*  Contents of A and Q will not be meaningful ofr register
		optimization, because the code to be generated shifts the contents of the registers.  */

	call cobol_register$load (addr (register_struc));

/*  build instruction to load the Q register with the occurrence number.  */
	work_occurrence_inst_ptr -> inst_struc_basic.fill1_op = ldq_op;

/*  Emit the ldq instruction  */
	call cobol_emit (work_occurrence_inst_ptr, null (), 1);

/*  at this point we have generated code to load the occurrence number into the Q register.  */

/*  emit a stream of code to convert the occurrence number into a fixed bin (35) value
	in the Q register  */

/*  The code stream emitted is:
		lda 0,dl
		lls 10
		ars 1
		lrs 28
		tnz
	*/

	call cobol_emit (addr (get_occurrence_no_code), null (), 5);

/*  Reserve a tag to which to transfer if the occurrence number is OK (non-zero)  */
	occurrence_ok_tag = cobol_$next_tag;
	cobol_$next_tag = cobol_$next_tag + 1;		/*  Make a reference to the tag just reserved at the tnz instruction just emitted.  */

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

/*  Generate code to signal an error, if the occurrence number is zero.  */

	call cobol_process_error (search_occurrence_error, fixed (index_data_item_ptr -> data_name.line, 17), 0);

/*  Define the occurrence_ok_tag.  */
	call cobol_define_tag (occurrence_ok_tag);

/*  Generate code to store the occurrence number, back into the temporary in the stack.  */
	work_occurrence_inst_ptr -> inst_struc_basic.fill1_op = stq_op;

/*  Emit the instruction.  */
	call cobol_emit (work_occurrence_inst_ptr, null (), 1);

/*  Now  generate code to load the offset into the A-Q register and squeeze out the junk bits.  */
	work_offset_inst_ptr -> inst_struc_basic.fill1_op = lda_op;
	call cobol_emit (work_offset_inst_ptr, null (), 1);

/*  Emit a stream of code to squeeze out the junk bits.  */
/*  The stream of code is:
		lrs 8
		ars 1
		lrs 8
		ars 1
		lrs 8
		ars 1
		lrs 12  RESULT WINDS UP IN Q
	*/

	call cobol_emit (addr (get_offset_code), null (), 7);

/*  Generate code to store the Q into the owrk offset word.  */
	work_offset_inst_ptr -> inst_struc_basic.fill1_op = stq_op;
	call cobol_emit (work_offset_inst_ptr, null (), 1);

/*  Now generate code to calculate the element length of the item described by the index data item,
	and store the element length in the stack for use later when the index data item is incremented.  */

/*  Note at this point in the generated code, the offset is contained in the Q register,
	the occurrence number is sorted in the stack.  The element length is calculated by dividing
	the  offset by the occurrence number.  */

	work_occurrence_inst_ptr -> inst_struc_basic.fill1_op = div_op;
	call cobol_emit (work_occurrence_inst_ptr, null (), 1);

/*  Store the quotient (in the Q ) into the stack space allocated to hold the element length  */
	element_length_inst_ptr -> inst_struc_basic.fill1_op = stq_op;
	call cobol_emit (element_length_inst_ptr, null (), 1);

     end get_index_item_data;


/**************************************************/
/*	INTERNAL PROCEDURE			*/
/*	increment_index_data_item		*/
/**************************************************/

increment_index_data_item:
     proc (index_data_item_ptr, work_offset_inst, work_occurrence_inst, element_length_inst);

/*
This procedure generates code to increment an index data item
that is referenced in the VARYING clause of a format 1 SEARCH
statement.  When this procedure is entered, code has been generated
to convert the contents of the index data item into the format of
an index data name in the stack.  (i.e. two consecutinve words of
storage; the first word contains the byte offset, the second
word contains the occurrence number.)
The value to be used to increment the byte offset is also
contained in a temporary in the stack.  This procedure generates
code that
	1. increments the value of the temporary index name
	representation.
	2. converts this index name representation to the
	index data item representation.
	3. moves the index data item representation into the
	index data item referenced in the VARYING clause.

*/

/*  DECLARATION OF THE PARAMETERS  */

dcl	index_data_item_ptr ptr;
dcl	work_offset_inst	bit (36);
dcl	work_occurrence_inst
			bit (36);
dcl	element_length_inst bit (36);

/*  DESCRIPTION OF THE PARAMETERS  */

/*
PARAMETER		DESCRIPTION

index_data_item_ptr	Pointer to the index data item token (type9)
		that is be be incremented because it appears
		in the VARYING clause of a SEARCH statement.
work_offset_inst	A word that contains the basic, non-eis
		address of the word containing the byte
		offset in the index data name format.
		(input)
work_occurrence_inst A word that contains the basic,non-eis
		address of the word containing the occurrence
		number in index data name format. (input)
element_length_inst	A word that contains the basic, non-eis
		address of the word containing the
		element length of the item represented
		by the index data item that appears in
		the VARYING clause.  (input)

*/

/*  DECLARATION OF INTERNAL STATIC VARIABLES  */

dcl	1 get_offset_code	int static,
	  2 i1		bit (36) init ("000000000000001100111011111000000000"b),
						/*  lrs 12  */
	  2 i2		bit (36) init ("000000000000000001111011101000000000"b),
						/*  als 1  */
	  2 i3		bit (36) init ("000000000000001000111011111000000000"b),
						/*  lls 8  */
	  2 i4		bit (36) init ("000000000000000001111011101000000000"b),
						/*  als 1  */
	  2 i5		bit (36) init ("000000000000001000111011111000000000"b),
	  2 i6		bit (36) init ("000000000000000001111011101000000000"b),
						/*  als 1  */
	  2 i7		bit (36) init ("000000000000001000111011111000000000"b);
						/*  lls 8  */


dcl	1 get_occurrence_code
			int static,
	  2 i1		bit (36) init ("000000000000011100111011111000000000"b),
						/*  lls 28  */
	  2 i2		bit (36) init ("000000000000000001111011101000000000"b),
						/*  als 1  */
	  2 i3		bit (36) init ("000000000000011010111011111000000000"b);
						/*  lls 26  */


/*  DECLARATION OF INTERNAL VARIABLES  */

dcl	work_offset_inst_ptr
			ptr;
dcl	work_occurrence_inst_ptr
			ptr;
dcl	element_length_inst_ptr
			ptr;

dcl	temp_ptr		ptr;

dcl	work_offset1	fixed bin;
dcl	work_offset2	fixed bin;
dcl	buff1		(1:10) ptr;
dcl	buff2		(1:10) ptr;
dcl	buff3		(1:10) ptr;

dcl	temp_offset_inst_ptr
			ptr;
dcl	temp_occurrence_inst_ptr
			ptr;
dcl	temp_offset_inst	bit (36);
dcl	temp_occurrence_inst
			bit (36);

/**************************************************/
/*	START OF EXECUTION			*/
/*	INTERNAL PROCEDURE			*/
/*	increment_index_data_item		*/
/**************************************************/

	work_offset_inst_ptr = addr (work_offset_inst);
	work_occurrence_inst_ptr = addr (work_occurrence_inst);
	element_length_inst_ptr = addr (element_length_inst);

	input_ptr = addr (buff1 (1));
	inst_ptr = addr (buff2 (1));
	reloc_ptr = addr (buff3 (1));

/*  Generate code to increment the work occurrence number by one.  */
	work_occurrence_inst_ptr -> inst_struc_basic.fill1_op = aos_op;
	call cobol_emit (work_occurrence_inst_ptr, null (), 1);

/*  Get the A and Q registers  */
	register_struc.what_reg = 3;			/*  A AND Q  */
	register_struc.lock = 0;
	register_struc.contains = 0;

	call cobol_register$load (addr (register_struc));

/*  Load the element length into the A register.  */
	element_length_inst_ptr -> inst_struc_basic.fill1_op = lda_op;
	call cobol_emit (element_length_inst_ptr, null (), 1);

/*  Add the contents of the A register to the byte offset in temporary storage.  */
	work_offset_inst_ptr -> inst_struc_basic.fill1_op = asa_op;
	call cobol_emit (work_offset_inst_ptr, null (), 1);

/*  At this point, code has been generated to increment the occurrence number by one,
	and the byte offset by the stored element length.  */

/*  Allocate 6 bytes on an even word boundary on the stack to receive the index data item
	format information.  */
	call cobol_alloc$stack (6, 2, work_offset1);


/*  Convert the word offset to a byte offset.  */
	work_offset1 = work_offset1 * 4;

/*  Calculate the byte offset of the occurrence number bytes of the temporary index data item.  */
	work_offset2 = work_offset1 + 4;

/*  Get the basic, non-eis address of the byte offset and occurrence number bytes.  */
	temp_offset_inst_ptr = addr (temp_offset_inst);
	temp_occurrence_inst_ptr = addr (temp_occurrence_inst);

	input_struc_basic.type = 1;			/*  basic, non-eis  */
	input_struc_basic.operand_no = 0;
	input_struc_basic.segno = 1000;		/*  stack  */

	input_struc_basic.char_offset = work_offset1;
	call cobol_addr (input_ptr, temp_offset_inst_ptr, reloc_ptr);

	input_struc_basic.char_offset = work_offset2;
	call cobol_addr (input_ptr, temp_occurrence_inst_ptr, reloc_ptr);

/*  Generate an instruction to load the stored offset into the Q.  */
	work_offset_inst_ptr -> inst_struc_basic.fill1_op = ldq_op;
	call cobol_emit (work_offset_inst_ptr, null (), 1);

/*  Emit a stream of code to expand the offset and insert the junk bits.
	The expanded result winds up in the A register.  */
/*  The emitted code stream is:
		lls 12
		als 1
		lls 8
		als 1
		lls 8
		als 1
		lls 8
	*/

	call cobol_emit (addr (get_offset_code), null (), 7);

/*  Emit code to store the A register into the temporary storage set aside for the offset
		part of the index data item.  */
	temp_offset_inst_ptr -> inst_struc_basic.fill1_op = sta_op;
	call cobol_emit (temp_offset_inst_ptr, null (), 1);

/*  Emit code to load the Q register with the occurrence number from the temporary.  */
	work_occurrence_inst_ptr -> inst_struc_basic.fill1_op = ldq_op;
	call cobol_emit (work_occurrence_inst_ptr, null (), 1);

/*  Emit a stream of code to expand the occurrence number and insert the junk bits.
	The expanded result winds up in the 2 leftmost bytes of the a register.  */
/*  The emitted stream is:
		lls 28
		als 1
		lls 26
	*/

/*  Emit the stream of code.  */
	call cobol_emit (addr (get_occurrence_code), null (), 3);

/*  Emit code to store the A register into the temporary storage for the occurrence number
	part of the index data item.  */
	temp_occurrence_inst_ptr -> inst_struc_basic.fill1_op = sta_op;
	call cobol_emit (temp_occurrence_inst_ptr, null (), 1);

/*  At this point, we have generated code to expand the offset and occurrence number and
	store these values in index data item format in the six bytes of storage in the stack.  */

/*  Now we must generate code to move the temporary index stat item from the stack
	into the index data item being incremented during the execution of the SEARCH.  */

/*  Make a copy of the input index data item token.  */

	temp_ptr = null ();
	call cobol_make_type9$copy (temp_ptr, index_data_item_ptr);

/*  Modify the copy so that it describes the six byte temporary in the stack.  */
	temp_ptr -> data_name.seg_num = 1000;		/*  stack  */
	temp_ptr -> data_name.offset = work_offset1;
	temp_ptr -> data_name.subscripted = "0"b;

/*  Build the input structure 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) = temp_ptr;
	input_struc.operand.send_receive (1) = 0;	/*  Sending  */
	input_struc.operand.size_sw (1) = 0;

	input_struc.operand.token_ptr (2) = index_data_item_ptr;
	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 mlr opcode into the instruction  */
	inst_struc.inst.fill1_op = mlr_op;

/*  Emit the instruction to move the temp index data item image to the index data item
		being incremented.  */
	call cobol_emit (inst_ptr, reloc_ptr, 3);

     end increment_index_data_item;

format2_search:
     proc;



/*  DECLARATION OF AN ENTRY ARRAY.  */

dcl	fmt2_eos_proc	(1:3) entry init (fmt2_eos1, fmt2_eos2, fmt2_eos3);

/**************************************************/
/*	START OF EXECUTION			*/
/*	INTERNAL PROCEDURE			*/
/*	format2_search			*/
/**************************************************/

	call fmt2_eos_proc (in_token.token_ptr (in_token.n) -> end_stmt.e);


fmt2_eos1:
     proc;

/*  Reserve a tag to be defined at the first instruction generated to test whether
	the index name is within limits.  */

	check_index_tag = cobol_$next_tag;

/*  Reserve a tag to be defined at the first instruction generated for the WHEN clause.  */

	next_when_tag = check_index_tag + 1;

/*  Reserve a tag to be defined at the first instruction of the next cobol statement.
	(The statement following this SEARCH statement. )  */

	next_stmt_tag = check_index_tag + 2;

	next_compare_tag = cobol_$next_tag + 3;

/*  Update the next tag counter in MCOBOL external data segment.  */

	cobol_$next_tag = cobol_$next_tag + 4;

	dn_ptr = in_token.token_ptr (2);
	if data_name.occurs_do
	then do;
		call cobol_read_rand (1, data_name.do_rec, com2_ptr);
		call cobol_read_rand (3, odo_rec.descr, dn_ptr);
		do_ptr = dn_ptr;
	     end;
	else do_ptr = null ();

/*  Generate code to initialize the index name being used in the search.  */

/*  Set up the in_token structure for a call to the SET generator.  */

	in_token_ptr = addr (work_in_token (1));
	in_token.token_ptr (1) = save_in_token_ptr -> in_token.token_ptr (1);
						/*  Reserved word SEARCH  */
	in_token.token_ptr (2) = save_in_token_ptr -> in_token.token_ptr (3);
						/*  Index name token.  */
	in_token.token_ptr (3) = addr (numeric_lit_1);
	in_token.token_ptr (4) = addr (set_eos_token);
	in_token.n = 4;
	set_eos_token.a = "000"b;			/*  Format 1 set.  */
	set_eos_token.e = 1;			/*  One operand to be set.  */

/*  Call the SET generator.  */
	call cobol_set_gen (in_token_ptr);


/*  Generate code to determine whether the index is at its maximum value.  */

	eos_ptr = save_in_token_ptr -> in_token.token_ptr (save_in_token_ptr -> in_token.n);

/*  Build an in_token structure for calling cobol_compare_gen.  */

	in_token.token_ptr (1) = null ();		/*  in_token.token_ptr(2) points to the index name already.  (It was set above when
	the in_token structure was built for the call to cobol_set_gen.  */

	in_token.token_ptr (3) = addr (work_numeric_lit);
	in_token.token_ptr (4) = addr (compare_eos_token);
	in_token.n = 4;

/*  Convert the maximum value that can be contained in the index name to a character string literal.  */


	work_numeric_lit.places_left = work_numeric_lit.places;

	compare_eos_token.e = 102;			/*  COMPARE EQUAL  */
	compare_eos_token.i = "000"b;			/*  Transfer if equal to the tag in end_stmt.h.  */

	if end_stmt.b = "1"b
	then do;					/*  AT END CLAUSE present.  */
						/*  Reserve a tag to be defined at the first instruction generated
		for the AT END clause.  */

		at_end_tag = cobol_$next_tag;
		cobol_$next_tag = cobol_$next_tag + 1;
		compare_eos_token.h = at_end_tag;	/*  Transfer to the at_end_tag when the index equals
			its maximum value.  */

	     end;					/*  AT END CLAUSE present.  */

	else compare_eos_token.h = next_stmt_tag;	/*  Transfer to the next Cobol statement when the
			index equals its maximum value.  */

	if do_ptr ^= null ()
	then do;
		in_token.token_ptr (3) = do_ptr;
		call bin_to_char (fixed (in_token.token_ptr (2) -> index_name.max, 17), work_numeric_lit.literal,
		     work_numeric_lit.places);
		work_numeric_lit.places_left = work_numeric_lit.places;
		compare_eos_token.e = 113;		/* greater compare */
		call cobol_compare_gen (in_token_ptr);
		compare_eos_token.e = 102;
	     end;

/*  Generate an instruction to transfer to the next_when_tag.  */

	call cobol_emit (addr (tra_inst), null (), 1);

/*  Make a tag reference at the instruction just emitted.  */
	call cobol_make_tagref (next_when_tag, cobol_$text_wd_off - 1, null ());

/*  Define the check_index_tag at the next instruction to be generated.  */
	call cobol_define_tag (check_index_tag);

	call bin_to_char (fixed (in_token.token_ptr (2) -> index_name.max, 17), work_numeric_lit.literal,
	     work_numeric_lit.places);
	work_numeric_lit.places_left = work_numeric_lit.places;

	if do_ptr ^= null ()
	then do;
		call cobol_compare_gen (in_token_ptr);
		in_token.token_ptr (3) = addr (work_numeric_lit);
	     end;
	call cobol_compare_gen (in_token_ptr);

/*  Generate code to increment the index by 1.  */

	in_token.token_ptr (1) = save_in_token_ptr -> in_token.token_ptr (1);
						/*  in_token.token_ptr(2) still points to the index name token.  */
	in_token.token_ptr (3) = addr (numeric_lit_1);
	in_token.token_ptr (4) = addr (set_eos_token);

	set_eos_token.a = "001"b;			/*  FOR AT 2 SET  */
	set_eos_token.b = "0"b;			/*  UP  */

	call cobol_set_gen (in_token_ptr);

/*  Check to see if AT END clause was present.  If present, generate a transfer to the WHEN clause.  */

	if end_stmt.b = "1"b
	then do;					/*  AT END CLAUSE present.  */

/*  Generate a transfer.  */
		call cobol_emit (addr (tra_inst), null (), 1);

/*  Make a reference to the next_when_tag at the instruction just emitted.  */
		call cobol_make_tagref (next_when_tag, cobol_$text_wd_off - 1, null ());

/*  Define the at_end_tag at the next instruction location.  */
		call cobol_define_tag (at_end_tag);


	     end;					/*  AT END CLAUSE present.  */

	else /*  Define the next_when tag at the next instruction location.  */
	     call cobol_define_tag (next_when_tag);

     end fmt2_eos1;


fmt2_eos2:
     proc;


	if in_token.token_ptr (in_token.n) -> end_stmt.b = "1"b
	then /*  This is the lase EOS2 in the SEARCH statement.  */ /*  Define the next_stmt_tag.  */
	     call cobol_define_tag (next_stmt_tag);

	else do;					/*  This is not the last EOS2 in the SEARCH statement.  */
						/*  Generate code to transfer to the next_stmt_tag.  */
		call cobol_emit (addr (tra_inst), null (), 1);

/*  Make a tagref at the instruction just emitted.  */
		call cobol_make_tagref (next_stmt_tag, cobol_$text_wd_off - 1, null ());

/*  Define the next_when_tag at the next instruction location.  */

		call cobol_define_tag (next_when_tag);

	     end;					/*  This is not the last EOS2 in the SEARCH statement.  */

     end fmt2_eos2;


fmt2_eos3:
     proc;

dcl	ix		fixed bin;
dcl	iy		fixed bin;		/*  Build an in_token structure for calling cobol_compare_gen.  */
	in_token_ptr = addr (work_in_token);
	in_token.n = 3;
	in_token.token_ptr (3) = addr (compare_eos_token);
	compare_eos_token.h = check_index_tag;
	compare_eos_token.i = "010"b;			/*  Transfer if not equal to check_index_tag.  */

	ix = 1;
	iy = 1;					/*  Generate code to compare two operands and transfer to check_index_tag if not equal.  */

/*  Process each pair of operands in the input token structure.  */

	do while (save_in_token_ptr -> in_token.token_ptr (iy) -> end_stmt.type ^= rtc_eos);

/*  Get a pointer to the first operand of the comparison.  */
	     in_token.token_ptr (1) = save_in_token_ptr -> in_token.token_ptr (ix);

/*  Get a pointer to the second operand of the comparison.  Note that the token for
			the reserved word EQUAL is in in_token.token_ptr(ix+ 1)  */

	     in_token.token_ptr (2) = save_in_token_ptr -> in_token.token_ptr (ix + 2);

	     call cobol_compare_gen (in_token_ptr);

/*  Increment the index to reference the pointer following the 2nd operand.  */
	     ix = ix + 4;
	     iy = ix - 1;

	end;

     end fmt2_eos3;
     end format2_search;

bin_to_char:
     proc (bin_value, ret_string, ret_length);

dcl	bin_value		fixed bin;
dcl	ret_string	char (*);
dcl	ret_length	fixed bin (15);

dcl	digit		fixed bin;
dcl	work_string	char (20);
dcl	work_value	fixed bin;
dcl	iy		fixed bin;

dcl	char_value	(0:9) char (1) int static init ("0", "1", "2", "3", "4", "5", "6", "7", "8", "9");

	if bin_value = 0
	then do;					/*  INput value is zero.  */
		ret_length = 1;
		substr (ret_string, 1, 1) = char_value (0);
	     end;					/*  Input value is zero.  */

	else do;					/*  Input value non-zero.  */

		work_value = bin_value;
		iy = 0;

		do while (work_value ^= 0);
		     iy = iy + 1;
		     digit = mod (work_value, 10);
		     work_value = work_value / 10;
		     substr (work_string, 21 - iy, 1) = char_value (digit);
		end;
		substr (ret_string, 1, iy) = substr (work_string, 21 - iy, iy);
		ret_length = iy;
	     end;


     end bin_to_char;

/**************************************************/
/*	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_type19;


%include cobol_type30;


%include cobol_type10;


%include cobol_type9;


%include cobol_in_token;

%include cobol_record_types;


%include cobol_;


%include cobol_occurs_ext;


%include cobol_addr_tokens;
%include cobol_odo_rec;



/**************************************************/
/*	END OF EXTERNAL PROCEDURE		*/
/*	cobol_search_gen			*/
/**************************************************/

     end cobol_search_gen;




		    cobol_section_gen.pl1           05/24/89  1042.8rew 05/24/89  0832.6       85248



/****^  ***********************************************************
        *                                                         *
        * 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_section_gen.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/*{*/
/* format: style3 */
cobol_section_gen:
     proc (in_token_ptr);

/*
The procedure cobol_section_gen performs the following functions:

  1.  Generates an end-of-perform range alterable GO and incre-
      ments perform_para_index by 1 if the paragraph being ter-
      minated is at the end of a perform range as determined by
      examining para_eop_flag ((1, it is; 0, it is not).

  2.  Generates the number of end-of-perform range alterable GO's
      dictated by the value of sect_eop_flag; 0, 1, or 2.

  3.  Determines if the section being entered is at the end of a
      PERFORM statement and/or SORT statement perform range by
      examining perform_list.perf.proc_num(perform_para_index).
      If it is not, sect_eop_flag is set to 0.  If it is, sect_
      eop_flag is set to 1, perform_sect_index is set equal to
      perform_para_index, and perform_para_index is incremented
      by 1.  Then, perform_list.perf.proc_num(perform_para_index)
      is examined, using the new value of perform_para_index, to
      determine if the section has been referenced in both a 
      PERFORM and a SORT statement (in this case there are two
      entries for the procedure in perform_list  -  the first for
      PERFORM statements and the second for SORT statements).  If
      there is no second entry in perform_list for the section,
      then no further action is taken.  If there is, then sect_
      eop_flag and perform_para_index are both incremented by 1.

  4.  Determines if the section being entered must be initialized
      prior to its execution as a result of an implicit transfer
      of control from the preceding section.  (Initialization is
      required if the section being entered has a COBOL segment
      number different from that of its predessor and if the seg-
      ment of which the section is a member is independent and
      contains alterable GO's.)  If initialization is required,
      code is generated to cause execution of an initialization
      sequence for the segment prior to execution of code gener-
      ated to implement the statements that comprise the section.

  5.  Associates the section's procedure number with the text 
      location into which the first instruction emitted by the 
      next generator called will be placed (this is the first
      free text location following the code, if any, generated
      by cobol_section_gen).

U__s_a_g_e:_

     declare cobol_section_gen entry (ptr);

     call cobol_section_gen (in_token_ptr);

						   */

%include cobol_in_token;

/*
G__e_n_e_r_a_t_e_d_C__o_d_e:_

Two sequences of code may be generated by cobol_section_gen.  They
are as follows;

  Sequence 1:  Implements end-of-perform range alterable GO's.

  Sequence 2:  Implements the transfer of control to and estab-
	     lishes return from the appropriate segment initi-
	     alization code sequence.

Sequence 1 -

     lda  target_An
     tra  0,al

where:
target_An is a 36-bit variable allocated in the program's COBOL
	data segment.  Each target_An, for n = 1, 2, 3, ...,
	is uniquely associated with the procedure at whose end
	these instructions are generated.

Sequence 2 -

     eaa  2,ic
     tra  s_init_relp,ic

where:
s_init_relp is the offset, relative to the instruction in which
	  it appears, of the first instruction of the initial-
	  ization code sequence provided for the COBOL segment
	  of which the section being entered is a part.

Note that following the execution of the eaa instruction bits 0 -
17 inc. of the a-register (au) will contain the address of the
instruction following the tra instruction i.e. the address of the
first instruction generated to implement the statements contained
in the section being entered.  Since the terminal instruction of
the initialization sequences for independent segments (which do
not otherwise employ the a-register) is tra 0,au, control will
be transferred to this instruction.
						   */

/*
D__a_t_a:_

     % include cobol_;

	Items in cobol_$incl.pl1 used (u) and/or set (s) by
	cobol_section_gen;
	     cobol_ptr (u)
	     para_eop_flag (u/s)
	     perform_list_ptr (u)
	     perform_para_index (u/s)
	     perform_sect_index (u/s)
	     priority_no (u/s)
	     sect_eop_flag (u/s)
	     seg_init_list_ptr (u)
	     text_wd_off (u)

						   */

%include cobol_perform_altgo;
%include cobol_perform_list;
%include cobol_seg_init_list;
%include cobol_type7;


dcl	proc_no		fixed bin,		/* Tag number of the section being
			   entered.		   */
	index		fixed bin;		/* Do loop index.		   */

/* Instruction pair to transfer control to and establish return
   from independent segment initialization code sequence.	   */

dcl	seg_init_tra_inst_pr
			(4) bit (18) unaligned static
			init ("000000000000000010"b, "110011101000000100"b, "000000000000000000"b,
			"111001000000000100"b);	/*
The instructions produced are:
     eaa  2,ic,
     tra  0,1c
						   */

/*
P__r_o_c_e_d_u_r_e_s_C__a_l_l_e_d:_
						   */

dcl	cobol_addr	entry (ptr, ptr, ptr),
	cobol_define_tag	entry (fixed bin),
	cobol_emit	entry (ptr, ptr, fixed bin),
	cobol_make_tagref	entry (fixed bin, fixed bin, ptr),
	cobol_register$load entry (ptr);

/*
B__u_i_l_t-__i_n_F__u_n_c_t_i_o_n_s_U__s_e_d:_
						   */

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

/*}*/

%include cobol_;

start:						/*  Get procedure (tag) number of section being entered.	   */
	proc_no = in_token.token_ptr (1) -> proc_def.proc_num;

/*		  "PERFORM" Functions		   */

	if cobol_$perform_list_ptr ^= null
	then do;

/* Paragraph terminated at end-of-perform range? */

		if cobol_$para_eop_flag ^= 0
		then /* Insert alterable GO */
		     do;
			call cobol_register$load (addr (register_request));
			input_struc_basic.segno = perform_list.perf.target_a_segno (cobol_$perform_para_index);
			input_struc_basic.char_offset =
			     perform_list.perf.target_a_offset (cobol_$perform_para_index);
			call cobol_addr (addr (input_struc_basic), addr (prfrm_altgo_inst_pr), null);
			call cobol_emit (addr (prfrm_altgo_inst_pr), null, 2);
			call cobol_define_tag (perform_list.perf.int_tag_no (cobol_$perform_para_index));
			cobol_$para_eop_flag = 0;
			cobol_$perform_para_index = cobol_$perform_para_index + 1;
		     end;

/* Section terminated at end-of-perform range? */

		do index = 1 to cobol_$sect_eop_flag;
		     call cobol_register$load (addr (register_request));
		     input_struc_basic.segno = perform_list.perf.target_a_segno (cobol_$perform_sect_index);
		     input_struc_basic.char_offset = perform_list.perf.target_a_offset (cobol_$perform_sect_index);
		     call cobol_addr (addr (input_struc_basic), addr (prfrm_altgo_inst_pr), null);
		     call cobol_emit (addr (prfrm_altgo_inst_pr), null, 2);
		     if in_token.token_ptr (1) -> proc_def.declarative_proc = "0"b
		     then call cobol_define_tag (perform_list.perf.int_tag_no (cobol_$perform_sect_index));

		     else perform_list.perf.int_tag_no (cobol_$perform_sect_index) =
			     -perform_list.perf.int_tag_no (cobol_$perform_sect_index);

		     cobol_$perform_sect_index = cobol_$perform_sect_index + 1;
		end;

/* Section entered at end-of-perform range? */

		cobol_$sect_eop_flag = 0;
		cobol_$perform_sect_index = cobol_$perform_para_index;
		if cobol_$perform_para_index <= perform_list.n
		then do while (proc_no = perform_list.perf.proc_num (cobol_$perform_para_index));
			cobol_$sect_eop_flag = cobol_$sect_eop_flag + 1;
			cobol_$perform_para_index = cobol_$perform_para_index + 1;
		     end;

	     end;

/*      Initialize segment containing section entered.	   */

	if cobol_$seg_init_list_ptr ^= null
	then do;
		if unspec (in_token.token_ptr (1) -> proc_def.priority)
		     ^= substr (unspec (cobol_$priority_no), 19, 18)
		then do;
			substr (unspec (cobol_$priority_no), 19, 18) =
			     unspec (in_token.token_ptr (1) -> proc_def.priority);
			if cobol_$priority_no > 49
			then do index = 1 to seg_init_list.n;
				if seg_init_list.seg.priority (index) = cobol_$priority_no
				then do;
					call cobol_emit (addr (seg_init_tra_inst_pr), null, 2);
					call cobol_make_tagref (seg_init_list.seg.int_tag_no (index),
					     cobol_$text_wd_off - 1, null);
					goto end_do_loop;
				     end;

			     end;
end_do_loop:
		     end;

	     end;

/*  Associate procedure number with next location in text.   */

	call cobol_define_tag (proc_no);

	return;

     end cobol_section_gen;




		    cobol_seginit_gen.pl1           05/24/89  1042.8rew 05/24/89  0830.0      147312



/****^  ***********************************************************
        *                                                         *
        * 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_seginit_gen.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 5/19/76 by Bob Chang to interface with prologue_gen changes.	*/
/* Modified on 5/18/76 by Bob Chang to interface with prologue_gen changes.	*/
/*{*/
/* format: style3 */
cobol_seginit_gen:
     proc (fxs_locno, last_decl_proc);

/*
The procedure cobol_seginit_gen is called by cobol_gen_driver_ only if
data and/or segment initialization is required for the program
being compiled.  The primary function of cobol_seginit_gen is to
generate code sequences to initialize explicit and implicit al- 
terable GO's, if any, contained in the program.  (An explicit al-
terable GO is one resulting from the implementation of an ALTER
statement.  An implicit alterable GO is one introduced at the end
of a procedure which terminates a perform range.)  In addition,
however, this procedure always updates stat.call_cnt from zero to 
one to indicate that initialization has been accomplished and
generates the transfer instruction at the end of the data/fixed-
segment initialization code sequence necessary to transfer con-
trol to the first instruction generated to implement the first
non-DECLARATIVE statement of the program.


U__s_a_g_e:_

     declare cobol_seginit_gen entry (fixed bin, fixed bin);

     call cobol_seginit_gen (fxs_locno, last_decl_proc);

						   */
declare	fxs_locno		fixed bin parameter,
	last_decl_proc	fixed bin parameter;

/*
fxs_locno	     is the compile time offset of the first instruc-
	     tion of the first executable statement of the pro-
	     gram.  (Input)

last_decl_proc is the procedure (tag) number of the last section
	     of the DECLARATIVES.  (Input)

						   */

/*
G__e_n_e_r_a_t_e_d_C__o_d_e:_

The following code is generated to initialize implicit alterable     
GO's (alterable GO's introduced at the end of perform ranges):  

     eaxn   t_relp,ic
     sxln   target_a_PNn

where:

n	   designates an index reqister number.  Any may be
	   used but two is reserved and used in the generated
	   code.

t_relp	   is the offset, relative to the instruction in which
	   it appears, of an instruction defined by a tag uni-
	   quely associated with target_a_PNn.  (Usually, this
	   is the instruction immediately following the end-of-
	   perform range alterable GO.)

target_a_PNn is a 36-bit variable allocated in the program's
	   COBOL data segment.  It is uniquely associated with
	   procedure-name-n which has been specified in a PER-
	   FORM statement as defining the end of a PERFORM
	   range.

Explicit Alterable GO's

Format 1 GO's with optional procedure-name present

Code Sequence 1, below, is generated if the COBOL segment con- 
taining procedure-name-2 does not require initialization before
control is transferred to procedure-name-2.  Code Sequence 2, be-
low, is generated if initialization is required.  Initialization
is not required if procedure-name-1 and procedure-name-2 are in
the same COBOL segment, if procedure-name-2 is in a fixed COBOL
segment, or if procedure-name-2 is in an independent COBOL seg-
ment which contains no alterable GO's.  The term "alterable GO"
is used here to designate a GO that is referenced by an ALTER
statement.  Procedure_name_1 is the procedure which conatins the
the GO statement and procedure-name-2 is the procedure to which
control is to be transferred.

     Sequence 1

  eaxn   pn2_relp,ic
  sxln   target_a_pn1

     Sequence 2

  eaxn   s(pn2)_init_relp,ic
  sxln   target_a_pn1
  eaxn   pn2_relp,ic
  stxn   target_a_pn1

where:

n	       designates an index reqister number.  Any may be
	       used but two is reserved and used in the genera-
	       ted code.

pn2_relp	       is the offset, relative to the instruction in
	       which it appears, of the first instruction of
	       procedure-name-2.

target_a_pn1     is a 36-bit variable, allocated in COBOL data on
	       a word boundary and uniquely associated with
	       procedure-name-1 (see alter_list), which con-
	       tains transfer address data.

s(pn2)_init_relp is the offset, relative to the instruction in
	       which it appears, of the first instruction of a
	       code sequence provided to initialize the alter-
	       able GO's in the segment containing procedure-
	       name-2.

Format 1 GO's with optional procedure-name absent

The following code initializes target_a_pn1 such that control is
transferred to the first instruction of a call to cobol_error_
which informs the user at execution time that no procedure has
been named to which control can be transferred.

  eaxn   er_relp,ic
  sxln   target_a_pn1

where:

er_relp	   is the offset, relative to the instruction in which
	   it appears, of the first instruction of a call to
	   cobol_error_.

target_a_pn1 is a 36-bit variable, allocated in the program's
	   COBOL data segment and uniquely associated with the
	   procedure containing the GO statement being initia-
	   lized (see alter_list), which contains transfer ad-
	   dress data.


Transfer instructions

An unconditional transfer instruction is generated at the end of
each initialization sequence.  The following instruction is gen-
erated at the end of the initialization sequence for fixed seg-
ments and is preceded by an instruction to update stat.call_cnt
from 0 to 1 (see fixed_static.incl.pl1 for a description of the
stat structure):

  aos   stat.call_cnt
  tra   0,0

where:

fxs_relp is the offset, relative to the transfer instruction, of
         the first instruction of the first executable statement
         of the program.

The following instruction is generated at the end of each code
sequence generated to initialize independent COBOL segments:

  tra   0,au

Prior to making the transfer to the initialization sequence, reg-
ister a, bits(0-17), will have been loaded with the offset within
the Text Section of the instruction to which control is to be
transferred subsequent to initialization.

						   */

/*
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 cobol_seginit_gen except 
those referencing data in the Linkage Section of the Object Seg- 
ment are non-relocatable.  The relocation code generated for each 
half of each non-relocatable instruction is "00000"b.

Instructions generated directly by cobol_seginit_gen that reference
data in the Linkage Section i.e. those instructions in the code
sequence of the form
	<opcode>  pr4|<offset>
are relocatable with respect to their left hand half and non-re-
locatable with respect to thier right hand half.  The relocation
code generated for the relocatable half of each such instruction
is "11001"b, when the operand referenced by the instruction is 
internal data, and "10100"b, when it is a link. In either case, 
the code generated for the non_relocatable half is "00000"b.
						   */

/*
D__a_t_a:_


     % include cobol_;

	Items in cobol_$incl.pl1 used (u) and/or set (s) by
	cobol_seginit_gen:

	     cobol_ptr (u)
	     text_wd_off (u)
	     perform_list_ptr (u)
	     seg_init_flag (u)
	     seg_init_list_ptr (u)

						   */

%include cobol_seg_init_list;
%include cobol_perform_list;

/*  Input structure for cobol_register$load		   */

declare	1 register_request	aligned static,
	  2 requested_reg	fixed bin aligned init (12),
	  2 assigned_reg	bit (4) aligned,
	  2 lock		fixed bin aligned init (1),
	  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; 1 requests that
	      the register be locked.

reg_set_now     not applicable for use_code = 0.

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

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

content_ptr     not applicable for use_code = 0.

literal_content not applicable for use_code = 0.
						   */

/*  Input structure 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.
						   */

/* Equate tag token					   */

declare	1 equate_tags	aligned static,
	  2 size		fixed bin aligned init (0),
	  2 line		fixed bin aligned init (0),
	  2 column	fixed bin aligned init (0),
	  2 type		fixed bin aligned init (31),
	  2 filler1	fixed bin aligned init (0),
	  2 equated_tag	fixed bin aligned,
	  2 true_tag	fixed bin aligned,
	  2 filler2	fixed bin aligned init (0),
	  2 filler3	fixed bin aligned init (0),
	  2 filler4	bit (16) aligned init ((16)"0"b);

/*
where:
type	  is the token type.

equated_tag is the tag number to be equated to true_tag.

true_tag	  is a tag which has been or will be associated with
	  an instruction location in the text.

No other fields of the token are used.

						   */

/* Instruction declarations				   */

dcl	init_perf_go	(4) bit (18) unaligned static init ("000000000000000000"b, "110010010000000100"b,
						/*  eax2   0,ic   */
			"000000000000000000"b, "100100010001000000"b);
						/*  sxl2   pr0|0  */

dcl	init_alt_go	(8) bit (18) unaligned static init ("000000000000000000"b, "110010010000000100"b,
						/*  eax2   0,ic   */
			"000000000000000000"b, "100100010001000000"b,
						/*  sxl2   pr0|0  */
			"000000000000000000"b, "110010010000000100"b,
						/*  eax2   0,ic   */
			"000000000000000000"b, "111100010001000000"b);
						/*  stx2   pr0|0  */

dcl	tra_ic_inst	(4) bit (18) unaligned static init ("100000000000001110"b, "000101100001000000"b,
						/*  aos    pr4|14 */
			"000000000000000000"b, "111001000000001000"b);
						/*  tra    0,0   */
						/* -5-18-76-*/

dcl	tra_a_inst	(2) bit (18) unaligned static init ("000000000000000000"b, "111001000000000001"b);
						/*  tra    0,au   */

dcl	tra_ic_reloc	(4) bit (5) aligned static init ("11001"b, "00000"b, "00000"b, "00000"b);

/*  Local data					   */

declare	index		fixed bin,		/* Do loop index.			   */
	jndex		fixed bin,		/* Do loop index.			   */
	init_ptr		ptr,			/* Ptr to initialization data in 	   */
						/* seg_init_list.			   */
	no_inst		fixed bin,		/* No of instructions emitted.	   */
	tag		fixed bin,		/* Tag number.			   */
	temp		fixed bin;		/* Temporary qualtity.		   */

/*  Based structure used to extract initialization data from   */
/*  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 pn2		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	entry (fixed bin),
	cobol_emit	entry (ptr, ptr, fixed bin),
	cobol_equate_tag	entry (ptr),
	cobol_make_tagref	entry (fixed bin, fixed bin, ptr),
	cobol_register$load entry (ptr),
	cobol_reset_r$in_line
			entry;


/*
B__u_i_l_t-__i_n_F__u_n_c_t_i_o_n_s_U__s_e_d:_
						   */

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

/*}*/

%include cobol_;


start:						/*  Initialize alterable GO's in fixed segments.		   */
	if cobol_$seg_init_flag ^= 0
	then do;
		call cobol_register$load (addr (register_request));

/*  Initialize end-of-perform range alterable GO's in all segments.  */

		if cobol_$perform_list_ptr ^= null
		then do;
			if last_decl_proc ^= 0
			then do;
				equate_tags.true_tag = last_decl_proc;

				do index = 1 to perform_list.n
				     while (perform_list.perf.proc_num (index) < last_decl_proc);
				     if perform_list.perf.int_tag_no (index) < 0
				     then do;
					     perform_list.perf.int_tag_no (index) =
						-perform_list.perf.int_tag_no (index);
					     equate_tags.equated_tag = perform_list.perf.int_tag_no (index);
					     call cobol_equate_tag (addr (equate_tags));
					end;

				end;

			     end;


			do index = 1 to perform_list.n;
			     target.segno = perform_list.perf.target_a_segno (index);
			     target.char_offset = perform_list.perf.target_a_offset (index);
			     call cobol_addr (addr (target), addr (init_perf_go (3)), null);
			     call cobol_emit (addr (init_perf_go), null, 2);
			     call cobol_make_tagref (perform_list.perf.int_tag_no (index), cobol_$text_wd_off - 2,
				null);
			end;

			call cobol_reset_r$in_line;
		     end;

/*  Initialize explicit GO's.			   */

		if cobol_$seg_init_list_ptr ^= null
		then do;
			if seg_init_list.seg.priority (1) = 0
			then do;
				index = 1;
				call initialize_go;
				index = 2;
			     end;

		     end;

	     end;

	else index = 1;

/*  Generate transfer to first executable instruction of program.  */

	temp = fxs_locno - cobol_$text_wd_off - 1;
	call cobol_emit (addr (tra_ic_inst), addr (tra_ic_reloc), 2);

/*  Initialize alterable GO's in independent segments.	   */

	if cobol_$seg_init_list_ptr ^= null
	then do index = index to seg_init_list.n;
		call cobol_define_tag (seg_init_list.seg.int_tag_no (index));
		call initialize_go;
		call cobol_emit (addr (tra_a_inst), null, 1);
	     end;

	return;

initialize_go:
     proc;

	do jndex = 0 to seg_init_list.seg.no_gos (index) - 1;
	     init_ptr = addrel (seg_init_list.seg.init_ptr (index), 3 * jndex);
	     target.segno = init_data.target_a_segno;
	     target.char_offset = init_data.target_a_offset;
	     call cobol_addr (addr (target), addr (init_alt_go (3)), null);
	     if init_data.init = 0
	     then no_inst = 2;

	     else do;
		     init_alt_go (7) = init_alt_go (3);
		     tag = init_data.init;
		     call cobol_make_tagref (tag, cobol_$text_wd_off, addr (init_alt_go));
		     no_inst = 4;
		end;

	     call cobol_emit (addr (init_alt_go), null, no_inst);
	     tag = init_data.pn2;
	     call cobol_make_tagref (tag, cobol_$text_wd_off - 2, null);

	end;

	return;

     end initialize_go;

     end cobol_seginit_gen;




		    cobol_send_gen.pl1              05/24/89  1042.8rew 05/24/89  0832.6      102294



/****^  ***********************************************************
        *                                                         *
        * 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_send_gen.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 10/02/77 by Bob Chang to fix the bug for mcs_ocdp. */
/* Modified on 05/05/77 by Bob Chang to fix the bug for mnemonic name hof.	*/
/* Modified on 04/12/77 by Bob Chang to fix the bug for end_indicator.	*/
/* Modified on 03/24/77 by Bob Chang to implement communication send verb.	*/
/* Created as a stub on 11/18/76 by ORN */

/* format: style3 */
cobol_send_gen:
     proc (in_token_ptr);

/* Declaration for static data.	*/
dcl	1 pr_struc	static,
	  2 what_ptr	fixed bin init (2),
	  2 pointer_no	bit (3),
	  2 lock		fixed bin init (0),
	  2 switch	fixed bin init (0);

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

dcl	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 mpout		static,
	  2 n		fixed bin init (4),
	  2 pt1		ptr,
	  2 pt2		ptr,
	  2 pt3		ptr,
	  2 pt4		ptr;
dcl	1 fb17_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 places_left	fixed bin init (4),
	    3 places_right	fixed bin init (0),
	    3 flags1	bit (36) init ("000000100100010001000000000000000000"b),
	    3 flags2	bit (36) init (""b),
	    3 seg		fixed bin init (0),
	    3 off		fixed bin,
	  2 fill2		(7) fixed bin init (0, 0, 0, 0, 0, 0, 0);

dcl	inst_seq		(20) bit (18) unaligned static init ("110000000000000000"b, "010101010001000000"b,
						/* spri2	pr6|offset	*/
			"000000000000000000"b, "010011101000000111"b,
						/* lda	0,dl		*/
			"110000000000000000"b, "111101101001000000"b,
						/* sta	pr6|offset	*/
			"110000000000000000"b, "100101000001000000"b,
						/* stz	pr6|offset	*/
			"110000000000000000"b, "010011100001000000"b,
						/* szn	pr6|offset	*/
			"000000000000000000"b, "110000000000000100"b,
						/* tze	0,ic		*/
			"000000000000000000"b, "010011101000000100"b,
						/* lda	0,ic		*/
			"000000000000000000"b, "010011111001000000"b,
						/* ldaq	pr0|offset	*/
			"000000000000000000"b, "010011101000000011"b,
						/* lda	0,du		*/
			"110000000000000000"b, "111101111001000000"b);
						/* staq	pr6|offset	*/

dcl	inst_buff		bit (36),
	inst_char		char (4) based (addr (inst_buff));
dcl	btd		(6) bit (18) static init ("000000000001000000"b, "011000001101000000"b,
						/* btd		*/
			"110000000000000000"b, "000000000000000100"b, "110000000000000000"b, "000011000000000100"b);


/*	Automatic data	*/
dcl	null_ptr		ptr static init (null),
	null_ptr_char	char (8) based (addr (null_ptr)),
	conoff		fixed bin,
	temp_char		char (4),
	temp_char1	char (1),
	temp_bit1		bit (9) based (addr (temp_char1)),
	con_flag		fixed bin,
	stoff		fixed bin,
	dn_ptr		ptr,
	name_ptr		ptr,
	in_op		fixed bin,
	char_conv		char (9),
	dec_conv		fixed dec (6),
	temp		fixed bin;

/* External procedure	*/
dcl	cobol_call_op	entry (fixed bin, fixed bin),
	cobol_reg_manager$after_op
			entry (fixed bin, fixed bin),
	cobol_move_gen	entry (ptr),
	cobol_pool	entry (char (*), fixed bin, fixed bin),
	cobol_pool$search_op
			entry (char (*), fixed bin, fixed bin, fixed bin),
	cobol_pointer_register$priority
			entry (fixed bin, fixed bin, bit (3)),
	cobol_emit	entry (ptr, ptr, fixed bin),
	cobol_define_tag	entry (fixed bin),
	cobol_make_tagref	entry (fixed bin, fixed bin, ptr),
	cobol_set_pr	entry (ptr, ptr),
	cobol_get_size	entry (ptr, fixed bin, fixed bin);

start:
	mpout.pt1 = in_token.token_ptr (1);
	mpout.pt4 = addr (type19_move);
	eos_ptr = in_token.token_ptr (in_token.n);

/* Generate epp2 instruction for communication token.	*/
	cdtoken_ptr = in_token.token_ptr (2);
	alpha_type9.seg = cdtoken.cd_seg;
	alpha_type9.off = cdtoken.cd_off - 20;
	call cobol_set_pr (addr (pr_struc), addr (alpha_type9));

/* Allocate 12 words in stack frame for parameters	*/
	stoff = 74;				/* Communication stack frame  from pr6|74	*/

/* Store cd_token address.	*/
	substr (inst_seq (1), 4, 15) = substr (unspec (stoff), 22, 15);
	call cobol_emit (addr (inst_seq (1)), null, 1);

/* Set up parameter for message type.	*/
	temp = stoff + 4;
	if end_stmt.a = "000"b | end_stmt.b
	then do;					/* Generate epp2 instruction for receiving data item.	     */
		dn_ptr = in_token.token_ptr (3);
		call cobol_set_pr (addr (pr_struc), dn_ptr);
						/* Store into stack frame.	     */
		temp = stoff + 2;
		substr (inst_seq (1), 4, 15) = substr (unspec (temp), 22, 15);
		call cobol_emit (addr (inst_seq (1)), null, 1);
		if ^data_name.variable_length
		then do;
			dec_conv = dec (data_name.item_length);
			char_conv = char (dec_conv);
			temp_char = substr (char_conv, 6, 4);
			con_flag = 1;
		     end;
		else do;
			temp = stoff + 16;
			call cobol_get_size (dn_ptr, temp, 0);
						/* Generate btd instruction	*/
			substr (btd (3), 4, 15) = substr (unspec (temp), 22, 15);
			temp = stoff + 4;
			substr (btd (5), 4, 15) = substr (unspec (temp), 22, 15);
			call cobol_emit (addr (btd), null, 3);
			con_flag = 0;
		     end;
	     end;
	else do;
		call cobol_pool$search_op (null_ptr_char, 2, conoff, in_op);
		substr (inst_seq (15), 4, 15) = substr (unspec (conoff), 22, 15);
		call cobol_emit (addr (inst_seq (15)), null, 1);
						/* Store into stack frame.	     */
		temp = stoff + 2;
		substr (inst_seq (19), 4, 15) = substr (unspec (temp), 22, 15);
		call cobol_emit (addr (inst_seq (19)), null, 1);
		temp_char = "9999";
		con_flag = 1;
	     end;
	if con_flag = 1
	then do;
		call cobol_pool (temp_char, 1, conoff);
		temp = -cobol_$text_wd_off - conoff;
		inst_seq (13) = substr (unspec (temp), 19, 18);
		temp = stoff + 4;
		substr (inst_seq (5), 4, 15) = substr (unspec (temp), 22, 15);
		call cobol_emit (addr (inst_seq (13)), null, 1);
		call cobol_emit (addr (inst_seq (5)), null, 1);
	     end;

	if end_stmt.a = "000"b
	then do;
		temp = stoff + 5;
		substr (inst_seq (7), 4, 15) = substr (unspec (temp), 22, 15);
		call cobol_emit (addr (inst_seq (7)), null, 1);
		temp = stoff + 6;
		substr (inst_seq (7), 4, 15) = substr (unspec (temp), 22, 15);
		call cobol_emit (addr (inst_seq (7)), null, 1);
	     end;
	else do;
		if end_stmt.d = "00"b
		then do;
			if end_stmt.b
			then mpout.pt2 = in_token.token_ptr (4);
			else mpout.pt2 = in_token.token_ptr (3);
			mpout.pt3 = addr (alpha_type9);
			alpha_type9.size = 1;
			alpha_type9.seg = 1000;
			alpha_type9.off = (stoff + 5) * 4;
			call cobol_move_gen (addr (mpout));
		     end;
		else do;
			dec_conv = dec (fixed (end_stmt.d));
			char_conv = char (dec_conv);
			temp_char1 = substr (char_conv, 9, 1);
			substr (inst_seq (17), 1, 9) = temp_bit1;
			call cobol_emit (addr (inst_seq (17)), null, 1);
			temp = stoff + 5;
			substr (inst_seq (5), 4, 15) = substr (unspec (temp), 22, 15);
			call cobol_emit (addr (inst_seq (5)), null, 1);
		     end;
		if end_stmt.f = "00"b
		then do;				/* no linage	*/
			temp = stoff + 6;
			substr (inst_seq (7), 4, 15) = substr (unspec (temp), 22, 15);
			call cobol_emit (addr (inst_seq (7)), null, 1);
		     end;
		else do;
			dn_ptr = in_token.token_ptr (in_token.n - 1);
			if data_name.type = 9
			then do;			/* line count in identifier	*/
				mpout.pt2 = dn_ptr;
				mpout.pt3 = addr (fb17_type9);
				fb17_type9.seg = 1000;
				fb17_type9.off = (stoff + 6) * 4 + 2;
				call cobol_move_gen (addr (mpout));
			     end;
			if end_stmt.f = "01"b
			then substr (inst_buff, 1, 9) = "000000001"b;
			else substr (inst_buff, 1, 9) = "000000010"b;
			if data_name.type = 9
			then do;			/* ldx2	type of line control	*/
				substr (inst_buff, 19, 18) = "010010010000000011"b;
				substr (inst_buff, 10, 9) = "000000001"b;
				call cobol_emit (addr (inst_buff), null, 1);
						/* stx2 pr6|stoff+6	*/
				temp = stoff + 6;
				substr (inst_buff, 1, 3) = "110"b;
				substr (inst_buff, 4, 15) = substr (unspec (temp), 22, 15);
				substr (inst_buff, 19, 18) = "111100010001000000"b;
				call cobol_emit (addr (inst_buff), null, 1);
			     end;
			else do;
				if data_name.type = 2
				then do;		/* advancing integer lines.	*/
					substr (inst_buff, 10, 9) = "000000001"b;
					temp =
					     fixed (
					     substr (dn_ptr -> numeric_lit.literal, 1,
					     dn_ptr -> numeric_lit.places_left));
					substr (inst_buff, 19, 18) = substr (unspec (temp), 19, 18);
				     end;
				else if data_name.type = 1 & dn_ptr -> reserved_word.key = reswd_PAGE
				then /* advancing page.	*/
				     substr (inst_buff, 10, 27) = "000000010000000000000000001"b;
				else if data_name.type = 17
				then do;
					if dn_ptr -> mnemonic_name.iw_key < 227
					     & dn_ptr -> mnemonic_name.iw_key > 210
					then do;	/* slew, channel number mnemonic name.	*/
						substr (inst_buff, 10, 9) = "000000011"b;
						temp = dn_ptr -> mnemonic_name.iw_key - 210;
						substr (inst_buff, 19, 18) = substr (unspec (temp), 19, 18);
					     end;
					else substr (inst_buff, 10, 27) = "000000010000000000000000001"b;
				     end;
				call cobol_pool (inst_char, 1, conoff);
				temp = -cobol_$text_wd_off - conoff;
				inst_seq (13) = substr (unspec (temp), 19, 18);
				temp = stoff + 6;
				substr (inst_seq (5), 4, 15) = substr (unspec (temp), 22, 15);
				call cobol_emit (addr (inst_seq (13)), null, 1);
				call cobol_emit (addr (inst_seq (5)), null, 1);
			     end;
		     end;
	     end;

/* Call cobol_operators_	*/
	call cobol_call_op (73, 0);

	call cobol_reg_manager$after_op (73, 0);


exit:
	return;

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

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

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


%include cobol_in_token;
%include cobol_;
%include cobol_type19;
%include cobol_type9;
%include cobol_type13;
%include cobol_type1;
%include cobol_reswd_values;
%include cobol_type2;
%include cobol_type17;
     end cobol_send_gen;




		    cobol_set_fsbptr.pl1            05/24/89  1042.8rew 05/24/89  0832.6       30492



/****^  ***********************************************************
        *                                                         *
        * 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_set_fsbptr.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 1/25/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_set_fsbptr:
     proc (ft_ptr);

dcl	ft_ptr		ptr;

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	instr		(3) bit (36);
dcl	reloc		(6) bit (5) aligned;
dcl	instr_ptr		ptr;
dcl	reloc_ptr		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	epp1		bit (12) static init ("011101001101"b);
dcl	epp1_indmod	bit (18) static init ("011101001101010000"b);

dcl	utemp		fixed bin;
dcl	i		fixed bin;
dcl	ic		fixed bin;

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


/*************************************/
start:
	instr_ptr = addr (instr);
	reloc_ptr = addr (reloc);
	do i = 1 to 6;
	     reloc (i) = ""b;
	end;
	ic = 1;
	if file_table.fsb.seg < 0
	then do;					/* external file - link to fsb */
		utemp = -file_table.fsb.seg;
		instr (1) = "100"b || substr (unspec (utemp), 22, 15) || epp1_indmod;
		if file_table.fsb.off ^= 0
		then do;
			instr (2) = "001"b || substr (unspec (file_table.fsb.off), 22, 15) || epp1;
			ic = 2;
		     end;
		reloc (1) = "10100"b;
	     end;
	else do;					/* internal file - fsb in cobol data segment */
		instr (1) = (18)"0"b || epp1_indmod;
		basic_struct.seg = file_table.fsb.seg;
		basic_struct.offset = file_table.fsb.off;
		call cobol_addr (addr (basic_struct), instr_ptr, reloc_ptr);
	     end;
	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 (instr_ptr, reloc_ptr, ic);
exit:
	return;


/*************************************/
%include cobol_file_table;
%include cobol_ext_;
%include cobol_fixed_common;
%include cobol_;
     end cobol_set_fsbptr;




		    cobol_set_gen.pl1               05/24/89  1042.8rew 05/24/89  0832.6      210366



/****^  ***********************************************************
        *                                                         *
        * 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_set_gen.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 04/05/80/ by FCH, [4.2-1], fix out-of range checking, BUG430(TR4533) */
/* Modified since Version 4.2 */
/*{*/
/* format: style3 */
cobol_set_gen:
     proc (in_token_ptr);

dcl	opno		fixed bin;
dcl	ok_tag		fixed bin;
dcl	retry_tag		fixed bin;
dcl	slen		fixed bin;
dcl	(i, j)		fixed bin;
dcl	temp		fixed bin;
dcl	value		fixed bin;
dcl	litoff		fixed bin;

dcl	temp_numlit	char (18);
dcl	char4		char (4) based;
dcl	char8		char (8) based;

dcl	done		bit (1);
dcl	ocsw		bit (1);
dcl	subsw		bit (1);

dcl	iptr		ptr;
dcl	s1p		ptr;
dcl	r1p		ptr;
dcl	s2p		ptr;
dcl	r2p		ptr;
dcl	dn_ptr		ptr;
dcl	name_ptr		ptr;

dcl	rterror_SET_RANGE	fixed bin static options (constant) init (61);
dcl	A		fixed bin static options (constant) init (1);
dcl	Q		fixed bin static options (constant) init (2);
dcl	AQ		fixed bin static options (constant) init (3);
dcl	X5		fixed bin static options (constant) init (15);

dcl	ADQ		bit (11) static options (constant) init ("00011111000"b);
dcl	CWL		bit (11) static options (constant) init ("00100100100"b);
dcl	LDA		bit (11) static options (constant) init ("01001110100"b);
dcl	LDQ		bit (11) static options (constant) init ("01001111000"b);
dcl	LCQ		bit (11) static options (constant) init ("01101111000"b);
dcl	LDAQ		bit (11) static options (constant) init ("01001111100"b);
dcl	STAQ		bit (11) static options (constant) init ("11110111100"b);
dcl	STA		bit (11) static options (constant) init ("11110110100"b);
dcl	STQ		bit (11) static options (constant) init ("11110111000"b);
dcl	STBQ		bit (11) static options (constant) init ("10110101000"b);
dcl	LXL5		bit (11) static options (constant) init ("11101010100"b);
dcl	LDX5		bit (11) static options (constant) init ("01001010100"b);
dcl	STX5		bit (11) static options (constant) init ("11110010100"b);
dcl	AOS		bit (11) static options (constant) init ("00010110000"b);
dcl	STBQ_MASK		bit (6) static options (constant) init ("110000"b);

dcl	set_seq		(2) bit (36) static options (constant) init ("000000000000000001010011101000000111"b,
						/* lda 1,dl */
			"100000000000001010011101010001010000"b);
						/*epp2 pr4|12,**/
dcl	set_reloc		(4) bit (5) aligned static options (constant) init ("00000"b, "00000"b, "11001"b, "00000"b);
dcl	QRS_instr		bit (36) static options (constant) init ("000000000000010010111011010000000000"b);
						/* qrs	22 */
dcl	QLS_instr		bit (36) static options (constant) init ("000000000000010010111011110000000000"b);
						/* qls	22 */
dcl	ANQ1_instr	bit (36) static options (constant) init ("000000000000000000011111110000000011"b);
						/* anq	0,du */
dcl	qls_instr		bit (36) static init ("000000000000000000111011110000000000"b);
						/* qls	X */
dcl	sta_instr		bit (36) static init ("010000000000000000111101101001000000"b);
						/* sta 2|x */
dcl	stz_instr		bit (36) static init ("010000000000000000100101000001000000"b);
						/* stz 2|x */
dcl	mpy_instr		bit (36) static init ("000000000000000000100000010000000111"b);
						/* mpy	X,dl */
dcl	tze_instr		bit (36) static init ("000000000000000000110000000000000100"b);
						/* tze X */
dcl	ldaq_ic_instr	bit (36) static init ("000000000000000000010011111000000100"b);
						/* ldaq X,ic */
dcl	ldq_ic_instr	bit (36) static init ("000000000000000000010011110000000100"b);
						/* ldq X,ic */
dcl	ldq_dl_instr	bit (36) static init ("000000000000000000010011110000000111"b);
						/* ldq X,dl */
dcl	lcq_ic_instr	bit (36) static init ("000000000000000000011011110000000100"b);
						/* lcq X,ic */
dcl	lcq_dl_instr	bit (36) static init ("000000000000000000011011110000000111"b);
						/* lcq X,dl */

dcl	reloc		(2) bit (5);
dcl	1 instr,
	  2 address,
	    3 regno	bit (3),
	    3 offset	bit (15),
	  2 op		bit (11),
	  2 reg		bit (1),
	  2 tag		bit (12);

dcl	1 out_token,
	  2 n		fixed bin,
	  2 fill		fixed bin,
	  2 ptr		(4) ptr;

dcl	1 pool,
	  2 num1		fixed bin (35),
	  2 num2		fixed bin (35);


dcl	1 add_eos		static options (constant),
	  2 size		fixed bin init (10),
	  2 line		fixed bin init (0),
	  2 column	fixed bin init (0),
	  2 type		fixed bin init (19),
	  2 verb		fixed bin init (2),
	  2 e		fixed bin init (1),
	  2 h		fixed bin init (1),
	  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 subtract_eos	static options (constant),
	  2 size		fixed bin init (10),
	  2 line		fixed bin init (0),
	  2 column	fixed bin init (0),
	  2 type		fixed bin init (19),
	  2 verb		fixed bin init (11),
	  2 e		fixed bin init (1),
	  2 h		fixed bin init (1),
	  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 move_eos	static options (constant),
	  2 size		fixed bin init (10),
	  2 line		fixed bin init (0),
	  2 column	fixed bin init (0),
	  2 type		fixed bin init (19),
	  2 verb		fixed bin init (18),
	  2 e		fixed bin init (1),
	  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 reg		aligned static,
	  2 num		fixed bin,
	  2 assigned_reg	bit (4),
	  2 lock		fixed bin init (1),
	  2 reg_set_now	fixed bin,
	  2 use_code	fixed bin init (0),
	  2 content_ptr	ptr init (null ()),
	  2 literal_content bit (36) init (""b);

dcl	1 ss1		aligned static,
	  2 type		fixed bin init (1),
	  2 operand_no	fixed bin init (0),
	  2 lock		fixed bin init (0),
	  2 segno		fixed bin,
	  2 offset	fixed bin (24),
	  2 send_receive	fixed bin init (0);

dcl	1 rs1		aligned static,
	  2 type		fixed bin init (1),
	  2 operand_no	fixed bin init (0),
	  2 lock		fixed bin init (0),
	  2 segno		fixed bin,
	  2 offset	fixed bin (24),
	  2 send_receive	fixed bin init (1);

dcl	1 ss2		aligned 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 init (null ()),
	    3 send_receive	fixed bin init (0),
	    3 ic_mod	fixed bin,
	    3 size_sw	fixed bin init (1);

dcl	1 rs2		aligned 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 init (null ()),
	    3 send_receive	fixed bin init (1),
	    3 ic_mod	fixed bin,
	    3 size_sw	fixed bin init (1);

declare	1 ptr_register_request
			aligned static,
	  2 what_pointer	fixed bin aligned init (2),
	  2 assigned_ptr	fixed bin aligned,
	  2 lock		fixed bin aligned init (1),
	  2 switch	fixed bin aligned init (0),
	  2 segno		fixed bin aligned init (0),
	  2 offset	fixed bin aligned init (0),
	  2 reset		fixed bin aligned;

dcl	cobol_pool	entry (char (*), fixed bin, fixed bin);
dcl	cobol_addr	entry (ptr, ptr, ptr);
dcl	cobol_emit	entry (ptr, ptr, fixed bin);
dcl	cobol_register$load entry (ptr);
dcl	cobol_register$release
			entry (ptr);
dcl	cobol_pointer_register$get
			entry (ptr);
dcl	cobol_pointer_register$priority
			entry (fixed bin, fixed bin, bit (3));
dcl	cobol_make_type9$long_bin
			entry (ptr, fixed bin, fixed bin (24));
dcl	cobol_move_gen	entry (ptr);
dcl	cobol_add_gen	entry (ptr);
dcl	cobol_subtract_gen	entry (ptr);
dcl	cobol_define_tag	entry (fixed bin);
dcl	cobol_make_tagref	entry (fixed bin, fixed bin, ptr);
dcl	cobol_gen_error	entry (fixed bin, fixed bin);

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

/*************************************/
start:
	ocsw = fixed_common.options.oc;
	eos_ptr = in_token.token_ptr (in_token.n);
	opno = end_stmt.e;
	dn_ptr = in_token.token_ptr (opno + 2);
	s1p = addr (ss1);
	r1p = addr (rs1);
	s2p = addr (ss2);
	r2p = addr (rs2);
	go to format (binary (end_stmt.a));

/*************************************/
format (0):					/* set {IN | IDN | ID} to {IN | IDN | ID | LIT} */
start0:
	if data_name.type = 10
	then do;					/* set x to IN */
		ind_ptr = dn_ptr;
		ss1.segno = index_name.seg_num;
		ss1.offset = index_name.offset;
		slen = index_name.struc_length;
		do i = 1 to opno;
		     dn_ptr = in_token.token_ptr (i + 1);
		     if data_name.type = 10
		     then do;			/* set IN to IN */
			     ind_ptr = dn_ptr;
			     rs1.segno = index_name.seg_num;
			     rs1.offset = index_name.offset + 4;
			     if ocsw
			     then call oc_start;
			     if slen = index_name.struc_length
			     then do;		/* equal element lengths */
				     call addr_emit (s1p, LDAQ);
				     call reg_lock (AQ);
				     rs1.offset = rs1.offset - 4;
				     call addr_emit (r1p, STAQ);
				     call reg_unlock (AQ);
				end;
			     else do;		/* unequal element lengths */
				     ss1.offset = ss1.offset + 4;
				     call addr_emit (s1p, LDQ);
				     ss1.offset = ss1.offset - 4;
				     call reg_lock (AQ);
				     ;
				     call addr_emit (r1p, STQ);
				     call mpy;
				     call adj_emit (-1, STQ);
				     call reg_unlock (AQ);
				end;
			     if ocsw
			     then call oc_finish;
			end;
		     else if data_name.type = 9
		     then if data_name.usage_index
			then do;			/* set IDN to IN */
				rs2.token_ptr = dn_ptr;
				call addr_emit (s1p, LDA);
				call adj_emit (1, LXL5);
				call reg_lock (A);
				call reg_lock (X5);
				call addr_emit (r2p, STA);
				call adj_emit (1, STX5);
				call reg_unlock (A);
				call reg_unlock (X5);
			     end;
			else do;			/* set ID to IN */
				out_token.n = 4;
				out_token.ptr (1) = in_token.token_ptr (1);
				out_token.ptr (2) = null ();
				out_token.ptr (3) = dn_ptr;
				out_token.ptr (4) = addr (move_eos);
				call cobol_make_type9$long_bin (out_token.ptr (2), ss1.segno, ss1.offset + 4);
				call cobol_move_gen (addr (out_token));
			     end;
		end;
	     end;

	else if data_name.type = 9
	then if data_name.usage_index
	     then do;				/* set x to IDN */
		     ss2.token_ptr = dn_ptr;
		     do i = 1 to opno;
			dn_ptr = in_token.token_ptr (i + 1);
			if data_name.type = 10
			then do;			/* set IN to IDN */
				ind_ptr = dn_ptr;
				rs1.segno = index_name.seg_num;
				rs1.offset = index_name.offset;
				if ocsw
				then call oc_start;
				call addr_emit (s2p, LDAQ);
				call reg_lock (AQ);
				call cobol_emit (addr (QRS_instr), null (), 1);
				call addr_emit (r1p, STAQ);
				call reg_unlock (AQ);
				if ocsw
				then do;
					call oc_finish;
					call oc_finish_idn;
				     end;
			     end;
			else do;			/* set IDN to IDN */
				rs2.token_ptr = dn_ptr;
				if data_name.subscripted
				then do;		/* can't use STBQ instruction */
					call addr_emit (s2p, LDA);
					call adj_emit (1, LDX5);
					call reg_lock (A);
					call reg_lock (X5);
					call addr_emit (r2p, STA);
					call adj_emit (1, STX5);
					call reg_unlock (A);
					call reg_unlock (X5);
				     end;
				else do;
					call addr_emit (s2p, LDAQ);
					call reg_lock (AQ);
					call addr_emit (r2p, STA);
					instr.tag = STBQ_MASK;
					call adj_emit (1, STBQ);
					call reg_unlock (AQ);
				     end;
			     end;
		     end;
		end;

	     else if (data_name.bin_18 & ^data_name.subscripted) /* set IN to ID(short binary) */ | data_name.bin_36
	     then do;				/* set to ID(long binary) */
		     ss2.token_ptr = dn_ptr;
		     do i = 1 to opno;
			ind_ptr = in_token.token_ptr (i + 1);
			rs1.segno = index_name.seg_num;
			rs1.offset = index_name.offset + 4;
			if ocsw
			then call oc_start;
			call addr_emit (s2p, LDQ);
			call reg_lock (Q);
			if data_name.bin_18
			then do;
				if mod (data_name.offset, 4) ^= 0 & ^data_name.linkage_section
				then call cobol_emit (addr (QLS_instr), null (), 1);
				call cobol_emit (addr (QRS_instr), null (), 1);
			     end;
			call addr_emit (r1p, STQ);
			call mpy;
			call adj_emit (-1, STQ);
			call reg_unlock (Q);
			;
			if ocsw
			then call oc_finish;
		     end;
		end;

	     else do;				/* set IN to ID(general) */
		     out_token.n = 4;
		     out_token.ptr = in_token.token_ptr (1);
		     out_token.ptr (2) = dn_ptr;
		     out_token.ptr (4) = addr (move_eos);
		     do i = 1 to opno;
			ind_ptr = in_token.token_ptr (i + 1);
			rs1.segno = index_name.seg_num;
			rs1.offset = index_name.offset + 4;
			if ocsw
			then call oc_start;
			out_token.ptr (3) = null ();
			call cobol_make_type9$long_bin (out_token.ptr (3), rs1.segno, rs1.offset);
			call cobol_move_gen (addr (out_token));
			call addr_emit (r1p, LDQ);
			call reg_lock (Q);
			call mpy;
			call adj_emit (-1, STQ);
			call reg_unlock (Q);
			if ocsw
			then call oc_finish;
		     end;
		end;

	else do;					/* set IN to LIT */
		nlit_ptr = dn_ptr;
		temp_numlit = (18)"0";
		substr (temp_numlit, 19 - numeric_lit.places_left, numeric_lit.places) = numeric_lit.literal;
		pool.num2 = fixed (temp_numlit);
		if pool.num2 = 0
		then call oc_unconditional;
		else do i = 1 to opno;
			ind_ptr = in_token.token_ptr (i + 1);
			rs1.segno = index_name.seg_num;
			rs1.offset = index_name.offset;
						/*[4.2-1]*/
			if pool.num2 < 1 | pool.num2 > index_name.max
			then call oc_unconditional;
			else do;
				pool.num1 = pool.num2 * index_name.struc_length;
				call cobol_pool (addr (pool) -> char8, 2, litoff);
				temp = -(cobol_$text_wd_off + litoff);
				substr (ldaq_ic_instr, 1, 18) = substr (unspec (temp), 19, 18);
				call cobol_emit (addr (ldaq_ic_instr), null (), 1);
				call reg_lock (AQ);
				call addr_emit (r1p, STAQ);
				call reg_unlock (AQ);
				;
			     end;
		     end;
	     end;
	return;


/*************************************/
format (1):					/* set IN {up | down} {ID | LIT} */
start1:
	dn_ptr = in_token.token_ptr (opno + 2);
	if data_name.type = 9
	then do;
		if (data_name.bin_18 & ^data_name.subscripted) /* set IN up | down ID(short binary) */
		     | data_name.bin_36
		then do;				/* set IN up | down ID(long binary) */
			ss2.token_ptr = dn_ptr;
			do i = 1 to opno;
			     ind_ptr = in_token.token_ptr (i + 1);
			     rs1.segno = index_name.seg_num;
			     rs1.offset = index_name.offset + 4;
			     if ocsw
			     then call oc_start;
			     if end_stmt.b
			     then call addr_emit (s2p, LCQ);
						/* DOWN */
			     else call addr_emit (s2p, LDQ);
						/* UP */
			     call reg_lock (Q);
			     if data_name.bin_18
			     then do;
				     if mod (data_name.offset, 4) ^= 0 & ^data_name.linkage_section
				     then call cobol_emit (addr (QLS_instr), null (), 1);
				     call cobol_emit (addr (QRS_instr), null (), 1);
				end;
			     call addr_emit (r1p, ADQ);
			     call adj_emit (0, STQ);
			     call mpy;
			     call adj_emit (-1, STQ);
			     call reg_unlock (Q);
			     if ocsw
			     then call oc_finish;
			end;
		     end;
		else do;				/* set IN up | down ID(general) */
			out_token.n = 4;
			out_token.ptr (1) = in_token.token_ptr (1);
			out_token.ptr (2) = dn_ptr;
			do i = 1 to opno;
			     ind_ptr = in_token.token_ptr (i + 1);
			     rs1.segno = index_name.seg_num;
			     rs1.offset = index_name.offset + 4;
			     if ocsw
			     then call oc_start;
			     out_token.ptr (3) = null ();
			     call cobol_make_type9$long_bin (out_token.ptr (3), rs1.segno, rs1.offset);
			     if end_stmt.b
			     then do;		/* DOWN */
				     out_token.ptr (4) = addr (subtract_eos);
				     call cobol_subtract_gen (addr (out_token));
				end;
			     else do;
				     out_token.ptr (4) = addr (add_eos);
				     call cobol_add_gen (addr (out_token));
				end;
			     call addr_emit (r1p, LDQ);
			     call reg_lock (Q);
			     call mpy;
			     call adj_emit (-1, STQ);
			     call reg_unlock (Q);
			     if ocsw
			     then call oc_finish;
			end;
		     end;
	     end;

	else do;					/* set IN up | down LIT */
		nlit_ptr = dn_ptr;
		temp_numlit = (18)"0";
		substr (temp_numlit, 19 - numeric_lit.places_left, numeric_lit.places) = numeric_lit.literal;
		value = fixed (temp_numlit);
		if numeric_lit.sign = "-"
		then subsw = ^end_stmt.b;
		else subsw = end_stmt.b;
		if value > 1 | subsw
		then do i = 1 to opno;
			ind_ptr = in_token.token_ptr (i + 1);
			rs1.segno = index_name.seg_num;
			rs1.offset = index_name.offset + 4;
			if ocsw
			then call oc_start;
			if value < 262144
			then do;
				if subsw
				then do;
					substr (lcq_dl_instr, 1, 18) = substr (unspec (value), 19, 18);
					call cobol_emit (addr (lcq_dl_instr), null (), 1);
				     end;
				else do;
					substr (ldq_dl_instr, 1, 18) = substr (unspec (value), 19, 18);
					call cobol_emit (addr (ldq_dl_instr), null (), 1);
				     end;
			     end;
			else do;
				call cobol_pool (addr (value) -> char4, 1, litoff);
				temp = -(cobol_$text_wd_off + litoff);
				if subsw
				then do;
					substr (lcq_ic_instr, 1, 18) = substr (unspec (temp), 19, 18);
					call cobol_emit (addr (lcq_ic_instr), null (), 1);
				     end;
				else do;
					substr (ldq_ic_instr, 1, 18) = substr (unspec (temp), 19, 18);
					call cobol_emit (addr (ldq_ic_instr), null (), 1);
				     end;
			     end;
			call reg_lock (Q);
			call addr_emit (r1p, ADQ);
			call adj_emit (0, STQ);
			call mpy;
			call adj_emit (-1, STQ);
			call reg_unlock (Q);
			if ocsw
			then call oc_finish;
		     end;
		else if value = 1
		then do i = 1 to opno;
			ind_ptr = in_token.token_ptr (i + 1);
			rs1.segno = index_name.seg_num;
			rs1.offset = index_name.offset + 4;
			if ocsw
			then call oc_start;
			call addr_emit (r1p, AOS);
			if index_name.struc_length = 1
			then call adj_emit (-1, AOS);
			else do;
				call reg_lock (Q);
				call adj_emit (0, LDQ);
				call mpy;
				call adj_emit (-1, STQ);
				call reg_unlock (Q);
			     end;
			if ocsw
			then call oc_finish;
		     end;
	     end;
	return;


/*************************************/
format (2):
start2:
	call cobol_pointer_register$get (addr (ptr_register_request));
	if end_stmt.c = "1"b
	then do;
		call cobol_emit (addr (set_seq (1)), addr (set_reloc (1)), 2);
		string (instr) = sta_instr;
	     end;
	else do;					/* OFF */
		call cobol_emit (addr (set_seq (2)), addr (set_reloc (3)), 1);
		string (instr) = stz_instr;
	     end;
	do i = 1 to opno;
	     name_ptr = in_token.token_ptr (i + 1);
	     temp = mnemonic_name.iw_key - 1;
	     instr.offset = substr (unspec (temp), 22, 15);
	     call cobol_emit (addr (instr), null (), 1);
	end;
	call cobol_pointer_register$priority (2, 0, "010"b);
	return;


/*************************************/
/* INTERNAL PROCEDURES */

adj_emit:
     proc (n, opcode);
dcl	n		fixed bin;
dcl	opcode		bit (11);
start:
	temp = fixed (instr.offset) + n;
	instr.offset = substr (unspec (temp), 22, 15);
	instr.op = opcode;
	call cobol_emit (addr (instr), null (), 1);
	return;
     end adj_emit;

addr_emit:
     proc (struc_ptr, opcode);
dcl	struc_ptr		ptr;
dcl	opcode		bit (11);
start:
	instr.op = opcode;
	call cobol_addr (struc_ptr, addr (instr), addr (reloc (1)));
	call cobol_emit (addr (instr), addr (reloc (1)), 1);
	return;
     end addr_emit;

mpy:
     proc;
dcl	n		fixed bin (35);
start:
	n = index_name.struc_length;
	if n ^= 1
	then do;
		done = "0"b;
		do j = 19 to 36 while (^done);
		     if substr (unspec (n), j, 1) = "1"b
		     then do;
			     if substr (unspec (n), j + 1) = ""b
			     then do;
				     temp = 36 - j;
				     substr (qls_instr, 1, 18) = substr (unspec (temp), 19, 18);
				     iptr = addr (qls_instr);
				end;
			     else do;
				     substr (mpy_instr, 1, 18) = substr (unspec (n), 19, 18);
				     iptr = addr (mpy_instr);
				end;
			     done = "1"b;
			end;
		end;
		if ^done
		then iptr = addr (ANQ1_instr);
		call cobol_emit (iptr, null (), 1);
	     end;
	return;
     end mpy;

reg_lock:
     proc (regno);
dcl	regno		fixed bin;
start:
	reg.num = regno;
	call cobol_register$load (addr (reg));
	return;
     end reg_lock;

reg_unlock:
     proc (regno);
dcl	regno		fixed bin;
start:
	if regno >= 10
	then temp = regno - 2;
	else temp = regno;
	reg.assigned_reg = substr (unspec (temp), 33, 4);
	reg.num = regno;
	call cobol_register$release (addr (reg));
	return;
     end reg_unlock;

oc_start:
     proc;
start:
	ok_tag = cobol_$next_tag;
	retry_tag = cobol_$next_tag + 1;
	cobol_$next_tag = cobol_$next_tag + 2;
	call cobol_define_tag (retry_tag);
	return;
     end oc_start;

oc_finish:
     proc;
start:						/*[4.2-1]*/
	pool.num1 = 1;
	if pool.num1 = 0
	then pool.num1 = 1;
	pool.num2 = index_name.max;
	call cobol_pool (addr (pool) -> char8, 2, litoff);
	temp = -(cobol_$text_wd_off + litoff);
	substr (ldaq_ic_instr, 1, 18) = substr (unspec (temp), 19, 18);
	call cobol_emit (addr (ldaq_ic_instr), null (), 1);
	rs1.offset = index_name.offset + 4;
	call reg_lock (AQ);
	call addr_emit (r1p, CWL);
	call reg_unlock (AQ);
	call cobol_emit (addr (tze_instr), null (), 1);
	call cobol_make_tagref (ok_tag, cobol_$text_wd_off - 1, null ());
	call cobol_gen_error (rterror_SET_RANGE, retry_tag);
	call cobol_define_tag (ok_tag);
	return;
     end oc_finish;

oc_finish_idn:
     proc;
start:
	ok_tag = cobol_$next_tag;
	cobol_$next_tag = cobol_$next_tag + 1;
	if index_name.struc_length ^= 1
	then do;					/* otherwise AQ will be already loaded */
		pool.num1 = pool.num1 * index_name.struc_length;
		pool.num2 = pool.num2 * index_name.struc_length;
		call cobol_pool (addr (pool) -> char8, 2, litoff);
		temp = -(cobol_$text_wd_off + litoff);
		substr (ldaq_ic_instr, 1, 18) = substr (unspec (temp), 19, 18);
		call cobol_emit (addr (ldaq_ic_instr), null (), 1);
	     end;
	call reg_lock (AQ);
	rs1.offset = rs1.offset - 4;
	call addr_emit (r1p, CWL);
	call reg_unlock (AQ);
	call cobol_emit (addr (tze_instr), null (), 1);
	call cobol_make_tagref (ok_tag, cobol_$text_wd_off - 1, null ());
	call cobol_gen_error (rterror_SET_RANGE, retry_tag);
	call cobol_define_tag (ok_tag);
	return;
     end oc_finish_idn;

oc_unconditional:
     proc;
	retry_tag = cobol_$next_tag;
	cobol_$next_tag = cobol_$next_tag + 1;
	call cobol_define_tag (retry_tag);		/* no escape */
	call cobol_gen_error (rterror_SET_RANGE, retry_tag);
	return;
     end oc_unconditional;


/*************************************/
/* INCLUDE FILES */
%include cobol_in_token;
%include cobol_type2;
%include cobol_type9;
%include cobol_type10;
%include cobol_type17;
%include cobol_type19;
%include cobol_fixed_common;
%include cobol_;
%include cobol_ext_;

     end cobol_set_gen;




		    cobol_set_pr.pl1                05/24/89  1042.8rew 05/24/89  0832.5       74853



/****^  ***********************************************************
        *                                                         *
        * 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_set_pr.pl1 Added Trace statements.
                                                   END HISTORY COMMENTS */


/* Modified on 09/23/83 by FCH, [5.2...], trace added */
/* Modified on 09/25/80 by FCH, [4.4-1], values in array epp_instr were being changed, BUG445 */
/* Modified on 01/12/78 by FCH, [3.0-1], a9db_instr changed from static to automatic */
/* Changes made since Version 3.0 */

/* format: style3 */
cobol_set_pr:
     proc (struc_ptr, dn_ptr);

dcl	struc_ptr		ptr;			/* pts to a structure identical to that used by cobol_pointer_register */
dcl	dn_ptr		ptr;			/* pts to a type 9 token */

/* This routine is passed an input structure identical to that
passed to cobol_pointer_register$get and additionally a pointer
to a type 9 token.  The pointer register specified in the
structure is set to point to the data item described by the type 9
token (to the byte).  The switch field in the input structure
should be set to 0.  If it is not, a call to this routine
is no different than a call to cobol_pointer_register$get, i.e.
the ptr to the type 9 token is ignored and the segno and offset
fields in the structure are used instead. */

dcl	1 structure	based (struc_ptr),
	  2 what_pointer	fixed bin,
	  2 pointer_no	bit (3),
	  2 lock		fixed bin,
	  2 switch	fixed bin,
	  2 segno		fixed bin,
	  2 offset	fixed bin (24),
	  2 reset		fixed bin;

/*
 what_pointer specifies the pointer register to be obtained.
	(input)
	0-7 - get this pointer register.
	 10 - get any temporary pointer register.
 pointer_no is the register that is assigned, in the
	range 0-7. (output)
 lock	can have the following values. (input)
	0 - do not change the lock or unlock status
	    of this pointer.
	1 - lock the pointer register.
	2 - unlock all pointer registers.
	3 - unlock all pointer registers and A register
	    and Q register and all index registers.
 switch	has the following values. (input)
	0 - the dn_ptr is to be used to set the pointer
	    register rather than segno and offset
	    fields which follow.  In this case the value
	    is not meaningful for register optimization.
	    Segment number and offset are meaningless.
	1 - a segment number and word offset are supplied.
	2 - a segment number and character offset are supplied
 segno 	is the segment number. (input)
	values recognized are:
	    2 - cobol data.
	 1000 - stack.
	 3000 - constants.
	 3002 - multics linkage.
	 4000 - pl1 operators.
	2nnnn - cobol linkage.
	   -n - link in multics linkage.
 offset	is the word or character offset (depending on switch).
	Any case when the offset is meaningless a 0 value
	must be used. 
	If a character offset is provided only the word
	portion is meaningful. (input)
 reset	specifies that the caller has requested a register
	that must have a preset value. For example a preset
	register to cobol data or the pointer to pl/1 operators
	(likely). This is only of interest to callers
	who request a specific register (what_pointer = 0-7)
	Such callers should test reset. If it is 1, a call to
	cobol_reset_r should be made in order
	to emit instructions to reload the register to
	its proper value.
/*}*/

dcl	1 addr_struc	static,
	  2 type		fixed bin,
	  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);		/* don't bother with size */

/*[4.4-1]*/
dcl	instr		bit (36);

dcl	epp_instr		(0:7) bit (36) static
			init ("000000000000000000011101000000000000"b, "000000000000000000011101001100000000"b,
			"000000000000000000011101010000000000"b, "000000000000000000011101011100000000"b,
			"000000000000000000011111000000000000"b, "000000000000000000011111001100000000"b,
			"000000000000000000011111010000000000"b, "000000000000000000011111011100000000"b)
			options (constant);
dcl	a9bd_instr	bit (36);			/*[3.0-1]*/
dcl	omit_sign_instr	(2) bit (36) static init ("000000000000000001010010010000000011"b,
						/* ldx2	1,du	*/
			"010000000000000000101000000101001010"b) /* a9bd	pr2|0,2	*/ options (constant);

dcl	reloc		(2) bit (5) aligned;
dcl	reloc_ptr		ptr;
dcl	instr_ptr		ptr;
dcl	addr_struc_ptr	ptr;
dcl	i		fixed bin;
dcl	backup		fixed bin;
dcl	subsw		bit (1);
dcl	omitsw		bit (1);

dcl	cobol_emit	entry (ptr, ptr, fixed bin);
dcl	cobol_addr	entry (ptr, ptr, ptr);
dcl	cobol_pointer_register$get
			entry (ptr);



	/***.....	dcl cobol_gen_driver_$Tr_Beg entry(char(*));/**/
	/***.....	dcl cobol_gen_driver_$Tr_End entry(char(*));/**/

	/***.....	dcl Trace_Bit bit(1) static external;/**/
	/***.....	dcl Trace_Lev fixed bin static external;/**/
	/***.....	dcl Trace_Line char(36) static external;/**/
	/***.....	dcl ioa_ entry options(variable); /**/
	/***..... dcl MY_NAME char (12) int static init ("COBOL_SET_PR");/**/


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

	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME);/**/

	omitsw = "0"b;
	go to start;

omit_sign:
     entry (struc_ptr, dn_ptr);

	/***..... dcl LOCAL_NAME char (10) int static init ("$OMIT_SIGN");/**/
	/***.....	if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME||LOCAL_NAME);/**/

	omitsw = "1"b;

start:
	if structure.switch ^= 0 | dn_ptr = null ()
	then do;

		call cobol_pointer_register$get (struc_ptr);
		go to pr_done;

	     end;



	if data_name.subscripted
	then do;

		subsw = "1"b;
		data_name.subscripted = "0"b;
		occurs_ptr = addrel (dn_ptr, substr (unspec (data_name.occurs_ptr), 17, 18));
		backup = 0;

		do i = 1 to occurs.dimensions;
		     backup = backup + divide (occurs.level.struc_length (i), 2, 35, 0);
						/* accumulate size of each dimension */
		end;

		data_name.offset = data_name.offset - backup;
						/* backup to zeroth element */


	     end;
	else subsw = "0"b;

	call cobol_pointer_register$get (struc_ptr);

	addr_struc.type = 2;
	addr_struc.operand.token_ptr = dn_ptr;
	addr_struc_ptr = addr (addr_struc);

/*[4.4-1]*/
	instr_ptr = addr (instr);			/*[4.4-1]*/
	instr = epp_instr (fixed (structure.pointer_no, 3));

	reloc_ptr = addr (reloc);

	call cobol_addr (addr_struc_ptr, instr_ptr, reloc_ptr);
	call cobol_emit (instr_ptr, reloc_ptr, 1);

	a9bd_instr = "000000000000000000101000000100000000"b;
						/*[3.0-1]*/

	if subsw
	then do;

		data_name.subscripted = "1"b;
		substr (a9bd_instr, 1, 3) = structure.pointer_no;
		addr_struc.type = 7;
		instr_ptr = addr (a9bd_instr);

		call cobol_addr (addr_struc_ptr, instr_ptr, reloc_ptr);
		call cobol_emit (instr_ptr, reloc_ptr, 1);

		data_name.offset = data_name.offset + backup;
						/* readjust offset to base of array */

	     end;
	else if mod (data_name.offset, 4) ^= 0
	then do;					/* non-word-aligned scalar data */

		substr (a9bd_instr, 1, 3) = structure.pointer_no;
		addr_struc.type = 7;
		instr_ptr = addr (a9bd_instr);

		call cobol_addr (addr_struc_ptr, instr_ptr, reloc_ptr);
		call cobol_emit (instr_ptr, reloc_ptr, 1);

	     end;

	if omitsw
	then if data_name.sign_separate
	     then call cobol_emit (addr (omit_sign_instr), null (), 2);
						/* adjust pr */

pr_done:	/***.....if Trace_Bit then call cobol_gen_driver_$Tr_End(MY_NAME);/**/
	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_occurs_ext;
%include cobol_type9;
%include cobol_;
     end cobol_set_pr;




		    cobol_set_type40.pl1            05/24/89  1042.8rew 05/24/89  0832.5       15921



/****^  ***********************************************************
        *                                                         *
        * 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_set_type40.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Created on 7/23/76 By Bob Chang for the table set up of type40 token. */
/* format: style3 */
cobol_set_type40:
     proc (alpha_name_ptr);
ebcdic:
     entry (alpha_name_ptr);				/* This procedure is called to set up the table for type40 token,  */


dcl	temp		fixed bin,
	table_char	char (512) based (table_ptr),
	table_ptr		ptr;
start:
	temp = fixed (op_con.ascii_ebcdic, 17) - 2048;
	table_ptr = addrel (cobol_$op_con_ptr, temp);
	alphabet_name.table = table_char;
	alphabet_name.segno = 3;
	alphabet_name.offset = fixed (op_con.ascii_ebcdic, 17) * 4;
	alphabet_name.iw_key = 12;
	alphabet_name.hival_char = "ÿ";
	alphabet_name.loval_char = "";
	return;

dcl	(addrel, fixed)	builtin;

%include cobol_;
%include cobol_op_con;
%include cobol_type40;

     end cobol_set_type40;




		    cobol_short_to_longbin.pl1      05/24/89  1042.8rew 05/24/89  0834.6      108108



/****^  ***********************************************************
        *                                                         *
        * 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_short_to_longbin.pl1 Added Trace statements.
                                                   END HISTORY COMMENTS */


/* Modified on 11/16/84 by FCH, [5.3...], trace added */
/* Modified on 10/19/84 by FCH, [5.3-1], BUG563(phx18381), new cobol_addr_tokens.incl.pl1 */
/* Modified since Version 5.3 */





/*{*/

/* format: style3 */
cobol_short_to_longbin:
     proc (source_token_ptr, target_token_ptr);

/*
This procedure generates code to convert a short binary datum
to a long binary datum using the hardware registers.
*/

/*  DECLARATION OF THE PARAMETERS  */

dcl	source_token_ptr	ptr;
dcl	target_token_ptr	ptr;

/*  DESCRIPTION OF THE PARAMETERS  */

/*
PARAMETER		DESCRIPTION

source_token_ptr	Pointer to a token that describes the short
		binary datum to be converted.  This token
		will always be a data name (type 9) token.
		(input)
target_token_ptr	Pointer to a token that describes the long
		binary result of the conversion.  The contents
		of this pointer on input to this procedure
		vary in meaning, depending on the entry
		point called.  See "Additional Details"
		below.

*/

/*

Additional Details

This procedure has two entry points:
	1. $register
	2. $temp

When called at the "register" entry point, code is  generated to
convert the short binary to a long binary, and leave the long
binary result in a hardware register. (either A orQ).  The
token poihted at by target_token_ptr will be a register (type100)
token.  The register containing the long binary value
will be locked.
If target_token_ptr is null on input, then this procedure
chooses the register in which the short binary value is converted.
Space for the register token in provided by this procedure.
If target_token_ptr is not null on input, then it must point to
a register token (type  100) that specifies the register into
which the short binary value is to be converted and returned.
This procedure acquires (loads) and locks the specified register.


When called at the "temp" entry point, code is generated to
convert the short binary to a long binary, and store the
result into a temporary in the stack.  The token pointed at by
target_token_ptr on exit will be a data name (type 9) token.
If target_token_ptr is null on input, then space for the data name
token is provided by this procedure.  If target_token_ptr
is not null, then it must point to a buffer in which the data name
token is to be built.


*/

/*  DECLARATION OF EXTERNAL ENTRIES  */

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_addr	ext entry (ptr, ptr, ptr);
dcl	cobol_emit	ext entry (ptr, ptr, fixed bin);
dcl	cobol_register$release
			ext entry (ptr);
dcl	cobol_register$load ext entry (ptr);

/*  DECLARATION OF INTERNAL STATIC DATA  */

dcl	shift_inst	bit (36) int static init ("000000000000010010000000000000000000"b);
						/*  18 in upper half  */

dcl	STA		bit (10) int static init ("1111011010"b);
						/*  755(0)  */
dcl	STQ		bit (10) int static init ("1111011100"b);
						/*  756(0)  */
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)  */


/*  DECLARATION OF INTERNAL VARIABLES  */

dcl	char_offset	fixed bin (24);
dcl	temp_target_ptr	ptr;

dcl	1 input_buff	aligned,
	  2 buff		(1:10) ptr;
dcl	1 inst_buff	aligned,
	  2 buff		(1:5) fixed bin;
dcl	1 reloc_buff	aligned,
	  2 buff		(1:6) 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	shift_inst_ptr	ptr;
dcl	any_register	bit (1);

dcl	dn_ptr		ptr;

/*************************************************/
/*	ENTRY POINT: register		*/
/**************************************************/

register:
     entry (source_token_ptr, target_token_ptr);

/*
This entry point generates code to convert a short binary datum
to a long binary datum, and leaves the long binary result in
a hardware register.  (either A or Q).
*/
	/***..... dcl LOCAL_NAME char (9) int static init ("$REGISTER");/**/
	/***.....	if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME||LOCAL_NAME);/**/


	any_register = "0"b;
	if target_token_ptr = null ()
	then do;					/*  Create space for the target token.  */
		target_token_ptr = cobol_$temp_token_ptr;
		cobol_$temp_token_ptr = addrel (cobol_$temp_token_ptr, 5);
		any_register = "1"b;
	     end;					/*  Create space for the target token.  */
	call common_processing (source_token_ptr, target_token_ptr, any_register);

/***************************************************/
/*	RETURN POINT: register		*/
/**************************************************/

clbx:	/***.....	if Trace_Bit then call cobol_gen_driver_$Tr_End(MY_NAME);/**/
	return;



/**************************************************/
/*	ENTRY POINT: temp			*/
/**************************************************/
temp:
     entry (source_token_ptr, target_token_ptr);
dcl	work_buff		(1:5) ptr;

	/***..... dcl LOCAL_NAME2 char (5) int static init ("$TEMP");/**/
	/***.....	if Trace_Bit then call cobol_gen_driver_$Tr_Beg(MY_NAME||LOCAL_NAME2);/**/


/*  Allocate space in the stack to hold the long binary result of the conversion.  */
	call cobol_alloc$stack (4, 0, char_offset);

/*  Make a long binary data name (type 9) token  */
	call cobol_make_type9$long_bin (target_token_ptr, 1000 /*stack*/, char_offset);

	temp_target_ptr = addr (work_buff (1));
	temp_target_ptr -> cobol_type100.type = 100;
	any_register = "1"b;
	call common_processing (source_token_ptr, temp_target_ptr, any_register);

/*  On returning from common_processing, code has been generated to convert
	the short binary in a register.  The result is in the register, and
	temp_target_ptr points to the register token that describes the
	register that contains the result.  */

	input_ptr = addr (input_buff);
	inst_ptr = addr (inst_buff);
	reloc_ptr = addr (reloc_buff);

	input_struc_basic.type = 1;
	input_struc_basic.operand_no = 0;
	input_struc_basic.lock = 0;
	input_struc_basic.segno = target_token_ptr -> data_name.seg_num;
	input_struc_basic.char_offset = target_token_ptr -> data_name.offset;

/*  Get the address of the temp in which to store the long fixed binary.  */
	call cobol_addr (input_ptr, inst_ptr, reloc_ptr);

	if register_struc.reg_no = "0001"b		/*  A register  */
	then inst_struc_basic.fill1_op = STA;
	else inst_struc_basic.fill1_op = STQ;		/*  Emit code to store the register into the temp  */
	call cobol_emit (inst_ptr, null (), 1);

/*  Unlock the register */
	call cobol_register$release (addr (register_struc));

/**************************************************/
/*	RETURN POINT: temp			*/
/**************************************************/

	go to clbx;


/**************************************************/
/*	INTERNAL PROCEDURE			*/
/*	common_processing			*/
/**************************************************/

common_processing:
     proc (source_tok_ptr, target_tok_ptr, any_register_flag);

/*
This internal procedure generates code to load a short binary value
into the A or Q register, and shift it as necessary to extend the sign, and
produce an equivalent long binary value in the same register.
*/

dcl	source_tok_ptr	ptr;
dcl	target_tok_ptr	ptr;
dcl	any_register_flag	bit (1);

/*  DESCRIPTION OF THE PARAMETERS  */

/*
PARAMETER		DESCRIPTION

source_tok_ptr	Pointer to the data name token (type9)
		for the short binary datum to be converted
		to long binary.  (input)
target_tok_ptr	Pointer to a register token (type 100)
		for the register which is to contain the
		converted value.  (input)
any_register_flag	A flag that indicates whether any register
		may be used for the conversion, or whether
		the input register token specifies a
		particular register to be used.  If "1"b,
		then any register may be used.


*/

/*  Establish addressability to the source of conversion  */
	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.operand.token_ptr (1) = source_tok_ptr;
	input_struc.operand.size_sw (1) = 0;
	call cobol_addr (input_ptr, inst_ptr, reloc_ptr);

	if any_register_flag
	then register_struc.what_reg = 4;		/*  A or Q  */
	else if target_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 the register  */
	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);

	shift_inst_ptr = addr (shift_inst);
	if mod (source_tok_ptr -> data_name.offset, 4) ^= 0
	then do;					/*  source is half-word aligned, and is presently in A or Qlower  */

		if register_struc.reg_no = "0001"b
		then shift_inst_ptr -> inst_struc_basic.fill1_op = ALS;
		else shift_inst_ptr -> inst_struc_basic.fill1_op = QLS;

/*  Emit code to shift the short binary to upper of A or Q  */
		call cobol_emit (shift_inst_ptr, null (), 1);
	     end;					/*  Source is half-word aligned, and is presently in A or q lower.  */

	if register_struc.reg_no = "0001"b		/*  A  */
	then shift_inst_ptr -> inst_struc_basic.fill1_op = ARS;
	else shift_inst_ptr -> inst_struc_basic.fill1_op = QRS;
						/*  Emit code to shift the value in upper to lower, extending the sign  */
	call cobol_emit (shift_inst_ptr, null (), 1);

/*  Set the register number of the register containing the long binary value into the output token.  */
	target_tok_ptr -> cobol_type100.register = register_struc.reg_no;
	target_tok_ptr -> cobol_type100.type = 100;
     end common_processing;

	/***.....	dcl cobol_gen_driver_$Tr_Beg entry(char(*));/**/
	/***.....	dcl cobol_gen_driver_$Tr_End entry(char(*));/**/

	/***.....	dcl Trace_Bit bit(1) static external;/**/
	/***.....	dcl Trace_Lev fixed bin static external;/**/
	/***.....	dcl Trace_Line char(36) static external;/**/
	/***.....	dcl ioa_ entry options(variable); /**/
	/***..... dcl MY_NAME char (22) int static init ("COBOL_SHORT_TO_LONGBIN");/**/


/*  INCLUDE FILES USED BY THIS PROCEDRUE  */


/*****	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_type100;


/**************************************************/
/*	END OF EXTERNAL PROCEDURE  		*/
/*	cobol_short_to_longbin		*/
/**************************************************/

     end cobol_short_to_longbin;




		    cobol_sort_gen.pl1              05/24/89  1042.8rew 05/24/89  0832.5      114687



/****^  ***********************************************************
        *                                                         *
        * 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,MCR8072),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8072 cobol_sort_gen.pl1 Correct inverted sorts for some binary data
     types.
                                                   END HISTORY COMMENTS */


/* Modified on 10/23/84 by FCH, [5.3-1], BUG564(phx17268), sort can produce inverted results */
/* Modified on 11/15/76 by Bob Chang to cooperate with merge statement for setting static data.	*/
/* Modified since Version 2.0	*/
/* format: style3 */
cobol_sort_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	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		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	instr_seq		(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	rel_seq8		(2) bit (5) aligned static init ("00000"b, "00000"b);
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	rel_seq10		(10) 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);
dcl	1 sort_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	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,
	dn_ptr		ptr,			/* pointer to the type 9 token */
	alpha_ptr		ptr,
	ft_ptr		ptr,			/* pointer to the type 12 token */
	sort_file_ptr	ptr,			/* pointer to the type 12 token */
	sort_gen_ptr	ptr,
	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),
	sort_stack_off	fixed bin static init (0),	/* returned value of cobol_alloc$stack */
	temp		fixed bin,
	sort_gen_text_wd_off
			fixed bin,
	retry_tag		fixed bin,
	passed_tag	fixed bin,
	passed_tag1	fixed bin,
	i		fixed bin,		/* work variable */
	linkoff		fixed bin;		/* word offset of entry point link */
dcl	bit18		bit (18) based;


/*
Procedures Called		*/

dcl	cobol_compare_gen$sort
			entry (ptr, ptr),
	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 (15), ptr),
	cobol_release_gen	entry (ptr);

start:
	eos_ptr = in_token.token_ptr (1);
	sort_file_ptr = in_token.token_ptr (2);

	desc_ptr = addr (desc_off (1));
	if first_call ^= cobol_$compile_count
	then do;
		first_call = cobol_$compile_count;
		call cobol_alloc$stack (56, 2, sort_stack_off);
		cobol_$init_stack_off = cobol_$stack_off;
	     end;


	if end_stmt.type = 19
	then if (end_stmt.verb = reswd_SORT & end_stmt.h = 91)
	     then call cobol_release_gen (null ());
	     else if end_stmt.h = 90
	     then do;
		     call cobol_call_op (18, 0);
		     call cobol_call_op (17, 0);
		end;
	     else ;
	else do;

		eos_ptr = in_token.token_ptr (in_token.n);
		call initiate;
		last_token = in_token.n - 1;
		alpha_name_ptr = null ();
		if end_stmt.d ^= "00"b
		then do;
			alpha_name_ptr = in_token.token_ptr (in_token.n - 1);
			last_token = in_token.n - 2;
			if alphabet_name.iw_key = 11	/* ascii */
			then do;
				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;				/* 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 (instr_seq), null (), 1);
		text_ptr = addrel (cobol_$text_base_ptr, cobol_$text_wd_off);
		call cobol_sort_util (sort_file_ptr, desc_ptr, object_name, object_name_len);
		call cobol_def_util (3, object_name, object_name_len, text_ptr, 0, desc_ptr, null ());
		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);
		sort_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 */
		do i = 3 to (last_token);
		     pt1 = in_token.token_ptr (i);
		     pt2 = addr (alpha_type9);
		     alpha_type9 = pt1 -> alpha_type9_based;
		     pt3 = addr (type19);
		     type19.e = 102;		/* EQUAL */
		     pt2 -> data_name.seg_num = 5002;
		     pt1 -> data_name.seg_num = 5001;
		     if data_name.numeric = "0"b
		     then do;			/* switch compare  operands around */
			     workpt2 = pt2;
			     pt2 = pt1;
			     pt1 = workpt2;
			end;
		     type19.h = cobol_$next_tag;
		     cobol_$next_tag = cobol_$next_tag + 1;
		     call cobol_compare_gen$sort (addr (sort_in_token), alpha_name_ptr);

/*[5.3-1]*/
		     ad_bit = data_name.ad_bit;

/*[5.3-1]*/
		     if data_name.display		/*[5.3-1]*/
		     then if data_name.numeric	/*[5.3-1]*/
			then call cmpn_test;	/*[5.3-1]*/
			else call cmpc_test;	/*[5.3-1]*/
		     else if data_name.bin_18 | data_name.bin_36
						/*[5.3-1]*/
		     then call cmpq_test;		/*[5.3-1]*/
		     else call cmpn_test;

/*[5.3-1]*/
		     substr (instr_seq11 (2), 7, 3) = op;

		     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;
		sort_gen_ptr = addrel (cobol_$text_base_ptr, sort_gen_text_wd_off);
		substr (sort_gen_ptr -> bit18, 1, 18) = substr (unspec (temp), 19, 18);
		call cobol_define_tag (passed_tag);
	     end;
	return;

/*[5.3-1]*/
dcl	1 instr		static,			/*[5.3-1]*/
	  2 tmi		bit (3) init ("100"b),	/*[5.3-1]*/
	  2 tpl		bit (3) init ("101"b),	/*[5.3-1]*/
	  2 tnc		bit (3) init ("010"b),	/*[5.3-1]*/
	  2 trc		bit (3) init ("011"b);

/*[5.3-1]*/
dcl	ad_bit		bit (1) aligned,
	op		bit (3) aligned;

cmpn_test:
     proc;

/*[5.3-1]*/
	if ad_bit
	then op = tmi;
	else op = tpl;

     end;

cmpc_test:
     proc;

/*[5.3-1]*/
	if ad_bit
	then op = tnc;
	else op = trc;

     end;

cmpq_test:
     proc;

/*[5.3-1]*/
	if ad_bit
	then op = tpl;
	else op = tmi;

     end;




/* Interal procedure to generate codes to call sort_$initiate.
	The call is through the operator sort_initiate.	*/
initiate:
     proc;


dcl	inst_seq		(4) bit (18) init ("000000000000000000"b, "011101011100000100"b,
						/* epp3 compare,ic	*/
			"000000000000000000"b, "111010010000000111"b);
						/* lxl2 sort_stack_off,dl	*/
dcl	rel_seq		(4) bit (5) aligned init ("00000"b, "00000"b, "00000"b, "00000"b);


	call cobol_call_op (16, 0);
	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 = -sort_stack_off;
	else temp = sort_stack_off;
	inst_seq (3) = substr (unspec (temp), 19, 18);
	call cobol_emit (addr (inst_seq), addr (rel_seq), 2);

	compare_hold_ic = cobol_$text_wd_off - 2;
	call cobol_call_op (14, retry_tag);
	call cobol_reg_manager$after_op (14);

	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_op_con;

%include cobol_entry_seq;
%include cobol_fixed_static;
%include cobol_;
%include cobol_file_table;
%include cobol_type1;
%include cobol_type9;
%include cobol_type12;
%include cobol_type19;
%include cobol_type40;
%include cobol_reswd_values;
%include cobol_alpha_def;
%include cobol_ext_;
%include cobol_definitions;
     end cobol_sort_gen;




		    cobol_sort_util.pl1             05/24/89  1042.8rew 05/24/89  0832.5       28620



/****^  ***********************************************************
        *                                                         *
        * 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_sort_util.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 11/18/76 by Bob Chang to interface with merge generators.	*/
/* Modified since Version 2.0	*/

/*{*/
/* format: style3 */
cobol_sort_util:
     proc (file_ptr, desc_ptr, object_name, object_name_len);

/* This procedure is called by sort_gen for:

	1. create the object_name for sort compare routine.

	2 set the argument  offset which is based on desc_ptr.

The input to this procedure is:

	1 sort_merge_count to identify the count for the number of times for sort.

	2 file_ptr which points to the type12 token to get the sort file file.

*/

dcl	sort_merge_count	fixed bin static,
	first_call	fixed bin static init (0),
	file_ptr		ptr,
	desc_ptr		ptr,
	desc_off		(3) fixed bin,
	object_name	char (32),
	object_name_len	fixed bin;


/*}*/
dcl	desc_bit1		bit (36) static init ("100110100000000000000000000000000000"b),
	desc_bit2		bit (36) static init ("100000100000000000000000000000000001"b),
	desc_char1	char (4) based (addr (desc_bit1)),
	desc_char2	char (4) based (addr (desc_bit2)),
	(i, j, k)		fixed bin,
	sort_char		char (3),
	name_ptr		ptr,
	conv_char		(0:9) char (1) static init ("0", "1", "2", "3", "4", "5", "6", "7", "8", "9");

dcl	cobol_pool	entry (char (*), fixed bin, fixed bin);


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

start:
	if first_call ^= cobol_$compile_count
	then do;
		first_call = cobol_$compile_count;
		sort_merge_count = 0;
	     end;
	sort_merge_count = sort_merge_count + 1;
	sort_char = "";
	j = sort_merge_count;
	do i = 1 to 3;
	     k = mod (j, 10);
	     j = divide (j, 10, 17, 0);
	     sort_char = conv_char (k) || sort_char;
	end;

	name_ptr = file_ptr;
	object_name = (32)" ";
	object_name = "cmp" || sort_char || "_" || substr (fd_token.name, 1, fd_token.name_size);
	object_name_len = index (object_name, " ") - 1;
	if object_name_len = -1
	then object_name_len = 32;
	desc_ptr = addr (desc_off (1));
	call cobol_pool (desc_char1, 1, desc_off (1));
	call cobol_pool (desc_char1, 1, desc_off (2));
	call cobol_pool (desc_char2, 1, desc_off (3));
	do i = 1 to 3;
	     desc_off (i) = -desc_off (i);
	end;


	return;

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

%include cobol_type12;
%include cobol_;


     end cobol_sort_util;




		    cobol_start_gen.pl1             05/24/89  1042.8rew 05/24/89  0832.5       89046



/****^  ***********************************************************
        *                                                         *
        * 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_start_gen.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modifile on 08/27/79 by PRP, [4.0-2] new operator for alternate keys*/
/* Modified on 06/27/79 by FCH, [4.0-1], not option added for debug */
/* Modified on 11/1/78 by FCH,[3.0-1], alt rec keys added */
/* Modifies since Version 3.0 */

/* format: style3 */
cobol_start_gen:
     proc (mp_ptr, passed_tag);

dcl	passed_tag	fixed bin;		/* for  in-line error handling */
dcl	ptag		fixed bin;
dcl	mp_ptr		ptr;
dcl	1 mp		based (mp_ptr),
	  2 n		fixed bin,		/* from 3 to 4 */
	  2 pt		(0 refer (mp.n)) ptr;	/* pt(1) pts to type1 token for START */
						/* pt(2) pts to type 12 token for the file in question */
						/* pt(3) pts to type9 token for key IF end_stmt.a = "1"b */
						/* pt(n) pts to type19 token (eos) */

dcl	1 args,
	  2 entryno	fixed bin,
	  2 arglist_off	fixed bin,
	  2 stacktemp_off	fixed bin,
	  2 n		fixed bin,
	  2 arg		(4),
	    3 pt		ptr,
	    3 type	fixed bin,
	    3 off1	fixed bin,
	    3 off2	fixed bin,
	    3 value	bit (18) unal,
	    3 indirect	bit (1) unal,
	    3 overlay	bit (1) unal,
	    3 repeat_nogen	bit (1) unal,
	    3 regsw	bit (1) unal,
	    3 regno	bit (3) unal;

dcl	file_key_desc	char (40) based;
dcl	argb		(4) bit (216) based (addr (args.arg (1)));
dcl	text		(0:10000) bit (36) based (cobol_$text_base_ptr);

dcl	ft_ptr		ptr;
dcl	fkey_ptr		ptr;
dcl	name_ptr		ptr;
dcl	dn_ptr		ptr;
dcl	arg_ptr		ptr;
dcl	ioerror_ptr	ptr;

dcl	aloff		fixed bin;
dcl	size		fixed bin;
dcl	reclen_off	fixed bin;
dcl	order_off		fixed bin;
dcl	relation_off	fixed bin;
dcl	keylen_off	fixed bin;
dcl	key_off		fixed bin;
dcl	ntag		fixed bin;
dcl	errno		fixed bin;
dcl	alt_sw		bit (1);

dcl	seek_head_sw	bit (1);
dcl	temp_bit2		bit (2);

/*[3.0-1]*/
dcl	char5		char (5),
	key_ctr		fixed bin;

/*************************************/
/*************************************/
/* INITIALIZATION */
start:
	rw_ptr = mp.pt (1);
	eos_ptr = mp.pt (mp.n);
	ioerror_ptr = addr (ioerror);
	ioerror.cobol_code = 0;
	ioerror.type1_ptr = mp.pt (1);
	ioerror.mode = 0;

	if end_stmt.b = "1"b
	then do;					/* in-line error coding follows */
		ioerror.is_tag = cobol_$next_tag;	/* to be defined at end of generated code for WRITE */
		ptag, passed_tag = cobol_$next_tag + 1; /* to be defined by gen driver at end of in-line coding */
		ioerror.ns_tag = ptag;
		cobol_$next_tag = cobol_$next_tag + 2;
	     end;
	else do;
		ioerror.is_tag = 0;
		ptag = 0;
		ioerror.ns_tag = cobol_$next_tag;	/* to be defined at end of generated code */
		cobol_$next_tag = cobol_$next_tag + 1;
	     end;

	arg_ptr = addr (args);
	iocb_arg.pt = addr (iocb_basic_struct);

	call cobol_read_ft (mp.pt (2) -> fd_token.file_no, ft_ptr);

	call cobol_alloc$stack (368, 2, aloff);		/* enough for 92 words - aloff is a wd offset */
	args.arglist_off = aloff;
	argb (1) = unspec (iocb_arg);
	reclen_off = aloff + 22;
	order_off = aloff + 23;
	relation_off = aloff + 26;
	keylen_off = aloff + 27;
	key_off = aloff + 28;


/*************************************/
/* START CODE GENERATION */
start_codegen:					/* MAKE SURE FILE IS OPEN */
	ioerror.retry_tag = cobol_$next_tag;
	ntag = cobol_$next_tag + 1;
	cobol_$next_tag = cobol_$next_tag + 2;

	call cobol_define_tag (ioerror.retry_tag);

	call cobol_set_fsbptr (ft_ptr);		/* OPERATOR21(init_start) */
	call cobol_call_op (21, ntag);		/* INT_START_OP */

	call cobol_gen_ioerror (ft_ptr, ioerror_ptr);

	call cobol_define_tag (ntag);

/*[3.0-1]*/
	alt_sw = file_table.organization = 3 /* ind */ /*[3.0-1]*/ & /*[3.0-1]*/ file_table.alternate_keys ^= 0;

	if file_table.external | file_table.open_out
	then do;

		ntag = cobol_$next_tag;
		cobol_$next_tag = cobol_$next_tag + 1;

		call cobol_io_util$bypass_mode_error (ntag, "11"b);

		if (file_table.external | file_table.rewrite | file_table.delete) & file_table.access < 2
		then call cobol_io_util$move_direct ("001"b, fsb_keylen_sw, 4, 1, ""b);
						/* zero the switch */
						/* OPERATOR54(delete error) */
		call cobol_call_op (54, ntag);	/* ERROR_OP */

		call cobol_gen_ioerror (ft_ptr, ioerror_ptr);

		call cobol_define_tag (ntag);

	     end;

/*[3.0-1]*/
	if alt_sw & end_stmt.e ^= 511			/*[3.0-1]*/
	then do;
		char5 = file_table.alt_key_info;	/*[3.0-1]*/
						/*[3.0-1]*/
		do key_ctr = 1 by 1 to end_stmt.e;	/*[3.0-1]*/
						/*[3.0-1]*/
		     call cobol_read_rand (1, char5, fkey_ptr);
						/*[3.0-1]*/
		     char5 = file_key.next_alt;	/*[3.0-1]*/
						/*[3.0-1]*/
		end;				/*[3.0-1]*/
	     end;

	else call cobol_read_rand (1, file_table.r_key_info, fkey_ptr);

	addr (fkey_type9.file_key_info) -> file_key_desc = file_key.desc;

	seek_head_sw = "0"b;


	if end_stmt.a ^= "0"b
	then do;

		if end_stmt.d = "00"b
		then if mp.pt (3) -> data_name.item_length = fkey_type9.size
		     then ;			/* = whole key */
		     else seek_head_sw = "1"b;
		else seek_head_sw = "1"b;

	     end;

	if ^seek_head_sw
	then do;

		mpout.pt1 = mp.pt (1);
		mpout.pt2 = addr (fkey_type9);

		if file_table.organization = 2
		then do;				/* relative */
			mpout.pt3 = addr (num_type9);
			size, num_type9.size, num_type9.places_left = 16;
			num_type9.seg = 5001;	/* from PR1 */
			num_type9.off = file_table.fsb.off + fsb_key;
		     end;
		else do;				/* indexed */
			mpout.pt3 = addr (alpha_type9);
			size, alpha_type9.size = fkey_type9.size;
			alpha_type9.seg = 5001;	/* from PR1 */
			alpha_type9.off = file_table.fsb.off + fsb_key;
		     end;

		mpout.pt4 = addr (type19);

		call cobol_move_gen (addr (mpout));

		call cobol_io_util$move_direct ("001"b, fsb_keylen_sw, 4, 1, substr (unspec (size), 19, 18));

		ntag = cobol_$next_tag;

/*[3.0-1]*/
		if alt_sw				/*[3.0-1]*/
		then do;
			call cobol_io_util$key_loc (0, 0);
						/*[3.0-1]*/
			call alt_start (84);	/*[3.0-1]*/
		     end;

		cobol_$next_tag = cobol_$next_tag + 1;

		call cobol_set_fsbptr (ft_ptr);

		call cobol_ioop_util$set_icode;	/* OPERATOR67(read_seek_key) */
		call cobol_call_op (67, ntag);	/* iox_$seek_key */

		call cobol_gen_ioerror (ft_ptr, ioerror_ptr);

		call cobol_define_tag (ntag);

		errno = seek_errno;

	     end;
	else do;					/* must call iox_$control */


		temp_bit2 = end_stmt.d;		/* relational code */

		call cobol_io_util$move_direct ("110"b, relation_off * 4, 4, 1, (16)"0"b || temp_bit2);

		mpout.pt1 = mp.pt (1);
		mpout.pt2 = addr (fkey_type9);

		if file_table.organization = 2
		then do;				/* relative */
			mpout.pt3 = addr (num_type9);
			size, num_type9.size, num_type9.places_left = 16;
			num_type9.seg = 1000;	/* stack */
			num_type9.off = key_off * 4;
		     end;
		else do;				/* indexed */
			mpout.pt3 = addr (alpha_type9);
			size, alpha_type9.size = mp.pt (3) -> data_name.item_length;
			alpha_type9.seg = 1000;	/* stack */
			alpha_type9.off = key_off * 4;
		     end;

		mpout.pt4 = addr (type19);

		call cobol_move_gen (addr (mpout));

		call cobol_io_util$move_direct ("110"b, keylen_off * 4, 4, 1, substr (unspec (size), 19, 18));

/*[3.0-1]*/
		if alt_sw				/*[3.0-1]*/
		then do;
			call cobol_io_util$key_loc (1, relation_off);
						/*[3.0-1]*/
			call alt_start (82);	/*[3.0-1]*/
		     end;

/* CALL iox_$control(iocb_ptr,order_name,struc_ptr,code)  where:
				     order_name char(*) - "seek_head",
				     struc_ptr ptr -> 1 struc,
						     2 relation fixed bin,
						     2 keylen fixed bin,
						     2 key char(0 refer (keylen));
				relation:	0 - head = key
					1 - head >= key
					2 - head > key			*/

		ntag = cobol_$next_tag;
		cobol_$next_tag = cobol_$next_tag + 1;

		call cobol_set_fsbptr (ft_ptr);

		call cobol_ioop_util$set_icode;

		call cobol_ioop_util$ldaldx5 (9, reclen_off);
						/* OPERATOR23(start_control) */
		if alt_sw
		then call cobol_call_op (83, ntag);	/*[4.0-2]  iox_$control for alternate keys */
		else call cobol_call_op (23, ntag);	/* iox_$control */

		call cobol_gen_ioerror (ft_ptr, ioerror_ptr);

		call cobol_define_tag (ntag);

		errno = control_errno;

	     end;

	if (file_table.external | file_table.delete | file_table.rewrite) & file_table.access < 2
	then do;

		call cobol_set_fsbptr (ft_ptr);

		call cobol_io_util$move_direct ("001"b, fsb_keylen_sw, 4, 1, ""b);
						/* zero the switch */

	     end;

/*[3.0-1]*/
	if alt_sw					/*[3.0-1]*/
	then do;
		call cobol_io_util$file_desc (file_table.file_desc_1_offset);
						/*[3.0-1]*/
		call cobol_call_op (79, 0);		/*[3.0-1]*/
	     end;

	call cobol_reg_manager$after_op (4095 + ioerror.cobol_code);

/*[4.0-1]*/
	if end_stmt.f = "01"b			/*[4.0-1]*/
	then passed_tag = ioerror.is_tag;		/*[4.0-1]*/
	else call cobol_gen_ioerror$finish_up (ft_ptr, ioerror_ptr);

	return;

alt_start:
     proc (i);

/*[3.0-1]*/
declare	i		fixed bin;

/*[3.0-1]*/
	call cobol_io_util$file_desc (file_table.file_desc_1_offset);
						/*[3.0-1]*/
	call cobol_io_util$key_num (end_stmt.e);	/*[3.0-1]*/
	call cobol_call_op (i, 0);			/* OPERATORi(*) */
     end;



/*************************************/
%include cobol_start_gen_info;
%include cobol_start_gen_data;
     end cobol_start_gen;




		    cobol_stop_gen.pl1              05/24/89  1042.8rew 05/24/89  0832.5       96948



/****^  ***********************************************************
        *                                                         *
        * 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_stop_gen.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 06/11/81 by FCH, OPERATOR(94) used for STOP RUN if CD INITIAL */
/* Modified on 01/14/77 by ORN to signal command_abort_ rather than cobol_compiler_error */
/* Modified since Version 2.0 */

/*{*/
/* format: style3 */
cobol_stop_gen:
     proc (in_token_ptr);

/*
The procedure cobol_stop_gen generates the code necessary to imple-
ment the STOP statement.  The general format of the STOP state-
ment is:

	S_T_O_P_ {R_U_N_|literal}

If RUN is specified, execution of the run-unit ceases and control
is transferred to the operating system.  This is accomplished by
calling cobol_stoprun_, a program supplied as part of the run
time package.

If literal is specified, the execution of the run-unit is sus-
pended and the literal plus prog_id, as contained in the stat
structure of the program, is communicated to the terminal.  A
start command issued from the terminal reactivates the run-unit.
The DISPLAY generator is called to generate the code necessary to
transmit the desired message to the terminal and the system sub-
routine cu_$cl is called to reach command level.  Execution is
resumed with the instruction following the call to cu_$cl.

U__s_a_g_e:_

     declare cobol_stop_gen entry (ptr);

     call cobol_stop_gen(in_token_ptr);

						   */


/*
G__e_n_e_r_a_t_e_d_C__o_d_e:_

STOP RUN  -

For the STOP RUN statement, code is generated to place the line
number of the STOP RUN source statement in the program's stat
structure and to call cobol_stoprun_, a program supplied as part
of the run time package.  cobol_stoprun_ has no parameters.

The code generated to set line_no in stat and call cobol_stoprun_ is 
as follows:

loc_a lda    iln1,dl
      ldq    iln2,dl
      staq   pr4|36		stat.line_no
      eax1   pr6|46
      fld    0,dl
      epp2   pr4|ep_c_sr_,*
      tsx0   pr0|call_eo
      tra    loc_a_relp,ic

where:

iln1 and iln2 are the two parts of the internal line number of
	    the source line containing the STOP RUN statement
	    as determined at compile time.

ep_c_sr_	    is the offset, relative to the base of the Linkage
	    Section, of an execution time pointer (created as a
	    Type 4 link in the Object Segment) to the entry
	    point of cobol_stoprun_.

call_eo	    is the location, relative to the label operator_
	    table in cobol_operators_, of the first instruction
	    of the PLI call operator call_ext_out.  The current
	    value of call_eo is 6.

loc_a_relp    is the offset, relative to the instruction in which
	    it appears, of the first instruction generated to
	    implement the STOP RUN statement (it may be either
	    the instruction labeled loc_a in the above code or
	    an instruction generated to load pr4 to point to
	    the Linkage Section).

STOP literal  -

For the STOP literal statement, code is generated to print a mes-
sage comprising the program identification (stat.prog_id), a
colon space, and the literal on the terminal and to suspend the
execution of the run-unit.  Mc_stop_run calls cobol_display_gen to 
generate the code for printing the message at the terminal and 
itself generates the code for calling system subroutine cu_$cl 
which affects the required suspension of execution. A description 
of the functionality of cu_$cl may be found in the MPM.  The code 
generated to call cu_$cl, which has no arguments, is as follows:

      eax1   pr6|46
      fld    0,dl
      epp2   pr4|ep_cu_$cl,*
      tsx0   pr0|call_eo

where:

ep_cu_$cl is the offset, relative to the base of the Linkage Sec-
	tion, of an execution time pointer (created as a Type 4
	link in the Object Segment) to the entry point of 
	cu_$cl.
all_eo	is the location, relative to the label operator_table
	in cobol_operators_, of the first instruction of the PLI
	call operator call_ext_out.  The current value of
	call_eo is 6.

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 cobol_stop_gen except those
referencing data in the Linkage Section of the Object Segment are
non-relocatable.  The relocation code generated for each half of
each non-relocatable instruction is "00000"b.

Instructions generated directly by cobol_stop_gen that reference
data in the Linkage Section i.e. those instructions in the code
sequence of the form
	<opcode>  pr4|<offset>
are relocatable with respect to their left hand half and non-re-
locatable with respect to thier right hand half.  The relocation
code generated for the relocatable half of each such instruction
is "11001"b, when the operand referenced by the instruction is 
internal data, and "10100"b, when it is a link. In either case, 
the code generated for the non_relocatable half is "00000"b.

D__a_t_a:_

     % include cobol_;

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

	     cobol_ptr (u)
	     temp_token_ptr (u)
	     text_wd_off (u)

						   */

dcl	inst_seq		(4) bit (18) unaligned static init ("000000000000000000"b, "010011101000000111"b,
						/* lda    iln1,dl	*/
			"000000000000000000"b, "010011110000000111"b);
						/* ldq    iln2,dl	*/

dcl	tra_ic		(2) bit (18) unaligned static init ("000000000000000000"b, "111001000000000100"b);
						/* tra    loc-a-relp,ic	*/

declare	1 token3		aligned static,
	  2 size		fixed bin aligned init (25),
	  2 line		fixed bin aligned init (0),
	  2 column	fixed bin aligned init (0),
	  2 type		fixed bin aligned init (3),
	  2 lit_type	bit (1) unaligned init ("0"b),
	  2 all_lit	bit (1) unaligned init ("0"b),
	  2 filler1	bit (6) unaligned init ((6)"0"b),
	  2 lit_size	fixed bin aligned init (2),
	  2 string	char (2) aligned init (": ");

declare	1 display_eos	aligned static,
	  2 size		fixed bin aligned init (38),
	  2 line		fixed bin aligned init (0),
	  2 column	fixed bin aligned init (0),
	  2 type		fixed bin aligned init (19),
	  2 verb		fixed bin aligned init (42),
	  2 e		fixed bin aligned init (3),
	  2 h		fixed bin aligned init (0),
	  2 i		fixed bin aligned init (0),
	  2 j		fixed bin aligned init (0),
	  2 a		bit (3) unaligned init ("001"b),
	  2 b		bit (1) unaligned init ("0"b),
	  2 c		bit (1) unaligned init ("0"b),
	  2 d		bit (2) unaligned init ("00"b),
	  2 f		bit (2) unaligned init ("00"b),
	  2 g		bit (2) unaligned init ("00"b),
	  2 k		bit (5) unaligned init ((5)"0"b);
						/*  Local Data					   */

declare	offset		fixed bin,		/* Word offset.		   */
	line_no		fixed bin,		/* Line number from type1 token. */
	local_in_token_ptr	ptr,			/* Ptr to in_token structure     */
						/* passed to display generator.  */
	type9_token_ptr	ptr;			/* Ptr to type 9 token for	   */
						/* stat.prog_id.		   */

dcl	next_tag1;

dcl	dn_ptr		ptr;			/* Ptr to data_name token.	   */


declare	1 seg_ovfl_error	aligned static,
	  2 my_name	char (32) init ("cobol_stop_gen"),
	  2 message_len	fixed bin init (40),
	  2 message	char (40) init ("temp_token_area segment length exceeded!");

/*
P__r_o_c_e_d_u_r_e_s_C__a_l_l_e_d:_
						   */

dcl	cobol_display_gen	entry (ptr),
	cobol_emit	entry (ptr, ptr, fixed bin),
	cobol_reg_manager$before_op
			entry (fixed bin),
	cobol_make_type9$alphanumeric
			entry (ptr, fixed bin, fixed bin, fixed bin),
	cobol_reg_manager$after_op
			entry (fixed bin),
	cobol_call_op	entry (fixed bin, fixed bin),
	cobol_define_tag	entry (fixed bin),
	signal_		entry (char (*), ptr, ptr);

/*
B__u_i_l_t-__i_n_F__u_n_c_t_i_o_n_s_U__s_e_d:_
						   */

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

/*}*/

%include cobol_;
%include cobol_type1;
%include cobol_type9;
%include cobol_type19;
%include cobol_in_token;


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

/*[4.4-1]*/
dcl	A		bit (3),
	op_num		fixed bin;
start:						/*[4.4-1]*/
	A = in_token.token_ptr (in_token.n) -> end_stmt.a;

/*[4.4-1]*/
	if A ^= "001"b
	then goto stop_run;

	else goto stop_literal;

/*  Implementation for STOP RUN statement		   */

stop_run:
	line_no = in_token.token_ptr (1) -> reserved_word.line;

/*  Insert table look-up to determine iln1 and iln2.  In mean- */
/*  time, use line_no as iln1 and 0 as iln2.		   */

/*[4.4-1]*/
	if A = "010"b
	then op_num = 94;
	else op_num = 48;

	inst_seq (1) = substr (unspec (line_no), 19, 18);
	next_tag1 = cobol_$next_tag;
	cobol_$next_tag = cobol_$next_tag + 1;
	call cobol_reg_manager$before_op (0);
	call cobol_define_tag (next_tag1);
	call cobol_emit (addr (inst_seq), null (), 2);	/*[4.4-1]*/
	call cobol_call_op (op_num, next_tag1);

	return;

/*  Implementation of STOP literal.			   */

stop_literal:
	if 262143 - binary (rel (temp_token_ptr), 17) < 40
	then goto signal_seg_ovfl;

	if substr (rel (temp_token_ptr), 18, 1) = "1"b
	then temp_token_ptr = addrel (temp_token_ptr, 1);

	local_in_token_ptr = temp_token_ptr;
	type9_token_ptr = addrel (local_in_token_ptr, 12);
	temp_token_ptr = addrel (local_in_token_ptr, 40);
	call cobol_make_type9$alphanumeric (type9_token_ptr, 3002, 76, 65);
	type9_token_ptr -> data_name.size_rtn = -1;
	type9_token_ptr -> data_name.variable_length = "1"b;
	local_in_token_ptr -> in_token.n = 5;
	local_in_token_ptr -> in_token.code = 0;
	local_in_token_ptr -> in_token.token_ptr (1) = in_token_ptr -> in_token.token_ptr (1);
	local_in_token_ptr -> in_token.token_ptr (2) = type9_token_ptr;
	local_in_token_ptr -> in_token.token_ptr (3) = addr (token3);
	local_in_token_ptr -> in_token.token_ptr (4) = in_token_ptr -> in_token.token_ptr (2);
	local_in_token_ptr -> in_token.token_ptr (5) = addr (display_eos);
	call cobol_display_gen (local_in_token_ptr);
	call cobol_reg_manager$after_op (0);
	call cobol_call_op (43, 0);

	return;

signal_seg_ovfl:
	call signal_ ("command_abort_", null, addr (seg_ovfl_error));
	return;

     end cobol_stop_gen;




		    cobol_store_binary.pl1          05/24/89  1042.8rew 05/24/89  0832.4      197100



/****^  ***********************************************************
        *                                                         *
        * 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_store_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, [5.3-1], BUG563(phx18381), new cobol_addr_tokens.incl.pl1 */
/* Modified on 02/22/77 by Bob Chang to fix the bug for reloc bits.	*/
/* 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_store_binary:
     proc (source_ptr, target_ptr, call_again);		/*
This procedure generates code to store a fixed vinary datum inot
another fixed binary datum, in the arithmetic (as opposed to
the Cobol MOVE) sense.
*/

/*  DECLARATION OF THE PARAMETERS  */

dcl	source_ptr	ptr;
dcl	target_ptr	ptr;
dcl	call_again	bit (1);

/*  DESCRIPTION OF THE PARAMETERS  */

/*
PARAMETER		DESCRIPTION

source_ptr	Pointer to a token that describes the
		value to be stored. (input)  The source
		can be in one of the following places:
		  a. index register (short binary value)
		  b. A or Q (long binary value)
		  c. A and Q (result of multiplication)
		  d. in a data item (long or short binary)
		  e. in an immediate constant token (type 102)

target_ptr	Pointer to the data name token of the
		target. (input)  The target is always either
		a long binary or short binary datum.

call_again	A flag that is set to "1"b by this procedure
		if the calling procedure should call this
		procedure again to store the result into
		the target.  This flag will be set only
		when the size of the source is greater
		than the size of the target, and
		code has been generated to move the source
		into a temporary, in order to force overflow.
		Under these circumstances, the input parameter
		source_ptr is set to a token that describes
		the temporary, and call_again is set to
		"1"b.  A subsequent call to this procedure,
		with no additional changes to the input
		parameters by the calling procedure, will
		then generate code to move the temporary,
		(which is now of the same size as the target)
		into the target.

*/

/*  DECLARATION OF EXTERNAL ENTRIES  */

dcl	cobol_addr	ext entry (ptr, ptr, ptr);
dcl	cobol_emit	ext entry (ptr, ptr, fixed bin);
dcl	cobol_make_reg_token
			ext entry (ptr, bit (4));
dcl	cobol_short_to_longbin$register
			ext entry (ptr, ptr);
dcl	cobol_register$load ext entry (ptr);
dcl	cobol_register$release
			ext entry (ptr);
dcl	cobol_make_type9$decimal_9bit
			ext entry (ptr, fixed bin, fixed bin (24), fixed bin, 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));
dcl	cobol_alloc$stack	ext entry (fixed bin, fixed bin, fixed bin (24));



/*  DECLARATION OF INTERNALL STATIC DATA  */

dcl	STA		bit (10) int static init ("1111011010"b);
						/* 755(0)  */
dcl	STQ		bit (10) int static init ("1111011100"b);
						/* 756(0) */
dcl	STX		bit (10) int static init ("1111000000"b);
						/*  740(0)  */
dcl	SXL		bit (10) int static init ("1001000000"b);
						/*  440(0)  */
dcl	LDA		bit (10) int static init ("0100111010"b);
						/*  235(0)  */
dcl	LDQ		bit (10) int static init ("0100111100"b);
						/*  236(0)  */
dcl	LDX		bit (10) int static init ("0100100000"b);
						/*  220(0)  */
dcl	LXL		bit (10) int static init ("1110100000"b);
						/*  720(0)  */
dcl	BTD		bit (10) int static init ("0110000011"b);
						/*  301(1)  */
dcl	DTB		bit (10) int static init ("0110001011"b);
						/*  305(1)  */
dcl	STAQ		bit (10) int static init ("1111011110"b);
						/*  757(0)  */


/*  DECLARATION OF INTERNAL VARIABLES  */

dcl	source_length	fixed bin;
dcl	target_length	fixed bin;
dcl	temp_source_ptr	ptr;
dcl	temp_ptr		ptr;

dcl	1 input_buff	aligned,
	  2 buff		(1:10) ptr;
dcl	1 inst_buff	aligned,
	  2 buff		(1:4) fixed bin;
dcl	1 reloc_buff	aligned,
	  2 buff		(1:10) bit (5) aligned;

dcl	temp_op		bit (10);


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


/**************************************************/
start:	/***.....	if Trace_Bit then call cobol_gen_driver_$Tr_Beg(csb);/**/
	if source_ptr -> data_name.type = rtc_immed_const
	then do;					/*  Source is an immediate constant token  */
						/*  Load the constant into an index register.  */
		temp_ptr = null ();
		if target_ptr -> data_name.bin_18
		then call immed_to_index (source_ptr, temp_ptr);
		else call immed_to_register (source_ptr, temp_ptr);
		source_ptr = temp_ptr;
	     end;					/*  Source is an immediate constant token.  */

	call get_length (source_ptr, source_length);
	call get_length (target_ptr, target_length);

	if target_length < source_length
	then call difficult_store (source_ptr, target_ptr, call_again);
	else call easy_store (source_ptr, target_ptr, call_again);
exit:	/***.....	if Trace_Bit then call cobol_gen_driver_$Tr_End(csb);/**/
	return;

	/***.....	dcl csb char(18) init("COBOL_STORE_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); /**/



/**************************************************/
easy_store:
     proc (es_source_ptr, es_target_ptr, es_call_again);

/*
This procedure generates code to store a fixed binary datum
into another fixed binary datum of length equal to or greater
than the source datum.  The source may be in an index register,
or the A or Q register, or in a cobol data item.  The target is
always a cobol data item.
*/

/*  DECLARATION OF THE PARAMETERS  */

dcl	es_source_ptr	ptr;
dcl	es_target_ptr	ptr;
dcl	es_call_again	bit (1);

start_easy_store:
	es_call_again = "0"b;

/*  Set up the input structure for calling the addressability utility.  */
	input_ptr = addr (input_buff);
	inst_ptr = addr (inst_buff);
	reloc_ptr = addr (reloc_buff);

	input_struc.type = 2;
	input_struc.operand_no = 1;
	input_struc.lock = 0;
	input_struc.send_receive (1) = 1;		/*  receiving  */
	input_struc.operand.size_sw (1) = 0;

	if es_source_ptr -> data_name.type = rtc_register
	then do;					/*  Source is in a register.  */

/*  Establish addressability to the target*/
		input_struc.operand.token_ptr (1) = es_target_ptr;
		call cobol_addr (input_ptr, inst_ptr, reloc_ptr);

		if (es_source_ptr -> cobol_type100.register = "0001"b /*  A  */
		     | es_source_ptr -> cobol_type100.register = "0010"b /*  Q  */)
		then do;				/*  Source is in the A or Q  */

			if es_source_ptr -> cobol_type100.register = "0001"b
						/*  source in A  */
			then inst_struc_basic.fill1_op = STA;
			else inst_struc_basic.fill1_op = STQ;

			call cobol_emit (inst_ptr, reloc_ptr, 1);
		     end;				/*  Source is in the A or Q  */

		else do;				/*  Source is in an index register  */
						/*  Note that if the source is in an index register, the target must be a short
			binary, because arithmetic is done in the index registers only if all targets are
			short binary.  */

			if mod (es_target_ptr -> data_name.offset, 4) = 0
			then temp_op = STX;		/*  Target is word aligned  */
			else temp_op = SXL;		/*  Target is half-word aligned  */

			substr (temp_op, 7, 3) = substr (es_source_ptr -> cobol_type100.register, 2, 3);
			inst_struc_basic.fill1_op = temp_op;
			call cobol_emit (inst_ptr, reloc_ptr, 1);

		     end;				/*  Source is in an index register  */

	     end;					/*  Source is in a register  */


	else do;					/*  Source must be in a cobol data item  */

		if es_source_ptr -> data_name.bin_36
		then do;				/*  Source is a long binary.  */

/*  Note that if the source is a long binary, then the target is also a long binary.  */

/*  Establish addressability to the source.  */
			input_struc.operand.token_ptr (1) = es_source_ptr;
			call cobol_addr (input_ptr, inst_ptr, reloc_ptr);

/*  Get the A or Q register  */
			register_struc.what_reg = 4;	/*  A or Q  */
			register_struc.lock = 1;
			register_struc.contains = 1;
			register_struc.tok_ptr = es_source_ptr;
			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);

/*  Establish addressability to the target.  */
			input_struc.operand.token_ptr (1) = es_target_ptr;
			call cobol_addr (input_ptr, inst_ptr, reloc_ptr);

			if register_struc.reg_no = "0001"b
						/*  A  */
			then inst_struc_basic.fill1_op = STA;
			else inst_struc_basic.fill1_op = STQ;
			call cobol_emit (inst_ptr, reloc_ptr, 1);

/*  The source is now in the A or Q  */
/*  Make a register token for the A or Q, and set the source pointer
			(es_source_ptr) to point to this register token, so that additional sotres
			(if any) can be done directly from the A or Q.  */

			es_source_ptr = null ();
			call cobol_make_reg_token (es_source_ptr, register_struc.reg_no);

		     end;				/*  Source is a long binary  */

		else do;				/*  Source must be a short binary.  */

			if es_target_ptr -> data_name.bin_18
			then do;			/*  Target is a short binary  */

/*  Establish addressability to the source  */
				input_struc.operand.token_ptr (1) = es_source_ptr;
				call cobol_addr (input_ptr, inst_ptr, reloc_ptr);

/*  Get an index register into which to load the short binary, and lock it  */
				register_struc.what_reg = 5;
				register_struc.lock = 1;
				register_struc.contains = 1;
				register_struc.tok_ptr = es_source_ptr;
				call cobol_register$load (addr (register_struc));

				if mod (es_source_ptr -> data_name.offset, 4) = 0
				then temp_op = LDX; /*  Source is word aligned.  */
				else temp_op = LXL; /*  Source is  half_word aligned  */
				substr (temp_op, 7, 3) = substr (register_struc.reg_no, 2, 3);
				inst_struc_basic.fill1_op = temp_op;
						/*  Emit the instruction to load the source into an index register.  */
				call cobol_emit (inst_ptr, reloc_ptr, 1);

/*  Establish addressability to the target.  */
				input_struc.operand.token_ptr (1) = es_target_ptr;
				call cobol_addr (input_ptr, inst_ptr, reloc_ptr);

				if mod (es_target_ptr -> data_name.offset, 4) = 0
				then temp_op = STX; /*  Target is word aligned.  */
				else temp_op = SXL; /*  Target is holf-word aligned.  */

				substr (temp_op, 7, 3) = substr (register_struc.reg_no, 2, 3);
				inst_struc_basic.fill1_op = temp_op;

/*  Emit the instruction to store the index register into the target.  */
				call cobol_emit (inst_ptr, reloc_ptr, 1);

/*  Make a register token for the index register, and set the source pointer
				to point to the register token, so that additional stores (if any)
				can be done directly from the index register.  */
				es_source_ptr = null ();
				call cobol_make_reg_token (es_source_ptr, register_struc.reg_no);

			     end;			/*  Target is a short binary.  */

			else do;			/*  Target is a long binary  */

				temp_source_ptr = null ();
						/*  Convert the short binary source to a long binary in the A or Q  */
				call cobol_short_to_longbin$register (es_source_ptr, temp_source_ptr);

/*  Establish addressabiity to the target.  */
				input_struc.operand.token_ptr (1) = es_target_ptr;
				call cobol_addr (input_ptr, inst_ptr, reloc_ptr);

				if temp_source_ptr -> cobol_type100.register = "0001"b
						/*  A  */
				then inst_struc_basic.fill1_op = STA;
				else inst_struc_basic.fill1_op = STQ;
						/*  Emit the instruction to store the register into the target.  */
				call cobol_emit (inst_ptr, reloc_ptr, 1);

/*  Set the source pointer to the register token for the long
				binary, so that additional stores (if any) can be done
				directly from the register.  */
				es_source_ptr = temp_source_ptr;
			     end;			/*  Target is a long binary  */

		     end;				/*  Source must be a short binary.  */

	     end;					/*  Source must be a cobol data item.  */
exit_easy_store:
	return;

     end easy_store;


/**************************************************/
difficult_store:
     proc (ds_source_ptr, ds_target_ptr, ds_call_again);

/*  DECLARATION OF THE PARAMETERS  */

dcl	ds_source_ptr	ptr;
dcl	ds_target_ptr	ptr;
dcl	ds_call_again	bit (1);



/*
This procedure generates code that attempts to force a fixed
point overflow condition because the source (to be stored)
is potentially larger than the receiving target.
*/

/*  DESCRIPTION OF THE PARAMETERS  */

/*
PARAMETER		DESCRIPTION

ds_source_ptr	Pointer to a token that describes the value
		to be stored.  (input)  This token may be
		a register token for either A,Q, or A-Q, or
		a data name token (type 9) for a long binary
		cobol data item.
ds_target_ptr	Pointer to a token that describes the
		target of the store.(input)  This token
		is always a data name (type 9) token for
		either a long binary or short binary
		data item.
ds_call_again	A flag that is always set to "1"b by
		this procedure.

*/

/*  DECLARATION OF INTERNAL VARIABLES  */

dcl	temp_length	fixed bin;
dcl	ret_offset	fixed bin (24);
dcl	temp_op		bit (10);
dcl	temp_source_ptr	ptr;
dcl	temp_dec_token_ptr	ptr;
dcl	temp_bin_token_ptr	ptr;


/**************************************************/
start_difficult_store:				/*  Set up for calling the addressability utility.  */
	input_ptr = addr (input_buff);
	inst_ptr = addr (inst_buff);
	reloc_ptr = addr (reloc_buff);

	if ds_source_ptr -> data_name.type = rtc_register
	then do;					/*  Source is in a register.  */
						/*  Store the register(s) into temporary storage  */
		if ds_source_ptr -> cobol_type100.register = "0011"b
						/*  A and Q  */
		then temp_length = 8;
		else temp_length = 4;		/*  Allocate some temporary, aligned on a double word boundary.  */
		call cobol_alloc$stack (temp_length, 2, ret_offset);

/*  Make a long binary data name token for the temporary.  */
		temp_source_ptr = null ();
		call cobol_make_type9$long_bin (temp_source_ptr, 1000 /*stack*/, 4 * ret_offset);
						/*  Modify the item length, because make_type9$long_bin assumes a length of 4 bytes.  */
		temp_source_ptr -> data_name.item_length = temp_length;

/*  Set up for calling the addressability utility.  */
		input_struc_basic.type = 1;
		input_struc_basic.operand_no = 0;
		input_struc_basic.lock = 0;
		input_struc_basic.char_offset = ret_offset * 4;
		input_struc_basic.segno = 1000;	/*  stack  */

		call cobol_addr (input_ptr, inst_ptr, reloc_ptr);

/*  Insert the appropriate opode to store the register(s) into the temporary  */
		if ds_source_ptr -> cobol_type100.register = "0001"b
		then temp_op = STA;
		else if ds_source_ptr -> cobol_type100.register = "0010"b
		then temp_op = STQ;
		else temp_op = STAQ;

/*  Emit code to store the source into a temporary  */
		inst_struc_basic.fill1_op = temp_op;
		call cobol_emit (inst_ptr, reloc_ptr, 1);

/*  Unlock the register that contained the source.  */
		register_struc.reg_no = ds_source_ptr -> cobol_type100.register;
		call cobol_register$release (addr (register_struc));
	     end;					/*  Source is in a register.  */

	else temp_source_ptr = ds_source_ptr;

/*  Allocate space in the stack into which the fixed binary will be converted to decimal.  */

	if temp_source_ptr -> data_name.item_length = 4
	then temp_length = 11;			/*  source is single-word fixed binary.  */
	else temp_length = 22;			/*  source is double-word fixed binary  */
	call cobol_alloc$stack (temp_length, 0, ret_offset);

/*  Make a data name token for the temporary  */
	temp_dec_token_ptr = null ();
	call cobol_make_type9$decimal_9bit (temp_dec_token_ptr, 1000 /*stack*/, ret_offset, temp_length, 0);

/*  Set up to build the BTD instruction.  */
	input_struc.type = 5;
	input_struc.operand_no = 2;
	input_struc.lock = 0;
	input_struc.operand.token_ptr (1) = temp_source_ptr;
	input_struc.operand.size_sw (1) = 0;
	input_struc.operand.token_ptr (2) = temp_dec_token_ptr;
	input_struc.operand.size_sw (2) = 0;
	call cobol_addr (input_ptr, inst_ptr, reloc_ptr);

/*  Insert the opcode and emit the EIS BTD instruction  */
	inst_struc_basic.fill1_op = BTD;
	call cobol_emit (inst_ptr, reloc_ptr, 3);

/*  Allocate work space the size of the target.  The decimal number will be converted into this work
	space, using a DTB instruction.  If the decimal number is too long, overflow will occur.  */

	call cobol_alloc$stack (fixed (ds_target_ptr -> data_name.item_length, 17), 0, ret_offset);
	temp_bin_token_ptr = null ();
	if ds_target_ptr -> data_name.item_length = 4
	then call cobol_make_type9$long_bin (temp_bin_token_ptr, 1000, ret_offset);
	else call cobol_make_type9$short_bin (temp_bin_token_ptr, 1000, ret_offset);

	input_struc.operand.token_ptr (1) = temp_dec_token_ptr;
	input_struc.operand.token_ptr (2) = temp_bin_token_ptr;
	call cobol_addr (input_ptr, inst_ptr, reloc_ptr);

/*  Insert the opcode and emit the EIS DTB instruction  */
	inst_struc_basic.fill1_op = DTB;
	call cobol_emit (inst_ptr, reloc_ptr, 3);

/*  Set the source pointer to point to the fixed binary temporary  */
	ds_source_ptr = temp_bin_token_ptr;
	ds_call_again = "1"b;
exit_difficult_store:
	return;

     end difficult_store;


/**************************************************/
get_length:
     proc (token_ptr, datum_length);

/*
This procedure determines the number of data bytes required
by the datum described by the token pointed at by token_ptr.
*/

/*  DECLARATION OF THE PARAMETERS  */

dcl	token_ptr		ptr;
dcl	datum_length	fixed bin;


start_get_length:
	if token_ptr -> data_name.type = rtc_register
	then do;					/*  Token describes a register  */

		if (token_ptr -> cobol_type100.register = "0001"b /*  A  */
		     | token_ptr -> cobol_type100.register = "0010"b /*  Q  */)
		then datum_length = 4;		/*  4 bytes = 36 bits = full word  */

		else if token_ptr -> cobol_type100.register = "0011"b
						/*  A and Q  */
		then datum_length = 8;

		else datum_length = 2;		/*  Must be an index register.  */
	     end;					/*  token describes a register.  */

	else datum_length = token_ptr -> data_name.item_length;
exit_get_length:
	return;

     end get_length;


immed_to_index:
     proc (source_tok_ptr, index_tok_ptr);

/*
This procedure generates code to load an immediate constant
into an index register.
*/

/*  DECLARATION OF THE PARAMETERS  */

dcl	source_tok_ptr	ptr;
dcl	index_tok_ptr	ptr;

/*  DECLARATION OF INTERNAL STATIC DATA  */

dcl	ldx_du_inst	bit (36) int static init ("000000000000000000010010000000000011"b);
						/*  LDXn 0,du  */

/**************************************************/
start_immed_to_index:				/*  Get an index register and lock it.  */
	register_struc.what_reg = 5;			/*  any index register  */
	register_struc.lock = 1;			/*  lock it  */
	register_struc.contains = 0;
	call cobol_register$load (addr (register_struc));

/*  Build LDXn const,du instruction  */
	substr (ldx_du_inst, 25, 3) = substr (register_struc.reg_no, 2, 3);
	substr (ldx_du_inst, 1, 18) = substr (unspec (source_tok_ptr -> immed_const.const_value), 19, 18);

	call cobol_emit (addr (ldx_du_inst), null (), 1);

/*  Make a register token tor the index that contains the constant.  */
	call cobol_make_reg_token (index_tok_ptr, register_struc.reg_no);

exit_immed_to_index:
	return;
     end immed_to_index;


immed_to_register:
     proc (source_tok_ptr, register_tok_ptr);

/*
This procedure generates code to load an immediate constant into the A or Q register.
*/

/*  DECLARATION OF THE PARAMETERS  */

dcl	source_tok_ptr	ptr;
dcl	register_tok_ptr	ptr;

/*  DECLARATION OF INTERNAL STATIC DATA  */

dcl	direct_lower_inst	bit (36) int static init ("000000000000000000000000000000000111"b);
						/*  zero,dl  */

start_immed_to_register:				/*  Get a register and lock it.  */
	register_struc.what_reg = 4;			/*  A or Q  */
	register_struc.lock = 1;
	register_struc.contains = 0;
	call cobol_register$load (addr (register_struc));

/*  Build LDA/Q const,dl instruction  */
	substr (direct_lower_inst, 1, 18) = substr (unspec (source_tok_ptr -> immed_const.const_value), 19, 18);

	if register_struc.reg_no = "0001"b
	then substr (direct_lower_inst, 19, 10) = LDA;
	else substr (direct_lower_inst, 19, 10) = LDQ;


	call cobol_emit (addr (direct_lower_inst), null (), 1);

/*  Make a register token for the register that contains the constant.  */
	call cobol_make_reg_token (register_tok_ptr, register_struc.reg_no);
exit_immed_to_register:
	return;

     end immed_to_register;


/*  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_type100;
%include cobol_addr_tokens;
%include cobol_type9;
%include cobol_record_types;
%include cobol_type102;

     end cobol_store_binary;




		    cobol_string.pl1                05/24/89  1042.8rew 05/24/89  0832.3      196443



/****^  ***********************************************************
        *                                                         *
        * 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_string.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 04/14/80 by FCH, [4.2-1], incorrect code if lit is sending field, BUG437(TR5906) */
/* Modified on 03/14/77 by Bob Chang to change the loading of registers after setting of pointer.	*/

/* format: style3 */
cobol_string:
     proc (sptr);

dcl	sptr		ptr;
dcl	1 s		based (sptr),
	  2 n		fixed bin,
	  2 tag		fixed bin,
	  2 rtp		ptr,			/* ptr to receiving item token */
	  2 ptp		ptr,			/* ptr to pointer item token (none if null) */
	  2 str		(0 refer (s.n)),
	    3 stp		ptr,			/* ptr to sending item token */
	    3 dtp		ptr;			/* ptr to delimiter item token (none if null) */

dcl	fixlen_mlr_instr	(3) bit (36) static init ("000000000001000000001000000101000000"b,
						/* mlr	(pr),(pr)		*/
			"000000000000000000000000000000000000"b,
						/* desc9a			*/
			"000000000000000000000000000000000000"b);
						/* desc9a			*/
dcl	move_instr	(3) bit (36) static init ("000000000001101001001000000101100000"b,
						/* mlr	(pr,rl),(pr,rl,x1)		*/
			"010000000000000000000000000000000101"b,
						/* desc9a	pr2|0	(sending item for A chars) */
			"001000000000000000000000000000000101"b);
						/* desc9a	pr1|0	(indexed by x1 for A chars) */
dcl	scan_instr	(3) bit (36) based (scan_instr_ptr);
dcl	scm_instr		(5) bit (36) static init ("000000000000000011001010100101100000"b,
						/* scm	(pr,rl),(du),mask(000)	*/
			"010000000000000000000000000000000101"b,
						/* desc9a	pr2|0	(len in A)	*/
			"000000000000000000000000000000000000"b,
						/* desc9a	literal	(len ignored)	*/
			"110000000000110111000000000001000000"b,
						/* arg	pr6|67	(tally)		*/
			"110000000000110111010011101001000000"b);
						/* lda	pr6|67	(tally)		*/
dcl	scd_instr		(6) bit (36) static init ("000000000000000011001010000101100000"b,
						/* scd	(pr,rl),(du),mask(000)	*/
			"010000000000000000000000000000000101"b,
						/* desc9a	pr2|0	(len in A)	*/
			"000000000000000000000000000000000000"b,
						/* desc9a	literal	(len ignored)	*/
			"110000000000110111000000000001000000"b,
						/* arg	pr6|67	(tally)		*/
			"000000000000000010110000110100000100"b,
						/* ttn	2,ic	(len already in A)	*/
			"110000000000110111010011101001000000"b);
						/* lda	pr6|67	(tally)		*/
dcl	bypass_ovfl_instr	(2) bit (36) static init ("110000000000110110010011100001000000"b,
						/* szn	pr6|66	(ovfl)		*/
			"000000000000000000110000000000000100"b);
						/* tze	[tag],ic	(bypass ovfl code)	*/
dcl	check_ovfl_instr	(5) bit (36) static init ("000000000000010010111011101000000000"b,
						/* als	22			*/
			"110000000000110001111101101001000000"b,
						/* sta	pr6|61	(atemp)		*/
			"110000000000110001000110001001000000"b,
						/* adx1	pr6|61	(atemp)		*/
			"110000000000110110010011100001000000"b,
						/* szn	pr6|66	(ovfl)		*/
			"000000000000000000110000001000000100"b);
						/* tnz	[endtag],ic		*/
dcl	adjust_length_instr (12) bit (36) static init ("110000000000110001111101101001000000"b,
						/* sta	pr6|61	(atemp)		*/
			"110000000000110100100101000001000000"b,
						/* stz	pr6|64	(x1temp)		*/
			"110000000000110100100100001001000000"b,
						/* sxl1	pr6|64	(x1temp)		*/
			"110000000000110100000111101001000000"b,
						/* ada	pr6|64	(x1temp)		*/
			"110000000000110101001001101001000000"b,
						/* cmpa	pr6|65	(rlen)		*/
			"000000000000000110110000100100000100"b,
						/* tmoz	6,ic	(not ovfl)	*/
			"110000000000110110000101100001000000"b,
						/* aos	pr6|66	(ovfl)		*/
			"110000000000110100011011101001000000"b,
						/* lca	pr6|64	(x1temp)		*/
			"110000000000110101000111101001000000"b,
						/* ada	pr6|65	(rlen)		*/
			"000000000000000000110000000000000100"b,
						/* tze	[endtag],ic  (none left)	*/
			"000000000000000010111001000000000100"b,
						/* tra	2,ic	(join)		*/
			"110000000000110001010011101001000000"b);
						/* lda	pr6|61	(atemp)		*/
dcl	scan_loop_instr	(16) bit (36) static init ("110000000000110011111010010001000000"b,
						/* lxl2	pr6|63	(dlen)		*/
			"110000000000110001100101000001000000"b,
						/* stz	pr6|61	(atemp)		*/
			"110000000000110001010011101001000000"b,
						/* lda	pr6|61	(atemp)		*/
			"110000000000110011000111101001000000"b,
						/* ada	pr6|63	(dlen)		*/
			"110000000000110010001001101001000000"b,
						/* cmpa	pr6|62	(slen)		*/
			"000000000000000011110000100100000100"b,
						/* tmoz	3,ic	(still more)	*/
			"110000000000110010010011101001000000"b,
						/* lda	pr6|62	(slen)		*/
			"000000000000001001111001000000000100"b,
						/* tra	11,ic	(no luck, exit)	*/
			"110000000000110001010011101001000000"b,
						/* lda	pr6|61	(atemp)		*/
			"000000000001100101001000110101100000"b,
						/* cmpc	(pr,rl),(pr,rl,al)		*/
			"000000000000000000000000000000001010"b,
						/* desc9a	delimiter (len in A)	*/
			"010000000000000000000000000000001010"b,
						/* desc9a	pr2|0 (len in A)		*/
			"000000000000000100110000000000000100"b,
						/* tze	4,ic	(found it)	*/
			"000000000000000001000111101000000111"b,
						/* ada	1,dl	(bump index)	*/
			"110000000000110001111101101001000000"b,
						/* sta	pr6|61	(atemp)		*/
			"111111111111110100111001000000000100"b);
						/* tra	-14,ic	(and again)	*/
dcl	adjust_and_test_x1_instr
			(8) bit (36) static init ("000000000000000001010011110000000111"b,
						/* ldq	1,du	(in case of ovfl)	*/
			"110000000000110110111101110001000000"b,
						/* stq	pr6|66	(ovfl)		*/
			"110000000000110000111010001001000000"b,
						/* lxl1	pr6|60	(ptr)		*/
			"000000000000000001001110001000000011"b,
						/* sbx1	1,du	(create offset)	*/
			"000000000000000000110000100000000100"b,
						/* tmi	[endtag],ic  ((out of range)	*/
			"110000000000110000001001101001000000"b,
						/* cmpa	pr6|60	(ptr)		*/
			"000000000000000000110000100000000100"b,
						/* tmi	[endtag],ic  (out of range)	*/
			"110000000000110110100101000001000000"b);
						/* stz	pr6|66	(ovfl)		*/
dcl	set_x1_instr	(2) bit (36) static init ("000000000000000000110010001000000000"b,
						/* eax1	0			*/
			"110000000000110110100101000001000000"b);
						/* stz	pr6|66	(ovfl)		*/
dcl	set_pointer_instr	(2) bit (36) static init ("000000000000000001000110001000000011"b,
						/* adx1	1,du			*/
			"110000000000110000100100001001000000"b);
						/* sxl1	pr6|60	(ptr)		*/
dcl	asa_instr		bit (36) static init ("110000000001010000000101101001000000"b) options (constant);
						/*-05/05/76-*/
dcl	tra_instr		bit (36) static init ("000000000000000000111001000000000100"b);

dcl	1 addr_struct	static,
	  2 type		fixed bin init (4),
	  2 operand_no	fixed bin init (2),
	  2 lock		fixed bin init (0),
	  2 op1,
	    3 tptr	ptr,
	    3 sr		fixed bin init (0),
	    3 ic_mod	fixed bin,
	    3 size_sw	fixed bin init (1),
	  2 op2,
	    3 tptr	ptr,
	    3 sr		fixed bin init (0),
	    3 ic_mod	fixed bin,
	    3 size_sw	fixed bin init (1);
dcl	1 pr_struct	static,
	  2 pr		fixed bin,
	  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,
	  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	ptr_off		fixed bin static init (48);
dcl	ptr_offx4		fixed bin static init (192);
dcl	atemp_off		fixed bin static init (49);
dcl	slen_off		fixed bin static init (50);
dcl	dlen_off		fixed bin static init (51);
dcl	x1temp_off	fixed bin static init (52);
dcl	rlen_off		fixed bin static init (53);
dcl	ovfl_off		fixed bin static init (54);
dcl	ovfl_offx4	fixed bin static init (216);

dcl	1 type3,
	  2 alignment	ptr,			/* so as to double word align the space */
	  2 rest		char (26);
dcl	1 stype9,
	  2 alignment	ptr,
	  2 rest		char (140);
dcl	1 rtype9,
	  2 alignment	ptr,
	  2 rest		char (140);
dcl	1 dtype9,
	  2 alignment	ptr,
	  2 rest		char (140);
dcl	type9_chars	char (148) aligned based (type9_ptr);

dcl	fixlen		(0:255) fixed bin auto;

dcl	endtag		fixed bin;
dcl	(i, j, next)	fixed bin;
dcl	ic		fixed bin;
dcl	temp		fixed bin;
dcl	(from_len, to_len)	fixed bin;
dcl	(varlen, litlen)	fixed bin;
dcl	total_fixlen	fixed bin;
dcl	rlen		fixed bin (20);
dcl	ovfl_no		fixed bin;
dcl	varlen_no		fixed bin;

dcl	fill_char		char (1);
dcl	temp_lit		char (256);

dcl	pr2set		bit (1);
dcl	lit		bit (18);
dcl	nolimit		bit (1);
dcl	two_in_one	bit (1);
dcl	move_completed	bit (1);

dcl	scan_instr_ptr	ptr;
dcl	stptr		ptr;
dcl	dtptr		ptr;
dcl	dn_ptr		ptr;
dcl	pr_struct_ptr	ptr;
dcl	type9_ptr		ptr;

dcl	cobol_addr	entry (ptr, ptr, ptr);
dcl	cobol_emit	entry (ptr, ptr, fixed bin);
dcl	cobol_get_size	entry (ptr, fixed bin, fixed bin);
dcl	cobol_set_pr	entry (ptr, ptr);
dcl	cobol_make_type9$type2_3
			entry (ptr, ptr);
dcl	cobol_make_type3$type1
			entry (ptr, ptr);
dcl	cobol_io_util$move_lit
			entry (bit (3) aligned, fixed bin, fixed bin, char (*));
dcl	cobol_io_util$move	entry (bit (3) aligned, fixed bin, fixed bin, bit (3) aligned, fixed bin, fixed bin);
dcl	cobol_io_util$t9dec_to_bin
			entry (bit (3) aligned, fixed bin, ptr);
dcl	cobol_io_util$bin_to_t9dec
			entry (bit (3) aligned, fixed bin, ptr);
dcl	cobol_reset_r$in_line
			entry;
dcl	cobol_pointer_register$priority
			entry (fixed bin, fixed bin, bit (3) aligned);
dcl	cobol_register$load entry (ptr);

dcl	cobol_make_tagref	entry (fixed bin, fixed bin, ptr);
dcl	cobol_define_tag_nc entry (fixed bin, fixed bin);


/*************************************/
start:
	endtag = cobol_$next_tag;
	cobol_$next_tag = cobol_$next_tag + 1;
	total_fixlen = 0;

	if s.rtp -> data_name.item_length = 0
	then do;					/* special case - string into unlimited stack area */
		nolimit = "1"b;
		rlen = 1048575;			/* segment size is only limiting factor */
	     end;
	else do;
		nolimit = "0"b;
		if s.rtp -> data_name.variable_length
		then rlen = 0;
		else rlen = s.rtp -> data_name.item_length;
	     end;

/* varlen_no = 1st sending field whose length can't be
						   predetermined; 0 indicates all fixed */

	if s.ptp = null () & rlen ^= 0
	then do;					/* try optimizing */

		ovfl_no, varlen_no = 0;

		do i = 1 to s.n while (varlen_no = 0 & ovfl_no = 0);

		     if s.dtp (i) ^= null ()		/*[4.2-1]*/
		     then do;
			     varlen_no = i;		/*[4.2-1]*/
			     fixlen (i) = 0;	/*[4.2-1]*/
			end;
		     else do;
			     dn_ptr = s.stp (i);

			     if data_name.type = 9
			     then do;

				     if data_name.variable_length
				     then varlen_no = i;
				     else fixlen (i) = data_name.item_length;
				end;
			     else if data_name.type = 3
			     then fixlen (i) = dn_ptr -> alphanum_lit.lit_size;
			     else if data_name.type = 2
			     then fixlen (i) = dn_ptr -> numeric_lit.places;
			     else fixlen (i) = 1;	/* fig-con */
			end;

		     if varlen_no = 0
		     then do;

			     if rlen < total_fixlen + fixlen (i)
			     then do;		/* overflow */

				     fixlen (i) = rlen - total_fixlen;
				     ovfl_no = i;
				end;
			     else do;
				     total_fixlen = total_fixlen + fixlen (i);
				     if rlen = total_fixlen
				     then if s.n > i
					then ovfl_no = i;
				end;
			end;
		end;

		if varlen_no ^= 1
		then do;				/* at least one fixed length */

			type9_ptr = addr (rtype9);
			type9_chars = s.rtp -> type9_chars;
			addr_struct.op2.tptr = type9_ptr;
			fixlen (0) = 0;

		     end;
	     end;
	else varlen_no = 1;				/* can't optimize */

	if varlen_no ^= 0
	then do;					/* at least one non-fixed length */

/* SET PR1 TO PT TO RECEIVING ITEM */
		pr_struct_ptr = addr (pr_struct);
		pr_struct.pr = 1;

		call cobol_set_pr (pr_struct_ptr, s.rtp);

		do reg_struct.what_reg = 1, 11, 12;	/* lock A, X1, and X2 */

		     call cobol_register$load (addr (reg_struct));

		end;

/* ESTABLISH SIZE OF RECEIVING ITEM */

		if ^nolimit
		then call cobol_get_size (s.rtp, rlen_off, 0);
						/* INITIALIZE X1 (indexes receiving item) */

		if s.ptp = null ()
		then do;

			if nolimit
			then ic = 1;		/* no ovfl checking will be done */
			else ic = 2;

			substr (set_x1_instr (1), 1, 18) = substr (unspec (total_fixlen), 19, 18);

			call cobol_emit (addr (set_x1_instr), null (), ic);

		     end;
		else do;

			call cobol_io_util$t9dec_to_bin ("110"b, ptr_offx4, ptp);
			call cobol_emit (addr (adjust_and_test_x1_instr), null (), 8);
			call cobol_make_tagref (endtag, cobol_$text_wd_off - 4, null ());
			call cobol_make_tagref (endtag, cobol_$text_wd_off - 2, null ());

		     end;
	     end;

	do i = 1 to s.n;				/* DETERMINE NUMBER OF CHARS TO BE MOVED AND STORE IN A */
	     dn_ptr = s.stp (i);

	     if data_name.type = 9
	     then stptr = dn_ptr;
	     else do;

		     if data_name.type = 1
		     then do;

			     dn_ptr = addr (type3);

			     call cobol_make_type3$type1 (dn_ptr, s.stp (i));

			end;

		     stptr = addr (stype9);

		     call cobol_make_type9$type2_3 (stptr, dn_ptr);

		end;

	     pr2set = "0"b;

	     if varlen_no = 0 | i < varlen_no
	     then do;				/* fixed length move */

		     type9_ptr -> data_name.offset = type9_ptr -> data_name.offset + fixlen (i - 1);
		     addr_struct.op1.tptr = stptr;
		     from_len, to_len = fixlen (i);
		     fixlen_mlr_instr (2) = unspec (from_len);
		     fill_char = "";
		     two_in_one = "0"b;

		     if i < s.n & i ^= ovfl_no
		     then do;			/* try optimizing with fill char */

			     next = i + 1;
			     dn_ptr = s.stp (next);

/*[4.2-1]*/
			     if fixlen (next) ^= 0 & data_name.type < 4
			     then do;		/* not a variable */


				     if data_name.type = 1
				     then do;

					     dn_ptr = addr (type3);

					     call cobol_make_type3$type1 (dn_ptr, s.stp (next));

					end;

				     litlen = fixlen (next);

				     if data_name.type = 3
				     then substr (temp_lit, 1, litlen) =
					     substr (dn_ptr -> alphanum_lit.string, 1, litlen);
				     else substr (temp_lit, 1, litlen) =
					     substr (dn_ptr -> numeric_lit.literal, 1, litlen);

				     fill_char = substr (temp_lit, 1, 1);
				     to_len = from_len + litlen;
				     two_in_one = "1"b;

				     do j = 2 to litlen while (two_in_one);

					if substr (temp_lit, j, 1) ^= fill_char
					then do;

						to_len = from_len;
						fill_char = "";
						two_in_one = "0"b;
					     end;
				     end;

				     if two_in_one
				     then do;	/* skip next move */
					     fixlen (next) = fixlen (i) + fixlen (next);
					     i = next;
					end;
				end;
			end;

		     fixlen_mlr_instr (3) = unspec (to_len);

		     call cobol_addr (addr (addr_struct), addr (fixlen_mlr_instr), null ());

		     move_completed = "0"b;

		     if ^two_in_one
		     then do;			/* try to optimize */

			     if substr (fixlen_mlr_instr (1), 12, 7) = "1000000"b
			     then do;

				     if s.stp (i) -> data_name.type = 3
				     then do;

					     call cobol_io_util$move_lit (substr (fixlen_mlr_instr (3), 1, 3),
						fixed (substr (fixlen_mlr_instr (3), 4, 17)),
						fixed (substr (fixlen_mlr_instr (3), 25, 12)),
						substr (s.stp (i) -> alphanum_lit.string, 1,
						s.stp (i) -> alphanum_lit.lit_size));

					     move_completed = "1"b;
					end;

				     else if substr (fixlen_mlr_instr (1), 30, 7) = "1000000"b
				     then do;

					     call cobol_io_util$move (substr (fixlen_mlr_instr (3), 1, 3),
						fixed (substr (fixlen_mlr_instr (3), 4, 17)),
						fixed (substr (fixlen_mlr_instr (3), 25, 12)),
						substr (fixlen_mlr_instr (2), 1, 3),
						fixed (substr (fixlen_mlr_instr (2), 4, 17)),
						fixed (substr (fixlen_mlr_instr (2), 25, 12)));

					     move_completed = "1"b;
					end;
				end;
			end;			/* try to optimize */

		     if ^move_completed
		     then do;

			     substr (fixlen_mlr_instr (1), 1, 9) = unspec (fill_char);

			     call cobol_emit (addr (fixlen_mlr_instr), null (), 3);

			end;

		     if i = ovfl_no
		     then return;			/* just like that */
		end;

	     else do;				/* variable length move */

		     if s.dtp (i) = null ()
		     then do;			/* no delimiter */

			     call cobol_get_size (stptr, 0, 0);

			     if nolimit
			     then if stptr -> data_name.type = 9
				then if stptr -> data_name.variable_length
				     then call cobol_emit (addr (asa_instr), null (), 1);

			end;
		     else do;

			     call cobol_get_size (stptr, slen_off, 0);

			     dn_ptr = s.dtp (i);
			     litlen, varlen = 0;

			     if data_name.type < 4
			     then do;

				     if data_name.type = 1
				     then do;

					     dn_ptr = addr (type3);

					     call cobol_make_type3$type1 (dn_ptr, s.dtp (i));

					end;

				     if data_name.type = 2
				     then do;

					     if dn_ptr -> numeric_lit.places < 3
					     then do;

						     lit = substr (unspec (dn_ptr -> numeric_lit.literal), 1,
							18);
						     litlen = dn_ptr -> numeric_lit.places;
						end;
					end;

				     else if data_name.type = 3
				     then do;


					     if dn_ptr -> alphanum_lit.lit_size < 3
					     then do;

						     lit = substr (unspec (dn_ptr -> alphanum_lit.string), 1,
							18);
						     litlen = dn_ptr -> alphanum_lit.lit_size;

						end;
					end;

				     if litlen = 0
				     then do;

					     dtptr = addr (dtype9);

					     call cobol_make_type9$type2_3 (dtptr, dn_ptr);

					end;
				end;
			     else do;		/* type9 token */

				     if ^data_name.variable_length & data_name.item_length < 3
				     then varlen = data_name.item_length;
				     dtptr = dn_ptr;

				end;

			     call cobol_pointer_register$priority (2, 0, "010"b);
						/* unlock pr2 */

			     pr_struct.pr = 2;

			     call cobol_set_pr (pr_struct_ptr, stptr);

			     pr2set = "1"b;

			     if litlen > 0 | varlen > 0
			     then do;

				     if litlen = 2 | varlen = 2
				     then do;	/* SCD */
					     scan_instr_ptr = addr (scd_instr);
					     ic = 6;
					end;
				     else do;	/* SCM */
					     scan_instr_ptr = addr (scm_instr);
					     ic = 5;
					end;

				     if varlen > 0
				     then do;	/* scan to variable */

					     addr_struct.op1.tptr = null ();
					     addr_struct.op2.tptr = dtptr;

					     call cobol_addr (addr (addr_struct), scan_instr_ptr, null ());

					end;
				     else do;	/* scan to literal */
					     substr (scan_instr (1), 12, 7) = "0000011"b;
						/* du */
					     scan_instr (3) = lit;
					end;

				     call cobol_emit (scan_instr_ptr, null (), ic);

				end;
			     else do;

				     call cobol_get_size (dtptr, dlen_off, 0);

				     addr_struct.op1.tptr = dtptr;
				     addr_struct.op1.ic_mod = 0;
				     addr_struct.op2.tptr = null ();

				     call cobol_addr (addr (addr_struct), addr (scan_loop_instr (10)), null ());

				     if addr_struct.op1.ic_mod = 1
				     then do;

					     temp = fixed (substr (scan_loop_instr (11), 1, 18), 18) - 9;
					     substr (scan_loop_instr (11), 1, 18) =
						substr (unspec (temp), 19, 18);
					end;

				     call cobol_emit (addr (scan_loop_instr), null (), 16);

				end;
			end;

/* ADJUST LENGTH IF NECESSARY AND RECORD OVERFLOW */

		     if ^nolimit
		     then do;

			     call cobol_emit (addr (adjust_length_instr), null (), 12);
			     call cobol_make_tagref (endtag, cobol_$text_wd_off - 3, null ());

			end;

/* MOVE STRING AND CHECK OVERFLOW */

		     if ^pr2set
		     then do;

			     addr_struct.op1.tptr = stptr;
			     addr_struct.op2.tptr = null ();

			     call cobol_addr (addr (addr_struct), addr (move_instr), null ());

			end;
		     else do;
			     substr (move_instr (1), 30, 7) = "1100000"b;
			     move_instr (2) = "010000000000000000000000000000000101"b;
			end;

		     call cobol_emit (addr (move_instr), null (), 3);

		     if i = s.n
		     then do;

			     if s.ptp ^= null ()
			     then call cobol_emit (addr (check_ovfl_instr), null (), 3);

			end;

		     else if nolimit
		     then call cobol_emit (addr (check_ovfl_instr), null (), 3);

		     else do;

			     call cobol_emit (addr (check_ovfl_instr), null (), 5);
			     call cobol_make_tagref (endtag, cobol_$text_wd_off - 1, null ());

			end;
		end;

	end;


	if ^nolimit
	then do;

		call cobol_define_tag_nc (endtag, cobol_$text_wd_off);


		if s.ptp ^= null ()
		then do;				/* must set pointer */

			call cobol_emit (addr (set_pointer_instr), null (), 2);
			call cobol_io_util$bin_to_t9dec ("110"b, ptr_offx4, s.ptp);

		     end;

		if s.tag > 0
		then do;

			if varlen_no = 0
			then call cobol_emit (addr (tra_instr), null (), 1);
						/* overflow impossible */

			else call cobol_emit (addr (bypass_ovfl_instr), null (), 2);

			call cobol_make_tagref (s.tag, cobol_$text_wd_off - 1, null ());

		     end;
	     end;

	call cobol_reset_r$in_line;

exit:
	return;


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

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

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

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

%include cobol_type1;
%include cobol_type2;
%include cobol_type3;
%include cobol_type9;
%include cobol_;
     end cobol_string;




		    cobol_string_gen.pl1            05/24/89  1042.8rew 05/24/89  0832.2       28134



/****^  ***********************************************************
        *                                                         *
        * 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_string_gen.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* format: style3 */
cobol_string_gen:
     proc (mp_ptr, passed_tag);

dcl	mp_ptr		ptr;
dcl	passed_tag	fixed bin;

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

dcl	1 s		auto,
	  2 n		fixed bin,
	  2 tag		fixed bin,
	  2 rtp		ptr,
	  2 ptp		ptr,
	  2 str		(256),
	    3 stp		ptr,
	    3 dtp		ptr;


dcl	(i, j, k, startj)	fixed bin;
dcl	into_key		fixed bin static init (116);
dcl	size_key		fixed bin static init (161);
dcl	delimited_key	fixed bin static init (90);

dcl	dn_ptr		ptr;
dcl	tptr		ptr;

dcl	cobol_string	entry (ptr);


/*************************************/
start:
	eos_ptr = mp.pt (mp.n);
	if end_stmt.b
	then do;
		passed_tag = cobol_$next_tag;
		cobol_$next_tag = cobol_$next_tag + 1;
		s.tag = passed_tag;
	     end;
	else s.tag = 0;

	j = 0;
	startj = 1;
	do i = 2 to mp.n - 1;
	     dn_ptr = mp.pt (i);
	     if data_name.type = 1
	     then do;
		     if dn_ptr -> reserved_word.key = into_key
		     then do;			/* INTO */
			     i = i + 1;
			     s.rtp = mp.pt (i);
			     if end_stmt.c
			     then do;
				     i = i + 1;
				     s.ptp = mp.pt (i);
				end;
			     else s.ptp = null ();
			end;
		     else if dn_ptr -> reserved_word.key = delimited_key
		     then do;
			     i = i + 1;
			     dn_ptr = mp.pt (i);
			     tptr = dn_ptr;
			     if data_name.type = 1
			     then if dn_ptr -> reserved_word.key = size_key
				then tptr = null ();
			     do k = startj to j;
				s.str.dtp (k) = tptr;
			     end;
			     startj = j + 1;
			end;
		     else do;			/* fig con */
			     j = j + 1;
			     s.stp (j) = mp.pt (i);
			end;
		end;
	     else do;				/* non-type1 */
		     j = j + 1;
		     s.stp (j) = mp.pt (i);
		end;
	end;
	s.n = j;					/*	s.str.dtp(s.n)=null();*/
	call cobol_string (addr (s));
	return;


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

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

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

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

%include cobol_type1;
%include cobol_type9;
%include cobol_type19;
%include cobol_;
     end cobol_string_gen;




		    cobol_subtract_gen.pl1          05/24/89  1042.8rew 05/24/89  0832.2       16299



/****^  ***********************************************************
        *                                                         *
        * 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_subtract_gen.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* format: style3 */
cobol_subtract_gen:
     proc (in_token_ptr, next_stmt_tag);

/*  This procedure acts as an interface between the Multics
COBOL compiler generator driver, cobol_gen_driver_, and the
procedure that actually generates code to do the work
to accomplish a COBOL SUBTRACT.  This procedure actually
is not required.  The cobol generator driver could be
modified to call cobol_add_gen directyl for SUBTRACT statements.
*/


dcl	in_token_ptr	ptr;
dcl	next_stmt_tag	fixed bin;

dcl	cobol_add_gen	ext entry (ptr, fixed bin);

	call cobol_add_gen (in_token_ptr, next_stmt_tag);


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

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

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

     end cobol_subtract_gen;




		    cobol_sym_init.pl1              05/24/89  1042.8rew 05/24/89  0832.2       73260



/****^  ***********************************************************
        *                                                         *
        * 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_sym_init.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 10/13/81 by FCH, [5.0-1], 32 char used-id caused seg-fault, BUG514(phx11725) */
/* Modified on 05/29/81 by FCH, [4.4-1], dtm incorrectly stored in obj module, phx09946(BUG485) */
/* Modified on 10/25/78 by FCH, [3.0-4], c_name decl changed */
/* Modified on 06/22/78 by RAL, [3.0-3], rewrote symbol_section to handle source and include files */
/* Modified on 04/27/78 by FCH, [3.0-2], symbol_section(source module path name) */
/* Modified on 04/27/78 by FCH, [3.0-1], compiler options to symbol sect */
/* Modified since Version 3.0 */

/* format: style3 */
cobol_sym_init:
     proc (tpath);					/* [3.0-2] */

/*	This procedure builds the SYMBOL SECTION
		(header, source_map, variable_area, symbol_relocation_block)
	The external procedure RELP1 is used to calculate the relative pointers
	used within all structures.
*/

	sym_ptr = cobol_$sym_base_ptr;

/* =====HEADER================ */

	relp = "000000000000010100"b;			/* set start of header variable area +20(decimal) words */

	symbol_block_header.decl_vers = 1;
	symbol_block_header.identifier = "symbtree";
	symbol_block_header.gen_version_number = 1;

	time = clock_ ();
	call date_time_ (time, string);

	symbol_block_header.gen_creation_time = time;	/* TBD */
	symbol_block_header.object_creation_time = time;
	symbol_block_header.generator = "cobol   ";

/* Build and Set gen_version_name */

	pp = addrel (sym_ptr, relp);
	symbol_block_header.gen_version_name_relp = relp; /* always begins at 20th word in symbol section. */
	substr (is, 1, 48) = "Multics COBOL, Version " || fixed_common.compiler_rev_no;
	symbol_block_header.gen_version_name_length = "000000000000110000"b;
						/* 48(decimal) */

/* Build and Set userid */

	char_string = get_group_id_ ();
	l = symbol_block_header.gen_version_name_length;
	symbol_block_header.userid_relp = RELP1 (relp, l);
	n = index (char_string, " ") - 1;

/*[5.0-1]*/
	if n < 1
	then n = 32;

	symbol_block_header.userid_length = substr (unspec (n), 19, 18);
	pp = addrel (sym_ptr, userid_relp);
	substr (is, 1, n) = char_string;

/* no comments */

	l = symbol_block_header.userid_length;
	relp = symbol_block_header.userid_relp;		/* [3.0-1] */
	symbol_block_header.comment_relp = RELP1 (relp, l);
						/* [3.0-1] */
	symbol_block_header.comment_length = substr (unspec (cobol_options_len), 19, 18);
						/* [3.0-1] */
	pp = addrel (sym_ptr, symbol_block_header.comment_relp);
						/* [3.0-1] */
	substr (is, 1, cobol_options_len) = cobol_options;/* [3.0-1] */

	symbol_block_header.text_boundary = "000000000000000010"b;
						/* 2 */
	symbol_block_header.stat_boundary = "000000000000000010"b;
						/* 2 */

/* the following items are set further into the compilation */

	symbol_block_header.section_relp = "0"b;
	symbol_block_header.block_size = "0"b;
	symbol_block_header.next_block_thread = "0"b;
	symbol_block_header.text_relocation_relp = "0"b;
	symbol_block_header.def_relocation_relp = "0"b;
	symbol_block_header.link_relocation_relp = "0"b;

/* Build and Set source map */

	RR = fixed (symbol_block_header.gen_version_name_length, 18) + fixed (symbol_block_header.userid_length, 18)
	     + fixed (symbol_block_header.comment_length, 18);
	l = substr (unspec (RR), 19, 18);

	symbol_block_header.source_map_relp = RELP1 (relp, l);

	if substr (userid_length, 17, 2) ^= "00"b
	then do;
		RR = fixed (symbol_block_header.source_map_relp, 18) + 1;
		symbol_block_header.source_map_relp = substr (unspec (RR), 19, 18);
		RR = fixed (l, 18) + 4;
		l = substr (unspec (RR), 19, 18);
	     end;

/* =====SOURCE_MAP============ */


/* [3.0-3] */
	p1 = addrel (sym_ptr, source_map_relp);
	source_map.decl_vers = 1;
	call cobol$pop_name (c_name_ptr);
	source_map.size = c_name.ct;
	RR = fixed (l, 18) + 8 + (16 * source_map.size);
	l = substr (unspec (RR), 19, 18);
	do i = source_map.size to 1 by -1;
	     RR = c_name.size + 1;
	     source_map.map.pathname_length (i) = substr (unspec (RR), 19, 18);
	     source_map.map.pathname_relp (i) = RELP1 (relp, l);
	     RR = fixed (l, 18);
	     RR = RR + fixed (pathname_length (i), 18);
	     l = substr (unspec (RR), 19, 18);
	     source_map.map.uid (i) = c_name.uid;	/*[4.4-1]*/
	     source_map.map.dtm (i) = 10000000000000000b * binary (c_name.dtm, 36);
	     pp = addrel (sym_ptr, source_map.pathname_relp (i));
	     substr (is, 1, fixed (source_map.pathname_length (i), 18)) = substr (c_name.pname, 1, c_name.size);
	     seg_name_length = c_name.size + 1;
	     call cobol$pop_name (c_name_ptr);
	end;					/* [3.0-3] */


/* =====VARIABLE_AREA========= */

	RR = fixed (l, 18) + fixed (pathname_length (source_map.size), 18);
	l = substr (unspec (RR), 19, 18);
	area_relp = RELP1 (relp, l);
	p2 = addrel (sym_ptr, area_relp);

	variable_area.decl_vers = 1;
	variable_area.identifier = "pl1info ";
	variable_area.flags = 0;
	variable_area.greatest_severity = 0;
	variable_area.root = "0"b;
	variable_area.profile = "0"b;
	variable_area.map_first = "0"b;
	variable_area.map_last = "0"b;
	RR = fixed (area_relp, 18) + 8;
	variable_area.segname_relp = substr (unspec (RR), 19, 18);
	variable_area.segname_length = substr (unspec (seg_name_length), 19, 18);

	RR = fixed (l, 18) + 32;
	l = substr (unspec (RR), 19, 18);
	pp = addrel (sym_ptr, RELP1 (relp, l));
	substr (is, 1, seg_name_length) = cobol_$obj_seg_name;

/* =====clean up================== */

	RR = fixed (l, 18) + seg_name_length;
	l = substr (unspec (RR), 19, 18);
	default_truncate = RELP1 (relp, l);
	optional_truncate = default_truncate;

	sym_wd_off = fixed (default_truncate, 18);

	call cobol_reloc (null (), 2 * sym_wd_off, 3004);

	return;


RELP1:
     proc (RC, RL) returns (bit (18));
declare	(RC, RL)		bit (18),
	(rc, rl)		fixed bin;

	rl = fixed (RL, 18);
	rc = fixed (RC, 18);

	RR = rl + mod (-rl, 4);
	RL = substr (unspec (RR), 19, 18);
	RR = divide (RR, 4, 31, 0) + rc;

	return (substr (unspec (RR), 19, 18));

     end RELP1;

/* [3.0-3] */
dcl	i		fixed bin;		/* [3.0-3] */
dcl	1 c_name		based (c_name_ptr),		/*[3.0-4]*/
	  2 ct		fixed bin,		/*[3.0-4]*/
	  2 size		fixed bin,		/*[3.0-4]*/
	  2 last_name_ptr	ptr,			/* [3.0-3] */
	  2 pname		char (168) aligned,		/* [3.0-3] */
	  2 uid		bit (36),			/* [3.0-3] */
	  2 dtm		bit (36);			/* [3.0-3] */
dcl	c_name_ptr	ptr;			/* [3.0-3] */
dcl	cobol$pop_name	entry (ptr);


declare	tpath		char (168) aligned;		/* [3.0-2] */

dcl	date_time_	entry (fixed bin (71), char (*)) ext,
	cobol_reloc	entry (ptr, fixed bin, fixed bin) ext,
	get_group_id_	entry returns (char (32)) ext,
	clock_		entry returns (fixed bin (71)) ext,
	get_wdir_		entry returns (char (168)) ext,
	(relp, l)		bit (18),
	(n, seg_name_length)
			fixed bin,
	RR		fixed bin,
	time		fixed bin (71) aligned,
	dirname		char (168) aligned,
	string		char (24),
	char_string	char (32),
	temp_string	char (26000) aligned,
	(p1, p2, pp)	ptr,
	is		char (262000) aligned based (pp);

dcl	addrel		builtin;
dcl	unspec		builtin;
dcl	fixed		builtin;
dcl	index		builtin;
dcl	null		builtin;
dcl	substr		builtin;

%include cobol_sbh;
%include cobol_fixed_common;
%include cobol_ext_;
%include cobol_source_map;
%include cobol_variable_area;
%include cobol_relinfo;
%include cobol_;

     end;




		    cobol_trans_alphabet.pl1        05/24/89  1042.8rew 05/24/89  0832.2       97866



/****^  ***********************************************************
        *                                                         *
        * 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_trans_alphabet.pl1 Added Trace statements.
                                                   END HISTORY COMMENTS */


/* Modified on 10/19/84 by FCH, [5.3-1], BUG563(phx18381), new cobol_addr_toke.nincl.pl1 */
/* Modified on 10/9/76 by George Mercuri to fix the bug for code_set. */
/* Modified on 9/01/76 by Bob Chang to fix the bug for code_set. */
/* Modified on 7/30/76 by Bob Chang to fix the bug for high vaule. */
/* Modified on 7/26/76 by Bob Chang to fix the bug for table of alphabet_name . */
/* Created on 6/21/76 by Bob Chang to implement  the alphabet_name. */
/* format: style3 */
cobol_trans_alphabet:
     proc (lop_ptr, rop_ptr, code_set, from_flag, sort_pcs_ptr, cmpc_filler);

/*
This procedure generates code that translates the ascii alphanumeric
operands of an alphanumeric comparison to alphabet alphanumeric
operands.
*/

/*

Assertions at entry:

	1. lop_ptr points to the left alphanumeric (ascii)
	data name (type 9) token.
	2. rop_ptr points to the right alphanumeric (ascii)
	data name (type 9) token.
	3. cmpc_filler contains the ascii fill character to
	be inserted into the cmpc instruction.

Assertions at exit:

	1. lop_ptr points to the left alphanumeric (alphabet)
	data name (type 9) token.
	2. rop_ptr points to the right alphanumeric (alphabet)
	data name (type 9) token.
	3 cmpc_filler contains the alphabet fill character to be
	inserted into the cmpc instruction.

*/

	io_flag = 0;
	goto start;

io:
     entry (lop_ptr, rop_ptr, code_set, from_flag);

	io_flag = 1;

/* The entry for io has the lop_ptr as the input operand and rop_ptr as the output
operand of the type9 token on the stack frame.
*/
/*  DECLARATIONS OF THE PARAMETERS  */

dcl	lop_ptr		ptr;
dcl	rop_ptr		ptr;
dcl	sort_pcs_ptr	ptr;


dcl	cmpc_filler	char (1);			/*}*/

/*  Declarations of internal variables  */

dcl	alphabet_lop_ptr	ptr;
dcl	alphabet_rop_ptr	ptr;

dcl	t_offset		fixed bin;
dcl	continue		bit (1);
dcl	cond		bit (1);
dcl	io_flag		fixed bin;
dcl	code_set		fixed bin;
dcl	from_flag		fixed bin;
dcl	source_ptr	ptr;
dcl	dest_ptr		ptr;
dcl	work_binary	fixed bin (35);
dcl	descrip_ptr	ptr;
dcl	descrip		bit (72) based (descrip_ptr);
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 (512),
	    3 fb2		(2) fixed bin init (0, 0),
	    3 flags1	bit (36) init ("010000100100000000010000000100000000"b),
	    3 flags2	bit (36) init (""b),
	    3 seg		fixed bin init (0),
	    3 off		fixed bin,
	  2 fill2		(7) fixed bin init (0, 0, 0, 0, 0, 0, 0);
dcl	1 eis_inst	aligned based (eis_ptr),
	  2 unused	bit (18) unaligned,
	  2 opcode	bit (10) unaligned;
dcl	1 work_inst	based (inst_ptr),
	  2 left_half	bit (18),
	  2 right_half	bit (18);


/*  DECLARATIONS OF VARIABLES USED TO TRANSLATE ASCII TO EBCDIC  */

dcl	alphabet_allocated	fixed bin int static init (0);

dcl	mvt_op		bit (10) int static init ("0011100001"b /* 160(1) */);
dcl	mvt_table		char (512) based (mvt_table_ptr),
	mvt_table_ptr	ptr;
dcl	dn_ptr		ptr;
dcl	eis_ptr		ptr;
dcl	alphabet_mvt_type9	(1:40) fixed bin int static;	/*  Buffer in which the data name operand (type 9)
	that describes the alphabet mvt table is built.  */

dcl	alphabet_mvt_type9_ptr
			ptr int static;		/*  Pointer to the alphabet_mvt_type9 operand  */

dcl	alphabet_lop	(1:40) fixed bin int static;	/*  Buffer in which the data name operand (type 9)
	for the alphabet left operand is built.  */

dcl	alphabet_rop	(1:40) fixed bin int static;	/*  Buffer in which the data name operrand (type 9)
	for the alphabet right operand is built  */

/*  Definition of eis fill character  */

dcl	1 eis_fill_def	int static,
	  2 space		char (1) init (" "),
	  2 zero		char (1) init ("0"),
	  2 quote		char (1) init (""""),
	  2 high_value	char (1) init (""),	/*  INIT TO OCTAL 177.  */
	  2 low_value	char (1) init ("");	/*  INIT TO OCTAL 000.  */



/* Declaration for the procedures  to be called. */

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

/*  WORK BUFFER IN WHICH INPUT TO THE ADDRESSABILITY UTILITY IS BUILT  */

dcl	wkbuff1		(1:20) fixed bin;

/*  WORK BUFFER IN WHICH THE OUTPUT FROM THE ADDRESSABILITY UTILITY IS RETURNED  */

dcl	wkbuff2		(1:5) fixed bin;

/*  WORK BUFFER IN WHICH RELOCATION INFORMATION IS PLACED BY THE ADDRESSABILITY UTILITY  */

dcl	wkbuff3		(1:10) fixed bin;

/**************************************************/
/*	START OF EXECUTION			*/
/* 	cobol_trans_alphabet		*/
/**************************************************/

start:
	input_ptr = addr (wkbuff1 (1));
	inst_ptr = addr (wkbuff2 (1));
	reloc_ptr = addr (wkbuff3 (1));

	cond = "0"b;
	continue = "1"b;
	dn_ptr = addr (alpha_type9);
	if io_flag > 0
	then do;
		data_name.seg_num = 3;
		if from_flag = 1
		then data_name.offset = alphabet_from_offset (code_set) * 4;
		else data_name.offset = alphabet_to_offset (code_set) * 4;
		source_ptr = lop_ptr;		/* TEMPORARY */
		dest_ptr = rop_ptr;			/* TEMPORARY */
	     end;
	else do;
		if sort_pcs_ptr = null ()
		then alpha_name_ptr = cobol_$main_pcs_ptr;
		else alpha_name_ptr = sort_pcs_ptr;
		data_name.seg_num = alphabet_name.segno;
		data_name.offset = alphabet_name.offset;

/*  Make copies of the input data name tokens  */

		alphabet_lop_ptr = addr (alphabet_lop (1));
		alphabet_rop_ptr = addr (alphabet_rop (1));

		call cobol_make_type9$copy (alphabet_lop_ptr, lop_ptr);
		call cobol_make_type9$copy (alphabet_rop_ptr, rop_ptr);


		alphabet_lop_ptr -> data_name.subscripted = "0"b;
		alphabet_rop_ptr -> data_name.subscripted = "0"b;

/*  Allocate on the run-time stack, a striing of bytes equal to the length of the
	     left operand  */

		call cobol_alloc$stack (fixed (alphabet_lop_ptr -> data_name.item_length, 17), 0, t_offset);

/*  Update the left operand to the stack segment number, and the offset just returned  */
		alphabet_lop_ptr -> data_name.seg_num = 1000;
						/*  Run time stack  */
		alphabet_lop_ptr -> data_name.offset = t_offset;
						/*  offset from alloc$stack  */

/*  Allocate on the run time stack, a string of bytes equal to the length of the right operand  */
		call cobol_alloc$stack (fixed (alphabet_rop_ptr -> data_name.item_length, 17), 0, t_offset);

/*  Update the right operand to the stack segment number and the offset just returned  */
		alphabet_rop_ptr -> data_name.seg_num = 1000;
						/*  Stack  */
		alphabet_rop_ptr -> data_name.offset = t_offset;
						/*  offset from alloc$stack  */

/*  Generate the instructions to move and translate the ascii data to alphabet form in
	     	the stack temporaries  */

/*  Generate code to translate left operand first  */
		source_ptr = lop_ptr;
		dest_ptr = alphabet_lop_ptr;
	     end;					/* TEMPORARY */


	do while (continue);			/*  Generate mvt instruction for left and right operands  */

/*  Build the input structure for the addressability utility  */

	     input_struc.type = 5;			/*  eis, 2 input operands, 2 eis descriptors and an instruction
	     	returned  */
	     input_struc.operand_no = 2;
	     input_struc.lock = 0;
	     input_struc.operand.token_ptr (1) = source_ptr;
	     input_struc.operand.send_receive (1) = 0;	/*  Send  */
	     input_struc.operand.size_sw (1) = 0;
	     input_struc.operand.token_ptr (2) = dest_ptr;
	     input_struc.operand.send_receive (2) = 1;	/*  Receive  */
	     input_struc.operand.size_sw (2) = 0;

/*  Call the addressability utility  */
	     call cobol_addr (input_ptr, inst_ptr, reloc_ptr);

/*  Insert the mvt opcode into the operand field of the returned instruction  */
	     inst_ptr -> eis_inst.opcode = mvt_op;

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


/*  Build the third descriptor  */
	     input_struc.type = 3;			/*  eis, 1 input operand, an instruction only returned  */
	     input_struc.operand_no = 1;
	     input_struc.lock = 0;

	     input_struc.operand.token_ptr (1) = dn_ptr;
	     input_struc.operand.send_receive (1) = 0;	/*  Send  */

/*  Call the addressability utility  */
	     call cobol_addr (input_ptr, inst_ptr, reloc_ptr);

/*  Zero the opcode field of the returned instruction  */
	     inst_ptr -> eis_inst.opcode = "0"b;

/*  Increment the address of the instruction, because addressability
	     calculated it relative to itself, instead of relative to the mvt instruction.  */

	     work_binary = binary (work_inst.left_half, 18);
	     if data_name.seg_num = 3000
	     then work_binary = work_binary + 3;
	     work_inst.left_half = substr (unspec (work_binary), 19, 18);
						/*  Emit the third descriptor  */
	     call cobol_emit (inst_ptr, reloc_ptr, 1);

	     if io_flag = 1
	     then return;				/*  Test to see whether both operands have been translated  */

	     if source_ptr = lop_ptr
	     then do;				/*  Must translate the right operand next  */
		     source_ptr = rop_ptr;
		     dest_ptr = alphabet_rop_ptr;
		end;				/*  Must translate the right operand next  */
	     else continue = "0"b;			/*  To exit from the loop  */

	end;					/*  Generate mvt_instructions for left and right operands  */

/*  Set lop_ptr and rop_ptr to the data name tokens for the alphabet strings in the stack  */


	lop_ptr = alphabet_lop_ptr;
	rop_ptr = alphabet_rop_ptr;

/*  Translate the cmpc filler character from ascii to alphabet  */
	cmpc_filler = substr (alphabet_name.table, binary (unspec (cmpc_filler)) + 1, 1);


/*****	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_alphabet_offset;
%include cobol_addr_tokens;
%include cobol_type9;
%include cobol_record_types;
%include cobol_ext_;
%include cobol_type40;
     end cobol_trans_alphabet;




		    cobol_unstring.pl1              05/24/89  1042.8rew 05/24/89  0832.1      204264



/****^  ***********************************************************
        *                                                         *
        * 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_unstring.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 03/26/76 by ORN to MOVE only _o_n_e character of a DELIMITED BY figcon into DELIMITER IN field. */

/* Modified on 03/17/76 by ORN to allow unstringing into non-separate sign numeric data fields
     by utilizing the new cobol_addr variable length encodement in the seg field of the type 9 token */
/* format: style3 */
cobol_unstring:
     proc (uptr, rwtp);

dcl	uptr		ptr;
dcl	rwtp		ptr;

dcl	1 u		based (uptr),
	  2 n		fixed bin,
	  2 tag		fixed bin,
	  2 stp		ptr,			/* pts to sending token */
	  2 dptr		ptr,			/* pts to d struct - may be null */
	  2 ptp		ptr,			/* pts to pointer token - may be null */
	  2 ttp		ptr,			/* pts to tallying token - may be null */
	  2 unstr		(256),
	    3 rtp		ptr,			/* pts to receiving token(i) */
	    3 dtp		ptr,			/* pts to delimiter token(i) - may be null */
	    3 ctp		ptr;			/* pts to count token(i) - may be null */
dcl	1 d		based (u.dptr),
	  2 n		fixed bin,
	  2 all_cnt	fixed bin,		/* number of entries with ALL */
	  2 delimiter	(256),
	    3 dtp		ptr,			/* pts to delimited token */
	    3 allsw	fixed bin;		/* 1 means ALL precedes delimiter */

dcl	text		(0:10000) bit (36) based (cobol_$text_base_ptr);

dcl	tra_instr		bit (36) static init ("000000000000000000111001000000000100"b);
						/* tra	-,ic			*/
dcl	epp2_instr	bit (36) static init ("110000000000000000011101010001000000"b);
						/* epp2	 pr6|-			*/
dcl	spri2_instr	bit (36) static init ("110000000000000000010101010001000000"b);
						/* spri2	pr6|-			*/
dcl	bump_tally_instr	bit (36) static init ("110000000000110001000101100001000000"b);
						/* aos	pr6|61	(tally)		*/
dcl	all_loop1_instr	(7) bit (36) static init ("110000000000111010111100010001000000"b,
						/* stx2	pr6|72	*/
			"000000000000000000110011101000001010"b,
						/* eaa	0,2	*/
			"000000000000010010111111001000000000"b,
						/* arl	22	*/
			"110000000000111001000111101001000000"b,
						/* ada	pr6|71	*/
			"000000000000000000110010010000000101"b,
						/* eax2	0,al	*/
			"110000000000110111001001101001000000"b,
						/* cmpa	pr6|67	*/
			"000000000000000101110000101100000100"b);
						/* tpnz	5,ic	*/
dcl	all_loop2_instr	(7) bit (36) static init ("111111111111111001110000000000000100"b,
						/* tze	-7,ic	*/
			"110000000000111010010010010001000000"b,
						/* ldx2	pr6|72	*/
			"110000000000111010111100001001000000"b,
						/* stx1	pr6|72	*/
			"110000000000111010001100010001000000"b,
						/* ssx2	pr6|72	*/
			"110000000000111010010010011001000000"b,
						/* ldx3	pr6|72	*/
			"110000000000111001001111101001000000"b,
						/* sba	pr6|71	*/
			"000000000000000000110010010000000101"b);
						/* eax2	0,al	*/
dcl	init_x2_instr	(3) bit (36) static init ("000000000000000000110010010000001001"b,
						/* eax2	0,1	*/
			"110000000000111011100101000001000000"b,
						/* stz	pr6|73	*/
			"000000000000000000111001000000000100"b);
						/* tra	0,ic	*/
dcl	check_x2_instr	(2) bit (36) static init ("110000000000111101001000010001000000"b,
						/* cmpx2	pr6|75	*/
			"000000000000000000110000100000000100"b);
						/* tmi	0,ic	*/
dcl	check_new_x1_instr	(9) bit (36) static init ("000000000000000000110011101000001010"b,
						/* eaa	0,2	*/
			"000000000000010010111111001000000000"b,
						/* arl	22	*/
			"110000000000111001000111101001000000"b,
						/* ada	pr6|71	*/
			"110000000000110000111101101001000000"b,
						/* sta	pr6|60	*/
			"000000000000000000110010001000000101"b,
						/* eax1	0,al	*/
			"110000000000111101001000001001000000"b,
						/* cmpx1	pr6|75	*/
			"000000000000000000110000101000000100"b,
						/* tpl	0,ic	*/
			"000000000000000000110010010000001001"b,
						/* eax2	0,x1	*/
			"000000000000000000111001000000000100"b);
						/* tra	0,ic	*/
dcl	check_del_instr	(5) bit (36) static init ("000000000000000000110010011000000101"b,
						/* eax3	0,al	*/
			"110000000000111011100100010001000000"b,
						/* sxl2	pr6|73	*/
			"110000000000111011000111101001000000"b,
						/* ada	pr6|73	*/
			"110000000000110111001001101001000000"b,
						/* cmpa	pr6|67	*/
			"000000000000000000110000101100000100"b);
						/* tpnz	0,ic	*/
dcl	comp_del_instr	(4) bit (36) static init ("000000000000000000001000110100000000"b,
						/* cmpc	(EIS)	*/
			"000000000000000000000000000000001011"b,
						/*  (EIS desc.)		*/
			"001000000000000000000000000000001011"b,
						/*  (EIS desc.)		*/
			"000000000000000000110000001000000100"b);
						/* tnz	0,ic	*/
dcl	set_x3_instr	(3) bit (36) static init ("110000000000111010111100001001000000"b,
						/* stx1	pr6|72	*/
			"110000000000111010001100010001000000"b,
						/* ssx2	pr6|72	*/
			"110000000000111010010010011001000000"b);
						/* ldx3	pr6|72	*/
dcl	bump_x2_instr	(2) bit (36) static init ("000000000000000001000110010000000011"b,
						/* adx2	1,du	*/
			"000000000000000000111001000000000100"b);
						/* tra	0,ic	*/
dcl	bump_x1_instr	(5) bit (36) static init ("110000000000111010111100011001000000"b,
						/* stx3	pr6|72	*/
			"110000000000111010000110001001000000"b,
						/* adx1	pr6|72	*/
			"110000000000110000100100001001000000"b,
						/* sxl1	pr6|60	*/
			"110000000000111101001000001001000000"b,
						/* cmpx1	pr6|75	*/
			"000000000000000000110000101000000100"b);
						/* tpl	0,ic	*/
dcl	save_send_len_instr (2) bit (36) static init ("000000000000000000110010010000000101"b,
						/* eax2	0,al	*/
			"110000000000111101111100010001000000"b);
						/* stx2	pr6|75	*/
dcl	set_pointer_instr	(6) bit (36) static init ("110000000000111101001000001001000000"b,
						/* cmpx1	pr6|75	*/
			"000000000000000010110000100100000100"b,
						/* tmoz	2,ic	*/
			"110000000000111101010010001001000000"b,
						/* ldx1	pr6|75	*/
			"000000000000000001000110001000000011"b,
						/* adx1	1,du	*/
			"110000000000110000100100001001000000"b,
						/* sxl1	pr6|60	*/
			"000000000000000001001110001000000011"b);
						/* sbx1	1,du	*/
dcl	set_count_instr	(3) bit (36) static init ("000000000000000000110011101000001011"b,
						/* eaa	0,3			*/
			"000000000000010010111111001000000000"b,
						/* arl	22	*/
			"110000000000111011111101101001000000"b);
						/* sta	pr6|73	(temp)		*/
dcl	adjust_length_instr (8) bit (36) static init ("000000000000000000110010011000000101"b,
						/* eax3	0,al			*/
			"110000000000110000000111101001000000"b,
						/* ada	pr6|60	(ptr)		*/
			"110000000000110111001001101001000000"b,
						/* cmpa	pr6|67	(slen)		*/
			"000000000000000101110000100100000100"b,
						/* tmoz	5,ic	(OK)		*/
			"110000000000110111001111101001000000"b,
						/* sba	pr6|67	(slen)		*/
			"000000000000010010111011101000000000"b,
						/* als	22			*/
			"110000000000111010111101101001000000"b,
						/* sta	pr6|72	(utemp)		*/
			"110000000000111010001110011001000000"b);
						/* sbx3	pr6|72	(utemp)		*/
dcl	bypass_ovfl_instr	(2) bit (36) static init ("110000000000111101001000001001000000"b,
						/* cmpx1	pr6|75	*/
			"000000000000000000110000101000000100"b);
						/* tpl	0,ic	*/
dcl	adjust_and_test_x1_instr
			(6) bit (36) static init ("110000000000110000111010001001000000"b,
						/* lxl1	pr6|60	(ptr)		*/
			"000000000000000001001110001000000011"b,
						/* sbx1	1,du	(create offset)	*/
			"000000000000000000110000100000000100"b,
						/* tmi	[end_tag],ic  (out of range)	*/
			"110000000000110000001001101001000000"b,
						/* cmpa	pr6|60	(ptr)		*/
			"000000000000000000110000100000000100"b,
						/* tmi	[end_tag],ic  (out of range)	*/
			"110000000000110000100100001001000000"b);
						/* sxl1	pr6|60	(ptr)		*/
dcl	zero_x1_instr	(2) bit (36) static init ("000000000000000000110010001000000000"b,
						/* eax1	0			*/
			"110000000000110000100101000001000000"b);
						/* stz	pr6|60	(ptr)		*/

dcl	1 mpout		auto,
	  2 n		fixed bin,
	  2 pt1		ptr,
	  2 pt2		ptr,
	  2 pt3		ptr,
	  2 pt4		ptr;
dcl	1 addr_struct	static,
	  2 type		fixed bin init (4),
	  2 operand_no	fixed bin init (2),
	  2 lock		fixed bin init (0),
	  2 op1,
	    3 tptr	ptr,
	    3 sr		fixed bin init (0),
	    3 ic_mod	fixed bin,
	    3 size_sw	fixed bin init (1),
	  2 op2,
	    3 tptr	ptr,
	    3 sr		fixed bin init (0),
	    3 ic_mod	fixed bin,
	    3 size_sw	fixed bin init (0);
dcl	1 pr_struct	static,
	  2 pr		fixed bin,
	  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,
	  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);

/* scratch pad use
 60	ptr
 61	tally
 62	paddr
 64	taddr
 67	slen
 71	dlen
 72	utemp
 73	temp
 75	uslen */
dcl	ptr_off		fixed bin static init (48);
dcl	ptr_offx4		fixed bin static init (192);
dcl	paddr_off		fixed bin static init (50);
dcl	tally_offx4	fixed bin static init (196);
dcl	count_offx4	fixed bin static init (236);
dcl	taddr_off		fixed bin static init (52);
dcl	slen_off		fixed bin static init (55);
dcl	dlen_off		fixed bin static init (57);

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 (40),
	    3 fb2		(2) fixed bin init (0, 0),
	    3 flags1	bit (36) init ("010000100100000000010000000100000000"b),
	    3 flags2	bit (36) init (""b),
	    3 seg		fixed bin init (11161),	/* PR1 with offset X1 and length in X3 (010 1011 1001 1001) */
						/*-03/17/76-*/
	    3 off		fixed bin init (0),
	  2 fill2		(7) fixed bin init (0, 0, 0, 0, 0, 0, 0);
dcl	1 zero_type2	static,
	  2 size		fixed bin init (37),
	  2 line		fixed bin init (0),
	  2 column	fixed bin init (0),
	  2 type		fixed bin init (2),
	  2 integral	bit (1) init ("1"b),
	  2 floating	bit (1) init ("0"b),
	  2 filler1	bit (5) init (""b),
	  2 subscript	bit (1) init ("0"b),
	  2 sign		char (1) init (" "),
	  2 exp_sign	char (1) init (" "),
	  2 exp_places	fixed bin init (0),
	  2 places_left	fixed bin init (1),
	  2 places_right	fixed bin init (0),
	  2 places	fixed bin init (1),
	  2 literal	char (1) init ("0");
dcl	1 blank_type3	static,
	  2 size		fixed bin init (25),
	  2 line		fixed bin init (0),
	  2 column	fixed bin init (0),
	  2 type		fixed bin init (3),
	  2 lit_type	bit (1) init ("0"b),
	  2 all_lit	bit (1) init ("1"b),
	  2 filler1	bit (6) init (""b),
	  2 lit_size	fixed bin init (1),
	  2 string	char (1) init (" ");
dcl	type9_chars	char (112) based (addr (type9));
dcl	1 type3		auto,
	  2 alignment	ptr,			/* so as to double-word align the space */
	  2 rest		char (26);
dcl	1 type9		auto,
	  2 header	(4) fixed bin,
	  2 repl_ptr	(2) ptr,
	  2 fill1		bit (108),
	  2 fb1		(3) fixed bin,
	  2 size		fixed bin,
	  2 fb2		(2) fixed bin,
	  2 flags		bit (72),
	  2 seg		fixed bin,
	  2 offset	fixed bin,
	  2 rest		char (28);
dcl	1 move_eos	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),
	  2 e		fixed bin init (1),
	  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	end_tag		fixed bin;
dcl	ovfl_tag		fixed bin;
dcl	nextdel_tag	fixed bin;
dcl	delfound_tag	fixed bin;
dcl	nextpos_tag	fixed bin;
dcl	nextrt_tag	fixed bin;

dcl	(i, j)		fixed bin;
dcl	ic		fixed bin;
dcl	temp		fixed bin;

dcl	psub		bit (1);
dcl	tsub		bit (1);
dcl	lit		bit (18);

dcl	dn_ptr		ptr;
dcl	pr_struct_ptr	ptr;

dcl	cobol_move_gen	entry (ptr);
dcl	cobol_addr	entry (ptr, ptr, ptr);
dcl	cobol_emit	entry (ptr, ptr, fixed bin);
dcl	cobol_get_size	entry (ptr, fixed bin, fixed bin);
dcl	cobol_get_size$omit_sign
			entry (ptr, fixed bin, fixed bin);
dcl	cobol_set_pr	entry (ptr, ptr);
dcl	cobol_make_type9$type2_3
			entry (ptr, ptr);
dcl	cobol_make_type3$type1
			entry (ptr, ptr);
dcl	cobol_io_util$t9dec_to_bin
			entry (bit (3) aligned, fixed bin, ptr);
dcl	cobol_io_util$bin_to_t9dec
			entry (bit (3) aligned, fixed bin, ptr);
dcl	cobol_reset_r$in_line
			entry;
dcl	cobol_register$load entry (ptr);
dcl	cobol_$register$load
			entry (ptr);
dcl	cobol_make_tagref	entry (fixed bin, fixed bin, ptr);
dcl	cobol_define_tag_nc entry (fixed bin, fixed bin);


/*************************************/
start:
	mpout.n = 4;
	mpout.pt1 = rwtp;
	mpout.pt4 = addr (move_eos);
	do reg_struct.what_reg = 1, 11, 12, 13;		/* lock A, X1, X2 and X3 */
	     call cobol_register$load (addr (reg_struct));
	end;
	end_tag = cobol_$next_tag;
	ovfl_tag = end_tag + 1;
	cobol_$next_tag = cobol_$next_tag + 2;

/* SET PR1 TO PT TO SENDING ITEM */
	pr_struct_ptr = addr (pr_struct);
	pr_struct.pr = 1;
	call cobol_set_pr (pr_struct_ptr, u.stp);

/* ESTABLISH SIZE OF SENDING ITEM */
	call cobol_get_size (u.stp, slen_off, 0);
	call cobol_emit (addr (save_send_len_instr), null (), 2);

/* ESTABLISH TALLY (if specified) */
	if u.ttp ^= null ()
	then do;
		dn_ptr = u.ttp;
		if ^data_name.subscripted
		then tsub = "0"b;
		else do;
			tsub = "1"b;
			pr_struct.pr = 2;
			call cobol_set_pr (pr_struct_ptr, u.ttp);
			substr (spri2_instr, 4, 15) = substr (unspec (taddr_off), 22, 15);
			call cobol_emit (addr (spri2_instr), null (), 1);
			type9_chars = dn_ptr -> type9_chars;
			type9.seg = 5002;		/* pointed to by PR2 */
			dn_ptr = addr (type9);
		     end;
		call cobol_io_util$t9dec_to_bin ("110"b, tally_offx4, dn_ptr);
	     end;

/* INITIALIZE X1 (indexes sending item) */
	if u.ptp = null ()
	then call cobol_emit (addr (zero_x1_instr), null (), 2);
	else do;
		dn_ptr = u.ptp;
		if ^data_name.subscripted
		then psub = "0"b;
		else do;
			psub = "1"b;
			pr_struct.pr = 2;
			call cobol_set_pr (pr_struct_ptr, u.ptp);
			substr (spri2_instr, 4, 15) = substr (unspec (paddr_off), 22, 15);
			call cobol_emit (addr (spri2_instr), null (), 1);
			type9_chars = dn_ptr -> type9_chars;
			type9.seg = 5002;		/* pointed to by PR2 */
			dn_ptr = addr (type9);
		     end;
		call cobol_io_util$t9dec_to_bin ("110"b, ptr_offx4, dn_ptr);
		call cobol_emit (addr (adjust_and_test_x1_instr), null (), 6);
		call cobol_make_tagref (ovfl_tag, cobol_$text_wd_off - 4, null ());
		call cobol_make_tagref (ovfl_tag, cobol_$text_wd_off - 2, null ());
	     end;

/* MAIN LOOP */
	if u.dptr = null ()
	then do i = 1 to u.n;			/* no delimiters specified */
		call cobol_get_size$omit_sign (u.rtp (i), 0, 0);
		call cobol_emit (addr (adjust_length_instr), null (), 8);
		mpout.pt2 = addr (alpha_type9);
		mpout.pt3 = rtp (i);
		call cobol_move_gen (addr (mpout));
		if u.ttp ^= null ()
		then call cobol_emit (addr (bump_tally_instr), null (), 1);
		if u.ctp (i) ^= null ()
		then do;
			call cobol_emit (addr (set_count_instr), null (), 3);
			call cobol_io_util$bin_to_t9dec ("110"b, count_offx4, u.ctp (i));
		     end;
		if u.dtp (i) ^= null ()
		then do;
			if u.dtp (i) -> data_name.numeric
			then mpout.pt2 = addr (zero_type2);
			else mpout.pt2 = addr (blank_type3);
			mpout.pt3 = u.dtp (i);
			call cobol_move_gen (addr (mpout));
		     end;
		if i = u.n
		then do;				/* may be able to avoid for last time */
			if u.tag > 0
			then temp = 5;
			else if u.ptp ^= null ()
			then temp = 2;
			else temp = 0;
		     end;
		else temp = 5;
		if temp > 0
		then do;
			call cobol_emit (addr (bump_x1_instr), null (), temp);
			if temp = 5
			then call cobol_make_tagref (end_tag, cobol_$text_wd_off - 1, null ());
		     end;
	     end;

	else do;					/* delimiter(s) specified */
		nextdel_tag = cobol_$next_tag;
		cobol_$next_tag = cobol_$next_tag + 1;
		call cobol_emit (addr (init_x2_instr), null (), 3);
		call cobol_make_tagref (nextdel_tag, cobol_$text_wd_off - 1, null ());
		do i = 1 to u.n;
		     if i > 1
		     then call cobol_define_tag_nc (nextrt_tag, cobol_$text_wd_off);
		     if u.n > 1
		     then do;
			     call cobol_emit (addr (check_new_x1_instr), null (), 9);
			     call cobol_make_tagref (end_tag, cobol_$text_wd_off - 3, null ());
			     call cobol_make_tagref (nextdel_tag, cobol_$text_wd_off - 1, null ());
			end;
		     nextpos_tag = cobol_$next_tag;
		     cobol_$next_tag = cobol_$next_tag + 1;
		     call cobol_define_tag_nc (nextpos_tag, cobol_$text_wd_off);
		     call cobol_emit (addr (check_x2_instr), null (), 2);
		     call cobol_make_tagref (nextdel_tag, cobol_$text_wd_off - 1, null ());
						/* NO MATCH FOUND */
		     if u.dtp (i) ^= null ()
		     then do;
			     if u.dtp (i) -> data_name.numeric
			     then mpout.pt2 = addr (zero_type2);
			     else mpout.pt2 = addr (blank_type3);
			     mpout.pt3 = u.dtp (i);
			     call cobol_move_gen (addr (mpout));
			end;			/* MOVE */
		     call cobol_emit (addr (set_x3_instr), null (), 3);
		     delfound_tag = cobol_$next_tag;
		     cobol_$next_tag = cobol_$next_tag + 1;
		     call cobol_define_tag_nc (delfound_tag, cobol_$text_wd_off);
		     mpout.pt2 = addr (alpha_type9);
		     mpout.pt3 = u.rtp (i);
		     call cobol_move_gen (addr (mpout));
		     if u.ttp ^= null ()
		     then call cobol_emit (addr (bump_tally_instr), null (), 1);
		     if u.ctp (i) ^= null ()
		     then do;
			     call cobol_emit (addr (set_count_instr), null (), 3);
			     call cobol_io_util$bin_to_t9dec ("110"b, count_offx4, u.ctp (i));
			end;
		     call cobol_emit (addr (tra_instr), null (), 1);
		     nextrt_tag = cobol_$next_tag;
		     cobol_$next_tag = cobol_$next_tag + 1;
		     call cobol_make_tagref (nextrt_tag, cobol_$text_wd_off - 1, null ());
		     do j = 1 to d.n;
			call cobol_define_tag_nc (nextdel_tag, cobol_$text_wd_off);
			nextdel_tag = cobol_$next_tag;
			cobol_$next_tag = cobol_$next_tag + 1;
			dn_ptr = d.dtp (j);
			if data_name.type = 1
			then do;
				dn_ptr = addr (type3);
				call cobol_make_type3$type1 (dn_ptr, d.dtp (j));
			     end;
			if data_name.type = 2 | data_name.type = 3
			then do;
				addr_struct.op1.tptr = addr (type9);
				call cobol_make_type9$type2_3 (addr_struct.op1.tptr, dn_ptr);
			     end;
			else addr_struct.op1.tptr = d.dtp (j);
			addr_struct.op2.tptr = null ();
			call cobol_get_size (addr_struct.op1.tptr, dlen_off, 0);
			call cobol_emit (addr (check_del_instr), null (), 5);
			call cobol_make_tagref (nextdel_tag, cobol_$text_wd_off - 1, null ());
			addr_struct.op1.ic_mod = 0;
			call cobol_addr (addr (addr_struct), addr (comp_del_instr), null ());
			substr (comp_del_instr (1), 31, 1) = "1"b;
						/* len in register */
			substr (comp_del_instr (1), 12, 7) = "1101010"b;
						/* pr,rl,x2 */
			call cobol_emit (addr (comp_del_instr), null (), 4);
			call cobol_make_tagref (nextdel_tag, cobol_$text_wd_off - 1, null ());
			if u.dtp (i) ^= null ()
			then do;
				mpout.pt2 = addr_struct.op1.tptr;
						/* type 9 token for this delimiter */
						/*-03/26/76-*/
				mpout.pt3 = u.dtp (i);
				call cobol_move_gen (addr (mpout));
			     end;
			if d.allsw (j) = 0
			then call cobol_emit (addr (set_x3_instr), null (), 3);
			else do;			/* ALL specified */
				call cobol_emit (addr (all_loop1_instr), null (), 7);
				if addr_struct.op1.ic_mod ^= 0
				then call cobol_addr (addr (addr_struct), addr (comp_del_instr), null ());
				call cobol_emit (addr (comp_del_instr), null (), 3);
				call cobol_emit (addr (all_loop2_instr), null (), 7);
			     end;
			call cobol_emit (addr (tra_instr), null (), 1);
			call cobol_make_tagref (delfound_tag, cobol_$text_wd_off - 1, null ());
			if j = d.n
			then do;			/* last time - provide exit via nextdel_tag */
				call cobol_define_tag_nc (nextdel_tag, cobol_$text_wd_off);
				nextdel_tag = cobol_$next_tag;
				cobol_$next_tag = cobol_$next_tag + 1;
				call cobol_emit (addr (bump_x2_instr), null (), 2);
				call cobol_make_tagref (nextpos_tag, cobol_$text_wd_off - 1, null ());
			     end;
		     end;
		     if i = u.n
		     then do;			/* last time - provide exit via nextrt_tag */
			     call cobol_define_tag_nc (nextrt_tag, cobol_$text_wd_off);
			     if u.ptp ^= null () | u.tag > 0
			     then call cobol_emit (addr (check_new_x1_instr), null (), 5);
			end;
		end;
	     end;

	call cobol_define_tag_nc (end_tag, cobol_$text_wd_off);


/* SET TALLY */
	if u.ttp ^= null ()
	then do;
		dn_ptr = u.ttp;
		if tsub
		then do;
			substr (epp2_instr, 4, 15) = substr (unspec (taddr_off), 22, 15);
			call cobol_emit (addr (epp2_instr), null (), 1);
			type9_chars = dn_ptr -> type9_chars;
			dn_ptr = addr (type9);
		     end;
		call cobol_io_util$bin_to_t9dec ("110"b, tally_offx4, dn_ptr);
	     end;

/* SET POINTER */
	if u.ptp ^= null ()
	then do;
		dn_ptr = u.ptp;
		if psub
		then do;
			substr (epp2_instr, 4, 15) = substr (unspec (paddr_off), 22, 15);
			call cobol_emit (addr (epp2_instr), null (), 1);
			type9_chars = dn_ptr -> type9_chars;
			type9.seg = 5002;
			dn_ptr = addr (type9);
		     end;
		if tag > 0
		then temp = 6;			/* must check x1 for overflow */
		else temp = 5;			/* forget it */
		call cobol_emit (addr (set_pointer_instr), null (), temp);
		call cobol_io_util$bin_to_t9dec ("110"b, ptr_offx4, u.ptp);
	     end;

/* CHECK FOR OVERFLOW */
	if u.tag > 0
	then do;
		call cobol_emit (addr (bypass_ovfl_instr), null (), 2);
		call cobol_make_tagref (tag, cobol_$text_wd_off - 1, null ());
	     end;
	call cobol_define_tag_nc (ovfl_tag, cobol_$text_wd_off);

	call cobol_reset_r$in_line;
	return;

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

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

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

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

%include cobol_type1;
%include cobol_type2;
%include cobol_type3;
%include cobol_type9;
%include cobol_;
     end cobol_unstring;




		    cobol_unstring_gen.pl1          05/24/89  1042.8rew 05/24/89  0832.1       35136



/****^  ***********************************************************
        *                                                         *
        * 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_unstring_gen.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* format: style3 */
cobol_unstring_gen:
     proc (mp_ptr, passed_tag);

dcl	mp_ptr		ptr;
dcl	passed_tag	fixed bin;

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

dcl	1 u		auto,
	  2 n		fixed bin,
	  2 tag		fixed bin,
	  2 stp		ptr,			/* pts to sending token */
	  2 dptr		ptr,			/* pts to d struct - may be null */
	  2 ptp		ptr,			/* pts to pointer token - may be null */
	  2 ttp		ptr,			/* pts to tallying token - may be null */
	  2 unstr		(256),
	    3 rtp		ptr,			/* pts to receiving token(i) */
	    3 dtp		ptr,			/* pts to delimiter token(i) - may be null */
	    3 ctp		ptr;			/* pts to count token(i) - may be null */
dcl	1 d		auto,
	  2 n		fixed bin,
	  2 all_cnt	fixed bin,		/* number of entries with ALL */
	  2 delimiter	(256),
	    3 dtp		ptr,			/* pts to delimited token */
	    3 allsw	fixed bin;		/* 1 means ALL precedes delimiter */

dcl	(i, j, temp)	fixed bin;
dcl	delimiter_key	fixed bin static init (91);
dcl	count_key		fixed bin static init (84);
dcl	all_key		fixed bin static init (73);

dcl	dn_ptr		ptr;

dcl	cobol_unstring	entry (ptr, ptr);


/*************************************/
start:
	eos_ptr = mp.pt (mp.n);
	if end_stmt.b
	then do;
		passed_tag = cobol_$next_tag;
		cobol_$next_tag = cobol_$next_tag + 1;
		u.tag = passed_tag;
	     end;
	else u.tag = 0;

	u.stp = mp.pt (2);

	j = 3;
	if end_stmt.e > 0
	then do;					/* at least one operand after DELIMITED */
		u.dptr = addr (d);
		d.all_cnt = 0;
		d.n = end_stmt.e;
		do i = 1 to d.n;
		     dn_ptr = mp.pt (j);
		     d.allsw (i) = 0;
		     if data_name.type = 1
		     then if dn_ptr -> reserved_word.key = all_key
			then do;			/*ALL */
				d.allsw (i) = 1;
				d.all_cnt = d.all_cnt + 1;
				j = j + 1;
			     end;
		     d.dtp (i) = mp.pt (j);
		     j = j + 1;
		end;
	     end;
	else u.dptr = null ();

	u.n = end_stmt.h;
	do i = 1 to u.n;
	     u.rtp (i) = mp.pt (j);
	     temp = j + 1;
	     if mp.pt (temp) -> data_name.type = 1 & mp.pt (temp) -> reserved_word.key = delimiter_key
	     then do;
		     j = j + 2;
		     u.dtp (i) = mp.pt (j);
		end;
	     else u.dtp (i) = null ();
	     temp = j + 1;
	     if mp.pt (temp) -> data_name.type = 1 & mp.pt (temp) -> reserved_word.key = count_key
	     then do;
		     j = j + 2;
		     u.ctp (i) = mp.pt (j);
		end;
	     else u.ctp (i) = null ();
	     j = j + 1;
	end;

	if end_stmt.d = "01"b
	then u.ptp = mp.pt (j);
	else u.ptp = null ();
	if end_stmt.c = "1"b
	then u.ttp = mp.pt (mp.n - 1);
	else u.ttp = null ();

	call cobol_unstring (addr (u), mp.pt (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_type1;
%include cobol_type9;
%include cobol_type19;
%include cobol_;
     end cobol_unstring_gen;




		    cobol_write_gen.pl1             05/24/89  1042.8rew 05/24/89  0832.1      133407



/****^  ***********************************************************
        *                                                         *
        * 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_write_gen.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 12/07/80 by FCH, [4.4-1], report writer added */
/* modified on 08/15/79 by MHD, [4.0-2],  fixed problem in write with LINAGE clause */
/* modified on 06/27/79 by FCH, [4.0-1], not option added for debug */
/* Modified on 11/13/78 by FCH, [3.0-1], alt rec keys added */
/* Modified since Version 3.0 */

/* format: style3 */
cobol_write_gen:
     proc (mp_ptr, passed_tag);

dcl	stoff		fixed bin;
dcl	(good_tag, stream_tag, seek_tag, write_tag, skip_tag, alt_tag, alt_seek_tag)
			fixed bin;
dcl	passed_tag	fixed bin;		/* for  in-line error handling */
dcl	ptag		fixed bin;
dcl	linage_ptr	ptr;
dcl	mp_ptr		ptr;
dcl	1 mp		based (mp_ptr),
	  2 n		fixed bin,		/* from 3 - 5 */
	  2 pt		(0 refer (mp.n)) ptr;	/* pt(1) pts to type1 token for WRITE */
						/* pt(2) pts to type9 token (record name) or type12 token(file name) */
						/* pt(3) pts to type9 token for FROM data IF eos.c = "1"b */
						/* pt(n-1) pts to type9 token for ADVANCING data IF eos.d ^= "00"b */
						/* pt(n) pts to type19 token (eos) */

dcl	1 args,
	  2 entryno	fixed bin,
	  2 arglist_off	fixed bin,
	  2 stacktemp_off	fixed bin,
	  2 n		fixed bin,
	  2 arg		(4),
	    3 pt		ptr,
	    3 type	fixed bin,
	    3 off1	fixed bin,
	    3 off2	fixed bin,
	    3 value	bit (18) unal,
	    3 indirect	bit (1) unal,
	    3 overlay	bit (1) unal,
	    3 repeat_nogen	bit (1) unal;

dcl	file_key_desc	char (40) based;
dcl	extend_sw		bit (1) aligned;
dcl	(alt_sw, code_set_sw, var)
			bit (1);
dcl	text		(0:100000) bit (36) based (cobol_$text_base_ptr);
dcl	argb		(4) bit (216) based (addr (args.arg (1)));
dcl	save_mp2_ptr	ptr;
dcl	ft_ptr		ptr;
dcl	fkey_ptr		ptr;
dcl	dn_ptr		ptr;
dcl	name_ptr		ptr;
dcl	arg_ptr		ptr;
dcl	ioerror_ptr	ptr;

dcl	(temp, fn)	fixed bin;
dcl	aloff		fixed bin init (0);
dcl	size		fixed bin;
dcl	offset		fixed bin;
dcl	reclen_off	fixed bin;
dcl	buflen_off	fixed bin;
dcl	buf_off		fixed bin;
dcl	ntag		fixed bin;

/*************************************/
/*************************************/
/* INITIALIZATION */
start:
	pr5_struct_ptr = addr (pr5_struct);
	rw_ptr = mp.pt (1);

	eos_ptr = mp.pt (mp.n);
	ioerror.retry_tag = cobol_$next_tag;
	good_tag = cobol_$next_tag + 1;
	stream_tag = cobol_$next_tag + 2;
	seek_tag = cobol_$next_tag + 3;
	write_tag = cobol_$next_tag + 4;		/* [3.0-1] */
	alt_tag = cobol_$next_tag + 5;		/* [3.0-1] */
	alt_seek_tag = cobol_$next_tag + 6;
	cobol_$next_tag = cobol_$next_tag + 7;		/*[4.4-1]*/
	call set_up;
	arg_ptr = addr (args);
	ioerror.cobol_code = 0;
	ioerror.type1_ptr = mp.pt (1);
	ioerror.mode = 0;
	ioerror_ptr = addr (ioerror);
	iocb_arg.pt = addr (iocb_struct);

	if end_stmt.b = "1"b
	then do;
		passed_tag, ioerror.ns_tag = cobol_$next_tag;
		ioerror.is_tag = cobol_$next_tag + 1;
		cobol_$next_tag = cobol_$next_tag + 2;
	     end;
	else do;
		ioerror.is_tag = 0;
		ioerror.ns_tag = cobol_$next_tag;
		cobol_$next_tag = cobol_$next_tag + 1;
	     end;

/*[4.4-1]*/
	call cobol_read_ft (fn, ft_ptr);

	if file_table.organization = 5
	then file_table.organization = 4;		/* temporary */

	iocb_struct.seg = file_table.fsb.seg;
	iocb_struct.offset = file_table.fsb.off;

	call cobol_alloc$stack (56, 2, aloff);		/* enough for 14 words - aloff is a wd offset */

	args.arglist_off = aloff;
	args.n = 4;
	argb (1) = unspec (iocb_arg);
	argb (4) = unspec (status_arg);
	buflen_off = 80;


/*************************************/
/* START CODE GENERATION */
start_codegen:					/* MOVE FROM DATANAME TO BUFFER IF NECESSARY */
	if end_stmt.c = "1"b			/* FROM specified */
	then do;
		mpout.pt1 = mp.pt (1);
		mpout.pt2 = mp.pt (3);
		mpout.pt3 = mp.pt (2);
		mpout.pt4 = addr (type19);

		call cobol_move_gen (addr (mpout));

	     end;

/* MAKE SURE FILE IS OPEN */

	call cobol_define_tag (ioerror.retry_tag);

	call cobol_set_fsbptr (ft_ptr);		/* generates epp1 pr4|102,* */

/* OPERATOR39(init_write) */
	call cobol_call_op (39, good_tag);		/* INT_WRITE_OP */

	call cobol_gen_ioerror (ft_ptr, ioerror_ptr);

	call cobol_define_tag (good_tag);

	if file_table.linage			/* LINAGE TOP initialization */
	then do;
		call cobol_read_rand (1, file_table.linage_info, linage_ptr);

		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);

		     end;

	     end;					/*[4.4-1]*/
	if var					/*[4.4-1]*/
	then do;
		var = data_name.variable_length;
		temp = data_name.item_length;
	     end;					/*[4.4-1]*/
	else do;
		var = file_table.variable;
		temp = file_table.max_cra_size;
	     end;					/* ESTABLISH RECORD LENGTH */
						/*[4.4-1]*/
	if ^var
	then do;

		call cobol_io_util$move_direct ("110"b, buflen_off * 4, 4, 1, substr (unspec (temp), 19, 18));
	     end;

	else do;

		if ^file_table.rec_do
		then call cobol_get_size (dn_ptr, buflen_off, reserved_word.line);

		else do;

			call cobol_read_rand (1, file_table.rec_do_info, fkey_ptr);

			addr (fkey_type9.file_key_info) -> file_key_desc = file_key.desc;

			call cobol_io_util$t9dec_to_bin ("110"b, buflen_off * 4, addr (fkey_type9));

		     end;
	     end;

/* CONVERT IF CODE SET INDICATES SO */
	code_set_sw = file_table.code_set_clause & file_table.code_set = 12;

	if code_set_sw
	then do;
		call cobol_alloc$stack (data_name.size + 1, 2, stoff);
						/*-10/07/76-*/

		trans_type9.seg = 1000;		/* in stack */
		trans_type9.off = stoff * 4;		/*-10/07/76-*/
		trans_type9.size = data_name.size;

		call cobol_trans_alphabet$io (dn_ptr, addr (trans_type9), fixed (file_table.code_set), 0);

		dn_ptr = addr (trans_type9);		/* set to converted record for remainder of this generator */

	     end;

/* STREAM OUTPUT */

/* [3.0-1] */
	alt_sw = file_table.organization = 3 /* ind */ /* [3.0-1] */ & /* [3.0-1] */ file_table.alternate_keys ^= 0;

	if file_table.organization = 4 | file_table.device = 1 | file_table.device = 3
	then do;
		if end_stmt.b = "1"b
		then /* in-line error coding follows */
		     call cobol_ioop_util$set_icode;

		if code_set_sw
		then do;
			save_mp2_ptr = mp.pt (2);
			mp.pt (2) = addr (trans_type9);


		     end;

		call cobol_linage (ft_ptr, mp_ptr, buflen_off, buf_off, ioerror_ptr);

/* OPPERATOR52(LINAGE) */
		call init_linage;			/*[4.0-2]*/
		if code_set_sw
		then mp.pt (2) = save_mp2_ptr;

		call cobol_set_fsbptr (ft_ptr);

		call cobol_ioop_util$disp (buf_off);

/* OPERATOR68(write_stream_linage) */

		if file_table.linage
		then call cobol_call_op (68, stream_tag);
						/* write_stream_linage_op */

/* OPERATOR40(write_stream) */

		else call cobol_call_op (40, stream_tag);
						/* write_stream_op */

		call cobol_gen_ioerror (ft_ptr, ioerror_ptr);

	     end;

	else do;

		if file_table.access < 2
		then if file_table.external | file_table.open_io
		     then do;
			     ntag = cobol_$next_tag;
			     cobol_$next_tag = cobol_$next_tag + 1;

			     call cobol_io_util$bypass_mode_error (ntag, "10"b);

			     call cobol_define_tag (ntag);

			end;

/* SEEK KEY FOR RELATIVE OR INDEXED FILES */

		if file_table.organization ^= 1	/* not sequential */
		then do;
			if file_table.relative_key | file_table.record_key
			then do;

				call cobol_read_rand (1, file_table.r_key_info, fkey_ptr);

				addr (fkey_type9.file_key_info) -> file_key_desc = file_key.desc;
			     end;

			if file_table.organization = 2 & file_table.access < 2
						/* relative sequential */
			then do;
				call cobol_io_util$fixed_add ("001"b, fsb_relkey, 1, ""b, 0);
						/* must maintain own relkey */

				call cobol_io_util$bin_to_dec ("001"b, fsb_key, 16, "001"b, fsb_relkey, 4);

				call cobol_io_util$move_direct ("001"b, fsb_keylen_sw, 4, 1,
				     "000000000000010000"b);

			     end;
			else do;

				mpout.pt1 = mp.pt (1);
				mpout.pt2 = addr (fkey_type9);
				if file_table.organization = 2
				then do;
					mpout.pt3 = addr (num_type9);
					size, num_type9.size, num_type9.places_left = 16;
					num_type9.seg = 5001;
						/* from PR1 */
					num_type9.off = file_table.fsb.off + fsb_key;
				     end;
				else do;		/* indexed */
					mpout.pt3 = addr (alpha_type9);
					size, alpha_type9.size = fkey_type9.size;
					alpha_type9.seg = 5001;
						/* from PR1 */
					alpha_type9.off = file_table.fsb.off + fsb_key;
				     end;

				mpout.pt4 = addr (type19);

				call cobol_move_gen (addr (mpout));
						/* must always move reckey to varying string */

				call cobol_io_util$move_direct ("001"b, fsb_keylen_sw, 4, 1,
				     substr (unspec (size), 19, 18));

			     end;

			if alt_sw
			then call EMIT_OP_91;

			call cobol_call_op (41, seek_tag);
						/* OPERATOR41(seek_tag) */

			call cobol_gen_ioerror (ft_ptr, ioerror_ptr);

			call cobol_define_tag (seek_tag);


/* RESET "LAST-KEY-READ" IF NECESSARY */
			if file_table.access < 2 & (file_table.external | file_table.open_io)
			then do;
				call cobol_set_fsbptr (ft_ptr);
						/* set pr1 to fsb */

				call cobol_io_util$move_direct ("001"b, fsb_keylen_sw, 4, 1, ""b);
						/* zero fsb.keylen_sw */

			     end;

		     end;

		else if alt_sw
		then call EMIT_OP_91;

/* WRITE THE RECORD */

		call cobol_set_pr (pr5_struct_ptr, dn_ptr);

		if end_stmt.b = "1"b
		then call cobol_ioop_util$set_icode;

		call cobol_call_op (42, write_tag);	/* OPERATOR42(write_record) */

		call cobol_gen_ioerror (ft_ptr, ioerror_ptr);

		call cobol_define_tag (write_tag);

/* [3.0-1] */
		if alt_sw				/* [3.0-1] */
		then do;
			call cobol_io_util$file_desc (file_table.file_desc_1_offset);
						/* [3.0-1] */
			call cobol_call_op (90, stream_tag);
						/* OPERATOR90(alt_add_write_keys) */
						/* [3.0-1] */
			call cobol_gen_ioerror (ft_ptr, ioerror_ptr);
						/* [3.0-1] */
		     end;

/* SET RELATIVE KEY IF NECESSARY */
		if file_table.organization = 2 & file_table.access < 2 & file_table.relative_key
		then do;
			call cobol_set_fsbptr (ft_ptr);

			mpout.pt1 = mp.pt (1);
			mpout.pt2 = addr (num_type9);
			num_type9.size, num_type9.places_left = 16;
			num_type9.seg = 5001;	/* from PR1 */
			num_type9.off = file_table.fsb.off + fsb_key;
			mpout.pt3 = addr (fkey_type9);
			mpout.pt4 = addr (type19);

			call cobol_move_gen (addr (mpout));

		     end;

	     end;


	call cobol_define_tag (stream_tag);

/* [3.0-1] */
	if alt_sw
	then call cobol_set_fsbptr (ft_ptr);



	call cobol_reg_manager$after_op (4095 + ioerror.cobol_code);

/*[4.0-1]*/
	if end_stmt.f = "01"b			/*[4.0-1]*/
	then passed_tag = ioerror.is_tag;		/*[4.0-1]*/
	else call cobol_gen_ioerror$finish_up (ft_ptr, ioerror_ptr);


	return;

EMIT_OP_91:
     proc;

/* [3.0-1] */
	call cobol_io_util$file_desc (file_table.file_desc_1_offset);
						/* [3.0-1] */
	call cobol_set_pr (pr5_struct_ptr, dn_ptr);	/* [3.0-1] */
	call cobol_call_op (91, alt_seek_tag);		/* OPERATOR91(alt_seek_key) */
						/* [3.0-1] */
	call cobol_gen_ioerror (ft_ptr, ioerror_ptr);	/* [3.0-1] */
	call cobol_define_tag (alt_seek_tag);		/* [3.0-1] */
	call cobol_set_fsbptr (ft_ptr);

     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.pt (1);
	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;
init_linage:
     proc;					/*[4.0-2]*/
						/*     This block of code was made into a subroutine in order to fix a bug in the
  write using a LINAGE clause.  This is the code genetated that assigns the new
  Page-Size, Footing-Size, and Bottom-Size  */

	if file_table.linage			/* LINAGE initialization */
	then do;
		call cobol_set_fsbptr (ft_ptr);

		skip_tag = cobol_$next_tag;
		cobol_$next_tag = cobol_$next_tag + 1;

		call cobol_ioop_util$bypass_reset (skip_tag);

		call cobol_read_rand (1, file_table.linage_info, linage_ptr);

		if linage_rec.body > 0
		then do;
			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);

		     end;
		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 do;
			if linage_rec.footing ^= 5
			then call linage_init (linage_rec.footing, 93 * 4);

			else do;

				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);

			     end;

		     end;
		else do;

			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);

		     end;

		if linage_rec.bottom > 0
		then do;
			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);

		     end;

		call cobol_define_tag (skip_tag);


	     end;

     end init_linage;

set_up:
     proc;

/*[4.4-1]*/
	if end_stmt.a = "010"b			/*[4.4-1]*/
	then do;
		end_stmt.c = "0"b;			/* write fn from dn (report) */
						/*[4.4-1]*/
		end_stmt.a = "001"b;		/*[4.4-1]*/
		dn_ptr = mp.pt (3);			/*[4.4-1]*/
		fn = mp.pt (2) -> fd_token.file_no;	/*[4.4-1]*/
		mp.pt (2) = mp.pt (3);		/*[4.4-1]*/
		var = "1"b;			/*[4.4-1]*/
	     end;					/*[4.4-1]*/
	else do;
		dn_ptr = mp.pt (2);			/*[4.4-1]*/
		fn = data_name.file_num;		/*[4.4-1]*/
		var = "0"b;			/*[4.4-1]*/
	     end;

     end;


%include cobol_write_gen_info;
%include cobol_write_gen_data;

declare	1 fd_token	based,
%include cobol_TYPE12;
     end cobol_write_gen;


*/
                                          -----------------------------------------------------------


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

*/
