


		    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.      *
   *                                                         *
   *********************************************************** */

/* Modified on 02/17/82 by FCH, [1], version number printed */

sort_merge_command:  proc(input_file, output_file, sort_desc, temp_dir, user_out_sw_par, total_if_pns,
		     arg_err_sw, fatal_sw, no_args_sw, merge_order_par, string_size_par,
		     file_size_par, total_args, arg_list_ptr, perm_sd, temp_sd);

/*   PARAMETERS   */
dcl (input_file(*) char(*),		/*   Input file pathnames or attach descriptions  (Output).	   */
     output_file  char(*),		/*   Output file pathname or attach description  (Output).	   */
     sort_desc(1)  ptr,		/*   Pointer to Sort/Merge Description (source form)  (Output).	*/
     temp_dir  char(*),		/*   Pathname of directory for work files  (Output). 		*/
     user_out_sw_par  char(*),     	/*   Switchname for diagnostics and Sort/Merge Report  (Output).  	*/
     total_if_pns  fixed bin(35),	/*   Number of input files specified by user  (Output).	   */
     arg_err_sw bit(1),		/*   Error(s) detected in arguments  (Output).			*/
     fatal_sw  bit(1),		/*   Fatal error detected  (Output).				*/
     no_args_sw  bit(1),		/*   no arguments specified - user will be prompted  (Output).	*/
     merge_order_par  fixed bin(35),	/*   Merge order specified by user  (Output).			*/
     string_size_par  fixed bin(35),	/*   String size specified by user  (Output).			*/
     file_size_par  float bin(27),	/*   File size specified by user  (Output).			*/
     total_args  fixed bin(35),	/*   Number of arguments specified  (Input).			*/
     arg_list_ptr  ptr,		/*   Pointer to command's argument list - sort or merge  (Input).	*/
     perm_sd    ptr,		/*   Pointer to Sort/Merge Description if -sd pn specified  (Output)  */
     temp_sd    ptr ) parameter;	/*   Pointer to Sort/Merge Description when -ci specified  (Output)   */

/*   EXTERNAL ENTRIES    */
dcl  convert_status_code_  entry(fixed bin(35), char(8) aligned, char(100) aligned);
dcl  cu_$arg_ptr_rel entry(fixed bin, ptr, fixed bin, fixed bin(35), ptr);
dcl  cv_dec_check_ entry(char(*), fixed bin(35)) returns(fixed bin(35));
dcl  cv_float_  entry(char(*), fixed bin(35), float bin(27));
dcl  expand_path_ entry(ptr, fixed bin, ptr, ptr, fixed bin(35));
dcl  get_pdir_ entry returns(char(168) aligned);
dcl  hcs_$initiate entry(char(*) aligned, char(*) aligned, char(*),
		     fixed bin(1), fixed bin(2), ptr, fixed bin(35)),
     hcs_$make_seg entry(char(*) aligned, char(*) aligned, char(*), fixed bin(5), ptr, fixed bin(35)),
     hcs_$truncate_seg entry(ptr, fixed bin(24), fixed bin(35)),
     hcs_$set_bc_seg entry(ptr, fixed bin(24), fixed bin(35));
dcl  ioa_ entry options(variable),
     ioa_$nnl  entry options(variable),
     ioa_$ioa_switch entry options(variable);
dcl  iox_$get_line  entry(ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35));

/*   EXTERNAL STATIC     */

%include sort_ext;
dcl (iox_$user_output,
     iox_$user_input,
     iox_$user_io)  ptr external static;
dcl (error_table_$bad_arg,
     error_table_$bigarg) fixed bin(35) external;

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

/*   AUTOMATIC AND BASED     */
dcl  shortinfo char(8) aligned,
     longinfo char(100) aligned;

dcl  none fixed bin(1);

dcl (if_arg_count,
     of_arg_count,
     td_arg_count,
     file_size_arg_count,
     ci_fi_arg_count,
     time_arg_count,
     merge_order_arg_count,
     string_size_arg_count,
     debug_arg_count,
     bf_lg_arg_count) fixed bin(17);

dcl (total_of_pns,
     total_td_pns,
     total_file_size_args,
     total_fi_pns,
     total_merge_order_args,
     total_string_size_args) fixed bin(17);
dcl  temp_if_pns fixed bin(17);

dcl  last_ci_fi char(16),
     last_bf_lg char(8),
     file_size char(16),
     merge_order char(8),
     string_size char(16);

dcl  arg_num      fixed bin,
     arg_ptr      ptr,
     arg_len      fixed bin,
     cu_code      fixed bin(35);
dcl  argument char(arg_len) based(arg_ptr);

dcl  pn_or_attach char(256);
dcl  file_spec_keyword  char(32);

dcl (expand_code,
     cv_err) fixed bin(35);

dcl  hcs_code fixed bin(35);
dcl  iox_code fixed bin(35);
dcl  process_dir char(168) aligned;


/*   Start.   */

/*   Set error switches off.   */
     no_args_sw, fatal_sw, arg_err_sw = off;

/*   Obtain all arguments of the command.   */
     call get_all_args;

/*   Process the arguments in appropriate sequence.
     Report errors including inconsistencies between arguments.
     Do not report on errors in Sort/Merge Description;
     that is deferred until sort_(merge_) or sort_(merge_)$initiate.
     Prepare parameters for call to sort_(merge_).     */

     call process_ci_fi_arg;
     call process_if_arg;
     call process_of_arg;
     call process_td_arg;
     call process_file_size_arg;
     call process_bf_lg_arg;
     call process_time_arg;
     call process_merge_order_arg;
     call process_string_size_arg;
     call process_debug_arg;

exit:
     return;		/*   To caller (sort or merge).   */


get_all_args: proc;		/*   Get all arguments of command.   */

/*   Set all argument counters = 0.   */
     if_arg_count,
     of_arg_count,
     td_arg_count,		/*   Not used by merge.   */
     file_size_arg_count,
     ci_fi_arg_count,
     bf_lg_arg_count,
     time_arg_count,
     merge_order_arg_count,		/*   Not used by merge.   */
     string_size_arg_count,		/*   Not used by merge.   */
     debug_arg_count = 0;
/*   Set all path name counters = 0.   */
     total_if_pns, temp_if_pns,
     total_of_pns,
     total_td_pns,		/*   Not used by merge.   */
     total_fi_pns = 0;
     if total_args = 0 then do;	/*   Prompt user.   */
/*1*/	call ioa_("^a:  Version 2.0",whoami);
	call ioa_("^a:  Command and basic arguments are:",
	     whoami);
	call ioa_("^2x^a  {-if pn|-ids ""att_desc""} {-of pn|-ods ""att_desc""}  {-ci|-^ad ^a_desc}",
	     whoami, substr(whoami, 1, 1), whoami);
	no_args_sw = on;
	go to exit;
	end;
     arg_num = 0;

/*   Get first argument -- Sort/Merge Description:
     call get_one_arg(none);
     if none = 1 then do;
	   Error:  Sort/Merge Description required, but will be detected later by process_ci_fi_arg.     
	return;
	end;
     call get_sd_arg;		*/
get_next_arg:  call get_one_arg(none);		/*   Get next argument of command.   */
     if none = 1 then return;
     if argument = "-input_file" | argument = "-if"
      | argument = "-input_description" | argument = "-ids" then do;
	call get_if_arg;
	go to get_next_arg;
	end;
     else if argument = "-output_file" | argument = "-of"
           | argument = "-output_description" | argument = "-ods" then do;
	call get_of_arg;
	go to get_next_arg;
	end;
     else if argument = "-temp_dir" | argument = "-td" | argument = "-temp_directory" then
	do;	/*   Will be rejected later for merge.   */
	call get_td_arg;
	go to get_next_arg;
	end;
     else if argument = "-ci" | argument = "-console_input" then
	do;		/*   Allow -ci argument to appear anywhere in command line.   */
	call get_ci_arg;
	go to get_next_arg;
	end;
     else if argument = "-sd" | argument = "-md"
	| argument = "-sort_desc" | argument = "-merge_desc"
	| argument = "-sort_description" | argument = "-merge_description" then do;
	call get_sd_arg;
	go to get_next_arg;
	end;
     else if argument = "-file_size" then do;
	call get_file_size_arg;
	go to get_next_arg;
	end;
     else if argument = "-brief" | argument = "-bf" then
	do;
	call get_bf_lg_arg;
	go to get_next_arg;
	end;
     else if argument = "-time" | argument = "-tm" then do;
	call get_time_arg;
	go to get_next_arg;
	end;
     else if argument = "-merge_order" then do;	/*   Will be rejected later for merge.   */
	call get_merge_order_arg;
	go to get_next_arg;
	end;
     else if argument = "-string_size" then do;	/*   Will be rejected later for merge.   */
	call get_string_size_arg;
	go to get_next_arg;
	end;
     else if argument = "-debug" | argument = "-db" then do;
	call get_debug_arg;
	go to get_next_arg;
	end;
     else do;
	/*   Error:  unrecognized control argument.   */   
	call convert_status_code_(error_table_$bad_arg, shortinfo, longinfo);
	call ioa_$ioa_switch(iox_$user_output, "^a:  ^a  Argument ""^a"" is ignored.", whoami, longinfo, argument);
	arg_err_sw = on;
	go to get_next_arg;
	end;
end get_all_args;

get_one_arg:  proc(none);		/*   Get one argument of command:   */
dcl  none fixed bin(1);     /* value 1 = no next argument     */

loop:  arg_num = arg_num + 1;
     if arg_num > total_args then
	do;
	none = 1;
	return;
	end;
     call cu_$arg_ptr_rel(arg_num, arg_ptr, arg_len, cu_code, arg_list_ptr);
     if cu_code ^= 0 then
	do;
	call convert_status_code_(cu_code, shortinfo, longinfo);
	call ioa_$ioa_switch(iox_$user_output, "^a:  ^a  Argument ^d", whoami, longinfo, arg_num);
	fatal_sw = on;
	return;
	end;
     if arg_len = 0 | argument = "" then
	do;
	arg_err_sw = on;
	call ioa_$ioa_switch(iox_$user_output, "^a:  Argument """" ignored.", whoami);
	go to loop;
	end;
     if arg_len > 256 then
	do;
	arg_len = 256;
	arg_err_sw = on;
	call convert_status_code_(error_table_$bigarg, shortinfo, longinfo);
	call ioa_$ioa_switch(iox_$user_output, "^a:  ^a  Argument ^a truncated.", whoami, longinfo, argument);
	end;
     none = 0;
end get_one_arg;


get_if_arg: proc;		/*   Get argument following input file specification keyword argument.   */
     if_arg_count = if_arg_count + 1;
     file_spec_keyword = argument;
     call get_pn_or_attach;
     if pn_or_attach = "" then return;	/*   No pathname or attach   */
     temp_if_pns = temp_if_pns + 1;
     if total_if_pns >= input_file_max then do;
	arg_err_sw = on;
	call ioa_$ioa_switch(iox_$user_output,
			"^a:  Too many input files specified.  Specification ^a ^a for input file ^d ignored.",
		whoami, file_spec_keyword, pn_or_attach, temp_if_pns);
	return;
	end;
     total_if_pns = total_if_pns + 1;
     input_file(total_if_pns) = before(file_spec_keyword, " ")||" "||pn_or_attach;
end get_if_arg;


get_of_arg: proc;		/*   Get word following input file specification keyword.   */
     of_arg_count = of_arg_count + 1;
     total_of_pns = 0;
     output_file = "";
     file_spec_keyword = argument;
     call get_pn_or_attach;
     if pn_or_attach = "" then return;	/*   No pathname or attach.   */
     total_of_pns = total_of_pns + 1;
     output_file = before(file_spec_keyword, " ")||" "||pn_or_attach;
end get_of_arg;


get_pn_or_attach:  proc;
     pn_or_attach = "";
     call get_one_arg(none);
     if none = 1 then do;	/*   No argument follows.   */
	call no_pns_err(file_spec_keyword, " or attach description");
	end;
     else if substr(argument, 1, 1) ^= "-" then do;	/*   Pathname or attach description.   */
	pn_or_attach = argument;
	end;
     else if argument = "-rp" | argument = "-replace" then do;
	pn_or_attach = argument;
	end;
     else do;	/*   Next control argument found.   */
	arg_num = arg_num - 1;
	call no_pns_err(file_spec_keyword, " or attach description");
	end;
end get_pn_or_attach;


get_td_arg: proc;		/*   Get path name or -pd or -wd following -td argument.   */
     td_arg_count = td_arg_count + 1;
     total_td_pns = 0;
     temp_dir = "-pd";
     call get_one_arg(none);
     if none = 1 then return;
     if argument = "-process_directory" | argument = "-working_directory"
		| argument = "-process_dir" | argument = "-working_dir"
		| argument = "-pd" | argument = "-wd"
		| substr(argument, 1, 1) ^= "-" then do;
	total_td_pns = total_td_pns + 1;
	temp_dir = argument;
	return;
	end;
     else
     /*   argument begins with "-" (but is not "-pd" or "-wd").   */
     arg_num = arg_num - 1;		/*   Will be treated as next control argument.   */
     return;
end get_td_arg;


get_ci_arg: proc;
     ci_fi_arg_count = ci_fi_arg_count + 1;
     last_ci_fi = "-console_input";
end get_ci_arg;


get_sd_arg:  proc;		/*   Get Sort/Merge Description argument:   */
     ci_fi_arg_count = ci_fi_arg_count + 1;
     total_fi_pns = 0;
     call get_one_arg(none);
     if none = 1 then return;
     if substr(argument, 1, 1) = "-" then do;	/*   Found next control argument.    */
	arg_num = arg_num - 1;
	return;
	end;
     else do;
	total_fi_pns = total_fi_pns + 1;
	sort_desc_pn = argument;
	last_ci_fi = "-fi";		/*   Indicates that S.D. argument is a path name (file input).   */
	end;
end get_sd_arg;


get_file_size_arg:  proc;
     file_size_arg_count = file_size_arg_count + 1;
     total_file_size_args = 0;
     call get_one_arg(none);
     if none = 1 then return;
     if substr(argument, 1, 1) = "-" then do;
	arg_num = arg_num - 1;
	return;
	end;
     else do;
	total_file_size_args = total_file_size_args + 1;
	if arg_len > 16 then do;
	     arg_err_sw = on;
	     call ioa_$ioa_switch(iox_$user_output,
			"^a:  -file_size argument too long.  Must be <_ 16 characters.",
			whoami);
	     end;
	file_size = argument;
	end;
end get_file_size_arg;


get_bf_lg_arg:  proc;		/*   Count report arguments; save last value:   */
     bf_lg_arg_count = bf_lg_arg_count + 1;
     last_bf_lg = argument;
end get_bf_lg_arg;


get_time_arg: proc;
     time_arg_count = time_arg_count + 1;
end get_time_arg;


get_merge_order_arg: proc;
     merge_order_arg_count = merge_order_arg_count + 1;
     total_merge_order_args = 0;
     call get_one_arg(none);
     if none = 1 then return;
     if substr(argument, 1, 1) = "-" then do;
	arg_num = arg_num - 1;
	return;
	end;
     else do;
	total_merge_order_args = total_merge_order_args + 1;
	merge_order = argument;
	end;
end get_merge_order_arg;


get_string_size_arg: proc;
     string_size_arg_count = string_size_arg_count + 1;
     total_string_size_args = 0;
     call get_one_arg(none);
     if none = 1 then return;
     if substr(argument, 1, 1) = "-" then do;
   	arg_num = arg_num - 1;
	return;
	end;
     else do;
	total_string_size_args = total_string_size_args + 1;
	string_size = argument;
	end;
end get_string_size_arg;


get_debug_arg:  proc;
     debug_arg_count = debug_arg_count + 1;
end get_debug_arg;


process_if_arg: proc;
/*   Process input file specification.   */
     if if_arg_count <= 0 then		/*   No -if/-ids argument.   */
	do;
	input_file(1) = "";		/*   Spaces will indicate no input files when sort_ is called.   */
	return;
	end;
end process_if_arg;


process_of_arg:  proc;
/*   Process output file specification.   */
     if of_arg_count <= 0 then		/*   No -of/-ods argument.   */
	do;
	output_file = "";
	return;
	end;
     if of_arg_count > 1 then		/*   More than one -of/-ods argument.   */
	do;
	call arg_count_err("-output_file", of_arg_count);
	end;
end process_of_arg;


process_td_arg: proc;
/*   Process -temp_dir argument.   */
     if td_arg_count <= 0 then
	do;
	temp_dir = "-pd";		/*   default   */
	return;
	end;
     if td_arg_count > 1 then		/*   More than one -td argument.   */
	do;
	call arg_count_err("-temp_dir", td_arg_count);
	end;
     if total_td_pns <= 0 then		/*   No path name (or -pd or -wd).   */
	do;
	call no_pns_err("-temp_dir", "");
	end;
     if whoami = "merge" then call not_permitted("-temp_dir");
end process_td_arg;


process_ci_fi_arg: proc;
/*   Process console input - Sort/Merge Description path name arguments.
     Get Sort/Merge Description.    */
     if ci_fi_arg_count <= 0 then		/*   No S.D. argument.   */
	do;
	call ioa_$ioa_switch(iox_$user_output,
	     "^a:  ^a Description not specified.  Please specify either ""-ci"" or ""-^ad pathname"".",
	     whoami, caps(whoami), substr(whoami, 1, 1));
	fatal_sw = on;
	return;     /*   Avoid getting Sort/Merge Description.     */
	end;
     if ci_fi_arg_count > 1 then		/*   More than one S.D. argument.   */
	do;
	call ioa_$ioa_switch(iox_$user_output,
	     "^a:  ^a Description given ^d times.",
	     whoami, caps(whoami), ci_fi_arg_count);
	arg_err_sw = on;
	end;
     call get_sort_desc;		/*   Get access to S.D.   */
     return;
end process_ci_fi_arg;


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


get_sort_desc:  proc;
/*   Get access to Sort/Merge Description; set "sort_desc" = pointer to segment.   */
dcl  dirname char(168) aligned,
     ename char(32) aligned;
dcl  line_buff char(200) aligned,
     max_line_length fixed bin(21) init(200),
     /*   How long should the above be ??   */
     read_length fixed bin(21),
     seg_length fixed bin(24),
     string char(262144) based(sort_desc(1));

     if last_ci_fi = "-fi" then
/*   File input:  Initiate segment.   */
	do;
	call expand_path_(addr(sort_desc_pn), length(sort_desc_pn), addr(dirname), addr(ename), expand_code);
	if expand_code ^= 0 then
	     do;
	     call sd_err(expand_code);
	     return;
	     end;
	call hcs_$initiate(dirname, ename, "", 0, 0, perm_sd, hcs_code);
	/*   ??  Test for error_table_$segknown  ??   */
	if perm_sd = null() then
	     do;
	     call sd_err(hcs_code);
	     return;
	     end;
	sort_desc(1) = perm_sd;
	return;
	end;   /*   of file input.   */
     else
/*   Console input:  Read user_input and store in temporary segment (whose name ends in ".sort_par_").   */
	do;
	process_dir = get_pdir_();
	/*   Set "sort_desc".   */
	sort_desc_pn = "[pd]>"||unique_prefix||"sort_par_";
	call hcs_$make_seg(process_dir, unique_prefix||"sort_par_", "", 8+2 /*  rw  */ , temp_sd, hcs_code);
	/*   ??  check error code  ??   */
	if temp_sd = null() then
	     do;
	     call unable_err(hcs_code, "create");
	     return;
	     end;
	sort_desc(1) = temp_sd;
	call ioa_$ioa_switch(iox_$user_io, "Input:");
	seg_length = 0;
get_line:
	call iox_$get_line(iox_$user_input, addr(line_buff), max_line_length, read_length, iox_code);
	if iox_code ^= 0 then do;
	     fatal_sw = on;
	     call convert_status_code_(iox_code, shortinfo, longinfo);
	     call ioa_$ioa_switch(iox_$user_output,
		"^a:  ^a  ^a Description  from user_input.",
		whoami, longinfo, caps(whoami));
	     return;
	     end;
	if substr(line_buff, 1, 2) = "."||nl then go to end_line;
	substr(string, seg_length + 1, read_length) = substr(line_buff, 1, read_length);
	seg_length = seg_length + read_length;
	go to get_line;
end_line:
	call hcs_$truncate_seg(sort_desc(1), divide(seg_length+3, 4, 24, 0), hcs_code);
	if hcs_code ^= 0 then do;
	     call unable_err(hcs_code, "truncate");
	     end;
	call hcs_$set_bc_seg(sort_desc(1), seg_length*9, hcs_code);
	if hcs_code ^= 0 then
	     do;
	     call unable_err(hcs_code, "set bit count for");
	     end;
	return;
	end; 		/*   of console input.   */
end get_sort_desc;


process_file_size_arg:  proc;
     file_size_par = 0;
     if file_size_arg_count <= 0 then return;
     if file_size_arg_count > 1 then call arg_count_err("-file_size", file_size_arg_count);
     if total_file_size_args <= 0 then call no_value_err("-file_size");
     else do;
	call cv_float_(file_size, cv_err, file_size_par);
	if cv_err ^= 0 then do;
	     arg_err_sw = on;
	     call ioa_$ioa_switch(iox_$user_output,
		     "^a:  -file_size argument has invalid value ""^a"".  Must be a decimal number.",
		     whoami, file_size);
	     end;
	end;
     if whoami = "merge" then call not_permitted("-file_size");
end process_file_size_arg;


process_bf_lg_arg:  proc;
/*   Process -brief report argument:
     prepare report parameter.   */
     user_out_sw_par = "";		/*   Report always produced   */
     user_out_sw = "user_output";	/*   on user_output.   */
     if bf_lg_arg_count <= 0 then return;	/*   No report argument.   */
     else call ioa_$ioa_switch(iox_$user_output, "^a:  Warning:  -brief argument no longer supported.", whoami);
end process_bf_lg_arg;


process_time_arg:  proc;
/*   Process -time argument:  set time_sw.   */
     if time_arg_count <= 0 then do;
	time_sw = off;
	end;
     else if time_arg_count >= 1 then do;   /*  Ignore multiple occurrences   */
	time_sw = on;
	end;
end process_time_arg;


process_merge_order_arg:  proc;
/*   Process -merge_order argument:  check integer > 0,
     prepare merge_order_parameter.   	*/
     merge_order_par = 0;
     if merge_order_arg_count <= 0 then return;		/*   Merge order not specified.   */
     if merge_order_arg_count > 1 then do;   	/*   Merge order specified more than once.   */
	call arg_count_err("-merge_order", merge_order_arg_count);
	end;
     if total_merge_order_args <= 0 then
	call no_value_err("-merge_order");
     else do;
	merge_order_par = cv_dec_check_(merge_order, cv_err);
	if cv_err ^= 0 | merge_order_par <= 0 then
	     call value_err("-merge_order", merge_order);
	end;
     if whoami = "merge" then call not_permitted("-merge_order");
end process_merge_order_arg;


process_string_size_arg:  proc;
/*   Process -string_size argument:  check integer > 0,
     prepare string_size parameter.   	*/
     string_size_par = 0;
     if string_size_arg_count <= 0 then return;
     if string_size_arg_count > 1 then 	/*   String size specified more than once   */
	call arg_count_err("-string_size", string_size_arg_count);
     if total_string_size_args <= 0 then
	call no_value_err("-string_size");
     else do;
  	string_size_par = cv_dec_check_(string_size, cv_err);
	if cv_err ^= 0 | string_size_par <= 0 then
	     call value_err("-string_size", string_size);
	end;
     if whoami = "merge" then call not_permitted("-string_size");
end process_string_size_arg;


process_debug_arg:  proc;
/*   Process -debug argument:  set debug_sw.   */
     if debug_arg_count <= 0 then debug_sw = off;
     else if debug_arg_count >= 1 then 		/*   ignore multiple occurrences   */
	debug_sw = on;
end process_debug_arg;


not_permitted:  proc(name);
dcl  name char(*) parameter;
	arg_err_sw = on;
	call ioa_$ioa_switch(iox_$user_output,
	     "^a:  ^a argument not permitted.",
	     whoami, name);
end not_permitted;


arg_count_err:  proc(arg1, count);
/*   Multiple specification of an argument.  */
dcl  arg1 char(*),
     count fixed bin(17);
     call ioa_$ioa_switch(iox_$user_output, "^a:  ^a argument given ^d times.", whoami, arg1, count);
     arg_err_sw = on;
end arg_count_err;

sd_err:  proc(code);
dcl  code fixed bin(35) parameter;
     fatal_sw = on;
     call convert_status_code_(code, shortinfo, longinfo);
     call ioa_$ioa_switch(iox_$user_output, "^a:  ^a  ^a Description pathname ^a",
		whoami, longinfo, caps(whoami), sort_desc_pn);
end sd_err;

unable_err:  proc(code, action);
dcl (code fixed bin(35),
     action char(*) ) parameter;
     fatal_sw = on;
     call convert_status_code_(code, shortinfo, longinfo);
     call ioa_$ioa_switch(iox_$user_output, "^a:  ^a  Unable to ^a temporary segment [pd]>^asort_par_",
		whoami, longinfo, action, unique_prefix);
end unable_err;


no_pns_err:  proc(name, attach);
/*   Argument given without pathname or attach.   */
dcl (name char(*),
     attach char(*) ) parameter;
     arg_err_sw = on;
     call ioa_$ioa_switch(iox_$user_output, "^a:  ^a argument present but no pathname^a given.",
		whoami, name, attach);
end no_pns_err;


no_value_err:  proc(name);
dcl  name char(*);
     arg_err_sw = on;
     call ioa_$ioa_switch(iox_$user_output, "^a:  ^a argument present but no value given.", whoami, name);
end no_value_err;


value_err:  proc(name, value);
dcl (name,
     value) char(*);
     arg_err_sw = on;
     call ioa_$ioa_switch(iox_$user_output, "^a:  ^a argument has invalid value ^a.  Must be a positive integer.",
		whoami, name, value);
end value_err;


end sort_merge_command;
   



		    sort_merge_command_finish.pl1   11/11/82  1552.0rew 11/11/82  1029.5       47853


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
%;
/* ***************************************
   *				 *
   *				 *
   * Copyright (c) 1975, 1976 by         *
   * Honeywell Information Systems, Inc. *
   *				 *
   *				 *
   *************************************** */
sort_merge_command_finish:  proc(arg_err_code, sort_code, arg_err_sw, fatal_sw);

/*   PARAMETERS   */
dcl (arg_err_code  fixed bin(35),	/*   Error(s) detected by sort or merge  (Output).   */
     sort_code	fixed bin(35),	/*   Errors detected by sort_ or merge_  (Input).   */
				/*   error_table_$badarg = error(s) in arguments;   */
				/*   other = some type of fatal error.		*/
     arg_err_sw	bit(1),		/*   Errors in arguments detected by sort or merge  (Input).   */
     fatal_sw	bit(1) ) parameter;	/*   Fatal error detected by sort or merge  (Input).   */

/*   EXTERNAL ENTRIES    */
dcl  clock_ entry returns(fixed bin(71));
dcl  com_err_  entry options(variable);
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  hcs_$get_process_usage entry(ptr, fixed bin(35));
dcl  ioa_ entry options(variable),
     ioa_$nnl  entry options(variable);

/*   EXTERNAL STATIC     */

%include sort_ext;
dcl  error_table_$bad_arg fixed bin(35) external;

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

/*   AUTOMATIC AND BASED     */
dcl  shortinfo char(8) aligned,
     longinfo char(100) aligned;


dcl  hcs_code fixed bin(35);


/*   Start   */

/*   Test for errors found by sort(merge):   */
     call test_arg_error(arg_err_code);
     if arg_err_code ^= 0 then return;

/*   Test for errors found by sort_(merge_):   */
     if sort_code ^= 0 then call test_sort_error;
     else if time_sw = on then do;
	etime(5) = clock_();
	call cpu_time_and_paging_(pf(5), vtime(5), pd_f(5));
	call hcs_$get_process_usage(addr(pu(5)), hcs_code);
	call print_time_info;
	end;
     return;		/*   To caller (sort or merge).   */

test_arg_error:  proc(code);		/*   Process errors detected in argument processing:   */
dcl  code fixed bin(35) parameter;
     code = 0;
     if arg_err_sw = on then do;	/*   Checked before fatal_sw since both may be on.   */
	call sort_com_err(1);		/*   Bad argument(s).   */
	code = 1;
	end;
     else if fatal_sw = on then do;
	call sort_com_err(0);	/*   Fatal error.   */
	code = 1;
	end;
end test_arg_error;

test_sort_error:  proc;		/*   Process error detected by sort_(merge_).   */
     if sort_code = error_table_$bad_arg then do;	/*   Bad argument(s) detected by sort_(merge_).   */
	call sort_com_err(1);
	end;
     else do;			/*   Some other error detected by sort_(merge_).   */
	call convert_status_code_(sort_code, shortinfo, longinfo);
	call com_err_(0, whoami, " ^a  ^a is abandoned.", longinfo, caps(whoami));
	end;
end test_sort_error;

sort_com_err:  proc(code);
dcl  code fixed bin parameter;
     if code ^= 0 then call com_err_(0, whoami,
			" Errors in arguments.  ^a will not be attempted.", caps(whoami));
     else call com_err_(0, whoami, " ^a will not be attempted.", caps(whoami));
end sort_com_err;


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


print_time_info:  proc;
dcl  head char(8);
     if whoami = "sort" then do;
	call ioa_("^/Merge order = ^d.", mii);
	call ioa_("String size =~ ^d.", max2);
	end;
     if compares_counter > 0 then head = "COMPARES"; else head = "";
     call ioa_("^/PHASE^3x^2xELAPSED^5xRCPU^5xVCPU^2xPAGES^2xP_DEV ^8a", head);
     call form_line("Overhead",
	etime(5) - etime(4) + etime(2) - etime(1),
	rcpu(5) - rcpu(4) + rcpu(2) - rcpu(1),
	vtime(5) - vtime(4) + vtime(2) - vtime(1),
	   pf(5) -    pf(4) +    pf(2) -    pf(1),
	pd_f(5) - pd_f(4) + pd_f(2) - pd_f(1),
	0);
     if whoami = "sort" then do;
	call form_line("Presort",
	     etime(3) - etime(2),
	     rcpu(3) - rcpu(2),
	     vtime(3) - vtime(2),
	        pf(3) -    pf(2),
	     pd_f(3) - pd_f(2),
	        presort_compares);
	end;
     call form_line("Merge",
	etime(4) - etime(3),
	rcpu(4) - rcpu(3),
	vtime(4) - vtime(3),
	   pf(4) -    pf(3),
	pd_f(4) - pd_f(3),
	   merge_compares);
     call form_line("TOTAL",
	etime(5) - etime(1),
	rcpu(5) - rcpu(1),
	vtime(5) - vtime(1),
	   pf(5) -    pf(1),
	pd_f(5) - pd_f(1),
	   compares_counter);
     call ioa_("");

end print_time_info;


form_line:  proc(name, etime, rtime, vtime, pf, pd_f, compares);
dcl (name char(*),
     etime fixed bin(71),
     rtime fixed bin(71),
     vtime fixed bin(71),
     pf    fixed bin,
     pd_f fixed bin,
     compares fixed bin(34) ) parameter;
     call ioa_$nnl("^8a ^8.2f ^8.2f ^8.2f ^6d ^6d",
	name,
	divide(etime, 10**6, 35, 8),
	divide(rtime, 10**6, 35, 8),
	divide(vtime, 10**6, 35, 8),
	pf,
	pd_f);
     if compares > 0 then call ioa_(" ^8d", compares);
     else call ioa_("");
end form_line;


end sort_merge_command_finish;
   



		    sort_merge_initiate.pl1         11/11/82  1552.0rew 11/11/82  1024.9       82764


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

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

/*   EXTERNAL ENTRIES     */
dcl  convert_status_code_  entry(fixed bin(35), char(8) aligned, char(100) aligned);
dcl  get_group_id_ entry returns(char(32));
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  sort_build_keys entry(ptr, fixed bin(35));
dcl  sort_convert_internal$convert_datatype entry(ptr, fixed bin(17), fixed bin(17));
/*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_$bad_arg,
     error_table_$fatal_error) fixed bin(35) external static;

/*   INTERNAL STATIC  (constants only)   */
dcl (on bit(1) init("1"b),
     off bit(1) init("0"b) ) internal static;
dcl  keys_number_max fixed bin(17) init(32) internal static;	/*   Currently up to 32 keys.   */	
dcl  keys_version_max fixed bin(17) init(1)  internal static;	/*   Currently 1 version only   */
dcl  exits_version_max fixed bin(17) init(1) internal static;	/*   Currently 1 version only   */

/*   AUTOMATIC and BASED     */
% include sort_sd;

dcl  work_ptr ptr;
dcl  keys_sw    bit(1);
dcl  arg_err_sw bit(1);
dcl  fatal_sw bit(1);
dcl  verify_keys_code fixed bin(35),
     verify_exits_code fixed bin(35);
dcl  hcs_code fixed bin(35),
     shortinfo char(8) aligned,
     longinfo char(100) aligned;


/*   Start.   */

     rec_ptr_a,
     rec_ptr_b = null();
     code = 0;
     arg_err_sw = off;
     fatal_sw = off;
     compares_counter,
     presort_compares,		/*   Not used by Merge.   */
     merge_compares = 0;
     user_id = get_group_id_();
     max_rec_length = (sys_info$max_seg_size - 100)*4;
		/*   Must be set before call process_key_desc.   */
     release_count = 0;		/*   not used by Merge.   */
     return_count = 0;

/*   keys_ptr:   */
     call process_key_desc;

/*   exits_ptr:   */
     call initialize_exits;

/*   Create temporary segments for output_record exit processing.   */
     if output_record_exit_sw = 1 then do;
	call hcs_$make_seg(get_pdir_(), unique_prefix||"sort_out_a_", "", 8+2, rec_ptr_a, hcs_code);
	if rec_ptr_a = null() then do;
	     call unable_error("create", "sort_out_a_");
	     end;
	call hcs_$make_seg(get_pdir_(), unique_prefix||"sort_out_b_", "", 8+2, rec_ptr_b, hcs_code);
	if rec_ptr_b = null() then do;
	     call unable_error("create", "sort_out_b_");
	     end;
	end;

/*   Test if keys and compare are both present or are both absent:   */
     if keys_sw = off & compare_sw = 0 then
	do;
	if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
		"^a:  Neither key descriptions nor user compare exit procedure specified.", whoami);
	arg_err_sw = on;
	end;
     if keys_sw = on & compare_sw = 1 then do;
	if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
		"^a:  Both key descriptions and user compare exit procedure specified.", whoami);;
	arg_err_sw = on;
	end;

/*   report:     */
     if user_out_sw = "" then report_sw = "01"b;		/*   Report suppressed.   */
     else report_sw = "00"b;				/*   Produce report.   */

     /*   Test for errors detected:   */
      if arg_err_sw = on then code = error_table_$bad_arg;

     if fatal_sw = on then code = error_table_$fatal_error;

exit:
     return;	/*   To caller (sort_initiate or merge_initiate).   */


initialize_exits: proc;
/*   Set all exit switches to off (0).   */
     compare_sw,
     input_record_exit_sw,		/*   Not used by Merge.   */
     output_record_exit_sw = 0;
     if exits_ptr = null() then return;
     work_ptr = exits_ptr;
     call verify_exits(work_ptr, verify_exits_code);
     if verify_exits_code ^= 0 then do;
	arg_err_sw = on;
	return;
	end;
/*   exits substructure is valid:  set entry variables.   */
/*1*/     if  exits.compare_exit ^= sort_$noexit then
	do;
	sort_ext$sort_compare_exit = exits.compare_exit;
	compare_sw = 1;
	end;
/*1*/     if exits.input_record_exit ^= sort_$noexit then do;
	sort_input_record_exit = exits.input_record_exit;
	input_record_exit_sw = 1;
	if substr(whoami, 1, 5) = "merge" then do;
	     arg_err_sw = on;
	     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
		"^a:  Input_record exit not permitted.",
		whoami);
	     end;
	end;
/*1*/     if exits.output_record_exit ^= sort_$noexit then do;
	sort_output_record_exit = exits.output_record_exit;
	output_record_exit_sw = 1;
	end;
     return;
end initialize_exits;


verify_exits:  proc(work_ptr, code);
/*   Validate exits substructure.   */
dcl (work_ptr ptr,
     code fixed bin(35) ) parameter;

     if exits.version < 0 | exits.version > exits_version_max then do;
	code = 1;
	if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
		"^a:  Exits structure has invalid version number ^d.  Must be > 0 and <_ ^d.",
		whoami, exits.version, exits_version_max);
	end;
     else code = 0;
end verify_exits;

process_key_desc: proc;
dcl  code fixed bin(35);
     keys_sw = off;
     min_rec_length = 0; 	/*   For sort_$release or merge_$return, in case no keys were specified   */
     if keys_ptr = null() then return;
     work_ptr = keys_ptr;
     keys_sw = on;
     call verify_keys(work_ptr, verify_keys_code);
     if verify_keys_code ^= 0 then do;
	arg_err_sw = on;
	return;
	end;
/*   Convert keys substructure into faster form.   /*
/*   Separate arrays for (datatype, word_offset, bit_offset, len, rv)
and with appropriate data types and with ranges of (0:n-1).   */

     call sort_build_keys(keys_ptr, code);
     if code ^= 0 then do;
	arg_err_sw = on;
	end;
end process_key_desc;


verify_keys:  proc(work_ptr, code);
/*   Validate keys substructure.   */
dcl (work_ptr ptr,
     code fixed bin(35) ) parameter;

dcl  i fixed bin,
     typecode fixed bin (17);

     code = 0;
     call check_structure;
     if code = 1 then return;
     do i = 1 to keys.number;
	call sort_convert_internal$convert_datatype(work_ptr, i, typecode);
	if typecode = 0 then do;
	     code = 1;
	     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw, 
		"^a:  Key ^d has invalid data type ""^a"".",
		whoami, i, datatype(i));
	     end;
	if len(i) <= 0 then do;
	     code = 1;
	     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
		"^a:  Key ^d has invalid length or precision ^d.  Must be > 0.",
			whoami, i, len(i));
	     end;
	if word_offset(i) < 0 then do;
	     call error(fixed(word_offset(i), 35), "word_offset", "", i);
	     end;
	if bit_offset(i) < 0 | bit_offset(i) > 35 then do;
	     call error(fixed(bit_offset(i), 35), "bit offset", " and <_ 35", i);
	     end;
	if rv(i) ^= "dsc" & rv(i) ^= "" then do;
	     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
		"^a:  Key ^d has invalid descending argument ""^a"".  Must be ""dsc"" or """".",
			whoami, i, rv(i));
	     code = 1;
	     end;
	end;	/*   of do   */
     return;

check_structure:  proc;
   if keys.version <= 0 | keys.version > keys_version_max then
	do;
	code = 1;
	if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
		"^a:  Keys structure has invalid version number ^d.  Must be > 0 and <_ ^d.",
		whoami, keys.version, keys_version_max);
	end;
     if keys.number <=0  |  keys.number > keys_number_max then
	do;
	code = 1;
	if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
		"^a:  Keys structure has invalid number of keys ^d.  Must be > 0 and <_ ^d.",
		whoami, keys.number, keys_number_max);
	end;
end check_structure;

error:  proc(value, literal, and, index);
dcl (value fixed bin(35),
     literal char(*),
     and char(*),
     index fixed bin(17) ) parameter;
     code = 1;
     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw, 
		"^a:  Key ^d has invalid ^a ^d.  Must be >_ 0^a.",
		whoami, index, literal, value, and);
end error;
end verify_keys;


unable_error:  proc(action, name);
dcl (action,
     name) char(*) parameter;
     fatal_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 ^a temporary segment [pd]>^a^a",
		whoami, longinfo, action, unique_prefix, name);
end unable_error;

end sort_merge_initiate;



		    sort_merge_print_report.pl1     11/11/82  1552.0rew 11/11/82  1029.5       40005


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

/*   EXTERNAL ENTRIES     */
dcl  ioa_$ioa_stream  entry options(variable);

/*   EXTERNAL STATIC     */
%include sort_ext;

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

/*   Start   */

  if report_sw ^= "01"b then do;
     if input_driver_is_sort = on & output_driver_is_sort = on then do;
	if read_count = release_count & read_count = return_count & read_count = write_count then do;
	     call print_sorted;
	     end;
	else if release_count = return_count then do;
	     call print_read;
	     call print_sorted;
	     call print_written;
	     end;
	else do;		/*   release_count /= return_count   */
	     call print_read;
	     call print_released;
	     call print_returned;
	     call print_written;
	     end;
	end;
     else if input_driver_is_sort = on & output_driver_is_sort = off then do;
	if read_count = release_count & read_count = return_count then do;
	     call print_sorted;
	     end;
	else if release_count = return_count then do;
	     call print_read;
	     call print_sorted;
	     end;
	else do;		/*   release_count /= return_count   */
	     call print_read;
	     call print_released;
	     call print_returned;
	     end;
	end;
     else if input_driver_is_sort = off & output_driver_is_sort = on then do;
	if release_count = return_count & release_count = write_count then do;
	     call print_sorted;
	     end;
	else if release_count = return_count then do;
	     call print_sorted;
	     call print_written;
	     end;
	else do;		/*   release_count /= return_count   */
	     call print_released;
	     call print_returned;
	     call print_written;
	     end;
	end;
     else do;		/*   neither sort's(merge's) input file proc nor sort's(merge's) output file proc   */
	if release_count = return_count then do;
	     call print_sorted;
	     end;
	else do;		/*   release_count /= return_count   */
	     call print_released;
	     call print_returned;
	     end;
	end;
  end;		/*   of if report_sw ^= "01"b then do;   */
  return;	/*   To caller (sort_ or merge_)  	*/


print_sorted:  proc;
     call print_input_ins_dele;
     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw, 
		"^7d records ^aed.", release_count, substr(whoami, 1, 4));
     call print_output_ins_dele;
end print_sorted;


print_read:  proc;
     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw, 
		"^7d records read.", read_count);
end print_read;


print_written:  proc;
     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw, 
		"^7d records written.", write_count);
end print_written;


print_released:  proc;
     call print_input_ins_dele;
     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw, 
		"^7d records released to ^a.", release_count, before(whoami, "_"));
end print_released;


print_returned:  proc;
     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw, 
		"^7d records returned from ^a.", return_count, before(whoami, "_"));
     call print_output_ins_dele;
end print_returned;


print_input_ins_dele:  proc;
     if input_record_exit_sw = 1 then do;
	if input_rec_inserted ^= 0 then
	if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
		"^7d records inserted at input.", input_rec_inserted);
	if input_rec_deleted ^= 0 then
	if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
		"^7d records deleted at input.", input_rec_deleted);
	end;
end print_input_ins_dele;


print_output_ins_dele:  proc;
     if output_record_exit_sw = 1 then do;
	if output_rec_inserted ^= 0 then
	if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
		"^7d records inserted at output.", output_rec_inserted);
	if output_rec_deleted ^= 0 then
	if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
		"^7d records deleted at output.", output_rec_deleted);
	end;
end print_output_ins_dele;


end sort_merge_print_report;
   



		    sort_merge_sub_error.pl1        11/11/82  1552.0rew 11/11/82  1029.6       21339


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
%;
/* ***************************************
   *				 *
   *				 *
   * Copyright (c) 1975, 1976, 1977 by   *
   * Honeywell Information Systems, Inc. *
   *				 *
   *				 *
   *************************************** */
sort_merge_sub_error:  proc;
/*   Handler for sub_error_ condition for sort and merge commands.   */

/*   EXTERNAL ENTRIES   */
dcl  continue_to_signal_  entry(fixed bin(35));
dcl  convert_status_code_  entry(fixed bin(35), char(8) aligned, char(100) aligned);
dcl  find_condition_info_  entry(ptr, ptr, fixed bin(35));
dcl  ioa_  entry options(variable);
dcl  ioa_$ioa_switch  entry options(variable);

/*   EXTERNAL STATIC   */
dcl  iox_$user_output  ptr external static;

/*   AUTOMATIC and BASED   */
dcl  continue_code  fixed bin(35);
dcl  cond_ptr ptr;
dcl  find_cond_code fixed bin(35);
dcl  shortinfo char(8) aligned,
     longinfo char(100) aligned;

dcl 1 info aligned based(infoptr),
      2 length fixed bin,
      2 version fixed bin,
      2 action_flags aligned,
        3 cant_restart bit(1) unaligned,	/*   At present, always off (=  ).   */
        3 default_restart bit(1) unaligned,	/*   At present, always on (= 1).   */
        3 pad bit(34) unaligned,
      2 string char(256) varying,
      2 code fixed bin(35),
      2 retval fixed bin(35),
      2 name char(32),
      2 infop ptr;

dcl 1 find_cond_info,
%include cond_info;


     cond_ptr = addr(find_cond_info);
     call find_condition_info_(null(), cond_ptr, find_cond_code);
     if cond_ptr = null() then do;
	call continue_to_signal_(continue_code);
	return;
	end;
     if condition_name ^= "sub_error_" | infoptr = null()
     | (substr(name, 1, 4) ^= "sort" & substr(name, 1, 5) ^= "merge") then do;
	call continue_to_signal_(continue_code);
	return;
	end;
     retval = 0;
     if code = 0 then call ioa_$ioa_switch(iox_$user_output,
	"^a: ^a", name, string);
     else do;
	call convert_status_code_(code, shortinfo, longinfo);
	call ioa_$ioa_switch(iox_$user_output,
		"^a:  ^a ^a", name, longinfo, string);
	end;
end sort_merge_sub_error;
 



		    sort_merge_subroutine.pl1       11/11/82  1552.0rew 11/11/82  1029.6      181566


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
%;
/* ***************************************
   *				 *
   *				 *
   * Copyright (c) 1975, 1976 by         *
   * Honeywell Information Systems, Inc. *
   *				 *
   *				 *
   *************************************** */
sort_merge_subroutine: proc(input_file, output_file, sort_desc, user_out_sw_par,
	sort_input_exit, sort_output_exit, arg_err_sw, fatal_sw,
	keys_ptr, exits_ptr,
	temp_sd_lex, temp_sd_int);

/*   PARAMETERS   */
dcl (input_file(*) char(*),				/*  Input file specs (Input)   */
     output_file char(*),				/*  Output file spec (Input)  */
     sort_desc(*) ptr,				/*  Sort/Merge Description (Input)  */
     user_out_sw_par     char(*),			/*  Switchname for Sort Report (Input)  */
     sort_code  fixed bin(35),			/*  Error code (Output)  */
     sort_input_exit  entry(fixed bin(35)) variable,	/*  User input_file proc (Output)  */
     sort_output_exit  entry(fixed bin(35)) variable,	/*  User output_file proc(Output)  */
     arg_err_sw  bit(1),				/*  Error(s) in arguments (Output)  */
     fatal_sw  bit(1),				/*  Fatal error encountered (Output)  */
     keys_ptr ptr,					/*  Keys structure (Output)  */
     exits_ptr ptr,					/*  Exits structure(Output)  */
     temp_sd_int  ptr ,				/*  Temporary segment for lex_string_ (Output)  */
     temp_sd_lex  ptr ) parameter;			/*  Temporary segment for S/M.D. internal form (Output) */

/*   EXTERNAL ENTRIES     */
dcl  check_star_name_$entry  entry(char(*) aligned, fixed bin(35));
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_equal_name_  entry(char(*) aligned, char(*) aligned, char(32) aligned, fixed bin(35));
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)),
     hcs_$truncate_seg entry(ptr, fixed bin(24), fixed bin(35)),
     hcs_$set_bc_seg entry(ptr, fixed bin(24), fixed bin(35)),
     hcs_$status_mins entry(ptr, fixed bin(2), fixed bin(24), fixed bin(35));
dcl  ioa_$ioa_stream  entry options(variable),
     ioa_$rsnnl entry options(variable);
dcl  sub_err_  entry options(variable);
dcl  translator_temp_$get_segment  entry(char(*) aligned, ptr, fixed bin(35));

dcl  sort_convert_internal entry(ptr, ptr, ptr, ptr, ptr, ptr, fixed bin(24), fixed bin(24), fixed bin(35));

/*   EXTERNAL STATIC     */

% include sort_ext;

dcl (error_table_$pathlong,
     error_table_$out_of_sequence,
     error_table_$dirseg) external static fixed bin(35);

/*   INTERNAL STATIC   (constants only)   */
dcl (on init("1"b),
     off init("0"b) ) bit(1) internal static;
dcl  io_exits_version_max fixed bin init(1) internal static;	/*   Currently only 1 version.   */

/*   AUTOMATIC AND BASED   */
dcl  user_out_sw_temp char(8);

dcl  source_sort_desc ptr;
dcl  seg_type fixed bin(2),
     bit_count fixed bin(24),
     seg_length fixed bin(24);

dcl  convert_int_code fixed bin(35),
     verify_input_files_code fixed bin(35);


% include sort_sd;
dcl  io_exits_ptr ptr,
     work_ptr ptr,
     filesize float bin(27);

dcl  hcs_code fixed bin(35);
dcl  expand_code fixed bin(35);
dcl  check_star_code fixed bin(35);
dcl  equal_code fixed bin(35);

dcl  in_dir char(168) aligned,
     in_ename char(32) aligned,
     first_in_ename char(32) aligned,
     first_in_kw  char(32),
     first_in_pathname  char(256),
     res_dir char(168) aligned,
     equal_name char(32) aligned,
     res_ename char(32) aligned,
     in_bit_count fixed bin(24),
     in_ptr ptr,
     type fixed bin(2),
     component char(32) aligned,
     comp_len fixed bin(17);

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

dcl  retval  fixed bin(35);

/*   Start   */

     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;
     fatal_sw = off;
     keys_ptr,
     io_exits_ptr,
     exits_ptr = null();
     if dimension(sort_desc, 1) = 1 then do;
	source_sort_desc = sort_desc(lbound(sort_desc, 1));
	call sd_is_source;
	end;
     else if dimension(sort_desc, 1) = 2 & substr(whoami, 1, 5) = "merge" then do;
	keys_ptr = sort_desc(lbound(sort_desc, 1) + 0);
	exits_ptr = sort_desc(lbound(sort_desc, 1) + 1);
	end;
     else if dimension(sort_desc, 1) = 3 & substr(whoami, 1, 4)  = "sort" then do;
	keys_ptr = sort_desc(lbound(sort_desc, 1) + 0);
	exits_ptr = sort_desc(lbound(sort_desc, 1) + 1);
	io_exits_ptr = sort_desc(lbound(sort_desc, 1) + 2);
	end;
     else do;
	arg_err_sw = on;
 	if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
			"^a:  ^a Description argument has an array dimension of ^d.  Must be 1 or ^d.",
			whoami, caps(whoami), dimension(sort_desc, 1), extent_sd());
	end;
     /*   Following calls must be done in sequence, so inter-relationships can be checked.   */
     call check_io_exits;
     call process_input_par;
     call process_output_par;
     user_out_sw_temp = user_out_sw_par;
     read_count,
     write_count = 0;
     input_rec_deleted,		/*   Not used by Merge.   */
     input_rec_inserted,		/*   Not used by Merge.   */
     output_rec_deleted,
     output_rec_inserted = 0;

     return;	/*   to caller (sort_ or merge_)   */


extent_sd:  proc  returns(fixed bin);
     if substr(whoami, 1, 4) = "sort" then return(3);
     else return(2);
end extent_sd;


sd_is_source:  proc;
     call hcs_$status_mins(source_sort_desc, seg_type, bit_count, hcs_code);     /*   Get bit count.   */
     if seg_type = 2 then hcs_code = error_table_$dirseg;          /*   Must not be a directory.   */
     if hcs_code ^= 0 then do;
	fatal_sw = on;
	call convert_status_code_(hcs_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);
	return;
	end;
     /*   Convert S.D. to internal form.   */
     call translator_temp_$get_segment((whoami), temp_sd_lex, hcs_code);
     if temp_sd_lex = null() then do;
	call unable_error("create", "sort_lex_");
	return;
	end;
     call hcs_$make_seg(get_pdir_(), unique_prefix||"sort_par_int_",
		"", 8+2  /*  rw  */, temp_sd_int, hcs_code);
     /*  ??  Test for error_table_$segknown  ??   */
     if temp_sd_int = null() then do;
	call unable_error("create", "sort_par_int_");
	return;
	end;
     call sort_convert_internal(source_sort_desc, temp_sd_int, temp_sd_lex, keys_ptr, io_exits_ptr, exits_ptr,
		bit_count, seg_length, convert_int_code);
     if convert_int_code ^= 0 then do;
	/*   Error; cannot use Sort/Merge Description internal format.   */
	arg_err_sw = on;
	return;
	end;
     call hcs_$truncate_seg(temp_sd_int, seg_length, hcs_code);
     if hcs_code ^= 0 then do;
	call unable_error("truncate", "sort_par_int_");
	return;
	end;
     call hcs_$set_bc_seg(temp_sd_int, seg_length*36, hcs_code);
     if hcs_code ^= 0 then do;
	call unable_error("set bit count for", "sort_par_int_");
	return;
	end;
end sd_is_source;


check_io_exits:  proc;   	/*   Validate io_exits structure.   */
     if io_exits_ptr = null() then return;
     work_ptr = io_exits_ptr;
     if io_exits.version < 0 | io_exits.version > io_exits_version_max then do;
	arg_err_sw = on;
	if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
			"^a:   IO_exits structure has invalid version number ^d.  Must be > 0 and <_ ^d.",
			whoami, io_exits.version, io_exits_version_max);
	io_exits_ptr = null();		/*   to protect process_input_par & process_output_par   */
	end;
     else if substr(whoami, 1, 5) = "merge" then do;
	/*   Reject input_file, output_file exits for Merge.   */
	io_exits_ptr = null();	/*   To protect process_input_par, process_output_par, & merge_.   */
	arg_err_sw = on;
	if io_exits.input_file_exit ^= noexit then do;
	     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
		"^a:  Input_file exit not permitted.", whoami);
	     end;
	if io_exits.output_file_exit ^= noexit then do;
	     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
		"^a:  Output_file exit not permitted.", whoami);
	     end;
	end;
end check_io_exits;


process_input_par: proc;
/*   Set driver to user's or sort's (merge's) input procedure.
     Check invalid input file specifications.
     Check for and reject star convention.
     Error if input file specification(s) and user's exit both are present,
     or if neither is present.   */
dcl  kw_index  fixed bin(17);
dcl  w2_index  fixed bin(17);
     if input_file(lbound(input_file, 1)) = "" then do;  /*  user did not supply input file specifications.   */
	input_driver_is_sort = off;
	end;
     else do;  /*  user did supply input file specifications.   */
	call verify_input_files(verify_input_files_code);	/*   Validate input_file array.   */
	if verify_input_files_code = 1 then do;
	     arg_err_sw = on;
	     end;
	input_driver_is_sort = on;
	end;
     if io_exits_ptr = null() then  /*  user did not supply io_exits structure.  */
	do;
	sort_input_exit = noexit;
	end;
     else  /*  user did supply io_exits structure.   */
	do;
	/*  io_exits structure already verified by check_io_exits.   */
	sort_input_exit = io_exits_ptr->io_exits.input_file_exit;
	end;
     if input_file(lbound(input_file, 1)) = "" & sort_input_exit = noexit then
	do;
	if substr(whoami, 1, 4) = "sort" then do;
	     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
		"^a:  Neither input file(s) nor user input_file exit procedure specified.",
		whoami);
	     end;
	else if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
			"^a:  No input file(s) specified.",
			whoami);
	arg_err_sw = on;
	end;
     if input_file(lbound(input_file, 1)) ^= "" & input_file_exit_sw = on then do;
	if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
	     "^a:  Both input file(s) and user input_file exit procedure specified.",
	     whoami);
	arg_err_sw = on;
	/*   Driver would use input file specifications since input_driver_is_sort switch is on.   */
	end;

verify_input_files:  proc(code);
/*   Validate form of input_file array:   */
dcl  code fixed bin(35) parameter;
dcl  i  fixed bin(17);

     code = 0;
     if dimension(input_file, 1) > input_file_max then do;
 	code = 1;
	if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
			"^a:  Invalid number of input files ^d.  Must be <_ ^d.",
		whoami, dimension(input_file, 1), input_file_max);
	end;
     first_in_ename = "";		/*   Initialize for process_equal.   */
     do i = lbound(input_file, 1) to hbound(input_file, 1);
	call scan_file_spec(input_file(i), kw_index, w2_index);
	if i = lbound(input_file, 1) then first_in_kw = before(substr(input_file(i), kw_index), " ");
	if substr(input_file(i), kw_index, 4) = "-if "
	 | substr(input_file(i), kw_index, 12) = "-input_file " then do;
	     /*   Reject star convention if used.   */
	     in_ename = "";	/*   Initialize.   */
	     call expand_path_(addr(substr(input_file(i), w2_index)), length(substr(input_file(i), w2_index)),
		addr(in_dir), addr(in_ename), expand_code);
	     if expand_code ^= 0 then do;
		call convert_status_code_(expand_code, shortinfo, longinfo);
		if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw, 
		"^a:  ^a  Checking star convention for input file ^d, pathname ^a",
			whoami, longinfo, i, substr(input_file(i), w2_index));
		arg_err_sw = on;
		end;
	     if in_ename ^= "" then do;
		/*   Check * convention and indicate error.   */
		call check_star_name_$entry(in_ename, check_star_code);
		if check_star_code ^= 0 then do;
		     arg_err_sw = on;
		     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
			"^a:  Star convention not allowed.  Input file ^d, pathname ^a",
			whoami, i, substr(input_file(i), w2_index));
		     end;
		end;
	     if i = lbound(input_file, 1) then do;
		first_in_ename = in_ename;	/*   Used by process_equal.   */
		first_in_pathname = substr(input_file(i), w2_index);	/*   Used by process_equal   */
		end;
	     end;
	else if substr(input_file(i),kw_index, 5) = "-ids "
	      |substr(input_file(i), kw_index, 19) = "-input_description " then do;
	     end;
	else do;  	/*   Error.   */
	     arg_err_sw = on;
	     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
		"^a:  Invalid input file specification ^a for input file ^d.",
		whoami, (input_file(i)), i);
	     end;
	end;	/*   of do i = lbound ...   */
end verify_input_files;


end process_input_par;


process_output_par:  proc;
/*   Set driver to user's or sort's (merge's) output procedure.
     Check for invalid output file specification.
     Check -replace; process equals convention.
     Error if output file specification and user's exit both are present,
     or if neither is present.   */
dcl  (kw_index, w2_index)  fixed bin(17);
     if output_file = "" then do;  /*  user did not supply output file specification.   */
	output_driver_is_sort = off;
	end;
     else do;  /*  user did supply output file specification.   */
	output_driver_is_sort = on;
	call scan_file_spec(output_file, kw_index, w2_index);
	if substr(output_file, kw_index, 4) = "-of "
	 | substr(output_file, kw_index, 13) = "-output_file " then do;
	     curr_output_file_name = substr(output_file, w2_index);
	     curr_output_file_attach = "";
	     if substr(output_file, w2_index) = "-rp"
	      | substr(output_file, w2_index) = "-replace" then do;
		if input_file(lbound(input_file, 1)) = "" then do;
		     arg_err_sw = on;
		     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
			"^a:  Output file specification is ^a but no input file was specified.",
			whoami, output_file);
		     end;
		if first_in_kw = "-ids" | first_in_kw = "-input_description" then do;
		     arg_err_sw = on;
		     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
	"^a:  Output file specification is ^a but first input file specification is an attach description.",
			whoami, output_file);
		     end;
		if substr(whoami, 1, 5) = "merge" then do;
		     arg_err_sw = on;
		     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
			"^a:  Output file specification ^a not permitted.",
			whoami, output_file);
		     end;
		curr_output_file_name = first_in_pathname;
		end;
	     else do;	/*   Is still -of but is not -rp.   */
		call process_equal(curr_output_file_name);
		end;
	     end;  	/*   of being -of specification.   */
	else if substr(output_file, kw_index, 5) = "-ods "
	      | substr(output_file, kw_index, 20) = "-output_description " then do;
	     curr_output_file_name = "";
	     curr_output_file_attach = substr(output_file, w2_index);
	     end;
	else do;  	   /*   Error.   */
	     arg_err_sw = on;
	     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
		"^a:  Invalid output file specification ^a",
		whoami, output_file);
	     end;
	end;
     if io_exits_ptr = null() then  /*  user did not supply io_exits structure.  */
	do;
	sort_output_exit = noexit;
	end;
     else  /*  user did supply io_exits structure.  */
	do;
	/*  io_exits structure already validated by check_io_exits.   */
	sort_output_exit = io_exits_ptr->io_exits.output_file_exit;
	end;
     if output_file = "" & sort_output_exit = noexit then
	do;
	if substr(whoami, 1, 4) = "sort" then do;
		 if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
			"^a:  Neither output file nor user output_file exit procedure specified.",
			whoami);
		     end;
	else if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
			"^a:  No output file specified.",
			whoami);
	arg_err_sw = on;
	end;
     if output_file ^= "" & output_file_exit_sw = on then do;
	if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
			"^a:  Both output file and user output_file exit procedure specified.",
			whoami);
	arg_err_sw = on;
	end;
end process_output_par;


scan_file_spec:  proc(file_spec, kw_par, w2_par);
dcl (file_spec char(*),
     kw_par fixed bin(17),
     w2_par  fixed bin(17) ) parameter;
     kw_par, w2_par = 1;
     do while(substr(file_spec, w2_par, 1) = " " & w2_par < length(file_spec));
	w2_par = w2_par + 1;
	end;
     kw_par = w2_par;
     do while(substr(file_spec, w2_par, 1) ^= " " & w2_par < length(file_spec));
	w2_par = w2_par + 1;
	end;
     do while(substr(file_spec, w2_par, 1) = " " & w2_par < length(file_spec));
	w2_par = w2_par + 1;
	end;
end scan_file_spec;


process_equal:  proc(res_pn);
/*   Process equals convention, for output file pathname against first input file pathname   */
dcl  res_pn char(*) parameter;		/*   path name   */
/*   Exit if first input_file entry name is blank.     */
     if input_file(lbound(input_file, 1)) = "" | first_in_ename = "" then return;
     /*   Also exit if there is an attach for the first input file.   */
     if first_in_kw = "-ids" | first_in_kw = "-input_description" then return;
     equal_name = "";		/*   Initialize.   */
     call expand_path_(addr(res_pn), length(res_pn),
		addr(res_dir), addr(equal_name), expand_code);
     if expand_code ^= 0 then do;
	call expand_err(expand_code, "output file", res_pn);
	return;
	end;
     if equal_name = "" then return;		/*   Return if no entry name to process equals convention on   */
     equal_code = 0;		/*   get_equal_name_ sometimes forgets to clear status code   */
     call get_equal_name_(first_in_ename, equal_name, res_ename, equal_code);
     if equal_code ^= 0 then
	do;
	call equal_err(equal_code, "output file", equal_name);
	return;
	end;
     if (index(res_dir, " ") = 0 & index(res_ename, " ") = 0)
     /*   Neither res_dir nor res_ename contains a space   */
	| (index(res_dir, " ") - 1 + index(res_ename, " ") - 1 + 1) >= 168 then do;
     /*   Length of concatenated path name too long   */
	arg_err_sw = on;
	call convert_status_code_(error_table_$pathlong, shortinfo, longinfo);
	if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
			"^a:  ^a  Processing ^a pathname for equals convention.", whoami, longinfo, "output file");
	return;
	end;
     if res_dir = ">" then res_pn = ">"|| res_ename;
     else res_pn = before(res_dir, " ") ||">"|| res_ename;
     return;
end process_equal;


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


expand_err: proc(code, name, value);
/*   Error from expand_path_.   */
dcl  code fixed bin(35),
     name char(*),
     value char(*);
     arg_err_sw = on;
     call convert_status_code_(code, shortinfo, longinfo);
     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
		     "^a:  ^a  Expanding ^a pathname ^a for equals convention.", whoami, longinfo, name, value);
end expand_err;

equal_err:  proc(code, name, value);
/*   Error from get_equal_name_.   */
dcl  code fixed bin(35),
     name char(*),
     value char(*) aligned;
     arg_err_sw = on;
     call convert_status_code_(code, shortinfo, longinfo);
     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
		     "^a:  ^a  Processing ^a entryname ^a for equals convention.", whoami, longinfo, name, value);
end equal_err;


unable_error:  proc(action, name);
dcl (action,
     name) char(*) parameter;
     fatal_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 ^a temporary segment [pd]>^a^a",
		whoami, longinfo, action, unique_prefix, name);
end unable_error;


noexit:  entry(sort_code);	/*   This is both sort_$noexit and merge_$noexit, when bound.   */
/*   Must set code ^= 0 to indicate erroneous call without a defined user procedure.   */
     call sub_err_(error_table_$out_of_sequence, (whoami), "c", null(), retval,
	"The entry ""^a_$noexit"" cannot be called.", before(whoami, "_"));
     return;


end sort_merge_subroutine;
  



		    sort_merge_terminate.pl1        11/11/82  1552.0rew 11/11/82  1029.7       20772


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

/*   PARAMETERS   */
dcl   ec     fixed bin(35) parameter;		/*  error code  */

/*   EXTERNAL ENTRIES   */
dcl  hcs_$delentry_seg  entry(ptr, fixed bin(35));
dcl  hcs_$truncate_seg  entry(ptr, fixed bin(21), fixed bin(35));
 dcl ioa_$ioa_stream entry options(variable);

 dcl  sort_cleanup_work entry;

/*   EXTERNAL STATIC   */

% include sort_ext;
dcl    error_table_$out_of_sequence fixed bin(35) ext;

/*   AUTOMATIC   */
dcl  hcs_code fixed bin(35);
dcl  cleanup  condition;


/*   Start:   */
start:
    state = 7;
     on cleanup call sort_cleanup_work;
     merge_compares = compares_counter - presort_compares;
     call print_report;
     if debug_sw = "0"b then do;
 	if rec_ptr_a ^= null() then call hcs_$delentry_seg(rec_ptr_a, hcs_code);
	rec_ptr_a = null();
	if rec_ptr_b ^= null() then call hcs_$delentry_seg(rec_ptr_b, hcs_code);
	rec_ptr_b = null();
	end;
     else do;
	if rec_ptr_a ^= null() then call hcs_$truncate_seg(rec_ptr_a, 0, hcs_code);
	if rec_ptr_a ^= null() then call hcs_$truncate_seg(rec_ptr_b, 0, hcs_code);
	end;
     call sort_cleanup_work;
exit:	state = 8;
     return;		/*   to caller   */


print_report:  proc;
     if report_sw = "01"b then return;
     if terminate_print_sw = "0"b then return;
     if release_count = return_count then
	do;
	     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
		"^7d records ^aed.", release_count, substr(whoami, 1, 4));
	end;
     else
	do;
	     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
		"^7d records released to ^a.", release_count, before(whoami, "_"));
	     if user_out_sw ^= "" then call ioa_$ioa_stream(user_out_sw,
		"^7d records returned from ^a.", return_count, before(whoami, "_"));
	end;
end print_report;

end terminate;



		    sort_output_proc.pl1            11/11/82  1552.0rew 11/11/82  1025.0      229986


/* ***********************************************************
   *                                                         *
   * 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], decrease size of IN */

sort_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);


/*   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_$out_of_sequence,
     error_table_$request_not_recognized,
     error_table_$long_record,
     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  retval  fixed bin(35);
dcl  cleanup condition;

/*   Start.   */
     output_proc_code = 0;
     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 sort_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;
	/*   sort_$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 if sort_code = error_table_$out_of_sequence then do;
	     call sub_err_(sort_code, (whoami), "c", null(), retval,
		" Calling sort_$return.");
	     call cleanup_proc;
	     go to exit;
	     end;
	else do;		/*  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   */
     return:	entry(pt,fb,fb1);
	dcl	pt ptr,
		fb fixed bin(21),
		fb1 fixed bin(35);
	    call sort_return(pt,fb,fb1);
	    return;
%;
  sort_return:  proc(retp,retbl,ec);
			/*  PARAMETERS, INTERNAL STATIC, AUTOMATIC, & BASED  */
	dcl	(retp ptr,
		retbl fixed bin(21)) parameter;
dcl (t,n,v1,v2,l,x,j,y,lft,rit,i) fixed bin(30) int static;
	dcl
		(ns,np) fixed bin(30) int static,
		s(36) static,
		retfb fixed bin(30);
	dcl	i1 fixed bin(30);
/*1*/	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  */
%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  */
	dcl	hold_cur_rec_ptr ptr int static,	/*  hold ptr to output record in sort's area  */
	hold_area_len int static;	/*  hold length of output record in case user destroys it  */
	ec = 0;     /*  initially set error code  */
		/*  test state code  */
	if state ^= 5 then    /*  sequence error  */
	    do;
		ec = error_table_$out_of_sequence;
		return;
	    end;
	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 release_count = 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();
		        ns=1;
		        n = 0;
		        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;
		 output_rec_inserted=output_rec_inserted+1;
		 go to in;  /*  transfer to  point where  exit routine is called-after determining new  winner*/
		end;
	if mii<2 then do;				/* Single merge string. */
	     if ns>n then do;
		disaster2 = 2;
			/*  data lost test  */
		if release_count > return_count  /*  data lost  */
		    then ec = error_table_$data_loss;
		    else
		ec = error_table_$end_of_info;  /*  all records have been gotten from single merge string  */
	     end;
	     else do;
		retp = msp (1);
		    /* update array element indicating current byte offset in string  */
		 /*  below adjusts IN.by_off for double word alignment  */
		retfb=divide(srp->IN.by_off(1) + fb + 4 - 1 +7,8,24)*8 + 1;
		srp->IN.by_off(1) = retfb;
		retp = addr(substr(retp->S,retfb,1));
		    /*  get byte position using word preceding record  */
		w_p = ptr(retp,fixed(rel(retp),21)-1);  /*  move back 1 word to get length of record  */
		retbl = fb;    /*  set up length  */
		    /*  set buffer pointer to correct record within string  */
		return_count = return_count +1;  /*  increment return count  */
		ns = ns+1;
	     end;
	     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  */
	   	        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 output record   */
		    hold_area_len = area_len;  /*   save length of output 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 into an area belonging to the sort  */
			substr(hold_cur_rec_ptr->S, 1, area_len) = substr(cur_rec_ptr->S, 1, area_len);
			cur_rec_ptr = hold_cur_rec_ptr;
		      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;  /*  restore held values  */
			    cur_rec_ptr = hold_cur_rec_ptr;
			    area_len = hold_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;
 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 old_rec_ptr=null() | ec=error_table_$end_of_info
		then old_rec_ptr=retp;  /*  set for next time through  */
		else do;    /*  perorm sequence check  */
		      pt1=old_rec_ptr;  /* set previous record pointer  */
		      pt2=retp;	   /*  current record pointer  */
		      call sort_comp;
		      if result = 1 then
			ec=error_table_$data_seq_error;
		      old_rec_ptr=retp;  /*  set for  next time through  */
		     end;
 exit:	return;

A0:	proc;
	     if mii<2 then do;			/* Single sorted string. */
		n = mip(1);		/*  number of records in first string  */
		if n<1 then do;
		/*   Ignore possible error.   */
		end;
		else do;
			   /*  set first element of array to indicate-for single merge
			   string case-character position of current record in this merge string  */
		     srp->IN.by_off(1) = 9;
		     retp = msp(1);       	/*  string pointer  */
		     retfb = srp->IN.by_off(1);  /*  set byte offset from srp-IN array  */
		     retp = addr(substr(retp->S,retfb,1));  /*  adjust pointer  */
		       /*  get byte position using word preceding record  */
		     w_p = ptr(retp,fixed(rel(retp),21)-1);  /*  move back 1 work-to get length  */
		     retbl = fb;  /*  set up length  */
		     ns = 2;
		end;
		return;
	     end;

/* Initialize for multiple merge strings. */

	     do i = 1 to mii;			/* Set indices for merge. */
		sip -> I (i) = i;			/*  sets ups I array  */
		srp->IN.ctr(i) = 1;    /*  record number in merge string  */
		srp->IN.by_off(i) = 9;  /*  set to char position of each record in each merge string  */
	     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;

/* 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 v2>0 then do;
		/*  below sets up pointers to record within S string (v1th & v2nd)  */
		/*  msp(vn) points to beginning of S string while by_off gives the offset within  */
			pt2 = addr(msp(v2)->S1(srp->IN.by_off(v2)));
			pt1 = addr(msp(v1)->S1(srp->IN.by_off(v1)));
			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;
		     rit = rit+1;
		     sip -> I (rit) = v1;
		end;
	     end;
	     y = s (n)+1;
	     call A1;
	     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  */
		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  */
		pt2 = addr(msp(v2)->S1(srp->IN.by_off(v2)));
		pt1 = addr(msp(v1)->S1(srp->IN.by_off(v1)));
		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);
	     retfb = srp->IN.by_off(v1);  /*  set byte offset from srp->IN array  */
	     retp = addr(substr(retp->S,retfb,1)); /* set pointer to correct record within string  */
		/*  get byte position using word preceding record  */
	     w_p = ptr(retp,fixed(rel(retp),21)-1);  /*  move back 1 word-to get length  */
	     retbl = fb;    /*  set up length  */
	     return;
	end A1;
A2:	proc;
						/* Delete last record output. */
	     i = srp->IN.ctr(v1) + 1;  /*  index of new record to look at -in v1th string  */
	     if i > mip(v1) then sip->I(v1) = 0;  /*  v1th string depleted  */
						/*  no more records in ths string to be looked at  */
	     srp->IN.ctr(v1) = i;  /*  update the index in v1th string to look at  */
		/*  below adjusts IN.by_off for double word alignment  */
	     retfb=divide(srp->IN.by_off(v1)+fb + 4 -1 +7,8,24)*8 +1;
	     srp->IN.by_off(v1) = retfb;
	     do j = 2 to n;
		if substr (unspec (v1), 36, 1) then v2 = v1+1; else v2 = v1-1;
		x = divide(v1+1,2,24);
		lft = s (j-1);
		v2 = sip -> I (v2+lft);
		v1 = sip -> I (v1+lft);
		if v1 = 0 then v1 = v2;
		else
		if v2>0 then do;
		 /*  below sets up pointers to records within S string  */
		    pt2 = addr(msp(v2)->S1(srp->IN.by_off(v2)));
		    pt1 = addr(msp(v1)->S1(srp->IN.by_off(v1)));
		    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;
     end;


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 return;
     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 cleanup_proc;


end sort_output_proc;
  



		    sort_presort.pl1                11/11/82  1552.0rew 11/11/82  1029.7       69885


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

			/*    EXTERNAL ENTRIES    */
dcl  sub_err_ entry  options(variable);
dcl	hcs_$make_seg  entry(char(*) aligned, char(*) aligned, char(*), fixed bin(5), ptr, fixed bin(35)),
	ioa_$rsnnl entry options(variable);
			/*    EXTERNAL STATIC    */

%include sort_ext;
	dcl	error_table_$fatal_error fixed bin(35) external,
		error_table_$improper_data_format fixed bin(35) ext;

			/*  PARAMETERS,AUTOMATIC, & BASED  */
	dcl	N char(8),
		ms_name char(32) aligned,
		shortinfo char(8) aligned,
		longinfo char(100) aligned,
		ioa_len fixed bin(17);
dcl  hcs_code fixed bin(35);
dcl  retval  fixed bin(35);
	dcl	(ns init(1),
		np init(0)) fixed bin(30),
		s(0:36);
	dcl 	i1 fixed bin(30);
	dcl	sp ptr,
		rp ptr;
%include sort_common;
dcl  (t,n,v1,v2,l,x,j,y,lft,rit,i) fixed bin(30);
dcl  sip_a  ptr,
     srp_a  ptr,
     ssp_a  ptr;
dcl  compares_counter_a  fixed bin(34);

start:	ec = 0;
     sip_a = sip;
     compares_counter_a = 0;
     srp_a = srp;
     ssp_a = ssp;

on illegal_procedure call illegal_procedure_handler;

	i=mii+1;	/* Count the merge strings. */
	if i>max4 then do;
	     call sub_err_(0, whoami, "c", null(), retval, "Maximum merge order of ^d exceeded.", max4);
	     ec = error_table_$fatal_error;
	     go to exit;
	     end;
	/* Create the next merge string  S segment. */
	    call ioa_$rsnnl("^d",N,ioa_len,i);
	     ms_name = unique_prefix||"sort_work.MS."||N;
	   call hcs_$make_seg(wf_dir_name, ms_name, "", 8+2,  /*  rw  */ sp, hcs_code);
	    if hcs_code ^= 0 then do;
		ec = error_table_$fatal_error;
		call sub_err_(hcs_code, whoami, "c", null(), retval, " ^a  Unable to create temporary segment ^a>^a",
			longinfo, before(wf_dir_name, " "), ms_name);
		go to exit;
		end;
	/*  if i = 1 then cmpe=cmp;    assign comparison procedure at the first call */

	mii=i;             /*  set merege item index  */
	mip(i) = sii;	/*  number of records in ith merge string  */
	msp(i)=sp;	/* Pointer to "next" merge S string. */

/*
	calculate the lengths of
	lists and their start pointers
	in a linear set.
*/
	/*   set up array of indices-each indicating beginning of next group of records to be  sorted  */
	s(0) = 0;		/*   for case where sii = 1 and n will be = 0   */
	t=0;
	l=sii;		/*  number of records to  be  sorted  */
	do n=1 by 1 while(l>1);
	s(n)=t;  /* start of the next list  an array of indices-each index indicating start of next  list */
	if substr(unspec(l),36,1) then do;
		l=l+1;  /* make the length even. */
		sip_a->I(t+l) = 0;		/*   clear second word of last pair if l is odd   */
		end;
	t=t+l;  /* accumulate the lengths. */
	l = divide(l,2,24);  /*  next list is 1/2 the length of the present list  */
	end;
	n=n-1;

		/*  below fills in I array(of indices into R) to reflect sorted records-performs presort*/
	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_a->I(x);
	v2=sip_a->I(x+1);
	if v2>0 then do;
		/*  below sets up pointers to records in S string  */
	     pt2 = addr(ssp_a->S1(srp_a->R.pt(v2)));
	     pt1 = addr(ssp_a->S1(srp_a->R.pt(v1)));
	    call sort_comp;
	    compares_counter_a=compares_counter_a+1;
	    if result = 0 then	/*  records ranked  equal  */
		do;
		if v1 < v2
		    then result = -1;     /*  rank records 1 first  */
		    else result = 1;     /*  rank record 2 first  */
		end;
	if result>0 then v1=v2;
	end;
	rit=rit+1;
	sip_a->I(rit)=v1;
	end;
	end;

		/*  below sets up new,sorted merge string  */
		/*  sets up new R table to reflect sorted records */
	y=s(n)+1;
	do i=1 to sii;		/*  gets last two winner records from previous sorts  */
	v2=sip_a->I(y+1);
	v1=sip_a->I(y);
	if v1 ^= 0 then;
	    else if v2 ^= 0 then;
	else i = sii + 1;
	do;
	if v1=0 then v1=v2;
	else
	if v2>0 then do;
		/*  below sets up pointers to records within S string  */
	     pt2 = addr(ssp_a->S1(srp_a->R.pt(v2)));
	     pt1 = addr(ssp_a->S1(srp_a->R.pt(v1)));
	    call sort_comp;
	    compares_counter_a=compares_counter_a+1;
	    if result = 0 then	/*  records ranked  equal  */
		do;
		if v1 < v2
		    then result = -1;     /*  rank records 1 first  */
		    else result = 1;     /*  rank record 2 first  */
		end;
	if result>0 then v1=v2;
	end;
	/* Move the next sorted record to the merge  string. */
	l=srp_a->R.ln(v1);	/*  length of winner record  */
		/*  following will set up mechansim for double word  alignemnt  */
	    ns = divide(ns + 4 -1 + 7,8,24)*8 +1;
	w_p =  addr(substr(sp->S,ns,1));
	w_p=ptr(w_p,fixed(rel(w_p),21)-1);  /*  move back 1 word to get lenght of record  */
	fb =  l;    /*  set length  */
	substr(sp->S, ns, l)= substr( ssp_a->S,  srp_a->R.pt(v1), l); /* move winner record into new S string-based on sp */
	np=np+1;
	ns=ns+l;
	sip_a->I(v1)=0; /* delete the last winner. */
		/*  below goes  through second pass of pre-sort  */
	do j=2 to n;  /* get the next winner. */
	lft=s(j-1);
	if substr(unspec(v1),36,1) then v2=v1+1;  else v2=v1-1;
	v2=sip_a->I(v2+lft);
	x = divide((v1+1),2,24);
	v1=sip_a->I(v1+lft);
	if v1=0 then v1=v2;
	else
	if v2>0 then do;
		/*  below sets up pointers to records within S string  */
	     pt2 = addr(ssp_a->S1(srp_a->R.pt(v2)));
	     pt1 = addr(ssp_a->S1(srp_a->R.pt(v1)));
	    call sort_comp;
	    compares_counter_a=compares_counter_a+1;
	    if result = 0 then	/*  records ranked  equal  */
		do;
		if v1 < v2
		    then result = -1;     /*  rank records 1 first  */
		    else result = 1;     /*  rank record 2 first  */
		end;
	if result>0 then v1=v2;
	end;
	sip_a->I(x+s(j))=v1;
	v1=x;
	end;
	end;
	end;

	old_input_file_num = curr_input_file_num;
exit:
     compares_counter = compares_counter + compares_counter_a;
	return;

%include sort_comp;


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;
	if curr_input_file_attach = "" then do;
	     file = "file name";
	     file_part = curr_input_file_name;
	     end;
	else do;
	     file = "attach description";
	     file_part = curr_input_file_attach;
	     end;
	if old_input_file_num = curr_input_file_num then do;
	     call sub_err_(error_table_$improper_data_format, whoami, "c", null(), retval,
			" Please check ^a and/or input file ^d, ^a ^a",
		     key_part, curr_input_file_num, file, file_part);
	     end;
	else do;
	     call sub_err_(error_table_$improper_data_format, whoami, "c", null(), retval,
			" Please check ^a and/or input files ^d to ^d.",
			key_part, old_input_file_num, curr_input_file_num);
	     end;
	end;
     else do;          /*   user input_file exit procedure   */
	call sub_err_(error_table_$improper_data_format, whoami, "c", null(), retval,
			" 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;

end	sort_presort;
   



		    sort_sort.pl1                   11/11/82  1554.5rew 11/11/82  1025.0      149706


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

sort_sort: proc (input_file, output_file, sort_desc,
     temp_dir, user_out_sw_par, file_size_par, sort_code);

/*   PARAMETERS   */
dcl (input_file (*) char (*),				/*   Input file pathnames or attach descriptions (Input).   */
     output_file char (*),				/*   Output file pathnames or attach description  (Input).   */
     sort_desc (*) ptr,				/*   Pointer to Sort Description (source form)  (Input).   */
     temp_dir char (*),				/*   Pathname of directory for work files  (Input).   */
     user_out_sw_par char (*),			/*   Switchname for diagnostics and Sort Report  (Input).   */
     file_size_par float bin (27),			/*   File size specified by user - millions of bytes  (Input).   */
     sort_code fixed bin (35),			/*   Status code  (Output).   */
     merge_order_par fixed bin (35),			/*   Merge order specified by caller of sort_private  (Input).   */
     string_size_par fixed bin (35)) parameter;		/*   String size specified by caller of sort_private  (Input).   */

/*   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  expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35));
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_$status_minf entry (char (*) aligned, char (*) aligned, fixed bin (1), fixed bin (2),
     fixed bin (24), fixed bin (35)),
     hcs_$initiate_count entry (char (*) aligned, char (*) aligned, char (*),
     fixed bin (24), fixed bin (2), 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_$ioa_stream entry options (variable);
dcl  ioa_$rsnnl 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  sort_initiate$initiate_private entry (char (*), ptr, ptr, char (*), float bin (27),
     fixed bin (35), fixed bin (35), fixed bin (35));
dcl (sort_input_proc,
     sort_output_proc) entry (fixed bin (35));
dcl  sort_commence$commence entry (fixed bin (35)),
     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  temp_dir_temp char (168),
     keys_ptr ptr,
     exits_ptr ptr,
     user_out_sw_temp char (32),
     code fixed bin (35),				/*   work location for status codes returned from calls made by driver   */
     merge_order_temp fixed bin (35),
     string_size_temp fixed bin (35);

dcl  file_size_user_val fixed bin (71),			/*   Value given by user - bytes.   */
     file_size_computed fixed bin (71),			/*   Amount of input data in storage system - bytes.   */
     file_size_pass float bin (27);			/*   Passed to sort_initiate - millions of bytes.   */
dcl  some_not_found bit (1);

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 calling input file procedure.   */
dcl  hcs_code fixed bin (35);

dcl  expand_code fixed bin (35);
dcl  in_dir char (168) aligned,
     in_ename char (32) aligned,
     in_bit_count fixed bin (24),
     in_ptr ptr,
     type fixed bin (2),
     component char (32) aligned,
     comp_len fixed bin (17);

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;
     sort_code = error_table_$out_of_sequence;
     return;					/*   to caller without resetting state variable   */
end;
state = 2;
merge_order_temp = 0;				/*   Merge order not specified.   */
string_size_temp = 0;				/*   String_size not specified.   */
time_sw = off;					/*   Timing not specified.   */
debug_sw = off;					/*   Debug option not specified.  */
arg_err_sw = off;					/*   Not done in common_start; see sort_private entry.   */
common_start:
sort_code = 0;
mii = 0;						/*   Used by sort_cleanup_work   */
sip = null ();					/*   Used by sort_cleanup_work   */
in_buff_ptr = null ();				/*   Used by cleanup procedure   */
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_temp = temp_dir;				/*   Pass on to sort_$initiate.   */

call sort_merge_subroutine (input_file, output_file, sort_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_buff;
file_size_user_val = file_size_par * 10**6;		/*   File size specified by user.   */
call set_file_size;

/*   Driver:   5 steps.   */
/*   (1)  Initiate.   */
if fatal_sw = off then
     call sort_initiate$initiate_private (temp_dir_temp, keys_ptr, exits_ptr, user_out_sw_temp, file_size_pass,
     code, merge_order_temp, string_size_temp);
if arg_err_sw = on | fatal_sw = on then do;
     sort_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 sort_$initiate.");
	sort_code = error_table_$fatal_error;
     end;
     else sort_code = code;
     go to exit;
end;
if time_sw = on then do;				/*   Beginning of Presort.   */
     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;

/*   (2)  Call an input file procedure.   */
if input_driver_is_sort = on then			/*   Call Sort's input file procedure, once per input file.   */
     do j = 1 to dimension (input_file, 1);
     curr_input_file_name = input_file (lbound (input_file, 1) + j - 1);
     curr_input_file_num = j;
     call scan_for_pn_or_attach (curr_input_file_name, curr_input_file_attach);
     call sort_input_proc (code);
     if code ^= 0 then do;
	if code ^= error_table_$fatal_error then do;
	     call sub_err_ (code, whoami, "c", null (), retval,
		"Sort's input_file procedure.");
	end;
	sort_code = error_table_$fatal_error;
	go to exit;
     end;
end;
else do;						/*   Call user's input file procedure.   */
     call sort_input_exit (code);
     if code ^= 0 then do;
	if code ^= error_table_$fatal_error
	then call sub_err_ (code, whoami, "c", null (), retval,
	     "User input_file exit procedure.");
	sort_code = error_table_$fatal_error;
	go to exit;
     end;
end;

/*   (3)  Commence.   */
call sort_commence$commence (code);
if code ^= 0 then do;
     if code = error_table_$out_of_sequence then
	call sub_err_ (code, whoami, "c", null (), retval,
	"Calling sort_$commence.");
     sort_code = error_table_$fatal_error;
     go to exit;
end;
if time_sw = on then do;				/*   End of Presort - beginning of Merge   */
     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;

/*   (4)  Call an output file procedure.   */
if output_driver_is_sort = on then			/*   Call Sort's output file procedure.   */
     do;
						/*   sort_merge_subroutine has set up curr_output_file_name & curr_output_file_attach.   */
     call sort_output_proc (code);
     if code ^= 0 then do;
	if code ^= error_table_$fatal_error then do;
	     call sub_err_ (code, whoami, "c", null (), retval,
		"Sort's output_file procedure.");
	end;
	sort_code = error_table_$fatal_error;
	go to exit;
     end;
end;
else do;						/*   Call user's output file procedure.   */
     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.");
	sort_code = error_table_$fatal_error;
	go to exit;
     end;
end;
if time_sw = on then do;				/*   End of Merge.   */
     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;

/*   (5)  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 sort_$terminate.");
     sort_code = error_table_$fatal_error;
     go to exit;
end;
exit:
call cleanup_proc;
state = 8;
return;						/*   to caller of sort_     */


/*  ENTRY   sort_$sort_private  called only by sort command.   */
sort_private: entry (input_file, output_file, sort_desc, temp_dir, user_out_sw_par, file_size_par, sort_code,
     merge_order_par, string_size_par);
state = 2;
if sort_code ^= 0 then arg_err_sw = on;			/*   sort has encountered some error already   */
else arg_err_sw = off;
merge_order_temp = merge_order_par;			/*   Pass on merge order from sort.   */
string_size_temp = string_size_par;			/*   Pass on string_size from sort.   */
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 = "sort_";
	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;


set_file_size: proc;
						/*   Decide on input file size to use for sorting   */
dcl (i, j) fixed bin (17);
dcl  pn char (256);
dcl  att char (4);					/*   Unused.   */

/*   First, compute the amount of input data which is in the storage system.   */
     some_not_found = off;
     if input_driver_is_sort = off then do;		/*   All input data unknown.   */
	some_not_found = on;
	file_size_computed = 0;
     end;
     else do;					/*   Input files specified.   */
	file_size_computed = 0;
	do j = lbound (input_file, 1) to hbound (input_file, 1); /*   For each input file.   */
	     if substr (input_file (j), 1, 4) = "-if "
	     | substr (input_file (j), 1, 12) = "-input_file" then do;
		pn = input_file (j);
		call scan_for_pn_or_attach (pn, att);
		call expand_path_ (addr (pn), length (pn), addr (in_dir),
		     addr (in_ename), expand_code);
		if expand_code ^= 0 then do;		/*   Cannot expand pathname.   */
		     some_not_found = on;
		end;
		else do;				/*   Try to find file in storage system.   */
		     call hcs_$status_minf (in_dir, in_ename, 1 /* chase links */, type, in_bit_count, hcs_code);
		     if hcs_code ^= 0 | type = 0 /* link */ then do; /*   Cannot get at file.   */
			some_not_found = on;
		     end;
		     else if type = 1 then do;	/*   single segment file   */
			if file_size_computed > 10**9 then do;
			     call file_too_large;
			     return;
			end;
			file_size_computed = file_size_computed + divide (in_bit_count, 9, 71);
		     end;
		     else do i = 0 to (in_bit_count - 1); /*   multi segment file   */
			if file_size_computed > 10**9 then do;
			     call file_too_large;
			     return;
			end;
			call ioa_$rsnnl ("^d", component, comp_len, i);
			call hcs_$initiate_count (before (in_dir, " ") || ">" || in_ename, component, "",
			     in_bit_count, 0, in_ptr, hcs_code);
			if in_ptr = null () then do;	/*   component missing.   */
			     some_not_found = on;
			end;
			else			/*   Component found.   */
			file_size_computed = file_size_computed + divide (in_bit_count, 9, 71);
		     end;				/*   of do  for components of multisegment file   */
		end;				/*   of else do (expand_code = 0)    */
	     end;					/*   of else do (file is specified by pathname)   */
	     else some_not_found = on;		/*   This file not in storage system.   */
	end;					/*   of do j = lbound ...   */
     end;						/*   of computation of input data which is in storage system   */

/*   Second, decide whether to use file size specified by user,
   or value computed to be in storage system,
   or default to 1.0 million bytes.  		   */
     if file_size_user_val < 50 then do;		/*   User did not specify file size   */
	if some_not_found = off			/*   All input is in the storagee system   */
	then file_size_pass = file_size_computed;
	else					/*   Some input is not in the storage system   */
	file_size_pass = file_size_computed + 1.04*10**6;
						/*   Amount in storage system plus allowance for amount not in storage system   */
     end;
     else do;					/*   User did specify file size   */
	if input_record_exit_sw = 1			/*   User can insert or delete records   */
	then file_size_pass = file_size_user_val;
						/*   user knows best, since records can be inserted or deleted   */
	else do;					/*   User cannot insert or delete records   */
	     if some_not_found = on			/*   Some input is not in the storage system   */
	     then file_size_pass = max (file_size_computed, file_size_user_val);
						/*   Take user value unless amount in storage system is greater   */
	     else					/*   All input is in the storage system   */
	     file_size_pass = file_size_computed;
	end;
     end;
     file_size_pass = divide (file_size_pass, 10**6, 63);
end set_file_size;


file_too_large: proc;
     if user_out_sw ^= "" then call ioa_$ioa_stream (user_out_sw,
	"^a:  Amount of input data too large.  Must be < 10**9 bytes.", whoami);
     arg_err_sw = on;
end file_too_large;


create_in_buff: proc;
     call hcs_$make_seg (get_pdir_ (), unique_prefix||"sort_in_buff_", "", 8+2, /* :  rw  */ in_buff_ptr, hcs_code);
     if in_buff_ptr = 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_",
	     whoami, longinfo, unique_prefix);
     end;
end create_in_buff;


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);
	if in_buff_ptr ^= null () then call hcs_$delentry_seg (in_buff_ptr, 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);
	if in_buff_ptr ^= null () then call hcs_$truncate_seg (in_buff_ptr, 0, code);
     end;
     call sort_cleanup_work;
     state = 8;
end cleanup_proc;


end sort_sort;


		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull
and Bull HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for 
managing computer hardware properly and for executing programs. Many subsequent operating systems
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by Bull HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved