


		    PNOTICE_sort.alm                02/14/84  0727.8r w 02/14/84  0727.7        3555


	dec	1			"version 1 structure
	dec	2			"no. of pnotices
	dec	3			"no. of STIs
	dec	156			"lgth of all pnotices + no. of pnotices
          acc       "Copyright, (C) Honeywell Information Systems Inc., 1982"
          acc       "Copyright (c) 1972 by Massachusetts Institute of
Technology and Honeywell Information Systems, Inc."

	aci	"W1SMGM0B0000"
	aci	"W2SMGM0B0000"
	aci	"W3SMGM0B0000"
	end
 



		    merge.pl1                       11/11/82  1552.0rew 11/11/82  1024.6       52245


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

/* Modified on 01/25/82 by FCH, [1], number of input files = 10 */

merge:  proc;

/*   EXTERNAL ENTRIES    */
dcl  clock_ entry returns(fixed bin(71));
dcl  com_err_  entry options(variable);
dcl  command_query_ entry options(variable);
dcl  cpu_time_and_paging_ entry(fixed bin, fixed bin(71), fixed bin);
dcl  cu_$arg_count entry(fixed bin),
     cu_$arg_list_ptr entry(ptr);
dcl  hcs_$get_process_usage entry(ptr, fixed bin(35));
dcl  hcs_$truncate_seg entry(ptr, fixed bin(24), fixed bin(35)),
     hcs_$delentry_seg entry(ptr, fixed bin(35)),
     hcs_$terminate_noname entry(ptr, fixed bin(35));
dcl  unique_chars_ entry(bit(*)) returns(char(15));

dcl  merge_$merge_private entry((*)char(*), char(*), (*)ptr, char(*), fixed bin(35));
dcl  sort_merge_command entry((*)char(*), char(*), (1)ptr, char(*), char(*), fixed bin(17),
		     bit(1), bit(1), bit(1), fixed bin(35), fixed bin(35),
		     float bin(27), fixed bin, ptr, ptr, ptr);
dcl  sort_merge_command_finish  entry(fixed bin(35), fixed bin(35), bit(1), bit(1));
dcl  sort_merge_sub_error  entry;

/*   EXTERNAL STATIC     */

%include sort_ext;
/*   INTERNAL STATIC (constants only)     */
dcl  pending_string char(120) varying init("Pending work in previous invocation of ^a will be lost if you proceed;
       do you wish to proceed?") internal static;
dcl (on init("1"b),
     off init("0"b) ) bit(1) internal static;

/*   AUTOMATIC AND BASED     */
%include sort_merge_pars;
dcl     output_file char(256),
     merge_desc(1)  ptr,
     temp_dir   char(168),
     user_out_sw_temp      char(8),
     merge_code   fixed bin(35),
     merge_order_temp  fixed bin(35),
     file_size_temp  float bin(27),
     string_size_temp  fixed bin(35);
dcl  input_file_temp(total_if_pns) char(256) based(addr(input_file));
dcl  arg_err_code  fixed bin(35);
dcl (perm_sd,
     temp_sd) ptr init(null());
dcl (fatal_sw,
     no_args_sw,
     arg_err_sw) bit(1);
dcl  total_if_pns  fixed bin(17);
dcl  total_args   fixed bin,
     arg_list_ptr ptr;

dcl 1 query_info aligned,
      2 version fixed bin init(2),
      2 yes_or_no_sw bit(1) unaligned,
      2 suppress_name_sw bit(1) aligned,
      2 status_code fixed bin(35),
      2 query_code fixed bin(35);
dcl  answer char(4) varying;

dcl  state_code  fixed bin(35);
dcl  hcs_code  fixed bin(35);

dcl  (sub_error_, cleanup) condition;


/*   Start.   */

     call state_test(state_code);		/*   Test state variable.   */
     if state_code ^= 0 then do;
	arg_err_sw = off;
	fatal_sw = on;
	call com_err_(0, "merge", " Merge will not be attempted.");
	return;		/*   to command level without resetting state variable   */
	end;
     etime(1) = clock_();
     call cpu_time_and_paging_(pf(1), vtime(1), pd_f(1));
     call hcs_$get_process_usage(addr(pu(1)), hcs_code);
     temp_sd,
     perm_sd = null();	/*   Used by cleanup proc   */
     debug_sw = off;	/*   used by cleanpp procedure   */
     on cleanup call cleanup_proc;
     on sub_error_ call sort_merge_sub_error;
     call cu_$arg_count(total_args);
/*   Get pointer to argument list, so that arguments may be obtained
     within any procedure via cu_$arg_ptr_rel   */
     call cu_$arg_list_ptr(arg_list_ptr);

     call sort_merge_command(input_file, output_file, merge_desc, temp_dir, user_out_sw_temp, total_if_pns,
			arg_err_sw, fatal_sw, no_args_sw, merge_order_temp, string_size_temp,
			file_size_temp, total_args, arg_list_ptr, perm_sd, temp_sd);

     if no_args_sw = on then go to exit;	/*   Prompting message printed by sort_merge_command.   */
     if arg_err_sw = on then merge_code = 1;
     /*   to ensure that merge_ will not attempt to execute merging process   */
     else merge_code = 0;
     if fatal_sw = off then		/*   go on if Merge Description is readable.   */
     call merge_$merge_private(input_file_temp, output_file, merge_desc, user_out_sw_temp, merge_code);

     call sort_merge_command_finish(arg_err_code, merge_code, arg_err_sw, fatal_sw);

exit:
     call cleanup_proc;
     state = 0;
     return;     /*  to command level   */

state_test: proc(state_code);		/*   Test state variable:   */
dcl  state_code fixed bin(35) parameter;
     if state = 0
	| (state = 8 & index(whoami, "_") ^= 0)		/*   Subroutine called last time   */
	then call set_state;
     else do;		/*   Error   */
	call query(pending_string);
	if answer = "no" then do;
	     state_code = 1;
	     return;
	     end;
	else call set_state;
	end;

set_state:  proc;
	whoami = "merge";
	state = 1;		/*   Set state variable.   */
	state_code = 0;
	unique_prefix = before(unique_chars_("0"b), " ")||".";	/*   Get unique string for temporary names.   */
end set_state;


end state_test;


query:  proc(string);		/*   Ask user about proceeding:   */
dcl  string char(*) varying parameter;
     yes_or_no_sw = on;
     suppress_name_sw = off;
     status_code, query_code = 0;
     call command_query_(addr(query_info), answer, "merge", string, whoami);
end query;


cleanup_proc:  proc;
dcl  code fixed bin(35);
     if debug_sw = off then do;
	if temp_sd ^= null() then call hcs_$delentry_seg(temp_sd, code);
	if perm_sd ^= null() then call hcs_$terminate_noname(perm_sd, code);
	end;
     else do;
	if temp_sd ^= null() then call hcs_$truncate_seg(temp_sd, 0, code);
	end;
     state = 0;
end cleanup_proc;


end merge;
   



		    merge_.alm                      11/11/82  1554.5rew 11/11/82  1030.3        7218


" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" * Copyright (c) 1972 by Massachusetts Institute of        *
" * Technology and Honeywell Information Systems, Inc.      *
" *                                                         *
" ***********************************************************
	name merge_

"macro which generates a call to an external entry point in sort_merge_

	macro	ext_transfer
	segdef	&1
&1:	getlp
	tra	&2

	&end

	ext_transfer	merge_,merge_merge$merge_merge
	ext_transfer	merge_private,merge_merge$merge_private
	ext_transfer	noexit,sort_merge_subroutine$noexit

	end merge_
  



		    merge_initiate.pl1              11/11/82  1552.0rew 11/11/82  1029.3       38016


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
%;
/* ***************************************
   *				 *
   *				 *
   * Copyright (c) 1975, 1976 by         *
   * Honeywell Information Systems, Inc. *
   *				 *
   *				 *
   *************************************** */
/*   ENTRY external to the Merge.
     Used by procedures which drive the Merge themselves.   */
/*   This entry is not supported presently.   */
initiate:	proc(keys_ptr, exits_ptr, user_out_sw_par, code);

/*   PARAMETERS   */
dcl (keys_ptr  ptr,			/*   Pointer to keys substructure  (Input)	   */
     exits_ptr ptr,			/*   Pointer to exits substructure  (Input)	   */
     user_out_sw_par    char(*), 	/*   Destination of Merge Report:  (Input)
				     ""       = normal (user_output);
				     "-bf"    = none (discard);
				     "<other>" = switchname.     */
     code      fixed bin(35)  	/*   Status code   		*/
    ) parameter;

/*   EXTERNAL ENTRIES     */
dcl  convert_status_code_  entry(fixed bin(35), char(8) aligned, char(100) aligned);
dcl  get_pdir_ entry returns(char(168) aligned);
dcl  hcs_$make_seg  entry(char(*) aligned, char(*) aligned, char(*), fixed bin(5), ptr, fixed bin(35));
dcl  ioa_$ioa_stream  entry options(variable);
dcl  unique_chars_ entry(bit(*)) returns(char(15));

dcl  sort_merge_initiate  entry(ptr, ptr, char(*), fixed bin(35));

/*   EXTERNAL STATIC     */

% include sort_ext;
dcl (error_table_$fatal_error,
     error_table_$out_of_sequence)  fixed bin(35) external static;

/*   INTERNAL STATIC  (constants only)   */
dcl (on bit(1) init("1"b),
     off bit(1) init("0"b) ) internal static;

/*   AUTOMATIC and BASED     */

dcl  state_code fixed bin(35);
dcl  keys_ptr_pass ptr,	/*   Arguments passed to sort_merge_initiate.   */
     exits_ptr_pass ptr,
     user_out_sw_pass char(32),
     s_m_init_code fixed bin(35);

dcl  hcs_code fixed bin(35),
     shortinfo char(8) aligned,
     longinfo char(100) aligned;


/*   Start.   */

     call state_test(state_code);
     if state_code ^= 0 then do;
	code = error_table_$out_of_sequence;
	go to exit;
	end;
     state = 3;
     if user_out_sw_par = "" then user_out_sw = "user_output";
     else if user_out_sw_par = "-bf" | user_out_sw_par = "-brief" then user_out_sw = "";
     else user_out_sw = user_out_sw_par;
     time_sw = off;		/*   Timing not specified.   */
     debug_sw = off;		/*   Debug option not specified.   */
     terminate_print_sw = on;		/*   merge_terminate should print Merge Report.   */

common_start:
     code = 0;
     disaster2 = 0;
     keys_ptr_pass = keys_ptr;
     exits_ptr_pass = exits_ptr;
     user_out_sw_pass = user_out_sw;
     s_m_init_code = 0;
     call sort_merge_initiate(keys_ptr_pass, exits_ptr_pass, user_out_sw_pass, s_m_init_code);

     call hcs_$make_seg(get_pdir_(), unique_prefix||"sort_work.SI", "",
		8+2,  /*  rw  */  sip, hcs_code);
     if hcs_code ^= 0 then do;
	call convert_status_code_(hcs_code, shortinfo, longinfo);
	if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
		"^A:  ^a  Unable to create temporary segment [pd]>^asort_work.SI",
		whoami, longinfo, unique_prefix);
	code = error_table_$fatal_error;
	end;

exit:
     if s_m_init_code ^= 0 then code = s_m_init_code;
     return;


/*   ENTRY internal to the Merge; called only by merge_ subroutine.   */
initiate_private:  entry(keys_ptr, exits_ptr, user_out_sw_par, code);
     /*   user_out_sw_par ignored; merge_ has already set user_out_sw properly.   */
     state = 3;
     terminate_print_sw = off;	/*   merge_ should print merge Report   */
     go to common_start;


state_test:  proc(state_code);
dcl  state_code fixed bin(35) parameter;
     if state = 0
	| (state = 8 & index(whoami, "_") ^= 0) 	/*   subroutine was called last   */
	then do;
	whoami = "merge_";
	unique_prefix = before(unique_chars_("0"b), " ")||".";
	state_code = 0;
	end;
     else do;		/*   Error   */
	state_code = 1;
	return;
	end;
end state_test;


end initiate;



		    merge_merge.pl1                 02/14/84  0729.1rew 02/14/84  0726.6       92556


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

merge_merge: proc(input_file, output_file, merge_desc,
	user_out_sw_par, merge_code);

/*   PARAMETERS   */
dcl (input_file(*) char(*),			/*   Input file pathnames or attach descriptions (Input).   */
     output_file char(*),			/*   Output file pathnames or attach description  (Input).   */
     merge_desc(*) ptr,			/*   Pointer to Merge Description (source form)  (Input).   */
     user_out_sw_par     char(*),		/*   Switchname for diagnostics and merge Report  (Input).   */
     merge_code  fixed bin(35) ) parameter;	/*   Status code  (Output).   */

/* Modified 12/01/83 by C Spitzer. change dcl of get_wdir_ so doesn't randomly fault. */

/*   EXTERNAL ENTRIES     */
dcl  clock_ entry returns(fixed bin(71));
dcl  convert_status_code_  entry(fixed bin(35), char(8) aligned, char(100) aligned);
dcl  cpu_time_and_paging_ entry(fixed bin, fixed bin(71), fixed bin);
dcl  get_pdir_  entry  returns(char(168) aligned);
dcl  hcs_$get_process_usage entry(ptr, fixed bin(35));
dcl  hcs_$make_seg  entry(char(*) aligned, char(*) aligned, char(*), fixed bin(5), ptr, fixed bin(35));
dcl  hcs_$truncate_seg entry(ptr, fixed bin(24), fixed bin(35)),
     hcs_$delentry_seg entry(ptr, fixed bin(35));
dcl  hmu entry;
dcl  ioa_$rsnnl  entry options(variable);
dcl  ioa_$ioa_stream  entry  options(variable);
dcl  sub_err_  entry options(variable);
dcl  translator_temp_$release_segment  entry(ptr, fixed bin(35));
dcl  unique_chars_ entry(bit(*)) returns(char(15));

dcl  merge_initiate$initiate_private entry(ptr, ptr, char(*), fixed bin(35));
dcl (sort_input_proc,
     merge_output_proc) entry(fixed bin(35));
dcl  sort_merge_terminate$terminate entry(fixed bin(35));
dcl  sort_cleanup_work entry;
dcl  sort_merge_subroutine  entry((*)char(*), char(*), (*)ptr, char(*),
			entry, entry, bit(1), bit(1),
			ptr, ptr,
			ptr, ptr);
dcl  sort_merge_print_report  entry;

/*   EXTERNAL STATIC     */

% include sort_ext;

dcl (error_table_$out_of_sequence,
     error_table_$fatal_error,
     error_table_$bad_arg) external static fixed bin(35);

/*   INTERNAL STATIC   (constants only)   */
dcl (on init("1"b),
     off init("0"b) ) bit(1) internal static;

/*   AUTOMATIC AND BASED   */
dcl  keys_ptr  ptr,
     exits_ptr  ptr,
     user_out_sw_temp char(32),
     code  fixed bin(35),
     file_size_temp  float bin(27),
     merge_order_temp  fixed bin(35),
     string_size_temp  fixed bin(35);

dcl (temp_sd_int,
     temp_sd_lex) ptr init(null());

dcl (sort_input_exit,
     sort_output_exit) entry(fixed bin(35)) variable;

dcl  state_code fixed bin(35);

dcl  arg_err_sw bit(1),
     fatal_sw bit(1);

dcl  j fixed bin(17);			/*   Used for do loop on input file names and attaches.   */
dcl  hcs_code fixed bin(35);

dcl  shortinfo char(8) aligned,
     longinfo  char(100) aligned;

dcl  retval  fixed bin(35);
dcl  cleanup  condition;

/*   Start.   */

     call state_test(state_code);		/*   Test state variable.   */
     if state_code ^= 0 then do;
	merge_code = error_table_$out_of_sequence;
	return;				/*   to caller without resetting state variable   */
	end;
     state = 2;
     time_sw = off;				/*   Timing not specified.   */
     debug_sw = off;			/*   Debug option not specified.  */
     arg_err_sw = off;			/*   Not done in common_start - see merge_private entry.   */
common_start:
     merge_code = 0;
     mii = dimension(input_file, 1);		/*   merge order = number of input files.   */
     sip = null();				/*   Used by sort_cleanup_work   */
     do j = 1 to mii + 1;			/*   extra location for pointer swapp9ng   */
	msp(j) = null();
	end;
     temp_sd_lex,
     temp_sd_int = null();			/*   used by cleanup procedure   */
     on cleanup call cleanup_proc;
     user_out_sw_temp = user_out_sw_par;	/*   Pass on.   */
     /*   temp_dir, file_size, string_size not used by merge.   */

     call sort_merge_subroutine(input_file, output_file, merge_desc, user_out_sw_temp,
			sort_input_exit, sort_output_exit, arg_err_sw, fatal_sw,
			keys_ptr, exits_ptr, temp_sd_lex, temp_sd_int);

     call create_in_buffs;			/*   uses mii for number of input files.   */

/*   Driver:   3 steps.   */
     /*   (1)  Initiate.   */
     if fatal_sw = off then
     call merge_initiate$initiate_private(keys_ptr, exits_ptr, user_out_sw_temp, code);
     if arg_err_sw = on | fatal_sw = on then do;
	merge_code = error_table_$bad_arg;
	go to exit;
	end;
     if code ^= 0 then do;
	if code = error_table_$out_of_sequence then  do;
	     call sub_err_(code, (whoami),  "c", null(), retval,
		"Calling merge_$initiate.");
	     merge_code = error_table_$fatal_error;
	     end;
	else merge_code = code;
	go to exit;
	end;

     if time_sw = on then do;		/*   End of Overhead phase (first part).   */
	etime(2) = clock_();
	call cpu_time_and_paging_(pf(2), vtime(2), pd_f(2));
	call hcs_$get_process_usage(addr(pu(2)), hcs_code);
	end;

     /*   No presort, beginning of merge phase.   */

     /*   Create arrays of input file names and attach descriptions.   */
     do j = 1 to mii;
	merge_input_file_names(j) = input_file(lbound(input_file, 1) + j - 1);
	call scan_for_pn_or_attach(merge_input_file_names(j), merge_input_file_attaches(j));
	end;
     if time_sw = on then do;
	etime(3) = clock_();
	call cpu_time_and_paging_(pf(3), vtime(3), pd_f(3));
	call hcs_$get_process_usage(addr(pu(3)), hcs_code);
	call hmu;
	end;
     state = 5;		/*   since there are no presort or commence calls   */

	/*   (2)  Call an output file procedure.   */
     if output_driver_is_sort = on then	/*   Call merge's output file procedure.   */
	do;
	/*   curr_output_file_name, curr_output_file_attach already set up by sort_merge_subroutine.   */
	call merge_output_proc(code);		
	if code ^= 0 then do;
	     if code ^= error_table_$fatal_error then do;
		call sub_err_(code, (whoami),  "c", null(), retval,
		"Merge's output_file procedure.");
		end;
	     merge_code = error_table_$fatal_error;
	     go to exit;
	     end;
	end;
     else do;			/*   Call user's output file procedure.   */
     /*   User output_file procedure currently not permitted for Merge.   */
	call sort_output_exit(code);		/*   User's output procedure.   */
	if code ^= 0 then do;
	     if code ^= error_table_$fatal_error
		then call sub_err_(code, (whoami),  "c", null(), retval,
		"User output_file exit procedure.");
	     merge_code = error_table_$fatal_error;
	     go to exit;
	     end;
	end;
     if time_sw = on then do;
	etime(4) = clock_();
	call cpu_time_and_paging_(pf(4), vtime(4), pd_f(4));
	call hcs_$get_process_usage(addr(pu(4)), hcs_code);
	end;

     /*   (3)  Terminate.   */
     call sort_merge_print_report;
     call sort_merge_terminate$terminate(code);
     if code ^= 0 then do;
	if code = error_table_$out_of_sequence then
		call sub_err_(code, (whoami),  "c", null(), retval,
		"Calling merge_$terminate.");
	merge_code = error_table_$fatal_error;
	end;
exit:
     call cleanup_proc;
     state = 8;
     return;	     /*   to caller of merge_     */


/*  ENTRY   merge_$merge_private  called only by merge command.   */
merge_private:  entry(input_file, output_file, merge_desc, user_out_sw_par, merge_code);
     state = 2;
     if merge_code ^= 0 then arg_err_sw = on;	/*   merge has encountered some error already   */
     else arg_err_sw = off;
     go to common_start;


state_test:  proc(state_code);		/*   Test state variable:   */
dcl  state_code fixed bin(35) parameter;
     if state = 0
	| (state = 8 & index(whoami, "_") ^= 0)		/*   Subroutine called last   */
	then do;
	whoami = "merge_";
	unique_prefix = before(unique_chars_("0"b), " ")||".";	/*   Get unique character string.   */
	state_code = 0;
	end;
     else do;
	state_code = 1;
	return;
	end;
end state_test;


scan_for_pn_or_attach:  proc(name, attach);
dcl (name  char(*),
     attach  char(*) ) parameter;
dcl  (j, k) fixed bin(17);
     k = 1;
     do while(substr(name, k, 1) = " " & k < length(name));
	k = k + 1;
	end;
     j = k;
     do while(substr(name, k, 1) ^= " " & k < length(name));
	k = k + 1;
	end;
     do while(substr(name, k, 1) = " " & k < length(name));
	k = k + 1;
	end;
     if substr(name, j, 4) = "-if " | substr(name, j, 12) = "-input_file " then do;
	name = substr(name, k);
	attach = "";
	end;
     else if substr(name, j, 5) = "-ids " | substr(name, j, 19) = "-input_description " then do;
	attach = substr(name, k);
	end;
end scan_for_pn_or_attach;


create_in_buffs:  proc;
dcl  i fixed bin;
dcl  number char(2) varying;
dcl  S  char(16) aligned based;
dcl  ioa_len fixed bin;
     do i = 1 to mii+1;   /*  extra segment for reading next input record without destroying previous merge winner*/
	call ioa_$rsnnl("^d", number, ioa_len, i);
	call hcs_$make_seg(get_pdir_(), unique_prefix||"sort_in_buff_"||number||"_", "",
		8+2,  /*  rw  */  msp(i), hcs_code);
	if msp(i) = null() then do;
	     arg_err_sw = on;
	     call convert_status_code_(hcs_code, shortinfo, longinfo);
	     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
		"^a:  ^a  Unable to create temporary segment [pd]>^asort_in_buff_^a_",
		whoami, longinfo, unique_prefix, number);
	     return;
	     end;
	msp(i) = addr(substr(msp(i)->S, 9));		/*   Leave space for record length prior to record.  */
	end;		/*   of do for all input files  (mii)   */
end create_in_buffs;


cleanup_proc:  proc;
dcl  code fixed bin(35);
     if debug_sw = off then do;
	if temp_sd_lex ^= null() then call translator_temp_$release_segment(temp_sd_lex, code);
	if temp_sd_int ^= null() then call hcs_$delentry_seg(temp_sd_int, code);
	end;
     else do;
	if temp_sd_lex ^= null() then call hcs_$truncate_seg(temp_sd_lex, 0, code);
	if temp_sd_int ^= null() then call hcs_$truncate_seg(temp_sd_int, 0, code);
	end;
     call sort_cleanup_work;
     state = 8;
end cleanup_proc;


end merge_merge;



		    merge_output_proc.pl1           11/11/82  1552.0rew 11/11/82  1029.3       51597


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
%;
/* ***************************************
   *				 *
   *				 *
   * Copyright (c) 1975, 1976 by         *
   * Honeywell Information Systems, Inc. *
   *				 *
   *				 *
   *************************************** */
merge_output_proc:  proc(output_proc_code);

/*   EXTERNAL ENTRIES   */

dcl  iox_$attach_ioname entry(char(*), ptr, char(*), fixed bin(35));
dcl  iox_$open entry(ptr, fixed bin, bit(1) aligned, fixed bin(35));
dcl  iox_$write_record entry(ptr, ptr, fixed bin(21), fixed bin(35));
dcl  iox_$close entry(ptr, fixed bin(35));
dcl  iox_$detach_iocb entry(ptr, fixed bin(35));
dcl  iox_$destroy_iocb entry(ptr, fixed bin(35));
dcl  sub_err_  entry options(variable);

dcl  merge_return$return  entry(ptr, fixed bin(21), fixed bin(35));

/*   EXTERNAL STATIC   */

%include sort_ext;

dcl (error_table_$not_detached,
     error_table_$not_attached,
     error_table_$not_closed,
     error_table_$end_of_info,
     error_table_$data_loss,
     error_table_$data_gain,
     error_table_$data_seq_error,
     error_table_$not_open,
     error_table_$fatal_error) fixed bin(35) external static;

/*   PARAMETERS AND AUTOMATIC     */
dcl  output_proc_code fixed bin(35) parameter;

dcl  out_attach_desc char(176),
     out_iocb_ptr ptr,
     iox_code fixed bin(35),
     out_mode fixed bin,
     seq_output fixed bin init(5),
     no_extend bit(1) aligned init("0"b),
     sort_code fixed bin(35),
     out_buff_ptr ptr,
     out_rec_len fixed bin(21),
     out_buff_len fixed bin(21) init(32768);
dcl  data_gain_sw bit(1) init("0"b);
	dcl	i fixed bin(21);

dcl  retval  fixed bin(35);
dcl  cleanup condition;

/*   Start.   */
     output_proc_code=0;
     do i=1 to mii;    /*  for cleanup work  */
	merge_in_iocb_ptrs(i)=null();
     end;
     out_iocb_ptr = null();
     on cleanup call cleanup_proc;
/*   Attach.   */
     if curr_output_file_attach = "" then out_attach_desc = "vfile_ "||curr_output_file_name;
     else out_attach_desc = curr_output_file_attach;
/*   without extend   */
     call iox_$attach_ioname(unique_prefix||"sort_out_1_", out_iocb_ptr, out_attach_desc, iox_code);
     if iox_code ^= 0 then
	do;
	/*   error_table_$not_detached   */
	call iox_error("Attaching");
	end;

/*   Open.   */
     out_mode = seq_output;
     call iox_$open(out_iocb_ptr, out_mode, no_extend, iox_code);
     if iox_code ^= 0 then
	do;
	/*   error_table_$not_attached,
	                 $not_closed     */
	call iox_error("Opening");
	end;

/*   Retrieve and write.   */
retrieve:  call merge_return$return(out_buff_ptr, out_rec_len, sort_code);
     if sort_code = error_table_$end_of_info then
     go to close;
     if sort_code ^= 0 then
	do;
	/*   merge_$return errors   */
	if sort_code = error_table_$data_loss then do;
	     call sub_err_(sort_code, (whoami), "c", null(), retval, "");
	     go to close;
	     end;
	else if sort_code = error_table_$data_gain then do;
	     if data_gain_sw = "0"b then call sub_err_(sort_code, (whoami), "c", null(), retval, "");
	     data_gain_sw = "1"b;
	     end;
	else if sort_code = error_table_$data_seq_error then do;
	     if curr_output_file_attach = "" then
	     call sub_err_(sort_code, (whoami), "c", null(), retval,
		" Record ^d of output file, file name ^a",
			write_count + 1, curr_output_file_name);
	     else call sub_err_(sort_code, (whoami), "c", null(), retval,
		" Record ^d of output file, attach description ^a",
			write_count + 1, curr_output_file_attach);
	     end;
	else do;		/*  error_table$out_of_sequence (call), error_table_$fatal_error   */
	     output_proc_code = sort_code;
	     call cleanup_proc;
	     go to exit;
	     end;
	end;
     call iox_$write_record(out_iocb_ptr, out_buff_ptr, out_rec_len, iox_code);
     if iox_code ^= 0 then
	do;
	/*  no errors returned?   */
	call iox_error("Writing");
	end;
     write_count = write_count + 1;
     go to retrieve;

/*   Close.   */
close:  call iox_$close(out_iocb_ptr, iox_code);
     if iox_code ^= 0 then
	do;
	/*   error_table_$not_open   */
	call iox_error("Closing");
	end;

/*   Detach.   */
     call iox_$detach_iocb(out_iocb_ptr, iox_code);
     if iox_code ^= 0 then
	do;
	/*   error_table_$not_attached,
		       $not_closed     */
	call iox_error("Detaching");
	end;

/*   Destroy iocb.   */
     call iox_$destroy_iocb(out_iocb_ptr, iox_code);
     out_iocb_ptr = null();
     /*  no errors returned?   */
exit:
     return;		/*   to driver   */


iox_error:  proc(action);
dcl  action char(*) parameter;
     output_proc_code = error_table_$fatal_error;
     if curr_output_file_attach = "" then
	call sub_err_(iox_code, (whoami), "c", null(), retval,
		" ^a output file, file name ^a", 
		action, curr_output_file_name);
     else
	call sub_err_(iox_code, (whoami), "c", null(), retval,
		" ^a output file, attach description ^a",
		action, curr_output_file_attach);
     call cleanup_proc;
     go to exit;
end iox_error;


cleanup_proc:  proc;
     if out_iocb_ptr ^= null() then 
     do;
     call iox_$close(out_iocb_ptr, iox_code);
     call iox_$detach_iocb(out_iocb_ptr, iox_code);
     call iox_$destroy_iocb(out_iocb_ptr, iox_code);
     end;
     do i = 1 to mii;
	if merge_in_iocb_ptrs(i)^=null() then 
	do;
	call iox_$close(merge_in_iocb_ptrs(i),iox_code);
	call iox_$detach_iocb(merge_in_iocb_ptrs(i),iox_code);
	call iox_$destroy_iocb(merge_in_iocb_ptrs(i),iox_code);
	end;
     end;
end cleanup_proc;


end merge_output_proc;
   



		    merge_return.pl1                11/11/82  1552.0rew 11/11/82  1024.6      262791


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

/* Modified on 01/25/82 by FCH, [1], delete variable initial list */

  return:  proc(retp,retbl,ec);
			/*    EXTERNAL ENTRIES    */
			/*    EXTERNAL STATIC    */

%include sort_ext;
	dcl	error_table_$data_gain fixed bin(35) ext,
		error_table_$data_loss fixed bin(35) ext,
		error_table_$out_of_sequence fixed bin(35) ext,
		error_table_$data_seq_error fixed bin(35) ext,
		error_table_$end_of_info fixed bin(35) ext,
		error_table_$long_record fixed bin(35) ext,
		error_table_$short_record fixed bin(35) ext,
		error_table_$fatal_error fixed bin(35) ext,
		error_table_$request_not_recognized fixed bin(35) ext,
		error_table_$improper_data_format fixed bin(35) ext;
			/*  PARAMETERS,AUTOMATIC, & BASED  */
	dcl merge_read_count(10) fixed bin(30) int static;  /*  read count of  each file  */
	dcl	(retp ptr,
		retbl fixed bin(21)) parameter;
	dcl
		(ns,np) fixed bin(30) int static,
		s(36) static,
		retfb fixed bin(30);
	dcl	i1 fixed bin(30);
	dcl	1 IN(127 * 1024) based,
		   2 ctr fixed bin(30),  /*  serial record count  */
		   2 by_off fixed bin(30);  /*  byte offset of current record  */
	dcl	(t,n,v1,v2,l,x,j,y,lft,rit,i) fixed bin(30) int static;
%include sort_common;

dcl  retval  fixed bin(35);
		       /*  following declarations are for output  record  exit  */
	dcl	hold_ptr ptr int static,
		hold_len fixed bin(21) int  static,
		s_retp ptr int static,
		s_retbl fixed bin(21) int static,
		rec_ptr_2 ptr int static,		/*  next record pointer  */
		rec_len_2 fixed bin(21) int static,	/*  next record length  */
		u_rec_ptr_2 ptr int static,  /*  rec_ptr_2 handed to the user  */
		u_rec_len_2 fixed bin(21) int static,  /*  rec_len_2 handed to the user  */
		action fixed bin int static,	/*  action code  */
		equal_key fixed bin(1) int  static,
		seq_check_sw bit(1) int static,
		close_exit_sw bit(1) int static,
		cur_rec_ptr ptr int static,		/*  current record pointer  */
		area_len fixed  bin(21)  int static,	/*  current  record length  */
		equal_key_sw bit(1) int static,
		old_retp ptr int static;		/*  old retp  pointer  */
	dcl	old_rec_ptr ptr int static;    /*  previous record for sequence checker  */
	       /*  Following inserted for merge   	*/
	dcl	in_attach_desc char(176),
		in_switch char(32),
		in_switch_length fixed bin(17),
		iox_code fixed bin(35),
		in_mode fixed bin init(4),
		no_extend bit(1) aligned init("0"b);
	dcl	input_file_len(10) fixed bin(21) int static,    /*  record length of each file  */
/*1*/		in_buff_len fixed bin(21) ;
	dcl	hold_cur_rec_ptr ptr int static,  /*  hold ptr to current record in sort's area  */
		hold_area_len fixed bin(17) int static;  /*  hold length of current record */
dcl  iox_$attach_ioname entry(char(*), ptr, char(*), fixed bin(35));
dcl  iox_$open entry(ptr, fixed bin, bit(1) aligned, fixed bin(35));
dcl  iox_$read_record entry(ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35));
dcl  iox_$close entry(ptr, fixed bin(35));
dcl  iox_$detach_iocb entry(ptr, fixed bin(35));
dcl  iox_$destroy_iocb entry(ptr, fixed bin(35));

dcl  establish_cleanup_proc_  entry(entry);
dcl  sub_err_ entry options(variable);
dcl  ioa_$rsnnl entry options(variable);

/*1*/	in_buff_len = max_rec_length;			/* maximum record length */
	ec = 0;     /*  initially set error code  */
		/*  test state code  */
	if state ^= 5 then    /*  sequence error  */
	    do;
		ec = error_table_$out_of_sequence;
		return;
	    end;
	on illegal_procedure call illegal_procedure_handler;
	if disaster2 = 0 then do;			/* Initial  call to RETURN. */
	     disaster2 = 1;
	    old_rec_ptr=null();  /*  set initially for sequence check previous record  */
			/*  following set for output record exit  */
	    equal_key_sw="0"b;
	    equal_key=1;
	    seq_check_sw="1"b;
	    action=10;
	     if mii = 0 then
		do;    /*  no records released  */
		 ec = error_table_$end_of_info;
		 if output_record_exit_sw = 0 then return;
		 else do;   /*  prepare to take exit  */
		        retp=null();
		        go to in;
		 end;
		end;
	     call A0;
	     return_count = return_count + 1;
	     go to rel_ck;
	end;

 g_a_w:	    if output_record_exit_sw ^= 0 & action = 3 | action = 11 then
		do;  /*  output rec sw on and just completed  inserting a record  */
		 if old_retp  =  rec_ptr_b  /*  just returned  current was in rec_ptr_b  */
		   then cur_rec_ptr=rec_ptr_a;  /*  set new current  area to rec_ptr_a  */
		   else cur_rec_ptr=rec_ptr_b;  /*  just  returned current was in rec_ptr_1-
					    set new current area to  rec_ptr_b    	*/
		 substr(cur_rec_ptr->S,1,u_rec_len_2)=substr(u_rec_ptr_2->S,1,u_rec_len_2);
		 area_len=u_rec_len_2;  /*  move just inserted record into current area  */
		 if action=11 then ec=error_table_$end_of_info;
		    /* just inserted a record at end of file-reset ec  */
		 rec_ptr_2=hold_ptr;  /*  move previous  next record into current next  */
		 rec_len_2=hold_len;
		 old_rec_ptr=msp(v1);  /*  save winner area ptr  */
		 msp(v1)=msp(mii+1);  /*  replace winner ptr with spare ptr  */
		 msp(mii+1)=old_rec_ptr;  /*  replace spare ptr with winner ptr  */
		 output_rec_inserted=output_rec_inserted+1;
		 go to in;  /*  transfer to  point where  exit routine is called-after determining new  winner*/
		end;
	if output_record_exit_sw^=0 & action=error_table_$end_of_info
		then go to in;  /*  just wrote last record  */
	if mii=1 then
	    do;    /*   single merge input file  */
	        /*  read another record from winner merge file  */
	     call iox_$read_record(merge_in_iocb_ptrs(1),msp(1),in_buff_len,input_file_len(1),iox_code);
	     if iox_code = error_table_$end_of_info then    /*  end_of file-  */
		do;    /*  end of file, close-detach-destroy iocb ponter  */
		/*   Close		*/
                  close:  call iox_$close(merge_in_iocb_ptrs(1), iox_code);
                        if iox_code ^= 0 then
	                   do;
	/*   error_table_$not_open   */
		         call iox_error("Closing",1);
	                   end;

		/*    Detach   */
                        call iox_$detach_iocb(merge_in_iocb_ptrs(1), iox_code);
                        if iox_code ^= 0 then
	                   do;
	/*   error_table_$not_attached,
		       $not_closed     */
	                   call iox_error("Detaching",1);
	                   end;

		/*  Destroy iocb  */
                        call iox_$destroy_iocb(merge_in_iocb_ptrs(1), iox_code);
                        merge_in_iocb_ptrs(1) = null();
     /*  no errors returned?   */
		    ec=error_table_$end_of_info;
		    read_count=merge_read_count(1);  /*  set read count  */
		    goto rel_ck;
		end;
	     else if iox_code ^= 0 then
		call iox_error("Reading",1);
	     else do;  /*  record successfully read  */
		merge_read_count(1)=merge_read_count(1)+1;  /*  increment read count  */
		release_count=release_count+1;
	          w_p=ptr(msp(1),fixed(rel(msp(1)),21)-1);  /*  move back 1 word
					to set length    */
	          fb=input_file_len(1);
		retbl=fb;    /*  set winner length  */
		retp=msp(1);    /*  set return pointer to record(winner) just read  */
		end;
	    return_count=return_count+1;
	    go to rel_ck;
	end;

/* Multiple merge strings. */
	call A2;
	call A1;
	return_count = return_count + 1;
 rel_ck:  if release_count < return_count then
	    do;    /*  data gain test  */
	      if ec=error_table_$end_of_info then return;  /*  already at end of info  */
	      ec=error_table_$data_gain;
	      return;
	    end;
 in:;
		    /*  following code is for output record  exit routine  */
	    if output_record_exit_sw ^= 0 then
		do;	/*  take output record exit  */
		    if action = error_table_$end_of_info then
			do;    /*  just wrote   last record  */
			   ec=error_table_$end_of_info;  /*  reset  error code  */
			   return;
			end;
		    if action ^= 3 then
		      do;    /*  just got winner record  */
		             /*  save winner record pointer  */
		        s_retp=retp;
	  	        s_retbl=retbl;
		      end;
		    if action=10 then
		      do;  /*  indicating first time through-no curent record,no previously
			   written record							*/
		        rec_ptr_2=retp;  /*  set up next record-to  winner  */
	    	        rec_len_2=retbl;
		        cur_rec_ptr=null();  /*  set current record ptr to null */
 ent:		        action=0;
		        if ec=error_table_$end_of_info then rec_ptr_2=null();
			/*  deleted every successive record of the file  */
		        u_rec_ptr_2=rec_ptr_2;  /*  set user's next pointer and next length  */
		        u_rec_len_2=rec_len_2;
		        if close_exit_sw="0"b then
		        call  sort_output_record_exit(cur_rec_ptr,area_len,u_rec_ptr_2,u_rec_len_2,
				action,equal_key,equal_key_sw,seq_check_sw,close_exit_sw);
		        old_retp=null();  /*  to indicate,next time through,that there is no previous record-
				       therefore no sequence check				*/
		        if action=3 then
			do;  /*  insert record at beginning of  file  */
			 call ck_len(u_rec_len_2,"inserted");  /*  check returned record length  */
			 cur_rec_ptr=rec_ptr_b;  /*  arbitrarily set to b  */
			 substr(cur_rec_ptr->S,1,u_rec_len_2)=substr(u_rec_ptr_2->S,1,u_rec_len_2);
				/*  set up current record  */
		 	 area_len=u_rec_len_2;
			 rec_ptr_2=retp;  /*  reset next reocrd to same-previous next record  */
		 	 rec_len_2=retbl;
			 output_rec_inserted=output_rec_inserted+1;
			 go to in;    /*  don't write current record-rather go back & call exit */
			end;
		        if ec = error_table_$end_of_info then action=ec;
			/*  deleted the entire file  */
		        msp(v1)=msp(mii+1);  /*  replace winner buffer pointer  */
		        msp(mii+1)=retp;  /*  replace spare buffer ptr with winner ptr  */
	   	        go to g_a_w;
		      end;
		    if action= 0 then
		      do;    /*  just completed accepting record  */
		        if old_retp=rec_ptr_b    /*  just returned current was in rec_ptr_b  */
			then cur_rec_ptr=rec_ptr_a;  /*  set new current area  to rec_ptr_a  */
			else cur_rec_ptr=rec_ptr_b;  /*  set new current area  to rec_ptr_b   */
		        substr(cur_rec_ptr->S,1,rec_len_2)=substr(rec_ptr_2->S,1,rec_len_2);
				/*  move previous next record into current  area  */
		        area_len=rec_len_2;
		        rec_ptr_2=retp;    /*  set up new  next record   */
		        rec_len_2=retbl;
		      end;
		    else if action=1 then
		      do;    /*  just  completed deleting the current record  */
		        substr(cur_rec_ptr->S,1,rec_len_2)=substr(rec_ptr_2->S,1,rec_len_2);
				/*  move old next record into current record  area  */
		        area_len=rec_len_2;
		        rec_ptr_2=retp;    /*   set up new next  record  */
		        rec_len_2=retbl;
		        output_rec_deleted=output_rec_deleted+1;
		      end;
		    else if action=2 then
		      do;  /*  just completed deleting next record-leave old current record alone  */
		        rec_ptr_2=retp;    /*  set up new next record  */
		        rec_len_2=retbl;
		        output_rec_deleted=output_rec_deleted+1;
		        if cur_rec_ptr=null() then go to ent;  /*  just deleted first record(of the file) */
		      end;
		    else if ^(action=11 | action=3) then
		      do;    /*  illegal action code  */
		        call sub_err_(error_table_$request_not_recognized,whoami, "c", null(), retval,
			     "Invalid action = ^d by user output_record exit procedure.",action );
		        ec=error_table_$fatal_error;
		        goto exit;
		      end;
		    action=0;  /*  set here in  case close exit is on  */
		    if close_exit_sw="1"b then go to sim;     /*  close  exit  switch is  on  */
		    if ec=error_table_$end_of_info then rec_ptr_2=null();  /*  no next rec-end of info */
		    if equal_key_sw="1"b then  /*  equal key swtich on  */
		      do;    /*  check for equal keys between current and next  */
		        pt1=cur_rec_ptr;  /*   current record  */
		        pt2=rec_ptr_2;  /*  next record  */
		        if pt1^=null() & pt2^= null() then
		        call sort_comp;  /*  invoke sort's comparison routine  */
		        equal_key=result;
		      end;
		    u_rec_ptr_2=rec_ptr_2;  /*  set user's next pointer and next length  */
		    u_rec_len_2=rec_len_2;
		    hold_cur_rec_ptr=cur_rec_ptr;  /*  save pointer to current record  */
		    hold_area_len=area_len;  /*  dave length of current record  */
		    call sort_output_record_exit(cur_rec_ptr,area_len,u_rec_ptr_2,u_rec_len_2,
					action,equal_key,equal_key_sw,seq_check_sw,close_exit_sw);
	 	    if action ^= 1 & cur_rec_ptr ^= hold_cur_rec_ptr then
			do;  /*  move record pointed to by user ptr into sort's area  */
		   	   substr(hold_cur_rec_ptr->S,1,area_len)=substr(cur_rec_ptr->S,1,area_len);
		   	   cur_rec_ptr=hold_cur_rec_ptr;  /*  restore cur_rec_ptr to user area  */
			end;
		    if action=1 | action=2 then
		      do;    /*  delete current or next record  */
		             /*  don't return a record back to sort_output  */
			   /*  rather go back and get anther  winner  */
			   /*  don't perform sequence  check  */
		        if ec=error_table_$end_of_info then   /*  no more records-simply   */
			do;    /*  return after incrementing deletion count  */
		   	   output_rec_deleted=output_rec_deleted+1;
			   return;
			end;
		        if action=1 then
			do;    /*  deleting current record  */
			   msp(v1)=msp(mii+1);  /*  replace winner buffer ptr with spare ptr  */
			   msp(mii+1)=rec_ptr_2;  /*  preserve next record pointer  */
		   	   cur_rec_ptr=hold_cur_rec_ptr;  /*  restore held value of cur_rec_ptr  */
			   area_len=hold_area_len;    /*  restore area len  */
			end;
		        if action=2 then call ck_len(area_len,"summarized");  /*  check returned current record len  */
		        goto g_a_w;   /*  transfer  to  get another  winner  */
		      end;
 sim:		    if action=0 then
		      do;  /*  accept current record  */
		        call ck_len(area_len,"altered");  /*  check returned current rec length  */
		        retp=cur_rec_ptr;  /*  set record return pointer to current record  */
		        retbl=area_len;
		      end;
		    else if action=3 then
		      do;  /*  insert record pointed to by rec_ptr_2-next record  */
		        call ck_len(u_rec_len_2,"inserted");  /*  check length of record to be inserted  */
		        call ck_len(area_len,"altered");    /*  check returned current record length  */
		        hold_ptr=s_retp;  /*  save old next pointer  */
		        hold_len=s_retbl;
		        retp=cur_rec_ptr;  /*  set return record to current record  */
		        retbl=area_len;
		      end;
	     	    else
		      do;    /*  illegal action code  */
		        call sub_err_(error_table_$request_not_recognized,whoami, "c", null(), retval,
			     "Invalid action = ^d by user output_record exit procedure.",action);
		        ec=error_table_$fatal_error;
		        goto exit;
		      end;
		    if ec=error_table_$end_of_info then
		      do;     /*  no more records to be read  */
		        if action ^= 3 then
			do;    /*  no record to be inserted  */
		     	   ec=0;  /*  reset ec so that sort_output will write record  */
				/*  retp should already be set  */
		  	   action=error_table_$end_of_info;  /*  set to indicate,on next time
						through, no records left  		*/
			end;
			else do;  /*  insert record at end of file-in rec_ptr_2  */
				/*  action=s 3  */
			   ec=0;  /*  reset so that sort_output will write current record  */
			   action=11;  /*  indicating no more records to be read  */
			end;
		        v1=mii;  /*  in case of multiple merge strings-an extra pass will be made
				through A2 and A!			*/
		      end;
		    if seq_check_sw="1"b & old_retp^=null() then
		/*  seq bit on and a previously written record  */
		      do;  /*  perform  sequence check-between current and record previously written-
			 cur_rec_ptr and rec_ptr_a or rec_ptr_b				    */
		        if retp=rec_ptr_a
			then pt1=rec_ptr_b;  /*  previous record is in rec_ptr_b  */
			else  pt1=rec_ptr_a;  /*  previous  record is in  rec_ptr_a  */
		        pt2=retp;    /*  current record  */
		        call sort_comp;
		        if result= 1 then ec=error_table_$data_seq_error;  /*  out of sequence-fatal  error  */
		      end;
		    old_rec_ptr=msp(v1);  /*  temporarily save winner ptr  */
		    msp(v1)=msp(mii+1);  /*  replace winner buffer pointer with spare  */
		    msp(mii+1)=old_rec_ptr;  /*  replace spare ptr with winner ptr  */
 con:		    old_retp=retp;    /*  set so that,on next time through,can distinguish which
				   record pointer was used			*/
		    return;
		end;    /*  end sort output record exit code  */
	    if return_count=0 then return;  /*  null output file-no sequence check  */
			/*  following is sequence checker   	*/
	    if return_count=1 | ec=error_table_$end_of_info then
		do;	/*  set up initially for sequence check  */
		   msp(v1)=msp(mii+1);    /*  replace winner buffer pointer with extra buffer ptr  */
		   msp(mii+1)=retp;  /*  replace miith ptr with winner area pointer  */
		end;
		else do;
		   pt1=msp(mii+1);    /*  set previous record pointer  */
		   pt2=retp;         /*  set current record pointer  */
		   call sort_comp;     /*  perform sequence check  */
		   if result=1 then ec=error_table_$data_seq_error;  /*  sequence error  */
		   msp(v1)=msp(mii+1);/*  replace winner buffer pointer  */
		   msp(mii+1)=retp;  /*  replace miith ptr with winner area ptr  */
		end;
 exit:	return;

A0:	proc;
	    if mii=1 then    /*  single merge input file  */
	      do;
		call init_return;    /*  get first winner  */
		if merge_read_count(1)=0 then    /*  a single null input file  */
		   do;
		    ec=error_table_$end_of_info;
		    goto rel_ck;
		   end;
		retp=msp(1);    /*  set winner pointer  */
		retbl=fb;    /*   set winner length  */
		v1=1;	/*  set for use in sequence checker  */
		return;
	      end;

	     do i = 1 to mii;			/* Set indices for merge. */
		sip -> I (i) = i;			/*  sets ups I array  */
	     end;

/*
   calculate the lengths of
   lists and their start pointers
   in a linear set.
   */
	     t = 0;
	     l = mii;				/*  number of merge srings  */
	     do n = 1 by 1 while (l>1);
		s (n) = t;			/* start of the next list. */
		if substr(unspec(l),36,1) then
		   do;  /*    l odd  */
		     l = l+1;  /*  make the length even  */
		     sip->I(t+l) = 0;  /*  clear 2nd word of pair if l was odd  */
		   end;
		t = t+l;				/* accumulate the lengths. */
		l = divide(l,2,24);
	     end;
	     n = n-1;
	     call init_return;  /*  call. proc which will read first record of each merge file,
		       	    along with firstly attaching,opening, etc.  */

/* Set s(n) to (one more than) the index to the list
   for the final 2 records to be compared. */
/*  below rearranges I array to reflect sorted records(the first record of each merge
   string being looked at)				*/
	     do i = 2 to n;
		lft = s (i-1);
		rit = s (i) ;
		do j = 1 by 2 to (rit - lft);
		     x = lft+j;
		     v1 = sip -> I (x);		/*  indices in I(sip)  */
		     v2 = sip -> I (x+1);
		     if v1=0 then v1=v2;    /*  no first record  */
		     else if v2>0 then
			do;
			   pt1=msp(v1);
			   pt2=msp(v2);
			   call sort_comp;
			   compares_counter=compares_counter+1;
			   if result=0 then    /*  rec0rds ranked equal  */
			      do;
				if v1<v2   /*  compares input order  */
		    		   then result=-1;  /*  rank record 1 first  */
				   else result=1;   /*  rank record 2 first  */
			      end;
			   if result=1 then v1=v2;  /*  record 2 ranks first-switch order  */
			end;
		     rit=rit+1;
		     sip->I(rit)=v1;
		end;
	     end;
	     i = s (n)+2;

	     y = s (n)+1;
	     call A1;
	     return;
   init_return:	proc;
	dcl	i fixed bin(30);

	     do i = 1 to mii;
		merge_read_count(i)=0;  /*  initialize read count for ith file  */
		call ioa_$rsnnl(unique_prefix || "sort_in_^d_",in_switch,in_switch_length,i);
			/*  converts from fixed bin to character srtring  */
		if merge_input_file_attaches(i) = ""
		    then in_attach_desc="vfile_ "||merge_input_file_names(i);
		    else in_attach_desc=merge_input_file_attaches(i);
		call iox_$attach_ioname(in_switch,merge_in_iocb_ptrs(i),in_attach_desc,iox_code);
		if iox_code ^= 0 then
		    call iox_error("Attaching",i);
		call iox_$open(merge_in_iocb_ptrs(i),in_mode,no_extend,iox_code);
		if iox_code ^= 0 then
		    call iox_error("Opening",i);
		        /*  read in first record of each file  */
		call iox_$read_record(merge_in_iocb_ptrs(i),msp(i),in_buff_len,
				     input_file_len(i),iox_code);
	     if iox_code = error_table_$end_of_info then    /*  end_of file-  */
		do;    /*  end of file, close-detach-destroy iocb ponter  */
		/*   Close		*/
                  close:  call iox_$close(merge_in_iocb_ptrs(i), iox_code);
                        if iox_code ^= 0 then
	                   do;
	/*   error_table_$not_open   */
	                   call iox_error("Closing",i);
	                   end;

		/*    Detach   */
                        call iox_$detach_iocb(merge_in_iocb_ptrs(i), iox_code);
                        if iox_code ^= 0 then
	                   do;
	/*   error_table_$not_attached,
		       $not_closed     */
	                   call iox_error("Detaching",i);
	                   end;

		/*  Destroy iocb  */
                        call iox_$destroy_iocb(merge_in_iocb_ptrs(i), iox_code);
                        merge_in_iocb_ptrs(i) = null();
     /*  no errors returned?   */
		    sip->I(i) = 0;
		    goto con;
		end;
		if iox_code ^= 0 then
		    call iox_error("Reading",i);
		if input_file_len(i)>max_rec_length then iox_code=error_table_$long_record;
		else if input_file_len(i)<min_rec_length then iox_code=error_table_$short_record;
		if iox_code^=0 then    /*  long or short record  */
		   do;
		    if merge_input_file_attaches(i)="" then
		       call sub_err_(iox_code,whoami, "c", null(), retval,
			     "Record ^d of input_file ^d,file name ^a",
			     merge_read_count(i),i,merge_input_file_names(i));
		       else call sub_err_(iox_code,whoami, "c", null(), retval,
			     "Record ^d of input file ^d,attach description ^a",
			     merge_read_count(i),i,merge_input_file_attaches(i));
		       iox_code=0;
		       ec=error_table_$fatal_error;
		       go to exit;
		   end;
		merge_read_count(i)=1;  /*  read 1st record of ith file  */
		release_count=release_count+1;
		w_p = ptr(msp(i),fixed(rel(msp(i)),21)-1);  /*  move back 1 word
						to set length  */
		fb = input_file_len(i);
   con:	    end;
	end init_return;
	end A0;

A1:	proc;
						/* Obtain the next record to output. */
	     v1 = sip -> I (y);
	     v2 = sip -> I (y+1);
	     if v1 ^= 0 then;
		else if v2 ^= 0 then;
		else do;
		    /*  data lost test  */
		if release_count > return_count
		    then ec = error_table_$data_loss;
		    else
		ec = error_table_$end_of_info;
		return_count=return_count-1;    /*  pre-adjust return_count  */
		do i=1 to mii;
		   read_count=merge_read_count(i)+read_count;  /*  summarize read count  */
		end;
		return;
	     end;
	     if v1 = 0 then do;
		v1 = v2;
	     end;
	     else
	     if v2>0 then do;
		   /*  below sets up pointers to records within S string  */
		pt1 = msp(v1);
		pt2 = msp(v2);
		call sort_comp;
		compares_counter=compares_counter+1;
	    if result = 0   then 	/*  records ranked equal  */
		do;
		 if v1 < v2	/*  compare merge string numbers  */
		    then result = -1;  /*  rank record 1 first  */
		    else result = 1;  /*  rank record 2 first  */
		 end;

		if result = 1 then do;    /*  second record first  */
		     v1 = v2;
		end;
	     end;
	     retp=msp(v1);
	     retbl=input_file_len(v1);   /*  set elngth  */
	     return;
	end A1;
A2:	proc;
	        /*  read another record from winner merge file  */
	     call iox_$read_record(merge_in_iocb_ptrs(v1),msp(v1),in_buff_len,input_file_len(v1),iox_code);
	     if iox_code = error_table_$end_of_info then    /*  end_of file-  */
		do;    /*  end of file, close-detach-destroy iocb ponter  */
		/*   Close		*/
                  close:  call iox_$close(merge_in_iocb_ptrs(v1), iox_code);
                        if iox_code ^= 0 then
	                   do;
	/*   error_table_$not_open   */
	                   call iox_error("Closing",v1);
	                   end;

		/*    Detach   */
                        call iox_$detach_iocb(merge_in_iocb_ptrs(v1), iox_code);
                        if iox_code ^= 0 then
	                   do;
	/*   error_table_$not_attached,
		       $not_closed     */
	                   call iox_error("Detaching",v1);
	                   end;

		/*  Destroy iocb  */
                        call iox_$destroy_iocb(merge_in_iocb_ptrs(v1), iox_code);
                        merge_in_iocb_ptrs(v1) = null();
     /*  no errors returned?   */
		    sip->I(v1) = 0;
		end;
	     else if iox_code ^= 0 then
		call iox_error("Reading",v1);
	     else do;  /*  record successfully read  */
		if input_file_len(v1)>max_rec_length then iox_code=error_table_$long_record;
		else if input_file_len(v1)<min_rec_length then iox_code=error_table_$short_record;
		if iox_code^=0 then    /*  long or short record  */
		   do;
		    if merge_input_file_attaches(v1)="" then
		       call sub_err_(iox_code,whoami, "c", null(), retval,
			     "Record ^d of input_file ^d,file name ^a",
			     merge_read_count(v1),v1,merge_input_file_names(v1));
		       else call sub_err_(iox_code,whoami, "c", null(), retval,
			     "Record ^d of input file ^d,attach description ^a",
			     merge_read_count(v1),v1,merge_input_file_attaches(v1));
		       iox_code=0;
		       ec=error_table_$fatal_error;
		       go to exit;
		   end;
		merge_read_count(v1)=merge_read_count(v1)+1;  /*  increment read count for ith file  */
		release_count=release_count+1;
	          w_p=ptr(msp(v1),fixed(rel(msp(v1)),21)-1);  /*  move back 1 word
					to set length    */
	          fb=input_file_len(v1);
		end;
	     do j = 2 to n;
		lft = s (j-1);
		if substr (unspec (v1), 36, 1) then v2 = v1+1; else v2 = v1-1;
		x = divide(v1+1,2,24);
		v1 = sip -> I (v1+lft);
		v2 = sip -> I (v2+lft);
		if v1 = 0 then v1 = v2;
		else
		if v2>0 then do;
		 /*  below sets up pointers to records within S string  */
		    pt1=msp(v1);
		    pt2=msp(v2);
		    call sort_comp;
		    compares_counter=compares_counter+1;
	    if result = 0   then 	/*  records ranked equal  */
		do;
		 if v1 < v2	/*  compare merge string numbers  */
		    then result = -1;  /*  rank record 1 first  */
		    else result = 1;  /*  rank record 2 first  */
		 end;
		    if result = 1 then v1 = v2;    /*  record 2 ranks first-switch order  */
		end;
		sip -> I (x+s (j)) = v1;
		v1 = x;
	     end;
	end A2;
%include sort_comp;
 ck_len:    proc(length,action_type);
		/*  this will be called from output record exit-its function is to
		check the length passed to it against  max record length and
		return the appropriate error code				*/
	    /*								*/
	dcl	length fixed bin(21) parameter,
		action_type char(*) parameter,
		sub_err_ entry options(variable);
	    if length > max_rec_length then
		do;    /*  record too long  */
		   call sub_err_(error_table_$long_record,whoami, "c", null(), retval,
			"Record ^a by user output_record exit procedure.",
			action_type);
		   ec=error_table_$fatal_error;
		   go to exit;
		end;
 end ck_len;
	dcl	illegal_procedure condition;

illegal_procedure_handler:  proc;
dcl  key_part char(40),
     type char(10),
     file char(20),
     file_part char(168),
     len fixed bin(17);
     if compare_sw = 1 then key_part = "user compare exit procedure";
     else do;
	if dt(i1) = 9 then type = "dec";
	else if dt(i1) = 10 then type = "float dec";
	else type = "unknown";
	call ioa_$rsnnl("key ^d, ^a(^d) ^d(^d)", key_part, len,
		i1 + 1, type, leng(i1), w(i1), mod(b(i1) - 1, 4)*9);
	end;
     if input_driver_is_sort = "1"b then do;
	     call sub_err_(error_table_$improper_data_format, whoami, "c", null(), retval,
			" Invalid key data.  Please check ^a and/or input files ^d and ^d.",
			key_part, v1, v2);
	end;
     else do;          /*   user input_file exit procedure   */
	call sub_err_(error_table_$improper_data_format, whoami, "c", null(), retval,
			" Invalid key data.  Please check ^a and/or user input_file exit procedure.",
		key_part);
	end;
      ec = error_table_$fatal_error;
     go to exit;
end illegal_procedure_handler;
iox_error:  proc(action,index);
dcl  action char(*) parameter,
     index fixed bin(30) parameter;
	ec = error_table_$fatal_error;
	if merge_input_file_attaches(index) = "" then
	     call sub_err_(iox_code, whoami, "c", null(), retval,
		"^a input file ^d, file name ^a",
			action,index,merge_input_file_names(index));
	else call sub_err_(iox_code, whoami, "c", null(), retval,
		"^a input file ^d, attach description ^a",
			action,index,merge_input_file_attaches(index));
	go to exit;
end iox_error;
     end;
 



		    sort.pl1                        11/11/82  1552.0rew 11/11/82  1024.6       55386


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

%;
/* ***************************************
   *				 *
   *				 *
   * Copyright (c) 1975, 1976 by         *
   * Honeywell Information Systems, Inc. *
   *				 *
   *				 *
   *************************************** */

/* Modified on 01/25/82 by FCH, [1], number of input files = 10 */

sort:  proc;

/*   EXTERNAL ENTRIES    */
dcl  clock_ entry returns(fixed bin(71));
dcl  com_err_  entry options(variable);
dcl  command_query_ entry options(variable);
dcl  cpu_time_and_paging_ entry(fixed bin, fixed bin(71), fixed bin);
dcl  cu_$arg_count entry(fixed bin),
     cu_$arg_list_ptr entry(ptr);
dcl  hcs_$get_process_usage entry(ptr, fixed bin(35));
dcl  hcs_$truncate_seg entry(ptr, fixed bin(24), fixed bin(35)),
     hcs_$delentry_seg entry(ptr, fixed bin(35)),
     hcs_$terminate_noname entry(ptr, fixed bin(35));
dcl  unique_chars_ entry(bit(*)) returns(char(15));

dcl  sort_$sort_private entry((*)char(*), char(*), (*)ptr, char(*), char(*), float bin(27),
		fixed bin(35), fixed bin(35), fixed bin(35));
dcl  sort_merge_command entry((*)char(*), char(*), (1)ptr, char(*), char(*), fixed bin(17),
		     bit(1), bit(1), bit(1), fixed bin(35), fixed bin(35),
		     float bin(27), fixed bin, ptr, ptr, ptr);
dcl  sort_merge_command_finish  entry(fixed bin(35), fixed bin(35), bit(1), bit(1));
dcl  sort_merge_sub_error  entry;

/*   EXTERNAL STATIC     */

%include sort_ext;
/*   INTERNAL STATIC (constants only)     */
dcl  pending_string char(120) varying init("Pending work in previous invocation of ^a will be lost if you proceed;
      do you wish to proceed?") internal static;
dcl (on init("1"b),
     off init("0"b) ) bit(1) internal static;

/*   AUTOMATIC AND BASED     */
%include sort_merge_pars;
dcl     output_file char(256),
     sort_desc(1)  ptr,
     temp_dir   char(168),
     user_out_sw_temp      char(8),
     sort_code   fixed bin(35),
     merge_order_temp  fixed bin(35),
     file_size_temp float bin(27),
     string_size_temp fixed bin(35);
dcl  input_file_temp(total_if_pns) char(256) based(addr(input_file));
dcl  arg_err_code fixed bin(35);
dcl (perm_sd,
     temp_sd) ptr init(null());
dcl (fatal_sw,
     no_args_sw,
     arg_err_sw) bit(1);
dcl  total_if_pns fixed bin(17);
dcl  total_args   fixed bin,
     arg_list_ptr ptr;

dcl 1 query_info aligned,
      2 version fixed bin init(2),
      2 yes_or_no_sw bit(1) unaligned,
      2 suppress_name_sw bit(1) aligned,
      2 status_code fixed bin(35),
      2 query_code fixed bin(35);
dcl  answer char(4) varying;

dcl  state_code fixed bin(35);
dcl  hcs_code fixed bin(35);

dcl  (sub_error_, cleanup)  condition;


/*   Start.   */

     call state_test(state_code);		/*   Test state variable.   */
     if state_code ^= 0 then do;
	arg_err_sw = off;
	fatal_sw = on;
	call com_err_(0, "sort", " Sort will not be attempted.");
	return;		/*   To command level without resetting state variable   */
	end;
     etime(1) = clock_();
     call cpu_time_and_paging_(pf(1), vtime(1), pd_f(1));
     call hcs_$get_process_usage(addr(pu(1)), hcs_code);

     temp_sd,
     perm_sd = null();	/*   used by cleanup procedure   */
     debug_sw = off;	/*   used by cleanup procedure   */
     on cleanup call cleanup_proc;
     on sub_error_ call sort_merge_sub_error;
     call cu_$arg_count(total_args);
/*   Get pointer to argument list, so that arguments may be obtained
     within any procedure via cu_$arg_ptr_rel   */
     call cu_$arg_list_ptr(arg_list_ptr);

     call sort_merge_command(input_file, output_file, sort_desc, temp_dir, user_out_sw_temp, total_if_pns,
			arg_err_sw, fatal_sw, no_args_sw, merge_order_temp, string_size_temp,
			file_size_temp, total_args, arg_list_ptr, perm_sd, temp_sd);

     if no_args_sw = on then go to exit;	/*   Prompting message printed by sort_merge_command.   */
     if arg_err_sw = on then sort_code = 1;
     /*   to ensure that sort_ will not attempt to execute sorting process   */
     else sort_code = 0;
     if fatal_sw = off then		/*   go on if Sort Description is readable.   */
     call sort_$sort_private(input_file_temp, output_file, sort_desc, temp_dir, user_out_sw_temp, file_size_temp,
			sort_code, merge_order_temp, string_size_temp);

     call sort_merge_command_finish(arg_err_code, sort_code, arg_err_sw, fatal_sw);

exit:
     call cleanup_proc;
     state = 0;
     return;     /*  to command level   */

state_test: proc(state_code);		/*   Test state variable:   */
dcl  state_code fixed bin(35) parameter;
     if state = 0
	| (state = 8 & index(whoami, "_") ^= 0)		/*   Subroutine called last time   */
	then call set_state;
     else do;		/*   Error   */
	call query(pending_string);
	if answer = "no" then do;
	     state_code = 1;
	     return;
	     end;
	else call set_state;		/*   answer = yes   */
	end;


set_state:  proc;
	whoami = "sort";
	state = 1;		/*   Set state variable.   */
	state_code = 0;
	unique_prefix = before(unique_chars_("0"b), " ")||".";	/*   Get unique string for temporary names.   */
end set_state;


end state_test;


query:  proc(string);		/*   Ask user about proceeding:   */
dcl  string char(*) varying parameter;
     yes_or_no_sw = on;
     suppress_name_sw = off;
     status_code, query_code = 0;
     call command_query_(addr(query_info), answer, "sort", string, whoami);
end query;


cleanup_proc:  proc;
dcl  code fixed bin(35);
     if debug_sw = off then do;
	if temp_sd ^= null() then call hcs_$delentry_seg(temp_sd, code);
	if perm_sd ^= null() then call hcs_$terminate_noname(perm_sd, code);
	end;
     else do;
	if temp_sd ^= null() then call hcs_$truncate_seg(temp_sd, 0, code);
	end;
     state = 0;
end cleanup_proc;


end sort;
  



		    sort_.alm                       11/11/82  1554.5rew 11/11/82  1030.4        9261


" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" * Copyright (c) 1972 by Massachusetts Institute of        *
" * Technology and Honeywell Information Systems, Inc.      *
" *                                                         *
" ***********************************************************
	name sort_

"macro which generates a call to an external entry point in sort_merge_

	macro	ext_transfer
	segdef	&1
&1:	getlp
	tra	&2

	&end

	ext_transfer	sort_,sort_sort$sort_sort
	ext_transfer	sort_private,sort_sort$sort_private
	ext_transfer	initiate,sort_initiate$initiate
	ext_transfer	release,sort_input_proc$release
	ext_transfer	return,sort_output_proc$return
	ext_transfer	terminate,sort_merge_terminate$terminate
	ext_transfer	commence,sort_commence$commence
	ext_transfer	noexit,sort_merge_subroutine$noexit

	end sort_
   



		    sort_build_keys.pl1             11/11/82  1552.0rew 11/11/82  1029.3       45189


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
%;
/* ***************************************
   *				 *
   *				 *
   * Copyright (c) 1975, 1976 by         *
   * Honeywell Information Systems, Inc. *
   *				 *
   *				 *
   *************************************** */
sort_build_keys:  proc(keys_ptr, code);
/*   EXTERNAL ENTRIES   */
dcl  ioa_$ioa_stream entry options(variable);

/*   EXTERNAL STATIC   */
% include sort_ext;

/*   PARAMETERS, BASED, AUTOMATIC   */
dcl (keys_ptr ptr,		/*   Pointer to keys substructure   */
     code fixed bin(35) ) parameter;		/*   status code          */
% include sort_sd;
dcl  work_ptr ptr,
   i fixed bin(17);

/*   Start.     */
     work_ptr = keys_ptr;
     code = 0;
     min_rec_length = 0;
     do i = 1 to keys.number;
	w(i-1) = word_offset(i);	/*  set word offset  */
	b(i-1) = bit_offset(i);	/*  set bit offset  */
	leng(i-1) = len(i);		/*  set key length  */
	if rv(i) = "dsc" then rev(i-1) = 1;  /*  set descending ranking   */
		      else rev(i-1) = 0;
	if datatype(i) = "char"
	    then do;		/*  data type = character  */
		if mod(bit_offset(i),9) ^= 0 
		   then do;
			call bit_offset_warning("character", 9);
		        end;
		dt(i-1) = 1;  	/*  set type code  */
		min_rec_length=max(min_rec_length,4*w(i-1)+leng(i-1)+divide(b(i-1),9,24));
			/*  for this data type-set b(i-1) to first byte upon which to begin sort */
		b(i-1)=4*w(i-1)+divide(b(i-1),9,24)+1;
			/*  compute min_rec_length-in terms of bytes */
	         end;
	else if datatype(i) = "bit"
	    then do;		/*  data type = bit  */
		dt(i-1) = 2;	/*  set type code  */
		min_rec_length=max(min_rec_length,4*w(i-1)+divide(b(i-1)+leng(i-1)-1,9,24)+1);
		    /*  for this data type set b(i-1) to the first bit upon which to begin sort */
		b(i-1) = w(i-1)*36 + b(i-1) + 1;
	         end;
	else if datatype(i) = "bin"
	    then do;		/*  data type = binary  */
		min_rec_length=max(min_rec_length,4*w(i-1)+divide(b(i-1)+leng(i-1)+1-1,9,24)+1);
		if leng(i-1)=35 & b(i-1) = 0 then dt(i-1)=3;  /* aligned-occupying 1 word  */
		else if leng(i-1)=71 & b(i-1) = 0 & mod(w(i-1),2)=0  /*  aligned-occupying 2 words  */
						/*  latter tests for even word alignment  */
		    then do;
			dt(i-1) = 4;
			w(i-1) = divide(w(i-1),2,24);  /*  set w(i-1) to index  in imaginary array of 2 word
						fixed binary numbers  		*/
		         end;
		else do;		/*  unaligned  */
		    dt(i-1) = 5;
		    b(i-1)= w(i-1)*36 + b(i-1)+1;  /*  set b(i-1) to bit offset from the beginnng of the record  */
		     end;
	         end;
	else if datatype(i) = "flbin"
	    then do;		/*  data type = floating binary  */
		min_rec_length=max(min_rec_length,4*w(i-1)+divide(b(i-1)+leng(i-1)+9-1,9,24)+1);
		if leng(i-1)=27 & b(i-1) = 0 then dt(i-1)=6;  /*  aligned-occupying 1 word  */
		else if leng(i-1)=63 & b(i-1) = 0 & mod(w(i-1),2)=0  /*  aligned-occupying 2 words  */
						/*  latter tests for even word alignment  */
			then do;
			      dt(i-1) = 7;
			      w(i-1) = divide(w(i-1),2,24);  /*  set to index in imaginary array of
						2 word floating binary numbers  */
			     end;
		else do;  /*  unaligned  */
		      dt(i-1)=8;
		      b(i-1)=w(i-1)*36+b(i-1)+1;  /*  set to bit offset from beginning of record */
		     end;
	         end;
	else if datatype(i) = "dec"
	    then do;		/*  data type = decimal  */
		if mod(bit_offset(i),9) ^= 0 
		   then do;
			call bit_offset_warning("fixed decimal", 9);
		        end;
		dt(i-1) = 9;
		min_rec_length=max(min_rec_length,4*w(i-1)+leng(i-1)+1+divide(b(i-1),9,24));
		    /*  set b(i-1) to byte offset from beginning of the record */
		b(i-1)=w(i-1)*4 + divide(b(i-1),9,24)+1;
	         end;
	else if datatype(i) = "fldec"
	    then do;		/*  data tupe = floating decimal  */
		dt(i-1)=10;
		min_rec_length=max(min_rec_length,4*w(i-1)+leng(i-1)+2+divide(b(i-1),9,24));
		if mod(bit_offset(i),9) ^= 0 
		   then do;
			call bit_offset_warning("float decimal", 9);
		        end;
		    /*  set b(i-1) to first byte within record upon which to begin sort  */
		b(i-1)=w(i-1)*4 + divide(b(i-1),9,24)+1;
	         end;
end;	/*   end do loop   */
     if min_rec_length > max_rec_length then do;
     	if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
		"^a:  Record length required to contain keys is ^d.  Must be < ^d.",
		     whoami, min_rec_length, max_rec_length);
	code = 1;
	end;
	    no_of_keys = keys.number-1;  /*  set for comparison routine  */
	return;


bit_offset_warning:  proc(datatype, integer);
dcl (datatype char(*),
     integer fixed bin ) parameter;

     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
		"^a:  Warning:  Key ^d is ""^a"" but bit offset is not a multiple of ^d.",
		whoami, i, datatype, integer);
end bit_offset_warning;


end sort_build_keys;
   



		    sort_cleanup_work.pl1           11/11/82  1552.0rew 11/11/82  1029.3       20754


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
%;
/* ***************************************
   *				 *
   *				 *
   * Copyright (c) 1975, 1976 by         *
   * Honeywell Information Systems, Inc. *
   *				 *
   *				 *
   *************************************** */
sort_cleanup_work:  proc;

/*   EXTERNAL ENTRIES   */
dcl  hcs_$delentry_seg  entry(ptr, fixed bin(35));
dcl  hcs_$truncate_seg  entry(ptr, fixed bin(24), fixed bin(35));
dcl  hcs_$delentry_file  entry(char(*) aligned, char(*), fixed bin(35));
dcl  hcs_$truncate_file  entry(char(*) aligned, char(*), fixed bin(24), fixed bin(35));

/*   EXTERNAL STATIC   */

% include sort_ext;

/*   AUTOMATIC   */
dcl  hcs_code fixed bin(35);
dcl  i fixed bin(35);

/*   Start   */
     if debug_sw = "0"b then do;
	call hcs_$delentry_seg(sip, hcs_code);
	sip = null();
	call hcs_$delentry_file(wf_dir_name, unique_prefix||"sort_work.SR", hcs_code);
	call hcs_$delentry_file(wf_dir_name, unique_prefix||"sort_work.SS", hcs_code);
		    /*   Ignore any error on deletion   */
	if mii > 0 then do;
	     do i = 1 to mii;
		call hcs_$delentry_seg(msp(i), hcs_code);
	     	/*   Ignore any error on deletion   */
		msp(i) = null();	/*  If segment number gets reused, later call by sort_(merge_) will be ok.  */
		end;
	     if substr(whoami, 1, 5) = "merge" then do;
		call hcs_$delentry_seg(msp(mii+1), hcs_code);  /* extra buffer */
		msp(mii+1) = null();
		end;
	     end;
	end;
     else do;		/*   debug_sw on   */
	call hcs_$truncate_seg(sip, 0, hcs_code);
	call hcs_$truncate_file(wf_dir_name, unique_prefix||"sort_work.SR", 0, hcs_code);
	call hcs_$truncate_file(wf_dir_name, unique_prefix||"sort_work.SS", 0, hcs_code);
	if mii > 0 then do;
	     do i = 1 to mii;
		call hcs_$truncate_seg(msp(i), 0, hcs_code);
		/*   No need to null() pointers, since segment is still initiated.   */
		end;
	     if substr(whoami, 1, 5) = "merge" then do;
		call hcs_$truncate_seg(msp(mii+1), 0, hcs_code);  /* extra buffer */
		end;
	     end;
	end;
     state = 8;
end sort_cleanup_work;
  



		    sort_commence.pl1               11/11/82  1552.0rew 11/11/82  1029.4       13473


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
%;
/* ***************************************
   *				 *
   *				 *
   * Copyright (c) 1975, 1976 by         *
   * Honeywell Information Systems, Inc. *
   *				 *
   *				 *
   *************************************** */
	commence:proc(ec);

/*   EXTERNAL ENTRIES     */
	    dcl sort_presort entry(fixed bin(35)) ext;

/*   EXTERNAL STATIC     */

% include sort_ext;

	   dcl   error_table_$out_of_sequence fixed bin(35) ext;

/*   PARAMETER     */
	    dcl	ec fixed bin(35);    /*  error code  */
	    dcl	rec_ptr ptr,
		rec_len fixed bin(21),
		sort_input_proc$release entry(ptr,fixed bin(21),fixed bin(35));

	    if state ^= 3 then
		do;    /*  sequence error--initiate not yet called  */
		   ec = error_table_$out_of_sequence;
		   return;
		end;
	    if input_record_exit_sw =1 then
		do;  /*  take input record exit  */
		 rec_ptr=null();    /*  indicating the last call  */
		 rec_len=min_rec_length;
		 call sort_input_proc$release(rec_ptr,rec_len,ec);
		 if ec^=0 then return;
		end;
	    state = 5;    /*  update state code  */
	    ec = 0;
	    if sii > 0 | input_rec_inserted > 0 then
	    call sort_presort(ec);
	     presort_compares = compares_counter;
	end;
   



		    sort_convert_internal.pl1       11/11/82  1552.0rew 11/11/82  1024.7      265878


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

/* Modified on 03/20/82 by FCH, [1], number of input files = 10, sort_merge_subroutine$noexit <- sort_$noexit */

sort_convert_internal:  proc(source_parameters, internal_parameters, p_area, keys_ptr, io_exits_ptr, exits_ptr,
			bit_count, seg_length, convert_int_code);
/*   Convert Sort/Merge Description from source form to internal form.   */

/*   PARAMETERS   */

/*   EXTERNAL ENTRIES   */
dcl  convert_status_code_  entry(fixed bin(35), char(8) aligned, char(100) aligned);
dcl  cv_dec_check_ entry(char(*), fixed bin(35)) returns(fixed bin(35));
dcl  ioa_$ioa_stream  entry  options(variable);
dcl  find_command_ entry(ptr, fixed bin, ptr, fixed bin(35));
dcl  find_command_code fixed bin(35);
dcl  lex_string_$init_lex_delims  entry(char(*), char(*), char(*), char(*), char(*),
		bit(*), char(*) varying aligned, char(*) varying aligned,
		char(*) varying aligned, char(*) varying aligned);
dcl  lex_string_$lex  entry(ptr, fixed bin(21), fixed bin(21), ptr, bit(*),
		char(*), char(*), char(*), char(*), char(*),
		char(*) varying aligned, char(*) varying aligned,
		char(*) varying aligned, char(*) varying aligned,
		ptr, ptr, fixed bin(35));

/*1*/dcl  sort_$noexit entry external;

/*   EXTERNAL STATIC   */

% include sort_ext;

dcl  sys_info$max_seg_size fixed bin(35) external static;
dcl (error_table_$no_stmt_delim,
     error_table_$unbalanced_quotes) fixed bin(35) external static;

/*   INTERNAL STATIC  (must be constants only)     */
dcl  nl char(1) internal static init("
");
dcl  tb char(1) internal static init("	");		/*   tab   */

dcl (quote_open char(1) init(""""),
     quote_close char(1) init(""""),
     comment_open char(2) init("/*"),
     comment_close char(2) init("*/"),
     statement_delim char(1) init(";"),
     s_init bit(2) init("10"b)	/*   suppress quoting delims, return statement delims   */
     ) internal static;
dcl (l_ignored_input fixed bin(21) init(0),
     s_lex bit(3) init("100"b)	/*   yes statement descriptors,
				     no  comment descriptors,
				     no  retain doubled quote_closes    */
     ) internal static;

/*   The following 4 declarations are synchronized with each other;
     if one is modified then the others must be modified consistently.   */
dcl keywords(22) char(16) internal static init(
	"keys", "key",
	"exits", "exit",
	"char", "character",
	"bit",
	"bin", "binary",
	"fixed",
	"dec", "decimal",
	"float",
	"flbin",
	"fldec",
	"dsc", "descending",
	"input_file",
	"output_file",
	"compare",		/*   Currently element 20   */
	"input_record",
	"output_record" );

/*    exit_words must be defined on the element of keywords which contains the exit name "compare".   */
dcl exit_words(keyword_codes.compare : exit_max) char(16) defined(keywords(20));

dcl 1 keyword_codes internal static,
      2 (
	keys(2) init((2)1),
	exits(2) init((2)2),
	char(2) init((2)100),
	bit     init(101),
	bina(2)     init((2)102),
	fixed   init(103),
	decim(2)     init((2)104),
	float   init(105),
	flbin   init(106),
	fldec   init(107),
	dsc(2)      init((2)200),
	input_file   init(300),
	output_file  init(301),
	compare init(302),
	input_record init(303),
	output_record init(304) ) fixed bin(17);

dcl  codes_array(22) fixed bin(17) based(addr(keyword_codes));

dcl (st_min init(1),
     st_max init(3),
     dt_min init(100),
     dt_max init(107),
     exit_min init(300),
     exit_max init(304) ) fixed bin(17) internal static;

/*   The following 3 declarations are synchronized with each other;
     if one is modified then all must be modifed consistently.   */
dcl  internal_datatypes(0:10) char(8) internal static init(
	"illegal",
	"char",
	"bit",
	(2)(1)"bin",
	(2)(1)"flbin",
	(2)(1)"dec",
	(2)(1)"fldec");

dcl  legal_datatype_bits(0:10) bit(8) init(	/*   Change to internal static when
					     compiler correctly initializes last element.   */
	"00000000"b,
	"10000000"b,
	"01000000"b,
	"00100000"b, "00110000"b,
	"00100100"b, "00000010"b,
	"00001000"b, "00011000"b,
	"00001100"b, "00000001"b);

dcl (on init("1"b),
     off init("0"b) ) bit(1) internal static;

/*   PARAMETERS, AUTOMATIC, AND BASED   */

%include lex_descriptors_;

dcl (ignored_break_chars char(4) varying aligned,	/*   , space tab newline   */
     break_chars char(8) varying aligned,	/*   , space tab newline : ; ( )   */
     lex_delims char(128) varying aligned,
     lex_control_chars char(128) varying aligned,
     p_input ptr,
     l_input fixed bin(21),
     p_first_statement_desc ptr,
     p_first_token_desc ptr,
     lex_code fixed bin(35) );

dcl  len_max(0:10) fixed bin(24) init(
	4095,   /*  illegal  */
	4095,   /*  char  */	/*   set dynamically; see references to word_offset_max   */
	4095,   /*  bit   */	/*   set dynamically; see references to word_offset_max   */
	  71,   /*  fxbin  */
	  71,   /*  fxbin  */
	  63,   /*  flbin  */
	  63,   /*  flbin  */
	  59,   /*  fxdec  */
	  59,   /*  fxdec  */
	  59,   /*  fldec  */
	  59    /*  fldec  */
       );

dcl statement_counts(st_min: st_max) fixed bin(17);
dcl  datatype_bits bit(dt_max - dt_min + 1),
     legal_datatype_index fixed bin(17);

dcl  exit_count_array(exit_min: exit_max) fixed bin(17);
dcl  user_name_array(exit_min: exit_max) char(168);

dcl  exit_pairs_count fixed bin(17);

%include sort_merge_pars;


/*   For deleted attach statement:
dcl 1 attach_array_init internal static,
      2 count fixed bin(17) init(0),
      2 desc char(168) init("");

dcl error fixed bin(35);
dcl  curr_switchname char(8);
dcl  curr_attach_index fixed bin(17);
dcl  curr_attach_len fixed bin(17);
dcl  in_attach_max fixed bin(17);		*/

dcl (source_parameters ptr,
     internal_parameters ptr,
     p_area ptr,
     keys_ptr	ptr,
     io_exits_ptr	ptr,
     exits_ptr	ptr,
/*     attaches_ptr   ptr,   */
     bit_count fixed bin(24),
     seg_length fixed bin(24),
     convert_int_code fixed bin(35) ) parameter;
dcl  atom_ptr ptr,
     atom_len fixed bin;

dcl  atom char(atom_len) based(atom_ptr);
dcl  cv_err fixed bin(35);
dcl  integer fixed bin(35);
dcl  atom_code fixed bin(17);

% include sort_sd;

dcl 1 dummy_exits based(work_ptr),
      2 version fixed bin,
      2 exits_array(keyword_codes.compare : exit_max) entry,
      2 dummy fixed bin(71);

dcl  exit_code fixed bin(17);
dcl  work_ptr ptr;
dcl  word_offset_max fixed bin(30);

dcl  shortinfo char(8) aligned,
     longinfo char(100) aligned;

/*   Start.   */
     convert_int_code = 0;
     word_offset_max = sys_info$max_seg_size - 100;
     /*   The literal subscripts below must be monitored if len_max is changed.   */
     len_max(1) = word_offset_max * 4;		/*   for char strings  */		
     len_max(2) = word_offset_max * 36;		/*   for bit strings   */
     work_ptr = internal_parameters;
     ignored_break_chars = ", "||tb||nl;
     break_chars = ", :;()"||tb||nl;
     call lex_string_$init_lex_delims(quote_open, quote_close, comment_open, comment_close,
		statement_delim, s_init, break_chars, ignored_break_chars,
		lex_delims, lex_control_chars);
     p_input = source_parameters;
     l_input = bin(bit_count, 35)/9;
     call lex_string_$lex(p_input, l_input, l_ignored_input, p_area, s_lex,
		quote_open, quote_close, comment_open, comment_close,
		statement_delim, break_chars, ignored_break_chars,
		lex_delims, lex_control_chars,
		p_first_statement_desc, p_first_token_desc, lex_code);
     /*   If no tokens, then p_first_token_desc = null().   */
     if lex_code ^= 0 then do;
	if lex_code = error_table_$unbalanced_quotes | lex_code = error_table_$no_stmt_delim then do;
	     convert_int_code = 1;
	     call convert_status_code_(lex_code, shortinfo, longinfo);
	     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
		"^a:  ^a  ^a Description pathname ^a", whoami, longinfo, caps(whoami), sort_desc_pn);
	     end;
	end;
     Ptoken = p_first_token_desc;
     call syntax;			/*   Process source form of S.D.   */
exit:     return;     /*  to sort_ or merge_   */

convert_datatype:  entry(keys_ptr_par, current_key, typecode);
dcl (keys_ptr_par ptr,
     current_key fixed bin(17),
     typecode fixed bin(17) ) parameter;
dcl  j fixed bin(17);
     typecode = 0;
     work_ptr = keys_ptr_par;
     do j = 0 to hbound(internal_datatypes, 1);
	if keys.datatype(current_key) = internal_datatypes(j) then do;
	     typecode = j;
	     return;
 	     end;
	end;   /*   of do   */
     return;

/*   The implementation of the state diagram
     for the source form of the Sort/Merge Description follows
     (consult the PLM for further information).   */

syntax:  proc;
enter_state:
     call enter_action;
new_statement_state:
     call scan;
     if atom_code = keyword_codes.keys(1) then go to keys_state;
     if atom_code = keyword_codes.exits(1) then go to exits_state;
/*     if atom_code = keyword_codes.attach then go to attach_state;  */
     if atom = ";" then go to new_statement_state;
     else go to err_1_state;
keys_state:
     call keys_action;
     call scan;     
     if atom = ":" then call scan;
     go to expect_dtw_state;
expect_dtw_state:  /*  expect data type word   */
     if atom_code >= dt_min & atom_code <= dt_max then go to dtw_state;
     if atom = ";" then go to end_of_statement_state;
     else go to err_6_state;
datatype_word_state:  dtw_state:
     call datatype_word_action;
     call scan;
     if atom_code >= dt_min & atom_code <= dt_max then go to datatype_word_state;
     else go to datatype_state;
datatype_state:  dt_state:
     call datatype_action;
     if atom = "(" then go to left_par_size_state;
     else go to err_8_state;
left_par_size_state:
     call scan;
     integer = cv_dec_check_(atom, cv_err);
     if cv_err = 0 then go to size_state;
     if atom = ")" then go to right_par_size_state;
     else go to err_9_state;
size_state:
     call size_action;
     call scan;
     if atom = ")" then go to right_par_size_state;
     else go to err_10_state;
right_par_size_state:
     call scan;
     integer = cv_dec_check_(atom, cv_err);
     if cv_err = 0 then go to w_state;
     else go to err_11_state;
w_state:
     call w_action;
     call scan;
     if atom = "(" then go to left_par_off_state;
     call no_bit_offset_action;	/*   No (, therefore aligned   */
     if atom_code = dsc(1) then go to rv_state;
     go to expect_dtw_state;
left_par_off_state:
     call scan;
     integer = cv_dec_check_(atom, cv_err);
     if cv_err = 0 then go to b_state;
     if atom = ")" then go to right_par_off_state;
     else go to err_13_state;
b_state:
     call b_action;
     call scan;
     if atom = ")" then go to right_par_off_state;
     else go to err_14_state;
right_par_off_state:
     call scan;
     if atom_code = dsc(1) then go to rv_state;
     go to expect_dtw_state;
rv_state:
     call rv_action;
     call scan;
     go to expect_dtw_state;
exits_state:
     call exits_action;
     call scan;
     if atom = ":" then call scan;
     go to expect_exit_name_state;
expect_exit_name_state:
     if atom_code >= exit_min & atom_code <= exit_max then go to exit_name_state;
     if atom = ";" then go to end_of_statement_state;
     else go to err_4_state;
exit_name_state:
     call exit_name_action;
     call scan;
     if atom ^= ";" then go to user_name_state;
     else go to err_5_state;
user_name_state:
     call user_name_action;
     call scan;
     go to expect_exit_name_state;
/*  attach_state:
     call attach_action;
     call scan;
     if atom = ":" then call scan;
     if atom = ";" then go to err_15_state;
     go to switchname_state;
switchname_state:
     call switchname_action(error);
     if error ^= 0 then go to scan_statement_state;
     call scan;
     if atom = ";" then go to err_16_state;
     go to module_name_state;
module_name_state:
     call modulename_action(error);
     if error ^= 0 then go to scan_statement_state;
     call scan;
     if atom = ";" then go to end_of_statement_state;
     go to attach_desc_word_state;
attach_desc_word_state:
     call attach_desc_word_action(error);
     if error ^= 0 then go to scan_statement_state;
     call scan;
     if atom = ";" then go to end_of_statement_state;
     go to attach_desc_word_state;  */
end_of_statement_state:
/*   Do not scan.   */
     go to new_statement_state;
end_file_state:
     call end_file_action;
     return;     /*  from syntax proc   */

err_1_state:
     convert_int_code = 1;
     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
		"^a:  Unrecognized statement keyword ""^a"".  Rest of statement ignored.",
		whoami, atom);
     go to scan_statement_state;
err_4_state:
     convert_int_code = 1;
     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw, 
		"^a:  Unrecognized exit name ""^a"" for presumed ^d"||
		ordinal(exit_pairs_count + 1)||" exit description.  Word ignored.",
		whoami, atom, exit_pairs_count + 1);
     call scan;
     go to expect_exit_name_state;
err_5_state:
     convert_int_code = 1;
     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw, 
		"^a:  Missing user exit procedure name for ^d"||
		ordinal(exit_pairs_count)||" exit description.", whoami, exit_pairs_count);
     call user_name_action;
     go to end_of_statement_state;
err_6_state:
     convert_int_code = 1;
     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw, 
		"^a:  Unrecognized data type ""^a"" for presumed key ^d.",
		whoami, atom, keys.number + 1);
     go to scan_key_state;
err_8_state:
     convert_int_code = 1;
     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
	"^a:  Invalid word ""^a"" following data type for key ^d.  Should be ( for (length) or (precision).",
		whoami, atom, keys.number);
     go to scan_key_state;
err_9_state:
     convert_int_code = 1;
     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw, 
		"^a:  Invalid length or precision ""^a"" for key ^d.",
		whoami, atom, keys.number);
     go to scan_key_state;
err_10_state:
     convert_int_code = 1;
   if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
		"^a:  Invalid word ""^a"" following length or precision for key ^d.  Should be ).",
		whoami, atom, keys.number);
     go to scan_key_state;
err_11_state:
     convert_int_code = 1;
     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
		"^a:  Invalid word ""^a"" following length or precision for key ^d.  Should be word offset.",
		 whoami, atom, keys.number);
     go to scan_key_state;
err_13_state:
     convert_int_code = 1;
     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw, 
		"^a:  Invalid bit offset ""^a"" for key ^d.",
		whoami, atom, keys.number);
     go to scan_key_state;
err_14_state:
     convert_int_code = 1;
     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw, 
		"^a:  Invalid word ""^a"" following bit offset for key ^d.  Should be ).",
		 whoami, atom, keys.number);
     go to scan_key_state;
/*  err_15_state:
     convert_int_code = 1;
     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw, 
		"^a:  Attach statement ^d is empty.",
		whoami, statement_counts(keyword_codes.attach));
     go to scan_statement_state;
err_16_state:
     convert_int_code = 1;
     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw, 
		"^a:  Attach statement ^d has no I/O module name.  Rest of statement ignored.",
		whoami, statement_counts(keyword_codes.attach));
     go to scan_statement_state;  */
scan_statement_state:
     if atom = ";" then go to end_of_statement_state;
     call scan;
     go to scan_statement_state;
scan_key_state:
     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw, 
		"^vxWill resume processing with next valid data type word.",
		length(before(whoami, " ")) + 3);
scan_key_loop:
     if atom = ";" then go to end_of_statement_state;
     call scan;
     if atom_code >= dt_min & atom_code <= dt_max then go to dtw_state;
     else go to scan_key_loop;


scan:  proc;				/*   Get next atom:   */
     if Ptoken = null() then go to end_file_state;	/*   End of S.D.   */
     atom_code = 0;
     atom_len = token.Lvalue;
     atom_ptr = token.Pvalue;
     call look_up_keyword;		/*   Get code corresponding to "atom".   */
     Ptoken = token.Pnext;
end scan;


end syntax;


look_up_keyword:  proc;
dcl  index fixed bin(17);

     do index = lbound(keywords, 1) to hbound(keywords, 1);
	if atom = keywords(index) then
	     do;
	     atom_code = codes_array(index);
	     go to end_lookup;
	     end;
     end;
end_lookup:
end look_up_keyword;


enter_action:  proc;			/*   Initialize variables.   */
     statement_counts = 0;
     exit_count_array = 0;
     exit_pairs_count = 0;
     keys_ptr,
     io_exits_ptr,
     exits_ptr = null();
/*     attaches_ptr = null();
     attach_array = attach_array_init;
     in_attach_max = 0;  */
end enter_action;


keys_action:  proc;
     datatype_bits = "0"b;
     keys.version = 1;
     statement_counts(atom_code) = statement_counts(atom_code) + 1;
     keys.number = 0;
end keys_action;


datatype_word_action:  proc;
     substr(datatype_bits, atom_code - dt_min + 1, 1) = "1"b;
end datatype_word_action;

datatype_action:  proc;
dcl  i fixed bin(17);
     keys.number = keys.number + 1;		/*   Add 1 to number of keys in keys substructure.   */
     legal_datatype_index = 0;
     do i = 1 to hbound(legal_datatype_bits, 1);	/*   Check for valid combination of data type words.   */
	if datatype_bits = legal_datatype_bits(i) then legal_datatype_index = i;
					/*   Hold index indicating data type.   */
	end;
     keys.datatype(keys.number) = internal_datatypes(legal_datatype_index);
					/*   Set data type for current key.   */
     keys.word_offset(keys.number) = 0;
     keys.bit_offset(keys.number) = 0;		/*   Set default for bit offset to 0.   */
     keys.rv(keys.number) = "";		/*   Set default for "descending" to off.   */
     if legal_datatype_index = 0 then
	call datatype_err_action;
     datatype_bits = "0"b;
end datatype_action;


datatype_err_action:  proc;
     convert_int_code = 1;
     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw, 
		"^a:  Inconsistent datatype attributes for key ^d.",
		whoami, keys.number);
end datatype_err_action;


w_action:  proc;
     if integer >= word_offset_max then
	do;
	convert_int_code = 1;
	if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw, 
		"^a:  Word offset of ^a too large for key ^d.",
		whoami, atom, keys.number);
	end;
     keys.word_offset(keys.number) = integer;	/*   Set word offset for current key.   */
end w_action;


no_bit_offset_action:  proc;
     /*   Adjust precision of aligned binary if appropriate.   */
     if keys.len(keys.number) < 0 then return;
     if keys.datatype(keys.number) = "bin" then do;
	if keys.len(keys.number) <= 35 then keys.len(keys.number) = 35;
	else if keys.len(keys.number) <= 71 & mod(keys.word_offset(keys.number), 2) = 0
		then keys.len(keys.number) = 71;
	end;
     else if keys.datatype(keys.number)   = "flbin" then do;
	if keys.len(keys.number) <= 27 then keys.len(keys.number) = 27;
	else if keys.len(keys.number) <= 63 & mod(keys.word_offset(keys.number), 2) = 0
		then keys.len(keys.number) = 63;
	end;
end no_bit_offset_action;


b_action:  proc;
     if integer > 35 then
	do;
	if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw, 
		"^a:  Bit offset of ^a too large for key ^d.",
		whoami, atom, keys.number);
	convert_int_code = 1;
	end;
     keys.bit_offset(keys.number) = integer;	/*   Set bit offset for current key.   */
end b_action;


size_action:  proc;
dcl  temp fixed bin(24);
     if integer > len_max(legal_datatype_index) then
	do;
	convert_int_code = 1;
	temp = len_max(legal_datatype_index);
	if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
		"^a:  Length ^a too large for ^a data type of key ^d.  Must not be greater than ^d.",
		whoami, atom, keys.datatype(keys.number), keys.number, temp);
	end;
     keys.len(keys.number) = integer;		/*   Set "size" for current key.   */
end size_action;


rv_action:  proc;
     keys.rv(keys.number) = "dsc";		/*   Srt rv for current key in keys structure.   */
end rv_action;


exits_action:  proc;
     statement_counts(atom_code) = statement_counts(atom_code) + 1;
end exits_action;


exit_name_action:  proc;
     exit_pairs_count = exit_pairs_count + 1;
     exit_code = atom_code;		/*   Hold exit code.   */
end exit_name_action;


user_name_action:  proc;
     exit_count_array(exit_code) = exit_count_array(exit_code) + 1;	/*   Increment count for proper exit name.   */
     user_name_array(exit_code) = atom;		/*   Get user name.   */
end user_name_action;


  /*  attach_action:  proc;
     statement_counts(atom_code) = statement_counts(atom_code) + 1;
end attach_action;


switchname_action:  proc(error);
dcl  error fixed bin(35) parameter;
     error = 0;
     curr_switchname = atom;
     if substr(atom, 1, 3) = "in_" then do;
	curr_attach_index = cv_dec_check_(substr(atom, 4), error);
	if error ^= 0 | curr_attach_index < 1 | curr_attach_index > input_file_max then do;
	     convert_int_code = 1;
	     error = 1;
	     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
			"^a:  Invalid input file switchname ^a  Rest of statement ignored.",
			whoami, curr_switchname);
	     return;
	     end;
	else in_attach_max = max(in_attach_max, curr_attach_index);
	end;
     else if atom = "out_1" then curr_attach_index = 0;
     else do;
	error = 1;
	convert_int_code = 1;
	if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw, 
		"^a:  Invalid switchname ^a  Rest of statement ignored.",
			whoami, curr_switchname);
	return;
	end;
     attach_array.count(curr_attach_index) = attach_array.count(curr_attach_index) + 1;
end switchname_action;


modulename_action:  proc(error);
dcl  error fixed bin(35) parameter;
     error = 0;
     curr_attach_len = atom_len + 1;
     if curr_attach_len > length(attach_array.desc(0)) then do;
	error = 1;
	convert_int_code = 1;
	if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
		"^a:  I/O module name for switchname ^a longer than ^d characters.  Rest of statement ignored.",
		whoami, curr_switchname, length(attach_array.desc(0)));
	end;
     else substr(attach_array.desc(curr_attach_index), 1) = atom ||" ";
end modulename_action;


attach_desc_word_action:  proc(error);
dcl  error fixed bin(35) parameter;
     error = 0;
     if curr_attach_len + atom_len > length(attach_array.desc(0)) then do;
	error = 1;
	convert_int_code = 1;
	if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
	     "^a:  Attach description for switchname ^a longer than ^d characters.  Rest of statement ignored.",
	     whoami, curr_switchname, length(attach_array.desc(0)));
	return;
	end;
     substr(attach_array.desc(curr_attach_index), curr_attach_len + 1) = atom||" ";
     curr_attach_len = curr_attach_len + atom_len + 1;
end attach_desc_word_action;  */


end_file_action:  proc;			/*   End of source S.D. encountered;
	Construct structures in order, and set keys_ptr, io_exits_ptr, and exits_ptr.   */
     call construct_keys;
     call construct_io_exits;
     call construct_exits;
/*     call construct_attaches;   */
     call construct_end;
end end_file_action;


construct_keys:  proc;			/*   Complete keys substructure:   */
     if statement_counts(keyword_codes.keys(1)) = 0 | keys.number = 0 then return;
     if statement_counts(keyword_codes.keys(1)) > 1 then
	do;
	if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
		"^a:  Keys statement specified ^d times.",
		whoami, statement_counts(keyword_codes.keys(1)));
	convert_int_code = 1;
	end;
     keys_ptr = work_ptr;
     work_ptr = addr(keys.dummy);	/*   Move pointer.   */
end construct_keys;


construct_io_exits:  proc;			/*   Construct io_exits substructure:   */
     input_file_exit_sw,
     output_file_exit_sw = off;
     if statement_counts(keyword_codes.exits(1)) = 0 then return;	/*   Does not move pointer.   */
     if exit_count_array(keyword_codes.input_file) = 0 & exit_count_array(keyword_codes.output_file) = 0 then return;
					/*   Does not move pointer.   */
     io_exits.version = 1;
     if exit_count_array(keyword_codes.input_file) > 1 then
	do;
	convert_int_code = 1;
	if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
		"^a:  Input_file exit specified ^d times.",
		whoami, exit_count_array(keyword_codes.input_file));
	end;
     if exit_count_array(keyword_codes.output_file) > 1 then
	do;
	convert_int_code = 1;
	if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
		"^a:  Output_file exit specified ^d times.",
		whoami, exit_count_array(keyword_codes.output_file));
	end;
     if exit_count_array(keyword_codes.input_file) > 0 then do;
	/*   Construct entry variable for input_file exit.   */
	input_file_exit_sw = on;
	call construct_entry_variable(addr(io_exits.input_file_exit),
		user_name_array(keyword_codes.input_file), "input_file");
	end;
/*1*/     else io_exits.input_file_exit = sort_$noexit;
     if exit_count_array(keyword_codes.output_file) > 0 then do;
	/*   Construct entry variable for output_file exit.   */
	output_file_exit_sw = on;
	call construct_entry_variable(addr(io_exits.output_file_exit),
		user_name_array(keyword_codes.output_file), "output_file");
	end;
/*1*/     else io_exits.output_file_exit = sort_$noexit;
     io_exits_ptr = work_ptr;
     work_ptr = addr(io_exits.dummy);		/*   move pointer.   */
end construct_io_exits;


construct_entry_variable:  proc(p, name, exit_name);
     /*   Construct entry variable for user exit procedure:   */
dcl (p ptr,
     name char(*),
     exit_name char(*) ) parameter;
dcl 1 entry_variable based(p),
      2 p1 ptr,
      2 p2 ptr;
dcl  ev  entry based(p);

     call find_command_(addr(name), length(name), p1, find_command_code);	/*   Process like a command name.   */
     p2 = null();
     if find_command_code ^= 0 then
	do;
	convert_int_code = 1;
	if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
		"^vxInitializing entry variable for user-supplied ^a exit procedure.",
		length(before(whoami, " ")) + 3, exit_name);
/*1*/	ev = sort_$noexit;
	end;
end construct_entry_variable;


construct_exits: proc;			/*   Construct exits substructure:   */
dcl  index fixed bin(17),
     sum fixed bin(35);
     if statement_counts(keyword_codes.exits(1)) = 0 then return;   	/*   Do not move pointer.   */
     sum = 0;
     do index = keyword_codes.compare to exit_max;
	sum = sum + exit_count_array(index);
	end;
     if sum = 0 then return;		/*   Without moving pointer.   */
     exits.version = 1;
/*   Test multiple occurrences & construct entry variable for each exit.     */
     do index = keyword_codes.compare to exit_max;
	if exit_count_array(index) > 1 then do;
	     convert_int_code = 1;
	     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
		"^a:  ^a exit specified ^d times.",
		whoami, exit_words(index), exit_count_array(index));
	     end;
	if exit_count_array(index) > 0 then do;
	     call construct_entry_variable(addr(exits_array(index)), user_name_array(index), exit_words(index));
	     end;
/*1*/	else exits_array(index) = sort_$noexit;
	end;   /*   of do index   */
     exits_ptr = work_ptr;
     work_ptr = addr(exits.dummy);		/*   Move pointer.   */
end construct_exits;


/*   construct_attaches:  proc;
dcl  i fixed bin(17),
     sum fixed bin(35);
     if statement_counts(keyword_codes.attach) = 0 then return;
     sum = 0;
     do i = lbound(attach_array, 1) to hbound(attach_array, 1);
	sum = sum + attach_array.count(i);
	end;
     if sum = 0 then return;
     attaches.version = 1;
     attaches.number = in_attach_max;
     do i = 1 to in_attach_max;
	if attach_array.count(i) > 1 then do;
	     convert_int_code = 1;
	     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
		"^a:  Attach statement for switchname in_^d specified ^d times.",
		whoami, i, attach_array.count(i));
	     end;
	if attach_array.count(i) > 0 then attaches.in_desc(i) = attach_array.desc(i);
	else attaches.in_desc(i) = "";
	end;
     if attach_array.count(0) > 1 then do;
	convert_int_code = 1;
	if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
		"^a:  Attach statement for switchname out_1 specified ^d times.",
		whoami, attach_array.count(0));
	end;
     if attach_array.count(0) > 0 then attaches.out_desc = attach_array.desc(0);
     else attaches.out_desc = "";
     attaches_ptr = work_ptr;
     work_ptr = addr(attaches.dummy);
end construct_attaches;   */


construct_end:  proc;
     seg_length = bin(rel(work_ptr), 24);
end construct_end;


ordinal:  proc(number) returns(char(2));	/*   Create an ordinal suffix (st, nd, rd, th, etc.):   */
dcl  number fixed bin(17),
     residue fixed bin(17);
     residue = mod(number, 100);
     if residue >= 11 & residue <= 19 then return("th");
     residue = mod(residue, 10);
     if residue = 1 then return("st");
     if residue = 2 then return("nd");
     if residue = 3 then return("rd");
     else return("th");
end ordinal;


caps:  proc(whoami)  returns(char(5));
dcl  whoami char(*) parameter;
     if whoami = "sort" then return("Sort");
     else return("Merge");
end caps;

end sort_convert_internal;
  



		    sort_ext.alm                    11/11/82  1552.0rew 11/11/82  1030.5       41679


" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" * Copyright (c) 1972 by Massachusetts Institute of        *
" * Technology and Honeywell Information Systems, Inc.      *
" *                                                         *
" ***********************************************************
"	External data for Sort
"	bindable as static internal

	name	sort_ext
	use	linkc
	even
"     FREQUENTLY USED VARIABLES:
"	DECLARATIONS EVEN WORD ALIGNED
	even
	segdef	mip
	bss	mip,1000			" (1000) bin(30)
	segdef	msp
	bss	msp,2000			" (1000) ptr
	segdef	in_buff_ptr
	bss	in_buff_ptr,2
	segdef	rec_ptr_a
	bss	rec_ptr_a,2
	segdef	rec_ptr_b
	bss	rec_ptr_b,2
	segdef	sip
	bss	sip,2
	segdef	sort_compare_exit
	bss	sort_compare_exit,4		" entry variable
	segdef	sort_input_record_exit
	bss	sort_input_record_exit,4	" entry variable
	segdef	sort_output_record_exit
	bss	sort_output_record_exit,4	" entry variable
	segdef	sort_equal_key_exit
	bss	sort_equal_key_exit,4	" entry variable
	segdef	srp
	bss	srp,2
	segdef	ssp
	bss	ssp,2
"	DECLARATIONS WORD ALIGNED
	segdef	compare_sw
	bss	compare_sw,1
	segdef	input_file_exit_sw
	bss	input_file_exit_sw,1
	segdef	input_rec_deleted
	bss	input_rec_deleted,1
	segdef	input_rec_inserted
	bss	input_rec_inserted,1
	segdef	input_record_exit_sw
	bss	input_record_exit_sw,1
	segdef	output_record_exit_sw
	bss	output_record_exit_sw,1
	segdef	equal_key_exit_sw
	bss	equal_key_exit_sw,1
	segdef	compares_counter
	bss	compares_counter,1
	segdef	disaster2
	bss	disaster2,1
	bss	,27			" To begin at multiple of 1024
	segdef	no_of_keys
	bss	no_of_keys,1
	segdef	dt
	bss	dt,32			" (0:31) bin(30)
	segdef	w
	bss	w,32			" (0:31) bin(30)
	segdef	b
	bss	b,32			" (0:31) bin(30)
	segdef	leng
	bss	leng,32			" (0:31) bin(30)
	segdef	rev
	bss	rev,32			" (0:31) bin(1)
	segdef	read_count
	bss	read_count,1
	segdef	write_count
	bss	write_count,1
	segdef	release_count
	bss	release_count,1
	segdef	return_count
	bss	return_count,1
	segdef	sii
	bss	sii,1
	segdef	ssi
	bss	ssi,1
"   NOT FREQUENTLY USED VARIABLES:
"	DECLARATIONS EVEN WORD ALIGNED
	even
	segdef	merge_in_iocb_ptrs
	bss	merge_in_iocb_ptrs,20	" (10) ptr
	segdef	time_info
	bss	time_info,30	" 1 time_info(5),
				"   2 etime fixed bin(71),
				"   2 vtime fixed bin(71),
				"   2 pf    fixed bin,
				"   2 pd_f  fixed bin;
	segdef	pu		" 1 pu(5),
pu:	dec	1		"   2 n fixed bin init((5) 1),
	bss	,3		"   3 rcpu fixed bin(71);
	dec	1
	bss	,3
	dec	1
	bss	,3
	dec	1
	bss	,3
	dec	1
	bss	,3
"	DECLARATIONS WORD ALIGNED
	segdef	acl
	bss	acl,9		" 1 acl(1) aligned,
				"   2 user_id char(32),
				"   2 modes bit(36),
	dec	0		"   2 pad init("0"b),
	bss	,1		"   2 acl_code fixed bin(35);
	segdef	debug_sw
	bss	debug_sw,1	" bit(1)
	segdef	input_driver_is_sort
	bss	input_driver_is_sort,1	" bit(1)
	segdef	input_file_max
input_file_max:  dec  10		" fixed bin(17) init(10)
	segdef	max1
	bss	max1,1
	segdef	max2
	bss	max2,1
	segdef	max3
	bss	max3,1
	segdef	max4
	bss	max4,1
	segdef	max_rec_length
	bss	max_rec_length,1
	segdef	merge_compares
	bss	merge_compares,1	" fixed bin834)
	segdef	merge_input_file_attaches
	bss	merge_input_file_attaches,640		" (10) char(256)
	segdef	merge_input_file_names
	bss	merge_input_file_names,640		" (10) char(256)
	segdef	mii
mii:	dec	0
	segdef	min_rec_length
	bss	min_rec_length,1
	segdef	old_input_file_num
	bss	old_input_file_num,1
	segdef	output_driver_is_sort
	bss	output_driver_is_sort,1	" bit(1)
	segdef	output_file_exit_sw
	bss	output_file_exit_sw,1
	segdef	output_rec_deleted
	bss	output_rec_deleted,1
	segdef	output_rec_inserted
	bss	output_rec_inserted,1
	segdef	presort_compares
	bss	presort_compares,1	" fixed bin(34)
	segdef	report_sw
	bss	report_sw,1
	segdef	sort_desc_pn
	bss	sort_desc_pn,42		" char(168)
	segdef	state
state:	dec	0			" init(0) fixed bin(35)
	segdef	terminate_print_sw
	bss	terminate_print_sw,1
	segdef	time_sw
	bss	time_sw,1		" bit(1)
	segdef	unique_prefix
	bss	unique_prefix,4
	segdef	wf_dir_name
	bss	wf_dir_name,42	" char(168)
	segdef	wf_full_name
	bss	wf_full_name,42
	segdef	whoami
	bss	whoami,2			" char(6)
	segdef	curr_input_file_attach
	bss	curr_input_file_attach,64	" char(256)
	segdef	curr_input_file_name
	bss	curr_input_file_name,64
	segdef	curr_input_file_num
	bss	curr_input_file_num,1
	segdef	curr_output_file_attach
	bss	curr_output_file_attach,64	" char(256)
	segdef	curr_output_file_name
	bss	curr_output_file_name,64
	segdef	user_out_sw
	bss	user_out_sw,8	" char(32)

	join	/link/linkc
	end
 



		    sort_initiate.pl1               02/14/84  0736.4r   02/14/84  0736.1       86346


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
%;
/* ***************************************
   *				 *
   *				 *
   * Copyright (c) 1975, 1976 by         *
   * Honeywell Information Systems, Inc. *
   *				 *
   *				 *
   *************************************** */
/*   ENTRY external to the Sort.
     Used by procedures which drive the Sort themselves.   */

/* Coded in ancient times by who knows */
/* Modified 4 Nov 1983 by C Spitzer. phx9857: work files bigger than 255 pages if input file is big enough
			       phx9927: make segs multiples of 64 pages to prevent ASTE thrashing */

initiate:	proc(temp_dir, keys_ptr, exits_ptr, user_out_sw_par, file_size_par, code);

/*   PARAMETERS   */
dcl (temp_dir char(*),		/*   Directory to contain work files:
				     "" = process directory;
				     relative or absolute path name.     */
     keys_ptr  ptr,			/*   Pointer to keys substructure	   */
     exits_ptr ptr,			/*   Pointer to exits substructure	   */
     user_out_sw_par    char(*), 	/*   Destination of Sort Report:
				     ""       = normal (user_output);
				     "-bf"    = none (discard);
				     "<other>" = switchname.     */
     file_size_par  float bin(27),	/*   File size passed by caller (sort, sort_, or user) -
				     millions of bytes  (Input).   */
     code      fixed bin(35)  	/*   Status code   		*/
    ) parameter;

/*   EXTERNAL ENTRIES     */
dcl  convert_status_code_  entry(fixed bin(35), char(8) aligned, char(100) aligned);
dcl  expand_path_ entry(ptr, fixed bin, ptr, ptr, fixed bin(35));
dcl  get_pdir_ entry returns(char(168) aligned),
     get_wdir_ entry returns(char(168) aligned);
dcl  ioa_$ioa_stream entry options(variable);
dcl  unique_chars_ entry(bit(*)) returns(char(15));

dcl  sort_merge_initiate  entry(ptr, ptr, char(*), fixed bin(35));

/*   EXTERNAL STATIC     */

% include sort_ext;

dcl  sys_info$max_seg_size fixed bin(35) external static;
dcl (error_table_$pathlong,
     error_table_$bad_arg,
     error_table_$out_of_sequence) fixed bin(35) external static;

/*   INTERNAL STATIC  (constants only)   */
dcl (on bit(1) init("1"b),
     off bit(1) init("0"b) ) internal static;

/*   AUTOMATIC and BASED     */
dcl  file_size_temp  fixed bin(71);	/*   Temporary location for file size - in bytes   */
dcl  merge_order fixed bin(35),
     string_size fixed bin(35);

dcl  state_code fixed bin(35);
dcl  arg_err_sw bit(1);
dcl  expand_path_code fixed bin(35);
dcl  shortinfo char(8) aligned,
     longinfo char(100) aligned;
dcl  keys_ptr_pass ptr,		/*   Arguments passed to sort_merge_initiate.   */
     exits_ptr_pass ptr,
     user_out_sw_pass char(32),
     s_m_init_code fixed bin(35);
dcl  (addr, before, ceil, divide, index, length, min, null, sqrt) builtin;

/*   Start.   */

     call state_test(state_code);
     if state_code ^= 0 then do;
	code = error_table_$out_of_sequence;
	return;		/*   to caller without resetting state variable   */
	end;
     state = 3;
     if user_out_sw_par = "" then user_out_sw = "user_output";
     else if user_out_sw_par = "-bf" | user_out_sw_par = "-brief" then user_out_sw = "";
     else user_out_sw = user_out_sw_par;
     merge_order = 0;		/*   Merge order not specified.   */
     string_size = 0;		/*   String_size not specified.   */
     time_sw = off;			/*   Timing not specified.   */
     debug_sw = off;		/*   Debug optionn not specified.   */
     terminate_print_sw = on;		/*   sort_terminate should print Sort Report.   */

common_start:
     code = 0;
     file_size_temp = file_size_par * 10**6 + 1;
     arg_err_sw = off;
     old_input_file_num = 1;		/*   For sort_presort's illegal_procedure handler.   */

     call initialize_presort;

     keys_ptr_pass = keys_ptr;
     exits_ptr_pass = exits_ptr;
     user_out_sw_pass = user_out_sw;
     s_m_init_code = 0;
     call sort_merge_initiate(keys_ptr_pass, exits_ptr_pass, user_out_sw_pass, s_m_init_code);

/*   temp_dir:   */
     call get_wf_dir_name;

exit:
     if s_m_init_code ^= 0 then code = s_m_init_code;
     if arg_err_sw = on then code = error_table_$bad_arg;
     return;


/*   ENTRY internal to the Sort; called only by sort_ subroutine.   */
initiate_private:  entry(temp_dir, keys_ptr, exits_ptr, user_out_sw_par, file_size_par,
			code, merge_order_par, string_size_par);
dcl (merge_order_par  fixed bin(35),			/*   Way of the merge.   */
     string_size_par  fixed bin(35) ) parameter;		/*   Presort string size in bytes.   */
     /*   user_out_sw_par ignored; sort_ has already set user_out_sw properly.   */
     /*   time_sw, debug_sw already set.   */
     state = 3;
     terminate_print_sw = off;	/*   sort_ should print Sort Report.   */
     merge_order = merge_order_par;
     string_size = string_size_par;
     go to common_start;


state_test:  proc(state_code);
dcl  state_code fixed bin(35) parameter;
     if state = 0
	| (state = 8 & index(whoami, "_") ^= 0) 		/*   subroutine was called last   */
	then do;
	unique_prefix = before(unique_chars_("0"b), " ")||".";
	whoami = "sort_";
	state_code = 0;
	end;
     else do;		/*   Error   */
	state_code = 1;
	return;
	end;
end state_test;


get_wf_dir_name: proc;

     if temp_dir = "" | temp_dir = "-pd" | temp_dir = "-process_directory" | temp_dir = "-process_dir" then
	/*   process directory   */
	do;
	wf_dir_name = get_pdir_();
	end;

     else if temp_dir = "-wd" | temp_dir = "-working_directory" | temp_dir = "-working_dir" then
	/*   current working directory   */
	do;
	wf_dir_name = get_wdir_();
	end;

     else
	     /*   Convert to absolute path name.   */
	do;
	call expand_path_(addr(temp_dir), length(temp_dir),
		        addr(wf_dir_name), null(), expand_path_code);
	if expand_path_code ^= 0 then
	     do;
	     /*   error_table_$badpath
			  $dirlong
			  $lesserr
			  $pathlong   */
		call convert_status_code_(expand_path_code, shortinfo, longinfo);
	     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw, 
		"^a:  ^a  Temporary directory pathname ^a",
		whoami, longinfo, temp_dir);
	     arg_err_sw = on;
	     return;
	     end;
	end;
     wf_full_name = before(wf_dir_name, " ")||">"||unique_prefix||"sort_work.";
     if index(wf_full_name, " ") = 0 | index(wf_full_name, " ") > 160 then do;
	/*   Error: work file directory name potentially too long   */
	call convert_status_code_(error_table_$pathlong, shortinfo, longinfo);
	if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw, 
		"^a:  ^a  Pathname and prefix for work files ^a",
		whoami, longinfo, wf_full_name);
	arg_err_sw = on;
	end;
end get_wf_dir_name;

initialize_presort:	proc;
	    /*  this procedure will initialize the necessary variables to perform the sort  */
	disaster2 = 0;   /*  return state -  =first call, 1 =later call, 2 = last call */
	mii = 0;		/*   number of merge strings produced   */
	sip = null();	/*   for sort_cleanup_proc in case release not called   */
	ssi = 0;
	sii = 0;
	max1 = (sys_info$max_seg_size -100)*4;
	max3 = divide(sys_info$max_seg_size - 100, 3, 24, 0);
	max4 = 999;		/*   maximum merge order   */
	call compute_string_size;
end initialize_presort;


compute_string_size:  proc;
dcl MAX_WORK_SEGMENT_SIZE_64K fixed bin (21) int static options (constant) init (4096*64);     /* 64 pages */
dcl MAX_WORK_SEGMENT_SIZE_255K fixed bin (21) int static options (constant) init (4096*255);   /* 255 pages */
dcl (number_64k_segs, number_255k_segs) fixed bin (30);
     if file_size_temp < 50 then file_size_temp = 1.04*10**6;	/*   Default    */
     if merge_order < 1 & string_size < 1 then	   /*  Caller did not specify; base string size on file size  */
	if file_size_temp <= 4096 then max2 = 4096;
	else do;
	     max2 = ceil(sqrt(divide(file_size_temp, 4096, 71, 36))) * 4096;
	     if max2 > MAX_WORK_SEGMENT_SIZE_64K	/* work segs larger than 64 pages */
	     then do;
		number_64k_segs = divide (max2, MAX_WORK_SEGMENT_SIZE_64K, 30, 0) + 1;
		number_255k_segs = divide (number_64k_segs, 4, 30, 0) + 1;
		if number_64k_segs > max4
		then if number_255k_segs > max4
		     then do;
			max2 = MAX_WORK_SEGMENT_SIZE_255K; /* size of a single work segment */
			max4 = number_255k_segs;	/* need this many work segments */
			end;
		     else max2 = MAX_WORK_SEGMENT_SIZE_255K;  /* have to use 255k segs */
		else max2 = MAX_WORK_SEGMENT_SIZE_64K;	/* use 64k work segs to prevent 255k ASTE thrashing */
		end;
	     end;
     else if merge_order < 1 & string_size > 0 then do;		/*   User specified string size   */
	max2 = string_size;
  	if max2 > max1 + 200 then do;
	     arg_err_sw = on;
	     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw, 
		"^a:  Invalid string_size argument ^d.  Must be < ^d.",
			whoami, max2, max1 + 201);
	     end;
	end;
     else if merge_order > 0 & string_size < 1 then do;		/*   User specified merge order   */
	max2 = divide(file_size_temp, merge_order, 71, 36);	/*   Compute corresponding string size   */
	if max2 > max1 + 200 then do;
	     arg_err_sw = on;
	     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
		"^a:  File size too large for specified merge_order argument ^d.",
		whoami, merge_order);
	     end;
	end;
     else do;
	arg_err_sw = on;
	if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw, 
		"^a:  Both merge_order and string_size arguments specified.",
		whoami);
	end;
end compute_string_size;


end initiate;
  



		    sort_input_proc.pl1             02/14/84  0736.4r   02/14/84  0735.8      110961


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
%;
/* ***************************************
   *				 *
   *				 *
   * Copyright (c) 1975, 1976, 1977 by   *
   * Honeywell Information Systems, Inc. *
   *				 *
   *				 *
   *************************************** */
sort_input_proc: proc(input_proc_code);

/*   EXTERNAL ENTRIES   */
dcl  ioa_$rsnnl entry options(variable);
dcl  iox_$attach_ioname entry(char(*), ptr, char(*), fixed bin(35));
dcl  iox_$open entry(ptr, fixed bin, bit(1) aligned, fixed bin(35));
dcl  iox_$read_record entry(ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35));
dcl  iox_$close entry(ptr, fixed bin(35));
dcl  iox_$detach_iocb entry(ptr, fixed bin(35));
dcl  iox_$destroy_iocb entry(ptr, fixed bin(35));
dcl  sub_err_ entry options(variable);


/*   EXTERNAL STATIC   */

%include sort_ext;

dcl (error_table_$not_detached,
     error_table_$not_attached,
     error_table_$not_closed,
     error_table_$no_record,
     error_table_$not_open,
     error_table_$short_record,
     error_table_$long_record,
     error_table_$end_of_info,
     error_table_$out_of_sequence,
     error_table_$request_not_recognized,
     error_table_$fatal_error) fixed bin(35) external;

/*   PARAMETERS AND AUTOMATIC   */
dcl  input_proc_code fixed bin(35) parameter;

dcl  in_switch char(32),
     in_switch_length fixed bin(17),
     iox_code fixed bin(35),
     sort_code fixed bin(35),
     in_iocb_ptr ptr,
     in_mode fixed bin,
     seq_input fixed bin init(4),
     no_extend bit(1) aligned init("0"b),
     in_buff_len fixed bin(21) init(sort_ext$max_rec_length),      
     in_rec_len fixed bin(21),
     in_attach_desc char(176);
dcl  this_file_read_count fixed bin(35);
dcl  sort_release_ptr ptr;
dcl  sort_release_len fixed bin (21);
dcl  retval  fixed bin(35);
dcl  cleanup condition;


/*   Start.   */
     input_proc_code = 0;
     in_iocb_ptr = null();
     on cleanup call cleanup_proc;
     call ioa_$rsnnl(unique_prefix||"sort_in_^d_", in_switch, in_switch_length, curr_input_file_num);
					/*   Convert from fixed binary to character string.   */
/*   Attach.   */
     if curr_input_file_attach = "" then in_attach_desc = "vfile_ "||curr_input_file_name;
     else in_attach_desc = curr_input_file_attach;
     call iox_$attach_ioname(in_switch, in_iocb_ptr, in_attach_desc, iox_code);
     if iox_code ^= 0 then do;
	/*   error_table_$not_detached   */
	call iox_error("Attaching");
          end;
/*   Open.   */
     in_mode = seq_input;
     call iox_$open(in_iocb_ptr, in_mode, no_extend, iox_code);
     if iox_code ^= 0 then do;
	/*   error_table_$not_attached
	                 $not_closed   */
	call iox_error("Opening");
	end;
     this_file_read_count = 0;
/*   Read and release.   */
read:  call iox_$read_record(in_iocb_ptr, in_buff_ptr, in_buff_len, in_rec_len, iox_code);
     if iox_code = error_table_$end_of_info then go to close;
     if iox_code ^= 0 then do;
	/*   error_table_$no_record
                           $long_record   */
	call iox_error("Reading");
          end;
     this_file_read_count = this_file_read_count + 1;
     sort_release_ptr = in_buff_ptr;			/* save to pass because sort_release can change the contents of it */
     sort_release_len = in_rec_len;
     call sort_release(sort_release_ptr, sort_release_len, sort_code);
     if sort_code ^= 0 then do;
	/*   release errors   */
	if sort_code = error_table_$long_record | sort_code = error_table_$short_record then do;
	     if curr_input_file_attach = "" then
	     call sub_err_(sort_code, whoami, "c", null(), retval,
		"Record ^d of input file ^d, file name ^a",
			this_file_read_count, curr_input_file_num, curr_input_file_name);
	     else call sub_err_(sort_code, whoami, "c", null(), retval,
		"Record ^d of input file ^d, attach description ^a",
			this_file_read_count, curr_input_file_num, curr_input_file_attach);
	     input_proc_code = error_table_$fatal_error;
	     call cleanup_proc;
	     go to exit;
	     end;
	else if sort_code = error_table_$out_of_sequence then do;
	     call sub_err_(sort_code, whoami, "c", null(), retval,
		"Calling sort_$release.");
	     call cleanup_proc;
	     go to exit;
	     end;
	else do;
	     input_proc_code = sort_code;
	     call cleanup_proc;
	     go to exit;
	     end;
          end;
     go to read;
/*   Close.   */
close:
     read_count = read_count + this_file_read_count;
     call iox_$close(in_iocb_ptr, iox_code);
     if iox_code ^= 0 then do;
	/*   error_table_$not_open   */
	call iox_error("Closing");
	end;
/*   Detach.   */
     call iox_$detach_iocb(in_iocb_ptr, iox_code);
     if iox_code ^= 0 then do;
	/*   error_table_$not_attached
		       $not_closed   */
	call iox_error("Detaching");
	end;
/*   Destroy iocb.   */
     call iox_$destroy_iocb(in_iocb_ptr, iox_code);
     in_iocb_ptr = null();
/*   no errors returned?   */
exit:
     return;		/*   to driver   */
   release:	entry(pt,fb,fb1);
	dcl	pt ptr,
		fb fixed bin(21),
		fb1 fixed bin(35);

	    sort_release_ptr = pt;
	    sort_release_len = fb;
	    call sort_release(sort_release_ptr,sort_release_len,fb1);
	    return;
		/*						*/
%;
sort_release:		proc(relp,relbl,ec);
			/*    EXTERNAL ENTRIES    */
dcl	hcs_$make_seg  entry(char(*) aligned, char(*) aligned, char(*), fixed bin(5), ptr, fixed bin(35)),
	sort_presort		entry(fixed bin(35)) ext;
			/*    EXTERNAL STATIC    */
			/*  PARAMETERS,AUTOMATIC & BASED  */
	dcl	presort_code fixed bin(35);
	dcl	retval fixed bin(35);
	dcl	(relp ptr,
		relbl fixed bin(21)) parameter;
dcl  		hcs_code fixed bin(35);
%include sort_common;
	dcl	input_rec char(262144) based(relp);
		/*  following declarations are for input record exit  */
	dcl	hold_ptr ptr int static,
		hold_len fixed bin(24) int  static,
		rec_len fixed bin(21) int static,
		rec_ptr ptr int static,
		action fixed bin int static,
		close_exit bit(1) int static;

	ec = 0;   /*    initially set error code to 0  */

		/*  test state code  */
	if state ^= 3 then     /*  initiate not yet called-sequence error  */
	    do;
		ec = error_table_$out_of_sequence;
		return;
	    end;

		/*  test for short and long record length  */
	if relbl > max_rec_length then  /*  record too long  */
	    do;
		ec = error_table_$long_record  ;
		return;
	    end;
	if relbl < min_rec_length then    /*  record too short  */
	    do;
		ec = error_table_$short_record;
		return;
	    end;
	if ssi=0 then do;	/* This is the initial call to RELEASE.  */
	call hcs_$make_seg(wf_dir_name, unique_prefix||"sort_work.SI", "", 8+2,  /*  rw  */ sip, hcs_code);
	if hcs_code ^= 0 then do;
	     call hcs_error("create", "SI");
	     return;
	     end;
	     call hcs_$make_seg(wf_dir_name, unique_prefix||"sort_work.SR", "", 8+2, srp, hcs_code);
	if hcs_code ^= 0 then do;
	     call hcs_error("create", "SR");
	     return;
	     end;
	call hcs_$make_seg(wf_dir_name, unique_prefix||"sort_work.SS", "", 8+2, ssp, hcs_code);
	if hcs_code ^= 0 then do;
	     call hcs_error("create", "SS");
	     return;
	     end;
	mii = 0;
	ssi = 1;
	sii = 0;
	end;
	if (((relbl+ssi)>max1) & (mii ^= 0)) | (sii>max3) | (relbl+ssi) > max2 then do;
					/* Sort the accumulated records. */
	call sort_presort(presort_code);
	if presort_code ^= 0 then do;
	     ec = presort_code;
	     return;
	     end;

	/* Initialize the sort tables for next input. */
	sii = 0;
	ssi = 1;
	end;
 rep:	if input_record_exit_sw ^= 0 then    /*  test for input record exit  */
	    do;
	      if close_exit = "1"b then if relp=null()  /* called from commence with close exit on */
		then return;
		else go to norm;
	      rec_ptr = relp;    /*  use input's input buffer  */
	      rec_len = relbl;
	      action = 0;
	      call sort_input_record_exit(rec_ptr,rec_len,action,close_exit);
	      if rec_ptr=null() & action^=3 then return;
		/*  called from commence and no inserted record  */
	      if  action = 0 then
		do;    /*  accept current record  */
		 call ck_len(rec_len,"altered");
		 relp = rec_ptr;  /*  set record to be accepted  to the one handed  back by user  */
		 relbl = rec_len;
		 go to norm;
		end;
	      if action = 1 then   /*  delete the current record  */
		do;
		 input_rec_deleted = input_rec_deleted+1;  /*  increment deleted count  */
		 return;
		end;
	      if  action = 3 then
		do;    /*  insert a new record  */
		 call ck_len(rec_len,"inserted");
		 hold_ptr = relp;  /*  save old current record and length  */
		 hold_len = relbl;
		 relp = rec_ptr;    /*  set release pointer to record to be inserted  */
		 relbl = rec_len;
		 input_rec_inserted = input_rec_inserted+1;  /*  increment inserted count  */
		 go to norm;
		end;
	      else do;    /*  illegal action code  */
		   call sub_err_(error_table_$request_not_recognized, whoami, "c", null(), retval,
			"Invalid action = ^d by user input_record exit procedure.",action);
		   ec=error_table_$fatal_error;
		   goto exit;
		 end;
	    end;
		/*  following will set up double word alignment mechanism  */
 norm:	ssi=divide(ssi + 4 -1 +7,8,24) *8 + 1;
     if compare_sw ^= 0 then do;
	w_p = addr(substr(ssp->S,ssi,1));
	w_p = ptr(w_p,fixed(rel(w_p),21)-1);   /*  move back one word  */
	fb = relbl;    /*  set length of  record  */
     end;
	/* Move the input record into the sort storage area. */
	substr(ssp->S,ssi,relbl)=substr(input_rec,1,relbl);  /*  relfb changed to 1-always start with first pos  */
	sii=sii+1;	/* Count of the records for the next sort. */
	srp->R.pt(sii)=ssi;	/* Location in sort storage segment of the record. */
	srp->R.ln(sii)=relbl;	/* The length of the record. */
	release_count = release_count +1;    /*  increment release count  */
	ssi=ssi+relbl;	/* Update the next location
			   available in the sort storage segment. */
	sip->I(sii)=sii;	/* Record index for sort. */
	if input_record_exit_sw ^= 0 & action = 3 then
	    do;  /*  input record  switch on and just   inserted a record  */
	         /*  don't get another record  */
	      relp = hold_ptr;  /*  reset current record to old current record  */
	      relbl = hold_len;
	      action  = 0;  /*  incase close exit is  on next  time through  */
	      go to rep;
	    end;
 exit:	return;


 ck_len:      proc(length,action_type);
		    /*  this will check the length handed to it by the input record exit
			code-if it is too long it will write an error mesage and exit with
			a fatal error code						*/
		/*						*/
	dcl	sub_err_ entry options(variable),
		length fixed bin(21) parameter,
		action_type char(*) parameter;
	    if length > max_rec_length then
		do;    /*  record too long  */
		   call sub_err_(error_table_$long_record,whoami, "c", null(), retval,
			"Record ^a by user input_record exit procedure.",action_type);
		   ec=error_table_$fatal_error;
		   goto exit;
		end;
	    if length <min_rec_length then
		do;    /*  record too short  */
		   call sub_err_(error_table_$short_record,whoami, "c", null(), retval,
			"Record ^a by user input_record exit procedure.",action_type);
		   ec=error_table_$fatal_error;
		   goto exit;
		end;
 end ck_len;
hcs_error:  proc(action, name);
dcl (action,
     name) char(*) parameter;
     call sub_err_(hcs_code, whoami, "c", null(), retval,
		"Unable to ^a temporary segment ^a>^a",
		action, before(wf_dir_name, " "), unique_prefix||name);
     ec = error_table_$fatal_error;
end hcs_error;
end sort_release;

iox_error:  proc(action);
dcl  action char(*) parameter;
	input_proc_code = error_table_$fatal_error;
	if curr_input_file_attach = "" then
	     call sub_err_(iox_code, whoami, "c", null(),retval,
		"^a input file ^d, file name ^a",
			action, curr_input_file_num, curr_input_file_name);
	else call sub_err_(iox_code, whoami, "c", null(), retval,
		"^a input file ^d, attach description ^a",
			action, curr_input_file_num, curr_input_file_attach);
	call cleanup_proc;
	go to exit;
end iox_error;


cleanup_proc:  proc;
     if in_iocb_ptr = null() then return;
     call iox_$close(in_iocb_ptr, iox_code);
     call iox_$detach_iocb(in_iocb_ptr, iox_code);
     call iox_$destroy_iocb(in_iocb_ptr, iox_code);
end cleanup_proc;

end sort_input_proc;
   



		    sort_merge_command.pl1          11/11/82  1552.0rew 11/11/82  1024.7      214785


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